123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878 |
- unit CustomSqliteDS;
- {
- This is TCustomSqliteDataset, a TDataset descendant class for use with fpc compiler
- Copyright (C) 2004-2007 Luiz Américo Pereira Câmara
- Email: [email protected]
- This library is free software; you can redistribute it and/or modify it
- under the terms of the GNU Library General Public License as published by
- the Free Software Foundation; either version 2 of the License, or (at your
- option) any later version with the following modification:
- As a special exception, the copyright holders of this library give you
- permission to link this library with independent modules to produce an
- executable, regardless of the license terms of these independent modules,and
- to copy and distribute the resulting executable under terms of your choice,
- provided that you also meet, for each linked independent module, the terms
- and conditions of the license of that module. An independent module is a
- module which is not derived from or based on this library. If you modify
- this library, you may extend this exception to your version of the library,
- but you are not obligated to do so. If you do not wish to do so, delete this
- exception statement from your 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 Library General Public License
- for more details.
- You should have received a copy of the GNU Library General Public License
- along with this library; if not, write to the Free Software Foundation,
- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
- }
- {$Mode ObjFpc}
- {$H+}
- {.$Define DEBUG_SQLITEDS}
- {.$Define DEBUGACTIVEBUFFER}
- interface
- uses
- Classes, SysUtils, db;
- const
- DefaultStringSize = 255;
- type
- TCustomSqliteDataset = class;
- PDataRecord = ^DataRecord;
- PPDataRecord = ^PDataRecord;
- DataRecord = record
- Row: PPChar;
- BookmarkFlag: TBookmarkFlag;
- Next: PDataRecord;
- Previous: PDataRecord;
- end;
-
- TDSStream = class(TStream)
- private
- FActiveItem: PDataRecord;
- FDataset: TCustomSqliteDataset;
- FFieldRow: PChar;
- FField: TField;
- FFieldOffset: Integer;
- FRowSize: Integer;
- FPosition: LongInt;
- public
- constructor Create(Dataset: TCustomSqliteDataset; Field: TField);
- 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;
- //callback types
- TSqliteCdeclCallback = function(UserData: Pointer; Count: LongInt; Values: PPChar; Names: PPChar): LongInt; cdecl;
- TSqliteCallback = function(UserData: Pointer; Count: LongInt; Values: PPChar; Names: PPChar): LongInt of object;
- TCallbackInfo = record
- Proc: TSqliteCallback;
- Data: Pointer;
- end;
- PCallbackInfo = ^TCallbackInfo;
-
- TRecordState = (rsAdded, rsDeleted, rsUpdated);
- TRecordStateSet = set of TRecordState;
- TQueryUpdatesCallback = procedure(UserData: Pointer; Values: PPChar; ABookmark: TBookmark; RecordState: TRecordState) of object;
- TGetSqlStrFunction = function(APChar: PChar): String;
- TSqliteOption = (soWildcardKey);
- TSqliteOptions = set of TSqliteOption;
- { TCustomSqliteDataset }
- TCustomSqliteDataset = class(TDataSet)
- private
- {$ifdef DEBUGACTIVEBUFFER}
- FFCurrentItem: PDataRecord;
- {$else}
- FCurrentItem: PDataRecord;
- {$endif}
- FInternalActiveBuffer: PDataRecord;
- FInsertBookmark: PDataRecord;
- FOnCallback: TSqliteCallback;
- FMasterLink: TMasterDataLink;
- FIndexFieldNames: String;
- FIndexFieldList: TList;
- FOnGetHandle: TDataSetNotifyEvent;
- FOptions: TSqliteOptions;
- FSQLList: TStrings;
- procedure CopyCacheToItem(AItem: PDataRecord);
- function GetIndexFields(Value: Integer): TField;
- procedure SetMasterIndexValue;
- procedure SetOptions(const AValue: TSqliteOptions);
- procedure UpdateCalcFieldList;
- procedure UpdateIndexFieldList;
- function FindRecordItem(StartItem: PDataRecord; const KeyFields: string; const KeyValues: Variant; LocateOptions: TLocateOptions; DoResync: Boolean): PDataRecord;
- procedure UpdateMasterDetailProperties;
- protected
- FPrimaryKey: String;
- FPrimaryKeyNo: Integer;
- FFileName: String;
- FSQL: String;
- FTableName: String;
- FSqlFilterTemplate: String;
- FAutoIncFieldNo: Integer;
- FNextAutoInc: Integer;
- FUpdatedItems: TFPList;
- FAddedItems: TFPList;
- FDeletedItems: TFPList;
- FCalcFieldList: TFPList;
- FReturnCode: Integer;
- FSqliteHandle: Pointer;
- FRowBufferSize: Integer;
- FRowCount: Integer;
- FRecordCount: Integer;
- FBeginItem: PDataRecord;
- FEndItem: PDataRecord;
- FCacheItem: PDataRecord;
- FGetSqlStr: array of TGetSqlStrFunction;
- FSaveOnClose: Boolean;
- FSaveOnRefetch: Boolean;
- FAutoIncrementKey: Boolean;
- FDataAllocated: Boolean;
- function SqliteExec(Sql: PChar; ACallback: TSqliteCdeclCallback; Data: Pointer): Integer; virtual; abstract;
- procedure InternalCloseHandle; virtual; abstract;
- function InternalGetHandle: Pointer; virtual; abstract;
- procedure GetSqliteHandle;
- procedure BuildLinkedList; virtual; abstract;
- procedure FreeItem(AItem: PDataRecord);
- procedure DisposeLinkedList;
- procedure SetDetailFilter;
- procedure MasterChanged(Sender: TObject);
- procedure SetMasterFields(const Value: String);
- function GetMasterFields: String;
- procedure SetMasterSource(Value: TDataSource);
- function GetMasterSource: TDataSource;
- procedure SetFileName(const Value: String);
- function GetRowsAffected: Integer; virtual; abstract;
- procedure RetrieveFieldDefs; virtual; abstract;
- //TDataSet overrides
- function AllocRecordBuffer: PChar; override;
- procedure ClearCalcFields(Buffer: PChar); override;
- procedure DoBeforeClose; override;
- procedure DoAfterInsert; override;
- procedure DoBeforeInsert; 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 InternalCancel; override;
- procedure InternalDelete; override;
- procedure InternalEdit; override;
- procedure InternalFirst; override;
- procedure InternalGotoBookmark(ABookmark: Pointer); override;
- procedure InternalInitFieldDefs; 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 SetRecNo(Value: Integer); override;
- public
- constructor Create(AOwner: TComponent); override;
- destructor Destroy; override;
- function BookmarkValid(ABookmark: TBookmark): Boolean; override;
- function CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Longint; override;
- function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override;
- function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override;
- function GetFieldData(Field: TField; Buffer: Pointer; NativeFormat: Boolean): Boolean; override;
- function Locate(const KeyFields: String; const KeyValues: Variant; LocateOptions: TLocateOptions) : Boolean; override;
- function LocateNext(const KeyFields: String; const KeyValues: Variant; LocateOptions: TLocateOptions) : Boolean;
- function Lookup(const KeyFields: String; const KeyValues: Variant; const ResultFields: String): Variant; override;
- procedure SetFieldData(Field: TField; Buffer: Pointer); override;
- procedure SetFieldData(Field: TField; Buffer: Pointer; NativeFormat: Boolean); override;
- // Additional procedures
- function ApplyUpdates: Boolean;
- procedure ClearUpdates(RecordStates: TRecordStateSet = [rsAdded, rsDeleted, rsUpdated]);
- function CreateTable: Boolean;
- function CreateTable(const ATableName: String): Boolean;
- procedure ExecCallback(const ASql: String; UserData: Pointer = nil);
- procedure ExecSQL;
- procedure ExecSQL(const ASql: String);
- procedure ExecSQLList;
- procedure ExecuteDirect(const ASql: String); virtual; abstract;
- function GetSQLValue(Values: PPChar; FieldIndex: Integer): String;
- procedure QueryUpdates(RecordStates: TRecordStateSet; Callback: TQueryUpdatesCallback; UserData: Pointer = nil);
- 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 ReturnString: String; virtual; abstract;
- class function SqliteVersion: String; virtual; abstract;
- function TableExists: Boolean;
- function TableExists(const ATableName: String): Boolean;
- function UpdatesPending: Boolean;
- {$ifdef DEBUGACTIVEBUFFER}
- procedure SetCurrentItem(Value: PDataRecord);
- property FCurrentItem: PDataRecord read FFCurrentItem write SetCurrentItem;
- {$endif}
- property ExpectedAppends: Integer write SetExpectedAppends;
- property ExpectedUpdates: Integer write SetExpectedUpdates;
- property ExpectedDeletes: Integer write SetExpectedDeletes;
- property IndexFields[Value: Integer]: TField read GetIndexFields;
- property RowsAffected: Integer read GetRowsAffected;
- property ReturnCode: Integer read FReturnCode;
- property SqliteHandle: Pointer read FSqliteHandle;
- property SQLList:TStrings read FSQLList;
- published
- property AutoIncrementKey: Boolean read FAutoIncrementKey write FAutoIncrementKey default False;
- property IndexFieldNames: string read FIndexFieldNames write FIndexFieldNames;
- property FileName: String read FFileName write SetFileName;
- property OnCallback: TSqliteCallback read FOnCallback write FOnCallback;
- property OnGetHandle: TDataSetNotifyEvent read FOnGetHandle write FOnGetHandle;
- property Options: TSqliteOptions read FOptions write SetOptions default [];
- property PrimaryKey: String read FPrimaryKey write FPrimaryKey;
- property SaveOnClose: Boolean read FSaveOnClose write FSaveOnClose default False;
- property SaveOnRefetch: Boolean read FSaveOnRefetch write FSaveOnRefetch default False;
- property SQL: String read FSQL write FSQL;
- property TableName: String read FTableName write FTableName;
- property MasterSource: TDataSource read GetMasterSource write SetMasterSource;
- property MasterFields: String read GetMasterFields write SetMasterFields;
-
- property Active;
- property FieldDefs;
- //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 BeforeRefresh;
- property AfterRefresh;
- property OnCalcFields;
- property OnDeleteError;
- property OnEditError;
- property OnNewRecord;
- property OnPostError;
- end;
-
- function Num2SQLStr(APChar: PChar): String;
- function Char2SQLStr(APChar: PChar): String;
- implementation
- uses
- strutils, variants, dbconst;
- const
- //sqlite2.x.x and sqlite3.x.x define these constants equally
- SQLITE_OK = 0;
- SQLITE_ROW = 100;
-
- NullString = 'NULL';
-
- function CallbackDispatcher(UserData: Pointer; Count: LongInt; Values: PPchar; Names: PPchar): LongInt; cdecl;
- begin
- with PCallbackInfo(UserData)^ do
- Result:= Proc(Data, Count, Values, Names);
- end;
-
- function Num2SQLStr(APChar: PChar): String;
- begin
- if APChar = nil then
- begin
- Result := NullString;
- Exit;
- end;
- Result := String(APChar);
- end;
- function Char2SQLStr(APChar: PChar): String;
- begin
- if APChar = nil then
- begin
- Result := NullString;
- Exit;
- end;
- //todo: create custom routine to directly transform PChar -> SQL str
- Result := String(APChar);
- if Pos('''', Result) > 0 then
- Result := AnsiReplaceStr(Result, '''', '''''');
- Result := '''' + Result + '''';
- end;
- // TDSStream
- constructor TDSStream.Create(Dataset: TCustomSqliteDataset; Field: TField);
- begin
- inherited Create;
- //FPosition := 0;
- FDataset := Dataset;
- FField := Field;
- if Field.FieldNo >= 0 then
- FFieldOffset := Field.FieldNo - 1
- else
- FFieldOffset := Dataset.FieldDefs.Count + Dataset.FCalcFieldList.IndexOf(Field);
- FActiveItem := PPDataRecord(Dataset.ActiveBuffer)^;
- FFieldRow := FActiveItem^.Row[FFieldOffset];
- 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;
- //FRowSize is always 0 when FPosition = 0,
- //so there's no need to check FPosition
- NewRow := StrAlloc(FRowSize + Count + 1);
- (NewRow + Count + FRowSize)^ := #0;
- if FRowSize > 0 then
- Move(FFieldRow^, NewRow^, FRowSize);
- Move(Buffer, (NewRow + FRowSize)^, Count);
- FActiveItem^.Row[FFieldOffset] := NewRow;
- StrDispose(FFieldRow);
- {$ifdef DEBUG_SQLITEDS}
- WriteLn('##TDSStream.Write##');
- WriteLn(' FPosition(Before): ', FPosition);
- WriteLn(' FRowSize(Before): ', FRowSize);
- WriteLn(' FPosition(After): ', FPosition+Count);
- WriteLn(' FRowSize(After): ', StrLen(NewRow));
- //WriteLn(' Stream Value: ',NewRow);
- {$endif}
- FFieldRow := NewRow;
- FRowSize := StrLen(NewRow);
- Inc(FPosition, Count);
- if not (FDataset.State in [dsCalcFields, dsFilter, dsNewValue]) then
- FDataset.DataEvent(deFieldChange, PtrInt(FField));
- 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_SQLITEDS}
- WriteLn('##TDSStream.Read##');
- 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;
- begin
- Result := AllocMem(SizeOf(PPDataRecord));
- PDataRecord(Pointer(Result)^) := FBeginItem;
- end;
- procedure TCustomSqliteDataset.ClearCalcFields(Buffer: PChar);
- var
- i: Integer;
- RecordItem: PDataRecord;
- begin
- if FCalcFieldList = nil then
- Exit;
- RecordItem := PPDataRecord(Buffer)^;
- for i := FieldDefs.Count to FieldDefs.Count + FCalcFieldList.Count - 1 do
- begin
- StrDispose(RecordItem^.Row[i]);
- RecordItem^.Row[i] := nil;
- end;
- 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;
- FEndItem^.BookmarkFlag := bfEOF;
-
- FMasterLink := TMasterDataLink.Create(Self);
- FMasterLink.OnMasterChange := @MasterChanged;
- FMasterLink.OnMasterDisable := @MasterChanged;
- BookmarkSize := SizeOf(Pointer);
- FUpdatedItems := TFPList.Create;
- FAddedItems := TFPList.Create;
- FDeletedItems := TFPList.Create;
- FSQLList := TStringList.Create;
- inherited Create(AOwner);
- end;
- function TCustomSqliteDataset.CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream;
- begin
- if Mode = bmWrite then
- begin
- if not (State in [dsEdit, dsInsert]) then
- begin
- DatabaseErrorFmt(SNotEditing,[Name],Self);
- Exit;
- end;
- StrDispose(FCacheItem^.Row[Field.FieldNo - 1]);
- FCacheItem^.Row[Field.FieldNo - 1] := nil;
- end;
- Result := TDSStream.Create(Self, Field);
- end;
- procedure TCustomSqliteDataset.DoBeforeClose;
- begin
- if FSaveOnClose then
- ApplyUpdates;
- inherited DoBeforeClose;
- end;
- procedure TCustomSqliteDataset.DoAfterInsert;
- begin
- //an append or an insert in an empty dataset
- if EOF then
- FInsertBookmark := FEndItem
- else
- FInsertBookmark := FInternalActiveBuffer;
- inherited DoAfterInsert;
- end;
- procedure TCustomSqliteDataset.DoBeforeInsert;
- begin
- FInternalActiveBuffer := PPDataRecord(ActiveBuffer)^;
- inherited DoBeforeInsert;
- end;
- destructor TCustomSqliteDataset.Destroy;
- begin
- inherited Destroy;
- if FSqliteHandle <> nil then
- InternalCloseHandle;
- FUpdatedItems.Destroy;
- FAddedItems.Destroy;
- FDeletedItems.Destroy;
- FMasterLink.Destroy;
- FSQLList.Destroy;
- //lists created on demand
- FIndexFieldList.Free;
- FCalcFieldList.Free;
- // dispose special items
- Dispose(FBeginItem);
- Dispose(FCacheItem);
- Dispose(FEndItem);
- end;
- function TCustomSqliteDataset.BookmarkValid(ABookmark: TBookmark): Boolean;
- var
- TempItem: PDataRecord;
- begin
- Result := False;
- TempItem := FBeginItem^.Next;
- while TempItem <> FEndItem do
- begin
- if TempItem = PPDataRecord(ABookmark)^ then
- begin
- Result := True;
- Exit;
- end;
- TempItem := TempItem^.Next;
- end;
- end;
- function TCustomSqliteDataset.CompareBookmarks(Bookmark1, Bookmark2: TBookmark
- ): LongInt;
- var
- TempItem: PDataRecord;
- begin
- if PPDataRecord(Bookmark1)^ = PPDataRecord(Bookmark2)^ then
- begin
- Result := 0;
- Exit;
- end;
- //assume Bookmark1 < Bookmark2
- Result := -1;
- TempItem := PPDataRecord(Bookmark1)^^.Previous;
- while TempItem <> FBeginItem do
- begin
- if TempItem = PPDataRecord(Bookmark2)^ then
- begin
- //Bookmark1 is greater than Bookmark2
- Result := 1;
- Exit;
- end;
- TempItem := TempItem^.Previous;
- end;
- end;
- procedure TCustomSqliteDataset.CopyCacheToItem(AItem: PDataRecord);
- var
- i: Integer;
- begin
- for i := 0 to FRowCount - 1 do
- begin
- StrDispose(AItem^.Row[i]);
- AItem^.Row[i] := FCacheItem^.Row[i];
- FCacheItem^.Row[i] := nil;
- end;
- AItem^.BookmarkFlag := FCacheItem^.BookmarkFlag;
- end;
- function TCustomSqliteDataset.GetIndexFields(Value: Integer): TField;
- begin
- Result := TField(FIndexFieldList[Value]);
- end;
- procedure TCustomSqliteDataset.SetMasterIndexValue;
- var
- i: Integer;
- begin
- for i := 0 to FIndexFieldList.Count - 1 do
- TField(FIndexFieldList[i]).AsString := TField(FMasterLink.Fields[i]).AsString;
- end;
- procedure TCustomSqliteDataset.SetOptions(const AValue: TSqliteOptions);
- begin
- FOptions := AValue;
- end;
- procedure TCustomSqliteDataset.UpdateCalcFieldList;
- var
- i: Integer;
- AField: TField;
- begin
- if FCalcFieldList = nil then
- FCalcFieldList := TFPList.Create
- else
- FCalcFieldList.Clear;
- for i := 0 to Fields.Count - 1 do
- begin
- AField := Fields[i];
- if AField.FieldKind in [fkCalculated, fkLookup] then
- FCalcFieldList.Add(AField);
- end;
- end;
- procedure TCustomSqliteDataset.DisposeLinkedList;
- var
- TempItem: PDataRecord;
- i: Integer;
- begin
- //Todo: insert debug info
- //Todo: see if FDataAllocated is still necessary
- FDataAllocated := False;
- TempItem := FBeginItem^.Next;
- while TempItem^.Next <> nil do
- begin
- TempItem := TempItem^.Next;
- FreeItem(TempItem^.Previous);
- end;
- //Dispose Deleted Items
- //Directly access list pointer since the index check is already done in the loop
- for i := 0 to FDeletedItems.Count - 1 do
- FreeItem(PDataRecord(FDeletedItems.List^[i]));
- //Dispose FBeginItem.Row
- FreeMem(FBeginItem^.Row, FRowBufferSize);
-
- //Dispose cache item row
- for i:= 0 to FRowCount - 1 do
- StrDispose(FCacheItem^.Row[i]);
- FreeMem(FCacheItem^.Row, FRowBufferSize);
- 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;
- NativeFormat: Boolean): Boolean;
- var
- ValError: Word;
- FieldRow: PChar;
- FieldOffset: Integer;
- begin
- if Field.FieldNo >= 0 then
- FieldOffset := Field.FieldNo - 1
- else
- FieldOffset := FieldDefs.Count + FCalcFieldList.IndexOf(Field);
- if not (State in [dsCalcFields, dsInternalCalc]) then
- FieldRow := PPDataRecord(ActiveBuffer)^^.Row[FieldOffset]
- else
- FieldRow := PPDataRecord(CalcBuffer)^^.Row[FieldOffset];
- 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(String(FieldRow), LongInt(Buffer^), ValError);
- Result := ValError = 0;
- end;
- ftBoolean, ftWord:
- begin
- Val(String(FieldRow), Word(Buffer^), ValError);
- Result := ValError = 0;
- end;
- ftFloat, ftDateTime, ftTime, ftDate, ftCurrency:
- begin
- Val(String(FieldRow), Double(Buffer^), ValError);
- Result := ValError = 0;
- end;
- ftLargeInt:
- begin
- Val(String(FieldRow), Int64(Buffer^), ValError);
- Result := ValError = 0;
- end;
- end;
- end;
- end;
- function TCustomSqliteDataset.GetFieldData(Field: TField; Buffer: Pointer): Boolean;
- begin
- Result := GetFieldData(Field, Buffer, False);
- 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;
- GetCalcFields(Buffer);
- 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) or (State = dsInsert) then
- Exit;
- TempItem := FBeginItem;
- TempActive := PPDataRecord(ActiveBuffer)^;
- if TempActive = FCacheItem then // Record is being edited
- TempActive := FInternalActiveBuffer;
- //RecNo is 1 based
- Inc(Result);
- while TempActive <> TempItem do
- begin
- if TempItem^.Next <> nil then
- begin
- Inc(Result);
- TempItem := TempItem^.Next;
- end
- else
- begin
- Result := -1;
- DatabaseError('GetRecNo - ActiveItem Not Found', Self);
- break;
- end;
- end;
- end;
- function TCustomSqliteDataset.GetRecordSize: Word;
- begin
- Result := SizeOf(PPDataRecord); //??
- end;
- procedure TCustomSqliteDataset.InternalAddRecord(Buffer: Pointer; DoAppend: Boolean);
- var
- NewItem: PDataRecord;
- begin
- {$ifdef DEBUG_SQLITEDS}
- if PPDataRecord(ActiveBuffer)^ <> FCacheItem then
- DatabaseError('PPDataRecord(ActiveBuffer) <> FCacheItem - Problem', Self);
- {$endif}
- New(NewItem);
- GetMem(NewItem^.Row, FRowBufferSize);
- //if is a detail dataset then set the index value
- if FMasterLink.Active then
- SetMasterIndexValue;
- //necessary to nullify the Row before copy the cache
- FillChar(NewItem^.Row^, FRowBufferSize, #0);
- CopyCacheToItem(NewItem);
- //insert in the linked list
- FInsertBookmark^.Previous^.Next := NewItem;
- NewItem^.Next := FInsertBookmark;
- NewItem^.Previous := FInsertBookmark^.Previous;
- FInsertBookmark^.Previous := NewItem;
-
- //update the cursor
- FCurrentItem := NewItem;
-
- Inc(FRecordCount);
- if FAutoIncFieldNo <> - 1 then
- Inc(FNextAutoInc);
- FAddedItems.Add(NewItem);
- end;
- procedure TCustomSqliteDataset.InternalClose;
- begin
- //BindFields(False);
- if DefaultFields then
- DestroyFields;
- if FDataAllocated then
- DisposeLinkedList;
- FAddedItems.Clear;
- FUpdatedItems.Clear;
- FDeletedItems.Clear;
- FRecordCount := 0;
- end;
- procedure TCustomSqliteDataset.InternalCancel;
- var
- i: Integer;
- begin
- PPDataRecord(ActiveBuffer)^ := FInternalActiveBuffer;
- //free the cache
- for i:= 0 to FRowCount - 1 do
- begin
- StrDispose(FCacheItem^.Row[i]);
- FCacheItem^.Row[i] := nil;
- end;
- end;
- procedure TCustomSqliteDataset.InternalDelete;
- var
- TempItem: PDataRecord;
- ValError, TempInteger: Integer;
- begin
- Dec(FRecordCount);
- TempItem := PPDataRecord(ActiveBuffer)^;
- 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(String(TempItem^.Row[FAutoIncFieldNo]), TempInteger, ValError);
- if (ValError = 0) and (TempInteger = (FNextAutoInc - 1)) then
- Dec(FNextAutoInc);
- end;
- // Update item lists
- FUpdatedItems.Remove(TempItem);
- if FAddedItems.Remove(TempItem) = -1 then
- FDeletedItems.Add(TempItem)
- else
- FreeItem(TempItem);
- end;
- procedure TCustomSqliteDataset.InternalEdit;
- var
- i: Integer;
- begin
- FInternalActiveBuffer := PPDataRecord(ActiveBuffer)^;
- //copy active item to cache
- for i:= 0 to FRowCount - 1 do
- FCacheItem^.Row[i] := StrNew(FInternalActiveBuffer^.Row[i]);
- FCacheItem^.BookmarkFlag := FInternalActiveBuffer^.BookmarkFlag;
- //now active buffer is the cache item
- PPDataRecord(ActiveBuffer)^ := FCacheItem;
- end;
- procedure TCustomSqliteDataset.InternalFirst;
- begin
- FCurrentItem := FBeginItem;
- end;
- procedure TCustomSqliteDataset.InternalGotoBookmark(ABookmark: Pointer);
- begin
- FCurrentItem := PDataRecord(ABookmark^);
- end;
- procedure TCustomSqliteDataset.InternalInitFieldDefs;
- begin
- if FSQL = '' then
- begin
- if FTablename = '' then
- DatabaseError('Tablename not set', Self);
- FSQL := 'Select * from ' + FTableName + ';';
- end;
- if FSqliteHandle = nil then
- GetSqliteHandle;
- RetrieveFieldDefs;
- end;
- procedure TCustomSqliteDataset.InternalInitRecord(Buffer: PChar);
- var
- TempStr: String;
- begin
- if FAutoIncFieldNo <> - 1 then
- begin
- Str(FNextAutoInc, TempStr);
- FCacheItem^.Row[FAutoIncFieldNo] := StrAlloc(Length(TempStr) + 1);
- StrPCopy(FCacheItem^.Row[FAutoIncFieldNo], TempStr);
- end;
- PPDataRecord(Buffer)^ := FCacheItem;
- FCacheItem^.BookmarkFlag := bfInserted;
- end;
- procedure TCustomSqliteDataset.InternalLast;
- begin
- FCurrentItem := FEndItem;
- end;
- procedure TCustomSqliteDataset.InternalOpen;
- begin
- InternalInitFieldDefs;
- if DefaultFields then
- CreateFields;
- BindFields(True);
- if CalcFieldsSize > 0 then
- UpdateCalcFieldList;
- if FIndexFieldNames <> '' then
- UpdateIndexFieldList;
- if FMasterLink.DataSource <> nil then
- UpdateMasterDetailProperties;
- // Get PrimaryKeyNo if available
- if TDefCollection(FieldDefs).Find(FPrimaryKey) <> nil then
- FPrimaryKeyNo := FieldDefs.Find(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(nil, True)
- else
- begin
- CopyCacheToItem(FInternalActiveBuffer);
- PPDataRecord(ActiveBuffer)^ := FInternalActiveBuffer;
- if (FUpdatedItems.IndexOf(FInternalActiveBuffer) = -1) and
- (FAddedItems.IndexOf(FInternalActiveBuffer) = -1) then
- FUpdatedItems.Add(FInternalActiveBuffer);
- end;
- end;
- procedure TCustomSqliteDataset.InternalSetToRecord(Buffer: PChar);
- begin
- FCurrentItem := PPDataRecord(Buffer)^;
- end;
- function TCustomSqliteDataset.IsCursorOpen: Boolean;
- begin
- Result := FDataAllocated;
- end;
- type
- TLocateCompareFunction = function (Value: PChar; const Key: String): Boolean;
-
- TLocateFieldInfo = record
- Index: Integer;
- Key: String;
- CompFunction: TLocateCompareFunction;
- end;
- function CompInsensitivePartial(UTF8Value: PChar; const AnsiKey: String): Boolean;
- var
- AnsiValue: AnsiString;
- begin
- //see comments of CompInsensitive and CompInsensitiveWild functions
- if UTF8Value <> nil then
- begin
- AnsiValue := UTF8Decode(UTF8Value);
- Result := AnsiStrLIComp(PChar(AnsiValue), PChar(AnsiKey), Length(AnsiKey)) = 0;
- end
- else
- Result := False;
- end;
- function CompSensitivePartial(UTF8Value: PChar; const UTF8Key: String): Boolean;
- begin
- if UTF8Value <> nil then
- Result := StrLComp(UTF8Value, PChar(UTF8Key), Length(UTF8Key)) = 0
- else
- Result := False;
- end;
- function CompInsensitive(UTF8Value: PChar; const AnsiKey: String): Boolean;
- begin
- //fpc does not provide a function to compare UTF8 directly, so convert the
- //UTF8Value string to ansi through a temporary widestring and compare with the
- //AnsiKey (already encoded in the system ansi encoding).
- //In unix systems where UTF8 is the system ansi encoding this would not be
- //necessary but there's no direct way to check that
- //todo: change this code when fpc has better support for unicode
- if UTF8Value <> nil then
- Result := AnsiCompareText(UTF8Decode(UTF8Value), AnsiKey) = 0
- else
- Result := False;
- end;
- function CompSensitive(UTF8Value: PChar; const UTF8Key: String): Boolean;
- begin
- if UTF8Value <> nil then
- Result := StrComp(UTF8Value, PChar(UTF8Key)) = 0
- else
- Result := False;
- end;
- function CompSensitiveWild(UTF8Value: PChar; const UTF8Key: String): Boolean;
- begin
- if UTF8Value <> nil then
- Result := IsWild(String(UTF8Value), UTF8Key, False)
- else
- Result := False;
- end;
- function CompInsensitiveWild(UTF8Value: PChar; const AnsiKey: String): Boolean;
- begin
- //IsWild does not work with UTF8 encoded strings for case insensitive searches,
- //so convert UTF8Value to the system ansi encoding before passing to IsWild.
- //AnsiKey is already encoded in ansi
- //todo: change this code when fpc has better support for unicode
- if UTF8Value <> nil then
- Result := IsWild(UTF8Decode(UTF8Value), AnsiKey, True)
- else
- Result := False;
- end;
- function TCustomSqliteDataset.FindRecordItem(StartItem: PDataRecord; const KeyFields: string; const KeyValues: Variant; LocateOptions: TLocateOptions; DoResync:Boolean): PDataRecord;
- var
- LocateFields: array of TLocateFieldInfo;
- AFieldList: TList;
- i, AFieldCount: Integer;
- MatchRecord: Boolean;
- AValue: String;
- TempItem: PDataRecord;
-
- begin
- Result := nil;
- AFieldList := TList.Create;
- try
- GetFieldList(AFieldList, KeyFields);
- AFieldCount := AFieldList.Count;
- if AFieldCount > 1 then
- begin
- if VarIsArray(KeyValues) then
- begin
- if Succ(VarArrayHighBound(KeyValues, 1)) <> AFieldCount then
- DatabaseError('Number of fields does not correspond to number of values', Self);
- end
- else
- DatabaseError('Wrong number of values specified: expected an array of variants got a variant', Self);
- end;
-
- //set the array of the fields info
- SetLength(LocateFields, AFieldCount);
-
- for i := 0 to AFieldCount - 1 do
- with TField(AFieldList[i]) do
- begin
- if not (DataType in [ftFloat, ftDateTime, ftTime, ftDate]) then
- begin
- //the loPartialKey and loCaseInsensitive is ignored in numeric fields
- if DataType in [ftString, ftMemo] then
- begin
- if loPartialKey in LocateOptions then
- begin
- if loCaseInsensitive in LocateOptions then
- LocateFields[i].CompFunction := @CompInsensitivePartial
- else
- LocateFields[i].CompFunction := @CompSensitivePartial;
- end
- else
- if soWildcardKey in FOptions then
- begin
- if loCaseInsensitive in LocateOptions then
- LocateFields[i].CompFunction := @CompInsensitiveWild
- else
- LocateFields[i].CompFunction := @CompSensitiveWild;
- end
- else
- begin
- if loCaseInsensitive in LocateOptions then
- LocateFields[i].CompFunction := @CompInsensitive
- else
- LocateFields[i].CompFunction := @CompSensitive;
- end;
- end
- else
- LocateFields[i].CompFunction := @CompSensitive;
-
- if VarIsArray(KeyValues) then
- LocateFields[i].Key := VarToStr(KeyValues[i])
- else
- LocateFields[i].Key := VarToStr(KeyValues);
- //store Key encoded as the system ansi encoding
- if loCaseInsensitive in LocateOptions then
- LocateFields[i].Key := UTF8Decode(LocateFields[i].Key);
- end
- else
- begin
- LocateFields[i].CompFunction := @CompSensitive;
- //get float types in appropriate format
- if VarIsArray(KeyValues) then
- Str(VarToDateTime(keyvalues[i]), AValue)
- else
- Str(VarToDateTime(keyvalues), AValue);
- LocateFields[i].Key := Trim(AValue);
- end;
- LocateFields[i].Index := FieldNo - 1;
- end;
- finally
- AFieldList.Destroy;
- end;
- {$ifdef DEBUG_SQLITEDS}
- WriteLn('##TCustomSqliteDataset.FindRecordItem##');
- WriteLn(' KeyFields: ', KeyFields);
- for i := 0 to AFieldCount - 1 do
- begin
- WriteLn('LocateFields[', i, ']');
- WriteLn(' Key: ', LocateFields[i].Key);
- WriteLn(' Index: ', LocateFields[i].Index);
- end;
- {$endif}
- //Search the list
- TempItem := StartItem;
- while TempItem <> FEndItem do
- begin
- MatchRecord := True;
- for i:= 0 to AFieldCount - 1 do
- begin
- with LocateFields[i] do
- if not CompFunction(TempItem^.Row[Index], Key) then
- begin
- MatchRecord := False;
- break; //for
- end;
- end;
- if MatchRecord then
- begin
- Result := TempItem;
- if DoResync and (TempItem <> PPDataRecord(ActiveBuffer)^) then
- begin
- DoBeforeScroll;
- FCurrentItem := TempItem;
- Resync([]);
- DoAfterScroll;
- end;
- break; //while
- end;
- TempItem := TempItem^.Next;
- end;
- end;
- procedure TCustomSqliteDataset.UpdateMasterDetailProperties;
- var
- i: Integer;
- begin
- if FMasterLink.Active and (FIndexFieldList.Count <> FMasterLink.Fields.Count) then
- DatabaseError('MasterFields count doesn''t match IndexFields count', Self);
- if FieldDefs.Count > 0 then
- begin
- //build the sql template used to filter the dataset
- FSqlFilterTemplate := 'SELECT ';
- for i := 0 to FieldDefs.Count - 2 do
- FSqlFilterTemplate := FSqlFilterTemplate + FieldDefs[i].Name + ',';
- FSqlFilterTemplate := FSqlFilterTemplate + FieldDefs[FieldDefs.Count - 1].Name +
- ' FROM ' + FTableName;
- end;
- //set FSQL considering MasterSource active record
- SetDetailFilter;
- end;
- procedure TCustomSqliteDataset.GetSqliteHandle;
- begin
- if FFileName = '' then
- DatabaseError('Filename not set', Self);
- FSqliteHandle := InternalGetHandle;
- if Assigned(FOnGetHandle) then
- FOnGetHandle(Self);
- end;
- procedure TCustomSqliteDataset.FreeItem(AItem: PDataRecord);
- var
- i: Integer;
- begin
- for i:= 0 to FRowCount - 1 do
- StrDispose(AItem^.Row[i]);
- FreeMem(AItem^.Row, FRowBufferSize);
- Dispose(AItem);
- end;
- function TCustomSqliteDataset.Locate(const KeyFields: String; const KeyValues: Variant; LocateOptions: TLocateOptions): Boolean;
- begin
- CheckBrowseMode;
- Result := FindRecordItem(FBeginItem^.Next, KeyFields, KeyValues, LocateOptions, True) <> nil;
- end;
-
- function TCustomSqliteDataset.LocateNext(const KeyFields: String; const KeyValues: Variant; LocateOptions: TLocateOptions): Boolean;
- begin
- CheckBrowseMode;
- Result := FindRecordItem(PPDataRecord(ActiveBuffer)^^.Next, KeyFields, KeyValues, LocateOptions, True) <> nil;
- end;
-
- function TCustomSqliteDataset.Lookup(const KeyFields: String; const KeyValues: Variant; const ResultFields: String): Variant;
- var
- TempItem: PDataRecord;
- SaveState: TDataSetState;
- begin
- CheckBrowseMode;
- TempItem := FindRecordItem(FBeginItem^.Next, KeyFields, KeyValues, [], False);
- if TempItem <> nil then
- begin
- SaveState := SetTempState(dsInternalCalc);
- try
- CalculateFields(PChar(@TempItem));
- Result := FieldByName(ResultFields).Value;
- finally
- RestoreState(SaveState);
- end;
- end
- else
- Result := Null;
- end;
- procedure TCustomSqliteDataset.SetBookmarkData(Buffer: PChar; Data: Pointer);
- begin
- //The BookMarkData is the Buffer itself: no need to set nothing;
- 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;
- end;
- procedure TCustomSqliteDataset.SetFieldData(Field: TField; Buffer: Pointer;
- NativeFormat: Boolean);
- var
- TempStr: String;
- FloatStr: PChar;
- FloatLen, FieldOffset: Integer;
- EditItem: PDataRecord;
- begin
- if not (State in [dsEdit, dsInsert, dsCalcFields]) then
- DatabaseErrorFmt(SNotEditing, [Name], Self);
- if Field.FieldNo >= 0 then
- begin
- FieldOffset := Field.FieldNo - 1;
- EditItem := FCacheItem;
- end
- else
- begin
- FieldOffset := FieldDefs.Count + FCalcFieldList.IndexOf(Field);
- EditItem := PPDataRecord(CalcBuffer)^;
- end;
- StrDispose(EditItem^.Row[FieldOffset]);
- if Buffer <> nil then
- begin
- case Field.Datatype of
- ftString:
- begin
- EditItem^.Row[FieldOffset] := StrNew(PChar(Buffer));
- end;
- ftInteger:
- begin
- Str(LongInt(Buffer^), TempStr);
- EditItem^.Row[FieldOffset] := StrAlloc(Length(TempStr) + 1);
- Move(PChar(TempStr)^, (EditItem^.Row[FieldOffset])^, Length(TempStr) + 1);
- end;
- ftBoolean, ftWord:
- begin
- Str(Word(Buffer^), TempStr);
- EditItem^.Row[FieldOffset] := StrAlloc(Length(TempStr) + 1);
- Move(PChar(TempStr)^, (EditItem^.Row[FieldOffset])^, Length(TempStr) + 1);
- end;
- ftFloat, ftDateTime, ftDate, ftTime, ftCurrency:
- begin
- Str(Double(Buffer^), TempStr);
- //Str returns an space as the first character for positive values
- //and the - sign for negative values. It's necessary to remove the extra
- //space while keeping the - sign
- if TempStr[1] = ' ' then
- begin
- FloatStr := PChar(TempStr) + 1;
- FloatLen := Length(TempStr);
- end
- else
- begin
- FloatStr := PChar(TempStr);
- FloatLen := Length(TempStr) + 1;
- end;
- EditItem^.Row[FieldOffset] := StrAlloc(FloatLen);
- Move(FloatStr^, (EditItem^.Row[FieldOffset])^, FloatLen);
- end;
- ftLargeInt:
- begin
- Str(Int64(Buffer^), TempStr);
- EditItem^.Row[FieldOffset] := StrAlloc(Length(TempStr) + 1);
- Move(PChar(TempStr)^, (EditItem^.Row[FieldOffset])^, Length(TempStr) + 1);
- end;
- end;// case
- end//if
- else
- EditItem^.Row[FieldOffset] := nil;
- if not (State in [dsCalcFields, dsFilter, dsNewValue]) then
- DataEvent(deFieldChange, Ptrint(Field));
- end;
- procedure TCustomSqliteDataset.SetFieldData(Field: TField; Buffer: Pointer);
- begin
- SetFieldData(Field, Buffer, False);
- 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);
- CheckBrowseMode;
- TempItem := FBeginItem;
- for Counter := 1 to Value do
- TempItem := TempItem^.Next;
- if TempItem <> PPDataRecord(ActiveBuffer)^ then
- begin
- DoBeforeScroll;
- FCurrentItem := TempItem;
- Resync([]);
- DoAfterScroll;
- end;
- end;
- // Specific functions
- procedure TCustomSqliteDataset.SetDetailFilter;
- function FieldToSqlStr(AField: TField): String;
- begin
- if not AField.IsNull then
- begin
- case AField.DataType of
- //todo: handle " caracter properly
- ftString, ftMemo:
- Result := '"' + AField.AsString + '"';
- ftDateTime, ftDate, ftTime:
- Str(AField.AsDateTime, Result);
- else
- Result := AField.AsString;
- end; //case
- end
- else
- Result:=NullString;
- end; //function
- var
- AFilter: String;
- i: Integer;
- begin
- if (FMasterLink.Dataset.RecordCount = 0) or not FMasterLink.Active then //Retrieve all data
- FSQL := FSqlFilterTemplate
- else
- begin
- AFilter := ' where ';
- for i := 0 to FMasterLink.Fields.Count - 1 do
- begin
- AFilter := AFilter + IndexFields[i].FieldName + ' = ' + FieldToSqlStr(TField(FMasterLink.Fields[i]));
- if i <> FMasterLink.Fields.Count - 1 then
- AFilter := AFilter + ' and ';
- end;
- FSQL := FSqlFilterTemplate + AFilter;
- end;
- end;
- procedure TCustomSqliteDataset.MasterChanged(Sender: TObject);
- begin
- SetDetailFilter;
- {$ifdef DEBUG_SQLITEDS}
- WriteLn('##TCustomSqliteDataset.MasterChanged##');
- WriteLn(' SQL used to filter detail dataset:');
- WriteLn(' ', FSQL);
- {$endif}
- RefetchData;
- end;
- procedure TCustomSqliteDataset.SetMasterFields(const Value: String);
- begin
- FMasterLink.FieldNames := Value;
- if Active and FMasterLink.Active then
- begin
- UpdateIndexFieldList;
- 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.UpdateIndexFieldList;
- begin
- if FIndexFieldList = nil then
- FIndexFieldList := TList.Create
- else
- FIndexFieldList.Clear;
- try
- GetFieldList(FIndexFieldList, FIndexFieldNames);
- except
- on E: Exception do
- begin
- FIndexFieldList.Clear;
- DatabaseError('Error retrieving index fields: ' + E.Message);
- end;
- end;
- end;
- function TCustomSqliteDataset.GetMasterSource: TDataSource;
- begin
- Result := FMasterLink.DataSource;
- end;
- procedure TCustomSqliteDataset.SetFileName(const Value: String);
- begin
- if Value <> FFileName then
- begin
- if Active then
- DatabaseError('It''s not allowed to change Filename in an open dataset', Self);
- if FSqliteHandle <> nil then
- InternalCloseHandle;
- FFileName := Value;
- end;
- end;
- procedure TCustomSqliteDataset.SetMasterSource(Value: TDataSource);
- begin
- FMasterLink.DataSource := Value;
- end;
- procedure TCustomSqliteDataset.ExecSQL(const ASQL: String);
- begin
- if FSqliteHandle = nil then
- GetSqliteHandle;
- ExecuteDirect(ASQL);
- end;
- procedure TCustomSqliteDataset.ExecSQLList;
- begin
- if FSqliteHandle = nil then
- GetSqliteHandle;
- FReturnCode := SqliteExec(PChar(FSQLList.Text), nil, nil);
- if FReturnCode <> SQLITE_OK then
- DatabaseError(ReturnString, Self);
- end;
- function TCustomSqliteDataset.GetSQLValue(Values: PPChar; FieldIndex: Integer
- ): String;
- begin
- if (State = dsInactive) or (FieldIndex < 0) or (FieldIndex >= FieldDefs.Count) then
- DatabaseError('Error retrieving SQL value: dataset inactive or field out of range', Self);
- Result := FGetSqlStr[FieldIndex](Values[FieldIndex]);
- end;
- procedure TCustomSqliteDataset.ExecSQL;
- begin
- ExecSQL(FSQL);
- end;
- function TCustomSqliteDataset.ApplyUpdates: Boolean;
- var
- iFields, iItems, StatementsCounter: Integer;
- SQLTemp, WhereKeyNameEqual, SQLLine, TemplateStr: String;
- TempItem: PDataRecord;
- begin
- Result := False;
- CheckBrowseMode;
- if not UpdatesPending then
- begin
- Result := True;
- Exit;
- end;
- //A PrimaryKey is only necessary to update or delete records
- if FPrimaryKeyNo <> -1 then
- begin
- WhereKeyNameEqual := ' WHERE ' + FieldDefs[FPrimaryKeyNo].Name + ' = ';
- Result := True;
- end else if (FUpdatedItems.Count + FDeletedItems.Count) = 0 then
- Result := True;
- if not Result then
- Exit;
- FReturnCode := SQLITE_OK;
- StatementsCounter := 0;
- SQLTemp := 'BEGIN;';
- {$ifdef DEBUG_SQLITEDS}
- WriteLn('##TCustomSqliteDataset.ApplyUpdates##');
- if FPrimaryKeyNo = FAutoIncFieldNo then
- WriteLn(' Using an AutoInc field as primary key');
- WriteLn(' PrimaryKey: ', WhereKeyNameEqual);
- WriteLn(' PrimaryKeyNo: ', FPrimaryKeyNo);
- {$endif}
- // Delete Records
- if FDeletedItems.Count > 0 then
- begin
- TemplateStr := 'DELETE FROM ' + FTableName + WhereKeyNameEqual;
- for iItems := 0 to FDeletedItems.Count - 1 do
- begin
- TempItem := PDataRecord(FDeletedItems.List^[iItems]);
- SQLTemp := SQLTemp + (TemplateStr +
- FGetSqlStr[FPrimaryKeyNo](TempItem^.Row[FPrimaryKeyNo]) + ';');
- FreeItem(TempItem);
- Inc(StatementsCounter);
- //ApplyUpdates each 400 statements
- if StatementsCounter = 400 then
- begin
- SQLTemp := SQLTemp + 'COMMIT;';
- FReturnCode := SqliteExec(PChar(SQLTemp), nil, nil);
- StatementsCounter := 0;
- SQLTemp := 'BEGIN;';
- if FReturnCode <> SQLITE_OK then
- begin
- SqliteExec('ROLLBACK;', nil, nil);
- Break;
- end;
- end;
- end;
- end;
- // Update changed records
- if (FUpdatedItems.Count > 0) and (FReturnCode = SQLITE_OK) then
- begin
- TemplateStr := 'UPDATE ' + FTableName + ' SET ';
- for iItems := 0 to FUpdatedItems.Count - 1 do
- begin
- SQLLine := TemplateStr;
- for iFields := 0 to FieldDefs.Count - 2 do
- begin
- SQLLine := SQLLine + (FieldDefs[iFields].Name + ' = ' +
- FGetSqlStr[iFields](PDataRecord(FUpdatedItems[iItems])^.Row[iFields]) + ',');
- end;
- iFields := FieldDefs.Count - 1;
- SQLLine := SQLLine + (FieldDefs[iFields].Name + ' = ' +
- FGetSqlStr[iFields](PDataRecord(FUpdatedItems[iItems])^.Row[iFields]) +
- WhereKeyNameEqual +
- FGetSqlStr[FPrimaryKeyNo](PDataRecord(FUpdatedItems[iItems])^.Row[FPrimaryKeyNo]) + ';');
- SQLTemp := SQLTemp + SQLLine;
- Inc(StatementsCounter);
- //ApplyUpdates each 400 statements
- if StatementsCounter = 400 then
- begin
- SQLTemp := SQLTemp + 'COMMIT;';
- FReturnCode := SqliteExec(PChar(SQLTemp), nil, nil);
- StatementsCounter := 0;
- SQLTemp := 'BEGIN;';
- if FReturnCode <> SQLITE_OK then
- begin
- SqliteExec('ROLLBACK;', nil, nil);
- Break;
- end;
- end;
- end;
- end;
- // Add new records
- if (FAddedItems.Count > 0) and (FReturnCode = SQLITE_OK) then
- begin
- // Build TemplateStr
- TemplateStr := 'INSERT INTO ' + FTableName + ' (';
- for iFields := 0 to FieldDefs.Count - 2 do
- TemplateStr := TemplateStr + FieldDefs[iFields].Name + ',';
- TemplateStr := TemplateStr + FieldDefs[FieldDefs.Count - 1].Name + ') VALUES (';
- for iItems := 0 to FAddedItems.Count - 1 do
- begin
- SQLLine := TemplateStr;
- for iFields := 0 to FieldDefs.Count - 2 do
- SQLLine := SQLLine + (FGetSqlStr[iFields](PDataRecord(FAddedItems[iItems])^.Row[iFields]) + ',');
- iFields := FieldDefs.Count - 1;
- SQLLine := SQLLine + (FGetSqlStr[iFields](PDataRecord(FAddedItems[iItems])^.Row[iFields]) + ');' );
- SQLTemp := SQLTemp + SQLLine;
- Inc(StatementsCounter);
- //ApplyUpdates each 400 statements
- if StatementsCounter = 400 then
- begin
- SQLTemp := SQLTemp + 'COMMIT;';
- FReturnCode := SqliteExec(PChar(SQLTemp), nil, nil);
- StatementsCounter := 0;
- SQLTemp := 'BEGIN;';
- if FReturnCode <> SQLITE_OK then
- begin
- SqliteExec('ROLLBACK;', nil, nil);
- Break;
- end;
- end;
- end;
- end;
- FAddedItems.Clear;
- FUpdatedItems.Clear;
- FDeletedItems.Clear;
- if FReturnCode = SQLITE_OK then
- begin
- SQLTemp := SQLTemp + 'COMMIT;';
- FReturnCode := SqliteExec(PChar(SQLTemp), nil, nil);
- if FReturnCode <> SQLITE_OK then
- SqliteExec('ROLLBACK;', nil, nil);
- end;
- Result := FReturnCode = SQLITE_OK;
- {$ifdef DEBUG_SQLITEDS}
- WriteLn(' Result: ', Result);
- {$endif}
- end;
- procedure TCustomSqliteDataset.ClearUpdates(RecordStates: TRecordStateSet);
- begin
- if rsUpdated in RecordStates then
- FUpdatedItems.Clear;
- if rsDeleted in RecordStates then
- FDeletedItems.Clear;
- if rsAdded in RecordStates then
- FAddedItems.Clear;
- end;
- function TCustomSqliteDataset.CreateTable: Boolean;
- begin
- Result := CreateTable(FTableName);
- end;
- function TCustomSqliteDataset.CreateTable(const ATableName: String): Boolean;
- var
- SQLTemp: String;
- i, StrSize: Integer;
- begin
- {$ifdef DEBUG_SQLITEDS}
- WriteLn('##TCustomSqliteDataset.CreateTable##');
- if ATableName = '' then
- WriteLn(' TableName Not Set');
- if FieldDefs.Count = 0 then
- WriteLn(' FieldDefs Not Initialized');
- {$endif}
- if (ATableName <> '') and (FieldDefs.Count > 0) then
- begin
- SQLTemp := 'CREATE TABLE ' + ATableName + ' (';
- for i := 0 to FieldDefs.Count - 1 do
- begin
- //todo: add index to autoinc field
- SQLTemp := SQLTemp + FieldDefs[i].Name;
- case FieldDefs[i].DataType of
- ftInteger:
- SQLTemp := SQLTemp + ' INTEGER';
- ftString:
- begin
- StrSize := FieldDefs[i].Size;
- if StrSize = 0 then
- StrSize := DefaultStringSize;
- SQLTemp := SQLTemp + ' VARCHAR(' + IntToStr(StrSize) + ')';
- end;
- ftBoolean:
- SQLTemp := SQLTemp + ' BOOL_INT';
- 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_INT';
- ftMemo:
- SQLTemp := SQLTemp + ' TEXT';
- else
- DatabaseError('Field type "' + FieldTypeNames[FieldDefs[i].DataType] +
- '" not supported', Self);
- end;
- if UpperCase(FieldDefs[i].Name) = UpperCase(FPrimaryKey) then
- SQLTemp := SQLTemp + ' PRIMARY KEY';
- if i <> FieldDefs.Count - 1 then
- SQLTemp := SQLTemp + ' , ';
- end;
- SQLTemp := SQLTemp + ');';
- {$ifdef DEBUG_SQLITEDS}
- WriteLn(' SQL: ',SqlTemp);
- {$endif}
- ExecSQL(SQLTemp);
- Result := FReturnCode = SQLITE_OK;
- end
- else
- Result := False;
- end;
- procedure TCustomSqliteDataset.ExecCallback(const ASQL: String; UserData: Pointer = nil);
- var
- CallbackInfo: TCallbackInfo;
- begin
- if not Assigned(FOnCallback) then
- DatabaseError('OnCallback property not set', Self);
- if FSqliteHandle = nil then
- GetSqliteHandle;
- CallbackInfo.Data := UserData;
- CallbackInfo.Proc := FOnCallback;
- SqliteExec(PChar(ASQL), @CallbackDispatcher, @CallbackInfo);
- end;
- procedure TCustomSqliteDataset.QueryUpdates(RecordStates: TRecordStateSet; Callback: TQueryUpdatesCallback;
- UserData: Pointer = nil);
- var
- i: Integer;
- TempItem: PDataRecord;
- begin
- if not Assigned(Callback) then
- DatabaseError('Callback parameter not set', Self);
- CheckBrowseMode;
- if rsDeleted in RecordStates then
- with FDeletedItems do
- for i := 0 to Count - 1 do
- Callback(UserData,PDataRecord(Items[i])^.Row, nil, rsDeleted);
- if rsUpdated in RecordStates then
- with FUpdatedItems do
- for i := 0 to Count - 1 do
- begin
- TempItem := PDataRecord(Items[i]);
- Callback(UserData, TempItem^.Row, TBookmark(@TempItem), rsUpdated);
- end;
- if rsAdded in RecordStates then
- with FAddedItems do
- for i := 0 to Count - 1 do
- begin
- TempItem := PDataRecord(Items[i]);
- Callback(UserData, TempItem^.Row, TBookmark(@TempItem), rsAdded);
- end;
- end;
- procedure TCustomSqliteDataset.RefetchData;
- var
- i: Integer;
- begin
- //Close
- if FSaveOnRefetch then
- ApplyUpdates;
- if FDataAllocated then
- DisposeLinkedList;
- FAddedItems.Clear;
- FUpdatedItems.Clear;
- FDeletedItems.Clear;
- //Reopen
- BuildLinkedList;
- FCurrentItem := FBeginItem;
- for i := 0 to BufferCount - 1 do
- PPDataRecord(Buffers[i])^ := FBeginItem;
- Resync([]);
- DoAfterScroll;
- end;
- function TCustomSqliteDataset.TableExists: Boolean;
- begin
- Result:=TableExists(FTableName);
- end;
- function TCustomSqliteDataset.TableExists(const ATableName: String): Boolean;
- begin
- ExecSql('SELECT name FROM SQLITE_MASTER WHERE type = ''table'' AND name LIKE ''' + ATableName + ''';');
- Result := FReturnCode = SQLITE_ROW;
- end;
- function TCustomSqliteDataset.UpdatesPending: Boolean;
- begin
- 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.
|