pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

apply patch to RxMemData for load/save data - tnx Rich, issue 0020413

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@2382 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
alexs75
2012-04-04 17:34:43 +00:00
parent e5a120017f
commit 77ca40896a
14 changed files with 1487 additions and 34 deletions
Download Patch File Download Diff File Expand all files Collapse all files

182
components/rx/Demos/TestRXMemDSLoad/rx_ext_test_case_1.pas Normal file
View File

@ -0,0 +1,182 @@
unit rx_ext_test_case_1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, fpcunit, testutils, testregistry, rxmemds, Dialogs;
type
{ TTCRxMemDataLifecycle }
TTCRxMemDataLifecycle= class(TTestCase)
protected
procedure SetUp; override;
procedure TearDown; override;
published
procedure TestHookUp;
procedure TestSave;
end;
implementation
uses
db, ex_rx_datapacket;
procedure TTCRxMemDataLifecycle.TestHookUp;
var
ads : TRxMemoryData;
aField : TField;
i : integer;
begin
ads := TRxMemoryData.Create(nil);
aField := TIntegerField.Create(nil);
aField.FieldName:= 'IntegerField1';
aField.Name := 'adsIntegerField1';
aField.DataSet := ads;
aField := TStringField.Create(nil);
aField.FieldName:= 'StringField1';
aField.Name := 'adsStringField1';
aField.Size := 20;
aField.DataSet := ads;
aField := TFloatField.Create(nil);
aField.FieldName:= 'FloatField1';
aField.Name := 'adsFloatField1';
aField.DataSet := ads;
ads.Open;
for i := 0 to 500 do
begin
ads.AppendRecord([i,'Name '+ IntToStr(i), 200 + (i*0.1)]);
end;
ads.First;
i:= 0;
while not ads.EOF do
begin
AssertTrue('Integer is incorrect ' + IntToStr(i), ads.FieldByName('IntegerField1').AsInteger = i);
AssertTrue('Float is incorrect ' + IntToStr(i), ads.FieldByName('FloatField1').AsFloat - (200 + (i*0.1)) < 0.01);
AssertTrue('String is incorrect ' + IntToStr(i), ads.FieldByName('StringField1').AsString = 'Name '+ IntToStr(i));
inc(i);
ads.Next;
end;
end;
procedure TTCRxMemDataLifecycle.TestSave;
var
ads1,ads2 : TRxMemoryData;
aField : TField;
i : integer;
sMemoTest : String;
begin
ads1 := TRxMemoryData.Create(nil);
ads2 := TRxMemoryData.Create(nil);
aField := TIntegerField.Create(nil);
aField.FieldName:= 'IntegerField1';
aField.Name := 'adsIntegerField1';
aField.DataSet := ads1;
aField := TStringField.Create(nil);
aField.FieldName:= 'StringField1';
aField.Name := 'adsStringField1';
aField.Size := 20;
aField.DataSet := ads1;
aField := TFloatField.Create(nil);
aField.FieldName:= 'FloatField1';
aField.Name := 'adsFloatField1';
aField.DataSet := ads1;
// TBooleanField
aField := TBooleanField.Create(nil);
aField.FieldName:= 'BooleanField1';
aField.Name := 'adsBooleanField1';
aField.DataSet := ads1;
// TDateTimeField
aField := TDateTimeField.Create(nil);
aField.FieldName:= 'DateTimeField1';
aField.Name := 'adsDateTimeField1';
aField.DataSet := ads1;
// TMemoField
aField := TMemoField.Create(nil);
aField.FieldName:= 'MemoField1';
aField.Name := 'adsMemoField1';
aField.Size:= 600;
aField.DataSet := ads1;
// TCurrencyField
aField := TCurrencyField.Create(nil);
aField.FieldName:= 'CurrencyField1';
aField.Name := 'adsCurrencyField1';
aField.DataSet := ads1;
ads1.Open;
ads2.Open;
sMemoTest := 'memo1';
for i := 0 to 500 do
begin
ads1.AppendRecord([i,'Name '+ IntToStr(i), 200 + (i*0.1),(i div 2) = 1, EncodeDate(2011,10,03) + i, sMemoTest, 1000 + (i*0.1)]);
sMemoTest := sMemoTest + 'a';
end;
ads1.SaveToFile('/tmp/testfile.xml',dfXML);
ads2.LoadFromFile('/tmp/testfile.xml',dfXML);
ads2.First;
sMemoTest := 'memo1';
i:= 0;
while not ads2.EOF do
begin
AssertTrue('Integer is incorrect ' + IntToStr(i), ads2.FieldByName('IntegerField1').AsInteger = i);
AssertTrue('Float is incorrect ' + IntToStr(i), ads2.FieldByName('FloatField1').AsFloat - (200 + (i*0.1)) < 0.01);
AssertTrue('String is incorrect ' + IntToStr(i), ads2.FieldByName('StringField1').AsString = 'Name '+ IntToStr(i));
AssertTrue('Currency is incorrect ' + IntToStr(i), ads2.FieldByName('CurrencyField1').AsFloat - (1000 + (i*0.1)) < 0.01);
AssertTrue('DateTime is incorrect ' + IntToStr(i), ads2.FieldByName('DateTimeField1').AsDateTime = EncodeDate(2011,10,03) + i);
AssertTrue('Memo is incorrect ' + IntToStr(i) + ads2.FieldByName('MemoField1').AsString, StrComp(Pchar(ads2.FieldByName('MemoField1').asString),Pchar(sMemoTest)) = 0);
sMemoTest := sMemoTest + 'a';
inc(i);
ads2.Next;
end;
ads1.Free;
ads2.Free;
end;
procedure TTCRxMemDataLifecycle.SetUp;
begin
end;
procedure TTCRxMemDataLifecycle.TearDown;
begin
end;
initialization
RegisterTest(TTCRxMemDataLifecycle);
end.

309
components/rx/Demos/TestRXMemDSLoad/rx_ext_test_harness.lpi Normal file
View File

@ -0,0 +1,309 @@
<?xml version="1.0"?>
<CONFIG>
<ProjectOptions>
<Version Value="9"/>
<General>
<MainUnit Value="0"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<ActiveWindowIndexAtStart Value="0"/>
</General>
<i18n>
<EnableI18N LFM="False"/>
</i18n>
<VersionInfo>
<StringTable ProductVersion=""/>
</VersionInfo>
<BuildModes Count="1" Active="Default">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
<ExcludeFileFilter Value="*.(bak|ppu|o|so);*~;backup"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
<LaunchingApplication PathPlusParams="/usr/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
</local>
</RunParams>
<RequiredPackages Count="4">
<Item1>
<PackageName Value="rxnew"/>
</Item1>
<Item2>
<PackageName Value="FPCUnitTestRunner"/>
</Item2>
<Item3>
<PackageName Value="LCL"/>
</Item3>
<Item4>
<PackageName Value="FCL"/>
</Item4>
</RequiredPackages>
<Units Count="19">
<Unit0>
<Filename Value="rx_ext_test_harness.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="rx_ext_test_harness"/>
<WindowIndex Value="0"/>
<TopLine Value="1"/>
<CursorPos X="35" Y="9"/>
<UsageCount Value="27"/>
</Unit0>
<Unit1>
<Filename Value="rx_ext_test_case_1.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="rx_ext_test_case_1"/>
<EditorIndex Value="0"/>
<WindowIndex Value="0"/>
<TopLine Value="1"/>
<CursorPos X="33" Y="120"/>
<UsageCount Value="27"/>
<Loaded Value="True"/>
</Unit1>
<Unit2>
<Filename Value="/usr/local/src/fpc-2.4.2/packages/fcl-fpcunit/src/testregistry.pp"/>
<UnitName Value="testregistry"/>
<WindowIndex Value="0"/>
<TopLine Value="1"/>
<CursorPos X="1" Y="1"/>
<UsageCount Value="12"/>
</Unit2>
<Unit3>
<Filename Value="../../../lazarus/components/rxnew/rx/rxmemds.pas"/>
<UnitName Value="rxmemds"/>
<WindowIndex Value="0"/>
<TopLine Value="18"/>
<CursorPos X="14" Y="41"/>
<UsageCount Value="13"/>
</Unit3>
<Unit4>
<Filename Value="../../../lazarus/components/fpcunit/guitestrunner.pas"/>
<UnitName Value="GuiTestRunner"/>
<EditorIndex Value="2"/>
<WindowIndex Value="0"/>
<TopLine Value="207"/>
<CursorPos X="1" Y="247"/>
<UsageCount Value="13"/>
<Loaded Value="True"/>
</Unit4>
<Unit5>
<Filename Value="/usr/local/src/fpc-2.4.2/packages/fcl-fpcunit/src/fpcunit.pp"/>
<UnitName Value="fpcunit"/>
<WindowIndex Value="0"/>
<TopLine Value="1226"/>
<CursorPos X="10" Y="908"/>
<UsageCount Value="12"/>
</Unit5>
<Unit6>
<Filename Value="../../../lazarus/components/rxnew/rx/ex_rx_datapacket.pas"/>
<UnitName Value="ex_rx_datapacket"/>
<WindowIndex Value="0"/>
<TopLine Value="1"/>
<CursorPos X="1" Y="1"/>
<UsageCount Value="11"/>
</Unit6>
<Unit7>
<Filename Value="../../../lazarus/components/rxnew/rx/ex_rx_xml_datapacket.pas"/>
<UnitName Value="ex_rx_xml_datapacket"/>
<WindowIndex Value="0"/>
<TopLine Value="329"/>
<CursorPos X="30" Y="342"/>
<UsageCount Value="11"/>
</Unit7>
<Unit8>
<Filename Value="/usr/local/src/fpc-2.4.2/packages/fcl-db/src/base/db.pas"/>
<UnitName Value="db"/>
<WindowIndex Value="0"/>
<TopLine Value="238"/>
<CursorPos X="17" Y="255"/>
<UsageCount Value="11"/>
</Unit8>
<Unit9>
<Filename Value="/usr/local/src/fpc-2.4.2/rtl/objpas/sysutils/datih.inc"/>
<WindowIndex Value="0"/>
<TopLine Value="100"/>
<CursorPos X="10" Y="109"/>
<UsageCount Value="11"/>
</Unit9>
<Unit10>
<Filename Value="/usr/local/src/fpc-2.4.2/rtl/objpas/sysutils/dati.inc"/>
<WindowIndex Value="0"/>
<TopLine Value="1101"/>
<CursorPos X="3" Y="1108"/>
<UsageCount Value="11"/>
</Unit10>
<Unit11>
<Filename Value="/usr/local/src/fpc-2.4.2/rtl/objpas/sysutils/syspchh.inc"/>
<WindowIndex Value="0"/>
<TopLine Value="12"/>
<CursorPos X="10" Y="29"/>
<UsageCount Value="11"/>
</Unit11>
<Unit12>
<Filename Value="/usr/local/src/fpc-2.4.2/rtl/inc/genstr.inc"/>
<WindowIndex Value="0"/>
<TopLine Value="243"/>
<CursorPos X="9" Y="248"/>
<UsageCount Value="11"/>
</Unit12>
<Unit13>
<Filename Value="/usr/local/share/lazarus/components/rxnew/rxmemds.pas"/>
<UnitName Value="rxmemds"/>
<IsVisibleTab Value="True"/>
<EditorIndex Value="1"/>
<WindowIndex Value="0"/>
<TopLine Value="1"/>
<CursorPos X="45" Y="40"/>
<UsageCount Value="10"/>
<Loaded Value="True"/>
</Unit13>
<Unit14>
<Filename Value="/usr/local/share/lazarus/components/rxnew/ex_rx_bin_datapacket.pas"/>
<UnitName Value="ex_rx_bin_datapacket"/>
<WindowIndex Value="0"/>
<TopLine Value="1"/>
<CursorPos X="1" Y="1"/>
<UsageCount Value="10"/>
</Unit14>
<Unit15>
<Filename Value="/usr/local/share/lazarus/components/rxnew/ex_rx_datapacket.pas"/>
<UnitName Value="ex_rx_datapacket"/>
<WindowIndex Value="0"/>
<TopLine Value="1"/>
<CursorPos X="1" Y="1"/>
<UsageCount Value="10"/>
</Unit15>
<Unit16>
<Filename Value="/usr/local/share/lazarus/components/rxnew/ex_rx_xml_datapacket.pas"/>
<UnitName Value="ex_rx_xml_datapacket"/>
<WindowIndex Value="0"/>
<TopLine Value="323"/>
<CursorPos X="80" Y="343"/>
<UsageCount Value="10"/>
</Unit16>
<Unit17>
<Filename Value="../rx/rxmemds.pas"/>
<UnitName Value="rxmemds"/>
<WindowIndex Value="0"/>
<TopLine Value="3"/>
<CursorPos X="3" Y="41"/>
<UsageCount Value="10"/>
</Unit17>
<Unit18>
<Filename Value="../../../../install/fpcsrc/packages/fcl-db/src/base/db.pas"/>
<UnitName Value="db"/>
<WindowIndex Value="0"/>
<TopLine Value="1367"/>
<CursorPos X="3" Y="1339"/>
<UsageCount Value="10"/>
</Unit18>
</Units>
<JumpHistory Count="20" HistoryIndex="19">
<Position1>
<Filename Value="rx_ext_test_case_1.pas"/>
<Caret Line="134" Column="1" TopLine="111"/>
</Position1>
<Position2>
<Filename Value="rx_ext_test_case_1.pas"/>
<Caret Line="135" Column="1" TopLine="111"/>
</Position2>
<Position3>
<Filename Value="rx_ext_test_case_1.pas"/>
<Caret Line="94" Column="18" TopLine="71"/>
</Position3>
<Position4>
<Filename Value="rx_ext_test_case_1.pas"/>
<Caret Line="101" Column="1" TopLine="81"/>
</Position4>
<Position5>
<Filename Value="rx_ext_test_case_1.pas"/>
<Caret Line="123" Column="1" TopLine="93"/>
</Position5>
<Position6>
<Filename Value="rx_ext_test_case_1.pas"/>
<Caret Line="116" Column="1" TopLine="93"/>
</Position6>
<Position7>
<Filename Value="rx_ext_test_case_1.pas"/>
<Caret Line="108" Column="2" TopLine="93"/>
</Position7>
<Position8>
<Filename Value="rx_ext_test_case_1.pas"/>
<Caret Line="150" Column="119" TopLine="122"/>
</Position8>
<Position9>
<Filename Value="rx_ext_test_case_1.pas"/>
<Caret Line="133" Column="81" TopLine="122"/>
</Position9>
<Position10>
<Filename Value="rx_ext_test_case_1.pas"/>
<Caret Line="120" Column="39" TopLine="91"/>
</Position10>
<Position11>
<Filename Value="rx_ext_test_case_1.pas"/>
<Caret Line="151" Column="164" TopLine="134"/>
</Position11>
<Position12>
<Filename Value="rx_ext_test_case_1.pas"/>
<Caret Line="137" Column="15" TopLine="115"/>
</Position12>
<Position13>
<Filename Value="rx_ext_test_case_1.pas"/>
<Caret Line="154" Column="164" TopLine="136"/>
</Position13>
<Position14>
<Filename Value="rx_ext_test_case_1.pas"/>
<Caret Line="137" Column="41" TopLine="130"/>
</Position14>
<Position15>
<Filename Value="rx_ext_test_case_1.pas"/>
<Caret Line="157" Column="7" TopLine="140"/>
</Position15>
<Position16>
<Filename Value="rx_ext_test_case_1.pas"/>
<Caret Line="137" Column="16" TopLine="127"/>
</Position16>
<Position17>
<Filename Value="rx_ext_test_case_1.pas"/>
<Caret Line="120" Column="33" TopLine="1"/>
</Position17>
<Position18>
<Filename Value="/usr/local/share/lazarus/components/rxnew/rxmemds.pas"/>
<Caret Line="207" Column="5" TopLine="268"/>
</Position18>
<Position19>
<Filename Value="/usr/local/share/lazarus/components/rxnew/rxmemds.pas"/>
<Caret Line="1689" Column="1" TopLine="1690"/>
</Position19>
<Position20>
<Filename Value="/usr/local/share/lazarus/components/rxnew/rxmemds.pas"/>
<Caret Line="73" Column="42" TopLine="53"/>
</Position20>
</JumpHistory>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
</SearchPaths>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

15
components/rx/Demos/TestRXMemDSLoad/rx_ext_test_harness.lpr Normal file
View File

@ -0,0 +1,15 @@
program rx_ext_test_harness;
{$mode objfpc}{$H+}
uses
Interfaces, Forms, GuiTestRunner, rxnew, rx_ext_test_case_1;
{$R *.res}
begin
Application.Initialize;
Application.CreateForm(TGuiTestRunner, TestRunner);
Application.Run;
end.

BIN
components/rx/Demos/TestRXMemDSLoad/rx_ext_test_harness.res Normal file
View File

Binary file not shown.

172
components/rx/ex_rx_bin_datapacket.pas Normal file
View File

@ -0,0 +1,172 @@
{
TBinaryRxDatapacketReader implementation
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
unit ex_rx_bin_datapacket;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, dom, db, ex_rx_datapacket;
type
TChangeLogEntry = record
UpdateKind : TUpdateKind;
OrigEntry : integer;
NewEntry : integer;
end;
TChangeLogEntryArr = array of TChangeLogEntry;
type
{ TBinaryRxDatapacketReader }
TBinaryRxDatapacketReader = class(TRxDataPacketReader)
public
procedure LoadFieldDefs(AFieldDefs : TFieldDefs); override;
procedure StoreFieldDefs(AFieldDefs : TFieldDefs); override;
function GetRecordRowState(out AUpdOrder : Integer) : TRowState; override;
procedure FinalizeStoreRecords; override;
function GetCurrentRecord : boolean; override;
procedure GotoNextRecord; override;
procedure InitLoadRecords; override;
procedure RestoreRecord(ADataset : TDataset); override;
procedure StoreRecord(ADataset : TDataset; ARowState : TRowState; AUpdOrder : integer = 0); override;
class function RecognizeStream(AStream : TStream) : boolean; override;
end;
implementation
uses
dbconst;
{ TBinaryRxDatapacketReader }
const
RxBinaryIdent = 'BinRxDataset';
procedure TBinaryRxDatapacketReader.LoadFieldDefs(AFieldDefs: TFieldDefs);
var
FldCount : word;
i : integer;
begin
if not RecognizeStream(Stream) then
DatabaseError(SStreamNotRecognised);
FldCount:=Stream.ReadWord;
AFieldDefs.Clear;
for i := 0 to FldCount -1 do with TFieldDef.create(AFieldDefs) do
begin
Name := Stream.ReadAnsiString;
Displayname := Stream.ReadAnsiString;
Size := Stream.ReadWord;
DataType := TFieldType(Stream.ReadWord);
if Stream.ReadByte = 1 then
Attributes := Attributes + [faReadonly];
end;
end;
procedure TBinaryRxDatapacketReader.StoreFieldDefs(AFieldDefs: TFieldDefs);
var i : integer;
begin
Stream.Write(RxBinaryIdent[1],length(RxBinaryIdent));
Stream.WriteWord(AFieldDefs.Count);
for i := 0 to AFieldDefs.Count -1 do with AFieldDefs[i] do
begin
Stream.WriteAnsiString(Name);
Stream.WriteAnsiString(DisplayName);
Stream.WriteWord(size);
Stream.WriteWord(ord(DataType));
if faReadonly in Attributes then
Stream.WriteByte(1)
else
Stream.WriteByte(0);
end;
end;
function TBinaryRxDatapacketReader.GetRecordRowState(out AUpdOrder: Integer
): TRowState;
var Buf : byte;
begin
Buf := 0;
AUpdOrder := 0;
Stream.Read(Buf,1);
Result := ByteToRowState(Buf);
if Result<>[] then
Stream.ReadBuffer(AUpdOrder,sizeof(integer));
end;
procedure TBinaryRxDatapacketReader.FinalizeStoreRecords;
begin
// Do nothing
end;
function TBinaryRxDatapacketReader.GetCurrentRecord: boolean;
var
Buf : byte;
begin
Buf := 0;
Result := (Stream.Read(Buf,1)=1) and (Buf=$fe);
end;
procedure TBinaryRxDatapacketReader.GotoNextRecord;
begin
// Do Nothing
end;
procedure TBinaryRxDatapacketReader.InitLoadRecords;
begin
// Do Nothing
end;
procedure TBinaryRxDatapacketReader.RestoreRecord(ADataset: TDataset);
begin
Stream.ReadBuffer(ADataset.ActiveBuffer^,ADataset.RecordSize);
end;
procedure TBinaryRxDatapacketReader.StoreRecord(ADataset: TDataset;
ARowState: TRowState; AUpdOrder: integer);
begin
Stream.WriteByte($fe);
Stream.WriteByte(RowStateToByte(ARowState));
if ARowState<>[] then
Stream.WriteBuffer(AUpdOrder,sizeof(integer));
Stream.WriteBuffer(ADataset.ActiveBuffer^,ADataset.RecordSize);
end;
class function TBinaryRxDatapacketReader.RecognizeStream(AStream: TStream
): boolean;
var s : string;
len : integer;
begin
Len := length(RxBinaryIdent);
setlength(s,len);
if (AStream.Read (s[1],len) = len)
and (s=RxBinaryIdent) then
Result := True
else
Result := False;
end;
initialization
RegisterDatapacketReader(TBinaryRxDatapacketReader,dfBinary);
end.

139
components/rx/ex_rx_datapacket.pas Normal file
View File

@ -0,0 +1,139 @@
unit ex_rx_datapacket;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils,db;
type
TRowStateValue = (rsvOriginal, rsvDeleted, rsvInserted, rsvUpdated, rsvDetailUpdates);
TRowState = set of TRowStateValue;
type
TRxDataPacketFormat = (dfBinary,dfXML,dfXMLUTF8,dfAny);
type
{ TRxDatapacketReader }
TRxDatapacketReaderClass = class of TRxDatapacketReader;
TRxDatapacketReader = class(TObject)
FStream : TStream;
protected
class function RowStateToByte(const ARowState : TRowState) : byte;
class function ByteToRowState(const AByte : Byte) : TRowState;
public
constructor create(AStream : TStream); virtual;
// Load a dataset from stream:
// Load the field-definitions from a stream.
procedure LoadFieldDefs(AFieldDefs : TFieldDefs); virtual; abstract;
// Is called before the records are loaded
procedure InitLoadRecords; virtual; abstract;
// Return the RowState of the current record, and the order of the update
function GetRecordRowState(out AUpdOrder : Integer) : TRowState; virtual; abstract;
// Returns if there is at least one more record available in the stream
function GetCurrentRecord : boolean; virtual; abstract;
// Store a record from stream in the current record-buffer
procedure RestoreRecord(ADataset : TDataset); virtual; abstract;
// Move the stream to the next record
procedure GotoNextRecord; virtual; abstract;
// Store a dataset to stream:
// Save the field-definitions to a stream.
procedure StoreFieldDefs(AFieldDefs : TFieldDefs); virtual; abstract;
// Save a record from the current record-buffer to the stream
procedure StoreRecord(ADataset : TDataset; ARowState : TRowState; AUpdOrder : integer = 0); virtual; abstract;
// Is called after all records are stored
procedure FinalizeStoreRecords; virtual; abstract;
// Checks if the provided stream is of the right format for this class
class function RecognizeStream(AStream : TStream) : boolean; virtual; abstract;
property Stream: TStream read FStream;
end;
type
TRxDatapacketReaderRegistration = record
ReaderClass : TRxDatapacketReaderClass;
Format : TRxDatapacketFormat;
end;
function GetRegisterDatapacketReader(AStream : TStream; AFormat : TRxDatapacketFormat; var ADataReaderClass : TRxDatapacketReaderRegistration) : boolean;
procedure RegisterDatapacketReader(ADatapacketReaderClass : TRxDatapacketReaderClass; AFormat : TRxDatapacketFormat);
implementation
var
RxRegisteredDatapacketReaders : Array of TRxDatapacketReaderRegistration;
function GetRegisterDatapacketReader(AStream: TStream;
AFormat: TRxDatapacketFormat;
var ADataReaderClass: TRxDatapacketReaderRegistration): boolean;
var i : integer;
begin
Result := False;
for i := 0 to length(RxRegisteredDatapacketReaders)-1 do if ((AFormat=dfAny) or (AFormat=RxRegisteredDatapacketReaders[i].Format)) then
begin
if (AStream <> nil) then
AStream.Seek(0,soFromBeginning); // ensure at start of stream to check value
if (AStream=nil) or (RxRegisteredDatapacketReaders[i].ReaderClass.RecognizeStream(AStream)) then
begin
ADataReaderClass := RxRegisteredDatapacketReaders[i];
Result := True;
if (AStream <> nil) then
AStream.Seek(0,soFromBeginning);
break;
end;
end;
end;
procedure RegisterDatapacketReader(
ADatapacketReaderClass: TRxDatapacketReaderClass; AFormat: TRxDatapacketFormat
);
begin
setlength(RxRegisteredDatapacketReaders,length(RxRegisteredDatapacketReaders)+1);
with RxRegisteredDatapacketReaders[length(RxRegisteredDatapacketReaders)-1] do
begin
Readerclass := ADatapacketReaderClass;
Format := AFormat;
end;
end;
{ TRxDatapacketReader }
class function TRxDatapacketReader.RowStateToByte(const ARowState: TRowState
): byte;
var RowStateInt : Byte;
begin
RowStateInt:=0;
if rsvOriginal in ARowState then RowStateInt := RowStateInt+1;
if rsvDeleted in ARowState then RowStateInt := RowStateInt+2;
if rsvInserted in ARowState then RowStateInt := RowStateInt+4;
if rsvUpdated in ARowState then RowStateInt := RowStateInt+8;
Result := RowStateInt;
end;
class function TRxDatapacketReader.ByteToRowState(const AByte: Byte
): TRowState;
begin
result := [];
if (AByte and 1)=1 then Result := Result+[rsvOriginal];
if (AByte and 2)=2 then Result := Result+[rsvDeleted];
if (AByte and 4)=4 then Result := Result+[rsvInserted];
if (AByte and 8)=8 then Result := Result+[rsvUpdated];
end;
constructor TRxDatapacketReader.create(AStream: TStream);
begin
FStream := AStream;
end;
initialization
setlength(RxRegisteredDatapacketReaders,0);
finalization
setlength(RxRegisteredDatapacketReaders,0);
end.

405
components/rx/ex_rx_xml_datapacket.pas Normal file
View File

@ -0,0 +1,405 @@
{
TXMLRxDatapacketReader implementation
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
unit ex_rx_xml_datapacket;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, dom, db, ex_rx_datapacket;
type
TChangeLogEntry = record
UpdateKind : TUpdateKind;
OrigEntry : integer;
NewEntry : integer;
end;
TChangeLogEntryArr = array of TChangeLogEntry;
type
{ TXMLRxDatapacketReader }
TXMLRxDatapacketReader = class(TRxDataPacketReader)
XMLDocument : TXMLDocument;
DataPacketNode : TDOMElement;
MetaDataNode : TDOMNode;
FieldsNode : TDOMNode;
FChangeLogNode,
FParamsNode,
FRowDataNode,
FRecordNode : TDOMNode;
FChangeLog : TChangeLogEntryArr;
FEntryNr : integer;
FLastChange : integer;
public
destructor destroy; override;
procedure StoreFieldDefs(AFieldDefs : TFieldDefs); override;
procedure StoreRecord(ADataset : TDataset; ARowState : TRowState; AUpdOrder : integer = 0); override;
procedure FinalizeStoreRecords; override;
procedure LoadFieldDefs(AFieldDefs : TFieldDefs); override;
procedure InitLoadRecords; override;
function GetCurrentRecord : boolean; override;
function GetRecordRowState(out AUpdOrder : Integer) : TRowState; override;
procedure RestoreRecord(ADataset : TDataset); override;
procedure GotoNextRecord; override;
class function RecognizeStream(AStream : TStream) : boolean; override;
end;
implementation
uses xmlwrite, xmlread, rxdconst;
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',
'',
'',
'',
'',
'',
'',
'',
'',
'',
'',
'',
'',
'',
''
);
{ TXMLRxDatapacketReader }
destructor TXMLRxDatapacketReader.destroy;
begin
FieldsNode.Free;
MetaDataNode.Free;
DataPacketNode.Free;
XMLDocument.Free;
inherited destroy;
end;
// Actually does a lot more than just loading the field defs...
procedure TXMLRxDatapacketReader.LoadFieldDefs(AFieldDefs : TFieldDefs);
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 i : integer;
AFieldDef : TFieldDef;
iFieldType : TFieldType;
FTString : string;
AFieldNode : TDOMNode;
bLoadFieldDefs : Boolean;
begin
// if we already have field defs then don't reload from the file
bLoadFieldDefs := (AFieldDefs.Count = 0);
ReadXMLFile(XMLDocument,Stream);
DataPacketNode := XMLDocument.FindNode('DATAPACKET') as TDOMElement;
if not assigned(DataPacketNode) then DatabaseError(sUnknownXMLDatasetFormat);
MetaDataNode := DataPacketNode.FindNode('METADATA');
if not assigned(MetaDataNode) then DatabaseError(sUnknownXMLDatasetFormat);
FieldsNode := MetaDataNode.FindNode('FIELDS');
if not assigned(FieldsNode) then DatabaseError(sUnknownXMLDatasetFormat);
if bLoadFieldDefs then
begin
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(AFieldDefs);
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;
end;
FChangeLogNode := MetaDataNode.FindNode('PARAMS');
if assigned(FChangeLogNode) then
FChangeLogNode := FChangeLogNode.Attributes.GetNamedItem('CHANGE_LOG');
FRowDataNode := DataPacketNode.FindNode('ROWDATA');
FRecordNode := nil;
end;
procedure TXMLRxDatapacketReader.StoreFieldDefs(AFieldDefs: TFieldDefs);
var i : integer;
AFieldNode : TDOMElement;
begin
XMLDocument := TXMLDocument.Create;
DataPacketNode := XMLDocument.CreateElement('DATAPACKET');
DataPacketNode.SetAttribute('Version','2.0');
MetaDataNode := XMLDocument.CreateElement('METADATA');
FieldsNode := XMLDocument.CreateElement('FIELDS');
for i := 0 to AFieldDefs.Count -1 do with AFieldDefs[i] do
begin
AFieldNode := XMLDocument.CreateElement('FIELD');
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}
if faReadonly in Attributes then AFieldNode.SetAttribute('readonly','true');
FieldsNode.AppendChild(AFieldNode);
end;
MetaDataNode.AppendChild(FieldsNode);
FParamsNode := XMLDocument.CreateElement('PARAMS');
MetaDataNode.AppendChild(FParamsNode);
DataPacketNode.AppendChild(MetaDataNode);
FRowDataNode := XMLDocument.CreateElement('ROWDATA');
setlength(FChangeLog,0);
FEntryNr:=0;
FLastChange:=-1;
end;
procedure TXMLRxDatapacketReader.FinalizeStoreRecords;
var ChangeLogStr : String;
i : integer;
begin
ChangeLogStr:='';
for i := 0 to length(FChangeLog)-1 do with FChangeLog[i] do
begin
ChangeLogStr:=ChangeLogStr+' '+inttostr(NewEntry)+' '+inttostr(OrigEntry)+' ';
if UpdateKind=ukModify then ChangeLogStr := ChangeLogStr+'8';
if UpdateKind=ukInsert then ChangeLogStr := ChangeLogStr+'4';
if UpdateKind=ukDelete then ChangeLogStr := ChangeLogStr+'2';
end;
setlength(FChangeLog,0);
if ChangeLogStr<>'' then
(FParamsNode as TDomElement).SetAttribute('CHANGE_LOG',Trim(ChangeLogStr));
DataPacketNode.AppendChild(FRowDataNode);
XMLDocument.AppendChild(DataPacketNode);
WriteXML(XMLDocument,Stream);
end;
function TXMLRxDatapacketReader.GetCurrentRecord: boolean;
begin
Result := assigned(FRecordNode);
end;
function TXMLRxDatapacketReader.GetRecordRowState(out AUpdOrder: Integer
): TRowState;
var ARowStateNode : TDOmNode;
ARowState : integer;
i : integer;
begin
ARowStateNode := FRecordNode.Attributes.GetNamedItem('RowState');
if ARowStateNode = nil then // This item is not edited
Result := []
else
begin
Result := ByteToRowState(StrToIntDef(ARowStateNode.NodeValue,0));
if Result = [rsvOriginal] then
begin
for i := 0 to length(FChangeLog)-1 do
if FChangeLog[i].NewEntry=FEntryNr then break;
assert(FChangeLog[i].NewEntry=FEntryNr);
end
else
begin
for i := 0 to length(FChangeLog)-1 do
if FChangeLog[i].OrigEntry=FEntryNr then break;
assert(FChangeLog[i].OrigEntry=FEntryNr);
end;
AUpdOrder:=i;
end;
end;
procedure TXMLRxDatapacketReader.InitLoadRecords;
var ChangeLogStr : String;
i,cp : integer;
ps : string;
begin
FRecordNode := FRowDataNode.FirstChild;
FEntryNr := 1;
setlength(FChangeLog,0);
if assigned(FChangeLogNode) then
ChangeLogStr:=FChangeLogNode.NodeValue
else
ChangeLogStr:='';
ps := '';
cp := 0;
if ChangeLogStr<>'' then for i := 1 to length(ChangeLogStr)+1 do
begin
if not (ChangeLogStr[i] in [' ',#0]) then
ps := ps + ChangeLogStr[i]
else
begin
case (cp mod 3) of
0 : begin
SetLength(FChangeLog,length(FChangeLog)+1);
FChangeLog[cp div 3].OrigEntry:=StrToIntDef(ps,0);
end;
1 : FChangeLog[cp div 3].NewEntry:=StrToIntDef(ps,0);
2 : begin
if ps = '2' then
FChangeLog[cp div 3].UpdateKind:=ukDelete
else if ps = '4' then
FChangeLog[cp div 3].UpdateKind:=ukInsert
else if ps = '8' then
FChangeLog[cp div 3].UpdateKind:=ukModify;
end;
end; {case}
ps := '';
inc(cp);
end;
end;
end;
procedure TXMLRxDatapacketReader.RestoreRecord(ADataset : TDataset);
var FieldNr : integer;
AFieldNode : TDomNode;
begin
with ADataset do for FieldNr:=0 to FieldCount-1 do
begin
AFieldNode := FRecordNode.Attributes.GetNamedItem(Fields[FieldNr].FieldName);
if assigned(AFieldNode) then
begin
Fields[FieldNr].AsString := AFieldNode.NodeValue; // set it to the filterbuffer
end
end;
end;
procedure TXMLRxDatapacketReader.StoreRecord(ADataset : TDataset; ARowState : TRowState; AUpdOrder : integer = 0);
var FieldNr : Integer;
ARecordNode : TDOMElement;
begin
inc(FEntryNr);
ARecordNode := XMLDocument.CreateElement('ROW');
for FieldNr := 0 to ADataset.Fields.Count-1 do
begin
ARecordNode.SetAttribute(ADataset.fields[FieldNr].FieldName,ADataset.fields[FieldNr].AsString);
end;
if ARowState<>[] then
begin
ARecordNode.SetAttribute('RowState',inttostr(RowStateToByte(ARowState)));
if AUpdOrder>=length(FChangeLog) then
setlength(FChangeLog,AUpdOrder+1);
if (rsvOriginal in ARowState) or (rsvDeleted in ARowState) then
FChangeLog[AUpdOrder].OrigEntry:=FEntryNr;
if (rsvDeleted in ARowState) or (rsvUpdated in ARowState) or (rsvInserted in ARowState) then
FChangeLog[AUpdOrder].NewEntry:=FEntryNr;
if ARowState=[rsvUpdated] then
FChangeLog[AUpdOrder].UpdateKind := ukModify;
if ARowState=[rsvInserted] then
FChangeLog[AUpdOrder].UpdateKind := ukInsert;
if ARowState=[rsvDeleted] then
FChangeLog[AUpdOrder].UpdateKind := ukDelete;
end;
FRowDataNode.AppendChild(ARecordNode);
end;
class function TXMLRxDatapacketReader.RecognizeStream(AStream: TStream): boolean;
const XmlStart = '<?xml';
var s : string;
len : integer;
begin
Len := length(XmlStart);
setlength(s,len);
if (AStream.Read (s[1],len) = len)
and (s=XmlStart) then
Result := True
else
Result := False;
end;
procedure TXMLRxDatapacketReader.GotoNextRecord;
begin
FRecordNode := FRecordNode.NextSibling;
inc(FEntryNr);
while assigned(FRecordNode) and (FRecordNode.CompareName('ROW')<>0) do
FRecordNode := FRecordNode.NextSibling;
end;
initialization
RegisterDatapacketReader(TXMLRxDatapacketReader,dfXML);
end.
end.

4
components/rx/languages/rxdconst.es.po
View File

@ -407,6 +407,10 @@ msgstr "buscar"
msgid "SUnknownFieldType %s"
msgstr "STipoCampoDesconocido %s"
#: rxdconst.sunknownxmldatasetformat
msgid "Unknown XML Dataset format"
msgstr ""
#: rxdconst.sunlockcaption
msgid "Unloock"
msgstr "Desbloquear"

4
components/rx/languages/rxdconst.po
View File

@ -405,6 +405,10 @@ msgstr ""
msgid "SUnknownFieldType %s"
msgstr ""
#: rxdconst.sunknownxmldatasetformat
msgid "Unknown XML Dataset format"
msgstr ""
#: rxdconst.sunlockcaption
msgid "Unloock"
msgstr ""

14
components/rx/languages/rxdconst.ru.po
View File

@ -23,7 +23,7 @@ msgstr "Изменить пароль"
#: rxdconst.scirculardatalink
msgid "SCircularDataLink"
msgstr ""
msgstr "Перекрёстная ссылка данных"
#: rxdconst.sconfirmpasswordlabel
msgid "&Confirm:"
@ -43,7 +43,7 @@ msgstr ""
#: rxdconst.sdbcomboboxfieldnotassigned
msgid "%s:TDBComboBox - DataField not assigned"
msgstr ""
msgstr "%s:TDBComboBox - Не присвоено свойство DataField"
#: rxdconst.sdbexceptcaption
msgid "Error in DB engine"
@ -111,7 +111,7 @@ msgstr "Ошибка в окончании выражения фильтра"
#: rxdconst.sfieldreadonly
msgid "SFieldReadOnly %s"
msgstr ""
msgstr "Поле %s только для чтения"
#: rxdconst.sfieldrequired
msgid "Field '%s' must have a value"
@ -386,8 +386,6 @@ msgid "&Selected fields:"
msgstr "&Выбранные поля"
#: rxdconst.srxsortbyformsortorder
#, fuzzy
#| msgid "Select field for sort data:"
msgid "Select f&ield for sort data:"
msgstr "Укажите поля для сортировки данных :"
@ -405,7 +403,11 @@ msgstr "поиск"
#: rxdconst.sunknownfieldtype
msgid "SUnknownFieldType %s"
msgstr ""
msgstr "Не определён тип данных для поля %s"
#: rxdconst.sunknownxmldatasetformat
msgid "Unknown XML Dataset format"
msgstr "Не известный формат XML данных"
#: rxdconst.sunlockcaption
msgid "Unloock"

2
components/rx/rxdconst.pas
View File

@ -160,6 +160,8 @@ resourcestring
sRxCopyOnlyMetadata = 'Copy only metadata';
sRxSourseDataset = 'Sourse dataset';
sUnknownXMLDatasetFormat = 'Unknown XML Dataset format';
const
{ The following strings should not be localized }
sAction = '.Action';

233
components/rx/rxmemds.pas
View File

@ -37,7 +37,7 @@ unit rxmemds;
interface
uses SysUtils, Classes, DB;
uses SysUtils, Classes, DB, ex_rx_datapacket;
{ TRxMemoryData }
@ -67,6 +67,19 @@ type
FIndexList: TList;
FCaseInsensitiveSort: Boolean;
FDescendingSort: Boolean;
FFileName: string;
FFileStream : TFileStream;
FDatasetReader : TRxDataPacketReader;
FPacketRecords: Integer;
FFilterBuffer : pchar;
FNullmaskSize : byte;
FBRecordCount : integer;
function IntAllocRecordBuffer: PChar;
procedure IntLoadFielddefsFromFile;
procedure IntLoadRecordsFromFile;
procedure SetPacketRecords(const AValue: Integer);
function AddRecord: TMemoryRecord;
procedure CopyRecord(RecordData, Buffer: PChar);
function GetOnFilterRecordEx: TFilterRecordEvent;
@ -98,9 +111,9 @@ type
procedure SetBlobData(Field: TField; Buffer: PChar; Value: TMemBlobData);
function AllocRecordBuffer: PChar; override;
procedure FreeRecordBuffer(var Buffer: PChar); override;
function BCDToCurr(BCD: Pointer; var Curr: Currency): Boolean; //override;
function CurrToBCD(const Curr: Currency; BCD: Pointer; Precision,
Decimals: Integer): Boolean; //override;
function BCDToCurr(BCD: Pointer; var Curr: Currency): Boolean;
function CurrToBCD(const Curr: Currency; BCD: Pointer;
Precision, Decimals: Integer): Boolean;
procedure InternalInitRecord(Buffer: PChar); override;
procedure ClearCalcFields(Buffer: PChar); override;
function GetRecord(Buffer: PChar; GetMode: TGetMode;
@ -153,6 +166,13 @@ type
Mode: TLoadMode): Integer;
function SaveToDataSet(Dest: TDataSet; ARecordCount: Integer): Integer;
procedure AppendRecord(const Values: array of const);
procedure SetDatasetPacket(AReader : TRxDataPacketReader);
procedure GetDatasetPacket(AWriter : TRxDataPacketReader);
procedure LoadFromStream(AStream : TStream; Format: TRxDataPacketFormat = dfBinary);
procedure SaveToStream(AStream : TStream; Format: TRxDataPacketFormat = dfBinary);
procedure LoadFromFile(AFileName: string = ''; Format: TRxDataPacketFormat = dfAny);
procedure SaveToFile(AFileName: string = ''; Format: TRxDataPacketFormat = dfAny);
published
property Capacity: Integer read GetCapacity write SetCapacity default 0;
property Active;
@ -183,6 +203,9 @@ type
property OnFilterRecordEx: TFilterRecordEvent read GetOnFilterRecordEx write SetOnFilterRecordEx;
property OnNewRecord;
property OnPostError;
property FileName : string read FFileName write FFileName;
property PacketRecords : Integer read FPacketRecords write SetPacketRecords default 10;
end;
{ TMemBlobStream }
@ -1221,13 +1244,6 @@ begin
BindFields(True);
InitBufferPointers(True);
InternalFirst;
// OpenCursor(false);
// ������ ����� ����������� ���� � �������� ������ ���������� � ������ FieldDefs
{ Fields.Clear;
CreateFields;
if DefaultFields then CreateFields;
BindFields(True);}
//
end;
procedure TRxMemoryData.InternalClose;
@ -1243,7 +1259,6 @@ end;
procedure TRxMemoryData.InternalHandleException;
begin
CustomApplication.HandleException(Self);
//Application.HandleException(Self);
end;
procedure TRxMemoryData.InternalInitFieldDefs;
@ -1308,7 +1323,6 @@ var
else
Result := AnsiCompareStr(S, S1) = 0;
end
// else Result := false //(Field.Value = Value);
else Result := (Field.Value = Value);
end;
@ -1700,6 +1714,199 @@ begin
FIndexList := nil;
end;
function TRxMemoryData.IntAllocRecordBuffer: PChar;
begin
// do nothing
end;
procedure TRxMemoryData.IntLoadFielddefsFromFile;
begin
FDatasetReader.LoadFielddefs(FieldDefs);
if DefaultFields then CreateFields;
end;
procedure TRxMemoryData.IntLoadRecordsFromFile;
var StoreState : TDataSetState;
AddRecordBuffer : boolean;
ARowState : TRowState;
AUpdOrder : integer;
begin
FDatasetReader.InitLoadRecords;
StoreState:=SetTempState(dsFilter);
while FDatasetReader.GetCurrentRecord do
begin
ARowState := FDatasetReader.GetRecordRowState(AUpdOrder);
FDatasetReader.RestoreRecord(self);
inc(FBRecordCount);
FDatasetReader.GotoNextRecord;
end;
RestoreState(StoreState);
if assigned(FFileStream) then
begin
FreeAndNil(FFileStream);
FreeAndNil(FDatasetReader);
end;
end;
procedure TRxMemoryData.SetPacketRecords(const AValue: Integer);
begin
if FPacketRecords=AValue then exit;
FPacketRecords:=AValue;
end;
procedure TRxMemoryData.SetDatasetPacket(AReader: TRxDataPacketReader);
var
StoreDSState : TDataSetState;
ARowState : TRowState;
AUpdOrder : integer;
begin
FDatasetReader := AReader;
DisableControls;
try
Filtered := False;
Close; // must be inactive to do IntLoadFielddefsFromFile
// load fields defs
IntLoadFielddefsFromFile;
FreeIndexList;
if not Active then Open;
Resync([]); // clears buffers if empty dataset
CheckBrowseMode;
FDatasetReader.InitLoadRecords;
try
while FDatasetReader.GetCurrentRecord do
begin
Append;
ARowState := FDatasetReader.GetRecordRowState(AUpdOrder); // added for binary export
FDatasetReader.RestoreRecord(TRxMemoryData(Self));
Post;
FDatasetReader.GotoNextRecord;
inc(FBRecordCount);
end;
finally
First;
end;
finally
EnableControls;
end;
if assigned(FFileStream) then
begin
FreeAndNil(FFileStream);
FreeAndNil(FDatasetReader);
end;
end;
procedure TRxMemoryData.GetDatasetPacket(AWriter: TRxDataPacketReader);
var
StoreDSState : TDataSetState;
begin
CheckBrowseMode;
UpdateCursorPos;
FDatasetReader := AWriter;
try
DisableControls;
try
FDatasetReader.StoreFieldDefs(FieldDefs);
First;
while not EOF do
begin
// ** NOTE ** had to cast self to TRxMemoryData just save current values
// otherwise the as string value in ex_rx_datapacket would not write.
FDatasetReader.StoreRecord(TRxMemoryData(Self),[]);
Next;
end;
FDatasetReader.FinalizeStoreRecords;
finally
EnableControls;
end;
finally
FDatasetReader := nil;
end;
end;
procedure TRxMemoryData.LoadFromStream(AStream: TStream;
Format: TRxDataPacketFormat);
var APacketReaderReg : TRxDatapacketReaderRegistration;
APacketReader : TRxDataPacketReader;
begin
if GetRegisterDatapacketReader(AStream,format,APacketReaderReg) then
APacketReader := APacketReaderReg.ReaderClass.create(AStream)
else
DatabaseError(SStreamNotRecognised);
try
SetDatasetPacket(APacketReader);
finally
APacketReader.Free;
end;
end;
procedure TRxMemoryData.SaveToStream(AStream: TStream;
Format: TRxDataPacketFormat);
var APacketReaderReg : TRxDatapacketReaderRegistration;
APacketWriter : TRxDataPacketReader;
begin
if GetRegisterDatapacketReader(Nil,format,APacketReaderReg) then
APacketWriter := APacketReaderReg.ReaderClass.create(AStream)
else
DatabaseError(SNoReaderClassRegistered);
try
GetDatasetPacket(APacketWriter);
finally
APacketWriter.Free;
end;
end;
procedure TRxMemoryData.LoadFromFile(AFileName: string;
Format: TRxDataPacketFormat);
var AFileStream : TFileStream;
begin
if AFileName='' then AFileName := FFileName;
AFileStream := TFileStream.Create(AFileName,fmOpenRead);
try
LoadFromStream(AFileStream, Format);
finally
AFileStream.Free;
end;
end;
procedure TRxMemoryData.SaveToFile(AFileName: string;
Format: TRxDataPacketFormat);
var AFileStream : TFileStream;
begin
if AFileName='' then AFileName := FFileName;
AFileStream := TFileStream.Create(AFileName,fmCreate);
try
SaveToStream(AFileStream, Format);
finally
AFileStream.Free;
end;
end;
{ TMemBlobStream }
constructor TMemBlobStream.Create(Field: TBlobField; Mode: TBlobStreamMode);

25
components/rx/rxnew.lpk
View File

@ -23,12 +23,11 @@
</CompilerOptions>
<Description Value="Delphi VCL Extensions (RX)
Copyright (c) 1998 Master-Bank
translate to Lazarus by alexs in 2005 - 2009
translate to Lazarus by alexs in 2005 - 2012
"/>
<License Value="free ware
"/>
<Version Build="105" Major="2" Minor="1" Release="2"/>
<Files Count="61">
<License Value="LGPL"/>
<Version Major="2" Minor="2" Release="1" Build="106"/>
<Files Count="64">
<Item1>
<Filename Value="autopanel.pas"/>
<UnitName Value="AutoPanel"/>
@ -276,8 +275,20 @@ translate to Lazarus by alexs in 2005 - 2009
<Filename Value="rxhistorynavigator.pas"/>
<UnitName Value="RxHistoryNavigator"/>
</Item61>
<Item62>
<Filename Value="ex_rx_bin_datapacket.pas"/>
<UnitName Value="ex_rx_bin_datapacket"/>
</Item62>
<Item63>
<Filename Value="ex_rx_datapacket.pas"/>
<UnitName Value="ex_rx_datapacket"/>
</Item63>
<Item64>
<Filename Value="ex_rx_xml_datapacket.pas"/>
<UnitName Value="ex_rx_xml_datapacket"/>
</Item64>
</Files>
<LazDoc Paths="docs\;\usr\local\share\lazarus\components\rxnew\docs\"/>
<LazDoc Paths="docs;\usr\local\share\lazarus\components\rxnew\docs"/>
<i18n>
<EnableI18N Value="True"/>
<OutDir Value="languages"/>
@ -299,7 +310,7 @@ translate to Lazarus by alexs in 2005 - 2009
</Item4>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)\"/>
<UnitPath Value="$(PkgOutDir)"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>

17
components/rx/rxnew.pas
View File

@ -2,7 +2,7 @@
This source is only used to compile and install the package.
}
unit rxnew;
unit rxnew;
interface
@ -17,17 +17,18 @@ uses
rxmemds, rxpopupunit, rxsortmemds, rxspin, rxstrutils, rxswitch,
RxSystemServices, rxtbrsetup, RxTimeEdit, rxtoolbar, RxVersInfo,
RxViewsPanel, rxxpman, seldsfrm, tooledit, vclutils, RxCloseFormValidator,
RxHistoryNavigator, LazarusPackageIntf;
RxHistoryNavigator, ex_rx_bin_datapacket, ex_rx_datapacket,
ex_rx_xml_datapacket, LazarusPackageIntf;
implementation
procedure Register;
procedure Register;
begin
RegisterUnit('registerrx', @registerrx.Register);
RegisterUnit('RegisterRxDB', @RegisterRxDB.Register);
RegisterUnit('RegisterRxTools', @RegisterRxTools.Register);
end;
RegisterUnit('registerrx', @registerrx.Register);
RegisterUnit('RegisterRxDB', @RegisterRxDB.Register);
RegisterUnit('RegisterRxTools', @RegisterRxTools.Register);
end;
initialization
RegisterPackage('rxnew', @Register);
RegisterPackage('rxnew', @Register);
end.