mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-20 11:29:27 +02:00
+ Original test examples and class included
This commit is contained in:
michael
parent
3095aa7d25
commit
c7b339b3ce
414
packages/base/sqlite/sqlitedb.pas
Normal file
414
packages/base/sqlite/sqlitedb.pas
Normal file
@ -0,0 +1,414 @@
|
||||
{$mode objfpc}
|
||||
{$h+}
|
||||
|
||||
unit SQLitedb;
|
||||
|
||||
interface
|
||||
|
||||
uses Classes,strings,sqlite;
|
||||
|
||||
type
|
||||
TSQLiteExecCallback = function(Sender: TObject; Columns: Integer; ColumnValues: Pointer; ColumnNames: Pointer): integer of object; cdecl;
|
||||
TSQLiteBusyCallback = function(Sender: TObject; ObjectName: PChar; BusyCount: integer): integer of object; cdecl;
|
||||
TOnData = Procedure(Sender: TObject; Columns: Integer; ColumnNames, ColumnValues: String) of object;
|
||||
TOnBusy = Procedure(Sender: TObject; ObjectName: String; BusyCount: integer; var Cancel: Boolean) of object;
|
||||
TOnQueryComplete = Procedure(Sender: TObject) of object;
|
||||
|
||||
TSQLite = class(TObject)
|
||||
private
|
||||
fSQLite: Pointer;
|
||||
fMsg: String;
|
||||
fIsOpen: Boolean;
|
||||
fBusy: Boolean;
|
||||
fError: Integer;
|
||||
fVersion: String;
|
||||
fEncoding: String;
|
||||
fTable: TStrings;
|
||||
fLstName: TStringList;
|
||||
fLstVal: TStringList;
|
||||
fOnData: TOnData;
|
||||
fOnBusy: TOnBusy;
|
||||
fOnQueryComplete: TOnQueryComplete;
|
||||
fBusyTimeout: integer;
|
||||
fPMsg: PChar;
|
||||
fChangeCount: integer;
|
||||
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: Integer 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: Integer read fBusyTimeout write SetBusyTimeout;
|
||||
property ChangeCount: Integer 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;
|
||||
Crlf: String = #13#10;
|
||||
Tab: Char = #9;
|
||||
|
||||
var
|
||||
MsgNoError: String;
|
||||
|
||||
function QuoteStr(const s: string; QuoteChar: Char ): string;
|
||||
begin
|
||||
Result := Concat(QuoteChar, s, QuoteChar);
|
||||
end;
|
||||
|
||||
function UnQuoteStr(const s: string; QuoteChar: Char ): string;
|
||||
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;
|
||||
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,#39);
|
||||
end;
|
||||
|
||||
function SQL2PasStr(const SQLString: string): string;
|
||||
const
|
||||
DblSngQuote: String = #39#39;
|
||||
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,#39);
|
||||
end;
|
||||
|
||||
procedure ValueList(const ColumnNames, ColumnValues: String; NameValuePairs: TStrings);
|
||||
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; ObjectName: PChar; BusyCount: integer): integer; cdecl;
|
||||
var
|
||||
sObjName: String;
|
||||
bCancel: Boolean;
|
||||
begin
|
||||
Result := -1;
|
||||
with TObject(Sender) as TSQLite do
|
||||
begin
|
||||
if Assigned(fOnBusy) then
|
||||
begin
|
||||
bCancel := False;
|
||||
sObjName := ObjectName;
|
||||
fOnBusy(Tobject(Sender), sObjName, BusyCount, bCancel);
|
||||
if bCancel then
|
||||
Result := 0;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function ExecCallback(Sender: TObject; Columns: Integer; ColumnValues: Pointer; ColumnNames: Pointer): integer; cdecl;
|
||||
var
|
||||
PVal, PName: ^PChar;
|
||||
n: integer;
|
||||
sVal, sName: String;
|
||||
begin
|
||||
Result := 0;
|
||||
with 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(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);
|
||||
Var i : Integer;
|
||||
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;
|
||||
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);
|
||||
var
|
||||
fPMsg1: PChar;
|
||||
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;
|
||||
fSQLite := SQLite_Open(name, 1, @fPMsg);
|
||||
SQLite_FreeMem(fPMsg);
|
||||
if fSQLite <> nil then
|
||||
begin
|
||||
//fVersion := String(SQLite_Version);
|
||||
//fEncoding := SQLite_Encoding;
|
||||
fIsOpen := True;
|
||||
fError := SQLITE_OK;
|
||||
end;
|
||||
fMsg := ErrorMessage(fError);
|
||||
end;
|
||||
|
||||
destructor TSQLite.Destroy;
|
||||
begin
|
||||
if fIsOpen then
|
||||
SQLite_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;
|
||||
//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;
|
||||
Psql:=StrAlloc (length(Sql)+1);
|
||||
strpcopy(Psql,Sql);
|
||||
List_FieldName.clear;
|
||||
List_Field.clear;
|
||||
Nb_Champ:=-1;
|
||||
fError := SQLite_Exec(fSQLite, Psql, @ExecCallback, Self, @fPMsg);
|
||||
strdispose(Psql);
|
||||
SQLite_FreeMem(fPMsg);
|
||||
fChangeCount := SQLite_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;
|
||||
begin
|
||||
Result := False;
|
||||
if fBusy and fIsOpen then
|
||||
begin
|
||||
do_SQLite_interrupt(fSQLite);
|
||||
fBusy := false;
|
||||
Result := True;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TSQLite.SetBusyTimeout(Timeout: Integer);
|
||||
begin
|
||||
fBusyTimeout := Timeout;
|
||||
if fIsOpen then
|
||||
begin
|
||||
SQLite_Busy_Timeout(fSQLite, fBusyTimeout);
|
||||
if fBusyTimeout > 0 then
|
||||
SQLite_Busy_Handler(fSQLite, @BusyCallback, Self)
|
||||
else
|
||||
SQLite_Busy_Handler(fSQLite, nil, nil);
|
||||
end;
|
||||
end;
|
||||
|
||||
function TSQLite.LastInsertRow: integer;
|
||||
begin
|
||||
if fIsOpen then
|
||||
Result := SQLite_Last_Insert_RowID(fSQLite)
|
||||
else
|
||||
Result := -1;
|
||||
end;
|
||||
|
||||
function TSQLite.ErrorMessage(ErrNo: Integer): string;
|
||||
begin
|
||||
exit;
|
||||
if ErrNo = 0 then
|
||||
Result := MsgNoError
|
||||
else
|
||||
Result := SQLite_Error_String(ErrNo);
|
||||
end;
|
||||
|
||||
function TSQLite.IsComplete(Sql: String): boolean;
|
||||
var Psql : pchar;
|
||||
begin
|
||||
Psql:=StrAlloc (length(Sql)+1);
|
||||
strpcopy(Psql,Sql);
|
||||
Writeln('Testing: ',psql);
|
||||
Result := SQLite_Complete(Psql)<>0;
|
||||
strdispose(Psql);
|
||||
end;
|
||||
|
||||
function TSQLite.DatabaseDetails(Table: TStrings): boolean;
|
||||
begin
|
||||
Result := Query('SELECT * FROM SQLITE_MASTER;', Table);
|
||||
end;
|
||||
|
||||
initialization
|
||||
|
||||
finalization
|
||||
|
||||
end.
|
||||
53
packages/base/sqlite/test.pas
Normal file
53
packages/base/sqlite/test.pas
Normal file
@ -0,0 +1,53 @@
|
||||
program test;
|
||||
uses sqlite,sqlitedb, strings,classes;
|
||||
|
||||
|
||||
|
||||
var
|
||||
MySQL: TSQLite;
|
||||
SQL: String;
|
||||
i,j : Integer;
|
||||
a : TStringList;
|
||||
begin
|
||||
Writeln('Creating class');
|
||||
MySQL := TSQLite.Create('test.db');
|
||||
MySQL.BusyTimeout := 1000;
|
||||
|
||||
// writeln(MySQL.Version);
|
||||
Writeln('Creating table');
|
||||
SQL := 'CREATE TABLE Test(No int, Nom varchar(32),Prenom varchar(32));';
|
||||
MySQL.Query(sql, nil);
|
||||
SQL := 'INSERT INTO Test VALUES(1,''Coursiere'', ''Olivier'');';
|
||||
if MySQL.IsComplete(sql) then
|
||||
begin
|
||||
Writeln('Inserting first row');
|
||||
MySQL.Query(sql, nil);
|
||||
end;
|
||||
SQL := 'INSERT INTO Test VALUES(2,''Jourde'', ''Eric'');';
|
||||
if MySQL.IsComplete(sql) then
|
||||
begin
|
||||
Writeln('Inserting second row') ;
|
||||
MySQL.Query(sql, nil);
|
||||
end;
|
||||
Writeln('Selecting rows') ;
|
||||
|
||||
SQL := 'SELECT * FROM Test;';
|
||||
MySQL.Query(sql, nil);
|
||||
writeln('Fields Names -------------------');
|
||||
for i:=0 to MySQL.List_FieldName.count-1 do
|
||||
writeln(i,' -> ',MySQL.List_FieldName.Strings[i]);
|
||||
writeln('Fields -------------------');
|
||||
for i:=0 to MySQL.List_Field.count-1 do
|
||||
begin
|
||||
a:=TStringList(MySQL.List_Field.items[i]);
|
||||
write(i,' -> ');
|
||||
for j:=0 to a.count-1 do
|
||||
write(a.Strings[j],' ');
|
||||
writeln('');
|
||||
end;
|
||||
|
||||
// Uncomment to remove table again.
|
||||
// SQL := 'DROP TABLE Test;';
|
||||
// MySQL.Query(sql, nil);
|
||||
MySQL.Free;
|
||||
end.
|
||||
Loading…
Reference in New Issue
Block a user