The generic list-based dataset is called TMdListDataSet and contains the list of objects, created when you open the dataset and freed when.
Generic Custom Dataset customized through RTTI In the 'Data aware controls???' thread, on 11/16/2000, Jeffrey Eib wrote: Quote> Possibly even better, though I haven't had time to experiment with this, -- Henry |
![Delphi generic tdataset Delphi generic tdataset](/uploads/1/2/5/8/125841372/375334095.png)
Re:Generic Custom Dataset customized through RTTIA fairly decent effort in this regard was done by Paul Johnson. You can obtain his Object DataSet from Torrys (www.torry.net). Just enter 'object dataset' in the quick search or go to DB Aware Components->Other->Tables. It is, at the very least, a pretty sound base on which to built something of greater functionality. You need to register your BO's with RegisterClass to make them accessible to the dataset and you probably need to put them into a package (along with a 'Register' procedure) and install this package in order to use the dataset in the IDE. Terry Field. Quote'Henry' <@> wrote in message news:3ba376b7_1@dnews... |
Re:Generic Custom Dataset customized through RTTIQuoteHenry <@> wrote in message news:3ba376b7_1@dnews... What I have implemented is to include in each business domain object, a class method which returns an array of the property definitions which the BDO makes available for dataset access. The declaration of the class method is: class function GetPropertyDefs: TFieldDataArray; override; TFieldDataArray is an open array of records with the following defintion: TFieldData = record FieldName: string; FieldType: TFieldType; FieldLength: integer; FieldReq: boolean; FieldReadOnly: boolean; end; The base dataset then queries the attached BDO for its property definitions and creates dataset fields, in DoCreateFieldDefs, based on the values returned: for Indx := 0 to Length(FFieldsDef) - 1 do with FFieldsDef[Indx] do FieldDefs.Add(UpperCase(FieldName), FieldType, FieldLength, FieldReq); I then use RTTI to access the values of the properties in GetFieldValue and SetFieldValue: PropTypeInfo := GetPropInfo(FBizObj.ClassInfo, FFieldsDef[Indx].FieldName); if (PropTypeInfo <> nil) then case FFieldsDef[Indx].FieldType of ftSmallint, ftInteger, ftWord, ftBoolean: begin Result := GetOrdProp(FBizObj, PropTypeInfo); Break; end; ftFloat, ftCurrency, ftBCD, ftDateTime: begin Result := GetFloatProp(FBizObj, PropTypeInfo); Break; end; ftString: begin Result := GetStrProp(FBizObj, PropTypeInfo); Break; end; end; This is just an overview, but it has been working nicely. Since I work for a business which becomes extremely busy for 6-7 months beginning in mid-March, I have been away from coding for awhile. When I left, I was working on making Master-Detail relationships work, mostly in notifying visual controls of the Detail part when the Master record has changed. I hope to get back into serious coding in the next few weeks. HTH Jeff Eib www.GarrettLiners.com P.S. One benefit of the way I coded this, is I have come up with a way of adding properties to a BDO without having to change the code. I use this mostly as a way of adding calculated or pre-formatted fields for the underlying BDO. I followed and implemented the Decorator pattern. Each additional decorator property that I add is then viewed by the dataset as just another field. |
![Delphi tdataset Delphi tdataset](http://www.delphisources.ru/pages/faq/master-delphi-7/content/images/fig17_07_0.jpg)
1. Custom-drawn TListView : how to customize subitem hints ?
2. Custom Dataset question
3. A problem with a Custom DataSet
4. Creating a custom dataset
5. Custom Dataset Problem ( TDataSet descendant )
6. ADO DataSet's Locate is more Slower then Client DataSet
7. AV when trying to copy from a normal dataset to a Memory Dataset
8. Copying Persistant Fields from Dataset to Dataset
9. To Borland: IDE difference between BDE Dataset and TADO dataset
10. Calling dataset.lookup changes state of dataset
PermalinkJoin GitHub today
GitHub is home to over 40 million developers working together to host and review code, manage projects, and build software together.
Sign up Find file Copy path
Cannot retrieve contributors at this time
/// DB VCL read-only virtual dataset |
// - this unit is a part of the freeware Synopse framework, |
// licensed under a MPL/GPL/LGPL tri-license; version 1.18 |
unit SynVirtualDataSet; |
{ |
This file is part of Synopse framework. |
Synopse framework. Copyright (C) 2019 Arnaud Bouchez |
Synopse Informatique - https://synopse.info |
*** BEGIN LICENSE BLOCK ***** |
Version: MPL 1.1/GPL 2.0/LGPL 2.1 |
The contents of this file are subject to the Mozilla Public License Version |
1.1 (the 'License'); you may not use this file except in compliance with |
the License. You may obtain a copy of the License at |
http://www.mozilla.org/MPL |
Software distributed under the License is distributed on an 'AS IS' basis, |
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License |
for the specific language governing rights and limitations under the License. |
The Original Code is Synopse mORMot framework. |
The Initial Developer of the Original Code is Arnaud Bouchez. |
Portions created by the Initial Developer are Copyright (C) 2019 |
the Initial Developer. All Rights Reserved. |
Contributor(s): |
- Alfred Glaenzer (alf) |
- Esteban Martin (EMartin) |
- mingda |
- Murat Ak |
- Valentin (StxLog) |
Alternatively, the contents of this file may be used under the terms of |
either the GNU General Public License Version 2 or later (the 'GPL'), or |
the GNU Lesser General Public License Version 2.1 or later (the 'LGPL'), |
in which case the provisions of the GPL or the LGPL are applicable instead |
of those above. If you wish to allow use of your version of this file only |
under the terms of either the GPL or the LGPL, and not to allow others to |
use your version of this file under the terms of the MPL, indicate your |
decision by deleting the provisions above and replace them with the notice |
and other provisions required by the GPL or the LGPL. If you do not delete |
the provisions above, a recipient may use your version of this file under |
the terms of any one of the MPL, the GPL or the LGPL. |
***** END LICENSE BLOCK ***** |
Version 1.18 |
- first public release, corresponding to Synopse mORMot Framework 1.18 |
} |
{$I Synopse.inc}// define HASINLINE CPU32 CPU64 OWNNORMTOUPPER |
interface |
uses |
SysUtils, |
Classes, |
{$ifndef FPC} |
Contnrs, |
{$endif} |
{$ifndef NOVARIANTS} |
Variants, |
{$endif} |
SynCommons, |
SynTable, |
{$ifdef ISDELPHIXE2} |
System.Generics.Collections, |
Data.DB, Data.FMTBcd; |
{$else} |
DB, FMTBcd; |
{$endif} |
type |
{$ifndef UNICODE}// defined as TRecordBuffer = PByte in newer DB.pas |
TRecordBuffer = PChar; |
{$endif} |
PDateTimeRec = ^TDateTimeRec; |
/// read-only virtual TDataSet able to access any content |
TSynVirtualDataSet = class(TDataSet) |
protected |
fCurrentRow: integer; |
fIsCursorOpen: boolean; |
// TDataSet overridden methods |
functionAllocRecordBuffer: TRecordBuffer; override; |
procedureFreeRecordBuffer(var Buffer: TRecordBuffer); override; |
procedureInternalInitRecord(Buffer: TRecordBuffer); override; |
functionGetCanModify: Boolean; override; |
procedureGetBookmarkData(Buffer: TRecordBuffer; Data: Pointer); override; |
functionGetBookmarkFlag(Buffer: TRecordBuffer): TBookmarkFlag; override; |
functionGetRecord(Buffer: TRecordBuffer; GetMode: TGetMode; DoCheck: Boolean): TGetResult; override; |
functionGetRecordSize: Word; override; |
procedureInternalClose; override; |
procedureInternalFirst; override; |
procedureInternalGotoBookmark(Bookmark: Pointer); override; |
procedureInternalHandleException; override; |
procedureInternalLast; override; |
procedureInternalSetToRecord(Buffer: TRecordBuffer); override; |
functionIsCursorOpen: Boolean; override; |
procedureSetBookmarkFlag(Buffer: TRecordBuffer; Value: TBookmarkFlag); override; |
procedureSetBookmarkData(Buffer: TRecordBuffer; Data: Pointer); override; |
procedureSetRecNo(Value: Integer); override; |
functionGetRecNo: Integer; override; |
// classses should override all those following methods: |
// - to read the data e.g. into memory: |
procedureInternalOpen; override; |
// - to initialize FieldDefs: |
// procedure InternalInitFieldDefs; override; |
// - to return row count: |
// function GetRecordCount: Integer; override; |
// - result should point to Int64,Double,Blob,UTF8 data (if ResultLen<>nil) |
functionGetRowFieldData(Field: TField; RowIndex: integer; out ResultLen: Integer; |
OnlyCheckNull: boolean): Pointer; virtual; abstract; |
// - to search for a field, returning RecNo (0 = not found by default) |
functionSearchForField(const aLookupFieldName: RawUTF8; const aLookupValue: variant; |
aOptions: TLocateOptions): integer; virtual; |
{$ifndef NOVARIANTS} |
// used to serialize TBCDVariant as JSON - BcdRead will always fail |
classprocedureBcdWrite(const aWriter: TTextWriter; const aValue); |
//class function BcdRead(P: PUTF8Char; var aValue; out aValid: Boolean): PUTF8Char; |
{$endif} |
public |
/// this overridden constructor will compute an unique Name property |
constructor Create(Owner: TComponent); override; |
/// get BLOB column data for the current active row |
// - handle ftBlob,ftMemo,ftWideMemo via GetRowFieldData() |
functionCreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override; |
/// get BLOB column data for a given row (may not the active row) |
// - handle ftBlob,ftMemo,ftWideMemo via GetRowFieldData() |
functionGetBlobStream(Field: TField; RowIndex: integer): TStream; |
/// get column data for the current active row |
// - handle ftBoolean,ftInteger,ftLargeint,ftFloat,ftCurrency,ftDate,ftTime, |
// ftDateTime,ftString,ftWideString kind of fields via GetRowFieldData() |
{$ifdef ISDELPHIXE3} |
{$ifdef ISDELPHIXE4} |
functionGetFieldData(Field: TField; var Buffer: TValueBuffer): Boolean; override; |
{$else} |
functionGetFieldData(Field: TField; Buffer: TValueBuffer): Boolean; override; |
{$endif} |
{$else} |
functionGetFieldData(Field: TField; Buffer: pointer): Boolean; override; |
{$endif} |
{$ifndef UNICODE} |
functionGetFieldData(Field: TField; Buffer: pointer; NativeFormat: Boolean): Boolean; override; |
{$endif} |
/// searching a dataset for a specified record and making it the active record |
// - will call SearchForField protected virtual method for actual lookup |
functionLocate(const KeyFields: string; const KeyValues: Variant; |
Options: TLocateOptions) : boolean; override; |
published |
property Active; |
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 OnCalcFields; |
property OnDeleteError; |
property OnEditError; |
property OnFilterRecord; |
property OnNewRecord; |
property OnPostError; |
end; |
{$ifndef NOVARIANTS} |
/// read-only virtual TDataSet able to access a dynamic array of TDocVariant |
// - could be used e.g. from the result of TMongoCollection.FindDocs() to |
// avoid most temporary conversion into JSON or TClientDataSet buffers |
TDocVariantArrayDataSet = class(TSynVirtualDataSet) |
protected |
fValues: TVariantDynArray; |
fColumns: arrayofrecord |
Name: RawUTF8; |
FieldType: TSQLDBFieldType; |
end; |
fTemp64: Int64; |
fTempUTF8: RawUTF8; |
fTempBlob: RawByteString; |
procedureInternalInitFieldDefs; override; |
functionGetRecordCount: Integer; override; |
functionGetRowFieldData(Field: TField; RowIndex: integer; |
out ResultLen: Integer; OnlyCheckNull: boolean): Pointer; override; |
functionSearchForField(const aLookupFieldName: RawUTF8; const aLookupValue: variant; |
aOptions: TLocateOptions): integer; override; |
public |
/// initialize the virtual TDataSet from a dynamic array of TDocVariant |
// - you can set the expected column names and types matching the results |
// document layout - if no column information is specified, the first |
// TDocVariant will be used as reference |
constructor Create(Owner: TComponent; const Data: TVariantDynArray; |
const ColumnNames: arrayof RawUTF8; const ColumnTypes: arrayof TSQLDBFieldType); reintroduce; |
end; |
{$endif} |
const |
/// map the VCL string type, depending on the Delphi compiler version |
{$ifdef UNICODE} |
ftDefaultVCLString = ftWideString; |
{$else} |
ftDefaultVCLString = ftString; |
{$endif} |
/// map the best ft*Memo type available, depending on the Delphi compiler version |
{$ifdef ISDELPHI2007ANDUP} |
ftDefaultMemo = ftWideMemo; |
{$else} |
ftDefaultMemo = ftMemo; |
{$endif} |
/// append a TBcd value as text to the output buffer |
// - very optimized for speed |
procedureAddBcd(WR: TTextWriter; const AValue: TBcd); |
type |
/// a string buffer, used by InternalBCDToBuffer to store its output text |
TBCDBuffer = array[0..66] of AnsiChar; |
/// convert a TBcd value as text to the output buffer |
// - buffer is to be array[0..66] of AnsiChar |
// - returns the resulting text start in PBeg, and the length as function result |
// - does not handle negative sign and 0 value - see AddBcd() function use case |
// - very optimized for speed |
functionInternalBCDToBuffer(const AValue: TBcd; out ADest: TBCDBuffer; var PBeg: PAnsiChar): integer; |
/// convert a TBcd value into a currency |
// - purepascal version included in latest Delphi versions is slower than this |
functionBCDToCurr(const AValue: TBcd; var Curr: Currency): boolean; |
/// convert a TBcd value into a RawUTF8 text |
// - will call fast InternalBCDToBuffer function |
procedureBCDToUTF8(const AValue: TBcd; var result: RawUTF8); overload; |
/// convert a TBcd value into a RawUTF8 text |
// - will call fast InternalBCDToBuffer function |
functionBCDToUTF8(const AValue: TBcd): RawUTF8; overload; |
{$ifdef HASINLINE}inline;{$endif} |
/// convert a TBcd value into a VCL string text |
// - will call fast InternalBCDToBuffer function |
functionBCDToString(const AValue: TBcd): string; |
/// export all rows of a TDataSet into JSON |
// - will work for any kind of TDataSet |
functionDataSetToJSON(Data: TDataSet): RawUTF8; |
{$ifndef NOVARIANTS} |
/// convert a dynamic array of TDocVariant result into a VCL DataSet |
// - this function is just a wrapper around TDocVariantArrayDataSet.Create() |
// - the TDataSet will be opened once created |
functionToDataSet(aOwner: TComponent; const Data: TVariantDynArray; |
const ColumnNames: arrayof RawUTF8; const ColumnTypes: arrayof TSQLDBFieldType): TDocVariantArrayDataSet; overload; |
{$endif} |
implementation |
functionInternalBCDToBuffer(const AValue: TBcd; out ADest: TBCDBuffer; var PBeg: PAnsiChar): integer; |
var i,DecimalPos: integer; |
P,Frac: PByte; |
PEnd: PAnsiChar; |
begin |
result := 0; |
if AValue.Precision=0then |
exit; |
DecimalPos := AValue.Precision-(AValue.SignSpecialPlaces and $3F); |
P := @ADest; |
Frac := @Avalue.Fraction; |
for i := 0to AValue.Precision-1dobegin |
if i=DecimalPos then |
if i=0thenbegin |
PWord(P)^ := ord('0')+ord('.')shl8; |
inc(P,2); |
endelsebegin |
P^ := ord('.'); |
inc(P); |
end; |
if (i and1)=0then |
P^ := ((Frac^ and $F0) shr4)+ord('0') elsebegin |
P^ := ((Frac^ and $0F))+ord('0'); |
inc(Frac); |
end; |
inc(P); |
end; |
// remove trailing 0 after decimal |
if AValue.Precision>DecimalPos thenbegin |
repeat dec(P) until (P^<>ord('0')) or (P=@ADest); |
PEnd := pointer(P); |
if PEnd^<>'.'then |
inc(PEnd); |
endelse |
PEnd := pointer(P); |
PEnd^ := #0; |
// remove leading 0 |
PBeg := @ADest; |
while (PBeg[0]='0') and (PBeg[1] in ['0'..'9']) do inc(PBeg); |
result := PEnd-PBeg; |
end; |
procedureAddBcd(WR: TTextWriter; const AValue: TBcd); |
var len: integer; |
PBeg: PAnsiChar; |
tmp: TBCDBuffer; |
begin |
len := InternalBCDToBuffer(AValue,tmp,PBeg); |
if len<=0then |
WR.Add('0') elsebegin |
if AValue.SignSpecialPlaces and $80=$80then |
WR.Add('-'); |
WR.AddNoJSONEscape(PBeg,len); |
end; |
end; |
functionBCDToCurr(const AValue: TBcd; var Curr: Currency): boolean; |
var len: integer; |
PBeg: PAnsiChar; |
tmp: TBCDBuffer; |
begin |
len := InternalBCDToBuffer(AValue,tmp,PBeg); |
if len<=0then |
Curr := 0elsebegin |
PInt64(@Curr)^ := StrToCurr64(pointer(PBeg)); |
if AValue.SignSpecialPlaces and $80=$80then |
Curr := -Curr; |
end; |
result := true; |
end; |
procedureBCDToUTF8(const AValue: TBcd; var result: RawUTF8); |
var len: integer; |
PBeg: PAnsiChar; |
tmp: TBCDBuffer; |
begin |
len := InternalBCDToBuffer(AValue,tmp,PBeg); |
SetString(result,PBeg,len); |
end; |
functionBCDToUTF8(const AValue: TBcd): RawUTF8; |
begin |
BCDToUTF8(AValue,result); |
end; |
functionBCDToString(const AValue: TBcd): string; |
var len: integer; |
PBeg: PAnsiChar; |
tmp: TBCDBuffer; |
begin |
len := InternalBCDToBuffer(AValue,tmp,PBeg); |
Ansi7ToString(PWinAnsiChar(PBeg),len,result); |
end; |
var |
GlobalDataSetCount: integer; |
type |
/// define how a single row is identified |
// - for TSynVirtualDataSet, it is just the row index (starting at 0) |
TRecInfoIdentifier = integer; |
PRecInfoIdentifier = ^TRecInfoIdentifier; |
/// pointer to an internal structure used to identify a row position |
PRecInfo = ^TRecInfo; |
/// internal structure used to identify a row position |
TRecInfo = record |
/// define how a single row is identified |
RowIndentifier: TRecInfoIdentifier; |
/// any associated bookmark |
Bookmark: TRecInfoIdentifier; |
/// any associated bookmark flag |
BookmarkFlag: TBookmarkFlag; |
end; |
{ TSynVirtualDataSet } |
functionTSynVirtualDataSet.AllocRecordBuffer: TRecordBuffer; |
begin |
result := AllocMem(sizeof(TRecInfo)); |
end; |
procedureTSynVirtualDataSet.FreeRecordBuffer(var Buffer: TRecordBuffer); |
begin |
FreeMem(Buffer); |
Buffer := nil; |
end; |
procedureTSynVirtualDataSet.GetBookmarkData(Buffer: TRecordBuffer; Data: Pointer); |
begin |
PRecInfoIdentifier(Data)^ := PRecInfo(Buffer)^.Bookmark; |
end; |
functionTSynVirtualDataSet.GetBookmarkFlag(Buffer: TRecordBuffer): TBookmarkFlag; |
begin |
result := PRecInfo(Buffer)^.BookmarkFlag; |
end; |
functionTSynVirtualDataSet.GetCanModify: Boolean; |
begin |
result := false; // we define a READ-ONLY TDataSet |
end; |
{$ifndef UNICODE} |
functionTSynVirtualDataSet.GetFieldData(Field: TField; Buffer: Pointer; |
NativeFormat: Boolean): Boolean; |
begin |
if Field.DataType in [ftWideString] then |
NativeFormat := true; // to force Buffer as PWideString |
Result := inherited GetFieldData(Field, Buffer, NativeFormat); |
end; |
{$endif} |
{$ifdef ISDELPHIXE3} |
{$ifdef ISDELPHIXE4} |
functionTSynVirtualDataSet.GetFieldData(Field: TField; var Buffer: TValueBuffer): Boolean; |
{$else} |
functionTSynVirtualDataSet.GetFieldData(Field: TField; Buffer: TValueBuffer): Boolean; |
{$endif} |
{$else} |
functionTSynVirtualDataSet.GetFieldData(Field: TField; Buffer: Pointer): Boolean; |
{$endif} |
var Data, Dest: pointer; |
RowIndex, DataLen, MaxLen: integer; |
Temp: RawByteString; |
OnlyTestForNull: boolean; |
TS: TTimeStamp; |
begin |
OnlyTestForNull := (Buffer=nil); |
RowIndex := PRecInfo(ActiveBuffer).RowIndentifier; |
Data := GetRowFieldData(Field,RowIndex,DataLen,OnlyTestForNull); |
result := Data<>nil; // null field or out-of-range RowIndex/Field |
if OnlyTestForNull ornot result then |
exit; |
Dest := pointer(Buffer); // works also if Buffer is [var] TValueBuffer |
case Field.DataType of// Data^ points to Int64,Double,Blob,UTF8 |
ftBoolean: |
PWORDBOOL(Dest)^ := PBoolean(Data)^; |
ftInteger: |
PInteger(Dest)^ := PInteger(Data)^; |
ftLargeint, ftFloat, ftCurrency: |
PInt64(Dest)^ := PInt64(Data)^; |
ftDate, ftTime, ftDateTime: |
if PDateTime(Data)^=0then// handle 30/12/1899 date as NULL |
result := false elsebegin// inlined DataConvert(Field,Data,Dest,true) |
TS := DateTimeToTimeStamp(PDateTime(Data)^); |
case Field.DataType of |
ftDate: PDateTimeRec(Dest)^.Date := TS.Date; |
ftTime: PDateTimeRec(Dest)^.Time := TS.Time; |
ftDateTime: |
if (TS.Time<0) or (TS.Date<=0) then |
result := false else// matches ValidateTimeStamp() expectations |
PDateTimeRec(Dest)^.DateTime := TimeStampToMSecs(TS); |
end; // see NativeToDateTime/DateTimeToNative in TDataSet.DataConvert |
end; |
ftString: begin |
if DataLen<>0thenbegin |
CurrentAnsiConvert.UTF8BufferToAnsi(Data,DataLen,Temp); |
DataLen := length(Temp); |
MaxLen := Field.DataSize-1; // without trailing #0 |
if DataLen>MaxLen then |
DataLen := MaxLen; |
move(pointer(Temp)^,Dest^,DataLen); |
end; |
PAnsiChar(Dest)[DataLen] := #0; |
end; |
ftWideString: begin |
{$ifdef ISDELPHI2007ANDUP}// here Dest = PWideChar[] of DataSize bytes |
if DataLen=0then |
PWideChar(Dest)^ := #0else |
UTF8ToWideChar(Dest,Data,(Field.DataSize-2)shr1,DataLen); |
{$else}// here Dest is PWideString |
UTF8ToWideString(Data,DataLen,WideString(Dest^)); |
{$endif} |
end; |
// ftBlob,ftMemo,ftWideMemo should be retrieved by CreateBlobStream() |
else raise EDatabaseError.CreateFmt('%s.GetFieldData unhandled DataType=%s (%d)', |
[ClassName,GetEnumName(TypeInfo(TFieldType),ord(Field.DataType))^,ord(Field.DataType)]); |
end; |
end; |
functionTSynVirtualDataSet.GetBlobStream(Field: TField; RowIndex: integer): TStream; |
var Data: pointer; |
DataLen: integer; |
begin |
Data := GetRowFieldData(Field,RowIndex,DataLen,false); |
if Data=nilthen// should point to Blob or UTF8 data |
result := nilelse |
case Field.DataType of |
ftBlob: |
result := TSynMemoryStream.Create(Data,DataLen); |
ftMemo, ftString: |
result := TRawByteStringStream.Create(CurrentAnsiConvert.UTF8BufferToAnsi(Data,DataLen)); |
{$ifdef ISDELPHI2007ANDUP} ftWideMemo, {$endif} ftWideString: |
result := TRawByteStringStream.Create(Utf8DecodeToRawUnicode(Data,DataLen)); |
else raise EDatabaseError.CreateFmt('%s.CreateBlobStream DataType=%d', |
[ClassName,ord(Field.DataType)]); |
end; |
end; |
functionTSynVirtualDataSet.CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; |
begin |
if Mode<>bmRead then |
raise EDatabaseError.CreateFmt('%s BLOB should be ReadOnly',[ClassName]); |
result := GetBlobStream(Field,PRecInfo(ActiveBuffer).RowIndentifier); |
if result=nilthen |
result := TSynMemoryStream.Create; // null BLOB returns a void TStream |
end; |
functionTSynVirtualDataSet.GetRecNo: Integer; |
begin |
result := fCurrentRow+1; |
end; |
functionTSynVirtualDataSet.GetRecord(Buffer: TRecordBuffer; GetMode: TGetMode; |
DoCheck: Boolean): TGetResult; |
begin |
result := grOK; |
case GetMode of |
gmPrior: |
if fCurrentRow>0then |
dec(fCurrentRow) else |
result := grBOF; |
gmCurrent: |
if fCurrentRow<0then |
result := grBOF else |
if fCurrentRow>=GetRecordCount then |
result := grEOF; |
gmNext: |
if fCurrentRow<GetRecordCount-1then |
inc(fCurrentRow) else |
result := grEOF; |
end; |
if result=grOK then |
with PRecInfo(Buffer)^ dobegin |
RowIndentifier := fCurrentRow; |
BookmarkFlag := bfCurrent; |
Bookmark := fCurrentRow; |
end; |
end; |
functionTSynVirtualDataSet.GetRecordSize: Word; |
begin |
result := SizeOf(TRecInfoIdentifier); // excluding Bookmark information |
end; |
procedureTSynVirtualDataSet.InternalClose; |
begin |
BindFields(false); |
{$ifdef ISDELPHIXE6} |
ifnot(lcPersistent in Fields.LifeCycles) then |
{$else} |
if DefaultFields then |
{$endif} |
DestroyFields; |
fIsCursorOpen := False; |
end; |
procedureTSynVirtualDataSet.InternalFirst; |
begin |
fCurrentRow := -1; |
end; |
procedureTSynVirtualDataSet.InternalGotoBookmark(Bookmark: Pointer); |
begin |
fCurrentRow := PRecInfoIdentifier(Bookmark)^; |
end; |
procedureTSynVirtualDataSet.InternalHandleException; |
begin |
if Assigned(Classes.ApplicationHandleException) then |
Classes.ApplicationHandleException(ExceptObject) else |
SysUtils.ShowException(ExceptObject,ExceptAddr); |
end; |
procedureTSynVirtualDataSet.InternalInitRecord(Buffer: TRecordBuffer); |
begin |
FillcharFast(Buffer^,sizeof(TRecInfo),0); |
end; |
procedureTSynVirtualDataSet.InternalLast; |
begin |
fCurrentRow := GetRecordCount; |
end; |
procedureTSynVirtualDataSet.InternalOpen; |
begin |
BookmarkSize := SizeOf(TRecInfo)-sizeof(TRecInfoIdentifier); |
InternalInitFieldDefs; |
{$ifdef ISDELPHIXE6} |
ifnot(lcPersistent in Fields.LifeCycles) then |
{$else} |
if DefaultFields then |
{$endif} |
CreateFields; |
BindFields(true); |
fCurrentRow := -1; |
fIsCursorOpen := True; |
end; |
procedureTSynVirtualDataSet.InternalSetToRecord(Buffer: TRecordBuffer); |
begin |
fCurrentRow := PRecInfo(Buffer).RowIndentifier; |
end; |
functionTSynVirtualDataSet.IsCursorOpen: Boolean; |
begin |
result := fIsCursorOpen; |
end; |
procedureTSynVirtualDataSet.SetBookmarkData(Buffer: TRecordBuffer; Data: Pointer); |
begin |
PRecInfo(Buffer)^.Bookmark := PRecInfoIdentifier(Data)^; |
end; |
procedureTSynVirtualDataSet.SetBookmarkFlag(Buffer: TRecordBuffer; Value: TBookmarkFlag); |
begin |
PRecInfo(Buffer)^.BookmarkFlag := Value; |
end; |
procedureTSynVirtualDataSet.SetRecNo(Value: Integer); |
begin |
CheckBrowseMode; |
ifValue<>RecNo thenbegin |
dec(Value); |
if cardinal(Value)>=cardinal(GetRecordCount) then |
raise ERangeError.CreateFmt('%s.SetRecNo(%d) with Count=%d', |
[ClassName,Value+1,GetRecordCount]); |
DoBeforeScroll; |
fCurrentRow := Value; |
Resync([rmCenter]); |
DoAfterScroll; |
end; |
end; |
constructor TSynVirtualDataSet.Create(Owner: TComponent); |
begin |
inherited Create(Owner); |
inc(GlobalDataSetCount); |
Name := ClassName+IntToStr(GlobalDataSetCount); // force unique name |
end; |
functionTSynVirtualDataSet.SearchForField(const aLookupFieldName: RawUTF8; |
const aLookupValue: variant; aOptions: TLocateOptions): integer; |
begin |
result := 0; // nothing found |
end; |
functionTSynVirtualDataSet.Locate(const KeyFields: string; |
const KeyValues: Variant; Options: TLocateOptions) : boolean; |
var i, l, h, found: Integer; |
{$ifdef ISDELPHIXE4} |
FieldList: TList<TField>; |
{$else} |
FieldList: TList; |
{$endif} |
begin |
CheckActive; |
result := true; |
ifnot IsEmpty then |
if VarIsArray(KeyValues) thenbegin |
{$ifdef ISDELPHIXE4} |
FieldList := TList<TField>.Create; |
{$else} |
FieldList := TList.Create; |
{$endif} |
try |
GetFieldList(FieldList,KeyFields); |
l := VarArrayLowBound(KeyValues,1); |
h := VarArrayHighBound(KeyValues,1); |
if (FieldList.Count = 1) and (l < h) thenbegin |
found := SearchForField(StringToUTF8(KeyFields),KeyValues,Options); |
if found>0thenbegin |
RecNo := found; |
exit; |
end; |
end |
elsefor i := 0to FieldList.Count - 1dobegin |
found := SearchForField(StringToUTF8(TField(FieldList[i]).FieldName), |
KeyValues[l+i],Options); |
if found>0thenbegin |
RecNo := found; |
exit; |
end; |
end; |
finally |
FieldList.Free; |
end; |
endelsebegin |
found := SearchForField(StringToUTF8(KeyFields),KeyValues,Options); |
if found>0thenbegin |
RecNo := found; |
exit; |
end; |
end; |
result := false; |
end; |
{$ifndef NOVARIANTS} |
type// as in FMTBcd.pas |
TFMTBcdData = class(TPersistent) |
private |
FBcd: TBcd; |
end; |
TFMTBcdVarData = packedrecord |
VType: TVarType; |
Reserved1, Reserved2, Reserved3: Word; |
VBcd: TFMTBcdData; |
Reserved4: Cardinal; |
end; |
classprocedureTSynVirtualDataSet.BcdWrite(const aWriter: TTextWriter; const aValue); |
begin |
AddBCD(aWriter,TFMTBcdVarData(aValue).VBcd.FBcd); |
end; |
{$endif NOVARIANTS} |
functionDataSetToJSON(Data: TDataSet): RawUTF8; |
var W: TJSONWriter; |
f: integer; |
blob: TRawByteStringStream; |
begin |
result := 'null'; |
if Data=nilthen |
exit; |
Data.First; |
if Data.Eof then |
exit; |
W := TJSONWriter.Create(nil,true,false); |
try |
// get col names and types |
SetLength(W.ColNames,Data.FieldCount); |
for f := 0to high(W.ColNames) do |
StringToUTF8(Data.FieldDefs[f].Name,W.ColNames[f]); |
W.AddColumns; |
W.Add('['); |
repeat |
W.Add('{'); |
for f := 0to Data.FieldCount-1dobegin |
W.AddString(W.ColNames[f]); |
with Data.Fields[f] do |
if IsNull then |
W.AddShort('null') else |
case DataType of |
ftBoolean: |
W.Add(AsBoolean); |
ftSmallint, ftInteger, ftWord, ftAutoInc: |
W.Add(AsInteger); |
ftLargeint: |
W.Add(TLargeintField(Data.Fields[f]).AsLargeInt); |
ftFloat, ftCurrency: // TCurrencyField is sadly a TFloatField |
W.Add(AsFloat,TFloatField(Data.Fields[f]).Precision); |
ftBCD: |
W.AddCurr64(AsCurrency); |
ftFMTBcd: |
AddBcd(W,AsBCD); |
ftTimeStamp, ftDate, ftTime, ftDateTime: begin |
W.Add('''); |
W.AddDateTime(AsDateTime); |
W.Add('''); |
end; |
ftString, ftFixedChar, ftMemo: begin |
W.Add('''); |
W.AddAnsiString({$ifdef UNICODE}AsAnsiString{$else}AsString{$endif}, |
twJSONEscape); |
W.Add('''); |
end; |
ftWideString: begin |
W.Add('''); |
W.AddJSONEscapeW(pointer(TWideStringField(Data.Fields[f]).Value)); |
W.Add('''); |
end; |
ftVariant: |
W.AddVariant(AsVariant); |
ftBytes, ftVarBytes, ftBlob, ftGraphic, ftOraBlob, ftOraClob: begin |
blob := TRawByteStringStream.Create; |
try |
(Data.Fields[f] as TBlobField).SaveToStream(blob); |
W.WrBase64(pointer(blob.DataString),length(blob.DataString),true); |
finally |
blob.Free; |
end; |
end; |
{$ifdef ISDELPHI2007ANDUP} |
ftWideMemo, ftFixedWideChar: begin |
W.Add('''); |
W.AddJSONEscapeW(pointer(AsWideString)); |
W.Add('''); |
end; |
{$endif} |
{$ifdef UNICODE} |
ftShortint, ftByte: |
W.Add(AsInteger); |
ftLongWord: |
W.AddU(TLongWordField(Data.Fields[f]).Value); |
ftExtended: |
W.Add(AsFloat,DOUBLE_PRECISION); |
ftSingle: |
W.Add(AsFloat,SINGLE_PRECISION); |
{$endif} |
else W.AddShort('null'); // unhandled field type |
end; |
W.Add(','); |
end; |
W.CancelLastComma; |
W.Add('}',','); |
Data.Next; |
until Data.Eof; |
W.CancelLastComma; |
W.Add(']'); |
W.SetText(result); |
finally |
W.Free; |
end; |
end; |
{ TDocVariantArrayDataSet } |
constructor TDocVariantArrayDataSet.Create(Owner: TComponent; |
const Data: TVariantDynArray; const ColumnNames: arrayof RawUTF8; |
const ColumnTypes: arrayof TSQLDBFieldType); |
var n,ndx,j: integer; |
first: PDocVariantData; |
begin |
fValues := Data; |
n := Length(ColumnNames); |
if n>0thenbegin |
if n<>length(ColumnTypes) then |
raise ESynException.CreateUTF8('%.Create(ColumnNames<>ColumnTypes)',[self]); |
SetLength(fColumns,n); |
for ndx := 0to n-1dobegin |
fColumns[ndx].Name := ColumnNames[ndx]; |
fColumns[ndx].FieldType := ColumnTypes[ndx]; |
end; |
endelse |
if fValues<>nilthenbegin |
first := _Safe(fValues[0],dvObject); |
SetLength(fColumns,first^.Count); |
for ndx := 0to first^.Count-1dobegin |
fColumns[ndx].Name := first^.Names[ndx]; |
fColumns[ndx].FieldType := VariantTypeToSQLDBFieldType(first^.Values[ndx]); |
case fColumns[ndx].FieldType of |
SynTable.ftNull: |
fColumns[ndx].FieldType := SynTable.ftBlob; |
SynTable.ftCurrency: |
fColumns[ndx].FieldType := SynTable.ftDouble; |
SynTable.ftInt64: // ensure type coherency of whole column |
for j := 1to first^.Count-1do |
if j>=Length(fValues) then// check objects are consistent |
break else |
with _Safe(fValues[j],dvObject)^ do |
if (ndx<Length(Names)) and IdemPropNameU(Names[ndx],fColumns[ndx].Name) then |
if VariantTypeToSQLDBFieldType(Values[ndx]) in |
[SynTable.ftNull,SynTable.ftDouble,SynTable.ftCurrency] thenbegin |
fColumns[ndx].FieldType := SynTable.ftDouble; |
break; |
end; |
end; |
end; |
end; |
inherited Create(Owner); |
end; |
functionTDocVariantArrayDataSet.GetRecordCount: Integer; |
begin |
result := length(fValues); |
end; |
functionTDocVariantArrayDataSet.GetRowFieldData(Field: TField; |
RowIndex: integer; out ResultLen: Integer; OnlyCheckNull: boolean): Pointer; |
var F,ndx: integer; |
wasString: Boolean; |
begin |
result := nil; |
F := Field.Index; |
if (cardinal(RowIndex)<cardinal(length(fValues))) and |
(cardinal(F)<cardinal(length(fColumns))) and |
not (fColumns[F].FieldType in [ftNull,SynTable.ftUnknown,SynTable.ftCurrency]) then |
with _Safe(fValues[RowIndex])^ do |
if (Kind=dvObject) and (Count>0) thenbegin |
if IdemPropNameU(fColumns[F].Name,Names[F]) then |
ndx := F else// optimistic match |
ndx := GetValueIndex(fColumns[F].Name); |
if ndx>=0then |
if VarIsEmptyOrNull(Values[ndx]) then |
exit elsebegin |
result := @fTemp64; |
ifnot OnlyCheckNull then |
case fColumns[F].FieldType of |
ftInt64: |
VariantToInt64(Values[ndx],fTemp64); |
ftDouble,SynTable.ftDate: |
VariantToDouble(Values[ndx],PDouble(@fTemp64)^); |
ftUTF8: begin |
VariantToUTF8(Values[ndx],fTempUTF8,wasString); |
result := pointer(fTempUTF8); |
ResultLen := length(fTempUTF8); |
end; |
SynTable.ftBlob: begin |
VariantToUTF8(Values[ndx],fTempUTF8,wasString); |
if Base64MagicCheckAndDecode(pointer(fTempUTF8),length(fTempUTF8),fTempBlob) thenbegin |
result := pointer(fTempBlob); |
ResultLen := length(fTempBlob); |
end; |
end; |
end; |
end; |
end; |
end; |
procedureTDocVariantArrayDataSet.InternalInitFieldDefs; |
const TYPES: array[TSQLDBFieldType] of TFieldType = ( |
// ftUnknown, ftNull, ftInt64, ftDouble, ftCurrency, ftDate, ftUTF8, ftBlob |
ftWideString,ftWideString,ftLargeint,ftFloat,ftFloat,ftDate,ftWideString,ftBlob); |
var F,siz: integer; |
begin |
FieldDefs.Clear; |
for F := 0to high(fColumns) dobegin |
if fColumns[F].FieldType=ftUTF8 then |
siz := 16else |
siz := 0; |
FieldDefs.Add(UTF8ToString(fColumns[F].Name),TYPES[fColumns[F].FieldType],siz); |
end; |
end; |
functionTDocVariantArrayDataSet.SearchForField(const aLookupFieldName: RawUTF8; |
const aLookupValue: variant; aOptions: TLocateOptions): integer; |
var f: integer; |
begin |
f := -1; // allows O(1) field lookup for invariant object columns |
for result := 1to length(fValues) do |
with _Safe(fValues[result-1])^ do |
if (Kind=dvObject) and (Count>0) thenbegin |
if (cardinal(f)>=cardinal(Count)) or |
not IdemPropNameU(aLookupFieldName,Names[f]) then |
f := GetValueIndex(aLookupFieldName); |
if (f>=0) and (SortDynArrayVariantComp(TVarData(Values[f]), |
TVarData(aLookupValue),loCaseInsensitive in aOptions)=0) then |
exit; |
end; |
result := 0; |
end; |
functionToDataSet(aOwner: TComponent; const Data: TVariantDynArray; |
const ColumnNames: arrayof RawUTF8; const ColumnTypes: arrayof TSQLDBFieldType): TDocVariantArrayDataSet; overload; |
begin |
result := TDocVariantArrayDataSet.Create(aOwner,Data,ColumnNames,ColumnTypes); |
result.Open; |
end; |
initialization |
{$ifndef NOVARIANTS} |
TTextWriter.RegisterCustomJSONSerializerForVariantByType( |
VarFMTBcd,nil,TSynVirtualDataSet.BcdWrite); |
{$endif} |
end. |
Copy lines Copy permalink