freepascal.compiler/fcl/db/sqldb/sqldb.pp

{   $Id$

    Copyright (c) 2004 by Joost van der Sluis


    SQL database & dataset

    See the file COPYING.FPC, included in this distribution,
    for details about the copyright.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

 **********************************************************************}

unit sqldb;

{$mode objfpc}
{$H+}
{$M+}   // ### remove this!!!

interface

uses SysUtils, Classes, DB;

type
  TSQLConnection = class;
  TSQLTransaction = class;
  TSQLQuery = class;

  TStatementType = (stNone, stSelect, stInsert, stUpdate, stDelete,
    stDDL, stGetSegment, stPutSegment, stExecProcedure,
    stStartTrans, stCommit, stRollback, stSelectForUpd);

  TSQLHandle = Class(TObject)
    protected
    StatementType       : TStatementType;
  end;


const
 StatementTokens : Array[TStatementType] of string = ('(none)', 'select',
                  'insert', 'update', 'delete',
                  'create', 'get', 'put', 'execute',
                  'start','commit','rollback', '?'
                 );


{ TSQLConnection }
type
  TSQLConnection = class (TDatabase)
  private
    FPassword            : string;
    FTransaction         : TSQLTransaction;
    FUserName            : string;
    FHostName            : string;
    FCharSet             : string;
    FRole                : String;
    
    procedure SetTransaction(Value : TSQLTransaction);
  protected
    procedure DoInternalConnect; override;
    procedure DoInternalDisconnect; override;
    function GetAsSQLText(Field : TField) : string; virtual;
    function GetHandle : pointer; virtual; abstract;

    Function AllocateCursorHandle : TSQLHandle; virtual; abstract;
    Function AllocateTransactionHandle : TSQLHandle; virtual; abstract;

    procedure FreeStatement(cursor : TSQLHandle); virtual; abstract;
    procedure PrepareStatement(cursor: TSQLHandle;ATransaction : TSQLTransaction;buf : string); virtual; abstract;
    procedure FreeFldBuffers(cursor : TSQLHandle); virtual; abstract;
    procedure Execute(cursor: TSQLHandle;atransaction:tSQLtransaction); virtual; abstract;
    procedure AddFieldDefs(cursor: TSQLHandle; FieldDefs : TfieldDefs); virtual; abstract;
    function Fetch(cursor : TSQLHandle) : boolean; virtual; abstract;
    function LoadField(cursor : TSQLHandle;FieldDef : TfieldDef;buffer : pointer) : boolean; virtual; abstract;
    function GetTransactionHandle(trans : TSQLHandle): pointer; virtual; abstract;
    function Commit(trans : TSQLHandle) : boolean; virtual; abstract;
    function RollBack(trans : TSQLHandle) : boolean; virtual; abstract;
    function StartdbTransaction(trans : TSQLHandle) : boolean; virtual; abstract;
    procedure CommitRetaining(trans : TSQLHandle); virtual; abstract;
    procedure RollBackRetaining(trans : TSQLHandle); virtual; abstract;
  public
    destructor Destroy; override;
    property Handle: Pointer read GetHandle;
  published
    property Password : string read FPassword write FPassword;
    property Transaction : TSQLTransaction read FTransaction write SetTransaction;
    property UserName : string read FUserName write FUserName;
    property CharSet : string read FCharSet write FCharSet;
    property HostName : string Read FHostName Write FHostName;

    property Connected;
    Property Role :  String read FRole write FRole;
    property DatabaseName;
    property KeepConnection;
    property LoginPrompt;
    property Params;
    property OnLogin;
  end;

{ TSQLTransaction }

  TCommitRollbackAction = (caNone, caCommit, caCommitRetaining, caRollback,
    caRollbackRetaining);

  TSQLTransaction = class (TDBTransaction)
  private
    FTrans               : TSQLHandle;
    FAction              : TCommitRollbackAction;
  protected
    function GetHandle : Pointer; virtual;
  public
    procedure Commit; virtual;
    procedure CommitRetaining; virtual;
    procedure Rollback; virtual;
    procedure RollbackRetaining; virtual;
    procedure StartTransaction; override;
    constructor Create(AOwner : TComponent); override;
    destructor Destroy; override;
    property Handle: Pointer read GetHandle;
    procedure EndTransaction; override;
  published
    property Action : TCommitRollbackAction read FAction write FAction;
    property Database;
  end;

{ TSQLQuery }

  TSQLQuery = class (Tbufdataset)
  private
    FCursor              : TSQLHandle;
    FUpdateable          : boolean;
    FTableName           : string;
    FSQL                 : TStrings;
    FIsEOF               : boolean;
    FLoadingFieldDefs    : boolean;

    procedure FreeStatement;
    procedure PrepareStatement;
    procedure FreeFldBuffers;
    procedure InitUpdates(SQL : string);

    procedure Execute;

  protected
    // abstract & virual methods of TBufDataset
    function Fetch : boolean; override;
    function LoadField(FieldDef : TFieldDef;buffer : pointer) : boolean; override;
    // abstract & virual methods of TDataset
    procedure SetDatabase(Value : TDatabase); override;
    procedure InternalAddRecord(Buffer: Pointer; AAppend: Boolean); override;
    procedure InternalClose; override;
    procedure InternalDelete; override;
    procedure InternalHandleException; override;
    procedure InternalInitFieldDefs; override;
    procedure InternalOpen; override;
    function  GetCanModify: Boolean; override;
    Function GetSQLStatementType(SQL : String) : TStatementType; virtual;
    function ApplyRecUpdate : boolean; override;
  public
    procedure ExecSQL; virtual;
    constructor Create(AOwner : TComponent); override;
    destructor Destroy; override;
  published
    // redeclared data set properties
    property Active;
//    property Filter;
//    property Filtered;
//    property FilterOptions;
    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 OnCalcFields;
    property OnDeleteError;
    property OnEditError;
    property OnFilterRecord;
    property OnNewRecord;
    property OnPostError;
    property AutoCalcFields;
    property Database;

    property Transaction;
    property SQL : TStrings read FSQL write FSQL;
  end;

implementation

uses dbconst;

{ TSQLConnection }

procedure TSQLConnection.SetTransaction(Value : TSQLTransaction);
begin
  if FTransaction = nil then
  begin
    FTransaction := Value;
    if Assigned(FTransaction) then
      FTransaction.Database := Self;
    exit;
  end;

  if (Value <> FTransaction) and (Value <> nil) then
    if (not FTransaction.Active) then
    begin
      FTransaction := Value;
      FTransaction.Database := Self;
    end
    else
      DatabaseError(SErrAssTransaction);
end;

procedure TSQLConnection.DoInternalConnect;
begin
// Where is this for?!?!
//  if Connected then
//    Close;
end;

procedure TSQLConnection.DoInternalDisconnect;
begin
end;

destructor TSQLConnection.Destroy;
begin
  inherited Destroy;
end;

function TSQLConnection.GetAsSQLText(Field : TField) : string;

begin
  if not assigned(field) then Result := 'Null'
  else case field.DataType of
    ftString : Result := '''' + field.asstring + ''''
  else
    Result := field.asstring;
  end; {case}
end;


{ TSQLTransaction }
procedure TSQLTransaction.EndTransaction;

begin
  rollback;
end;

function TSQLTransaction.GetHandle: pointer;
begin
  Result := (Database as tsqlconnection).GetTransactionHandle(FTrans);
end;

procedure TSQLTransaction.Commit;
begin
  if active then
    begin
    closedatasets;
    if (Database as tsqlconnection).commit(FTrans) then
      begin
      closeTrans;
      FreeAndNil(FTrans);
      end;
    end;
end;

procedure TSQLTransaction.CommitRetaining;
begin
  if active then
    (Database as tsqlconnection).commitRetaining(FTrans);
end;

procedure TSQLTransaction.Rollback;
begin
  if active then
    begin
    closedatasets;
    if (Database as tsqlconnection).RollBack(FTrans) then
      begin
      CloseTrans;
      FreeAndNil(FTrans);
      end;
    end;
end;

procedure TSQLTransaction.RollbackRetaining;
begin
  if active then
    (Database as tsqlconnection).RollBackRetaining(FTrans);
end;

procedure TSQLTransaction.StartTransaction;

var db : TSQLConnection;

begin
  if Active then
    DatabaseError(SErrTransAlreadyActive);

  db := (Database as tsqlconnection);

  if Db = nil then
    DatabaseError(SErrDatabasenAssigned);

  if not Db.Connected then
    Db.Open;
  if not assigned(FTrans) then FTrans := Db.AllocateTransactionHandle;

  if Db.StartdbTransaction(FTrans) then OpenTrans;
end;

constructor TSQLTransaction.Create(AOwner : TComponent);
begin
  inherited Create(AOwner);
end;

destructor TSQLTransaction.Destroy;
begin
  Rollback;
  inherited Destroy;
end;

{ TSQLQuery }
procedure TSQLQuery.SetDatabase(Value : TDatabase);

var db : tsqlconnection;

begin
  if (Database <> Value) then
    begin
    db := value as tsqlconnection;
    inherited setdatabase(value);
    if assigned(value) and (Transaction = nil) and (Assigned(db.Transaction)) then
      transaction := Db.Transaction;
    end;
end;

procedure TSQLQuery.FreeStatement;
begin
  if assigned(FCursor) then
    begin
    (Database as tsqlconnection).FreeStatement(FCursor);
//    FreeAndNil(FCursor);
    end;
end;

procedure TSQLQuery.PrepareStatement;
var
  Buf   : string;
  x     : integer;
  db    : tsqlconnection;
  sqltr : tsqltransaction;

begin
  db := (Database as tsqlconnection);
  if Db = nil then
    DatabaseError(SErrDatabasenAssigned);
  if not Db.Connected then
    db.Open;
  if Transaction = nil then
    DatabaseError(SErrTransactionnSet);

  sqltr := (transaction as tsqltransaction);
  if not sqltr.Active then sqltr.StartTransaction;

  if assigned(fcursor) then FreeAndNil(fcursor);
  FCursor := Db.AllocateCursorHandle;

  Buf := '';
  for x := 0 to FSQL.Count - 1 do
    Buf := Buf + FSQL[x] + ' ';

  if Buf='' then
    begin
    DatabaseError(SErrNoStatement);
    exit;
    end;
  FCursor.StatementType := GetSQLStatementType(buf);
  if FCursor.StatementType = stSelect then
    InitUpdates(Buf);
  Db.PrepareStatement(Fcursor,sqltr,buf);
end;

procedure TSQLQuery.FreeFldBuffers;
begin
  if assigned(FCursor) then (Database as tsqlconnection).FreeFldBuffers(FCursor);
end;

function TSQLQuery.Fetch : boolean;
begin
  if not (Fcursor.StatementType in [stSelect]) then
    Exit;

  if not FIsEof then FIsEOF := not (Database as tsqlconnection).Fetch(Fcursor);
  Result := not FIsEOF;
end;

procedure TSQLQuery.Execute;
begin
  (Database as tsqlconnection).execute(Fcursor,Transaction as tsqltransaction);
end;

function TSQLQuery.LoadField(FieldDef : TFieldDef;buffer : pointer) : boolean;

begin
  result := (Database as tSQLConnection).LoadField(FCursor,FieldDef,buffer)
end;

procedure TSQLQuery.InternalAddRecord(Buffer: Pointer; AAppend: Boolean);
begin
  // not implemented - sql dataset
end;

procedure TSQLQuery.InternalClose;
begin
  FreeFldBuffers;
  FreeStatement;
  if DefaultFields then
    DestroyFields;
  FIsEOF := False;
//  FRecordSize := 0;
  inherited internalclose;
end;

procedure TSQLQuery.InternalDelete;
begin
  // not implemented - sql dataset
end;

procedure TSQLQuery.InternalHandleException;
begin
end;

procedure TSQLQuery.InternalInitFieldDefs;
begin
  if FLoadingFieldDefs then
    Exit;

  FLoadingFieldDefs := True;

  try
    FieldDefs.Clear;

    (Database as tsqlconnection).AddFieldDefs(fcursor,FieldDefs);
  finally
    FLoadingFieldDefs := False;
  end;
end;

procedure TSQLQuery.InitUpdates(SQL : string);

Var
  L       : Integer;
  P,PP    : PChar;
  PS: PChar;
  S       : string;

  function GetStatement(var StartP : PChar) : PChar;
  
  var p        : pchar;
      Cmt, Stm : boolean;
  
  begin
    p := StartP;
    Cmt := false;
    Stm := False;
    While ((P-PP)<L) do
      begin
      if Cmt then
        begin
        end
      else if (p^ in [',',' ','(',')',#13,#10,#9]) then
        begin
        if stm then break;
        end
      else if not stm then
        begin
        StartP := p;
        stm := true;
        end;
      inc(p);
      end;
    Result := P;
  end;

begin
  FUpdateable := False;

  L:=Length(SQL);

  PP:=Pchar(SQL);
  P := pp;
  PS := pp;

// select-keyword
  P := GetStatement(PS);

  Setlength(S,P-PS);
  Move(PS^,S[1],(P-PS));
  S:=Lowercase(S);

  if (S) <> 'select' then exit;

// select-part

  While ((P-PP)<L) and  (S <> 'from') do
    begin
    repeat
    PS := P;
    P := GetStatement(PS);
    until P^ <> ',';

    Setlength(S,P-PS);
    Move(PS^,S[1],(P-PS));
    S:=Lowercase(S);

    end;

// from-part

  PS := P;
  P := GetStatement(PS);

  Setlength(FTableName,P-PS);
  Move(PS^,FTableName[1],(P-PS));

  While ((P-PP)<L)  do
    begin
    PS := P;
    P := GetStatement(PS);

    if P^ = ',' then exit; // select-statements from more then one table are not updateable

    Setlength(S,P-PS);
    Move(PS^,S[1],(P-PS));
    S:=Lowercase(S);
    
    if (s = 'where') or (s='order') then break;
    end;

  FUpdateable := True;

end;

procedure TSQLQuery.InternalOpen;
begin
  try
    PrepareStatement;
    if Fcursor.StatementType in [stSelect] then
      begin
      Execute;
      InternalInitFieldDefs;
      if DefaultFields then
        CreateFields;
      end
    else
      DatabaseError(SErrNoSelectStatement,Self);
  except
    on E:Exception do
      raise;
  end;
  inherited InternalOpen;
end;

// public part

procedure TSQLQuery.ExecSQL;
begin
  try
    PrepareStatement;
    Execute;
  finally
    FreeStatement;
  end;
end;

constructor TSQLQuery.Create(AOwner : TComponent);
begin
  inherited Create(AOwner);
  FSQL := TStringList.Create;
end;

destructor TSQLQuery.Destroy;
begin
  if Active then Close;
//  if assigned(FCursor) then FCursor.destroy;
  FreeAndNil(FSQL);
  inherited Destroy;
end;

Function TSQLQuery.GetSQLStatementType(SQL : String) : TStatementType;

Var
  L       : Integer;
  cmt     : boolean;
  P,PE,PP : PChar;
  S       : string;
  T       : TStatementType;

begin
  Result:=stNone;
  L:=Length(SQL);
  If (L=0) then
    Exit;
  P:=Pchar(SQL);
  PP:=P;
  Cmt:=False;
  While ((P-PP)<L) do
    begin
    if not (P^ in [' ',#13,#10,#9]) then
      begin
      if not Cmt then
        begin
        // Check for comment.
        Cmt:=(P^='/') and (((P-PP)<=L) and (P[1]='*'));
        if not (cmt) then
          Break;
        end
      else
        begin
        // Check for end of comment.
         Cmt:=Not( (P^='*') and (((P-PP)<=L) and (P[1]='/')) );
        If not cmt then
          Inc(p);
        end;
      end;
    inc(P);
    end;
  PE:=P+1;
  While ((PE-PP)<L) and (PE^ in ['0'..'9','a'..'z','A'..'Z','_']) do
   Inc(PE);
  Setlength(S,PE-P);
  Move(P^,S[1],(PE-P));
  S:=Lowercase(s);
  For t:=stselect to strollback do
    if (S=StatementTokens[t]) then
      Exit(t);
end;

function TSQLQuery.ApplyRecUpdate : boolean;

var r,x,f     : integer;
    fieldsstr,
    v : string;
    modify_query : tsqlquery;
    sql_tables : string;
    sql_set    : string;
    sql_where  : string;
    s : string;

begin
  Result := False;
  sql_tables := FTableName;
  s := fields[0].oldvalue;
  sql_where := '('+fields[0].displayName+'='+s+')';
  sql_set := '';
  for x := 0 to Fields.Count -1 do
    if ord(ActiveBuffer[(Fields[x].Fieldno-1) div 8]) and (1 shl ((Fields[x].Fieldno-1) mod 8)) > 0 then // check for null
      sql_set := sql_set + fields[x].DisplayName + '=' + (Database as TSQLConnection).GetAsSQLText(nil) + ','
    else
      sql_set := sql_set + fields[x].DisplayName + '=' + (Database as TSQLConnection).GetAsSQLText(fields[x]) + ',';

  setlength(sql_set,length(sql_set)-1);

  with tsqlquery.Create(nil) do
    begin
    DataBase := self.Database;
    transaction := self.transaction;
    sql.clear;
    s := 'update ' + sql_tables + ' set ' + sql_set + ' where ' + sql_where;
    sql.add(s);
    ExecSQL;
    Result := true;
    Free;
    end;
end;


Function TSQLQuery.GetCanModify: Boolean;

begin
  if FCursor.StatementType = stSelect then
    Result:= Active and  FUpdateable
  else
    Result := False;
end;

end.

{
  $Log$
  Revision 1.10  2004-12-29 14:31:27  michael
    + Patch from Joost van der Sluis:
    - implemented support for modifying queries, with a simple parser
    - implemented ApplyRecUpdate

  Revision 1.9  2004/12/13 19:22:16  michael
    * Ptahc from Joost van der Sluis
    - moved IsCursorOpen from TSQLQuery to tbufdataset
    - moved SetFieldData from TSQLQuery to TBufDataset
    - very first start for support of cached updates

  Revision 1.8  2004/12/04 22:43:38  michael
    * Patch from Joost van der Sluis
    - replaced checkactive in commit and rollback for 'if active'
    - fixed a warning
    - adapted for the changes in TBuffDataset

  Revision 1.7  2004/11/05 08:32:02  michael
  TBufDataset.inc:
    - replaced Freemem by Reallocmem, Free by FreeAndNil

  Database.inc:
    - Moved Active property from TSQLTransaction to TDBTransaction
    - Gives an error if the database of an active transaction is changed

  Dataset.inc
    - Don't distribute events if FDisableControlsCount > 0
    - Replaced FActive by FState<>dsInactive
    - Set EOF after append

  db.pp:
    - Removed duplicate definition of TAlignment
    - Moved Active property from TSQLTransaction to TDBTransaction
    - Replaced FActive by FState<>dsInactive
    - Gives an error if the database of an active transaction is changed

  sqldb:
    - Moved Active property from TSQLTransaction to TDBTransaction
    - replaced Freemem by Reallocmem, Free by FreeAndNil

  IBConnection:
    - Moved FSQLDAAllocated to the cursor

  PQConnection:
    - Don't try to free the statement if a fatal error occured

  Revision 1.6  2004/10/27 07:23:13  michael
  + Patch from Joost Van der Sluis to fix transactions

  Revision 1.5  2004/10/10 14:45:52  michael
  + Use of dbconst for resource strings

  Revision 1.4  2004/10/10 14:24:22  michael
  * Large patch from Joost Van der Sluis.
  * Float fix in interbase
  + Commit and commitretaining for pqconnection
  + Preparestatement and prepareselect joined.
  + Freestatement and FreeSelect joined
  + TSQLQuery.GetSQLStatementType implemented
  + TBufDataset.AllocBuffer now no longer does a realloc
  + Fetch=True means succesfully got data. False means end of data.
  + Default implementation of GetFieldData implemented/

  Revision 1.3  2004/10/02 14:52:25  michael
  + Added mysql connection

  Revision 1.2  2004/09/26 16:56:32  michael
  + Further fixes from Joost van der sluis for Postgresql

  Revision 1.1  2004/08/31 09:49:47  michael
  + initial implementation of TSQLQuery

}