
//////////////////////////////////////////////////
//  DB Access Components
//  Copyright © 1998-2014 Devart. All right reserved.
//  Mem Data
//  Created:            06.11.03
//////////////////////////////////////////////////

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

interface

uses
  Classes, SysUtils, {$IFDEF VER6P}Variants,{$ENDIF}
{$IFDEF NEXTGEN}
  Generics.Collections, System.SysConst,
{$ENDIF}
{$IFDEF HAVE_COMPRESS_INTERNAL}
  ZLib, {$IFNDEF FPC}ZLibConst,{$ELSE}zstream,{$ENDIF}
{$ENDIF}
{$IFDEF CLR}
  System.Text, System.Xml, System.Runtime.InteropServices,
{$ELSE}
  {$IFNDEF EntityDAC}
  CLRClasses,
  {$ELSE}
  EntityDAC.Common.CLRClasses,
  {$ENDIF}
{$ENDIF}
{$IFNDEF EntityDAC}
  CRTypes;
{$ELSE}
  EntityDAC.Common.Types;
{$ENDIF}

{$IFDEF AUTOREFCOUNT}
type
  GCHandle = record
  private
    FAddrOfPinnedObject: Pointer;
    FTarget: TObject;

    function GetAddrOfPinnedObject: Pointer;
    function GetTarget: TObject;
  public
    class function Alloc(Ptr: Pointer): Pointer; overload; static;
    class function Alloc(Obj: TObject): Pointer; overload; static;

    class procedure Release(Ptr: pointer); static;

    property AddrOfPinnedObject: Pointer read GetAddrOfPinnedObject;
    property Target: TObject read GetTarget;
  end;
  PGCHandle = ^GCHandle;
{$ENDIF}

{ CLR compatibility routines }
{$IFDEF CLR}
  function CompareMem(P1, P2: IntPtr; Length: Integer): boolean;
{$ENDIF}
  function CompareGuid(const g1, g2: TGuid): boolean;
  function TimeStampToDateTime(const ATimeStamp: TTimeStamp): TDateTime;

  function VarEqual(const Value1, Value2: variant): boolean;
  procedure OleVarClear(pValue: POleVariant);
  function GetOleVariant(pValue: POleVariant): OleVariant;
  procedure SetOleVariant(pValue: POleVariant; const Value: OleVariant);

  procedure CopyBuffer(Source, Dest: IntPtr; Count: Integer);
  procedure CopyBufferAnsi(const Source: AnsiString; Dest: IntPtr; Count{Bytes (#0 included)}: Integer);
  procedure CopyBufferUni(const Source: WideString; Dest: IntPtr; Count{Bytes (#0 included)}: Integer);

{$IFNDEF VER17P}
  function BytesOf(const Val: IntPtr; const Len: integer): TBytes;
{$ENDIF}
  procedure FillChar(X: IntPtr; Count: Integer; Value: byte);
  function DynArrayCreate(SourceArray: array of Byte): TBytes; overload;
{$IFNDEF NEXTGEN}
  function DynArrayCreate(SourceArray: array of AnsiChar): TBytes; overload;
{$ENDIF}
  procedure ArrayCopy(SourceArray: TBytes; SourceIndex: Integer; DestinationArray: TBytes; DestinationIndex: Integer; Length: Integer);
{$IFDEF AUTOREFCOUNT}
  function AllocGCHandle(Obj: TObject; Pinned: boolean = False): IntPtr; overload;
{$ENDIF}
  function AllocGCHandle(Obj: {$IFDEF CLR}TObject{$ELSE}pointer{$ENDIF}; Pinned: boolean = False): IntPtr; overload;
  function GetGCHandleTarget(Handle: IntPtr): TObject;
  function GetAddrOfPinnedObject(Handle: IntPtr): IntPtr;
  procedure FreeGCHandle(Handle: IntPtr);
  function AllocValueBuffer(Size: Integer): TValueBuffer;
  procedure FreeValueBuffer(Buffer: TValueBuffer);

  procedure FreeString(P: IntPtr); {$IFDEF USE_INLINE}inline;{$ENDIF}
  function AllocOrdinal(out Obj: IntPtr): IntPtr; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  function AllocOrdinal(out Obj: ShortInt): IntPtr; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  function AllocOrdinal(out Obj: Byte): IntPtr; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  function AllocOrdinal(out Obj: Word): IntPtr; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  function AllocOrdinal(out Obj: Integer): IntPtr; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  function AllocOrdinal(out Obj: Cardinal): IntPtr; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  function OrdinalToPtr(out Obj: Double): IntPtr; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  function OrdinalToPtr(out Obj: Byte): IntPtr; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  function OrdinalToPtr(out Obj: SmallInt): IntPtr; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  function OrdinalToPtr(out Obj: Integer): IntPtr; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  function OrdinalToPtr(out Obj: Int64): IntPtr; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  function OrdinalToPtr(out Obj: Cardinal): IntPtr; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  function OrdinalToPtr(out Obj: Word): IntPtr; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  function OrdinalToPtr(out Obj: IntPtr): IntPtr; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  procedure PtrToOrdinal(P: IntPtr; out Obj: ShortInt); overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  procedure PtrToOrdinal(P: IntPtr; out Obj: Byte); overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  procedure PtrToOrdinal(P: IntPtr; out Obj: SmallInt); overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  procedure PtrToOrdinal(P: IntPtr; out Obj: Word); overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  procedure PtrToOrdinal(P: IntPtr; out Obj: Integer); overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  procedure PtrToOrdinal(P: IntPtr; out Obj: Int64); overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  procedure PtrToOrdinal(P: IntPtr; out Obj: Double); overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  procedure PtrToOrdinal(P: IntPtr; out Obj: Cardinal); overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  procedure PtrToOrdinal(P: IntPtr; out Obj: IntPtr); overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
  procedure FreeOrdinal(P: IntPtr); {$IFDEF USE_INLINE}inline;{$ENDIF}
{ PChar and PWideChar routines }
{$IFDEF CLR}
  procedure StrCopy(Dest: PAChar; const Source: PAChar);
  function StrComp(const Str1: PAChar; const Str2: PAChar): Integer;
  procedure StrLCopy(Dest: PAChar; const Source: PAChar; MaxLen{Chars}: Integer);
  function StrLen(const Str: PAChar): Integer;

  function AnsiUpperCase(const S: string): string;
  function AnsiCompareText(const S1, S2: string): Integer;
  function AnsiCompareStr(const S1, S2: string): Integer;
  function AnsiSameText(const S1, S2: string): Boolean;
{$ELSE}
{$IFDEF NEXTGEN}
  function StrCopy(Dest: PAnsiChar; const Source: PAnsiChar): PAnsiChar; inline;
  function StrLCopy(Dest: PAnsiChar; const Source: PAnsiChar; MaxLen: Cardinal): PAnsiChar;
  function StrComp(const Str1, Str2: PAnsiChar): Integer;
  function StrLen(const Str: PAnsiChar): Cardinal; inline;
  function CompareStr(const S1, S2: PAnsiChar): Integer; overload;
  function Copy(const S: TBytes; Index, Count: Integer): TBytes; inline; overload;
  function Copy(const S: string; Index, Count: Integer): string; inline; overload;
  function Copy(const S: PAnsiChar; Index, Count: Integer): string; inline; overload;
  function Copy(const S: AnsiString; Index, Count: Integer): AnsiString; overload;
  function TrimRight(const S: AnsiString): AnsiString; overload;
  procedure Delete(var s: string; Index, Count: Integer); inline; overload;
  procedure Delete(var s: AnsiString; Index, Count: Integer); overload;
  function AnsiUpperCase(const S: AnsiString): AnsiString; overload;

  procedure BinToHex(Buffer: PAnsiChar; Text: PWideChar; BufSize: Integer);
  function HexToBin(Text: PWideChar; Buffer: PAnsiChar; BufSize: Integer): Integer;
  function VarToWideStr(const Value: Variant): string; inline;
  function WideUpperCase(const S: string): string; inline;
{$ENDIF}
  function AnsiStrCompS(S1, S2: PAnsiChar): Integer; {$IFDEF USE_INLINE}inline;{$ENDIF} // SORT_STRINGSORT
  function AnsiStrICompS(S1, S2: PAnsiChar): Integer; {$IFDEF USE_INLINE}inline;{$ENDIF} // SORT_STRINGSORT
{$ENDIF}
  function AnsiCompareTextS(const S1, S2: AnsiString): Integer; {$IFDEF USE_INLINE}inline;{$ENDIF} // SORT_STRINGSORT
  function AnsiCompareStrS(const S1, S2: AnsiString): Integer; {$IFDEF USE_INLINE}inline;{$ENDIF} // SORT_STRINGSORT

  procedure BinToHexA(const Buffer: TBytes; {$IFDEF CLR}var{$ENDIF} Text: PAnsiChar; BufSize: Integer);
  procedure BinToHexW(const Buffer: TBytes; {$IFDEF CLR}var{$ENDIF} Text: PWideChar; BufSize: Integer);
{$IFNDEF CLR}
  function HexToBinA(Text: PAnsiChar; Buffer: IntPtr; BufSize: Integer): Integer; overload;
  function HexToBinW(Text: PWideChar; Buffer: IntPtr; BufSize: Integer): Integer; overload;
{$ELSE}
  function HexToBinA(Text: IntPtr; var Buffer: TBytes; BufSize: Integer): Integer; overload;
  function HexToBinW(Text: IntPtr; var Buffer: TBytes; BufSize: Integer): Integer; overload;
  function HexToBinA(Text: PAnsiChar; var Buffer: TBytes; BufSize: Integer): Integer; overload;
  function HexToBinW(Text: PWideChar; var Buffer: TBytes; BufSize: Integer): Integer; overload;
  function HexToBinA(Text: IntPtr; Buffer: IntPtr; BufSize: Integer): Integer; overload;
  function HexToBinW(Text: IntPtr; Buffer: IntPtr; BufSize: Integer): Integer; overload;
{$ENDIF}

  function StrCopyW(Dest: PWChar; const Source: PWChar): IntPtr;
  procedure StrLCopyW(Dest: PWChar; const Source: PWChar; MaxLen{WideChars}: Integer);
  function StrLenW(const Str: PWChar): Integer;
  procedure StrTrim(const Str: PAChar; Len: Integer = -1);
  procedure StrTrimW(const Str: PWChar; Len: Integer = -1);
  function AnsiStrLCompWS(const S1, S2: WideString; MaxLen: Integer): Integer; // SORT_STRINGSORT
  function AnsiStrLICompWS(const S1, S2: WideString; MaxLen: Integer): Integer; // SORT_STRINGSORT
  function AnsiStrCompWS(const S1, S2: WideString): Integer; // SORT_STRINGSORT
  function AnsiStrICompWS(const S1, S2: WideString): Integer; // SORT_STRINGSORT

{$IFDEF MSWINDOWS}
{$IFNDEF VER7P}
  function VarArrayAsPSafeArray(const A: Variant): PVarArray;
{$ENDIF}
{$IFDEF FPC}
const
  VAR_INVALIDARG    = HRESULT($80070057); // = Windows.E_INVALIDARG
{$ENDIF}
{$ENDIF}

type
  TDAList = TList;

{$IFDEF AUTOREFCOUNT}
  TDAObjectList = TList<TObject>;
{$ELSE}
  TDAObjectList = class(TList)
  protected
    procedure Notify(Instance: {$IFDEF CLR}TObject{$ELSE}Pointer{$ENDIF}; Action: TListNotification); override;
  end;
{$ENDIF}

{$IFNDEF CLR}
  function TryEncodeDate(Year, Month, Day: Word; out Date: TDateTime): Boolean;
  function TryEncodeTime(Hour, Min, Sec, MSec: Word; out Time: TDateTime): Boolean;
  function TryEncodeDateTime(const AYear, AMonth, ADay, AHour, AMinute, ASecond,
    AMilliSecond: Word; out AValue: TDateTime): Boolean;
  function EncodeDateTime(const AYear, AMonth, ADay, AHour, AMinute, ASecond,
    AMilliSecond: Word): TDateTime;
{$ENDIF}

  function Reverse4(Value: cardinal): cardinal;
{$IFNDEF CLR}
  procedure Reverse8(pValue: IntPtr);
{$ENDIF}

{$IFDEF WIN32_64}
{$IFNDEF VER14P}
  procedure NameThreadForDebugging(AThreadName: AnsiString; AThreadID: LongWord = $FFFFFFFF);
{$ENDIF}
{$ENDIF}

{$IFDEF HAVE_COMPRESS_INTERFACE}
const
  MIN_COMPRESS_LENGTH = 50; // Don't compress small bl.

  procedure CheckZLib;
  procedure DoCompress(dest: IntPtr; destLen: IntPtr; const source: IntPtr; sourceLen: longint);
  procedure DoUncompress(dest: IntPtr; destlen: IntPtr; source: IntPtr; sourceLne: longint);

type
  TCompressProc = function(dest: IntPtr; destLen: IntPtr; const source: IntPtr; sourceLen: longint): longint; {$IFNDEF MSWINDOWS}cdecl;{$ENDIF}
  TUncompressProc = function(dest: IntPtr; destlen: IntPtr; source: IntPtr; sourceLne: longint): longint; {$IFNDEF MSWINDOWS}cdecl;{$ENDIF}

{$IFDEF VER12P}
{$IFDEF HAVE_COMPRESS_INTERNAL}
  ECompressionError = EZCompressionError;
  EDecompressionError = EZDecompressionError;
{$ENDIF}
{$ENDIF}

var
  CompressProc: TCompressProc;
  UncompressProc: TUncompressProc;

{$ENDIF}

{$IFDEF MSWINDOWS}
var
  IsWin9x: boolean;
{$ENDIF}

{ Unicode build support for Delphi 10-11 }

implementation

uses
{$IFDEF VER5}
  ActiveX,
{$ENDIF}
{$IFDEF VER6}
   SysConst, {$IFNDEF CLR}VarUtils,{$ENDIF}
{$ENDIF}
{$IFDEF MSWINDOWS}
  Windows,
{$ENDIF}
{$IFDEF POSIX}
  Posix.String_, Posix.Wctype,
{$ENDIF}
{$IFDEF CLR}
  RTLConsts,
{$ENDIF}
{$IFNDEF EntityDAC}
  DAConsts, CRFunctions;
{$ELSE}
  EntityDAC.Common.Consts, EntityDAC.Common.Functions;
{$ENDIF}

{$IFDEF AUTOREFCOUNT}

function GCHandle.GetAddrOfPinnedObject: Pointer;
begin
  if FTarget <> nil then
    Result := Pointer(FTarget)
  else
    Result := FAddrOfPinnedObject;
end;

function GCHandle.GetTarget: TObject;
begin
  Result := FTarget;
end;

class function GCHandle.Alloc(Ptr: Pointer): Pointer;
var
  Handle: PGCHandle;
begin
  New(Handle);
  Handle.FAddrOfPinnedObject := Ptr;
  Handle.FTarget := nil;
  Result := Handle;
end;

class function GCHandle.Alloc(Obj: TObject): Pointer;
var
  Handle: PGCHandle;
begin
  New(Handle);
  Handle.FAddrOfPinnedObject := nil;
  Handle.FTarget := Obj;
  Result := Handle;
end;

class procedure GCHandle.Release(Ptr: pointer);
var
  Handle: PGCHandle;
begin
  if Ptr <> nil then begin
    Handle := Ptr;
    Handle.FAddrOfPinnedObject := nil;
    Handle.FTarget := nil;
    Dispose(Handle);
  end;
end;

{$ENDIF}

{$IFDEF CLR}
[DllImport('kernel32.dll')]
procedure CopyMemory(Dest, Source: IntPtr; Count: cardinal); external;

[DllImport('kernel32.dll')]
function lstrcpy(lpString1, lpString2: IntPtr): IntPtr; external;

[DllImport('kernel32.dll')]
function lstrcpyn(lpString1, lpString2: IntPtr; iMaxLength: Integer): IntPtr; external;

[DllImport('kernel32.dll')]
function lstrcmp(lpString1, lpString2: IntPtr): integer; external;

[DllImport('kernel32.dll')]
function lstrlen(lpString: IntPtr): Integer; external;

[DllImport('kernel32.dll')]
procedure FillMemory(Destination: IntPtr; Length: DWORD; Fill: Byte); external;

function CompareMem(P1, P2: IntPtr; Length: Integer): boolean;
var
  i: Integer;
begin
  Result := False;
  for i := 0 to Length - 1 do begin
    if Marshal.ReadByte(P1) <> Marshal.ReadByte(P2) then
      Exit;
    P1 := PtrOffset(P1, 1);
    P2 := PtrOffset(P2, 1);
  end;
  Result := True;
end;

function CompareGuid(const g1, g2: TGuid): boolean;
begin
  Result := g1 = g2;
end;
{$ELSE}
function CompareGuid(const g1, g2: TGuid): boolean;
begin
  Result := CompareMem(@g1, @g2, SizeOf(TGuid));
end;
{$ENDIF}

function TimeStampToDateTime(const ATimeStamp: TTimeStamp): TDateTime;
begin
  if (ATimeStamp.Time < 0) or (ATimeStamp.Date <= 0) then
    raise EConvertError.Create(Format('''%d.%d'' is not a valid timestamp', [ATimeStamp.Date, ATimeStamp.Time]));

  Result := ATimeStamp.Date - DateDelta;
{$IFNDEF CLR}
  if Result < 0 then
    Result := Result - (ATimeStamp.Time / MSecsPerDay)
  else
{$ENDIF}
    Result := Result + (ATimeStamp.Time / MSecsPerDay);
end;

// bug in D8 in compare strings as variant type
function VarEqual(const Value1, Value2: variant): boolean;
var
{$IFDEF CLR}
  va_old, va_new: TBytes;
  i: integer;
{$ELSE}
  va_old, va_new: PVarArray;
  va_data_old, va_data_new: IntPtr;
{$ENDIF}
begin
{$IFDEF CLR}
  if (Value1 <> nil) and (Value2 <> nil) and
    (Integer(Convert.GetTypeCode(Value1)) = 18) and (Integer(Convert.GetTypeCode(Value2)) = 18)
  then
    Result := System.String.CompareOrdinal(string(Value1), string(Value2)) = 0
  else
{$ELSE}
  // prevent comparing as AnsiString
  if (VarType(Value1) = varOleStr) and ((VarType(Value2) = varOleStr) or (VarType(Value2) = varString)) or
    (VarType(Value2) = varOleStr) and ((VarType(Value1) = varOleStr) or (VarType(Value1) = varString))
  then
    Result := WideString(Value1) = WideString(Value2)
  else
{$ENDIF}
  if (VarType(Value1) = varNull) and (VarType(Value2) = varNull) then
    Result := True
  else
  if (VarType(Value1) = varNull) or (VarType(Value2) = varNull) then
    Result := False
  else
  if VarIsStr(Value1) and (Value1 = '') then
    Result := VarIsStr(Value2) and (Value2 = '')
  else
  if VarIsStr(Value2) and (Value2 = '') then
    Result := False
  else
  if (VarType(Value1) = varArray + varByte) or
    (VarType(Value2) = varArray + varByte) then begin
    {$IFDEF CLR}
      va_old := Value1;
      va_new := Value2;
      if (va_old = nil) and (va_new = nil) then
        Result := True
      else
        if (va_old = nil) or (va_new = nil) or
          (Length(va_old) <> Length(va_new)) then
          Result := False
        else begin
          Result := True;
          for i := Low(va_old) to High(va_old) do
            if va_old[i] <> va_new[i] then begin
              Result := False;
              Break;
            end;
        end;
    {$ELSE}
      va_old := TVarData(Value1).VArray;
      va_new := TVarData(Value2).VArray;
      if (va_old = nil) and (va_new = nil) then
        Result := True
      else
        if (va_old = nil) or (va_new = nil) or
          (va_old.Bounds[0].ElementCount <> va_new.Bounds[0].ElementCount) then
          Result := False
        else begin
          va_data_old := va_old.Data;
          va_data_new := va_new.Data;
          if (va_data_old = nil) and (va_data_new = nil) then
            Result := True
          else
            if (va_data_old = nil) or (va_data_new = nil) then
              Result := False
            else
              Result := CompareMem(va_data_old, va_data_new, va_old.Bounds[0].ElementCount);
        end;
    {$ENDIF}
  end
{$IFDEF VER5}
  else
  if (VarType(Value1) = VT_DECIMAL) or (VarType(Value2) = VT_DECIMAL) then
    Result := string(Value1) = string(Value2)
  else
  if (VarType(Value1) = VT_CY) or (VarType(Value2) = VT_CY) then
    Result := string(Value1) = string(Value2)
{$ENDIF}
  else
    Result := Value1 = Value2;
end;

procedure CopyBuffer(Source, Dest: IntPtr; Count: Integer);
begin
{$IFDEF CLR}
  CopyMemory(Dest, Source, Count);
{$ELSE}
  Move(Source^, Dest^, Count);
{$ENDIF}
end;

procedure CopyBufferAnsi(const Source: AnsiString; Dest: IntPtr; Count{Bytes (#0 included)}: Integer);
{$IFDEF CLR}
var
  buf: TBytes;
begin
  SetLength(buf, Count);
  Encoding.Default.GetBytes(Source, 0, Count - 1{#0}, buf, 0);
  buf[Count - 1] := 0;
  Marshal.Copy(buf, 0, Dest, Count);
end;
{$ELSE}
begin
  CopyBuffer(PAnsiChar(Source), Dest, Count);
end;
{$ENDIF}

procedure CopyBufferUni(const Source: WideString; Dest: IntPtr; Count{Bytes (#0#0 included)}: Integer);
{$IFDEF CLR}
var
  buf: TBytes;
begin
  SetLength(buf, Count);
  Encoding.Unicode.GetBytes(Source, 0, (Count - 2{#0#0}) shr 1, buf, 0);
  buf[Count - 1] := 0;
  buf[Count - 2] := 0;
  Marshal.Copy(buf, 0, Dest, Count);
end;
{$ELSE}
begin
  CopyBuffer(PWideChar(Source), Dest, Count);
end;
{$ENDIF}

{$IFNDEF VER17P}
function BytesOf(const Val: IntPtr; const Len: integer): TBytes;
begin
  SetLength(Result, Len);
{$IFNDEF CLR}
  Move(PByte(Val)^, Result[0], Len);
{$ELSE}
  Marshal.Copy(Val, Result, 0, Len);
{$ENDIF}
end;
{$ENDIF}

procedure FillChar(X: IntPtr; Count: Integer; Value: byte);
begin
{$IFDEF CLR}
  FillMemory(X, Count, Value);
{$ELSE}
  System.FillChar(X^, Count, Value);
{$ENDIF}
end;

function DynArrayCreate(SourceArray: array of byte): TBytes; overload;
begin
{$IFDEF CLR}
  Result := SourceArray;
{$ELSE}
  SetLength(Result, High(SourceArray) + 1);
  Move(SourceArray, Pointer(Result)^, High(SourceArray) + 1);
{$ENDIF}
end;

{$IFNDEF NEXTGEN}
function DynArrayCreate(SourceArray: array of AnsiChar): TBytes; overload;
begin
{$IFDEF CLR}
  Result := Encoding.Default.GetBytes(SourceArray);
{$ELSE}
  SetLength(Result, High(SourceArray) + 1);
  Move(SourceArray, Pointer(Result)^, High(SourceArray) + 1);
{$ENDIF}
end;
{$ENDIF}

procedure ArrayCopy(SourceArray: TBytes; SourceIndex: Integer; DestinationArray: TBytes; DestinationIndex: Integer; Length: Integer);
begin
{$IFDEF CLR}
  System.Array.Copy(SourceArray, SourceIndex, DestinationArray, DestinationIndex, Length);
{$ELSE}
  System.Move(SourceArray[sourceIndex], DestinationArray[destinationIndex], Length);
{$ENDIF}
end;

{$IFDEF AUTOREFCOUNT}
function AllocGCHandle(Obj: TObject; Pinned: boolean = False): IntPtr;
begin
  Result := GCHandle.Alloc(Obj);
end;
{$ENDIF}

function AllocGCHandle(Obj: {$IFDEF CLR}TObject{$ELSE}pointer{$ENDIF};
  Pinned: boolean = False): IntPtr;
begin
{$IFDEF CLR}
  if Pinned then
    Result := IntPtr(GCHandle.Alloc(Obj, GCHandleType.Pinned))
  else
    Result := IntPtr(GCHandle.Alloc(Obj, GCHandleType.Normal));
{$ELSE}
  {$IFDEF AUTOREFCOUNT}
  Result := GCHandle.Alloc(Obj);
  {$ELSE}
  Result := Obj;
  {$ENDIF}
{$ENDIF}
end;

function GetGCHandleTarget(Handle: IntPtr): TObject;
begin
{$IFDEF CLR}
  if Handle = nil then
    Result := nil
  else
    Result := GCHandle(Handle).Target;
{$ELSE}
  {$IFDEF AUTOREFCOUNT}
  if Handle = nil then
    Result := nil
  else
    Result := PGCHandle(Handle).Target;
  {$ELSE}
  Result := Handle;
  {$ENDIF}
{$ENDIF}
end;

function GetAddrOfPinnedObject(Handle: IntPtr): IntPtr;
begin
{$IFDEF CLR}
  if Handle = nil then
    Result := nil
  else
    Result := GCHandle(Handle).AddrOfPinnedObject;
{$ELSE}
  {$IFDEF AUTOREFCOUNT}
  if Handle = nil then
    Result := nil
  else
    Result := PGCHandle(Handle).AddrOfPinnedObject;
  {$ELSE}
  Result := Handle;
  {$ENDIF}
{$ENDIF}
end;

procedure FreeGCHandle(Handle: IntPtr);
begin
{$IFDEF CLR}
  GCHandle(Handle).Free;
{$ELSE}
  {$IFDEF AUTOREFCOUNT}
  GCHandle.Release(Handle);
  {$ENDIF}
{$ENDIF}
end;

function AllocValueBuffer(Size: Integer): TValueBuffer;
begin
{$IFDEF CLR}
  Result := Marshal.AllocHGlobal(sizeof(IntPtr));
{$ELSE}
  {$IFNDEF VER17P}
  Result := Marshal.AllocHGlobal(sizeof(IntPtr));
  {$ELSE}
  SetLength(Result, Size);
  {$ENDIF}
{$ENDIF}
end;

procedure FreeValueBuffer(Buffer: TValueBuffer);
begin
{$IFDEF CLR}
  Marshal.FreeHGlobal(Buffer);
{$ELSE}
  {$IFNDEF VER17P}
  Marshal.FreeHGlobal(Buffer);
  {$ELSE}
  // do nothing
  {$ENDIF}
{$ENDIF}
end;

procedure FreeString(P: IntPtr);
begin
{$IFDEF CLR}
  Marshal.FreeHGlobal(P);
{$ENDIF}
end;

function AllocOrdinal(out Obj: ShortInt): IntPtr; overload;
begin
{$IFDEF CLR}
  Result := Marshal.AllocHGlobal(sizeof(ShortInt));
{$ELSE}
  Result := @Obj;
{$ENDIF}
end;

function AllocOrdinal(out Obj: Byte): IntPtr; overload;
begin
{$IFDEF CLR}
  Result := Marshal.AllocHGlobal(sizeof(Byte));
{$ELSE}
  Result := @Obj;
{$ENDIF}
end;

function AllocOrdinal(out Obj: Word): IntPtr; overload;
begin
{$IFDEF CLR}
  Result := Marshal.AllocHGlobal(sizeof(Word));
{$ELSE}
  Result := @Obj;
{$ENDIF}
end;

function AllocOrdinal(out Obj: Integer): IntPtr; overload;
begin
{$IFDEF CLR}
  Result := Marshal.AllocHGlobal(sizeof(Integer));
{$ELSE}
  Result := @Obj;
{$ENDIF}
end;

function AllocOrdinal(out Obj: Cardinal): IntPtr; overload;
begin
{$IFDEF CLR}
  Result := Marshal.AllocHGlobal(sizeof(Cardinal));
{$ELSE}
  Result := @Obj;
{$ENDIF}
end;

function AllocOrdinal(out Obj: IntPtr): IntPtr; overload;
begin
{$IFDEF CLR}
  Result := Marshal.AllocHGlobal(sizeof(IntPtr));
{$ELSE}
  Result := @Obj;
{$ENDIF}
end;

function OrdinalToPtr(out Obj: Double): IntPtr; overload;
begin
{$IFDEF CLR}
  Result := Marshal.AllocHGlobal(sizeof(Int64));
  Marshal.WriteInt64(Result, BitConverter.DoubleToInt64Bits(Obj));
{$ELSE}
  Result := @Obj;
{$ENDIF}
end;

function OrdinalToPtr(out Obj: Byte): IntPtr; overload;
begin
{$IFDEF CLR}
  Result := Marshal.AllocHGlobal(sizeof(Byte));
  Marshal.WriteByte(Result, Obj);
{$ELSE}
  Result := @Obj;
{$ENDIF}
end;

function OrdinalToPtr(out Obj: SmallInt): IntPtr; overload;
begin
{$IFDEF CLR}
  Result := Marshal.AllocHGlobal(sizeof(SmallInt));
  Marshal.WriteInt16(Result, Obj);
{$ELSE}
  Result := @Obj;
{$ENDIF}
end;

function OrdinalToPtr(out Obj: Integer): IntPtr; overload;
begin
{$IFDEF CLR}
  Result := Marshal.AllocHGlobal(sizeof(Integer));
  Marshal.WriteInt32(Result, Obj);
{$ELSE}
  Result := @Obj;
{$ENDIF}
end;

function OrdinalToPtr(out Obj: Int64): IntPtr; overload;
begin
{$IFDEF CLR}
  Result := Marshal.AllocHGlobal(sizeof(Int64));
  Marshal.WriteInt64(Result, Obj);
{$ELSE}
  Result := @Obj;
{$ENDIF}
end;

function OrdinalToPtr(out Obj: Cardinal): IntPtr; overload;
begin
{$IFDEF CLR}
  Result := Marshal.AllocHGlobal(sizeof(Cardinal));
  Marshal.WriteInt32(Result, Obj);
{$ELSE}
  Result := @Obj;
{$ENDIF}
end;

function OrdinalToPtr(out Obj: Word): IntPtr; overload;
begin
{$IFDEF CLR}
  Result := Marshal.AllocHGlobal(sizeof(Word));
  Marshal.WriteInt16(Result, Obj);
{$ELSE}
  Result := @Obj;
{$ENDIF}
end;

function OrdinalToPtr(out Obj: IntPtr): IntPtr; overload;
begin
{$IFDEF CLR}
  Result := Marshal.AllocHGlobal(sizeof(Integer));
  Marshal.WriteIntPtr(Result, Obj);
{$ELSE}
  Result := @Obj;
{$ENDIF}
end;

procedure PtrToOrdinal(P: IntPtr; out Obj: ShortInt); overload;
begin
{$IFDEF CLR}
  Obj := Marshal.ReadByte(P);
  Marshal.FreeHGlobal(P);
{$ELSE}
{$ENDIF}
end;

procedure PtrToOrdinal(P: IntPtr; out Obj: Byte); overload;
begin
{$IFDEF CLR}
  Obj := Marshal.ReadByte(P);
  Marshal.FreeHGlobal(P);
{$ELSE}
{$ENDIF}
end;

procedure PtrToOrdinal(P: IntPtr; out Obj: SmallInt); overload;
begin
{$IFDEF CLR}
  Obj := Marshal.ReadInt16(P);
  Marshal.FreeHGlobal(P);
{$ELSE}
{$ENDIF}
end;

procedure PtrToOrdinal(P: IntPtr; out Obj: Word); overload;
begin
{$IFDEF CLR}
  Obj := Word(Marshal.ReadInt32(P));
  Marshal.FreeHGlobal(P);
{$ELSE}
{$ENDIF}
end;

procedure PtrToOrdinal(P: IntPtr; out Obj: Integer); overload;
begin
{$IFDEF CLR}
  Obj := Marshal.ReadInt32(P);
  Marshal.FreeHGlobal(P);
{$ELSE}
{$ENDIF}
end;

procedure PtrToOrdinal(P: IntPtr; out Obj: Int64); overload;
begin
{$IFDEF CLR}
  Obj := Marshal.ReadInt64(P);
  Marshal.FreeHGlobal(P);
{$ELSE}
{$ENDIF}
end;

procedure PtrToOrdinal(P: IntPtr; out Obj: Double); overload;
begin
{$IFDEF CLR}
  Obj := BitConverter.Int64BitsToDouble(Marshal.ReadInt64(P));
  Marshal.FreeHGlobal(P);
{$ELSE}
{$ENDIF}
end;

procedure PtrToOrdinal(P: IntPtr; out Obj: Cardinal); overload;
begin
{$IFDEF CLR}
  Obj := Marshal.ReadInt32(P);
  Marshal.FreeHGlobal(P);
{$ELSE}
{$ENDIF}
end;

procedure PtrToOrdinal(P: IntPtr; out Obj: IntPtr); overload;
begin
{$IFDEF CLR}
  Obj := Marshal.ReadIntPtr(P);
  Marshal.FreeHGlobal(P);
{$ELSE}
{$ENDIF}
end;

procedure FreeOrdinal(P: IntPtr);
begin
{$IFDEF CLR}
  Marshal.FreeHGlobal(P);
{$ELSE}
{$ENDIF}
end;

{$IFDEF CLR}
procedure StrCopy(Dest: PAChar; const Source: PAChar);
begin
  Win32Check(lstrcpy(Dest, Source) <> nil);
end;

procedure StrLCopy(Dest: PAChar; const Source: PAChar; MaxLen{Chars}: Integer);
begin
  Win32Check(lstrcpyn(Dest, Source, MaxLen + 1) <> nil);
end;

function StrComp(const Str1: PAChar; const Str2: PAChar): Integer;
begin
  Result := lstrcmp(Str1, Str2);
end;

function StrLen(const Str: PAChar): Integer;
begin
  Result := lstrlen(Str);
end;

function StrLenW(const Str: PWChar): Integer;
var
  s: WideString;
begin
  s := Marshal.PtrToStringUni(Str);
  Result := s.Length;
end;

procedure StrTrim(const Str: PAChar; Len: Integer = -1);
var
  i: Integer;
  v: byte;
  pStr: IntPtr;
begin
  if Len = - 1 then // Detect length
    Len := StrLen(Str);

  i := Len - 1;

  while i >= 0 do begin
    pStr := PtrOffset(Str, i);
    v := Marshal.ReadByte(pStr);
    if (v <> 32 {Byte(' ')}) and (v <> 0{Byte(#0)}) then
      Exit;
    Marshal.WriteByte(pStr, Byte(#0));
    Dec(i);
  end;
end;

procedure StrTrimW(const Str: PWChar; Len: Integer = -1);
var
  i: Integer;
  v: smallint;
  pWStr: IntPtr;
begin
  if Len = - 1 then // Detect length
    Len := StrLenW(Str);

  i := (Len - 1) shl 1;

  while i >= 0 do begin
    pWStr := PtrOffset(Str, i);
    v := Marshal.ReadInt16(pWStr);
    if (v <> 32 {SmallInt(' ')}) and (v <> 0{SmallInt(#0)})  then
      Exit;
    Marshal.WriteInt16(pWStr, Word(#0));
    Dec(i);
    Dec(i);
  end;
end;

{$ENDIF}

function StrCopyW(Dest: PWChar; const Source: PWChar): IntPtr;
{$IFDEF CLR}
var
  Buf: SmallInt;
  i: Integer;
begin
  i := 0;
  repeat
    Buf := Marshal.ReadInt16(Source, i);
    Marshal.WriteInt16(Dest, i, Buf);
    Inc(i, 2);
  until Buf = 0;
{$ELSE}
{$IFDEF PUREPASCAL}
var
  Src: PWChar;
begin
  Result := Dest;
  Src := Source;
  repeat
    Dest^ := Src^;
    Inc(Dest);
    Inc(Src);
  until Src^ = #0;
{$ELSE}
asm
{$IFDEF CPUX64}
        PUSH    RDI
        PUSH    RSI
        MOV     RSI,Dest
        MOV     RDI,Source
        MOV     RCX,0FFFFFFFFFFFFFFFFH
        XOR     AX,AX
        REPNE   SCASW
        NOT     RCX
        SHL     RCX, 1  // Size := Len * sizeof(WideChar)
        MOV     RDI,RSI
        MOV     RSI,Source
        MOV     RDX,RCX
        MOV     RAX,RDI
        SHR     RCX,2
        REP     MOVSD
        MOV     RCX,RDX
        AND     RCX,3
        REP     MOVSB
        POP     RSI
        POP     RDI
{$ELSE}
        PUSH    EDI
        PUSH    ESI
        MOV     ESI,Dest
        MOV     EDI,Source
        MOV     ECX,0FFFFFFFFH
        XOR     AX,AX
        REPNE   SCASW
        NOT     ECX
        SHL     ECX, 1  // Size := Len * sizeof(WideChar)
        MOV     EDI,ESI
        MOV     ESI,Source
        MOV     EDX,ECX
        MOV     EAX,EDI
        SHR     ECX,2
        REP     MOVSD
        MOV     ECX,EDX
        AND     ECX,3
        REP     MOVSB
        POP     ESI
        POP     EDI
{$ENDIF CPUX64}
{$ENDIF PUREPASCAL}
{$ENDIF CLR}
end;

procedure StrLCopyW(Dest: PWChar; const Source: PWChar; MaxLen{WideChars}: Integer);
{$IFDEF CLR}
var
  Buf: SmallInt;
  i: Integer;
begin
  i := 0;
  Buf := 0;
  while i < MaxLen * 2 do begin
    Buf := Marshal.ReadInt16(Source, i);
    Marshal.WriteInt16(Dest, i, Buf);
    if Buf = 0 then
      Break;
    Inc(i, 2);
  end;
  if Buf <> 0 then
    Marshal.WriteInt16(Dest, i, 0);
{$ELSE}
var
  pwc: PWideChar;
begin
  pwc := Source;
  while (pwc^ <> #0) and (pwc < PWideChar(Source) + MaxLen) do begin
    PWideChar(Dest)^ := pwc^;
    Inc(PWideChar(Dest));
    Inc(pwc);
  end;
  PWideChar(Dest)^ := #0;
{$ENDIF}
end;

{$IFNDEF CLR}
function StrLenW(const Str: PWChar): Integer; {$IFNDEF PUREPASCAL}assembler;{$ENDIF}
{$IFDEF PUREPASCAL}
begin
  if Str = nil then
    Result := 0
  else
    Result := Length(WideString(Str));
{$ELSE}
asm
{$IFDEF CPUX64}
        MOV     RDX,RDI
        MOV     RDI,Str
        MOV     RCX,0FFFFFFFFFFFFFFFFH
        XOR     AX,AX
        REPNE   SCASW
        MOV     RAX,0FFFFFFFFFFFFFFFEH
        SUB     RAX,RCX
        MOV     RDI,RDX
{$ELSE}
        MOV     EDX,EDI
        MOV     EDI,Str
        MOV     ECX,0FFFFFFFFH
        XOR     AX,AX
        REPNE   SCASW
        MOV     EAX,0FFFFFFFEH
        SUB     EAX,ECX
        MOV     EDI,EDX
{$ENDIF}
{$ENDIF}
end;

procedure StrTrim(const Str: PAChar; Len: Integer = -1);
var
  pc: PAnsiChar;
begin
  if Len = - 1 then // Detect length
    Len := StrLen(Str);

  pc := PAnsiChar(Str) + Len - 1;

  while ((pc^ = ' ') or (pc^ = #0)) and (pc >= Str) do begin
    pc^ := #0;
    Dec(pc);
  end;
end;

procedure StrTrimW(const Str: PWChar; Len: Integer = -1);
var
  pwc: PWideChar;
begin
  if Len = - 1 then // Detect length
    Len := StrLenW(Str);

  pwc := PWideChar(Str) + Len - 1;

  while ((pwc^ = ' ') or (pwc^ = #0)) and (pwc >= Str) do begin
    PWideChar(pwc)^ := #0;
    Dec(pwc);
  end;
end;
{$ENDIF}

function AnsiStrLCompWS(const S1, S2: WideString; MaxLen: Integer): Integer;
begin
{$IFDEF MSWINDOWS}
  Assert(not IsWin9x, 'Unicode support on Win9x');
{$IFDEF CLR}
  Result := CompareStringW(LOCALE_USER_DEFAULT, SORT_STRINGSORT, S1, MaxLen, S2, MaxLen) - 2;
{$ELSE}
  Result := CompareStringW(LOCALE_USER_DEFAULT, SORT_STRINGSORT, PWideChar(S1), MaxLen,
    PWideChar(S2), MaxLen) - 2;
{$ENDIF}
{$ELSE}
{$IFDEF POSIX}
{$IFDEF NEXTGEN}
  Result := AnsiCompareStr(S1, S2);
{$ELSE}
  Result := WideCompareStr(S1, S2);
{$ENDIF}
{$ELSE}
  Result := 0;
  Assert(False);
{$ENDIF}
{$ENDIF}
end;

function AnsiStrLICompWS(const S1, S2: WideString; MaxLen: Integer): Integer;
begin
{$IFDEF MSWINDOWS}
  Assert(not IsWin9x, 'Unicode support on Win9x');
{$IFDEF CLR}
  Result := CompareStringW(LOCALE_USER_DEFAULT, NORM_IGNORECASE + SORT_STRINGSORT,
    S1, MaxLen, S2, MaxLen) - 2;
{$ELSE}
  Result := CompareStringW(LOCALE_USER_DEFAULT, NORM_IGNORECASE + SORT_STRINGSORT,
    PWideChar(S1), MaxLen, PWideChar(S2), MaxLen) - 2;
{$ENDIF}
{$ELSE}
{$IFDEF POSIX}
{$IFDEF NEXTGEN}
  Result := AnsiCompareText(S1, S2);
{$ELSE}
  Result := WideCompareText(S1, S2);
{$ENDIF}
{$ELSE}
  Result := 0;
  Assert(False);
{$ENDIF}
{$ENDIF}
end;

function AnsiStrCompWS(const S1, S2: WideString): Integer;
begin
{$IFDEF MSWINDOWS}
  Assert(not IsWin9x, 'Unicode support on Win9x');
{$IFDEF CLR}
  Result := CompareStringW(LOCALE_USER_DEFAULT, SORT_STRINGSORT, S1, -1, S2, -1) - 2;
{$ELSE}
  Result := CompareStringW(LOCALE_USER_DEFAULT, SORT_STRINGSORT, PWideChar(S1), -1,
    PWideChar(S2), -1) - 2;
{$ENDIF}
{$ELSE}
{$IFDEF POSIX}
{$IFDEF NEXTGEN}
  Result := AnsiCompareStr(S1, S2);
{$ELSE}
  Result := WideCompareStr(S1, S2);
{$ENDIF}
{$ELSE}
  Result := 0;
  Assert(False);
{$ENDIF}
{$ENDIF}
end;

function AnsiStrICompWS(const S1, S2: WideString): Integer;
begin
{$IFDEF MSWINDOWS}
  Assert(not IsWin9x, 'Unicode support on Win9x');
{$IFDEF CLR}
  Result := CompareStringW(LOCALE_USER_DEFAULT, NORM_IGNORECASE + SORT_STRINGSORT, S1, -1,
    S2, -1) - 2;
{$ELSE}
  Result := CompareStringW(LOCALE_USER_DEFAULT, NORM_IGNORECASE + SORT_STRINGSORT, PWideChar(S1),
    -1, PWideChar(S2), -1) - 2;
{$ENDIF}
{$ELSE}
{$IFDEF POSIX}
{$IFDEF NEXTGEN}
  Result := AnsiCompareText(S1, S2);
{$ELSE}
  Result := WideCompareText(S1, S2);
{$ENDIF}
{$ELSE}
  Result := 0;
  Assert(False);
{$ENDIF}
{$ENDIF}
end;

{$IFDEF CLR}
function AnsiUpperCase(const S: string): string;
begin
  if S <> nil then
    Result := System.String(S).ToUpper
  else
    Result := '';
end;

function AnsiCompareText(const S1, S2: string): Integer;
begin
  Result := System.String.Compare(S1, S2, True);
end;

function AnsiCompareStr(const S1, S2: string): Integer;
begin
  Result := System.String.Compare(S1, S2, False);
end;

function AnsiSameText(const S1, S2: string): Boolean;
begin
  Result := System.String.Compare(S1, S2, True) = 0;
end;

{$ELSE}

{$IFDEF NEXTGEN}

function StrCopy(Dest: PAnsiChar; const Source: PAnsiChar): PAnsiChar;
begin
  Move(Source^, Dest^, StrLen(Source) + 1);
  Result := Dest;
end;

function StrLCopy(Dest: PAnsiChar; const Source: PAnsiChar; MaxLen: Cardinal): PAnsiChar;
var
  Len: Cardinal;
begin
  Result := Dest;
  Len := StrLen(Source);
  if Len > MaxLen then
    Len := MaxLen;
  Move(Source^, Dest^, Len);
  Dest[Len] := #0;
end;

function StrComp(const Str1, Str2: PAnsiChar): Integer;
var
  P1, P2: PAnsiChar;
begin
  P1 := Str1;
  P2 := Str2;
  while True do
  begin
    if (P1^ <> P2^) or (P1^ = #0) then
      Exit(Ord(P1^) - Ord(P2^));
    Inc(P1);
    Inc(P2);
  end;
end;

function StrLen(const Str: PAnsiChar): Cardinal;
begin
  Result := Length(Str);
end;

function CompareStr(const S1, S2: PAnsiChar): Integer;
var
  P1, P2: PAnsiChar;
  I: Integer;
  L1, L2: Integer;
begin
  { Length and PChar of S1 }
  L1 := Length(S1);
  P1 := PAnsiChar(S1);

  { Length and PChar of S2 }
  L2 := Length(S2);
  P2 := PAnsiChar(S2);

  { Continue the loop until the end of one string is reached. }
  I := 0;
  while (I < L1) and (I < L2) do
  begin
    if (P1^ <> P2^) then
      Exit(Ord(P1^) - Ord(P2^));

    Inc(P1);
    Inc(P2);
    Inc(I);
  end;

  { If chars were not different return the difference in length }
  Result := L1 - L2;
end;

function Copy(const S: TBytes; Index, Count: Integer): TBytes;
begin
  Result := System.Copy(S, Index, Count);
end;

function Copy(const S: string; Index, Count: Integer): string;
begin
  Result := System.Copy(S, Index, Count);
end;

function Copy(const S: PAnsiChar; Index, Count: Integer): string;
begin
  Result := string(System.Copy(S, Index, Count));
end;

function Copy(const S: AnsiString; Index, Count: Integer): AnsiString;
begin
  if (LengthA(S) = 0) or (Count <= 0) or (Index <= 0) then begin
    SetLengthA(Result, 0);
    Exit;
  end;

  SetLengthA(Result, Count);
  if Count > 0 then
    Move(S[Index]^, Result[1]^, Count);
end;

function TrimRight(const S: AnsiString): AnsiString;
var
  I: Integer;
begin
  if LengthA(S) = 0 then begin
    SetLengthA(Result, 0);
    Exit;
  end;

  I := LengthA(S);
  while (I >= 1) and (S[I]^ <= ' ') do Dec(I);
  Result := Copy(S, 1, I);
end;

procedure Delete(var s: string; Index, Count: Integer);
begin
  System.Delete(s, Index, Count);
end;

procedure Delete(var s: AnsiString; Index, Count: Integer);
var
  Len, TailLen: Integer;
begin
  Len := LengthA(s);
  if (Count > 0) and (Index >= 1) and (Index <= Len) then
  begin
    TailLen := Len - Index + 1;
    if Count > TailLen then Count := TailLen;
    Move(S[Index + Count]^, S[Index]^, TailLen - Count);
    S[Len - Count + 1]^ := #0;
  end;
end;

procedure AnsiStrUpper(Str: PAnsiChar);
{$IFDEF MSWINDOWS}
begin
  CharUpperA(Str);
end;
{$ENDIF}
{$IFDEF POSIX}
var
  Temp: string;
  Squish: AnsiString;
  I: Integer;
begin
  Temp := string(Str);    // expand and copy multibyte to widechar
  for I := Low(string) to High(Temp) do
    Temp[I] := WideChar(towupper(UCS4Char(Temp[I])));
  Squish := AnsiString(Temp);  // reduce and copy widechar to multibyte
  if Cardinal(LengthA(Squish)) > StrLen(Str) then
    raise ERangeError.CreateRes(@SRangeError);

  Move(Squish[1]^, Str^, LengthA(Squish));
end;
{$ENDIF}

function AnsiUpperCase(const S: AnsiString): AnsiString;
var
  Len: Integer;
begin
  Len := LengthA(S);
  Result := Copy(S, 1, Len);
  if Len > 0 then
    AnsiStrUpper(Result.Ptr);
end;

{$IFDEF POSIX}
function AnsiStrComp(S1, S2: PAnsiChar): Integer; inline;
begin
{$IFDEF LINUX}
  Result := strcoll_l(PAnsiChar(UTF8String(S1)), PAnsiChar(UTF8String(S2)), UTF8CompareLocale);
{$ELSE}
  Result := AnsiCompareStr(string(S1), string(S2));
{$ENDIF}
end;

function AnsiStrIComp(S1, S2: PAnsiChar): Integer; inline;
begin
  Result := AnsiCompareText(string(S1), string(S2));
end;
{$ENDIF POSIX}

procedure BinToHex(Buffer: PAnsiChar; Text: PWideChar; BufSize: Integer);
const
  Convert: array[0..15] of WideChar = '0123456789ABCDEF';
var
  I: Integer;
begin
  for I := 0 to BufSize - 1 do
  begin
    Text[0] := Convert[Byte(Buffer[I]) shr 4];
    Text[1] := Convert[Byte(Buffer[I]) and $F];
    Inc(Text, 2);
  end;
end;

function HexToBin(Text: PWideChar; Buffer: PAnsiChar; BufSize: Integer): Integer;
const
  Convert: array['0'..'f'] of SmallInt =
    ( 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,-1,-1,-1,-1,-1,-1,
     -1,10,11,12,13,14,15,-1,-1,-1,-1,-1,-1,-1,-1,-1,
     -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,
     -1,10,11,12,13,14,15);
var
  I: Integer;
begin
  I := BufSize;
  while I > 0 do
  begin
    if CharInSet(Text[0], [':'..'@']) or CharInSet(Text[0], ['G'..#96]) or
       CharInSet(Text[1], [':'..'@']) or CharInSet(Text[1], ['G'..#96]) then
       Break;
    if not CharInSet(Text[0], ['0'..'f']) or not CharInSet(Text[1], ['0'..'f']) then Break;
    PByte(Buffer)[0] := AnsiChar((Convert[Text[0]] shl 4) + Convert[Text[1]]);
    Inc(Buffer);
    Inc(Text, 2);
    Dec(I);
  end;
  Result := BufSize - I;
end;

function VarToWideStr(const Value: Variant): string;
begin
  Result := VarToStr(Value);
end;

function WideUpperCase(const S: string): string;
begin
  Result := UpperCase(S);
end;

{$ENDIF NEXTGEN}

function AnsiStrCompS(S1, S2: PAnsiChar): Integer; // SORT_STRINGSORT
begin
{$IFDEF WIN32_64}
  Result := CompareStringA(LOCALE_USER_DEFAULT, SORT_STRINGSORT, S1, -1, S2, -1) - 2;
{$ELSE}
  Result := AnsiStrComp(S1, S2);
{$ENDIF}
end;

function AnsiStrICompS(S1, S2: PAnsiChar): Integer; // SORT_STRINGSORT
begin
{$IFDEF WIN32_64}
  Result := CompareStringA(LOCALE_USER_DEFAULT, NORM_IGNORECASE + SORT_STRINGSORT, S1, -1,
    S2, -1) - 2;
{$ELSE}
  Result := AnsiStrIComp(S1, S2);
{$ENDIF}
end;

{$ENDIF !CLR}

function AnsiCompareTextS(const S1, S2: AnsiString): Integer; // SORT_STRINGSORT
begin
{$IFDEF WIN32_64}
  Result := CompareStringA(LOCALE_USER_DEFAULT, NORM_IGNORECASE + SORT_STRINGSORT, PAnsiChar(S1),
    Length(S1), PAnsiChar(S2), Length(S2)) - 2;
{$ELSE}
  Result := AnsiCompareText(string(S1), string(S2));
{$ENDIF}
end;

function AnsiCompareStrS(const S1, S2: AnsiString): Integer; // SORT_STRINGSORT
begin
{$IFDEF WIN32_64}
  Result := CompareStringA(LOCALE_USER_DEFAULT, SORT_STRINGSORT, PAnsiChar(S1), Length(S1),
    PAnsiChar(S2), Length(S2)) - 2;
{$ELSE}
  Result := AnsiCompareStr(string(S1), string(S2));
{$ENDIF}
end;

procedure BinToHexA(const Buffer: TBytes; {$IFDEF CLR}var{$ENDIF} Text: PAnsiChar; BufSize: Integer);
const
{$IFNDEF NEXTGEN}
  Convert: array[0..15] of AnsiChar = AnsiString('0123456789ABCDEF');
{$ELSE}
  Convert: array[0..15] of Byte = ($30, $31, $32, $33, $34, $35, $36, $37, $38, $39, $41, $42, $43, $44, $45, $46);
{$ENDIF}
var
  I, J: Integer;
begin
  I := 0;
{$IFDEF CLR}
  J := 1;
{$ELSE}
  J := 0;
{$ENDIF}
  while i < BufSize do begin
  {$IFDEF NEXTGEN}
    PByte(Text)[J] := Convert[Byte(Buffer[I]) shr 4];
    Inc(J);
    PByte(Text)[J] := Convert[Byte(Buffer[I]) and $F];
    Inc(J);
  {$ELSE}
    Text[J] := Convert[Byte(Buffer[I]) shr 4];
    Inc(J);
    Text[J] := Convert[Byte(Buffer[I]) and $F];
    Inc(J);
  {$ENDIF}
    Inc(I);
  end;
end;

procedure BinToHexW(const Buffer: TBytes; {$IFDEF CLR}var{$ENDIF} Text: PWideChar; BufSize: Integer);
const
  Convert: array[0..15] of WideChar = WideString('0123456789ABCDEF');
var
  I, J: Integer;
begin
  I := 0;
{$IFDEF CLR}
  J := 1;
{$ELSE}
  J := 0;
{$ENDIF}
  while i < BufSize do begin
    Text[J] := WideChar(Convert[Byte(Buffer[I]) shr 4]);
    Inc(J);
    Text[J] := WideChar(Convert[Byte(Buffer[I]) and $F]);
    Inc(J);
    Inc(I);
  end;
end;

{$IFNDEF CLR}
function HexToBinA(Text: PAnsiChar; Buffer: IntPtr; BufSize: Integer): Integer;
const
  Convert: array['0'..'f'] of Byte =
    ( 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 0, 0, 0, 0, 0, 0,
      0,10,11,12,13,14,15, 0, 0, 0, 0, 0, 0, 0, 0, 0,
      0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
      0,10,11,12,13,14,15);
var
  I, J: Integer;
  C1, C2: Char;
begin
  I := 0;
  J := 0;
  while I < BufSize do
  begin
    C1 := Char(Text[J]);
    Inc(J);
    C2 := Char(Text[J]);
    Inc(J);
    
    if not CharInSet(C1, ['0'..'f']) or
       not CharInSet(C2, ['0'..'f'])
    then
      Break;
      
    Marshal.WriteByte(Buffer, I, (Convert[C1] shl 4) + Convert[C2]);
    Inc(I);
  end;
  Result := I;
end;

function HexToBinW(Text: PWideChar; Buffer: IntPtr; BufSize: Integer): Integer;
const
  Convert: array['0'..'f'] of Byte =
    ( 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 0, 0, 0, 0, 0, 0,
      0,10,11,12,13,14,15, 0, 0, 0, 0, 0, 0, 0, 0, 0,
      0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
      0,10,11,12,13,14,15);
var
  I, J: Integer;
  C1, C2: Char;
begin
  I := 0;
  J := 0;
  while I < BufSize do
  begin
    C1 := Char(Text[J]);
    Inc(J);
    C2 := Char(Text[J]);
    Inc(J);

    if not CharInSet(C1, ['0'..'f']) or
       not CharInSet(C2, ['0'..'f'])
    then
      Break;

    Marshal.WriteByte(Buffer, I, (Convert[C1] shl 4) + Convert[C2]);
    Inc(I);
  end;
  Result := I;
end;
{$ELSE}
function HexToBinA(Text: IntPtr; var Buffer: TBytes; BufSize: Integer): Integer;
var
  TextBuf: TBytes;
begin
  TextBuf := Encoding.Default.GetBytes(Marshal.PtrToStringAnsi(Text, BufSize * 2));
  SetLength(Buffer, BufSize);
  Result := HexToBin(TextBuf, 0, Buffer, 0, BufSize);
  if Length(Buffer) <> Result then
    SetLength(Buffer, Result);
end;

function HexToBinW(Text: IntPtr; var Buffer: TBytes; BufSize: Integer): Integer;
var
  TextBuf: TBytes;
begin
  TextBuf := Encoding.Default.GetBytes(Marshal.PtrToStringUni(Text, BufSize * 2));
  SetLength(Buffer, BufSize);
  Result := HexToBin(TextBuf, 0, Buffer, 0, BufSize);
  if Length(Buffer) <> Result then
    SetLength(Buffer, Result);
end;

function HexToBinA(Text: PAnsiChar; var Buffer: TBytes; BufSize: Integer): Integer;
var
  p: IntPtr;
begin
  p := Marshal.StringToHGlobalAnsi(Text);
  try
    Result := HexToBinA(p, Buffer, BufSize);
  finally
    Marshal.FreeCoTaskMem(p);
  end;
end;

function HexToBinW(Text: PWideChar; var Buffer: TBytes; BufSize: Integer): Integer;
var
  p: IntPtr;
begin
  p := Marshal.StringToHGlobalUni(Text);
  try
    Result := HexToBinW(p, Buffer, BufSize);
  finally
    Marshal.FreeCoTaskMem(p);
  end;
end;

function HexToBinA(Text: IntPtr; Buffer: IntPtr; BufSize: Integer): Integer;
var
  ResBuf: TBytes;
begin
  Result := HexToBinA(Text, ResBuf, BufSize);
  Marshal.Copy(ResBuf, 0, Buffer, Length(ResBuf));
end;

function HexToBinW(Text: IntPtr; Buffer: IntPtr; BufSize: Integer): Integer;
var
  ResBuf: TBytes;
begin
  Result := HexToBinW(Text, ResBuf, BufSize);
  Marshal.Copy(ResBuf, 0, Buffer, Length(ResBuf));
end;
{$ENDIF}

{$IFNDEF AUTOREFCOUNT}
{ TDAObjectList }

procedure TDAObjectList.Notify(Instance: {$IFDEF CLR}TObject{$ELSE}Pointer{$ENDIF}; Action: TListNotification);
begin
  if Action = lnDeleted then
    TObject(Instance).Free;
  inherited Notify(Instance, Action);
end;
{$ENDIF}

{$IFDEF CLR}
const
  ole32    = 'ole32.dll';
  oleaut32 = 'oleaut32.dll';

[DllImport(oleaut32, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'VariantClear')]
function VariantClear(Value: POleVariant): HResult; external;

procedure OleVarClear(pValue: POleVariant);
begin
  SetOleVariant(pValue, Unassigned);
end;

function GetOleVariant(pValue: POleVariant): OleVariant;
begin
  Result := OleVariant(Marshal.GetObjectForNativeVariant(pValue));
//  Result := OleVariant(Marshal.PtrToStructure(pValue, TypeOf(OleVariant)));
end;

procedure SetOleVariant(pValue: POleVariant; const Value: OleVariant);
begin
  Marshal.GetNativeVariantForObject(TObject(Value), pValue);
end;

{$ELSE}
procedure OleVarClear(pValue: POleVariant);
begin
  pValue^ := Unassigned;
end;

function GetOleVariant(pValue: POleVariant): OleVariant;
begin
  Result := pValue^;
end;

procedure SetOleVariant(pValue: POleVariant; const Value: OleVariant);
begin
  pValue^ := Value;
end;
{$ENDIF}

{$IFNDEF CLR}
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 < 24) and (Min < 60) and (Sec < 60) and (MSec < 1000) then
  begin
    Time := (Integer(Hour * 3600000) + Integer(Min * 60000) + Sec * 1000 + 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
      if AValue >= 0 then
        AValue := AValue + LTime
      else
        AValue := AValue - LTime;
  end;
end;

function EncodeDateTime(const AYear, AMonth, ADay, AHour, AMinute, ASecond,
  AMilliSecond: Word): TDateTime;
begin
  if not TryEncodeDateTime(AYear, AMonth, ADay,
                           AHour, AMinute, ASecond, AMilliSecond, Result) then
    raise EConvertError.Create(SDateEncodeError);
end;
{$ENDIF}

function Reverse4(Value: cardinal): cardinal;
begin
   Result := Cardinal((byte(Value) shl 24) or (byte(Value shr 8) shl 16)
           or (byte(Value shr 16) shl 8) or byte(Value shr 24));
end;

{$IFNDEF CLR}
procedure Reverse8(pValue: IntPtr);
var
  FirstByte: PByte;
  LastByte: PByte;
  TmpValue: Byte;
  i: Integer;
begin
  FirstByte := PByte(pValue);
  LastByte := FirstByte;
  Inc(LastByte, SizeOf(Int64) - 1);
  for i := 0 to 3 do begin
    TmpValue := LastByte^;
    LastByte^ := FirstByte^;
    FirstByte^ := TmpValue;
    Inc(FirstByte);
    Dec(LastByte);
  end;
end;
{$ENDIF}

{$IFDEF WIN32_64}
{$IFNDEF VER14P}
procedure NameThreadForDebugging(AThreadName: AnsiString; AThreadID: LongWord);
type
  TThreadNameInfo = record
    FType: LongWord;     // must be 0x1000
    FName: PAnsiChar;    // pointer to name (in user address space)
    FThreadID: LongWord; // thread ID (-1 indicates caller thread)
    FFlags: LongWord;    // reserved for future use, must be zero
  end;
var
  ThreadNameInfo: TThreadNameInfo;
begin
  //if IsDebuggerPresent then
  begin
    ThreadNameInfo.FType := $1000;
    ThreadNameInfo.FName := PAnsiChar(AThreadName);
    ThreadNameInfo.FThreadID := AThreadID;
    ThreadNameInfo.FFlags := 0;

    try
      RaiseException($406D1388, 0, sizeof(ThreadNameInfo) div sizeof(LongWord), @ThreadNameInfo);
    except
    end;
  end;
end;
{$ENDIF}
{$ENDIF}

{$IFDEF MSWINDOWS}
{$IFNDEF VER7P}
function GetVarDataArrayInfo(const AVarData: TVarData; out AVarType: TVarType;
  out AVarArray: PVarArray): Boolean;
begin
  // variant that points to another variant?  lets go spelunking
  if AVarData.VType = varByRef or varVariant then
    Result := GetVarDataArrayInfo(PVarData(AVarData.VPointer)^, AVarType, AVarArray)
  else
  begin
    // make sure we are pointing to an array then
    AVarType := AVarData.VType;
    Result := (AVarType and varArray) <> 0;

    // figure out the array data pointer
    if Result then
      if (AVarType and varByRef) <> 0 then
        AVarArray := PVarArray(AVarData.VPointer^)
      else
        AVarArray := AVarData.VArray
    else
      AVarArray := nil;
  end;
end;
{$ENDIF}

{$IFNDEF VER7P}
function VarArrayAsPSafeArray(const A: Variant): PVarArray;
var
  LVarType: TVarType;
begin
  if not GetVarDataArrayInfo(TVarData(A), LVarType, Result) then
    VarResultCheck(VAR_INVALIDARG);
end;
{$ENDIF}
{$ENDIF}

{$IFDEF HAVE_COMPRESS_INTERFACE}
procedure CheckZLib;
begin
  if not Assigned(CompressProc) then
    raise Exception.Create(SCompressorNotLinked);
  if not Assigned(UncompressProc) then
    raise Exception.Create(SUncompressorNotLinked);
end;

procedure DoCompress(dest: IntPtr; destLen: IntPtr; const source: IntPtr; sourceLen: longint);
begin
  Assert(Assigned(CompressProc), SCompressorNotLinked);
  CompressProc(dest, destLen, source, sourceLen)
end;

procedure DoUncompress(dest: IntPtr; destlen: IntPtr; source: IntPtr; sourceLne: longint);
begin
  Assert(Assigned(UncompressProc), SUncompressorNotLinked);
  UncompressProc(dest, destLen, source, sourceLne)
end;

{$IFDEF HAVE_COMPRESS_INTERNAL}
function CCheck(code: Integer): Integer;
begin
  Result := code;
  if code < 0 then
    raise ECompressionError.Create(sError);
end;

function DCheck(code: Integer): Integer;
begin
  Result := code;
  if code < 0 then
    raise EDecompressionError.Create(sError);
end;

function compress(dest: IntPtr; destLen: IntPtr; const source: IntPtr; sourceLen: longint): longint; {$IFNDEF MSWINDOWS}cdecl;{$ENDIF}
var
  strm: TZStreamRec;
begin
  FillChar(@strm, sizeof(strm), 0);
  strm.zalloc := zlibAllocMem;
  strm.zfree := zlibFreeMem;
  strm.next_in := source;
  strm.avail_in := sourceLen;
  strm.next_out := dest;
  strm.avail_out := Integer(destLen^);
  CCheck(deflateInit_(strm, Z_DEFAULT_COMPRESSION{Z_BEST_COMPRESSION}, zlib_version, sizeof(strm)));
  try
    Result := CCheck(deflate(strm, Z_FINISH));
    if Result <> Z_STREAM_END then
      raise EZlibError.CreateRes(@sTargetBufferTooSmall);
  finally
    CCheck(deflateEnd(strm));
  end;
  Integer(destLen^) := strm.total_out;
end;

function uncompress(dest: IntPtr; destlen: IntPtr; source: IntPtr; sourceLne: longint): longint; {$IFNDEF MSWINDOWS}cdecl;{$ENDIF}
var
  strm: TZStreamRec;
begin
  FillChar(@strm, sizeof(strm), 0);
  strm.zalloc := zlibAllocMem;
  strm.zfree := zlibFreeMem;
  strm.next_in := source;
  strm.avail_in := sourcelne;
  strm.next_out := dest;
  strm.avail_out := Integer(destlen^);
  DCheck(inflateInit_(strm, zlib_version, sizeof(strm)));
  try
    Result := DCheck(inflate(strm, Z_FINISH));
    if Result <> Z_STREAM_END then
      raise EZlibError.CreateRes(@sTargetBufferTooSmall);
  finally
    DCheck(inflateEnd(strm));
  end;
end;
{$ENDIF}
{$ENDIF}

{$IFDEF MSWINDOWS}
var
  lpVersionInformation: TOSVersionInfo;
{$ENDIF}

initialization
{$IFDEF MSWINDOWS}
  lpVersionInformation.dwOSVersionInfoSize := sizeof(lpVersionInformation);
{$IFDEF VER6P}
  {$WARN SYMBOL_PLATFORM OFF}
{$ENDIF}
{$IFDEF CLR}
  IsWin9x := False;
{$ELSE}
  Win32Check(GetVersionEx(lpVersionInformation));
  IsWin9x := lpVersionInformation.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS;
{$ENDIF}
{$ENDIF}

{$IFDEF HAVE_COMPRESS_INTERNAL}
  CompressProc := compress;
  UncompressProc := uncompress;
{$ENDIF}
end.
