|
|
@@ -0,0 +1,494 @@
|
|
|
+{$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.
|
daniel