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

* First try to implement TBufDataset.LoadFromFile and SaveToFile (xml)

Browse Source 
git-svn-id: trunk@11321 -
This commit is contained in:
joost 2008-07-04 21:07:27 +00:00
parent 2348c7ea00
commit 976151cf02
1 changed files with 251 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -22,7 +22,7 @@ unit BufDataset;
interface interface
uses Classes,Sysutils,db,bufdataset_parser; uses Classes,Sysutils,db,bufdataset_parser,dom;
type type
TBufDataset = Class; TBufDataset = Class;
@ -114,7 +114,7 @@ type
Desc : Boolean; Desc : Boolean;
end; end;
TDBCompareStruct = array of TDBCompareRec; TDBCompareStruct = array of TDBCompareRec;
PBufIndex = ^TBufIndex; PBufIndex = ^TBufIndex;
TBufIndex = record TBufIndex = record
Name : String; Name : String;
@ -134,6 +134,8 @@ type
{$ENDIF ARRAYBUF} {$ENDIF ARRAYBUF}
IndNr : integer; IndNr : integer;
end; end;
TDataPacketFormat = (dfBinary,dfXML,dfXMLUTF8);
TBufDataset = class(TDBDataSet) TBufDataset = class(TDBDataSet)
private private
@ -170,6 +172,9 @@ type
FBlobBuffers : array of PBlobBuffer; FBlobBuffers : array of PBlobBuffer;
FUpdateBlobBuffers: array of PBlobBuffer; FUpdateBlobBuffers: array of PBlobBuffer;
FRowDataNode,
FRecordNode : TDOMNode;
procedure AddRecordToIndex(ANewRecord, ABeforeRecord: PBufRecLinkItem; procedure AddRecordToIndex(ANewRecord, ABeforeRecord: PBufRecLinkItem;
var AIndex: TBufIndex); var AIndex: TBufIndex);
@ -239,8 +244,8 @@ type
procedure SetFilterText(const Value: String); override; {virtual;} procedure SetFilterText(const Value: String); override; {virtual;}
procedure SetFiltered(Value: Boolean); override; {virtual;} procedure SetFiltered(Value: Boolean); override; {virtual;}
{abstracts, must be overidden by descendents} {abstracts, must be overidden by descendents}
function Fetch : boolean; virtual; abstract; function Fetch : boolean; virtual;
function LoadField(FieldDef : TFieldDef;buffer : pointer; out CreateBlob : boolean) : boolean; virtual; abstract; function LoadField(FieldDef : TFieldDef;buffer : pointer; out CreateBlob : boolean) : boolean; virtual;
procedure LoadBlobIntoBuffer(FieldDef: TFieldDef;ABlobBuf: PBufBlobField); virtual; abstract; procedure LoadBlobIntoBuffer(FieldDef: TFieldDef;ABlobBuf: PBufBlobField); virtual; abstract;
public public
@ -264,6 +269,8 @@ type
{$IFNDEF ARRAYBUF} {$IFNDEF ARRAYBUF}
property MaxIndexesCount : Integer read FMaxIndexesCount write SetMaxIndexesCount; property MaxIndexesCount : Integer read FMaxIndexesCount write SetMaxIndexesCount;
{$ENDIF ARRAYBUF} {$ENDIF ARRAYBUF}
procedure SaveToFile(const FileName: string = ''; Format: TDataPacketFormat = dfBinary);
procedure LoadFromFile(const FileName: string = '');
published published
property PacketRecords : Integer read FPacketRecords write SetPacketRecords default 10; property PacketRecords : Integer read FPacketRecords write SetPacketRecords default 10;
property OnUpdateError: TResolverErrorEvent read FOnUpdateError write SetOnUpdateError; property OnUpdateError: TResolverErrorEvent read FOnUpdateError write SetOnUpdateError;
@ -274,7 +281,7 @@ type
implementation implementation
uses variants, dbconst; uses variants, dbconst, xmlwrite, xmlread;
function DBCompareText(subValue, aValue: pointer; options: TLocateOptions): LargeInt; function DBCompareText(subValue, aValue: pointer; options: TLocateOptions): LargeInt;
@ -2092,6 +2099,195 @@ begin
InternalAddIndex(AName,AFields,AOptions,ADescFields,ACaseInsFields); InternalAddIndex(AName,AFields,AOptions,ADescFields,ACaseInsFields);
end; end;
const
XMLFieldtypenames : Array [TFieldType] of String[15] =
(
'Unknown',
'string',
'i2',
'i4',
'i4',
'boolean',
'r8',
'r8',
'fixed',
'date',
'time',
'datetime',
'bin.hex',
'bin.hex',
'i4',
'bin.hex',
'bin.hex',
'bin.hex',
'bin.hex',
'bin.hex',
'bin.hex',
'bin.hex',
'',
'string',
'string',
'i8',
'',
'',
'',
'',
'',
'',
'',
'',
'',
'',
'',
'',
'',
''
);
procedure TBufDataset.SaveToFile(const FileName: string;
Format: TDataPacketFormat);
var XMLDocument : TXMLDocument;
DataPacketNode : TDOMElement;
MetaDataNode : TDOMElement;
FieldsNode : TDOMElement;
RowDataNode : TDOMElement;
ParamsNode : TDOMElement;
AFieldNode : TDOMElement;
ARecordNode : TDOMElement;
i : integer;
BookMrk : TBookmark;
begin
// TODO: implement filename property}
// CheckActive;
XMLDocument := TXMLDocument.Create;
DataPacketNode := XMLDocument.CreateElement('DATAPACKET');
DataPacketNode.SetAttribute('Version','2.0');
MetaDataNode := XMLDocument.CreateElement('METADATA');
FieldsNode := XMLDocument.CreateElement('FIELDS');
for i := 0 to Fields.Count -1 do with fields[i] do
begin
AFieldNode := XMLDocument.CreateElement('FIELD');
if fields[i].Name <> '' then AFieldNode.SetAttribute('fieldname',fields[i].Name);
AFieldNode.SetAttribute('attrname',fields[i].FieldName);
if size <> 0 then AFieldNode.SetAttribute('width',IntToStr(Size));
AFieldNode.SetAttribute('fieldtype',XMLFieldtypenames[fields[i].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}
if ReadOnly then AFieldNode.SetAttribute('readonly','true');
FieldsNode.AppendChild(AFieldNode);
end;
MetaDataNode.AppendChild(FieldsNode);
ParamsNode := XMLDocument.CreateElement('PARAMS');
MetaDataNode.AppendChild(ParamsNode);
DataPacketNode.AppendChild(MetaDataNode);
RowDataNode := XMLDocument.CreateElement('ROWDATA');
DisableControls;
BookMrk:=GetBookmark;
first;
while not eof do
begin
ARecordNode := XMLDocument.CreateElement('ROW');
for i := 0 to Fields.Count-1 do
begin
ARecordNode.SetAttribute(fields[i].FieldName,fields[i].AsString);
end;
RowDataNode.AppendChild(ARecordNode);
Next;
end;
GotoBookmark(Bookmrk);
EnableControls;
DataPacketNode.AppendChild(RowDataNode);
XMLDocument.AppendChild(DataPacketNode);
WriteXML(XMLDocument,FileName);
FieldsNode.Free;
MetaDataNode.Free;
DataPacketNode.Free;
XMLDocument.Free;
end;
procedure TBufDataset.LoadFromFile(const FileName: string);
function GetNodeAttribute(const aNode : TDOMNode; AttName : String) : string;
var AnAttr : TDomNode;
begin
AnAttr := ANode.Attributes.GetNamedItem(AttName);
if assigned(AnAttr) then result := AnAttr.NodeValue
else result := '';
end;
var XMLDocument : TXMLDocument;
DataPacketNode : TDOMNode;
MetaDataNode : TDOMNode;
FieldsNode : TDOMNode;
ParamsNode : TDOMElement;
AFieldNode : TDOMNode;
AFieldDef : TFieldDef;
iFieldType : TFieldType;
FTString : string;
i : integer;
begin
ReadXMLFile(XMLDocument,FileName);
DataPacketNode := XMLDocument.FindNode('DATAPACKET');
if not assigned(DataPacketNode) then DatabaseError('Onbekend formaat');
MetaDataNode := DataPacketNode.FindNode('METADATA');
if not assigned(MetaDataNode) then DatabaseError('Onbekend formaat');
FieldsNode := MetaDataNode.FindNode('FIELDS');
if not assigned(FieldsNode) then DatabaseError('Onbekend formaat');
with FieldsNode.ChildNodes do for i := 0 to Count - 1 do
begin
AFieldNode := item[i];
if AFieldNode.CompareName('FIELD')=0 then
begin
AFieldDef := TFieldDef.create(FieldDefs);
AFieldDef.DisplayName:=GetNodeAttribute(AFieldNode,'fieldname');
AFieldDef.Name:=GetNodeAttribute(AFieldNode,'attrname');
AFieldDef.Size:=StrToIntDef(GetNodeAttribute(AFieldNode,'width'),0);
FTString:=GetNodeAttribute(AFieldNode,'fieldtype');
AFieldDef.DataType:=ftUnknown;
for iFieldType:=low(TFieldType) to high(TFieldType) do
if SameText(XMLFieldtypenames[iFieldType],FTString) then
begin
AFieldDef.DataType:=iFieldType;
break;
end;
end;
end;
FRowDataNode := DataPacketNode.FindNode('ROWDATA');
FRecordNode := nil;
// XMLDocument.Free; <-- MEM LEAK!
CreateFields;
Open;
end;
procedure TBufDataset.InternalAddIndex(const AName, AFields : string; AOptions : TIndexOptions; const ADescFields: string; procedure TBufDataset.InternalAddIndex(const AName, AFields : string; AOptions : TIndexOptions; const ADescFields: string;
const ACaseInsFields: string); const ACaseInsFields: string);
var StoreIndNr : Integer; var StoreIndNr : Integer;
@ -2172,6 +2368,56 @@ begin
Refresh; Refresh;
end; end;
function TBufDataset.Fetch: boolean;
begin
if assigned(FRowDataNode) then // The dataset is being read from a xml-document
begin
if FRecordNode = nil then FRecordNode := FRowDataNode.FirstChild
else FRecordNode := FRecordNode.NextSibling;
while assigned(FRecordNode) and (FRecordNode.CompareName('ROW')<>0) do
FRecordNode := FRecordNode.NextSibling;
result := assigned(FRecordNode);
end
else result := False;
end;
function TBufDataset.LoadField(FieldDef: TFieldDef; buffer: pointer; out
CreateBlob: boolean): boolean;
var AFieldNode : TDOMNode;
AStr : String;
Int1 : Integer;
begin
if assigned(FRowDataNode) then // The dataset is being read from a xml-document
begin
CreateBlob:=False;
AFieldNode := FRecordNode.Attributes.GetNamedItem(FieldDef.Name);
Result := True;
if AFieldNode=nil then
result := false
else
begin
case FieldDef.DataType of
ftString : begin
AStr:=AFieldNode.NodeValue;
Int1 := length(AStr);
if Int1>FieldDef.size then
Int1 := FieldDef.Size;
if int1 > 0 then
move(AStr[1],buffer^,Int1);
end;
ftInteger: begin
result := False;
end
else
result := False;
end; {case}
end;
end
else result := False;
end;
procedure TBufDataset.InitialiseIndex(AIndex : TBufIndex); procedure TBufDataset.InitialiseIndex(AIndex : TBufIndex);
begin begin
{$IFDEF ARRAYBUF} {$IFDEF ARRAYBUF}