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.