david
2824855ea7
- Recompilación en Delphi10 de todos los paquetes de RO para generar las DCU's en Lib\D10 - Recompilación en Delphi10 de todos los paquetes de DA para generar las DCU's en Lib\D10 git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.RemObjects@9 b6239004-a887-0f4b-9937-50029ccdca16
1916 lines
50 KiB
ObjectPascal
1916 lines
50 KiB
ObjectPascal
unit uROClasses;
|
|
|
|
{----------------------------------------------------------------------------}
|
|
{ RemObjects SDK Library - Core Library }
|
|
{ }
|
|
{ compiler: Delphi 5 and up, Kylix 2 and up }
|
|
{ platform: Win32, Linux }
|
|
{ }
|
|
{ (c)opyright RemObjects Software. all rights reserved. }
|
|
{ }
|
|
{ Using this code requires a valid license of the RemObjects SDK }
|
|
{ which can be obtained at http://www.remobjects.com. }
|
|
{----------------------------------------------------------------------------}
|
|
|
|
{$I RemObjects.inc}
|
|
|
|
interface
|
|
|
|
uses Classes, {$IFDEF MSWINDOWS} Windows, {$ENDIF} SyncObjs, SysUtils
|
|
{$IFDEF LINUX}, Libc{$ENDIF};
|
|
|
|
const MinTimerMS = 100;
|
|
|
|
type
|
|
{$IFDEF DELPHI5}
|
|
IInterface = IUnknown;
|
|
{$ENDIF DELPHI5}
|
|
{$IFDEF LINUX}
|
|
TROEvent = class
|
|
private
|
|
FEvent: TSemaphore;
|
|
public
|
|
constructor Create(Dummy: Pointer; ManualReset, InitialVal: Boolean; Name: string);
|
|
destructor Destroy; override;
|
|
function WaitFor(Timeout: LongWord): TWaitResult;
|
|
procedure SetEvent;
|
|
procedure ResetEvent;
|
|
end;
|
|
{$ELSE}
|
|
TROEvent = TEvent;
|
|
{$ENDIF}
|
|
{ IROStrings
|
|
Interface wrapper around a TStrings }
|
|
IROStrings = interface
|
|
['{A96F7741-E9C4-4055-BF38-185B6063380C}']
|
|
function GetCount : integer;
|
|
function GetStringsObj : TStrings;
|
|
|
|
function GetValues(const Name: string): string;
|
|
procedure SetValues(const Name, Value: string);
|
|
function GetNames(Index: Integer): string;
|
|
|
|
function GetObject(Index: Integer): TObject;
|
|
procedure PutObject(Index: Integer; const Value: TObject);
|
|
|
|
function GetText : string;
|
|
procedure SetText(const Value : string);
|
|
|
|
function GetCommaText : string;
|
|
procedure SetCommaText(const Value : string);
|
|
|
|
function GetStrings(Index : integer) : string;
|
|
procedure SetStrings(Index : integer; const Value : string);
|
|
|
|
function GetSorted : boolean;
|
|
procedure SetSorted(aValue : boolean);
|
|
procedure CustomSort(Compare: TStringListSortCompare);
|
|
|
|
function GetDuplicates : TDuplicates;
|
|
procedure SetDuplicates(Value : TDuplicates);
|
|
|
|
function Add(const aString : string) : integer;
|
|
function AddObject(const aString: string; aObject: TObject): Integer;
|
|
|
|
procedure Insert(Index: Integer; const S: string);
|
|
procedure InsertObject(Index: Integer; const S: string; AObject: TObject);
|
|
|
|
procedure Delete(Index : integer);
|
|
function IndexOf(const aString : string) : integer;
|
|
|
|
|
|
function ExtractValue(const aName : string) : string;
|
|
function RenameName(const aName : string) : boolean;
|
|
|
|
function Find(const aString : string) : integer;
|
|
|
|
procedure Clear;
|
|
|
|
function IndexOfName(const aName : string) : integer;
|
|
|
|
procedure AddStrings(aList : TStrings);
|
|
|
|
property Count : integer read GetCount;
|
|
property Sorted : boolean read GetSorted write SetSorted;
|
|
property Duplicates: TDuplicates read GetDuplicates write SetDuplicates;
|
|
//property StringsObj : TStrings read GetStringsObj;
|
|
property Strings : TStrings read GetStringsObj;
|
|
property Values[const aName : string] : string read GetValues write SetValues;
|
|
property Names[Index : integer] : string read GetNames;
|
|
property StringAccess[Index : integer] : string read GetStrings write SetStrings; default;
|
|
property Text : string read GetText write SetText;
|
|
property CommaText : string read GetCommaText write SetCommaText;
|
|
property Objects[Index: Integer]: TObject read GetObject write PutObject;
|
|
end;
|
|
|
|
{$IFDEF DELPHI5}
|
|
TSeekOrigin = (soBeginning, soCurrent, soEnd); { Under Delphi 5 we can assume 0,1,m2 to be used }
|
|
{$ENDIF}
|
|
|
|
{ IROStream
|
|
Interface wrapper around TStream }
|
|
IROStream = interface
|
|
['{662BD786-2337-46DA-9F5C-FD226C2BBB13}']
|
|
function GetStreamObj : TStream;
|
|
function GetPosition: Int64;
|
|
procedure SetPosition(const aValue: Int64);
|
|
function GetSize: Int64;
|
|
procedure SetSize(const aValue: Int64);
|
|
function Read(var Buffer; Count: Longint): Longint;
|
|
function Write(const Buffer; Count: Longint): Longint;
|
|
function Seek(Offset: Longint; Origin: Word): Longint; overload;
|
|
function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; overload;
|
|
procedure ReadBuffer(var Buffer; Count: Longint);
|
|
procedure WriteBuffer(const Buffer; Count: Longint);
|
|
function ReadComponent(Instance: TComponent): TComponent;
|
|
procedure WriteComponent(Instance: TComponent);
|
|
|
|
property Stream : TStream read GetStreamObj;
|
|
property Position: Int64 read GetPosition write SetPosition;
|
|
property Size: Int64 read GetSize write SetSize;
|
|
|
|
procedure BeginUpdate;
|
|
procedure EndUpdate;
|
|
function InUpdateMode: Boolean;
|
|
end;
|
|
|
|
{ IROIdentifiedInterface }
|
|
IROInterfaceWithID = interface
|
|
['{048F42B5-D3E4-4BD5-9E72-16BF9FC01388}']
|
|
function GetID : string;
|
|
end;
|
|
|
|
{ Forwards }
|
|
TROThreadTimer = class;
|
|
|
|
{ Misc }
|
|
TStringArray = array of string;
|
|
|
|
{ TROStrings }
|
|
TROStrings = class(TInterfacedObject, IROStrings)
|
|
private
|
|
fListRef : TStrings;
|
|
fOwnsList : boolean;
|
|
|
|
protected
|
|
// IROStrings
|
|
function GetCount : integer;
|
|
function GetStringsObj : TStrings;
|
|
function GetValues(const Name: string): string;
|
|
procedure SetValues(const Name, Value: string);
|
|
function GetNames(Index: Integer): string;
|
|
function GetStrings(Index : integer) : string;
|
|
procedure SetStrings(Index : integer; const Value : string);
|
|
|
|
function GetObject(Index: Integer): TObject;
|
|
procedure PutObject(Index: Integer; const Value: TObject);
|
|
|
|
function GetDuplicates : TDuplicates;
|
|
procedure SetDuplicates(Value : TDuplicates);
|
|
|
|
function GetText : string;
|
|
procedure SetText(const Value : string);
|
|
|
|
function GetCommaText : string;
|
|
procedure SetCommaText(const Value : string);
|
|
|
|
function GetSorted : boolean;
|
|
procedure SetSorted(aValue : boolean);
|
|
|
|
procedure CustomSort(Compare: TStringListSortCompare);
|
|
|
|
procedure Clear;
|
|
|
|
function Add(const aString : string) : integer;
|
|
function AddObject(const aString: string; aObject: TObject): Integer;
|
|
procedure Insert(Index: Integer; const S: string);
|
|
procedure InsertObject(Index: Integer; const S: string; AObject: TObject);
|
|
|
|
procedure Delete(Index : integer);
|
|
function IndexOf(const aString : string) : integer;
|
|
|
|
function ExtractValue(const aName : string) : string;
|
|
function RenameName(const aName : string) : boolean;
|
|
|
|
function Find(const aString : string) : integer;
|
|
|
|
procedure AddStrings(aList : TStrings);
|
|
|
|
function IndexOfName(const aName : string) : integer;
|
|
|
|
public
|
|
constructor Create(aList : TStrings; OwnsList : boolean); overload; virtual;
|
|
constructor CreateCopy(aList:TStrings); overload; virtual;
|
|
constructor Create; overload;
|
|
|
|
destructor Destroy; override;
|
|
end;
|
|
|
|
{ TROStream }
|
|
TROStream = class(TInterfacedObject, IROStream)
|
|
private
|
|
fStreamRef : TStream;
|
|
fOwnsStream : boolean;
|
|
FOnChange: TNotifyEvent;
|
|
FChanging: byte;
|
|
procedure Changed;
|
|
protected
|
|
// IROStream
|
|
function GetStreamObj : TStream;
|
|
function GetPosition: Int64;
|
|
procedure SetPosition(const aValue: Int64);
|
|
function GetSize: Int64;
|
|
procedure SetSize(const aValue: Int64);
|
|
function Read(var Buffer; Count: Longint): Longint;
|
|
function Write(const Buffer; Count: Longint): Longint;
|
|
function Seek(Offset: Longint; Origin: Word): Longint; overload;
|
|
function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; overload;
|
|
procedure ReadBuffer(var Buffer; Count: Longint);
|
|
procedure WriteBuffer(const Buffer; Count: Longint);
|
|
function ReadComponent(Instance: TComponent): TComponent;
|
|
procedure WriteComponent(Instance: TComponent);
|
|
procedure BeginUpdate;
|
|
procedure EndUpdate;
|
|
function InUpdateMode: Boolean;
|
|
public
|
|
constructor Create(aStream : TStream; OwnsStream : boolean); overload; virtual;
|
|
constructor Create; overload;
|
|
|
|
destructor Destroy; override;
|
|
property OnChange: TNotifyEvent read FOnChange write FOnChange;
|
|
end;
|
|
|
|
|
|
{$M+}
|
|
TROBinaryMemoryStream = class(TMemoryStream)
|
|
private
|
|
FCapacityIncrement: integer;
|
|
protected
|
|
function Realloc(var NewCapacity: Longint): Pointer; override;
|
|
public
|
|
constructor Create(const iString:string); overload;
|
|
constructor Create; overload; // required for C++ compatibility
|
|
procedure Assign(iSource:TStream);
|
|
function Clone:TROBinaryMemoryStream;
|
|
|
|
procedure LoadFromString(const iString:string);
|
|
procedure LoadFromHexString(const iString:string);
|
|
function ToString:string;
|
|
function ToHexString:string;
|
|
function ToReadableString:string;
|
|
property CapacityIncrement: integer read FCapacityIncrement write FCapacityIncrement;
|
|
end;
|
|
{$M-}
|
|
|
|
TROConstantMemoryStream = class(TROBinaryMemoryStream)
|
|
public
|
|
constructor Create(aStream: TCustomMemoryStream; aFreeOldStream: boolean=false); reintroduce;
|
|
destructor Destroy; override;
|
|
|
|
function Write(const Buffer; Count: Integer): Integer; override;
|
|
end;
|
|
|
|
{ TROThreadTimer }
|
|
TROTimerEvent = procedure(CurrentTickCount : cardinal) of object;
|
|
|
|
TROThreadTimer = class(TThread)
|
|
private
|
|
{$IFDEF MSWINDOWS}
|
|
fFreeWaiting: TObject; // TROEvent
|
|
fIsTerminated: Boolean;
|
|
{$ENDIF MSWINDOWS}
|
|
|
|
fTimerEvent : TROTimerEvent;
|
|
fTimeoutMS : integer;
|
|
{$IFDEF WIN32}
|
|
fWakeUp : TEvent;
|
|
{$ENDIF}
|
|
fSynchronized: Boolean;
|
|
|
|
function GetTimeout: integer;
|
|
procedure SetTimeout(const Value: integer);
|
|
procedure RunEvent;
|
|
|
|
protected
|
|
{$IFDEF MSWINDOWS}
|
|
procedure DoTerminate; override;
|
|
{$ENDIF MSWINDOWS}
|
|
procedure Execute; override;
|
|
|
|
public
|
|
constructor Create(aTimerEvent: TROTimerEvent; aTimeout: integer); overload;
|
|
constructor Create(aTimerEvent: TROTimerEvent; aTimeout: integer; Synchronized: Boolean); overload;
|
|
destructor Destroy; override;
|
|
|
|
procedure TerminateWaitFor; virtual;
|
|
|
|
{$IFDEF MSWINDOWS}
|
|
function WaitFor: DWORD; reintroduce;
|
|
{$IFNDEF FPC}
|
|
procedure Free; reintroduce; // Windows limitation workaround
|
|
{$ENDIF}
|
|
{$ENDIF MSWINDOWS}
|
|
|
|
// got to make sure we aren't freeing threads from within themselves
|
|
procedure AsyncFree;
|
|
|
|
// In MS
|
|
property Timeout : integer read GetTimeout write SetTimeout;
|
|
property Synchronized : Boolean read fSynchronized write fSynchronized;
|
|
end;
|
|
|
|
TROInterfaceRegistry = class(TInterfaceList)
|
|
private
|
|
fInterfaceType:TGUID;
|
|
public
|
|
constructor Create(aInterfaceType:TGUID);
|
|
procedure Register(aInterface:IInterface);
|
|
procedure Unregister(aInterface:IInterface);
|
|
end;
|
|
|
|
TClassList = TList;
|
|
|
|
{ Exceptions }
|
|
{$M+}
|
|
EROException = class(Exception)
|
|
public
|
|
procedure ReadException(ASerializer: TObject);virtual;
|
|
procedure WriteException(ASerializer: TObject);virtual;
|
|
destructor Destroy; override;
|
|
end;
|
|
{$M-}
|
|
|
|
EROServerException = class(EROException);
|
|
EROUnregisteredServerException = class(EROServerException); // Marshelled exceptions that have not being registered in the framework
|
|
|
|
EROInvalidStream = class(EROException);
|
|
|
|
EROUserError = class(EROException); // Indicates something was done incorrectly by the user
|
|
|
|
EROUnknownItem = class(EROException); // uRODL, uRODynamicRequest and similar
|
|
|
|
EROIDEProblem = class(EROException);
|
|
|
|
{ TROCollection }
|
|
TROSearchOption = (soIgnoreCase);
|
|
|
|
TROSearchOptions = set of TROSearchOption;
|
|
TROCollection = class(TCollection)
|
|
private
|
|
protected
|
|
public
|
|
function Search(const aPropertyName : string;
|
|
const aPropertyValue : Variant;
|
|
StartFrom : integer = 0;
|
|
Options : TROSearchOptions = [soIgnoreCase]) : TCollectionItem;
|
|
function GetIndex(const aPropertyName : string;
|
|
const aPropertyValue : Variant;
|
|
StartFrom : integer = 0;
|
|
Options : TROSearchOptions = [soIgnoreCase]) : integer;
|
|
end;
|
|
|
|
TROInterfacedObject = class(TObject, IInterface)
|
|
protected
|
|
FRefCount: Integer;
|
|
function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall;
|
|
function _AddRef: Integer; virtual; stdcall;
|
|
function _Release: Integer; virtual; stdcall;
|
|
public
|
|
procedure AfterConstruction; override;
|
|
procedure BeforeDestruction; override;
|
|
class function NewInstance: TObject; override;
|
|
property RefCount: Integer read FRefCount;
|
|
end;
|
|
|
|
// Exceptions
|
|
procedure Check(DoRaise : boolean; const aMessage : string; const Parameters : array of const; iExceptionClass:ExceptClass); overload;
|
|
procedure Check(DoRaise : boolean; const aMessage : string; const Parameters : array of const); overload;
|
|
procedure Check(DoRaise : boolean; const aMessage : string); overload;
|
|
|
|
procedure RaiseError(const aMessage : string; const Parameters : array of const; iExceptionClass:ExceptClass); overload;
|
|
procedure RaiseError(const aMessage : string; const Parameters : array of const); overload;
|
|
procedure RaiseError(const aMessage : string); overload;
|
|
procedure RaiseInvalidStreamError(const anErrorMessage : string; const someParams : array of const; iStream:TStream);
|
|
procedure NotSupported(const Hint : string = '');
|
|
|
|
// IROStrings
|
|
function NewROStrings : IROStrings; overload;
|
|
function NewROStrings(const someStrings : array of string) : IROStrings; overload;
|
|
function NewROStrings(const someText : string) : IROStrings; overload;
|
|
function NewROStrings(const aList : TStrings; OwnList : boolean = TRUE) : IROStrings; overload;
|
|
function ListStringElements(const aString : string; const aSeparator : string = ';') : IROStrings;
|
|
function ListParameters(const aString : string; ParameterID : char = ':'; StringDelimiter : char = '''') : IROStrings;
|
|
function PackStrings(aList : IROStrings; const aDelimiter : string) : string;
|
|
|
|
// IROStreams
|
|
function NewROStream : IROStream; overload;
|
|
function NewROStream(aStream : TStream; OwnsStream : boolean = TRUE) : IROStream; overload;
|
|
|
|
// TStrings
|
|
procedure StringArrayToStrings(const anArray : TStringArray; Destination : TStrings; ClearStrings : boolean = TRUE);
|
|
function StringsToStringArray(aSource : TStrings) : TStringArray;
|
|
function StringsToString(const aStringList : TStrings) : string;
|
|
|
|
// Numeric
|
|
function IncID(CurrVal, MaxVal : integer) : integer;
|
|
function LoopList(var CurrentIndex : integer; const ListCount : integer; var EvalCount : integer) : boolean;
|
|
|
|
// Time
|
|
procedure StartTickCounter(var aTickTracker : cardinal);
|
|
function GetElapsedTicks(const aTickTracker : cardinal) : cardinal;
|
|
|
|
// Variants
|
|
function StreamToVariant(Stream: TStream): Variant;
|
|
procedure VariantToStream(const Data: Variant; Stream: TStream);
|
|
|
|
// Interfaces
|
|
function GetRefCount(const anInstance : IUnknown) : integer;
|
|
|
|
// Strings
|
|
function TrimAndClean(const aString : string) : string;
|
|
function SameText(const Str1, Str2 : string) : boolean;
|
|
function WriteSpace(Count : integer) : string;
|
|
|
|
type
|
|
TSetOfChars = set of char;
|
|
|
|
function NewGuid:TGUID;
|
|
function NewGuidAsString:string;
|
|
function NewStrippedGuidAsString:string;
|
|
|
|
procedure ReplaceChar(var s:string; iChars:TSetOfChars; iChar:char);
|
|
procedure Remove(var s:string; iChars:TSetOfChars); overload;
|
|
procedure RemoveExcept(var s:string; iChars:TSetOfChars);
|
|
function MakeValidIdentifier(const aName:string):string;
|
|
function CleanStringFromBinaries(const iString:string):string;
|
|
procedure SaveStringToFile(const aFilename, aString: string);
|
|
|
|
function EndsWith(const iSubStr,iString:string):boolean;
|
|
|
|
function GetTempPath:string;
|
|
function GetTempFileName(const aFileExt:string):string;
|
|
|
|
{$IFDEF LINUX}
|
|
function GetTickCount:cardinal;
|
|
{$ENDIF}
|
|
|
|
{$IFDEF DELPHI5}
|
|
function TryEncodeDateTime(const AYear, AMonth, ADay, AHour, AMinute, ASecond, AMilliSecond: Word; out AValue: TDateTime): Boolean;
|
|
procedure DecodeDateTime(const AValue: TDateTime; out AYear, AMonth, ADay, AHour, AMinute, ASecond, AMilliSecond: Word);
|
|
function MinutesBetween(const ANow, AThen: TDateTime): Int64;
|
|
{$ENDIF DELPHI5}
|
|
{$IFNDEF DELPHI7UP}
|
|
function IncMinute(const AValue: TDateTime; const ANumberOfMinutes: Int64): TDateTime;
|
|
function IncYear(const AValue: TDateTime; const ANumberOfYears: Integer): TDateTime;
|
|
{$ENDIF DELPHI7UP}
|
|
|
|
function WrappedHexString(iData:string; iWrapLength:integer=40):string;
|
|
function StringFromHexString(iData:string):string;
|
|
function StringToHexString(iData:string):string;
|
|
function ROVariantsEqual(const A, B: Variant): Boolean;
|
|
function ROWideCompare(const S1, S2: WideString; aCaseInsensitive: Boolean {$IFDEF MSWINDOWS};aLocale: LCID = LOCALE_USER_DEFAULT{$ENDIF}): Integer;
|
|
|
|
implementation
|
|
|
|
uses {$IFDEF MSWINDOWS}ActiveX,{$ENDIF}
|
|
{$IFDEF FPC}Variants,
|
|
{$ELSE}
|
|
{$IFDEF VER140UP}Variants,{$ENDIF}
|
|
{$ENDIF}
|
|
TypInfo,uRORes, uROSerializer;
|
|
|
|
|
|
{ TROBinaryMemoryStream }
|
|
|
|
procedure TROBinaryMemoryStream.Assign(iSource:TStream);
|
|
begin
|
|
if (iSource is TROBinaryMemoryStream) then begin
|
|
Clear();
|
|
CopyFrom(iSource,0);
|
|
Position := iSource.Position;
|
|
end
|
|
else begin
|
|
raise EConvertError.CreateResFmt(@err_AssignError, [iSource.ClassName, ClassName]);
|
|
end;
|
|
end;
|
|
|
|
function TROBinaryMemoryStream.Clone:TROBinaryMemoryStream;
|
|
begin
|
|
Result := ClassType.Create() as TROBinaryMemoryStream;
|
|
Result.Assign(self);
|
|
end;
|
|
|
|
constructor TROBinaryMemoryStream.Create;
|
|
begin
|
|
inherited Create;
|
|
end;
|
|
|
|
constructor TROBinaryMemoryStream.Create(const iString: string);
|
|
begin
|
|
FCapacityIncrement:=0; //standard mode
|
|
Create();
|
|
LoadFromString(iString);
|
|
end;
|
|
|
|
procedure TROBinaryMemoryStream.LoadFromString(const iString: string);
|
|
var
|
|
lLength:integer;
|
|
begin
|
|
lLength := Length(iString);
|
|
SetSize(lLength);
|
|
Move(pChar(iString)^,Memory^,Length(iString));
|
|
Seek(0,soFromBeginning);
|
|
end;
|
|
|
|
procedure TROBinaryMemoryStream.LoadFromHexString(const iString: string);
|
|
begin
|
|
if Length(iString) mod 2 <> 0 then RaiseError('String length must be 2n');
|
|
Size := Length(iString) div 2;
|
|
HexToBin(pChar(iString),Memory,Size);
|
|
Seek(0,soFromBeginning);
|
|
end;
|
|
|
|
function TROBinaryMemoryStream.ToHexString: string;
|
|
begin
|
|
SetLength(result,Size*2);
|
|
BinToHex(Memory,pChar(result),Size);
|
|
end;
|
|
|
|
function TROBinaryMemoryStream.ToReadableString: string;
|
|
begin
|
|
Result := CleanStringFromBinaries(ToString);
|
|
end;
|
|
|
|
function TROBinaryMemoryStream.ToString: string;
|
|
begin
|
|
SetLength(Result,Size);
|
|
Seek(0,soFromBeginning);
|
|
Read(Result[1],Size);
|
|
end;
|
|
|
|
|
|
// Exceptions
|
|
procedure RaiseError(const aMessage : string; const Parameters : array of const);
|
|
begin
|
|
raise EROException.CreateFmt(aMessage, Parameters);
|
|
end;
|
|
|
|
procedure RaiseError(const aMessage : string; const Parameters : array of const; iExceptionClass:ExceptClass);
|
|
begin
|
|
raise iExceptionClass.CreateFmt(aMessage, Parameters);
|
|
end;
|
|
|
|
procedure Check(DoRaise : boolean; const aMessage : string; const Parameters : array of const; iExceptionClass:ExceptClass); overload;
|
|
begin
|
|
if DoRaise
|
|
then RaiseError(aMessage, Parameters, iExceptionClass);
|
|
end;
|
|
|
|
procedure Check(DoRaise : boolean; const aMessage : string; const Parameters : array of const);
|
|
begin
|
|
if DoRaise
|
|
then RaiseError(aMessage, Parameters);
|
|
end;
|
|
|
|
procedure RaiseError(const aMessage : string);
|
|
begin
|
|
RaiseError(aMessage, []);
|
|
end;
|
|
|
|
procedure Check(DoRaise : boolean; const aMessage : string);
|
|
begin
|
|
Check(DoRaise, aMessage, []);
|
|
end;
|
|
|
|
procedure NotSupported(const Hint : string = '');
|
|
const Msg = 'Not Supported';
|
|
begin
|
|
if (Hint<>'') then RaiseError(Hint+' '+Msg) else RaiseError(Msg);
|
|
end;
|
|
|
|
procedure RaiseInvalidStreamError(const anErrorMessage : string; const someParams : array of const; iStream:TStream);
|
|
var
|
|
lStringStream:TStringStream;
|
|
lSize:Int64;
|
|
begin
|
|
lStringStream := TStringStream.Create('');
|
|
try
|
|
iStream.Seek(0,soFromBeginning);
|
|
lSize := iStream.Size;
|
|
if lSize > 500 then lSize := 500;
|
|
lStringStream.CopyFrom(iStream,lSize);
|
|
raise EROInvalidStream.Create(Format(anErrorMessage,someParams)+#13#13+CleanStringFromBinaries(lStringStream.DataString));
|
|
finally
|
|
lStringStream.Free();
|
|
end;
|
|
end;
|
|
|
|
// IROStrings
|
|
function NewROStrings : IROStrings;
|
|
var sl : TStringList;
|
|
begin
|
|
sl := TStringList.Create;
|
|
result := NewROStrings(sl, TRUE);
|
|
end;
|
|
|
|
function NewROStrings(const aList : TStrings; OwnList : boolean = TRUE) : IROStrings;
|
|
begin
|
|
result := TROStrings.Create(aList, OwnList);
|
|
end;
|
|
|
|
function NewROStrings(const someStrings : array of string) : IROStrings;
|
|
var i : integer;
|
|
begin
|
|
result := NewROStrings;
|
|
for i := 0 to Length(someStrings) do
|
|
result.Add(someStrings[i])
|
|
end;
|
|
|
|
function NewROStrings(const someText : string) : IROStrings; overload;
|
|
begin
|
|
result := NewROStrings;
|
|
result.Text := someText;
|
|
end;
|
|
|
|
function ListStringElements(const aString : string; const aSeparator : string = ';') : IROStrings;
|
|
var str : string;
|
|
spl, i : integer;
|
|
list : TStringList;
|
|
begin
|
|
str := aString;
|
|
spl := Length(aSeparator);
|
|
list := TStringList.Create;
|
|
|
|
result := NewROStrings(list);
|
|
|
|
i := Pos(aSeparator, str);
|
|
while (i>0) do begin
|
|
result.Add(Copy(str, 1, i-1));
|
|
Delete(str, 1, i-1+spl);
|
|
|
|
i := Pos(aSeparator, str);
|
|
end;
|
|
|
|
if (str<>'') then result.Add(str);
|
|
end;
|
|
|
|
function ListParameters(const aString : string; ParameterID : char = ':'; StringDelimiter : char = '''') : IROStrings;
|
|
var startidx, i, len : integer;
|
|
//instr : boolean;
|
|
begin
|
|
result := NewROStrings;
|
|
//instr := FALSE; was not used elsewhere?
|
|
|
|
startidx := 0;
|
|
len := Length(aString);
|
|
|
|
for i := 0 to len do begin
|
|
if (aString[i]=StringDelimiter) then begin
|
|
//instr := instr XOR TRUE; was not used elsewhere?
|
|
Continue;
|
|
end
|
|
|
|
else if (aString[i]=ParameterID)
|
|
then startidx := i
|
|
|
|
else if ((startidx>0) and not (aString[i] in ['a'..'z', 'A'..'Z', '0'..'9', '_'])) then begin
|
|
result.Add(Copy(aString, startidx+1, i-startidx-1));
|
|
startidx := 0;
|
|
end
|
|
|
|
else if ((i=len) and (startidx>0))
|
|
then result.Add(Copy(aString, startidx+1, i-startidx-1));
|
|
end;
|
|
end;
|
|
|
|
function PackStrings(aList : IROStrings; const aDelimiter : string) : string;
|
|
var i : integer;
|
|
begin
|
|
result := '';
|
|
if (aList.Count=0) then Exit;
|
|
|
|
for i := 0 to (aList.Count-1) do
|
|
result := result+aList[i]+aDelimiter;
|
|
|
|
Delete(result, Length(result), Length(aDelimiter));
|
|
end;
|
|
|
|
// IROStreams
|
|
function NewROStream : IROStream;
|
|
begin
|
|
result := TROStream.Create;
|
|
end;
|
|
|
|
function NewROStream(aStream : TStream; OwnsStream : boolean = TRUE) : IROStream;
|
|
begin
|
|
result := TROStream.Create(aStream, OwnsStream);
|
|
end;
|
|
|
|
// TStrings
|
|
procedure StringArrayToStrings(const anArray : TStringArray; Destination : TStrings; ClearStrings : boolean = TRUE);
|
|
var i : integer;
|
|
begin
|
|
if ClearStrings then Destination.Clear;
|
|
for i := 0 to Length(anArray)-1 do
|
|
Destination.Add(anArray[i])
|
|
end;
|
|
|
|
function StringsToStringArray(aSource : TStrings) : TStringArray;
|
|
var i : integer;
|
|
begin
|
|
SetLength(result, aSource.Count-1);
|
|
for i := 0 to (aSource.Count-1) do
|
|
result[i] := aSource[i];
|
|
end;
|
|
|
|
function StringsToString(const aStringList : TStrings) : string;
|
|
var i : integer;
|
|
begin
|
|
result := aStringList.Text;
|
|
for i := 1 to Length(result) do
|
|
if (result[i] in [#10, #13]) then result[i] := #32
|
|
end;
|
|
|
|
// Streams
|
|
function StreamToVariant(Stream: TStream): Variant;
|
|
var p: Pointer;
|
|
begin
|
|
Result := VarArrayCreate([0, Stream.Size - 1], varByte);
|
|
p := VarArrayLock(Result);
|
|
try
|
|
Stream.Position := 0; //start from beginning of stream
|
|
Stream.Read(p^, Stream.Size);
|
|
finally
|
|
VarArrayUnlock(Result);
|
|
end;
|
|
end;
|
|
|
|
procedure VariantToStream(const Data: Variant; Stream: TStream);
|
|
var p: Pointer;
|
|
begin
|
|
p := VarArrayLock(Data);
|
|
try
|
|
Stream.Write(p^, VarArrayHighBound(Data, 1) + 1); //assuming low bound = 0
|
|
finally
|
|
VarArrayUnlock(Data);
|
|
end;
|
|
end;
|
|
|
|
// Interfaces
|
|
function GetRefCount(const anInstance : IUnknown) : integer;
|
|
begin
|
|
anInstance._AddRef;
|
|
result := anInstance._Release;
|
|
end;
|
|
|
|
// Strings
|
|
function TrimAndClean(const aString : string) : string;
|
|
const DirtyChars : set of char = [#13, #10, #32];
|
|
var i : integer;
|
|
begin
|
|
result := aString;
|
|
|
|
while ((Length(result)>0) and (result[1] in DirtyChars))
|
|
do Delete(result, 1, 1);
|
|
|
|
while (Length(result)>0) do begin
|
|
i := Length(result);
|
|
if (result[i] in DirtyChars)
|
|
then Delete(result, i, 1)
|
|
else Exit;
|
|
end;
|
|
end;
|
|
|
|
function SameText(const Str1, Str2 : string) : boolean;
|
|
begin
|
|
result := CompareText(Str1, Str2)=0
|
|
end;
|
|
|
|
function WriteSpace(Count : integer) : string;
|
|
begin
|
|
SetLength(result, Count);
|
|
FillChar(result[1], Count, #32);
|
|
end;
|
|
|
|
// Numeric
|
|
function IncID(CurrVal, MaxVal : integer) : integer;
|
|
begin
|
|
if (CurrVal>=MaxVal)
|
|
then result := 0
|
|
else result := CurrVal+1;
|
|
end;
|
|
|
|
procedure StartListLoop(const StartFrom : integer; var CurrentIndex : integer; var EvalCount : integer);
|
|
begin
|
|
CurrentIndex := StartFrom;
|
|
EvalCount := 0;
|
|
end;
|
|
|
|
function LoopList(var CurrentIndex : integer; const ListCount : integer; var EvalCount : integer) : boolean;
|
|
begin
|
|
result := TRUE;
|
|
if (EvalCount<ListCount) then begin
|
|
CurrentIndex := IncID(CurrentIndex, ListCount-1);
|
|
Inc(EvalCount);
|
|
end
|
|
else result := FALSE;
|
|
end;
|
|
|
|
// Time
|
|
procedure StartTickCounter(var aTickTracker : cardinal);
|
|
begin
|
|
aTickTracker := GetTickCount
|
|
end;
|
|
|
|
function GetElapsedTicks(const aTickTracker : cardinal) : cardinal;
|
|
begin
|
|
result := GetTickCount-aTickTracker
|
|
end;
|
|
|
|
{$IFDEF MSWINDOWS}
|
|
function GetTempPath:string;
|
|
var
|
|
lTempdir : array[0..MAX_PATH] of char;
|
|
begin
|
|
Windows.GetTempPath(SizeOf(lTempdir), lTempdir);
|
|
result := IncludeTrailingPathDelimiter(lTempdir);
|
|
end;
|
|
{$ENDIF}
|
|
{$IFDEF LINUX}
|
|
function GetTempPath:string;
|
|
begin
|
|
result := GetEnv('tmp');
|
|
end;
|
|
{$ENDIF}
|
|
|
|
function GetTempFileName(const aFileExt:string):string;
|
|
begin
|
|
result := GetTempPath+NewGuidAsString()+aFileExt;
|
|
end;
|
|
|
|
{$IFDEF LINUX}
|
|
function GetTickCount:cardinal;
|
|
begin
|
|
result := clock div (CLOCKS_PER_SEC div 1000);
|
|
//ToDo: test if this works!
|
|
end;
|
|
{$ENDIF}
|
|
|
|
function NewGuid:TGUID;
|
|
begin
|
|
{$IFDEF MSWINDOWS}
|
|
CoCreateGuid(result);
|
|
{$ENDIF MSWINDOWS}
|
|
{$IFDEF LINUX}
|
|
CreateGuid(result);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function NewGuidAsString:string;
|
|
begin
|
|
result := GuidToString(NewGuid());
|
|
end;
|
|
|
|
function NewStrippedGuidAsString:string;
|
|
begin
|
|
result := NewGuidAsString();
|
|
Remove(result,['-','{','}']);
|
|
end;
|
|
|
|
procedure ReplaceChar(var s:string; iChars:TSetOfChars; iChar:char);
|
|
var i:Integer;
|
|
begin
|
|
for i := 1 to length(s) do begin
|
|
if (s[i] in iChars) then s[i] := iChar;
|
|
end;
|
|
end;
|
|
|
|
procedure Remove(var s:string; iChars:TSetOfChars); overload;
|
|
var i,l:Integer;
|
|
source:string;
|
|
begin
|
|
source := s;
|
|
l := 0;
|
|
for i := 1 to length(s) do begin
|
|
if not (s[i] in iChars) then begin
|
|
s[l+1] := s[i];
|
|
inc(l);
|
|
end;
|
|
end;
|
|
SetLength(s,l);
|
|
end;
|
|
|
|
procedure RemoveExcept(var s:string; iChars:TSetOfChars);
|
|
var i,l:Integer;
|
|
source:string;
|
|
begin
|
|
source := s;
|
|
l := 0;
|
|
for i := 1 to length(s) do begin
|
|
if s[i] in iChars then begin
|
|
s[l+1] := s[i];
|
|
inc(l);
|
|
end;
|
|
end;
|
|
SetLength(s,l);
|
|
end;
|
|
|
|
function MakeValidIdentifier(const aName:string):string;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
result := aName;
|
|
for i := 1 to Length(result) do
|
|
if not (result[i] in ['a'..'z','A'..'Z','0'..'9','_']) then result[i] := '_';
|
|
end;
|
|
|
|
function CleanStringFromBinaries(const iString:string):string;
|
|
var i:integer;
|
|
begin
|
|
Result := iString;
|
|
for i := 1 to Length(Result) do
|
|
if not (Result[i] in [#13,#$20..#$7f]) then Result[i] := '.';
|
|
end;
|
|
|
|
procedure SaveStringToFile(const aFilename, aString:string);
|
|
var
|
|
lText:TextFile;
|
|
begin
|
|
try
|
|
AssignFile(lText,aFilename);
|
|
Rewrite(lText);
|
|
try
|
|
Write(lText,aString);
|
|
finally
|
|
CloseFile(lText);
|
|
end;
|
|
except
|
|
on E:Exception do
|
|
raise EInOutError.Create('Error saving file '+aFilename+' ('+E.ClassName+': '+E.Message+')');
|
|
end;
|
|
end;
|
|
|
|
function EndsWith(const iSubStr,iString:string):boolean; overload;
|
|
var Len,Len2,i:integer;
|
|
begin
|
|
//ToDo -cOptimize: optimize, like we did with StartsWith
|
|
Len := Length(iSubStr);
|
|
Len2 := Length(iString);
|
|
if Len <= Len2 then begin
|
|
for i := 1 to Len do begin;
|
|
if iSubStr[Len-i+1] <> iString[Len2-i+1] then begin
|
|
result := false;
|
|
exit;
|
|
end
|
|
end;
|
|
result := true;
|
|
end
|
|
else begin
|
|
result := false;
|
|
end;
|
|
end;
|
|
|
|
{$IFNDEF DELPHI7UP}
|
|
const
|
|
HoursPerDay = 24;
|
|
MinsPerHour = 60;
|
|
SecsPerMin = 60;
|
|
MSecsPerSec = 1000;
|
|
MinsPerDay = HoursPerDay * MinsPerHour;
|
|
SecsPerDay = MinsPerDay * SecsPerMin;
|
|
MSecsPerDay = SecsPerDay * MSecsPerSec;
|
|
{$ENDIF DELPHI7UP}
|
|
|
|
{$IFDEF DELPHI5}
|
|
function TryEncodeDate(Year, Month, Day: Word; out Date: TDateTime): Boolean;
|
|
var
|
|
I: Integer;
|
|
DayTable: PDayTable;
|
|
begin
|
|
Result := False;
|
|
DayTable := @MonthDays[IsLeapYear(Year)];
|
|
if (Year >= 1) and (Year <= 9999) and (Month >= 1) and (Month <= 12) and
|
|
(Day >= 1) and (Day <= DayTable^[Month]) then
|
|
begin
|
|
for I := 1 to Month - 1 do Inc(Day, DayTable^[I]);
|
|
I := Year - 1;
|
|
Date := I * 365 + I div 4 - I div 100 + I div 400 + Day - DateDelta;
|
|
Result := True;
|
|
end;
|
|
end;
|
|
|
|
function TryEncodeTime(Hour, Min, Sec, MSec: Word; out Time: TDateTime): Boolean;
|
|
begin
|
|
Result := False;
|
|
if (Hour < HoursPerDay) and (Min < MinsPerHour) and (Sec < SecsPerMin) and (MSec < MSecsPerSec) then
|
|
begin
|
|
Time := (Hour * (MinsPerHour * SecsPerMin * MSecsPerSec) +
|
|
Min * (SecsPerMin * MSecsPerSec) +
|
|
Sec * MSecsPerSec +
|
|
MSec) / MSecsPerDay;
|
|
Result := True;
|
|
end;
|
|
end;
|
|
|
|
function TryEncodeDateTime(const AYear, AMonth, ADay, AHour, AMinute, ASecond, AMilliSecond: Word; out AValue: TDateTime): Boolean;
|
|
var
|
|
LTime: TDateTime;
|
|
begin
|
|
Result := TryEncodeDate(AYear, AMonth, ADay, AValue);
|
|
if Result then begin
|
|
Result := TryEncodeTime(AHour, AMinute, ASecond, AMilliSecond, LTime);
|
|
if Result then
|
|
AValue := AValue + LTime;
|
|
end;
|
|
end;
|
|
|
|
procedure DecodeDateTime(const AValue: TDateTime; out AYear, AMonth, ADay, AHour, AMinute, ASecond, AMilliSecond: Word);
|
|
begin
|
|
DecodeDate(AValue, AYear, AMonth, ADay);
|
|
DecodeTime(AValue, AHour, AMinute, ASecond, AMilliSecond);
|
|
end;
|
|
{$ENDIF DELPHI5}
|
|
|
|
{$IFNDEF DELPHI7UP}
|
|
function SpanOfNowAndThen(const ANow, AThen: TDateTime): TDateTime;
|
|
begin
|
|
if ANow < AThen then
|
|
Result := AThen - ANow
|
|
else
|
|
Result := ANow - AThen;
|
|
end;
|
|
|
|
function MinuteSpan(const ANow, AThen: TDateTime): Double;
|
|
begin
|
|
Result := MinsPerDay * SpanOfNowAndThen(ANow, AThen);
|
|
end;
|
|
|
|
function MinutesBetween(const ANow, AThen: TDateTime): Int64;
|
|
begin
|
|
Result := Trunc(MinuteSpan(ANow, AThen));
|
|
end;
|
|
|
|
function IncMinute(const AValue: TDateTime; const ANumberOfMinutes: Int64):TDateTime;
|
|
begin
|
|
Result := ((AValue * MinsPerDay) + ANumberOfMinutes) / MinsPerDay;
|
|
end;
|
|
|
|
function IncYear(const AValue: TDateTime; const ANumberOfYears: Integer): TDateTime;
|
|
begin
|
|
Result := AValue+365;
|
|
end;
|
|
{$ENDIF DELPHI7UP}
|
|
|
|
function StringFromHexString(iData:string):string;
|
|
begin
|
|
Remove(iData,[#13,#10,#32]);
|
|
if Length(iData) mod 2 <> 0 then raise EROException.Create('String length must be 2n');
|
|
SetLength(Result,Length(iData) div 2);
|
|
HexToBin(pChar(iData),pChar(result),Length(result));
|
|
end;
|
|
|
|
{----------------------------------------------------------------------------}
|
|
function StringToHexString(iData:string):string;
|
|
begin
|
|
SetLength(Result,Length(iData) * 2);
|
|
BinToHex(pChar(iData),pChar(result),Length(iData));
|
|
end;
|
|
|
|
{----------------------------------------------------------------------------}
|
|
function WrappedHexString(iData:string; iWrapLength:integer=40):string;
|
|
var i:integer;
|
|
s:string;
|
|
begin
|
|
for i := 1 to length(iData) do begin
|
|
s := s+IntToHex(byte(iData[i]),2);
|
|
if i mod iWrapLength = 0 then s := s+#13#10;
|
|
end;
|
|
result := s;
|
|
end;
|
|
|
|
function TROBinaryMemoryStream.Realloc(var NewCapacity: Integer): Pointer;
|
|
begin
|
|
if (FCapacityIncrement = 0) or (NewCapacity=0) then begin
|
|
Result := inherited Realloc(NewCapacity)
|
|
end else begin
|
|
inc(NewCapacity,FCapacityIncrement);
|
|
Result := inherited Realloc(NewCapacity);
|
|
end;
|
|
end;
|
|
|
|
{ TROStrings }
|
|
|
|
function TROStrings.Add(const aString: string): integer;
|
|
begin
|
|
result := fListRef.Add(aString)
|
|
end;
|
|
|
|
function TROStrings.AddObject(const aString: string; aObject: TObject): Integer;
|
|
begin
|
|
result := fListRef.AddObject(aString, aObject);
|
|
end;
|
|
|
|
procedure TROStrings.AddStrings(aList: TStrings);
|
|
begin
|
|
fListRef.AddStrings(aList);
|
|
end;
|
|
|
|
constructor TROStrings.Create(aList: TStrings; OwnsList: boolean);
|
|
begin
|
|
inherited Create;
|
|
|
|
if not Assigned(aList) then begin
|
|
fListRef := TStringList.Create;
|
|
fOwnsList := true;
|
|
end
|
|
else begin
|
|
fListRef := aList;
|
|
fOwnsList := OwnsList;
|
|
end;
|
|
end;
|
|
|
|
constructor TROStrings.Create;
|
|
begin
|
|
Create(nil,true);
|
|
end;
|
|
|
|
constructor TROStrings.CreateCopy(aList: TStrings);
|
|
begin
|
|
Create(nil,true);
|
|
fListRef.Assign(aList);
|
|
end;
|
|
|
|
procedure TROStrings.CustomSort(Compare: TStringListSortCompare);
|
|
begin
|
|
if (fListRef is TStringList)
|
|
then TStringList(fListRef).CustomSort(Compare);
|
|
end;
|
|
|
|
procedure TROStrings.Clear;
|
|
begin
|
|
fListRef.Clear
|
|
end;
|
|
|
|
procedure TROStrings.Delete(Index: integer);
|
|
begin
|
|
fListRef.Delete(Index);
|
|
end;
|
|
|
|
destructor TROStrings.Destroy;
|
|
begin
|
|
if fOwnsList
|
|
then fListRef.Free;
|
|
|
|
inherited;
|
|
end;
|
|
|
|
function TROStrings.ExtractValue(const aName: string): string;
|
|
var idx : integer;
|
|
begin
|
|
result := '';
|
|
|
|
idx := fListRef.IndexOfName(aName);
|
|
if (idx>=0) then begin
|
|
result := fListRef.Values[aName];
|
|
fListRef.Delete(idx);
|
|
end
|
|
end;
|
|
|
|
function TROStrings.Find(const aString: string): integer;
|
|
begin
|
|
result := fListRef.IndexOf(aString)
|
|
end;
|
|
|
|
function TROStrings.GetCount: integer;
|
|
begin
|
|
result := fListRef.Count
|
|
end;
|
|
|
|
function TROStrings.GetDuplicates: TDuplicates;
|
|
begin
|
|
if (fListRef is TStringList) then
|
|
result := TStringList(fListRef).Duplicates
|
|
else
|
|
result := dupAccept;
|
|
end;
|
|
|
|
function TROStrings.GetNames(Index: Integer): string;
|
|
begin
|
|
result := fListRef.Names[Index]
|
|
end;
|
|
|
|
function TROStrings.GetSorted: boolean;
|
|
begin
|
|
if (fListRef is TStringList)
|
|
then result := TStringList(fListRef).Sorted
|
|
else result := FALSE;
|
|
end;
|
|
|
|
function TROStrings.GetStrings(Index: integer): string;
|
|
begin
|
|
result := fListRef[Index]
|
|
end;
|
|
|
|
function TROStrings.GetStringsObj: TStrings;
|
|
begin
|
|
result := fListRef
|
|
end;
|
|
|
|
function TROStrings.GetText: string;
|
|
begin
|
|
result := fListRef.Text
|
|
end;
|
|
|
|
function TROStrings.GetValues(const Name: string): string;
|
|
begin
|
|
result := fListRef.Values[Name]
|
|
end;
|
|
|
|
function TROStrings.IndexOf(const aString: string): integer;
|
|
begin
|
|
result := fListRef.IndexOf(aString)
|
|
end;
|
|
|
|
function TROStrings.IndexOfName(const aName: string): integer;
|
|
begin
|
|
if (fListRef is TStringList)
|
|
then result := TStringList(fListRef).IndexOfName(aName)
|
|
else result := -1
|
|
end;
|
|
|
|
function TROStrings.RenameName(const aName : string) : boolean;
|
|
var idx : integer;
|
|
curr : string;
|
|
begin
|
|
// TODO: check this works...
|
|
idx := fListRef.IndexOfName(aName);
|
|
result := idx>=0;
|
|
|
|
if result then begin
|
|
curr := fListRef[idx];
|
|
fListRef[idx] := aName+Copy(curr, Pos('=', curr), MaxInt);
|
|
end;
|
|
end;
|
|
|
|
procedure TROStrings.SetDuplicates(Value: TDuplicates);
|
|
begin
|
|
if (fListRef is TStringList) then
|
|
TStringList(fListRef).Duplicates := Value;
|
|
end;
|
|
|
|
procedure TROStrings.SetSorted(aValue: boolean);
|
|
begin
|
|
if (fListRef is TStringList)
|
|
then TStringList(fListRef).Sorted := aValue
|
|
end;
|
|
|
|
procedure TROStrings.SetStrings(Index: integer; const Value: string);
|
|
begin
|
|
fListRef[Index] := Value
|
|
end;
|
|
|
|
procedure TROStrings.SetText(const Value: string);
|
|
begin
|
|
fListRef.Text := Value
|
|
end;
|
|
|
|
procedure TROStrings.SetValues(const Name, Value: string);
|
|
begin
|
|
fListRef.Values[Name] := Value
|
|
end;
|
|
|
|
function TROStrings.GetObject(Index: Integer): TObject;
|
|
begin
|
|
result := fListRef.Objects[Index];
|
|
end;
|
|
|
|
procedure TROStrings.PutObject(Index: Integer; const Value: TObject);
|
|
begin
|
|
fListRef.Objects[Index] := Value;
|
|
end;
|
|
|
|
procedure TROStrings.Insert(Index: Integer; const S: string);
|
|
begin
|
|
fListRef.Insert(Index, S);
|
|
end;
|
|
|
|
procedure TROStrings.InsertObject(Index: Integer; const S: string; AObject: TObject);
|
|
begin
|
|
fListRef.InsertObject(Index, S, AObject);
|
|
end;
|
|
|
|
function TROStrings.GetCommaText: string;
|
|
begin
|
|
result := fListRef.CommaText
|
|
end;
|
|
|
|
procedure TROStrings.SetCommaText(const Value: string);
|
|
begin
|
|
fListRef.CommaText := Value
|
|
end;
|
|
|
|
{ TROThreadTimer }
|
|
|
|
constructor TROThreadTimer.Create(aTimerEvent: TROTimerEvent; aTimeout: integer);
|
|
begin
|
|
inherited Create(true);
|
|
{$IFDEF WIN32}
|
|
fWakeUp := TEvent.Create(nil,False,False,'');
|
|
{$ENDIF}
|
|
fTimerEvent := aTimerEvent;
|
|
Timeout := aTimeout;
|
|
|
|
Resume();
|
|
end;
|
|
|
|
destructor TROThreadTimer.Destroy;
|
|
begin
|
|
Terminate();
|
|
{$IFDEF WIN32}
|
|
fWakeUp.SetEvent();
|
|
{$ENDIF}
|
|
inherited;
|
|
{$IFDEF WIN32}
|
|
FreeAndNIL(fWakeUp);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure TROThreadTimer.Execute;
|
|
{$IFNDEF WIN32}
|
|
var
|
|
nexttime: Cardinal;
|
|
{$ENDIF}
|
|
begin
|
|
// inherited;
|
|
|
|
while not Terminated do begin
|
|
{$IFDEF WIN32}
|
|
fWakeUp.WaitFor(fTimeoutMS);
|
|
{$ELSE}
|
|
nexttime := GetTickCount + fTimeoutMS;
|
|
if nexttime < fTimeoutMS then // truncated integer
|
|
begin
|
|
while not terminated and (GetTickCount > $80000000) do
|
|
Sleep(10);
|
|
end;
|
|
while not terminated do
|
|
begin
|
|
Sleep(10);
|
|
if GetTickCount > nexttime then
|
|
break;
|
|
end;
|
|
{$ENDIF}
|
|
if (not Terminated) then
|
|
begin
|
|
if fSynchronized then
|
|
Synchronize(RunEvent)
|
|
else
|
|
RunEvent;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TROThreadTimer.RunEvent;
|
|
begin
|
|
if Assigned(fTimerEvent) then
|
|
begin
|
|
fTimerEvent(GetTickCount());
|
|
end;
|
|
end;
|
|
|
|
function TROThreadTimer.GetTimeout: integer;
|
|
begin
|
|
result := fTimeoutMS;
|
|
end;
|
|
|
|
procedure TROThreadTimer.SetTimeout(const Value: integer);
|
|
begin
|
|
if (Value<MinTimerMS) then
|
|
fTimeoutMS := MinTimerMS
|
|
else
|
|
fTimeoutMS := Value;
|
|
end;
|
|
|
|
constructor TROThreadTimer.Create(aTimerEvent: TROTimerEvent;
|
|
aTimeout: integer; Synchronized: Boolean);
|
|
begin
|
|
inherited Create(true);
|
|
|
|
{$IFDEF WIN32}
|
|
fWakeUp := TEvent.Create(nil,False,False,'');
|
|
{$ENDIF}
|
|
|
|
fTimerEvent := aTimerEvent;
|
|
Timeout := aTimeout;
|
|
fSynchronized := Synchronized;
|
|
|
|
Resume();
|
|
end;
|
|
|
|
procedure TROThreadTimer.AsyncFree;
|
|
begin
|
|
FreeOnTerminate := true;
|
|
fTimerEvent := nil;
|
|
Terminate;
|
|
{$IFDEF WIN32}
|
|
fWakeUp.SetEvent;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure TROThreadTimer.TerminateWaitFor;
|
|
begin
|
|
Terminate;
|
|
WaitFor();
|
|
end;
|
|
|
|
{$IFDEF MSWINDOWS}
|
|
|
|
function TROThreadTimer.WaitFor: DWord;
|
|
var
|
|
lEvent: TROEvent;
|
|
begin
|
|
result := 0;
|
|
if fIsTerminated then exit;
|
|
lEvent := TROEvent.Create(nil, false, false, '');
|
|
try
|
|
fFreeWaiting := lEvent;
|
|
Terminate;
|
|
fWakeUp.SetEvent;
|
|
while Suspended do Resume;
|
|
lEvent.WaitFor(INFINITE);
|
|
sleep(10); // make sure it's actually terminated
|
|
fFreeWaiting := nil;
|
|
finally
|
|
lEvent.Free;
|
|
end;
|
|
end;
|
|
{$IFNDEF FPC}
|
|
procedure TROThreadTimer.Free;
|
|
begin
|
|
if self = nil then exit;
|
|
if ModuleIsLib then begin
|
|
// Windows doesn't return from EndThread until DllMain, so waitfor never returns either.
|
|
if fIsTerminated then
|
|
Destroy
|
|
else begin
|
|
FreeOnTerminate := true;
|
|
WaitFor;
|
|
end;
|
|
end else
|
|
Destroy;
|
|
end;
|
|
{$ENDIF}
|
|
procedure TROThreadTimer.DoTerminate;
|
|
begin
|
|
inherited;
|
|
fIsTerminated := true;
|
|
if fFreeWaiting <> nil then
|
|
TROEvent(fFreeWaiting).SetEvent;
|
|
end;
|
|
|
|
{$ENDIF MSWINDOWS}
|
|
|
|
{ TROInterfaceRegistry }
|
|
|
|
constructor TROInterfaceRegistry.Create(aInterfaceType: TGUID);
|
|
begin
|
|
inherited Create();
|
|
fInterfaceType := fInterfaceType;
|
|
end;
|
|
|
|
procedure TROInterfaceRegistry.Register(aInterface: IInterface);
|
|
begin
|
|
//ToDo: if not Supports(aInterface,fInterfaceType) then RaiseError('Unsupported Interface Type.');
|
|
if IndexOf(aInterface) = -1 then Add(aInterface);
|
|
end;
|
|
|
|
procedure TROInterfaceRegistry.Unregister(aInterface: IInterface);
|
|
var
|
|
lIndex:integer;
|
|
begin
|
|
lIndex := IndexOf(aInterface);
|
|
if lIndex <> -1 then Delete(lIndex);
|
|
end;
|
|
|
|
{ TROStream }
|
|
constructor TROStream.Create(aStream : TStream; OwnsStream : boolean);
|
|
begin
|
|
inherited Create;
|
|
|
|
if not Assigned(aStream) then begin
|
|
fStreamRef := TMemoryStream.Create;
|
|
fOwnsStream := TRUE;
|
|
end
|
|
else begin
|
|
fStreamRef := aStream;
|
|
fOwnsStream := OwnsStream;
|
|
end;
|
|
end;
|
|
|
|
procedure TROStream.BeginUpdate;
|
|
begin
|
|
Check(FChanging <> 0, 'Stream is already in UpdateMode');
|
|
inc(FChanging);
|
|
end;
|
|
|
|
constructor TROStream.Create;
|
|
begin
|
|
Create(NIL, TRUE);
|
|
end;
|
|
|
|
destructor TROStream.Destroy;
|
|
begin
|
|
if fOwnsStream
|
|
then fStreamRef.Free;
|
|
|
|
inherited;
|
|
end;
|
|
|
|
procedure TROStream.EndUpdate;
|
|
begin
|
|
Check(FChanging = 0, 'Stream is not in UpdateMode');
|
|
dec(FChanging);
|
|
Changed;
|
|
end;
|
|
|
|
function TROStream.GetPosition: Int64;
|
|
begin
|
|
result := fStreamRef.Position
|
|
end;
|
|
|
|
function TROStream.GetSize: Int64;
|
|
begin
|
|
result := fStreamRef.Size
|
|
end;
|
|
|
|
function TROStream.GetStreamObj: TStream;
|
|
begin
|
|
result := fStreamRef
|
|
end;
|
|
|
|
function TROStream.Read(var Buffer; Count: Integer): Longint;
|
|
begin
|
|
result := fStreamRef.Read(Buffer, Count)
|
|
end;
|
|
|
|
procedure TROStream.ReadBuffer(var Buffer; Count: Integer);
|
|
begin
|
|
fStreamRef.ReadBuffer(Buffer, Count);
|
|
end;
|
|
|
|
function TROStream.ReadComponent(Instance: TComponent): TComponent;
|
|
begin
|
|
result := fStreamRef.ReadComponent(Instance)
|
|
end;
|
|
|
|
function TROStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
|
|
begin
|
|
{$IFDEF DELPHI5}
|
|
result := fStreamRef.Seek(Offset, word(Origin));
|
|
{$ELSE}
|
|
result := fStreamRef.Seek(Offset, Origin);
|
|
{$ENDIF DELPHI5}
|
|
end;
|
|
|
|
function TROStream.Seek(Offset: Integer; Origin: Word): Longint;
|
|
begin
|
|
result := fStreamRef.Seek(Offset, Origin);
|
|
end;
|
|
|
|
procedure TROStream.SetPosition(const aValue: Int64);
|
|
begin
|
|
fStreamRef.Position := aValue;
|
|
end;
|
|
|
|
procedure TROStream.SetSize(const aValue: Int64);
|
|
begin
|
|
fStreamRef.Size := aValue;
|
|
Changed;
|
|
end;
|
|
|
|
function TROStream.Write(const Buffer; Count: Integer): Longint;
|
|
begin
|
|
result := fStreamRef.Write(Buffer, Count);
|
|
Changed;
|
|
end;
|
|
|
|
procedure TROStream.WriteBuffer(const Buffer; Count: Integer);
|
|
begin
|
|
fStreamRef.WriteBuffer(Buffer, Count);
|
|
Changed;
|
|
end;
|
|
|
|
procedure TROStream.WriteComponent(Instance: TComponent);
|
|
begin
|
|
fStreamRef.WriteComponent(Instance);
|
|
Changed;
|
|
end;
|
|
|
|
procedure TROStream.Changed;
|
|
begin
|
|
if (FChanging = 0) and Assigned(FOnChange) then FOnChange(Self);
|
|
end;
|
|
|
|
function TROStream.InUpdateMode: Boolean;
|
|
begin
|
|
Result:= FChanging<>0;
|
|
end;
|
|
|
|
{ TROCollection }
|
|
|
|
function TROCollection.GetIndex(const aPropertyName: string;
|
|
const aPropertyValue: Variant; StartFrom: integer;
|
|
Options: TROSearchOptions): integer;
|
|
var i : integer;
|
|
val : Variant;
|
|
curritem : TObject;
|
|
begin
|
|
result := -1;
|
|
|
|
for i := StartFrom to (Count-1) do begin
|
|
curritem := Items[i];
|
|
if (curritem=NIL) then Continue;
|
|
|
|
val := GetPropValue(curritem, aPropertyName, FALSE);
|
|
|
|
if (soIgnoreCase in Options) then begin
|
|
if (VarToStr(val)=VarToStr(aPropertyValue)) then begin
|
|
result := i;
|
|
Exit;
|
|
end;
|
|
end
|
|
else begin
|
|
if (val=aPropertyValue) then begin
|
|
result := i;
|
|
Exit;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TROCollection.Search(const aPropertyName : string;
|
|
const aPropertyValue : Variant; StartFrom : integer = 0;
|
|
Options : TROSearchOptions = [soIgnoreCase]) : TCollectionItem;
|
|
var idx : integer;
|
|
begin
|
|
idx := GetIndex(aPropertyName, aPropertyValue, StartFrom, Options);
|
|
if (idx>=0)
|
|
then result := Items[idx]
|
|
else result := NIL;
|
|
end;
|
|
|
|
{ TROConstantMemoryStream }
|
|
|
|
constructor TROConstantMemoryStream.Create(aStream: TCustomMemoryStream; aFreeOldStream: boolean=false);
|
|
var
|
|
lSize: longint;
|
|
lMemory: Pointer;
|
|
begin
|
|
inherited Create();
|
|
lSize := aStream.Size;
|
|
GetMem(lMemory, lSize);
|
|
Move(aStream.Memory^, lMemory^, lSize);
|
|
SetPointer(lMemory, lSize);
|
|
if aFreeOldStream then
|
|
aStream.Free();
|
|
end;
|
|
|
|
destructor TROConstantMemoryStream.Destroy;
|
|
begin
|
|
FreeMem(Memory);
|
|
inherited;
|
|
end;
|
|
|
|
function TROConstantMemoryStream.Write(const Buffer; Count: Integer): Integer;
|
|
begin
|
|
result := 0; // else it will warn
|
|
RaiseError(err_StreamIsReadOnly);
|
|
end;
|
|
|
|
{ TROInterfacedObject }
|
|
|
|
function TROInterfacedObject.QueryInterface(const IID: TGUID;
|
|
out Obj): HResult;
|
|
begin
|
|
if GetInterface(IID, Obj) then
|
|
Result := 0
|
|
else
|
|
Result := E_NOINTERFACE;
|
|
end;
|
|
|
|
function TROInterfacedObject._AddRef: Integer;
|
|
begin
|
|
Result := InterlockedIncrement(FRefCount);
|
|
end;
|
|
|
|
function TROInterfacedObject._Release: Integer;
|
|
begin
|
|
Result := InterlockedDecrement(FRefCount);
|
|
if Result = 0 then
|
|
Destroy;
|
|
end;
|
|
|
|
procedure TROInterfacedObject.AfterConstruction;
|
|
begin
|
|
// Release the constructor's implicit refcount
|
|
InterlockedDecrement(FRefCount);
|
|
end;
|
|
|
|
procedure TROInterfacedObject.BeforeDestruction;
|
|
begin
|
|
if RefCount <> 0 then
|
|
{$IFDEF FPC}
|
|
raise Exception.Create('Invalid Pointer Operation');
|
|
{$ELSE}
|
|
System.Error(reInvalidPtr);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
// Set an implicit refcount so that refcounting
|
|
// during construction won't destroy the object.
|
|
class function TROInterfacedObject.NewInstance: TObject;
|
|
begin
|
|
Result := inherited NewInstance;
|
|
TROInterfacedObject(Result).FRefCount := 1;
|
|
end;
|
|
|
|
{$IFDEF LINUX}
|
|
constructor TROEvent.Create(Dummy: Pointer; ManualReset, InitialVal: Boolean;
|
|
Name: string);
|
|
begin
|
|
inherited Create;
|
|
sem_init(FEvent, {$IFDEF FPC}0{$ELSE}False{$ENDIF}, Byte(InitialVal));
|
|
end;
|
|
|
|
destructor TROEvent.Destroy;
|
|
begin
|
|
sem_destroy(FEvent);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TROEvent.SetEvent;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
sem_getvalue(FEvent,{$IFDEF FPC}@{$ENDIF FPC}I);
|
|
if I = 0 then
|
|
sem_post(FEvent);
|
|
end;
|
|
|
|
function TROEvent.WaitFor(Timeout: LongWord): TWaitResult;
|
|
var
|
|
inttimeout: TimeSpec;
|
|
begin
|
|
if Timeout = Cardinal($FFFFFFFF) then
|
|
begin
|
|
if sem_Wait(FEvent) = 0 then
|
|
result := wrSignaled
|
|
else
|
|
result := wrTimeout;
|
|
end
|
|
else begin
|
|
inttimeout.tv_sec := __time(nil) + (timeout div 1000);
|
|
inttimeout.tv_nsec := (timeout mod 1000);
|
|
if sem_timedwait(FEvent, {$IFDEF FPC}@{$ENDIF FPC}inttimeout) = 0 then
|
|
Result := wrSignaled
|
|
else
|
|
Result := wrTimeout;
|
|
end;
|
|
end;
|
|
procedure TROEvent.ResetEvent;
|
|
begin
|
|
end;
|
|
|
|
{$ENDIF}
|
|
|
|
|
|
function ROWideCompare(const S1, S2: WideString; aCaseInsensitive: Boolean {$IFDEF MSWINDOWS};aLocale: LCID = LOCALE_USER_DEFAULT{$ENDIF}): Integer;{$IFDEF MSWINDOWS}
|
|
var
|
|
dwCmpFlags: integer;
|
|
ls1,ls2: AnsiString;
|
|
begin
|
|
SetLastError(0);
|
|
if aCaseInsensitive then
|
|
dwCmpFlags := NORM_IGNORECASE
|
|
else
|
|
dwCmpFlags := 0;
|
|
if Win32Platform = VER_PLATFORM_WIN32_NT then
|
|
Result := CompareStringW(ALocale, dwCmpFlags, PWideChar(S1), Length(S1), PWideChar(S2), Length(S2)) - 2
|
|
else begin
|
|
ls1:= s1;
|
|
ls2:= s2;
|
|
Result := CompareStringA(ALocale, dwCmpFlags, PAnsiChar(ls1), Length(ls1), PAnsiChar(ls2), Length(ls2)) - 2
|
|
end;
|
|
if GetLastError <>0 then RaiseLastOSError;
|
|
end;
|
|
{$ENDIF}
|
|
{$IFDEF LINUX}
|
|
var
|
|
UCS4_S1, UCS4_S2: UCS4String;
|
|
ls1,ls2: WideString;
|
|
begin
|
|
if aCaseInsensitive then begin
|
|
ls1:= WideUpperCase(s1);
|
|
ls2:= WideUpperCase(s2);
|
|
end else begin
|
|
ls1:=s1;
|
|
ls2:=s2;
|
|
end;
|
|
UCS4_S1 := WideStringToUCS4String(ls1);
|
|
UCS4_S2 := WideStringToUCS4String(ls2);
|
|
{$IFDEF FPC}
|
|
Result:=wcscoll(pwchar_t(UCS4_S1),pwchar_t(UCS4_S2));
|
|
{$ELSE}
|
|
SetLastError(0);
|
|
Result := wcscoll(PUCS4Chars(UCS4_S1), PUCS4Chars(UCS4_S2));
|
|
if GetLastError <> 0 then RaiseLastOSError;
|
|
{$ENDIF}
|
|
end;
|
|
{$ENDIF}
|
|
|
|
function ROVariantsEqual(const A, B: Variant): Boolean;
|
|
|
|
function VarCompareArray(const A, B: Variant): TVariantRelationship;
|
|
const
|
|
varArrayOfByte = varArray or varByte;
|
|
var
|
|
lALen, lBLen: Integer;
|
|
lAPtr, lBPtr: Pointer;
|
|
begin
|
|
// The only type of variant arrays we expect to find is variant array of byte
|
|
// All other types are not supported by this simple procedure
|
|
Result := vrNotEqual;
|
|
if VarIsType(A, varArrayOfByte) and VarIsType(B, varArrayOfByte) then
|
|
begin
|
|
lALen := VarArrayHighBound(A, 1) - VarArrayLowBound(A, 1) + 1;
|
|
lBLen := VarArrayHighBound(B, 1) - VarArrayLowBound(B, 1) + 1;
|
|
if lALen <> lBLen then Exit;
|
|
|
|
lAPtr := nil;
|
|
lBPtr := nil;
|
|
try
|
|
lAPtr := VarArrayLock(A);
|
|
lBPtr := VarArrayLock(B);
|
|
if CompareMem(lAPtr, lBPtr, lALen) then Result := vrEqual;
|
|
finally
|
|
if Assigned(lAPtr) then VarArrayUnlock(A);
|
|
if Assigned(lBPtr) then VarArrayUnlock(B);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
if VarIsArray(A) xor VarIsArray(B) then
|
|
Result := False
|
|
else
|
|
if VarIsArray(A) and VarIsArray(B) then
|
|
Result := VarCompareArray(A, B) = vrEqual
|
|
else
|
|
if (VarType(A) = VarType(B)) and (VarType(A)= varOleStr) then
|
|
Result:= ROWideCompare(VarToWideStr(A),VarToWideStr(B),False) =0
|
|
else
|
|
Result := VarCompareValue(A, B) = vrEqual;
|
|
end;
|
|
|
|
|
|
|
|
{ EROException }
|
|
|
|
destructor EROException.Destroy;
|
|
var props : PPropList;
|
|
cnt, i : integer;
|
|
sub : TObject;
|
|
begin
|
|
cnt := GetTypeData(ClassInfo).PropCount;
|
|
if (cnt=0) then Exit;
|
|
|
|
GetMem(props, cnt*SizeOf(PPropInfo));
|
|
try
|
|
cnt := GetPropList(ClassInfo, [tkClass], props);
|
|
|
|
for i := 0 to (cnt-1) do begin
|
|
with props^[i]^ do
|
|
if (PropType^.Kind=tkClass) then begin
|
|
sub := GetObjectProp(Self, Name);
|
|
sub.Free;
|
|
end;
|
|
end;
|
|
finally
|
|
FreeMem(props, cnt*SizeOf(PPropInfo));
|
|
end;
|
|
|
|
inherited;
|
|
end;
|
|
|
|
procedure EROException.ReadException(ASerializer: TObject);
|
|
begin
|
|
ReadObjectFromSerializer(TROSerializer(ASerializer),Self);
|
|
end;
|
|
|
|
procedure EROException.WriteException(ASerializer: TObject);
|
|
begin
|
|
WriteObjectToSerializer(TROSerializer(ASerializer),Self);
|
|
end;
|
|
|
|
end.
|