Vichingo455-RePacks
/
xtool
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases 1 Wiki Activity
xtool/contrib/mORMot/SQLite3/mORMotVCL.pas

495 lines
18 KiB
ObjectPascal
Raw Blame History

/// DB VCL dataset using TSQLTable/TSQLTableJSON data access
// - this unit is a part of the freeware Synopse framework,
// licensed under a MPL/GPL/LGPL tri-license; version 1.18
unit mORMotVCL;
{
This file is part of Synopse mORmot framework.
Synopse mORMot framework. Copyright (C) 2022 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) 2022
the Initial Developer. All Rights Reserved.
Contributor(s):
- Alfred Glaenzer (alf)
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.17
- first public release, corresponding to Synopse mORMot Framework 1.17
Version 1.18
- renamed SQLite3VCL.pas to mORMotVCL.pas
- fixed ticket [9de8be5d9e] with some types like TEnumeration or TTimeLog
- fixed process with Unicode content
- introduced new aForceWideString optional parameter for ticket [2970335e40]
}
{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER
interface
uses
{$ifdef ISDELPHIXE2}System.SysUtils,{$else}SysUtils,{$endif}
Classes,
{$ifndef FPC}
Contnrs,
{$endif}
DB,
SynVirtualDataSet,
SynCommons, mORMot;
type
/// read-only virtual TDataSet able to access a TSQLTable
TSynSQLTableDataSet = class(TSynVirtualDataSet)
protected
fTable: TSQLTable;
{$ifndef UNICODE}
fForceWideString: boolean;
{$endif}
fTableShouldBeFreed: boolean;
fTemp64: Int64;
fTempBlob: TSQLRawBlob;
procedure InternalInitFieldDefs; override;
function GetRecordCount: Integer; override;
function GetRowFieldData(Field: TField; RowIndex: integer;
out ResultLen: Integer; OnlyCheckNull: boolean): Pointer; override;
function SearchForField(const aLookupFieldName: RawUTF8; const aLookupValue: variant;
aOptions: TLocateOptions): integer; override;
public
/// initialize the virtual TDataSet from a TSQLTable
// - WARNING: the supplied TSQLTable instance shall remain available
// all the time the returned TSynSQLTableDataSet instance is used, unless
// the TableShouldBeFreed property is set to true or CreateOwnedTable()
// constructor is used instead
// - with non-Unicode version of Delphi, you can set ForceWideString to
// force the use of WideString fields instead of AnsiString, if needed
// - the TDataSet will be opened once created
constructor Create(Owner: TComponent; Table: TSQLTable
{$ifndef UNICODE}; ForceWideString: boolean=false{$endif}); reintroduce;
/// initialize the virtual TDataSet owning a TSQLTable
// - this constructor will set TableShouldBeFreed to TRUE
// - with non-Unicode version of Delphi, you can set ForceWideString to
// force the use of WideString fields instead of AnsiString, if needed
// - the TDataSet will be opened once created
constructor CreateOwnedTable(Owner: TComponent; Table: TSQLTable
{$ifndef UNICODE}; ForceWideString: boolean=false{$endif}); reintroduce;
/// initialize the virtual TDataSet from a supplied JSON result
// - this constructor will parse the supplied JSON content and create
// an internal TSQLTableJSON instance to process the data, guessing the
// column types from the JSON content
// - with non-Unicode version of Delphi, you can set ForceWideString to
// force the use of WideString fields instead of AnsiString, if needed
// - the TDataSet will be opened once created
constructor CreateFromJSON(Owner: TComponent; const JSON: RawUTF8
{$ifndef UNICODE}; ForceWideString: boolean=false{$endif}); reintroduce; overload;
/// initialize the virtual TDataSet from a supplied JSON result
// - you can set the expected column types matching the results column layout
// - this constructor will parse the supplied JSON content and create
// an internal TSQLTableJSON instance to process the data
// - with non-Unicode version of Delphi, you can set ForceWideString to
// force the use of WideString fields instead of AnsiString, if needed
// - the TDataSet will be opened once created
constructor CreateFromJSON(Owner: TComponent; const JSON: RawUTF8;
const ColumnTypes: array of TSQLFieldType
{$ifndef UNICODE}; ForceWideString: boolean=false{$endif}); reintroduce; overload;
/// initialize the virtual TDataSet from a supplied JSON ORM result
// - you can set the TSQLRecord classes to retrieve the expected column types
// - this constructor will parse the supplied JSON content and create
// an internal TSQLTableJSON instance to process the data
// - with non-Unicode version of Delphi, you can set ForceWideString to
// force the use of WideString fields instead of AnsiString, if needed
// - the TDataSet will be opened once created
constructor CreateFromJSON(Owner: TComponent; const JSON: RawUTF8;
const Tables: array of TSQLRecordClass
{$ifndef UNICODE}; ForceWideString: boolean=false{$endif}); reintroduce; overload;
/// finalize the class instance
destructor Destroy; override;
/// if the supplied TSQLTable instance should be released with this class
// - Create() will left to FALSE (meaning that the TSQLTable instance shall
// remain available all the time the TSynSQLTableDataSet instance is used)
// - CreateOwnedTable() will set to TRUE if you want the TSQLTable to be
// freed when this TSynSQLTableDataSet instance will be released
// - you can also set it after Create(), on purpose
property TableShouldBeFreed: boolean read fTableShouldBeFreed write fTableShouldBeFreed;
/// access to the internal TSQLTable[JSON] data
// - you can use e.g. the SortFields() methods
// - you may change the table content on the fly, if the column remains the same
property Table: TSQLTable read fTable write fTable;
end;
/// store low-level DB.pas field information
// - as used by GetDBFieldDef and GetDBFieldValue
TDBFieldDef = record
FieldName: string;
DBType: TFieldType;
DBSize: Integer;
SQLType: TSQLFieldType;
SQLIndex: integer;
FieldType: PSQLTableFieldType;
end;
/// get low-level DB.pas field information
// - ready to be added to a TDataset as:
// ! aDataSet.FieldDefs.Add(FieldName,DBType,DBSize);
procedure GetDBFieldDef(aTable: TSQLTable; aField: integer;
out DBFieldDef: TDBFieldDef{$ifndef UNICODE}; aForceWideString: boolean=false{$endif});
/// fill a DB.pas field content
// - used e.g. by mORMotMidasVCL.ToClientDataSet
procedure GetDBFieldValue(aTable: TSQLTable; aRow: integer; aField: TField;
aDataSet: TDataSet; const DBFieldDef: TDBFieldDef);
/// convert a JSON result into a VCL DataSet, guessing the field types from the JSON
// - this function is just a wrapper around TSynSQLTableDataSet.CreateFromJSON()
// - with non-Unicode version of Delphi, you can set aForceWideString to
// force the use of WideString fields instead of AnsiString, if needed
// - with Unicode version of Delphi (2009+), string/UnicodeString will be used
function JSONToDataSet(aOwner: TComponent; const aJSON: RawUTF8
{$ifndef UNICODE}; aForceWideString: boolean=false{$endif}): TSynSQLTableDataSet; overload;
{$ifdef HASINLINE}inline;{$endif}
/// convert a JSON ORM result into a VCL DataSet, following TSQLRecord field types
// - this function is just a wrapper around TSynSQLTableDataSet.CreateFromJSON()
// - with non-Unicode version of Delphi, you can set aForceWideString to
// force the use of WideString fields instead of AnsiString, if needed
// - with Unicode version of Delphi (2009+), string/UnicodeString will be used
function JSONTableToDataSet(aOwner: TComponent; const aJSON: RawUTF8;
const Tables: array of TSQLRecordClass
{$ifndef UNICODE}; aForceWideString: boolean=false{$endif}): TSynSQLTableDataSet;
/// convert a JSON result into a VCL DataSet, with a given set of column types
// - this function is just a wrapper around TSynSQLTableDataSet.CreateFromJSON()
// - with non-Unicode version of Delphi, you can set aForceWideString to
// force the use of WideString fields instead of AnsiString, if needed
// - with Unicode version of Delphi (2009+), string/UnicodeString will be used
function JSONToDataSet(aOwner: TComponent; const aJSON: RawUTF8;
const ColumnTypes: array of TSQLFieldType
{$ifndef UNICODE}; aForceWideString: boolean=false{$endif}): TSynSQLTableDataSet; overload;
implementation
function JSONToDataSet(aOwner: TComponent; const aJSON: RawUTF8
{$ifndef UNICODE}; aForceWideString: boolean{$endif}): TSynSQLTableDataSet;
begin
result := TSynSQLTableDataSet.CreateFromJSON(
aOwner,aJSON{$ifndef UNICODE},aForceWideString{$endif});
end;
function JSONToDataSet(aOwner: TComponent; const aJSON: RawUTF8;
const ColumnTypes: array of TSQLFieldType
{$ifndef UNICODE}; aForceWideString: boolean{$endif}): TSynSQLTableDataSet;
begin
result := TSynSQLTableDataSet.CreateFromJSON(
aOwner,aJSON,ColumnTypes{$ifndef UNICODE},aForceWideString{$endif});
end;
function JSONTableToDataSet(aOwner: TComponent; const aJSON: RawUTF8;
const Tables: array of TSQLRecordClass
{$ifndef UNICODE}; aForceWideString: boolean{$endif}): TSynSQLTableDataSet;
begin
result := TSynSQLTableDataSet.CreateFromJSON(
aOwner,aJSON,Tables{$ifndef UNICODE},aForceWideString{$endif});
end;
{ TSynSQLTableDataSet }
constructor TSynSQLTableDataSet.Create(Owner: TComponent; Table: TSQLTable
{$ifndef UNICODE}; ForceWideString: boolean{$endif});
begin
inherited Create(Owner);
{$ifndef UNICODE}
fForceWideString := ForceWideString;
{$endif}
if Table<>nil then
fTable := Table;
Open;
end;
constructor TSynSQLTableDataSet.CreateOwnedTable(Owner: TComponent; Table: TSQLTable
{$ifndef UNICODE}; ForceWideString: boolean{$endif});
begin
Create(Owner,Table{$ifndef UNICODE},ForceWideString{$endif});
if Table<>nil then
fTableShouldBeFreed := true;
end;
constructor TSynSQLTableDataSet.CreateFromJSON(Owner: TComponent; const JSON: RawUTF8
{$ifndef UNICODE}; ForceWideString: boolean{$endif});
var T: TSQLTable;
begin
T := TSQLTableJSON.Create('',JSON);
try
CreateOwnedTable(Owner,T{$ifndef UNICODE},ForceWideString{$endif});
T := nil;
finally
T.Free; // release temporary instance in case of TSynSQLTableDataSet error
end;
end;
constructor TSynSQLTableDataSet.CreateFromJSON(Owner: TComponent; const JSON: RawUTF8;
const ColumnTypes: array of TSQLFieldType
{$ifndef UNICODE}; ForceWideString: boolean{$endif});
var T: TSQLTable;
begin
T := TSQLTableJSON.CreateWithColumnTypes(ColumnTypes,'',JSON);
try
CreateOwnedTable(Owner,T{$ifndef UNICODE},ForceWideString{$endif});
T := nil;
finally
T.Free; // release temporary instance in case of TSynSQLTableDataSet error
end;
end;
constructor TSynSQLTableDataSet.CreateFromJSON(Owner: TComponent; const JSON: RawUTF8;
const Tables: array of TSQLRecordClass
{$ifndef UNICODE}; ForceWideString: boolean{$endif});
var T: TSQLTable;
begin
T := TSQLTableJSON.CreateFromTables(Tables,'',JSON);
try
CreateOwnedTable(Owner,T{$ifndef UNICODE},ForceWideString{$endif});
T := nil;
finally
T.Free; // release temporary instance in case of TSynSQLTableDataSet error
end;
end;
destructor TSynSQLTableDataSet.Destroy;
begin
inherited;
if fTableShouldBeFreed then
FreeAndNil(fTable);
end;
function TSynSQLTableDataSet.GetRecordCount: Integer;
begin
if fTable<>nil then
result := fTable.RowCount else
result := 0;
end;
function TSynSQLTableDataSet.GetRowFieldData(Field: TField; RowIndex: integer;
out ResultLen: Integer; OnlyCheckNull: boolean): Pointer;
var info: PSQLTableFieldType;
F: integer;
P: PUTF8Char;
label Txt;
begin
result := nil;
F := Field.Index;
inc(RowIndex); // first TSQLTable row are field names
P := fTable.Get(RowIndex,F);
if P=nil then // null field or out-of-range RowIndex/F -> result := nil
exit;
result := @fTemp64; // let result point to Int64, Double or TDatetime
if OnlyCheckNull then
exit;
case fTable.FieldType(F,info) of
sftBoolean, sftInteger, sftID, sftTID:
SetInt64(P,fTemp64);
sftFloat, sftCurrency:
unaligned(PDouble(@fTemp64)^) := GetExtended(P);
sftEnumerate, sftSet:
if info^.ContentTypeInfo=nil then
SetInt64(P,fTemp64) else
goto Txt;
sftDateTime, sftDateTimeMS:
unaligned(PDouble(@fTemp64)^) := Iso8601ToDateTimePUTF8Char(P,0);
sftTimeLog, sftModTime, sftCreateTime:
unaligned(PDouble(@fTemp64)^) := TimeLogToDateTime(GetInt64(P));
sftUnixTime:
unaligned(PDouble(@fTemp64)^) := UnixTimeToDateTime(GetInt64(P));
sftUnixMSTime:
unaligned(PDouble(@fTemp64)^) := UnixMSTimeToDateTime(GetInt64(P));
sftBlob: begin
fTempBlob := BlobToTSQLRawBlob(P);
result := pointer(fTempBlob);
resultLen := length(fTempBlob);
end;
else begin // e.g. sftUTF8Text
Txt:result := P;
resultLen := StrLen(P);
end;
end;
end;
procedure GetDBFieldValue(aTable: TSQLTable; aRow: integer; aField: TField;
aDataSet: TDataSet; const DBFieldDef: TDBFieldDef);
var blob: TSQLRawBlob;
sstream,dstream: TStream;
P: PUTF8Char;
begin
if (aField<>nil) and (aRow>0) then
with DBFieldDef do begin
P := aTable.Get(aRow,SQLIndex);
if P=nil then
aField.Clear else
case SQLType of
sftBoolean:
aField.AsBoolean := GetInt64(P)<>0;
sftInteger, sftID, sftTID, sftSessionUserID:
if aField.DataType=ftLargeInt then // handle Int64 values directly
TLargeintField(aField).Value := GetInt64(P) else
aField.AsInteger := GetInteger(P);
sftFloat, sftCurrency:
aField.AsFloat := GetExtended(P);
sftEnumerate, sftSet:
if FieldType^.ContentTypeInfo=nil then
aField.AsInteger := GetInteger(P) else
aField.AsString := aTable.GetString(aRow,SQLIndex);
sftDateTime, sftDateTimeMS:
aField.AsDateTime := Iso8601ToDateTimePUTF8Char(P,0);
sftUnixTime:
aField.AsDateTime := UnixTimeToDateTime(GetInt64(P));
sftUnixMSTime:
aField.AsDateTime := UnixMSTimeToDateTime(GetInt64(P));
sftTimeLog, sftModTime, sftCreateTime:
aField.AsDateTime := TimeLogToDateTime(GetInt64(P));
sftBlob: begin
blob := BlobToTSQLRawBlob(P);
if (blob='') or (aDataSet=nil) then
aField.Clear else begin
sstream := TRawByteStringStream.Create(blob);
try
dstream := aDataSet.CreateBlobStream(aField,bmWrite);
try
dstream.CopyFrom(sstream,0);
finally
dstream.Free;
end;
finally
sstream.Free;
end;
end;
end;
sftUTF8Text:
if aField.DataType=ftWideString then
TWideStringField(aField).Value := aTable.GetSynUnicode(aRow,SQLIndex) else
aField.AsString := aTable.GetString(aRow,SQLIndex);
else
aField.AsVariant := aTable.GetVariant(aRow,SQLIndex);
end;
end;
end;
procedure GetDBFieldDef(aTable: TSQLTable; aField: integer;
out DBFieldDef: TDBFieldDef{$ifndef UNICODE}; aForceWideString: boolean{$endif});
begin
with DBFieldDef do begin
DBSize := 0;
SQLIndex := aField;
FieldName := aTable.GetString(0,aField);
if FieldName='' then begin
DBType := DB.ftUnknown;
SQLType := sftUnknown;
end else begin
SQLType := aTable.FieldType(aField,FieldType);
case SQLType of
sftBoolean:
DBType := ftBoolean;
sftInteger, sftID, sftTID:
DBType := ftLargeint; // LargeInt=Int64
sftFloat, sftCurrency:
DBType := ftFloat;
sftEnumerate, sftSet:
if FieldType^.ContentTypeInfo=nil then
DBType := ftInteger else begin
DBSize := 64;
DBType := ftDefaultVCLString;
end;
sftRecord: begin
DBSize := 64;
DBType := ftDefaultVCLString;
end;
sftDateTime, sftDateTimeMS, sftUnixTime, sftUnixMSTime,
sftTimeLog, sftModTime, sftCreateTime:
DBType := ftDateTime;
sftBlob: begin
DBSize := (aTable.FieldLengthMax(aField,true)*3) shr 2;
DBType := DB.ftBlob;
end;
sftUTF8Text: begin
DBSize := aTable.FieldLengthMax(aField,true);
{$ifndef UNICODE} // for Delphi 2009+ TWideStringField = UnicodeString!
if aForceWideString then
DBType := ftWideString else
{$endif}
DBType := ftDefaultVCLString;
end;
else begin
DBType := ftDefaultVCLString;
DBSize := aTable.FieldLengthMax(aField,true);
end;
end;
end;
end;
end;
procedure TSynSQLTableDataSet.InternalInitFieldDefs;
var F: Integer;
Def: TDBFieldDef;
begin
FieldDefs.Clear;
for F := 0 to fTable.FieldCount-1 do begin
GetDBFieldDef(fTable,F,Def{$ifndef UNICODE},fForceWideString{$endif});
FieldDefs.Add(Def.FieldName,Def.DBType,Def.DBSize);
end;
end;
function TSynSQLTableDataSet.SearchForField(const aLookupFieldName: RawUTF8;
const aLookupValue: variant; aOptions: TLocateOptions): integer;
var f: integer;
val: RawUTF8;
begin
f := Table.FieldIndex(aLookupFieldName);
if f<0 then
result := 0 else begin
VariantToUTF8(aLookupValue,val);
if loPartialKey in aOptions then
result := Table.SearchFieldIdemPChar(val,f) else
result := Table.SearchFieldEquals(val,f,1,not (loCaseInsensitive in aOptions));
end;
end;
end.
Reference in New Issue View Git Blame Copy Permalink