
//////////////////////////////////////////////////
//  DB Access Components
//  Copyright © 1998-2014 Devart. All right reserved.
//  CRFunctions
//////////////////////////////////////////////////

{$IFNDEF CLR}
{$IFNDEF EntityDAC}
{$I Dac.inc}
unit CRFunctions;
{$ENDIF}
{$ENDIF}

interface

uses
  Classes, SysUtils,
{$IFDEF VER6P}
  Variants,
{$IFNDEF FPC}
  FMTBcd, SqlTimSt,
{$ENDIF}
{$IFNDEF CLR}
  VarUtils,
{$ENDIF}
{$ENDIF}
{$IFNDEF EntityDAC}
  CRTypes;
{$ELSE}
  EntityDAC.Common.Types;
{$ENDIF}

type
  CRBitConverter = class
  public
    class function Int32BitsToSingle(Value: Integer): Single; {$IFDEF USE_INLINE}inline;{$ENDIF}
    class function SingleToInt32Bits(Value: Single): integer; {$IFDEF USE_INLINE}inline;{$ENDIF}
    class function BytesToExtended(const Value: TBytes): Extended; {$IFDEF USE_INLINE}inline;{$ENDIF}
    class function ExtendedToBytes(Value: Extended): TBytes; {$IFDEF USE_INLINE}inline;{$ENDIF}
  end;

{$IFNDEF VER6P}
{$IFNDEF FPC}
  TValueRelationship = -1..1;

const
  FuzzFactor = 1000;
  SingleResolution   = 1E-7 * FuzzFactor;
  DoubleResolution   = 1E-15 * FuzzFactor;

  LessThanValue = Low(TValueRelationship);
  EqualsValue = 0;
  GreaterThanValue = High(TValueRelationship);

  function SameValue(const A, B: Double; Epsilon: Double = 0): Boolean; overload;
  function SameValue(const A, B: Single; Epsilon: Single = 0): Boolean; overload;
  function CompareValue(const A, B: Double; Epsilon: Double = 0): TValueRelationship; overload;
  function CompareValue(const A, B: Single; Epsilon: Single = 0): TValueRelationship; overload;
{$ENDIF}
{$ENDIF}

{$IFDEF VER6P}
{$IFNDEF FPC}
  function GetBcdPrecision(const Bcd: TBcd): Integer;
  function GetBcdScale(const Bcd: TBcd): Integer;
  function IsBcdInt(const Bcd: TBcd): Boolean;
  function IsBcdZero(const Bcd: TBcd): Boolean;
  function SQLTimeStampCompare(const Value1, Value2: TSQLTimeStamp): integer;
{$ENDIF}
{$ENDIF}
  function TryStrToGUID(const S: string; out Value: TGUID): Boolean;

{ Delphi 5 support }

{$IFDEF VER5}
  function TryStrToInt(const S: string; out Value: Integer): Boolean;
  function TryStrToInt64(const S: string; out Value: Int64): Boolean;
  function TryStrToFloat(const S: string; out Value: Extended): Boolean; overload;
  function TryStrToFloat(const S: string; out Value: Double): Boolean; overload;
  function TryStrToDate(const S: string; out Value: TDateTime): Boolean;
  function TryStrToTime(const S: string; out Value: TDateTime): Boolean;
  function TryStrToDateTime(const S: string; out Value: TDateTime): Boolean;
  function BoolToStr(const Value: boolean; UseBoolStrs: Boolean = False): string;
  procedure DecodeDateTime(const AValue: TDateTime; out AYear, AMonth, ADay,
    AHour, AMinute, ASecond, AMilliSecond: Word);
  function WideUpperCase(const S: WideString): WideString;
  function VarToWideStr(const V: Variant): WideString;
  function VarIsStr(const V: Variant): Boolean;
  function AnsiDequotedStr(const S: string; AQuote: Char): string;
  function AnsiContainsText(const AText, ASubText: string): Boolean;
  procedure VarResultCheck(AResult: HRESULT);
  procedure RaiseLastOSError;
  function StringToGUID(const S: string): TGUID;
  function GUIDToString(const GUID: TGUID): string;
  function GetEnvironmentVariable(const Name: string): string; overload;
  function GetEnvironmentVariable(lpName: PChar; lpBuffer: PChar; nSize: Cardinal): Cardinal; overload;
{$ENDIF}

{ Delphi 5 and 6 support }

{$IFNDEF VER7P}
  function StrToBool(const S: string): Boolean;
  function TryStrToBool(const S: string; out Value: Boolean): Boolean;

  procedure SafeArrayCheck(AResult: HRESULT);
  procedure SafeArrayError(AResult: HRESULT);

  function LeftStr(const AText: AnsiString; const ACount: Integer): AnsiString; overload;
  function RightStr(const AText: AnsiString; const ACount: Integer): AnsiString; overload;
  function PosEx(const SubStr, S: string; Offset: Cardinal = 1): Integer;
{$ENDIF}

  procedure AssignStrings(Source: TStrings; Dest: TStrings); overload;

{$IFNDEF FPC}
{$IFNDEF CLR}
{$IFNDEF NEXTGEN}
// These functions was changed in the Delphi XE and they are copied to this unit for compatibility
  function UnicodeToUtf8(Dest: PAnsiChar; Source: PWideChar; MaxBytes: Integer): Integer; overload;
  function UnicodeToUtf8(Dest: PAnsiChar; MaxDestBytes: Cardinal; Source: PWideChar; SourceChars: Cardinal): Cardinal; overload;
  function Utf8ToUnicode(Dest: PWideChar; Source: PAnsiChar; MaxChars: Integer): Integer; overload;
  function Utf8ToUnicode(Dest: PWideChar; MaxDestChars: Cardinal; Source: PAnsiChar; SourceBytes: Cardinal): Cardinal; overload;
  function Utf8Encode(const WS: WideString): {$IFDEF VER12P}RawByteString{$ELSE}UTF8String{$ENDIF};
  function Utf8Decode(const S: {$IFDEF VER12P}RawByteString{$ELSE}UTF8String{$ENDIF}): WideString;
  function AnsiToUtf8(const S: AnsiString): {$IFDEF VER12P}RawByteString{$ELSE}UTF8String{$ENDIF};
  function Utf8ToAnsi(const S: {$IFDEF VER12P}RawByteString{$ELSE}UTF8String{$ENDIF}): AnsiString;
{$ELSE}
  function Utf8Encode(const S: string): AnsiString;
  function Utf8Decode(const S: AnsiString): string;
  function AnsiToUtf8(const S: AnsiString): AnsiString;
  function Utf8ToAnsi(const S: AnsiString): AnsiString;
{$ENDIF}
{$ELSE}
  function Utf8Encode(const WS: WideString): UTF8String;
  function Utf8Decode(const S: UTF8String): WideString;
  function AnsiToUtf8(const S: AnsiString): UTF8String;
  function Utf8ToAnsi(const S: UTF8String): AnsiString;
{$ENDIF}
{$ELSE}
  function UnicodeToUtf8(Dest: PAnsiChar; MaxDestBytes: Cardinal; Source: PWideChar; SourceChars: Cardinal): Cardinal;
  function Utf8Encode(const WS: WideString): UTF8String;
  function Utf8Decode(const S: UTF8String): WideString;
  function AnsiToUtf8(const S: AnsiString): UTF8String;
  function Utf8ToAnsi(const S: UTF8String): AnsiString;
{$ENDIF}

{$IFDEF CLR}
  procedure UniqueString(s: string);
{$ENDIF}

{$IFNDEF VER12P}
  function CharInSet(C: Char; const CharSet: TSysCharSet): Boolean;
{$ELSE}
  function StrToUInt64(const S: string): UInt64;
  function TryStrToUInt64(const S: string; out Value: UInt64): Boolean;
{$ENDIF}

{ POSIX support }

{$IFDEF POSIX}
  function GetTickCount: Cardinal;

{$IFNDEF PUREPASCAL}
  function InterlockedIncrement(var I: Integer): Integer;
  function InterlockedDecrement(var I: Integer): Integer;
{$ELSE}
{$IFDEF NEXTGEN}
  function InterlockedIncrement(var I: Integer): Integer; inline;
  function InterlockedDecrement(var I: Integer): Integer; inline;
{$ENDIF}
{$ENDIF}

{$IFNDEF NEXTGEN}
  function WideCharToMultiByte(CodePage: Cardinal; dwFlags: Cardinal;
    lpWideCharStr: PWideChar; cchWideChar: Integer; lpMultiByteStr: PAnsiChar;
    cchMultiByte: Integer; lpDefaultChar: PAnsiChar; lpUsedDefaultChar: PLongBool): Integer;
  function MultiByteToWideChar(CodePage: Cardinal; dwFlags: Cardinal;
    const lpMultiByteStr: PAnsiChar; cchMultiByte: Integer;
    lpWideCharStr: PWideChar; cchWideChar: Integer): Integer;
{$ENDIF}
{$ENDIF}

  function PtrOffset(Value: IntPtr; Offset: Integer): IntPtr; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
{$IFNDEF FPC}
  function PtrOffset(Value: IntPtr; Offset: Int64): IntPtr; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
{$ENDIF}
  function PtrSubstract(Value1: IntPtr; Value2: IntPtr): Integer; {$IFDEF USE_INLINE}inline;{$ENDIF}
  function PtrCompare(Value1: IntPtr; Value2: IntPtr): Integer; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  function PtrCompare(Value1: IntPtr; Offset1: Integer; Value2: IntPtr; Offset2: Integer): Integer; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  function PtrCompare(Value1: IntPtr; Offset1: Int64; Value2: IntPtr; Offset2: Int64): Integer; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}

  function IsClass(Obj: TObject; AClass: TClass): boolean;
  function IsMainThread: boolean;

  function LengthA(const AStr: AnsiString): integer; {$IFDEF USE_INLINE}inline;{$ENDIF}
  procedure SetLengthA(var AStr: AnsiString; NewLength: integer); {$IFDEF USE_INLINE}inline;{$ENDIF}

{ FPC support}

{$IFDEF FPC}

{$IFDEF UNIX}
function GetTickCount: Cardinal;
{$ENDIF}

{$IFDEF CPUX64}
function VarArrayCreate(const Bounds: array of Integer; aVarType: TVarType): Variant;
{$ENDIF}

{$ENDIF}

function SwapLongWord(const Value: LongWord): LongWord; {$IFDEF USE_INLINE}inline;{$ENDIF}

implementation

uses
{$IFDEF VER6}
  SysConst,
{$ENDIF}
{$IFNDEF VER6P}
{$IFNDEF FPC}
  Math,
{$ENDIF}
{$ENDIF}
{$IFDEF VER11P}
  StrUtils,
{$ENDIF}
{$IFDEF CLR}
  System.Threading,
{$ENDIF}
{$IFDEF MSWINDOWS}
  Windows;
{$ENDIF}
{$IFDEF POSIX}
  System.Diagnostics;
{$ENDIF}
{$IFDEF UNIX}
  unix;
{$ENDIF}

type
{$IFDEF FPC}
  PNativeInt = IntPtr;
  PNativeUInt = IntPtr;
{$ELSE}
  PNativeInt = NativeInt;
  PNativeUInt = NativeUInt;
{$ENDIF}

{$IFNDEF VER6P}
{$IFNDEF FPC}

function SameValue(const A, B: Double; Epsilon: Double): Boolean;
begin
  if Epsilon = 0 then
    Epsilon := Max(Min(Abs(A), Abs(B)) * DoubleResolution, DoubleResolution);
  if A > B then
    Result := (A - B) <= Epsilon
  else
    Result := (B - A) <= Epsilon;
end;

function SameValue(const A, B: Single; Epsilon: Single): Boolean;
begin
  if Epsilon = 0 then
    Epsilon := Max(Min(Abs(A), Abs(B)) * SingleResolution, SingleResolution);
  if A > B then
    Result := (A - B) <= Epsilon
  else
    Result := (B - A) <= Epsilon;
end;

function CompareValue(const A, B: Double; Epsilon: Double = 0): TValueRelationship;
begin
  if SameValue(A, B, Epsilon) then
    Result := EqualsValue
  else if A < B then
    Result := LessThanValue
  else
    Result := GreaterThanValue;
end;

function CompareValue(const A, B: Single; Epsilon: Single = 0): TValueRelationship;
begin
  if SameValue(A, B, Epsilon) then
    Result := EqualsValue
  else if A < B then
    Result := LessThanValue
  else
    Result := GreaterThanValue;
end;

{$ENDIF}
{$ENDIF}

{$IFDEF VER6P}
{$IFNDEF FPC}

function GetBcdPrecision(const Bcd: TBcd): Integer;
var
  b: Byte;
  I, J: Integer;
begin
  I := 0;
  J := Bcd.Precision - 1;

  while I < J do begin
    b := Bcd.Fraction[I div 2];
    if b <> 0 then begin
      if b shr 4 = 0 then
        Inc(I);
      break;
    end;
    I := I + 2;
  end;

  if Bcd.Precision mod 2 > 0 then begin
    b := Bcd.Fraction[J div 2];
    if b shr 4 <> 0 then begin
      Result := J - I + 1;
      exit;
    end;
    Dec(J)
  end;

  while I < J do begin
    b := Bcd.Fraction[J div 2];
    if b <> 0 then begin
      if b and $0F = 0 then
        Dec(J);
      break;
    end;
    J := J - 2;
  end;

  Result := J - I + 1;
end;

function GetBcdScale(const Bcd: TBcd): Integer;
var
  b: Byte;
  I, J: Integer;
begin
  Result := 0;

  I := Bcd.Precision - (Bcd.SignSpecialPlaces and $7F);
  J := Bcd.Precision - 1;

  if Bcd.Precision mod 2 = 1 then begin
    b := Bcd.Fraction[J div 2];
    if b shr 4 <> 0 then begin
      Result := J - I + 1;
      exit;
    end;
    Inc(I);
  end;

  while I < J do begin
    b := Bcd.Fraction[J div 2];
    if b <> 0 then begin
      if b and $0F <> 0 then
        Result := J - I  + 1
      else
        Result := J - I;
      exit;
    end;
    J := J - 2;
  end;

  if J mod 2 = 0 then begin
    b := Bcd.Fraction[J div 2];
    if b shr 4 <> 0 then
      Result := 1;
  end;
end;

function IsBcdInt(const Bcd: TBcd): Boolean;
var
  b: Byte;
  I, J: Integer;
begin
  Result := True;

  I := Bcd.Precision - (Bcd.SignSpecialPlaces and $7F);
  if I mod 2 = 1 then begin
    I := I div 2;
    b := Bcd.Fraction[I];
    Result := b and $0F = 0;
    Inc(I);
  end
  else
    I := I div 2;

  J := Bcd.Precision div 2;
  while Result and (I < J) do begin
    b := Bcd.Fraction[I];
    if b <> 0 then
      Result := False;
    Inc(I);
  end;

  if Result and (Bcd.Precision mod 2 > 0) then begin
    b := Bcd.Fraction[I];
    if b shr 4 <> 0 then
      Result := False;
  end;
end;

function IsBcdZero(const Bcd: TBcd): Boolean;
var
  i: Integer;
begin
{$IFNDEF CLR}
  for i := Low(Bcd.Fraction) to High(Bcd.Fraction) do
{$ELSE}
  for i := 0 to SizeOfFraction - 1 do
{$ENDIF}
    if Bcd.Fraction[i] <> 0 then begin
      Result := False;
      Exit;
    end;

  Result := True;
end;

function SQLTimeStampCompare(const Value1, Value2: TSQLTimeStamp): integer;
var
  Status: Integer;
begin
  Status := Value1.Year - Value2.Year;
  if Status = 0 then
    Status := Value1.Month - Value2.Month;
  if Status = 0 then
    Status := Value1.Day - Value2.Day;
  if Status = 0 then
    Status := Value1.Hour - Value2.Hour;
  if Status = 0 then
    Status := Value1.Minute - Value2.Minute;
  if Status = 0 then
    Status := Value1.Second - Value2.Second;
  if Status = 0 then
    Status := Value1.Fractions - Value2.Fractions;
  if Status = 0 then
    Result := 0
  else
  if Status > 0 then
    Result := 1
  else
    Result := -1;
end;

{$ENDIF}
{$ENDIF}

function TryStrToGUID(const S: string; out Value: TGUID): Boolean;
begin
  Result := True;
  try
    Value := StringToGUID(S);
  except
    Result := False;
  end;
end;

{ Delphi 5 support }

{$IFDEF VER5}

function TryStrToInt(const S: string; out Value: Integer): Boolean;
var
  E: Integer;
begin
  Val(S, Value, E);
  Result := E = 0;
end;

function TryStrToInt64(const S: string; out Value: Int64): Boolean;
var
  E: Integer;
begin
  Val(S, Value, E);
  Result := E = 0;
end;

function TryStrToFloat(const S: string; out Value: Extended): Boolean;
begin
  Result := TextToFloat(PChar(S), Value, fvExtended);
end;

function TryStrToFloat(const S: string; out Value: Double): Boolean;
var
  LValue: Extended;
begin
  Result := TextToFloat(PChar(S), LValue, fvExtended);
  if Result then
    Value := LValue;
end;

function TryStrToDate(const S: string; out Value: TDateTime): Boolean;
begin
  Result := True;
  try
    Value := StrToDate(S);
  except
    Result := False;
  end;
end;

function TryStrToTime(const S: string; out Value: TDateTime): Boolean;
begin
  Result := True;
  try
    Value := StrToTime(S);
  except
    Result := False;
  end;
end;

function TryStrToDateTime(const S: string; out Value: TDateTime): Boolean;
begin
  Result := True;
  try
    Value := StrToDateTime(S);
  except
    Result := False;
  end;
end;

function BoolToStr(const Value: boolean; UseBoolStrs: Boolean = False): string;
const
  cSimpleBoolStrs: array [boolean] of String = ('0', '-1');
begin
  if UseBoolStrs then
  begin
    if Value then
      Result := 'True'
    else
      Result := 'False';
  end
  else
    Result := cSimpleBoolStrs[Value];
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 WideUpperCase(const S: WideString): WideString;
var
  Len: Integer;
begin
  Len := Length(S);
  SetString(Result, PWideChar(S), Len);
  if Len > 0 then CharUpperBuffW(Pointer(Result), Len);
end;

function VarToWideStr(const V: Variant): WideString;
begin
  if not VarIsNull(V) then
    Result := V
  else
    Result := '';;
end;

function VarIsStr(const V: Variant): Boolean;
begin
  case VarType(V) of
    varString, varOleStr:
      Result := True;
  else
    Result := False;
  end;
end;

function AnsiDequotedStr(const S: string; AQuote: Char): string;
var
  LText: PChar;
begin
  LText := PChar(S);
  Result := AnsiExtractQuotedStr(LText, AQuote);
  if Result = '' then
    Result := S;
end;

function AnsiContainsText(const AText, ASubText: string): Boolean;
begin
  Result := AnsiPos(AnsiUppercase(ASubText), AnsiUppercase(AText)) > 0;
end;

procedure VarCastError;
begin
  raise EVariantTypeCastError.Create(SInvalidVarCast);
end;

procedure VarInvalidOp;
begin
  raise EVariantInvalidOpError.Create(SInvalidVarOp);
end;

procedure TranslateResult(AResult: HRESULT);
begin
  case AResult of
    VAR_TYPEMISMATCH:  VarCastError;
    VAR_BADVARTYPE:    raise EVariantBadVarTypeError.Create(SVarBadType);
    VAR_EXCEPTION:     VarInvalidOp;
    VAR_OVERFLOW:      raise EVariantOverflowError.Create(SVarOverflow);
    VAR_BADINDEX:      raise EVariantBadIndexError.Create(SVarArrayBounds);
    VAR_ARRAYISLOCKED: raise EVariantArrayLockedError.Create(SVarArrayLocked);
    VAR_NOTIMPL:       raise EVariantNotImplError.Create(SVarNotImplemented);
    VAR_OUTOFMEMORY:   raise EVariantOutOfMemoryError.Create(SOutOfMemory);
    VAR_INVALIDARG:    raise EVariantInvalidArgError.Create(SVarInvalid);
    VAR_UNEXPECTED:    raise EVariantUnexpectedError.Create(SVarUnexpected);
  else
    raise EVariantError.CreateFmt(SInvalidVarOpWithHResultWithPrefix,
      [HexDisplayPrefix, AResult, SysErrorMessage(AResult)]);
  end;
end;

procedure VarResultCheck(AResult: HRESULT);
begin
  if AResult <> VAR_OK then
    TranslateResult(AResult);
end;

procedure RaiseLastOSError;
begin
  RaiseLastWin32Error;
end;

function StringFromCLSID(const clsid: TGUID; out psz: PWideChar): HResult; stdcall;
  external 'ole32.dll' name 'StringFromCLSID';
procedure CoTaskMemFree(pv: Pointer); stdcall;
  external 'ole32.dll' name 'CoTaskMemFree';
function CLSIDFromString(psz: PWideChar; out clsid: TGUID): HResult; stdcall;
  external 'ole32.dll' name 'CLSIDFromString';

function StringToGUID(const S: string): TGUID;
begin
  if not Succeeded(CLSIDFromString(PWideChar(WideString(S)), Result)) then
    raise EConvertError.CreateFmt('''%s'' is not a valid GUID value', [s]);
end;

function GUIDToString(const GUID: TGUID): string;
var
  P: PWideChar;
begin
  if not Succeeded(StringFromCLSID(GUID, P)) then
    raise EConvertError.Create('''%s'' is not a valid GUID value');
  Result := P;
  CoTaskMemFree(P);
end;

function GetEnvironmentVariable(const Name: string): string;
var
  Len: integer;
begin
  Result := '';
  Len := Windows.GetEnvironmentVariable(PChar(Name), nil, 0);
  if Len > 0 then
  begin
    SetLength(Result, Len - 1);
    Windows.GetEnvironmentVariable(PChar(Name), PChar(Result), Len);
  end;
end;

function GetEnvironmentVariable(lpName: PChar; lpBuffer: PChar; nSize: Cardinal): Cardinal;
begin
  Result := Windows.GetEnvironmentVariable(lpNAme, lpBuffer, nSize);
end;

{$ENDIF}

{ Delphi 5 and 6 support }

{$IFNDEF VER7P}
var
  TrueBoolStrs: array of string;
  FalseBoolStrs: array of string;
const
  DefaultTrueBoolStr = 'True';
  DefaultFalseBoolStr = 'False';

procedure ConvertErrorFmt(ResString: PResStringRec; const Args: array of const);
begin
  raise EConvertError.CreateResFmt(ResString, Args);
end;

function StrToBool(const S: string): Boolean;
begin
  if not TryStrToBool(S, Result) then
  {$IFDEF VER5}
    raise EConvertError.Create('InvalidBoolean - ' + S);
  {$ELSE}
  {$IFDEF FPC}
    raise EConvertError.Create('InvalidBoolean - ' + S);
  {$ELSE}
    ConvertErrorFmt(@SInvalidBoolean, [S]);
  {$ENDIF}
  {$ENDIF}
end;

procedure VerifyBoolStrArray;
begin
  if Length(TrueBoolStrs) = 0 then
  begin
    SetLength(TrueBoolStrs, 1);
    TrueBoolStrs[0] := DefaultTrueBoolStr;
  end;
  if Length(FalseBoolStrs) = 0 then
  begin
    SetLength(FalseBoolStrs, 1);
    FalseBoolStrs[0] := DefaultFalseBoolStr;
  end;
end;

function TryStrToBool(const S: string; out Value: Boolean): Boolean;

  function CompareWith(const aArray: array of string): Boolean;
  var
    I: Integer;
  begin
    Result := False;
    for I := Low(aArray) to High(aArray) do
      if AnsiSameText(S, aArray[I]) then
      begin
        Result := True;
        Break;
      end;
  end;

var
  LResult: Extended;
begin
  Result := TryStrToFloat(S, LResult);
  if Result then
    Value := LResult <> 0
  else
  begin
    VerifyBoolStrArray;
    Result := CompareWith(TrueBoolStrs);
    if Result then
      Value := True
    else
    begin
      Result := CompareWith(FalseBoolStrs);
      if Result then
        Value := False;
    end;
  end;
end;

procedure SafeArrayCheck(AResult: HRESULT);
begin
  if AResult and $80000000 <> 0 then
    SafeArrayError(AResult);
end;

procedure SafeArrayError(AResult: HRESULT);
begin
  case AResult of
    VAR_BADINDEX:      raise ESafeArrayBoundsError.CreateHResult(AResult, SVarArrayBounds);
    VAR_ARRAYISLOCKED: raise ESafeArrayLockedError.CreateHResult(AResult, SVarArrayLocked);
  else
    raise ESafeArrayError.CreateHResult(AResult);
  end;
end;

function LeftStr(const AText: AnsiString; const ACount: Integer): AnsiString; overload;
begin
  Result := Copy(AnsiString(AText), 1, ACount);
end;

function RightStr(const AText: AnsiString; const ACount: Integer): AnsiString; overload;
begin
  Result := Copy(AnsiString(AText), Length(AnsiString(AText)) + 1 - ACount, ACount);
end;

function PosEx(const SubStr, S: string; Offset: Cardinal = 1): Integer;
var
  I,X: Integer;
  Len, LenSubStr: Integer;
begin
  if Offset = 1 then
    Result := Pos(SubStr, S)
  else
  begin
    I := Offset;
    LenSubStr := Length(SubStr);
    Len := Length(S) - LenSubStr + 1;
    while I <= Len do
    begin
      if S[I] = SubStr[1] then
      begin
        X := 1;
        while (X < LenSubStr) and (S[I + X] = SubStr[X + 1]) do
          Inc(X);
        if (X = LenSubStr) then
        begin
          Result := I;
          exit;
        end;
      end;
      Inc(I);
    end;
    Result := 0;
  end;
end;
{$ENDIF}

procedure AssignStrings(Source: TStrings; Dest: TStrings);
begin
  Dest.Assign(Source);
end;

{ UTF8Encoding }

{$IFNDEF FPC}
{$IFNDEF CLR}
{$IFNDEF NEXTGEN}

function UnicodeToUtf8(Dest: PAnsiChar; Source: PWideChar; MaxBytes: Integer): Integer;
begin
  Result := {$IFNDEF EntityDAC}CRFunctions{$ELSE}EntityDAC.Common.Functions{$ENDIF}.UnicodeToUtf8(Dest, MaxBytes, Source, Cardinal(-1));
end;

function UnicodeToUtf8(Dest: PAnsiChar; MaxDestBytes: Cardinal; Source: PWideChar; SourceChars: Cardinal): Cardinal;
begin
  Result := 0;
  if Source = nil then Exit;
  if Dest <> nil then
  begin
    Result := Cardinal(WideCharToMultiByte(CP_UTF8, 0, Source, Integer(SourceChars), Dest, Integer(MaxDestBytes), nil, nil));
    if (Result > 0) and (Result <= MaxDestBytes) and (Dest[Result - 1] <> #0) then
    begin
      if Result = MaxDestBytes then
      begin
        while (Result > 1) and (Byte(Dest[Result - 1]) > $7F) and (Byte(Dest[Result - 1]) and $80 <> 0) and (Byte(Dest[Result - 1]) and $C0 <> $C0) do
          Dec(Result);
      end else
        Inc(Result);
      Dest[Result - 1] := #0;
    end;
  end else
    Result := Cardinal(WideCharToMultiByte(CP_UTF8, 0, Source, Integer(SourceChars), nil, 0, nil, nil));
end;

function Utf8ToUnicode(Dest: PWideChar; Source: PAnsiChar; MaxChars: Integer): Integer;
begin
  Result := {$IFNDEF EntityDAC}CRFunctions{$ELSE}EntityDAC.Common.Functions{$ENDIF}.Utf8ToUnicode(Dest, MaxChars, Source, Cardinal(-1));
end;

function Utf8ToUnicode(Dest: PWideChar; MaxDestChars: Cardinal; Source: PAnsiChar; SourceBytes: Cardinal): Cardinal;
begin
  Result := 0;
  if Source = nil then Exit;
  if (Dest <> nil) and (MaxDestChars > 0) then
  begin
    Result := Cardinal(MultibyteToWideChar(CP_UTF8, 0, Source, Integer(SourceBytes), Dest, Integer(MaxDestChars)));
    if (Result > 0) and (Result <= MaxDestChars) and (Dest[Result - 1] <> #0) then
    begin
      if Result = MaxDestChars then
      begin
        if (Result > 1) and (Word(Dest[Result - 1]) >= $DC00) and (Word(Dest[Result - 1]) <= $DFFF) then
          Dec(Result);
      end else
        Inc(Result);
      Dest[Result - 1] := #0;
    end;
  end else
    Result := Cardinal(MultibyteToWideChar(CP_UTF8, 0, Source, Integer(SourceBytes), nil, 0));
end;

function Utf8Encode(const WS: WideString):{$IFDEF VER12P}RawByteString{$ELSE}UTF8String{$ENDIF};
var
  L: Integer;
  Temp: {$IFDEF VER12P}RawByteString{$ELSE}UTF8String{$ENDIF};
begin
  Result := '';
  if WS = '' then Exit;
  SetLength(Temp, Length(WS) * 3); // SetLength includes space for null terminator

  L := {$IFNDEF EntityDAC}CRFunctions{$ELSE}EntityDAC.Common.Functions{$ENDIF}.UnicodeToUtf8(PAnsiChar(Temp), Length(Temp)+1, PWideChar(WS), Length(WS));
  if L > 0 then
    SetLength(Temp, L-1)
  else
    Temp := '';
  Result := Temp;
end;

function Utf8Decode(const S: {$IFDEF VER12P}RawByteString{$ELSE}UTF8String{$ENDIF}): WideString;
var
  L: Integer;
  Temp: WideString;
begin
  Result := '';
  if S = '' then Exit;
  SetLength(Temp, Length(S));

  L := {$IFNDEF EntityDAC}CRFunctions{$ELSE}EntityDAC.Common.Functions{$ENDIF}.Utf8ToUnicode(PWideChar(Temp), Length(Temp)+1, PAnsiChar(S), Length(S));
  if L > 0 then
    SetLength(Temp, L-1)
  else
    Temp := '';
  Result := Temp;
end;

function AnsiToUtf8(const S: AnsiString): {$IFDEF VER12P}RawByteString{$ELSE}UTF8String{$ENDIF};
begin
  Result := Utf8Encode(WideString(S));
end;

function Utf8ToAnsi(const S: {$IFDEF VER12P}RawByteString{$ELSE}UTF8String{$ENDIF}): AnsiString;
begin
  Result := AnsiString(Utf8Decode(S));
end;

{$ELSE !NEXTGEN}
function Utf8Encode(const S: string): AnsiString;
begin
  Result := AnsiString(MarshaledAString(System.Utf8Encode(S)));
end;

function Utf8Decode(const S: AnsiString): string;
begin
  Result := System.Utf8Decode(MarshaledAString(S));
end;

function AnsiToUtf8(const S: AnsiString): AnsiString;
begin
  Result := AnsiString(MarshaledAString(System.AnsiToUtf8(string(S))));
end;

function Utf8ToAnsi(const S: AnsiString): AnsiString;
begin
  Result := AnsiString(System.Utf8ToAnsi(MarshaledAString(S)));
end;
{$ENDIF NEXTGEN}

{$ELSE CLR}

function Utf8Encode(const WS: WideString): UTF8String;
begin
  Result := Borland.Delphi.System.Utf8Encode(WS);
end;

function Utf8Decode(const S: UTF8String): WideString;
begin
  Result := Borland.Delphi.System.Utf8Decode(S);
end;

function AnsiToUtf8(const S: AnsiString): UTF8String;
begin
  Result := Borland.Delphi.System.AnsiToUtf8(S);
end;

function Utf8ToAnsi(const S: UTF8String): AnsiString;
begin
  Result := Borland.Delphi.System.Utf8ToAnsi(S);
end;

{$ENDIF}
{$ELSE}
function UnicodeToUtf8(Dest: PAnsiChar; MaxDestBytes: Cardinal; Source: PWideChar; SourceChars: Cardinal): Cardinal;
begin
  Result := System.UnicodeToUtf8(Dest, MaxDestBytes, Source, SourceChars);
end;

function Utf8Encode(const WS: WideString): UTF8String;
begin
  Result := System.Utf8Encode(WS);
end;

function Utf8Decode(const S: UTF8String): WideString;
begin
  Result := System.Utf8Decode(S);
end;

function AnsiToUtf8(const S: AnsiString): UTF8String;
begin
  Result := System.AnsiToUtf8(S);
end;

function Utf8ToAnsi(const S: UTF8String): AnsiString;
begin
  Result := System.Utf8ToAnsi(S);
end;
{$ENDIF}

{$IFDEF CLR}
procedure UniqueString(s: string);
begin

end;
{$ENDIF}

{$IFNDEF VER12P}
function CharInSet(C: Char; const CharSet: TSysCharSet): Boolean;
begin
{$IFDEF CLR}
  Result := AnsiChar(C) in CharSet;
{$ELSE}
  Result := C in CharSet;
{$ENDIF}
end;
{$ELSE}
function StrToUInt64(const S: string): UInt64;
const
  SInvalidInteger = '''''%s'''' is not a valid integer value';
var
  E: Integer;
begin
  Val(S, Result, E);
  if E <> 0 then
    raise EConvertError.CreateFmt(SInvalidInteger, [S]);
end;

function TryStrToUInt64(const S: string; out Value: UInt64): Boolean;
var
  E: Integer;
begin
  Val(S, Value, E);
  Result := E = 0;
end;
{$ENDIF}

{ POSIX support }

{$IFDEF POSIX}

function GetTickCount: Cardinal;
{$IFDEF LINUX}
var
  t: tms;
begin
  Result := Cardinal(Int64(Cardinal(times(t)) * 1000) div sysconf(_SC_CLK_TCK));
end;
{$ELSE}
begin
  Result := TStopwatch.GetTimeStamp div 10000;
end;
{$ENDIF}

{$IFNDEF PUREPASCAL}
function InterlockedIncrement(var I: Integer): Integer;
asm
{$IFNDEF CPUX64}
      MOV   EDX,1
      XCHG  EAX,EDX
 LOCK XADD  [EDX],EAX
      INC   EAX
{$ELSE}
      MOV   EAX,1
 LOCK XADD  dword ptr [RCX],EAX
      INC   EAX
{$ENDIF}
end;

function InterlockedDecrement(var I: Integer): Integer;
asm
{$IFNDEF CPUX64}
      MOV   EDX,-1
      XCHG  EAX,EDX
 LOCK XADD  [EDX],EAX
      DEC   EAX
{$ELSE}
      MOV   EAX,-1
 LOCK XADD  dword ptr [RCX],EAX
      DEC   EAX
{$ENDIF}
end;

{$ELSE}
function InterlockedIncrement(var I: Integer): Integer;
begin
  Result := AtomicIncrement(I);
end;

function InterlockedDecrement(var I: Integer): Integer;
begin
  Result := AtomicDecrement(I);
end;
{$ENDIF}

{$IFNDEF NEXTGEN}
function WideCharToMultiByte(CodePage: Cardinal; dwFlags: Cardinal;
  lpWideCharStr: PWideChar; cchWideChar: Integer; lpMultiByteStr: PAnsiChar;
  cchMultiByte: Integer; lpDefaultChar: PAnsiChar; lpUsedDefaultChar: PLongBool): Integer;
begin
  Result := LocaleCharsFromUnicode(CodePage, dwFlags, lpWideCharStr, cchWideChar, lpMultiByteStr, cchMultiByte, lpDefaultChar, lpUsedDefaultChar);
end;

function MultiByteToWideChar(CodePage: Cardinal; dwFlags: Cardinal;
  const lpMultiByteStr: PAnsiChar; cchMultiByte: Integer;
  lpWideCharStr: PWideChar; cchWideChar: Integer): Integer;
begin
  Result := UnicodeFromLocaleChars(CodePage, dwFlags, lpMultiByteStr, Integer(cchMultiByte), lpWideCharStr, cchWideChar);
end;
{$ENDIF}
{$ENDIF}

{ FPC support}

{$IFDEF FPC}

{$IFDEF UNIX}
function GetTickCount: Cardinal;
var
  tv: timeval;
begin
  fpgettimeofday(@tv, nil);
  {$RANGECHECKS OFF}
  Result := int64(tv.tv_sec) * 1000 + tv.tv_usec div 1000;
end;
{$ENDIF}

{$IFDEF CPUX64}
function VarArrayCreate(const Bounds: array of Integer; aVarType: TVarType): Variant;
var
  i: integer;
  Bounds64: array of Int64;
begin
  SetLength(Bounds64, Length(Bounds));
  for i := 0 to Length(Bounds) - 1 do
    Bounds64[i] := Bounds[i];
  Result :=  Variants.VarArrayCreate(Bounds64, aVarType);
end;
{$ENDIF}

{$ENDIF}

function SwapLongWord(const Value: LongWord): LongWord;
begin
  Result:= ((Value and $FF) shl 24) or ((Value and $FF00) shl 8) or ((Value and $FF0000) shr 8) or ((Value and $FF000000) shr 24);
end;

function PtrOffset(Value: IntPtr; Offset: Integer): IntPtr;
begin
{$IFDEF CLR}
  if IntPtr.Size = 4 then
    Result := IntPtr(Value.ToInt32 + Offset)
  else
    Result := IntPtr(Value.ToInt64 + Offset);
{$ELSE}
  Result := IntPtr(PNativeInt(Value) + Offset);
{$ENDIF}
end;

{$IFNDEF FPC}
function PtrOffset(Value: IntPtr; Offset: Int64): IntPtr;
begin
{$IFDEF CLR}
  Result := IntPtr(Value.ToInt64 + Offset);
{$ELSE}
  Result := IntPtr(PNativeInt(Value) + Offset);
{$ENDIF}
end;
{$ENDIF}

function PtrSubstract(Value1: IntPtr; Value2: IntPtr): Integer;
begin
{$IFDEF CLR}
  if IntPtr.Size = 4 then
    Result := Value1.ToInt32 - Value2.ToInt32
  else
    Result := Integer(Value1.ToInt64 - Value2.ToInt64);
{$ELSE}
  Result := Integer(PNativeInt(Value1) - PNativeInt(Value2));
{$ENDIF}
end;

function PtrCompare(Value1: IntPtr; Value2: IntPtr): Integer;
begin
{$IFDEF CLR}
  if IntPtr.Size = 4 then
    if Cardinal(Value1.ToInt32) > Cardinal(Value2.ToInt32) then
      Result := 1
    else if Cardinal(Value1.ToInt32) < Cardinal(Value2.ToInt32) then
      Result := -1
    else
      Result := 0
  else
    if UInt64(Value1.ToInt64) > UInt64(Value2.ToInt64) then
      Result := 1
    else if UInt64(Value1.ToInt64) < UInt64(Value2.ToInt64) then
      Result := -1
    else
      Result := 0
{$ELSE}
  if PNativeUInt(Value1) > PNativeUInt(Value2) then
    Result := 1
  else if PNativeUInt(Value1) < PNativeUInt(Value2) then
    Result := -1
  else
    Result := 0
{$ENDIF}
end;

function PtrCompare(Value1: IntPtr; Offset1: Integer; Value2: IntPtr; Offset2: Integer): Integer;
begin
{$IFDEF CLR}
  if IntPtr.Size = 4 then
    if Cardinal(Value1.ToInt32 + Offset1) > Cardinal(Value2.ToInt32 + Offset2) then
      Result := 1
    else if Cardinal(Value1.ToInt32 + Offset1) < Cardinal(Value2.ToInt32 + Offset2) then
      Result := -1
    else
      Result := 0
  else
    if UInt64(Value1.ToInt64 + Offset1) > UInt64(Value2.ToInt64 + Offset2) then
      Result := 1
    else if UInt64(Value1.ToInt64 + Offset1) < UInt64(Value2.ToInt64 + Offset2) then
      Result := -1
    else
      Result := 0
{$ELSE}
  if PNativeUInt(PNativeInt(Value1) + Offset1) > PNativeUInt(PNativeInt(Value2) + Offset2) then
    Result := 1
  else if PNativeUInt(PNativeInt(Value1) + Offset1) < PNativeUInt(PNativeInt(Value2) + Offset2) then
    Result := -1
  else
    Result := 0
{$ENDIF}
end;

function PtrCompare(Value1: IntPtr; Offset1: Int64; Value2: IntPtr; Offset2: Int64): Integer;
begin
{$IFDEF CLR}
  if Value1.ToInt64 + Offset1 > Value2.ToInt64 + Offset2 then
    Result := 1
  else if Value1.ToInt64 + Offset1 < Value2.ToInt64 + Offset2 then
    Result := -1
  else
    Result := 0
{$ELSE}
{$IFDEF FPC}
  if Value1 + Offset1 > Value2 + Offset2 then
    Result := 1
  else if Value1 + Offset1 < Value2 + Offset2 then
    Result := -1
  else
    Result := 0
{$ELSE}
  if PNativeInt(Value1) + Offset1 > PNativeInt(Value2) + Offset2 then
    Result := 1
  else if PNativeInt(Value1) + Offset1 < PNativeInt(Value2) + Offset2 then
    Result := -1
  else
    Result := 0
{$ENDIF}
{$ENDIF}
end;

function IsClass(Obj: TObject; AClass: TClass): boolean;

  function IsClassByName(Obj: TObject; AClass: TClass): boolean;
  var
    ParentClass: TClass;
  begin
    Result := False;
    if Obj = nil then
      Exit;

    ParentClass := Obj.ClassType;
    while ParentClass <> nil do begin
      Result := ParentClass.ClassName = AClass.ClassName;
      if not Result then
        ParentClass := ParentClass.ClassParent
      else
        Break;
    end;
  end;

begin
  if IsLibrary then
    Result := IsClassByName(Obj, AClass)
  else
    Result := Obj is AClass;
end;

function IsMainThread: boolean;
begin
{$IFDEF WIN32_64}
  Result := GetCurrentThreadID = MainThreadID;
{$ENDIF}
{$IFDEF CLR}
  Result := System.Threading.Thread.CurrentThread = MainThread;
{$ENDIF}
{$IFDEF POSIX}
  Result := TThread.CurrentThread.ThreadID = MainThreadID;
{$ENDIF}
end;

function LengthA(const AStr: AnsiString): integer;
begin
{$IFDEF NEXTGEN}
  Result := AStr.Length();
{$ELSE}
  Result := Length(AStr);
{$ENDIF}
end;

procedure SetLengthA(var AStr: AnsiString; NewLength: integer);
begin
{$IFDEF NEXTGEN}
  AStr.SetLength(NewLength);
{$ELSE}
  SetLength(AStr, NewLength);
{$ENDIF}
end;

{ CRBitConverter}

class function CRBitConverter.Int32BitsToSingle(Value: Integer): Single;
begin
{$IFNDEF CLR}
  Result := Single(Pointer(@Value)^);
{$ELSE}
  Result := BitConverter.ToSingle(BitConverter.GetBytes(Value), 0);
{$ENDIF}
end;

class function CRBitConverter.SingleToInt32Bits(Value: Single): integer;
begin
{$IFNDEF CLR}
  Result := Integer(Pointer(@Value)^);
{$ELSE}
  Result := BitConverter.ToInt32(BitConverter.GetBytes(Value), 0);
{$ENDIF}
end;

class function CRBitConverter.BytesToExtended(const Value: TBytes): Extended;
begin
{$IFNDEF CLR}
  Result := Extended(Pointer(@Value[0])^);
{$ELSE}
  Result := BitConverter.ToDouble(Value, 0);
{$ENDIF}
end;

class function CRBitConverter.ExtendedToBytes(Value: Extended): TBytes;
begin
{$IFNDEF CLR}
  SetLength(Result, SizeOf(Extended));
  Extended(Pointer(@Result[0])^) := Value;
{$ELSE}
  Result := BitConverter.GetBytes(Value);
{$ENDIF}
end;

end.
