mORMot Open Source

unit Pi.Air.DB.Client.Provider.Mormot;

interface

uses
  System.Classes,
  Datasnap.DBClient,
  Datasnap.Provider,
  SynCommons,
  SynDB,
  SynDBRemote,
  Data.DB,
  SynVirtualDataSet
;

type

  TInternalConnection = class(TSQLDBWinHTTPConnectionProperties)
  private
    function GetQuoteChar: string;
  end;

{ TInternalSQLDataSet }

  TInternalSQLDataSet = class(TSynVirtualDataSet)
  private
    FConnection: TInternalConnection;
    FCommandText: String;
    fDataAccess: TSQLDBProxyStatementRandomAccess;
    fTemp64: Int64;
    fData: RawByteString;
    procedure OpenDB;
  protected
    // IProvider
    procedure PSSetCommandText(const ACommandText: string); override;
    function PSGetTableName: string; override;
    function PSUpdateRecord(UpdateKind: TUpdateKind; Delta: TDataSet): Boolean; override;
    function PSIsSQLBased: Boolean; override;
    function PSIsSQLSupported: Boolean; override;
    function PSExecuteStatement(const ASQL: string; AParams: TParams): Integer; overload; override;
    // End of IProvider
    procedure InternalInitFieldDefs; override;
    function GetRecordCount: Integer; override;
    function GetRowFieldData(Field: TField; RowIndex: integer; out ResultLen: Integer;
      OnlyCheckNull: boolean): Pointer; override;

    procedure InternalOpen; override;
    procedure InternalClose; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

      /// read-only access to the internal binary buffer
    property Data: RawByteString read fData;
    /// read-only access to the internal SynDB data
    property DataAccess: TSQLDBProxyStatementRandomAccess read fDataAccess;
published
    property SQLConnection: TInternalConnection read FConnection write FConnection;
    property CommandText: String read FCommandText write FCommandText;
  end;

{ TSimpleDataSet }

  TPiCustomClientDataSet = class(TCustomClientDataSet)
  private
    FConnection: TInternalConnection;
    FInternalConnection: TInternalConnection; { Always points to internal if present }
    FDataSet: TInternalSQLDataSet;
    FProvider: TDataSetProvider;
  protected
    procedure AllocConnection; virtual;
    procedure AllocDataSet; virtual;
    procedure AllocProvider; virtual;
    procedure Loaded; override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure OpenCursor(InfoQuery: Boolean); override;
    procedure SetConnection(Value: TInternalConnection); virtual;
    { IProviderSupport }
    function PSGetCommandText: string; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure FetchParams;
  published
    property CommandText;
    property Active;
    property Aggregates;
    property AggregatesActive;
    property AutoCalcFields;
    property Connection: TInternalConnection read FConnection write SetConnection;
    property DataSet: TInternalSQLDataSet read FDataSet;
    property Constraints;
    property DisableStringTrim;
    property FileName;
    property Filter;
    property Filtered;
    property FilterOptions;
    property FieldDefs;
    property IndexDefs;
    property IndexFieldNames;
    property IndexName;
    property FetchOnDemand;
    property MasterFields;
    property MasterSource;
    property ObjectView;
    property PacketRecords;
    property Params;
    property ReadOnly;
    property StoreDefs;
    property BeforeOpen;
    property AfterOpen;
    property BeforeClose;
    property AfterClose;
    property BeforeInsert;
    property AfterInsert;
    property BeforeEdit;
    property AfterEdit;
    property BeforePost;
    property AfterPost;
    property BeforeCancel;
    property AfterCancel;
    property BeforeDelete;
    property AfterDelete;
    property BeforeScroll;
    property AfterScroll;
    property BeforeRefresh;
    property AfterRefresh;
    property OnCalcFields;
    property OnDeleteError;
    property OnEditError;
    property OnFilterRecord;
    property OnNewRecord;
    property OnPostError;
    property OnReconcileError;
    property BeforeApplyUpdates;
    property AfterApplyUpdates;
    property BeforeGetRecords;
    property AfterGetRecords;
    property BeforeRowRequest;
    property AfterRowRequest;
    property BeforeExecute;
    property AfterExecute;
    property BeforeGetParams;
    property AfterGetParams;
  end;


implementation

uses
  System.SysUtils,
  Data.SqlConst,
  Data.DBCommon
;

function NextPiece(Start: string; InLiteral: Boolean; QuoteChar: WideChar; EndParam: Boolean = False): Integer;
var
  P, Len: Integer;
  C, LQuoteChar: Char;
begin
  P := 1;
  Len := Start.Length - 1;
  Result := -1;
  LQuoteChar := QuoteChar;
  while (Result = -1) and (P <= Len) and (Start.Chars[P] <> #0) do
  begin
    C := Start.Chars[P];
    if (C = '''') or (C = LQuoteChar) then
      InLiteral := not InLiteral
    else if not InLiteral and ((C = ' ') or (C = ')') or (C = ',') or (C = '=')
      or (C = ':') or (C = '>') or (C = '<') or (C = #13) or (C = #10)) then
    begin
      if EndParam then
      begin
        if not ((C = '=') or (C = ':') or (C = '<') or (C = '>')) then
          Result := P;
      end
      else
      begin
        if (C = ':') then
        begin
          if ((Start.Chars[P-1] = ' ') or (Start.Chars[P-1] = ')') or (Start.Chars[P-1] = ',')
            or (Start.Chars[P-1] = '=') or (Start.Chars[P-1] = '(')) then
            Result := P - 1;
        end
        else if (P < Len) and (Start.Chars[P + 1] = ':') then
          Result := P;
      end;
    end;
    Inc(P);
  end;
end;

// SqlObjects does not support named params: convert to ?
// if not yet converted
function FixParams(SQL: string; Count: Integer; QuoteChar: string): string;
var
  Param, Start: string;
  Pos, EndPos: Integer;
  InLiteral: Boolean;
  Q: Char;
begin
  Q := #0;
  if QuoteChar.Length > 0 then
    Q := QuoteChar.Chars[0];
  if (Q = #0) or (Q = ' ') then Q := '''';
  InLiteral := False;
  Start := SQL;
  Pos := NextPiece(Start, InLiteral, Q);
  while Pos >= 0 do
  begin
    Start := Start.SubString(Pos + 1, Start.Length - Pos + 1);
    EndPos := NextPiece(Start, InLiteral, Q, True);
    if EndPos = -1 then
      Param := Start.SubString(0, Start.Length)
    else
      Param := Start.SubString(0, EndPos);
    SQL := SQL.Replace(Param, ' ? ', []);
    Pos := NextPiece(Start, InLiteral, Q);
  end;
  Result := SQL;
end;

{ TPiCustomClientDataSet }

constructor TPiCustomClientDataSet.Create(AOwner: TComponent);
begin
  inherited;
  AllocProvider;
  AllocDataSet;
  //AllocConnection;
end;

destructor TPiCustomClientDataSet.Destroy;
begin
  inherited; { Reserved }
end;

procedure TPiCustomClientDataSet.FetchParams;
begin
  if not HasAppServer and Assigned(FProvider) then
    SetProvider(FProvider);

  inherited FetchParams;
end;

procedure TPiCustomClientDataSet.Loaded;
begin
  inherited;
  { Internal connection can now be safely deleted if needed }
  if FInternalConnection <> FConnection then
    FreeAndNil(FInternalConnection);
end;

procedure TPiCustomClientDataSet.AllocConnection;
begin
  FConnection := TInternalConnection.Create('', '', '', '');
  FInternalConnection := FConnection;
  //FConnection.Name := 'InternalConnection';             { Do not localize }
  //FConnection.SetSubComponent(True);
  FDataSet.SQLConnection := FConnection;
end;

procedure TPiCustomClientDataSet.AllocDataSet;
begin
  FDataSet := TInternalSQLDataSet.Create(Self);
  FDataSet.Name := 'InternalDataSet';                   { Do not localize }
  FDataSet.SQLConnection := FConnection;
  FDataSet.SetSubComponent(True);
  FProvider.DataSet := FDataSet;
end;

procedure TPiCustomClientDataSet.AllocProvider;
begin
  FProvider := TDataSetProvider.Create(Self);
  FProvider.DataSet := FDataSet;
  FProvider.Name := 'InternalProvider';                 { Do not localize }
  FProvider.SetSubComponent(True);
  FProvider.Options := FProvider.Options + [poAllowCommandText];
  SetProvider(FProvider);
end;

procedure TPiCustomClientDataSet.Notification(AComponent: TComponent; Operation: TOperation);
begin
  inherited;
  {
  if not (csDestroying in ComponentState ) and (Operation = opRemove) and
     (AComponent = FConnection) and (AComponent.Owner <> Self) then
    AllocConnection;
  }
end;

procedure TPiCustomClientDataSet.OpenCursor(InfoQuery: Boolean);
begin
  if Assigned(FProvider) then
    SetProvider(FProvider);
  if FProvider.DataSet = Self then
    raise Exception.Create(SCircularProvider);
  inherited;
end;

procedure TPiCustomClientDataSet.SetConnection(Value: TInternalConnection);
begin
  { Assigning existing value or clearing internal connection is a NOP }
  if (Value = FConnection) or ((Value = nil) and Assigned(FInternalConnection)) then
    Exit;
  { Remove FreeNotification from existing external reference }
  {if FConnection <> FInternalConnection then
    FConnection.RemoveFreeNotification(Self);}
  { Reference to external connection was cleared, recreate internal }
  if (Value = nil) then
    AllocConnection
  else
  begin
    { Free the internal connection when assigning an external connection }
    if Assigned(FInternalConnection) then //and
       { but not if we are streaming in, then wait until loaded is called }
       //not (csLoading in FInternalConnection.ComponentState) then
      FreeAndNil(FInternalConnection);
    FConnection := Value;
    //FConnection.FreeNotification(Self);
    FDataSet.SQLConnection := FConnection;
  end;
end;

function TPiCustomClientDataSet.PSGetCommandText: string;
var
  IP: IProviderSupportNG;
begin
  if Supports(FDataSet, IProviderSupportNG, IP) then
    Result := IP.PSGetCommandText
  else
    Result := CommandText;
end;

{ TInternalSQLDataSet }

constructor TInternalSQLDataSet.Create(AOwner: TComponent);
begin
  inherited;
  //SetUniDirectional(True);
end;

destructor TInternalSQLDataSet.Destroy;
begin
  if Assigned(fDataAccess) then
    FreeAndNil(fDataAccess);
  inherited;
end;

function TInternalSQLDataSet.GetRecordCount: Integer;
begin
  result := fDataAccess.DataRowCount;
end;

function TInternalSQLDataSet.GetRowFieldData(Field: Data.DB.TField;
  RowIndex: integer; out ResultLen: Integer; OnlyCheckNull: boolean): Pointer;
var F: integer;
begin
  result := nil;
  F := Field.Index;
  if not fDataAccess.GotoRow(RowIndex) then
    exit;
  result := fDataAccess.ColumnData(F);
  if (result<>nil) and not OnlyCheckNull then
    case fDataAccess.Columns[F].ColumnType of
    SynCommons.ftInt64: begin
      fTemp64 := FromVarInt64(PByte(result));
      result := @fTemp64;
    end;
    SynCommons.ftCurrency: begin // ftFloat expects a DOUBLE value
      PDouble(@fTemp64)^ := PCurrency(result)^;
      result := @fTemp64;
    end;
    SynCommons.ftUTF8, SynCommons.ftBlob:
      resultLen := FromVarUInt32(PByte(result));
    end; // other ColumnTypes are already in the expected format
end;

procedure TInternalSQLDataSet.InternalClose;
begin
  inherited;
  if Assigned(fDataAccess) then
    FreeAndNil(fDataAccess);
  //fData := '';
end;

procedure TInternalSQLDataSet.InternalInitFieldDefs;
var F: integer;
    DBType: TFieldType;
begin
  FieldDefs.Clear;
  if fDataAccess=nil then
    exit;
  for F := 0 to fDataAccess.ColumnCount-1 do
    with fDataAccess.Columns[F] do begin
    case ColumnType of
    SynCommons.ftInt64: DBType := ftLargeint;
    SynCommons.ftDate:  DBType := ftDateTime;
    SynCommons.ftUTF8:  DBType := ftWideString; // means UnicodeString for Delphi 2009+
    SynCommons.ftBlob:  DBType := ftBlob;
    SynCommons.ftDouble, SynCommons.ftCurrency: DBType := ftFloat;
    else raise EDatabaseError.CreateFmt('GetFieldData ColumnType=%d',[ord(ColumnType)]);
    end;
    //FieldDefs.Add(UTF8ToString(ColumnName),DBType,ColumnDataSize);
    if (DBType = ftWideString) and (ColumnValueDBSize = 0) then // blob
      FieldDefs.Add(UTF8ToString(ColumnName),ftMemo,ColumnValueDBSize) // Murat
    else
      FieldDefs.Add(UTF8ToString(ColumnName),DBType,ColumnValueDBSize); // Murat
  end;
end;

procedure TInternalSQLDataSet.InternalOpen;
begin
  OpenDB;
  inherited;
end;

procedure TInternalSQLDataSet.OpenDB;
var
  IRows: ISQLDBRows;
  DataStream: TRawByteStringStream;
  DataRowPosition: TCardinalDynArray;
begin
  DataRowPosition := nil;
  IRows := FConnection.Execute(FCommandText, []);
  DataStream := TRawByteStringStream.Create;
  try
    IRows.Instance.FetchAllToBinary(DataStream, 0, @DataRowPosition);
    fData := DataStream.DataString;

    fDataAccess := TSQLDBProxyStatementRandomAccess.Create(
      pointer(fData), length(fData), @DataRowPosition);
  finally
    DataStream.Free;
  end;
  //IRows := nil;
end;

function TInternalSQLDataSet.PSExecuteStatement(const ASQL: string;
  AParams: TParams): Integer;
var
  SQLText: String;
  ParamCount: Integer;
  I: Integer;
  Stmt: ISQLDBStatement;
begin
  Result := 0;
  if (AParams <> nil) and (AParams.Count > 0) then
  begin
    SQLText := FixParams(ASQL, AParams.Count, FConnection.GetQuoteChar);
    ParamCount := AParams.Count;
  end
  else
  begin
    SQLText := ASQL.Substring(0, ASQL.Length);
    ParamCount := 0;
  end;
  if ParamCount = 0 then
    Result := FConnection.ExecuteNoResult(SQLText, [])
  else begin
    Stmt := FConnection.NewThreadSafeStatementPrepared(ASQL, false, true);
    FConnection.StoreVoidStringAsNull := False;
    for I := 0 to AParams.Count - 1 do
    begin
      case AParams[i].DataType of
        ftInteger, ftLargeInt:
          Stmt.Bind(I + 1, AParams[i].AsInteger);
        ftDateTime:
          Stmt.BindDateTime(I + 1, AParams[i].AsDateTime);
        ftFloat:
          Stmt.Bind(I + 1, AParams[i].AsFloat);
        ftString:
          Stmt.BindTextS(I + 1, AParams[i].AsString);
        ftWideString, ftMemo:
          //Stmt.BindTextW(I + 1, AParams[i].AsWideString);
          Stmt.BindTextS(I + 1, AParams[i].AsString);
        else
          raise Exception.Create('not defined!');
      end;
    end;
    //Result := FConnection.ExecuteNoResult(SQLText, Args);
    //Stmt.Bind(Params);
    Stmt.ExecutePrepared;
    try
      result := Stmt.UpdateCount;
    except // may occur e.g. for Firebird's CREATE DATABASE
      result := 0;
    end;
  end;
end;

function TInternalSQLDataSet.PSGetTableName: string;
begin
  Result := GetTableNameFromSQLEx(CommandText, idMixCase);
end;

function TInternalSQLDataSet.PSIsSQLBased: Boolean;
begin
  Result := True;
end;

function TInternalSQLDataSet.PSIsSQLSupported: Boolean;
begin
  Result := True;
end;

procedure TInternalSQLDataSet.PSSetCommandText(const ACommandText: string);
begin
  inherited;
  FCommandText := ACommandText;
end;

function TInternalSQLDataSet.PSUpdateRecord(UpdateKind: TUpdateKind;
  Delta: TDataSet): Boolean;
begin
  Result := False;
end;

{ TInternalConnection }

function TInternalConnection.GetQuoteChar: string;
begin
  {
  if Assigned(MetaData) then
    Result := MetaData.QuoteChar
  else
    Result := '"';
  FQuoteChar := Result;
  }
  Result := '"';
end;

end.

function TSynVirtualDataSet.CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream;
begin
  if Mode<>bmRead then
    raise EDatabaseError.CreateFmt('%s BLOB should be ReadOnly',[ClassName]);
  result := GetBlobStream(Field,PRecInfo(ActiveBuffer).RowIndentifier);
  if result = nil then // Murat
    result := TMemoryStream.Create;
end;

  AConnection := TInternalConnection.Create(EditHostName.Text + ':' + EditPort.Text, 'remote', 'username', 'password');
  ADataSet := TPiCustomClientDataSet.Create(nil);
  ADataSet.Connection := AConnection;
  ADataSet.Close;
  ADataSet.CommandText := Memo1.Text;
  ADataSet.Open;

FPiClientDataSet.ApplyUpdates(0);