1194 lines
32 KiB
ObjectPascal
1194 lines
32 KiB
ObjectPascal
{*******************************************************************}
|
|
{ }
|
|
{ ExpressWeb Framework by Developer Express }
|
|
{ Web Persistent Module }
|
|
{ }
|
|
{ Copyright (c) 2000-2009 Developer Express Inc. }
|
|
{ ALL RIGHTS RESERVED }
|
|
{ }
|
|
{ The entire contents of this file is protected by U.S. and }
|
|
{ International Copyright Laws. Unauthorized reproduction, }
|
|
{ reverse-engineering, and distribution of all or any portion of }
|
|
{ the code contained in this file is strictly prohibited and may }
|
|
{ result in severe civil and criminal penalties and will be }
|
|
{ prosecuted to the maximum extent possible under the law. }
|
|
{ }
|
|
{ RESTRICTIONS }
|
|
{ }
|
|
{ THIS SOURCE CODE AND ALL RESULTING INTERMEDIATE FILES }
|
|
{ (DCU, OBJ, DLL, ETC.) ARE CONFIDENTIAL AND PROPRIETARY TRADE }
|
|
{ SECRETS OF DEVELOPER EXPRESS INC. THE REGISTERED DEVELOPER IS }
|
|
{ LICENSED TO DISTRIBUTE THE EXPRESSWEB FRAMEWORK AND ALL }
|
|
{ ACCOMPANYING VCL CLASSES AS PART OF AN EXECUTABLE WEB }
|
|
{ APPLICATION ONLY. }
|
|
{ }
|
|
{ THE SOURCE CODE CONTAINED WITHIN THIS FILE AND ALL RELATED }
|
|
{ FILES OR ANY PORTION OF ITS CONTENTS SHALL AT NO TIME BE }
|
|
{ COPIED, TRANSFERRED, SOLD, DISTRIBUTED, OR OTHERWISE MADE }
|
|
{ AVAILABLE TO OTHER INDIVIDUALS WITHOUT EXPRESS WRITTEN CONSENT }
|
|
{ AND PERMISSION FROM DEVELOPER EXPRESS INC. }
|
|
{ }
|
|
{ CONSULT THE END USER LICENSE AGREEMENT FOR INFORMATION ON }
|
|
{ ADDITIONAL RESTRICTIONS. }
|
|
{ }
|
|
{*******************************************************************}
|
|
unit cxWebFiler;
|
|
|
|
{$I cxVer.inc}
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes,
|
|
cxWebIntf;
|
|
|
|
type
|
|
TcxCompItems = class;
|
|
|
|
TcxCompItem = class
|
|
private
|
|
FDeleting: Boolean;
|
|
FItems: TcxCompItems;
|
|
FName: string;
|
|
FOwner: TcxCompItems;
|
|
FValue: Integer;
|
|
FSize: Integer;
|
|
function GetIndex: Integer;
|
|
function GetItem(Index: Integer): TcxCompItem;
|
|
public
|
|
constructor Create(AOwner: TcxCompItems);
|
|
destructor Destroy; override;
|
|
function Add(Name: string; Value: Integer): TcxCompItem;
|
|
procedure Clear;
|
|
function Count: Integer;
|
|
function First: TcxCompItem;
|
|
function GetItemByName(Name: string): TcxCompItem;
|
|
function IndexOf(Name: string): integer;
|
|
property Deleting: Boolean read FDeleting;
|
|
property Index: Integer read GetIndex;
|
|
property Items[Index: Integer]: TcxCompItem read GetItem;
|
|
function Last: TcxCompItem;
|
|
property Name: string read FName write FName;
|
|
property Value: Integer read FValue write FValue;
|
|
property Size: Integer read FSize write FSize;
|
|
end;
|
|
|
|
TcxCompItems = class
|
|
private
|
|
FItems: TList;
|
|
function GetItem(Index: Integer): TcxCompItem;
|
|
public
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
function Add(Name: string; Value: Integer): TcxCompItem;
|
|
procedure Clear;
|
|
function Count: Integer;
|
|
procedure Delete(Index: Integer);
|
|
function First: TcxCompItem;
|
|
function GetItemByName(Name: string): TcxCompItem;
|
|
function IndexOf(Item: TcxCompItem): Integer;
|
|
function IndexOfName(Name: string): Integer;
|
|
function Last: TcxCompItem;
|
|
property Items[Index: Integer]: TcxCompItem read GetItem;
|
|
end;
|
|
|
|
TcxComparator = class(TObject)
|
|
private
|
|
FSamplePropPos: Integer;
|
|
FCorrection: Integer;
|
|
FInput: TReader;
|
|
FSample: TReader;
|
|
FPatch: TStream;
|
|
FObjList: TcxCompItems;
|
|
FCurrentObj: TcxCompItem;
|
|
FRoot: TComponent;
|
|
FRootPersistent: IcxWebModuleComponentPersistent;
|
|
|
|
function IsObjectPersistent(const AObjID: string): Boolean;
|
|
procedure WriteAddCommand(Offset: Integer; Count: Integer; Data: PChar);
|
|
procedure WriteDiscardCommand(Offset: Integer; Count: Integer);
|
|
procedure WriteReplaceCommand(Offset1, Offset2: Integer; Count: Integer; Data: PChar);
|
|
protected
|
|
procedure AddProperty(const Name: string);
|
|
procedure AddObject(const HeaderSize: Integer);
|
|
procedure CompareBinary(const BytesPerUnit: Integer);
|
|
procedure CompareBytes(const Count: Integer);
|
|
procedure CompareCollection;
|
|
procedure CompareList;
|
|
procedure CompareObject;
|
|
procedure CompareSetBody;
|
|
procedure CompareStrs;
|
|
procedure CompareValue;
|
|
procedure DiscardObject(Obj: TcxCompItem);
|
|
procedure DiscardProperty(Prop: TcxCompItem);
|
|
procedure PrepareObject;
|
|
function ReadObjectHeader(AReader: TReader; var Header: string): Integer;
|
|
public
|
|
constructor Create(ARoot: TComponent);
|
|
destructor Destroy; override;
|
|
procedure ApplyStreamPatch(Patch, Sample, Output: TStream);
|
|
procedure CreateStreamPatch(Input, Sample, Patch: TStream);
|
|
end;
|
|
|
|
TcxWebFilerClass = class of TcxWebFiler;
|
|
TcxWebFiler = class
|
|
private
|
|
class function BinaryStreamToString(BinStream: TStream): string; virtual;
|
|
class function LoadFromResource(ARoot: TComponent): TResourceStream; virtual;
|
|
class procedure StringToBinaryStream(const Str: string; BinStream: TStream); virtual;
|
|
public
|
|
class function ComponentToString(const ARoot: TComponent): string; virtual;
|
|
class procedure StringToComponent(const Source: string; ARoot: TComponent); virtual;
|
|
end;
|
|
|
|
(*
|
|
IcxWebStreamCoder = interface
|
|
['{20FD9453-66A3-447C-9552-81ABA11FB0BD}']
|
|
procedure DecodeStream(InStream, OutStream: TStream);
|
|
procedure EncodeStream(InStream, OutStream: TStream);
|
|
end;
|
|
|
|
IcxWebFiler = interface
|
|
['{25CB2124-7CD1-4744-B751-8520F728FDBF}']
|
|
function ComponentToString(const AComponent: TComponent): string;
|
|
procedure StringToComponent(const Source: string; AComponent: TComponent);
|
|
end;
|
|
|
|
{ filer }
|
|
function cxActiveWebFiler: IcxWebFiler;
|
|
procedure cxRegisterWebFiler(const AFiler: IcxWebFiler);
|
|
procedure cxUnregisterWebFiler(const AFiler: IcxWebFiler);
|
|
|
|
{ coder }
|
|
function cxActiveWebStreamCoder: IcxWebStreamCoder;
|
|
procedure cxRegisterWebStreamCoder(const ACoder: IcxWebStreamCoder);
|
|
procedure cxUnregisterWebStreamCoder(const ACoder: IcxWebStreamCoder);
|
|
*)
|
|
|
|
implementation
|
|
|
|
uses SysUtils, RTLConsts,
|
|
{$IFDEF VCL}
|
|
Windows;
|
|
{$ELSE}
|
|
Types;
|
|
{$ENDIF}
|
|
|
|
const
|
|
BASE = 64;
|
|
NULL_CHAR = '=';
|
|
EncodeTable: array[0..BASE - 1] of Char =
|
|
'ABCDEFGHIJKLMNOPQRSTUVWXYZ' +
|
|
'abcdefghijklmnopqrstuvwxyz' +
|
|
'0123456789+/';
|
|
|
|
type
|
|
PPacket = ^TPacket;
|
|
TPacket = packed record
|
|
case Integer of
|
|
0: (b0, b1, b2, b3: Byte);
|
|
1: (i: Integer);
|
|
2: (a: array[0..3] of Byte);
|
|
end;
|
|
|
|
TcxCompOp = (coAdd, coDiscard, coReplace);
|
|
TcxCompCmdHeader = packed record
|
|
Op: TcxCompOp;
|
|
Offset: Integer;
|
|
Count: Word;
|
|
end;
|
|
|
|
const
|
|
MAX_COUNT = $FFFF; // Word
|
|
|
|
procedure EncodeStream(Input, Output: TStream);
|
|
type
|
|
PInteger = ^Integer;
|
|
const
|
|
CRLF = #$0D#$0A;
|
|
var
|
|
InBuf: array[0..767] of Byte;
|
|
OutBuf: array[0..1023] of Char;
|
|
BufPtr: PChar;
|
|
NumChars, BytesRead: Integer;
|
|
I, Len: Integer;
|
|
Packet: TPacket;
|
|
|
|
procedure EncodePacket;
|
|
var
|
|
J: Integer;
|
|
begin
|
|
for J := 0 to 3 do
|
|
begin
|
|
if NumChars < J then
|
|
BufPtr[J] := NULL_CHAR
|
|
else
|
|
BufPtr[J] := EncodeTable[Packet.i mod BASE];
|
|
Packet.i := Packet.i div BASE;
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
repeat
|
|
BytesRead := Input.Read(InBuf, SizeOf(InBuf));
|
|
I := 0;
|
|
BufPtr := OutBuf;
|
|
while I < BytesRead do
|
|
begin
|
|
if BytesRead - I < 3 then
|
|
NumChars := BytesRead - I
|
|
else NumChars := 3;
|
|
Packet.i := 0;
|
|
Packet.b0 := InBuf[I];
|
|
if NumChars > 1 then
|
|
Packet.b1 := InBuf[I + 1];
|
|
if NumChars > 2 then
|
|
Packet.b2 := InBuf[I + 2];
|
|
EncodePacket;
|
|
Inc(I, 3);
|
|
Inc(BufPtr, 4);
|
|
end;
|
|
Len := BufPtr - PChar(@OutBuf);
|
|
Output.Write(Outbuf, Len);
|
|
if Len = SizeOf(OutBuf) then
|
|
Output.Write(CRLF, 2);
|
|
until BytesRead = 0;
|
|
end;
|
|
|
|
procedure DecodeStream(Input, Output: TStream);
|
|
var
|
|
DecodeTable: array[#0..#127] of Byte;
|
|
InBuf: array[0..1023] of Char;
|
|
OutBuf: array[0..767] of Byte;
|
|
InBufPtr, OutBufPtr: PChar;
|
|
I, J, nChars, BytesRead: Integer;
|
|
Packet: TPacket;
|
|
|
|
function DecodePacket: TPacket;
|
|
var
|
|
Weight: Integer;
|
|
begin
|
|
Result.i := 0;
|
|
nChars := 0;
|
|
Weight := 1;
|
|
repeat
|
|
Result.i := Result.i + DecodeTable[InBufPtr[nChars]] * Weight;
|
|
Inc(nChars);
|
|
Weight := Weight * BASE;
|
|
until (nChars > 3) or (InBufPtr[nChars] = NULL_CHAR);
|
|
Dec(nChars);
|
|
end;
|
|
|
|
begin
|
|
FillChar(DecodeTable, SizeOf(DecodeTable), BASE);
|
|
for I := Low(EncodeTable) to High(EncodeTable) do
|
|
DecodeTable[EncodeTable[I]] := I;
|
|
repeat
|
|
BytesRead := Input.Read(InBuf, SizeOf(InBuf));
|
|
InBufPtr := InBuf;
|
|
OutBufPtr := @OutBuf;
|
|
I := 0;
|
|
while I < BytesRead do
|
|
begin
|
|
Packet := DecodePacket;
|
|
J := 0;
|
|
while nChars > 0 do
|
|
begin
|
|
OutBufPtr^ := Char(Packet.a[J]);
|
|
Inc(OutBufPtr);
|
|
Dec(nChars);
|
|
Inc(J);
|
|
end;
|
|
Inc(InBufPtr, 4);
|
|
Inc(I, 4);
|
|
end;
|
|
Output.Write(OutBuf, OutBufPtr - PChar(@OutBuf));
|
|
if BytesRead = SizeOf(InBuf) then
|
|
Input.Read(InBuf, 2);
|
|
until BytesRead = 0;
|
|
end;
|
|
|
|
{ TcxWebFiler }
|
|
|
|
class function TcxWebFiler.BinaryStreamToString(BinStream: TStream): string;
|
|
var
|
|
StrStream: TStringStream;
|
|
begin
|
|
StrStream := TStringStream.Create('');
|
|
try
|
|
EncodeStream(BinStream, StrStream);
|
|
Result := StrStream.DataString;
|
|
finally
|
|
StrStream.Free;
|
|
end;
|
|
end;
|
|
|
|
class function TcxWebFiler.LoadFromResource(ARoot: TComponent): TResourceStream;
|
|
var
|
|
HInst: THandle;
|
|
ResName: string;
|
|
begin
|
|
HInst := FindResourceHInstance(FindClassHInstance(ARoot.ClassType));
|
|
ResName := ARoot.ClassType.ClassName;
|
|
if FindResource(HInst, PChar(ResName), RT_RCDATA) = 0 then
|
|
raise EResNotFound.CreateFmt('%s', [ResName]);
|
|
Result := TResourceStream.Create(HInst, ResName, RT_RCDATA);
|
|
end;
|
|
|
|
class procedure TcxWebFiler.StringToBinaryStream(const Str: string; BinStream: TStream);
|
|
var
|
|
StrStream: TStringStream;
|
|
begin
|
|
StrStream := TStringStream.Create('');
|
|
try
|
|
StrStream.WriteString(Str);
|
|
StrStream.Position := 0;
|
|
DecodeStream(StrStream, BinStream);
|
|
finally
|
|
StrStream.Free;
|
|
end;
|
|
end;
|
|
|
|
class function TcxWebFiler.ComponentToString(const ARoot: TComponent): string;
|
|
var
|
|
Resource: TResourceStream;
|
|
Component, Patch: TMemoryStream;
|
|
begin
|
|
Component := TMemoryStream.Create;
|
|
try
|
|
Resource:= LoadFromResource(ARoot);
|
|
try
|
|
Component.WriteComponent(ARoot);
|
|
Component.Position := 0;
|
|
Patch := TMemoryStream.Create;
|
|
try
|
|
with TcxComparator.Create(ARoot) do
|
|
try
|
|
CreateStreamPatch(Component, Resource, Patch);
|
|
finally
|
|
Free;
|
|
end;
|
|
Patch.Position := 0;
|
|
Result := BinaryStreamToString(Patch);
|
|
finally
|
|
Patch.Free;
|
|
end;
|
|
finally
|
|
Resource.Free;
|
|
end;
|
|
finally
|
|
Component.Free;
|
|
end;
|
|
end;
|
|
|
|
class procedure TcxWebFiler.StringToComponent(const Source: string; ARoot: TComponent);
|
|
var
|
|
Resource: TResourceStream;
|
|
Component, Patch: TMemoryStream;
|
|
LocalizeLoading: Boolean;
|
|
begin
|
|
GlobalNameSpace.BeginWrite; // hold lock across all ancestor loads (performance)
|
|
try
|
|
LocalizeLoading := (ARoot.ComponentState * [csInline, csLoading]) = [];
|
|
if LocalizeLoading then BeginGlobalLoading; // push new loadlist onto stack
|
|
try
|
|
Resource := LoadFromResource(ARoot);
|
|
try
|
|
Component := TMemoryStream.Create;
|
|
try
|
|
Patch := TMemoryStream.Create;
|
|
try
|
|
StringToBinaryStream(Source, Patch);
|
|
Patch.Position := 0;
|
|
with TcxComparator.Create(ARoot) do
|
|
try
|
|
ApplyStreamPatch(Patch, Resource, Component);
|
|
finally
|
|
Free;
|
|
end;
|
|
Component.Position := 0;
|
|
finally
|
|
Patch.Free;
|
|
end;
|
|
Component.ReadComponent(ARoot);
|
|
finally
|
|
Component.Free;
|
|
end;
|
|
finally
|
|
Resource.Free;
|
|
end;
|
|
if LocalizeLoading then NotifyGlobalLoading; // call Loaded
|
|
finally
|
|
if LocalizeLoading then EndGlobalLoading; // pop loadlist off stack
|
|
end;
|
|
finally
|
|
GlobalNameSpace.EndWrite;
|
|
end;
|
|
end;
|
|
|
|
type
|
|
TReaderWrapper = class(TReader);
|
|
|
|
constructor TcxComparator.Create(ARoot: TComponent);
|
|
begin
|
|
FObjList := TcxCompItems.Create;
|
|
FRoot := ARoot;
|
|
Supports(FRoot, IcxWebModuleComponentPersistent, FRootPersistent);
|
|
end;
|
|
|
|
destructor TcxComparator.Destroy;
|
|
begin
|
|
if FObjList <> nil then FObjList.Free;
|
|
end;
|
|
|
|
procedure TcxComparator.ApplyStreamPatch(Patch, Sample, Output: TStream);
|
|
var
|
|
BytesRead, SamplePos: Integer;
|
|
CmdHeader: TcxCompCmdHeader;
|
|
begin
|
|
BytesRead := Patch.Read(CmdHeader, SizeOf(CmdHeader));
|
|
while BytesRead > 0 do
|
|
begin
|
|
case CmdHeader.Op of
|
|
coAdd:
|
|
begin
|
|
if CmdHeader.Offset > Output.Position then
|
|
Output.CopyFrom(Sample, CmdHeader.Offset - Output.Position);
|
|
Output.CopyFrom(Patch, CmdHeader.Count);
|
|
end;
|
|
coDiscard:
|
|
begin
|
|
if CmdHeader.Offset > Sample.Position then
|
|
Output.CopyFrom(Sample, CmdHeader.Offset - Sample.Position);
|
|
Sample.Seek(CmdHeader.Count, soFromCurrent);
|
|
end;
|
|
coReplace:
|
|
begin
|
|
if CmdHeader.Offset > Output.Position then
|
|
Output.CopyFrom(Sample, CmdHeader.Offset - Output.Position);
|
|
Patch.Read(SamplePos, SizeOf(SamplePos));
|
|
if SamplePos > Sample.Position then
|
|
Output.CopyFrom(Sample, SamplePos - Sample.Position);
|
|
Output.CopyFrom(Patch, CmdHeader.Count);
|
|
Sample.Seek(CmdHeader.Count, soFromCurrent);
|
|
end;
|
|
end;
|
|
BytesRead := Patch.Read(CmdHeader, SizeOf(CmdHeader));
|
|
end;
|
|
if Sample.Position < Sample.Size then
|
|
Output.CopyFrom(Sample, Sample.Size - Sample.Position);
|
|
end;
|
|
|
|
procedure TcxComparator.CreateStreamPatch(Input, Sample, Patch: TStream);
|
|
begin
|
|
FPatch := Patch;
|
|
FSample := TReader.Create(Sample, 4096);
|
|
try
|
|
FObjList.Clear;
|
|
FSample.ReadSignature;
|
|
PrepareObject;
|
|
FInput := TReader.Create(Input, 4096);
|
|
try
|
|
FInput.ReadSignature;
|
|
FCorrection := 0;
|
|
CompareObject;
|
|
while FObjList.Count > 0 do
|
|
DiscardObject(FObjList.First);
|
|
finally
|
|
FInput.Free;
|
|
end;
|
|
finally
|
|
FSample.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TcxComparator.AddProperty(const Name: string);
|
|
var
|
|
Count: Integer;
|
|
StartPos: Integer;
|
|
Buf: PChar;
|
|
begin
|
|
StartPos := FInput.Position - Length(Name) - 1;
|
|
FInput.SkipValue;
|
|
Count := FInput.Position - StartPos;
|
|
FInput.Position := StartPos;
|
|
GetMem(Buf, Count);
|
|
try
|
|
FInput.Read(Buf^, Count);
|
|
WriteAddCommand(StartPos, Count, Buf);
|
|
finally
|
|
if Buf <> nil then FreeMem(Buf);
|
|
end;
|
|
end;
|
|
|
|
procedure TcxComparator.AddObject(const HeaderSize: Integer);
|
|
var
|
|
Count: Integer;
|
|
StartPos: Integer;
|
|
Buf: PChar;
|
|
begin
|
|
StartPos := FInput.Position - HeaderSize;
|
|
TReaderWrapper(FInput).SkipComponent(False);
|
|
Count := FInput.Position - StartPos;
|
|
FInput.Position := StartPos;
|
|
GetMem(Buf, Count);
|
|
try
|
|
FInput.Read(Buf^, Count);
|
|
FInput.Position := FInput.Position - SizeOf(vaNull);
|
|
WriteAddCommand(StartPos, Count, Buf);
|
|
finally
|
|
if Buf <> nil then FreeMem(Buf);
|
|
end;
|
|
end;
|
|
|
|
procedure TcxComparator.CompareBinary(const BytesPerUnit: Integer);
|
|
var
|
|
Len1, Len2: Longint;
|
|
Buf: PChar;
|
|
begin
|
|
FInput.Read(Len1, SizeOf(Len1));
|
|
FSample.Position := FSamplePropPos;
|
|
FSample.Read(Len2, SizeOf(Len2));
|
|
if Len1 = Len2 then
|
|
begin
|
|
Inc(FSamplePropPos, SizeOf(Len2));
|
|
CompareBytes(Len1 * BytesPerUnit);
|
|
end
|
|
else
|
|
begin
|
|
Len1 := Len1 * BytesPerUnit + SizeOf(Len1);
|
|
Len2 := Len2 * BytesPerUnit + SizeOf(Len2);
|
|
FInput.Position := FInput.Position - SizeOf(Len1);
|
|
FSample.Position := FSample.Position - SizeOf(Len2);
|
|
WriteDiscardCommand(FSample.Position, Len2);
|
|
FSample.Position := FSample.Position + Len2;
|
|
GetMem(Buf, Len1);
|
|
try
|
|
FInput.Read(Buf^, Len1);
|
|
WriteAddCommand(FInput.Position - Len1, Len1, Buf);
|
|
finally
|
|
if Buf <> nil then FreeMem(Buf);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TcxComparator.CompareBytes(const Count: Integer);
|
|
var
|
|
Buf1, Buf2: PChar;
|
|
begin
|
|
GetMem(Buf1, Count);
|
|
GetMem(Buf2, Count);
|
|
try
|
|
FInput.Read(Buf1^, Count);
|
|
FSample.Position := FSamplePropPos;
|
|
FSample.Read(Buf2^, Count);
|
|
if not CompareMem(Buf1, Buf2, Count) then
|
|
WriteReplaceCommand(FInput.Position - Count, FSample.Position - Count, Count, Buf1);
|
|
finally
|
|
if Buf1 <> nil then FreeMem(Buf1);
|
|
if Buf2 <> nil then FreeMem(Buf2);
|
|
end;
|
|
end;
|
|
|
|
procedure TcxComparator.CompareCollection;
|
|
var
|
|
StartPos: Integer;
|
|
Len1, Len2: Integer;
|
|
Buf: PChar;
|
|
begin
|
|
StartPos := FInput.Position;
|
|
FInput.Position := FInput.Position - SizeOf(TValueType);
|
|
FInput.SkipValue;
|
|
Len1 := FInput.Position - StartPos;
|
|
FInput.Position := StartPos;
|
|
FSample.Position := FSamplePropPos - SizeOf(TValueType);
|
|
FSample.SkipValue;
|
|
Len2 := FSample.Position - FSamplePropPos;
|
|
if Len1 = Len2 then
|
|
CompareBytes(Len1)
|
|
else
|
|
begin
|
|
WriteDiscardCommand(FSamplePropPos, Len2);
|
|
FSample.Position := FSamplePropPos + Len2;
|
|
GetMem(Buf, Len1);
|
|
try
|
|
FInput.Read(Buf^, Len1);
|
|
WriteAddCommand(StartPos, Len1, Buf);
|
|
finally
|
|
if Buf <> nil then FreeMem(Buf);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TcxComparator.CompareList;
|
|
var
|
|
StartPos, Count: Integer;
|
|
Buf: PChar;
|
|
begin
|
|
while not FInput.EndOfList do
|
|
begin
|
|
if FSample.NextValue <> vaNull then
|
|
begin
|
|
CompareValue;
|
|
FSamplePropPos := FSample.Position;
|
|
end
|
|
else
|
|
begin
|
|
StartPos := FInput.Position;
|
|
FInput.SkipValue;
|
|
Count := FInput.Position - StartPos;
|
|
GetMem(Buf, Count);
|
|
try
|
|
FInput.Position := StartPos;
|
|
FInput.Read(Buf^, Count);
|
|
WriteAddCommand(StartPos, Count, Buf);
|
|
finally
|
|
if Buf <> nil then FreeMem(Buf);
|
|
end;
|
|
end;
|
|
end;
|
|
FInput.ReadListEnd;
|
|
StartPos := FSample.Position;
|
|
while not FSample.EndOfList do
|
|
FSample.SkipValue;
|
|
if FSample.Position > StartPos then
|
|
WriteDiscardCommand(StartPos, FSample.Position - StartPos);
|
|
FSample.ReadListEnd;
|
|
end;
|
|
|
|
procedure TcxComparator.CompareObject;
|
|
var
|
|
ObjID: string;
|
|
HeaderSize, StartPos: Integer;
|
|
Obj, Prop: TcxCompItem;
|
|
PropName: string;
|
|
SkipProperties: Boolean;
|
|
begin
|
|
HeaderSize := ReadObjectHeader(FInput, ObjID);
|
|
Obj := FObjList.GetItemByName(ObjID);
|
|
FCurrentObj := Obj;
|
|
if Obj <> nil then
|
|
begin
|
|
while Obj <> FObjList.First do
|
|
DiscardObject(FObjList.First);
|
|
SkipProperties := not IsObjectPersistent(ObjID);
|
|
StartPos := FInput.Position - HeaderSize;
|
|
while not FInput.EndOfList do
|
|
begin
|
|
if not SkipProperties then
|
|
begin
|
|
PropName := FInput.ReadStr;
|
|
Prop := Obj.GetItemByName(PropName);
|
|
if Prop <> nil then
|
|
begin
|
|
while Prop <> Obj.First do DiscardProperty(Obj.First);
|
|
FSamplePropPos := Prop.Value;
|
|
CompareValue;
|
|
Prop.Free;
|
|
end
|
|
else
|
|
AddProperty(PropName);
|
|
end
|
|
else
|
|
TReaderWrapper(FInput).SkipProperty;
|
|
end;
|
|
FInput.ReadListEnd;
|
|
if SkipProperties then
|
|
FCorrection := FCorrection + Obj.Size - (FInput.Position - StartPos);
|
|
while Obj.Count > 0 do DiscardProperty(Obj.First);
|
|
Obj.Free;
|
|
end
|
|
else
|
|
if IsObjectPersistent(ObjID) then
|
|
AddObject(HeaderSize)
|
|
else
|
|
begin
|
|
StartPos := FInput.Position - HeaderSize;
|
|
TReaderWrapper(FInput).SkipComponent(False);
|
|
FCorrection := FCorrection - (FInput.Position - StartPos);
|
|
FInput.Position := FInput.Position - SizeOf(vaNull);
|
|
end;
|
|
while not FInput.EndOfList do
|
|
CompareObject;
|
|
FInput.ReadListEnd;
|
|
end;
|
|
|
|
procedure TcxComparator.PrepareObject;
|
|
var
|
|
HeaderSize: Integer;
|
|
ObjID: string;
|
|
Obj: TcxCompItem;
|
|
SkipProperies: Boolean;
|
|
begin
|
|
HeaderSize := ReadObjectHeader(FSample, ObjID);
|
|
Obj := FObjList.Add(ObjID, FSample.Position - HeaderSize);
|
|
SkipProperies := not IsObjectPersistent(ObjID);
|
|
while not FSample.EndOfList do
|
|
if not SkipProperies then
|
|
begin
|
|
Obj.Add(FSample.ReadStr, FSample.Position);
|
|
FSample.SkipValue;
|
|
end
|
|
else
|
|
TReaderWrapper(FSample).SkipProperty;
|
|
FSample.ReadListEnd;
|
|
Obj.Size := FSample.Position - Obj.Value;
|
|
while not FSample.EndOfList
|
|
do PrepareObject;
|
|
FSample.ReadListEnd;
|
|
end;
|
|
|
|
procedure TcxComparator.CompareSetBody;
|
|
var
|
|
S: string;
|
|
Index: Integer;
|
|
List: TcxCompItems;
|
|
Buf: PChar;
|
|
Count: Integer;
|
|
begin
|
|
FSample.Position := FSamplePropPos;
|
|
List := TcxCompItems.Create;
|
|
try
|
|
repeat
|
|
S := FSample.ReadStr;
|
|
List.Add(S, FSamplePropPos);
|
|
FSamplePropPos := FSample.Position;
|
|
until S = '';
|
|
repeat
|
|
S := FInput.ReadStr;
|
|
Index := List.IndexOfName(S);
|
|
while Index > 0 do
|
|
begin
|
|
WriteDiscardCommand(List.First.Value, Length(List.First.Name) + 1);
|
|
List.First.Free;
|
|
Dec(Index);
|
|
end;
|
|
if Index = -1 then
|
|
begin
|
|
Count := Length(S) + 1;
|
|
FInput.Position := FInput.Position - Count;
|
|
GetMem(Buf, Count);
|
|
try
|
|
FInput.Read(Buf^, Count);
|
|
WriteAddCommand(FInput.Position - Count, Count, Buf);
|
|
finally
|
|
if Buf <> nil then FreeMem(Buf);
|
|
end;
|
|
end
|
|
else
|
|
List.First.Free;
|
|
until S = '';
|
|
while List.Count > 0 do
|
|
begin
|
|
WriteDiscardCommand(List.First.Value, Length(List.First.Name) + 1);
|
|
List.First.Free;
|
|
end;
|
|
finally
|
|
List.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TcxComparator.CompareStrs;
|
|
var
|
|
Len1, Len2: Byte;
|
|
StartPos: Integer;
|
|
Buf: PChar;
|
|
begin
|
|
FInput.Read(Len1, 1);
|
|
FSample.Position := FSamplePropPos;
|
|
FSample.Read(Len2, 1);
|
|
Inc(FSamplePropPos);
|
|
if Len1 = Len2 then
|
|
CompareBytes(Len1)
|
|
else
|
|
begin
|
|
WriteDiscardCommand(FSample.Position - 1, Len2 + 1);
|
|
FSample.Position := FSample.Position + Len2;
|
|
GetMem(Buf, Len1 + 1);
|
|
try
|
|
StartPos := FInput.Position - 1;
|
|
FInput.Position := StartPos;
|
|
FInput.Read(Buf^, Len1 + 1);
|
|
WriteAddCommand(StartPos, Len1 + 1, Buf);
|
|
finally
|
|
if Buf <> nil then FreeMem(Buf);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TcxComparator.CompareValue;
|
|
var
|
|
StartPos: Integer;
|
|
Count: Integer;
|
|
Buf: PChar;
|
|
begin
|
|
if not (FInput.NextValue in [{vaNull, vaNil,} vaFalse, vaTrue]) then
|
|
begin
|
|
FSample.Position := FSamplePropPos;
|
|
if FInput.NextValue <> FSample.NextValue then
|
|
begin
|
|
FSample.SkipValue;
|
|
WriteDiscardCommand(FSamplePropPos, FSample.Position - FSamplePropPos);
|
|
StartPos := FInput.Position;
|
|
FInput.SkipValue;
|
|
Count := FInput.Position - StartPos;
|
|
GetMem(Buf, Count);
|
|
try
|
|
FInput.Position := StartPos;
|
|
FInput.Read(Buf^, Count);
|
|
WriteAddCommand(StartPos, Count, Buf);
|
|
finally
|
|
if Buf <> nil then FreeMem(Buf);
|
|
end;
|
|
exit;
|
|
end
|
|
else
|
|
FSample.Position := FSample.Position + SizeOf(TValueType);
|
|
FSamplePropPos := FSample.Position;
|
|
end;
|
|
case FInput.ReadValue of
|
|
vaNull, vaNil, vaFalse, vaTrue:
|
|
begin
|
|
FInput.Position := FInput.Position - SizeOf(TValueType);
|
|
CompareBytes(SizeOf(TValueType));
|
|
end;
|
|
vaList: CompareList;
|
|
vaInt8: CompareBytes(SizeOf(Byte));
|
|
vaInt16: CompareBytes(SizeOf(Word));
|
|
vaInt32: CompareBytes(SizeOf(LongInt));
|
|
vaExtended: CompareBytes(SizeOf(Extended));
|
|
vaString, vaIdent: CompareStrs;
|
|
vaBinary: CompareBinary(1);
|
|
vaSet: CompareSetBody;
|
|
vaLString: CompareBinary(1);
|
|
vaCollection: CompareCollection;
|
|
vaSingle: CompareBytes(Sizeof(Single));
|
|
vaCurrency: CompareBytes(SizeOf(Currency));
|
|
vaDate: CompareBytes(Sizeof(TDateTime));
|
|
vaWString: CompareBinary(Sizeof(WideChar));
|
|
vaInt64: CompareBytes(Sizeof(Int64));
|
|
vaUTF8String: CompareBinary(1);
|
|
end;
|
|
end;
|
|
|
|
procedure TcxComparator.DiscardObject(Obj: TcxCompItem);
|
|
var
|
|
Count: Integer;
|
|
begin
|
|
if IsObjectPersistent('') then
|
|
begin
|
|
FSample.Position := Obj.Value;
|
|
TReaderWrapper(FSample).SkipComponent(True);
|
|
Count := FSample.Position - Obj.Value;
|
|
WriteDiscardCommand(Obj.Value, Count);
|
|
end;
|
|
Obj.Free;
|
|
end;
|
|
|
|
procedure TcxComparator.DiscardProperty(Prop: TcxCompItem);
|
|
var
|
|
Count, StartPos: Integer;
|
|
begin
|
|
StartPos := Prop.Value - Length(Prop.Name) - 1;
|
|
FSample.Position := Prop.Value;
|
|
FSample.SkipValue;
|
|
Count := FSample.Position - StartPos;
|
|
WriteDiscardCommand(StartPos, Count);
|
|
Prop.Free;
|
|
end;
|
|
|
|
function TcxComparator.ReadObjectHeader(AReader: TReader; var Header: string): Integer;
|
|
var
|
|
ClassName, ObjectName: string;
|
|
Flags: TFilerFlags;
|
|
StartPos, Position: Integer;
|
|
begin
|
|
Header := '';
|
|
StartPos := AReader.Position;
|
|
AReader.ReadPrefix(Flags, Position);
|
|
ClassName := AReader.ReadStr;
|
|
ObjectName := AReader.ReadStr;
|
|
if ObjectName <> '' then
|
|
Header := ObjectName + ':';
|
|
Header := Header + ClassName;
|
|
Result := AReader.Position - StartPos;
|
|
end;
|
|
|
|
function TcxComparator.IsObjectPersistent(const AObjID: string): Boolean;
|
|
var
|
|
ObjName: string;
|
|
P: Integer;
|
|
begin
|
|
if (FRootPersistent = nil) then
|
|
begin
|
|
Result := False;
|
|
Exit;
|
|
end;
|
|
ObjName := '';
|
|
P := Pos(':', AObjID) - 1;
|
|
if P > 0 then
|
|
begin
|
|
SetLength(ObjName, P);
|
|
StrLCopy(PChar(ObjName), PChar(AObjID), P);
|
|
end;
|
|
if SameText(ObjName, FRoot.Name) then
|
|
Result := FRootPersistent.IsComponentPersistent(FRoot)
|
|
else
|
|
Result := FRootPersistent.IsComponentPersistent(FRoot.FindComponent(ObjName));
|
|
end;
|
|
|
|
procedure TcxComparator.WriteAddCommand(Offset: Integer; Count: Integer; Data: PChar);
|
|
var
|
|
CmdHeader: TcxCompCmdHeader;
|
|
N, Off: Integer;
|
|
begin
|
|
Off := 0;
|
|
while Count > 0 do
|
|
begin
|
|
if Count > MAX_COUNT then
|
|
N := MAX_COUNT
|
|
else
|
|
N := Count;
|
|
CmdHeader.Op := coAdd;
|
|
CmdHeader.Offset := Offset + FCorrection;
|
|
CmdHeader.Count := N;
|
|
FPatch.WriteBuffer(CmdHeader, SizeOf(CmdHeader));
|
|
FPatch.WriteBuffer((Data + Off)^, N);
|
|
Dec(Count, N);
|
|
Inc(Offset, N);
|
|
Inc(Off, N);
|
|
end;
|
|
end;
|
|
|
|
procedure TcxComparator.WriteDiscardCommand(Offset: Integer; Count: Integer);
|
|
var
|
|
CmdHeader: TcxCompCmdHeader;
|
|
N: Integer;
|
|
begin
|
|
while Count > 0 do
|
|
begin
|
|
if Count > MAX_COUNT then
|
|
N := MAX_COUNT
|
|
else
|
|
N := Count;
|
|
CmdHeader.Op := coDiscard;
|
|
CmdHeader.Offset := Offset;
|
|
CmdHeader.Count := N;
|
|
FPatch.WriteBuffer(CmdHeader, SizeOf(CmdHeader));
|
|
Dec(Count, N);
|
|
Inc(Offset, N);
|
|
end;
|
|
end;
|
|
|
|
procedure TcxComparator.WriteReplaceCommand(Offset1, Offset2: Integer; Count: Integer; Data: PChar);
|
|
var
|
|
CmdHeader: TcxCompCmdHeader;
|
|
N, Off: Integer;
|
|
begin
|
|
Off := 0;
|
|
while Count > 0 do
|
|
begin
|
|
if Count > MAX_COUNT then
|
|
N := MAX_COUNT
|
|
else
|
|
N := Count;
|
|
CmdHeader.Op := coReplace;
|
|
CmdHeader.Offset := Offset1 + FCorrection;
|
|
CmdHeader.Count := N;
|
|
FPatch.WriteBuffer(CmdHeader, SizeOf(CmdHeader));
|
|
FPatch.WriteBuffer(Offset2, SizeOf(Offset2));
|
|
FPatch.WriteBuffer((Data + Off)^, N);
|
|
Dec(Count, N);
|
|
Inc(Offset1, N);
|
|
Inc(Offset2, N);
|
|
Inc(Off, N);
|
|
end;
|
|
end;
|
|
|
|
{ TcxCompItems }
|
|
|
|
constructor TcxCompItems.Create;
|
|
begin
|
|
FItems := nil;
|
|
end;
|
|
|
|
destructor TcxCompItems.Destroy;
|
|
begin
|
|
Clear;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TcxCompItems.Add(Name: string; Value: Integer): TcxCompItem;
|
|
var
|
|
Item: TcxCompItem;
|
|
begin
|
|
if FItems = nil then
|
|
FItems := TList.Create;
|
|
Item := TcxCompItem.Create(Self);
|
|
FItems.Add(Item);
|
|
Item.Name := Name;
|
|
Item.Value := Value;
|
|
Result := Item;
|
|
end;
|
|
|
|
procedure TcxCompItems.Clear;
|
|
begin
|
|
while Count > 0 do
|
|
Delete(0);
|
|
end;
|
|
|
|
function TcxCompItems.Count: Integer;
|
|
begin
|
|
Result := 0;
|
|
if FItems <> nil then
|
|
Result := FItems.Count;
|
|
end;
|
|
|
|
procedure TcxCompItems.Delete(Index: Integer);
|
|
begin
|
|
if FItems <> nil then
|
|
begin
|
|
if Items[Index].Deleting then
|
|
FItems.Delete(Index)
|
|
else
|
|
Items[Index].Free;
|
|
if Count = 0 then
|
|
begin
|
|
FItems.Free;
|
|
FItems := nil;
|
|
end;
|
|
end
|
|
else
|
|
raise EListError.CreateResFmt(@SListIndexError, [Index]);
|
|
end;
|
|
|
|
function TcxCompItems.First: TcxCompItem;
|
|
begin
|
|
Result := nil;
|
|
if FItems <> nil then Result := TcxCompItem(FItems.First);
|
|
end;
|
|
|
|
function TcxCompItems.GetItemByName(Name: string): TcxCompItem;
|
|
var
|
|
Index: Integer;
|
|
begin
|
|
Result := nil;
|
|
Index := IndexOfName(Name);
|
|
if Index <> -1 then
|
|
Result := Items[Index];
|
|
end;
|
|
|
|
function TcxCompItems.IndexOf(Item: TcxCompItem): Integer;
|
|
begin
|
|
Result := -1;
|
|
if FItems <> nil then
|
|
Result := FItems.IndexOf(Item);
|
|
end;
|
|
|
|
function TcxCompItems.IndexOfName(Name: string): Integer;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
Result := -1;
|
|
I := 0;
|
|
while (I < Count) and (Result < 0) do
|
|
begin
|
|
if Items[I].Name = Name then
|
|
Result := I;
|
|
Inc(I);
|
|
end;
|
|
end;
|
|
|
|
function TcxCompItems.Last: TcxCompItem;
|
|
begin
|
|
Result := nil;
|
|
if FItems <> nil then Result := TcxCompItem(FItems.Last);
|
|
end;
|
|
|
|
function TcxCompItems.GetItem(Index: Integer): TcxCompItem;
|
|
begin
|
|
Result := nil;
|
|
if FItems <> nil then
|
|
Result := TcxCompItem(FItems.Items[Index]);
|
|
end;
|
|
|
|
{ TcxCompItem }
|
|
|
|
constructor TcxCompItem.Create(AOwner: TcxCompItems);
|
|
begin
|
|
FOwner := AOwner;
|
|
FItems := nil;
|
|
end;
|
|
|
|
destructor TcxCompItem.Destroy;
|
|
begin
|
|
FDeleting := True;
|
|
Clear;
|
|
if FOwner <> nil then
|
|
FOwner.Delete(Index);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TcxCompItem.Add(Name: string; Value: Integer): TcxCompItem;
|
|
begin
|
|
if FItems = nil then
|
|
FItems := TcxCompItems.Create;
|
|
Result := FItems.Add(Name, Value);
|
|
end;
|
|
|
|
function TcxCompItem.First: TcxCompItem;
|
|
begin
|
|
Result := nil;
|
|
if FItems <> nil then Result := FItems.First;
|
|
end;
|
|
|
|
function TcxCompItem.GetItemByName(Name: string): TcxCompItem;
|
|
begin
|
|
Result := nil;
|
|
if FItems <> nil then
|
|
Result := FItems.GetItemByName(Name);
|
|
end;
|
|
|
|
function TcxCompItem.IndexOf(Name: string): Integer;
|
|
begin
|
|
Result := -1;
|
|
if FItems <> nil then
|
|
Result := FItems.IndexOfName(Name);
|
|
end;
|
|
|
|
function TcxCompItem.Count: Integer;
|
|
begin
|
|
Result := 0;
|
|
if FItems <> nil then
|
|
Result := FItems.Count;
|
|
end;
|
|
|
|
function TcxCompItem.Last: TcxCompItem;
|
|
begin
|
|
Result := nil;
|
|
if FItems <> nil then Result := FItems.Last;
|
|
end;
|
|
|
|
function TcxCompItem.GetIndex: Integer;
|
|
begin
|
|
Result := FOwner.IndexOf(Self);
|
|
end;
|
|
|
|
function TcxCompItem.GetItem(Index: Integer): TcxCompItem;
|
|
begin
|
|
Result := nil;
|
|
if FItems <> nil then
|
|
Result := FItems.GetItem(Index);
|
|
end;
|
|
|
|
procedure TcxCompItem.Clear;
|
|
begin
|
|
if FItems <> nil then
|
|
begin
|
|
FItems.Free;
|
|
FItems := nil;
|
|
end;
|
|
end;
|
|
|
|
end.
|