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, TypInfo
 {$IFNDEF MSWINDOWS},unixtype, baseunix, pthreads {$ENDIF}
  ;

const MinTimerMS = 100;
var
  ROInitializeThreads: Boolean = False;

type TRODataType = (rtInteger, rtDateTime, rtDouble, rtCurrency, rtWidestring, rtString,
                    rtInt64, rtBoolean, rtVariant, rtBinary, rtXML, rtGuid, rtDecimal,
                    rtUTF8String, rtXsDateTime, rtUserDefined);
     TRODataTypeMapping = record
       Name: string;
       NewType: TRODataType;
     end;

    DataTypeNames_Array = array[TRODataType] of string;
    DataTypeRemapping_Array = array[0..0] of TRODataTypeMapping;
const
  DataTypeNames : DataTypeNames_Array = (
        'Integer',
        'DateTime',
        'Double',
        'Currency',
        'Widestring',
        'AnsiString',
        'Int64',
        'Boolean',
        'Variant',
        'Binary',
        'Xml',
        'Guid',
        'Decimal',
        'Utf8String',
        'XsDateTime',
        '???');
  DataTypeRemapping: DataTypeRemapping_Array =
  (
  //  (Name: 'Utf8String'; NewType: rtString)
    (Name: '???'; NewType: rtUserDefined)
  );



type
  {$IFDEF DELPHI5}
  IInterface = IUnknown;
  {$ENDIF DELPHI5}
  {$IFNDEF MSWINDOWS}

  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:Ansistring); overload;
     constructor Create; overload;    // required for C++ compatibility
     procedure Assign(iSource:TStream);
     function Clone:TROBinaryMemoryStream;

     procedure LoadFromString(const iString:Ansistring);
     procedure LoadFromHexString(const iString:Ansistring);
     function ToString:AnsiString;  {$IFDEF DELPHI12UP}reintroduce;{$ENDIF}
     function ToHexString:Ansistring;
     function ToReadableString:Ansistring;
     function WriteAnsiString(AString: AnsiString): integer;
     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;

  { TROInitializedThread }
  TROInitializedThread = class(TThread)
  private
    FInitialize: Boolean;
  public
    constructor Create(CreateSuspended: Boolean);
    destructor Destroy; override;
  end;

  { TROThreadTimer }
  TROTimerEvent = procedure(CurrentTickCount : cardinal) of object;

  TROThreadTimer = class(TROInitializedThread)
  private
    {$IFDEF MSWINDOWS}
    fFreeWaiting: TObject; // TROEvent
    fIsTerminated: Boolean;
    {$ENDIF MSWINDOWS}

    fTimerEvent : TROTimerEvent;
    fTimeoutMS : integer;
    {$IFDEF MSWINDOWS}
    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}

    // 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
    class function GetAttributeCount: Integer; virtual;
    class function GetAttributeName(aIndex: Integer): string; virtual;
    class function GetAttributeValue(aIndex: Integer): string; virtual;

    procedure ReadException(ASerializer: TObject);virtual;
    procedure WriteException(ASerializer: TObject);virtual;
    destructor Destroy; override;
  end;
  {$M-}

  EROExceptionClass = class of EROException;

  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

  EROCircularReference = class(EROException); // RODL entities' circular references 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;

  TROBaseSerializer = class
  protected
    procedure ReadObject(obj: TObject);virtual;abstract;
    procedure WriteObject(obj: TObject);virtual;abstract;
  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
  TSetOfAnsiChars = set of AnsiChar;

function NewGuid:TGUID;
function NewGuidAsString:string;
function NewStrippedGuidAsString:string;

procedure ReplaceChar(var s:string; iChars:TSetOfAnsiChars; iChar:char);
procedure Remove(var s:string; iChars:TSetOfAnsiChars); overload;
procedure RemoveAnsi(var s:Ansistring; iChars:TSetOfAnsiChars); overload;
procedure RemoveExcept(var s:string; iChars:TSetOfAnsiChars);
function MakeValidIdentifier(const aName:string):string;
function CleanStringFromBinaries(const iString:Ansistring):Ansistring;
procedure SaveStringToFile(const aFilename, aString: string);

function EndsWith(const iSubStr,iString:string):boolean;

function GetTempPath:string;
function GetTempFileName(const aFileExt:string):string;

{$IFNDEF MSWINDOWS}
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;
function IncMinute(const AValue: TDateTime; const ANumberOfMinutes: Int64): TDateTime;
function IncYear(const AValue: TDateTime; const ANumberOfYears: Integer): TDateTime;
{$ENDIF DELPHI5}

function WrappedHexString(iData:string; iWrapLength:integer=40):string;
function StringFromHexString(iData:string):string;
function StringFromHexStringAnsi(iData:Ansistring):Ansistring;
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;
function ROAnsiCompare(const S1, S2: AnsiString; aCaseInsensitive: Boolean {$IFDEF MSWINDOWS};aLocale: LCID = LOCALE_USER_DEFAULT{$ENDIF}): Integer;
function AnsiHexToBin(aString: AnsiString): Ansistring;

{$IFNDEF DELPHI2009UP}
  // from system.pas
const
   varUString  = $0102; { Unicode string 258 } {not OLE compatible}

function CharInSet(c: Char; CharSet: TSysCharSet):Boolean;
function UTF8ToString(const S: UTF8String): WideString;
{$ENDIF}

Function ROGetEnumName(aTypeInfo : PTypeInfo;Value : Integer) : string;
function ROGetEnumValue(TypeInfo: PTypeInfo; const Name: string): Integer;

function AnsiStringToWideString(AValue: AnsiString): WideString;
function WideStringToAnsiString(AValue: WideString): AnsiString;
function VarToAnsiStr(const Value: Variant): Ansistring;
function GUIDToAnsiString(const GUID: TGUID): Ansistring;
function StrToDataType(const aString : string) : TRODataType;

{$IFDEF DARWIN}
function sem_timedwait(__sem:cint;wait_time: timespec):cint;
{$ENDIF}
implementation

{$IFDEF DELPHI6}
  {$DEFINE PATCH_MEMORYSTREAM_REALLOC}
{$ENDIF}
{$IFDEF DELPHI7}
  {$DEFINE PATCH_MEMORYSTREAM_REALLOC}
{$ENDIF}

uses {$IFDEF MSWINDOWS}ActiveX,{$ENDIF}
     {$IFDEF FPC}Variants,
     {$ELSE}
       {$IFDEF VER140UP}Variants,{$ENDIF}
     {$ENDIF}
     {$IFDEF PATCH_MEMORYSTREAM_REALLOC}RTLConsts,{$ENDIF}
     uRORes{, uROSerializer};

function GUIDToAnsiString(const GUID: TGUID): Ansistring;
begin
{$IFDEF UNICODE}
  SetLength(Result, 38);
  StrLFmt(PAnsiChar(Result), 38,'{%.8x-%.4x-%.4x-%.2x%.2x-%.2x%.2x%.2x%.2x%.2x%.2x}',   // do not localize
    [GUID.D1, GUID.D2, GUID.D3, GUID.D4[0], GUID.D4[1], GUID.D4[2], GUID.D4[3],
    GUID.D4[4], GUID.D4[5], GUID.D4[6], GUID.D4[7]]);
{$ELSE}
  Result := GUIDToString(GUID);
{$ENDIF}
end;

function VarToAnsiStr(const Value: Variant): Ansistring;
begin
  if (Value = Unassigned) or VarIsnull(Value) then
    Result := ''
  else
    {$IFDEF UNICODE}
    // based on _VarOleStrToString
    if TVarData(Value).VType = varString then
      Result := AnsiString(TVarData(Value).VString)
    else
      Result := WideStringToAnsiString(VarToWideStr(Value));
    {$ELSE}
    Result := VarToStr(Value);
    {$ENDIF}
end;

{$IFNDEF DELPHI2009UP}
function CharInSet(c: Char; CharSet: TSysCharSet): Boolean;
begin
  Result := c in CharSet;
end;

function UTF8ToString(const S: UTF8String): WideString;
begin
  Result := UTF8Decode(S);
end;
{$ENDIF}

function AnsiStringToWideString(AValue: AnsiString): WideString;
begin
  {$IFDEF UNICODE} //AnsiStringToWideString
  Result := StringOf(BytesOf(AValue));
  {$ELSE}
  Result := AValue;
  {$ENDIF}
end;

function WideStringToAnsiString(AValue: WideString): AnsiString;
{$IFDEF UNICODE} //WideStringToAnsiString
var
  b: TBytes;
begin
  b := BytesOf(AValue);
  SetLength(Result, Length(b));
  Move(b[0], pointer(Result)^,Length(b));
end;
{$ELSE}
begin
  Result := AValue;
end;
{$ENDIF}

{$IFDEF FPC}
const
  BooleanIdents: array [Boolean] of string = ('False', 'True');
{$ENDIF}

Function ROGetEnumName(aTypeInfo : PTypeInfo;Value : Integer) : string;
begin
  {$IFDEF FPC}
  if (aTypeInfo = System.TypeInfo(Boolean)) then
    { LongBool/WordBool/ByteBool have MinValue < 0 and arbitrary content in Value; Boolean has Value in [0, 1] }
    Result := BooleanIdents[Value <> 0]
  else
  {$ENDIF}
    Result := TypInfo.GetEnumName(aTypeInfo,Value);
end;

function ROGetEnumValue(TypeInfo: PTypeInfo; const Name: string): Integer;
begin
{$IFDEF FPC}
  if (TypeInfo = System.TypeInfo(Boolean)) then  begin
    if SameText(Name, BooleanIdents[False]) then
      Result := 0
    else
      Result := 1;
  end
  else
{$ENDIF FPC}
  Result := TypInfo.GetEnumValue(TypeInfo, Name);
end;

function StrToDataType(const aString : string) : TRODataType;
var dt : TRODataType;
    i: Integer;
begin
  result := rtUserDefined;

  for dt := Low(TRODataType) to High(TRODataType) do
    if (CompareText(aString, DataTypeNames[dt])=0) then begin
      result := dt;
      Exit;
    end;
  for i := low(DataTypeRemapping) to High(DataTypeRemapping) do
  begin
    if CompareText(aString, DataTypeRemapping[i].Name) = 0 then begin
      Result := DataTypeRemapping[i].NewType;
      exit;
    end;
  end;
end;

{ 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: Ansistring);
begin
  FCapacityIncrement:=0; //standard mode
  Create();
  LoadFromString(iString);
end;

procedure TROBinaryMemoryStream.LoadFromString(const iString: Ansistring);
var
  lLength:integer;
begin
  lLength := Length(iString);
  SetSize(lLength);
  Move(pointer(iString)^,Memory^,Length(iString));
  Seek(0,soFromBeginning);
end;

procedure TROBinaryMemoryStream.LoadFromHexString(const iString: Ansistring);
begin
  if Length(iString) mod 2 <> 0 then RaiseError('String length must be 2n');
  Size := Length(iString) div 2;
  HexToBin(pAnsiChar(iString),Memory,Size);
  Seek(0,soFromBeginning);
end;

function TROBinaryMemoryStream.ToHexString: Ansistring;
begin
  SetLength(result,Size*2);
  BinToHex(Memory,pAnsiChar(result),Size);
end;

function TROBinaryMemoryStream.ToReadableString: Ansistring;
begin
  Result := CleanStringFromBinaries(ToString);
end;

function TROBinaryMemoryStream.ToString: AnsiString;
begin
  SetLength(Result,Size);
  Seek(0,soFromBeginning);
  Read(pointer(Result)^,Size);
end;


function TROBinaryMemoryStream.WriteAnsiString(AString: AnsiString): integer;
begin
  Result:=Write(pointer(AString)^, Length(Astring));
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
  lSize:Int64;
  s: Ansistring;
begin
  iStream.Seek(0,soFromBeginning);
  lSize := iStream.Size;
  if lSize > 500 then lSize := 500;
  SetLength(s, lSize);
  iStream.ReadBuffer(pointer(s)^,lSize);
  raise EROInvalidStream.Create(Format(anErrorMessage,someParams)+#13#13+{$IFDEF UNICODE}UTF8ToString{$ENDIF}(CleanStringFromBinaries(s)));
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 CharInSet(aString[i], ['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 CharInSet(result[i], [#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 AnsiChar = [#13, #10, #32];
var i : integer;
begin
  result := aString;

  while ((Length(result)>0) and CharInSet(result[1], DirtyChars)) do
    Delete(result, 1, 1);

  while (Length(result)>0) do begin
    i := Length(result);
    if CharInSet(result[i], 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(Length(lTempdir), lTempdir);
  result := IncludeTrailingPathDelimiter(lTempdir);
end;
{$ENDIF}
{$IFNDEF MSWINDOWS}
function GetTempPath:string;
begin
  result := GetEnvironmentVariable('tmp');
end;
{$ENDIF}

function GetTempFileName(const aFileExt:string):string;
begin
  result := GetTempPath+NewStrippedGuidAsString()+aFileExt;
end;

{$IFNDEF MSWINDOWS}
function GetTickCount:cardinal;
begin
  // from lclintf.pas (FPC)
  Result := DWord(Trunc(Now * 24 * 60 * 60 * 1000));

  //  result := clock div (CLOCKS_PER_SEC div 1000);
end;
{$ENDIF}

function NewGuid:TGUID;
begin
  {$IFDEF MSWINDOWS}
  CoCreateGuid(result);
  {$ELSE}
  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:TSetOfAnsiChars; iChar:char);
var i:Integer;
begin
  for i := 1 to length(s) do begin
    if CharInSet(s[i], iChars) then s[i] := iChar;
  end;
end;

procedure Remove(var s:string; iChars:TSetOfAnsiChars); 
var i,l:Integer;
   // source:string;
begin
 // source := s;
  l := 0;
  for i := 1 to length(s) do begin
    if not CharInSet(s[i], iChars) then begin
      s[l+1] := s[i];
      inc(l);
    end;
  end;
  SetLength(s,l);
end;

procedure RemoveAnsi(var s:Ansistring; iChars:TSetOfAnsiChars);
var i,l:Integer;
   // source:string;
begin
 // source := s;
  l := 0;
  for i := 1 to length(s) do begin
    if not CharInSet(s[i], iChars) then begin
      s[l+1] := s[i];
      inc(l);
    end;
  end;
  SetLength(s,l);
end;

procedure RemoveExcept(var s:string; iChars:TSetOfAnsiChars);
var i,l:Integer;
  //  source:string;
begin
//  source := s;
  l := 0;
  for i := 1 to length(s) do begin
    if CharInSet(s[i], 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 CharInSet(result[i], ['a'..'z','A'..'Z','0'..'9','_']) then result[i] := '_';
end;

function CleanStringFromBinaries(const iString:Ansistring):Ansistring;
var i:integer;
begin
  Result := iString;
  for i := 1 to Length(Result) do
    if not CharInSet(Result[i], [#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;

{$IFDEF DELPHI5}
const
  HoursPerDay   = 24;
  MinsPerHour   = 60;
  SecsPerMin    = 60;
  MSecsPerSec   = 1000;
  MinsPerDay    = HoursPerDay * MinsPerHour;
  SecsPerDay    = MinsPerDay * SecsPerMin;
  MSecsPerDay   = SecsPerDay * MSecsPerSec;

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;

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;
}
function IncYear(const AValue: TDateTime; const ANumberOfYears: Integer ): TDateTime;
Var
  Y,M,D,H,N,S,MS : Word;
begin
  DecodeDateTime(AValue,Y,M,D,H,N,S,MS);
  Y:=Y+ANumberOfYears;
  If (M=2) and (D=29) And (Not IsLeapYear(Y)) then D:=28;
  Result:=EncodeDateTime(Y,M,D,H,N,S,MS);
end;
{$ENDIF DELPHI5}

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 AnsiHexToBin(aString: AnsiString): Ansistring;
var
  i,j,k: integer;
begin
  k:=0;
  Result := '';
  if Length(aString) mod 2 <> 0 then raise EROException.Create('String length must be 2n');
  for i:= 1 to Length(aString) do begin
    j:= ord(aString[i]);
    case j  of
      48..57: dec(j,48);
      65..70: dec(j, 55);
      97..120: dec(j, 87);
    else
      raise Exception.CreateFmt('Can''t decode hex string: "%s"', [aString]);
    end;
    k:= k*16 + j;
    if i mod 2 = 0 then begin
      Result := Result + AnsiChar(k);
      k := 0;
    end;   
  end;
end;

function StringFromHexStringAnsi(iData:Ansistring):Ansistring;
begin
  RemoveAnsi(iData,[#13,#10,#32]);
  Result := AnsiHexToBin(iData);
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
  s := '';
  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;
const
  MemoryDelta = $2000; { Must be a power of 2 }
begin
  if (FCapacityIncrement <> 0) and (NewCapacity<>0) then inc(NewCapacity,FCapacityIncrement);
  {$IFDEF PATCH_MEMORYSTREAM_REALLOC}
  if (NewCapacity > 0) and (NewCapacity <> Position) then
    NewCapacity := (NewCapacity + (MemoryDelta - 1)) and not (MemoryDelta - 1);
  Result := Memory;
  if NewCapacity <> Capacity then
  begin
    if NewCapacity = 0 then
    begin
      FreeMem(Memory);
      Result := nil;
    end else
    begin
      if Capacity = 0 then
        GetMem(Result, NewCapacity)
      else
        ReallocMem(Result, NewCapacity);
      if Result = nil then raise EStreamError.CreateRes(@SMemoryStreamError);
    end;
  end;
  {$ELSE}
  Result := inherited Realloc(NewCapacity);
  {$ENDIF}
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 MSWINDOWS}
  fWakeUp := TEvent.Create(nil,False,False,'');
  fFreeWaiting := nil;
{$ENDIF}
  fTimerEvent := aTimerEvent;
  Timeout := aTimeout;  
  Resume();
end;

destructor TROThreadTimer.Destroy;
begin
  if not Terminated then Terminate();
{$IFDEF MSWINDOWS}
  while fFreeWaiting <> nil do Sleep(1);
  if fWakeUp <> nil then fWakeUp.SetEvent();
  FreeAndNIL(fWakeUp);
{$ENDIF}
  inherited;
end;

procedure TROThreadTimer.Execute;
{$IFNDEF MSWINDOWS}
var
  nexttime: Cardinal;
{$ENDIF}
begin
//  inherited;

  while not Terminated do begin
  {$IFDEF MSWINDOWS}
    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 MSWINDOWS}
  fWakeUp := TEvent.Create(nil,False,False,'');
  fFreeWaiting := nil;
  {$ENDIF}

  fTimerEvent := aTimerEvent;
  Timeout := aTimeout;
  fSynchronized := Synchronized;
  Resume();
end;

procedure TROThreadTimer.AsyncFree;
begin
  FreeOnTerminate := true;
  fTimerEvent := nil;
  Terminate;
  {$IFDEF MSWINDOWS}
  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);
    fFreeWaiting := nil;
  finally
    lEvent.Free;
  end;
  sleep(10); // make sure it''s actually terminated
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 := aInterfaceType;
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;
  {$IFDEF FPC}lMemory := nil; {$ENDIF}
  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;

{$IFNDEF MSWINDOWS}
constructor TROEvent.Create(Dummy: Pointer; ManualReset, InitialVal: Boolean;
  Name: string);
begin
  inherited Create;
  sem_init(FEvent, 0, Byte(InitialVal));
end;

destructor TROEvent.Destroy;
begin
  sem_destroy(FEvent);
  inherited Destroy;
end;

procedure TROEvent.SetEvent;
var
  i: Integer;
begin
  {$IFDEF FPC}
  i:=0;
  {$ENDIF}
  sem_getvalue(FEvent,I);
  if I = 0 then
    sem_post(FEvent);
end;

{$IFDEF DARWIN}
{ from /developers/SDKs/MACOSX10.5.sdk/usr/include/mach/samaphore.h
extern kern_return_t semaphore_timedwait (semaphore_t semaphore, mach_timespec_t wait_time;
}
function semaphore_timedwait(__sem:cint;wait_time: timespec):cint;cdecl;external 'c'  name 'semaphore_timedwait';

function sem_timedwait(__sem:cint;wait_time: timespec):cint;
begin
  Result := semaphore_timedwait(__sem,wait_time);
end;
{$ENDIF}

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 := fptime + (timeout div 1000);
    inttimeout.tv_nsec := (timeout mod 1000);
    if sem_timedwait(FEvent, inttimeout) = 0 then
      Result := wrSignaled
    else
      Result := wrTimeout;
  end;
end;
procedure TROEvent.ResetEvent;
begin
end;
{$ENDIF}

{$IFDEF MSWINDOWS}
function ROWideCompare(const S1, S2: WideString; aCaseInsensitive: Boolean; aLocale: LCID = LOCALE_USER_DEFAULT): Integer;
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
  {$WARNINGS OFF}
    ls1:= s1;
    ls2:= s2;
  {$WARNINGS ON}
    Result := CompareStringA(ALocale, dwCmpFlags, PAnsiChar(ls1), Length(ls1), PAnsiChar(ls2), Length(ls2)) - 2
  end;
  if GetLastError <>0 then RaiseLastOSError;
end;

function ROAnsiCompare(const S1, S2: AnsiString; aCaseInsensitive: Boolean; aLocale: LCID = LOCALE_USER_DEFAULT): Integer;
var
  dwCmpFlags: integer;
begin
  SetLastError(0);
  if aCaseInsensitive then
    dwCmpFlags := NORM_IGNORECASE
  else
    dwCmpFlags := 0;
  Result := CompareStringA(ALocale, dwCmpFlags, PAnsiChar(s1), Length(s1), PAnsiChar(s2), Length(s2)) - 2;
  if GetLastError <>0 then RaiseLastOSError;
end;
{$ENDIF}

{$IFNDEF MSWINDOWS}
function ROWideCompare(const S1, S2: WideString; aCaseInsensitive: Boolean): Integer;
begin
  if aCaseInsensitive then
    Result:= WideCompareText(s1, s2)
  else
    Result:= WideCompareStr(s1, s2)
end;

function ROAnsiCompare(const S1, S2: AnsiString; aCaseInsensitive: Boolean): Integer;
begin
  if aCaseInsensitive then
    Result:= AnsiCompareText(s1, s2)
  else
    Result:= AnsiCompareStr(s1, s2)
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)) then
      case VarType(A) of
        varUString, varOleStr: Result:= ROWideCompare(VarToWideStr(A),VarToWideStr(B),False) = 0;
        varString : Result:= ROAnsiCompare(VarToAnsiStr(A),VarToAnsiStr(B),False) = 0;
      else
        Result := VarCompareValue(A, B) = vrEqual;
      end
    else
      Result := VarCompareValue(A, B) = vrEqual;
end;

{ EROException }

class function EROException.GetAttributeCount: Integer;
begin
  result := 0;
end;

class function EROException.GetAttributeName(aIndex: Integer): string;
begin
  result := '';
end;

class function EROException.GetAttributeValue(aIndex: Integer): string;
begin
  result := '';
end;

destructor EROException.Destroy;
var props : PPropList;
    cnt, i : integer;
    sub : TObject;
    lName : string;
begin
  cnt := GetTypeData(ClassInfo).PropCount;
  if (cnt=0) then Exit;
  {$IFDEF FPC}
  props := nil;
  {$ENDIF}
  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
          lName := {$IFDEF UNICODE}UTF8ToString{$ENDIF}(Name); 
          sub := GetObjectProp(Self, lName);
          sub.Free;
        end;
    end;
  finally
    FreeMem(props, cnt*SizeOf(PPropInfo));
  end;

  inherited;
end;

procedure EROException.ReadException(ASerializer: TObject);
begin
  TROBaseSerializer(ASerializer).ReadObject(Self);
end;

procedure EROException.WriteException(ASerializer: TObject);
begin
  TROBaseSerializer(ASerializer).WriteObject(Self);
end;

{ TROInitializedThread }

constructor TROInitializedThread.Create(CreateSuspended: Boolean);
begin
  FInitialize := ROInitializeThreads;
  {$IFDEF MSWINDOWS}
  if FInitialize then CoInitialize(nil);
  {$ENDIF}
  inherited Create(CreateSuspended);
end;

destructor TROInitializedThread.Destroy;
begin
  inherited;
  {$IFDEF MSWINDOWS}
  if FInitialize then CoUninitialize;
  {$ENDIF}
end;

end.