* Stream TBufdataset fmtBcd fields (xml)

 * 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 -

packages/fcl-db/src/base/bufdataset.pas

@@ -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);

packages/fcl-db/src/base/xmldatapacketreader.pp

@@ -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

packages/fcl-db/tests/testbufdatasetstreams.pas

@@ -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);

packages/fcl-db/tests/testdbbasics.pas

@@ -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

packages/fcl-db/tests/toolsunit.pas

@@ -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