SQLite3Commons;

{$define INCLUDE_FTS3}
{ define this if you want to include the FTS3/FTS4 feature into the library
  - FTS3 is an SQLite module implementing full-text search
  - will include also FTS4 extension module since 3.7.4
  - see http://www.sqlite.org/fts3.html for documentation
  - not defined by default, to save about 50 KB of code size
  - should be defined for both SynSQLite3 and SQLite3 units }

{.$define USEFASTCALL}
{ use the fastcall calling convention to access the SQLite3 library
  - BCC32 -pr fastcall (=Delphi resgister) is buggy, don't know why
   (because of issues with BCC32 itself, or some obfuscated calls in source?)
  - should be defined for both SynSQLite3 and SQLite3 units }
................................................................................
procedure TSQLRestServerDB.CreateMissingTables(user_version: cardinal);
var t,f: integer;
    TableNamesAtCreation, aFields: TRawUTF8DynArray;
    TableJustCreated: TSQLFieldTables;
    aSQL: RawUTF8;
begin
  if DB.TransactionActive then
    raise ESQLException.Create('CreateMissingTables: Transaction');
  fDB.GetTableNames(TableNamesAtCreation);
  fillchar(TableJustCreated,sizeof(TSQLFieldTables),0);
  try
    // create not static and not existing tables
    for t := 0 to high(Model.Tables) do
      if ((fStaticData=nil) or (fStaticData[t]=nil)) then
      // this table is not static -> check if already existing, create if necessary
................................................................................
        if Req=@fStaticStatement then
          Close;
      end;
    finally
      DB.UnLock;
    end;
  except
    on E: ESQLException do begin
      {$ifdef WITHLOG}
      DB.Log.Log(sllError,'% for %',[E,aSQL],self);
      {$else}
      LogToTextFile('TSQLRestServerDB.EngineExecute: '+RawUTF8(E.Message)+#13#10+aSQL);
      {$endif}
      result := false;
    end;
................................................................................
      finally
        R.Close; // always release statement
      end;
    finally
      DB.UnLock;
    end;
  except
    on E: ESQLException do begin
      {$ifdef WITHLOG}
      DB.Log.Log(sllError,'% for %',[E,aSQL],self);
      {$else}
      LogToTextFile('TSQLRestServerDB.EngineExecute Error: '+RawUTF8(E.Message)+#13#10+aSQL);
      {$endif}
      result := false;
    end;
................................................................................

function TSQLRestServerDB.EngineExecuteAll(const aSQL: RawUTF8): boolean;
begin
  try
    DB.ExecuteAll(aSQL); // Execute all statements (don't use fStatementCache[])
    result := true;
  except
    on E: ESQLException do begin
      {$ifdef WITHLOG}
      DB.Log.Log(sllError,'% for %',[E,aSQL],self);
      {$else}
      LogToTextFile('TSQLRestServerDB.EngineExecuteAll Error: '+RawUTF8(E.Message)+#13#10+aSQL);
      {$endif}
      result := false;
    end;
................................................................................
                Req^.Close;
            end;
          finally
            MS.Free;
          end;
        end;
      except
        on ESQLException do
          result := '';
      end;
    finally
      DB.UnLockJSON(result,RowCount);
    end;
  end;
  if ReturnedRowCount<>nil then
................................................................................
        if Req=@fStaticStatement then
          Close;
      end;
    finally
      DB.UnLock;
    end;
  except
    on ESQLException do
      result := false;
  end;
end;

procedure TSQLRestServerDB.SetNoAJAXJSON(const Value: boolean);
begin
  inherited;
................................................................................
        until Step<>SQLITE_ROW; // Execute all steps of the first statement
        result := true;
      end;
    finally
      DB.UnLock;
    end;
  except
    on ESQLException do
      result := false;
  end;
end;

function TSQLRestServerDB.UpdateField(Table: TSQLRecordClass; Where: integer;
  const FieldName: shortstring; FieldValue: integer; ByID: boolean): boolean;
var Field: PPropInfo;
................................................................................

procedure TSQLRestServerDB.Commit(SessionID: cardinal=1);
begin
  inherited Commit(SessionID); // reset fTransactionActive + write all TSQLVirtualTableJSON
  try
    DB.Commit;
  except
    on ESQLException do
      ; // just catch exception
  end;
end;

procedure TSQLRestServerDB.RollBack(SessionID: cardinal=1);
begin
  inherited; // reset TSQLRestServerDB.fTransactionActive flag
  try
    DB.RollBack; // reset TSQLDataBase.RollBack
  except
    on ESQLException do
      ; // just catch exception
  end;
end;

function TSQLRestServerDB.TransactionBegin(aTable: TSQLRecordClass; SessionID: cardinal=1): boolean;
begin
  result := inherited TransactionBegin(aTable,SessionID);
  if result then
    // fTransactionActive flag was not already set
    try
      DB.TransactionBegin;
    except
      on ESQLException do
        result := false;
    end;
end;

function TSQLRestServerDB.Backup(Dest: TStream): boolean;
var Source: TFileStream;
    Closed: boolean;
................................................................................
      result := fServer.InternalListJSON(TSQLRecordClass(Tables[0]),aSQL) else
      // we access localy the DB -> TSQLTableDB handle Tables parameter
      result := TSQLTableDB.Create(fServer.DB,
        RecordClassesToClasses(Tables),aSQL,not fServer.NoAJAXJSON);
    if fServer.DB.InternalState<>nil then
      result.InternalState := fServer.DB.InternalState^;
  except
    on ESQLException do
      result := nil;
  end;
end;

function TSQLRestClientDB.InternalURI(const url, method: RawUTF8;
  Resp, Head, SendData: PRawUTF8): Int64Rec;
var R,H,S: RawUTF8; // temp '' string to be used when no PString is provided
................................................................................

{ TSQLVirtualTableModuleServerDB }

constructor TSQLVirtualTableModuleServerDB.Create(
  aClass: TSQLVirtualTableClass; aServer: TSQLRestServer);
begin
  if not aServer.InheritsFrom(TSQLRestServerDB) then
    raise Exception.CreateFmt('%.Create expects a DB Server',[ClassName]);
  inherited Create(aClass,aServer);
  DB := TSQLRestServerDB(aServer).DB; // SetDB setter will do the work
end;


{ ************ Unit-Testing classes and functions }

................................................................................
  VO := TSQLRecordPeopleObject.Create;
{$endif}
  V2 := nil;
  if not IsMemory then begin
    DeleteFile('dali1.json');
    DeleteFile('dali2.data');
  end;
  Demo.RegisterSQLFunction(TypeInfo(TIntegerDynArray),SortDynArrayInteger,
    'MyIntegerDynArrayContains');
  ModelC := TSQLModel.Create(
    [TSQLRecordPeople, {$ifdef INCLUDE_FTS3} TSQLFTSTest, {$endif}
     TSQLASource, TSQLADest, TSQLADests, TSQLRecordPeopleArray
     {$ifndef LVCL}, TSQLRecordPeopleObject{$endif},
     TSQLRecordDali1,TSQLRecordDali2],'root');
  ModelC.VirtualTableRegister(TSQLRecordDali1,TSQLVirtualTableJSON);

  SQLite3Commons;

{$define INCLUDE_FTS3}
{ define this if you want to include the FTS3/FTS4 feature into the library
  - FTS3 is an SQLite module implementing full-text search
  - will include also FTS4 extension module since 3.7.4
  - see http://www.sqlite.org/fts3.html for documentation
  - is defined by default, but can be unset to save about 50 KB of code size
  - should be defined for both SynSQLite3 and SQLite3 units }

{.$define USEFASTCALL}
{ use the fastcall calling convention to access the SQLite3 library
  - BCC32 -pr fastcall (=Delphi resgister) is buggy, don't know why
   (because of issues with BCC32 itself, or some obfuscated calls in source?)
  - should be defined for both SynSQLite3 and SQLite3 units }
................................................................................
procedure TSQLRestServerDB.CreateMissingTables(user_version: cardinal);
var t,f: integer;
    TableNamesAtCreation, aFields: TRawUTF8DynArray;
    TableJustCreated: TSQLFieldTables;
    aSQL: RawUTF8;
begin
  if DB.TransactionActive then
    raise EBusinessLayerException.Create('CreateMissingTables: Transaction');
  fDB.GetTableNames(TableNamesAtCreation);
  fillchar(TableJustCreated,sizeof(TSQLFieldTables),0);
  try
    // create not static and not existing tables
    for t := 0 to high(Model.Tables) do
      if ((fStaticData=nil) or (fStaticData[t]=nil)) then
      // this table is not static -> check if already existing, create if necessary
................................................................................
        if Req=@fStaticStatement then
          Close;
      end;
    finally
      DB.UnLock;
    end;
  except
    on E: ESQLite3Exception do begin
      {$ifdef WITHLOG}
      DB.Log.Log(sllError,'% for %',[E,aSQL],self);
      {$else}
      LogToTextFile('TSQLRestServerDB.EngineExecute: '+RawUTF8(E.Message)+#13#10+aSQL);
      {$endif}
      result := false;
    end;
................................................................................
      finally
        R.Close; // always release statement
      end;
    finally
      DB.UnLock;
    end;
  except
    on E: ESQLite3Exception do begin
      {$ifdef WITHLOG}
      DB.Log.Log(sllError,'% for %',[E,aSQL],self);
      {$else}
      LogToTextFile('TSQLRestServerDB.EngineExecute Error: '+RawUTF8(E.Message)+#13#10+aSQL);
      {$endif}
      result := false;
    end;
................................................................................

function TSQLRestServerDB.EngineExecuteAll(const aSQL: RawUTF8): boolean;
begin
  try
    DB.ExecuteAll(aSQL); // Execute all statements (don't use fStatementCache[])
    result := true;
  except
    on E: ESQLite3Exception do begin
      {$ifdef WITHLOG}
      DB.Log.Log(sllError,'% for %',[E,aSQL],self);
      {$else}
      LogToTextFile('TSQLRestServerDB.EngineExecuteAll Error: '+RawUTF8(E.Message)+#13#10+aSQL);
      {$endif}
      result := false;
    end;
................................................................................
                Req^.Close;
            end;
          finally
            MS.Free;
          end;
        end;
      except
        on ESQLite3Exception do
          result := '';
      end;
    finally
      DB.UnLockJSON(result,RowCount);
    end;
  end;
  if ReturnedRowCount<>nil then
................................................................................
        if Req=@fStaticStatement then
          Close;
      end;
    finally
      DB.UnLock;
    end;
  except
    on ESQLite3Exception do
      result := false;
  end;
end;

procedure TSQLRestServerDB.SetNoAJAXJSON(const Value: boolean);
begin
  inherited;
................................................................................
        until Step<>SQLITE_ROW; // Execute all steps of the first statement
        result := true;
      end;
    finally
      DB.UnLock;
    end;
  except
    on ESQLite3Exception do
      result := false;
  end;
end;

function TSQLRestServerDB.UpdateField(Table: TSQLRecordClass; Where: integer;
  const FieldName: shortstring; FieldValue: integer; ByID: boolean): boolean;
var Field: PPropInfo;
................................................................................

procedure TSQLRestServerDB.Commit(SessionID: cardinal=1);
begin
  inherited Commit(SessionID); // reset fTransactionActive + write all TSQLVirtualTableJSON
  try
    DB.Commit;
  except
    on ESQLite3Exception do
      ; // just catch exception
  end;
end;

procedure TSQLRestServerDB.RollBack(SessionID: cardinal=1);
begin
  inherited; // reset TSQLRestServerDB.fTransactionActive flag
  try
    DB.RollBack; // reset TSQLDataBase.RollBack
  except
    on ESQLite3Exception do
      ; // just catch exception
  end;
end;

function TSQLRestServerDB.TransactionBegin(aTable: TSQLRecordClass; SessionID: cardinal=1): boolean;
begin
  result := inherited TransactionBegin(aTable,SessionID);
  if result then
    // fTransactionActive flag was not already set
    try
      DB.TransactionBegin;
    except
      on ESQLite3Exception do
        result := false;
    end;
end;

function TSQLRestServerDB.Backup(Dest: TStream): boolean;
var Source: TFileStream;
    Closed: boolean;
................................................................................
      result := fServer.InternalListJSON(TSQLRecordClass(Tables[0]),aSQL) else
      // we access localy the DB -> TSQLTableDB handle Tables parameter
      result := TSQLTableDB.Create(fServer.DB,
        RecordClassesToClasses(Tables),aSQL,not fServer.NoAJAXJSON);
    if fServer.DB.InternalState<>nil then
      result.InternalState := fServer.DB.InternalState^;
  except
    on ESQLite3Exception do
      result := nil;
  end;
end;

function TSQLRestClientDB.InternalURI(const url, method: RawUTF8;
  Resp, Head, SendData: PRawUTF8): Int64Rec;
var R,H,S: RawUTF8; // temp '' string to be used when no PString is provided
................................................................................

{ TSQLVirtualTableModuleServerDB }

constructor TSQLVirtualTableModuleServerDB.Create(
  aClass: TSQLVirtualTableClass; aServer: TSQLRestServer);
begin
  if not aServer.InheritsFrom(TSQLRestServerDB) then
    raise EBusinessLayerException.CreateFmt('%.Create expects a DB Server',[ClassName]);
  inherited Create(aClass,aServer);
  DB := TSQLRestServerDB(aServer).DB; // SetDB setter will do the work
end;


{ ************ Unit-Testing classes and functions }

................................................................................
  VO := TSQLRecordPeopleObject.Create;
{$endif}
  V2 := nil;
  if not IsMemory then begin
    DeleteFile('dali1.json');
    DeleteFile('dali2.data');
  end;
  Demo.RegisterSQLFunction(TypeInfo(TIntegerDynArray),@SortDynArrayInteger,
    'MyIntegerDynArrayContains');
  ModelC := TSQLModel.Create(
    [TSQLRecordPeople, {$ifdef INCLUDE_FTS3} TSQLFTSTest, {$endif}
     TSQLASource, TSQLADest, TSQLADests, TSQLRecordPeopleArray
     {$ifndef LVCL}, TSQLRecordPeopleObject{$endif},
     TSQLRecordDali1,TSQLRecordDali2],'root');
  ModelC.VirtualTableRegister(TSQLRecordDali1,TSQLVirtualTableJSON);

      by TSQLRestServerStaticInMemory.SaveToBinary)
    - fixed issue with TAuthSession.IDCardinal=0 after 76 connections
    - fixed issue in SetInt64Prop() with a setter method
    - fixed potential issue in TSQLTable.SearchValue in case of invalid Client
      supplied parameter (now checks TSQLRest class type)

  Version 1.16



    - added a generic JSON error message mechanism within the framework
      (including error code as integer and text, with custom error messages
      in RecordCanBeUpdated method and also in TSQLRestServerCallBackParams)
    - the TSQLRestServerCallBack method prototype has been modified to supply
      "var aParams: TSQLRestServerCallBackParams: cardinal" as unique parameter:
      this is a CODE BREAK change and you shall refresh ALL your server-side
      code to match the new signature (using a record passed by value as
................................................................................

  /// maximum handled dimension for TSQLRecordRTree
  // - this value is the one used by SQLite3 R-Tree virtual table
  RTREE_MAX_DIMENSION = 5;


type





















  TSQLModel = class;
  TSQLRest = class;
  TSQLRestClient = class;

{$M+} { we need the RTTI information to be compiled for the published
        properties of these classes and their children (like TPersistent),
        to enable ORM - must be defined at the forward definition level }
  TSQLRecord = class;      // published properties = ORM fields/columns
  TSQLAuthUser = class;

  TSQLRestServer = class;  // published events = RESTful callbacks handlers


{$M-}

  /// class-reference type (metaclass) of TSQLRecord
  TSQLRecordClass = class of TSQLRecord;

  PSQLRecordClass = ^TSQLRecordClass;
................................................................................

  /// all our services shall inherit from this interface
  // - in the current implementation, we rely on a single inheritance from
  // IService, in order to simplify the implementation
  IService = interface(IInvokable)
  end;


  /// the possible Server-side instance implementation patterns for Services
  // - each interface-based service will be implemented by a corresponding
  // class instance on the server: this parameter is used to define how
  // class instances are created and managed
  // - on the Client-side, each instance will be handled depending on the
  // server side implementation (i.e. with sicClientDriven behavior if necessary)
  // - sicSingle: one object instance is created per call - this is the
................................................................................
    Args: TServiceMethodArgumentDynArray;
    /// needed CPU stack size (in bytes) for all arguments
    ArgsSize: cardinal;
    /// contains all used kind of arguments
    ArgsUsed: set of TServiceMethodValueType;
    /// contains the count of variables for all used kind of arguments
    ArgsUsedCount: array[TServiceMethodValueVar] of integer;
    /// execute a method






    procedure InternalExecute(Instance, Method: pointer;
      Par: PUTF8Char; Res: TTextWriter; var Error: RawUTF8);
  end;

  /// describe a service provider methods
  TServiceMethodDynArray = array of TServiceMethod;

  /// an abstract service provider, as registered in TServiceContainer
  // - this will be either implemented by a TInterfacedObjectClass on the server,
................................................................................
  protected
    fInterfaceTypeInfo: PTypeInfo;
    fInterfaceIID: TGUID;
    fInterfaceURI: RawUTF8;
    fInterfaceMangledURI: RawUTF8;
    fInstanceCreation: TServiceInstanceImplementation;
    fRest: TSQLRest;
    fSharedInstance: TInterfacedObject;
    fSharedInterface: IInterface;
    fMethodsCount: integer;
    fMethods: TServiceMethodDynArray;
    /// return one instance of this interface - here is the magic
    function InternalProduce: TInterfacedObject; virtual; abstract;
  public
    /// initialize the service provider parameters
    // - it will check and retrieve all methods of the supplied interface,
    // and prepare all internal structures for its serialized execution
    constructor Create(aRest: TSQLRest; aInterface: PTypeInfo;
      aInstanceCreation: TServiceInstanceImplementation);
    /// release the service provider memory and structures
    destructor Destroy; override;
    /// retrieve an instance of this interface
    // - will call InternalProduce virtual method to retrieve a class
    // - sicClientDriven kind of instance creation will behave the same as sicSingle
    function FromFactory(out Obj): Boolean;
    /// get the index in Methods[] of a given method name
    // - returns -1 if the method name is unknown
    function MethodIndex(const aMethod: RawUTF8): integer;
    /// the associated RESTful instance
    property Rest: TSQLRest read fRest;
    /// the registered Interface low-level Delphi RTTI type
    property InterfaceTypeInfo: PTypeInfo read fInterfaceTypeInfo;
................................................................................
    // - only relevant on the server side; on the client side, this class will
    // be accessed only to retrieve a remote access instance, i.e. sicSingle
    property InstanceCreation: TServiceInstanceImplementation read fInstanceCreation;
    /// the declared methods
    property Methods: TServiceMethodDynArray read fMethods;
  end;

  /// service provider use this to store one internal instance 

  TServiceFactoryServerInstance = record
    /// the internal Instance ID, as remotely sent in "id":1
    // - is set to 0 when an entry in the array is free
    InstanceID: Cardinal;
    /// last time stamp access of this instance
    LastAccess: Cardinal;
    /// the implementation instance itself
    Instance: TInterfacedObject;
  end;

  /// service provider use this to store its internal instances 

  TServiceFactoryServerInstanceDynArray = array of TServiceFactoryServerInstance;

  /// a service provider implemented on the server side
  TServiceFactoryServer = class(TServiceFactory)
  protected
    fImplementationClass: TInterfacedObjectClass;
    fInstances: TServiceFactoryServerInstanceDynArray;
    fInstance: TDynArray;
    fInstancesCount: integer;
    fInstanceCurrentID: integer;
    fInstanceTimeOut: cardinal;
    fInstanceLock: TRTLCriticalSection;
    function InternalProduce: TInterfacedObject; override;



  public
    /// initialize the service provider on the server side
    // - expect an implementation class
    // - for sicClientDriven, a time out (in seconds) can be defined
    constructor Create(aRest: TSQLRest; aInterface: PTypeInfo;
      aInstanceCreation: TServiceInstanceImplementation;
      aImplementationClass: TInterfacedObjectClass;
      aTimeOutSec: cardinal=30*60); reintroduce;
    /// release all used memory
    // - e.g. any internal implementation instances
    destructor Destroy; override;



    /// call a given method of this service provider
    // - aMethodIndex is the index in Methods[]
    // - if aMethodIndex=-1, then it will free/release corresponding aInstanceID
    // (is called  e.g. from {"method":"free", "params":[], "id":1234} )
    // - aParamsJSONArray is e.g. '[1,2]' i.e. a true JSON array, which will
    // contain the incoming parameters in the same exact order than the
    // corresponding implemented interface method
................................................................................
    // instance, ExecuteMethod(..,'[1,2]') over ICalculator.Add will return:
    // $ {"result":[3],"id":0}
    // the returned "id" number is the Instance identifier to be used for any later
    // sicClientDriven remote call - or just 0 in case of sicSingle or sicShared
    function ExecuteMethod(aSession: cardinal; aMethodIndex, aInstanceID: Integer;
      aParamsJSONArray: PUTF8Char; var aResp, aHead, aErrorMsg: RawUTF8): cardinal;
  end;























  /// a global services provider class
  // - used to maintain a list of interfaces implementation
  TServiceContainer = class
  protected
    fRest: TSQLRest;
    fList: TObjectList;
    fExpectMangledURI: boolean;



  public
    /// initialize the list
    constructor Create(aRest: TSQLRest);
    /// release all registered services
    destructor Destroy; override;
    /// method called on the server side to register a service
    // - will raise an exception on error
    // - will return true if some interfaces have been added
    function AddImplementation(aImplementationClass: TInterfacedObjectClass;
      const aInterfaces: array of PTypeInfo;
      aInstanceCreation: TServiceInstanceImplementation): boolean;
    /// return the number of registered service interfaces
    function Count: integer;











    /// retrieve a service provider from its URI
    // - it expects the supplied URI variable  to be e.g. '00amyWGct0y_ze4lIsj2Mw'
    // or 'Calculator', depending on the ExpectMangledURI property
    // - on match, it  will return the service the corresponding interface factory
    // - returns nil if the URI does not match any registered interface
    function Service(const aURI: RawUTF8): TServiceFactory; overload;
    /// retrieve a service provider from its index in the list
    // - returns nil if out of range index
    function Service(aIndex: integer): TServiceFactory; overload; {$ifdef HASINLINE}inline;{$endif}
    /// the associated RESTful instance
    property Rest: TSQLRest read fRest;
    /// set if the URI is expected to be mangled from the GUID
    // - by default (FALSE), the clear service name is expected to be supplied at
    // the URI level (e.g. 'Calculator')
    // - if this property is set to TRUE, the mangled URI value will be expected
    // instead (may enhance security) - e.g. '00amyWGct0y_ze4lIsj2Mw'
    property ExpectMangledURI: boolean read fExpectMangledURI write fExpectMangledURI;
  end;
































  /// for TSQLRestCache, stores a table values
  TSQLRestCacheEntryValue = record
    /// corresponding ID
    ID: integer;
    /// GetTickCount value when this cached value was stored
    // - equals 0 when there is no JSON value cached
    TimeStamp: cardinal; 
    /// JSON encoded UTF-8 serialization of the record
    JSON: RawUTF8;
  end;

  /// for TSQLRestCache, stores all tables values
  TSQLRestCacheEntryValueDynArray = array of TSQLRestCacheEntryValue;
................................................................................
  TURIMapRequest = function(url, method, SendData: PUTF8Char; Resp, Head: PPUTF8Char): Int64Rec; cdecl;

{$ifdef MSWINDOWS}
  {$define WITHSTATPROCESS}
  // if defined, the server statistics will contain precise working time process
{$endif}

{$ifdef FPC}
{$PACKRECORDS 1}
{$else}
{$A-} { compiler use packed storage here, not aligned data }
{$endif}
  /// used for statistics update in TSQLRestServer.URI()
  TSQLRestServerStats = class(TPersistent)
  private
    /// used to determine if something changed
    fLastIncomingBytes: cardinal;
    /// current count of connected clients
    fClientsCurrent,
................................................................................
    property ServiceCalls: cardinal read fServices;
{$ifdef WITHSTATPROCESS}
    /// the global time spent in the server process
    property ProcessTime: RawUTF8 read GetProcessTimeString;
{$endif}
  end;

{$ifdef FPC}
{$PACKRECORDS 8}
{$else}
{$A+}
{$endif}

  ///  used to define how to trigger Events on record update
  // - see TSQLRestServer.OnUpdateEvent property
  // - returns true on success, false if an error occured (but action must continue)
  // - to be used only server-side, not to synchronize some clients: the framework
  // is designed around a stateless RESTful architecture (like HTTP/1.1), in which
  // clients ask the server for refresh (see TSQLRestClientURI.UpdateFromServer)
  TNotifySQLEvent = function(Sender: TSQLRestServer; Event: TSQLEvent;
................................................................................
    {{ wrapper to the protected URI method to call a method on the server, using
      a ModelRoot/[TableName/[ID/]]MethodName RESTful PUT request
      - returns the HTTP error code (e.g. 200 on success)
      - this version will use a PUT with the supplied raw UTF-8 data }
    function CallBackPut(const aMethodName, aSentData: RawUTF8;
      out aResponse: RawUTF8; aTable: TSQLRecordClass=nil; aID: integer=0;
      aResponseHead: PRawUTF8=nil): integer;











    /// is set to TRUE, all BLOB fields are transferred between the Client and
    // the remote Server
    // - i.e. Add() Update() will use Blob-related RESTful PUT/POST request
    // - i.e. Retrieve() will use Blob-related RESTful GET request
    // - note that the Refresh method won't handle BLOB fields, even if this
    // property setting is set to TRUE
    // - by default, this property is set to FALSE, which setting will spare
................................................................................
    // fastest common call with one TSQLRecordClass
    result := TSQLRecordClass(Tables[0]).RecordProps.
      SQLFromSelectWhere(SQLSelect,SQLWhere);
    exit;
  end;
  // 'SELECT T1.F1,T1.F2,T1.F3,T2.F1,T2.F2 FROM T1,T2 WHERE ..' e.g.
  if PtrUInt(high(Tables))>high(Props) then
    raise Exception.Create('SQLFromSelectWhere');
  for i := 0 to high(Tables) do begin
    Props[i] := TSQLRecordClass(Tables[i]).RecordProps;
    if Props[i]=nil then
      raise Exception.CreateFmt('SQLFromSelectWhere: not in Model: %s',
        [Tables[i].ClassName]);
  end;
  if SQLSelect='*' then
     // don't send BLOB values to query: retrieve all other fields
    if high(Tables)=0 then
      result := 'SELECT '+Props[0].SQLTableSimpleFields[true,false] else begin
      result := 'SELECT '+Props[0].SQLTableSimpleFields[true,true];
................................................................................
      FU := GetJSONField(P,P);
      inc(Len,length(FU));
      if P=nil then break;
      Fields2[FieldsCount] := FU;
      Values[FieldsCount] := GetSQLValue; // update EndOfObject
      inc(FieldsCount);
      if FieldsCount=MAX_SQLFIELDS then
        raise Exception.Create('Too many inlines in GetJSONObjectAsSQL');
    until EndOfObject in [#0,'}',']'];
    Return(@Fields2,@Values,InlinedParams);
  end else begin
    // get "VAL1","VAL2"...
    if RowID>0 then
      raise Exception.Create('GetJSONObjectAsSQL(expanded) won''t handle RowID');
    FieldsCount := length(Fields);
    for F := 0 to FieldsCount-1 do begin
      inc(Len,length(Fields[F]));
      Values[F] := GetSQLValue; // update EndOfObject
    end;
    Return(@Fields[0],@Values,InlinedParams);
  end;
................................................................................
procedure TSQLRecordFill.SetMappedFieldsExpandedJSONWriter(aClass: TSQLRecordClass;
  W: TJSONWriter);
var i,n: integer;
begin // update ID, TModTime and FillPrepare mapped fields
  if (self=nil) or (W=nil) or (aClass=nil) then
    exit;
  if fTableMapRecordManyInstances<>nil then
    raise Exception.Create('SetMappedFieldsExpandedJSONWriter after FillPrepareMany');
  if fTableMapFieldsColNames=nil then
  with aClass.RecordProps do begin // init fTableMapFields[Max,ColNames] from mapping
    n := 1;
    for i := 0 to high(Fields) do
      if FieldType[i]=sftModTime then begin
        Include(fTableMapFields,i);
        inc(n);
................................................................................
procedure TSQLRecord.FillRow(aRow: integer; aDest: TSQLRecord=nil);
begin
  if self<>nil then
    if aDest=nil then
      fFill.Fill(aRow) else
      if fFill.fTableMapRecordManyInstances=nil then
        fFill.Fill(aRow,aDest) else
        raise Exception.Create('FillRow() forbidden after FillPrepareMany');
end;

function TSQLRecord.FillOne: boolean;
begin
  if (self=nil) or (fFill=nil) or (fFill.Table=nil) or
     (fFill.Table.RowCount=0) or // also check if FillTable is emtpy
     (cardinal(fFill.FillCurrentRow)>cardinal(fFill.Table.RowCount)) then
................................................................................
      case Kind of
      rFTS3:  result := result+'fts3(';
      rFTS4:  result := result+'fts4(';
      rRTree: result := result+'rtree(ID,';
      rCustomForcedID, rCustomAutoID: begin
        M := aModel.VirtualTableModule(self);
        if M=nil then
          raise Exception.CreateFmt('No registered module for %s',[ClassName]);
        result := result+M.ModuleName+'('+GetVirtualTableSQLCreate(RecordProps);
      end;
      end;
      case Kind of
      rFTS3, rFTS4: begin
        for i := 0 to n-1 do
          if FieldType[i]<>sftUTF8Text then
            raise Exception.CreateFmt('%s.%s: FTS3/FTS4 field must be RawUTF8',
              [SQLTableName,FieldsName[i]]) else
            Fields[i]^.AppendName(result,',');
        if InheritsFrom(TSQLRecordFTS3Porter) or
           InheritsFrom(TSQLRecordFTS4Porter) then
          result := result+' tokenize=porter)' else
          result := result+' tokenize=simple)';
      end;
      rRTree: begin
        if (n<3) or (n>RTREE_MAX_DIMENSION*2+1) or (n and 2<>1) then
          raise Exception.CreateFmt('%d: %s RTREE expects an odd 3..%d column number',
            [n,SQLTableName,RTREE_MAX_DIMENSION*2+1]);
        for i := 0 to n-1 do
          if FieldType[i]<>sftFloat then
            raise Exception.CreateFmt('%s.%s: RTREE field must be double',
              [SQLTableName,FieldsName[i]]) else
            Fields[i]^.AppendName(result,',');
        result[length(result)] := ')';
      end;
      end;
    end else begin
      // inherits from TSQLRecord: create a "normal" SQLite3 table
................................................................................
        FieldType := Props.FieldType[f];
        FieldName := @Props.Fields[f]^.ShortName;
        FieldRecordClass := TSQLRecordClass(PT^.ClassType^.ClassType);
      end;
    end;
    sftMany:
      if GetTableIndex(TSQLRecordClass(PT^.ClassType^.ClassType))<0 then
        raise Exception.CreateFmt('%s must include %s for %s.%s',
          [ClassName,TSQLRecordClass(PT^.ClassType^.ClassType).ClassName,
           Tables[aIndex].ClassName,Props.FieldsName[f]]);
    end;
  end;
  if Last then
    QuickSortRawUTF8(fTablesName,length(fTablesName),@fTablesNameIndex,StrIComp);
end;
................................................................................
    aTableIndexCreated^ := n;
  result := true;
end;

constructor TSQLModel.Create(CloneFrom: TSQLModel);
begin
  if CloneFrom=nil then
    raise Exception.Create('TSQLModel.Create(CloneFrom=nil)');
  Create(CloneFrom.fTables,CloneFrom.fRoot);
  fVirtualTableModule := CloneFrom.fVirtualTableModule;
end;

constructor TSQLModel.Create(TabParameters: PSQLRibbonTabParameters;
  TabParametersCount, TabParametersSize: integer;
  const NonVisibleTables: array of TSQLRecordClass; const aRoot: RawUTF8);
var i: integer;
    Tables: array of TSQLRecordClass;
begin
  if (TabParameters=nil) or (TabParametersCount<=0) or
     (cardinal(TabParametersSize)<sizeof(TSQLRibbonTabParameters)) then
    raise Exception.Create('TSQLModel.Create(TabParameters?)');
  SetLength(Tables,TabParametersCount+length(NonVisibleTables));
  for i := 0 to TabParametersCount-1 do begin
    Tables[i] := TabParameters^.Table;
    inc(PtrUInt(TabParameters),TabParametersSize);
  end;
  for i := 0 to high(NonVisibleTables) do
    Tables[i+TabParametersCount] := NonVisibleTables[i];
................................................................................
end;

constructor TSQLModel.Create(const Tables: array of TSQLRecordClass; const aRoot: RawUTF8='root');
var N, i: integer;
begin
  N := length(Tables);
  if N>sizeof(SUPERVISOR_ACCESS_RIGHTS.Get)*8 then // TSQLAccessRights bits size
    raise Exception.CreateFmt('%s has too many Tables: %d>%d',
      [ClassName,N,sizeof(SUPERVISOR_ACCESS_RIGHTS.Get)*8]); // e.g. N>64
  // set the Tables to be associated with this Model, as TSQLRecord classes
  SetLength(fTables,N);
  move(Tables[0],fTables[0],N*Sizeof(Tables[0]));
  SetLength(fTablesName,N);
  SetLength(fTablesNameIndex,N);
  SetLength(TableProps,N);
................................................................................
    result := SetCache(PSQLRecordClass(aRecord)^,aRecord.fID);
end;

constructor TSQLRestCache.Create(aRest: TSQLRest);
var i: integer;
begin
  if aRest=nil then
    Exception.CreateFmt('%s.Create',[ClassName]);
  fRest := aRest;
  SetLength(fCache,length(fRest.Model.Tables));
  for i := 0 to high(fCache) do
    with fCache[i] do begin
      Value.Init(TypeInfo(TSQLRestCacheEntryValueDynArray),Values,@Count);
      Value.Compare := SortDynArrayInteger; // will search/sort by ID
      InitializeCriticalSection(Mutex);
................................................................................
    result := URI(Model.getURICallBack(aMethodName,aTable,aID),
      'PUT',nil,aResponseHead,@aSentData).Lo;
{$ifdef WITHLOG}
    SQLite3Log.Add.Log(sllServiceReturn,'Result=%',result);
{$endif}
  end;
end;













procedure TSQLRestClientURI.BatchAbort;
begin
  if self<>nil then begin
    fBatchCount := 0;
    fBatchTable := nil;
    fBatch.CancelAll;
................................................................................
    P := pointer(result);
    repeat
      Read := FileRead(Handle,P^,L);
      if Read=0 then begin
        sleep(100); // nothing available -> wait a little and retry
        Read := FileRead(Handle,P^,L);
        if Read=0 then begin // server may be down -> abort
          raise Exception.Create('ReadString');
          exit;
        end;
      end;
      inc(P,Read);
      dec(L,Read);
    until L=0; // loop until received all expected data 
  end;
................................................................................
end;

destructor TSQLRestServer.Destroy;
var i: integer;
begin
{$ifdef WITHLOG}
  if not InheritsFrom(TSQLRestServerStatic) then
    SQLite3Log.Add.Log(sllInfo,StringToUTF8(Stats.DebugMessage),self);
{$endif}
{$ifdef MSWINDOWS}
  if GlobalURIRequestServer=self then begin
    GlobalURIRequestServer := nil;
    sleep(200); // way some time any request is finished in another thread
  end;
  // close any opened server
................................................................................
  if (ppBeg=0) or (PosEx(RawUTF8('):'),SQL,ppBeg+2)=0) then
    // SQL code with no valid :(...): internal parameters -> leave maxParam=0
    exit;
  // compute GenericSQL from SQL, converting :(...): into ?
  Gen := PUTF8Char(pointer(result))+ppBeg-1; // Gen^ just before :(
  P := PUTF8Char(pointer(SQL))+ppBeg+1; // P^ just after :(
  repeat
    Gen^ := '?'; // replace :(...): into ?
    inc(Gen);
    if length(Values)<=maxParam then
      SetLength(Values,maxParam+8);
    P := SQLParamContent(P,Types[maxParam],Values[maxParam]);
    if P=nil then begin
      maxParam := 0;
      result := SQL;
................................................................................
      inc(P);
    end;
    if P^=#0 then
      Break;
    inc(P,2);
    inc(maxParam);
    if maxParam>high(Types) then
      raise Exception.Create('Too many :(): params');
  until false;
  // get statement from cache, or create new one
  SetLength(result,Gen-pointer(result));
  inc(maxParam);
end;

procedure TSQLRestServer.SetNoAJAXJSON(const Value: boolean);
var i: integer;
begin
................................................................................
  const aInterfaces: array of PTypeInfo;
  aInstanceCreation: TServiceInstanceImplementation): boolean;
begin
  result := False;
  if (self=nil) or (aImplementationClass=nil) or (high(aInterfaces)<0) then
    exit;
  if fServices=nil then
    fServices := TServiceContainer.Create(self);

  result := fServices.AddImplementation(aImplementationClass,aInterfaces,aInstanceCreation);
end;

function TSQLRestServer.ServiceCall(aSession: cardinal; const aURI, aSentData: RawUTF8;
  var aResp, aHead, aErrorMsg: RawUTF8; var aResult: cardinal): boolean;
var Service: TServiceFactory;
    method, JSON: RawUTF8;
    Values: TPUtf8CharDynArray;
    m, id: integer;
begin
  result := false;
  if aSentData='' then
    exit;
  Service := Services.Service(aURI);
  if Service=nil then
    exit;
  inc(fStats.fServices);
  SetString(JSON,PAnsiChar(aSentData),length(aSentData)); // in-place modif.
  JSONDecode(JSON,['METHOD','PARAMS','ID'],Values,True);
  if Values[0]=nil then begin
    aErrorMsg := 'Method name required';
................................................................................
  end;
  if Values[1]=nil then begin
    aErrorMsg := 'Parameters required';
    exit;
  end;
  method := Values[0];
  id := GetCardinal(Values[2]);








  if (id<>0) and IdemPropNameU(method,'free') then
    // "method":"free" to release the sicClientDriven server-side instance
    m := -1 else begin
    // regular method
    m := Service.MethodIndex(method);
    if m<0 then begin
      aErrorMsg := 'Unknown method';
................................................................................

constructor TSQLRestClientURIDll.Create(aModel: TSQLModel; const DllName: TFileName);
var aRequest: TURIMapRequest;
    aDLL: cardinal;
begin
  aDLL := LoadLibrary(pointer(DllName));
  if aDLL=0 then
    raise Exception.Create(DllName);
  aRequest := GetProcAddress(aDLL,'URIRequest');
  if (@aRequest=nil) or (aRequest(nil,nil,nil,nil,nil).Lo<>404) then begin
    FreeLibrary(aDLL);
    raise Exception.CreateFmt('%s doesn''t export a valid URIRequest function',[DllName]);
  end;
  Create(aModel,aRequest);
  fLibraryHandle := aDLL;
end;

constructor TSQLRestClientURIDll.Create(aModel: TSQLModel; aRequest: TURIMapRequest);
begin
................................................................................
    if WaitNamedPipe(pointer(fPipeName),1000) then
      // 1000 since we have sleep(128) in TSQLRestServerNamedPipe.EngineExecute
      CreatePipe;
  end;
  if Pipe=Invalid_Handle_Value then begin // server must exist
    if (aModel<>nil) and (aModel.Owner=self) then
      aModel.Free; // avoid memory leak
    raise Exception.CreateFmt(
      '%s can''t connect to server "%s"'#13'via "%s":'#13'%s',
      [ClassName,ApplicationName,fPipeName,SysErrorMessage(GetLastError)]);
  end;
{$ifdef ANONYMOUSNAMEDPIPE}
  RevertToSelf; // we just needed to be anonymous during pipe connection
{$endif}
  inherited Create(aModel);
................................................................................
constructor TSQLRestServerStaticInMemory.Create(aClass: TSQLRecordClass; aServer: TSQLRestServer;
  const aFileName: TFileName = ''; aBinaryFile: boolean=false);
var JSON: RawUTF8;
    Stream: TStream;
begin
  inherited Create(aClass,aServer,aFileName,aBinaryFile);
  if fStoredClassProps.Kind in INSERT_WITH_ID then
    raise Exception.CreateFmt('%s: %s virtual table can''t be static',
      [fStoredClassProps.SQLTableName,aClass.ClassName]);
  fBinaryFile := aBinaryFile;
  fValue := TObjectList.Create;
  if (fFileName<>'') and FileExists(fFileName) then begin
    if aBinaryFile then begin
      Stream := TSynMemoryStreamMapped.Create(fFileName);
      try
................................................................................
{ TSQLRestServerStatic }

constructor TSQLRestServerStatic.Create(aClass: TSQLRecordClass;
  aServer: TSQLRestServer; const aFileName: TFileName; aBinaryFile: boolean);
begin
  inherited Create(nil,false);
  if aClass=nil then
    raise Exception.CreateFmt('%s.Create expect a class',[ClassName]);
  fStoredClass := aClass;
  fStoredClassProps := aClass.RecordProps;
  fIsUnique := fStoredClassProps.IsUniqueFieldsBits;
  if aServer<>nil then begin
    fOwner := aServer;
    fModel := aServer.Model;
    fNoAJAXJSON := aServer.fNoAJAXJSON; // expanded as main Server
................................................................................

constructor TSQLRestClientURIMessage.Create(aModel: TSQLModel;
  const ServerWindowName: string; ClientWindow: HWND; TimeOutMS: cardinal);
begin
  inherited Create(aModel);
  fServerWindow := FindWindow(pointer(ServerWindowName),nil);
  if fServerWindow=0 then
    raise Exception.CreateFmt('No "%s" window available - server may be down',
      [ServerWindowName]);
  fClientWindow := ClientWindow;
  fTimeOutMS := TimeOutMS;
end;

constructor TSQLRestClientURIMessage.Create(aModel: TSQLModel;
  const ServerWindowName, ClientWindowName: string; TimeOutMS: cardinal);
var H: HWND;
begin
  H := CreateInternalWindow(ClientWindowName,self);
  if H=0 then
    raise Exception.CreateFmt('Impossible to create "%s" client window',
      [ClientWindowName]);
  fClientWindowName := ClientWindowName;
  Create(aModel,ServerWindowName,H,TimeOutMS);
end;

destructor TSQLRestClientURIMessage.Destroy;
begin
................................................................................
    CP := InternalClassProp(aClassType);
    if CP=nil then
      exit;
    P := @CP^.PropList;
    for pi := 0 to CP^.PropCount-1 do begin
      // 0. check that this property is not an ID/RowID (handled separately)
      if IsRowID(P^.ShortName) then
        raise Exception.CreateFmt('%s should not include a %s published property',
          [aTable.ClassName,P^.ShortName]);
      // 1. store RTTI for this property
      FieldType[f] := P^.PropType^^.SQLFieldType;
      Fields[f] := P;
      FieldName := RawUTF8(P^.ShortName);
      for j := 0 to f-1 do
        if IdemPropNameU(FieldsName[j],FieldName) then
          raise Exception.CreateFmt('dup property name %s in %s',
            [FieldName,aTable.ClassName]);
      FieldsName[f] := FieldName;
      fFieldsNameSorted[f] := FieldName;
      fFieldsNameIndex[f] := f; 
      // 2. handle unique fields, i.e. if marked as "stored false"
      Unique := not P^.IsStored;
      if Unique then begin
................................................................................
          ManyFields[nMany] := P;
          inc(nMany);
        end;
        sftBlobDynArray: begin
          if P^.Index<>0 then
            for j := 0 to nDynArray-1 do
            if DynArrayFields[j]^.Index=P^.Index then
              raise Exception.CreateFmt('dup index %d for %s.%s and %s properties',
                [P^.Index,aTable.ClassName,P^.ShortName,DynArrayFields[j]^.ShortName]);
          DynArrayFields[nDynArray] := P;
          inc(nDynArray);
          goto Simple;
        end;
        else begin
          // this code follows NOT_SIMPLE_FIELDS const 
................................................................................
  SQLTableName := GetDisplayNameFromClass(aTable);
  ExternalTableName := SQLTableName;
  SQLTableNameUpperWithDot := UpperCase(SQLTableName)+'.';
  ClassProp := InternalClassProp(aTable);
  assert(ClassProp<>nil);
  nProps := PClassProp(aTable)^.FieldCountWithParents;
  if nProps>MAX_SQLFIELDS then
    raise Exception.CreateFmt('%s has too many fields: %d>%d',
      [SQLTableName,nProps,MAX_SQLFIELDS]);
  SetLength(FieldType,nProps);
  SetLength(Fields,nProps);
  SetLength(FieldsName,nProps);
  SetLength(fFieldsNameSorted,nProps);
  SetLength(fFieldsNameIndex,nProps);
  SetLength(ManyFields,nProps);
................................................................................

constructor TSQLVirtualTable.Create(aModule: TSQLVirtualTableModule;
  const aTableName: RawUTF8; FieldCount: integer; Fields: PPUTF8CharArray);
var aTable: TSQLRecordClass;
    aTableIndex: integer;
begin
  if (aModule=nil) or (aTableName='') then
    raise Exception.CreateFmt('Invalid parameters to %s.Create',[ClassName]);
  fModule := aModule;
  fTableName := aTableName;
  if fModule.fFeatures.StaticClass<>nil then
    // create no fStatic instance e.g. for TSQLVirtualTableLog
    if fModule.Server=nil then
      raise Exception.CreateFmt('Missing aModule.Server for %s.Create',[ClassName]) else
    with fModule.Server do begin
      aTableIndex := Model.GetTableIndex(aTableName);
      if aTableIndex>=0 then begin
        aTable := Model.Tables[aTableIndex];
        fStatic := fModule.fFeatures.StaticClass.Create(aTable,fModule.Server,
          fModule.FileName(aTableName),self.InheritsFrom(TSQLVirtualTableBinary));
        if length(fStaticVirtualTable)<>length(Model.Tables) then
................................................................................
      {$endif}
      Access;
      exit; // create successfull
    end;
    User.GroupRights.Free;
    User.GroupRights := GID;
  end;
  raise Exception.Create('TAuthSession.Create');
end;

destructor TAuthSession.Destroy;
begin
  if User<>nil then begin
    User.GroupRights.Free;
    fUser.Free;
................................................................................
{ TServiceFactory }

type
  PInterfaceTypeData = ^TInterfaceTypeData;
  TInterfaceTypeData = packed record
    IntfParent : PPTypeInfo; // ancestor
    IntfFlags : set of (ifHasGuid, ifDispInterface, ifDispatch);
    Guid : TGUID;
    IntfUnit : ShortString;
  end;
  TMethodKind = (mkProcedure, mkFunction, mkConstructor, mkDestructor,
    mkClassProcedure, mkClassFunction, { Obsolete } mkSafeProcedure, mkSafeFunction);
  TIntfMethodEntryTail = packed record
    Kind: TMethodKind;
    CC: TCallingConvention;
................................................................................
    PP: ^PPTypeInfo absolute P;
    Ancestor: PTypeInfo;
    Kind: TMethodKind;
    i,j, n, m,a,reg,offs: integer;
begin
  // check supplied interface
  if (aRest=nil) or (aInterface=nil) then
    raise Exception.Create('Invalid call');
  fRest := aRest;
  fInstanceCreation := aInstanceCreation;
  fInterfaceTypeInfo := aInterface;
  fInterfaceURI := aInterface^.ShortName;
  if fInterfaceURI[1] in ['I','i'] then
    Delete(fInterfaceURI,1,1);
  P := fInterfaceTypeInfo.ClassType;
  if PI^.IntfParent<>nil then
    Ancestor := PI^.IntfParent^ else
    Ancestor := nil;
  if (Ancestor<>nil) and (Ancestor<>TypeInfo(IService)) then
    raise Exception.CreateFmt('%s interface should not have %s as parent but IService',
      [fInterfaceTypeInfo^.ShortName,Ancestor^.ShortName]);
  fInterfaceIID := PI^.Guid;
  P := @PI^.IntfUnit[ord(PI^.IntfUnit[0])+1];
  fInterfaceMangledURI := BinToBase64URI(@fInterfaceIID,sizeof(TGUID));
  // retrieve methods (not from ancestors since we inherit from IService)
  n := PW^; inc(PW);
  if PW^=$ffff then
    raise Exception.CreateFmt('%s interface has no RTTI',[fInterfaceTypeInfo^.ShortName]);
  inc(PW);
  fMethodsCount := n;
  SetLength(fMethods,n); // QueryInterface, _AddRef, _Release are hard-coded
  for i := 0 to n-1 do
  with fMethods[i] do begin

    SetString(URI,PAnsiChar(@PS^[1]),ord(PS^[0]));
    PS := @PS^[ord(PS^[0])+1];
    Kind := PME^.Kind;
    CallingConvention := PME^.CC;
    if CallingConvention<>ccRegister then
      raise Exception.CreateFmt('%s.%s method shall use register calling convention',
        [fInterfaceTypeInfo^.ShortName,URI]);
    n := PME^.ParamCount;
    inc(PME);
    if Kind=mkFunction then
      SetLength(Args,n+1) else
      SetLength(Args,n);
    for j := 0 to n-1 do
................................................................................
        ValueDirection := smdOut;
      inc(PF);
      ParamName := PS;
      PS := @PS^[ord(PS^[0])+1];
      TypeName := PS;
      PS := @PS^[ord(PS^[0])+1];
      if PP^=nil then
        raise Exception.CreateFmt('%s.%s method %s parameter has no information',
          [fInterfaceTypeInfo^.ShortName,URI,ParamName^]);
      TypeInfo := PP^^;
      inc(PP);
      {$ifdef ISDELPHIXE2}
      inc(PW); // skip attributes
      {$endif}
      if j=0 then
        ValueType := smvSelf else
        ValueType := TypeInfoToMethodValueType(TypeInfo);
      if ValueType=smvNone then
        raise Exception.CreateFmt('%s.%s method %s parameter has unexpected type %s',
          [fInterfaceTypeInfo^.ShortName,URI,ParamName^,TypeName^]);
    end;
    if Kind=mkFunction then
    with Args[n] do begin
      ParamName := @CONST_RESULT_NAME;
      ValueDirection := smdResult;
      TypeName := PS;
      PS := @PS^[ord(PS^[0])+1];
      TypeInfo := PP^^;
      inc(PP);
      ValueType := TypeInfoToMethodValueType(TypeInfo);
      if ValueType=smvNone then
        raise Exception.CreateFmt('%s.%s method has unexpected result type %s',
          [fInterfaceTypeInfo^.ShortName,URI,TypeName^]);
    end;
    {$ifdef ISDELPHIXE2}
    inc(PW); // skip attributes
    {$endif}
  end;
  // compute asm low-level layout of the parameters for each method
................................................................................
    with Args[a] do
      if OffsetInStack>=0 then begin
        dec(offs,SizeInStack);
        OffsetInStack := offs;
      end;
    assert(offs=0);
  end;
  // initialize the shared instance
  if InstanceCreation=sicShared then begin
    fSharedInstance := InternalProduce;
    if (fSharedInstance=nil) or
       not fSharedInstance.GetInterface(fInterfaceIID,fSharedInterface) then
      raise Exception.CreateFmt('%s internal class does not implement "%s" interface',
        [ClassName,fInterfaceURI]);
  end;
end;

destructor TServiceFactory.Destroy;
begin
  inherited;
end;

function TServiceFactory.FromFactory(out Obj): Boolean;
begin
  result := false;
  if Self<>nil then
    case fInstanceCreation of
    sicShared:
    if fSharedInterface<>nil then begin
      IInterface(Obj) := fSharedInterface; // copy implementation interface
      result := true;
    end;
    sicSingle, sicClientDriven:
      result := InternalProduce.GetInterface(fInterfaceIID,Obj);
    end;
end;

function TServiceFactory.MethodIndex(const aMethod: RawUTF8): integer;
begin
  for result := 0 to fMethodsCount-1 do
    if IdemPropNameU(aMethod,fMethods[result].URI) then
      exit;
  result := -1;
end;


{ TServiceContainer }

function IsEqualGUID(const guid1, guid2: TGUID): Boolean; {$ifdef HASINLINE}inline;{$endif}
var a: array[0..3] of integer absolute guid1;
    b: array[0..3] of integer absolute guid2;
begin // faster implementation than in SysUtils.pas
  Result := (a[0]=b[0]) and (a[1]=b[1]) and (a[2]=b[2]) and (a[3]=b[3]);
end;

function TServiceContainer.AddImplementation(
  aImplementationClass: TInterfacedObjectClass;
  const aInterfaces: array of PTypeInfo;
  aInstanceCreation: TServiceInstanceImplementation): boolean;
var C: TClass;
    T: PInterfaceTable;
    i, j: integer;
    UID: array of ^TGUID;
begin
  result := false;
  // check input parameters
  if (self=nil) or (aImplementationClass=nil) or (high(aInterfaces)<0) then
    exit;

  SetLength(UID,length(aInterfaces));
  for j := 0 to high(aInterfaces) do
    with aInterfaces[j]^, PInterfaceTypeData(ClassType)^ do
    if Kind<>tkInterface then
      raise Exception.CreateFmt('%s is not an interface',[ShortName]) else
    if not (ifHasGuid in IntfFlags) then
      raise Exception.CreateFmt('%s interface has no GUID',[ShortName]) else begin
      UID[j] := @Guid;
      for i := 0 to fList.Count-1 do
        if IsEqualGUID(TServiceFactory(fList.List[i]).InterfaceIID,Guid) then
          raise Exception.CreateFmt('%s GUID already registered',[ShortName]);
    end;
  // check that all interfaces are implemented by this class
  C := aImplementationClass;
  repeat
    T := C.GetInterfaceTable;
    if T<>nil then
      for i := 0 to T^.EntryCount-1 do
        with T^.Entries[i] do
................................................................................
            UID[j] := nil;
            break;
          end;
    C := C.ClassParent;
  until C=nil;
  for j := 0 to high(aInterfaces) do
    if UID[j]<>nil then
      raise Exception.CreateFmt('Interface %s not found in %s implementation',
        [aInterfaces[j]^.ShortName,aImplementationClass.ClassName]);
  // register this implementation class
  for j := 0 to high(aInterfaces) do
    fList.Add(TServiceFactoryServer.Create(Rest,aInterfaces[j],aInstanceCreation,
      aImplementationClass));
  result := true;
end;




function TServiceContainer.Count: integer;
begin
  if self=nil then
    result := 0 else
    result := fList.Count;
end;

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

destructor TServiceContainer.Destroy;
begin
  fList.Free;
  inherited;
end;















function TServiceContainer.Service(const aURI: RawUTF8): TServiceFactory;
var i: Integer;
begin
  if (self<>nil) and (aURI<>'') then
  with fList do begin
    if ExpectMangledURI then begin
      for i := 0 to Count-1 do begin
        result := List[i];
................................................................................
        if IdemPropNameU(aURI,result.fInterfaceURI) then
          exit;
      end;
  end;
  result := nil;
end;














function TServiceContainer.Service(aIndex: integer): TServiceFactory;
begin
  if (Self=nil) or (Cardinal(aIndex)>=Cardinal(fList.Count)) then
    result := nil else
    result := fList.List[aIndex];
end;













{ TServiceFactoryServer }

constructor TServiceFactoryServer.Create(aRest: TSQLRest; aInterface: PTypeInfo;
  aInstanceCreation: TServiceInstanceImplementation;
  aImplementationClass: TInterfacedObjectClass; aTimeOutSec: cardinal);
begin





  fImplementationClass := aImplementationClass; // inherited Create needs itpc

  inherited Create(aRest,aInterface,aInstanceCreation);







  if InstanceCreation=sicClientDriven then begin


    InitializeCriticalSection(fInstanceLock);
    fInstanceTimeOut := aTimeOutSec;
    fInstance.Init(TypeInfo(TServiceFactoryServerInstanceDynArray),
      fInstances,@fInstancesCount);
    fInstance.Compare := SortDynArrayInteger;

  end;
end;

destructor TServiceFactoryServer.Destroy;
var i: integer;
begin
  try
    for i := 0 to fInstancesCount-1 do
      fInstances[i].Instance.Free;
  except

  end;
  DeleteCriticalSection(fInstanceLock);
  inherited;
end;

function TServiceFactoryServer.InternalProduce: TInterfacedObject;

begin









  if (Self=nil) or (fImplementationClass=nil) then











    result := nil else



























    result := fImplementationClass.Create;


end;





















function TServiceFactoryServer.ExecuteMethod(aSession: cardinal;
  aMethodIndex, aInstanceID: Integer; aParamsJSONArray: PUTF8Char;
  var aResp, aHead, aErrorMsg: RawUTF8): cardinal;
var i: integer;
    Inst: TServiceFactoryServerInstance;
    TimeOutTimeStamp: cardinal;
    WR: TTextWriter;
    entry: PInterfaceEntry;
    method: pointer;
begin // returns 200 + {"result":[3],"id":0} on success

  result := 400;
  // 1. initialize Inst.Instance and Inst.InstanceID
  Inst.InstanceID := 0;
  Inst.Instance := nil;
  case InstanceCreation of
    sicSingle:
      if cardinal(aMethodIndex)>=cardinal(fMethodsCount) then
        exit else
        Inst.Instance := InternalProduce;
    sicShared:
      if cardinal(aMethodIndex)>=cardinal(fMethodsCount) then
        exit else
        Inst.Instance := fSharedInstance;
    sicClientDriven: begin
      Inst.InstanceID := aInstanceID;
      Inst.LastAccess := GetTickCount;
      TimeOutTimeStamp := Inst.LastAccess+fInstanceTimeOut;
      EnterCriticalSection(fInstanceLock);
      try
        // first release any deprecated instances
        for i := 0 to fInstancesCount-1 do
          with fInstances[i] do
          if (LastAccess<Inst.LastAccess) or
             (LastAccess>TimeOutTimeStamp) then begin
            InstanceID := 0; // mark this entry is empty
            FreeAndNil(Instance);
          end;
        // retrieve or initialize the instance
        if Inst.InstanceID=0 then begin
          if cardinal(aMethodIndex)>=cardinal(fMethodsCount) then
            exit;
          // initialize the new instance
          inc(fInstanceCurrentID);
          Inst.InstanceID := fInstanceCurrentID;
          for i := 0 to fInstancesCount-1 do
            if fInstances[i].InstanceID=0 then begin
              Inst.Instance := InternalProduce; // found an empty entry
              if Inst.Instance<>nil then
                fInstances[i] := Inst;
              break;
            end;
          if Inst.Instance=nil then begin
            Inst.Instance := InternalProduce; // append a new entry
            if Inst.Instance<>nil then
             fInstance.Add(Inst);
          end;
        end else
          // search the given instance
          for i := 0 to fInstancesCount-1 do
            with fInstances[i] do
            if InstanceID=Inst.InstanceID then begin
              if aMethodIndex<0 then begin
                // aMethodIndex=-1 fpr {"method":"free", "params":[], "id":1234}
                InstanceID := 0;
                FreeAndNil(Instance);
                result := 200; // successfully released instance
                exit;
              end;
              LastAccess := Inst.LastAccess;
              Inst.Instance := Instance;
              break;
            end;
      finally
        LeaveCriticalSection(fInstanceLock);
      end;
    end;
  end;
  if Inst.Instance=nil then begin
    aErrorMsg := FormatUTF8('Implementation instance %d not found or deprecated',
      [Inst.InstanceID]);
    exit;
  end;
  // 2. call method implementation

  entry := Inst.Instance.GetInterfaceEntry(fInterfaceIID);
  if entry=nil then
    exit;
  method := PPointerArray(PPointer(PtrInt(Inst.Instance)+entry^.IOffset)^)^
    [aMethodIndex+3]; // +3 for hardcoded QueryInterface+_AddRef+_Release
  WR := TTextWriter.CreateOwnedStream;
  try
    // root/calculator {"method":"add","params":[1,2]} -> {"result":[3],"id":0}
    try
      WR.AddShort('{"result":[');
      fMethods[aMethodIndex].InternalExecute(
        Inst.Instance,method,aParamsJSONArray,WR,aErrorMsg);
      if aErrorMsg<>'' then
        exit; // wrong request
      WR.AddShort('],"id":');
      WR.Add(Inst.InstanceID);
      WR.AddShort('}');
      aResp := WR.Text;
      result := 200; // success
    except
      on E: Exception do begin
        result := 500;
        aErrorMsg := FormatUTF8('%s: %s',[E.ClassName,E.Message]);
        exit;
      end;
    end;
  finally
    WR.Free;
  end;



end;











// we already have the value on the FPU ST(0) register -> do nothing functions 
function LoadDouble: double; asm end;
function LoadCurrency: currency; asm end;

procedure TServiceMethod.InternalExecute(Instance, Method: pointer;
  Par: PUTF8Char; Res: TTextWriter; var Error: RawUTF8);
var Stack: TByteDynArray;
    StackSize: integer;
    Int64s: TInt64DynArray;
    RawUTF8s: TRawUTF8DynArray;
    Strings: TStringDynArray;
    WideStrings: TWideStringDynArray;
    Objects: array of TObject;
    DynArrays: array of record
      Wrapper: TDynArray;
      Value: pointer;
    end;
    Value: pointer;
    i,a: integer;
    wasString, valid: boolean;
    EndOfObject: AnsiChar;
    Val: PUTF8Char;
    cla: TClass;
    obj: TJSONObject;
    r: packed record EAX, EDX, ECX, EAX2, EDX2: integer; end;
begin

  StackSize := ArgsSize;
  SetLength(Stack,StackSize);
  SetLength(Int64s,ArgsUsedCount[smvv64]);
  SetLength(RawUTF8s,ArgsUsedCount[smvvRawUTF8]);
  SetLength(Strings,ArgsUsedCount[smvvString]);
  SetLength(WideStrings,ArgsUsedCount[smvvWideString]);
  SetLength(Objects,ArgsUsedCount[smvvObject]);
  SetLength(DynArrays,ArgsUsedCount[smvvDynArray]);
  try
    // 1. read the parameters
    while (Par^<>#0) and (Par^<=' ') do inc(Par);
    if Par^<>'[' then begin
      Error := 'Array expected';
      Exit;
    end;
    inc(Par);
    for a:= 0 to high(Args) do
    with Args[a] do begin
      Error := FormatUTF8('Invalid argument %',[ParamName^]);
      case ValueType of
      smvSelf:
        continue; // self parameter is never transmitted
      smvObject: begin
        if TypeInfo^.Kind<>tkClass then
          Exit;
        cla := TypeInfo^.ClassType^.ClassType;
................................................................................
        REGEAX: r.EAX := PInteger(Value)^;
        REGEDX: r.EDX := PInteger(Value)^;
        REGECX: r.ECX := PInteger(Value)^;
        else    move(Value^,Stack[OffsetInStack],SizeInStack);
        end;
    end;
    // 3. execute the method

    asm
      mov eax,StackSize
      mov edx,dword ptr Stack
      add edx,eax // pascal/register convention = left-to-right
      shr eax,2
      jz @z
  @n: sub edx,4
................................................................................
      if (ValueVar=smvv64) and (ValueDirection=smdResult) then begin
        case ValueType of // ordinal/real result values from CPU/FPU registers
        smvDouble, smvDateTime: Res.Add(LoadDouble);
        smvCurrency:            Res.Add(LoadCurrency);
        smvBoolean:             Res.Add(PByte(@r.EAX2)^);
        smvInteger:             Res.Add(r.EAX2);
        smvInt64:               Res.Add(PInt64(@r.EAX2)^);
        else raise Exception.CreateFmt('Invalid result type %d',[ord(ValueType)]);
        end;
      end else
      case ValueType of
      smvObject:     Res.WriteObject(Objects[IndexVar],False,False,true);
      smvDynArray:   Res.AddDynArrayJSON(DynArrays[IndexVar].Wrapper);
      smvBoolean:    Res.Add(PByte(@Int64s[IndexVar])^);
      smvInteger:    Res.Add(PInteger(@Int64s[IndexVar])^);
................................................................................
      smvWideString: Res.AddJSONEscapeW(pointer(WideStrings[IndexVar]));
      end;
      if ValueIsString then
        Res.Add('"',',') else
        Res.Add(',');
    end;
    Res.CancelLastComma;
    Error := ''; // mark success
  finally // manual release memory for Objects[] and DynArrays[]
    for i := 0 to high(Objects) do
      Objects[i].Free;
    for i := 0 to high(DynArrays) do
      DynArrays[i].Wrapper.Clear;
  end;
end;









































































































































































































initialization
  pointer(@SQLFieldTypeComp[sftAnsiText]) := @AnsiIComp;
{$ifndef USENORMTOUPPER}
  pointer(@SQLFieldTypeComp[sftUTF8Text]) := @AnsiIComp;
{$endif}
  DefaultHasher := @crc32; // faster and more accurate than kr32()

end.

      by TSQLRestServerStaticInMemory.SaveToBinary)
    - fixed issue with TAuthSession.IDCardinal=0 after 76 connections
    - fixed issue in SetInt64Prop() with a setter method
    - fixed potential issue in TSQLTable.SearchValue in case of invalid Client
      supplied parameter (now checks TSQLRest class type)

  Version 1.16
    - added dedicated Exception classes (EORMException, EParsingException,
      ESecurityException, ECommunicationException, EBusinessLayerException,
      EServiceException) all inheriting from SynCommons.ESynException
    - added a generic JSON error message mechanism within the framework
      (including error code as integer and text, with custom error messages
      in RecordCanBeUpdated method and also in TSQLRestServerCallBackParams)
    - the TSQLRestServerCallBack method prototype has been modified to supply
      "var aParams: TSQLRestServerCallBackParams: cardinal" as unique parameter:
      this is a CODE BREAK change and you shall refresh ALL your server-side
      code to match the new signature (using a record passed by value as
................................................................................

  /// maximum handled dimension for TSQLRecordRTree
  // - this value is the one used by SQLite3 R-Tree virtual table
  RTREE_MAX_DIMENSION = 5;


type
  /// generic parent class of all custom Exception types of this unit
  EORMException = class(ESynException);

  /// exception raised in case of wrong Model definition
  EModelException = class(EORMException);

  /// exception raised in case of unexpected parsing error
  EParsingException = class(EORMException);

  /// exception raised in case of a Client-Server communication error
  ECommunicationException = class(EORMException);

  /// exception raised in case of an error in project implementation logic
  EBusinessLayerException = class(EORMException);

  /// exception raised in case of any authentication error
  ESecurityException = class(EORMException);

  /// exception dedicated to interface based service implementation
  EServiceException = class(EORMException);

  TSQLModel = class;
  TSQLRest = class;
  TSQLRestClient = class;

{$M+} { we need the RTTI information to be compiled for the published
        properties of these classes and their children (like TPersistent),
        to enable ORM - must be defined at the forward definition level }
  TSQLRecord = class;      // published properties = ORM fields/columns
  TSQLAuthUser = class;

  TSQLRestServer = class;  // published events = RESTful callbacks handlers
  TSQLRestClientURI = class;

{$M-}

  /// class-reference type (metaclass) of TSQLRecord
  TSQLRecordClass = class of TSQLRecord;

  PSQLRecordClass = ^TSQLRecordClass;
................................................................................

  /// all our services shall inherit from this interface
  // - in the current implementation, we rely on a single inheritance from
  // IService, in order to simplify the implementation
  IService = interface(IInvokable)
  end;


  /// the possible Server-side instance implementation patterns for Services
  // - each interface-based service will be implemented by a corresponding
  // class instance on the server: this parameter is used to define how
  // class instances are created and managed
  // - on the Client-side, each instance will be handled depending on the
  // server side implementation (i.e. with sicClientDriven behavior if necessary)
  // - sicSingle: one object instance is created per call - this is the
................................................................................
    Args: TServiceMethodArgumentDynArray;
    /// needed CPU stack size (in bytes) for all arguments
    ArgsSize: cardinal;
    /// contains all used kind of arguments
    ArgsUsed: set of TServiceMethodValueType;
    /// contains the count of variables for all used kind of arguments
    ArgsUsedCount: array[TServiceMethodValueVar] of integer;
    /// method index in the original interface
    // - our custom methods start at index 3, since QueryInterface, _AddRef,
    // and _Release methods are always defined by default
    MethodIndex: integer;
    /// 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
    function InternalExecute(Instance: pointer; Entry: PInterfaceEntry;
      Par: PUTF8Char; Res: TTextWriter): boolean;
  end;

  /// describe a service provider methods
  TServiceMethodDynArray = array of TServiceMethod;

  /// an abstract service provider, as registered in TServiceContainer
  // - this will be either implemented by a TInterfacedObjectClass on the server,
................................................................................
  protected
    fInterfaceTypeInfo: PTypeInfo;
    fInterfaceIID: TGUID;
    fInterfaceURI: RawUTF8;
    fInterfaceMangledURI: RawUTF8;
    fInstanceCreation: TServiceInstanceImplementation;
    fRest: TSQLRest;


    fMethodsCount: integer;
    fMethods: TServiceMethodDynArray;

    fSharedInstance: TInterfacedObject;
  public
    /// initialize the service provider parameters
    // - it will check and retrieve all methods of the supplied interface,
    // and prepare all internal structures for its serialized execution
    constructor Create(aRest: TSQLRest; aInterface: PTypeInfo;
      aInstanceCreation: TServiceInstanceImplementation);
    /// retrieve an instance of this interface
    // - this virtual method will be overriden to reflect the expected
    // behavior of client or server side
    function Get(out Obj): Boolean; virtual; abstract;


    /// get the index in Methods[] of a given method name
    // - returns -1 if the method name is unknown
    function MethodIndex(const aMethod: RawUTF8): integer;
    /// the associated RESTful instance
    property Rest: TSQLRest read fRest;
    /// the registered Interface low-level Delphi RTTI type
    property InterfaceTypeInfo: PTypeInfo read fInterfaceTypeInfo;
................................................................................
    // - only relevant on the server side; on the client side, this class will
    // be accessed only to retrieve a remote access instance, i.e. sicSingle
    property InstanceCreation: TServiceInstanceImplementation read fInstanceCreation;
    /// the declared methods
    property Methods: TServiceMethodDynArray read fMethods;
  end;

  /// server-side service provider use this to store one internal instance
  // - used by TServiceFactoryServer in sicClientDriven mode
  TServiceFactoryServerInstance = record
    /// the internal Instance ID, as remotely sent in "id":1
    // - is set to 0 when an entry in the array is free
    InstanceID: Cardinal;
    /// last time stamp access of this instance
    LastAccess: Cardinal;
    /// the implementation instance itself
    Instance: TInterfacedObject;
  end;

  /// server-side service provider use this to store its internal instances
  // - used by TServiceFactoryServer in sicClientDriven mode
  TServiceFactoryServerInstanceDynArray = array of TServiceFactoryServerInstance;

  /// a service provider implemented on the server side
  TServiceFactoryServer = class(TServiceFactory)
  protected

    fInstances: TServiceFactoryServerInstanceDynArray;
    fInstance: TDynArray;
    fInstancesCount: integer;
    fInstanceCurrentID: integer;
    fInstanceTimeOut: cardinal;
    fInstanceLock: TRTLCriticalSection;
    fImplementationClass: TInterfacedObjectClass;
    fSharedInterface: IInterface;
    function ClientDrivenRetrieve(var Inst: TServiceFactoryServerInstance;
      aMethodIndex: integer): boolean;
  public
    /// initialize the service provider on the server side
    // - expect an implementation class
    // - for sicClientDriven, a time out (in seconds) can be defined
    constructor Create(aRest: TSQLRest; aInterface: PTypeInfo;
      aInstanceCreation: TServiceInstanceImplementation;
      aImplementationClass: TInterfacedObjectClass;
      aTimeOutSec: cardinal=30*60); reintroduce;
    /// release all used memory
    // - e.g. any internal TServiceFactoryServerInstance instances
    destructor Destroy; override;
    /// retrieve an instance of this interface from the server side
    // - sicClientDriven kind of instance creation will behave the same as sicSingle
    function Get(out Obj): Boolean; override;
    /// call a given method of this service provider
    // - aMethodIndex is the index in Methods[]
    // - if aMethodIndex=-1, then it will free/release corresponding aInstanceID
    // (is called  e.g. from {"method":"free", "params":[], "id":1234} )
    // - aParamsJSONArray is e.g. '[1,2]' i.e. a true JSON array, which will
    // contain the incoming parameters in the same exact order than the
    // corresponding implemented interface method
................................................................................
    // instance, ExecuteMethod(..,'[1,2]') over ICalculator.Add will return:
    // $ {"result":[3],"id":0}
    // the returned "id" number is the Instance identifier to be used for any later
    // sicClientDriven remote call - or just 0 in case of sicSingle or sicShared
    function ExecuteMethod(aSession: cardinal; aMethodIndex, aInstanceID: Integer;
      aParamsJSONArray: PUTF8Char; var aResp, aHead, aErrorMsg: RawUTF8): cardinal;
  end;

  /// a service provider implemented on the client side
  TServiceFactoryClient = class(TServiceFactory)
  protected
    fClient: TSQLRestClientURI;
    fRemoteClassName: RawUTF8;
    fFakeVTable: array of pointer;
    fFakeStub: PByteArray;
    function CallClient(const aMethod: RawUTF8; const aParams: RawUTF8='';
      aResult: PRawUTF8=nil; aClientDrivenID: PCardinal=nil): boolean;
  public
    /// initialize the service provider parameters
    // - it will check and retrieve all methods of the supplied interface,
    // and prepare all internal structures for its serialized execution
    constructor Create(aRest: TSQLRest; aInterface: PTypeInfo;
      aInstanceCreation: TServiceInstanceImplementation);
    /// finalize the service provider used structures
    // - especially the internal shared VTable and code Stub
    destructor Destroy; override;
    /// retrieve an instance of this interface from the server side
    function Get(out Obj): Boolean; override;
  end;

  /// a global services provider class
  // - used to maintain a list of interfaces implementation
  TServiceContainer = class
  protected
    fRest: TSQLRest;
    fList: TObjectList;
    fExpectMangledURI: boolean;
    procedure CheckInterface(const aInterfaces: array of PTypeInfo);
    /// retrieve a service provider from its URI
    function GetService(const aURI: RawUTF8): TServiceFactory;
  public
    /// initialize the list
    constructor Create(aRest: TSQLRest);
    /// release all registered services
    destructor Destroy; override;






    /// return the number of registered service interfaces
    function Count: integer;
    /// retrieve a service provider from its index in the list
    // - returns nil if out of range index
    function Index(aIndex: integer): TServiceFactory; overload; {$ifdef HASINLINE}inline;{$endif}
    /// retrieve a service provider from its GUID
    // - on match, it  will return the service the corresponding interface factory
    // - returns nil if the GUID does not match any registered interface
    function GUID(const aGUID: TGUID): TServiceFactory; overload;
    /// retrieve a service provider from its type information
    // - on match, it  will return the service the corresponding interface factory
    // - returns nil if the type information does not match any registered interface
    function Info(aTypeInfo: PTypeInfo): TServiceFactory; overload; virtual;
    /// retrieve a service provider from its URI
    // - it expects the supplied URI variable  to be e.g. '00amyWGct0y_ze4lIsj2Mw'
    // or 'Calculator', depending on the ExpectMangledURI property
    // - on match, it  will return the service the corresponding interface factory
    // - returns nil if the URI does not match any registered interface
    property Services[const aURI: RawUTF8]: TServiceFactory read GetService; default;



    /// the associated RESTful instance
    property Rest: TSQLRest read fRest;
    /// set if the URI is expected to be mangled from the GUID
    // - by default (FALSE), the clear service name is expected to be supplied at
    // the URI level (e.g. 'Calculator')
    // - if this property is set to TRUE, the mangled URI value will be expected
    // instead (may enhance security) - e.g. '00amyWGct0y_ze4lIsj2Mw'
    property ExpectMangledURI: boolean read fExpectMangledURI write fExpectMangledURI;
  end;

  /// a services provider class to be used on the server side
  // - this will maintain a list of true implementation classes
  TServiceContainerServer = class(TServiceContainer)
  public
    /// method called on the server side to register a service via its interface(s)
    // and a specified implementation class
    // - will raise an exception on error
    // - will return true if some interfaces have been added
    function AddImplementation(aImplementationClass: TInterfacedObjectClass;
      const aInterfaces: array of PTypeInfo;
      aInstanceCreation: TServiceInstanceImplementation): boolean;
  end;

  /// a services provider class to be used on the client side
  // - this will maintain a list of fake implementation classes, which will
  // remotely call the server to make the actual process
  TServiceContainerClient = class(TServiceContainer)
  protected
  public
    /// retrieve a service provider from its type information
    // - this overriden method will register the internface, if was not yet
    // - in this case, the interface will be registered with sicClientDriven
    // implementation method
    function Info(aTypeInfo: PTypeInfo): TServiceFactory; overload; override;
    /// method called on the client side to register a service via its interface(s)
    // - will raise an exception on error
    // - will return true if some interfaces have been added
    function AddInterface(const aInterfaces: array of PTypeInfo;
      aInstanceCreation: TServiceInstanceImplementation): boolean;
  end;

  /// for TSQLRestCache, stores a table values
  TSQLRestCacheEntryValue = record
    /// corresponding ID
    ID: integer;
    /// GetTickCount value when this cached value was stored
    // - equals 0 licwhen there is no JSON value cached
    TimeStamp: cardinal; 
    /// JSON encoded UTF-8 serialization of the record
    JSON: RawUTF8;
  end;

  /// for TSQLRestCache, stores all tables values
  TSQLRestCacheEntryValueDynArray = array of TSQLRestCacheEntryValue;
................................................................................
  TURIMapRequest = function(url, method, SendData: PUTF8Char; Resp, Head: PPUTF8Char): Int64Rec; cdecl;

{$ifdef MSWINDOWS}
  {$define WITHSTATPROCESS}
  // if defined, the server statistics will contain precise working time process
{$endif}






  /// used for statistics update in TSQLRestServer.URI()
  TSQLRestServerStats = class(TPersistent)
  private
    /// used to determine if something changed
    fLastIncomingBytes: cardinal;
    /// current count of connected clients
    fClientsCurrent,
................................................................................
    property ServiceCalls: cardinal read fServices;
{$ifdef WITHSTATPROCESS}
    /// the global time spent in the server process
    property ProcessTime: RawUTF8 read GetProcessTimeString;
{$endif}
  end;







  ///  used to define how to trigger Events on record update
  // - see TSQLRestServer.OnUpdateEvent property
  // - returns true on success, false if an error occured (but action must continue)
  // - to be used only server-side, not to synchronize some clients: the framework
  // is designed around a stateless RESTful architecture (like HTTP/1.1), in which
  // clients ask the server for refresh (see TSQLRestClientURI.UpdateFromServer)
  TNotifySQLEvent = function(Sender: TSQLRestServer; Event: TSQLEvent;
................................................................................
    {{ wrapper to the protected URI method to call a method on the server, using
      a ModelRoot/[TableName/[ID/]]MethodName RESTful PUT request
      - returns the HTTP error code (e.g. 200 on success)
      - this version will use a PUT with the supplied raw UTF-8 data }
    function CallBackPut(const aMethodName, aSentData: RawUTF8;
      out aResponse: RawUTF8; aTable: TSQLRecordClass=nil; aID: integer=0;
      aResponseHead: PRawUTF8=nil): integer;
    /// register a Service on the client side via its interface
    // - this methods expects a list of interfaces to be registered to the client
    // (e.g. [TypeInfo(IMyInterface)])
    // - instance implementation pattern will be set by the appropriate parameter
    // - will return true on success, false if registration failed (e.g. if any of
    // the supplied interfaces is not correct or is not available on the server)
    // - that is, server side will be called to check for the availability of
    // this interface(s)
    function ServiceRegister(const aInterfaces: array of PTypeInfo;
      aInstanceCreation: TServiceInstanceImplementation=sicSingle): boolean; virtual;

    /// is set to TRUE, all BLOB fields are transferred between the Client and
    // the remote Server
    // - i.e. Add() Update() will use Blob-related RESTful PUT/POST request
    // - i.e. Retrieve() will use Blob-related RESTful GET request
    // - note that the Refresh method won't handle BLOB fields, even if this
    // property setting is set to TRUE
    // - by default, this property is set to FALSE, which setting will spare
................................................................................
    // fastest common call with one TSQLRecordClass
    result := TSQLRecordClass(Tables[0]).RecordProps.
      SQLFromSelectWhere(SQLSelect,SQLWhere);
    exit;
  end;
  // 'SELECT T1.F1,T1.F2,T1.F3,T2.F1,T2.F2 FROM T1,T2 WHERE ..' e.g.
  if PtrUInt(high(Tables))>high(Props) then
    raise EModelException.Create('SQLFromSelectWhere');
  for i := 0 to high(Tables) do begin
    Props[i] := TSQLRecordClass(Tables[i]).RecordProps;
    if Props[i]=nil then
      raise EModelException.CreateFmt('SQLFromSelectWhere: not in Model: %s',
        [Tables[i].ClassName]);
  end;
  if SQLSelect='*' then
     // don't send BLOB values to query: retrieve all other fields
    if high(Tables)=0 then
      result := 'SELECT '+Props[0].SQLTableSimpleFields[true,false] else begin
      result := 'SELECT '+Props[0].SQLTableSimpleFields[true,true];
................................................................................
      FU := GetJSONField(P,P);
      inc(Len,length(FU));
      if P=nil then break;
      Fields2[FieldsCount] := FU;
      Values[FieldsCount] := GetSQLValue; // update EndOfObject
      inc(FieldsCount);
      if FieldsCount=MAX_SQLFIELDS then
        raise EParsingException.Create('Too many inlines in GetJSONObjectAsSQL');
    until EndOfObject in [#0,'}',']'];
    Return(@Fields2,@Values,InlinedParams);
  end else begin
    // get "VAL1","VAL2"...
    if RowID>0 then
      raise EParsingException.Create('GetJSONObjectAsSQL(expanded) won''t handle RowID');
    FieldsCount := length(Fields);
    for F := 0 to FieldsCount-1 do begin
      inc(Len,length(Fields[F]));
      Values[F] := GetSQLValue; // update EndOfObject
    end;
    Return(@Fields[0],@Values,InlinedParams);
  end;
................................................................................
procedure TSQLRecordFill.SetMappedFieldsExpandedJSONWriter(aClass: TSQLRecordClass;
  W: TJSONWriter);
var i,n: integer;
begin // update ID, TModTime and FillPrepare mapped fields
  if (self=nil) or (W=nil) or (aClass=nil) then
    exit;
  if fTableMapRecordManyInstances<>nil then
    raise EBusinessLayerException.Create('SetMappedFieldsExpandedJSONWriter after FillPrepareMany');
  if fTableMapFieldsColNames=nil then
  with aClass.RecordProps do begin // init fTableMapFields[Max,ColNames] from mapping
    n := 1;
    for i := 0 to high(Fields) do
      if FieldType[i]=sftModTime then begin
        Include(fTableMapFields,i);
        inc(n);
................................................................................
procedure TSQLRecord.FillRow(aRow: integer; aDest: TSQLRecord=nil);
begin
  if self<>nil then
    if aDest=nil then
      fFill.Fill(aRow) else
      if fFill.fTableMapRecordManyInstances=nil then
        fFill.Fill(aRow,aDest) else
        raise EBusinessLayerException.Create('FillRow() forbidden after FillPrepareMany');
end;

function TSQLRecord.FillOne: boolean;
begin
  if (self=nil) or (fFill=nil) or (fFill.Table=nil) or
     (fFill.Table.RowCount=0) or // also check if FillTable is emtpy
     (cardinal(fFill.FillCurrentRow)>cardinal(fFill.Table.RowCount)) then
................................................................................
      case Kind of
      rFTS3:  result := result+'fts3(';
      rFTS4:  result := result+'fts4(';
      rRTree: result := result+'rtree(ID,';
      rCustomForcedID, rCustomAutoID: begin
        M := aModel.VirtualTableModule(self);
        if M=nil then
          raise EModelException.CreateFmt('No registered module for %s',[ClassName]);
        result := result+M.ModuleName+'('+GetVirtualTableSQLCreate(RecordProps);
      end;
      end;
      case Kind of
      rFTS3, rFTS4: begin
        for i := 0 to n-1 do
          if FieldType[i]<>sftUTF8Text then
            raise EModelException.CreateFmt('%s.%s: FTS3/FTS4 field must be RawUTF8',
              [SQLTableName,FieldsName[i]]) else
            Fields[i]^.AppendName(result,',');
        if InheritsFrom(TSQLRecordFTS3Porter) or
           InheritsFrom(TSQLRecordFTS4Porter) then
          result := result+' tokenize=porter)' else
          result := result+' tokenize=simple)';
      end;
      rRTree: begin
        if (n<3) or (n>RTREE_MAX_DIMENSION*2+1) or (n and 2<>1) then
          raise EModelException.CreateFmt('%d: %s RTREE expects an odd 3..%d column number',
            [n,SQLTableName,RTREE_MAX_DIMENSION*2+1]);
        for i := 0 to n-1 do
          if FieldType[i]<>sftFloat then
            raise EModelException.CreateFmt('%s.%s: RTREE field must be double',
              [SQLTableName,FieldsName[i]]) else
            Fields[i]^.AppendName(result,',');
        result[length(result)] := ')';
      end;
      end;
    end else begin
      // inherits from TSQLRecord: create a "normal" SQLite3 table
................................................................................
        FieldType := Props.FieldType[f];
        FieldName := @Props.Fields[f]^.ShortName;
        FieldRecordClass := TSQLRecordClass(PT^.ClassType^.ClassType);
      end;
    end;
    sftMany:
      if GetTableIndex(TSQLRecordClass(PT^.ClassType^.ClassType))<0 then
        raise EModelException.CreateFmt('%s must include %s for %s.%s',
          [ClassName,TSQLRecordClass(PT^.ClassType^.ClassType).ClassName,
           Tables[aIndex].ClassName,Props.FieldsName[f]]);
    end;
  end;
  if Last then
    QuickSortRawUTF8(fTablesName,length(fTablesName),@fTablesNameIndex,StrIComp);
end;
................................................................................
    aTableIndexCreated^ := n;
  result := true;
end;

constructor TSQLModel.Create(CloneFrom: TSQLModel);
begin
  if CloneFrom=nil then
    raise EModelException.Create('TSQLModel.Create(CloneFrom=nil)');
  Create(CloneFrom.fTables,CloneFrom.fRoot);
  fVirtualTableModule := CloneFrom.fVirtualTableModule;
end;

constructor TSQLModel.Create(TabParameters: PSQLRibbonTabParameters;
  TabParametersCount, TabParametersSize: integer;
  const NonVisibleTables: array of TSQLRecordClass; const aRoot: RawUTF8);
var i: integer;
    Tables: array of TSQLRecordClass;
begin
  if (TabParameters=nil) or (TabParametersCount<=0) or
     (cardinal(TabParametersSize)<sizeof(TSQLRibbonTabParameters)) then
    raise EModelException.Create('TSQLModel.Create(TabParameters?)');
  SetLength(Tables,TabParametersCount+length(NonVisibleTables));
  for i := 0 to TabParametersCount-1 do begin
    Tables[i] := TabParameters^.Table;
    inc(PtrUInt(TabParameters),TabParametersSize);
  end;
  for i := 0 to high(NonVisibleTables) do
    Tables[i+TabParametersCount] := NonVisibleTables[i];
................................................................................
end;

constructor TSQLModel.Create(const Tables: array of TSQLRecordClass; const aRoot: RawUTF8='root');
var N, i: integer;
begin
  N := length(Tables);
  if N>sizeof(SUPERVISOR_ACCESS_RIGHTS.Get)*8 then // TSQLAccessRights bits size
    raise EModelException.CreateFmt('%s has too many Tables: %d>%d',
      [ClassName,N,sizeof(SUPERVISOR_ACCESS_RIGHTS.Get)*8]); // e.g. N>64
  // set the Tables to be associated with this Model, as TSQLRecord classes
  SetLength(fTables,N);
  move(Tables[0],fTables[0],N*Sizeof(Tables[0]));
  SetLength(fTablesName,N);
  SetLength(fTablesNameIndex,N);
  SetLength(TableProps,N);
................................................................................
    result := SetCache(PSQLRecordClass(aRecord)^,aRecord.fID);
end;

constructor TSQLRestCache.Create(aRest: TSQLRest);
var i: integer;
begin
  if aRest=nil then
    EBusinessLayerException.CreateFmt('%s.Create',[ClassName]);
  fRest := aRest;
  SetLength(fCache,length(fRest.Model.Tables));
  for i := 0 to high(fCache) do
    with fCache[i] do begin
      Value.Init(TypeInfo(TSQLRestCacheEntryValueDynArray),Values,@Count);
      Value.Compare := SortDynArrayInteger; // will search/sort by ID
      InitializeCriticalSection(Mutex);
................................................................................
    result := URI(Model.getURICallBack(aMethodName,aTable,aID),
      'PUT',nil,aResponseHead,@aSentData).Lo;
{$ifdef WITHLOG}
    SQLite3Log.Add.Log(sllServiceReturn,'Result=%',result);
{$endif}
  end;
end;

function TSQLRestClientURI.ServiceRegister(const aInterfaces: array of PTypeInfo;
  aInstanceCreation: TServiceInstanceImplementation=sicSingle): boolean; 
begin
  result := False;
  if (self=nil) or (high(aInterfaces)<0) then
    exit;
  if fServices=nil then
    fServices := TServiceContainerClient.Create(self);
  result := (fServices as TServiceContainerClient).AddInterface(
    aInterfaces,aInstanceCreation);
end;

procedure TSQLRestClientURI.BatchAbort;
begin
  if self<>nil then begin
    fBatchCount := 0;
    fBatchTable := nil;
    fBatch.CancelAll;
................................................................................
    P := pointer(result);
    repeat
      Read := FileRead(Handle,P^,L);
      if Read=0 then begin
        sleep(100); // nothing available -> wait a little and retry
        Read := FileRead(Handle,P^,L);
        if Read=0 then begin // server may be down -> abort
          raise ECommunicationException.Create('ReadString');
          exit;
        end;
      end;
      inc(P,Read);
      dec(L,Read);
    until L=0; // loop until received all expected data 
  end;
................................................................................
end;

destructor TSQLRestServer.Destroy;
var i: integer;
begin
{$ifdef WITHLOG}
  if not InheritsFrom(TSQLRestServerStatic) then
    SQLite3Log.Add.Log(sllInfo,Stats.DebugMessage,self);
{$endif}
{$ifdef MSWINDOWS}
  if GlobalURIRequestServer=self then begin
    GlobalURIRequestServer := nil;
    sleep(200); // way some time any request is finished in another thread
  end;
  // close any opened server
................................................................................
  if (ppBeg=0) or (PosEx(RawUTF8('):'),SQL,ppBeg+2)=0) then
    // SQL code with no valid :(...): internal parameters -> leave maxParam=0
    exit;
  // compute GenericSQL from SQL, converting :(...): into ?
  Gen := PUTF8Char(pointer(result))+ppBeg-1; // Gen^ just before :(
  P := PUTF8Char(pointer(SQL))+ppBeg+1; // P^ just after :(
  repeat
    Gen^ := '?'; // replace :(...): by ?
    inc(Gen);
    if length(Values)<=maxParam then
      SetLength(Values,maxParam+8);
    P := SQLParamContent(P,Types[maxParam],Values[maxParam]);
    if P=nil then begin
      maxParam := 0;
      result := SQL;
................................................................................
      inc(P);
    end;
    if P^=#0 then
      Break;
    inc(P,2);
    inc(maxParam);
    if maxParam>high(Types) then
      raise EParsingException.Create('Too many :(): params');
  until false;
  // return the correct SQL statement, with params in Values[]
  SetLength(result,Gen-pointer(result));
  inc(maxParam);
end;

procedure TSQLRestServer.SetNoAJAXJSON(const Value: boolean);
var i: integer;
begin
................................................................................
  const aInterfaces: array of PTypeInfo;
  aInstanceCreation: TServiceInstanceImplementation): boolean;
begin
  result := False;
  if (self=nil) or (aImplementationClass=nil) or (high(aInterfaces)<0) then
    exit;
  if fServices=nil then
    fServices := TServiceContainerServer.Create(self);
  result := (fServices as TServiceContainerServer).
    AddImplementation(aImplementationClass,aInterfaces,aInstanceCreation);
end;

function TSQLRestServer.ServiceCall(aSession: cardinal; const aURI, aSentData: RawUTF8;
  var aResp, aHead, aErrorMsg: RawUTF8; var aResult: cardinal): boolean;
var Service: TServiceFactory;
    method, JSON: RawUTF8;
    Values: TPUtf8CharDynArray;
    m, id: integer;
begin
  result := false;
  if aSentData='' then
    exit;
  Service := Services[aURI];
  if Service=nil then
    exit;
  inc(fStats.fServices);
  SetString(JSON,PAnsiChar(aSentData),length(aSentData)); // in-place modif.
  JSONDecode(JSON,['METHOD','PARAMS','ID'],Values,True);
  if Values[0]=nil then begin
    aErrorMsg := 'Method name required';
................................................................................
  end;
  if Values[1]=nil then begin
    aErrorMsg := 'Parameters required';
    exit;
  end;
  method := Values[0];
  id := GetCardinal(Values[2]);
  if IdemPropNameU(method,'ClassName') then begin
    // "method":"ClassName" to retrieve the implementation class and test existing
    aResult := 200; // OK
    aResp := '{"result":["'+RawUTF8(
      (Service as TServiceFactoryServer).fImplementationClass.ClassName)+'"],"id":0}';
    result := true;
    exit; // "id":0 for this method -> no instance was created
  end;
  if (id<>0) and IdemPropNameU(method,'free') then
    // "method":"free" to release the sicClientDriven server-side instance
    m := -1 else begin
    // regular method
    m := Service.MethodIndex(method);
    if m<0 then begin
      aErrorMsg := 'Unknown method';
................................................................................

constructor TSQLRestClientURIDll.Create(aModel: TSQLModel; const DllName: TFileName);
var aRequest: TURIMapRequest;
    aDLL: cardinal;
begin
  aDLL := LoadLibrary(pointer(DllName));
  if aDLL=0 then
    raise ECommunicationException.Create(DllName);
  aRequest := GetProcAddress(aDLL,'URIRequest');
  if (@aRequest=nil) or (aRequest(nil,nil,nil,nil,nil).Lo<>404) then begin
    FreeLibrary(aDLL);
    raise ECommunicationException.CreateFmt('%s doesn''t export a valid URIRequest function',[DllName]);
  end;
  Create(aModel,aRequest);
  fLibraryHandle := aDLL;
end;

constructor TSQLRestClientURIDll.Create(aModel: TSQLModel; aRequest: TURIMapRequest);
begin
................................................................................
    if WaitNamedPipe(pointer(fPipeName),1000) then
      // 1000 since we have sleep(128) in TSQLRestServerNamedPipe.EngineExecute
      CreatePipe;
  end;
  if Pipe=Invalid_Handle_Value then begin // server must exist
    if (aModel<>nil) and (aModel.Owner=self) then
      aModel.Free; // avoid memory leak
    raise ECommunicationException.CreateFmt(
      '%s can''t connect to server "%s"'#13'via "%s":'#13'%s',
      [ClassName,ApplicationName,fPipeName,SysErrorMessage(GetLastError)]);
  end;
{$ifdef ANONYMOUSNAMEDPIPE}
  RevertToSelf; // we just needed to be anonymous during pipe connection
{$endif}
  inherited Create(aModel);
................................................................................
constructor TSQLRestServerStaticInMemory.Create(aClass: TSQLRecordClass; aServer: TSQLRestServer;
  const aFileName: TFileName = ''; aBinaryFile: boolean=false);
var JSON: RawUTF8;
    Stream: TStream;
begin
  inherited Create(aClass,aServer,aFileName,aBinaryFile);
  if fStoredClassProps.Kind in INSERT_WITH_ID then
    raise EModelException.CreateFmt('%s: %s virtual table can''t be static',
      [fStoredClassProps.SQLTableName,aClass.ClassName]);
  fBinaryFile := aBinaryFile;
  fValue := TObjectList.Create;
  if (fFileName<>'') and FileExists(fFileName) then begin
    if aBinaryFile then begin
      Stream := TSynMemoryStreamMapped.Create(fFileName);
      try
................................................................................
{ TSQLRestServerStatic }

constructor TSQLRestServerStatic.Create(aClass: TSQLRecordClass;
  aServer: TSQLRestServer; const aFileName: TFileName; aBinaryFile: boolean);
begin
  inherited Create(nil,false);
  if aClass=nil then
    raise EBusinessLayerException.CreateFmt('%s.Create expect a class',[ClassName]);
  fStoredClass := aClass;
  fStoredClassProps := aClass.RecordProps;
  fIsUnique := fStoredClassProps.IsUniqueFieldsBits;
  if aServer<>nil then begin
    fOwner := aServer;
    fModel := aServer.Model;
    fNoAJAXJSON := aServer.fNoAJAXJSON; // expanded as main Server
................................................................................

constructor TSQLRestClientURIMessage.Create(aModel: TSQLModel;
  const ServerWindowName: string; ClientWindow: HWND; TimeOutMS: cardinal);
begin
  inherited Create(aModel);
  fServerWindow := FindWindow(pointer(ServerWindowName),nil);
  if fServerWindow=0 then
    raise ECommunicationException.CreateFmt('No "%s" window available - server may be down',
      [ServerWindowName]);
  fClientWindow := ClientWindow;
  fTimeOutMS := TimeOutMS;
end;

constructor TSQLRestClientURIMessage.Create(aModel: TSQLModel;
  const ServerWindowName, ClientWindowName: string; TimeOutMS: cardinal);
var H: HWND;
begin
  H := CreateInternalWindow(ClientWindowName,self);
  if H=0 then
    raise ECommunicationException.CreateFmt('Impossible to create "%s" client window',
      [ClientWindowName]);
  fClientWindowName := ClientWindowName;
  Create(aModel,ServerWindowName,H,TimeOutMS);
end;

destructor TSQLRestClientURIMessage.Destroy;
begin
................................................................................
    CP := InternalClassProp(aClassType);
    if CP=nil then
      exit;
    P := @CP^.PropList;
    for pi := 0 to CP^.PropCount-1 do begin
      // 0. check that this property is not an ID/RowID (handled separately)
      if IsRowID(P^.ShortName) then
        raise EModelException.CreateFmt('%s should not include a %s published property',
          [aTable.ClassName,P^.ShortName]);
      // 1. store RTTI for this property
      FieldType[f] := P^.PropType^^.SQLFieldType;
      Fields[f] := P;
      FieldName := RawUTF8(P^.ShortName);
      for j := 0 to f-1 do
        if IdemPropNameU(FieldsName[j],FieldName) then
          raise EModelException.CreateFmt('dup property name %s in %s',
            [FieldName,aTable.ClassName]);
      FieldsName[f] := FieldName;
      fFieldsNameSorted[f] := FieldName;
      fFieldsNameIndex[f] := f; 
      // 2. handle unique fields, i.e. if marked as "stored false"
      Unique := not P^.IsStored;
      if Unique then begin
................................................................................
          ManyFields[nMany] := P;
          inc(nMany);
        end;
        sftBlobDynArray: begin
          if P^.Index<>0 then
            for j := 0 to nDynArray-1 do
            if DynArrayFields[j]^.Index=P^.Index then
              raise EModelException.CreateFmt('dup index %d for %s.%s and %s properties',
                [P^.Index,aTable.ClassName,P^.ShortName,DynArrayFields[j]^.ShortName]);
          DynArrayFields[nDynArray] := P;
          inc(nDynArray);
          goto Simple;
        end;
        else begin
          // this code follows NOT_SIMPLE_FIELDS const 
................................................................................
  SQLTableName := GetDisplayNameFromClass(aTable);
  ExternalTableName := SQLTableName;
  SQLTableNameUpperWithDot := UpperCase(SQLTableName)+'.';
  ClassProp := InternalClassProp(aTable);
  assert(ClassProp<>nil);
  nProps := PClassProp(aTable)^.FieldCountWithParents;
  if nProps>MAX_SQLFIELDS then
    raise EModelException.CreateFmt('%s has too many fields: %d>%d',
      [SQLTableName,nProps,MAX_SQLFIELDS]);
  SetLength(FieldType,nProps);
  SetLength(Fields,nProps);
  SetLength(FieldsName,nProps);
  SetLength(fFieldsNameSorted,nProps);
  SetLength(fFieldsNameIndex,nProps);
  SetLength(ManyFields,nProps);
................................................................................

constructor TSQLVirtualTable.Create(aModule: TSQLVirtualTableModule;
  const aTableName: RawUTF8; FieldCount: integer; Fields: PPUTF8CharArray);
var aTable: TSQLRecordClass;
    aTableIndex: integer;
begin
  if (aModule=nil) or (aTableName='') then
    raise EModelException.CreateFmt('Invalid parameters to %s.Create',[ClassName]);
  fModule := aModule;
  fTableName := aTableName;
  if fModule.fFeatures.StaticClass<>nil then
    // create no fStatic instance e.g. for TSQLVirtualTableLog
    if fModule.Server=nil then
      raise EModelException.CreateFmt('Missing aModule.Server for %s.Create',[ClassName]) else
    with fModule.Server do begin
      aTableIndex := Model.GetTableIndex(aTableName);
      if aTableIndex>=0 then begin
        aTable := Model.Tables[aTableIndex];
        fStatic := fModule.fFeatures.StaticClass.Create(aTable,fModule.Server,
          fModule.FileName(aTableName),self.InheritsFrom(TSQLVirtualTableBinary));
        if length(fStaticVirtualTable)<>length(Model.Tables) then
................................................................................
      {$endif}
      Access;
      exit; // create successfull
    end;
    User.GroupRights.Free;
    User.GroupRights := GID;
  end;
  raise ESecurityException.Create('TAuthSession.Create');
end;

destructor TAuthSession.Destroy;
begin
  if User<>nil then begin
    User.GroupRights.Free;
    fUser.Free;
................................................................................
{ TServiceFactory }

type
  PInterfaceTypeData = ^TInterfaceTypeData;
  TInterfaceTypeData = packed record
    IntfParent : PPTypeInfo; // ancestor
    IntfFlags : set of (ifHasGuid, ifDispInterface, ifDispatch);
    IntfGuid : TGUID;
    IntfUnit : ShortString;
  end;
  TMethodKind = (mkProcedure, mkFunction, mkConstructor, mkDestructor,
    mkClassProcedure, mkClassFunction, { Obsolete } mkSafeProcedure, mkSafeFunction);
  TIntfMethodEntryTail = packed record
    Kind: TMethodKind;
    CC: TCallingConvention;
................................................................................
    PP: ^PPTypeInfo absolute P;
    Ancestor: PTypeInfo;
    Kind: TMethodKind;
    i,j, n, m,a,reg,offs: integer;
begin
  // check supplied interface
  if (aRest=nil) or (aInterface=nil) then
    raise EServiceException.Create('Invalid call');
  fRest := aRest;
  fInstanceCreation := aInstanceCreation;
  fInterfaceTypeInfo := aInterface;
  fInterfaceURI := aInterface^.ShortName;
  if fInterfaceURI[1] in ['I','i'] then
    Delete(fInterfaceURI,1,1);
  P := fInterfaceTypeInfo.ClassType;
  if PI^.IntfParent<>nil then
    Ancestor := PI^.IntfParent^ else
    Ancestor := nil;
  if (Ancestor<>nil) and (Ancestor<>TypeInfo(IService)) then
    raise EServiceException.CreateFmt('%s interface should not have %s as parent but IService',
      [fInterfaceTypeInfo^.ShortName,Ancestor^.ShortName]);
  fInterfaceIID := PI^.IntfGuid;
  P := @PI^.IntfUnit[ord(PI^.IntfUnit[0])+1];
  fInterfaceMangledURI := BinToBase64URI(@fInterfaceIID,sizeof(TGUID));
  // retrieve methods (not from ancestors since we inherit from IService)
  n := PW^; inc(PW);
  if PW^=$ffff then
    raise EServiceException.CreateFmt('%s interface has no RTTI',[fInterfaceTypeInfo^.ShortName]);
  inc(PW);
  fMethodsCount := n;
  SetLength(fMethods,n); // QueryInterface, _AddRef, _Release are hard-coded
  for i := 0 to n-1 do
  with fMethods[i] do begin
    MethodIndex := i+3; // +3 because of QueryInterface+_AddRef+_Release
    SetString(URI,PAnsiChar(@PS^[1]),ord(PS^[0]));
    PS := @PS^[ord(PS^[0])+1];
    Kind := PME^.Kind;
    CallingConvention := PME^.CC;
    if CallingConvention<>ccRegister then
      raise EServiceException.CreateFmt('%s.%s method shall use register calling convention',
        [fInterfaceTypeInfo^.ShortName,URI]);
    n := PME^.ParamCount;
    inc(PME);
    if Kind=mkFunction then
      SetLength(Args,n+1) else
      SetLength(Args,n);
    for j := 0 to n-1 do
................................................................................
        ValueDirection := smdOut;
      inc(PF);
      ParamName := PS;
      PS := @PS^[ord(PS^[0])+1];
      TypeName := PS;
      PS := @PS^[ord(PS^[0])+1];
      if PP^=nil then
        raise EServiceException.CreateFmt('%s.%s method %s parameter has no information',
          [fInterfaceTypeInfo^.ShortName,URI,ParamName^]);
      TypeInfo := PP^^;
      inc(PP);
      {$ifdef ISDELPHIXE2}
      inc(PW); // skip attributes
      {$endif}
      if j=0 then
        ValueType := smvSelf else
        ValueType := TypeInfoToMethodValueType(TypeInfo);
      if ValueType=smvNone then
        raise EServiceException.CreateFmt('%s.%s method %s parameter has unexpected type %s',
          [fInterfaceTypeInfo^.ShortName,URI,ParamName^,TypeName^]);
    end;
    if Kind=mkFunction then
    with Args[n] do begin
      ParamName := @CONST_RESULT_NAME;
      ValueDirection := smdResult;
      TypeName := PS;
      PS := @PS^[ord(PS^[0])+1];
      TypeInfo := PP^^;
      inc(PP);
      ValueType := TypeInfoToMethodValueType(TypeInfo);
      if ValueType=smvNone then
        raise EServiceException.CreateFmt('%s.%s method has unexpected result type %s',
          [fInterfaceTypeInfo^.ShortName,URI,TypeName^]);
    end;
    {$ifdef ISDELPHIXE2}
    inc(PW); // skip attributes
    {$endif}
  end;
  // compute asm low-level layout of the parameters for each method
................................................................................
    with Args[a] do
      if OffsetInStack>=0 then begin
        dec(offs,SizeInStack);
        OffsetInStack := offs;
      end;
    assert(offs=0);
  end;




























end;

function TServiceFactory.MethodIndex(const aMethod: RawUTF8): integer;
begin
  for result := 0 to fMethodsCount-1 do
    if IdemPropNameU(aMethod,fMethods[result].URI) then
      exit;
  result := -1;
end;


{ TServiceContainerServer }

function IsEqualGUID(const guid1, guid2: TGUID): Boolean; {$ifdef HASINLINE}inline;{$endif}
var a: array[0..3] of integer absolute guid1;
    b: array[0..3] of integer absolute guid2;
begin // faster implementation than in SysUtils.pas
  Result := (a[0]=b[0]) and (a[1]=b[1]) and (a[2]=b[2]) and (a[3]=b[3]);
end;

function TServiceContainerServer.AddImplementation(
  aImplementationClass: TInterfacedObjectClass;
  const aInterfaces: array of PTypeInfo;
  aInstanceCreation: TServiceInstanceImplementation): boolean;
var C: TClass;
    T: PInterfaceTable;
    i, j: integer;
    UID: array of ^TGUID;
begin
  result := false;
  // check input parameters
  if (self=nil) or (aImplementationClass=nil) or (high(aInterfaces)<0) then
    exit;
  CheckInterface(aInterfaces);
  SetLength(UID,length(aInterfaces));
  for j := 0 to high(aInterfaces) do

    UID[j] := @PInterfaceTypeData(aInterfaces[j]^.ClassType)^.IntfGuid;








  // check that all interfaces are implemented by this class
  C := aImplementationClass;
  repeat
    T := C.GetInterfaceTable;
    if T<>nil then
      for i := 0 to T^.EntryCount-1 do
        with T^.Entries[i] do
................................................................................
            UID[j] := nil;
            break;
          end;
    C := C.ClassParent;
  until C=nil;
  for j := 0 to high(aInterfaces) do
    if UID[j]<>nil then
      raise EServiceException.CreateFmt('Interface %s not found in %s implementation',
        [aInterfaces[j]^.ShortName,aImplementationClass.ClassName]);
  // register this implementation class
  for j := 0 to high(aInterfaces) do
    fList.Add(TServiceFactoryServer.Create(Rest,aInterfaces[j],aInstanceCreation,
      aImplementationClass));
  result := true;
end;


{ TServiceContainer }

function TServiceContainer.Count: integer;
begin
  if self=nil then
    result := 0 else
    result := fList.Count;
end;

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

destructor TServiceContainer.Destroy;
begin
  fList.Free;
  inherited;
end;

procedure TServiceContainer.CheckInterface(const aInterfaces: array of PTypeInfo);
var i: integer;
begin
  for i := 0 to high(aInterfaces) do
    with aInterfaces[i]^, PInterfaceTypeData(ClassType)^ do
    if Kind<>tkInterface then
      raise EServiceException.CreateFmt('%s is not an interface',[ShortName]) else
    if not (ifHasGuid in IntfFlags) then
      raise EServiceException.CreateFmt('%s interface has no GUID',[ShortName]) else begin
      if Guid(IntfGuid)<>nil  then
        raise EServiceException.CreateFmt('%s GUID already registered',[ShortName]);
    end;
end;

function TServiceContainer.GetService(const aURI: RawUTF8): TServiceFactory;
var i: Integer;
begin
  if (self<>nil) and (aURI<>'') then
  with fList do begin
    if ExpectMangledURI then begin
      for i := 0 to Count-1 do begin
        result := List[i];
................................................................................
        if IdemPropNameU(aURI,result.fInterfaceURI) then
          exit;
      end;
  end;
  result := nil;
end;

function TServiceContainer.Info(aTypeInfo: PTypeInfo): TServiceFactory;
var i: Integer;
begin
  if self<>nil then
    with fList do
    for i := 0 to Count-1 do begin
      result := List[i];
      if result.fInterfaceTypeInfo=aTypeInfo then
        exit;
    end;
  result := nil;
end;

function TServiceContainer.Index(aIndex: integer): TServiceFactory;
begin
  if (Self=nil) or (Cardinal(aIndex)>=Cardinal(fList.Count)) then
    result := nil else
    result := fList.List[aIndex];
end;

function TServiceContainer.GUID(const aGUID: TGUID): TServiceFactory;
var i: Integer;
begin
  if self<>nil then
    for i := 0 to fList.Count-1 do begin
      result := fList.List[i];
      if IsEqualGUID(result.InterfaceIID,aGUID) then
        exit;
    end;
  result := nil;
end;

{ TServiceFactoryServer }

constructor TServiceFactoryServer.Create(aRest: TSQLRest; aInterface: PTypeInfo;
  aInstanceCreation: TServiceInstanceImplementation;
  aImplementationClass: TInterfacedObjectClass; aTimeOutSec: cardinal);
begin
  // extract RTTI from the interface
  inherited Create(aRest,aInterface,aInstanceCreation);
  if fRest.MethodAddress(ShortString(InterfaceURI))<>nil then
    raise EServiceException.CreateFmt('%s is already exposed as %s published method',
      [InterfaceURI,fRest.ClassName]) else
  fImplementationClass := aImplementationClass;
  // initialize the shared instance or client driven parameters
  case InstanceCreation of
  sicShared: begin
    fSharedInstance := fImplementationClass.Create;
    if (fSharedInstance=nil) or
       not fSharedInstance.GetInterface(fInterfaceIID,fSharedInterface) then
      raise EServiceException.CreateFmt('No implementation available for "%s" interface',
        [fInterfaceURI]);
  end;
  sicClientDriven:
    if aTimeOutSec=0 then
      fInstanceCreation := sicSingle else begin
      InitializeCriticalSection(fInstanceLock);
      fInstanceTimeOut := aTimeOutSec*1000;
      fInstance.Init(TypeInfo(TServiceFactoryServerInstanceDynArray),
        fInstances,@fInstancesCount);
      fInstance.Compare := SortDynArrayInteger;
    end;
  end;
end;

destructor TServiceFactoryServer.Destroy;
var i: integer;
begin
  try
    for i := 0 to fInstancesCount-1 do
      fInstances[i].Instance.Free;
  except
    ; // better ignore any error in business logic code
  end;
  DeleteCriticalSection(fInstanceLock);
  inherited;
end;

function TServiceFactoryServer.Get(out Obj): Boolean;
var O: TInterfacedObject;
begin
  result := false;
  if Self<>nil then
    case fInstanceCreation of
    sicShared:
    if fSharedInterface<>nil then begin
      IInterface(Obj) := fSharedInterface; // copy implementation interface
      result := true;
    end;
    sicSingle, sicClientDriven: begin
      O := fImplementationClass.Create;
      if O<>nil then
        result := O.GetInterface(fInterfaceIID,Obj);
    end;
    end;
end;

function TServiceFactoryServer.ClientDrivenRetrieve(var Inst: TServiceFactoryServerInstance;
  aMethodIndex: integer): boolean;
var i: integer;
    TimeOutTimeStamp: cardinal;
begin
  result := false;
  Inst.LastAccess := GetTickCount;
  TimeOutTimeStamp := Inst.LastAccess+fInstanceTimeOut;
  EnterCriticalSection(fInstanceLock);
  try
    // first release any deprecated instances
    for i := 0 to fInstancesCount-1 do
      with fInstances[i] do
      if (LastAccess<Inst.LastAccess) or
         (LastAccess>TimeOutTimeStamp) then begin
        InstanceID := 0; // mark this entry is empty
        FreeAndNil(Instance);
      end;
    // retrieve or initialize the instance
    if Inst.InstanceID=0 then begin
      if cardinal(aMethodIndex)>=cardinal(fMethodsCount) then
        exit;
      // initialize the new instance
      inc(fInstanceCurrentID);
      Inst.InstanceID := fInstanceCurrentID;
      for i := 0 to fInstancesCount-1 do
        if fInstances[i].InstanceID=0 then begin
          Inst.Instance := fImplementationClass.Create; // found an empty entry
          if Inst.Instance<>nil then
            fInstances[i] := Inst;
          break;
        end;
      if Inst.Instance=nil then begin
        Inst.Instance := fImplementationClass.Create; // append a new entry
        if Inst.Instance<>nil then
          fInstance.Add(Inst);
      end;
    end else
      // search the given instance
      for i := 0 to fInstancesCount-1 do
        with fInstances[i] do
        if InstanceID=Inst.InstanceID then begin
          if aMethodIndex<0 then begin
            // aMethodIndex=-1 for {"method":"free", "params":[], "id":1234}
            InstanceID := 0;
            FreeAndNil(Instance);
            result := true; // successfully released instance
            exit;
          end;
          LastAccess := Inst.LastAccess;
          Inst.Instance := Instance;
          break;
        end;
  finally
    LeaveCriticalSection(fInstanceLock);
  end;
end;

function TServiceFactoryServer.ExecuteMethod(aSession: cardinal;
  aMethodIndex, aInstanceID: Integer; aParamsJSONArray: PUTF8Char;
  var aResp, aHead, aErrorMsg: RawUTF8): cardinal;

var Inst: TServiceFactoryServerInstance;

    WR: TTextWriter;
    entry: PInterfaceEntry;


begin
  result := 400;
  // 1. initialize Inst.Instance and Inst.InstanceID
  Inst.InstanceID := 0;
  Inst.Instance := nil;
  case InstanceCreation of
    sicSingle:
      if cardinal(aMethodIndex)>=cardinal(fMethodsCount) then
        exit else
        Inst.Instance := fImplementationClass.Create;
    sicShared:
      if cardinal(aMethodIndex)>=cardinal(fMethodsCount) then
        exit else
        Inst.Instance := fSharedInstance;
    sicClientDriven: begin
      Inst.InstanceID := aInstanceID;
      if ClientDrivenRetrieve(Inst,aMethodIndex) then begin
        result := 200;



































        exit; // {"method":"free", "params":[], "id":1234}











      end;
    end;
  end;
  if Inst.Instance=nil then begin
    aErrorMsg := FormatUTF8('Implementation instance %d not found or deprecated',
      [Inst.InstanceID]);
    exit;
  end;
  // 2. call method implementation
  try
    entry := Inst.Instance.GetInterfaceEntry(fInterfaceIID);
    if entry=nil then
      exit;


    WR := TTextWriter.CreateOwnedStream;
    try
      // root/calculator {"method":"add","params":[1,2]} -> {"result":[3],"id":0}
      try
        WR.AddShort('{"result":[');
        if not fMethods[aMethodIndex].InternalExecute(
           Inst.Instance,entry,aParamsJSONArray,WR) then

          exit; // wrong request
        WR.AddShort('],"id":');
        WR.Add(Inst.InstanceID); // only set in sicClientDriven mode
        WR.AddShort('}');
        aResp := WR.Text;
        result := 200; // success
      except
        on E: Exception do begin
          result := 500; // Internal Server Error
          aErrorMsg := FormatUTF8('%s: %s',[E.ClassName,E.Message]);
          exit;
        end;
      end;
    finally
      WR.Free;
    end;
  finally
    if InstanceCreation=sicSingle then
      Inst.Instance.Free; // always release single shot instance
  end;
end;


{ TServiceMethod }

type
  TDynArrayFake = record
    Wrapper: TDynArray;
    Value: Pointer;
  end;

// we already have the value on the FPU ST(0) register -> do nothing functions
function LoadDouble: double; asm end;
function LoadCurrency: currency; asm end;

function TServiceMethod.InternalExecute(Instance: pointer; Entry: PInterfaceEntry;
  Par: PUTF8Char; Res: TTextWriter): boolean;
var Stack: TByteDynArray;
    StackSize: integer;
    Int64s: TInt64DynArray;
    RawUTF8s: TRawUTF8DynArray;
    Strings: TStringDynArray;
    WideStrings: TWideStringDynArray;
    Objects: array of TObject;
    DynArrays: array of TDynArrayFake;

    Value, method: pointer;


    i,a: integer;
    wasString, valid: boolean;
    EndOfObject: AnsiChar;
    Val: PUTF8Char;
    cla: TClass;
    obj: TJSONObject;
    r: packed record EAX, EDX, ECX, EAX2, EDX2: integer; end;
begin
  result := false;
  StackSize := ArgsSize;
  SetLength(Stack,StackSize);
  SetLength(Int64s,ArgsUsedCount[smvv64]);
  SetLength(RawUTF8s,ArgsUsedCount[smvvRawUTF8]);
  SetLength(Strings,ArgsUsedCount[smvvString]);
  SetLength(WideStrings,ArgsUsedCount[smvvWideString]);
  SetLength(Objects,ArgsUsedCount[smvvObject]);
  SetLength(DynArrays,ArgsUsedCount[smvvDynArray]);
  try
    // 1. read the parameters
    while (Par^<>#0) and (Par^<=' ') do inc(Par);
    if Par^<>'[' then

      Exit;

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

      case ValueType of
      smvSelf:
        continue; // self parameter is never transmitted
      smvObject: begin
        if TypeInfo^.Kind<>tkClass then
          Exit;
        cla := TypeInfo^.ClassType^.ClassType;
................................................................................
        REGEAX: r.EAX := PInteger(Value)^;
        REGEDX: r.EDX := PInteger(Value)^;
        REGECX: r.ECX := PInteger(Value)^;
        else    move(Value^,Stack[OffsetInStack],SizeInStack);
        end;
    end;
    // 3. execute the method
    method := PPointerArray(PPointer(PtrInt(Instance)+entry^.IOffset)^)^[MethodIndex];
    asm
      mov eax,StackSize
      mov edx,dword ptr Stack
      add edx,eax // pascal/register convention = left-to-right
      shr eax,2
      jz @z
  @n: sub edx,4
................................................................................
      if (ValueVar=smvv64) and (ValueDirection=smdResult) then begin
        case ValueType of // ordinal/real result values from CPU/FPU registers
        smvDouble, smvDateTime: Res.Add(LoadDouble);
        smvCurrency:            Res.Add(LoadCurrency);
        smvBoolean:             Res.Add(PByte(@r.EAX2)^);
        smvInteger:             Res.Add(r.EAX2);
        smvInt64:               Res.Add(PInt64(@r.EAX2)^);
        else raise EServiceException.CreateFmt('Invalid result type %d',[ord(ValueType)]);
        end;
      end else
      case ValueType of
      smvObject:     Res.WriteObject(Objects[IndexVar],False,False,true);
      smvDynArray:   Res.AddDynArrayJSON(DynArrays[IndexVar].Wrapper);
      smvBoolean:    Res.Add(PByte(@Int64s[IndexVar])^);
      smvInteger:    Res.Add(PInteger(@Int64s[IndexVar])^);
................................................................................
      smvWideString: Res.AddJSONEscapeW(pointer(WideStrings[IndexVar]));
      end;
      if ValueIsString then
        Res.Add('"',',') else
        Res.Add(',');
    end;
    Res.CancelLastComma;
    Result := true;
  finally // manual release memory for Objects[] and DynArrays[]
    for i := 0 to high(Objects) do
      Objects[i].Free;
    for i := 0 to high(DynArrays) do
      DynArrays[i].Wrapper.Clear;
  end;
end;


{ TServiceContainerClient }

function TServiceContainerClient.Info(aTypeInfo: PTypeInfo): TServiceFactory;
begin
  result := inherited Info(aTypeInfo);
  if (result=nil) and AddInterface(aTypeInfo,sicClientDriven) then
    result := inherited Info(aTypeInfo);
end;

function TServiceContainerClient.AddInterface(
  const aInterfaces: array of PTypeInfo;
  aInstanceCreation: TServiceInstanceImplementation): boolean;
var i: integer;
begin
  result := false;
  if (self=nil) or (high(aInterfaces)<0) then
    exit;
  CheckInterface(aInterfaces);
  for i := 0 to high(aInterfaces) do
    fList.Add(TServiceFactoryClient.Create(Rest,aInterfaces[i],aInstanceCreation));
  result := true;
end;


{ TServiceFactoryClient }

type
  /// map the stack memory layout at TInterfacedObjectFake.FakeCall()
  TFakeCall = packed record
    EDX, ECX, MethodIndex, EBP, Ret2: integer;
    Args: array[word] of byte;
  end;

  /// instances of this class will emulate a given interface
  TInterfacedObjectFake = class(TInterfacedObject)
  protected
    fFactory: TServiceFactoryClient;
    fVTable: PPointerArray;
    function FakeCall(const aCall: TFakeCall): Int64;
    function SelfFromFake: TInterfacedObjectFake;
    function FakeQueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
    function Fake_AddRef: Integer; stdcall;
    function Fake_Release: Integer; stdcall;
  public
    /// create an instance, using the specified interface
    constructor Create(aFactory: TServiceFactoryClient);
    /// release the remote server instance (in sicClientDriven mode);
    destructor Destroy; override;
    /// the associated interface factory
    property Factory: TServiceFactoryClient read fFactory;
  end;

constructor TInterfacedObjectFake.Create(aFactory: TServiceFactoryClient);
begin
  inherited Create;
  fFactory := aFactory;
  fVTable := Pointer(aFactory.fFakeVTable);
end;

destructor TInterfacedObjectFake.Destroy;
begin
  if (fFactory<>nil) and (fFactory.InstanceCreation=sicClientDriven) then
  try
    fFactory.CallClient('free'); // release server instance
  except
    ; // ignore any exception here
  end;
  inherited;
end;

function TInterfacedObjectFake.Fake_AddRef: Integer;
begin
  result := SelfFromFake._AddRef;
end;

function TInterfacedObjectFake.Fake_Release: Integer;
begin
  result := SelfFromFake._Release;
end;

function TInterfacedObjectFake.FakeQueryInterface(const IID: TGUID; out Obj): HResult;
begin
  self := SelfFromFake;
  if (fFactory<>nil) and IsEqualGUID(IID,fFactory.fInterfaceIID) then begin
    pointer(Obj) := @fVTable;
    _AddRef;
    result := NOERROR;
  end else
    result := SelfFromFake.QueryInterface(IID,Obj);
end;

function TInterfacedObjectFake.SelfFromFake: TInterfacedObjectFake;
asm
  sub eax,TInterfacedObjectFake.fVTable
end;

function TInterfacedObjectFake.FakeCall(const aCall: TFakeCall): Int64;
begin
  self := SelfFromFake;
  assert(fFactory.ClassNameIs('TServiceFactoryClient'));
  with aCall do  { TODO: remote RESTful server call using JSON }
  case MethodIndex of
  0: result := EDX+ECX;
  1: result := PInt64(@Args[0])^*PInt64(@Args[8])^;
  else result := 0;
  end;
end;

function TServiceFactoryClient.CallClient(const aMethod, aParams: RawUTF8;
  aResult: PRawUTF8; aClientDrivenID: Pcardinal): boolean;
var sent,resp,head: RawUTF8;
    Values: TPUtf8CharDynArray;
begin
  Result := false;
  if Self=nil then
    exit;
  if fClient=nil then
    fClient := fRest as TSQLRestClientURI;
  sent := '{"method":"'+aMethod+'","params":['+aParams+']}';
  if fClient.URI(fClient.Model.Root+'/'+fInterfaceURI,'POST',@resp,@head,@sent).Lo<>200 then
    exit;
  JSONDecode(resp,['RESULT','ID'],Values,True);
  if (Values[0]=nil) or (Values[1]=nil) then
    Exit;
  if aResult<>nil then
    aResult^ := Values[0];
  if aClientDrivenID<>nil then
    aClientDrivenID^ := GetCardinal(Values[1]);
  result := true;
end;

constructor TServiceFactoryClient.Create(aRest: TSQLRest;
  aInterface: PTypeInfo; aInstanceCreation: TServiceInstanceImplementation);
var i, siz: integer;
    P: PCardinal;
begin
  // extract RTTI from the interface
  if not aRest.InheritsFrom(TSQLRestClientURI) then
    EServiceException.CreateFmt('%s interface needs a Client connection',
      [aInterface^.ShortName]);
  inherited Create(aRest,aInterface,aInstanceCreation);
  // check if this interface is supported on the server
  if not CallClient('ClassName','',@fRemoteClassName) then
    raise EServiceException.CreateFmt('%s interface not supported by server',
      [fInterfaceURI]);
  // create the fake interface
  SetLength(fFakeVTable,fMethodsCount+3);
  fFakeVTable[0] := @TInterfacedObjectFake.FakeQueryInterface;
  fFakeVTable[1] := @TInterfacedObjectFake.Fake_AddRef;
  fFakeVTable[2] := @TInterfacedObjectFake.Fake_Release;
  siz := (((fMethodsCount*24) shr 12)+1) shl 12; // 4 KB granularity
  fFakeStub := VirtualAlloc(nil,siz,MEM_COMMIT,PAGE_EXECUTE_READWRITE);
  P := pointer(fFakeStub);
  for i := 0 to fMethodsCount-1 do begin
    fFakeVTable[i+3] := P;
    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].ArgsSize or $900000;   // ret {StackSize}; nop
    inc(PByte(P),3); 
  end;
  // initialize a shared instance (if needed)
  if fInstanceCreation=sicShared then begin
    fSharedInstance := TInterfacedObjectFake.Create(self);
    TInterfacedObjectFake(fSharedInstance)._AddRef; // force stay alive
  end;
end;

function TServiceFactoryClient.Get(out Obj): Boolean;
var O: TInterfacedObjectFake;
begin
  result := false;
  if Self=nil then
    exit;
  case fInstanceCreation of
  sicShared:
    O := TInterfacedObjectFake(fSharedInstance);
  sicSingle, sicClientDriven:
    O := TInterfacedObjectFake.Create(self);
  else exit;
  end;
  pointer(Obj) := @O.fVTable;
  O._AddRef;
  result := true;
end;

destructor TServiceFactoryClient.Destroy;
begin
  Assert(TInterfacedObjectFake(fSharedInstance).fRefCount=1);
  TInterfacedObjectFake(fSharedInstance)._Release; // bonne nuit les petits
  if fFakeStub<>nil then
    VirtualFree(fFakeStub,0,MEM_RELEASE);
  inherited;
end;


initialization
  pointer(@SQLFieldTypeComp[sftAnsiText]) := @AnsiIComp;
{$ifndef USENORMTOUPPER}
  pointer(@SQLFieldTypeComp[sftUTF8Text]) := @AnsiIComp;
{$endif}
  DefaultHasher := @crc32; // faster and more accurate than kr32()

end.

  if ErrMsg='' then
    for i := 0 to high(aServers) do
    with aServers[i].Model do
    for j := i+1 to high(aServers) do
      if aServers[j].Model.Root=Root then
        ErrMsg:= 'Duplicated Root URI';
  if ErrMsg<>'' then
     raise Exception.Create('TSQLite3HttpServer.Create: '+ErrMsg);
  SetLength(fDBServers,length(aServers));
  for i := 0 to high(aServers) do
  with fDBServers[i] do begin
    Server := aServers[i];
    RestAccessRights := HTTP_DEFAULT_ACCESS_RIGHTS;
  end;
  {$ifndef USETCPPREFIX}
................................................................................
    fHttpServer := THttpApiServer.Create(false);
    for i := 0 to high(aServers) do begin
      j := THttpApiServer(fHttpServer).AddUrl(
        aServers[i].Model.Root,aPort,false,aDomainName);
      if j<>NO_ERROR then begin
        ErrMsg := 'Impossible to register URL';
        if j=ERROR_ACCESS_DENIED then
          ErrMsg := ': administrator rights needed';
        raise Exception.Create('TSQLite3HttpServer.Create: '+ErrMsg);
        break;
      end;
    end;
  except
    on E: Exception do begin
      {$ifdef WITHLOG}
      Log.Log(sllError,'% for %',[E,fHttpServer],self);

  if ErrMsg='' then
    for i := 0 to high(aServers) do
    with aServers[i].Model do
    for j := i+1 to high(aServers) do
      if aServers[j].Model.Root=Root then
        ErrMsg:= 'Duplicated Root URI';
  if ErrMsg<>'' then
     raise EModelException.CreateFmt('%s.Create: %s',[ClassName,ErrMsg]);
  SetLength(fDBServers,length(aServers));
  for i := 0 to high(aServers) do
  with fDBServers[i] do begin
    Server := aServers[i];
    RestAccessRights := HTTP_DEFAULT_ACCESS_RIGHTS;
  end;
  {$ifndef USETCPPREFIX}
................................................................................
    fHttpServer := THttpApiServer.Create(false);
    for i := 0 to high(aServers) do begin
      j := THttpApiServer(fHttpServer).AddUrl(
        aServers[i].Model.Root,aPort,false,aDomainName);
      if j<>NO_ERROR then begin
        ErrMsg := 'Impossible to register URL';
        if j=ERROR_ACCESS_DENIED then
          ErrMsg := ErrMsg+' (administrator rights needed)';
        raise ECommunicationException.CreateFmt('%s.Create: %s',[ClassName,ErrMsg]);
        break;
      end;
    end;
  except
    on E: Exception do begin
      {$ifdef WITHLOG}
      Log.Log(sllError,'% for %',[E,fHttpServer],self);

constructor TSQLRestServerStaticBigTable.Create(aClass: TSQLRecordClass;
  aServer: TSQLRestServer; const aFileName: TFileName;
  aBinaryFile: boolean);
begin
  inherited Create(aClass,aServer,aFileName,aBinaryFile);
  if fStoredClassProps.Kind in INSERT_WITH_ID then
    raise Exception.CreateFmt('%s: %s virtual table can''t be static',
      [fStoredClassProps.SQLTableName,aClass.ClassName]);
  if aBinaryFile then
    fBig := TSynBigTableMetaData.Create(aFileName,fStoredClassProps.SQLTableName) else
    fBig := TSynBigTableRecord.Create(aFileName,fStoredClassProps.SQLTableName);
end;

function TSQLRestServerStaticBigTable.CreateSQLMultiIndex(

constructor TSQLRestServerStaticBigTable.Create(aClass: TSQLRecordClass;
  aServer: TSQLRestServer; const aFileName: TFileName;
  aBinaryFile: boolean);
begin
  inherited Create(aClass,aServer,aFileName,aBinaryFile);
  if fStoredClassProps.Kind in INSERT_WITH_ID then
    raise EModelException.CreateFmt('%s: %s virtual table can''t be static',
      [fStoredClassProps.SQLTableName,aClass.ClassName]);
  if aBinaryFile then
    fBig := TSynBigTableMetaData.Create(aFileName,fStoredClassProps.SQLTableName) else
    fBig := TSynBigTableRecord.Create(aFileName,fStoredClassProps.SQLTableName);
end;

function TSQLRestServerStaticBigTable.CreateSQLMultiIndex(

  Version 1.15 - July 12, 2011
  - Initial Release, handling OleDB, Oracle/OCI, and SQLite3 databases

  Version 1.16
  - SynDbExplorer now executes selected text statement (very convenient)
  - will try to reconnect to the server in case of error triggerred
  - added advanced Query Builder (right click on selected tables in left list)
  - now accepts a SQLite3 database file as command line parameter
  - fix error ORA-00932 at OCI client level
  - added UTF-8 BOM to CSV or TXT exports
  - now direct-to-file fast export feature (into CSV, TXT, SQLite3,
    Synopse BigTable records or two JSON flavors)
  - SQLite3 3.7.10 including (beta) private encryption methods

  Version 1.15 - July 12, 2011
  - Initial Release, handling OleDB, Oracle/OCI, and SQLite3 databases

  Version 1.16
  - SynDbExplorer now executes selected text statement (very convenient)
  - will try to reconnect to the server in case of error triggerred
  - added advanced Query Builder
  - now accepts a SQLite3 database file as command line parameter
  - fix error ORA-00932 at OCI client level
  - added UTF-8 BOM to CSV or TXT exports
  - now direct-to-file fast export feature (into CSV, TXT, SQLite3,
    Synopse BigTable records or two JSON flavors)
  - SQLite3 3.7.10 including (beta) private encryption methods

    (inserting '?' as inlined :(...): parameters, with proper string quote) -
    with associated regression tests

  Version 1.16
  - introducing new TSynAnsiConvert and TSynAnsiFixedWidth classes, able to
    process Unicode to/from Ansi conversion in all possible code pages, with
    generic access methods and optimized handling of fixed width encodings

  - TSynLog allows read sharing of the .log created file
  - TSynLog now stores the executable build time, and library name (if any)
  - TSynLog and TSynMapFile now handle libraries (.dll/.ocx/.bpl) .map/.mab
    debugging information (only .exe was previously handled) 
  - TSynCache now handle an integer ResultTag: PtrInt value parameter (used e.g.
    to store the row counts of a SQL result cache)
  - TMemoryMapText class (and therefore TSynLogFile) is now able to map/open
................................................................................
  SysUtils;


const
  {{ the corresponding version of the freeware Synopse framework }
  SYNOPSE_FRAMEWORK_VERSION = '1.16'{$ifdef LVCL}+' LVCL'{$endif};











{ ************ common types used for compatibility between compilers and CPU }

{$ifndef FPC} { make cross-compiler and cross-CPU types available to Delphi }
type

  /// a CPU-dependent unsigned integer type cast of a pointer / register
................................................................................
    move(U256,fAnsiToWide[0],256*2);
    SetLength(fWideToAnsi,65536);
    fillchar(fWideToAnsi[1],65535,ord('?')); // '?' for unknown char
    for i := 1 to 255 do
      if fAnsiToWide[i]<>0 then
        fWideToAnsi[fAnsiToWide[i]] := i;
  end else
    raise Exception.CreateFmt('%s.Create - Invalid code page %d',[ClassName,fCodePage]);

end;

function TSynAnsiFixedWidth.IsValidAnsi(WideText: PWideChar; Length: integer): boolean;
var i: integer;
    wc: cardinal;
begin
  result := false;
................................................................................
    exit; // avoid GPF if void
  if Stream.InheritsFrom(TCustomMemoryStream) then begin
    Posi := MemStream.Seek(0,soFromCurrent);
    PosiEnd := Posi+SaveToLength;
    if PosiEnd>MemStream.Size then
      MemStream.Size := PosiEnd;
    if SaveTo(PAnsiChar(MemStream.Memory)+Posi)-MemStream.Memory<>PosiEnd then
      Exception.Create('TDynArray.SaveToStream');
    MemStream.Seek(PosiEnd,soFromBeginning);
  end else begin
    tmp := SaveTo;
    Stream.Write(pointer(tmp)^,length(tmp));
  end;
end;

................................................................................
function TDynArray.SaveTo: RawByteString;
var Len: integer;
begin
  Len := SaveToLength;
  SetString(result,nil,Len);
  if Len<>0 then
    if SaveTo(pointer(result))-pointer(result)<>Len then
      raise Exception.Create('TDynArray.SaveTo');
end;

function JSONArrayCount(P: PUTF8Char): integer;
var n: integer;
begin
  result := -1;
  n := 0;
................................................................................

procedure TDynArray.Init(aTypeInfo: pointer; var aValue; aCountPointer: PInteger=nil);
var Typ: PDynArrayTypeInfo absolute aTypeInfo;
begin
  TypeInfo := aTypeInfo;
  Value := @aValue;
  if Typ^.Kind<>tkDynArray then
    raise Exception.CreateFmt('%s is not a dynamic array',[Typ^.Name]);
  inc(PtrUInt(Typ),ord(Typ^.Name[0]));
  with Typ^ do begin
    ElemSize := elSize;
    if elType=nil then
      ElemType := nil else
      ElemType := elType^;
  end;
................................................................................
      if looped then
        Break else begin
        result := 0;
        n := first;
        looped := true;
      end;
  until false;
  raise Exception.Create('HashFind'); // we should never reach here
end;

function TDynArrayHashed.GetHashFromIndex(aIndex: Integer): Cardinal;
begin
  if cardinal(aIndex)>=cardinal(Count) then
    result := 0 else
    // it's faster to rehash than to loop in fHashs[].Index values
................................................................................

function TTextWriter.Text: RawUTF8;
begin
  Flush;
  if fStream.InheritsFrom(TRawByteStringStream) then
    if fInitialStreamPosition=0 then
      result := TRawByteStringStream(fStream).DataString else
      raise Exception.CreateFmt(
        'TTextWriter.Text with fInitialStreamPosition=%d',[fInitialStreamPosition]) else
  if fStream.InheritsFrom(TMemoryStream) then
    SetString(result,PAnsiChar(TMemoryStream(fStream).Memory)+fInitialStreamPosition,
      TMemoryStream(fStream).Seek(0,soFromCurrent)-fInitialStreamPosition) else
    result := '';
end;

................................................................................
    if aCustomSize>Available then
      fBufSize := Int64Rec(Available).Lo;
      fBufSize := aCustomSize;
  end;
  with Int64Rec(fFileSize) do
    fMap := CreateFileMapping(fFile,nil,PAGE_READONLY,Hi,Lo,nil);
  if fMap=0 then
    raise Exception.Create('MemoryMap.Map');
  with Int64Rec(aCustomOffset) do
    fBuf := MapViewOfFile(fMap,FILE_MAP_READ,Hi,Lo,fBufSize);
  if fBuf=nil then begin
    // Windows failed to find a contiguous VA space -> fall back on direct read
    CloseHandle(fMap);
    fMap := 0;
  end else
................................................................................
  fFileStream := TFileStream.Create(aFileName,fmOpenRead or fmShareDenyNone);
  Create(fFileStream.Handle);
end;

constructor TSynMemoryStreamMapped.Create(aFile: THandle; aCustomSize: cardinal; aCustomOffset: Int64);
begin
  if not fMap.Map(aFile) then
    raise Exception.Create('TSynMemoryStreamMapped mapping error');
  inherited Create(fMap.fBuf,fMap.fBufSize);
end;

destructor TSynMemoryStreamMapped.Destroy;
begin
  fMap.UnMap;
  fFileStream.Free;
................................................................................
        end;
        PInteger(PBeg)^ := PAnsiChar(P)-PBeg-4; // format: Isize+varUInt32s
      end;
      wkSorted: begin
        PBeg := PAnsiChar(P)+4; // leave space for chunk size
        P := PByte(CleverStoreInteger(pointer(PI),PBeg,PEnd,ValuesCount,n));
        if P=nil then
          raise Exception.Create('TFileBufferWriter.WriteVarUInt32Array: data not sorted');
        PInteger(PBeg-4)^ := PAnsiChar(P)-PBeg; // format: Isize+cleverStorage
      end;
      end;
      inc(PtrUInt(PI),n*4);
      fPos := PtrUInt(P)-PtrUInt(fBuf);
      inc(fTotalWritten,PtrUInt(fPos-pos));
      dec(ValuesCount,n);
................................................................................
procedure TFileBufferReader.Close;
begin
  fMap.UnMap;
end;

procedure TFileBufferReader.ErrorInvalidContent;
begin
  raise Exception.Create('TFileBufferReader: invalid content');
end;

procedure TFileBufferReader.OpenFrom(aBuffer: pointer; aBufferSize: cardinal);
begin
  fCurrentPos := 0;
  fMap.Map(aBuffer,aBufferSize);
end;
................................................................................
  if (self<>nil) and ((RecordBuffer=nil) or (RecordBufferLen=0)) then begin
    // no data yet -> use default
    RecordBuffer := pointer(fDefaultRecordData);
    RecordBufferLen := fDefaultRecordLength;
  end;
  if RecordBuffer=pointer(result) then
    // update content code below will fail -> please correct calling code
    raise Exception.Create('In-place call of TSynTable.UpdateFieldData');
  if (self=nil) or (cardinal(FieldIndex)>=cardinal(fField.Count)) then begin
    SetString(result,PAnsiChar(RecordBuffer),RecordBufferLen);
    exit;
  end;
  F := TSynTableFieldProperties(fField.List[FieldIndex]);
  NewSize := length(NewFieldData);
  if NewSize=0 then begin
................................................................................
  move(NewData^,PByteArray(result)[DestOffset],NewSize);
  move(Dest[OldSize],PByteArray(result)[DestOffset+NewSize],RecordBufferLen-DestOffset);
end;

constructor TSynTable.Create(const aTableName: RawUTF8);
begin
  if not FieldNameValid(pointer(aTableName)) then
    raise Exception.CreateFmt('Invalid TSynTable.Create(%s)',[aTableName]);
  fTableName := aTableName;
  fField := TObjectList.Create;
  fFieldVariableIndex := -1;
end;

procedure TSynTable.LoadFrom(var RD: TFileBufferReader);
var n, i: integer;
................................................................................
      aSize := Getlength(Data);
      WR.Write(Data,aSize);
      Inc(PtrUInt(Data),aSize);
    end else
      // add default field content for a newly added field
      WR.Write(Pointer(fDefaultFieldData),fDefaultFieldLength);
    if WR.fTotalWritten>1 shl 30 then
      raise Exception.Create('File size too big (>1GB)') else
      Offsets64[Count] := WR.fTotalWritten;
    IDs[Count] := ID;
    NewIndexs[Index] := Count;
    inc(Count);
  end;
end;

................................................................................
      // both indexes equal -1 -> force sort
      OrderedIndexSort(0,OrderedIndexCount-1);
      OrderedIndexNotSorted := false;
    end else begin
      // added record
      if tfoUnique in Options then begin
        if fOrderedIndexFindAdd<0 then
          raise Exception.CreateFmt(
            '%s.CheckConstraint call needed before %s.OrderedIndexUpdate',[ClassName,Name]);
        OrderedIndexReverseSet(InsertInteger(OrderedIndex,OrderedIndexCount,
          aNewIndex,fOrderedIndexFindAdd));
      end else begin
        AddInteger(OrderedIndex,OrderedIndexCount,aNewIndex);
        OrderedIndexReverseSet(OrderedIndexCount-1);
        OrderedIndexNotSorted := true; // -> OrderedIndexSort() call on purpose
................................................................................
{$ifndef DELPHI5OROLDER}

{ TSynTableData }

procedure TSynTableData.CheckVTableInitialized;
begin
  if VTable=nil then
    raise Exception.Create('TSynTableData non initialized');
end;

{$ifdef USESYNTABLEVARIANT}

function TSynTableData.GetFieldValue(const FieldName: RawUTF8): Variant;
var aField: TSynTableFieldProperties;
begin
  if IsRowID(Pointer(FieldName)) then
    result := VID else begin
    CheckVTableInitialized;
    aField := VTable.FieldFromName[FieldName];
    if aField=nil then
      raise Exception.CreateFmt('Unknown %s property',[FieldName]) else
    result := GetFieldValue(aField);
  end;
end;

function TSynTableData.GetFieldValue(aField: TSynTableFieldProperties): Variant;
begin
  CheckVTableInitialized;
................................................................................
var F: TSynTableFieldProperties;
begin
  CheckVTableInitialized;
  if IsRowID(Pointer(FieldName)) then
    VID := Value else begin
    F := VTable.FieldFromName[FieldName];
    if F=nil then
      raise Exception.CreateFmt('Unknown %s property',[FieldName]) else
      SetFieldValue(F,Value);
  end;
end;

procedure TSynTableData.SetFieldValue(aField: TSynTableFieldProperties; const Value: Variant);
begin
  SetFieldSBFValue(aField,aField.SBF(Value));
................................................................................
  Result := VTable.Validate(Pointer(VValue),RecordIndex);
end;

{$endif DELPHI5OROLDER}

{ TSynMapFile }

var
  ExeMapFile: TSynMapFile = nil;

const
  MAGIC_MAB = $A5A5A5A5;

type
  TSynLZHead = packed record
    Magic: cardinal;
    CompressedSize: integer;
................................................................................
    S^.Stop := Addr-1;
    inc(PtrUInt(S),A.ElemSize);
    S^.Start := Addr;
  end;
  S^.Stop := Addr+FromVarUInt32(P);
  R.fCurrentPos := PtrUInt(P)-PtrUInt(R.fMap.fBuf);
end;






constructor TSynMapFile.Create(const aExeName: TFileName=''; MabCreate: boolean=true);

  procedure LoadMap;
    var P, PEnd: PUTF8Char;
    procedure NextLine;
    begin
................................................................................
var SymCount, UnitCount, i: integer;
    MabFile: TFileName;
    MapAge, MabAge: TDateTime;
begin
  fSymbols.Init(TypeInfo(TSynMapSymbolDynArray),fSymbol,@SymCount);
  fUnits.Init(TypeInfo(TSynMapUnitDynArray),fUnit,nil,nil,nil,@UnitCount);
  // 1. search for an external .map file matching the running .exe/.dll name
  if aExeName='' then
    fMapFile := GetModuleName(hInstance) else


    fMapFile := aExeName;
  fMapFile := ChangeFileExt(fMapFile,'.map');
  MabFile := ChangeFileExt(fMapFile,'.mab');
  MapAge := FileAgeToDateTime(fMapFile);
  MabAge := FileAgeToDateTime(MabFile);
  if (MabAge<=MapAge) and (MapAge>0) then
    LoadMap; // if no faster-to-load .mab available and accurate
................................................................................
  S := A.Value^;
  Diff := S^.Start;
  W.WriteVarUInt32(Diff);
  if W.fPos+n*5>W.fBufLen then
    W.fTotalWritten := W.Flush;
  with W do
    if fPos+n*5>fBufLen then // BufLen=1 shl 19=512 KB should be enough
      raise Exception.CreateFmt('too big %s',[PDynArrayTypeInfo(A.TypeInfo).Name]) else
      P := @PByteArray(fBuf)^[fPos];
  Beg := PtrUInt(P);
  for i := 1 to n-1 do begin
    inc(PtrUInt(S),A.ElemSize);
    P := ToVarUInt32(S^.Start-Diff,P);
    Diff := S^.Start;
  end;
................................................................................
        until L>R;
        exit;
      end;
  until L>R;
  result := -1;
end;

const

  /// Delphi linker starts the code section at this fixed offset
  CodeSection = $1000;

class procedure TSynMapFile.Log(W: TTextWriter; Addr: PtrUInt);
var u, s, Line: integer;
begin
  if (W=nil) or (Addr=0) or (ExeMapFile=nil) then
    exit;
  with ExeMapFile do
  if HasDebugInfo then begin
    dec(Addr,fGetModuleHandle);
    s := FindSymbol(Addr);
    u := FindUnit(Addr,Line);
    if s<0 then begin
      if u<0 then
        exit;
................................................................................
  end;
end;

procedure TSynLog.LogFileHeader;
begin
  QueryPerformanceFrequency(fFrequencyTimeStamp);
  ExeVersionRetrieve;
  if ExeMapFile=nil then begin
    ExeMapFile := TSynMapFile.Create;
    GarbageCollector.Add(ExeMapFile);
    ExeMapFile.fGetModuleHandle := GetModuleHandle(nil)+CodeSection;
  end;
  // array of const is buggy under Delphi 5 :( -> use fWriter.Add*()
  with ExeVersion, SystemInfo, OSVersionInfo, fWriter do begin
    AddString(ProgramFullSpec);
    AddShort(#13'Host='); AddString(Host);
    AddShort(' User=');   AddString(User);
    AddShort(' CPU='); Add(dwNumberOfProcessors); Add('*');
................................................................................
    Add(wProcessorRevision);
    AddShort(' OS='); Add(ord(OSVersion)); Add('.'); Add(wServicePackMajor);
    Add('='); Add(dwMajorVersion); Add('.'); Add(dwMinorVersion); Add('.');
    Add(dwBuildNumber);
    AddShort(' Wow64='); Add(integer(IsWow64));
    AddShort(' Freq='); Add(fFrequencyTimeStamp);
    if IsLibrary then begin
      AddShort(' Instance='); AddString(InstanceFileName);
    end;
    Add(#13);
    AddClassName(self.ClassType); AddShort(' '+SYNOPSE_FRAMEWORK_VERSION+' ');
    AddDateTime(Now); Add(#13,#13);
  end;
  QueryPerformanceCounter(fStartTimeStamp);
  fHeaderWritten := true;

    (inserting '?' as inlined :(...): parameters, with proper string quote) -
    with associated regression tests

  Version 1.16
  - introducing new TSynAnsiConvert and TSynAnsiFixedWidth classes, able to
    process Unicode to/from Ansi conversion in all possible code pages, with
    generic access methods and optimized handling of fixed width encodings
  - added dedicated Exception classes (ESynException, ETableDataException)
  - TSynLog allows read sharing of the .log created file
  - TSynLog now stores the executable build time, and library name (if any)
  - TSynLog and TSynMapFile now handle libraries (.dll/.ocx/.bpl) .map/.mab
    debugging information (only .exe was previously handled) 
  - TSynCache now handle an integer ResultTag: PtrInt value parameter (used e.g.
    to store the row counts of a SQL result cache)
  - TMemoryMapText class (and therefore TSynLogFile) is now able to map/open
................................................................................
  SysUtils;


const
  {{ the corresponding version of the freeware Synopse framework }
  SYNOPSE_FRAMEWORK_VERSION = '1.16'{$ifdef LVCL}+' LVCL'{$endif};

{ ************ some custom Exception classes }

type
  /// generic parent class of all custom Exception types of this unit
  ESynException = class(Exception);

  /// exception raised by all TSynTable related code
  ETableDataException = class(Exception);
  

{ ************ common types used for compatibility between compilers and CPU }

{$ifndef FPC} { make cross-compiler and cross-CPU types available to Delphi }
type

  /// a CPU-dependent unsigned integer type cast of a pointer / register
................................................................................
    move(U256,fAnsiToWide[0],256*2);
    SetLength(fWideToAnsi,65536);
    fillchar(fWideToAnsi[1],65535,ord('?')); // '?' for unknown char
    for i := 1 to 255 do
      if fAnsiToWide[i]<>0 then
        fWideToAnsi[fAnsiToWide[i]] := i;
  end else
    raise ESynException.CreateFmt('%s.Create - Invalid code page %d',
      [ClassName,fCodePage]);
end;

function TSynAnsiFixedWidth.IsValidAnsi(WideText: PWideChar; Length: integer): boolean;
var i: integer;
    wc: cardinal;
begin
  result := false;
................................................................................
    exit; // avoid GPF if void
  if Stream.InheritsFrom(TCustomMemoryStream) then begin
    Posi := MemStream.Seek(0,soFromCurrent);
    PosiEnd := Posi+SaveToLength;
    if PosiEnd>MemStream.Size then
      MemStream.Size := PosiEnd;
    if SaveTo(PAnsiChar(MemStream.Memory)+Posi)-MemStream.Memory<>PosiEnd then
      EStreamError.Create('TDynArray.SaveToStream');
    MemStream.Seek(PosiEnd,soFromBeginning);
  end else begin
    tmp := SaveTo;
    Stream.Write(pointer(tmp)^,length(tmp));
  end;
end;

................................................................................
function TDynArray.SaveTo: RawByteString;
var Len: integer;
begin
  Len := SaveToLength;
  SetString(result,nil,Len);
  if Len<>0 then
    if SaveTo(pointer(result))-pointer(result)<>Len then
      raise ESynException.Create('TDynArray.SaveTo');
end;

function JSONArrayCount(P: PUTF8Char): integer;
var n: integer;
begin
  result := -1;
  n := 0;
................................................................................

procedure TDynArray.Init(aTypeInfo: pointer; var aValue; aCountPointer: PInteger=nil);
var Typ: PDynArrayTypeInfo absolute aTypeInfo;
begin
  TypeInfo := aTypeInfo;
  Value := @aValue;
  if Typ^.Kind<>tkDynArray then
    raise ESynException.CreateFmt('%s is not a dynamic array',[Typ^.Name]);
  inc(PtrUInt(Typ),ord(Typ^.Name[0]));
  with Typ^ do begin
    ElemSize := elSize;
    if elType=nil then
      ElemType := nil else
      ElemType := elType^;
  end;
................................................................................
      if looped then
        Break else begin
        result := 0;
        n := first;
        looped := true;
      end;
  until false;
  raise ESynException.Create('HashFind'); // we should never reach here
end;

function TDynArrayHashed.GetHashFromIndex(aIndex: Integer): Cardinal;
begin
  if cardinal(aIndex)>=cardinal(Count) then
    result := 0 else
    // it's faster to rehash than to loop in fHashs[].Index values
................................................................................

function TTextWriter.Text: RawUTF8;
begin
  Flush;
  if fStream.InheritsFrom(TRawByteStringStream) then
    if fInitialStreamPosition=0 then
      result := TRawByteStringStream(fStream).DataString else
      raise ESynException.CreateFmt(
        'TTextWriter.Text with fInitialStreamPosition=%d',[fInitialStreamPosition]) else
  if fStream.InheritsFrom(TMemoryStream) then
    SetString(result,PAnsiChar(TMemoryStream(fStream).Memory)+fInitialStreamPosition,
      TMemoryStream(fStream).Seek(0,soFromCurrent)-fInitialStreamPosition) else
    result := '';
end;

................................................................................
    if aCustomSize>Available then
      fBufSize := Int64Rec(Available).Lo;
      fBufSize := aCustomSize;
  end;
  with Int64Rec(fFileSize) do
    fMap := CreateFileMapping(fFile,nil,PAGE_READONLY,Hi,Lo,nil);
  if fMap=0 then
    raise ESynException.Create('MemoryMap.Map');
  with Int64Rec(aCustomOffset) do
    fBuf := MapViewOfFile(fMap,FILE_MAP_READ,Hi,Lo,fBufSize);
  if fBuf=nil then begin
    // Windows failed to find a contiguous VA space -> fall back on direct read
    CloseHandle(fMap);
    fMap := 0;
  end else
................................................................................
  fFileStream := TFileStream.Create(aFileName,fmOpenRead or fmShareDenyNone);
  Create(fFileStream.Handle);
end;

constructor TSynMemoryStreamMapped.Create(aFile: THandle; aCustomSize: cardinal; aCustomOffset: Int64);
begin
  if not fMap.Map(aFile) then
    raise ESynException.CreateFmt('%s mapping error',[ClassName]);
  inherited Create(fMap.fBuf,fMap.fBufSize);
end;

destructor TSynMemoryStreamMapped.Destroy;
begin
  fMap.UnMap;
  fFileStream.Free;
................................................................................
        end;
        PInteger(PBeg)^ := PAnsiChar(P)-PBeg-4; // format: Isize+varUInt32s
      end;
      wkSorted: begin
        PBeg := PAnsiChar(P)+4; // leave space for chunk size
        P := PByte(CleverStoreInteger(pointer(PI),PBeg,PEnd,ValuesCount,n));
        if P=nil then
          raise ESynException.Create('WriteVarUInt32Array: data not sorted');
        PInteger(PBeg-4)^ := PAnsiChar(P)-PBeg; // format: Isize+cleverStorage
      end;
      end;
      inc(PtrUInt(PI),n*4);
      fPos := PtrUInt(P)-PtrUInt(fBuf);
      inc(fTotalWritten,PtrUInt(fPos-pos));
      dec(ValuesCount,n);
................................................................................
procedure TFileBufferReader.Close;
begin
  fMap.UnMap;
end;

procedure TFileBufferReader.ErrorInvalidContent;
begin
  raise ESynException.Create('TFileBufferReader: invalid content');
end;

procedure TFileBufferReader.OpenFrom(aBuffer: pointer; aBufferSize: cardinal);
begin
  fCurrentPos := 0;
  fMap.Map(aBuffer,aBufferSize);
end;
................................................................................
  if (self<>nil) and ((RecordBuffer=nil) or (RecordBufferLen=0)) then begin
    // no data yet -> use default
    RecordBuffer := pointer(fDefaultRecordData);
    RecordBufferLen := fDefaultRecordLength;
  end;
  if RecordBuffer=pointer(result) then
    // update content code below will fail -> please correct calling code
    raise ETableDataException.Create('In-place call of TSynTable.UpdateFieldData');
  if (self=nil) or (cardinal(FieldIndex)>=cardinal(fField.Count)) then begin
    SetString(result,PAnsiChar(RecordBuffer),RecordBufferLen);
    exit;
  end;
  F := TSynTableFieldProperties(fField.List[FieldIndex]);
  NewSize := length(NewFieldData);
  if NewSize=0 then begin
................................................................................
  move(NewData^,PByteArray(result)[DestOffset],NewSize);
  move(Dest[OldSize],PByteArray(result)[DestOffset+NewSize],RecordBufferLen-DestOffset);
end;

constructor TSynTable.Create(const aTableName: RawUTF8);
begin
  if not FieldNameValid(pointer(aTableName)) then
    raise ETableDataException.CreateFmt('Invalid TSynTable.Create(%s)',[aTableName]);
  fTableName := aTableName;
  fField := TObjectList.Create;
  fFieldVariableIndex := -1;
end;

procedure TSynTable.LoadFrom(var RD: TFileBufferReader);
var n, i: integer;
................................................................................
      aSize := Getlength(Data);
      WR.Write(Data,aSize);
      Inc(PtrUInt(Data),aSize);
    end else
      // add default field content for a newly added field
      WR.Write(Pointer(fDefaultFieldData),fDefaultFieldLength);
    if WR.fTotalWritten>1 shl 30 then
      raise ETableDataException.Create('File size too big (>1GB)') else
      Offsets64[Count] := WR.fTotalWritten;
    IDs[Count] := ID;
    NewIndexs[Index] := Count;
    inc(Count);
  end;
end;

................................................................................
      // both indexes equal -1 -> force sort
      OrderedIndexSort(0,OrderedIndexCount-1);
      OrderedIndexNotSorted := false;
    end else begin
      // added record
      if tfoUnique in Options then begin
        if fOrderedIndexFindAdd<0 then
          raise ETableDataException.CreateFmt(
            '%s.CheckConstraint call needed before %s.OrderedIndexUpdate',[ClassName,Name]);
        OrderedIndexReverseSet(InsertInteger(OrderedIndex,OrderedIndexCount,
          aNewIndex,fOrderedIndexFindAdd));
      end else begin
        AddInteger(OrderedIndex,OrderedIndexCount,aNewIndex);
        OrderedIndexReverseSet(OrderedIndexCount-1);
        OrderedIndexNotSorted := true; // -> OrderedIndexSort() call on purpose
................................................................................
{$ifndef DELPHI5OROLDER}

{ TSynTableData }

procedure TSynTableData.CheckVTableInitialized;
begin
  if VTable=nil then
    raise ETableDataException.Create('TSynTableData non initialized');
end;

{$ifdef USESYNTABLEVARIANT}

function TSynTableData.GetFieldValue(const FieldName: RawUTF8): Variant;
var aField: TSynTableFieldProperties;
begin
  if IsRowID(Pointer(FieldName)) then
    result := VID else begin
    CheckVTableInitialized;
    aField := VTable.FieldFromName[FieldName];
    if aField=nil then
      raise ETableDataException.CreateFmt('Unknown %s property',[FieldName]) else
    result := GetFieldValue(aField);
  end;
end;

function TSynTableData.GetFieldValue(aField: TSynTableFieldProperties): Variant;
begin
  CheckVTableInitialized;
................................................................................
var F: TSynTableFieldProperties;
begin
  CheckVTableInitialized;
  if IsRowID(Pointer(FieldName)) then
    VID := Value else begin
    F := VTable.FieldFromName[FieldName];
    if F=nil then
      raise ETableDataException.CreateFmt('Unknown %s property',[FieldName]) else
      SetFieldValue(F,Value);
  end;
end;

procedure TSynTableData.SetFieldValue(aField: TSynTableFieldProperties; const Value: Variant);
begin
  SetFieldSBFValue(aField,aField.SBF(Value));
................................................................................
  Result := VTable.Validate(Pointer(VValue),RecordIndex);
end;

{$endif DELPHI5OROLDER}

{ TSynMapFile }




const
  MAGIC_MAB = $A5A5A5A5;

type
  TSynLZHead = packed record
    Magic: cardinal;
    CompressedSize: integer;
................................................................................
    S^.Stop := Addr-1;
    inc(PtrUInt(S),A.ElemSize);
    S^.Start := Addr;
  end;
  S^.Stop := Addr+FromVarUInt32(P);
  R.fCurrentPos := PtrUInt(P)-PtrUInt(R.fMap.fBuf);
end;

const
  /// Delphi linker starts the code section at this fixed offset
  CODE_SECTION = $1000;


constructor TSynMapFile.Create(const aExeName: TFileName=''; MabCreate: boolean=true);

  procedure LoadMap;
    var P, PEnd: PUTF8Char;
    procedure NextLine;
    begin
................................................................................
var SymCount, UnitCount, i: integer;
    MabFile: TFileName;
    MapAge, MabAge: TDateTime;
begin
  fSymbols.Init(TypeInfo(TSynMapSymbolDynArray),fSymbol,@SymCount);
  fUnits.Init(TypeInfo(TSynMapUnitDynArray),fUnit,nil,nil,nil,@UnitCount);
  // 1. search for an external .map file matching the running .exe/.dll name
  if aExeName='' then begin
    fMapFile := GetModuleName(hInstance);
    fGetModuleHandle := GetModuleHandle(pointer(ExtractFileName(fMapFile)))+CODE_SECTION;
  end else
    fMapFile := aExeName;
  fMapFile := ChangeFileExt(fMapFile,'.map');
  MabFile := ChangeFileExt(fMapFile,'.mab');
  MapAge := FileAgeToDateTime(fMapFile);
  MabAge := FileAgeToDateTime(MabFile);
  if (MabAge<=MapAge) and (MapAge>0) then
    LoadMap; // if no faster-to-load .mab available and accurate
................................................................................
  S := A.Value^;
  Diff := S^.Start;
  W.WriteVarUInt32(Diff);
  if W.fPos+n*5>W.fBufLen then
    W.fTotalWritten := W.Flush;
  with W do
    if fPos+n*5>fBufLen then // BufLen=1 shl 19=512 KB should be enough
      raise ESynException.CreateFmt('too big %s',[PDynArrayTypeInfo(A.TypeInfo).Name]) else
      P := @PByteArray(fBuf)^[fPos];
  Beg := PtrUInt(P);
  for i := 1 to n-1 do begin
    inc(PtrUInt(S),A.ElemSize);
    P := ToVarUInt32(S^.Start-Diff,P);
    Diff := S^.Start;
  end;
................................................................................
        until L>R;
        exit;
      end;
  until L>R;
  result := -1;
end;


var
  InstanceMapFile: TSynMapFile;

  
class procedure TSynMapFile.Log(W: TTextWriter; Addr: PtrUInt);
var u, s, Line: integer;
begin
  if (W=nil) or (Addr=0) or (InstanceMapFile=nil) then
    exit;
  with InstanceMapFile do
  if HasDebugInfo then begin
    dec(Addr,fGetModuleHandle);
    s := FindSymbol(Addr);
    u := FindUnit(Addr,Line);
    if s<0 then begin
      if u<0 then
        exit;
................................................................................
  end;
end;

procedure TSynLog.LogFileHeader;
begin
  QueryPerformanceFrequency(fFrequencyTimeStamp);
  ExeVersionRetrieve;
  if InstanceMapFile=nil then begin
    InstanceMapFile := TSynMapFile.Create;
    GarbageCollector.Add(InstanceMapFile);

  end;
  // array of const is buggy under Delphi 5 :( -> use fWriter.Add*()
  with ExeVersion, SystemInfo, OSVersionInfo, fWriter do begin
    AddString(ProgramFullSpec);
    AddShort(#13'Host='); AddString(Host);
    AddShort(' User=');   AddString(User);
    AddShort(' CPU='); Add(dwNumberOfProcessors); Add('*');
................................................................................
    Add(wProcessorRevision);
    AddShort(' OS='); Add(ord(OSVersion)); Add('.'); Add(wServicePackMajor);
    Add('='); Add(dwMajorVersion); Add('.'); Add(dwMinorVersion); Add('.');
    Add(dwBuildNumber);
    AddShort(' Wow64='); Add(integer(IsWow64));
    AddShort(' Freq='); Add(fFrequencyTimeStamp);
    if IsLibrary then begin
      AddShort(' Instance='); AddJSONEscapeString(InstanceFileName);
    end;
    Add(#13);
    AddClassName(self.ClassType); AddShort(' '+SYNOPSE_FRAMEWORK_VERSION+' ');
    AddDateTime(Now); Add(#13,#13);
  end;
  QueryPerformanceCounter(fStartTimeStamp);
  fHeaderWritten := true;

/// SynLZ Compression routines
// - licensed under a MPL/GPL/LGPL tri-license; version 1.15
unit SynLZ;

{
    This file is part of Synopse SynLZ Compression.

    Synopse SynLZ Compression. Copyright (C) 2012 Arnaud Bouchez
      Synopse Informatique - http://synopse.info
................................................................................

  Conclusion:
   SynLZ compresses better than LZ4,
   SynLZ is faster to compress than LZ4,
   but SynLZ is slower to decompress than LZ4,
   and SynLZ is still very competitive for our Client-Server mORMot purpose ;)

   
  Revision history

  Version 1.6
  - first release, associated with the main Synopse SQLite3 framework

  Version 1.13
  - code modifications to compile with Delphi 5 compiler
................................................................................
  - comment refactoring (mostly for inclusion in SynProject documentation)
  - new CompressSynLZ function, for THttpSocket.RegisterCompress - this
    function will return 'synlzo' as "ACCEPT-ENCODING:" HTTP header parameter

  Version 1.15
  - force ignore asm version of the code if PUREPASCAL conditional is defined




}

interface

{$I Synopse.inc}

/// get maximum possible (worse) compressed size for out_p
................................................................................
  assert(result=dst-dst_beg);
end;

function Hash32(P: PIntegerArray; L: integer): cardinal;
// faster than Adler32, even asm version, because read DWORD aligned data
var s1,s2: cardinal;
    i: integer;
const Mask: array[0..3] of cardinal = (0,$ff,$ffff,$ffffff);
begin
  if P<>nil then begin
    s1 := 0;
    s2 := 0;
    for i := 1 to L shr 4 do begin // 16 bytes (4 DWORD) by loop - aligned read
      inc(s1,P^[0]);
      inc(s2,s1);
................................................................................
      inc(PtrUInt(P),16);
    end;
    for i := 1 to (L shr 2)and 3 do begin // 4 bytes (DWORD) by loop
      inc(s1,P^[0]);
      inc(s2,s1);
      inc(PtrUInt(P),4);
    end;
    inc(s1,P^[0] and Mask[L and 3]);      // remaining 0..3 bytes




    inc(s2,s1);
    result := s1 xor (s2 shl 16);
  end else
    result := 0;
end;

function CompressSynLZ(var Data: AnsiString; Compress: boolean): AnsiString;

/// SynLZ Compression routines
// - licensed under a MPL/GPL/LGPL tri-license; version 1.16
unit SynLZ;

{
    This file is part of Synopse SynLZ Compression.

    Synopse SynLZ Compression. Copyright (C) 2012 Arnaud Bouchez
      Synopse Informatique - http://synopse.info
................................................................................

  Conclusion:
   SynLZ compresses better than LZ4,
   SynLZ is faster to compress than LZ4,
   but SynLZ is slower to decompress than LZ4,
   and SynLZ is still very competitive for our Client-Server mORMot purpose ;)


  Revision history

  Version 1.6
  - first release, associated with the main Synopse SQLite3 framework

  Version 1.13
  - code modifications to compile with Delphi 5 compiler
................................................................................
  - comment refactoring (mostly for inclusion in SynProject documentation)
  - new CompressSynLZ function, for THttpSocket.RegisterCompress - this
    function will return 'synlzo' as "ACCEPT-ENCODING:" HTTP header parameter

  Version 1.15
  - force ignore asm version of the code if PUREPASCAL conditional is defined

  Version 1.16
  - fixed potential GPF issue in Hash32() function

}

interface

{$I Synopse.inc}

/// get maximum possible (worse) compressed size for out_p
................................................................................
  assert(result=dst-dst_beg);
end;

function Hash32(P: PIntegerArray; L: integer): cardinal;
// faster than Adler32, even asm version, because read DWORD aligned data
var s1,s2: cardinal;
    i: integer;

begin
  if P<>nil then begin
    s1 := 0;
    s2 := 0;
    for i := 1 to L shr 4 do begin // 16 bytes (4 DWORD) by loop - aligned read
      inc(s1,P^[0]);
      inc(s2,s1);
................................................................................
      inc(PtrUInt(P),16);
    end;
    for i := 1 to (L shr 2)and 3 do begin // 4 bytes (DWORD) by loop
      inc(s1,P^[0]);
      inc(s2,s1);
      inc(PtrUInt(P),4);
    end;
    case L and 3 of // remaining 0..3 bytes
    1: inc(s1,PByte(P)^);
    2: inc(s1,PWord(P)^);
    3: inc(s1,PWord(P)^ or (PByteArray(P)^[2] shl 16));
    end;
    inc(s2,s1);
    result := s1 xor (s2 shl 16);
  end else
    result := 0;
end;

function CompressSynLZ(var Data: AnsiString; Compress: boolean): AnsiString;

    for an optional integer pointer, to return the count of row data
  - added an optional behavior parameter to TSQLDataBase.TransactionBegin method
  - reintroduce TSQLDataBaseSQLFunction.Create() constructor, and added some
    TSQLDataBase.RegisterSQLFunction() overloaded methods
  - fixed issue in TSQLRequest.Reset() which was triggered an error about the
    latest statement execution
  - fixed rounding issue when exporting DOUBLE columns into JSON
  - fixed issue of unraised exception in TSQLRequest.PrepareNext 

  - engine is now compiled including tracing within the FTS3 extension - added
    sqlite3_trace() function prototype to register your own tracing callback

    Todo:
    - port to systems other than Delphi+Win32 (use external DLL?)
}

................................................................................
{$endif}

{$define INCLUDE_FTS3}
{ define this if you want to include the FTS3/FTS4 feature into the library
  - FTS3 is an SQLite module implementing full-text search
  - will include also FTS4 extension module since 3.7.4
  - see http://www.sqlite.org/fts3.html for documentation
  - not defined by default, to save about 50 KB of code size
  - should be defined for both SynSQLite3 and SQLite3 units }

{$ifdef INCLUDE_FTS3}
  {$define INCLUDE_TRACE} 
  { define this is you want to include the TRACE feature into the library
   - our C source code custom header will define SQLITE_OMIT_TRACE if FTS3/FST4
   is not defined }
................................................................................
const
  /// SQL statement to get all tables names in the current database file
  // (taken from official SQLite3 documentation)
  SQL_GET_TABLE_NAMES =
    'SELECT name FROM sqlite_master WHERE type=''table'' AND name NOT LIKE ''sqlite_%'';';

type
  /// custom SQLite3 Exception type
  ESQLException = class(Exception)
  public
    /// the DB which raised this exception
    DB: TSQLite3DB;
    /// the corresponding error code
    ErrorCode: integer;
    /// create the exception, getting the message from DB
    constructor Create(aDB: TSQLite3DB; aErrorCode: integer); reintroduce; overload;
    /// create the exception, getting the message from caller
    constructor Create(const aMessage: string; aErrorCode: integer); reintroduce; overload;
  end;

{{ test the result state of a sqlite3_*() function
  - raise a ESQLException if the result state is an error
  - return the result state otherwize (SQLITE_OK,SQLITE_ROW,SQLITE_DONE e.g.) }
function sqlite3_check(DB: TSQLite3DB; aResult: integer): integer;

{{ Returns a pointer to a block of memory at least N bytes in length
 - should call native malloc() function, i.e. GetMem() in this unit }
function sqlite3_malloc(n: Integer): Pointer;
  {$ifndef USEFASTCALL}cdecl;{$endif} external;
................................................................................
    function GetParamCount: integer;

  // 1. general request process
  public
    {{ Prepare a UTF-8 encoded SQL statement
     - compile the SQL into byte-code
     - parameters ? ?NNN :VV @VV $VV can be bound with Bind*() functions below
     - raise an ESQLException on any error }
    function Prepare(DB: TSQLite3DB; const SQL: RawUTF8): integer;
    {{ Prepare a WinAnsi SQL statement
     - behave the same as Prepare() }
    function PrepareAnsi(DB: TSQLite3DB; const SQL: WinAnsiString): integer;
    {{ Prepare the next SQL command initialized in previous Prepare()
     - raise an ESQLException on any error }
    function PrepareNext: integer;
    {{ Evaluate An SQL Statement, returning the sqlite3_step() result status:
     - return SQLITE_ROW on success, with data ready to be retrieved via the
      Field*() methods
     - return SQLITE_DONE if the SQL commands were executed
     - raise an ESQLException on any error }
    function Step: integer;
    {{ Reset A Prepared Statement Object
     - reset a prepared statement object back to its initial state,
      ready to be re-executed.
     - any SQL statement variables that had values bound to them using the Bind*()
      function below retain their values. Use BindReset() to reset the bindings
     - return SQLITE_OK on success, or the previous Step error code }
    function Reset: integer;
    {{ Execute all SQL statements already prepared by a call to Prepare()
     - the statement is closed
     - raise an ESQLException on any error }
    procedure ExecuteAll; overload;
    {{ Execute all SQL statements in the aSQL UTF-8 encoded string
     - internaly call Prepare() then Step then PrepareNext until end of aSQL
     - Close is always called internaly
     - raise an ESQLException on any error }
    procedure ExecuteAll(aDB: TSQLite3DB; const aSQL: RawUTF8); overload;
    {{ Execute one SQL statement already prepared by a call to Prepare()
     - the statement is closed
     - raise an ESQLException on any error }
    procedure Execute; overload;
    {{ Execute one SQL statement in the aSQL UTF-8 encoded string
     - Execute the first statement in aSQL: call Prepare() then Step once
     - Close is always called internaly
     - raise an ESQLException on any error }
    procedure Execute(aDB: TSQLite3DB; const aSQL: RawUTF8); overload;
    {{ Execute a SQL statement which return integers from the aSQL UTF-8 encoded string
     - Execute the first statement in aSQL
     - this statement must get (at least) one field/column result of INTEGER
     - return result as a dynamic array of Int64 in ID
     - return count of row in integer function result (may be < length(ID))
     - raise an ESQLException on any error }
    function Execute(aDB: TSQLite3DB; const aSQL: RawUTF8; var ID: TInt64DynArray): integer; overload;
    {{ Execute a SQL statement which return one integer from the aSQL UTF-8 encoded string
     - Execute the first statement in aSQL
     - this statement must get (at least) one field/column result of INTEGER
     - return result as an unique Int64 in ID
     - raise an ESQLException on any error }
    procedure Execute(aDB: TSQLite3DB; const aSQL: RawUTF8; out ID: Int64); overload;
    {{ Execute a SQL statement which return one TEXT value from the aSQL UTF-8 encoded string
     - Execute the first statement in aSQL
     - this statement must get (at least) one field/column result of TEXT
     - raise an ESQLException on any error }
    procedure Execute(aDB: TSQLite3DB; const aSQL: RawUTF8; out Value: RawUTF8); overload;
    {{ Execute a SQL statement which return TEXT from the aSQL UTF-8 encoded string
     - Execute the first statement in aSQL
     - this statement must get (at least) one field/column result of TEXT
     - return result as a dynamic array of RawUTF8 in ID
     - return count of row in integer function result (may be < length(ID))
     - raise an ESQLException on any error }
    function Execute(aDB: TSQLite3DB; const aSQL: RawUTF8; var Values: TRawUTF8DynArray): integer; overload;
    /// Execute one SQL statement which return the results in JSON format
    // - JSON format is more compact than XML and well supported
    // - Execute the first statement in aSQL
    // - if SQL is '', the statement should have been prepared, reset and bound if necessary
    // - raise an ESQLException on any error
    // - JSON data is added to TStream, with UTF-8 encoding
    // - if Expand is true, JSON data is an array of objects, for direct use
    // with any Ajax or .NET client:
    // & [ {"col1":val11,"col2":"val12"},{"col1":val21,... ]
    // - if Expand is false, JSON data is serialized (used in TSQLTableJSON)
    // & { "FieldCount":1,"Values":["col1","col2",val11,"val12",val21,..] }
    // - BLOB field value is saved as Base64, in the '"\uFFF0base64encodedbinary"'
................................................................................
    function Execute(aDB: TSQLite3DB; const aSQL: RawUTF8; JSON: TStream;
      Expand: boolean=false): PtrInt; overload;
    /// Execute one SQL statement which return the results in JSON format
    // - use internaly Execute() above with a TRawByteStringStream, and return a string
    // - BLOB field value is saved as Base64, e.g. '"\uFFF0base64encodedbinary"'
    // - returns the number of data rows added to JSON (excluding the headers)
    // in the integer variable mapped by aResultCount (if any)
    // - if any error occurs, the ESQLException is handled and '' is returned
    function ExecuteJSON(aDB: TSQLite3DB; const aSQL: RawUTF8; Expand: boolean=false;
      aResultCount: PPtrInt=nil): RawUTF8;
    {{ Execute all SQL statements in the aSQL UTF-8 encoded string, results will
      be written as ANSI text in OutFile }
    procedure ExecuteDebug(aDB: TSQLite3DB; const aSQL: RawUTF8; const OutFile: Text);
    {{ close the Request handle
     - call it even if an ESQLException has been raised }
    procedure Close;

    {{ read-only access to the Request (SQLite3 statement) handle }
    property Request: TSQLite3Statement read fRequest;
    {{ read-only access to the SQLite3 database handle }
    property RequestDB: TSQLite3DB read fDB;
    {{ returns true if the current prepared statement makes no direct changes
................................................................................
  public
    {{ Reset All Bindings On A Prepared Statement
     - Contrary to the intuition of many, Reset() does not reset the bindings
      on a prepared statement. Use this routine to reset all host parameter }
    procedure BindReset;
    {{ bind a NULL value to a parameter
     - the leftmost SQL parameter has an index of 1, but ?NNN may override it
     - raise an ESQLException on any error }
    procedure BindNull(Param: Integer); 
    {{ bind an integer value to a parameter
     - the leftmost SQL parameter has an index of 1, but ?NNN may override it
     - raise an ESQLException on any error }
    procedure Bind(Param: Integer; Value: Int64); overload;
    {{ bind a double value to a parameter
     - the leftmost SQL parameter has an index of 1, but ?NNN may override it
     - raise an ESQLException on any error }
    procedure Bind(Param: Integer; Value: double); overload;
    {{ bind a UTF-8 encoded string to a parameter
     - the leftmost SQL parameter has an index of 1, but ?NNN may override it
     - raise an ESQLException on any error }
    procedure Bind(Param: Integer; const Value: RawUTF8); overload;
    {{ bind a Blob buffer to a parameter
     - the leftmost SQL parameter has an index of 1, but ?NNN may override it
     - raise an ESQLException on any error }
    procedure Bind(Param: Integer; Data: pointer; Size: integer); overload;
    {{ bind a Blob TCustomMemoryStream buffer to a parameter
     - the leftmost SQL parameter has an index of 1, but ?NNN may override it
     - raise an ESQLException on any error }
    procedure Bind(Param: Integer; Data: TCustomMemoryStream); overload;
    {{ bind a ZeroBlob buffer to a parameter
     - uses a fixed amount of memory (just an integer to hold its size) while
      it is being processed. Zeroblobs are intended to serve as placeholders
      for BLOBs whose content is later written using incremental BLOB I/O routines
      (as with TSQLBlobStream created from TSQLDataBase.Blob() e.g.).
     - a negative value for the Size parameter results in a zero-length BLOB
     - the leftmost SQL parameter has an index of 1, but ?NNN may override it
     - raise an ESQLException on any error }
    procedure BindZero(Param: Integer; Size: integer);

  // 3. Field attributes after a sucessfull Step() (returned SQLITE_ROW)
  public
    {{ the field name of the current ROW  }
    function FieldName(Col: integer): RawUTF8;
    {{ the field index matching this name
................................................................................
  // - called for every row of a Statement
  // - the implementation may update the database directly by using a
  // local or shared TSQLRequest
  // - the TSQLRequest may be shared and prepared before the call for even
  // faster access than with a local TSQLRequest 
  // - no TSQLDataBase or higher levels objects can be used inside this method,
  // since all locking and try..finally protection is outside it
  // - can optionnaly trigger a ESQLException on any error
  TOnSQLStoredProc = procedure(Statement: TSQLRequest) of object;

  {{ TSQLDataBase.TransactionBegin can be deferred, immediate, or exclusive
   - tbDeferred means that no locks are acquired on the database until the
   database is first accessed. Thus with a deferred transaction, the BEGIN
   statement itself does nothing to the filesystem. Locks are not acquired
   until the first read or write operation. The first read operation against
................................................................................
     - SYSTEMNOCASE collation is added (our custom fast UTF-8 case insensitive compare,
       which is used also in the SQLite3UI unit for coherency and efficiency)
     - ISO8601 collation is added (TDateTime stored as ISO-8601 encoded TEXT)
     - WIN32CASE and WIN32NOCASE collations are added (use slow but accurate Win32 CompareW)
     - some additional SQl functions are registered: MOD, SOUNDEX/SOUNDEXFR/SOUNDEXES,
       RANK, CONCAT
     - initialize a TRTLCriticalSection to ensure that all access to the database is atomic
     - raise an ESQLException on any error }
    constructor Create(const aFileName: TFileName; const aPassword: RawUTF8='');
    {{ close a database and free its memory and context
      - if TransactionBegin was called but not commited, a RollBack is performed }
    destructor Destroy; override;
    {{ Execute all SQL statements in aSQL UTF-8 encoded string
     - can be prepared with TransactionBegin()
     - raise an ESQLException on any error }
    procedure ExecuteAll(const aSQL: RawUTF8);
    {{ Execute one SQL statements in aSQL UTF-8 encoded string
     - can be prepared with TransactionBegin()
     - raise an ESQLException on any error }
    procedure Execute(const aSQL: RawUTF8); overload;
    {{ Execute one SQL statement which return integers from the aSQL UTF-8 encoded string
     - Execute the first statement in aSQL
     - this statement must get a one field/column result of INTEGER
     - return result as a dynamic array of RawUTF8, as TEXT result
     - return count of row in integer function result (may be < length(ID))
     - raise an ESQLException on any error }
    function Execute(const aSQL: RawUTF8; var ID: TInt64DynArray): integer; overload;
    {{ Execute one SQL statement returning TEXT from the aSQL UTF-8 encoded string
     - Execute the first statement in aSQL
     - this statement must get (at least) one field/column result of TEXT
     - return result as a dynamic array of RawUTF8 in ID
     - return count of row in integer function result (may be < length(ID))
     - raise an ESQLException on any error }
    function Execute(const aSQL: RawUTF8; var Values: TRawUTF8DynArray): integer; overload;
    {{ Execute one SQL statement which return one integer from the aSQL UTF-8 encoded string
     - Execute the first statement in aSQL
     - this statement must get a one field/column result of INTEGER
     - return result as a dynamic array of RawUTF8, as TEXT result
     - raise an ESQLException on any error }
    procedure Execute(const aSQL: RawUTF8; out ID: Int64); overload;
    {{ Execute one SQL statement which return one UTF-8 encoded string value
     - Execute the first statement in aSQL
     - this statement must get a one field/column result of INTEGER
     - return result as a dynamic array of RawUTF8, as TEXT result
     - raise an ESQLException on any error }
    procedure Execute(const aSQL: RawUTF8; out ID: RawUTF8); overload;
    /// Execute one SQL statement returning its results in JSON format
    // - the BLOB data is encoded as '"\uFFF0base64encodedbinary"'
    function ExecuteJSON(const aSQL: RawUTF8; Expand: boolean=false; aResultCount: PPtrInt=nil): RawUTF8;
    {{ begin a transaction
     - Execute SQL statements with Execute() procedure below
     - must be ended with Commit on success
     - must be aborted with Rollback after an ESQLException raised
    - The default transaction behavior is tbDeferred }
    procedure TransactionBegin(aBehavior: TSQLDataBaseTransactionBehaviour = tbDeferred);
    {{ end a transaction: write all Execute() statements to the disk }
    procedure Commit;
    {{ abort a transaction: restore the previous state of the database }
    procedure RollBack;
    {{ return the last Insert Rowid }
................................................................................

    {{ open a BLOB incrementally for read[/write] access
     - find a BLOB located in row RowID, column ColumnName, table TableName
      in database DBName; in other words, the same BLOB that would be selected by:
      ! SELECT ColumnName FROM DBName.TableName WHERE rowid = RowID;
     - use after a TSQLRequest.BindZero() to reserve Blob memory
     - if RowID=-1, then the last inserted RowID is used
     - will raise an ESQLException on any error }
    function Blob(const DBName, TableName, ColumnName: RawUTF8;
      RowID: Int64=-1; ReadWrite: boolean=false): TSQLBlobStream;
    {{ backup of the opened Database into an external file name
     - don't use the experimental SQLite Online Backup API
     - database is closed, VACCUUMed, copied, then reopened: it's very fast  }
    function Backup(const BackupFileName: TFileName): boolean;

................................................................................
var
  /// in order to allow file encryption on disk, initialize this pointer
  // with SQLEncryptTableSize bytes of XOR tables
  // - you can use fixed or custom (SHA+AES) generated table
  // - using a fixed XOR table is very fast and provides strong enough encryption
  // - the first page (first 1024 bytes) is not encrypted, since its content
  // (mostly zero) can be used to easily guess the beginning of the key
  // - if the key is not correct, a ESQLException will be raised with
  // 'database disk image is malformed' (ErrorCode=SQLITE_CORRUPT)
  // - this table is common to ALL files accessed by the database engine: you
  // have maintain several XOR mask arrays, and set SQLEncryptTable before any
  // sqlite3*() call, to mix passowords or crypted and uncrypted databases
  // (see ChangeSQLEncryptTablePassWord() for multiple SQLEncryptTable use)
  // - please note that this encryption is compatible only with SQlite3 files
  // using the default page size of 1024
................................................................................
  if (aPassword<>'') and (aFileName<>':memory:') and (aFileName<>'') then begin
    SetLength(fCypherBlock,SQLEncryptTableSize);
    CreateSQLEncryptTableBytes(aPassword,pointer(fCypherBlock));
  end;
  fSQLFunctions := TObjectList.Create;
  result := DBOpen;
  if result<>SQLITE_OK then
    raise ESQLException.Create(fDB,result);
end;

destructor TSQLDataBase.Destroy;
{$ifndef INCLUDE_FTS3}
var S: TSQLite3Statement;
{$endif}
begin
................................................................................
    n: integer;
begin
  if self=nil then
    exit; // avoid GPF in case of call from a static-only server
  Lock('');
  try
    try
      R.Prepare(fDB,FormatUTF8('PRAGMA table_info(%);',[TableName])); // ESQLException
      SetLength(Names,64);
      n := 0;
      repeat
        if R.Step<>SQLITE_ROW then break;
        Names[n] := sqlite3_column_text(R.Request,1); // cid,name,type,notnull,dflt_value,pk
        inc(n);
      until n=64;
................................................................................
  fRequest := 0;
  fFieldCount := 0;
end;

procedure TSQLRequest.ExecuteAll;
begin
  if RequestDB=0 then
    raise ESQLException.Create(0,SQLITE_CANTOPEN);
  try
    repeat
      repeat
      until Step<>SQLITE_ROW; // all steps of this statement
    until PrepareNext=SQLITE_DONE; // all statements
  finally
    Close; // always release statement
  end;
end;

procedure TSQLRequest.Execute;
begin
  if RequestDB=0 then
    raise ESQLException.Create(0,SQLITE_CANTOPEN);
  try
    repeat
    until Step<>SQLITE_ROW; // Execute all steps of the first statement
  finally
    Close; // always release statement
  end;
end;

procedure TSQLRequest.ExecuteAll(aDB: TSQLite3DB; const aSQL: RawUTF8);
begin
  try
    Prepare(aDB,aSQL); // will raise an ESQLException on error
    ExecuteAll;
  finally
    Close; // always release statement, even if done normaly in EngineExecuteAll
  end;
end;

procedure TSQLRequest.Execute(aDB: TSQLite3DB; const aSQL: RawUTF8);
begin
  try
    Prepare(aDB,aSQL); // will raise an ESQLException on error
    Execute;
  finally
    Close; // always release statement, even if done normaly in Execute
  end;
end;

function TSQLRequest.Execute(aDB: TSQLite3DB; const aSQL: RawUTF8; var ID: TInt64DynArray): integer;
var LID, Res: integer;
begin
  result := 0;
  LID := length(ID);
  try
    Prepare(aDB,aSQL); // will raise an ESQLException on error
    if FieldCount>0 then
    repeat
      res := Step;
      if res=SQLITE_ROW then begin
        if result>=LID then begin
          inc(LID,256);
          SetLength(ID,LID);
................................................................................
  end;
end;

procedure TSQLRequest.Execute(aDB: TSQLite3DB; const aSQL: RawUTF8; out ID: Int64);
begin
  ID := 0;
  try
    Prepare(aDB,aSQL); // will raise an ESQLException on error
    if FieldCount>0 then
    if Step=SQLITE_ROW then
      ID := sqlite3_column_int64(Request,0); // get first column value
  finally
    Close; // always release statement
  end;
end;

procedure TSQLRequest.Execute(aDB: TSQLite3DB; const aSQL: RawUTF8; out Value: RawUTF8);
begin
  Value := '';
  try
    Prepare(aDB,aSQL); // will raise an ESQLException on error
    if FieldCount>0 then
    if Step=SQLITE_ROW then
      Value := sqlite3_column_text(Request,0); // get first column value
  finally
    Close; // always release statement
  end;
end;
................................................................................

function TSQLRequest.Execute(aDB: TSQLite3DB; const aSQL: RawUTF8; var Values: TRawUTF8DynArray): integer;
var LValues, Res: integer;
begin
  result := 0;
  LValues := length(Values);
  try
    Prepare(aDB,aSQL); // will raise an ESQLException on error
    if FieldCount>0 then
    repeat
      res := Step;
      if res=SQLITE_ROW then begin
        if result>=LValues then begin
          if LValues<256 then
            inc(LValues,16) else
................................................................................
    W: TJSONWriter;
begin
  result := 0;
  W := TJSONWriter.Create(JSON,Expand,false);
  try
    // prepare the SQL request
    if aSQL<>'' then // if not already prepared, reset and bound by caller
      Prepare(aDB,aSQL); // will raise an ESQLException on error
    if FieldCount<=0 then begin
      W.CancelAllVoid;
      exit;
    end;
    // get col names and types
    SetLength(W.ColNames,FieldCount);
    for i := 0 to FieldCount-1 do
................................................................................

procedure TSQLRequest.ExecuteDebug(aDB: TSQLite3DB; const aSQL: RawUTF8; const OutFile: Text);
var Res, i, n: integer;
begin
  {$I-}
  writeln;
  try
    Prepare(aDB,aSQL); // will raise an ESQLException on error
    repeat
      repeat
        Res := Step;
        if Res=SQLITE_ROW then begin
          n := FieldCount-1;
          for i := 0 to n do begin
            write(OutFile,FieldA(i));
................................................................................
  try
    try
      RowCount := Execute(aDB,aSQL,Stream,Expand); // create JSON data in Stream
      if aResultCount<>nil then
        aResultCount^ := RowCount;
      result := Stream.DataString;
    except
      on ESQLException do
        result := '';
    end;
    // Close has been called in Execute() above since aSQL<>''
  finally
    Stream.Free;
  end;
end;
................................................................................

function TSQLRequest.FieldA(Col: integer): WinAnsiString;
var P: PUTF8Char;
    L,L2: integer;
begin
  result := '';
  if cardinal(Col)>=cardinal(FieldCount) then
    raise ESQLException.Create(RequestDB, SQLITE_RANGE);
  P := sqlite3_column_text(Request,Col);
  L := SynCommons.StrLen(P); // faster than sqlite3_column_bytes(Request,Col)
  if L>0 then begin
    SetLength(result,L);
    L2 := UTF8ToWinPChar(pointer(result),P,L);
    if L2<>L then
      SetLength(result,L2);
................................................................................
  end;
end;

function TSQLRequest.FieldBlob(Col: integer): RawByteString;
var P: PAnsiChar;
begin
  if cardinal(Col)>=cardinal(FieldCount) then
    raise ESQLException.Create(RequestDB, SQLITE_RANGE);
  P := sqlite3_column_blob(Request,Col);
  SetString(result,P,sqlite3_column_bytes(Request,Col));
end;

function TSQLRequest.FieldBlobToStream(Col: integer): TStream;
begin
  result := TRawByteStringStream.Create(FieldBlob(Col));
end;

function TSQLRequest.FieldDouble(Col: integer): double;
begin
  if cardinal(Col)>=cardinal(FieldCount) then
    raise ESQLException.Create(RequestDB, SQLITE_RANGE);
  result := sqlite3_column_double(Request,Col);
end;

function TSQLRequest.FieldInt(Col: integer): Int64;
begin // internaly, SQLite always uses Int64 -> pure Integer function is useless
  if cardinal(Col)>=cardinal(FieldCount) then
    raise ESQLException.Create(RequestDB, SQLITE_RANGE);
  result := sqlite3_column_int64(Request,Col);
end;

function TSQLRequest.FieldName(Col: integer): RawUTF8;
var P: PUTF8Char;
begin
  if cardinal(Col)>=cardinal(FieldCount) then
    raise ESQLException.Create(RequestDB, SQLITE_RANGE);
  P := sqlite3_column_name(Request,Col);
  SetString(result,P,SynCommons.StrLen(P));
end;

function TSQLRequest.FieldIndex(const aColumnName: RawUTF8): integer;
begin
  if Request=0 then
    raise ESQLException.Create(RequestDB,SQLITE_MISUSE);
  for result := 0 to FieldCount-1 do
    if StrIComp(pointer(aColumnName),sqlite3_column_name(Request,result))=0 then
      exit;
  result := -1; // not found
end;

function TSQLRequest.FieldNull(Col: Integer): Boolean;
begin
  if cardinal(Col)>=cardinal(FieldCount) then
    raise ESQLException.Create(RequestDB, SQLITE_RANGE);
  result := sqlite3_column_type(Request,Col)=SQLITE_NULL;
end;

function TSQLRequest.FieldType(Col: Integer): integer;
begin
  if cardinal(Col)>=cardinal(FieldCount) then
    raise ESQLException.Create(RequestDB, SQLITE_RANGE);
  result := sqlite3_column_type(Request,Col);
end;

function TSQLRequest.FieldUTF8(Col: integer): RawUTF8;
var P: PUTF8Char;
begin
  if cardinal(Col)>=cardinal(FieldCount) then
    raise ESQLException.Create(RequestDB, SQLITE_RANGE);
  P := pointer(sqlite3_column_text(Request,Col));
  SetString(result,P,SynCommons.StrLen(P));
end;

function TSQLRequest.FieldValue(Col: integer): TSQLite3Value;
begin
  if cardinal(Col)>=cardinal(FieldCount) then
    raise ESQLException.Create(RequestDB, SQLITE_RANGE);
  result := sqlite3_column_value(Request,Col);
end;

function TSQLRequest.FieldW(Col: integer): RawUnicode;
begin
  if cardinal(Col)>=cardinal(FieldCount) then
    raise ESQLException.Create(RequestDB, SQLITE_RANGE);
  result := Utf8DecodeToRawUnicode(sqlite3_column_text(Request,Col),0);
end;

function TSQLRequest.Prepare(DB: TSQLite3DB; const SQL: RawUTF8): integer;
begin
  fDB := DB;
  fRequest := 0;
  if DB=0 then
    raise ESQLException.Create(DB,SQLITE_CANTOPEN);
  result := sqlite3_prepare_v2(RequestDB, pointer(SQL), length(SQL)+1, fRequest, fNextSQL);
  while (result=SQLITE_OK) and (Request=0) do // comment or white-space
    result := sqlite3_prepare_v2(RequestDB, fNextSQL, -1, fRequest, fNextSQL);
  fFieldCount := sqlite3_column_count(fRequest);
  sqlite3_check(RequestDB,result);
end;

................................................................................
      result := SQLITE_DONE; // nothing more to add
  end;
end;

function TSQLRequest.Reset: integer;
begin
  if Request=0 then
    raise ESQLException.Create(RequestDB,SQLITE_MISUSE);
  result := sqlite3_reset(Request); // no check here since it was PREVIOUS state
end;

function TSQLRequest.Step: integer;
begin
  if Request=0 then
    raise ESQLException.Create(RequestDB,SQLITE_MISUSE);
  result := sqlite3_check(RequestDB,sqlite3_step(Request));
end;

function TSQLRequest.GetReadOnly: Boolean;
begin
  if Request=0 then
    raise ESQLException.Create(RequestDB,SQLITE_MISUSE);
  result := sqlite3_stmt_readonly(Request);
end;

procedure TSQLRequest.FieldsToJSON(WR: TJSONWriter);
var i: integer;
begin
  if Request=0 then
    raise ESQLException.Create(RequestDB,SQLITE_MISUSE);
  if WR.Expand then
    WR.Add('{');
  for i := 0 to FieldCount-1 do begin
    if WR.Expand then
      WR.AddString(WR.ColNames[i]); // '"'+ColNames[]+'":'
    case sqlite3_column_type(Request,i) of // fast evaluation: type may vary
      SQLITE_BLOB: 
................................................................................
begin
  if Request=0 then
    result := 0 else
    result := sqlite3_bind_parameter_count(Request);
end;


{ ESQLException }

constructor ESQLException.Create(aDB: TSQLite3DB; aErrorCode: integer);
begin
  if aDB=0 then
    CreateFmt(sErrorSQLite3NoDB,[aErrorCode]) else
    Create(string(sqlite3_errmsg(aDB)),aErrorCode);
  DB := aDB;
end;

constructor ESQLException.Create(const aMessage: string; aErrorCode: integer);
begin
  ErrorCode := aErrorCode;
  Create(aMessage);
end;

function sqlite3_check(DB: TSQLite3DB; aResult: integer): integer;
begin
  if (DB=0) or (aResult in [SQLITE_ERROR..SQLITE_ROW-1]) then // possible error codes
    raise ESQLException.Create(DB,aResult);
  result := aResult;
end;


{ TSQLBlobStream }

constructor TSQLBlobStream.Create(aDB: TSQLite3DB; const DBName, TableName,

    for an optional integer pointer, to return the count of row data
  - added an optional behavior parameter to TSQLDataBase.TransactionBegin method
  - reintroduce TSQLDataBaseSQLFunction.Create() constructor, and added some
    TSQLDataBase.RegisterSQLFunction() overloaded methods
  - fixed issue in TSQLRequest.Reset() which was triggered an error about the
    latest statement execution
  - fixed rounding issue when exporting DOUBLE columns into JSON
  - fixed issue of unraised exception in TSQLRequest.PrepareNext
  - renamed ESQLException into ESQLite3Exception
  - engine is now compiled including tracing within the FTS3 extension - added
    sqlite3_trace() function prototype to register your own tracing callback

    Todo:
    - port to systems other than Delphi+Win32 (use external DLL?)
}

................................................................................
{$endif}

{$define INCLUDE_FTS3}
{ define this if you want to include the FTS3/FTS4 feature into the library
  - FTS3 is an SQLite module implementing full-text search
  - will include also FTS4 extension module since 3.7.4
  - see http://www.sqlite.org/fts3.html for documentation
  - is defined by default, but can be unset to save about 50 KB of code size
  - should be defined for both SynSQLite3 and SQLite3 units }

{$ifdef INCLUDE_FTS3}
  {$define INCLUDE_TRACE} 
  { define this is you want to include the TRACE feature into the library
   - our C source code custom header will define SQLITE_OMIT_TRACE if FTS3/FST4
   is not defined }
................................................................................
const
  /// SQL statement to get all tables names in the current database file
  // (taken from official SQLite3 documentation)
  SQL_GET_TABLE_NAMES =
    'SELECT name FROM sqlite_master WHERE type=''table'' AND name NOT LIKE ''sqlite_%'';';

type
  /// custom SQLite3 dedicated Exception type
  ESQLite3Exception = class(ESynException)
  public
    /// the DB which raised this exception
    DB: TSQLite3DB;
    /// the corresponding error code
    ErrorCode: integer;
    /// create the exception, getting the message from DB
    constructor Create(aDB: TSQLite3DB; aErrorCode: integer); reintroduce; overload;
    /// create the exception, getting the message from caller
    constructor Create(const aMessage: string; aErrorCode: integer); reintroduce; overload;
  end;

{{ test the result state of a sqlite3_*() function
  - raise a ESQLite3Exception if the result state is an error
  - return the result state otherwize (SQLITE_OK,SQLITE_ROW,SQLITE_DONE e.g.) }
function sqlite3_check(DB: TSQLite3DB; aResult: integer): integer;

{{ Returns a pointer to a block of memory at least N bytes in length
 - should call native malloc() function, i.e. GetMem() in this unit }
function sqlite3_malloc(n: Integer): Pointer;
  {$ifndef USEFASTCALL}cdecl;{$endif} external;
................................................................................
    function GetParamCount: integer;

  // 1. general request process
  public
    {{ Prepare a UTF-8 encoded SQL statement
     - compile the SQL into byte-code
     - parameters ? ?NNN :VV @VV $VV can be bound with Bind*() functions below
     - raise an ESQLite3Exception on any error }
    function Prepare(DB: TSQLite3DB; const SQL: RawUTF8): integer;
    {{ Prepare a WinAnsi SQL statement
     - behave the same as Prepare() }
    function PrepareAnsi(DB: TSQLite3DB; const SQL: WinAnsiString): integer;
    {{ Prepare the next SQL command initialized in previous Prepare()
     - raise an ESQLite3Exception on any error }
    function PrepareNext: integer;
    {{ Evaluate An SQL Statement, returning the sqlite3_step() result status:
     - return SQLITE_ROW on success, with data ready to be retrieved via the
      Field*() methods
     - return SQLITE_DONE if the SQL commands were executed
     - raise an ESQLite3Exception on any error }
    function Step: integer;
    {{ Reset A Prepared Statement Object
     - reset a prepared statement object back to its initial state,
      ready to be re-executed.
     - any SQL statement variables that had values bound to them using the Bind*()
      function below retain their values. Use BindReset() to reset the bindings
     - return SQLITE_OK on success, or the previous Step error code }
    function Reset: integer;
    {{ Execute all SQL statements already prepared by a call to Prepare()
     - the statement is closed
     - raise an ESQLite3Exception on any error }
    procedure ExecuteAll; overload;
    {{ Execute all SQL statements in the aSQL UTF-8 encoded string
     - internaly call Prepare() then Step then PrepareNext until end of aSQL
     - Close is always called internaly
     - raise an ESQLite3Exception on any error }
    procedure ExecuteAll(aDB: TSQLite3DB; const aSQL: RawUTF8); overload;
    {{ Execute one SQL statement already prepared by a call to Prepare()
     - the statement is closed
     - raise an ESQLite3Exception on any error }
    procedure Execute; overload;
    {{ Execute one SQL statement in the aSQL UTF-8 encoded string
     - Execute the first statement in aSQL: call Prepare() then Step once
     - Close is always called internaly
     - raise an ESQLite3Exception on any error }
    procedure Execute(aDB: TSQLite3DB; const aSQL: RawUTF8); overload;
    {{ Execute a SQL statement which return integers from the aSQL UTF-8 encoded string
     - Execute the first statement in aSQL
     - this statement must get (at least) one field/column result of INTEGER
     - return result as a dynamic array of Int64 in ID
     - return count of row in integer function result (may be < length(ID))
     - raise an ESQLite3Exception on any error }
    function Execute(aDB: TSQLite3DB; const aSQL: RawUTF8; var ID: TInt64DynArray): integer; overload;
    {{ Execute a SQL statement which return one integer from the aSQL UTF-8 encoded string
     - Execute the first statement in aSQL
     - this statement must get (at least) one field/column result of INTEGER
     - return result as an unique Int64 in ID
     - raise an ESQLite3Exception on any error }
    procedure Execute(aDB: TSQLite3DB; const aSQL: RawUTF8; out ID: Int64); overload;
    {{ Execute a SQL statement which return one TEXT value from the aSQL UTF-8 encoded string
     - Execute the first statement in aSQL
     - this statement must get (at least) one field/column result of TEXT
     - raise an ESQLite3Exception on any error }
    procedure Execute(aDB: TSQLite3DB; const aSQL: RawUTF8; out Value: RawUTF8); overload;
    {{ Execute a SQL statement which return TEXT from the aSQL UTF-8 encoded string
     - Execute the first statement in aSQL
     - this statement must get (at least) one field/column result of TEXT
     - return result as a dynamic array of RawUTF8 in ID
     - return count of row in integer function result (may be < length(ID))
     - raise an ESQLite3Exception on any error }
    function Execute(aDB: TSQLite3DB; const aSQL: RawUTF8; var Values: TRawUTF8DynArray): integer; overload;
    /// Execute one SQL statement which return the results in JSON format
    // - JSON format is more compact than XML and well supported
    // - Execute the first statement in aSQL
    // - if SQL is '', the statement should have been prepared, reset and bound if necessary
    // - raise an ESQLite3Exception on any error
    // - JSON data is added to TStream, with UTF-8 encoding
    // - if Expand is true, JSON data is an array of objects, for direct use
    // with any Ajax or .NET client:
    // & [ {"col1":val11,"col2":"val12"},{"col1":val21,... ]
    // - if Expand is false, JSON data is serialized (used in TSQLTableJSON)
    // & { "FieldCount":1,"Values":["col1","col2",val11,"val12",val21,..] }
    // - BLOB field value is saved as Base64, in the '"\uFFF0base64encodedbinary"'
................................................................................
    function Execute(aDB: TSQLite3DB; const aSQL: RawUTF8; JSON: TStream;
      Expand: boolean=false): PtrInt; overload;
    /// Execute one SQL statement which return the results in JSON format
    // - use internaly Execute() above with a TRawByteStringStream, and return a string
    // - BLOB field value is saved as Base64, e.g. '"\uFFF0base64encodedbinary"'
    // - returns the number of data rows added to JSON (excluding the headers)
    // in the integer variable mapped by aResultCount (if any)
    // - if any error occurs, the ESQLite3Exception is handled and '' is returned
    function ExecuteJSON(aDB: TSQLite3DB; const aSQL: RawUTF8; Expand: boolean=false;
      aResultCount: PPtrInt=nil): RawUTF8;
    {{ Execute all SQL statements in the aSQL UTF-8 encoded string, results will
      be written as ANSI text in OutFile }
    procedure ExecuteDebug(aDB: TSQLite3DB; const aSQL: RawUTF8; const OutFile: Text);
    {{ close the Request handle
     - call it even if an ESQLite3Exception has been raised }
    procedure Close;

    {{ read-only access to the Request (SQLite3 statement) handle }
    property Request: TSQLite3Statement read fRequest;
    {{ read-only access to the SQLite3 database handle }
    property RequestDB: TSQLite3DB read fDB;
    {{ returns true if the current prepared statement makes no direct changes
................................................................................
  public
    {{ Reset All Bindings On A Prepared Statement
     - Contrary to the intuition of many, Reset() does not reset the bindings
      on a prepared statement. Use this routine to reset all host parameter }
    procedure BindReset;
    {{ bind a NULL value to a parameter
     - the leftmost SQL parameter has an index of 1, but ?NNN may override it
     - raise an ESQLite3Exception on any error }
    procedure BindNull(Param: Integer); 
    {{ bind an integer value to a parameter
     - the leftmost SQL parameter has an index of 1, but ?NNN may override it
     - raise an ESQLite3Exception on any error }
    procedure Bind(Param: Integer; Value: Int64); overload;
    {{ bind a double value to a parameter
     - the leftmost SQL parameter has an index of 1, but ?NNN may override it
     - raise an ESQLite3Exception on any error }
    procedure Bind(Param: Integer; Value: double); overload;
    {{ bind a UTF-8 encoded string to a parameter
     - the leftmost SQL parameter has an index of 1, but ?NNN may override it
     - raise an ESQLite3Exception on any error }
    procedure Bind(Param: Integer; const Value: RawUTF8); overload;
    {{ bind a Blob buffer to a parameter
     - the leftmost SQL parameter has an index of 1, but ?NNN may override it
     - raise an ESQLite3Exception on any error }
    procedure Bind(Param: Integer; Data: pointer; Size: integer); overload;
    {{ bind a Blob TCustomMemoryStream buffer to a parameter
     - the leftmost SQL parameter has an index of 1, but ?NNN may override it
     - raise an ESQLite3Exception on any error }
    procedure Bind(Param: Integer; Data: TCustomMemoryStream); overload;
    {{ bind a ZeroBlob buffer to a parameter
     - uses a fixed amount of memory (just an integer to hold its size) while
      it is being processed. Zeroblobs are intended to serve as placeholders
      for BLOBs whose content is later written using incremental BLOB I/O routines
      (as with TSQLBlobStream created from TSQLDataBase.Blob() e.g.).
     - a negative value for the Size parameter results in a zero-length BLOB
     - the leftmost SQL parameter has an index of 1, but ?NNN may override it
     - raise an ESQLite3Exception on any error }
    procedure BindZero(Param: Integer; Size: integer);

  // 3. Field attributes after a sucessfull Step() (returned SQLITE_ROW)
  public
    {{ the field name of the current ROW  }
    function FieldName(Col: integer): RawUTF8;
    {{ the field index matching this name
................................................................................
  // - called for every row of a Statement
  // - the implementation may update the database directly by using a
  // local or shared TSQLRequest
  // - the TSQLRequest may be shared and prepared before the call for even
  // faster access than with a local TSQLRequest 
  // - no TSQLDataBase or higher levels objects can be used inside this method,
  // since all locking and try..finally protection is outside it
  // - can optionnaly trigger a ESQLite3Exception on any error
  TOnSQLStoredProc = procedure(Statement: TSQLRequest) of object;

  {{ TSQLDataBase.TransactionBegin can be deferred, immediate, or exclusive
   - tbDeferred means that no locks are acquired on the database until the
   database is first accessed. Thus with a deferred transaction, the BEGIN
   statement itself does nothing to the filesystem. Locks are not acquired
   until the first read or write operation. The first read operation against
................................................................................
     - SYSTEMNOCASE collation is added (our custom fast UTF-8 case insensitive compare,
       which is used also in the SQLite3UI unit for coherency and efficiency)
     - ISO8601 collation is added (TDateTime stored as ISO-8601 encoded TEXT)
     - WIN32CASE and WIN32NOCASE collations are added (use slow but accurate Win32 CompareW)
     - some additional SQl functions are registered: MOD, SOUNDEX/SOUNDEXFR/SOUNDEXES,
       RANK, CONCAT
     - initialize a TRTLCriticalSection to ensure that all access to the database is atomic
     - raise an ESQLite3Exception on any error }
    constructor Create(const aFileName: TFileName; const aPassword: RawUTF8='');
    {{ close a database and free its memory and context
      - if TransactionBegin was called but not commited, a RollBack is performed }
    destructor Destroy; override;
    {{ Execute all SQL statements in aSQL UTF-8 encoded string
     - can be prepared with TransactionBegin()
     - raise an ESQLite3Exception on any error }
    procedure ExecuteAll(const aSQL: RawUTF8);
    {{ Execute one SQL statements in aSQL UTF-8 encoded string
     - can be prepared with TransactionBegin()
     - raise an ESQLite3Exception on any error }
    procedure Execute(const aSQL: RawUTF8); overload;
    {{ Execute one SQL statement which return integers from the aSQL UTF-8 encoded string
     - Execute the first statement in aSQL
     - this statement must get a one field/column result of INTEGER
     - return result as a dynamic array of RawUTF8, as TEXT result
     - return count of row in integer function result (may be < length(ID))
     - raise an ESQLite3Exception on any error }
    function Execute(const aSQL: RawUTF8; var ID: TInt64DynArray): integer; overload;
    {{ Execute one SQL statement returning TEXT from the aSQL UTF-8 encoded string
     - Execute the first statement in aSQL
     - this statement must get (at least) one field/column result of TEXT
     - return result as a dynamic array of RawUTF8 in ID
     - return count of row in integer function result (may be < length(ID))
     - raise an ESQLite3Exception on any error }
    function Execute(const aSQL: RawUTF8; var Values: TRawUTF8DynArray): integer; overload;
    {{ Execute one SQL statement which return one integer from the aSQL UTF-8 encoded string
     - Execute the first statement in aSQL
     - this statement must get a one field/column result of INTEGER
     - return result as a dynamic array of RawUTF8, as TEXT result
     - raise an ESQLite3Exception on any error }
    procedure Execute(const aSQL: RawUTF8; out ID: Int64); overload;
    {{ Execute one SQL statement which return one UTF-8 encoded string value
     - Execute the first statement in aSQL
     - this statement must get a one field/column result of INTEGER
     - return result as a dynamic array of RawUTF8, as TEXT result
     - raise an ESQLite3Exception on any error }
    procedure Execute(const aSQL: RawUTF8; out ID: RawUTF8); overload;
    /// Execute one SQL statement returning its results in JSON format
    // - the BLOB data is encoded as '"\uFFF0base64encodedbinary"'
    function ExecuteJSON(const aSQL: RawUTF8; Expand: boolean=false; aResultCount: PPtrInt=nil): RawUTF8;
    {{ begin a transaction
     - Execute SQL statements with Execute() procedure below
     - must be ended with Commit on success
     - must be aborted with Rollback after an ESQLite3Exception raised
    - The default transaction behavior is tbDeferred }
    procedure TransactionBegin(aBehavior: TSQLDataBaseTransactionBehaviour = tbDeferred);
    {{ end a transaction: write all Execute() statements to the disk }
    procedure Commit;
    {{ abort a transaction: restore the previous state of the database }
    procedure RollBack;
    {{ return the last Insert Rowid }
................................................................................

    {{ open a BLOB incrementally for read[/write] access
     - find a BLOB located in row RowID, column ColumnName, table TableName
      in database DBName; in other words, the same BLOB that would be selected by:
      ! SELECT ColumnName FROM DBName.TableName WHERE rowid = RowID;
     - use after a TSQLRequest.BindZero() to reserve Blob memory
     - if RowID=-1, then the last inserted RowID is used
     - will raise an ESQLite3Exception on any error }
    function Blob(const DBName, TableName, ColumnName: RawUTF8;
      RowID: Int64=-1; ReadWrite: boolean=false): TSQLBlobStream;
    {{ backup of the opened Database into an external file name
     - don't use the experimental SQLite Online Backup API
     - database is closed, VACCUUMed, copied, then reopened: it's very fast  }
    function Backup(const BackupFileName: TFileName): boolean;

................................................................................
var
  /// in order to allow file encryption on disk, initialize this pointer
  // with SQLEncryptTableSize bytes of XOR tables
  // - you can use fixed or custom (SHA+AES) generated table
  // - using a fixed XOR table is very fast and provides strong enough encryption
  // - the first page (first 1024 bytes) is not encrypted, since its content
  // (mostly zero) can be used to easily guess the beginning of the key
  // - if the key is not correct, a ESQLite3Exception will be raised with
  // 'database disk image is malformed' (ErrorCode=SQLITE_CORRUPT)
  // - this table is common to ALL files accessed by the database engine: you
  // have maintain several XOR mask arrays, and set SQLEncryptTable before any
  // sqlite3*() call, to mix passowords or crypted and uncrypted databases
  // (see ChangeSQLEncryptTablePassWord() for multiple SQLEncryptTable use)
  // - please note that this encryption is compatible only with SQlite3 files
  // using the default page size of 1024
................................................................................
  if (aPassword<>'') and (aFileName<>':memory:') and (aFileName<>'') then begin
    SetLength(fCypherBlock,SQLEncryptTableSize);
    CreateSQLEncryptTableBytes(aPassword,pointer(fCypherBlock));
  end;
  fSQLFunctions := TObjectList.Create;
  result := DBOpen;
  if result<>SQLITE_OK then
    raise ESQLite3Exception.Create(fDB,result);
end;

destructor TSQLDataBase.Destroy;
{$ifndef INCLUDE_FTS3}
var S: TSQLite3Statement;
{$endif}
begin
................................................................................
    n: integer;
begin
  if self=nil then
    exit; // avoid GPF in case of call from a static-only server
  Lock('');
  try
    try
      R.Prepare(fDB,FormatUTF8('PRAGMA table_info(%);',[TableName])); // ESQLite3Exception
      SetLength(Names,64);
      n := 0;
      repeat
        if R.Step<>SQLITE_ROW then break;
        Names[n] := sqlite3_column_text(R.Request,1); // cid,name,type,notnull,dflt_value,pk
        inc(n);
      until n=64;
................................................................................
  fRequest := 0;
  fFieldCount := 0;
end;

procedure TSQLRequest.ExecuteAll;
begin
  if RequestDB=0 then
    raise ESQLite3Exception.Create(0,SQLITE_CANTOPEN);
  try
    repeat
      repeat
      until Step<>SQLITE_ROW; // all steps of this statement
    until PrepareNext=SQLITE_DONE; // all statements
  finally
    Close; // always release statement
  end;
end;

procedure TSQLRequest.Execute;
begin
  if RequestDB=0 then
    raise ESQLite3Exception.Create(0,SQLITE_CANTOPEN);
  try
    repeat
    until Step<>SQLITE_ROW; // Execute all steps of the first statement
  finally
    Close; // always release statement
  end;
end;

procedure TSQLRequest.ExecuteAll(aDB: TSQLite3DB; const aSQL: RawUTF8);
begin
  try
    Prepare(aDB,aSQL); // will raise an ESQLite3Exception on error
    ExecuteAll;
  finally
    Close; // always release statement, even if done normaly in EngineExecuteAll
  end;
end;

procedure TSQLRequest.Execute(aDB: TSQLite3DB; const aSQL: RawUTF8);
begin
  try
    Prepare(aDB,aSQL); // will raise an ESQLite3Exception on error
    Execute;
  finally
    Close; // always release statement, even if done normaly in Execute
  end;
end;

function TSQLRequest.Execute(aDB: TSQLite3DB; const aSQL: RawUTF8; var ID: TInt64DynArray): integer;
var LID, Res: integer;
begin
  result := 0;
  LID := length(ID);
  try
    Prepare(aDB,aSQL); // will raise an ESQLite3Exception on error
    if FieldCount>0 then
    repeat
      res := Step;
      if res=SQLITE_ROW then begin
        if result>=LID then begin
          inc(LID,256);
          SetLength(ID,LID);
................................................................................
  end;
end;

procedure TSQLRequest.Execute(aDB: TSQLite3DB; const aSQL: RawUTF8; out ID: Int64);
begin
  ID := 0;
  try
    Prepare(aDB,aSQL); // will raise an ESQLite3Exception on error
    if FieldCount>0 then
    if Step=SQLITE_ROW then
      ID := sqlite3_column_int64(Request,0); // get first column value
  finally
    Close; // always release statement
  end;
end;

procedure TSQLRequest.Execute(aDB: TSQLite3DB; const aSQL: RawUTF8; out Value: RawUTF8);
begin
  Value := '';
  try
    Prepare(aDB,aSQL); // will raise an ESQLite3Exception on error
    if FieldCount>0 then
    if Step=SQLITE_ROW then
      Value := sqlite3_column_text(Request,0); // get first column value
  finally
    Close; // always release statement
  end;
end;
................................................................................

function TSQLRequest.Execute(aDB: TSQLite3DB; const aSQL: RawUTF8; var Values: TRawUTF8DynArray): integer;
var LValues, Res: integer;
begin
  result := 0;
  LValues := length(Values);
  try
    Prepare(aDB,aSQL); // will raise an ESQLite3Exception on error
    if FieldCount>0 then
    repeat
      res := Step;
      if res=SQLITE_ROW then begin
        if result>=LValues then begin
          if LValues<256 then
            inc(LValues,16) else
................................................................................
    W: TJSONWriter;
begin
  result := 0;
  W := TJSONWriter.Create(JSON,Expand,false);
  try
    // prepare the SQL request
    if aSQL<>'' then // if not already prepared, reset and bound by caller
      Prepare(aDB,aSQL); // will raise an ESQLite3Exception on error
    if FieldCount<=0 then begin
      W.CancelAllVoid;
      exit;
    end;
    // get col names and types
    SetLength(W.ColNames,FieldCount);
    for i := 0 to FieldCount-1 do
................................................................................

procedure TSQLRequest.ExecuteDebug(aDB: TSQLite3DB; const aSQL: RawUTF8; const OutFile: Text);
var Res, i, n: integer;
begin
  {$I-}
  writeln;
  try
    Prepare(aDB,aSQL); // will raise an ESQLite3Exception on error
    repeat
      repeat
        Res := Step;
        if Res=SQLITE_ROW then begin
          n := FieldCount-1;
          for i := 0 to n do begin
            write(OutFile,FieldA(i));
................................................................................
  try
    try
      RowCount := Execute(aDB,aSQL,Stream,Expand); // create JSON data in Stream
      if aResultCount<>nil then
        aResultCount^ := RowCount;
      result := Stream.DataString;
    except
      on ESQLite3Exception do
        result := '';
    end;
    // Close has been called in Execute() above since aSQL<>''
  finally
    Stream.Free;
  end;
end;
................................................................................

function TSQLRequest.FieldA(Col: integer): WinAnsiString;
var P: PUTF8Char;
    L,L2: integer;
begin
  result := '';
  if cardinal(Col)>=cardinal(FieldCount) then
    raise ESQLite3Exception.Create(RequestDB, SQLITE_RANGE);
  P := sqlite3_column_text(Request,Col);
  L := SynCommons.StrLen(P); // faster than sqlite3_column_bytes(Request,Col)
  if L>0 then begin
    SetLength(result,L);
    L2 := UTF8ToWinPChar(pointer(result),P,L);
    if L2<>L then
      SetLength(result,L2);
................................................................................
  end;
end;

function TSQLRequest.FieldBlob(Col: integer): RawByteString;
var P: PAnsiChar;
begin
  if cardinal(Col)>=cardinal(FieldCount) then
    raise ESQLite3Exception.Create(RequestDB, SQLITE_RANGE);
  P := sqlite3_column_blob(Request,Col);
  SetString(result,P,sqlite3_column_bytes(Request,Col));
end;

function TSQLRequest.FieldBlobToStream(Col: integer): TStream;
begin
  result := TRawByteStringStream.Create(FieldBlob(Col));
end;

function TSQLRequest.FieldDouble(Col: integer): double;
begin
  if cardinal(Col)>=cardinal(FieldCount) then
    raise ESQLite3Exception.Create(RequestDB, SQLITE_RANGE);
  result := sqlite3_column_double(Request,Col);
end;

function TSQLRequest.FieldInt(Col: integer): Int64;
begin // internaly, SQLite always uses Int64 -> pure Integer function is useless
  if cardinal(Col)>=cardinal(FieldCount) then
    raise ESQLite3Exception.Create(RequestDB, SQLITE_RANGE);
  result := sqlite3_column_int64(Request,Col);
end;

function TSQLRequest.FieldName(Col: integer): RawUTF8;
var P: PUTF8Char;
begin
  if cardinal(Col)>=cardinal(FieldCount) then
    raise ESQLite3Exception.Create(RequestDB, SQLITE_RANGE);
  P := sqlite3_column_name(Request,Col);
  SetString(result,P,SynCommons.StrLen(P));
end;

function TSQLRequest.FieldIndex(const aColumnName: RawUTF8): integer;
begin
  if Request=0 then
    raise ESQLite3Exception.Create(RequestDB,SQLITE_MISUSE);
  for result := 0 to FieldCount-1 do
    if StrIComp(pointer(aColumnName),sqlite3_column_name(Request,result))=0 then
      exit;
  result := -1; // not found
end;

function TSQLRequest.FieldNull(Col: Integer): Boolean;
begin
  if cardinal(Col)>=cardinal(FieldCount) then
    raise ESQLite3Exception.Create(RequestDB, SQLITE_RANGE);
  result := sqlite3_column_type(Request,Col)=SQLITE_NULL;
end;

function TSQLRequest.FieldType(Col: Integer): integer;
begin
  if cardinal(Col)>=cardinal(FieldCount) then
    raise ESQLite3Exception.Create(RequestDB, SQLITE_RANGE);
  result := sqlite3_column_type(Request,Col);
end;

function TSQLRequest.FieldUTF8(Col: integer): RawUTF8;
var P: PUTF8Char;
begin
  if cardinal(Col)>=cardinal(FieldCount) then
    raise ESQLite3Exception.Create(RequestDB, SQLITE_RANGE);
  P := pointer(sqlite3_column_text(Request,Col));
  SetString(result,P,SynCommons.StrLen(P));
end;

function TSQLRequest.FieldValue(Col: integer): TSQLite3Value;
begin
  if cardinal(Col)>=cardinal(FieldCount) then
    raise ESQLite3Exception.Create(RequestDB, SQLITE_RANGE);
  result := sqlite3_column_value(Request,Col);
end;

function TSQLRequest.FieldW(Col: integer): RawUnicode;
begin
  if cardinal(Col)>=cardinal(FieldCount) then
    raise ESQLite3Exception.Create(RequestDB, SQLITE_RANGE);
  result := Utf8DecodeToRawUnicode(sqlite3_column_text(Request,Col),0);
end;

function TSQLRequest.Prepare(DB: TSQLite3DB; const SQL: RawUTF8): integer;
begin
  fDB := DB;
  fRequest := 0;
  if DB=0 then
    raise ESQLite3Exception.Create(DB,SQLITE_CANTOPEN);
  result := sqlite3_prepare_v2(RequestDB, pointer(SQL), length(SQL)+1, fRequest, fNextSQL);
  while (result=SQLITE_OK) and (Request=0) do // comment or white-space
    result := sqlite3_prepare_v2(RequestDB, fNextSQL, -1, fRequest, fNextSQL);
  fFieldCount := sqlite3_column_count(fRequest);
  sqlite3_check(RequestDB,result);
end;

................................................................................
      result := SQLITE_DONE; // nothing more to add
  end;
end;

function TSQLRequest.Reset: integer;
begin
  if Request=0 then
    raise ESQLite3Exception.Create(RequestDB,SQLITE_MISUSE);
  result := sqlite3_reset(Request); // no check here since it was PREVIOUS state
end;

function TSQLRequest.Step: integer;
begin
  if Request=0 then
    raise ESQLite3Exception.Create(RequestDB,SQLITE_MISUSE);
  result := sqlite3_check(RequestDB,sqlite3_step(Request));
end;

function TSQLRequest.GetReadOnly: Boolean;
begin
  if Request=0 then
    raise ESQLite3Exception.Create(RequestDB,SQLITE_MISUSE);
  result := sqlite3_stmt_readonly(Request);
end;

procedure TSQLRequest.FieldsToJSON(WR: TJSONWriter);
var i: integer;
begin
  if Request=0 then
    raise ESQLite3Exception.Create(RequestDB,SQLITE_MISUSE);
  if WR.Expand then
    WR.Add('{');
  for i := 0 to FieldCount-1 do begin
    if WR.Expand then
      WR.AddString(WR.ColNames[i]); // '"'+ColNames[]+'":'
    case sqlite3_column_type(Request,i) of // fast evaluation: type may vary
      SQLITE_BLOB: 
................................................................................
begin
  if Request=0 then
    result := 0 else
    result := sqlite3_bind_parameter_count(Request);
end;


{ ESQLite3Exception }

constructor ESQLite3Exception.Create(aDB: TSQLite3DB; aErrorCode: integer);
begin
  if aDB=0 then
    CreateFmt(sErrorSQLite3NoDB,[aErrorCode]) else
    Create(string(sqlite3_errmsg(aDB)),aErrorCode);
  DB := aDB;
end;

constructor ESQLite3Exception.Create(const aMessage: string; aErrorCode: integer);
begin
  ErrorCode := aErrorCode;
  Create(aMessage);
end;

function sqlite3_check(DB: TSQLite3DB; aResult: integer): integer;
begin
  if (DB=0) or (aResult in [SQLITE_ERROR..SQLITE_ROW-1]) then // possible error codes
    raise ESQLite3Exception.Create(DB,aResult);
  result := aResult;
end;


{ TSQLBlobStream }

constructor TSQLBlobStream.Create(aDB: TSQLite3DB; const DBName, TableName,

    /// test TSQLRecordExternal implementation via slower Virtual Table calls
    // - using the Virtual Table mechanism of SQLite3 is more than 2 times
    // slower than direct REST access
    procedure ExternalViaVirtualTable;
  end;
{$endif}















  /// a test case which will test the interface-based SOA implementation of
  // the mORMot framework
  TTestServiceOrientedArchitecture = class(TSynTestCase)
  protected
    fModel: TSQLModel;
    fClient: TSQLRestClientDB;

  public
    /// release the associated memory and object instances
    destructor Destroy; override;
  published
    /// initialize the SOA implementation
    procedure ServiceInitialization;
    /// test the server-side implementation
    procedure ServerSide;


  end;

{$endif}

implementation

uses
................................................................................
end;

{$endif LVCL}

{ TServiceCalculator }

type
  ICalculator = interface(IService)
    ['{9A60C8ED-CEB2-4E09-87D4-4A16F496E5FE}']
    function Add(n1,n2: integer): integer;
    function Multiply(n1,n2: Int64): Int64;
    function Subtract(n1,n2: double): double;
    procedure ToText(Value: Currency; var Result: RawUTF8);
    function ToTextFunc(Value: double): string;
  end;

  TServiceCalculator = class(TInterfacedObject, ICalculator)
  public
    function Add(n1,n2: integer): integer;
    function Subtract(n1,n2: double): double;
    function Multiply(n1,n2: Int64): Int64;
    procedure ToText(Value: Currency; var Result: RawUTF8);
    function ToTextFunc(Value: double): string;
................................................................................
function TServiceCalculator.ToTextFunc(Value: double): string;
begin
  result := DoubleToString(Value);
end;


{ TTestServiceOrientedArchitecture }














































destructor TTestServiceOrientedArchitecture.Destroy;
begin
  fClient.Free;
  fModel.Free;
  inherited;
end;

procedure TTestServiceOrientedArchitecture.ServerSide;
var I: ICalculator;
procedure TestI;
var s: RawUTF8;
begin
  Check(I.Add(1,2)=3);
  Check(I.Multiply(2,3)=6);
  CheckSame(I.Subtract(23,20),3);
  I.ToText(3.14,s);
  Check(s='3.14');
  Check(I.ToTextFunc(777)='777');
end;
function Ask(const Method, Params: RawUTF8; ExpectedResult: cardinal): RawUTF8;
var resp,head: RawUTF8;
begin
  Check(fClient.Server.URI('root/calculator','POST',
    '{"method":"'+Method+'", "params": [ '+Params+' ]}',resp,head,
    @SUPERVISOR_ACCESS_RIGHTS).Lo=ExpectedResult);
  result := JSONDecode(resp,'RESULT',nil,true);
end;

begin
  I := TServiceCalculator.Create;
  TestI;
  I := nil;
  if CheckFailed(fModel<>nil) or CheckFailed(fClient<>nil) or
     CheckFailed(fClient.Server.Services.Count=1) or
     CheckFailed(fClient.Server.Services.Service(0).FromFactory(I)) or
     CheckFailed(Assigned(I)) then exit;
  TestI;




  Check(Ask('None','1,2',400)='');
  Check(Ask('Add','1,2',200)='[3]');
  Check(Ask('Multiply','2,3',200)='[6]');
  Check(Ask('Subtract','23,20',200)='[3]');
  Check(Ask('ToText','777,"abc"',200)='["777"]'); // "abc" for var parameter
  Check(Ask('ToTextFunc','777',200)='["777"]');
end;
................................................................................
  fClient := TSQLRestClientDB.Create(fModel,nil,'test.db3',TSQLRestServerDB);
  // register TServiceCalculator as the ICalculator implementation on the server
  Check(fClient.Server.
    ServiceRegister(TServiceCalculator,[TypeInfo(ICalculator)],sicShared));
  // verify ICalculator RTTI-generated details
  Check(fClient.Server.Services<>nil);
  if CheckFailed(fClient.Server.Services.Count=1) then exit;
  S := fClient.Server.Services.Service(0);
  if CheckFailed(S<>nil) then exit;
  Check(S.InterfaceURI='Calculator');
  Check(S.InstanceCreation=sicShared);
  Check(S.InterfaceTypeInfo^.Kind=tkInterface);
  Check(S.InterfaceTypeInfo^.ShortName='ICalculator');
  Check(GUIDToString(S.InterfaceIID)='{9A60C8ED-CEB2-4E09-87D4-4A16F496E5FE}');
  Check(S.InterfaceMangledURI='7chgmrLOCU6H1EoW9Jbl_g');
  fClient.Server.Services.ExpectMangledURI := true;
  Check(fClient.Server.Services.Service(S.InterfaceMangledURI)=S);
  fClient.Server.Services.ExpectMangledURI := false;
  Check(fClient.Server.Services.Service('CALCULAtor')=S);
  Check(fClient.Server.Services.Service('CALCULAtors')=nil);
  if CheckFailed(length(S.Methods)=5) then exit;
  for i := 0 to 4 do
    with S.Methods[i] do begin
      Check(CallingConvention=ccRegister);
      Check(URI=ExpectedURI[i]);
      Check(length(Args)=ExpectedParCount[i]);
      Check(ArgsUsed=ExpectedArgs[i]);
................................................................................
          Check(Args[2].ValueType=smvString);
      end;
    end;
end;

{$endif DELPHI5OROLDER}


end.

    /// test TSQLRecordExternal implementation via slower Virtual Table calls
    // - using the Virtual Table mechanism of SQLite3 is more than 2 times
    // slower than direct REST access
    procedure ExternalViaVirtualTable;
  end;
{$endif}

  /// a test interface, used by TTestServiceOrientedArchitecture
  ICalculator = interface(IService)
    ['{9A60C8ED-CEB2-4E09-87D4-4A16F496E5FE}']
    function Add(n1,n2: integer): integer;
    function Multiply(n1,n2: Int64): Int64;
    function Subtract(n1,n2: double): double;
    procedure ToText(Value: Currency; var Result: RawUTF8);
    function ToTextFunc(Value: double): string;
  end;

const
  IID_ICalculator: TGUID = '{9A60C8ED-CEB2-4E09-87D4-4A16F496E5FE}';

type
  /// a test case which will test the interface-based SOA implementation of
  // the mORMot framework
  TTestServiceOrientedArchitecture = class(TSynTestCase)
  protected
    fModel: TSQLModel;
    fClient: TSQLRestClientDB;
    procedure Test(I: ICalculator);
  public
    /// release the associated memory and object instances
    destructor Destroy; override;
  published
    /// initialize the SOA implementation
    procedure ServiceInitialization;
    /// test the server-side implementation
    procedure ServerSide;
    /// test the client-side implementation
    procedure ClientSide;
  end;

{$endif}

implementation

uses
................................................................................
end;

{$endif LVCL}

{ TServiceCalculator }

type









  TServiceCalculator = class(TInterfacedObject, ICalculator)
  public
    function Add(n1,n2: integer): integer;
    function Subtract(n1,n2: double): double;
    function Multiply(n1,n2: Int64): Int64;
    procedure ToText(Value: Currency; var Result: RawUTF8);
    function ToTextFunc(Value: double): string;
................................................................................
function TServiceCalculator.ToTextFunc(Value: double): string;
begin
  result := DoubleToString(Value);
end;


{ TTestServiceOrientedArchitecture }

procedure TTestServiceOrientedArchitecture.Test(I: ICalculator);
var s: RawUTF8;
    t: integer;
    i1,i2: integer;
    n1,n2: double;
begin
  Check(I.Add(1,2)=3);
  Check(I.Multiply(2,3)=6);
  CheckSame(I.Subtract(23,20),3);
  I.ToText(3.14,s);
  Check(s='3.14');
  Check(I.ToTextFunc(777)='777');
  for t := 1 to 1000 do begin
    i1 := Random(MaxInt)-Random(MaxInt);
    i2 := Random(MaxInt)-i1;
    Check(I.Add(i1,i2)=i1+i2);
    Check(I.Multiply(i1,i2)=Int64(i1)*Int64(i2));
    n1 := Random*1E-17-Random*1E-9;
    n2 := n1*Random;
    CheckSame(I.Subtract(n1,n2),n1-n2);
    Check(I.ToTextFunc(n1)=DoubleToString(n1));
  end;
end;

procedure TTestServiceOrientedArchitecture.ClientSide;
var I: ICalculator;
begin
  Check(fClient.ServiceRegister([TypeInfo(ICalculator)],sicShared));
  // once registered, can be accessed by its GUID or URI
  if CheckFailed(fClient.Services.Info(TypeInfo(ICalculator)).Get(I)) then
    exit;
  Check(I.Add(1,2)=3);
  Check(I.Multiply(2,3)=6);
  I := nil;
  if CheckFailed(fClient.Services.GUID(IID_ICalculator).Get(I)) then
    exit;
  Check(I.Add(1,2)=3);
  Check(I.Multiply(2,3)=6);
  I := nil;
  if CheckFailed(fClient.Services['Calculator'].Get(I)) then
    exit;
  Check(I.Add(1,2)=3);
  Check(I.Multiply(2,3)=6);
end;

destructor TTestServiceOrientedArchitecture.Destroy;
begin
  fClient.Free;
  fModel.Free;
  inherited;
end;

procedure TTestServiceOrientedArchitecture.ServerSide;











function Ask(const Method, Params: RawUTF8; ExpectedResult: cardinal): RawUTF8;
var resp,head: RawUTF8;
begin
  Check(fClient.Server.URI('root/calculator','POST',
    '{"method":"'+Method+'", "params": [ '+Params+' ]}',resp,head,
    @SUPERVISOR_ACCESS_RIGHTS).Lo=ExpectedResult);
  result := JSONDecode(resp,'RESULT',nil,true);
end;
var I: ICalculator;
begin
  I := TServiceCalculator.Create;
  Test(I);
  I := nil;
  if CheckFailed(fModel<>nil) or CheckFailed(fClient<>nil) or
     CheckFailed(fClient.Server.Services.Count=1) or
     CheckFailed(fClient.Server.Services.Index(0).Get(I)) or
     CheckFailed(Assigned(I)) then exit;
  Test(I);
  I := nil;
  if CheckFailed(fClient.Server.Services['Calculator'].Get(I)) then
    exit;
  Test(I);
  Check(Ask('None','1,2',400)='');
  Check(Ask('Add','1,2',200)='[3]');
  Check(Ask('Multiply','2,3',200)='[6]');
  Check(Ask('Subtract','23,20',200)='[3]');
  Check(Ask('ToText','777,"abc"',200)='["777"]'); // "abc" for var parameter
  Check(Ask('ToTextFunc','777',200)='["777"]');
end;
................................................................................
  fClient := TSQLRestClientDB.Create(fModel,nil,'test.db3',TSQLRestServerDB);
  // register TServiceCalculator as the ICalculator implementation on the server
  Check(fClient.Server.
    ServiceRegister(TServiceCalculator,[TypeInfo(ICalculator)],sicShared));
  // verify ICalculator RTTI-generated details
  Check(fClient.Server.Services<>nil);
  if CheckFailed(fClient.Server.Services.Count=1) then exit;
  S := fClient.Server.Services.Index(0);
  if CheckFailed(S<>nil) then exit;
  Check(S.InterfaceURI='Calculator');
  Check(S.InstanceCreation=sicShared);
  Check(S.InterfaceTypeInfo^.Kind=tkInterface);
  Check(S.InterfaceTypeInfo^.ShortName='ICalculator');
  Check(GUIDToString(S.InterfaceIID)='{9A60C8ED-CEB2-4E09-87D4-4A16F496E5FE}');
  Check(S.InterfaceMangledURI='7chgmrLOCU6H1EoW9Jbl_g');
  fClient.Server.Services.ExpectMangledURI := true;
  Check(fClient.Server.Services[S.InterfaceMangledURI]=S);
  fClient.Server.Services.ExpectMangledURI := false;
  Check(fClient.Server.Services['CALCULAtor']=S);
  Check(fClient.Server.Services['CALCULAtors']=nil);
  if CheckFailed(length(S.Methods)=5) then exit;
  for i := 0 to 4 do
    with S.Methods[i] do begin
      Check(CallingConvention=ccRegister);
      Check(URI=ExpectedURI[i]);
      Check(length(Args)=ExpectedParCount[i]);
      Check(ArgsUsed=ExpectedArgs[i]);
................................................................................
          Check(Args[2].ValueType=smvString);
      end;
    end;
end;

{$endif DELPHI5OROLDER}


end.