paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-22 09:50:24 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Stream TBufdataset fmtBcd fields (xml)

Browse Source 
* Stream TBufdataset blob and memo-fields (xml)
 * Refactored code to recognize xml-fieldtypes
 * ftVarBytes fields do not have the 'Binary' subtype (delphi compat)
 * Use fielddefs instead of fields to stream dataset (fixes problems with 
   calculated fields)
 * Added basic blob-tests

git-svn-id: trunk@21735 -
This commit is contained in:
joost 2012-06-29 16:04:55 +00:00
parent bb28a7cd08
commit 4151e3f2c1
5 changed files with 181 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
packages/fcl-db/src/base/bufdataset.pas
View File

@ -457,7 +457,6 @@ type
procedure InitDefaultIndexes;
protected
procedure UpdateIndexDefs; override;
function GetNewBlobBuffer : PBlobBuffer;
function GetNewWriteBlobBuffer : PBlobBuffer;
procedure FreeBlobBuffer(var ABlobBuffer: PBlobBuffer);
procedure SetRecNo(Value: Longint); override;
@ -523,6 +522,7 @@ type
function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override;
procedure AddIndex(const AName, AFields : string; AOptions : TIndexOptions; const ADescFields: string = '';
const ACaseInsFields: string = ''); virtual;
function GetNewBlobBuffer : PBlobBuffer;
procedure SetDatasetPacket(AReader : TDataPacketReader);
procedure GetDatasetPacket(AWriter : TDataPacketReader);

89
packages/fcl-db/src/base/xmldatapacketreader.pp
View File

@ -62,7 +62,7 @@ type
implementation
uses xmlwrite, xmlread;
uses xmlwrite, xmlread, base64;
const
XMLFieldtypenames : Array [TFieldType] of String[15] =
@ -74,21 +74,21 @@ const
'i4',
'boolean',
'r8',
'r8',
'r8:Money',
'fixed',
'date',
'time',
'datetime',
'bin.hex',
'bin.hex',
'i4',
'bin.hex',
'bin.hex',
'bin.hex',
'bin.hex',
'bin.hex',
'bin.hex',
'bin.hex',
'i4:Autoinc',
'bin.hex:Binary',
'bin.hex:Text',
'bin.hex:Graphics',
'bin.hex:Formatted',
'bin.hex:Ole',
'bin.hex:Ole',
'bin.hex:Graphics',
'',
'string',
'string',
@ -104,7 +104,7 @@ const
'',
'',
'',
'',
'fixedFMT',
'',
''
);
@ -137,6 +137,7 @@ var i : integer;
AFieldDef : TFieldDef;
iFieldType : TFieldType;
FTString : string;
SubFTString : string;
AFieldNode : TDOMNode;
begin
@ -160,6 +161,9 @@ begin
AFieldDef.Name:=GetNodeAttribute(AFieldNode,'attrname');
AFieldDef.Size:=StrToIntDef(GetNodeAttribute(AFieldNode,'width'),0);
FTString:=GetNodeAttribute(AFieldNode,'fieldtype');
SubFTString:=GetNodeAttribute(AFieldNode,'subtype');
if SubFTString<>'' then
FTString:=FTString+':'+SubFTString;
AFieldDef.DataType:=ftUnknown;
for iFieldType:=low(TFieldType) to high(TFieldType) do
@ -181,8 +185,9 @@ end;
procedure TXMLDatapacketReader.StoreFieldDefs(AFieldDefs: TFieldDefs);
var i : integer;
var i,p : integer;
AFieldNode : TDOMElement;
AStringFT : string;
begin
XMLDocument := TXMLDocument.Create;
@ -198,22 +203,15 @@ begin
if Name <> '' then AFieldNode.SetAttribute('fieldname',Name);
AFieldNode.SetAttribute('attrname',DisplayName);
if size <> 0 then AFieldNode.SetAttribute('width',IntToStr(Size));
AFieldNode.SetAttribute('fieldtype',XMLFieldtypenames[DataType]);
case DataType of
ftAutoInc : begin
AFieldNode.SetAttribute('readonly','true');
AFieldNode.SetAttribute('subtype','Autoinc');
end;
ftCurrency: AFieldNode.SetAttribute('subtype','Money');
ftVarBytes,
ftBlob : AFieldNode.SetAttribute('subtype','Binary');
ftMemo : AFieldNode.SetAttribute('subtype','Text');
ftTypedBinary,
ftGraphic: AFieldNode.SetAttribute('subtype','Graphics');
ftFmtMemo : AFieldNode.SetAttribute('subtype','Formatted');
ftParadoxOle,
ftDBaseOle : AFieldNode.SetAttribute('subtype','Ole');
end; {case}
AStringFT:=XMLFieldtypenames[DataType];
p := pos(':',AStringFT);
if p > 1 then
begin
AFieldNode.SetAttribute('fieldtype',copy(AStringFT,1,p-1));
AFieldNode.SetAttribute('subtype',copy(AStringFT,p+1,25));
end
else
AFieldNode.SetAttribute('fieldtype',AStringFT);
if faReadonly in Attributes then AFieldNode.SetAttribute('readonly','true');
FieldsNode.AppendChild(AFieldNode);
@ -329,28 +327,49 @@ begin
end;
procedure TXMLDatapacketReader.RestoreRecord(ADataset : TCustomBufDataset);
var FieldNr : integer;
AFieldNode : TDomNode;
var FieldNr : integer;
AFieldNode : TDomNode;
ABufBlobField: TBufBlobField;
AField: TField;
s: string;
begin
with ADataset do for FieldNr:=0 to FieldCount-1 do
with ADataset do for FieldNr:=0 to FieldDefs.Count-1 do
begin
AFieldNode := FRecordNode.Attributes.GetNamedItem(Fields[FieldNr].FieldName);
AFieldNode := FRecordNode.Attributes.GetNamedItem(FieldDefs[FieldNr].Name);
if assigned(AFieldNode) then
begin
Fields[FieldNr].AsString := AFieldNode.NodeValue; // set it to the filterbuffer
if FieldDefs[FieldNr].DataType in [ftMemo,ftBlob] then
begin
ABufBlobField.BlobBuffer:=ADataset.GetNewBlobBuffer;
afield := Fields.FieldByNumber(FieldDefs[FieldNr].FieldNo);
AField.SetData(@ABufBlobField);
s := AFieldNode.NodeValue;
if (FieldDefs[FieldNr].DataType = ftBlob) and (s<>'') then
s := DecodeStringBase64(s);
ABufBlobField.BlobBuffer^.Size:=length(s);
ReAllocMem(ABufBlobField.BlobBuffer^.Buffer,ABufBlobField.BlobBuffer^.Size);
move(s[1],ABufBlobField.BlobBuffer^.Buffer^,ABufBlobField.BlobBuffer^.Size);
end
else
Fields.FieldByNumber(FieldDefs[FieldNr].FieldNo).AsString := AFieldNode.NodeValue; // set it to the filterbuffer
end
end;
end;
procedure TXMLDatapacketReader.StoreRecord(ADataset : TCustomBufDataset; ARowState : TRowState; AUpdOrder : integer = 0);
var FieldNr : Integer;
AField: TField;
ARecordNode : TDOMElement;
begin
inc(FEntryNr);
ARecordNode := XMLDocument.CreateElement('ROW');
for FieldNr := 0 to ADataset.Fields.Count-1 do
for FieldNr := 0 to ADataset.FieldDefs.Count-1 do
begin
ARecordNode.SetAttribute(ADataset.fields[FieldNr].FieldName,ADataset.fields[FieldNr].AsString);
AField := ADataset.Fields.FieldByNumber(ADataset.FieldDefs[FieldNr].FieldNo);
if AField.DataType=ftBlob then
ARecordNode.SetAttribute(AField.FieldName,EncodeStringBase64(AField.AsString))
else
ARecordNode.SetAttribute(AField.FieldName,AField.AsString);
end;
if ARowState<>[] then
begin

91
packages/fcl-db/tests/testbufdatasetstreams.pas
View File

@ -69,6 +69,8 @@ type
procedure TestSeveralEditsXML;
procedure TestDeleteAllXML;
procedure TestDeleteAllInsertXML;
procedure TestStreamingBlobFieldsXML;
procedure TestStreamingBigBlobFieldsXML;
procedure TestAppendDeleteBIN;
@ -452,6 +454,95 @@ begin
TestChangesXML(@DeleteAllInsertChange);
end;
procedure TTestBufDatasetStreams.TestStreamingBlobFieldsXML;
var SaveDs: TCustomBufDataset;
LoadDs: TCustomBufDataset;
begin
SaveDs := DBConnector.GetFieldDataset as TCustomBufDataset;
SaveDs.Open;
SaveDs.SaveToFile('FieldsDS.xml',dfXML);
LoadDs := TCustomBufDataset.Create(nil);
LoadDs.LoadFromFile('FieldsDS.xml');
LoadDS.First;
SaveDS.First;
while not LoadDS.EOF do
begin
AssertEquals(LoadDS.FieldByName('FBLOB').AsString,SaveDS.FieldByName('FBLOB').AsString);
AssertEquals(LoadDS.FieldByName('FMEMO').AsString,SaveDS.FieldByName('FMEMO').AsString);
LoadDS.Next;
SaveDS.Next;
end;
LoadDs.Free;
end;
procedure TTestBufDatasetStreams.TestStreamingBigBlobFieldsXML;
var
SaveDs: TCustomBufDataset;
LoadDs: TCustomBufDataset;
j: integer;
i: byte;
s: string;
f: file of byte;
fn: string;
fs: TMemoryStream;
begin
// Create a temp. file with blob-data.
fn := GetTempFileName;
assign(f,fn);
Rewrite(f);
s := 'This is a blob-field test file.';
for j := 0 to 250 do
begin
for i := 1 to length(s) do
write(f,ord(s[i]));
for i := 0 to 255 do
write(f,i);
end;
close(f);
try
// Open dataset and set blob-field-data to content of blob-file.
SaveDs := DBConnector.GetFieldDataset(true) as TCustomBufDataset;
SaveDs.Open;
SaveDs.Edit;
TBlobField(SaveDs.FieldByName('FBLOB')).LoadFromFile(fn);
SaveDs.Post;
// Save this dataset to file.
SaveDs.SaveToFile('FieldsDS.xml',dfXML);
// Load this file in another dataset
LoadDs := TCustomBufDataset.Create(nil);
try
LoadDs.LoadFromFile('FieldsDS.xml');
LoadDS.First;
// Compare the content of the blob-field with the file on disc
fs := TMemoryStream.Create;
try
TBlobField(SaveDs.FieldByName('FBLOB')).SaveToStream(fs);
fs.Seek(0,soBeginning);
assign(f,fn);
reset(f);
for j := 0 to fs.Size-1 do
begin
read(f,i);
CheckEquals(i,fs.ReadByte);
end;
finally
fs.free;
end;
finally
LoadDs.Free;
end;
finally
DeleteFile(fn);
end;
end;
procedure TTestBufDatasetStreams.TestAppendDeleteBIN;
begin
TestChanges(@AppendDeleteChange);

33
packages/fcl-db/tests/testdbbasics.pas
View File

@ -42,6 +42,8 @@ type
procedure TestSupportBCDFields;
procedure TestSupportfmtBCDFields;
procedure TestSupportFixedStringFields;
procedure TestSupportBlobFields;
procedure TestSupportMemoFields;
procedure TestDoubleClose;
procedure TestCalculatedField;
@ -2387,6 +2389,37 @@ begin
ds.close;
end;
procedure TTestDBBasics.TestSupportBlobFields;
var i : byte;
ds : TDataset;
Fld : TField;
begin
TestfieldDefinition(ftBlob,0,ds,Fld);
for i := 0 to testValuesCount-1 do
begin
CheckEquals(testValues[ftBlob,i],Fld.AsString);
ds.Next;
end;
ds.close;
end;
procedure TTestDBBasics.TestSupportMemoFields;
var i : byte;
ds : TDataset;
Fld : TField;
begin
TestfieldDefinition(ftMemo,0,ds,Fld);
for i := 0 to testValuesCount-1 do
begin
CheckEquals(testValues[ftMemo,i],Fld.AsString);
ds.Next;
end;
ds.close;
end;
procedure TTestDBBasics.TestDoubleClose;
begin
with DBConnector.GetNDataset(1) do

2
packages/fcl-db/tests/toolsunit.pas
View File

@ -311,6 +311,8 @@ begin
testValues[ftFixedChar] := testStringValues;
testValues[ftTime] := testTimeValues;
testValues[ftDate] := testDateValues;
testValues[ftBlob] := testStringValues;
testValues[ftMemo] := testStringValues;
testValues[ftFMTBcd] := testFmtBCDValues;
for i := 0 to testValuesCount-1 do
begin