{ This file is part of the Pas2JS run time library. Copyright (c) 2017 by Mattias Gaertner See the file COPYING.FPC, included in this distribution, for details about the copyright. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. **********************************************************************} unit Classes; {$mode objfpc} interface uses RTLConsts, Types, SysUtils, JS; type TNotifyEvent = procedure(Sender: TObject) of object; // Notification operations : // Observer has changed, is freed, item added to/deleted from list, custom event. TFPObservedOperation = (ooChange,ooFree,ooAddItem,ooDeleteItem,ooCustom); EStreamError = class(Exception); EFCreateError = class(EStreamError); EFOpenError = class(EStreamError); EFilerError = class(EStreamError); EReadError = class(EFilerError); EWriteError = class(EFilerError); EClassNotFound = class(EFilerError); EMethodNotFound = class(EFilerError); EInvalidImage = class(EFilerError); EResNotFound = class(Exception); EListError = class(Exception); EBitsError = class(Exception); EStringListError = class(EListError); EComponentError = class(Exception); EParserError = class(Exception); EOutOfResources = class(EOutOfMemory); EInvalidOperation = class(Exception); TListAssignOp = (laCopy, laAnd, laOr, laXor, laSrcUnique, laDestUnique); TListSortCompare = function(Item1, Item2: JSValue): Integer; TListCallback = Types.TListCallback; TListStaticCallback = Types.TListStaticCallback; TAlignment = (taLeftJustify, taRightJustify, taCenter); { TFPListEnumerator } TFPList = Class; TFPListEnumerator = class private FList: TFPList; FPosition: Integer; public constructor Create(AList: TFPList); reintroduce; function GetCurrent: JSValue; function MoveNext: Boolean; property Current: JSValue read GetCurrent; end; { TFPList } TFPList = class(TObject) private FList: TJSValueDynArray; FCount: Integer; FCapacity: Integer; procedure CopyMove(aList: TFPList); procedure MergeMove(aList: TFPList); procedure DoCopy(ListA, ListB: TFPList); procedure DoSrcUnique(ListA, ListB: TFPList); procedure DoAnd(ListA, ListB: TFPList); procedure DoDestUnique(ListA, ListB: TFPList); procedure DoOr(ListA, ListB: TFPList); procedure DoXOr(ListA, ListB: TFPList); protected function Get(Index: Integer): JSValue; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE} procedure Put(Index: Integer; Item: JSValue); {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE} procedure SetCapacity(NewCapacity: Integer); procedure SetCount(NewCount: Integer); Procedure RaiseIndexError(Index: Integer); public //Type // TDirection = (FromBeginning, FromEnd); destructor Destroy; override; procedure AddList(AList: TFPList); function Add(Item: JSValue): Integer; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE} procedure Clear; procedure Delete(Index: Integer); {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE} class procedure Error(const Msg: string; const Data: String); procedure Exchange(Index1, Index2: Integer); function Expand: TFPList; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE} function Extract(Item: JSValue): JSValue; function First: JSValue; function GetEnumerator: TFPListEnumerator; function IndexOf(Item: JSValue): Integer; function IndexOfItem(Item: JSValue; Direction: TDirection): Integer; procedure Insert(Index: Integer; Item: JSValue); {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE} function Last: JSValue; procedure Move(CurIndex, NewIndex: Integer); procedure Assign (ListA: TFPList; AOperator: TListAssignOp=laCopy; ListB: TFPList=nil); function Remove(Item: JSValue): Integer; procedure Pack; procedure Sort(const Compare: TListSortCompare); procedure ForEachCall(const proc2call: TListCallback; const arg: JSValue); procedure ForEachCall(const proc2call: TListStaticCallback; const arg: JSValue); property Capacity: Integer read FCapacity write SetCapacity; property Count: Integer read FCount write SetCount; property Items[Index: Integer]: JSValue read Get write Put; default; property List: TJSValueDynArray read FList; end; TListNotification = (lnAdded, lnExtracted, lnDeleted); TList = class; { TListEnumerator } TListEnumerator = class private FList: TList; FPosition: Integer; public constructor Create(AList: TList); reintroduce; function GetCurrent: JSValue; function MoveNext: Boolean; property Current: JSValue read GetCurrent; end; { TList } TList = class(TObject) private FList: TFPList; procedure CopyMove (aList : TList); procedure MergeMove (aList : TList); procedure DoCopy(ListA, ListB : TList); procedure DoSrcUnique(ListA, ListB : TList); procedure DoAnd(ListA, ListB : TList); procedure DoDestUnique(ListA, ListB : TList); procedure DoOr(ListA, ListB : TList); procedure DoXOr(ListA, ListB : TList); protected function Get(Index: Integer): JSValue; procedure Put(Index: Integer; Item: JSValue); procedure Notify(aValue: JSValue; Action: TListNotification); virtual; procedure SetCapacity(NewCapacity: Integer); function GetCapacity: integer; procedure SetCount(NewCount: Integer); function GetCount: integer; function GetList: TJSValueDynArray; property FPList : TFPList Read FList; public constructor Create; reintroduce; destructor Destroy; override; Procedure AddList(AList : TList); function Add(Item: JSValue): Integer; procedure Clear; virtual; procedure Delete(Index: Integer); class procedure Error(const Msg: string; Data: String); virtual; procedure Exchange(Index1, Index2: Integer); function Expand: TList; function Extract(Item: JSValue): JSValue; function First: JSValue; function GetEnumerator: TListEnumerator; function IndexOf(Item: JSValue): Integer; procedure Insert(Index: Integer; Item: JSValue); function Last: JSValue; procedure Move(CurIndex, NewIndex: Integer); procedure Assign (ListA: TList; AOperator: TListAssignOp=laCopy; ListB: TList=nil); function Remove(Item: JSValue): Integer; procedure Pack; procedure Sort(const Compare: TListSortCompare); property Capacity: Integer read GetCapacity write SetCapacity; property Count: Integer read GetCount write SetCount; property Items[Index: Integer]: JSValue read Get write Put; default; property List: TJSValueDynArray read GetList; end; { TPersistent } TPersistent = class(TObject) private //FObservers : TFPList; procedure AssignError(Source: TPersistent); protected procedure AssignTo(Dest: TPersistent); virtual; function GetOwner: TPersistent; virtual; public procedure Assign(Source: TPersistent); virtual; //procedure FPOAttachObserver(AObserver : TObject); //procedure FPODetachObserver(AObserver : TObject); //procedure FPONotifyObservers(ASender : TObject; AOperation: TFPObservedOperation; Data: TObject); function GetNamePath: string; virtual; end; TPersistentClass = Class of TPersistent; { TInterfacedPersistent } TInterfacedPersistent = class(TPersistent, IInterface) private FOwnerInterface: IInterface; protected function _AddRef: Integer; function _Release: Integer; public function QueryInterface(const IID: TGUID; out Obj): integer; virtual; procedure AfterConstruction; override; end; TStrings = Class; { TStringsEnumerator class } TStringsEnumerator = class private FStrings: TStrings; FPosition: Integer; public constructor Create(AStrings: TStrings); reintroduce; function GetCurrent: String; function MoveNext: Boolean; property Current: String read GetCurrent; end; { TStrings class } TStrings = class(TPersistent) private FSpecialCharsInited : boolean; FAlwaysQuote: Boolean; FQuoteChar : Char; FDelimiter : Char; FNameValueSeparator : Char; FUpdateCount: Integer; FLBS : TTextLineBreakStyle; FSkipLastLineBreak : Boolean; FStrictDelimiter : Boolean; FLineBreak : String; function GetCommaText: string; function GetName(Index: Integer): string; function GetValue(const Name: string): string; Function GetLBS : TTextLineBreakStyle; Procedure SetLBS (AValue : TTextLineBreakStyle); procedure SetCommaText(const Value: string); procedure SetValue(const Name, Value: string); procedure SetDelimiter(c:Char); procedure SetQuoteChar(c:Char); procedure SetNameValueSeparator(c:Char); procedure DoSetTextStr(const Value: string; DoClear : Boolean); Function GetDelimiter : Char; Function GetNameValueSeparator : Char; Function GetQuoteChar: Char; Function GetLineBreak : String; procedure SetLineBreak(const S : String); Function GetSkipLastLineBreak : Boolean; procedure SetSkipLastLineBreak(const AValue : Boolean); protected procedure Error(const Msg: string; Data: Integer); function Get(Index: Integer): string; virtual; abstract; function GetCapacity: Integer; virtual; function GetCount: Integer; virtual; abstract; function GetObject(Index: Integer): TObject; virtual; function GetTextStr: string; virtual; procedure Put(Index: Integer; const S: string); virtual; procedure PutObject(Index: Integer; AObject: TObject); virtual; procedure SetCapacity(NewCapacity: Integer); virtual; procedure SetTextStr(const Value: string); virtual; procedure SetUpdateState(Updating: Boolean); virtual; property UpdateCount: Integer read FUpdateCount; Function DoCompareText(const s1,s2 : string) : PtrInt; virtual; Function GetDelimitedText: string; Procedure SetDelimitedText(Const AValue: string); Function GetValueFromIndex(Index: Integer): string; Procedure SetValueFromIndex(Index: Integer; const Value: string); Procedure CheckSpecialChars; // Class Function GetNextLine (Const Value : String; Var S : String; Var P : Integer) : Boolean; Function GetNextLinebreak (Const Value : String; Out S : String; Var P : Integer) : Boolean; public constructor Create; reintroduce; destructor Destroy; override; function Add(const S: string): Integer; virtual; overload; // function AddFmt(const Fmt : string; const Args : Array of const): Integer; overload; function AddObject(const S: string; AObject: TObject): Integer; virtual; overload; // function AddObject(const Fmt: string; Args : Array of const; AObject: TObject): Integer; overload; procedure Append(const S: string); procedure AddStrings(TheStrings: TStrings); overload; virtual; procedure AddStrings(TheStrings: TStrings; ClearFirst : Boolean); overload; procedure AddStrings(const TheStrings: array of string); overload; virtual; procedure AddStrings(const TheStrings: array of string; ClearFirst : Boolean); overload; function AddPair(const AName, AValue: string): TStrings; overload; function AddPair(const AName, AValue: string; AObject: TObject): TStrings; overload; Procedure AddText(Const S : String); virtual; procedure Assign(Source: TPersistent); override; procedure BeginUpdate; procedure Clear; virtual; abstract; procedure Delete(Index: Integer); virtual; abstract; procedure EndUpdate; function Equals(Obj: TObject): Boolean; override; overload; function Equals(TheStrings: TStrings): Boolean; overload; procedure Exchange(Index1, Index2: Integer); virtual; function GetEnumerator: TStringsEnumerator; function IndexOf(const S: string): Integer; virtual; function IndexOfName(const Name: string): Integer; virtual; function IndexOfObject(AObject: TObject): Integer; virtual; procedure Insert(Index: Integer; const S: string); virtual; abstract; procedure InsertObject(Index: Integer; const S: string; AObject: TObject); procedure Move(CurIndex, NewIndex: Integer); virtual; procedure GetNameValue(Index : Integer; Out AName,AValue : String); function ExtractName(Const S:String):String; Property TextLineBreakStyle : TTextLineBreakStyle Read GetLBS Write SetLBS; property Delimiter: Char read GetDelimiter write SetDelimiter; property DelimitedText: string read GetDelimitedText write SetDelimitedText; property LineBreak : string Read GetLineBreak write SetLineBreak; Property StrictDelimiter : Boolean Read FStrictDelimiter Write FStrictDelimiter; property AlwaysQuote: Boolean read FAlwaysQuote write FAlwaysQuote; property QuoteChar: Char read GetQuoteChar write SetQuoteChar; Property NameValueSeparator : Char Read GetNameValueSeparator Write SetNameValueSeparator; property ValueFromIndex[Index: Integer]: string read GetValueFromIndex write SetValueFromIndex; property Capacity: Integer read GetCapacity write SetCapacity; property CommaText: string read GetCommaText write SetCommaText; property Count: Integer read GetCount; property Names[Index: Integer]: string read GetName; property Objects[Index: Integer]: TObject read GetObject write PutObject; property Values[const Name: string]: string read GetValue write SetValue; property Strings[Index: Integer]: string read Get write Put; default; property Text: string read GetTextStr write SetTextStr; Property SkipLastLineBreak : Boolean Read GetSkipLastLineBreak Write SetSkipLastLineBreak; end; { TStringList} TStringItem = record FString: string; FObject: TObject; end; TStringItemArray = Array of TStringItem; TStringList = class; TStringListSortCompare = function(List: TStringList; Index1, Index2: Integer): Integer; TStringsSortStyle = (sslNone,sslUser,sslAuto); TStringsSortStyles = Set of TStringsSortStyle; TStringList = class(TStrings) private FList: TStringItemArray; FCount: Integer; FOnChange: TNotifyEvent; FOnChanging: TNotifyEvent; FDuplicates: TDuplicates; FCaseSensitive : Boolean; FForceSort : Boolean; FOwnsObjects : Boolean; FSortStyle: TStringsSortStyle; procedure ExchangeItemsInt(Index1, Index2: Integer); function GetSorted: Boolean; procedure Grow; procedure InternalClear(FromIndex : Integer = 0; ClearOnly : Boolean = False); procedure QuickSort(L, R: Integer; CompareFn: TStringListSortCompare); procedure SetSorted(Value: Boolean); procedure SetCaseSensitive(b : boolean); procedure SetSortStyle(AValue: TStringsSortStyle); protected Procedure CheckIndex(AIndex : Integer); procedure ExchangeItems(Index1, Index2: Integer); virtual; procedure Changed; virtual; procedure Changing; virtual; function Get(Index: Integer): string; override; function GetCapacity: Integer; override; function GetCount: Integer; override; function GetObject(Index: Integer): TObject; override; procedure Put(Index: Integer; const S: string); override; procedure PutObject(Index: Integer; AObject: TObject); override; procedure SetCapacity(NewCapacity: Integer); override; procedure SetUpdateState(Updating: Boolean); override; procedure InsertItem(Index: Integer; const S: string); virtual; procedure InsertItem(Index: Integer; const S: string; O: TObject); virtual; Function DoCompareText(const s1,s2 : string) : PtrInt; override; function CompareStrings(const s1,s2 : string) : Integer; virtual; public destructor Destroy; override; function Add(const S: string): Integer; override; procedure Clear; override; procedure Delete(Index: Integer); override; procedure Exchange(Index1, Index2: Integer); override; function Find(const S: string; Out Index: Integer): Boolean; virtual; function IndexOf(const S: string): Integer; override; procedure Insert(Index: Integer; const S: string); override; procedure Sort; virtual; procedure CustomSort(CompareFn: TStringListSortCompare); virtual; property Duplicates: TDuplicates read FDuplicates write FDuplicates; property Sorted: Boolean read GetSorted write SetSorted; property CaseSensitive: Boolean read FCaseSensitive write SetCaseSensitive; property OnChange: TNotifyEvent read FOnChange write FOnChange; property OnChanging: TNotifyEvent read FOnChanging write FOnChanging; property OwnsObjects : boolean read FOwnsObjects write FOwnsObjects; Property SortStyle : TStringsSortStyle Read FSortStyle Write SetSortStyle; end; TCollection = class; { TCollectionItem } TCollectionItem = class(TPersistent) private FCollection: TCollection; FID: Integer; FUpdateCount: Integer; function GetIndex: Integer; protected procedure SetCollection(Value: TCollection);virtual; procedure Changed(AllItems: Boolean); function GetOwner: TPersistent; override; function GetDisplayName: string; virtual; procedure SetIndex(Value: Integer); virtual; procedure SetDisplayName(const Value: string); virtual; property UpdateCount: Integer read FUpdateCount; public constructor Create(ACollection: TCollection); virtual; reintroduce; destructor Destroy; override; function GetNamePath: string; override; property Collection: TCollection read FCollection write SetCollection; property ID: Integer read FID; property Index: Integer read GetIndex write SetIndex; property DisplayName: string read GetDisplayName write SetDisplayName; end; TCollectionEnumerator = class private FCollection: TCollection; FPosition: Integer; public constructor Create(ACollection: TCollection); reintroduce; function GetCurrent: TCollectionItem; function MoveNext: Boolean; property Current: TCollectionItem read GetCurrent; end; TCollectionItemClass = class of TCollectionItem; TCollectionNotification = (cnAdded, cnExtracting, cnDeleting); TCollectionSortCompare = function (Item1, Item2: TCollectionItem): Integer; TCollection = class(TPersistent) private FItemClass: TCollectionItemClass; FItems: TFpList; FUpdateCount: Integer; FNextID: Integer; FPropName: string; function GetCount: Integer; function GetPropName: string; procedure InsertItem(Item: TCollectionItem); procedure RemoveItem(Item: TCollectionItem); procedure DoClear; protected { Design-time editor support } function GetAttrCount: Integer; virtual; function GetAttr(Index: Integer): string; virtual; function GetItemAttr(Index, ItemIndex: Integer): string; virtual; procedure Changed; function GetItem(Index: Integer): TCollectionItem; procedure SetItem(Index: Integer; Value: TCollectionItem); procedure SetItemName(Item: TCollectionItem); virtual; procedure SetPropName; virtual; procedure Update(Item: TCollectionItem); virtual; procedure Notify(Item: TCollectionItem;Action: TCollectionNotification); virtual; property PropName: string read GetPropName write FPropName; property UpdateCount: Integer read FUpdateCount; public constructor Create(AItemClass: TCollectionItemClass); reintroduce; destructor Destroy; override; function Owner: TPersistent; function Add: TCollectionItem; procedure Assign(Source: TPersistent); override; procedure BeginUpdate; virtual; procedure Clear; procedure EndUpdate; virtual; procedure Delete(Index: Integer); function GetEnumerator: TCollectionEnumerator; function GetNamePath: string; override; function Insert(Index: Integer): TCollectionItem; function FindItemID(ID: Integer): TCollectionItem; procedure Exchange(Const Index1, index2: integer); procedure Sort(Const Compare : TCollectionSortCompare); property Count: Integer read GetCount; property ItemClass: TCollectionItemClass read FItemClass; property Items[Index: Integer]: TCollectionItem read GetItem write SetItem; end; TOwnedCollection = class(TCollection) private FOwner: TPersistent; protected Function GetOwner: TPersistent; override; public Constructor Create(AOwner: TPersistent; AItemClass: TCollectionItemClass); reintroduce; end; TComponent = Class; TOperation = (opInsert, opRemove); TComponentStateItem = ( csLoading, csReading, csWriting, csDestroying, csDesigning, csAncestor, csUpdating, csFixups, csFreeNotification, csInline, csDesignInstance); TComponentState = set of TComponentStateItem; TComponentStyleItem = (csInheritable, csCheckPropAvail, csSubComponent, csTransient); TComponentStyle = set of TComponentStyleItem; TGetChildProc = procedure (Child: TComponent) of object; TComponentName = string; { TComponentEnumerator } TComponentEnumerator = class private FComponent: TComponent; FPosition: Integer; public constructor Create(AComponent: TComponent); reintroduce; function GetCurrent: TComponent; function MoveNext: Boolean; property Current: TComponent read GetCurrent; end; TComponent = class(TPersistent, IInterface) private FOwner: TComponent; FName: TComponentName; FTag: Ptrint; FComponents: TFpList; FFreeNotifies: TFpList; FDesignInfo: Longint; FComponentState: TComponentState; function GetComponent(AIndex: Integer): TComponent; function GetComponentCount: Integer; function GetComponentIndex: Integer; procedure Insert(AComponent: TComponent); procedure Remove(AComponent: TComponent); procedure RemoveNotification(AComponent: TComponent); procedure SetComponentIndex(Value: Integer); protected FComponentStyle: TComponentStyle; procedure ChangeName(const NewName: TComponentName); procedure GetChildren(Proc: TGetChildProc; Root: TComponent); virtual; function GetChildOwner: TComponent; virtual; function GetChildParent: TComponent; virtual; function GetOwner: TPersistent; override; procedure Loaded; virtual; procedure Loading; virtual; procedure SetWriting(Value: Boolean); virtual; procedure SetReading(Value: Boolean); virtual; procedure Notification(AComponent: TComponent; Operation: TOperation); virtual; procedure PaletteCreated; virtual; procedure SetAncestor(Value: Boolean); procedure SetDesigning(Value: Boolean; SetChildren : Boolean = True); procedure SetDesignInstance(Value: Boolean); procedure SetInline(Value: Boolean); procedure SetName(const NewName: TComponentName); virtual; procedure SetChildOrder(Child: TComponent; Order: Integer); virtual; procedure SetParentComponent(Value: TComponent); virtual; procedure Updating; virtual; procedure Updated; virtual; procedure ValidateRename(AComponent: TComponent; const CurName, NewName: string); virtual; procedure ValidateContainer(AComponent: TComponent); virtual; procedure ValidateInsert(AComponent: TComponent); virtual; protected function _AddRef: Integer; function _Release: Integer; public constructor Create(AOwner: TComponent); virtual; reintroduce; destructor Destroy; override; procedure BeforeDestruction; override; procedure DestroyComponents; procedure Destroying; function QueryInterface(const IID: TGUID; out Obj): integer; virtual; // function ExecuteAction(Action: TBasicAction): Boolean; virtual; function FindComponent(const AName: string): TComponent; procedure FreeNotification(AComponent: TComponent); procedure RemoveFreeNotification(AComponent: TComponent); function GetNamePath: string; override; function GetParentComponent: TComponent; virtual; function HasParent: Boolean; virtual; procedure InsertComponent(AComponent: TComponent); procedure RemoveComponent(AComponent: TComponent); procedure SetSubComponent(ASubComponent: Boolean); function GetEnumerator: TComponentEnumerator; // function UpdateAction(Action: TBasicAction): Boolean; dynamic; property Components[Index: Integer]: TComponent read GetComponent; property ComponentCount: Integer read GetComponentCount; property ComponentIndex: Integer read GetComponentIndex write SetComponentIndex; property ComponentState: TComponentState read FComponentState; property ComponentStyle: TComponentStyle read FComponentStyle; property DesignInfo: Longint read FDesignInfo write FDesignInfo; property Owner: TComponent read FOwner; published property Name: TComponentName read FName write SetName stored False; property Tag: PtrInt read FTag write FTag {default 0}; end; TComponentClass = Class of TComponent; TSeekOrigin = (soBeginning, soCurrent, soEnd); { TStream } TStream = class(TObject) private FEndian: TEndian; function MakeInt(B: TBytes; aSize: Integer; Signed: Boolean): NativeInt; function MakeBytes(B: NativeInt; aSize: Integer; Signed: Boolean): TBytes; protected procedure InvalidSeek; virtual; procedure Discard(const Count: NativeInt); procedure DiscardLarge(Count: NativeInt; const MaxBufferSize: Longint); procedure FakeSeekForward(Offset: NativeInt; const Origin: TSeekOrigin; const Pos: NativeInt); function GetPosition: NativeInt; virtual; procedure SetPosition(const Pos: NativeInt); virtual; function GetSize: NativeInt; virtual; procedure SetSize(const NewSize: NativeInt); virtual; procedure SetSize64(const NewSize: NativeInt); virtual; procedure ReadNotImplemented; procedure WriteNotImplemented; function ReadMaxSizeData(Buffer : TBytes; aSize,aCount : NativeInt) : NativeInt; Procedure ReadExactSizeData(Buffer : TBytes; aSize,aCount : NativeInt); function WriteMaxSizeData(Const Buffer : TBytes; aSize,aCount : NativeInt) : NativeInt; Procedure WriteExactSizeData(Const Buffer : TBytes; aSize,aCount : NativeInt); public function Read(var Buffer: TBytes; Count: Longint): Longint; overload; function Read(Buffer : TBytes; aOffset, Count: Longint): Longint; virtual; abstract; overload; function Write(const Buffer: TBytes; Count: Longint): Longint; virtual; overload; function Write(const Buffer: TBytes; Offset, Count: Longint): Longint; virtual; abstract; overload; function Seek(const Offset: NativeInt; Origin: TSeekOrigin): NativeInt; virtual; abstract; overload; function ReadData(Buffer: TBytes; Count: NativeInt): NativeInt; overload; function ReadData(var Buffer: Boolean): NativeInt; overload; function ReadData(var Buffer: Boolean; Count: NativeInt): NativeInt; overload; function ReadData(var Buffer: WideChar): NativeInt; overload; function ReadData(var Buffer: WideChar; Count: NativeInt): NativeInt; overload; function ReadData(var Buffer: Int8): NativeInt; overload; function ReadData(var Buffer: Int8; Count: NativeInt): NativeInt; overload; function ReadData(var Buffer: UInt8): NativeInt; overload; function ReadData(var Buffer: UInt8; Count: NativeInt): NativeInt; overload; function ReadData(var Buffer: Int16): NativeInt; overload; function ReadData(var Buffer: Int16; Count: NativeInt): NativeInt; overload; function ReadData(var Buffer: UInt16): NativeInt; overload; function ReadData(var Buffer: UInt16; Count: NativeInt): NativeInt; overload; function ReadData(var Buffer: Int32): NativeInt; overload; function ReadData(var Buffer: Int32; Count: NativeInt): NativeInt; overload; function ReadData(var Buffer: UInt32): NativeInt; overload; function ReadData(var Buffer: UInt32; Count: NativeInt): NativeInt; overload; // NativeLargeint. Stored as a float64, Read as float64. function ReadData(var Buffer: NativeLargeInt): NativeInt; overload; function ReadData(var Buffer: NativeLargeInt; Count: NativeInt): NativeInt; overload; function ReadData(var Buffer: NativeLargeUInt): NativeInt; overload; function ReadData(var Buffer: NativeLargeUInt; Count: NativeInt): NativeInt; overload; function ReadData(var Buffer: Double): NativeInt; overload; function ReadData(var Buffer: Double; Count: NativeInt): NativeInt; overload; procedure ReadBuffer(var Buffer: TBytes; Count: NativeInt); overload; procedure ReadBuffer(var Buffer: TBytes; Offset, Count: NativeInt); overload; procedure ReadBufferData(var Buffer: Boolean); overload; procedure ReadBufferData(var Buffer: Boolean; Count: NativeInt); overload; procedure ReadBufferData(var Buffer: WideChar); overload; procedure ReadBufferData(var Buffer: WideChar; Count: NativeInt); overload; procedure ReadBufferData(var Buffer: Int8); overload; procedure ReadBufferData(var Buffer: Int8; Count: NativeInt); overload; procedure ReadBufferData(var Buffer: UInt8); overload; procedure ReadBufferData(var Buffer: UInt8; Count: NativeInt); overload; procedure ReadBufferData(var Buffer: Int16); overload; procedure ReadBufferData(var Buffer: Int16; Count: NativeInt); overload; procedure ReadBufferData(var Buffer: UInt16); overload; procedure ReadBufferData(var Buffer: UInt16; Count: NativeInt); overload; procedure ReadBufferData(var Buffer: Int32); overload; procedure ReadBufferData(var Buffer: Int32; Count: NativeInt); overload; procedure ReadBufferData(var Buffer: UInt32); overload; procedure ReadBufferData(var Buffer: UInt32; Count: NativeInt); overload; // NativeLargeint. Stored as a float64, Read as float64. procedure ReadBufferData(var Buffer: NativeLargeInt); overload; procedure ReadBufferData(var Buffer: NativeLargeInt; Count: NativeInt); overload; procedure ReadBufferData(var Buffer: NativeLargeUInt); overload; procedure ReadBufferData(var Buffer: NativeLargeUInt; Count: NativeInt); overload; procedure ReadBufferData(var Buffer: Double); overload; procedure ReadBufferData(var Buffer: Double; Count: NativeInt); overload; procedure WriteBuffer(const Buffer: TBytes; Count: NativeInt); overload; procedure WriteBuffer(const Buffer: TBytes; Offset, Count: NativeInt); overload; function WriteData(const Buffer: TBytes; Count: NativeInt): NativeInt; overload; function WriteData(const Buffer: Boolean): NativeInt; overload; function WriteData(const Buffer: Boolean; Count: NativeInt): NativeInt; overload; function WriteData(const Buffer: WideChar): NativeInt; overload; function WriteData(const Buffer: WideChar; Count: NativeInt): NativeInt; overload; function WriteData(const Buffer: Int8): NativeInt; overload; function WriteData(const Buffer: Int8; Count: NativeInt): NativeInt; overload; function WriteData(const Buffer: UInt8): NativeInt; overload; function WriteData(const Buffer: UInt8; Count: NativeInt): NativeInt; overload; function WriteData(const Buffer: Int16): NativeInt; overload; function WriteData(const Buffer: Int16; Count: NativeInt): NativeInt; overload; function WriteData(const Buffer: UInt16): NativeInt; overload; function WriteData(const Buffer: UInt16; Count: NativeInt): NativeInt; overload; function WriteData(const Buffer: Int32): NativeInt; overload; function WriteData(const Buffer: Int32; Count: NativeInt): NativeInt; overload; function WriteData(const Buffer: UInt32): NativeInt; overload; function WriteData(const Buffer: UInt32; Count: NativeInt): NativeInt; overload; // NativeLargeint. Stored as a float64, Read as float64. function WriteData(const Buffer: NativeLargeInt): NativeInt; overload; function WriteData(const Buffer: NativeLargeInt; Count: NativeInt): NativeInt; overload; function WriteData(const Buffer: NativeLargeUInt): NativeInt; overload; function WriteData(const Buffer: NativeLargeUInt; Count: NativeInt): NativeInt; overload; function WriteData(const Buffer: Double): NativeInt; overload; function WriteData(const Buffer: Double; Count: NativeInt): NativeInt; overload; {$IFDEF FPC_HAS_TYPE_EXTENDED} function WriteData(const Buffer: Extended): NativeInt; overload; function WriteData(const Buffer: Extended; Count: NativeInt): NativeInt; overload; function WriteData(const Buffer: TExtended80Rec): NativeInt; overload; function WriteData(const Buffer: TExtended80Rec; Count: NativeInt): NativeInt; overload; {$ENDIF} procedure WriteBufferData(Buffer: Int32); overload; procedure WriteBufferData(Buffer: Int32; Count: NativeInt); overload; procedure WriteBufferData(Buffer: Boolean); overload; procedure WriteBufferData(Buffer: Boolean; Count: NativeInt); overload; procedure WriteBufferData(Buffer: WideChar); overload; procedure WriteBufferData(Buffer: WideChar; Count: NativeInt); overload; procedure WriteBufferData(Buffer: Int8); overload; procedure WriteBufferData(Buffer: Int8; Count: NativeInt); overload; procedure WriteBufferData(Buffer: UInt8); overload; procedure WriteBufferData(Buffer: UInt8; Count: NativeInt); overload; procedure WriteBufferData(Buffer: Int16); overload; procedure WriteBufferData(Buffer: Int16; Count: NativeInt); overload; procedure WriteBufferData(Buffer: UInt16); overload; procedure WriteBufferData(Buffer: UInt16; Count: NativeInt); overload; procedure WriteBufferData(Buffer: UInt32); overload; procedure WriteBufferData(Buffer: UInt32; Count: NativeInt); overload; // NativeLargeint. Stored as a float64, Read as float64. procedure WriteBufferData(Buffer: NativeLargeInt); overload; procedure WriteBufferData(Buffer: NativeLargeInt; Count: NativeInt); overload; procedure WriteBufferData(Buffer: NativeLargeUInt); overload; procedure WriteBufferData(Buffer: NativeLargeUInt; Count: NativeInt); overload; procedure WriteBufferData(Buffer: Double); overload; procedure WriteBufferData(Buffer: Double; Count: NativeInt); overload; function CopyFrom(Source: TStream; Count: NativeInt): NativeInt; { function ReadComponent(Instance: TComponent): TComponent; function ReadComponentRes(Instance: TComponent): TComponent; procedure WriteComponent(Instance: TComponent); procedure WriteComponentRes(const ResName: string; Instance: TComponent); procedure WriteDescendent(Instance, Ancestor: TComponent); procedure WriteDescendentRes(const ResName: string; Instance, Ancestor: TComponent); procedure WriteResourceHeader(const ResName: string; {!!!:out} var FixupInfo: Longint); procedure FixupResourceHeader(FixupInfo: Longint); procedure ReadResHeader; } function ReadByte : Byte; function ReadWord : Word; function ReadDWord : Cardinal; function ReadQWord : NativeLargeUInt; procedure WriteByte(b : Byte); procedure WriteWord(w : Word); procedure WriteDWord(d : Cardinal); procedure WriteQWord(q : NativeLargeUInt); property Position: NativeInt read GetPosition write SetPosition; property Size: NativeInt read GetSize write SetSize64; Property Endian: TEndian Read FEndian Write FEndian; end; { TCustomMemoryStream abstract class } TCustomMemoryStream = class(TStream) private FMemory: TJSArrayBuffer; FDataView : TJSDataView; FDataArray : TJSUint8Array; FSize, FPosition: PtrInt; FSizeBoundsSeek : Boolean; function GetDataArray: TJSUint8Array; function GetDataView: TJSDataview; protected Function GetSize : NativeInt; Override; function GetPosition: NativeInt; Override; procedure SetPointer(Ptr: TJSArrayBuffer; ASize: PtrInt); Property DataView : TJSDataview Read GetDataView; Property DataArray : TJSUint8Array Read GetDataArray; public Class Function MemoryToBytes(Mem : TJSArrayBuffer) : TBytes; overload; Class Function MemoryToBytes(Mem : TJSUint8Array) : TBytes; overload; Class Function BytesToMemory(aBytes : TBytes) : TJSArrayBuffer; function Read(Buffer : TBytes; Offset, Count: LongInt): LongInt; override; function Seek(const Offset: NativeInt; Origin: TSeekOrigin): NativeInt; override; procedure SaveToStream(Stream: TStream); property Memory: TJSArrayBuffer read FMemory; Property SizeBoundsSeek : Boolean Read FSizeBoundsSeek Write FSizeBoundsSeek; end; { TMemoryStream } TMemoryStream = class(TCustomMemoryStream) private FCapacity: PtrInt; procedure SetCapacity(NewCapacity: PtrInt); protected function Realloc(var NewCapacity: PtrInt): TJSArrayBuffer; virtual; property Capacity: PtrInt read FCapacity write SetCapacity; public destructor Destroy; override; procedure Clear; procedure LoadFromStream(Stream: TStream); procedure SetSize(const NewSize: NativeInt); override; function Write(const Buffer: TBytes; Offset, Count: LongInt): LongInt; override; end; { TBytesStream } TBytesStream = class(TMemoryStream) private function GetBytes: TBytes; public constructor Create(const ABytes: TBytes); virtual; overload; property Bytes: TBytes read GetBytes; end; Procedure RegisterClass(AClass : TPersistentClass); Function GetClass(AClassName : string) : TPersistentClass; implementation { TInterfacedPersistent } function TInterfacedPersistent._AddRef: Integer; begin Result:=-1; if Assigned(FOwnerInterface) then Result:=FOwnerInterface._AddRef; end; function TInterfacedPersistent._Release: Integer; begin Result:=-1; if Assigned(FOwnerInterface) then Result:=FOwnerInterface._Release; end; function TInterfacedPersistent.QueryInterface(const IID: TGUID; out Obj): integer; begin Result:=E_NOINTERFACE; if GetInterface(IID, Obj) then Result:=0; end; procedure TInterfacedPersistent.AfterConstruction; begin inherited AfterConstruction; if (GetOwner<>nil) then GetOwner.GetInterface(IInterface, FOwnerInterface); end; { TComponentEnumerator } constructor TComponentEnumerator.Create(AComponent: TComponent); begin inherited Create; FComponent := AComponent; FPosition := -1; end; function TComponentEnumerator.GetCurrent: TComponent; begin Result := FComponent.Components[FPosition]; end; function TComponentEnumerator.MoveNext: Boolean; begin Inc(FPosition); Result := FPosition < FComponent.ComponentCount; end; { TListEnumerator } constructor TListEnumerator.Create(AList: TList); begin inherited Create; FList := AList; FPosition := -1; end; function TListEnumerator.GetCurrent: JSValue; begin Result := FList[FPosition]; end; function TListEnumerator.MoveNext: Boolean; begin Inc(FPosition); Result := FPosition < FList.Count; end; { TFPListEnumerator } constructor TFPListEnumerator.Create(AList: TFPList); begin inherited Create; FList := AList; FPosition := -1; end; function TFPListEnumerator.GetCurrent: JSValue; begin Result := FList[FPosition]; end; function TFPListEnumerator.MoveNext: Boolean; begin Inc(FPosition); Result := FPosition < FList.Count; end; { TFPList } procedure TFPList.CopyMove(aList: TFPList); var r : integer; begin Clear; for r := 0 to aList.count-1 do Add(aList[r]); end; procedure TFPList.MergeMove(aList: TFPList); var r : integer; begin For r := 0 to aList.count-1 do if IndexOf(aList[r]) < 0 then Add(aList[r]); end; procedure TFPList.DoCopy(ListA, ListB: TFPList); begin if Assigned(ListB) then CopyMove(ListB) else CopyMove(ListA); end; procedure TFPList.DoSrcUnique(ListA, ListB: TFPList); var r : integer; begin if Assigned(ListB) then begin Clear; for r := 0 to ListA.Count-1 do if ListB.IndexOf(ListA[r]) < 0 then Add(ListA[r]); end else begin for r := Count-1 downto 0 do if ListA.IndexOf(Self[r]) >= 0 then Delete(r); end; end; procedure TFPList.DoAnd(ListA, ListB: TFPList); var r : integer; begin if Assigned(ListB) then begin Clear; for r := 0 to ListA.count-1 do if ListB.IndexOf(ListA[r]) >= 0 then Add(ListA[r]); end else begin for r := Count-1 downto 0 do if ListA.IndexOf(Self[r]) < 0 then Delete(r); end; end; procedure TFPList.DoDestUnique(ListA, ListB: TFPList); procedure MoveElements(Src, Dest: TFPList); var r : integer; begin Clear; for r := 0 to Src.count-1 do if Dest.IndexOf(Src[r]) < 0 then self.Add(Src[r]); end; var Dest : TFPList; begin if Assigned(ListB) then MoveElements(ListB, ListA) else Dest := TFPList.Create; try Dest.CopyMove(Self); MoveElements(ListA, Dest) finally Dest.Destroy; end; end; procedure TFPList.DoOr(ListA, ListB: TFPList); begin if Assigned(ListB) then begin CopyMove(ListA); MergeMove(ListB); end else MergeMove(ListA); end; procedure TFPList.DoXOr(ListA, ListB: TFPList); var r : integer; l : TFPList; begin if Assigned(ListB) then begin Clear; for r := 0 to ListA.Count-1 do if ListB.IndexOf(ListA[r]) < 0 then Add(ListA[r]); for r := 0 to ListB.Count-1 do if ListA.IndexOf(ListB[r]) < 0 then Add(ListB[r]); end else begin l := TFPList.Create; try l.CopyMove(Self); for r := Count-1 downto 0 do if listA.IndexOf(Self[r]) >= 0 then Delete(r); for r := 0 to ListA.Count-1 do if l.IndexOf(ListA[r]) < 0 then Add(ListA[r]); finally l.Destroy; end; end; end; function TFPList.Get(Index: Integer): JSValue; begin If (Index < 0) or (Index >= FCount) then RaiseIndexError(Index); Result:=FList[Index]; end; procedure TFPList.Put(Index: Integer; Item: JSValue); begin if (Index < 0) or (Index >= FCount) then RaiseIndexError(Index); FList[Index] := Item; end; procedure TFPList.SetCapacity(NewCapacity: Integer); begin If (NewCapacity < FCount) then Error (SListCapacityError, str(NewCapacity)); if NewCapacity = FCapacity then exit; SetLength(FList,NewCapacity); FCapacity := NewCapacity; end; procedure TFPList.SetCount(NewCount: Integer); begin if (NewCount < 0) then Error(SListCountError, str(NewCount)); If NewCount > FCount then begin If NewCount > FCapacity then SetCapacity(NewCount); end; FCount := NewCount; end; procedure TFPList.RaiseIndexError(Index: Integer); begin Error(SListIndexError, str(Index)); end; destructor TFPList.Destroy; begin Clear; inherited Destroy; end; procedure TFPList.AddList(AList: TFPList); Var I : Integer; begin If (Capacity=FCount) then Error (SListIndexError, str(Index)); FCount := FCount-1; System.Delete(FList,Index,1); Dec(FCapacity); end; class procedure TFPList.Error(const Msg: string; const Data: String); begin Raise EListError.CreateFmt(Msg,[Data]); end; procedure TFPList.Exchange(Index1, Index2: Integer); var Temp : JSValue; begin If (Index1 >= FCount) or (Index1 < 0) then Error(SListIndexError, str(Index1)); If (Index2 >= FCount) or (Index2 < 0) then Error(SListIndexError, str(Index2)); Temp := FList[Index1]; FList[Index1] := FList[Index2]; FList[Index2] := Temp; end; function TFPList.Expand: TFPList; var IncSize : Integer; begin if FCount < FCapacity then exit(self); IncSize := 4; if FCapacity > 3 then IncSize := IncSize + 4; if FCapacity > 8 then IncSize := IncSize+8; if FCapacity > 127 then Inc(IncSize, FCapacity shr 2); SetCapacity(FCapacity + IncSize); Result := Self; end; function TFPList.Extract(Item: JSValue): JSValue; var i : Integer; begin i := IndexOf(Item); if i >= 0 then begin Result := Item; Delete(i); end else Result := nil; end; function TFPList.First: JSValue; begin If FCount = 0 then Result := Nil else Result := Items[0]; end; function TFPList.GetEnumerator: TFPListEnumerator; begin Result:=TFPListEnumerator.Create(Self); end; function TFPList.IndexOf(Item: JSValue): Integer; Var C : Integer; begin Result:=0; C:=Count; while (ResultItem) do Inc(Result); If Result>=C then Result:=-1; end; function TFPList.IndexOfItem(Item: JSValue; Direction: TDirection): Integer; begin if Direction=fromBeginning then Result:=IndexOf(Item) else begin Result:=Count-1; while (Result >=0) and (Flist[Result]<>Item) do Result:=Result - 1; end; end; procedure TFPList.Insert(Index: Integer; Item: JSValue); begin if (Index < 0) or (Index > FCount )then Error(SlistIndexError, str(Index)); TJSArray(FList).splice(Index, 0, Item); inc(FCapacity); inc(FCount); end; function TFPList.Last: JSValue; begin If FCount = 0 then Result := nil else Result := Items[FCount - 1]; end; procedure TFPList.Move(CurIndex, NewIndex: Integer); var Temp: JSValue; begin if (CurIndex < 0) or (CurIndex > Count - 1) then Error(SListIndexError, str(CurIndex)); if (NewIndex < 0) or (NewIndex > Count -1) then Error(SlistIndexError, str(NewIndex)); if CurIndex=NewIndex then exit; Temp:=FList[CurIndex]; // ToDo: use TJSArray.copyWithin if available TJSArray(FList).splice(CurIndex,1); TJSArray(FList).splice(NewIndex,0,Temp); end; procedure TFPList.Assign(ListA: TFPList; AOperator: TListAssignOp; ListB: TFPList); begin case AOperator of laCopy : DoCopy (ListA, ListB); // replace dest with src laSrcUnique : DoSrcUnique (ListA, ListB); // replace dest with src that are not in dest laAnd : DoAnd (ListA, ListB); // remove from dest that are not in src laDestUnique: DoDestUnique (ListA, ListB);// remove from dest that are in src laOr : DoOr (ListA, ListB); // add to dest from src and not in dest laXOr : DoXOr (ListA, ListB); // add to dest from src and not in dest, remove from dest that are in src end; end; function TFPList.Remove(Item: JSValue): Integer; begin Result := IndexOf(Item); If Result <> -1 then Delete(Result); end; procedure TFPList.Pack; var Dst, i: Integer; V: JSValue; begin Dst:=0; for i:=0 to Count-1 do begin V:=FList[i]; if not Assigned(V) then continue; FList[Dst]:=V; inc(Dst); end; end; // Needed by Sort method. Procedure QuickSort(aList: TJSValueDynArray; L, R : Longint; const Compare: TListSortCompare); var I, J : Longint; P, Q : JSValue; begin repeat I := L; J := R; P := aList[ (L + R) div 2 ]; repeat while Compare(P, aList[i]) > 0 do I := I + 1; while Compare(P, aList[J]) < 0 do J := J - 1; If I <= J then begin Q := aList[I]; aList[I] := aList[J]; aList[J] := Q; I := I + 1; J := J - 1; end; until I > J; // sort the smaller range recursively // sort the bigger range via the loop // Reasons: memory usage is O(log(n)) instead of O(n) and loop is faster than recursion if J - L < R - I then begin if L < J then QuickSort(aList, L, J, Compare); L := I; end else begin if I < R then QuickSort(aList, I, R, Compare); R := J; end; until L >= R; end; procedure TFPList.Sort(const Compare: TListSortCompare); begin if Not Assigned(FList) or (FCount < 2) then exit; QuickSort(Flist, 0, FCount-1, Compare); end; procedure TFPList.ForEachCall(const proc2call: TListCallback; const arg: JSValue ); var i : integer; v : JSValue; begin For I:=0 To Count-1 Do begin v:=FList[i]; if Assigned(v) then proc2call(v,arg); end; end; procedure TFPList.ForEachCall(const proc2call: TListStaticCallback; const arg: JSValue); var i : integer; v : JSValue; begin For I:=0 To Count-1 Do begin v:=FList[i]; if Assigned(v) then proc2call(v,arg); end; end; { TList } procedure TList.CopyMove(aList: TList); var r : integer; begin Clear; for r := 0 to aList.count-1 do Add(aList[r]); end; procedure TList.MergeMove(aList: TList); var r : integer; begin For r := 0 to aList.count-1 do if IndexOf(aList[r]) < 0 then Add(aList[r]); end; procedure TList.DoCopy(ListA, ListB: TList); begin if Assigned(ListB) then CopyMove(ListB) else CopyMove(ListA); end; procedure TList.DoSrcUnique(ListA, ListB: TList); var r : integer; begin if Assigned(ListB) then begin Clear; for r := 0 to ListA.Count-1 do if ListB.IndexOf(ListA[r]) < 0 then Add(ListA[r]); end else begin for r := Count-1 downto 0 do if ListA.IndexOf(Self[r]) >= 0 then Delete(r); end; end; procedure TList.DoAnd(ListA, ListB: TList); var r : integer; begin if Assigned(ListB) then begin Clear; for r := 0 to ListA.Count-1 do if ListB.IndexOf(ListA[r]) >= 0 then Add(ListA[r]); end else begin for r := Count-1 downto 0 do if ListA.IndexOf(Self[r]) < 0 then Delete(r); end; end; procedure TList.DoDestUnique(ListA, ListB: TList); procedure MoveElements(Src, Dest : TList); var r : integer; begin Clear; for r := 0 to Src.Count-1 do if Dest.IndexOf(Src[r]) < 0 then Add(Src[r]); end; var Dest : TList; begin if Assigned(ListB) then MoveElements(ListB, ListA) else try Dest := TList.Create; Dest.CopyMove(Self); MoveElements(ListA, Dest) finally Dest.Destroy; end; end; procedure TList.DoOr(ListA, ListB: TList); begin if Assigned(ListB) then begin CopyMove(ListA); MergeMove(ListB); end else MergeMove(ListA); end; procedure TList.DoXOr(ListA, ListB: TList); var r : integer; l : TList; begin if Assigned(ListB) then begin Clear; for r := 0 to ListA.Count-1 do if ListB.IndexOf(ListA[r]) < 0 then Add(ListA[r]); for r := 0 to ListB.Count-1 do if ListA.IndexOf(ListB[r]) < 0 then Add(ListB[r]); end else try l := TList.Create; l.CopyMove (Self); for r := Count-1 downto 0 do if listA.IndexOf(Self[r]) >= 0 then Delete(r); for r := 0 to ListA.Count-1 do if l.IndexOf(ListA[r]) < 0 then Add(ListA[r]); finally l.Destroy; end; end; function TList.Get(Index: Integer): JSValue; begin Result := FList.Get(Index); end; procedure TList.Put(Index: Integer; Item: JSValue); var V : JSValue; begin V := Get(Index); FList.Put(Index, Item); if Assigned(V) then Notify(V, lnDeleted); if Assigned(Item) then Notify(Item, lnAdded); end; procedure TList.Notify(aValue: JSValue; Action: TListNotification); begin if Assigned(aValue) then ; if Action=lnExtracted then ; end; procedure TList.SetCapacity(NewCapacity: Integer); begin FList.SetCapacity(NewCapacity); end; function TList.GetCapacity: integer; begin Result := FList.Capacity; end; procedure TList.SetCount(NewCount: Integer); begin if NewCount < FList.Count then while FList.Count > NewCount do Delete(FList.Count - 1) else FList.SetCount(NewCount); end; function TList.GetCount: integer; begin Result := FList.Count; end; function TList.GetList: TJSValueDynArray; begin Result := FList.List; end; constructor TList.Create; begin inherited Create; FList := TFPList.Create; end; destructor TList.Destroy; begin if Assigned(FList) then Clear; FreeAndNil(FList); end; procedure TList.AddList(AList: TList); var I: Integer; begin { this only does FList.AddList(AList.FList), avoiding notifications } FList.AddList(AList.FList); { make lnAdded notifications } for I := 0 to AList.Count - 1 do if Assigned(AList[I]) then Notify(AList[I], lnAdded); end; function TList.Add(Item: JSValue): Integer; begin Result := FList.Add(Item); if Assigned(Item) then Notify(Item, lnAdded); end; procedure TList.Clear; begin While (FList.Count>0) do Delete(Count-1); end; procedure TList.Delete(Index: Integer); var V : JSValue; begin V:=FList.Get(Index); FList.Delete(Index); if assigned(V) then Notify(V, lnDeleted); end; class procedure TList.Error(const Msg: string; Data: String); begin Raise EListError.CreateFmt(Msg,[Data]); end; procedure TList.Exchange(Index1, Index2: Integer); begin FList.Exchange(Index1, Index2); end; function TList.Expand: TList; begin FList.Expand; Result:=Self; end; function TList.Extract(Item: JSValue): JSValue; var c : integer; begin c := FList.Count; Result := FList.Extract(Item); if c <> FList.Count then Notify (Result, lnExtracted); end; function TList.First: JSValue; begin Result := FList.First; end; function TList.GetEnumerator: TListEnumerator; begin Result:=TListEnumerator.Create(Self); end; function TList.IndexOf(Item: JSValue): Integer; begin Result := FList.IndexOf(Item); end; procedure TList.Insert(Index: Integer; Item: JSValue); begin FList.Insert(Index, Item); if Assigned(Item) then Notify(Item,lnAdded); end; function TList.Last: JSValue; begin Result := FList.Last; end; procedure TList.Move(CurIndex, NewIndex: Integer); begin FList.Move(CurIndex, NewIndex); end; procedure TList.Assign(ListA: TList; AOperator: TListAssignOp; ListB: TList); begin case AOperator of laCopy : DoCopy (ListA, ListB); // replace dest with src laSrcUnique : DoSrcUnique (ListA, ListB); // replace dest with src that are not in dest laAnd : DoAnd (ListA, ListB); // remove from dest that are not in src laDestUnique: DoDestUnique (ListA, ListB);// remove from dest that are in src laOr : DoOr (ListA, ListB); // add to dest from src and not in dest laXOr : DoXOr (ListA, ListB); // add to dest from src and not in dest, remove from dest that are in src end; end; function TList.Remove(Item: JSValue): Integer; begin Result := IndexOf(Item); if Result <> -1 then Self.Delete(Result); end; procedure TList.Pack; begin FList.Pack; end; procedure TList.Sort(const Compare: TListSortCompare); begin FList.Sort(Compare); end; { TPersistent } procedure TPersistent.AssignError(Source: TPersistent); var SourceName: String; begin if Source<>Nil then SourceName:=Source.ClassName else SourceName:='Nil'; raise EConvertError.Create('Cannot assign a '+SourceName+' to a '+ClassName+'.'); end; procedure TPersistent.AssignTo(Dest: TPersistent); begin Dest.AssignError(Self); end; function TPersistent.GetOwner: TPersistent; begin Result:=nil; end; procedure TPersistent.Assign(Source: TPersistent); begin If Source<>Nil then Source.AssignTo(Self) else AssignError(Nil); end; function TPersistent.GetNamePath: string; var OwnerName: String; TheOwner: TPersistent; begin Result:=ClassName; TheOwner:=GetOwner; if TheOwner<>Nil then begin OwnerName:=TheOwner.GetNamePath; if OwnerName<>'' then Result:=OwnerName+'.'+Result; end; end; { This file is part of the Free Component Library (FCL) Copyright (c) 1999-2000 by the Free Pascal development team See the file COPYING.FPC, included in this distribution, for details about the copyright. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. **********************************************************************} {****************************************************************************} {* TStringsEnumerator *} {****************************************************************************} constructor TStringsEnumerator.Create(AStrings: TStrings); begin inherited Create; FStrings := AStrings; FPosition := -1; end; function TStringsEnumerator.GetCurrent: String; begin Result := FStrings[FPosition]; end; function TStringsEnumerator.MoveNext: Boolean; begin Inc(FPosition); Result := FPosition < FStrings.Count; end; {****************************************************************************} {* TStrings *} {****************************************************************************} // Function to quote text. Should move maybe to sysutils !! // Also, it is not clear at this point what exactly should be done. { //!! is used to mark unsupported things. } { For compatibility we can't add a Constructor to TSTrings to initialize the special characters. Therefore we add a routine which is called whenever the special chars are needed. } Procedure Tstrings.CheckSpecialChars; begin If Not FSpecialCharsInited then begin FQuoteChar:='"'; FDelimiter:=','; FNameValueSeparator:='='; FLBS:=DefaultTextLineBreakStyle; FSpecialCharsInited:=true; FLineBreak:=sLineBreak; end; end; Function TStrings.GetSkipLastLineBreak : Boolean; begin CheckSpecialChars; Result:=FSkipLastLineBreak; end; procedure TStrings.SetSkipLastLineBreak(const AValue : Boolean); begin CheckSpecialChars; FSkipLastLineBreak:=AValue; end; Function TStrings.GetLBS : TTextLineBreakStyle; begin CheckSpecialChars; Result:=FLBS; end; Procedure TStrings.SetLBS (AValue : TTextLineBreakStyle); begin CheckSpecialChars; FLBS:=AValue; end; procedure TStrings.SetDelimiter(c:Char); begin CheckSpecialChars; FDelimiter:=c; end; Function TStrings.GetDelimiter : Char; begin CheckSpecialChars; Result:=FDelimiter; end; procedure TStrings.SetLineBreak(Const S : String); begin CheckSpecialChars; FLineBreak:=S; end; Function TStrings.GetLineBreak : String; begin CheckSpecialChars; Result:=FLineBreak; end; procedure TStrings.SetQuoteChar(c:Char); begin CheckSpecialChars; FQuoteChar:=c; end; Function TStrings.GetQuoteChar :Char; begin CheckSpecialChars; Result:=FQuoteChar; end; procedure TStrings.SetNameValueSeparator(c:Char); begin CheckSpecialChars; FNameValueSeparator:=c; end; Function TStrings.GetNameValueSeparator :Char; begin CheckSpecialChars; Result:=FNameValueSeparator; end; function TStrings.GetCommaText: string; Var C1,C2 : Char; FSD : Boolean; begin CheckSpecialChars; FSD:=StrictDelimiter; C1:=Delimiter; C2:=QuoteChar; Delimiter:=','; QuoteChar:='"'; StrictDelimiter:=False; Try Result:=GetDelimitedText; Finally Delimiter:=C1; QuoteChar:=C2; StrictDelimiter:=FSD; end; end; Function TStrings.GetDelimitedText: string; Var I: integer; RE : string; S : String; doQuote : Boolean; begin CheckSpecialChars; result:=''; RE:=QuoteChar+'|'+Delimiter; if not StrictDelimiter then RE:=' |'+RE; RE:='/'+RE+'/'; // Check for break characters and quote if required. For i:=0 to count-1 do begin S:=Strings[i]; doQuote:=FAlwaysQuote or (TJSString(s).search(RE)<>-1); if DoQuote then Result:=Result+QuoteString(S,QuoteChar) else Result:=Result+S; if I0 then begin AName:=Copy(AValue,1,L-1); // System.Delete(AValue,1,L); AValue:=Copy(AValue,L+1,length(AValue)-L); end else AName:=''; end; function TStrings.ExtractName(const s:String):String; var L: Longint; begin CheckSpecialChars; L:=Pos(FNameValueSeparator,S); If L<>0 then Result:=Copy(S,1,L-1) else Result:=''; end; function TStrings.GetName(Index: Integer): string; Var V : String; begin GetNameValue(Index,Result,V); end; Function TStrings.GetValue(const Name: string): string; Var L : longint; N : String; begin Result:=''; L:=IndexOfName(Name); If L<>-1 then GetNameValue(L,N,Result); end; Function TStrings.GetValueFromIndex(Index: Integer): string; Var N : String; begin GetNameValue(Index,N,Result); end; Procedure TStrings.SetValueFromIndex(Index: Integer; const Value: string); begin If (Value='') then Delete(Index) else begin If (Index<0) then Index:=Add(''); CheckSpecialChars; Strings[Index]:=GetName(Index)+FNameValueSeparator+Value; end; end; Procedure TStrings.SetDelimitedText(const AValue: string); var i,j:integer; aNotFirst:boolean; begin CheckSpecialChars; BeginUpdate; i:=1; j:=1; aNotFirst:=false; { Paraphrased from Delphi XE2 help: Strings must be separated by Delimiter characters or spaces. They may be enclosed in QuoteChars. QuoteChars in the string must be repeated to distinguish them from the QuoteChars enclosing the string. } try Clear; If StrictDelimiter then begin while i<=length(AValue) do begin // skip delimiter if aNotFirst and (i<=length(AValue)) and (AValue[i]=FDelimiter) then inc(i); // read next string if i<=length(AValue) then begin if AValue[i]=FQuoteChar then begin // next string is quoted j:=i+1; while (j<=length(AValue)) and ( (AValue[j]<>FQuoteChar) or ( (j+1<=length(AValue)) and (AValue[j+1]=FQuoteChar) ) ) do begin if (j<=length(AValue)) and (AValue[j]=FQuoteChar) then inc(j,2) else inc(j); end; // j is position of closing quote Add( StringReplace (Copy(AValue,i+1,j-i-1), FQuoteChar+FQuoteChar,FQuoteChar, [rfReplaceAll])); i:=j+1; end else begin // next string is not quoted; read until delimiter j:=i; while (j<=length(AValue)) and (AValue[j]<>FDelimiter) do inc(j); Add( Copy(AValue,i,j-i)); i:=j; end; end else begin if aNotFirst then Add(''); end; aNotFirst:=true; end; end else begin while i<=length(AValue) do begin // skip delimiter if aNotFirst and (i<=length(AValue)) and (AValue[i]=FDelimiter) then inc(i); // skip spaces while (i<=length(AValue)) and (Ord(AValue[i])<=Ord(' ')) do inc(i); // read next string if i<=length(AValue) then begin if AValue[i]=FQuoteChar then begin // next string is quoted j:=i+1; while (j<=length(AValue)) and ( (AValue[j]<>FQuoteChar) or ( (j+1<=length(AValue)) and (AValue[j+1]=FQuoteChar) ) ) do begin if (j<=length(AValue)) and (AValue[j]=FQuoteChar) then inc(j,2) else inc(j); end; // j is position of closing quote Add( StringReplace (Copy(AValue,i+1,j-i-1), FQuoteChar+FQuoteChar,FQuoteChar, [rfReplaceAll])); i:=j+1; end else begin // next string is not quoted; read until control character/space/delimiter j:=i; while (j<=length(AValue)) and (Ord(AValue[j])>Ord(' ')) and (AValue[j]<>FDelimiter) do inc(j); Add( Copy(AValue,i,j-i)); i:=j; end; end else begin if aNotFirst then Add(''); end; // skip spaces while (i<=length(AValue)) and (Ord(AValue[i])<=Ord(' ')) do inc(i); aNotFirst:=true; end; end; finally EndUpdate; end; end; Procedure TStrings.SetCommaText(const Value: string); Var C1,C2 : Char; begin CheckSpecialChars; C1:=Delimiter; C2:=QuoteChar; Delimiter:=','; QuoteChar:='"'; Try SetDelimitedText(Value); Finally Delimiter:=C1; QuoteChar:=C2; end; end; Procedure TStrings.SetValue(const Name, Value: string); Var L : longint; begin CheckSpecialChars; L:=IndexOfName(Name); if L=-1 then Add (Name+FNameValueSeparator+Value) else Strings[L]:=Name+FNameValueSeparator+value; end; Procedure TStrings.Error(const Msg: string; Data: Integer); begin Raise EStringListError.CreateFmt(Msg,[IntToStr(Data)]); end; Function TStrings.GetCapacity: Integer; begin Result:=Count; end; Function TStrings.GetObject(Index: Integer): TObject; begin if Index=0 then ; Result:=Nil; end; Function TStrings.GetTextStr: string; Var I : Longint; S,NL : String; begin CheckSpecialChars; // Determine needed place if FLineBreak<>sLineBreak then NL:=FLineBreak else Case FLBS of tlbsLF : NL:=#10; tlbsCRLF : NL:=#13#10; tlbsCR : NL:=#13; end; Result:=''; For i:=0 To count-1 do begin S:=Strings[I]; Result:=Result+S; if (I Capacity then Capacity := Count + High(TheStrings)+1; For Runner:=Low(TheStrings) to High(TheStrings) do self.Add(Thestrings[Runner]); end; Procedure TStrings.AddStrings(const TheStrings: array of string; ClearFirst : Boolean); begin beginupdate; try if ClearFirst then Clear; AddStrings(TheStrings); finally EndUpdate; end; end; function TStrings.AddPair(const AName, AValue: string): TStrings; begin Result:=AddPair(AName,AValue,Nil); end; function TStrings.AddPair(const AName, AValue: string; AObject: TObject): TStrings; begin Result := Self; AddObject(AName+NameValueSeparator+AValue, AObject); end; Procedure TStrings.Assign(Source: TPersistent); Var S : TStrings; begin If Source is TStrings then begin S:=TStrings(Source); BeginUpdate; Try clear; FSpecialCharsInited:=S.FSpecialCharsInited; FQuoteChar:=S.FQuoteChar; FDelimiter:=S.FDelimiter; FNameValueSeparator:=S.FNameValueSeparator; FLBS:=S.FLBS; FLineBreak:=S.FLineBreak; AddStrings(S); finally EndUpdate; end; end else Inherited Assign(Source); end; Procedure TStrings.BeginUpdate; begin if FUpdateCount = 0 then SetUpdateState(true); inc(FUpdateCount); end; Procedure TStrings.EndUpdate; begin If FUpdateCount>0 then Dec(FUpdateCount); if FUpdateCount=0 then SetUpdateState(False); end; Function TStrings.Equals(Obj: TObject): Boolean; begin if Obj is TStrings then Result := Equals(TStrings(Obj)) else Result := inherited Equals(Obj); end; Function TStrings.Equals(TheStrings: TStrings): Boolean; Var Runner,Nr : Longint; begin Result:=False; Nr:=Self.Count; if Nr<>TheStrings.Count then exit; For Runner:=0 to Nr-1 do If Strings[Runner]<>TheStrings[Runner] then exit; Result:=True; end; Procedure TStrings.Exchange(Index1, Index2: Integer); Var Obj : TObject; Str : String; begin beginUpdate; Try Obj:=Objects[Index1]; Str:=Strings[Index1]; Objects[Index1]:=Objects[Index2]; Strings[Index1]:=Strings[Index2]; Objects[Index2]:=Obj; Strings[Index2]:=Str; finally EndUpdate; end; end; function TStrings.GetEnumerator: TStringsEnumerator; begin Result:=TStringsEnumerator.Create(Self); end; Function TStrings.DoCompareText(const s1,s2 : string) : PtrInt; begin result:=CompareText(s1,s2); end; Function TStrings.IndexOf(const S: string): Integer; begin Result:=0; While (Result0) do Result:=Result+1; if Result=Count then Result:=-1; end; Function TStrings.IndexOfName(const Name: string): Integer; Var len : longint; S : String; begin CheckSpecialChars; Result:=0; while (Result=0) and (DoCompareText(Name,Copy(S,1,Len))=0) then exit; inc(result); end; result:=-1; end; Function TStrings.IndexOfObject(AObject: TObject): Integer; begin Result:=0; While (ResultAObject) do Result:=Result+1; If Result=Count then Result:=-1; end; Procedure TStrings.InsertObject(Index: Integer; const S: string; AObject: TObject); begin Insert (Index,S); Objects[Index]:=AObject; end; Procedure TStrings.Move(CurIndex, NewIndex: Integer); Var Obj : TObject; Str : String; begin BeginUpdate; Try Obj:=Objects[CurIndex]; Str:=Strings[CurIndex]; Objects[CurIndex]:=Nil; // Prevent Delete from freeing. Delete(Curindex); InsertObject(NewIndex,Str,Obj); finally EndUpdate; end; end; {****************************************************************************} {* TStringList *} {****************************************************************************} procedure TStringList.ExchangeItemsInt(Index1, Index2: Integer); Var S : String; O : TObject; begin S:=Flist[Index1].FString; O:=Flist[Index1].FObject; Flist[Index1].Fstring:=Flist[Index2].Fstring; Flist[Index1].FObject:=Flist[Index2].FObject; Flist[Index2].Fstring:=S; Flist[Index2].FObject:=O; end; function TStringList.GetSorted: Boolean; begin Result:=FSortStyle in [sslUser,sslAuto]; end; procedure TStringList.ExchangeItems(Index1, Index2: Integer); begin ExchangeItemsInt(Index1, Index2); end; procedure TStringList.Grow; Var NC : Integer; begin NC:=Capacity; If NC>=256 then NC:=NC+(NC Div 4) else if NC=0 then NC:=4 else NC:=NC*4; SetCapacity(NC); end; procedure TStringList.InternalClear(FromIndex: Integer; ClearOnly: Boolean); Var I: Integer; begin if FromIndex < FCount then begin if FOwnsObjects then begin For I:=FromIndex to FCount-1 do begin Flist[I].FString:=''; freeandnil(Flist[i].FObject); end; end else begin For I:=FromIndex to FCount-1 do Flist[I].FString:=''; end; FCount:=FromIndex; end; if Not ClearOnly then SetCapacity(0); end; procedure TStringList.QuickSort(L, R: Integer; CompareFn: TStringListSortCompare ); var Pivot, vL, vR: Integer; begin //if ExchangeItems is override call that, else call (faster) ExchangeItemsInt if R - L <= 1 then begin // a little bit of time saver if L < R then if CompareFn(Self, L, R) > 0 then ExchangeItems(L, R); Exit; end; vL := L; vR := R; Pivot := L + Random(R - L); // they say random is best while vL < vR do begin while (vL < Pivot) and (CompareFn(Self, vL, Pivot) <= 0) do Inc(vL); while (vR > Pivot) and (CompareFn(Self, vR, Pivot) > 0) do Dec(vR); ExchangeItems(vL, vR); if Pivot = vL then // swap pivot if we just hit it from one side Pivot := vR else if Pivot = vR then Pivot := vL; end; if Pivot - 1 >= L then QuickSort(L, Pivot - 1, CompareFn); if Pivot + 1 <= R then QuickSort(Pivot + 1, R, CompareFn); end; procedure TStringList.InsertItem(Index: Integer; const S: string); begin InsertItem(Index, S, nil); end; procedure TStringList.InsertItem(Index: Integer; const S: string; O: TObject); Var It : TStringItem; begin Changing; If FCount=Capacity then Grow; it.FString:=S; it.FObject:=O; TJSArray(FList).Splice(Index,0,It); Inc(FCount); Changed; end; procedure TStringList.SetSorted(Value: Boolean); begin If Value then SortStyle:=sslAuto else SortStyle:=sslNone end; procedure TStringList.Changed; begin If (FUpdateCount=0) Then begin If Assigned(FOnChange) then FOnchange(Self); end; end; procedure TStringList.Changing; begin If FUpdateCount=0 then if Assigned(FOnChanging) then FOnchanging(Self); end; function TStringList.Get(Index: Integer): string; begin CheckIndex(Index); Result:=Flist[Index].FString; end; function TStringList.GetCapacity: Integer; begin Result:=Length(FList); end; function TStringList.GetCount: Integer; begin Result:=FCount; end; function TStringList.GetObject(Index: Integer): TObject; begin CheckIndex(Index); Result:=Flist[Index].FObject; end; procedure TStringList.Put(Index: Integer; const S: string); begin If Sorted then Error(SSortedListError,0); CheckIndex(Index); Changing; Flist[Index].FString:=S; Changed; end; procedure TStringList.PutObject(Index: Integer; AObject: TObject); begin CheckIndex(Index); Changing; Flist[Index].FObject:=AObject; Changed; end; procedure TStringList.SetCapacity(NewCapacity: Integer); begin If (NewCapacity<0) then Error (SListCapacityError,NewCapacity); If NewCapacity<>Capacity then SetLength(FList,NewCapacity) end; procedure TStringList.SetUpdateState(Updating: Boolean); begin If Updating then Changing else Changed end; destructor TStringList.Destroy; begin InternalClear; Inherited destroy; end; function TStringList.Add(const S: string): Integer; begin If Not (SortStyle=sslAuto) then Result:=FCount else If Find (S,Result) then Case DUplicates of DupIgnore : Exit; DupError : Error(SDuplicateString,0) end; InsertItem (Result,S); end; procedure TStringList.Clear; begin if FCount = 0 then Exit; Changing; InternalClear; Changed; end; procedure TStringList.Delete(Index: Integer); begin CheckIndex(Index); Changing; if FOwnsObjects then FreeAndNil(Flist[Index].FObject); TJSArray(FList).splice(Index,1); FList[Count-1].FString:=''; Flist[Count-1].FObject:=Nil; Dec(FCount); Changed; end; procedure TStringList.Exchange(Index1, Index2: Integer); begin CheckIndex(Index1); CheckIndex(Index2); Changing; ExchangeItemsInt(Index1,Index2); changed; end; procedure TStringList.SetCaseSensitive(b : boolean); begin if b=FCaseSensitive then Exit; FCaseSensitive:=b; if FSortStyle=sslAuto then begin FForceSort:=True; try Sort; finally FForceSort:=False; end; end; end; procedure TStringList.SetSortStyle(AValue: TStringsSortStyle); begin if FSortStyle=AValue then Exit; if (AValue=sslAuto) then Sort; FSortStyle:=AValue; end; procedure TStringList.CheckIndex(AIndex: Integer); begin If (AIndex<0) or (AIndex>=FCount) then Error(SListIndexError,AIndex); end; function TStringList.DoCompareText(const s1, s2: string): PtrInt; begin if FCaseSensitive then result:=CompareStr(s1,s2) else result:=CompareText(s1,s2); end; function TStringList.CompareStrings(const s1,s2 : string) : Integer; begin Result := DoCompareText(s1, s2); end; function TStringList.Find(const S: string; out Index: Integer): Boolean; var L, R, I: Integer; CompareRes: PtrInt; begin Result := false; Index:=-1; if Not Sorted then Raise EListError.Create(SErrFindNeedsSortedList); // Use binary search. L := 0; R := Count - 1; while (L<=R) do begin I := L + (R - L) div 2; CompareRes := DoCompareText(S, Flist[I].FString); if (CompareRes>0) then L := I+1 else begin R := I-1; if (CompareRes=0) then begin Result := true; if (Duplicates<>dupAccept) then L := I; // forces end of while loop end; end; end; Index := L; end; function TStringList.IndexOf(const S: string): Integer; begin If Not Sorted then Result:=Inherited indexOf(S) else // faster using binary search... If Not Find (S,Result) then Result:=-1; end; procedure TStringList.Insert(Index: Integer; const S: string); begin If SortStyle=sslAuto then Error (SSortedListError,0) else begin If (Index<0) or (Index>FCount) then Error(SListIndexError,Index); // Cannot use CheckIndex, because there >= FCount... InsertItem (Index,S); end; end; procedure TStringList.CustomSort(CompareFn: TStringListSortCompare); begin If (FForceSort or (Not (FSortStyle=sslAuto))) and (FCount>1) then begin Changing; QuickSort(0,FCount-1, CompareFn); Changed; end; end; function StringListAnsiCompare(List: TStringList; Index1, Index: Integer): Integer; begin Result := List.DoCompareText(List.FList[Index1].FString, List.FList[Index].FString); end; procedure TStringList.Sort; begin CustomSort(@StringListAnsiCompare); end; {****************************************************************************} {* TCollectionItem *} {****************************************************************************} function TCollectionItem.GetIndex: Integer; begin if FCollection<>nil then Result:=FCollection.FItems.IndexOf(Self) else Result:=-1; end; procedure TCollectionItem.SetCollection(Value: TCollection); begin IF Value<>FCollection then begin If FCollection<>Nil then FCollection.RemoveItem(Self); if Value<>Nil then Value.InsertItem(Self); end; end; procedure TCollectionItem.Changed(AllItems: Boolean); begin If (FCollection<>Nil) and (FCollection.UpdateCount=0) then begin If AllItems then FCollection.Update(Nil) else FCollection.Update(Self); end; end; function TCollectionItem.GetNamePath: string; begin If FCollection<>Nil then Result:=FCollection.GetNamePath+'['+IntToStr(Index)+']' else Result:=ClassName; end; function TCollectionItem.GetOwner: TPersistent; begin Result:=FCollection; end; function TCollectionItem.GetDisplayName: string; begin Result:=ClassName; end; procedure TCollectionItem.SetIndex(Value: Integer); Var Temp : Longint; begin Temp:=GetIndex; If (Temp>-1) and (Temp<>Value) then begin FCollection.FItems.Move(Temp,Value); Changed(True); end; end; procedure TCollectionItem.SetDisplayName(const Value: string); begin Changed(False); if Value='' then ; end; constructor TCollectionItem.Create(ACollection: TCollection); begin Inherited Create; SetCollection(ACollection); end; destructor TCollectionItem.Destroy; begin SetCollection(Nil); Inherited Destroy; end; {****************************************************************************} {* TCollectionEnumerator *} {****************************************************************************} constructor TCollectionEnumerator.Create(ACollection: TCollection); begin inherited Create; FCollection := ACollection; FPosition := -1; end; function TCollectionEnumerator.GetCurrent: TCollectionItem; begin Result := FCollection.Items[FPosition]; end; function TCollectionEnumerator.MoveNext: Boolean; begin Inc(FPosition); Result := FPosition < FCollection.Count; end; {****************************************************************************} {* TCollection *} {****************************************************************************} function TCollection.Owner: TPersistent; begin result:=getowner; end; function TCollection.GetCount: Integer; begin Result:=FItems.Count; end; Procedure TCollection.SetPropName; { Var TheOwner : TPersistent; PropList : PPropList; I, PropCount : Integer; } begin FPropName:=''; { TheOwner:=GetOwner; // TODO: This needs to wait till Mattias finishes typeinfo. // It's normally only used in the designer so should not be a problem currently. if (TheOwner=Nil) Or (TheOwner.Classinfo=Nil) Then Exit; // get information from the owner RTTI PropCount:=GetPropList(TheOwner, PropList); Try For I:=0 To PropCount-1 Do If (PropList^[i]^.PropType^.Kind=tkClass) And (GetObjectProp(TheOwner, PropList^[i], ClassType)=Self) Then Begin FPropName:=PropList^[i]^.Name; Exit; End; Finally FreeMem(PropList); End; } end; function TCollection.GetPropName: string; {Var TheOwner : TPersistent;} begin Result:=FPropNAme; // TheOwner:=GetOwner; // If (Result<>'') or (TheOwner=Nil) Or (TheOwner.Classinfo=Nil) then exit; SetPropName; Result:=FPropName; end; procedure TCollection.InsertItem(Item: TCollectionItem); begin If Not(Item Is FitemClass) then exit; FItems.add(Item); Item.FCollection:=Self; Item.FID:=FNextID; inc(FNextID); SetItemName(Item); Notify(Item,cnAdded); Changed; end; procedure TCollection.RemoveItem(Item: TCollectionItem); Var I : Integer; begin Notify(Item,cnExtracting); I:=FItems.IndexOfItem(Item,fromEnd); If (I<>-1) then FItems.Delete(I); Item.FCollection:=Nil; Changed; end; function TCollection.GetAttrCount: Integer; begin Result:=0; end; function TCollection.GetAttr(Index: Integer): string; begin Result:=''; if Index=0 then ; end; function TCollection.GetItemAttr(Index, ItemIndex: Integer): string; begin Result:=TCollectionItem(FItems.Items[ItemIndex]).DisplayName; if Index=0 then ; end; function TCollection.GetEnumerator: TCollectionEnumerator; begin Result := TCollectionEnumerator.Create(Self); end; function TCollection.GetNamePath: string; var o : TPersistent; begin o:=getowner; if assigned(o) and (propname<>'') then result:=o.getnamepath+'.'+propname else result:=classname; end; procedure TCollection.Changed; begin if FUpdateCount=0 then Update(Nil); end; function TCollection.GetItem(Index: Integer): TCollectionItem; begin Result:=TCollectionItem(FItems.Items[Index]); end; procedure TCollection.SetItem(Index: Integer; Value: TCollectionItem); begin TCollectionItem(FItems.items[Index]).Assign(Value); end; procedure TCollection.SetItemName(Item: TCollectionItem); begin if Item=nil then ; end; procedure TCollection.Update(Item: TCollectionItem); begin if Item=nil then ; end; constructor TCollection.Create(AItemClass: TCollectionItemClass); begin inherited create; FItemClass:=AItemClass; FItems:=TFpList.Create; end; destructor TCollection.Destroy; begin FUpdateCount:=1; // Prevent OnChange try DoClear; Finally FUpdateCount:=0; end; if assigned(FItems) then FItems.Destroy; Inherited Destroy; end; function TCollection.Add: TCollectionItem; begin Result:=FItemClass.Create(Self); end; procedure TCollection.Assign(Source: TPersistent); Var I : Longint; begin If Source is TCollection then begin Clear; For I:=0 To TCollection(Source).Count-1 do Add.Assign(TCollection(Source).Items[I]); exit; end else Inherited Assign(Source); end; procedure TCollection.BeginUpdate; begin inc(FUpdateCount); end; procedure TCollection.Clear; begin if FItems.Count=0 then exit; // Prevent Changed BeginUpdate; try DoClear; finally EndUpdate; end; end; procedure TCollection.DoClear; var Item: TCollectionItem; begin While FItems.Count>0 do begin Item:=TCollectionItem(FItems.Last); if Assigned(Item) then Item.Destroy; end; end; procedure TCollection.EndUpdate; begin if FUpdateCount>0 then dec(FUpdateCount); if FUpdateCount=0 then Changed; end; function TCollection.FindItemID(ID: Integer): TCollectionItem; Var I : Longint; begin For I:=0 to Fitems.Count-1 do begin Result:=TCollectionItem(FItems.items[I]); If Result.Id=Id then exit; end; Result:=Nil; end; procedure TCollection.Delete(Index: Integer); Var Item : TCollectionItem; begin Item:=TCollectionItem(FItems[Index]); Notify(Item,cnDeleting); If assigned(Item) then Item.Destroy; end; function TCollection.Insert(Index: Integer): TCollectionItem; begin Result:=Add; Result.Index:=Index; end; procedure TCollection.Notify(Item: TCollectionItem;Action: TCollectionNotification); begin if Item=nil then ; if Action=cnAdded then ; end; procedure TCollection.Sort(Const Compare : TCollectionSortCompare); begin BeginUpdate; try FItems.Sort(TListSortCompare(Compare)); Finally EndUpdate; end; end; procedure TCollection.Exchange(Const Index1, index2: integer); begin FItems.Exchange(Index1,Index2); end; {****************************************************************************} {* TOwnedCollection *} {****************************************************************************} Constructor TOwnedCollection.Create(AOwner: TPersistent; AItemClass: TCollectionItemClass); Begin FOwner := AOwner; inherited Create(AItemClass); end; Function TOwnedCollection.GetOwner: TPersistent; begin Result:=FOwner; end; {****************************************************************************} {* TComponent *} {****************************************************************************} Function TComponent.GetComponent(AIndex: Integer): TComponent; begin If not assigned(FComponents) then Result:=Nil else Result:=TComponent(FComponents.Items[Aindex]); end; Function TComponent.GetComponentCount: Integer; begin If not assigned(FComponents) then result:=0 else Result:=FComponents.Count; end; Function TComponent.GetComponentIndex: Integer; begin If Assigned(FOwner) and Assigned(FOwner.FComponents) then Result:=FOWner.FComponents.IndexOf(Self) else Result:=-1; end; Procedure TComponent.Insert(AComponent: TComponent); begin If not assigned(FComponents) then FComponents:=TFpList.Create; FComponents.Add(AComponent); AComponent.FOwner:=Self; end; Procedure TComponent.Remove(AComponent: TComponent); begin AComponent.FOwner:=Nil; If assigned(FCOmponents) then begin FComponents.Remove(AComponent); IF FComponents.Count=0 then begin FComponents.Destroy; FComponents:=Nil; end; end; end; Procedure TComponent.RemoveNotification(AComponent: TComponent); begin if FFreeNotifies<>nil then begin FFreeNotifies.Remove(AComponent); if FFreeNotifies.Count=0 then begin FFreeNotifies.Destroy; FFreeNotifies:=nil; Exclude(FComponentState,csFreeNotification); end; end; end; Procedure TComponent.SetComponentIndex(Value: Integer); Var Temp,Count : longint; begin If Not assigned(Fowner) then exit; Temp:=getcomponentindex; If temp<0 then exit; If value<0 then value:=0; Count:=Fowner.FComponents.Count; If Value>=Count then value:=count-1; If Value<>Temp then begin FOWner.FComponents.Delete(Temp); FOwner.FComponents.Insert(Value,Self); end; end; Procedure TComponent.ChangeName(const NewName: TComponentName); begin FName:=NewName; end; Procedure TComponent.GetChildren(Proc: TGetChildProc; Root: TComponent); begin // Does nothing. if Proc=nil then ; if Root=nil then ; end; Function TComponent.GetChildOwner: TComponent; begin Result:=Nil; end; Function TComponent.GetChildParent: TComponent; begin Result:=Self; end; Function TComponent.GetNamePath: string; begin Result:=FName; end; Function TComponent.GetOwner: TPersistent; begin Result:=FOwner; end; Procedure TComponent.Loaded; begin Exclude(FComponentState,csLoading); end; Procedure TComponent.Loading; begin Include(FComponentState,csLoading); end; procedure TComponent.SetWriting(Value: Boolean); begin If Value then Include(FComponentState,csWriting) else Exclude(FComponentState,csWriting); end; procedure TComponent.SetReading(Value: Boolean); begin If Value then Include(FComponentState,csReading) else Exclude(FComponentState,csReading); end; Procedure TComponent.Notification(AComponent: TComponent; Operation: TOperation); Var C : Longint; begin If (Operation=opRemove) then RemoveFreeNotification(AComponent); If Not assigned(FComponents) then exit; C:=FComponents.Count-1; While (C>=0) do begin TComponent(FComponents.Items[C]).Notification(AComponent,Operation); Dec(C); if C>=FComponents.Count then C:=FComponents.Count-1; end; end; procedure TComponent.PaletteCreated; begin end; Procedure TComponent.SetAncestor(Value: Boolean); Var Runner : Longint; begin If Value then Include(FComponentState,csAncestor) else Exclude(FCOmponentState,csAncestor); if Assigned(FComponents) then For Runner:=0 To FComponents.Count-1 do TComponent(FComponents.Items[Runner]).SetAncestor(Value); end; Procedure TComponent.SetDesigning(Value: Boolean; SetChildren : Boolean = True); Var Runner : Longint; begin If Value then Include(FComponentState,csDesigning) else Exclude(FComponentState,csDesigning); if Assigned(FComponents) and SetChildren then For Runner:=0 To FComponents.Count - 1 do TComponent(FComponents.items[Runner]).SetDesigning(Value); end; Procedure TComponent.SetDesignInstance(Value: Boolean); begin If Value then Include(FComponentState,csDesignInstance) else Exclude(FComponentState,csDesignInstance); end; Procedure TComponent.SetInline(Value: Boolean); begin If Value then Include(FComponentState,csInline) else Exclude(FComponentState,csInline); end; Procedure TComponent.SetName(const NewName: TComponentName); begin If FName=NewName then exit; If (NewName<>'') and not IsValidIdent(NewName) then Raise EComponentError.CreateFmt(SInvalidName,[NewName]); If Assigned(FOwner) Then FOwner.ValidateRename(Self,FName,NewName) else ValidateRename(Nil,FName,NewName); ChangeName(NewName); end; Procedure TComponent.SetChildOrder(Child: TComponent; Order: Integer); begin // does nothing if Child=nil then ; if Order=0 then ; end; Procedure TComponent.SetParentComponent(Value: TComponent); begin // Does nothing if Value=nil then ; end; Procedure TComponent.Updating; begin Include (FComponentState,csUpdating); end; Procedure TComponent.Updated; begin Exclude(FComponentState,csUpdating); end; Procedure TComponent.ValidateRename(AComponent: TComponent; const CurName, NewName: string); begin //!! This contradicts the Delphi manual. If (AComponent<>Nil) and (CompareText(CurName,NewName)<>0) and (AComponent.Owner = Self) and (FindComponent(NewName)<>Nil) then raise EComponentError.Createfmt(SDuplicateName,[newname]); If (csDesigning in FComponentState) and (FOwner<>Nil) then FOwner.ValidateRename(AComponent,Curname,Newname); end; Procedure TComponent.ValidateContainer(AComponent: TComponent); begin AComponent.ValidateInsert(Self); end; Procedure TComponent.ValidateInsert(AComponent: TComponent); begin // Does nothing. if AComponent=nil then ; end; function TComponent._AddRef: Integer; begin Result:=-1; end; function TComponent._Release: Integer; begin Result:=-1; end; Constructor TComponent.Create(AOwner: TComponent); begin FComponentStyle:=[csInheritable]; If Assigned(AOwner) then AOwner.InsertComponent(Self); end; Destructor TComponent.Destroy; Var I : Integer; C : TComponent; begin Destroying; If Assigned(FFreeNotifies) then begin I:=FFreeNotifies.Count-1; While (I>=0) do begin C:=TComponent(FFreeNotifies.Items[I]); // Delete, so one component is not notified twice, if it is owned. FFreeNotifies.Delete(I); C.Notification (self,opRemove); If (FFreeNotifies=Nil) then I:=0 else if (I>FFreeNotifies.Count) then I:=FFreeNotifies.Count; dec(i); end; FreeAndNil(FFreeNotifies); end; DestroyComponents; If FOwner<>Nil Then FOwner.RemoveComponent(Self); inherited destroy; end; Procedure TComponent.BeforeDestruction; begin if not(csDestroying in FComponentstate) then Destroying; end; Procedure TComponent.DestroyComponents; Var acomponent: TComponent; begin While assigned(FComponents) do begin aComponent:=TComponent(FComponents.Last); Remove(aComponent); Acomponent.Destroy; end; end; Procedure TComponent.Destroying; Var Runner : longint; begin If csDestroying in FComponentstate Then Exit; include (FComponentState,csDestroying); If Assigned(FComponents) then for Runner:=0 to FComponents.Count-1 do TComponent(FComponents.Items[Runner]).Destroying; end; function TComponent.QueryInterface(const IID: TGUID; out Obj): integer; begin if GetInterface(IID, Obj) then Result := S_OK else Result := E_NOINTERFACE; end; Function TComponent.FindComponent(const AName: string): TComponent; Var I : longint; begin Result:=Nil; If (AName='') or Not assigned(FComponents) then exit; For i:=0 to FComponents.Count-1 do if (CompareText(TComponent(FComponents[I]).Name,AName)=0) then begin Result:=TComponent(FComponents.Items[I]); exit; end; end; Procedure TComponent.FreeNotification(AComponent: TComponent); begin If (Owner<>Nil) and (AComponent=Owner) then exit; If not (Assigned(FFreeNotifies)) then FFreeNotifies:=TFpList.Create; If FFreeNotifies.IndexOf(AComponent)=-1 then begin FFreeNotifies.Add(AComponent); AComponent.FreeNotification (self); end; end; procedure TComponent.RemoveFreeNotification(AComponent: TComponent); begin RemoveNotification(AComponent); AComponent.RemoveNotification (self); end; Function TComponent.GetParentComponent: TComponent; begin Result:=Nil; end; Function TComponent.HasParent: Boolean; begin Result:=False; end; Procedure TComponent.InsertComponent(AComponent: TComponent); begin AComponent.ValidateContainer(Self); ValidateRename(AComponent,'',AComponent.FName); Insert(AComponent); If csDesigning in FComponentState then AComponent.SetDesigning(true); Notification(AComponent,opInsert); end; Procedure TComponent.RemoveComponent(AComponent: TComponent); begin Notification(AComponent,opRemove); Remove(AComponent); Acomponent.Setdesigning(False); ValidateRename(AComponent,AComponent.FName,''); end; procedure TComponent.SetSubComponent(ASubComponent: Boolean); begin if ASubComponent then Include(FComponentStyle, csSubComponent) else Exclude(FComponentStyle, csSubComponent); end; function TComponent.GetEnumerator: TComponentEnumerator; begin Result:=TComponentEnumerator.Create(Self); end; { --------------------------------------------------------------------- TStream ---------------------------------------------------------------------} Resourcestring SStreamInvalidSeek = 'Seek is not implemented for class %s'; SStreamNoReading = 'Stream reading is not implemented for class %s'; SStreamNoWriting = 'Stream writing is not implemented for class %s'; SReadError = 'Could not read data from stream'; SWriteError = 'Could not write data to stream'; SMemoryStreamError = 'Could not allocate memory'; SerrInvalidStreamSize = 'Invalid Stream size'; procedure TStream.ReadNotImplemented; begin raise EStreamError.CreateFmt(SStreamNoReading, [ClassName]); end; procedure TStream.WriteNotImplemented; begin raise EStreamError.CreateFmt(SStreamNoWriting, [ClassName]); end; function TStream.Read(var Buffer: TBytes; Count: Longint): Longint; begin Result:=Read(Buffer,0,Count); end; function TStream.Write(const Buffer: TBytes; Count: Longint): Longint; begin Result:=Self.Write(Buffer,0,Count); end; function TStream.GetPosition: NativeInt; begin Result:=Seek(0,soCurrent); end; procedure TStream.SetPosition(const Pos: NativeInt); begin Seek(pos,soBeginning); end; procedure TStream.SetSize64(const NewSize: NativeInt); begin // Required because can't use overloaded functions in properties SetSize(NewSize); end; function TStream.GetSize: NativeInt; var p : NativeInt; begin p:=Seek(0,soCurrent); GetSize:=Seek(0,soEnd); Seek(p,soBeginning); end; procedure TStream.SetSize(const NewSize: NativeInt); begin if NewSize<0 then Raise EStreamError.Create(SerrInvalidStreamSize); end; procedure TStream.Discard(const Count: NativeInt); const CSmallSize =255; CLargeMaxBuffer =32*1024; // 32 KiB var Buffer: TBytes; begin if Count=0 then Exit; if (Count<=CSmallSize) then begin SetLength(Buffer,CSmallSize); ReadBuffer(Buffer,Count) end else DiscardLarge(Count,CLargeMaxBuffer); end; procedure TStream.DiscardLarge(Count: NativeInt; const MaxBufferSize: Longint); var Buffer: TBytes; begin if Count=0 then Exit; if Count>MaxBufferSize then SetLength(Buffer,MaxBufferSize) else SetLength(Buffer,Count); while (Count>=Length(Buffer)) do begin ReadBuffer(Buffer,Length(Buffer)); Dec(Count,Length(Buffer)); end; if Count>0 then ReadBuffer(Buffer,Count); end; procedure TStream.InvalidSeek; begin raise EStreamError.CreateFmt(SStreamInvalidSeek, [ClassName]); end; procedure TStream.FakeSeekForward(Offset: NativeInt; const Origin: TSeekOrigin; const Pos: NativeInt); begin if Origin=soBeginning then Dec(Offset,Pos); if (Offset<0) or (Origin=soEnd) then InvalidSeek; if Offset>0 then Discard(Offset); end; function TStream.ReadData({var} Buffer: TBytes; Count: NativeInt): NativeInt; begin Result:=Read(Buffer,0,Count); end; function TStream.ReadMaxSizeData(Buffer : TBytes; aSize,aCount : NativeInt) : NativeInt; Var CP : NativeInt; begin if aCount<=aSize then Result:=read(Buffer,aCount) else begin Result:=Read(Buffer,aSize); CP:=Position; Result:=Result+Seek(aCount-aSize,soCurrent)-CP; end end; function TStream.WriteMaxSizeData(const Buffer : TBytes; aSize,aCount : NativeInt) : NativeInt; Var CP : NativeInt; begin if aCount<=aSize then Result:=Self.Write(Buffer,aCount) else begin Result:=Self.Write(Buffer,aSize); CP:=Position; Result:=Result+Seek(aCount-aSize,soCurrent)-CP; end end; procedure TStream.WriteExactSizeData(const Buffer : TBytes; aSize, aCount: NativeInt); begin // Embarcadero docs mentions no exception. Does not seem very logical WriteMaxSizeData(Buffer,aSize,ACount); end; procedure TStream.ReadExactSizeData(Buffer : TBytes; aSize, aCount: NativeInt); begin if ReadMaxSizeData(Buffer,aSize,ACount)<>aCount then Raise EReadError.Create(SReadError); end; function TStream.ReadData(var Buffer: Boolean): NativeInt; Var B : Byte; begin Result:=ReadData(B,1); if Result=1 then Buffer:=B<>0; end; function TStream.ReadData(var Buffer: Boolean; Count: NativeInt): NativeInt; Var B : TBytes; begin SetLength(B,Count); Result:=ReadMaxSizeData(B,1,Count); if Result>0 then Buffer:=B[0]<>0 end; function TStream.ReadData(var Buffer: WideChar): NativeInt; begin Result:=ReadData(Buffer,2); end; function TStream.ReadData(var Buffer: WideChar; Count: NativeInt): NativeInt; Var W : Word; begin Result:=ReadData(W,Count); if Result=2 then Buffer:=WideChar(W); end; function TStream.ReadData(var Buffer: Int8): NativeInt; begin Result:=ReadData(Buffer,1); end; Function TStream.MakeInt(B : TBytes; aSize : Integer; Signed : Boolean) : NativeInt; Var Mem : TJSArrayBuffer; A : TJSUInt8Array; D : TJSDataView; isLittle : Boolean; begin IsLittle:=(Endian=TEndian.Little); Mem:=TJSArrayBuffer.New(Length(B)); A:=TJSUInt8Array.new(Mem); A._set(B); D:=TJSDataView.New(Mem); if Signed then case aSize of 1 : Result:=D.getInt8(0); 2 : Result:=D.getInt16(0,IsLittle); 4 : Result:=D.getInt32(0,IsLittle); // Todo : fix sign 8 : Result:=Round(D.getFloat64(0,IsLittle)); end else case aSize of 1 : Result:=D.getUInt8(0); 2 : Result:=D.getUInt16(0,IsLittle); 4 : Result:=D.getUInt32(0,IsLittle); 8 : Result:=Round(D.getFloat64(0,IsLittle)); end end; function TStream.MakeBytes(B: NativeInt; aSize: Integer; Signed: Boolean): TBytes; Var Mem : TJSArrayBuffer; A : TJSUInt8Array; D : TJSDataView; isLittle : Boolean; begin IsLittle:=(Endian=TEndian.Little); Mem:=TJSArrayBuffer.New(aSize); D:=TJSDataView.New(Mem); if Signed then case aSize of 1 : D.setInt8(0,B); 2 : D.setInt16(0,B,IsLittle); 4 : D.setInt32(0,B,IsLittle); 8 : D.setFloat64(0,B,IsLittle); end else case aSize of 1 : D.SetUInt8(0,B); 2 : D.SetUInt16(0,B,IsLittle); 4 : D.SetUInt32(0,B,IsLittle); 8 : D.setFloat64(0,B,IsLittle); end; SetLength(Result,aSize); A:=TJSUInt8Array.new(Mem); Result:=TMemoryStream.MemoryToBytes(A); end; function TStream.ReadData(var Buffer: Int8; Count: NativeInt): NativeInt; Var B : TBytes; begin SetLength(B,Count); Result:=ReadMaxSizeData(B,1,Count); if Result>=1 then Buffer:=MakeInt(B,1,True); end; function TStream.ReadData(var Buffer: UInt8): NativeInt; begin Result:=ReadData(Buffer,1); end; function TStream.ReadData(var Buffer: UInt8; Count: NativeInt): NativeInt; Var B : TBytes; begin SetLength(B,Count); Result:=ReadMaxSizeData(B,1,Count); if Result>=1 then Buffer:=MakeInt(B,1,False); end; function TStream.ReadData(var Buffer: Int16): NativeInt; begin Result:=ReadData(Buffer,2); end; function TStream.ReadData(var Buffer: Int16; Count: NativeInt): NativeInt; Var B : TBytes; begin SetLength(B,Count); Result:=ReadMaxSizeData(B,2,Count); if Result>=2 then Buffer:=MakeInt(B,2,True); end; function TStream.ReadData(var Buffer: UInt16): NativeInt; begin Result:=ReadData(Buffer,2); end; function TStream.ReadData(var Buffer: UInt16; Count: NativeInt): NativeInt; Var B : TBytes; begin SetLength(B,Count); Result:=ReadMaxSizeData(B,2,Count); if Result>=2 then Buffer:=MakeInt(B,2,False); end; function TStream.ReadData(var Buffer: Int32): NativeInt; begin Result:=ReadData(Buffer,4); end; function TStream.ReadData(var Buffer: Int32; Count: NativeInt): NativeInt; Var B : TBytes; begin SetLength(B,Count); Result:=ReadMaxSizeData(B,4,Count); if Result>=4 then Buffer:=MakeInt(B,4,True); end; function TStream.ReadData(var Buffer: UInt32): NativeInt; begin Result:=ReadData(Buffer,4); end; function TStream.ReadData(var Buffer: UInt32; Count: NativeInt): NativeInt; Var B : TBytes; begin SetLength(B,Count); Result:=ReadMaxSizeData(B,4,Count); if Result>=4 then Buffer:=MakeInt(B,4,False); end; function TStream.ReadData(var Buffer: NativeInt): NativeInt; begin Result:=ReadData(Buffer,8); end; function TStream.ReadData(var Buffer: NativeInt; Count: NativeInt): NativeInt; Var B : TBytes; begin SetLength(B,Count); Result:=ReadMaxSizeData(B,8,8); if Result>=8 then Buffer:=MakeInt(B,8,True); end; function TStream.ReadData(var Buffer: NativeLargeUInt): NativeInt; begin Result:=ReadData(Buffer,8); end; function TStream.ReadData(var Buffer: NativeLargeUInt; Count: NativeInt): NativeInt; Var B : TBytes; B1 : Integer; begin SetLength(B,Count); Result:=ReadMaxSizeData(B,4,4); if Result>=4 then begin B1:=MakeInt(B,4,False); Result:=Result+ReadMaxSizeData(B,4,4); Buffer:=MakeInt(B,4,False); Buffer:=(Buffer shl 32) or B1; end; end; function TStream.ReadData(var Buffer: Double): NativeInt; begin Result:=ReadData(Buffer,8); end; function TStream.ReadData(var Buffer: Double; Count: NativeInt): NativeInt; Var B : TBytes; Mem : TJSArrayBuffer; A : TJSUInt8Array; D : TJSDataView; begin SetLength(B,Count); Result:=ReadMaxSizeData(B,8,Count); if Result>=8 then begin Mem:=TJSArrayBuffer.New(8); A:=TJSUInt8Array.new(Mem); A._set(B); D:=TJSDataView.New(Mem); Buffer:=D.getFloat64(0); end; end; procedure TStream.ReadBuffer(var Buffer: TBytes; Count: NativeInt); begin ReadBuffer(Buffer,0,Count); end; procedure TStream.ReadBuffer(var Buffer: TBytes; Offset, Count: NativeInt); begin if Read(Buffer,OffSet,Count)<>Count then Raise EStreamError.Create(SReadError); end; procedure TStream.ReadBufferData(var Buffer: Boolean); begin ReadBufferData(Buffer,1); end; procedure TStream.ReadBufferData(var Buffer: Boolean; Count: NativeInt); begin if (ReadData(Buffer,Count)<>Count) then Raise EStreamError.Create(SReadError); end; procedure TStream.ReadBufferData(var Buffer: WideChar); begin ReadBufferData(Buffer,2); end; procedure TStream.ReadBufferData(var Buffer: WideChar; Count: NativeInt); begin if (ReadData(Buffer,Count)<>Count) then Raise EStreamError.Create(SReadError); end; procedure TStream.ReadBufferData(var Buffer: Int8); begin ReadBufferData(Buffer,1); end; procedure TStream.ReadBufferData(var Buffer: Int8; Count: NativeInt); begin if (ReadData(Buffer,Count)<>Count) then Raise EStreamError.Create(SReadError); end; procedure TStream.ReadBufferData(var Buffer: UInt8); begin ReadBufferData(Buffer,1); end; procedure TStream.ReadBufferData(var Buffer: UInt8; Count: NativeInt); begin if (ReadData(Buffer,Count)<>Count) then Raise EStreamError.Create(SReadError); end; procedure TStream.ReadBufferData(var Buffer: Int16); begin ReadBufferData(Buffer,2); end; procedure TStream.ReadBufferData(var Buffer: Int16; Count: NativeInt); begin if (ReadData(Buffer,Count)<>Count) then Raise EStreamError.Create(SReadError); end; procedure TStream.ReadBufferData(var Buffer: UInt16); begin ReadBufferData(Buffer,2); end; procedure TStream.ReadBufferData(var Buffer: UInt16; Count: NativeInt); begin if (ReadData(Buffer,Count)<>Count) then Raise EStreamError.Create(SReadError); end; procedure TStream.ReadBufferData(var Buffer: Int32); begin ReadBufferData(Buffer,4); end; procedure TStream.ReadBufferData(var Buffer: Int32; Count: NativeInt); begin if (ReadData(Buffer,Count)<>Count) then Raise EStreamError.Create(SReadError); end; procedure TStream.ReadBufferData(var Buffer: UInt32); begin ReadBufferData(Buffer,4); end; procedure TStream.ReadBufferData(var Buffer: UInt32; Count: NativeInt); begin if (ReadData(Buffer,Count)<>Count) then Raise EStreamError.Create(SReadError); end; procedure TStream.ReadBufferData(var Buffer: NativeLargeInt); begin ReadBufferData(Buffer,8) end; procedure TStream.ReadBufferData(var Buffer: NativeLargeInt; Count: NativeInt); begin if (ReadData(Buffer,Count)<>Count) then Raise EStreamError.Create(SReadError); end; procedure TStream.ReadBufferData(var Buffer: NativeLargeUInt); begin ReadBufferData(Buffer,8); end; procedure TStream.ReadBufferData(var Buffer: NativeLargeUInt; Count: NativeInt); begin if (ReadData(Buffer,Count)<>Count) then Raise EStreamError.Create(SReadError); end; procedure TStream.ReadBufferData(var Buffer: Double); begin ReadBufferData(Buffer,8); end; procedure TStream.ReadBufferData(var Buffer: Double; Count: NativeInt); begin if (ReadData(Buffer,Count)<>Count) then Raise EStreamError.Create(SReadError); end; procedure TStream.WriteBuffer(const Buffer: TBytes; Count: NativeInt); begin WriteBuffer(Buffer,0,Count); end; procedure TStream.WriteBuffer(const Buffer: TBytes; Offset, Count: NativeInt); begin if Self.Write(Buffer,Offset,Count)<>Count then Raise EStreamError.Create(SWriteError); end; function TStream.WriteData(const Buffer: TBytes; Count: NativeInt): NativeInt; begin Result:=Self.Write(Buffer, 0, Count); end; function TStream.WriteData(const Buffer: Boolean): NativeInt; begin Result:=WriteData(Buffer,1); end; function TStream.WriteData(const Buffer: Boolean; Count: NativeInt): NativeInt; Var B : Int8; begin B:=Ord(Buffer); Result:=WriteData(B,Count); end; function TStream.WriteData(const Buffer: WideChar): NativeInt; begin Result:=WriteData(Buffer,2); end; function TStream.WriteData(const Buffer: WideChar; Count: NativeInt): NativeInt; Var U : UInt16; begin U:=Ord(Buffer); Result:=WriteData(U,Count); end; function TStream.WriteData(const Buffer: Int8): NativeInt; begin Result:=WriteData(Buffer,1); end; function TStream.WriteData(const Buffer: Int8; Count: NativeInt): NativeInt; begin Result:=WriteMaxSizeData(MakeBytes(Buffer,1,True),1,Count); end; function TStream.WriteData(const Buffer: UInt8): NativeInt; begin Result:=WriteData(Buffer,1); end; function TStream.WriteData(const Buffer: UInt8; Count: NativeInt): NativeInt; begin Result:=WriteMaxSizeData(MakeBytes(Buffer,1,False),1,Count); end; function TStream.WriteData(const Buffer: Int16): NativeInt; begin Result:=WriteData(Buffer,2); end; function TStream.WriteData(const Buffer: Int16; Count: NativeInt): NativeInt; begin Result:=WriteMaxSizeData(MakeBytes(Buffer,2,True),2,Count); end; function TStream.WriteData(const Buffer: UInt16): NativeInt; begin Result:=WriteData(Buffer,2); end; function TStream.WriteData(const Buffer: UInt16; Count: NativeInt): NativeInt; begin Result:=WriteMaxSizeData(MakeBytes(Buffer,2,True),2,Count); end; function TStream.WriteData(const Buffer: Int32): NativeInt; begin Result:=WriteData(Buffer,4); end; function TStream.WriteData(const Buffer: Int32; Count: NativeInt): NativeInt; begin Result:=WriteMaxSizeData(MakeBytes(Buffer,4,True),4,Count); end; function TStream.WriteData(const Buffer: UInt32): NativeInt; begin Result:=WriteData(Buffer,4); end; function TStream.WriteData(const Buffer: UInt32; Count: NativeInt): NativeInt; begin Result:=WriteMaxSizeData(MakeBytes(Buffer,4,False),4,Count); end; function TStream.WriteData(const Buffer: NativeLargeInt): NativeInt; begin Result:=WriteData(Buffer,8); end; function TStream.WriteData(const Buffer: NativeLargeInt; Count: NativeInt): NativeInt; begin Result:=WriteMaxSizeData(MakeBytes(Buffer,8,True),8,Count); end; function TStream.WriteData(const Buffer: NativeLargeUInt): NativeInt; begin Result:=WriteData(Buffer,8); end; function TStream.WriteData(const Buffer: NativeLargeUInt; Count: NativeInt): NativeInt; begin Result:=WriteMaxSizeData(MakeBytes(Buffer,8,False),8,Count); end; function TStream.WriteData(const Buffer: Double): NativeInt; begin Result:=WriteData(Buffer,8); end; function TStream.WriteData(const Buffer: Double; Count: NativeInt): NativeInt; Var Mem : TJSArrayBuffer; A : TJSUint8array; D : TJSDataview; B : TBytes; I : Integer; begin Mem:=TJSArrayBuffer.New(8); D:=TJSDataView.new(Mem); D.setFloat64(0,Buffer); SetLength(B,8); A:=TJSUint8array.New(Mem); For I:=0 to 7 do B[i]:=A[i]; Result:=WriteMaxSizeData(B,8,Count); end; procedure TStream.WriteBufferData(Buffer: Int32); begin WriteBufferData(Buffer,4); end; procedure TStream.WriteBufferData(Buffer: Int32; Count: NativeInt); begin if (WriteData(Buffer,Count)<>Count) then Raise EStreamError.Create(SWriteError); end; procedure TStream.WriteBufferData(Buffer: Boolean); begin WriteBufferData(Buffer,1); end; procedure TStream.WriteBufferData(Buffer: Boolean; Count: NativeInt); begin if (WriteData(Buffer,Count)<>Count) then Raise EStreamError.Create(SWriteError); end; procedure TStream.WriteBufferData(Buffer: WideChar); begin WriteBufferData(Buffer,2); end; procedure TStream.WriteBufferData(Buffer: WideChar; Count: NativeInt); begin if (WriteData(Buffer,Count)<>Count) then Raise EStreamError.Create(SWriteError); end; procedure TStream.WriteBufferData(Buffer: Int8); begin WriteBufferData(Buffer,1); end; procedure TStream.WriteBufferData(Buffer: Int8; Count: NativeInt); begin if (WriteData(Buffer,Count)<>Count) then Raise EStreamError.Create(SWriteError); end; procedure TStream.WriteBufferData(Buffer: UInt8); begin WriteBufferData(Buffer,1); end; procedure TStream.WriteBufferData(Buffer: UInt8; Count: NativeInt); begin if (WriteData(Buffer,Count)<>Count) then Raise EStreamError.Create(SWriteError); end; procedure TStream.WriteBufferData(Buffer: Int16); begin WriteBufferData(Buffer,2); end; procedure TStream.WriteBufferData(Buffer: Int16; Count: NativeInt); begin if (WriteData(Buffer,Count)<>Count) then Raise EStreamError.Create(SWriteError); end; procedure TStream.WriteBufferData(Buffer: UInt16); begin WriteBufferData(Buffer,2); end; procedure TStream.WriteBufferData(Buffer: UInt16; Count: NativeInt); begin if (WriteData(Buffer,Count)<>Count) then Raise EStreamError.Create(SWriteError); end; procedure TStream.WriteBufferData(Buffer: UInt32); begin WriteBufferData(Buffer,4); end; procedure TStream.WriteBufferData(Buffer: UInt32; Count: NativeInt); begin if (WriteData(Buffer,Count)<>Count) then Raise EStreamError.Create(SWriteError); end; procedure TStream.WriteBufferData(Buffer: NativeInt); begin WriteBufferData(Buffer,8); end; procedure TStream.WriteBufferData(Buffer: NativeInt; Count: NativeInt); begin if (WriteData(Buffer,Count)<>Count) then Raise EStreamError.Create(SWriteError); end; procedure TStream.WriteBufferData(Buffer: NativeLargeUInt); begin WriteBufferData(Buffer,8); end; procedure TStream.WriteBufferData(Buffer: NativeLargeUInt; Count: NativeInt); begin if (WriteData(Buffer,Count)<>Count) then Raise EStreamError.Create(SWriteError); end; procedure TStream.WriteBufferData(Buffer: Double); begin WriteBufferData(Buffer,8); end; procedure TStream.WriteBufferData(Buffer: Double; Count: NativeInt); begin if (WriteData(Buffer,Count)<>Count) then Raise EStreamError.Create(SWriteError); end; function TStream.CopyFrom(Source: TStream; Count: NativeInt): NativeInt; var Buffer: TBytes; BufferSize, i: LongInt; const MaxSize = $20000; begin Result:=0; if Count=0 then Source.Position:=0; // This WILL fail for non-seekable streams... BufferSize:=MaxSize; if (Count>0) and (Count0 then WriteBuffer(Buffer,i); Inc(Result,i); until i0 do begin if Count>BufferSize then i:=BufferSize else i:=Count; Source.ReadBuffer(Buffer,i); WriteBuffer(Buffer,i); Dec(count,i); Inc(Result,i); end; end; (* function TStream.ReadComponent(Instance: TComponent): TComponent; var Reader: TReader; begin Reader := TReader.Create(Self, 4096); try Result := Reader.ReadRootComponent(Instance); finally Reader.Free; end; end; function TStream.ReadComponentRes(Instance: TComponent): TComponent; begin ReadResHeader; Result := ReadComponent(Instance); end; procedure TStream.WriteComponent(Instance: TComponent); begin WriteDescendent(Instance, nil); end; procedure TStream.WriteComponentRes(const ResName: string; Instance: TComponent); begin WriteDescendentRes(ResName, Instance, nil); end; procedure TStream.WriteDescendent(Instance, Ancestor: TComponent); var Driver : TAbstractObjectWriter; Writer : TWriter; begin Driver := TBinaryObjectWriter.Create(Self, 4096); Try Writer := TWriter.Create(Driver); Try Writer.WriteDescendent(Instance, Ancestor); Finally Writer.Destroy; end; Finally Driver.Free; end; end; procedure TStream.WriteDescendentRes(const ResName: string; Instance, Ancestor: TComponent); var FixupInfo: Longint; begin { Write a resource header } WriteResourceHeader(ResName, FixupInfo); { Write the instance itself } WriteDescendent(Instance, Ancestor); { Insert the correct resource size into the resource header } FixupResourceHeader(FixupInfo); end; procedure TStream.WriteResourceHeader(const ResName: string; {!!!: out} var FixupInfo: Longint); var ResType, Flags : word; begin ResType:=NtoLE(word($000A)); Flags:=NtoLE(word($1030)); { Note: This is a Windows 16 bit resource } { Numeric resource type } WriteByte($ff); { Application defined data } WriteWord(ResType); { write the name as asciiz } WriteBuffer(ResName[1],length(ResName)); WriteByte(0); { Movable, Pure and Discardable } WriteWord(Flags); { Placeholder for the resource size } WriteDWord(0); { Return current stream position so that the resource size can be inserted later } FixupInfo := Position; end; procedure TStream.FixupResourceHeader(FixupInfo: Longint); var ResSize,TmpResSize : Longint; begin ResSize := Position - FixupInfo; TmpResSize := NtoLE(longword(ResSize)); { Insert the correct resource size into the placeholder written by WriteResourceHeader } Position := FixupInfo - 4; WriteDWord(TmpResSize); { Seek back to the end of the resource } Position := FixupInfo + ResSize; end; procedure TStream.ReadResHeader; var ResType, Flags : word; begin try { Note: This is a Windows 16 bit resource } { application specific resource ? } if ReadByte<>$ff then raise EInvalidImage.Create(SInvalidImage); ResType:=LEtoN(ReadWord); if ResType<>$000a then raise EInvalidImage.Create(SInvalidImage); { read name } while ReadByte<>0 do ; { check the access specifier } Flags:=LEtoN(ReadWord); if Flags<>$1030 then raise EInvalidImage.Create(SInvalidImage); { ignore the size } ReadDWord; except on EInvalidImage do raise; else raise EInvalidImage.create(SInvalidImage); end; end; *) function TStream.ReadByte : Byte; begin ReadBufferData(Result,1); end; function TStream.ReadWord : Word; begin ReadBufferData(Result,2); end; function TStream.ReadDWord : Cardinal; begin ReadBufferData(Result,4); end; function TStream.ReadQWord: NativeLargeUInt; begin ReadBufferData(Result,8); end; procedure TStream.WriteByte(b : Byte); begin WriteBufferData(b,1); end; procedure TStream.WriteWord(w : Word); begin WriteBufferData(W,2); end; procedure TStream.WriteDWord(d : Cardinal); begin WriteBufferData(d,4); end; procedure TStream.WriteQWord(q: NativeLargeUInt); begin WriteBufferData(q,8); end; {****************************************************************************} {* TCustomMemoryStream *} {****************************************************************************} procedure TCustomMemoryStream.SetPointer(Ptr: TJSArrayBuffer; ASize: PtrInt); begin FMemory:=Ptr; FSize:=ASize; FDataView:=Nil; FDataArray:=Nil; end; Class Function TCustomMemoryStream.MemoryToBytes(Mem : TJSArrayBuffer) : TBytes; overload; begin Result:=MemoryToBytes(TJSUint8Array.New(Mem)); end; class function TCustomMemoryStream.MemoryToBytes(Mem: TJSUint8Array): TBytes; Var I : Integer; begin // This must be improved, but needs some asm or TJSFunction.call() to implement answers in // https://stackoverflow.com/questions/29676635/convert-uint8array-to-array-in-javascript for i:=0 to mem.length-1 do Result[i]:=Mem[i]; end; class function TCustomMemoryStream.BytesToMemory(aBytes: TBytes): TJSArrayBuffer; Var a : TJSUint8Array; begin Result:=TJSArrayBuffer.new(Length(aBytes)); A:=TJSUint8Array.New(Result); A._set(aBytes); end; function TCustomMemoryStream.GetDataArray: TJSUint8Array; begin if FDataArray=Nil then FDataArray:=TJSUint8Array.new(Memory); Result:=FDataArray; end; function TCustomMemoryStream.GetDataView: TJSDataview; begin if FDataView=Nil then FDataView:=TJSDataView.New(Memory); Result:=FDataView; end; function TCustomMemoryStream.GetSize: NativeInt; begin Result:=FSize; end; function TCustomMemoryStream.GetPosition: NativeInt; begin Result:=FPosition; end; function TCustomMemoryStream.Read(Buffer : TBytes; offset, Count: LongInt): LongInt; Var I,Src,Dest : Integer; begin Result:=0; If (FSize>0) and (FPosition=0) then begin Result:=Count; If (Result>(FSize-FPosition)) then Result:=(FSize-FPosition); Src:=FPosition; Dest:=Offset; I:=0; While IFSize) then FPosition:=FSize; Result:=FPosition; {$IFDEF DEBUG} if Result < 0 then raise Exception.Create('TCustomMemoryStream'); {$ENDIF} end; procedure TCustomMemoryStream.SaveToStream(Stream: TStream); begin if FSize>0 then Stream.WriteBuffer(TMemoryStream.MemoryToBytes(Memory),FSize); end; {****************************************************************************} {* TMemoryStream *} {****************************************************************************} Const TMSGrow = 4096; { Use 4k blocks. } procedure TMemoryStream.SetCapacity(NewCapacity: PtrInt); begin SetPointer (Realloc(NewCapacity),Fsize); FCapacity:=NewCapacity; end; function TMemoryStream.Realloc(var NewCapacity: PtrInt): TJSArrayBuffer; Var GC : PtrInt; DestView : TJSUInt8array; begin If NewCapacity<0 Then NewCapacity:=0 else begin GC:=FCapacity + (FCapacity div 4); // if growing, grow at least a quarter if (NewCapacity>FCapacity) and (NewCapacity < GC) then NewCapacity := GC; // round off to block size. NewCapacity := (NewCapacity + (TMSGrow-1)) and not (TMSGROW-1); end; // Only now check ! If NewCapacity=FCapacity then Result:=FMemory else if NewCapacity=0 then Result:=Nil else begin // New buffer Result:=TJSArrayBuffer.New(NewCapacity); If (Result=Nil) then Raise EStreamError.Create(SMemoryStreamError); // Transfer DestView:=TJSUInt8array.New(Result); Destview._Set(Self.DataArray); end; end; destructor TMemoryStream.Destroy; begin Clear; Inherited Destroy; end; procedure TMemoryStream.Clear; begin FSize:=0; FPosition:=0; SetCapacity (0); end; procedure TMemoryStream.LoadFromStream(Stream: TStream); begin Stream.Position:=0; SetSize(Stream.Size); If FSize>0 then Stream.ReadBuffer(MemoryToBytes(FMemory),FSize); end; procedure TMemoryStream.SetSize(const NewSize: NativeInt); begin SetCapacity (NewSize); FSize:=NewSize; IF FPosition>FSize then FPosition:=FSize; end; function TMemoryStream.Write(Const Buffer : TBytes; OffSet, Count: LongInt): LongInt; Var NewPos : PtrInt; begin If (Count=0) or (FPosition<0) then exit(0); NewPos:=FPosition+Count; If NewPos>Fsize then begin IF NewPos>FCapacity then SetCapacity (NewPos); FSize:=Newpos; end; DataArray._set(Copy(Buffer,Offset,Count),FPosition); FPosition:=NewPos; Result:=Count; end; {****************************************************************************} {* TBytesStream *} {****************************************************************************} constructor TBytesStream.Create(const ABytes: TBytes); begin inherited Create; SetPointer(TMemoryStream.BytesToMemory(aBytes),Length(ABytes)); FCapacity:=Length(ABytes); end; function TBytesStream.GetBytes: TBytes; begin Result:=TMemoryStream.MemoryToBytes(Memory); end; { --------------------------------------------------------------------- Global routines ---------------------------------------------------------------------} var ClassList : TJSObject; Procedure RegisterClass(AClass : TPersistentClass); begin ClassList[AClass.ClassName]:=AClass; end; Function GetClass(AClassName : string) : TPersistentClass; begin Result:=nil; if AClassName='' then exit; if not ClassList.hasOwnProperty(AClassName) then exit; Result:=TPersistentClass(ClassList[AClassName]); end; initialization ClassList:=TJSObject.create(nil); end.