freepascal.compiler/packages/base/sqlite/sqlite3db.pas

{$mode objfpc}
{$h+}
{*************************************************************
SQLite3 Object Oriented handle
O. Rinaudo - 2005 - [email protected]
G. Marcou  - 2007 - [email protected]
*************************************************************}

unit SQLite3db;

interface

uses  Classes,strings,sqlite3;
{*************************************************************}
{*************************************************************}
type
   TSQLiteExecCallback = function(Sender: pointer; Columns: Integer; ColumnValues: ppchar; ColumnNames: ppchar): integer of object; cdecl;
   TSQLiteBusyCallback = function(Sender: TObject; BusyCount: integer): longint of object; cdecl;
   TOnData = Procedure(Sender: TObject; Columns: Integer; ColumnNames, ColumnValues: String)  of object;
   TOnBusy = Procedure(Sender: TObject; BusyCount: integer; var Cancel: Boolean) of object;
   TOnQueryComplete = Procedure(Sender: TObject) of object;

   TSQLite = class(TObject)
{*************************************************************}
{*************************************************************}   
   private
   fPSQlite: PPsqlite3;
   fSQLite:Psqlite3;
   fMsg: String;
   fIsOpen: Boolean;
   fBusy: Boolean;
   fError: longint;
   fVersion: String;
   fEncoding: String;
   fTable: TStrings;
   fLstName: TStringList;
   fLstVal: TStringList;
   fOnData: TOnData;
   fOnBusy: TOnBusy;
   fOnQueryComplete: TOnQueryComplete;
   fBusyTimeout: longint;
   fPMsg: PChar;
   fChangeCount: longint;
   fNb_Champ :  Integer;
   fList_FieldName : TStringList;
   fList_Field : TList;
   procedure SetBusyTimeout(Timeout: integer);
{*************************************************************}
{*************************************************************}   
   public
   constructor Create(DBFileName: String);
   destructor Destroy; override;
   function Query(Sql: String; Table: TStrings ): boolean;
   function ErrorMessage(ErrNo: Integer): string;
   function IsComplete(Sql: String): boolean;
   function LastInsertRow: integer;
   function Cancel: boolean;
   function DatabaseDetails(Table: TStrings): boolean;
   property LastErrorMessage: string read fMsg;
   property LastError: longint read fError;
   property Version: String read fVersion;
   property Encoding: String read fEncoding;
   property OnData: TOnData read fOnData write fOnData;
   property OnBusy: TOnBusy read fOnBusy write fOnBusy;
   property OnQueryComplete: TOnQueryComplete read fOnQueryComplete write fOnQueryComplete;
   property BusyTimeout: longint read fBusyTimeout write SetBusyTimeout;
   property ChangeCount: longint read fChangeCount;
   property List_FieldName: TStringList read fList_FieldName write fList_FieldName;
   property List_Field: TList read fList_Field write fList_Field;
   property Nb_Champ: integer read fNb_Champ write fNb_Champ;
 procedure SQLOnData(Sender: TObject; Columns: Integer; ColumnNames, ColumnValues: String);

 end;
function Pas2SQLStr(const PasString: string): string;
function SQL2PasStr(const SQLString: string): string;
function QuoteStr(const s: string; QuoteChar: Char ): string;
function UnQuoteStr(const s: string; QuoteChar: Char ): string;
procedure ValueList(const ColumnNames, ColumnValues: String; NameValuePairs: TStrings);
{*************************************************************}
{*************************************************************}
implementation
Const
   DblQuote: Char      = '"';
   SngQuote: Char      = #39;
   DblSngQuote: String = #39#39;
   Crlf: String	       = #13#10;
   Tab: Char	       = #9;
var
   MsgNoError : String;
{*************************************************************}
{*************************************************************}
function QuoteStr(const s: string; QuoteChar: Char ): string;
{*************************************************************
SQlite3 enclosing string with quotes
G. Marcou
*************************************************************}
begin
   Result := Concat(QuoteChar, s, QuoteChar);
end;
{*************************************************************}
function UnQuoteStr(const s: string; QuoteChar: Char ): string;
{*************************************************************
SQlite3 Remove enclosing quotes from string
G. Marcou
*************************************************************}
begin
   Result := s;
   if length(Result) > 1 then
   begin
      if Result[1] = QuoteChar then
	 Delete(Result, 1, 1);
      if Result[Length(Result)] = QuoteChar then
	 Delete(Result, Length(Result), 1);
   end;
end;
{*************************************************************}
function Pas2SQLStr(const PasString: string): string;
{*************************************************************
SQlite3 SQL string are use double quotes, Pascal string use
single quote.
G. Marcou
*************************************************************}
var
   n : integer;
begin
   Result := SQL2PasStr(PasString);
   n := Length(Result);
   while n > 0 do
   begin
      if Result[n] = SngQuote then
	 Insert(SngQuote, Result, n);
      dec(n);
   end;
   Result := QuoteStr(Result,SngQuote);
end;
{*************************************************************}
function SQL2PasStr(const SQLString: string): string;
{*************************************************************
SQlite3 SQL string are use double quotes, Pascal string use
single quote.
G. Marcou
*************************************************************}
var
   p : integer;
begin
   Result := SQLString;
   p := pos(DblSngQuote, Result);
   while p > 0 do
   begin
      Delete(Result, p, 1);
      p := pos(DblSngQuote, Result);
   end;
   Result := UnQuoteStr(Result,SngQuote);
end;
{*************************************************************}
procedure ValueList(const ColumnNames, ColumnValues : String;
NameValuePairs					    : TStrings);
{*************************************************************
SQlite3 build (name=value) pair list
G. Marcou
*************************************************************}
var
   n		     : integer;
   lstName, lstValue : TStringList;
begin		     
   if NameValuePairs <> nil then
   begin
      lstName := TStringList.Create;
      lstValue := TStringList.Create;
      lstName.CommaText := ColumnNames;
      lstValue.CommaText := ColumnValues;
      NameValuePairs.Clear;
      if lstName.Count = LstValue.Count then
	 if lstName.Count > 0 then
	    for n := 0 to lstName.Count - 1 do
	       NameValuePairs.Append(Concat(lstName.Strings[n], '=', lstValue.Strings[n]));
      lstValue.Free;
      lstName.Free;
   end;
end;
{*************************************************************}
{function SystemErrorMsg(ErrNo: Integer ): String;
var
  buf: PChar;
  size: Integer;
  MsgLen: Integer;
begin}
{  size := 256;
  GetMem(buf, size);
  If ErrNo = - 1 then
    ErrNo := GetLastError;
  MsgLen := FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil, ErrNo, 0, buf, size, nil);
  if MsgLen = 0 then
    Result := 'ERROR'
  else
    Result := buf;}
{end;}
{*************************************************************}
function BusyCallback(Sender : pointer;
BusyCount		     : integer): longint; cdecl;
{*************************************************************
SQlite3 busy callback 
G. Marcou
*************************************************************}
var
  bCancel: Boolean;
begin
  Result := -1;
  with TObject(Sender) as TSQLite do
  begin
    if Assigned(fOnBusy) then
    begin
      bCancel := False;
      fOnBusy(Tobject(Sender), BusyCount, bCancel);
      if bCancel then
        Result := 0;
    end;
  end;
end;
{*************************************************************}
function ExecCallback(Sender : Pointer;
Columns			     : Integer;
ColumnValues		     : PPChar;
ColumnNames		     : PPchar): integer; cdecl;
{*************************************************************
SQlite3 Build table and data from callback
G. Marcou
*************************************************************}
var
   PVal, PName : ^PChar;
   n	       : integer;
   sVal, sName : String;
begin
   Result := 0;
   with TObject(Sender) as TSQLite do
   begin
      if (Assigned(fOnData) or Assigned(fTable)) then
      begin
	 fLstName.Clear;
	 fLstVal.Clear;
	 if Columns > 0 then
	 begin
	    PName := ColumnNames;
	    PVal := ColumnValues;
	    for n := 0 to Columns - 1 do
	    begin
	       fLstName.Append(PName^);
	       fLstVal.Append(PVal^);
	       inc(PName);
	       inc(PVal);
	    end;
	 end;
	 sVal := fLstVal.CommaText;
	 sName := fLstName.CommaText;
	 if Assigned(fOnData) then
	    fOnData(TObject(Sender), Columns, sName, sVal);
	 if Assigned(fTable) then
	 begin
	    if fTable.Count = 0 then
	       fTable.Append(sName);
	    fTable.Append(sVal);
	 end;
      end;
   end;
end;
{*************************************************************}
procedure TSQLite.SQLOnData(Sender : TObject;
Columns				   : Integer;
ColumnNames, ColumnValues	   : String);
{*************************************************************
SQlite3 Fill up field list names and field list values
G. Marcou
*************************************************************}
Var
   InterS,val : String;
   Field      : TStringList;
   {************************************************}
   function Pos1(a: String ; s : char) : integer;
   var i,j : Integer;
   begin
      j:=-1;
      for i:=1 to length(a) Do
      begin
	 if a[i] = s then
	 begin
	    j:=i;
	    break;
	 end;
      end;
      result:=j;
   end; { Pos1 }
   {*************************************************}
begin
   If Nb_Champ = -1 Then
   Begin {Put the fields name in List_FieldName}
      Nb_Champ:=Columns;
      InterS:=ColumnNames;
      While (Pos1(InterS,',') > 0)  do
      begin
	 val:=copy(InterS,1,Pos1(InterS,',')-1);
	 InterS:=copy(InterS,Pos1(InterS,',')+1,length(InterS));
	 List_FieldName.add(val);
      end;
      if length(InterS) > 0 then List_FieldName.add(InterS);
   end;
   {Put the list of TStringList of value}
   Field :=TStringList.Create;
        InterS:=ColumnValues;
   While (Pos1(InterS,',') > 0)  do
   begin
      val:=copy(InterS,1,Pos1(InterS,',')-1);
      InterS:=copy(InterS,Pos1(InterS,',')+1,length(InterS));
      Field.add(val);
   end;
   if length(InterS) > 0 then Field.add(InterS);
   List_Field.add(Field);
end;
{*************************************************************}
constructor TSQLite.Create(DBFileName: String);
{*************************************************************
SQlite3 constructor
G. Marcou
*************************************************************}
var
   name	  : pchar;
begin	  
   inherited Create;
   List_FieldName := TStringList.Create;
   List_Field := TList.Create;
   fError := SQLITE_ERROR;
   fIsOpen := False;
   fLstName := TStringList.Create;
   fLstVal := TStringList.Create;
   fOnData := nil;
   fOnBusy := nil;
   fOnQueryComplete := nil;
   fChangeCount := 0;
   name:=StrAlloc (length(DBFileName)+1);
   strpcopy(name,DBFileName);
   OnData:=@SQLOnData;
   writeln('Try to open');
   sqlite3_open(name,@fSQLite);
   writeln('Open success');
   sqlite3_free(fPMsg);
   writeln('Free memory');
   if fSQLite <> nil then
   begin
      //fVersion := String(SQLite_Version);
      //fEncoding := SQLite_Encoding;
      fIsOpen := True;
      fError := SQLITE_OK;
   end;
   fMsg := sqlite3_errmsg(fSQLite);
end;
{*************************************************************}
destructor TSQLite.Destroy;
{*************************************************************
SQLite3 destructor
G. Marcou
*************************************************************}
begin
   if fIsOpen then
      fError:=sqlite3_close(fSQLite);
   fIsOpen := False;
   fLstName.Free;
   fLstVal.Free;
   fSQLite := nil;
   fOnData := nil;
   fOnBusy := nil;
   fOnQueryComplete := nil;
   fLstName := nil;
   fLstVal := nil;
   List_FieldName.destroy;
   List_Field.destroy;
   inherited Destroy;
end;
{*************************************************************}
function TSQLite.Query(Sql: String; Table: TStrings ): boolean;
{*************************************************************
SQLite3 query the database
G. Marcou
*************************************************************}
//var
//  fPMsg: PChar;
//var Psql : pchar;
begin
   fError := SQLITE_ERROR;
   if fIsOpen then
   begin
      fPMsg := nil;
      fBusy := True;
      fTable := Table;
      if fTable <> nil then
	 fTable.Clear;
      List_FieldName.clear;
      List_Field.clear;
      Nb_Champ:=-1;
      fError := sqlite3_exec(fSQLite, PChar(sql), @ExecCallback, Self, @fPMsg);
      sqlite3_free(fPMsg);
      fChangeCount := sqlite3_changes(fSQLite);
      fTable := nil;
      fBusy := False;
      if Assigned(fOnQueryComplete) then
	 fOnQueryComplete(Self);
   end;
   fMsg := ErrorMessage(fError);
   Result := (fError = SQLITE_OK);
end;
{*************************************************************}
function TSQLite.Cancel: boolean;
{*************************************************************
SQLite3 interrupt database
G. Marcou
*************************************************************}
begin
   Result := False;
   if fBusy and fIsOpen then
   begin
      sqlite3_interrupt(fSQLite);
      fBusy := false;
      Result := True;
   end;
end;
{*************************************************************}
procedure TSQLite.SetBusyTimeout(Timeout: Integer);
{*************************************************************
SQLite3 busy timeout
G. Marcou
*************************************************************}
begin
   fBusyTimeout := Timeout;
   if fIsOpen then
   begin
      fError:=sqlite3_busy_timeout(fSQLite, fBusyTimeout);
      if fBusyTimeout > 0 then
	 sqlite3_busy_handler(fSQLite, @BusyCallback, Self)
      else
	 sqlite3_busy_handler(fSQLite, nil, nil);
   end;
end;
{*************************************************************}
function TSQLite.LastInsertRow: longint;
{*************************************************************
SQLite3 Get ID of the last inserted row
G. Marcou
*************************************************************}
begin
  if fIsOpen then
    Result := sqlite3_last_insert_rowid(fSQLite)
  else
    Result := -1;
end;
{*************************************************************}
function TSQLite.ErrorMessage(ErrNo: Integer): string;
{*************************************************************
SQLite3 Return comprehensive error message
G. Marcou
*************************************************************}
begin
  if ErrNo = 0 then
    Result := MsgNoError
  else
    Result := sqlite3_errmsg(fSQLite);
end;
{*************************************************************}
function TSQLite.IsComplete(Sql: String): boolean;
{*************************************************************
SQLite3 Return true when complete
G. Marcou
*************************************************************}
var Psql : pchar;
begin
   Psql:=StrAlloc (length(Sql)+1);
   strpcopy(Psql,Sql);
//   Writeln('Testing: ',psql);
   Result := sqlite3_complete(Psql)<>0;
   strdispose(Psql);
end;
{*************************************************************}
function TSQLite.DatabaseDetails(Table: TStrings): boolean;
{*************************************************************
SQLite3 Query the database
G. Marcou
*************************************************************}
begin
  Result := Query('SELECT * FROM SQLITE_MASTER;', Table);
end;
{*************************************************************}
{*************************************************************}
initialization

finalization

end.