mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-06-02 05:22:36 +02:00
415 lines
11 KiB
ObjectPascal
415 lines
11 KiB
ObjectPascal
{$mode objfpc}
|
|
{$h+}
|
|
|
|
unit SQLitedb;
|
|
|
|
interface
|
|
|
|
uses Classes,strings,sqlite;
|
|
|
|
type
|
|
TSQLiteExecCallback = function(Sender: pointer; Columns: Integer; ColumnValues: ppchar; ColumnNames: ppchar): 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: Pointer; Columns: Integer; ColumnValues: PPChar; ColumnNames: PPchar): integer; cdecl;
|
|
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);
|
|
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.
|