{
Author: Mattias Gaertner
*****************************************************************************
This file is part of the Lazarus Component Library (LCL)
See the file COPYING.modifiedLGPL.txt, included in this distribution,
for details about the license.
*****************************************************************************
Abstract:
This unit maintains and stores all lazarus resources in the global list
named LazarusResources and provides methods and types to stream components.
A lazarus resource is an ansistring, with a name and a valuetype. Both, name
and valuetype, are ansistrings as well.
Lazarus resources are normally included via an include directive in the
initialization part of a unit. To create such include files use the
BinaryToLazarusResourceCode procedure.
To create a LRS file from an LFM file use the LFMtoLRSfile function which
transforms the LFM text to binary format and stores it as Lazarus resource
include file.
}
unit LResources;
{$mode objfpc}{$H+}
{ $DEFINE WideStringLenDoubled}
interface
uses
{$IFDEF Windows}
Windows,
{$ENDIF}
Classes, SysUtils, Types, RtlConsts, TypInfo, variants,
// LCL
LCLProc, LCLStrConsts,
// LazUtils
LazConfigStorage, FPCAdds, DynQueue, LazUTF8, LazLoggerBase;
{$DEFINE UseLRS}
{$DEFINE UseRES}
const
LRSComment = // do not translate this!
'This is an automatically generated lazarus resource file';
type
TFilerSignature = array[1..4] of Char;
{ TLResourceList }
TLResource = class
public
Name: AnsiString;
ValueType: AnsiString;
Value: AnsiString;
end;
TLResourceList = class(TObject)
private
FList: TList; // main list with all resource pointers
FMergeList: TList; // list needed for mergesort
FSortedCount: integer; // 0 .. FSortedCount-1 resources are sorted
function FindPosition(const Name: AnsiString):integer;
function GetItems(Index: integer): TLResource;
procedure Sort;
procedure MergeSort(List, MergeList: TList; Pos1, Pos2: integer);
procedure Merge(List, MergeList: TList; Pos1, Pos2, Pos3: integer);
public
constructor Create;
destructor Destroy; override;
procedure Add(const Name, ValueType, Value: AnsiString);
procedure Add(const Name, ValueType: AnsiString; const Values: array of string);
function Find(const Name: AnsiString): TLResource; overload;
function Find(const Name, ValueType: AnsiString): TLResource; overload;
function Count: integer;
property Items[Index: integer]: TLResource read GetItems;
end;
{ TLazarusResourceStream }
TLazarusResourceStream = class(TCustomMemoryStream)
private
FLRes: TLResource;
{$ifdef UseRES}
FPRes: TFPResourceHGLOBAL;
{$endif}
procedure Initialize(Name, ResType: PChar);
public
constructor Create(const ResName: string; ResType: PChar);
constructor CreateFromID(ResID: Integer; ResType: PChar);
constructor CreateFromHandle(AHandle: TLResource); overload;
{$ifdef UseRES}
// here from FP resource handle
constructor CreateFromHandle(Instance: TFPResourceHMODULE; AHandle: TFPResourceHandle); overload;
{$endif}
destructor Destroy; override;
function Write(const Buffer; Count: Longint): Longint; override;
property Res: TLResource read FLRes;
end;
{ TAbstractTranslator}
TAbstractTranslator = class(TObject)//Should it be somewhat more than TObject?
public
procedure TranslateStringProperty(Sender:TObject; const Instance: TPersistent; PropInfo: PPropInfo; var Content:string);virtual;abstract;
//seems like we need nothing more here
end;
var LRSTranslator: TAbstractTranslator;
type
TLRSItemType = (
lrsitCollection,
lrsitComponent,
lrsitList,
lrsitProperty
);
TLRSORStackItem = record
Name: string;
ItemType: TLRSItemType;
Root: TComponent;
PushCount: integer; // waiting for this number of Pop
ItemNr: integer; // nr in a collection or list
end;
PLRSORStackItem = ^TLRSORStackItem;
{ TLRSObjectReader }
TLRSObjectReader = class(TAbstractObjectReader)
private
FStream: TStream;
FBuffer: Pointer;
FBufSize: Integer;
FBufPos: Integer;
FBufEnd: Integer;
FStack: PLRSORStackItem;
FStackPointer: integer;
FStackCapacity: integer;
FReader: TReader;
procedure SkipProperty;
procedure SkipSetBody;
procedure Push(ItemType: TLRSItemType; const AName: string = '';
Root: TComponent = nil; PushCount: integer = 1);
procedure Pop;
procedure ClearStack;
function InternalReadValue: TValueType;
procedure EndPropertyIfOpen;
protected
function ReadIntegerContent: integer;
public
constructor Create(AStream: TStream; BufSize: Integer); virtual;
destructor Destroy; override;
function NextValue: TValueType; override;
function ReadValue: TValueType; override;
procedure BeginRootComponent; override;
procedure BeginComponent(var Flags: TFilerFlags; var AChildPos: Integer;
var CompClassName, CompName: String); override;
function BeginProperty: String; override;
function GetStackPath: string;
procedure Read(var Buf; Count: LongInt); override;
procedure ReadBinary(const DestData: TMemoryStream); override;
function ReadFloat: Extended; override;
function ReadSingle: Single; override;
function ReadCurrency: Currency; override;
function ReadDate: TDateTime; override;
function ReadIdent(ValueType: TValueType): String; override;
function ReadInt8: ShortInt; override;
function ReadInt16: SmallInt; override;
function ReadInt32: LongInt; override;
function ReadInt64: Int64; override;
function ReadSet(EnumType: Pointer): Integer; override;
procedure ReadSignature; override;
function ReadStr: String; override;
function ReadString(StringType: TValueType): String; override;
function ReadWideString: WideString; override;
function ReadUnicodeString: UnicodeString; override;
procedure SkipComponent(SkipComponentInfos: Boolean); override;
procedure SkipValue; override;
public
property Stream: TStream read FStream;
property Reader: TReader read FReader write FReader;
end;
TLRSObjectReaderClass = class of TLRSObjectReader;
{ TLRSOWStackItem
The TLRSObjectWriter can find empty entries and omit writing them to stream.
For example:
inline ConditionalOptionsFrame: TCompOptsConditionalsFrame
inherited COCTreeView: TTreeView
end
inherited COCPopupMenu: TPopupMenu
end
end
The empty inherited child components will not be written if
WriteEmptyInheritedChilds = false (default).
Reason:
This allows one to delete/rename controls in ancestors without the need
to update all descendants.
}
TLRSOWStackItemState = (
lrsowsisStarted, // now writing header
lrsowsisHeaderWritten, // header saved on stack, not yet written to stream, waiting for data
lrsowsisDataWritten // header written to stream, data written
);
TLRSOWStackItem = record
Name: string;
ItemType: TLRSItemType;
Root: TComponent;
PushCount: integer; // waiting for this number of Pop
ItemNr: integer; // nr in a collection or list
SkipIfEmpty: boolean;
State: TLRSOWStackItemState;
Buffer: Pointer;
BufCount: PtrInt;
BufCapacity: PtrInt;
end;
PLRSOWStackItem = ^TLRSOWStackItem;
{$IF FPC_FULLVERSION>30300}
TLazObjectWriterString = RawByteString;
{$ELSE}
TLazObjectWriterString = String;
{$ENDIF}
{ TLRSObjectWriter }
TLRSObjectWriter = class(TAbstractObjectWriter)
private
FStream: TStream;
FBuffer: Pointer;
FBufSize: Integer;
FBufPos: Integer;
FSignatureWritten: Boolean;
FStack: PLRSOWStackItem;
FStackPointer: integer;
FStackCapacity: integer;
FWriteEmptyInheritedChilds: boolean;
FWriter: TWriter;
procedure Push(ItemType: TLRSItemType; const AName: string = '';
Root: TComponent = nil; PushCount: integer = 1;
SkipIfEmpty: boolean = false);
procedure EndHeader;
procedure Pop(WriteNull: boolean);
procedure ClearStack;
procedure FlushStackToStream;
procedure WriteToStream(const Buffer; Count: Longint);
protected
procedure FlushBuffer; override;
procedure WriteValue(Value: TValueType);
procedure WriteStr(const Value: String);
procedure WriteIntegerContent(i: integer);
procedure WriteWordContent(w: word);
procedure WriteInt64Content(i: int64);
procedure WriteSingleContent(s: single);
procedure WriteDoubleContent(d: Double);
procedure WriteExtendedContent(e: Extended);
procedure WriteCurrencyContent(c: Currency);
procedure WriteWideStringContent(const ws: WideString);
procedure WriteWordsReversed(p: PWord; Count: integer);
procedure WriteNulls(Count: integer);
public
constructor Create(Stream: TStream; BufSize: Integer); virtual;
destructor Destroy; override;
{ Begin/End markers. Those ones who don't have an end indicator, use
"EndList", after the occurrence named in the comment. Note that this
only counts for "EndList" calls on the same level; each BeginXXX call
increases the current level. }
procedure BeginCollection; override;{ Ends with the next "EndList" }
procedure BeginComponent(Component: TComponent; Flags: TFilerFlags;
ChildPos: Integer); override; { Ends after the second "EndList" }
procedure WriteSignature; override;
procedure BeginList; override;
procedure EndList; override;
procedure BeginProperty(const PropName: String); override;
procedure EndProperty; override;
function GetStackPath: string;
procedure Write(const Buffer; Count: Longint); override;
procedure WriteBinary(const Buffer; Count: LongInt); override;
procedure WriteBoolean(Value: Boolean); override;
procedure WriteFloat(const Value: Extended); override;
procedure WriteSingle(const Value: Single); override;
procedure WriteCurrency(const Value: Currency); override;
procedure WriteDate(const Value: TDateTime); override;
procedure WriteIdent(const Ident: string); override;
procedure WriteInteger(Value: Int64); override;
procedure WriteMethodName(const Name: String); override;
procedure WriteSet(Value: LongInt; SetType: Pointer); override;
procedure WriteString(const Value: TLazObjectWriterString); override;
procedure WriteWideString(const Value: WideString); override;
procedure WriteUnicodeString(const Value: UnicodeString); override;
procedure WriteVariant(const Value: Variant); override;
property WriteEmptyInheritedChilds: boolean read FWriteEmptyInheritedChilds write FWriteEmptyInheritedChilds;
property Writer: TWriter read FWriter write FWriter;
end;
TLRSObjectWriterClass = class of TLRSObjectWriter;
TLRPositionLink = record
LFMPosition: int64;
LRSPosition: int64;
Data: Pointer;
end;
PLRPositionLink = ^TLRPositionLink;
{ TLRPositionLinks }
TLRPositionLinks = class
private
FItems: TFPList;
FCount: integer;
function GetData(Index: integer): Pointer;
function GetLFM(Index: integer): Int64;
function GetLRS(Index: integer): Int64;
procedure SetCount(const AValue: integer);
procedure SetData(Index: integer; const AValue: Pointer);
procedure SetLFM(Index: integer; const AValue: Int64);
procedure SetLRS(Index: integer; const AValue: Int64);
public
constructor Create;
destructor Destroy; override;
procedure Clear;
procedure Sort(LFMPositions: Boolean);
function IndexOf(const Position: int64; LFMPositions: Boolean): integer;
function IndexOfRange(const FromPos, ToPos: int64;
LFMPositions: Boolean): integer;
procedure SetPosition(const FromPos, ToPos, MappedPos: int64;
LFMtoLRSPositions: Boolean);
procedure Add(const LFMPos, LRSPos: Int64; AData: Pointer);
public
property LFM[Index: integer]: int64 read GetLFM write SetLFM;
property LRS[Index: integer]: int64 read GetLRS write SetLRS;
property Data[Index: integer]: Pointer read GetData write SetData;
property Count: integer read FCount write SetCount;
end;
{ TUTF8Parser }
TUTF8Parser = class(TObject)
private
fStream : TStream;
fBuf : pchar;
fBufLen : integer; // read
fPos : integer;
fLineStart : integer; // column = fPos - fLineStart + 1
fFloatType : char;
fSourceLine : integer;
fToken : char;
fEofReached : boolean;
fLastTokenStr : string;
function GetTokenName(aTok : char) : string;
procedure LoadBuffer;
procedure CheckLoadBuffer; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
procedure ProcessChar; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
function IsNumber : boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
function IsHexNum : boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
function IsAlpha : boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
function IsAlphaNum : boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
function GetHexValue(c : char) : byte; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
function GetAlphaNum : string;
procedure HandleNewLine;
procedure SkipSpaces;
procedure SkipWhitespace;
procedure HandleEof;
procedure HandleAlphaNum;
procedure HandleNumber;
procedure HandleHexNumber;
function HandleQuotedString: string;
function HandleDecimalString: string;
procedure HandleString;
procedure HandleMinus;
procedure HandleUnknown;
public
constructor Create(Stream: TStream);
destructor Destroy; override;
procedure CheckToken(T: Char);
procedure CheckTokenSymbol(const S: string);
procedure Error(const Ident: string);
procedure ErrorFmt(const Ident: string; const Args: array of const);
procedure ErrorStr(const Message: string);
procedure HexToBinary(Stream: TStream);
function NextToken: Char;
function SourcePos: Longint;
function TokenComponentIdent: string;
function TokenFloat: Extended;
function TokenInt: Int64;
function TokenString: string;
function TokenSymbolIs(const S: string): Boolean;
property FloatType: Char read fFloatType;
property SourceLine: Integer read fSourceLine;
function SourceColumn: integer;
property Token: Char read fToken;
end deprecated 'use Classes.TParser instead';
{ TCustomLazComponentQueue
A queue to stream components, used for multithreading or network.
The function ConvertComponentAsString converts a component to binary format
with a leading size information (using WriteLRSInt64MB).
When streaming components over network, they will arrive in chunks.
TCustomLazComponentQueue tells you, if a whole component has arrived and if
it has completely arrived. }
TCustomLazComponentQueue = class(TComponent)
private
FOnFindComponentClass: TFindComponentClassEvent;
protected
FQueue: TDynamicDataQueue;
function ReadComponentSize(out ComponentSize, SizeLength: int64): Boolean; virtual;
public
constructor Create(TheOwner: TComponent); override;
destructor Destroy; override;
procedure Clear;
function Write(const Buffer; Count: Longint): Longint;
function CopyFrom(AStream: TStream; Count: Longint): Longint;
function HasComponent: Boolean; virtual;
function ReadComponent(var AComponent: TComponent;
NewOwner: TComponent = nil): Boolean; virtual;
function ConvertComponentAsString(AComponent: TComponent): string;
property OnFindComponentClass: TFindComponentClassEvent
read FOnFindComponentClass write FOnFindComponentClass;
end;
{ TLazComponentQueue }
TLazComponentQueue = class(TCustomLazComponentQueue)
published
property Name;
property OnFindComponentClass;
end;
TPropertyToSkip = record
PersistentClass: TPersistentClass;
PropertyName: String;
Note: String;
HelpKeyword: String;
end;
PRemovedProperty = ^TPropertyToSkip;
{ TPropertyToSkipList }
TPropertiesToSkip = class(TList)
private
function GetItem(AIndex: Integer): PRemovedProperty;
procedure SetItem(AIndex: Integer; const AValue: PRemovedProperty);
protected
procedure Notify(Ptr: Pointer; Action: TListNotification); override;
procedure DoPropertyNotFound(Reader: TReader; Instance: TPersistent;
var PropName: string; IsPath: boolean; var Handled, Skip: Boolean);
public
function IndexOf(AInstance: TPersistent; const APropertyName: String): Integer; overload;
function IndexOf(AClass: TPersistentClass; APropertyName: String): Integer; overload;
function Add(APersistentClass: TPersistentClass; const APropertyName, ANote,
AHelpKeyWord: string): Integer; reintroduce;
property Items[AIndex: Integer]: PRemovedProperty read GetItem write SetItem;
end;
const
ObjStreamMaskInherited = 1;
ObjStreamMaskChildPos = 2;
ObjStreamMaskInline = 4;
var
LazarusResources: TLResourceList;
PropertiesToSkip: TPropertiesToSkip = nil;
LRSObjectReaderClass: TLRSObjectReaderClass=TLRSObjectReader;
LRSObjectWriterClass: TLRSObjectWriterClass=TLRSObjectWriter;
function InitResourceComponent(Instance: TComponent; RootAncestor: TClass): Boolean;
function InitLazResourceComponent(Instance: TComponent;
RootAncestor: TClass): Boolean;
function CreateLRSReader(s: TStream; var DestroyDriver: boolean): TReader;
function CreateLRSWriter(s: TStream; var DestroyDriver: boolean): TWriter;
function GetClassNameFromLRSStream(s: TStream; out IsInherited: Boolean): shortstring;
procedure GetComponentInfoFromLRSStream(s: TStream;
out ComponentName, ComponentClassName: string;
out IsInherited: Boolean);
procedure WriteComponentAsBinaryToStream(AStream: TStream;
AComponent: TComponent);
procedure ReadComponentFromBinaryStream(AStream: TStream;
var RootComponent: TComponent;
OnFindComponentClass: TFindComponentClassEvent;
TheOwner: TComponent = nil;
Parent: TComponent = nil;
ReaderRoot: TComponent = nil);
procedure WriteComponentAsTextToStream(AStream: TStream;
AComponent: TComponent);
procedure ReadComponentFromTextStream(AStream: TStream;
var RootComponent: TComponent;
OnFindComponentClass: TFindComponentClassEvent;
TheOwner: TComponent = nil;
Parent: TComponent = nil);
procedure SaveComponentToConfig(Config: TConfigStorage; const Path: string;
AComponent: TComponent);
procedure LoadComponentFromConfig(Config: TConfigStorage; const Path: string;
var RootComponent: TComponent;
OnFindComponentClass: TFindComponentClassEvent;
TheOwner: TComponent = nil;
Parent: TComponent = nil);
function CompareComponents(Component1, Component2: TComponent): boolean;
function CompareMemStreams(Stream1, Stream2: TCustomMemoryStream): boolean;
procedure BinaryToLazarusResourceCode(BinStream, ResStream: TStream;
const ResourceName, ResourceType: String);
function LFMtoLRSfile(const LFMfilename: string): boolean;// true on success
function LFMtoLRSstream(LFMStream, LRSStream: TStream): boolean;// true on success
function FindLFMClassName(LFMStream: TStream):AnsiString;
procedure ReadLFMHeader(LFMStream: TStream;
out LFMType, LFMComponentName, LFMClassName: String);
procedure ReadLFMHeader(const LFMSource: string;
out LFMClassName: String; out LFMType: String);
procedure ReadLFMHeader(const LFMSource: string;
out LFMType, LFMComponentName, LFMClassName: String);
function ReadLFMHeaderFromFile(const Filename: string;
out LFMType, LFMComponentName, LFMClassName: String): boolean;
function CreateLFMFile(AComponent: TComponent; LFMStream: TStream): integer;
function SameLFMTypeName(aUnitname, aTypename, LFMTypename: string): boolean;
type
TLRSStreamOriginalFormat = (sofUnknown, sofBinary, sofText);
procedure LRSObjectBinaryToText(Input, Output: TStream); // binary to lfm
procedure LRSObjectTextToBinary(Input, Output: TStream; // lfm to binary
Links: TLRPositionLinks = nil);
procedure LRSObjectToText(Input, Output: TStream;
var OriginalFormat: TLRSStreamOriginalFormat);
procedure LRSObjectResourceToText(Input, Output: TStream); // lrs to lfm
procedure LRSObjectResToText(Input, Output: TStream;
var OriginalFormat: TLRSStreamOriginalFormat);
function TestFormStreamFormat(Stream: TStream): TLRSStreamOriginalFormat;
procedure FormDataToText(FormStream, TextStream: TStream;
aFormat: TLRSStreamOriginalFormat = sofUnknown);
function FindResourceLFM(ResName: string): HRSRC;
procedure DefineRectProperty(Filer: TFiler; const Name: string;
ARect, DefaultRect: PRect);
procedure ReverseBytes(p: Pointer; Count: integer);
procedure ReverseByteOrderInWords(p: PWord; Count: integer);
function ConvertLRSExtendedToDouble(p: Pointer): Double;
procedure ConvertEndianBigDoubleToLRSExtended(BigEndianDouble,
LRSExtended: Pointer);
procedure ConvertLEDoubleToLRSExtended(LEDouble, LRSExtended: Pointer);
function ReadLRSShortInt(s: TStream): shortint;
function ReadLRSByte(s: TStream): byte;
function ReadLRSSmallInt(s: TStream): smallint;
function ReadLRSWord(s: TStream): word;
function ReadLRSInteger(s: TStream): integer;
function ReadLRSCardinal(s: TStream): cardinal;
function ReadLRSInt64(s: TStream): int64;
function ReadLRSSingle(s: TStream): Single;
function ReadLRSDouble(s: TStream): Double;
function ReadLRSExtended(s: TStream): Extended;
function ReadLRSCurrency(s: TStream): Currency;
function ReadLRSWideString(s: TStream): WideString;
function ReadLRSEndianLittleExtendedAsDouble(s: TStream): Double;
function ReadLRSValueType(s: TStream): TValueType;
function ReadLRSInt64MB(s: TStream): int64;// multibyte
procedure WriteLRSSmallInt(s: TStream; const i: smallint);
procedure WriteLRSWord(s: TStream; const w: word);
procedure WriteLRSInteger(s: TStream; const i: integer);
procedure WriteLRSCardinal(s: TStream; const c: cardinal);
procedure WriteLRSSingle(s: TStream; const si: Single);
procedure WriteLRSDouble(s: TStream; const d: Double);
procedure WriteLRSExtended(s: TStream; const e: extended);
procedure WriteLRSInt64(s: TStream; const i: int64);
procedure WriteLRSCurrency(s: TStream; const c: Currency);
procedure WriteLRSWideStringContent(s: TStream; const w: WideString);
procedure WriteLRSInt64MB(s: TStream; const Value: int64);// multibyte
procedure WriteLRSReversedWord(s: TStream; w: word);
procedure WriteLRS4BytesReversed(s: TStream; p: Pointer);
procedure WriteLRS8BytesReversed(s: TStream; p: Pointer);
procedure WriteLRS10BytesReversed(s: TStream; p: Pointer);
procedure WriteLRSNull(s: TStream; Count: integer);
procedure WriteLRSEndianBigDoubleAsEndianLittleExtended(s: TStream;
EndBigDouble: PByte);
procedure WriteLRSDoubleAsExtended(s: TStream; ADouble: PByte);
procedure WriteLRSReversedWords(s: TStream; p: Pointer; Count: integer);
function FloatToLFMStr(const Value: extended; Precision, Digits: Integer
): string;
function CompareLRPositionLinkWithLFMPosition(Item1, Item2: Pointer): integer;
function CompareLRPositionLinkWithLRSPosition(Item1, Item2: Pointer): integer;
procedure RegisterPropertyToSkip(PersistentClass: TPersistentClass;
const PropertyName, Note, HelpKeyWord: string);
procedure Register;
implementation
const
LineEnd: ShortString = LineEnding;
var
ByteToStr: array[char] of shortstring;
ByteToStrValid: boolean=false;
type
{ TDefineRectPropertyClass }
TDefineRectPropertyClass = class
public
Value: PRect;
DefaultValue: PRect;
constructor Create(AValue, ADefaultRect: PRect);
procedure ReadData(Reader: TReader);
procedure WriteData(Writer: TWriter);
function HasData: Boolean;
end;
{ TReaderUniqueNamer - dummy class, used by the reader functions to rename
components, that are read from a stream, on the fly. }
TReaderUniqueNamer = class
procedure OnSetName(Reader: TReader; Component: TComponent;
var Name: string);
end;
{ TPropertiesToSkip }
function TPropertiesToSkip.GetItem(AIndex: Integer): PRemovedProperty;
begin
Result := inherited Get(AIndex);
end;
procedure TPropertiesToSkip.SetItem(AIndex: Integer;
const AValue: PRemovedProperty);
begin
inherited Put(AIndex, AValue);
end;
procedure TPropertiesToSkip.Notify(Ptr: Pointer; Action: TListNotification);
begin
if Action = lnDeleted then
Dispose(PRemovedProperty(Ptr))
else
inherited Notify(Ptr, Action);
end;
procedure TPropertiesToSkip.DoPropertyNotFound(Reader: TReader; Instance: TPersistent;
var PropName: string; IsPath: boolean; var Handled, Skip: Boolean);
begin
Skip := IndexOf(Instance, PropName) >= 0;
Handled := Skip;
end;
function TPropertiesToSkip.IndexOf(AInstance: TPersistent;
const APropertyName: String): Integer;
begin
if AInstance <> nil then
Result := IndexOf(TPersistentClass(AInstance.ClassType), APropertyName)
else
Result := -1;
end;
function TPropertiesToSkip.IndexOf(AClass: TPersistentClass;
APropertyName: String): Integer;
var
PropertyInfo: PRemovedProperty;
begin
APropertyName := LowerCase(APropertyName);
Result := Count - 1;
while Result >= 0 do
begin
PropertyInfo := Items[Result];
if AClass.InheritsFrom(PropertyInfo^.PersistentClass) and
(APropertyName = PropertyInfo^.PropertyName) then
begin
Exit;
end;
Dec(Result);
end;
Result := -1;
end;
function TPropertiesToSkip.Add(APersistentClass: TPersistentClass;
const APropertyName, ANote, AHelpKeyWord: string): Integer;
var
Item: PRemovedProperty;
begin
Result := IndexOf(APersistentClass, APropertyName);
if Result = -1 then
begin
New(Item);
Item^.PersistentClass := APersistentClass;
Item^.PropertyName := LowerCase(APropertyName);
Item^.Note := ANote;
Item^.HelpKeyword := AHelpKeyWord;
Result := inherited Add(Item);
end;
end;
{ TReaderUniqueNamer }
procedure TReaderUniqueNamer.OnSetName(Reader: TReader; Component: TComponent;
var Name: string);
procedure MakeValidIdentifier;
var
i: Integer;
begin
for i:=length(Name) downto 1 do
if not (Name[i] in ['0'..'9','_','a'..'z','A'..'Z']) then
System.Delete(Name,i,1);
if (Name<>'') and (Name[1] in ['0'..'9']) then
Name:='_'+Name;
end;
function NameIsUnique: Boolean;
var
Owner: TComponent;
i: Integer;
CurComponent: TComponent;
begin
Result:=true;
if Name='' then exit;
Owner:=Component.Owner;
if Owner=nil then exit;
for i:=0 to Owner.ComponentCount-1 do begin
CurComponent:=Owner.Components[i];
if CurComponent=Component then continue;
if CompareText(CurComponent.Name,Name)=0 then exit(false);
end;
end;
begin
MakeValidIdentifier;
while not NameIsUnique do
Name:=CreateNextIdentifier(Name);
end;
{ TDefineRectPropertyClass }
constructor TDefineRectPropertyClass.Create(AValue, ADefaultRect: PRect);
begin
Value:=AValue;
DefaultValue:=ADefaultRect;
end;
procedure TDefineRectPropertyClass.ReadData(Reader: TReader);
begin
with Reader do begin
ReadListBegin;
Value^.Left:=ReadInteger;
Value^.Top:=ReadInteger;
Value^.Right:=ReadInteger;
Value^.Bottom:=ReadInteger;
ReadListEnd;
end;
end;
procedure TDefineRectPropertyClass.WriteData(Writer: TWriter);
begin
with Writer do begin
WriteListBegin;
WriteInteger(Value^.Left);
WriteInteger(Value^.Top);
WriteInteger(Value^.Right);
WriteInteger(Value^.Bottom);
WriteListEnd;
end;
end;
function TDefineRectPropertyClass.HasData: Boolean;
begin
if DefaultValue<>nil then begin
Result:=(DefaultValue^.Left<>Value^.Left)
or (DefaultValue^.Top<>Value^.Top)
or (DefaultValue^.Right<>Value^.Right)
or (DefaultValue^.Bottom<>Value^.Bottom);
end else begin
Result:=(Value^.Left<>0)
or (Value^.Top<>0)
or (Value^.Right<>0)
or (Value^.Bottom<>0);
end;
end;
function InitResourceComponent(Instance: TComponent; RootAncestor: TClass): Boolean;
begin
Result := InitLazResourceComponent(Instance, RootAncestor);
end;
function FindResourceLFM(ResName: string): HRSRC;
{$if defined(WinCE)}
var
u: UnicodeString;
begin
u:=ResName;
Result := FindResource(HInstance,PWideChar(u),Windows.RT_RCDATA);
end;
{$else}
begin
Result := FindResource(HInstance,PChar(ResName),
{$ifdef Windows}Windows.{$endif}RT_RCDATA);
end;
{$endif}
procedure DefineRectProperty(Filer: TFiler; const Name: string; ARect,
DefaultRect: PRect);
var
PropDef: TDefineRectPropertyClass;
begin
PropDef := TDefineRectPropertyClass.Create(ARect, DefaultRect);
try
Filer.DefineProperty(Name,@PropDef.ReadData,@PropDef.WriteData,PropDef.HasData);
finally
PropDef.Free;
end;
end;
procedure InitByteToStr;
var
c: Char;
begin
if ByteToStrValid then exit;
for c:=Low(char) to High(char) do
ByteToStr[c]:=IntToStr(ord(c));
ByteToStrValid:=true;
end;
function GetClassNameFromLRSStream(s: TStream; out IsInherited: Boolean
): shortstring;
var
Signature: TFilerSignature;
NameLen: byte;
OldPosition: Int64;
begin
Result:='';
OldPosition:=s.Position;
// read signature
Signature:='1234';
s.Read(Signature[1],length(Signature));
if Signature<>FilerSignature then exit;
// read classname length
NameLen:=0;
s.Read(NameLen,1);
if (NameLen and $f0) = $f0 then begin
// this was the Flag Byte
IsInherited := (NameLen and ObjStreamMaskInherited) <> 0;
// read namelen
s.Read(NameLen,1);
end else
IsInherited := False;
// read classname
if NameLen>0 then begin
SetLength(Result,NameLen);
s.Read(Result[1],NameLen);
end;
s.Position:=OldPosition;
end;
procedure GetComponentInfoFromLRSStream(s: TStream; out ComponentName,
ComponentClassName: string; out IsInherited: Boolean);
var
Signature: TFilerSignature;
NameLen: byte;
OldPosition: Int64;
Flag: Byte;
begin
ComponentName:='';
ComponentClassName:='';
OldPosition:=s.Position;
// read signature
Signature:='1234';
s.Read(Signature[1],length(Signature));
if Signature<>FilerSignature then exit;
// read classname length
NameLen:=0;
s.Read(NameLen,1);
if (NameLen and $f0) = $f0 then begin
// Read Flag Byte
Flag:=NameLen;
IsInherited := (Flag and ObjStreamMaskInherited) <> 0;
s.Read(NameLen,1);
end else
IsInherited := False;
// read classname
if NameLen>0 then begin
SetLength(ComponentClassName,NameLen);
s.Read(ComponentClassName[1],NameLen);
end;
// read component name length
NameLen:=0;
s.Read(NameLen,1);
// read componentname
if NameLen>0 then begin
SetLength(ComponentName,NameLen);
s.Read(ComponentName[1],NameLen);
end;
s.Position:=OldPosition;
end;
procedure WriteComponentAsBinaryToStream(AStream: TStream;
AComponent: TComponent);
var
Writer: TWriter;
DestroyDriver: Boolean;
begin
DestroyDriver:=false;
Writer:=nil;
try
Writer:=CreateLRSWriter(AStream,DestroyDriver);
Writer.WriteDescendent(AComponent,nil);
finally
if DestroyDriver then
Writer.Driver.Free;
Writer.Free;
end;
end;
procedure ReadComponentFromBinaryStream(AStream: TStream;
var RootComponent: TComponent;
OnFindComponentClass: TFindComponentClassEvent; TheOwner: TComponent;
Parent: TComponent; ReaderRoot: TComponent);
var
DestroyDriver: Boolean;
Reader: TReader;
IsInherited: Boolean;
AClassName: String;
AClass: TComponentClass;
UniqueNamer: TReaderUniqueNamer;
begin
// get root class
AClassName:=GetClassNameFromLRSStream(AStream,IsInherited);
if IsInherited then begin
// inherited is not supported by this simple function
{$IFNDEF DisableChecks}
DebugLn('ReadComponentFromBinaryStream WARNING: "inherited" is not supported by this simple function');
{$ENDIF}
end;
AClass:=nil;
OnFindComponentClass(nil,AClassName,AClass);
if AClass=nil then
raise EClassNotFound.CreateFmt('Class "%s" not found', [AClassName]);
if RootComponent=nil then begin
// create root component
// first create the new instance and set the variable ...
RootComponent:=AClass.NewInstance as TComponent;
// then call the constructor
RootComponent.Create(TheOwner);
end else begin
// there is a root component, check if class is compatible
if not RootComponent.InheritsFrom(AClass) then begin
raise EComponentError.CreateFmt('Cannot assign a %s to a %s.',
[AClassName,RootComponent.ClassName]);
end;
end;
// read the root component
DestroyDriver:=false;
Reader:=nil;
UniqueNamer:=nil;
try
UniqueNamer:=TReaderUniqueNamer.Create;
Reader:=CreateLRSReader(AStream,DestroyDriver);
if ReaderRoot = nil then
Reader.Root:=RootComponent
else
Reader.Root:=ReaderRoot;
Reader.Owner:=TheOwner;
Reader.Parent:=Parent;
Reader.OnFindComponentClass:=OnFindComponentClass;
Reader.OnSetName:=@UniqueNamer.OnSetName;
Reader.BeginReferences;
try
Reader.Driver.BeginRootComponent;
RootComponent:=Reader.ReadComponent(RootComponent);
Reader.FixupReferences;
finally
Reader.EndReferences;
end;
finally
if DestroyDriver then
Reader.Driver.Free;
UniqueNamer.Free;
Reader.Free;
end;
end;
procedure WriteComponentAsTextToStream(AStream: TStream; AComponent: TComponent);
var
BinStream: TMemoryStream;
begin
BinStream:=nil;
try
BinStream:=TMemoryStream.Create;
WriteComponentAsBinaryToStream(BinStream,AComponent);
BinStream.Position:=0;
LRSObjectBinaryToText(BinStream,AStream);
finally
BinStream.Free;
end;
end;
procedure ReadComponentFromTextStream(AStream: TStream;
var RootComponent: TComponent;
OnFindComponentClass: TFindComponentClassEvent; TheOwner: TComponent;
Parent: TComponent);
var
BinStream: TMemoryStream;
begin
BinStream:=nil;
try
BinStream:=TMemoryStream.Create;
LRSObjectTextToBinary(AStream,BinStream);
BinStream.Position:=0;
ReadComponentFromBinaryStream(BinStream,RootComponent,OnFindComponentClass,
TheOwner,Parent);
finally
BinStream.Free;
end;
end;
procedure SaveComponentToConfig(Config: TConfigStorage; const Path: string;
AComponent: TComponent);
var
BinStream: TMemoryStream;
TxtStream: TMemoryStream;
s: string;
begin
BinStream:=nil;
TxtStream:=nil;
try
// write component to stream
BinStream:=TMemoryStream.Create;
WriteComponentAsBinaryToStream(BinStream,AComponent);
// convert it to human readable text format
BinStream.Position:=0;
TxtStream:=TMemoryStream.Create;
LRSObjectBinaryToText(BinStream,TxtStream);
// convert stream to string
SetLength(s,TxtStream.Size);
TxtStream.Position:=0;
if s<>'' then
TxtStream.Read(s[1],length(s));
// write to config
Config.SetDeleteValue(Path,s,'');
finally
BinStream.Free;
TxtStream.Free;
end;
end;
procedure LoadComponentFromConfig(Config: TConfigStorage; const Path: string;
var RootComponent: TComponent;
OnFindComponentClass: TFindComponentClassEvent; TheOwner: TComponent;
Parent: TComponent);
var
s: String;
TxtStream: TMemoryStream;
begin
// read from config
s:=Config.GetValue(Path,'');
TxtStream:=nil;
try
TxtStream:=TMemoryStream.Create;
if s<>'' then
TxtStream.Write(s[1],length(s));
TxtStream.Position:=0;
// create component from stream
ReadComponentFromTextStream(TxtStream,RootComponent,OnFindComponentClass,
TheOwner,Parent);
finally
TxtStream.Free;
end;
end;
function CompareComponents(Component1, Component2: TComponent): boolean;
var
Stream1: TMemoryStream;
Stream2: TMemoryStream;
i: Integer;
begin
if Component1=Component2 then exit(true);
Result:=false;
// quick checks
if (Component1=nil) or (Component2=nil) then exit;
if (Component1.ClassType<>Component2.ClassType) then exit;
if Component1.ComponentCount<>Component2.ComponentCount then exit;
for i:=0 to Component1.ComponentCount-1 do begin
if Component1.Components[i].ClassType<>Component2.Components[i].ClassType
then exit;
end;
// expensive streaming test
try
Stream1:=nil;
Stream2:=nil;
try
Stream1:=TMemoryStream.Create;
WriteComponentAsBinaryToStream(Stream1,Component1);
Stream2:=TMemoryStream.Create;
WriteComponentAsBinaryToStream(Stream2,Component2);
Result:=CompareMemStreams(Stream1,Stream2);
finally
Stream1.Free;
Stream2.Free;
end;
except
end;
end;
function CompareMemStreams(Stream1, Stream2: TCustomMemoryStream
): boolean;
var
p1: Pointer;
p2: Pointer;
Cnt: Int64;
CurCnt: cardinal;
begin
if Stream1=Stream2 then exit(true);
Result:=false;
if (Stream1=nil) or (Stream2=nil) then exit;
if Stream1.Size<>Stream2.Size then exit;
Cnt:=Stream1.Size;
p1:=Stream1.Memory;
p2:=Stream2.Memory;
while Cnt>0 do begin
CurCnt:=Cnt;
if CurCnt>=High(Cardinal) then CurCnt:=High(Cardinal);
if not CompareMem(p1,p2,CurCnt) then exit;
inc(p1,CurCnt);
inc(p2,CurCnt);
dec(Cnt,CurCnt);
end;
Result:=true;
end;
procedure BinaryToLazarusResourceCode(BinStream,ResStream:TStream;
const ResourceName, ResourceType: String);
{ example ResStream:
LazarusResources.Add('ResourceName','ResourceType',
#123#45#34#78#18#72#45#34#78#18#72#72##45#34#78#45#34#78#184#34#78#145#34#78
+#83#187#6#78#83
);
}
const
ReadBufSize = 4096;
WriteBufSize = 4096;
var
s, Indent: string;
x: integer;
c: char;
RangeString, NewRangeString: boolean;
RightMargin, CurLine: integer;
WriteBufStart, Writebuf: PChar;
WriteBufPos: Integer;
ReadBufStart, ReadBuf: PChar;
ReadBufPos, ReadBufLen: integer;
MinCharCount: Integer;
procedure FillReadBuf;
begin
ReadBuf:=ReadBufStart;
ReadBufPos:=0;
ReadBufLen:=BinStream.Read(ReadBuf^,ReadBufSize);
end;
procedure InitReadBuf;
begin
GetMem(ReadBufStart,ReadBufSize);
FillReadBuf;
end;
function ReadChar(var c: char): boolean;
begin
if ReadBufPos>=ReadBufLen then begin
FillReadBuf;
if ReadBufLen=0 then begin
Result:=false;
exit;
end;
end;
c:=ReadBuf^;
inc(ReadBuf);
inc(ReadBufPos);
Result:=true;
end;
procedure InitWriteBuf;
begin
GetMem(WriteBufStart,WriteBufSize);
WriteBuf:=WriteBufStart;
WriteBufPos:=0;
end;
procedure FlushWriteBuf;
begin
if WriteBufPos>0 then begin
ResStream.Write(WriteBufStart^,WriteBufPos);
WriteBuf:=WriteBufStart;
WriteBufPos:=0;
end;
end;
procedure WriteChar(c: char);
begin
WriteBuf^:=c;
inc(WriteBufPos);
inc(WriteBuf);
if WriteBufPos>=WriteBufSize then
FlushWriteBuf;
end;
procedure WriteString(const s: string);
var
i: Integer;
begin
for i:=1 to length(s) do WriteChar(s[i]);
end;
procedure WriteShortString(const s: string);
var
i: Integer;
begin
for i:=1 to length(s) do WriteChar(s[i]);
end;
begin
// fpc is not optimized for building a constant string out of thousands of
// lines. It needs huge amounts of memory and becomes very slow. Therefore big
// files are split into several strings.
InitReadBuf;
InitWriteBuf;
InitByteToStr;
Indent:='';
s:=Indent+'LazarusResources.Add('''+ResourceName+''','''+ResourceType+''',['+LineEnd;
WriteString(s);
Indent:=' '+Indent;
WriteString(Indent);
x:=length(Indent);
RangeString:=false;
CurLine:=1;
RightMargin:=80;
if ReadBufLen>0 then begin
while ReadChar(c) do begin
NewRangeString:=(ord(c)>=32) and (ord(c)<127);
// check if new char fits into line or if a new line must be started
if NewRangeString then begin
if RangeString then
MinCharCount:=2 // char plus '
else
MinCharCount:=3; // ' plus char plus '
if c='''' then inc(MinCharCount);
end else begin
MinCharCount:=1+length(ByteToStr[c]); // # plus number
if RangeString then
inc(MinCharCount); // plus ' for ending last string constant
end;
if x+MinCharCount>RightMargin then begin
// break line
if RangeString then begin
// end string constant
WriteChar('''');
end;
// write line ending
WriteShortString(LineEnd);
x:=0;
inc(CurLine);
// write indention
WriteString(Indent);
inc(x,length(Indent));
// write operator
if (CurLine and 63)<>1 then
WriteChar('+')
else
WriteChar(',');
inc(x);
RangeString:=false;
end;
// write converted byte
if RangeString<>NewRangeString then begin
WriteChar('''');
inc(x);
end;
if NewRangeString then begin
WriteChar(c);
inc(x);
if c='''' then begin
WriteChar(c);
inc(x);
end;
end else begin
WriteChar('#');
inc(x);
WriteShortString(ByteToStr[c]);
inc(x,length(ByteToStr[c]));
end;
// next
RangeString:=NewRangeString;
end;
if RangeString then begin
WriteChar('''');
end;
end else begin
WriteShortString('''''');
end;
Indent:=copy(Indent,3,length(Indent)-2);
s:=LineEnd+Indent+']);'+LineEnd;
WriteString(s);
FlushWriteBuf;
FreeMem(ReadBufStart);
FreeMem(WriteBufStart);
end;
function FindLFMClassName(LFMStream:TStream):ansistring;
{ examples:
object Form1: TForm1
inherited AboutBox2: TAboutBox2
-> the classname is the last word of the first line
}
var c:char;
StartPos, EndPos: Int64;
begin
Result:='';
StartPos:=-1;
c:=' ';
// read till end of line
repeat
// remember last non identifier char position
if (not (c in ['a'..'z','A'..'Z','0'..'9','_'])) then
StartPos:=LFMStream.Position;
if LFMStream.Read(c,1)<>1 then exit;
if LFMStream.Position>1000 then exit;
until c in [#10,#13];
if StartPos<0 then exit;
EndPos:=LFMStream.Position-1;
if EndPos-StartPos>255 then exit;
SetLength(Result,EndPos-StartPos);
LFMStream.Position:=StartPos;
if Length(Result) > 0 then
LFMStream.Read(Result[1],length(Result));
LFMStream.Position:=0;
if not IsValidIdent(Result) then
Result:='';
end;
function LFMtoLRSfile(const LFMfilename: string):boolean;
// returns true if successful
var
LFMFileStream, LRSFileStream: TFileStream;
LFMMemStream, LRSMemStream: TMemoryStream;
LRSfilename: string;
begin
Result:=true;
try
LFMFileStream:=TFileStream.Create(LFMfilename,fmOpenRead);
LFMMemStream:=TMemoryStream.Create;
LRSMemStream:=TMemoryStream.Create;
try
LFMMemStream.SetSize(LFMFileStream.Size);
LFMMemStream.CopyFrom(LFMFileStream,LFMFileStream.Size);
LFMMemStream.Position:=0;
LRSfilename:=ChangeFileExt(LFMfilename,'.lrs');
Result:=LFMtoLRSstream(LFMMemStream,LRSMemStream);
if not Result then exit;
LRSMemStream.Position:=0;
LRSFileStream:=TFileStream.Create(LRSfilename,fmCreate);
try
LRSFileStream.CopyFrom(LRSMemStream,LRSMemStream.Size);
finally
LRSFileStream.Free;
end;
finally
LFMMemStream.Free;
LRSMemStream.Free;
LFMFileStream.Free;
end;
except
on E: Exception do begin
{$IFNDEF DisableChecks}
DebugLn('LFMtoLRSfile ',E.Message);
{$ENDIF}
Result:=false;
end;
end;
end;
function LFMtoLRSstream(LFMStream, LRSStream: TStream):boolean;
// returns true if successful
var FormClassName:ansistring;
BinStream:TMemoryStream;
begin
Result:=true;
try
FormClassName:=FindLFMClassName(LFMStream);
BinStream:=TMemoryStream.Create;
try
LRSObjectTextToBinary(LFMStream,BinStream);
BinStream.Position:=0;
BinaryToLazarusResourceCode(BinStream,LRSStream,FormClassName,'FORMDATA');
finally
BinStream.Free;
end;
except
on E: Exception do begin
{$IFNDEF DisableChecks}
DebugLn('LFMtoLRSstream ',E.Message);
{$ENDIF}
Result:=false;
end;
end;
end;
//==============================================================================
{ TLResourceList }
constructor TLResourceList.Create;
begin
FList := TList.Create;
FMergeList := TList.Create;
FSortedCount := 0;
end;
destructor TLResourceList.Destroy;
var
a: integer;
begin
for a := 0 to FList.Count - 1 do
TLResource(FList[a]).Free;
FList.Free;
FMergeList.Free;
end;
function TLResourceList.Count: integer;
begin
if (Self<>nil) and (FList<>nil) then
Result:=FList.Count
else
Result:=0;
end;
procedure TLResourceList.Add(const Name, ValueType: AnsiString;
const Values: array of string);
var
NewLResource: TLResource;
i, TotalLen, ValueCount, p: integer;
begin
NewLResource := TLResource.Create;
NewLResource.Name := Name;
NewLResource.ValueType := uppercase(ValueType);
ValueCount := High(Values) - Low(Values) + 1;
case ValueCount of
0:
begin
NewLResource.Free;
exit;
end;
1:
NewLResource.Value:=Values[0];
else
TotalLen := 0;
for i := Low(Values) to High(Values) do
inc(TotalLen, length(Values[i]));
SetLength(NewLResource.Value, TotalLen);
p := 1;
for i := Low(Values) to High(Values) do
begin
if length(Values[i]) > 0 then
begin
Move(Values[i][1], NewLResource.Value[p], length(Values[i]));
inc(p, length(Values[i]));
end;
end;
end;
FList.Add(NewLResource);
end;
function TLResourceList.Find(const Name: AnsiString):TLResource;
var
P: Integer;
begin
P := FindPosition(Name);
if P >= 0 then
Result := TLResource(FList[P])
else
Result := nil;
end;
function TLResourceList.Find(const Name, ValueType: AnsiString): TLResource;
var
P, I: Integer;
begin
P := FindPosition(Name);
if P >= 0 then
begin
// Since we can have many resources that have the same name but different type
// we should look before and after found position (do not forget that we are searching
// them by dividing intervals)
// look before position
for I := P - 1 downto 0 do
begin
Result := TLResource(FList[I]);
if SysUtils.CompareText(Result.Name,Name)<>0 then
break;
if Result.ValueType = ValueType then
Exit;
end;
// look behind position
for I := P to FList.Count - 1 do
begin
Result := TLResource(FList[I]);
if SysUtils.CompareText(Result.Name,Name)<>0 then
break;
if Result.ValueType = ValueType then
Exit;
end;
end;
Result := nil;
end;
function TLResourceList.FindPosition(const Name: AnsiString): Integer;
var
L, R, C: Integer;
begin
if FSortedCount < FList.Count then
Sort;
L := 0;
R := FList.Count-1;
while (L <= R) do
begin
Result := (L + R) shr 1;
C := SysUtils.CompareText(Name, TLResource(FList[Result]).Name);
if C < 0 then
R := Result - 1
else
if C > 0 then
L := Result + 1
else
Exit;
end;
Result := -1;
end;
function TLResourceList.GetItems(Index: integer): TLResource;
begin
Result := TLResource(FList[Index]);
end;
procedure TLResourceList.Sort;
{$IFNDEF DisableChecks}
var
i: Integer;
r1: TLResource;
r2: TLResource;
{$ENDIF}
begin
if FSortedCount = FList.Count then
exit;
// sort the unsorted elements
FMergeList.Count := FList.Count;
MergeSort(FList, FMergeList, FSortedCount, FList.Count - 1);
// merge both
Merge(FList, FMergeList, 0, FSortedCount, FList.Count - 1);
FSortedCount := FList.Count;
// check for doubles
{$IFNDEF DisableChecks}
for i:=0 to FList.Count-2 do
begin
r1:=TLResource(FList[i]);
r2:=TLResource(FList[i+1]);
if (SysUtils.CompareText(r1.Name,r2.Name)=0) and (r1.ValueType=r2.ValueType) then
begin
DebugLn(['TLResourceList.Sort ',i,' DUPLICATE RESOURCE FOUND: ',r1.Name,':',r1.ValueType]);
//DumpStack;
end;
end;
{$ENDIF}
end;
procedure TLResourceList.MergeSort(List, MergeList: TList; Pos1, Pos2: integer);
var
cmp, mid: integer;
begin
if Pos1 = Pos2 then
begin
end else
if Pos1 + 1 = Pos2 then
begin
cmp := SysUtils.CompareText(TLResource(List[Pos1]).Name, TLResource(List[Pos2]).Name);
if cmp > 0 then
begin
MergeList[Pos1] := List[Pos1];
List[Pos1] := List[Pos2];
List[Pos2] := MergeList[Pos1];
end;
end else
begin
if Pos2 > Pos1 then
begin
mid := (Pos1 + Pos2) shr 1;
MergeSort(List, MergeList, Pos1, mid);
MergeSort(List, MergeList, mid + 1, Pos2);
Merge(List, MergeList, Pos1, mid + 1, Pos2);
end;
end;
end;
procedure TLResourceList.Merge(List, MergeList: TList; Pos1, Pos2, Pos3: integer);
// merge two sorted arrays
// the first array ranges Pos1..Pos2-1, the second ranges Pos2..Pos3
var
Src1Pos, Src2Pos, DestPos, cmp, a: integer;
begin
if (Pos1 >= Pos2) or (Pos2 > Pos3) then
exit;
Src1Pos := Pos2 - 1;
Src2Pos := Pos3;
DestPos := Pos3;
while (Src2Pos >= Pos2) and (Src1Pos >= Pos1) do
begin
cmp:=SysUtils.CompareText(TLResource(List[Src1Pos]).Name, TLResource(List[Src2Pos]).Name);
if cmp > 0 then
begin
MergeList[DestPos] := List[Src1Pos];
dec(Src1Pos);
end else
begin
MergeList[DestPos] := List[Src2Pos];
dec(Src2Pos);
end;
dec(DestPos);
end;
while Src2Pos >= Pos2 do
begin
MergeList[DestPos] := List[Src2Pos];
dec(Src2Pos);
dec(DestPos);
end;
for a := DestPos + 1 to Pos3 do
List[a] := MergeList[a];
end;
procedure TLResourceList.Add(const Name, ValueType, Value: AnsiString);
begin
Add(Name, ValueType, [Value]);
end;
//------------------------------------------------------------------------------
// Delphi object streams
type
TDelphiValueType = (dvaNull, dvaList, dvaInt8, dvaInt16, dvaInt32, dvaExtended,
dvaString, dvaIdent, dvaFalse, dvaTrue, dvaBinary, dvaSet, dvaLString,
dvaNil, dvaCollection, dvaSingle, dvaCurrency, dvaDate, dvaWString,
dvaInt64, dvaUTF8String);
TDelphiReader = class
private
FStream: TStream;
protected
procedure SkipBytes(Count: Integer);
procedure SkipSetBody;
procedure SkipProperty;
public
constructor Create(Stream: TStream);
procedure ReadSignature;
procedure Read(out Buf; Count: Longint);
function ReadInteger: Longint;
function ReadValue: TDelphiValueType;
function NextValue: TDelphiValueType;
function ReadStr: string;
function EndOfList: Boolean;
procedure SkipValue;
procedure CheckValue(Value: TDelphiValueType);
procedure ReadListEnd;
procedure ReadPrefix(var Flags: TFilerFlags; var AChildPos: Integer); virtual;
function ReadFloat: Extended;
function ReadSingle: Single;
function ReadCurrency: Currency;
function ReadDate: TDateTime;
function ReadString: string;
//function ReadWideString: WideString;
function ReadInt64: Int64;
function ReadIdent: string;
end;
TDelphiWriter = class
private
FStream: TStream;
public
constructor Create(Stream: TStream);
procedure Write(const Buf; Count: Longint);
end;
{ TDelphiReader }
procedure ReadError(Msg: string);
begin
raise EReadError.Create(Msg);
end;
procedure PropValueError;
begin
ReadError(rsInvalidPropertyValue);
end;
procedure TDelphiReader.SkipBytes(Count: Integer);
begin
FStream.Position:=FStream.Position+Count;
end;
procedure TDelphiReader.SkipSetBody;
begin
while ReadStr <> '' do ;
end;
procedure TDelphiReader.SkipProperty;
begin
ReadStr; { Skips property name }
SkipValue;
end;
constructor TDelphiReader.Create(Stream: TStream);
begin
FStream:=Stream;
end;
procedure TDelphiReader.ReadSignature;
var
Signature: TFilerSignature;
begin
Signature:='1234';
Read(Signature[1], length(Signature));
if Signature<>FilerSignature then
ReadError(rsInvalidStreamFormat);
end;
procedure TDelphiReader.Read(out Buf; Count: Longint);
begin
FStream.Read(Buf,Count);
end;
function TDelphiReader.ReadInteger: Longint;
var
S: Shortint;
I: Smallint;
begin
case ReadValue of
dvaInt8:
begin
Read(S, SizeOf(Shortint));
Result := S;
end;
dvaInt16:
begin
Read(I, SizeOf(I));
Result := I;
end;
dvaInt32:
Read(Result, SizeOf(Result));
else
Result:=0;
PropValueError;
end;
end;
function TDelphiReader.ReadValue: TDelphiValueType;
var b: byte;
begin
Read(b,1);
Result:=TDelphiValueType(b);
end;
function TDelphiReader.NextValue: TDelphiValueType;
begin
Result := ReadValue;
FStream.Position:=FStream.Position-1;
end;
function TDelphiReader.ReadStr: string;
var
L: Byte;
begin
Read(L, SizeOf(Byte));
SetLength(Result, L);
if L>0 then
Read(Result[1], L);
end;
function TDelphiReader.EndOfList: Boolean;
begin
Result := (ReadValue = dvaNull);
FStream.Position:=FStream.Position-1;
end;
procedure TDelphiReader.SkipValue;
procedure SkipList;
begin
while not EndOfList do SkipValue;
ReadListEnd;
end;
procedure SkipBinary(BytesPerUnit: Integer);
var
Count: Longint;
begin
Read(Count, SizeOf(Count));
SkipBytes(Count * BytesPerUnit);
end;
procedure SkipCollection;
begin
while not EndOfList do
begin
if NextValue in [dvaInt8, dvaInt16, dvaInt32] then SkipValue;
SkipBytes(1);
while not EndOfList do SkipProperty;
ReadListEnd;
end;
ReadListEnd;
end;
begin
case ReadValue of
dvaNull: { no value field, just an identifier };
dvaList: SkipList;
dvaInt8: SkipBytes(SizeOf(Byte));
dvaInt16: SkipBytes(SizeOf(Word));
dvaInt32: SkipBytes(SizeOf(LongInt));
dvaExtended: SkipBytes(SizeOf(Extended));
dvaString, dvaIdent: ReadStr;
dvaFalse, dvaTrue: { no value field, just an identifier };
dvaBinary: SkipBinary(1);
dvaSet: SkipSetBody;
dvaLString: SkipBinary(1);
dvaCollection: SkipCollection;
dvaSingle: SkipBytes(Sizeof(Single));
dvaCurrency: SkipBytes(SizeOf(Currency));
dvaDate: SkipBytes(Sizeof(TDateTime));
dvaWString: SkipBinary(Sizeof(WideChar));
dvaInt64: SkipBytes(Sizeof(Int64));
dvaUTF8String: SkipBinary(1);
end;
end;
procedure TDelphiReader.CheckValue(Value: TDelphiValueType);
begin
if ReadValue <> Value then
begin
FStream.Position:=FStream.Position-1;
SkipValue;
PropValueError;
end;
end;
procedure TDelphiReader.ReadListEnd;
begin
CheckValue(dvaNull);
end;
procedure TDelphiReader.ReadPrefix(var Flags: TFilerFlags;
var AChildPos: Integer);
var
Prefix: Byte;
begin
Flags := [];
if Byte(NextValue) and $F0 = $F0 then
begin
Prefix := Byte(ReadValue);
if (Prefix and ObjStreamMaskInherited)>0 then
Include(Flags,ffInherited);
if (Prefix and ObjStreamMaskChildPos)>0 then
Include(Flags,ffChildPos);
if (Prefix and ObjStreamMaskInline)>0 then
Include(Flags,ffInline);
if ffChildPos in Flags then AChildPos := ReadInteger;
end;
end;
function TDelphiReader.ReadFloat: Extended;
begin
if ReadValue = dvaExtended then
Read(Result, SizeOf(Result))
else begin
FStream.Position:=FStream.Position-1;
Result := ReadInteger;
end;
end;
function TDelphiReader.ReadSingle: Single;
begin
if ReadValue = dvaSingle then
Read(Result, SizeOf(Result))
else begin
FStream.Position:=FStream.Position-1;
Result := ReadInteger;
end;
end;
function TDelphiReader.ReadCurrency: Currency;
begin
if ReadValue = dvaCurrency then
Read(Result, SizeOf(Result))
else begin
FStream.Position:=FStream.Position-1;
Result := ReadInteger;
end;
end;
function TDelphiReader.ReadDate: TDateTime;
begin
if ReadValue = dvaDate then
Read(Result, SizeOf(Result))
else begin
FStream.Position:=FStream.Position-1;
Result := ReadInteger;
end;
end;
function TDelphiReader.ReadString: string;
var
L: Integer;
begin
Result := '';
if NextValue in [dvaWString, dvaUTF8String] then begin
ReadError('TDelphiReader.ReadString: WideString and UTF8String are not implemented yet');
//Result := ReadWideString;
end else
begin
L := 0;
case ReadValue of
dvaString:
Read(L, SizeOf(Byte));
dvaLString:
Read(L, SizeOf(Integer));
else
PropValueError;
end;
SetLength(Result, L);
Read(Pointer(Result)^, L);
end;
end;
function TDelphiReader.ReadInt64: Int64;
begin
if NextValue = dvaInt64 then
begin
ReadValue;
Read(Result, Sizeof(Result));
end
else
Result := ReadInteger;
end;
function TDelphiReader.ReadIdent: string;
var
L: Byte;
begin
case ReadValue of
dvaIdent:
begin
Read(L, SizeOf(Byte));
SetLength(Result, L);
Read(Result[1], L);
end;
dvaFalse:
Result := 'False';
dvaTrue:
Result := 'True';
dvaNil:
Result := 'nil';
dvaNull:
Result := 'Null';
else
Result:='';
PropValueError;
end;
end;
{ TDelphiWriter }
{ MultiByte Character Set (MBCS) byte type }
type
TMbcsByteType = (mbSingleByte, mbLeadByte, mbTrailByte);
function ByteType(const S: string; Index: Integer): TMbcsByteType;
begin
Result := mbSingleByte;
{ ToDo:
if SysLocale.FarEast then
Result := ByteTypeTest(PChar(S), Index-1);
}
end;
constructor TDelphiWriter.Create(Stream: TStream);
begin
FStream:=Stream;
end;
procedure TDelphiWriter.Write(const Buf; Count: Longint);
begin
FStream.Write(Buf,Count);
end;
procedure ReadLFMHeader(LFMStream: TStream;
out LFMType, LFMComponentName, LFMClassName: String);
var
c:char;
Token: String;
begin
{ examples:
object Form1: TForm1
inherited AboutBox2: ns.unit2/TAboutBox2
}
LFMComponentName:='';
LFMClassName := '';
LFMType := '';
Token := '';
while (LFMStream.Read(c,1)=1) and (LFMStream.Position<1000) do begin
case c of
' ',#9,':':
begin
if Token<>'' then begin
if LFMType = '' then
LFMType := Token
else if LFMComponentName='' then
LFMComponentName:=Token
else if LFMClassName = '' then
begin
LFMClassName := Token;
exit;
end;
Token := '';
end;
end;
'a'..'z','A'..'Z','0'..'9','_','.','/':
Token:=Token+c;
else
break;
end;
end;
LFMStream.Position:=0;
end;
procedure ReadLFMHeader(const LFMSource: string;
out LFMClassName: String; out LFMType: String);
var
LFMComponentName: string;
begin
ReadLFMHeader(LFMSource,LFMType,LFMComponentName,LFMClassName);
end;
procedure ReadLFMHeader(const LFMSource: string; out LFMType, LFMComponentName,
LFMClassName: String);
var
p: Integer;
StartPos: LongInt;
begin
{ examples:
object Form1: TForm1
inherited AboutBox2: ns.unit1/TAboutBox2
- LFMType is the first word on the line, e.g. object or inherited
- LFMComponentName is the second word
- LFMClassName is the third
}
// read LFMType
p:=1;
while (p<=length(LFMSource))
and (LFMSource[p] in ['a'..'z','A'..'Z','0'..'9','_']) do
inc(p);
LFMType:=copy(LFMSource,1,p-1);
// read LFMComponentName
while (p<=length(LFMSource)) and (LFMSource[p] in [' ',#9]) do inc(p);
StartPos:=p;
while (p<=length(LFMSource))
and (LFMSource[p] in ['a'..'z','A'..'Z','0'..'9','_']) do
inc(p);
LFMComponentName:=copy(LFMSource,StartPos,p-StartPos);
// read LFMClassName
while (p<=length(LFMSource)) and (LFMSource[p] in [' ',#9,':']) do inc(p);
StartPos:=p;
while (p<=length(LFMSource))
and (LFMSource[p] in ['a'..'z','A'..'Z','0'..'9','_','.','/']) do
inc(p);
LFMClassName:=copy(LFMSource,StartPos,p-StartPos);
end;
function ReadLFMHeaderFromFile(const Filename: string; out LFMType,
LFMComponentName, LFMClassName: String): boolean;
var
fs: TFileStream;
Header: string;
Cnt: LongInt;
begin
Result:=false;
try
fs:=TFileStream.Create(Filename,fmOpenRead);
try
SetLength(Header,600);
Cnt:=fs.Read(Header[1],length(Header));
SetLength(Header,Cnt);
ReadLFMHeader(Header,LFMType,LFMComponentName,LFMClassName);
Result:=LFMClassName<>'';
finally
fs.Free;
end;
except
end;
end;
function CreateLFMFile(AComponent: TComponent; LFMStream: TStream): integer;
// 0 = ok
// -1 = error while streaming AForm to binary stream
// -2 = error while streaming binary stream to text file
var
BinStream: TMemoryStream;
DestroyDriver: Boolean;
Writer: TWriter;
begin
Result:=0;
BinStream:=TMemoryStream.Create;
try
try
// write component to binary stream
DestroyDriver:=false;
Writer:=CreateLRSWriter(BinStream,DestroyDriver);
try
Writer.WriteDescendent(AComponent,nil);
finally
if DestroyDriver then Writer.Driver.Free;
Writer.Free;
end;
except
Result:=-1;
exit;
end;
try
// transform binary to text
BinStream.Position:=0;
LRSObjectBinaryToText(BinStream,LFMStream);
except
Result:=-2;
exit;
end;
finally
BinStream.Free;
end;
end;
function SameLFMTypeName(aUnitname, aTypename, LFMTypename: string): boolean;
var
p: SizeInt;
begin
p:=Pos('/',LFMTypename);
if p>0 then
begin
if aUnitname<>'' then
Result:=CompareText(aUnitname+'/'+aTypename,LFMTypename)=0
else
Result:=CompareText(aTypename,copy(LFMTypename,p+1,length(LFMTypename)))=0;
end else begin
Result:=CompareText(aTypename,LFMTypename)=0;
end;
end;
procedure LRSObjectBinaryToText(Input, Output: TStream);
procedure OutStr(const s: String);
{$IFDEF VerboseLRSObjectBinaryToText}
var
i: Integer;
{$ENDIF}
begin
{$IFDEF VerboseLRSObjectBinaryToText}
for i:=1 to length(s) do begin
if (s[i] in [#0..#8,#11..#12,#14..#31]) then begin
DbgOut('#'+IntToStr(ord(s[i])));
RaiseGDBException('ObjectLRSToText: Invalid character');
end else
DbgOut(s[i]);
end;
{$ENDIF}
if Length(s) > 0 then
Output.Write(s[1], Length(s));
end;
procedure OutLn(const s: String);
begin
OutStr(s + LineEnding);
end;
procedure OutString(const s: String);
var
res, NewStr: String;
i: Integer;
InString, NewInString: Boolean;
begin
if s<>'' then begin
res := '';
InString := False;
for i := 1 to Length(s) do begin
NewInString := InString;
case s[i] of
#0..#31: begin
NewInString := False;
NewStr := '#' + IntToStr(Ord(s[i]));
end;
'''': begin
NewInString := True;
NewStr:=''''''; // write two ticks, so the reader will read one
end;
else begin
NewInString := True;
NewStr := s[i];
end;
end;
if NewInString <> InString then begin
NewStr := '''' + NewStr;
InString := NewInString;
end;
res := res + NewStr;
end;
if InString then res := res + '''';
end else begin
res:='''''';
end;
OutStr(res);
end;
procedure OutWideString(const s: WideString);
// write as normal string
var
res, NewStr: String;
i: Integer;
InString, NewInString: Boolean;
begin
//debugln('OutWideString ',s);
res := '';
if s<>'' then begin
InString := False;
for i := 1 to Length(s) do begin
NewInString := InString;
if (ord(s[i])<ord(' ')) or (ord(s[i])>=127) then begin
// special char
NewInString := False;
NewStr := '#' + IntToStr(Ord(s[i]));
end
else if s[i]='''' then begin
// '
if InString then
NewStr := ''''''
else
NewStr := '''''''';
end
else begin
// normal char
NewInString := True;
NewStr := AnsiString(s[i]);
end;
if NewInString <> InString then begin
NewStr := '''' + NewStr;
InString := NewInString;
end;
res := res + NewStr;
end;
if InString then res := res + '''';
end else begin
res:='''''';
end;
OutStr(res);
end;
function ReadInt(ValueType: TValueType): LongInt;
var
w: Word;
begin
case ValueType of
vaInt8: Result := ShortInt(Input.ReadByte);
vaInt16: begin
w:=ReadLRSWord(Input);
//DebugLn('ReadInt vaInt16 w=',IntToStr(w));
Result := SmallInt(w);
end;
vaInt32: Result := ReadLRSInteger(Input);
else Result := 0;
end;
end;
function ReadInt: LongInt;
begin
Result := ReadInt(TValueType(Input.ReadByte));
end;
function ReadShortString: String;
var
len: Byte;
begin
len := Input.ReadByte;
SetLength(Result, len);
if (Len > 0) then
Input.Read(Result[1], len);
end;
function ReadLongString: String;
var
len: integer;
begin
len := ReadLRSInteger(Input);
SetLength(Result, len);
if (Len > 0) then
Input.Read(Result[1], len);
end;
procedure ReadPropList(const indent: String);
procedure ProcessValue(ValueType: TValueType; const Indent: String);
procedure Stop(const s: String);
begin
RaiseGDBException('ObjectLRSToText '+s);
end;
function ValueTypeAsString(ValueType: TValueType): string;
begin
case ValueType of
vaNull: Result:='vaNull';
vaList: Result:='vaList';
vaInt8: Result:='vaInt8';
vaInt16: Result:='vaInt16';
vaInt32: Result:='vaInt32';
vaExtended: Result:='vaExtended';
vaString: Result:='vaString';
vaIdent: Result:='vaIdent';
vaFalse: Result:='vaFalse';
vaTrue: Result:='vaTrue';
vaBinary: Result:='vaBinary';
vaSet: Result:='vaSet';
vaLString: Result:='vaLString';
vaNil: Result:='vaNil';
vaCollection: Result:='vaCollection';
vaSingle: Result:='vaSingle';
vaCurrency: Result:='vaCurrency';
vaDate: Result:='vaDate';
vaWString: Result:='vaWString';
vaInt64: Result:='vaInt64';
vaUTF8String: Result:='vaUTF8String';
vaUString: Result:='vaUString';
vaQWord : Result:='vaQWord';
else Result:='Unknown ValueType='+dbgs(Ord(ValueType));
end;
end;
procedure UnknownValueType;
var
s: String;
{$IFNDEF DisableChecks}
HintStr: string;
HintLen: Int64;
{$ENDIF}
begin
s:=ValueTypeAsString(ValueType);
if s<>'' then
s:='Unimplemented ValueType='+s;
{$IFNDEF DisableChecks}
HintLen:=Output.Position;
if HintLen>50 then HintLen:=50;
SetLength(HintStr,HintLen);
if HintStr<>'' then begin
try
Output.Position:=Output.Position-length(HintStr);
Output.Read(HintStr[1],length(HintStr));
//debugln('ObjectLRSToText:');
debugln(DbgStr(HintStr));
except
end;
end;
{$ENDIF}
s:=s+' ';
Stop(s);
end;
procedure ProcessBinary;
var
ToDo, DoNow, StartPos, i: LongInt;
lbuf: array[0..31] of Byte;
s: String;
p: pchar;
const
HexDigits: array[0..$F] of char = '0123456789ABCDEF';
begin
ToDo := ReadLRSCardinal(Input);
OutLn('{');
while ToDo > 0 do begin
DoNow := ToDo;
if DoNow > 32 then DoNow := 32;
Dec(ToDo, DoNow);
s := Indent + ' ';
StartPos := length(s);
Input.Read(lbuf, DoNow);
setlength(s, StartPos+DoNow*2);
p := @s[StartPos];
for i := 0 to DoNow - 1 do begin
inc(p);
p^ := HexDigits[(lbuf[i] shr 4) and $F];
inc(p);
p^ := HexDigits[lbuf[i] and $F];
end;
OutLn(s);
end;
OutStr(indent);
OutLn('}');
end;
var
s: String;
IsFirst: Boolean;
ext: Extended;
ASingle: single;
ADate: TDateTime;
ACurrency: Currency;
AWideString: WideString;
begin
//DebugLn(['ProcessValue ',Indent,' ValueType="',ValueTypeAsString(ValueType),'"']);
case ValueType of
vaList: begin
OutStr('(');
IsFirst := True;
while True do begin
ValueType := TValueType(Input.ReadByte);
if ValueType = vaNull then break;
if IsFirst then begin
OutLn('');
IsFirst := False;
end;
OutStr(Indent + ' ');
ProcessValue(ValueType, Indent + ' ');
end;
OutLn(Indent + ')');
end;
vaInt8: begin
// MG: IntToStr has a bug with ShortInt, therefore these typecasts
OutLn(IntToStr(Integer(ShortInt(Input.ReadByte))));
end;
vaInt16: OutLn(IntToStr(SmallInt(ReadLRSWord(Input))));
vaInt32: OutLn(IntToStr(ReadLRSInteger(Input)));
vaInt64: OutLn(IntToStr(ReadLRSInt64(Input)));
vaExtended: begin
ext:=ReadLRSExtended(Input);
OutLn(FloatToStr(ext));
end;
vaString: begin
OutString(ReadShortString);
OutLn('');
end;
vaIdent: OutLn(ReadShortString);
vaFalse: OutLn('False');
vaTrue: OutLn('True');
vaBinary: ProcessBinary;
vaSet: begin
OutStr('[');
IsFirst := True;
while True do begin
s := ReadShortString;
if Length(s) = 0 then break;
if not IsFirst then OutStr(', ');
IsFirst := False;
OutStr(s);
end;
OutLn(']');
end;
vaLString: begin
OutString(ReadLongString);
OutLn('');
end;
vaNil:
OutLn('nil');
vaCollection: begin
OutStr('<');
while Input.ReadByte <> 0 do begin
OutLn(Indent);
Input.Seek(-1, soFromCurrent);
OutStr(indent + ' item');
ValueType := TValueType(Input.ReadByte);
if ValueType <> vaList then
OutStr('[' + IntToStr(ReadInt(ValueType)) + ']');
OutLn('');
ReadPropList(indent + ' ');
OutStr(indent + ' end');
end;
OutLn('>');
end;
vaSingle: begin
ASingle:=ReadLRSSingle(Input);
OutLn(FloatToStr(ASingle) + 's');
end;
vaDate: begin
ADate:=TDateTime(ReadLRSDouble(Input));
OutLn(FloatToStr(ADate) + 'd');
end;
vaCurrency: begin
ACurrency:=ReadLRSCurrency(Input);
OutLn(FloatToStr(ACurrency * 10000) + 'c');
end;
vaWString,vaUString: begin
AWideString:=ReadLRSWideString(Input);
OutWideString(AWideString);
OutLn('');
end;
else
if ord(ValueType)=20 then begin
// vaUTF8String
// Delphi saves widestrings as UTF8 strings
// The LCL does not use widestrings, but UTF8 directly
// so, simply read and write the string
OutString(ReadLongString);
OutLn('');
end else
UnknownValueType;
end;
end;
var
NextByte: Byte;
begin
while Input.ReadByte <> 0 do begin
Input.Seek(-1, soFromCurrent);
OutStr(indent + ReadShortString + ' = ');
NextByte:=Input.ReadByte;
if NextByte<>0 then
ProcessValue(TValueType(NextByte), Indent)
else
OutLn('');
end;
end;
procedure ReadObject(const indent: String);
var
b: Byte;
ObjClassName, ObjName: String;
ChildPos: LongInt;
begin
ChildPos := 0;
// Check for FilerFlags
b := Input.ReadByte;
if (b and $f0) = $f0 then begin
if (b and ObjStreamMaskChildPos) <> 0 then
ChildPos := ReadInt;
end else begin
b := 0;
Input.Seek(-1, soFromCurrent);
end;
ObjClassName := ReadShortString;
ObjName := ReadShortString;
OutStr(Indent);
if (b and ObjStreamMaskInherited) <> 0 then OutStr('inherited')
else if (b and ObjStreamMaskInline) <> 0 then OutStr('inline')
else OutStr('object');
OutStr(' ');
if ObjName <> '' then
OutStr(ObjName + ': ');
OutStr(ObjClassName);
if (b and ObjStreamMaskChildPos) <> 0 then OutStr('[' + IntToStr(ChildPos) + ']');
OutLn('');
ReadPropList(indent + ' ');
while Input.ReadByte <> 0 do begin
Input.Seek(-1, soFromCurrent);
ReadObject(indent + ' ');
end;
OutLn(indent + 'end');
end;
var
OldDecimalSeparator: Char;
OldThousandSeparator: Char;
Signature: TFilerSignature;
begin
// Endian note: comparing 2 cardinals is endian independent
Signature:='1234';
Input.Read(Signature[1], length(Signature));
if Signature<>FilerSignature then
raise EReadError.Create('Illegal stream image' {###SInvalidImage});
OldDecimalSeparator:=DefaultFormatSettings.DecimalSeparator;
DefaultFormatSettings.DecimalSeparator:='.';
OldThousandSeparator:=DefaultFormatSettings.ThousandSeparator;
DefaultFormatSettings.ThousandSeparator:=',';
try
ReadObject('');
finally
DefaultFormatSettings.DecimalSeparator:=OldDecimalSeparator;
DefaultFormatSettings.ThousandSeparator:=OldThousandSeparator;
end;
end;
function TestFormStreamFormat(Stream: TStream): TLRSStreamOriginalFormat;
var
Pos: TStreamSeekType;
Signature: TFilerSignature;
begin
Pos := Stream.Position;
Signature[1] := #0; // initialize, in case the stream is at its end
Stream.Read(Signature, length(Signature));
Stream.Position := Pos;
if (Signature[1] = #$FF) or (Signature = FilerSignature) then
Result := sofBinary
// text format may begin with "object", "inherited", or whitespace
else if Signature[1] in ['o','O','i','I',' ',#13,#11,#9] then
Result := sofText
else
Result := sofUnknown;
end;
type
TObjectTextConvertProc = procedure (Input, Output: TStream);
procedure InternalLRSBinaryToText(Input, Output: TStream;
var OriginalFormat: TLRSStreamOriginalFormat;
ConvertProc: TObjectTextConvertProc;
BinarySignature: TFilerSignature);
var
Pos: TStreamSeekType;
Signature: TFilerSignature;
begin
Pos := Input.Position;
Signature := BinarySignature;
Signature[1]:=#0;
Input.Read(Signature[1], length(Signature));
Input.Position := Pos;
if Signature = BinarySignature then
begin // definitely binary format
if OriginalFormat = sofBinary then begin
if Output is TMemoryStream then
TMemoryStream(Output).SetSize(Output.Position+(Input.Size-Input.Position));
Output.CopyFrom(Input, Input.Size - Input.Position)
end else
begin
if OriginalFormat = sofUnknown then
Originalformat := sofBinary;
ConvertProc(Input, Output);
end;
end
else // might be text format
begin
if OriginalFormat = sofBinary then
ConvertProc(Input, Output)
else
begin
if OriginalFormat = sofUnknown then
begin // text format may begin with "object", "inherited", or whitespace
if Signature[1] in ['o','O','i','I',' ',#13,#11,#9] then
OriginalFormat := sofText
else // not binary, not text... let it raise the exception
begin
ConvertProc(Input, Output);
Exit;
end;
end;
if OriginalFormat = sofText then begin
if Output is TMemoryStream then
TMemoryStream(Output).SetSize(Output.Position
+(Input.Size - Input.Position));
Output.CopyFrom(Input, Input.Size - Input.Position);
end;
end;
end;
end;
procedure LRSObjectTextToBinary(Input, Output: TStream; Links: TLRPositionLinks);
var
parser: TParser;
OldDecimalSeparator: Char;
OldThousandSeparator: Char;
TokenStartPos: LongInt;
procedure WriteShortString(const s: String);
var
Size: Integer;
begin
Size:=length(s);
if Size>255 then Size:=255;
Output.WriteByte(byte(Size));
if Size > 0 then
Output.Write(s[1], Size);
end;
procedure WriteLongString(const s: String);
begin
WriteLRSInteger(Output,Length(s));
if Length(s) > 0 then
Output.Write(s[1], Length(s));
end;
procedure WriteWideString(const s: WideString);
begin
WriteLRSInteger(Output,Length(s));
if Length(s) > 0 then
Output.Write(s[1], Length(s)*2);
end;
procedure WriteInteger(value: LongInt);
begin
if (value >= -128) and (value <= 127) then begin
Output.WriteByte(Ord(vaInt8));
Output.WriteByte(Byte(value));
end else if (value >= -32768) and (value <= 32767) then begin
Output.WriteByte(Ord(vaInt16));
WriteLRSWord(Output,Word(value));
end else begin
Output.WriteByte(ord(vaInt32));
WriteLRSInteger(Output,value);
end;
end;
procedure WriteInt64(const Value: Int64);
begin
if (Value >= -$80000000) and (Value <= $7fffffff) then
WriteInteger(Integer(Value))
else begin
Output.WriteByte(ord(vaInt64));
WriteLRSInt64(Output,Value);
end;
end;
procedure WriteIntegerStr(const s: string);
begin
if length(s)>7 then
WriteInt64(StrToInt64(s))
else
WriteInteger(StrToInt(s));
end;
function ParserNextToken: Char;
begin
TokenStartPos:=Parser.SourcePos;
Result:=Parser.NextToken;
if Links<>nil then
Links.SetPosition(TokenStartPos,Parser.SourcePos,Output.Position,true);
end;
procedure ProcessProperty; forward;
{$if not declared(toWString)}
const toWString = char(5);
{$endif}
procedure ProcessValue;
procedure RaiseValueExpected;
begin
parser.Error('Value expected, but '+parser.TokenString+' found');
end;
var
flt: Extended;
stream: TMemoryStream;
BinDataSize: LongInt;
toStringBuf: String;
begin
if parser.TokenSymbolIs('END') then exit;
if parser.TokenSymbolIs('OBJECT') then
RaiseValueExpected;
case parser.Token of
toInteger:
begin
WriteIntegerStr(parser.TokenString);
ParserNextToken;
end;
toFloat:
begin
flt := Parser.TokenFloat;
case parser.FloatType of
's': begin
Output.WriteByte(Ord(vaSingle));
WriteLRSSingle(Output,flt);
end;
'd': begin
Output.WriteByte(Ord(vaDate));
WriteLRSDouble(Output,flt);
end;
'c': begin
Output.WriteByte(Ord(vaCurrency));
WriteLRSCurrency(Output,flt/10000);
end;
else
begin
Output.WriteByte(Ord(vaExtended));
WriteLRSExtended(Output,flt);
end;
end;
ParserNextToken;
end;
toString:
begin
toStringBuf := parser.TokenString;
//DebugLn(['ProcessValue toStringBuf="',toStringBuf,'" ',dbgstr(toStringBuf)]);
while ParserNextToken = '+' do
begin
ParserNextToken; // Get next string fragment
if not (parser.Token in [toString,toWString]) then
parser.CheckToken(toString);
toStringBuf := toStringBuf + parser.TokenString;
end;
if length(toStringBuf)<256 then begin
//debugln('LRSObjectTextToBinary.ProcessValue WriteShortString');
Output.WriteByte(Ord(vaString));
WriteShortString(toStringBuf);
end else begin
//debugln('LRSObjectTextToBinary.ProcessValue WriteLongString');
Output.WriteByte(Ord(vaLString));
WriteLongString(toStringBuf);
end;
end;
toWString:
begin
toStringBuf := parser.TokenString;
//DebugLn(['ProcessValue toStringBuf="',toStringBuf,'" ',dbgstr(toStringBuf)]);
while ParserNextToken = '+' do
begin
ParserNextToken; // Get next string fragment
if not (parser.Token in [toString,toWString]) then
parser.CheckToken(toString);
toStringBuf := toStringBuf + parser.TokenString;
end;
Output.WriteByte(Ord(vaWString));
WriteWideString(UTF8Decode(toStringBuf));
end;
toSymbol:
begin
if CompareText(parser.TokenString, 'True') = 0 then
Output.WriteByte(Ord(vaTrue))
else if CompareText(parser.TokenString, 'False') = 0 then
Output.WriteByte(Ord(vaFalse))
else if CompareText(parser.TokenString, 'nil') = 0 then
Output.WriteByte(Ord(vaNil))
else
begin
Output.WriteByte(Ord(vaIdent));
WriteShortString(parser.TokenComponentIdent);
end;
ParserNextToken;
end;
// Set
'[':
begin
ParserNextToken;
Output.WriteByte(Ord(vaSet));
if parser.Token <> ']' then
while True do
begin
parser.CheckToken(toSymbol);
WriteShortString(parser.TokenString);
ParserNextToken;
if parser.Token = ']' then
break;
parser.CheckToken(',');
ParserNextToken;
end;
Output.WriteByte(0);
ParserNextToken;
end;
// List
'(':
begin
Output.WriteByte(Ord(vaList));
ParserNextToken;
while parser.Token <> ')' do
ProcessValue;
Output.WriteByte(0);
ParserNextToken;
end;
// Collection
'<':
begin
ParserNextToken;
Output.WriteByte(Ord(vaCollection));
while parser.Token <> '>' do
begin
parser.CheckTokenSymbol('item');
ParserNextToken;
// ConvertOrder
Output.WriteByte(Ord(vaList));
while not parser.TokenSymbolIs('end') do
ProcessProperty;
ParserNextToken; // Skip 'end'
Output.WriteByte(0);
end;
Output.WriteByte(0);
ParserNextToken;
end;
// Binary data
'{':
begin
Output.WriteByte(Ord(vaBinary));
stream := TMemoryStream.Create;
try
parser.HexToBinary(stream);
BinDataSize:=integer(stream.Size);
WriteLRSInteger(Output,BinDataSize);
Output.Write(Stream.Memory^, BinDataSize);
Stream.Position:=0;
//debugln('LRSObjectTextToBinary binary data "',dbgMemStream(Stream,30),'"');
finally
stream.Free;
end;
ParserNextToken;
end;
else
parser.Error('Invalid Property');
end;
end;
procedure ProcessProperty;
var
name: String;
begin
// Get name of property
parser.CheckToken(toSymbol);
name := parser.TokenString;
while True do begin
ParserNextToken;
if parser.Token <> '.' then break;
ParserNextToken;
parser.CheckToken(toSymbol);
name := name + '.' + parser.TokenString;
end;
WriteShortString(name);
parser.CheckToken('=');
ParserNextToken;
ProcessValue;
end;
procedure ProcessObject;
var
Flags: Byte;
ChildPos: Integer;
ObjectName, ObjectType: String;
begin
if parser.TokenSymbolIs('OBJECT') then
Flags :=0 { IsInherited := False }
else if parser.TokenSymbolIs('INHERITED') then
Flags := 1 { IsInherited := True; }
else begin
parser.CheckTokenSymbol('INLINE');
Flags := 4;
end;
ParserNextToken;
parser.CheckToken(toSymbol);
if parser.TokenSymbolIs('END') then begin
// 'object end': no name, no content
// this is normally invalid, but Delphi can create this, so ignore it
exit;
end;
ObjectName := '';
ObjectType := parser.TokenString;
ParserNextToken;
ChildPos := 0;
if parser.Token = ':' then begin
ParserNextToken;
parser.CheckToken(toSymbol);
ObjectName := ObjectType;
ObjectType := parser.TokenString;
ParserNextToken;
if parser.Token = '[' then begin
ParserNextToken;
ChildPos := parser.TokenInt;
ParserNextToken;
parser.CheckToken(']');
ParserNextToken;
Flags := Flags or 2;
end;
end;
if Flags <> 0 then begin
Output.WriteByte($f0 or Flags);
if (Flags and ObjStreamMaskChildPos) <> 0 then
WriteInteger(ChildPos);
end;
WriteShortString(ObjectType);
WriteShortString(ObjectName);
// Convert property list
while not (parser.TokenSymbolIs('END') or
parser.TokenSymbolIs('OBJECT') or
parser.TokenSymbolIs('INHERITED') or
parser.TokenSymbolIs('INLINE'))
do
ProcessProperty;
Output.WriteByte(0); // Terminate property list
// Convert child objects
while not parser.TokenSymbolIs('END') do ProcessObject;
ParserNextToken; // Skip end token
Output.WriteByte(0); // Terminate property list
end;
var
Count: Integer;
begin
if Links<>nil then begin
// sort links for LFM positions
Links.Sort(true);
end;
parser := TParser.Create(Input);
OldDecimalSeparator:=DefaultFormatSettings.DecimalSeparator;
DefaultFormatSettings.DecimalSeparator:='.';
OldThousandSeparator:=DefaultFormatSettings.ThousandSeparator;
DefaultFormatSettings.ThousandSeparator:=',';
try
Count:=0;
repeat
Output.Write(FilerSignature[1], length(FilerSignature));
ProcessObject;
inc(Count);
until parser.TokenString='';
if Count>1 then
Output.WriteByte(0); // Terminate object list
finally
parser.Free;
DefaultFormatSettings.DecimalSeparator:=OldDecimalSeparator;
DefaultFormatSettings.ThousandSeparator:=OldThousandSeparator;
end;
end;
procedure LRSObjectToText(Input, Output: TStream;
var OriginalFormat: TLRSStreamOriginalFormat);
begin
InternalLRSBinaryToText(Input, Output, OriginalFormat,
@LRSObjectBinaryToText, FilerSignature);
end;
procedure LRSObjectResToText(Input, Output: TStream;
var OriginalFormat: TLRSStreamOriginalFormat);
begin
InternalLRSBinaryToText(Input, Output, OriginalFormat,
@LRSObjectResourceToText, #255);
end;
procedure LRSObjectResourceToText(Input, Output: TStream);
begin
Input.ReadResHeader;
LRSObjectBinaryToText(Input, Output);
end;
procedure FormDataToText(FormStream, TextStream: TStream; aFormat: TLRSStreamOriginalFormat);
begin
if aFormat = sofUnknown then
aFormat := TestFormStreamFormat(FormStream);
case aFormat of
sofBinary:
LRSObjectResourceToText(FormStream, TextStream);
sofText:
begin
if TextStream is TMemoryStream then
TMemoryStream(TextStream).SetSize(TextStream.Position+FormStream.Size);
TextStream.CopyFrom(FormStream,FormStream.Size);
end;
else
raise Exception.Create(rsInvalidFormObjectStream);
end;
end;
function InitLazResourceComponent(Instance: TComponent;
RootAncestor: TClass): Boolean;
function InitComponent(ClassType: TClass): Boolean;
var
{$ifdef UseLRS}
LazResource: TLResource;
{$endif}
{$ifdef UseRES}
FPResource: TFPResourceHandle;
{$endif}
ResName: String;
GenericInd: Integer;
Stream: TStream;
Reader: TReader;
DestroyDriver: Boolean;
Driver: TAbstractObjectReader;
begin
//DebugLn(['[InitComponent] ClassType=',ClassType.Classname,' Instance=',DbgsName(Instance),' RootAncestor=',DbgsName(RootAncestor),' ClassType.ClassParent=',DbgsName(ClassType.ClassParent)]);
Result := False;
if (ClassType = TComponent) or (ClassType = RootAncestor) then
Exit;
if Assigned(ClassType.ClassParent) then
Result := InitComponent(ClassType.ClassParent);
Stream := nil;
ResName := ClassType.ClassName;
// Generics class name can contain <> and resource files do not support it
GenericInd := ResName.IndexOf('<');
if GenericInd > 0 then
SetLength(ResName, GenericInd);
{$ifdef UseLRS}
LazResource := LazarusResources.Find(ResName);
if (LazResource <> nil) and (LazResource.Value <> '') then
Stream := TLazarusResourceStream.CreateFromHandle(LazResource);
//DebugLn('[InitComponent] CompResource found for ',ClassType.Classname);
{$endif}
{$ifdef UseRES}
if Stream = nil then
begin
FPResource := FindResourceLFM(ResName);
if FPResource <> 0 then
Stream := TLazarusResourceStream.CreateFromHandle(HInstance, FPResource);
end;
{$endif}
if Stream = nil then
Exit;
try
//DebugLn('Form Stream "',ClassType.ClassName,'"');
//try
DestroyDriver:=false;
Reader := CreateLRSReader(Stream, DestroyDriver);
try
Reader.ReadRootComponent(Instance);
finally
Driver := Reader.Driver;
Reader.Free;
if DestroyDriver then
Driver.Free;
end;
//except
// on E: Exception do begin
// DebugLn(Format(rsFormStreamingError,[ClassType.ClassName,E.Message]));
// exit;
// end;
//end;
finally
Stream.Free;
end;
Result := True;
end;
begin
if Instance.ComponentState * [csLoading, csInline] <> []
then begin
// global loading not needed
Result := InitComponent(Instance.ClassType);
end
else try
BeginGlobalLoading;
Result := InitComponent(Instance.ClassType);
NotifyGlobalLoading;
finally
EndGlobalLoading;
end;
end;
function CreateLRSReader(s: TStream; var DestroyDriver: boolean): TReader;
var
p: Pointer;
Driver: TAbstractObjectReader;
begin
Result:=TReader.Create(s,4096);
//If included Default translator LRSTranslator will be set
if Assigned(LRSTranslator) then
Result.OnReadStringProperty:=@(LRSTranslator.TranslateStringProperty);
Result.OnPropertyNotFound := @(PropertiesToSkip.DoPropertyNotFound);
DestroyDriver:=false;
if Result.Driver.ClassType=LRSObjectReaderClass then
begin
TLRSObjectReader(Result.Driver).Reader:=Result;
exit;
end;
// hack to set a write protected variable.
// DestroyDriver:=true; TReader will free it
Driver:=LRSObjectReaderClass.Create(s,4096);
p:=@Result.Driver;
Result.Driver.Free;
TAbstractObjectReader(p^):=Driver;
TLRSObjectReader(Driver).Reader:=Result;
end;
function CreateLRSWriter(s: TStream; var DestroyDriver: boolean): TWriter;
var
Driver: TAbstractObjectWriter;
begin
Driver:=LRSObjectWriterClass.Create(s,4096);
DestroyDriver:=true;
Result:=TWriter.Create(Driver);
TLRSObjectWriter(Driver).Writer:=Result;
end;
{ LRS format converter functions }
procedure ReverseBytes(p: Pointer; Count: integer);
var
p1: PChar;
p2: PChar;
c: Char;
begin
p1:=PChar(p);
p2:=PChar(p)+Count-1;
while p1<p2 do begin
c:=p1^;
p1^:=p2^;
p2^:=c;
inc(p1);
dec(p2);
end;
end;
procedure ReverseByteOrderInWords(p: PWord; Count: integer);
var
i: Integer;
w: Word;
begin
for i:=0 to Count-1 do begin
w:=p[i];
w:=(w shr 8) or ((w and $ff) shl 8);
p[i]:=w;
end;
end;
function ConvertLRSExtendedToDouble(p: Pointer): Double;
type
Ti386ExtendedReversed = packed record
{$IFDEF FPC_BIG_ENDIAN}
ExponentAndSign: word;
Mantissa: qword;
{$ELSE}
Mantissa: qword;
ExponentAndSign: word;
{$ENDIF}
end;
var
e: Ti386ExtendedReversed;
Exponent: word;
ExponentAndSign: word;
Mantissa: qword;
begin
System.Move(p^,e,10);
{$IFDEF FPC_BIG_ENDIAN}
ReverseBytes(@e,10);
{$ENDIF}
// i386 extended
Exponent:=(e.ExponentAndSign and $7fff);
if (Exponent>$4000+$3ff) or (Exponent<$4000-$400) then begin
// exponent out of bounds
Result:=0;
exit;
end;
dec(Exponent,$4000-$400);
ExponentAndSign:=Exponent or ((e.ExponentAndSign and $8000) shr 4);
// i386 extended has leading 1, double has not (shl 1)
// i386 has 64 bit, double has 52 bit (shr 12)
{$IFDEF FPC_REQUIRES_PROPER_ALIGNMENT}
{$IFDEF FPC_BIG_ENDIAN}
// accessing Mantissa will couse trouble, copy it first
System.Move(e.Mantissa, Mantissa, SizeOf(Mantissa));
Mantissa := (Mantissa shl 1) shr 12;
{$ELSE FPC_BIG_ENDIAN}
Mantissa := (e.Mantissa shl 1) shr 12;
{$ENDIF FPC_BIG_ENDIAN}
{$ELSE FPC_REQUIRES_PROPER_ALIGNMENT}
Mantissa := (e.Mantissa shl 1) shr 12;
{$ENDIF FPC_REQUIRES_PROPER_ALIGNMENT}
// put together
QWord(Result):=Mantissa or (qword(ExponentAndSign) shl 52);
end;
procedure ConvertEndianBigDoubleToLRSExtended(BigEndianDouble, LRSExtended: Pointer);
// Floats consists of a sign bit, some exponent bits and the mantissa bits
// A 0 is all bits 0
// not 0 has always a leading 1, which exponent is stored
// Single/Double does not save the leading 1, Extended does.
//
// Double is 8 bytes long, leftmost bit is sign,
// then 11 bit exponent based $400, then 52 bit mantissa without leading 1
//
// Extended is 10 bytes long, leftmost bit is sign,
// then 15 bit exponent based $4000, then 64 bit mantissa with leading 1
// EndianLittle means reversed byte order
var
e: array[0..9] of byte;
i: Integer;
Exponent: Word;
d: PByte;
begin
d:=PByte(BigEndianDouble);
// convert ppc double to i386 extended
if (PCardinal(d)[0] or PCardinal(d)[1])=0 then begin
// 0
FillChar(LRSExtended^,10,#0);
end else begin
Exponent:=((d[0] and $7f) shl 4)+(d[1] shr 4);
inc(Exponent,$4000-$400);
if (d[0] and $80)>0 then
// signed
inc(Exponent,$8000);
e[9]:=Exponent shr 8;
e[8]:=Exponent and $ff;
e[7]:=($80 or (d[1] shl 3) or (d[2] shr 5)) and $ff;
for i:=3 to 7 do begin
e[9-i]:=((d[i-1] shl 3) or (d[i] shr 5)) and $ff;
end;
e[1]:=(d[7] shl 3) and $ff;
e[0]:=0;
System.Move(e[0],LRSExtended^,10);
end;
end;
procedure ConvertLEDoubleToLRSExtended(LEDouble, LRSExtended: Pointer);
type
TMantissaWrap = record
case boolean of
True: (Q: QWord);
False: (B: array[0..7] of Byte);
end;
TExpWrap = packed record
Mantissa: TMantissaWrap;
Exp: Word;
end;
var
Q: PQWord absolute LEDouble;
C: PCardinal absolute LEDouble;
W: PWord absolute LEDouble;
E: ^TExpWrap absolute LRSExtended;
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
Mantissa: TMantissaWrap;
{$endif}
begin
if W[3] and $7FF0 = $7FF0 // infinite or NaN
then E^.Exp := $7FFF
else E^.Exp := (W[3] and $7FFF) shr 4 - $3FF + $3FFF;
E^.Exp := E^.Exp or (W[3] and $8000); // sign
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
Mantissa.Q := (Q^ shl 11);
Mantissa.B[7] := Mantissa.B[7] or $80; // add ignored 1
System.Move(Mantissa, E^.Mantissa, 8);
{$else}
E^.Mantissa.Q := (Q^ shl 11);
E^.Mantissa.B[7] := E^.Mantissa.B[7] or $80; // add ignored 1
{$endif}
end;
function ReadLRSShortInt(s: TStream): shortint;
begin
Result:=0;
s.Read(Result,1);
end;
function ReadLRSByte(s: TStream): byte;
begin
Result:=0;
s.Read(Result,1);
end;
function ReadLRSWord(s: TStream): word;
begin
Result:=0;
s.Read(Result,2);
{$IFDEF FPC_BIG_ENDIAN}
Result:=((Result and $ff) shl 8) or (Result shr 8);
{$ENDIF}
end;
function ReadLRSSmallInt(s: TStream): smallint;
begin
Result:=0;
{$IFDEF FPC_BIG_ENDIAN}
Result:=smallint(ReadLRSWord(s));
{$ELSE}
s.Read(Result,2);
{$ENDIF}
end;
function ReadLRSInteger(s: TStream): integer;
begin
Result:=0;
s.Read(Result,4);
{$IFDEF FPC_BIG_ENDIAN}
ReverseBytes(@Result,4);
{$ENDIF}
end;
function ReadLRSCardinal(s: TStream): cardinal;
begin
Result:=0;
s.Read(Result,4);
{$IFDEF FPC_BIG_ENDIAN}
ReverseBytes(@Result,4);
{$ENDIF}
end;
function ReadLRSInt64(s: TStream): int64;
begin
Result:=0;
s.Read(Result,8);
{$IFDEF FPC_BIG_ENDIAN}
ReverseBytes(@Result,8);
{$ENDIF}
end;
function ReadLRSSingle(s: TStream): Single;
begin
Result:=0;
s.Read(Result,4);
{$IFDEF FPC_BIG_ENDIAN}
ReverseBytes(@Result,4);
{$ENDIF}
end;
function ReadLRSDouble(s: TStream): Double;
begin
Result:=0;
s.Read(Result,8);
{$IFDEF FPC_BIG_ENDIAN}
ReverseBytes(@Result,8);
{$ENDIF}
end;
function ReadLRSExtended(s: TStream): Extended;
begin
Result:=0;
{$IFDEF FPC_HAS_TYPE_EXTENDED}
s.Read(Result,10);
{$IFDEF FPC_BIG_ENDIAN}
ReverseBytes(@Result,10);
{$ENDIF}
{$ELSE}
// possible endian conversion is handled in ConvertLRSExtendedToDouble
Result:=ReadLRSEndianLittleExtendedAsDouble(s);
{$ENDIF}
end;
function ReadLRSCurrency(s: TStream): Currency;
begin
Result:=0;
s.Read(Result,8);
{$IFDEF FPC_BIG_ENDIAN}
ReverseBytes(@Result,8);
{$ENDIF}
end;
function ReadLRSWideString(s: TStream): WideString;
var
Len: LongInt;
begin
Len:=ReadLRSInteger(s);
SetLength(Result,Len);
if Len>0 then begin
s.Read(Result[1],Len*2);
{$IFDEF FPC_BIG_ENDIAN}
ReverseByteOrderInWords(PWord(@Result[1]),Len);
{$ENDIF}
end;
end;
function ReadLRSEndianLittleExtendedAsDouble(s: TStream): Double;
var
e: array[1..10] of byte;
begin
s.Read(e,10);
Result:=ConvertLRSExtendedToDouble(@e);
end;
function ReadLRSValueType(s: TStream): TValueType;
var
b: byte;
begin
s.Read(b,1);
Result:=TValueType(b);
end;
function ReadLRSInt64MB(s: TStream): int64;
var
v: TValueType;
begin
v:=ReadLRSValueType(s);
case v of
vaInt8: Result:=ReadLRSShortInt(s);
vaInt16: Result:=ReadLRSSmallInt(s);
vaInt32: Result:=ReadLRSInteger(s);
vaInt64: Result:=ReadLRSInt64(s);
else
raise EInOutError.Create('ordinal valuetype missing');
end;
end;
procedure WriteLRSReversedWord(s: TStream; w: word);
begin
w:=(w shr 8) or ((w and $ff) shl 8);
s.Write(w,2);
end;
procedure WriteLRS4BytesReversed(s: TStream; p: Pointer);
var
a: array[0..3] of char;
i: Integer;
begin
for i:=0 to 3 do
a[i]:=PChar(p)[3-i];
s.Write(a[0],4);
end;
procedure WriteLRS8BytesReversed(s: TStream; p: Pointer);
var
a: array[0..7] of char;
i: Integer;
begin
for i:=0 to 7 do
a[i]:=PChar(p)[7-i];
s.Write(a[0],8);
end;
procedure WriteLRS10BytesReversed(s: TStream; p: Pointer);
var
a: array[0..9] of char;
i: Integer;
begin
for i:=0 to 9 do
a[i]:=PChar(p)[9-i];
s.Write(a[0],10);
end;
procedure WriteLRSReversedWords(s: TStream; p: Pointer; Count: integer);
var
w: Word;
i: Integer;
begin
for i:=0 to Count-1 do begin
w:=PWord(P)[i];
w:=(w shr 8) or ((w and $ff) shl 8);
s.Write(w,2);
end;
end;
function FloatToLFMStr(const Value: extended; Precision, Digits: Integer): string;
var
P: Integer;
TooSmall, TooLarge: Boolean;
DeletePos: LongInt;
begin
Result:='';
If (Precision = -1) or (Precision > 15) then Precision := 15;
TooSmall := (Abs(Value) < 0.00001) and (Value>0.0);
if TooSmall then begin
P := 0;
TooLarge := False;
end
else begin
Str(Value:digits:precision, Result);
P := Pos('.', Result);
TooLarge :=(P > Precision + 1) or (Pos('E', Result)<>0);
End;
if TooSmall or TooLarge then begin
// use exponential format
Str(Value:Precision + 8, Result);
P:=4;
while (P>0) and (Digits < P) and (Result[Precision + 5] = '0') do begin
if P<>1 then
system.Delete(Result, Precision + 5, 1)
else
system.Delete(Result, Precision + 3, 3);
Dec(P);
end;
if Result[1] = ' ' then
System.Delete(Result, 1, 1);
// Strip unneeded zeroes.
P:=Pos('E',result)-1;
If P>=0 then begin
{ delete superfluous +? }
if result[p+2]='+' then
system.Delete(Result,P+2,1);
DeletePos:=p;
while (DeletePos>1) and (Result[DeletePos]='0') do
Dec(DeletePos);
if (DeletePos>0) and (Result[DeletePos]=DefaultFormatSettings.DecimalSeparator) Then
Dec(DeletePos);
if (DeletePos<p) then
system.Delete(Result,DeletePos,p-DeletePos);
end;
end
else if (P<>0) then begin
// we have a decimalseparator
P := Length(Result);
While (P>0) and (Result[P] = '0') Do
Dec(P);
If (P>0) and (Result[P]=DefaultFormatSettings.DecimalSeparator) Then
Dec(P);
SetLength(Result, P);
end;
end;
function CompareLRPositionLinkWithLFMPosition(Item1, Item2: Pointer): integer;
var
p1: Int64;
p2: Int64;
begin
p1:=PLRPositionLink(Item1)^.LFMPosition;
p2:=PLRPositionLink(Item2)^.LFMPosition;
if p1<p2 then
Result:=1
else if p1>p2 then
Result:=-1
else
Result:=0;
end;
function CompareLRPositionLinkWithLRSPosition(Item1, Item2: Pointer): integer;
var
p1: Int64;
p2: Int64;
begin
p1:=PLRPositionLink(Item1)^.LRSPosition;
p2:=PLRPositionLink(Item2)^.LRSPosition;
if p1<p2 then
Result:=1
else if p1>p2 then
Result:=-1
else
Result:=0;
end;
procedure RegisterPropertyToSkip(PersistentClass: TPersistentClass;
const PropertyName, Note, HelpKeyWord: string);
begin
PropertiesToSkip.Add(PersistentClass, PropertyName, Note, HelpKeyWord);
end;
procedure Register;
begin
RegisterComponents('System',[TLazComponentQueue]);
end;
procedure WriteLRSNull(s: TStream; Count: integer);
var
c: char;
i: Integer;
begin
c:=#0;
for i:=0 to Count-1 do
s.Write(c,1);
end;
procedure WriteLRSEndianBigDoubleAsEndianLittleExtended(s: TStream;
EndBigDouble: PByte);
var
e: array[0..9] of byte;
begin
ConvertEndianBigDoubleToLRSExtended(EndBigDouble,@e);
s.Write(e[0],10);
end;
procedure WriteLRSDoubleAsExtended(s: TStream; ADouble: PByte);
var
e: array[0..9] of byte;
begin
{$ifdef FPC_LITTLE_ENDIAN}
ConvertLEDoubleToLRSExtended(ADouble,@e);
{$else}
ConvertEndianBigDoubleToLRSExtended(ADouble,@e);
{$endif}
s.Write(e[0],10);
end;
procedure WriteLRSSmallInt(s: TStream; const i: SmallInt);
begin
{$IFDEF FPC_LITTLE_ENDIAN}
s.Write(i,2);
{$ELSE}
WriteLRSReversedWord(s,Word(i));
{$ENDIF}
end;
procedure WriteLRSWord(s: TStream; const w: word);
begin
{$IFDEF FPC_LITTLE_ENDIAN}
s.Write(w,2);
{$ELSE}
WriteLRSReversedWord(s,w);
{$ENDIF}
end;
procedure WriteLRSInteger(s: TStream; const i: integer);
begin
{$IFDEF FPC_LITTLE_ENDIAN}
s.Write(i,4);
{$ELSE}
WriteLRS4BytesReversed(s,@i);
{$ENDIF}
end;
procedure WriteLRSCardinal(s: TStream; const c: cardinal);
begin
{$IFDEF FPC_LITTLE_ENDIAN}
s.Write(c,4);
{$ELSE}
WriteLRS4BytesReversed(s,@c);
{$ENDIF}
end;
procedure WriteLRSSingle(s: TStream; const si: Single);
begin
{$IFDEF FPC_LITTLE_ENDIAN}
s.Write(si,4);
{$ELSE}
WriteLRS4BytesReversed(s,@si);
{$ENDIF}
end;
procedure WriteLRSDouble(s: TStream; const d: Double);
begin
{$IFDEF FPC_LITTLE_ENDIAN}
s.Write(d,8);
{$ELSE}
WriteLRS8BytesReversed(s,@d);
{$ENDIF}
end;
procedure WriteLRSExtended(s: TStream; const e: extended);
begin
{$IFDEF FPC_HAS_TYPE_EXTENDED}
{$IFDEF FPC_BIG_ENDIAN}
WriteLRS10BytesReversed(s, @e);
{$ELSE}
s.Write(e,10);
{$ENDIF}
{$ELSE}
WriteLRSDoubleAsExtended(s,pbyte(@e))
{$ENDIF}
end;
procedure WriteLRSInt64(s: TStream; const i: int64);
begin
{$IFDEF FPC_LITTLE_ENDIAN}
s.Write(i,8);
{$ELSE}
WriteLRS8BytesReversed(s,@i);
{$ENDIF}
end;
procedure WriteLRSCurrency(s: TStream; const c: Currency);
begin
{$IFDEF FPC_LITTLE_ENDIAN}
s.Write(c,8);
{$ELSE}
WriteLRS8BytesReversed(s,@c);
{$ENDIF}
end;
procedure WriteLRSWideStringContent(s: TStream; const w: WideString);
var
Size: Integer;
begin
Size:=length(w);
if Size=0 then exit;
{$IFDEF FPC_LITTLE_ENDIAN}
s.Write(w[1], Size * 2);
{$ELSE}
WriteLRSReversedWords(s,@w[1],Size);
{$ENDIF}
end;
procedure WriteLRSInt64MB(s: TStream; const Value: int64);
var
w: Word;
i: Integer;
b: Byte;
begin
// Use the smallest possible integer type for the given value:
if (Value >= -128) and (Value <= 127) then
begin
b:=byte(vaInt8);
s.Write(b, 1);
b:=byte(Value);
s.Write(b, 1);
end else if (Value >= -32768) and (Value <= 32767) then
begin
b:=byte(vaInt16);
s.Write(b, 1);
w:=Word(Value);
WriteLRSWord(s,w);
end else if (Value >= -$80000000) and (Value <= $7fffffff) then
begin
b:=byte(vaInt32);
s.Write(b, 1);
i:=Integer(Value);
WriteLRSInteger(s,i);
end else
begin
b:=byte(vaInt64);
s.Write(b, 1);
WriteLRSInt64(s,Value);
end;
end;
{ TLRSObjectReader }
procedure TLRSObjectReader.Read(var Buf; Count: LongInt);
var
CopyNow: LongInt;
Dest: Pointer;
begin
Dest := @Buf;
while Count > 0 do
begin
if FBufPos >= FBufEnd then
begin
FBufEnd := FStream.Read(FBuffer^, FBufSize);
if FBufEnd = 0 then
raise EReadError.Create('Read Error');
FBufPos := 0;
end;
CopyNow := FBufEnd - FBufPos;
if CopyNow > Count then
CopyNow := Count;
Move(PChar(FBuffer)[FBufPos], Dest^, CopyNow);
Inc(FBufPos, CopyNow);
Dest:=Dest+CopyNow;
Dec(Count, CopyNow);
end;
end;
procedure TLRSObjectReader.SkipProperty;
begin
{ Skip property name, then the property value }
ReadStr;
SkipValue;
end;
procedure TLRSObjectReader.SkipSetBody;
begin
while Length(ReadStr) > 0 do;
end;
procedure TLRSObjectReader.Push(ItemType: TLRSItemType; const AName: string;
Root: TComponent; PushCount: integer);
begin
if FStackPointer=FStackCapacity then begin
FStackCapacity:=FStackCapacity*2+10;
ReAllocMem(FStack,SizeOf(TLRSORStackItem)*FStackCapacity);
FillByte(FStack[FStackPointer],SizeOf(TLRSORStackItem)*(FStackCapacity-FStackPointer),0);
end;
//DebugLn(['TLRSObjectReader.Push AName=',AName,' Type=', GetEnumName(TypeInfo(TLRSItemType), Integer(ItemType)),' PushCount=',PushCount]);
FStack[FStackPointer].Name:=AName;
FStack[FStackPointer].ItemType:=ItemType;
FStack[FStackPointer].Root:=Root;
FStack[FStackPointer].PushCount:=PushCount;
FStack[FStackPointer].ItemNr:=-1;
inc(FStackPointer);
end;
procedure TLRSObjectReader.Pop;
var
Item: PLRSORStackItem;
begin
if FStackPointer=0 then
raise Exception.Create('Error: TLRSObjectReader.Pop stack is empty');
Item:=@FStack[FStackPointer-1];
//DebugLn(['TLRSObjectReader.Pop AName=',Item^.Name,
// ' Type=',GetEnumName(TypeInfo(TLRSItemType), Integer(item^.ItemType)),
// ' PushCount=',item^.PushCount,' StackPtr=', FStackPointer]);
if Item^.PushCount>1 then begin
// stack item still needs more EndList
dec(Item^.PushCount);
end else begin
// stack item is complete
dec(FStackPointer);
end;
end;
procedure TLRSObjectReader.ClearStack;
var
i: Integer;
begin
for i:=0 to FStackCapacity-1 do begin
FStack[i].Name:='';
end;
ReAllocMem(FStack,0);
end;
function TLRSObjectReader.InternalReadValue: TValueType;
var
b: byte;
begin
Result := vaNull; { Necessary in FPC as TValueType is larger than 1 byte! }
Read(b,1);
Result:=TValueType(b);
end;
function TLRSObjectReader.ReadIntegerContent: integer;
begin
Result:=0;
Read(Result,4);
{$ifdef FPC_BIG_ENDIAN}
ReverseBytes(@Result,4);
{$endif}
end;
constructor TLRSObjectReader.Create(AStream: TStream; BufSize: Integer);
begin
inherited Create;
FStream := AStream;
FBufSize := BufSize;
GetMem(FBuffer, BufSize);
end;
destructor TLRSObjectReader.Destroy;
begin
{ Seek back the amount of bytes that we didn't process until now: }
if Assigned(FStream) then
FStream.Seek(Integer(FBufPos) - Integer(FBufEnd), soFromCurrent);
if Assigned(FBuffer) then
FreeMem(FBuffer, FBufSize);
ClearStack;
inherited Destroy;
end;
function TLRSObjectReader.ReadValue: TValueType;
begin
Result := InternalReadValue;
case Result of
vaNull:
begin
EndPropertyIfOpen;
// End previous element collection, list or component.
if FStackPointer > 0 then
Pop;
end;
vaCollection:
begin
Push(lrsitCollection);
end;
vaList:
begin
// Increase counter for next collection item.
if (FStackPointer > 0) and (FStack[FStackPointer-1].ItemType = lrsitCollection) then
Inc(FStack[FStackPointer-1].ItemNr);
Push(lrsitList);
end;
end;
end;
function TLRSObjectReader.NextValue: TValueType;
begin
Result := InternalReadValue;
{ We only 'peek' at the next value, so seek back to unget the read value: }
Dec(FBufPos);
end;
procedure TLRSObjectReader.BeginRootComponent;
var
Signature: TFilerSignature;
begin
{ Read filer signature }
Signature:='1234';
Read(Signature[1],length(Signature));
if Signature <> FilerSignature then
raise EReadError.Create('Invalid Filer Signature');
end;
procedure TLRSObjectReader.BeginComponent(var Flags: TFilerFlags;
var AChildPos: Integer; var CompClassName, CompName: String);
var
Prefix: Byte;
ValueType: TValueType;
ItemName: String;
ItemRoot: TComponent;
begin
{ Every component can start with a special prefix: }
Flags := [];
if (Byte(NextValue) and $f0) = $f0 then
begin
Prefix := Byte(ReadValue);
if (ObjStreamMaskInherited and Prefix)<>0 then
Include(Flags,ffInherited);
if (ObjStreamMaskInline and Prefix)<>0 then
Include(Flags,ffInline);
if (ObjStreamMaskChildPos and Prefix)<>0 then
begin
Include(Flags,ffChildPos);
ValueType := ReadValue;
case ValueType of
vaInt8:
AChildPos := ReadInt8;
vaInt16:
AChildPos := ReadInt16;
vaInt32:
AChildPos := ReadInt32;
else
PropValueError;
end;
end;
end;
CompClassName := ReadStr;
CompName := ReadStr;
// Top component is addressed by ClassName.
if FStackPointer = 0 then
begin
ItemName := CompClassName;
ItemRoot := nil;
end
else
begin
ItemName := CompName;
if Assigned(Reader) then
// Reader.LookupRoot is the current Root component.
ItemRoot := Reader.LookupRoot
else
ItemRoot := nil;
end;
// A component has two lists: properties and childs, hence PopCount=2.
Push(lrsitComponent, ItemName, ItemRoot, 2);
end;
function TLRSObjectReader.BeginProperty: String;
begin
EndPropertyIfOpen;
Result := ReadStr;
Push(lrsitProperty, Result);
end;
procedure TLRSObjectReader.EndPropertyIfOpen;
begin
// End previous property.
if (FStackPointer > 0) and (FStack[FStackPointer-1].ItemType = lrsitProperty) then
Pop;
end;
function TLRSObjectReader.GetStackPath: string;
var
i: Integer;
CurName: string;
Item: PLRSORStackItem;
begin
Result:='';
for i:=0 to FStackPointer-1 do
begin
Item := @FStack[i];
// Reader.Root is the top component in the module.
if Assigned(Reader) and
(Item^.ItemType = lrsitComponent) and
(Item^.Root = Reader.Root) and
(Item^.Root <> nil) then
begin
// Restart path from top component.
Result := Item^.Root.ClassName;
end;
CurName:=Item^.Name;
if CurName<>'' then begin
if Result<>'' then Result:=Result+'.';
Result:=Result+CurName;
end;
if Item^.ItemNr >= 0 then
Result := Result + '[' + IntToStr(Item^.ItemNr) + ']';
end;
end;
procedure TLRSObjectReader.ReadBinary(const DestData: TMemoryStream);
var
BinSize: LongInt;
begin
BinSize:=ReadIntegerContent;
DestData.Size := BinSize;
Read(DestData.Memory^, BinSize);
end;
function TLRSObjectReader.ReadFloat: Extended;
{$ifndef FPC_HAS_TYPE_EXTENDED}
var
e: array[1..10] of byte;
{$endif}
begin
Result:=0;
{$ifdef FPC_HAS_TYPE_EXTENDED}
Read(Result, 10);
{$ifdef FPC_BIG_ENDIAN}
ReverseBytes(@Result, 10);
{$endif FPC_BIG_ENDIAN}
{$else FPC_HAS_TYPE_EXTENDED}
Read(e, 10);
Result := ConvertLRSExtendedToDouble(@e);
{$endif FPC_HAS_TYPE_EXTENDED}
end;
function TLRSObjectReader.ReadSingle: Single;
begin
Result:=0;
Read(Result, 4);
{$ifdef FPC_BIG_ENDIAN}
ReverseBytes(@Result,4);
{$endif}
end;
function TLRSObjectReader.ReadCurrency: Currency;
begin
Result:=0;
Read(Result, 8);
{$ifdef FPC_BIG_ENDIAN}
ReverseBytes(@Result,8);
{$endif}
end;
function TLRSObjectReader.ReadDate: TDateTime;
begin
Result:=0;
Read(Result, 8);
{$ifdef FPC_BIG_ENDIAN}
ReverseBytes(@Result,8);
{$endif}
end;
function TLRSObjectReader.ReadIdent(ValueType: TValueType): String;
var
b: Byte;
begin
case ValueType of
vaIdent:
begin
Read(b, 1);
SetLength(Result, b);
if ( b > 0 ) then
Read(Result[1], b);
end;
vaNil:
Result := 'nil';
vaFalse:
Result := 'False';
vaTrue:
Result := 'True';
vaNull:
Result := 'Null';
else
Result:='';
RaiseGDBException('');
end;
end;
function TLRSObjectReader.ReadInt8: ShortInt;
begin
Result:=0;
Read(Result, 1);
end;
function TLRSObjectReader.ReadInt16: SmallInt;
begin
Result:=0;
Read(Result, 2);
{$ifdef FPC_BIG_ENDIAN}
ReverseBytes(@Result,2);
{$endif}
end;
function TLRSObjectReader.ReadInt32: LongInt;
begin
Result:=0;
Read(Result, 4);
{$ifdef FPC_BIG_ENDIAN}
ReverseBytes(@Result,4);
{$endif}
end;
function TLRSObjectReader.ReadInt64: Int64;
begin
Result:=0;
Read(Result, 8);
{$ifdef FPC_BIG_ENDIAN}
ReverseBytes(@Result,8);
{$endif}
end;
function TLRSObjectReader.ReadSet(EnumType: Pointer): Integer;
type
tset = set of 0..31;
var
OName: String;
OValue: Integer;
begin
try
Result := 0;
while True do
begin
OName := ReadStr;
if Length(OName) = 0 then
break;
OValue := GetEnumValue(PTypeInfo(EnumType), OName);
// Eg. "Options" is a set and can give an error when changing component type.
// Do nothing on error (OValue = -1), was PropValueError; (JuMa)
if OValue >= 0 then
include(tset(result),OValue);
end;
except
SkipSetBody;
raise;
end;
end;
procedure TLRSObjectReader.ReadSignature;
begin
end;
function TLRSObjectReader.ReadStr: String;
var
b: Byte;
begin
Read(b, 1);
SetLength(Result, b);
if b > 0 then
Read(Result[1], b);
end;
function TLRSObjectReader.ReadString(StringType: TValueType): String;
var
i: Integer;
b: byte;
begin
case StringType of
vaString:
begin
Read(b, 1);
i:=b;
end;
vaLString:
i:=ReadIntegerContent;
else
raise Exception.Create('TLRSObjectReader.ReadString invalid StringType');
end;
SetLength(Result, i);
if i > 0 then
Read(Pointer(@Result[1])^, i);
end;
function TLRSObjectReader.ReadWideString: WideString;
var
i: Integer;
begin
i:=ReadIntegerContent;
SetLength(Result, i);
if i > 0 then
Read(Pointer(@Result[1])^, i*2);
//debugln('TLRSObjectReader.ReadWideString ',Result);
end;
function TLRSObjectReader.ReadUnicodeString: UnicodeString;
var
i: Integer;
begin
i:=ReadIntegerContent;
SetLength(Result, i);
if i > 0 then
Read(Pointer(@Result[1])^, i*2);
//debugln('TLRSObjectReader.ReadWideString ',Result);
end;
procedure TLRSObjectReader.SkipComponent(SkipComponentInfos: Boolean);
var
Flags: TFilerFlags;
Dummy: Integer;
CompClassName, CompName: String;
begin
if SkipComponentInfos then
{ Skip prefix, component class name and component object name }
BeginComponent(Flags, Dummy, CompClassName, CompName);
{ Skip properties }
while NextValue <> vaNull do
SkipProperty;
ReadValue;
{ Skip children }
while NextValue <> vaNull do
SkipComponent(True);
ReadValue;
end;
procedure TLRSObjectReader.SkipValue;
procedure SkipBytes(Count: LongInt);
var
Dummy: array[0..1023] of Byte;
SkipNow: Integer;
begin
while Count > 0 do
begin
if Count > 1024 then
SkipNow := 1024
else
SkipNow := Count;
Read(Dummy, SkipNow);
Dec(Count, SkipNow);
end;
end;
var
Count: LongInt;
begin
case ReadValue of
vaNull, vaFalse, vaTrue, vaNil: ;
vaList:
begin
while NextValue <> vaNull do
SkipValue;
ReadValue;
end;
vaInt8:
SkipBytes(1);
vaInt16:
SkipBytes(2);
vaInt32:
SkipBytes(4);
vaExtended:
SkipBytes(10);
vaString, vaIdent:
ReadStr;
vaBinary, vaLString:
begin
Count:=ReadIntegerContent;
SkipBytes(Count);
end;
vaWString, vaUString:
begin
Count:=ReadIntegerContent;
SkipBytes(Count*2);
end;
vaSet:
SkipSetBody;
vaCollection:
begin
while NextValue <> vaNull do
begin
{ Skip the order value if present }
if NextValue in [vaInt8, vaInt16, vaInt32] then
SkipValue;
SkipBytes(1);
while NextValue <> vaNull do
SkipProperty;
ReadValue;
end;
ReadValue;
end;
vaSingle:
SkipBytes(4);
vaCurrency:
SkipBytes(SizeOf(Currency));
vaDate:
SkipBytes(8);
vaInt64:
SkipBytes(8);
else
RaiseGDBException('TLRSObjectReader.SkipValue unknown valuetype');
end;
end;
{ TLRSObjectWriter }
procedure TLRSObjectWriter.Push(ItemType: TLRSItemType; const AName: string;
Root: TComponent; PushCount: integer;
SkipIfEmpty: boolean);
begin
if FStackPointer=FStackCapacity then begin
FStackCapacity:=FStackCapacity*2+10;
ReAllocMem(FStack,SizeOf(TLRSOWStackItem)*FStackCapacity);
FillByte(FStack[FStackPointer],SizeOf(TLRSOWStackItem)*(FStackCapacity-FStackPointer),0);
end;
//if AName<>'' then DebugLn(['TLRSObjectWriter.Push AName=',AName, ' Type=', GetEnumName(TypeInfo(TLRSItemType), Integer(ItemType)),' PushCount=',PushCount,' SkipIfEmpty=',SkipIfEmpty]);
FStack[FStackPointer].Name:=AName;
FStack[FStackPointer].ItemType:=ItemType;
FStack[FStackPointer].Root:=Root;
FStack[FStackPointer].PushCount:=PushCount;
FStack[FStackPointer].ItemNr:=-1;
FStack[FStackPointer].SkipIfEmpty:=SkipIfEmpty;
FStack[FStackPointer].BufCount:=0;
if SkipIfEmpty then
FStack[FStackPointer].State:=lrsowsisStarted
else begin
FlushStackToStream;
FStack[FStackPointer].State:=lrsowsisDataWritten;
end;
inc(FStackPointer);
end;
procedure TLRSObjectWriter.EndHeader;
var
Item: PLRSOWStackItem;
begin
Item:=@FStack[FStackPointer-1];
if Item^.State=lrsowsisStarted then
Item^.State:=lrsowsisHeaderWritten;
end;
procedure TLRSObjectWriter.Pop(WriteNull: boolean);
var
Item: PLRSOWStackItem;
begin
if FStackPointer=0 then
raise Exception.Create('Error: TLRSObjectWriter.Pop stack is empty');
Item:=@FStack[FStackPointer-1];
if Item^.PushCount>1 then begin
// stack item still needs more EndList
dec(Item^.PushCount);
if WriteNull then begin
if Item^.State=lrsowsisHeaderWritten then begin
// no data yet, append EndList to header
Item^.State:=lrsowsisStarted;
WriteValue(vaNull);
// wait again for data
Item^.State:=lrsowsisHeaderWritten;
end else begin
// write EndList to stream
WriteValue(vaNull);
end;
end;
end else begin
// stack item is complete
dec(FStackPointer);
//if Item^.BufCount>0 then DebugLn(['TLRSObjectWriter.Pop SKIPPED: ',Item^.Name]);
if (Item^.State=lrsowsisDataWritten) and WriteNull then
WriteValue(vaNull);
end;
end;
procedure TLRSObjectWriter.ClearStack;
var
i: Integer;
begin
for i:=0 to FStackCapacity-1 do begin
FStack[i].Name:='';
ReAllocMem(FStack[i].Buffer,0);
end;
ReAllocMem(FStack,0);
end;
procedure TLRSObjectWriter.FlushStackToStream;
var
i: Integer;
Item: PLRSOWStackItem;
begin
for i:=0 to FStackPointer-1 do begin
Item:=@FStack[i];
if Item^.State<>lrsowsisDataWritten then begin
//DebugLn(['TLRSObjectWriter.Write FLUSH from stack to stream']);
Item^.State:=lrsowsisDataWritten;
WriteToStream(Item^.Buffer^,Item^.BufCount);
Item^.BufCount:=0;
end;
end;
end;
procedure TLRSObjectWriter.WriteToStream(const Buffer; Count: Longint);
var
CopyNow: LongInt;
SourceBuf: PChar;
begin
//DebugLn(['TLRSObjectWriter.WriteToStream ',dbgMemRange(@Buffer,Count,80)]);
if Count<2*FBufSize then begin
// write a small amount of data
SourceBuf:=@Buffer;
while Count > 0 do
begin
CopyNow := Count;
if CopyNow > FBufSize - FBufPos then
CopyNow := FBufSize - FBufPos;
Move(SourceBuf^, PChar(FBuffer)[FBufPos], CopyNow);
Dec(Count, CopyNow);
Inc(FBufPos, CopyNow);
SourceBuf:=SourceBuf+CopyNow;
if FBufPos = FBufSize then
FlushBuffer;
end;
end else begin
// write a big amount of data
if FBufPos>0 then
FlushBuffer;
FStream.WriteBuffer(Buffer, Count);
end;
end;
procedure TLRSObjectWriter.FlushBuffer;
begin
FStream.WriteBuffer(FBuffer^, FBufPos);
FBufPos := 0;
end;
procedure TLRSObjectWriter.Write(const Buffer; Count: Longint);
var
Item: PLRSOWStackItem;
begin
if Count=0 then exit;
if (FStackPointer>0) then
begin
Item:=@FStack[FStackPointer-1];
case Item^.State of
lrsowsisStarted:
begin
// store data on stack
//DebugLn(['TLRSObjectWriter.Write STORE data on stack']);
if Item^.BufCount+Count>Item^.BufCapacity then
begin
Item^.BufCapacity:=Item^.BufCount+Count+10;
ReAllocMem(Item^.Buffer,Item^.BufCapacity);
end;
System.Move(Buffer,PByte(Item^.Buffer)[Item^.BufCount],Count);
inc(Item^.BufCount,Count);
exit;
end;
lrsowsisHeaderWritten:
begin
// flush header(s) from stack to stream
FlushStackToStream;
end;
end;
end;
// write data to stream
WriteToStream(Buffer,Count);
end;
procedure TLRSObjectWriter.WriteValue(Value: TValueType);
var
b: byte;
begin
b:=byte(Value);
Write(b, 1);
end;
procedure TLRSObjectWriter.WriteStr(const Value: String);
var
i: Integer;
b: Byte;
begin
i := Length(Value);
if i > 255 then
i := 255;
b:=byte(i);
Write(b,1);
if i > 0 then
Write(Value[1], i);
end;
procedure TLRSObjectWriter.WriteIntegerContent(i: integer);
begin
{$IFDEF FPC_BIG_ENDIAN}
ReverseBytes(@i,4);
{$ENDIF}
Write(i,4);
end;
procedure TLRSObjectWriter.WriteWordContent(w: word);
begin
{$IFDEF FPC_BIG_ENDIAN}
ReverseBytes(@w,2);
{$ENDIF}
Write(w,2);
end;
procedure TLRSObjectWriter.WriteInt64Content(i: int64);
begin
{$IFDEF FPC_BIG_ENDIAN}
ReverseBytes(@i,8);
{$ENDIF}
Write(i,8);
end;
procedure TLRSObjectWriter.WriteSingleContent(s: single);
begin
{$IFDEF FPC_BIG_ENDIAN}
ReverseBytes(@s,4);
{$ENDIF}
Write(s,4);
end;
procedure TLRSObjectWriter.WriteDoubleContent(d: Double);
begin
{$IFDEF FPC_BIG_ENDIAN}
ReverseBytes(@d,8);
{$ENDIF}
Write(d,8);
end;
procedure TLRSObjectWriter.WriteExtendedContent(e: Extended);
{$IFNDEF FPC_HAS_TYPE_EXTENDED}
var
LRSExtended: array[1..10] of byte;
{$endif}
begin
{$IFDEF FPC_HAS_TYPE_EXTENDED}
{$IFDEF FPC_BIG_ENDIAN}
ReverseBytes(@e,10);
{$ENDIF}
Write(e,10);
{$ELSE}
{$IFDEF FPC_BIG_ENDIAN}
ConvertEndianBigDoubleToLRSExtended(@e,@LRSExtended);
{$ELSE}
ConvertLEDoubleToLRSExtended(@e,@LRSExtended);
{$ENDIF}
Write(LRSExtended,10);
{$ENDIF}
end;
procedure TLRSObjectWriter.WriteCurrencyContent(c: Currency);
begin
{$IFDEF FPC_BIG_ENDIAN}
ReverseBytes(@c,8);
{$ENDIF}
Write(c,8);
end;
procedure TLRSObjectWriter.WriteWideStringContent(const ws: WideString);
begin
if ws='' then exit;
{$IFDEF FPC_BIG_ENDIAN}
WriteWordsReversed(PWord(@ws[1]),length(ws));
{$ELSE}
Write(ws[1],length(ws)*2);
{$ENDIF}
end;
procedure TLRSObjectWriter.WriteWordsReversed(p: PWord; Count: integer);
var
i: Integer;
w: Word;
begin
for i:=0 to Count-1 do begin
w:=p[i];
w:=((w and $ff) shl 8) or (w and $ff);
Write(w,2);
end;
end;
procedure TLRSObjectWriter.WriteNulls(Count: integer);
var
c: Char;
i: Integer;
begin
c:=#0;
for i:=0 to Count-1 do Write(c,1);
end;
constructor TLRSObjectWriter.Create(Stream: TStream; BufSize: Integer);
begin
inherited Create;
FStream := Stream;
FBufSize := BufSize;
GetMem(FBuffer, BufSize);
end;
destructor TLRSObjectWriter.Destroy;
begin
// Flush all data which hasn't been written yet
if Assigned(FStream) then
FlushBuffer;
if Assigned(FBuffer) then begin
FreeMem(FBuffer, FBufSize);
FBuffer:=nil;
end;
ClearStack;
inherited Destroy;
end;
procedure TLRSObjectWriter.BeginCollection;
begin
//DebugLn(['TLRSObjectWriter.BeginCollection ',FStackPointer]);
Push(lrsitCollection);
WriteValue(vaCollection);
end;
procedure TLRSObjectWriter.BeginComponent(Component: TComponent;
Flags: TFilerFlags; ChildPos: Integer);
var
Prefix: Byte;
CanBeOmitted: boolean;
ItemName: String;
ItemRoot: TComponent;
begin
//DebugLn(['TLRSObjectWriter.BeginComponent ',FStackPointer]);
// an inherited child component can be omitted if empty
CanBeOmitted:=(not WriteEmptyInheritedChilds)
and (FStackPointer>0) and (ffInherited in Flags)
and (not (ffChildPos in Flags));
// Top component is addressed by ClassName.
if FStackPointer = 0 then
begin
ItemName := Component.ClassName;
ItemRoot := nil;
end
else
begin
ItemName := Component.Name;
if Assigned(Writer) then
// Writer.Root is the current Root component.
ItemRoot := Writer.Root
else
ItemRoot := nil;
end;
// A component has two lists: properties and childs, hence PopCount=2.
Push(lrsitComponent, ItemName, ItemRoot, 2, CanBeOmitted);
if not FSignatureWritten then
begin
Write(FilerSignature[1], length(FilerSignature));
FSignatureWritten := True;
end;
{ Only write the flags if they are needed! }
if Flags <> [] then
begin
Prefix := $f0;
if ffInherited in Flags then
inc(Prefix,ObjStreamMaskInherited);
if ffInline in Flags then
inc(Prefix,ObjStreamMaskInline);
if ffChildPos in Flags then
inc(Prefix,ObjStreamMaskChildPos);
Write(Prefix, 1);
if ffChildPos in Flags then
WriteInteger(ChildPos);
end;
WriteStr(Component.ClassName);
WriteStr(Component.Name);
EndHeader;
end;
procedure TLRSObjectWriter.WriteSignature;
begin
end;
procedure TLRSObjectWriter.BeginList;
begin
// Increase counter for next collection item.
if (FStackPointer > 0) and (FStack[FStackPointer-1].ItemType = lrsitCollection) then
Inc(FStack[FStackPointer-1].ItemNr);
//DebugLn(['TLRSObjectWriter.BeginList ',FStackPointer]);
Push(lrsitList);
WriteValue(vaList);
end;
procedure TLRSObjectWriter.EndList;
begin
//DebugLn(['TLRSObjectWriter.EndList ',FStackPointer]);
Pop(true);
end;
procedure TLRSObjectWriter.BeginProperty(const PropName: String);
begin
//DebugLn(['TLRSObjectWriter.BeginProperty ',FStackPointer,' ',PropName]);
Push(lrsitProperty, PropName);
WriteStr(PropName);
end;
procedure TLRSObjectWriter.EndProperty;
begin
//DebugLn(['TLRSObjectWriter.EndProperty ',FStackPointer]);
Pop(false);
end;
function TLRSObjectWriter.GetStackPath: string;
var
i: Integer;
CurName: string;
Item: PLRSOWStackItem;
begin
Result:='';
for i:=0 to FStackPointer-1 do
begin
Item := @FStack[i];
// Writer.LookupRoot is the top component in the module.
if Assigned(Writer) and
(Item^.ItemType = lrsitComponent) and
(Item^.Root = Writer.LookupRoot) and
(Item^.Root <> nil) then
begin
// Restart path from top component.
Result := Item^.Root.ClassName;
end;
CurName:=Item^.Name;
if CurName<>'' then begin
if Result<>'' then Result:=Result+'.';
Result:=Result+CurName;
end;
if Item^.ItemNr >= 0 then
Result := Result + '[' + IntToStr(Item^.ItemNr) + ']';
end;
end;
procedure TLRSObjectWriter.WriteBinary(const Buffer; Count: LongInt);
begin
WriteValue(vaBinary);
WriteIntegerContent(Count);
Write(Buffer, Count);
end;
procedure TLRSObjectWriter.WriteBoolean(Value: Boolean);
begin
if Value then
WriteValue(vaTrue)
else
WriteValue(vaFalse);
end;
procedure TLRSObjectWriter.WriteFloat(const Value: Extended);
begin
WriteValue(vaExtended);
WriteExtendedContent(Value);
end;
procedure TLRSObjectWriter.WriteSingle(const Value: Single);
begin
WriteValue(vaSingle);
WriteSingleContent(Value);
end;
procedure TLRSObjectWriter.WriteCurrency(const Value: Currency);
begin
WriteValue(vaCurrency);
WriteCurrencyContent(Value);
end;
procedure TLRSObjectWriter.WriteDate(const Value: TDateTime);
begin
WriteValue(vaDate);
WriteDoubleContent(Value);
end;
procedure TLRSObjectWriter.WriteIdent(const Ident: string);
begin
{ Check if Ident is a special identifier before trying to just write
Ident directly }
if UpperCase(Ident) = 'NIL' then
WriteValue(vaNil)
else if UpperCase(Ident) = 'FALSE' then
WriteValue(vaFalse)
else if UpperCase(Ident) = 'TRUE' then
WriteValue(vaTrue)
else if UpperCase(Ident) = 'NULL' then
WriteValue(vaNull) else
begin
WriteValue(vaIdent);
WriteStr(Ident);
end;
end;
procedure TLRSObjectWriter.WriteInteger(Value: Int64);
var
w: Word;
i: Integer;
b: Byte;
begin
//debugln('TLRSObjectWriter.WriteInteger Value=',Value);
// Use the smallest possible integer type for the given value:
if (Value >= -128) and (Value <= 127) then
begin
WriteValue(vaInt8);
b:=Byte(Value);
Write(b, 1);
end else if (Value >= -32768) and (Value <= 32767) then
begin
WriteValue(vaInt16);
w:=Word(Value);
WriteWordContent(w);
end else if (Value >= -$80000000) and (Value <= $7fffffff) then
begin
WriteValue(vaInt32);
i:=Integer(Value);
WriteIntegerContent(i);
end else
begin
WriteValue(vaInt64);
WriteInt64Content(Value);
end;
end;
procedure TLRSObjectWriter.WriteMethodName(const Name: String);
begin
if Length(Name) > 0 then
begin
WriteValue(vaIdent);
WriteStr(Name);
end else
WriteValue(vaNil);
end;
procedure TLRSObjectWriter.WriteSet(Value: LongInt; SetType: Pointer);
type
tset = set of 0..31;
var
i: Integer;
begin
WriteValue(vaSet);
for i := 0 to 31 do
begin
if (i in tset(Value)) then
WriteStr(GetEnumName(PTypeInfo(SetType), i));
end;
WriteStr('');
end;
procedure TLRSObjectWriter.WriteString(const Value: TLazObjectWriterString);
var
i: Integer;
b: Byte;
begin
i := Length(Value);
if i <= 255 then
begin
WriteValue(vaString);
b:=byte(i);
Write(b, 1);
end else
begin
WriteValue(vaLString);
WriteIntegerContent(i);
end;
if i > 0 then
Write(Value[1], i);
end;
procedure TLRSObjectWriter.WriteWideString(const Value: WideString);
var
i: Integer;
begin
WriteValue(vaWString);
i := Length(Value);
WriteIntegerContent(i);
WriteWideStringContent(Value);
end;
procedure TLRSObjectWriter.WriteUnicodeString(const Value: UnicodeString);
var
i: Integer;
begin
WriteValue(vaUString);
i := Length(Value);
WriteIntegerContent(i);
WriteWideStringContent(Value);
end;
procedure TLRSObjectWriter.WriteVariant(const Value: Variant);
begin
case VarType(Value) of
varnull:
WriteValue(vaNull);
varsmallint, varinteger, varshortint, varint64, varbyte, varword, varlongword, varqword:
WriteInteger(Value);
varsingle:
WriteSingle(Value);
vardouble:
WriteFloat(Value);
vardate:
WriteDate(Value);
varcurrency:
WriteCurrency(Value);
varolestr, varstring:
WriteString(String(Value));
varboolean:
WriteBoolean(Value);
else
WriteValue(vaNil);
end;
end;
{ TLRPositionLinks }
function TLRPositionLinks.GetLFM(Index: integer): Int64;
begin
Result:=PLRPositionLink(FItems[Index])^.LFMPosition;
end;
function TLRPositionLinks.GetData(Index: integer): Pointer;
begin
Result:=PLRPositionLink(FItems[Index])^.Data;
end;
function TLRPositionLinks.GetLRS(Index: integer): Int64;
begin
Result:=PLRPositionLink(FItems[Index])^.LRSPosition;
end;
procedure TLRPositionLinks.SetCount(const AValue: integer);
var
i: LongInt;
Item: PLRPositionLink;
begin
if FCount=AValue then exit;
// free old items
for i:=AValue to FCount-1 do begin
Item:=PLRPositionLink(FItems[i]);
Dispose(Item);
end;
// create new items
FItems.Count:=AValue;
for i:=FCount to AValue-1 do begin
New(Item);
Item^.LFMPosition:=-1;
Item^.LRSPosition:=-1;
Item^.Data:=nil;
FItems[i]:=Item;
end;
FCount:=AValue;
end;
procedure TLRPositionLinks.SetData(Index: integer; const AValue: Pointer);
begin
PLRPositionLink(FItems[Index])^.Data:=AValue;
end;
procedure TLRPositionLinks.SetLFM(Index: integer; const AValue: Int64);
begin
PLRPositionLink(FItems[Index])^.LFMPosition:=AValue;
end;
procedure TLRPositionLinks.SetLRS(Index: integer; const AValue: Int64);
begin
PLRPositionLink(FItems[Index])^.LRSPosition:=AValue;
end;
constructor TLRPositionLinks.Create;
begin
FItems:=TFPList.Create;
end;
destructor TLRPositionLinks.Destroy;
begin
Count:=0;
FItems.Free;
inherited Destroy;
end;
procedure TLRPositionLinks.Clear;
begin
Count:=0;
end;
procedure TLRPositionLinks.Sort(LFMPositions: Boolean);
begin
if LFMPositions then
FItems.Sort(@CompareLRPositionLinkWithLFMPosition)
else
FItems.Sort(@CompareLRPositionLinkWithLRSPosition)
end;
function TLRPositionLinks.IndexOf(const Position: int64; LFMPositions: Boolean
): integer;
var
l, r, m: integer;
p: Int64;
begin
// binary search for the line
l:=0;
r:=FCount-1;
while r>=l do begin
m:=(l+r) shr 1;
if LFMPositions then
p:=PLRPositionLink(FItems[m])^.LFMPosition
else
p:=PLRPositionLink(FItems[m])^.LRSPosition;
if p>Position then begin
// too high, search lower
r:=m-1;
end else if p<Position then begin
// too low, search higher
l:=m+1;
end else begin
// position found
Result:=m;
exit;
end;
end;
Result:=-1;
end;
function TLRPositionLinks.IndexOfRange(const FromPos, ToPos: int64;
LFMPositions: Boolean): integer;
var
l, r, m: integer;
p: Int64;
Item: PLRPositionLink;
begin
// binary search for the line
l:=0;
r:=FCount-1;
while r>=l do begin
m:=(l+r) shr 1;
Item:=PLRPositionLink(FItems[m]);
if LFMPositions then
p:=Item^.LFMPosition
else
p:=Item^.LRSPosition;
if p>=ToPos then begin
// too high, search lower
r:=m-1;
end else if p<FromPos then begin
// too low, search higher
l:=m+1;
end else begin
// position found
Result:=m;
exit;
end;
end;
Result:=-1;
end;
procedure TLRPositionLinks.SetPosition(const FromPos, ToPos, MappedPos: int64;
LFMtoLRSPositions: Boolean);
var
i: LongInt;
begin
i:=IndexOfRange(FromPos,ToPos,LFMtoLRSPositions);
if i>=0 then
if LFMtoLRSPositions then
PLRPositionLink(FItems[i])^.LRSPosition:=MappedPos
else
PLRPositionLink(FItems[i])^.LFMPosition:=MappedPos;
end;
procedure TLRPositionLinks.Add(const LFMPos, LRSPos: Int64; AData: Pointer);
var
Item: PLRPositionLink;
begin
Count:=Count+1;
Item:=PLRPositionLink(FItems[Count-1]);
Item^.LFMPosition:=LFMPos;
Item^.LRSPosition:=LRSPos;
Item^.Data:=AData;
end;
{ TCustomLazComponentQueue }
function TCustomLazComponentQueue.ReadComponentSize(out ComponentSize,
SizeLength: int64): Boolean;
// returns true if there are enough bytes to read the ComponentSize
// and returns the ComponentSize
// and returns the size (SizeLength) needed to store the ComponentSize
procedure ReadBytes(var p);
var a: array[1..9] of byte;
begin
FQueue.Top(a[1],1+SizeLength);
System.Move(a[2],p,SizeLength);
{$IFDEF FPC_BIG_ENDIAN}
ReverseBytes(@p,SizeLength);
{$ENDIF}
end;
var
v8: ShortInt;
v16: SmallInt;
v32: Integer;
v64: int64;
vt: TValueType;
begin
Result:=false;
// check if there are enough bytes
if (FQueue.Size<2) then exit;
FQueue.Top(vt,1);
case vt of
vaInt8: SizeLength:=1;
vaInt16: SizeLength:=2;
vaInt32: SizeLength:=4;
vaInt64: SizeLength:=8;
else
raise EInOutError.Create('Invalid size type');
end;
if FQueue.Size<1+SizeLength then exit; // need more data
// read the ComponentSize
Result:=true;
case vt of
vaInt8:
begin
ReadBytes(v8);
ComponentSize:=v8;
end;
vaInt16:
begin
ReadBytes(v16);
ComponentSize:=v16;
end;
vaInt32:
begin
ReadBytes(v32);
ComponentSize:=v32;
end;
vaInt64:
begin
ReadBytes(v64);
ComponentSize:=v64;
end;
end;
inc(SizeLength);
if ComponentSize<0 then
raise EInOutError.Create('Size of data in queue is negative');
end;
constructor TCustomLazComponentQueue.Create(TheOwner: TComponent);
begin
inherited Create(TheOwner);
FQueue:=TDynamicDataQueue.Create;
end;
destructor TCustomLazComponentQueue.Destroy;
begin
FreeAndNil(FQueue);
inherited Destroy;
end;
procedure TCustomLazComponentQueue.Clear;
begin
FQueue.Clear;
end;
function TCustomLazComponentQueue.Write(const Buffer; Count: Longint): Longint;
begin
Result:=FQueue.Push(Buffer,Count);
end;
function TCustomLazComponentQueue.CopyFrom(AStream: TStream; Count: Longint
): Longint;
begin
Result:=FQueue.Push(AStream,Count);
end;
function TCustomLazComponentQueue.HasComponent: Boolean;
var
ComponentSize, SizeLength: int64;
begin
if not ReadComponentSize(ComponentSize,SizeLength) then exit(false);
Result:=FQueue.Size-SizeLength>=ComponentSize;
end;
function TCustomLazComponentQueue.ReadComponent(var AComponent: TComponent;
NewOwner: TComponent): Boolean;
var
ComponentSize, SizeLength: int64;
AStream: TMemoryStream;
begin
Result:=false;
if not ReadComponentSize(ComponentSize,SizeLength) then exit;
if (FQueue.Size-SizeLength<ComponentSize) then exit;
// a complete component is in the buffer -> copy it to a stream
AStream:=TMemoryStream.Create;
try
// copy component to stream
AStream.Size:=SizeLength+ComponentSize;
FQueue.Pop(AStream,SizeLength+ComponentSize);
// create/read the component
AStream.Position:=SizeLength;
ReadComponentFromBinaryStream(AStream,AComponent,
OnFindComponentClass,NewOwner);
finally
AStream.Free;
end;
Result:=true;
end;
function TCustomLazComponentQueue.ConvertComponentAsString(AComponent: TComponent
): string;
var
AStream: TMemoryStream;
ComponentSize: Int64;
LengthSize: Int64;
begin
// write component to stream
AStream:=TMemoryStream.Create;
try
WriteComponentAsBinaryToStream(AStream,AComponent);
ComponentSize:=AStream.Size;
WriteLRSInt64MB(AStream,ComponentSize);
LengthSize:=AStream.Size-ComponentSize;
//debugln('TCustomLazComponentQueue.ConvertComponentAsString ComponentSize=',ComponentSize,' LengthSize=',LengthSize);
SetLength(Result,AStream.Size);
// write size
AStream.Position:=ComponentSize;
AStream.Read(Result[1],LengthSize);
//debugln('TCustomLazComponentQueue.ConvertComponentAsString ',hexstr(ord(Result[1]),2),' ',hexstr(ord(Result[2]),2),' ',hexstr(ord(Result[3]),2),' ',hexstr(ord(Result[4]),2));
// write component
AStream.Position:=0;
AStream.Read(Result[LengthSize+1],ComponentSize);
finally
AStream.Free;
end;
end;
{ TLazarusResourceStream }
procedure TLazarusResourceStream.Initialize(Name, ResType: PChar);
begin
if ResType <> nil then
FLRes := LazarusResources.Find(Name, ResType)
else
FLRes := LazarusResources.Find(Name);
if FLRes = nil then
raise EResNotFound.CreateFmt(SResNotFound, [Name]);
SetPointer(PChar(FLRes.Value), Length(FLRes.Value));
end;
constructor TLazarusResourceStream.Create(const ResName: string; ResType: PChar);
begin
inherited Create;
Initialize(PChar(ResName), ResType);
end;
constructor TLazarusResourceStream.CreateFromID(ResID: Integer; ResType: PChar);
begin
inherited Create;
Initialize(PChar(PtrInt(ResID)), ResType);
end;
constructor TLazarusResourceStream.CreateFromHandle(AHandle: TLResource);
begin
inherited Create;
FLRes := AHandle;
SetPointer(PChar(FLRes.Value), Length(FLRes.Value));
end;
{$ifdef UseRes}
constructor TLazarusResourceStream.CreateFromHandle(Instance: TFPResourceHMODULE; AHandle: TFPResourceHandle);
begin
FPRes := LoadResource(Instance, AHandle);
if FPRes <> 0 then
SetPointer(LockResource(FPRes), SizeOfResource(Instance, AHandle));
end;
{$endif}
destructor TLazarusResourceStream.Destroy;
begin
{$ifdef UseRES}
if FPRes <> 0 then
begin
UnlockResource(FPRes);
FreeResource(FPRes);
end;
{$endif}
inherited Destroy;
end;
function TLazarusResourceStream.Write(const Buffer; Count: Longint): Longint;
begin
Result := 0;
raise EStreamError.Create(SCantWriteResourceStreamError);
end;
const
ParseBufSize = 4096;
LastSpecialToken = 5;
TokNames : array[0..LastSpecialToken] of string =
(
'EOF',
'Symbol',
'String',
'Integer',
'Float',
'WideString'
);
function TUTF8Parser.GetTokenName(aTok: char): string;
begin
if ord(aTok) <= LastSpecialToken then
Result:=TokNames[ord(aTok)]
else Result:=aTok;
end;
procedure TUTF8Parser.LoadBuffer;
var newread : integer;
begin
newread:=fStream.Read(fBuf[0],ParseBufSize);
fBuf[newread]:=#0;
fLineStart:=fLineStart-fPos; // column = fPos - fLineStart + 1
fPos:=0;
fBufLen:=newread;
fEofReached:=newread=0;
end;
procedure TUTF8Parser.CheckLoadBuffer; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
begin
if fBuf[fPos]<>#0 then exit;
if fPos<fBufLen then begin
// skip #0
repeat
inc(fPos);
if fBuf[fPos]<>#0 then exit;
until (fPos=fBufLen);
end;
LoadBuffer;
end;
procedure TUTF8Parser.ProcessChar; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
begin
fLastTokenStr:=fLastTokenStr+fBuf[fPos];
inc(fPos);
CheckLoadBuffer;
end;
function TUTF8Parser.IsNumber: boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
begin
Result:=fBuf[fPos] in ['0'..'9'];
end;
function TUTF8Parser.IsHexNum: boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
begin
Result:=fBuf[fPos] in ['0'..'9','A'..'F','a'..'f'];
end;
function TUTF8Parser.IsAlpha: boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
begin
Result:=fBuf[fPos] in ['_','A'..'Z','a'..'z'];
end;
function TUTF8Parser.IsAlphaNum: boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
begin
Result:=IsAlpha or IsNumber;
end;
function TUTF8Parser.GetHexValue(c: char): byte; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
begin
case c of
'0'..'9' : Result:=ord(c)-$30;
'A'..'F' : Result:=ord(c)-$37; //-$41+$0A
'a'..'f' : Result:=ord(c)-$57; //-$61+$0A
end;
end;
function TUTF8Parser.GetAlphaNum: string;
begin
if not IsAlpha then
ErrorFmt(SParExpected,[GetTokenName(toSymbol)]);
Result:='';
while IsAlphaNum do
begin
Result:=Result+fBuf[fPos];
inc(fPos);
CheckLoadBuffer;
end;
end;
procedure TUTF8Parser.HandleNewLine;
begin
if fBuf[fPos]=#13 then //CR
begin
inc(fPos);
CheckLoadBuffer;
if fBuf[fPos]=#10 then inc(fPos); //CR LF
end
else
inc(fPos); //LF
CheckLoadBuffer;
inc(fSourceLine);
fLineStart:=fPos;
end;
procedure TUTF8Parser.SkipSpaces;
begin
while fBuf[fPos] in [' ',#9] do begin
inc(fPos);
CheckLoadBuffer;
end;
end;
procedure TUTF8Parser.SkipWhitespace;
begin
while true do
begin
case fBuf[fPos] of
' ',#9 : SkipSpaces;
#10,#13 : HandleNewLine
else break;
end;
end;
end;
procedure TUTF8Parser.HandleEof;
begin
fToken:=toEOF;
fLastTokenStr:='';
end;
procedure TUTF8Parser.HandleAlphaNum;
begin
fLastTokenStr:=GetAlphaNum;
fToken:=toSymbol;
end;
procedure TUTF8Parser.HandleNumber;
type
floatPunct = (fpDot,fpE);
floatPuncts = set of floatPunct;
var
allowed : floatPuncts;
begin
fLastTokenStr:='';
while IsNumber do
ProcessChar;
fToken:=toInteger;
if (fBuf[fPos] in ['.','e','E']) then
begin
fToken:=toFloat;
allowed:=[fpDot,fpE];
while (fBuf[fPos] in ['.','e','E','0'..'9']) do
begin
case fBuf[fPos] of
'.' : if fpDot in allowed then Exclude(allowed,fpDot) else break;
'E','e' : if fpE in allowed then
begin
allowed:=[];
ProcessChar;
if (fBuf[fPos] in ['+','-']) then ProcessChar;
if not (fBuf[fPos] in ['0'..'9']) then
ErrorFmt(SParInvalidFloat,[fLastTokenStr+fBuf[fPos]]);
end
else break;
end;
ProcessChar;
end;
end;
if (fBuf[fPos] in ['s','S','d','D','c','C']) then //single, date, currency
begin
fFloatType:=fBuf[fPos];
inc(fPos);
CheckLoadBuffer;
fToken:=toFloat;
end
else fFloatType:=#0;
end;
procedure TUTF8Parser.HandleHexNumber;
var valid : boolean;
begin
fLastTokenStr:='$';
inc(fPos);
CheckLoadBuffer;
valid:=false;
while IsHexNum do
begin
valid:=true;
ProcessChar;
end;
if not valid then
ErrorFmt(SParInvalidInteger,[fLastTokenStr]);
fToken:=toInteger;
end;
function TUTF8Parser.HandleQuotedString: string;
begin
Result:='';
inc(fPos);
CheckLoadBuffer;
while true do
begin
case fBuf[fPos] of
#0 : ErrorStr(SParUnterminatedString);
#13,#10 : ErrorStr(SParUnterminatedString);
'''' : begin
inc(fPos);
CheckLoadBuffer;
if fBuf[fPos]<>'''' then exit;
end;
end;
Result:=Result+fBuf[fPos];
inc(fPos);
CheckLoadBuffer;
end;
end;
function TUTF8Parser.HandleDecimalString: string;
var
i: integer;
begin
Result:='';
inc(fPos);
CheckLoadBuffer;
while IsNumber do
begin
Result:=Result+fBuf[fPos];
inc(fPos);
CheckLoadBuffer;
end;
if not TryStrToInt(Result,i) then
i:=0;
Result:=UnicodeToUTF8(i); // widestring
end;
procedure TUTF8Parser.HandleString;
var
IsWideString: Boolean;
begin
fLastTokenStr:='';
IsWideString := false;
while true do begin
case fBuf[fPos] of
'''' : fLastTokenStr:=fLastTokenStr+HandleQuotedString;
'#' : begin
fLastTokenStr:=fLastTokenStr+HandleDecimalString;
IsWideString:=true;
end;
else break;
end;
end;
if IsWideString then
fToken:=Classes.toWString
else
fToken:=Classes.toString;
end;
procedure TUTF8Parser.HandleMinus;
begin
inc(fPos);
CheckLoadBuffer;
if IsNumber then
begin
HandleNumber;
fLastTokenStr:='-'+fLastTokenStr;
end
else
begin
fToken:='-';
fLastTokenStr:=fToken;
end;
end;
procedure TUTF8Parser.HandleUnknown;
begin
fToken:=fBuf[fPos];
fLastTokenStr:=fToken;
inc(fPos);
CheckLoadBuffer;
end;
constructor TUTF8Parser.Create(Stream: TStream);
begin
fStream:=Stream;
fBuf:=GetMem(ParseBufSize+1);
fBufLen:=0;
fPos:=0;
fLineStart:=0;
fSourceLine:=1;
fEofReached:=false;
fLastTokenStr:='';
fFloatType:=#0;
fToken:=#0;
LoadBuffer;
NextToken;
end;
destructor TUTF8Parser.Destroy;
begin
fStream.Position:=SourcePos;
FreeMem(fBuf);
end;
procedure TUTF8Parser.CheckToken(T: Char);
begin
if fToken<>T then
ErrorFmt(SParWrongTokenType,[GetTokenName(T),GetTokenName(fToken)]);
end;
procedure TUTF8Parser.CheckTokenSymbol(const S: string);
begin
CheckToken(toSymbol);
if CompareText(fLastTokenStr,S)<>0 then
ErrorFmt(SParWrongTokenSymbol,[s,fLastTokenStr]);
end;
procedure TUTF8Parser.Error(const Ident: string);
begin
ErrorStr(Ident);
end;
procedure TUTF8Parser.ErrorFmt(const Ident: string; const Args: array of const);
begin
ErrorStr(Format(Ident,Args));
end;
procedure TUTF8Parser.ErrorStr(const Message: string);
begin
debugln(['TUTF8Parser.ErrorStr Message="',Message,'" at y=',SourceLine,',x=',SourceColumn]);
raise EParserError.CreateFmt(Message+SParLocInfo,[SourceLine,SourceColumn,SourcePos]);
end;
procedure TUTF8Parser.HexToBinary(Stream: TStream);
var outbuf : array[0..ParseBufSize-1] of byte;
b : byte;
i : integer;
begin
i:=0;
SkipWhitespace;
while IsHexNum do
begin
b:=(GetHexValue(fBuf[fPos]) shl 4);
inc(fPos);
CheckLoadBuffer;
if not IsHexNum then
Error(SParUnterminatedBinValue);
b:=b or GetHexValue(fBuf[fPos]);
inc(fPos);
CheckLoadBuffer;
outbuf[i]:=b;
inc(i);
if i>=ParseBufSize then
begin
Stream.WriteBuffer(outbuf[0],i);
i:=0;
end;
SkipWhitespace;
end;
if i>0 then
Stream.WriteBuffer(outbuf[0],i);
NextToken;
end;
function TUTF8Parser.NextToken: Char;
begin
SkipWhiteSpace;
if fEofReached then
HandleEof
else
case fBuf[fPos] of
'_','A'..'Z','a'..'z' : HandleAlphaNum;
'$' : HandleHexNumber;
'-' : HandleMinus;
'0'..'9' : HandleNumber;
'''','#' : HandleString
else
HandleUnknown;
end;
Result:=fToken;
end;
function TUTF8Parser.SourcePos: Longint;
begin
Result:=fStream.Position-fBufLen+fPos;
end;
function TUTF8Parser.TokenComponentIdent: string;
begin
if fToken<>toSymbol then
ErrorFmt(SParExpected,[GetTokenName(toSymbol)]);
CheckLoadBuffer;
while fBuf[fPos]='.' do
begin
ProcessChar;
fLastTokenStr:=fLastTokenStr+GetAlphaNum;
end;
Result:=fLastTokenStr;
end;
function TUTF8Parser.TokenFloat: Extended;
var errcode : word;
begin
Val(fLastTokenStr,Result,errcode);
if errcode<>0 then
ErrorFmt(SParInvalidFloat,[fLastTokenStr]);
end;
function TUTF8Parser.TokenInt: Int64;
begin
if not TryStrToInt64(fLastTokenStr,Result) then
Result:=Int64(StrToQWord(fLastTokenStr)); //second chance for malformed files
end;
function TUTF8Parser.TokenString: string;
begin
case fToken of
toFloat : if fFloatType<>#0 then
Result:=fLastTokenStr+fFloatType
else Result:=fLastTokenStr
else
Result:=fLastTokenStr;
end;
end;
function TUTF8Parser.TokenSymbolIs(const S: string): Boolean;
begin
Result:=(fToken=toSymbol) and (CompareText(fLastTokenStr,S)=0);
end;
function TUTF8Parser.SourceColumn: integer;
begin
Result:=fPos-fLineStart+1;
end;
//------------------------------------------------------------------------------
procedure InternalInit;
begin
LazarusResources := TLResourceList.Create;
RegisterInitComponentHandler(TComponent, @InitResourceComponent);
PropertiesToSkip := TPropertiesToSkip.Create;
end;
initialization
InternalInit;
finalization
FreeAndNil(LazarusResources);
FreeAndNil(PropertiesToSkip);
end.