diff options
Diffstat (limited to 'packages/sqlite/src/sqlite3db.pas')
| -rw-r--r-- | packages/sqlite/src/sqlite3db.pas | 494 |
1 files changed, 494 insertions, 0 deletions
diff --git a/packages/sqlite/src/sqlite3db.pas b/packages/sqlite/src/sqlite3db.pas new file mode 100644 index 0000000000..a7625b00db --- /dev/null +++ b/packages/sqlite/src/sqlite3db.pas @@ -0,0 +1,494 @@ +{$mode objfpc} +{$h+} +{************************************************************* +SQLite3 Object Oriented handle +O. Rinaudo - 2005 - orinaudo@gmail.com +G. Marcou - 2007 - g.marcou@chimie.u-strasbg.fr +*************************************************************} + +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. |