unit customsqliteds; { This is TCustomSqliteDataset, a TDataset descendant class for use with fpc compiler Copyright (C) 2004 Luiz Américo Pereira Câmara Email: pascalive@bol.com.br This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA } {$Mode ObjFpc} {$H+} { $Define USE_SQLITEDS_INTERNALS} { $Define DEBUG} { $Define DEBUGACTIVEBUFFER} interface uses Classes, SysUtils, Db; type PDataRecord = ^DataRecord; PPDataRecord = ^PDataRecord; DataRecord = record Row: PPchar; BookmarkFlag: TBookmarkFlag; Next: PDataRecord; Previous: PDataRecord; end; TDSStream = class(TStream) private FActiveItem:PDataRecord; FFieldRow:PChar; FFieldIndex:Integer; FRowSize: Integer; FPosition: Longint; public constructor Create(const ActiveItem: PDataRecord; FieldIndex:Integer); function Write(const Buffer; Count: Longint): Longint; override; function Read(var Buffer; Count: Longint): Longint; override; function Seek(Offset: Longint; Origin: Word): Longint; override; end; TSqliteCallback = function (UserData:Pointer; Columns:longint; Values:PPchar; ColumnNames:PPchar):longint;cdecl; { TCustomSqliteDataset } TCustomSqliteDataset = class(TDataSet) private FPrimaryKey: String; FPrimaryKeyNo: Integer; {$ifdef DEBUGACTIVEBUFFER} FFCurrentItem: PDataRecord; {$else} FCurrentItem: PDataRecord; {$endif} FBufferSize: Integer; FExpectedAppends: Integer; FExpectedDeletes: Integer; FExpectedUpdates: Integer; FSaveOnClose: Boolean; FSaveOnRefetch: Boolean; FSqlMode: Boolean; FUpdatedItems: TFPList; FAddedItems: TFPList; FDeletedItems: TFPList; FOrphanItems: TFPList; FMasterLink: TMasterDataLink; FIndexFieldNames: String; FIndexFieldList: TList; function GetIndexFields(Value: Integer): TField; procedure UpdateIndexFields; function FindRecordItem(StartItem: PDataRecord; const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions; DoResync:Boolean):PDataRecord; protected FFileName: String; FSql: String; FTableName: String; FAutoIncFieldNo: Integer; FNextAutoInc:Integer; FSqliteReturnId: Integer; FSqliteHandle: Pointer; FDataAllocated: Boolean; FRowBufferSize: Integer; FRowCount: Integer; FRecordCount: Integer; FBeginItem: PDataRecord; FEndItem: PDataRecord; FCacheItem: PDataRecord; function SqliteExec(AHandle: Pointer; Sql:PChar):Integer;virtual; abstract; procedure SqliteClose(AHandle: Pointer);virtual;abstract; function GetSqliteHandle: Pointer; virtual; abstract; function GetSqliteVersion: String; virtual; abstract; procedure BuildLinkedList; virtual; abstract; procedure DisposeLinkedList; procedure SetDetailFilter; procedure MasterChanged(Sender: TObject); procedure MasterDisabled(Sender: TObject); procedure SetMasterFields(Value:String); function GetMasterFields:String; procedure SetMasterSource(Value: TDataSource); function GetMasterSource:TDataSource; //TDataSet overrides function AllocRecordBuffer: PChar; override; function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override; procedure FreeRecordBuffer(var Buffer: PChar); override; procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override; function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override; function GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; override; function GetRecordCount: Integer; override; function GetRecNo: Integer; override; function GetRecordSize: Word; override; procedure InternalAddRecord(Buffer: Pointer; DoAppend: Boolean); override; procedure InternalClose; override; procedure InternalDelete; override; procedure InternalFirst; override; procedure InternalGotoBookmark(ABookmark: Pointer); override; procedure InternalInitRecord(Buffer: PChar); override; procedure InternalLast; override; procedure InternalOpen; override; procedure InternalPost; override; procedure InternalSetToRecord(Buffer: PChar); override; function IsCursorOpen: Boolean; override; procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override; procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override; procedure SetExpectedAppends(AValue:Integer); procedure SetExpectedUpdates(AValue:Integer); procedure SetExpectedDeletes(AValue:Integer); procedure SetFieldData(Field: TField; Buffer: Pointer); override; procedure SetRecNo(Value: Integer); override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override; function Locate(const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions) : boolean; override; function LocateNext(const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions) : boolean; function Lookup(const KeyFields: string; const KeyValues: Variant; const ResultFields: string): Variant;{$ifndef ver2_0_0}override;{$endif} // Additional procedures function ApplyUpdates: Boolean; virtual; function CreateTable: Boolean; virtual; function ExecSQL:Integer; function ExecSQL(const ASql:String):Integer; function QuickQuery(const ASql:String):String;overload; function QuickQuery(const ASql:String;const AStrList: TStrings):String;overload; function QuickQuery(const ASql:String;const AStrList: TStrings;FillObjects:Boolean):String;virtual;abstract;overload; procedure RefetchData; function SqliteReturnString: String; virtual;abstract; function TableExists: Boolean;virtual;abstract; function UpdatesPending: Boolean; {$ifdef DEBUGACTIVEBUFFER} procedure SetCurrentItem(Value:PDataRecord); property FCurrentItem: PDataRecord read FFCurrentItem write SetCurrentItem; {$endif} {$ifdef USE_SQLITEDS_INTERNALS} property BeginItem: PDataRecord read FBeginItem; property EndItem: PDataRecord read FEndItem; property UpdatedItems: TFPList read FUpdatedItems; property AddedItems: TFPList read FAddedItems; property DeletedItems: TFPList read FDeletedItems; {$endif} property ExpectedAppends: Integer read FExpectedAppends write SetExpectedAppends; property ExpectedUpdates: Integer read FExpectedUpdates write SetExpectedUpdates; property ExpectedDeletes: Integer read FExpectedDeletes write SetExpectedDeletes; property IndexFields[Value: Integer]: TField read GetIndexFields; property SqliteReturnId: Integer read FSqliteReturnId; property SqliteHandle: Pointer read FSqliteHandle; property SqliteVersion: String read GetSqliteVersion; published property IndexFieldNames: string read FIndexFieldNames write FIndexFieldNames; property FileName: String read FFileName write FFileName; property PrimaryKey: String read FPrimaryKey write FPrimaryKey; property SaveOnClose: Boolean read FSaveOnClose write FSaveOnClose; property SaveOnRefetch: Boolean read FSaveOnRefetch write FSaveOnRefetch; property SQL: String read FSql write FSql; property SqlMode: Boolean read FSqlMode write FSqlMode; property TableName: String read FTableName write FTableName; property MasterSource: TDataSource read GetMasterSource write SetMasterSource; property MasterFields: string read GetMasterFields write SetMasterFields; property Active; //Events property BeforeOpen; property AfterOpen; property BeforeClose; property AfterClose; property BeforeInsert; property AfterInsert; property BeforeEdit; property AfterEdit; property BeforePost; property AfterPost; property BeforeCancel; property AfterCancel; property BeforeDelete; property AfterDelete; property BeforeScroll; property AfterScroll; property OnDeleteError; property OnEditError; end; implementation uses strutils, variants; const SQLITE_OK = 0;//sqlite2.x.x and sqlite3.x.x defines this equal // TDSStream constructor TDSStream.Create(const ActiveItem: PDataRecord; FieldIndex:Integer); begin inherited Create; FPosition:=0; FActiveItem:=ActiveItem; FFieldIndex:=FieldIndex; FFieldRow:=ActiveItem^.Row[FieldIndex]; if FFieldRow <> nil then FRowSize:=StrLen(FFieldRow) else FRowSize:=0; end; function TDSStream.Seek(Offset: Longint; Origin: Word): Longint; begin Case Origin of soFromBeginning : FPosition:=Offset; soFromEnd : FPosition:=FRowSize+Offset; soFromCurrent : FPosition:=FPosition+Offset; end; Result:=FPosition; end; function TDSStream.Write(const Buffer; Count: Longint): Longint; var NewRow:PChar; begin Result:=Count; if Count = 0 then Exit; //Todo: see how TDbMemo read/write to field and choose best if order if FPosition = 0 then begin NewRow:=StrAlloc(Count+1); (NewRow+Count)^:=#0; Move(Buffer,NewRow^,Count); end else begin NewRow:=StrAlloc(FRowSize+Count+1); (NewRow+Count+FRowSize)^:=#0; Move(FFieldRow^,NewRow^,FRowSize); Move(Buffer,(NewRow+FRowSize)^,Count); end; FActiveItem^.Row[FFieldIndex]:=NewRow; StrDispose(FFieldRow); FFieldRow:=NewRow; FRowSize:=StrLen(NewRow); Inc(FPosition,Count); {$ifdef DEBUG} WriteLn('Writing a BlobStream'); WriteLn('Stream.Size: ',StrLen(NewRow)); WriteLn('Stream Value: ',NewRow); WriteLn('FPosition:',FPosition); {$endif} end; function TDSStream.Read(var Buffer; Count: Longint): Longint; var BytesToMove:Integer; begin if (FRowSize - FPosition) >= Count then BytesToMove:=Count else BytesToMove:=FRowSize - FPosition; Move((FFieldRow+FPosition)^,Buffer,BytesToMove); Inc(FPosition,BytesToMove); Result:=BytesToMove; {$ifdef DEBUG} WriteLn('Reading a BlobStream'); WriteLn('Bytes requested: ',Count); WriteLn('Bytes Moved: ',BytesToMove); WriteLn('Stream.Size: ',FRowSize); WriteLn('Stream Value: ',FFieldRow); {$endif} end; // TCustomSqliteDataset override methods function TCustomSqliteDataset.AllocRecordBuffer: PChar; var APointer:Pointer; begin APointer := AllocMem(FBufferSize); PDataRecord(APointer^):=FBeginItem; Result:=APointer; end; constructor TCustomSqliteDataset.Create(AOwner: TComponent); begin // setup special items New(FBeginItem); New(FCacheItem); New(FEndItem); FBeginItem^.Previous:=nil; FEndItem^.Next:=nil; FBeginItem^.BookMarkFlag:=bfBOF; FCacheItem^.BookMarkFlag:=bfEOF; FEndItem^.BookMarkFlag:=bfEOF; FMasterLink:=TMasterDataLink.Create(Self); FMasterLink.OnMasterChange:=@MasterChanged; FMasterLink.OnMasterDisable:=@MasterDisabled; FIndexFieldList:=TList.Create; BookmarkSize := SizeOf(Pointer); FBufferSize := SizeOf(PPDataRecord); FUpdatedItems:= TFPList.Create; FUpdatedItems.Capacity:=20; FAddedItems:= TFPList.Create; FAddedItems.Capacity:=20; FOrphanItems:= TFPList.Create; FOrphanItems.Capacity:=20; FDeletedItems:= TFPList.Create; FDeletedItems.Capacity:=20; inherited Create(AOwner); end; function TCustomSqliteDataset.CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; begin Result:= TDSStream.Create(PPDataRecord(ActiveBuffer)^,Field.FieldNo - 1); end; destructor TCustomSqliteDataset.Destroy; begin inherited Destroy; FUpdatedItems.Destroy; FAddedItems.Destroy; FDeletedItems.Destroy; FOrphanItems.Destroy; FMasterLink.Destroy; FIndexFieldList.Destroy; // dispose special items Dispose(FBeginItem); Dispose(FCacheItem); Dispose(FEndItem); end; function TCustomSqliteDataset.GetIndexFields(Value: Integer): TField; begin if (Value < 0) or (Value > FIndexFieldList.Count - 1) then DatabaseError('Error acessing IndexFields: Index out of bonds',Self); Result:= TField(FIndexFieldList[Value]); end; procedure TCustomSqliteDataset.DisposeLinkedList; var TempItem:PDataRecord; Counter,I:Integer; begin //Todo: insert debug info FDataAllocated:=False; TempItem:=FBeginItem^.Next; if TempItem <> nil then while TempItem^.Next <> nil do begin for Counter:= 0 to FRowCount - 1 do StrDispose(TempItem^.Row[Counter]); FreeMem(TempItem^.Row,FRowBufferSize); TempItem:=TempItem^.Next; Dispose(TempItem^.Previous); end; //Dispose FBeginItem.Row FreeMem(FBeginItem^.Row,FRowBufferSize); //Dispose cache item for Counter:= 0 to FRowCount - 1 do StrDispose(FCacheItem^.Row[Counter]); FreeMem(FCacheItem^.Row,FRowBufferSize); //Dispose OrphanItems for Counter:= 0 to FOrphanItems.Count - 1 do begin TempItem:=PDataRecord(FOrphanItems[Counter]); for I:= 0 to FRowCount - 1 do StrDispose(TempItem^.Row[I]); FreeMem(TempItem^.Row,FRowBufferSize); Dispose(TempItem); end; end; procedure TCustomSqliteDataset.FreeRecordBuffer(var Buffer: PChar); begin FreeMem(Buffer); end; procedure TCustomSqliteDataset.GetBookmarkData(Buffer: PChar; Data: Pointer); begin Pointer(Data^) := PPDataRecord(Buffer)^; end; function TCustomSqliteDataset.GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; begin Result := PPDataRecord(Buffer)^^.BookmarkFlag; end; function TCustomSqliteDataset.GetFieldData(Field: TField; Buffer: Pointer): Boolean; var ValError:Word; FieldRow:PChar; begin FieldRow:=PPDataRecord(ActiveBuffer)^^.Row[Field.FieldNo - 1]; Result := FieldRow <> nil; if Result and (Buffer <> nil) then //supports GetIsNull begin case Field.Datatype of ftString: begin Move(FieldRow^,PChar(Buffer)^,StrLen(FieldRow)+1); end; ftInteger,ftAutoInc: begin Val(StrPas(FieldRow),LongInt(Buffer^),ValError); Result:= ValError = 0; end; ftBoolean,ftWord: begin Val(StrPas(FieldRow),Word(Buffer^),ValError); Result:= ValError = 0; end; ftFloat,ftDateTime,ftTime,ftDate,ftCurrency: begin Val(StrPas(FieldRow),Double(Buffer^),ValError); Result:= ValError = 0; end; ftLargeInt: begin Val(StrPas(FieldRow),Int64(Buffer^),ValError); Result:= ValError = 0; end; end; end; end; function TCustomSqliteDataset.GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; begin Result := grOk; case GetMode of gmPrior: if (FCurrentItem^.Previous = FBeginItem) or (FCurrentItem = FBeginItem) then begin Result := grBOF; FCurrentItem := FBeginItem; end else FCurrentItem:=FCurrentItem^.Previous; gmCurrent: if (FCurrentItem = FBeginItem) or (FCurrentItem = FEndItem) then Result := grError; gmNext: if (FCurrentItem = FEndItem) or (FCurrentItem^.Next = FEndItem) then Result := grEOF else FCurrentItem:=FCurrentItem^.Next; end; //case if Result = grOk then begin PDataRecord(Pointer(Buffer)^):=FCurrentItem; FCurrentItem^.BookmarkFlag := bfCurrent; end else if (Result = grError) and DoCheck then DatabaseError('No records found',Self); end; function TCustomSqliteDataset.GetRecordCount: Integer; begin Result := FRecordCount; end; function TCustomSqliteDataset.GetRecNo: Integer; var TempItem,TempActive:PDataRecord; begin Result:= -1; if FRecordCount = 0 then Exit; TempItem:=FBeginItem; TempActive:=PPDataRecord(ActiveBuffer)^; if TempActive = FCacheItem then // Record not posted yet Result:=FRecordCount else while TempActive <> TempItem do begin if TempItem^.Next <> nil then begin inc(Result); TempItem:=TempItem^.Next; end else begin Result:=-1; DatabaseError('Sqliteds.GetRecNo - ActiveItem Not Found',Self); break; end; end; end; function TCustomSqliteDataset.GetRecordSize: Word; begin Result := FBufferSize; //?? end; procedure TCustomSqliteDataset.InternalAddRecord(Buffer: Pointer; DoAppend: Boolean); var NewItem: PDataRecord; Counter:Integer; begin {$ifdef DEBUG} if PPDataRecord(Buffer)^ <> FCacheItem then DatabaseError('PPDataRecord(Buffer) <> FCacheItem - Problem',Self); {$endif} New(NewItem); GetMem(NewItem^.Row,FRowBufferSize); for Counter := 0 to FRowCount - 1 do NewItem^.Row[Counter]:=StrNew(FCacheItem^.Row[Counter]); FEndItem^.Previous^.Next:=NewItem; NewItem^.Previous:=FEndItem^.Previous; NewItem^.Next:=FEndItem; FEndItem^.Previous:=NewItem; Inc(FRecordCount); if FAutoIncFieldNo <> - 1 then Inc(FNextAutoInc); FAddedItems.Add(NewItem); end; procedure TCustomSqliteDataset.InternalClose; begin if FSaveOnClose then ApplyUpdates; //BindFields(False); if DefaultFields then DestroyFields; if FDataAllocated then DisposeLinkedList; if FSqliteHandle <> nil then begin SqliteClose(FSqliteHandle); FSqliteHandle := nil; end; FAddedItems.Clear; FUpdatedItems.Clear; FDeletedItems.Clear; FOrphanItems.Clear; FRecordCount:=0; end; procedure TCustomSqliteDataset.InternalDelete; var TempItem:PDataRecord; ValError,TempInteger:Integer; begin If FRecordCount = 0 then Exit; Dec(FRecordCount); TempItem:=PPDataRecord(ActiveBuffer)^; // Remove from changed list FUpdatedItems.Remove(TempItem); if FAddedItems.Remove(TempItem) = -1 then FDeletedItems.Add(TempItem); FOrphanItems.Add(TempItem); TempItem^.Next^.Previous:=TempItem^.Previous; TempItem^.Previous^.Next:=TempItem^.Next; if FCurrentItem = TempItem then begin if FCurrentItem^.Previous <> FBeginItem then FCurrentItem:= FCurrentItem^.Previous else FCurrentItem:= FCurrentItem^.Next; end; // Dec FNextAutoInc (only if deleted item is the last record) if FAutoIncFieldNo <> -1 then begin Val(StrPas(TempItem^.Row[FAutoIncFieldNo]),TempInteger,ValError); if (ValError = 0) and (TempInteger = (FNextAutoInc - 1)) then Dec(FNextAutoInc); end; end; procedure TCustomSqliteDataset.InternalFirst; begin FCurrentItem := FBeginItem; end; procedure TCustomSqliteDataset.InternalGotoBookmark(ABookmark: Pointer); begin FCurrentItem := PDataRecord(ABookmark^); end; procedure TCustomSqliteDataset.InternalInitRecord(Buffer: PChar); var Counter:Integer; TempStr:String; begin for Counter:= 0 to FRowCount - 1 do begin StrDispose(FCacheItem^.Row[Counter]); FCacheItem^.Row[Counter]:=nil; end; if FAutoIncFieldNo <> - 1 then begin Str(FNextAutoInc,TempStr); FCacheItem^.Row[FAutoIncFieldNo]:=StrAlloc(Length(TempStr)+1); StrPCopy(FCacheItem^.Row[FAutoIncFieldNo],TempStr); end; PPDataRecord(Buffer)^:=FCacheItem; end; procedure TCustomSqliteDataset.InternalLast; begin FCurrentItem := FEndItem; end; procedure TCustomSqliteDataset.InternalOpen; begin FAutoIncFieldNo:=-1; if not FileExists(FFileName) then DatabaseError('File "'+ExpandFileName(FFileName)+'" not found',Self); if (FTablename = '') and not (FSqlMode) then DatabaseError('Tablename not set',Self); if MasterSource <> nil then begin FSql := 'Select * from '+FTableName+';'; // forced to obtain all fields FMasterLink.FieldNames:=FMasterLink.FieldNames; //workaround to fill MasterLinks.Fields //if FMasterLink.Fields.Count = 0 MasterChanged will not be called anyway so ignore it end; FSqliteHandle:=GetSqliteHandle; if FSql = '' then FSql := 'Select * from '+FTableName+';'; InternalInitFieldDefs; if DefaultFields then CreateFields; BindFields(True); UpdateIndexFields; if FMasterLink.Active then begin if FIndexFieldList.Count <> FMasterLink.Fields.Count then DatabaseError('MasterFields count doesn''t match IndexFields count',Self); //Set FSql considering MasterSource active record SetDetailFilter; end; // Get PrimaryKeyNo if available if Fields.FindField(FPrimaryKey) <> nil then FPrimaryKeyNo:=Fields.FindField(FPrimaryKey).FieldNo - 1 else FPrimaryKeyNo:=FAutoIncFieldNo; // -1 if there's no AutoIncField BuildLinkedList; FCurrentItem:=FBeginItem; end; procedure TCustomSqliteDataset.InternalPost; begin if (State<>dsEdit) then InternalAddRecord(ActiveBuffer,True); end; procedure TCustomSqliteDataset.InternalSetToRecord(Buffer: PChar); begin FCurrentItem:=PPDataRecord(Buffer)^; end; function TCustomSqliteDataset.IsCursorOpen: Boolean; begin Result := FDataAllocated; end; function TCustomSqliteDataset.FindRecordItem(StartItem: PDataRecord; const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions; DoResync:Boolean):PDataRecord; var AValue:String; AField:TField; AFieldIndex:Integer; TempItem:PDataRecord; begin Result:=nil; // Now, it allows to search only one field and ignores options AField:=Fields.FieldByName(KeyFields); //FieldByName raises an exeception if field not found AFieldIndex:=AField.FieldNo - 1; //get float types in appropriate format if not (AField.DataType in [ftFloat,ftDateTime,ftTime,ftDate]) then AValue:=keyvalues else begin Str(VarToDateTime(keyvalues),AValue); AValue:=Trim(AValue); end; {$ifdef DEBUG} writeln('=FindRecord='); writeln('keyfields: ',keyfields); writeln('keyvalues: ',keyvalues); writeln('AValue: ',AValue); {$endif} //Search the list TempItem:=StartItem; while TempItem <> FEndItem do begin if TempItem^.Row[AFieldIndex] <> nil then begin if StrComp(TempItem^.Row[AFieldIndex],PChar(AValue)) = 0 then begin Result:=TempItem; if DoResync then begin FCurrentItem:=TempItem; Resync([]); end; Break; end; end; TempItem:=TempItem^.Next; end; end; function TCustomSqliteDataset.Locate(const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions) : boolean; begin Result:=FindRecordItem(FBeginItem^.Next,KeyFields,KeyValues,Options,True) <> nil; end; function TCustomSqliteDataset.LocateNext(const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions) : boolean; begin Result:=FindRecordItem(PPDataRecord(ActiveBuffer)^^.Next,KeyFields,KeyValues,Options,True) <> nil; end; function TCustomSqliteDataset.Lookup(const KeyFields: string; const KeyValues: Variant; const ResultFields: string): Variant; var TempItem:PDataRecord; begin TempItem:=FindRecordItem(FBeginItem^.Next,KeyFields,KeyValues,[],False); if TempItem <> nil then Result:=TempItem^.Row[FieldByName(ResultFields).FieldNo - 1] else Result:=False; end; procedure TCustomSqliteDataset.SetBookmarkData(Buffer: PChar; Data: Pointer); begin //The BookMarkData is the Buffer itself; end; procedure TCustomSqliteDataset.SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); begin PPDataRecord(Buffer)^^.BookmarkFlag := Value; end; procedure TCustomSqliteDataset.SetExpectedAppends(AValue:Integer); begin FAddedItems.Capacity:=AValue; end; procedure TCustomSqliteDataset.SetExpectedUpdates(AValue:Integer); begin FUpdatedItems.Capacity:=AValue; end; procedure TCustomSqliteDataset.SetExpectedDeletes(AValue:Integer); begin FDeletedItems.Capacity:=AValue; FOrphanItems.Capacity:=AValue; end; procedure TCustomSqliteDataset.SetFieldData(Field: TField; Buffer: Pointer); var TempStr:String; ActiveItem:PDataRecord; begin ActiveItem:=PPDataRecord(ActiveBuffer)^; if (ActiveItem <> FCacheItem) and (FUpdatedItems.IndexOf(ActiveItem) = -1) and (FAddedItems.IndexOf(ActiveItem) = -1) then FUpdatedItems.Add(ActiveItem); StrDispose(ActiveItem^.Row[Pred(Field.FieldNo)]); if Buffer <> nil then begin case Field.Datatype of ftString: begin ActiveItem^.Row[Pred(Field.FieldNo)]:=StrNew(PChar(Buffer)); end; ftInteger: begin Str(LongInt(Buffer^),TempStr); ActiveItem^.Row[Pred(Field.FieldNo)]:=StrAlloc(Length(TempStr)+1); StrPCopy(ActiveItem^.Row[Pred(Field.FieldNo)],TempStr); end; ftBoolean,ftWord: begin Str(Word(Buffer^),TempStr); ActiveItem^.Row[Pred(Field.FieldNo)]:=StrAlloc(Length(TempStr)+1); StrPCopy(ActiveItem^.Row[Pred(Field.FieldNo)],TempStr); end; ftFloat,ftDateTime,ftDate,ftTime,ftCurrency: begin Str(Double(Buffer^),TempStr); ActiveItem^.Row[Pred(Field.FieldNo)]:=StrAlloc(Length(TempStr)+1); StrPCopy(ActiveItem^.Row[Pred(Field.FieldNo)],TempStr); end; ftLargeInt: begin Str(Int64(Buffer^),TempStr); ActiveItem^.Row[Pred(Field.FieldNo)]:=StrAlloc(Length(TempStr)+1); StrPCopy(ActiveItem^.Row[Pred(Field.FieldNo)],TempStr); end; end;// case end//if else ActiveItem^.Row[Pred(Field.FieldNo)]:=nil; if not (State in [dsCalcFields, dsFilter, dsNewValue]) then DataEvent(deFieldChange, Ptrint(Field)); end; procedure TCustomSqliteDataset.SetRecNo(Value: Integer); var Counter:Integer; TempItem:PDataRecord; begin if (Value >= FRecordCount) or (Value < 0) then DatabaseError('Record Number Out Of Range',Self); TempItem:=FBeginItem; for Counter := 0 to Value do TempItem:=TempItem^.Next; FCurrentItem:=TempItem; Resync([]); end; // Specific functions procedure TCustomSqliteDataset.SetDetailFilter; function GetSqlStr(AField:TField):String; begin case AField.DataType of ftString,ftMemo: Result:='"'+AField.AsString+'"';//todo: handle " caracter properly ftDateTime,ftDate,ftTime:Str(AField.AsDateTime,Result); else Result:=AField.AsString; end;//case end;//function var AFilter:String; i:Integer; begin if FMasterLink.Dataset.RecordCount = 0 then //Retrieve all data FSql:='Select * from '+FTableName else begin AFilter:=' where '; for i:= 0 to FMasterLink.Fields.Count - 1 do begin AFilter:=AFilter + IndexFields[i].FieldName +' = '+ GetSqlStr(TField(FMasterLink.Fields[i])); if i <> FMasterLink.Fields.Count - 1 then AFilter:= AFilter + ' and '; end; FSql:='Select * from '+FTableName+AFilter; end; end; procedure TCustomSqliteDataset.MasterChanged(Sender: TObject); begin SetDetailFilter; {$ifdef DEBUG} writeln('Sql used to filter detail dataset:'); writeln(FSql); {$endif} RefetchData; end; procedure TCustomSqliteDataset.MasterDisabled(Sender: TObject); begin FSql:='Select * from '+FTableName+';'; RefetchData; end; procedure TCustomSqliteDataset.SetMasterFields(Value: String); begin FMasterLink.FieldNames:=Value; if Active and FMasterLink.Active then begin UpdateIndexFields; if (FIndexFieldList.Count <> FMasterLink.Fields.Count) then DatabaseError('MasterFields count doesn''t match IndexFields count',Self); end; end; function TCustomSqliteDataset.GetMasterFields: String; begin Result:=FMasterLink.FieldNames; end; procedure TCustomSqliteDataset.UpdateIndexFields; begin FIndexFieldList.Clear; if FIndexFieldNames <> '' then begin try GetFieldList(FIndexFieldList, FIndexFieldNames); except FIndexFieldList.Clear; raise; end; end; end; function TCustomSqliteDataset.GetMasterSource: TDataSource; begin Result := FMasterLink.DataSource; end; procedure TCustomSqliteDataset.SetMasterSource(Value: TDataSource); begin FMasterLink.DataSource := Value; end; function TCustomSqliteDataset.ExecSQL(const ASql:String):Integer; var AHandle: Pointer; begin Result:=0; //Todo check if Filename exists if FSqliteHandle <> nil then AHandle:=FSqliteHandle else if FFileName <> '' then AHandle := GetSqliteHandle else DatabaseError ('ExecSql - FileName not set',Self); FSqliteReturnId:= SqliteExec(AHandle,PChar(ASql)); //todo: add a way to get the num of changes //Result:=sqlite_changes(AHandle); if AHandle <> FSqliteHandle then SqliteClose(AHandle); end; function TCustomSqliteDataset.ExecSQL:Integer; begin Result:=ExecSQL(FSql); end; function TCustomSqliteDataset.ApplyUpdates:Boolean; var CounterFields,CounterItems,StatementsCounter:Integer; SqlTemp,KeyName,ASqlLine,TemplateStr:String; begin if not UpdatesPending then begin Result:=True; Exit; end; Result:=False; if (FPrimaryKeyNo <> -1) and not FSqlMode then begin StatementsCounter:=0; KeyName:=Fields[FPrimaryKeyNo].FieldName; {$ifdef DEBUG} WriteLn('ApplyUpdates called'); if FPrimaryKeyNo = FAutoIncFieldNo then WriteLn('Using an AutoInc field as primary key'); WriteLn('PrimaryKey: ',KeyName); WriteLn('PrimaryKeyNo: ',FPrimaryKeyNo); {$endif} SqlTemp:='BEGIN TRANSACTION;'; // Update changed records if FUpdatedItems.Count > 0 then TemplateStr:='UPDATE '+FTableName+' SET '; for CounterItems:= 0 to FUpdatedItems.Count - 1 do begin ASqlLine:=TemplateStr; for CounterFields:= 0 to Fields.Count - 1 do begin if PDataRecord(FUpdatedItems[CounterItems])^.Row[CounterFields] <> nil then begin ASqlLine:=ASqlLine + Fields[CounterFields].FieldName +' = '; if not (Fields[CounterFields].DataType in [ftString,ftMemo]) then ASqlLine:=ASqlLine+StrPas(PDataRecord(FUpdatedItems[CounterItems])^.Row[CounterFields])+ ',' else ASqlLine:=ASqlLine+''''+ AnsiReplaceStr(StrPas(PDataRecord(FUpdatedItems[CounterItems])^.Row[CounterFields]),'''','''''')+''','; end else ASqlLine:=ASqlLine + Fields[CounterFields].FieldName +' = NULL,'; end; //Todo: see if system.delete trunks AnsiString system.delete(ASqlLine,Length(ASqlLine),1); SqlTemp:=SqlTemp + ASqlLine+' WHERE '+KeyName+' = '+StrPas(PDataRecord(FUpdatedItems[CounterItems])^.Row[FPrimaryKeyNo])+';'; inc(StatementsCounter); //ApplyUpdates each 400 statements if StatementsCounter = 400 then begin SqlTemp:=SqlTemp+'END TRANSACTION;'; FSqliteReturnId:=SqliteExec(FSqliteHandle,PChar(SqlTemp)); StatementsCounter:=0; SqlTemp:='BEGIN TRANSACTION;'; end; end; // Add new records // Build TemplateStr if FAddedItems.Count > 0 then begin TemplateStr:='INSERT INTO '+FTableName+ ' ('; for CounterFields:= 0 to Fields.Count - 1 do begin TemplateStr:=TemplateStr + Fields[CounterFields].FieldName; if CounterFields <> Fields.Count - 1 then TemplateStr:=TemplateStr+','; end; TemplateStr:=TemplateStr+') VALUES ('; end; for CounterItems:= 0 to FAddedItems.Count - 1 do begin ASqlLine:=TemplateStr; for CounterFields:= 0 to Fields.Count - 1 do begin if PDataRecord(FAddedItems[CounterItems])^.Row[CounterFields] <> nil then begin if not (Fields[CounterFields].DataType in [ftString,ftMemo]) then ASqlLine:=ASqlLine+StrPas(PDataRecord(FAddedItems[CounterItems])^.Row[CounterFields]) else ASqlLine:=ASqlLine+''''+ AnsiReplaceStr(StrPas(PDataRecord(FAddedItems[CounterItems])^.Row[CounterFields]),'''','''''')+''''; end else ASqlLine:=ASqlLine + 'NULL'; //Todo: see if delete ASqline is faster if CounterFields <> Fields.Count - 1 then ASqlLine:=ASqlLine+','; end; SqlTemp:=SqlTemp+ASqlLine+');'; inc(StatementsCounter); //ApplyUpdates each 400 statements if StatementsCounter = 400 then begin SqlTemp:=SqlTemp+'END TRANSACTION;'; FSqliteReturnId:=SqliteExec(FSqliteHandle,PChar(SqlTemp)); StatementsCounter:=0; SqlTemp:='BEGIN TRANSACTION;'; end; end; // Delete Items if FDeletedItems.Count > 0 then TemplateStr:='DELETE FROM '+FTableName+ ' WHERE '+KeyName+' = '; for CounterItems:= 0 to FDeletedItems.Count - 1 do begin SqlTemp:=SqlTemp+TemplateStr+ StrPas(PDataRecord(FDeletedItems[CounterItems])^.Row[FPrimaryKeyNo])+';'; inc(StatementsCounter); //ApplyUpdates each 400 statements if StatementsCounter = 400 then begin SqlTemp:=SqlTemp+'END TRANSACTION;'; FSqliteReturnId:=SqliteExec(FSqliteHandle,PChar(SqlTemp)); StatementsCounter:=0; SqlTemp:='BEGIN TRANSACTION;'; end; end; SqlTemp:=SqlTemp+'END TRANSACTION;'; {$ifdef DEBUG} writeln('ApplyUpdates Sql: ',SqlTemp); {$endif} FAddedItems.Clear; FUpdatedItems.Clear; FDeletedItems.Clear; FSqliteReturnId:=SqliteExec(FSqliteHandle,PChar(SqlTemp)); Result:= FSqliteReturnId = SQLITE_OK; end; {$ifdef DEBUG} writeln('ApplyUpdates Result: ',Result); {$endif} end; function TCustomSqliteDataset.CreateTable: Boolean; var SqlTemp:String; Counter:Integer; begin {$ifdef DEBUG} if FTableName = '' then WriteLn('CreateTable : TableName Not Set'); if FieldDefs.Count = 0 then WriteLn('CreateTable : FieldDefs Not Initialized'); {$endif} if (FTableName <> '') and (FieldDefs.Count > 0) then begin FSqliteHandle:= GetSqliteHandle; SqlTemp:='CREATE TABLE '+FTableName+' ('; for Counter := 0 to FieldDefs.Count-1 do begin SqlTemp:=SqlTemp + FieldDefs[Counter].Name; case FieldDefs[Counter].DataType of ftInteger: SqlTemp:=SqlTemp + ' INTEGER'; ftString: SqlTemp:=SqlTemp + ' VARCHAR'; ftBoolean: SqlTemp:=SqlTemp + ' BOOLEAN'; ftFloat: SqlTemp:=SqlTemp + ' FLOAT'; ftWord: SqlTemp:=SqlTemp + ' WORD'; ftDateTime: SqlTemp:=SqlTemp + ' DATETIME'; ftDate: SqlTemp:=SqlTemp + ' DATE'; ftTime: SqlTemp:=SqlTemp + ' TIME'; ftLargeInt: SqlTemp:=SqlTemp + ' LARGEINT'; ftCurrency: SqlTemp:=SqlTemp + ' CURRENCY'; ftAutoInc: SqlTemp:=SqlTemp + ' AUTOINC'; ftMemo: SqlTemp:=SqlTemp + ' MEMO'; else DatabaseError('Field type "'+FieldTypeNames[FieldDefs[Counter].DataType]+'" not supported',Self); end; if Counter <> FieldDefs.Count - 1 then SqlTemp:=SqlTemp+ ' , '; end; SqlTemp:=SqlTemp+');'; {$ifdef DEBUG} writeln('CreateTable Sql: ',SqlTemp); {$endif} FSqliteReturnId:=SqliteExec(FSqliteHandle,PChar(SqlTemp)); Result:= FSqliteReturnId = SQLITE_OK; SqliteClose(FSqliteHandle); FSqliteHandle:=nil; end else Result:=False; end; procedure TCustomSqliteDataset.RefetchData; var i:Integer; begin //Close if FSaveOnRefetch then ApplyUpdates; if FDataAllocated then DisposeLinkedList; FAddedItems.Clear; FUpdatedItems.Clear; FDeletedItems.Clear; FOrphanItems.Clear; //Reopen BuildLinkedList; FCurrentItem:=FBeginItem; for i := 0 to BufferCount - 1 do PPDataRecord(Buffers[i])^:=FBeginItem; Resync([]); end; function TCustomSqliteDataset.UpdatesPending: Boolean; begin //Sometimes FBeginItem is inserted in FUpdatedItems FUpdatedItems.Remove(FBeginItem); Result:= (FUpdatedItems.Count > 0) or (FAddedItems.Count > 0) or (FDeletedItems.Count > 0); end; function TCustomSqliteDataset.QuickQuery(const ASql:String):String; begin Result:=QuickQuery(ASql,nil,False); end; function TCustomSqliteDataset.QuickQuery(const ASql:String;const AStrList: TStrings):String; begin Result:=QuickQuery(ASql,AStrList,False) end; {$ifdef DEBUGACTIVEBUFFER} procedure TCustomSqliteDataset.SetCurrentItem(Value:PDataRecord); var ANo:Integer; function GetItemPos:Integer; var TempItem:PDataRecord; begin Result:= -1; TempItem:=FBeginItem; if Value = FCacheItem then Result:=-2 else while Value <> TempItem do begin if TempItem^.Next <> nil then begin inc(Result); TempItem:=TempItem^.Next; end else begin Result:=-1; break; end; end; end; begin if Value = FBeginItem then begin writeln('FCurrentItem set to FBeginItem: ',IntToHex(Integer(Value),0)); FFCurrentItem:=Value; end else if Value = FEndItem then begin writeln('FCurrentItem set to FEndItem: ',IntToHex(Integer(Value),0)); FFCurrentItem:=Value; end else if Value = FCacheItem then begin writeln('FCurrentItem set to FCacheItem: ',IntToHex(Integer(Value),0)); FFCurrentItem:=Value; end else begin writeln('FCurrentItem set from ',IntToHex(Integer(FFCurrentItem),0),' to ',IntToHex(Integer(Value),0)); Ano:=GetItemPos; writeln('Item position is ',ANo); FFCurrentItem:=Value; end; end; {$endif} end.