david
fff1b2a4dc
git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.SDAC@3 6f543ec7-021b-7e4c-98c9-62eafc7fb9a8
1683 lines
44 KiB
ObjectPascal
1683 lines
44 KiB
ObjectPascal
|
|
//////////////////////////////////////////////////
|
|
// DB Access Components
|
|
// Copyright © 1998-2007 Core Lab. All right reserved.
|
|
// Mem Data
|
|
// Created: 06.11.03
|
|
//////////////////////////////////////////////////
|
|
|
|
{$IFNDEF CLR}
|
|
|
|
{$I Dac.inc}
|
|
|
|
unit MemUtils;
|
|
{$ENDIF}
|
|
interface
|
|
uses
|
|
Classes, SysUtils, {$IFDEF VER6P}Variants, {$ENDIF}
|
|
{$IFDEF HAVE_COMPRESS_INTERNAL}
|
|
ZLib, ZLibConst,
|
|
{$ENDIF}
|
|
{$IFDEF LINUX}
|
|
{$ELSE}
|
|
Windows,
|
|
{$ENDIF}
|
|
{$IFDEF CLR}
|
|
System.Xml,
|
|
System.Runtime.InteropServices;
|
|
{$ELSE}
|
|
CLRClasses;
|
|
{$ENDIF}
|
|
|
|
{$IFNDEF VER6P}
|
|
const
|
|
varShortInt = $0010; { vt_i1 }
|
|
varWord = $0012; { vt_ui2 }
|
|
varLongWord = $0013; { vt_ui4 }
|
|
varInt64 = $0014; { vt_i8 }
|
|
|
|
type
|
|
TVarType = Word;
|
|
{$ENDIF}
|
|
|
|
{$IFDEF CLR}
|
|
const
|
|
wsAttribute: System.Xml.WriteState = System.Xml.WriteState.Attribute;
|
|
wsClosed: System.Xml.WriteState = System.Xml.WriteState.Closed;
|
|
wsContent: System.Xml.WriteState = System.Xml.WriteState.Content;
|
|
wsElement: System.Xml.WriteState = System.Xml.WriteState.Element;
|
|
wsStart: System.Xml.WriteState = System.Xml.WriteState.Start;
|
|
|
|
fmtNone: System.Xml.Formatting = System.Xml.Formatting.None;
|
|
fmtIndented: System.Xml.Formatting = System.Xml.Formatting.Indented;
|
|
|
|
ntNone: System.Xml.XmlNodeType = System.Xml.XmlNodeType.None;
|
|
ntElement: System.Xml.XmlNodeType = System.Xml.XmlNodeType.Element;
|
|
ntAttribute: System.Xml.XmlNodeType = System.Xml.XmlNodeType.Attribute;
|
|
ntEndElement: System.Xml.XmlNodeType = System.Xml.XmlNodeType.EndElement;
|
|
ntComment: System.Xml.XmlNodeType = System.Xml.XmlNodeType.Comment;
|
|
ntDeclaration: System.Xml.XmlNodeType = System.Xml.XmlNodeType.XmlDeclaration;
|
|
ntDocumentType: System.Xml.XmlNodeType = System.Xml.XmlNodeType.DocumentType;
|
|
ntText: System.Xml.XmlNodeType = System.Xml.XmlNodeType.Text;
|
|
{$ENDIF}
|
|
|
|
type
|
|
{$IFNDEF CLR}
|
|
TValueArr = PChar;
|
|
{$ELSE}
|
|
TValueArr = TBytes;
|
|
|
|
PChar = string;
|
|
PWideChar = string;
|
|
|
|
POleVariant = IntPtr;
|
|
|
|
const
|
|
{ TStream seek origins compatibility aliases }
|
|
soFromBeginning = soBeginning;
|
|
soFromCurrent = soCurrent;
|
|
soFromEnd = soEnd;
|
|
{$ENDIF}
|
|
|
|
{$IFNDEF VER7P}
|
|
const
|
|
MSecsPerSec = 1000;
|
|
{$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: cardinal);
|
|
procedure CopyBufferAnsi(const Source: string; Dest: IntPtr; Count{Bytes (#0 included)}: cardinal);
|
|
procedure CopyBufferUni(const Source: WideString; Dest: IntPtr; Count{Bytes (#0 included)}: cardinal);
|
|
|
|
procedure FillChar(X: IntPtr; Count: integer; Value: byte);
|
|
procedure FillStr(var S: string; Count: integer; Value: char);
|
|
procedure ArrayCopy(sourceArray: TBytes; sourceIndex: integer; destinationArray: TBytes; destinationIndex: integer; length: integer);
|
|
function AllocGCHandle(Obj: {$IFDEF CLR}TObject{$ELSE}pointer{$ENDIF}; Pinned: boolean = False): IntPtr;
|
|
function GetGCHandleTarget(Handle: IntPtr): TObject;
|
|
function GetAddrOfPinnedObject(Handle: IntPtr): IntPtr;
|
|
procedure FreeGCHandle(Handle: IntPtr);
|
|
|
|
function AllocString(var S: string; Length: integer): IntPtr;
|
|
procedure FreeString(P: IntPtr);
|
|
function AllocOrdinal(var Obj: IntPtr): IntPtr; overload;
|
|
function AllocOrdinal(var Obj: shortint): IntPtr; overload;
|
|
function AllocOrdinal(var Obj: byte): IntPtr; overload;
|
|
function AllocOrdinal(var Obj: word): IntPtr; overload;
|
|
function AllocOrdinal(var Obj: integer): IntPtr; overload;
|
|
function AllocOrdinal(var Obj: cardinal): IntPtr; overload;
|
|
function OrdinalToPtr(var Obj: double): IntPtr; overload;
|
|
function OrdinalToPtr(var Obj: byte): IntPtr; overload;
|
|
function OrdinalToPtr(var Obj: smallint): IntPtr; overload;
|
|
function OrdinalToPtr(var Obj: integer): IntPtr; overload;
|
|
function OrdinalToPtr(var Obj: int64): IntPtr; overload;
|
|
function OrdinalToPtr(var Obj: cardinal): IntPtr; overload;
|
|
function OrdinalToPtr(var Obj: word): IntPtr; overload;
|
|
function OrdinalToPtr(var Obj: IntPtr): IntPtr; overload;
|
|
procedure PtrToOrdinal(P: IntPtr; var Obj: shortint); overload;
|
|
procedure PtrToOrdinal(P: IntPtr; var Obj: byte); overload;
|
|
procedure PtrToOrdinal(P: IntPtr; var Obj: smallint); overload;
|
|
procedure PtrToOrdinal(P: IntPtr; var Obj: word); overload;
|
|
procedure PtrToOrdinal(P: IntPtr; var Obj: integer); overload;
|
|
procedure PtrToOrdinal(P: IntPtr; var Obj: int64); overload;
|
|
procedure PtrToOrdinal(P: IntPtr; var Obj: cardinal); overload;
|
|
procedure PtrToOrdinal(P: IntPtr; var Obj: IntPtr); overload;
|
|
procedure FreeOrdinal(P: IntPtr);
|
|
{ PChar and PWideChar routines }
|
|
{$IFDEF CLR}
|
|
procedure StrCopy(Dest: IntPtr; const Source: IntPtr);
|
|
function StrComp(const Str1: IntPtr; const Str2: IntPtr): integer;
|
|
procedure StrLCopy(Dest: IntPtr; const Source: IntPtr; MaxLen{Chars}: Cardinal);
|
|
function StrLen(const Str: IntPtr): Cardinal;
|
|
|
|
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}
|
|
function AnsiStrCompS(S1, S2: PChar): Integer; // SORT_STRINGSORT
|
|
function AnsiStrICompS(S1, S2: PChar): Integer; // SORT_STRINGSORT
|
|
{$ENDIF}
|
|
function AnsiCompareTextS(const S1, S2: string): integer; // SORT_STRINGSORT
|
|
function AnsiCompareStrS(const S1, S2: string): integer; // SORT_STRINGSORT
|
|
function Utf8ToWs(const Dest: TValueArr; DestIdx: Cardinal; MaxDestBytes{w/wo #0}: Cardinal;
|
|
const Source: TValueArr; SourceIdx, SourceBytes: Cardinal;
|
|
const AddNull: boolean): Cardinal{bytes w/wo #0};
|
|
|
|
function StrCopyW(Dest: IntPtr; const Source: IntPtr): IntPtr;
|
|
procedure StrLCopyW(Dest: IntPtr; const Source: IntPtr; MaxLen{WideChars}: Cardinal);
|
|
function StrLenW(const Str: IntPtr): Cardinal;
|
|
procedure StrTrim(const Str: IntPtr; Len: integer = -1);
|
|
procedure StrTrimW(const Str: IntPtr; Len: integer = -1);
|
|
function AnsiStrLCompWS(const S1, S2: WideString; MaxLen: Cardinal): Integer; // SORT_STRINGSORT
|
|
function AnsiStrLICompWS(const S1, S2: WideString; MaxLen: Cardinal): Integer; // SORT_STRINGSORT
|
|
function AnsiStrCompWS(const S1, S2: WideString): Integer; // SORT_STRINGSORT
|
|
function AnsiStrICompWS(const S1, S2: WideString): Integer; // SORT_STRINGSORT
|
|
|
|
function IsClass(Obj: TObject; AClass: TClass): boolean;
|
|
|
|
type
|
|
{$IFDEF CLR}
|
|
TDAList = class(TObject)
|
|
FList: array of TObject;
|
|
FCount: Integer;
|
|
FCapacity: Integer;
|
|
protected
|
|
function Get(Index: Integer): TObject;
|
|
procedure Grow; virtual;
|
|
procedure Put(Index: Integer; Item: TObject);
|
|
procedure SetCapacity(NewCapacity: Integer);
|
|
|
|
public
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
function Add(Item: TObject): Integer;
|
|
procedure Clear; virtual;
|
|
procedure Delete(Index: Integer);
|
|
function IndexOf(Item: TObject): Integer;
|
|
function Last: TObject;
|
|
function Remove(Item: TObject): Integer;
|
|
procedure Sort(Compare: TListSortCompare);
|
|
|
|
property Capacity: Integer read FCapacity write SetCapacity;
|
|
property Count: Integer read FCount;
|
|
property Items[Index: Integer]: TObject read Get write Put; default;
|
|
|
|
end;
|
|
{$ELSE}
|
|
TDAList = TList;
|
|
{$ENDIF}
|
|
|
|
{$IFNDEF CLR}
|
|
function TryEncodeDate(Year, Month, Day: Word; var Date: TDateTime): Boolean;
|
|
function TryEncodeTime(Hour, Min, Sec, MSec: Word; var 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}
|
|
|
|
{$IFNDEF VER6P}
|
|
function BoolToStr(const Value: boolean; UseBoolStrs: Boolean = False): string;
|
|
function TryStrToBool(const S: string; out Value: Boolean): Boolean;
|
|
function StrToBool(const S: string): Boolean;
|
|
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;
|
|
{$ENDIF}
|
|
|
|
{$IFDEF VER6}
|
|
function StrToBool(const S: string): Boolean;
|
|
function TryStrToBool(const S: string; out Value: Boolean): Boolean;
|
|
{$ENDIF}
|
|
|
|
function Reverse4(Value: cardinal): cardinal;
|
|
{$IFNDEF CLR}
|
|
procedure Reverse8(pValue: IntPtr);
|
|
{$ENDIF}
|
|
|
|
{$IFDEF VER8}
|
|
type
|
|
UTF8String = AnsiString deprecated;
|
|
|
|
function UTF8Encode(const WS: WideString): UTF8String; deprecated;
|
|
function UTF8Decode(const S: UTF8String): WideString; deprecated;
|
|
{$ENDIF}
|
|
|
|
{$IFDEF HAVE_COMPRESS}
|
|
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; {$IFDEF LINUX}cdecl;{$ENDIF}
|
|
TUncompressProc = function(dest: IntPtr; destlen: IntPtr; source: IntPtr; sourceLne: longint): longint; {$IFDEF LINUX}cdecl;{$ENDIF}
|
|
|
|
var
|
|
CompressProc: TCompressProc;
|
|
UncompressProc: TUncompressProc;
|
|
|
|
{$ENDIF}
|
|
|
|
{$IFDEF MSWINDOWS}
|
|
var
|
|
IsWin9x: boolean;
|
|
{$ENDIF}
|
|
|
|
implementation
|
|
|
|
{$IFDEF CLR}
|
|
uses
|
|
ActiveX, System.Text,
|
|
RTLConsts;
|
|
{$ELSE}
|
|
uses
|
|
{$IFDEF VER6}
|
|
SysConst,
|
|
{$ENDIF}
|
|
DAConsts;
|
|
{$ENDIF}
|
|
|
|
{$IFNDEF CLR}
|
|
{$IFDEF MSWINDOWS}
|
|
{$DEFINE SORT_STRINGSORT}
|
|
{$ENDIF}
|
|
{$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 := IntPtr(integer(P1) + 1);
|
|
P2 := IntPtr(integer(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;
|
|
procedure ValidateTimeStamp(const ATimeStamp: TTimeStamp);
|
|
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]));
|
|
end;
|
|
begin
|
|
ValidateTimeStamp(ATimeStamp);
|
|
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) = 8) and ((VarType(Value2) = 8) or (VarType(Value2) = 256)) or
|
|
(VarType(Value2) = 8) and ((VarType(Value1) = 8) or (VarType(Value1) = 256))
|
|
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) or
|
|
(VarType(Value2) <> VarType(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
|
|
else
|
|
Result := Value1 = Value2;
|
|
end;
|
|
|
|
procedure CopyBuffer(Source, Dest: IntPtr; Count: cardinal);
|
|
begin
|
|
{$IFDEF CLR}
|
|
CopyMemory(Dest, Source, Count);
|
|
{$ELSE}
|
|
Move(Source^, Dest^, Count);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure CopyBufferAnsi(const Source: string; Dest: IntPtr; Count{Bytes (#0 included)}: cardinal);
|
|
{$IFDEF CLR}
|
|
var
|
|
buf: TBytes;
|
|
CountInt: integer; // To prevent CLR compiler error
|
|
begin
|
|
SetLength(buf, Count);
|
|
CountInt := Convert.ToInt32(Count); // To prevent CLR compiler error
|
|
Encoding.Default.GetBytes(Source, 0, CountInt - 1{#0}, buf, 0);
|
|
buf[CountInt - 1] := 0;
|
|
Marshal.Copy(buf, 0, Dest, CountInt);
|
|
end;
|
|
{$ELSE}
|
|
begin
|
|
CopyBuffer(PChar(Source), Dest, Count);
|
|
end;
|
|
{$ENDIF}
|
|
|
|
procedure CopyBufferUni(const Source: WideString; Dest: IntPtr; Count{Bytes (#0#0 included)}: cardinal);
|
|
{$IFDEF CLR}
|
|
var
|
|
buf: TBytes;
|
|
CountInt: integer; // To prevent CLR compiler error
|
|
begin
|
|
SetLength(buf, Count);
|
|
CountInt := Convert.ToInt32(Count); // To prevent CLR compiler error
|
|
Encoding.Unicode.GetBytes(Source, 0, (CountInt - 1{#0}) shr 1, buf, 0);
|
|
buf[CountInt - 1] := 0;
|
|
buf[CountInt - 2] := 0;
|
|
Marshal.Copy(buf, 0, Dest, CountInt);
|
|
end;
|
|
{$ELSE}
|
|
begin
|
|
CopyBuffer(PWideChar(Source), Dest, Count);
|
|
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;
|
|
|
|
procedure FillStr(var S: string; Count: integer; Value: char);
|
|
begin
|
|
{$IFDEF CLR}
|
|
S := System.String.Create(Value, Count);
|
|
{$ELSE}
|
|
SetLength(S, Count);
|
|
FillChar(PChar(S), Count, byte(Value));
|
|
{$ENDIF}
|
|
end;
|
|
|
|
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;
|
|
|
|
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}
|
|
Result := Obj;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function GetGCHandleTarget(Handle: IntPtr): TObject;
|
|
begin
|
|
{$IFDEF CLR}
|
|
if Handle = nil then
|
|
Result := nil
|
|
else
|
|
Result := GCHandle(Handle).Target;
|
|
{$ELSE}
|
|
Result := Handle;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function GetAddrOfPinnedObject(Handle: IntPtr): IntPtr;
|
|
begin
|
|
{$IFDEF CLR}
|
|
Result := GCHandle(Handle).AddrOfPinnedObject;
|
|
{$ELSE}
|
|
Result := Handle;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure FreeGCHandle(Handle: IntPtr);
|
|
begin
|
|
{$IFDEF CLR}
|
|
GCHandle(Handle).Free;
|
|
{$ELSE}
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function AllocString(var S: string; Length: integer): IntPtr;
|
|
begin
|
|
{$IFDEF CLR}
|
|
Result := Marshal.AllocHGlobal(Length + 1);
|
|
{$ELSE}
|
|
SetLength(S, Length);
|
|
Result := PChar(S);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure FreeString(P: IntPtr);
|
|
begin
|
|
{$IFDEF CLR}
|
|
Marshal.FreeHGlobal(P);
|
|
{$ELSE}
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function AllocOrdinal(var Obj: shortint): IntPtr; overload;
|
|
begin
|
|
{$IFDEF CLR}
|
|
Result := Marshal.AllocHGlobal(sizeof(shortint));
|
|
{$ELSE}
|
|
Result := @Obj;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function AllocOrdinal(var Obj: byte): IntPtr; overload;
|
|
begin
|
|
{$IFDEF CLR}
|
|
Result := Marshal.AllocHGlobal(sizeof(byte));
|
|
{$ELSE}
|
|
Result := @Obj;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function AllocOrdinal(var Obj: word): IntPtr; overload;
|
|
begin
|
|
{$IFDEF CLR}
|
|
Result := Marshal.AllocHGlobal(sizeof(word));
|
|
{$ELSE}
|
|
Result := @Obj;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function AllocOrdinal(var Obj: integer): IntPtr; overload;
|
|
begin
|
|
{$IFDEF CLR}
|
|
Result := Marshal.AllocHGlobal(sizeof(integer));
|
|
{$ELSE}
|
|
Result := @Obj;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function AllocOrdinal(var Obj: cardinal): IntPtr; overload;
|
|
begin
|
|
{$IFDEF CLR}
|
|
Result := Marshal.AllocHGlobal(sizeof(integer));
|
|
{$ELSE}
|
|
Result := @Obj;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function AllocOrdinal(var Obj: IntPtr): IntPtr; overload;
|
|
begin
|
|
{$IFDEF CLR}
|
|
Result := Marshal.AllocHGlobal(sizeof(IntPtr));
|
|
{$ELSE}
|
|
Result := @Obj;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function OrdinalToPtr(var 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(var Obj: byte): IntPtr; overload;
|
|
begin
|
|
{$IFDEF CLR}
|
|
Result := Marshal.AllocHGlobal(sizeof(byte));
|
|
Marshal.WriteByte(Result, Obj);
|
|
{$ELSE}
|
|
Result := @Obj;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function OrdinalToPtr(var Obj: smallint): IntPtr; overload;
|
|
begin
|
|
{$IFDEF CLR}
|
|
Result := Marshal.AllocHGlobal(sizeof(smallint));
|
|
Marshal.WriteInt16(Result, Obj);
|
|
{$ELSE}
|
|
Result := @Obj;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function OrdinalToPtr(var Obj: integer): IntPtr; overload;
|
|
begin
|
|
{$IFDEF CLR}
|
|
Result := Marshal.AllocHGlobal(sizeof(integer));
|
|
Marshal.WriteInt32(Result, Obj);
|
|
{$ELSE}
|
|
Result := @Obj;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function OrdinalToPtr(var Obj: int64): IntPtr; overload;
|
|
begin
|
|
{$IFDEF CLR}
|
|
Result := Marshal.AllocHGlobal(sizeof(int64));
|
|
Marshal.WriteInt64(Result, Obj);
|
|
{$ELSE}
|
|
Result := @Obj;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function OrdinalToPtr(var Obj: cardinal): IntPtr; overload;
|
|
begin
|
|
{$IFDEF CLR}
|
|
Result := Marshal.AllocHGlobal(sizeof(cardinal));
|
|
Marshal.WriteInt32(Result, Obj);
|
|
{$ELSE}
|
|
Result := @Obj;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function OrdinalToPtr(var Obj: word): IntPtr; overload;
|
|
begin
|
|
{$IFDEF CLR}
|
|
Result := Marshal.AllocHGlobal(sizeof(word));
|
|
Marshal.WriteInt16(Result, Obj);
|
|
{$ELSE}
|
|
Result := @Obj;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function OrdinalToPtr(var 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; var Obj: shortint); overload;
|
|
begin
|
|
{$IFDEF CLR}
|
|
Obj := Marshal.ReadByte(P);
|
|
Marshal.FreeHGlobal(P);
|
|
{$ELSE}
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure PtrToOrdinal(P: IntPtr; var Obj: byte); overload;
|
|
begin
|
|
{$IFDEF CLR}
|
|
Obj := Marshal.ReadByte(P);
|
|
Marshal.FreeHGlobal(P);
|
|
{$ELSE}
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure PtrToOrdinal(P: IntPtr; var Obj: smallint); overload;
|
|
begin
|
|
{$IFDEF CLR}
|
|
Obj := Marshal.ReadInt16(P);
|
|
Marshal.FreeHGlobal(P);
|
|
{$ELSE}
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure PtrToOrdinal(P: IntPtr; var Obj: word); overload;
|
|
begin
|
|
{$IFDEF CLR}
|
|
Obj := Word(Marshal.ReadInt32(P));
|
|
Marshal.FreeHGlobal(P);
|
|
{$ELSE}
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure PtrToOrdinal(P: IntPtr; var Obj: integer); overload;
|
|
begin
|
|
{$IFDEF CLR}
|
|
Obj := Marshal.ReadInt32(P);
|
|
Marshal.FreeHGlobal(P);
|
|
{$ELSE}
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure PtrToOrdinal(P: IntPtr; var Obj: int64); overload;
|
|
begin
|
|
{$IFDEF CLR}
|
|
Obj := Marshal.ReadInt64(P);
|
|
Marshal.FreeHGlobal(P);
|
|
{$ELSE}
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure PtrToOrdinal(P: IntPtr; var Obj: cardinal); overload;
|
|
begin
|
|
{$IFDEF CLR}
|
|
Obj := Marshal.ReadInt32(P);
|
|
Marshal.FreeHGlobal(P);
|
|
{$ELSE}
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure PtrToOrdinal(P: IntPtr; var 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: IntPtr; const Source: IntPtr);
|
|
begin
|
|
Win32Check(lstrcpy(Dest, Source) <> nil);
|
|
end;
|
|
|
|
procedure StrLCopy(Dest: IntPtr; const Source: IntPtr; MaxLen{Chars}: Cardinal);
|
|
begin
|
|
Win32Check(lstrcpyn(Dest, Source, Integer(MaxLen + 1)) <> nil);
|
|
end;
|
|
|
|
function StrComp(const Str1: IntPtr; const Str2: IntPtr): integer;
|
|
begin
|
|
Result := lstrcmp(Str1, Str2);
|
|
end;
|
|
|
|
function StrLen(const Str: IntPtr): Cardinal;
|
|
begin
|
|
Result := lstrlen(Str);
|
|
end;
|
|
|
|
function StrLenW(const Str: IntPtr): Cardinal;
|
|
var
|
|
s: WideString;
|
|
begin
|
|
s := Marshal.PtrToStringUni(Str);
|
|
Result := s.Length;
|
|
end;
|
|
|
|
procedure StrTrim(const Str: IntPtr; Len: integer = -1);
|
|
var
|
|
i: integer;
|
|
v: byte;
|
|
begin
|
|
if Len = - 1 then // Detect length
|
|
Len := StrLen(Str);
|
|
|
|
i := Integer(Str) + Len - 1;
|
|
|
|
while True do begin
|
|
v := Marshal.ReadByte(IntPtr(i));
|
|
if ((v <> 32 {Byte(' ')}) and (v <> 0{Byte(#0)})) or (i < Integer(Str)) then
|
|
Exit;
|
|
Marshal.WriteByte(IntPtr(i), Byte(#0));
|
|
Dec(i);
|
|
end;
|
|
end;
|
|
|
|
procedure StrTrimW(const Str: IntPtr; Len: integer = -1);
|
|
var
|
|
i: integer;
|
|
v: smallint;
|
|
begin
|
|
if Len = - 1 then // Detect length
|
|
Len := StrLenW(Str);
|
|
|
|
i := Integer(Str) + (Len - 1) shl 1;
|
|
|
|
while True do begin
|
|
v := Marshal.ReadInt16(IntPtr(i));
|
|
if ((v <> 32 {SmallInt(' ')}) and (v <> 0{SmallInt(#0)})) or (i < Integer(Str)) then
|
|
Exit;
|
|
Marshal.WriteInt16(IntPtr(i), SmallInt(#0));
|
|
Dec(i);
|
|
Dec(i);
|
|
end;
|
|
end;
|
|
|
|
{$ENDIF}
|
|
|
|
function StrCopyW(Dest: IntPtr; const Source: IntPtr): 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}
|
|
asm
|
|
PUSH EDI
|
|
PUSH ESI
|
|
MOV ESI,EAX
|
|
MOV EDI,EDX
|
|
MOV ECX,0FFFFFFFFH
|
|
XOR AX,AX
|
|
REPNE SCASW
|
|
NOT ECX
|
|
SHL ECX, 1 // Size := Len * sizeof(WideChar)
|
|
MOV EDI,ESI
|
|
MOV ESI,EDX
|
|
MOV EDX,ECX
|
|
MOV EAX,EDI
|
|
SHR ECX,2
|
|
REP MOVSD
|
|
MOV ECX,EDX
|
|
AND ECX,3
|
|
REP MOVSB
|
|
POP ESI
|
|
POP EDI
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure StrLCopyW(Dest: IntPtr; const Source: IntPtr; MaxLen{WideChars}: Cardinal);
|
|
{$IFDEF CLR}
|
|
var
|
|
Buf: smallint;
|
|
i: cardinal;
|
|
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: IntPtr): Cardinal; assembler;
|
|
asm
|
|
MOV EDX,EDI
|
|
MOV EDI,EAX
|
|
MOV ECX,0FFFFFFFFH
|
|
XOR AX,AX
|
|
REPNE SCASW
|
|
MOV EAX,0FFFFFFFEH
|
|
SUB EAX,ECX
|
|
MOV EDI,EDX
|
|
end;
|
|
|
|
procedure StrTrim(const Str: IntPtr; Len: integer = -1);
|
|
var
|
|
pc: PChar;
|
|
begin
|
|
if Len = - 1 then // Detect length
|
|
Len := StrLen(Str);
|
|
|
|
pc := PChar(Str) + Len - 1;
|
|
|
|
while ((pc^ = ' ') or (pc^ = #0)) and (pc >= Str) do begin
|
|
pc^ := #0;
|
|
Dec(pc);
|
|
end;
|
|
end;
|
|
|
|
procedure StrTrimW(const Str: IntPtr; 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: Cardinal): 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}
|
|
Result := 0;
|
|
Assert(False);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function AnsiStrLICompWS(const S1, S2: WideString; MaxLen: Cardinal): 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}
|
|
Result := 0;
|
|
Assert(False);
|
|
{$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}
|
|
Result := 0;
|
|
Assert(False);
|
|
{$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}
|
|
Result := 0;
|
|
Assert(False);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function IsClass(Obj: TObject; AClass: TClass): boolean;
|
|
|
|
function IsClassByName(Obj: TObject; AClass: TClass): boolean;
|
|
var
|
|
ParentClass: TClass;
|
|
begin
|
|
Result := False;
|
|
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;
|
|
|
|
{$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}
|
|
|
|
function AnsiStrCompS(S1, S2: PChar): Integer; // SORT_STRINGSORT
|
|
begin
|
|
{$IFDEF SORT_STRINGSORT}
|
|
Result := CompareString(LOCALE_USER_DEFAULT, SORT_STRINGSORT, S1, -1, S2, -1) - 2;
|
|
{$ELSE}
|
|
Result := AnsiStrComp(S1, S2);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function AnsiStrICompS(S1, S2: PChar): Integer; // SORT_STRINGSORT
|
|
begin
|
|
{$IFDEF SORT_STRINGSORT}
|
|
Result := CompareString(LOCALE_USER_DEFAULT, NORM_IGNORECASE + SORT_STRINGSORT, S1, -1,
|
|
S2, -1) - 2;
|
|
{$ELSE}
|
|
Result := AnsiStrIComp(S1, S2);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
{$ENDIF}
|
|
|
|
function AnsiCompareTextS(const S1, S2: string): integer; // SORT_STRINGSORT
|
|
begin
|
|
{$IFDEF SORT_STRINGSORT}
|
|
Result := CompareString(LOCALE_USER_DEFAULT, NORM_IGNORECASE + SORT_STRINGSORT, PChar(S1),
|
|
Length(S1), PChar(S2), Length(S2)) - 2;
|
|
{$ELSE}
|
|
Result := AnsiCompareText(S1, S2);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function AnsiCompareStrS(const S1, S2: string): integer; // SORT_STRINGSORT
|
|
begin
|
|
{$IFDEF SORT_STRINGSORT}
|
|
Result := CompareString(LOCALE_USER_DEFAULT, SORT_STRINGSORT, PChar(S1), Length(S1),
|
|
PChar(S2), Length(S2)) - 2;
|
|
{$ELSE}
|
|
Result := AnsiCompareStr(S1, S2);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
// Convert Utf8 buffer to WideString buffer with or without null terminator.
|
|
// Nearly copied from System.Utf8ToUnicode
|
|
function Utf8ToWs(const Dest: TValueArr; DestIdx: Cardinal; MaxDestBytes{w/wo #0}: Cardinal;
|
|
const Source: TValueArr; SourceIdx, SourceBytes: Cardinal;
|
|
const AddNull: boolean): Cardinal{bytes w/wo #0};
|
|
var
|
|
i: Cardinal;
|
|
c: Byte;
|
|
wc: Cardinal;
|
|
begin
|
|
Assert(Source <> nil, 'Utf8ToWs: Source is nil');
|
|
Assert(Dest <> nil, 'Utf8ToWs: Destination is nil');
|
|
{$IFDEF CLR}
|
|
Assert(Integer(DestIdx + MaxDestBytes) <= Length(Dest), 'Utf8ToWs: DestIdx = ' + IntToStr(DestIdx) + ', MaxDestBytes = ' + IntToStr(MaxDestBytes) + ', Length(Dest) = ' + IntToStr(Length(Dest)));
|
|
Assert(Integer(SourceIdx + SourceBytes) <= Length(Source), 'Utf8ToWs: SourceIdx = ' + IntToStr(SourceIdx) + ', SourceBytes = ' + IntToStr(SourceBytes) + ', Length(Source) = ' + IntToStr(Length(Source)));
|
|
{$ENDIF}
|
|
Result := 0;
|
|
i := SourceIdx;
|
|
while i < SourceIdx + SourceBytes do
|
|
begin
|
|
wc := Cardinal(Source[Integer(i)]);
|
|
if wc = 0 then //zero terminator
|
|
break;
|
|
Inc(i);
|
|
if (wc and $80) <> 0 then
|
|
begin
|
|
Assert(i < SourceIdx + SourceBytes, 'Utf8ToWs: Incomplete multibyte char');
|
|
wc := wc and $3F;
|
|
if (wc and $20) <> 0 then
|
|
begin
|
|
c := Byte(Source[Integer(i)]);
|
|
Inc(i);
|
|
Assert((c and $C0) = $80, 'Utf8ToWs: Malformed trail byte or out of range char');
|
|
Assert(i < SourceIdx + SourceBytes, 'Utf8ToWs: Incomplete multibyte char');
|
|
wc := (wc shl 6) or (c and $3F);
|
|
end;
|
|
c := Byte(Source[Integer(i)]);
|
|
Inc(i);
|
|
Assert((c and $C0) = $80, 'Utf8ToWs: Malformed trail byte');
|
|
wc := (wc shl 6) or (c and $3F);
|
|
end;
|
|
|
|
if not (Result + 1 < MaxDestBytes) then
|
|
Break;
|
|
{$IFDEF CLR}
|
|
Dest[Integer(Result + DestIdx)] := Byte(wc);
|
|
Dest[Integer(Result + DestIdx + 1)] := Byte(wc shr 8);
|
|
{$ELSE}
|
|
Cardinal(Pointer(Cardinal(Dest) + DestIdx + Result)^) := wc;
|
|
{$ENDIF}
|
|
Inc(Result, SizeOf(WideChar));
|
|
end;
|
|
|
|
if AddNull and (MaxDestBytes > 0) then begin
|
|
if Result >= MaxDestBytes then
|
|
Result := MaxDestBytes - SizeOf(WideChar);
|
|
{$IFDEF CLR}
|
|
Dest[Integer(Result + DestIdx)] := 0;
|
|
Dest[Integer(Result + DestIdx + 1)] := 0;
|
|
{$ELSE}
|
|
Marshal.WriteInt16(Dest, Integer(DestIdx + Result), 0);
|
|
{$ENDIF}
|
|
Inc(Result, SizeOf(WideChar));
|
|
end;
|
|
end;
|
|
|
|
{$IFDEF CLR}
|
|
{ TDAList }
|
|
constructor TDAList.Create;
|
|
begin
|
|
inherited Create;
|
|
|
|
SetCapacity(10);
|
|
end;
|
|
|
|
destructor TDAList.Destroy;
|
|
begin
|
|
Clear;
|
|
|
|
inherited;
|
|
end;
|
|
|
|
procedure TDAList.Clear;
|
|
begin
|
|
FCount := 0;
|
|
SetCapacity(0);
|
|
end;
|
|
|
|
procedure TDAList.Delete(Index: Integer);
|
|
begin
|
|
if (Index < 0) or (Index >= FCount) then
|
|
TList.Error({$IFNDEF CLR}@{$ENDIF}SListIndexError, Index);
|
|
Dec(FCount);
|
|
if Index < FCount then
|
|
{$IFDEF CLR}
|
|
System.Array.Copy(FList, Index + 1, FList, Index, FCount - Index);
|
|
{$ELSE}//TODO
|
|
System.Move(FList[Index + 1], FList[Index],
|
|
(FCount - Index) * SizeOf(Pointer));
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function TDAList.IndexOf(Item: TObject): Integer;
|
|
begin
|
|
Result := 0;
|
|
while (Result < FCount) and (FList[Result] <> Item) do
|
|
Inc(Result);
|
|
if Result = FCount then
|
|
Result := -1;
|
|
end;
|
|
|
|
function TDAList.Last: TObject;
|
|
begin
|
|
Result := Get(FCount - 1);
|
|
end;
|
|
|
|
function TDAList.Remove(Item: TObject): Integer;
|
|
begin
|
|
Result := IndexOf(Item);
|
|
if Result >= 0 then
|
|
Delete(Result);
|
|
end;
|
|
|
|
procedure QuickSort(var SortList: array of TObject; L, R: Integer;
|
|
SCompare: TListSortCompare);
|
|
var
|
|
I, J: Integer;
|
|
P, T: TObject;
|
|
begin
|
|
repeat
|
|
I := L;
|
|
J := R;
|
|
P := SortList[(L + R) shr 1];
|
|
repeat
|
|
while SCompare(SortList[I], P) < 0 do
|
|
Inc(I);
|
|
while SCompare(SortList[J], P) > 0 do
|
|
Dec(J);
|
|
if I <= J then
|
|
begin
|
|
T := SortList[I];
|
|
SortList[I] := SortList[J];
|
|
SortList[J] := T;
|
|
Inc(I);
|
|
Dec(J);
|
|
end;
|
|
until I > J;
|
|
if L < J then
|
|
QuickSort(SortList, L, J, SCompare);
|
|
L := I;
|
|
until I >= R;
|
|
end;
|
|
|
|
procedure TDAList.Sort(Compare: TListSortCompare);
|
|
begin
|
|
if (FList <> nil) and (Count > 0) then
|
|
QuickSort(FList, 0, Count - 1, Compare);
|
|
end;
|
|
|
|
function TDAList.Add(Item: TObject): Integer;
|
|
begin
|
|
Result := FCount;
|
|
if Result = FCapacity then
|
|
Grow;
|
|
FList[Result] := Item;
|
|
Inc(FCount);
|
|
end;
|
|
|
|
function TDAList.Get(Index: Integer): TObject;
|
|
begin
|
|
if (Index < 0) or (Index >= FCount) then
|
|
TList.Error({$IFNDEF CLR}@{$ENDIF}SListIndexError, Index);
|
|
Result := FList[Index];
|
|
end;
|
|
|
|
procedure TDAList.Grow;
|
|
var
|
|
Delta: Integer;
|
|
begin
|
|
if FCapacity > 64 then
|
|
Delta := FCapacity div 4
|
|
else
|
|
if FCapacity > 8 then
|
|
Delta := 16
|
|
else
|
|
Delta := 4;
|
|
SetCapacity(FCapacity + Delta);
|
|
end;
|
|
|
|
procedure TDAList.Put(Index: Integer; Item: TObject);
|
|
begin
|
|
if (Index < 0) or (Index >= FCount) then
|
|
TList.Error({$IFNDEF CLR}@{$ENDIF}SListIndexError, Index);
|
|
FList[Index] := Item;
|
|
end;
|
|
|
|
procedure TDAList.SetCapacity(NewCapacity: Integer);
|
|
begin
|
|
if (NewCapacity < FCount) or (NewCapacity > MaxListSize) then
|
|
TList.Error({$IFNDEF CLR}@{$ENDIF}SListCapacityError, NewCapacity);
|
|
if NewCapacity <> FCapacity then
|
|
begin
|
|
SetLength(FList, NewCapacity);
|
|
FCapacity := NewCapacity;
|
|
end;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
{$IFDEF CLR}
|
|
const
|
|
ole32 = 'ole32.dll';
|
|
oleaut32 = 'oleaut32.dll';
|
|
|
|
// Copied from ActiveX.pas (d7)
|
|
const
|
|
STGM_READ = $00000000;
|
|
|
|
[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 VER6P}
|
|
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;
|
|
|
|
function TryStrToBool(const S: string; out Value: Boolean): Boolean;
|
|
begin
|
|
Result := True;
|
|
if SameText(s, 'True') or SameText(s, 'Yes') or SameText(s, '1') then
|
|
Value := True
|
|
else
|
|
if SameText(s, 'False') or SameText(s, 'No') or SameText(s, '0') then
|
|
Value := False
|
|
else
|
|
Result := False;
|
|
end;
|
|
|
|
function StrToBool(const S: string): Boolean;
|
|
begin
|
|
if not TryStrToBool(S, Result) then
|
|
raise EConvertError.Create('InvalidBoolean - ' + S);
|
|
end;
|
|
|
|
type
|
|
PWordBool = ^WordBool;
|
|
|
|
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;
|
|
{$ENDIF}
|
|
|
|
{$IFDEF VER6}
|
|
procedure ConvertErrorFmt(ResString: PResStringRec; const Args: array of const); local;
|
|
begin
|
|
raise EConvertError.CreateResFmt(ResString, Args);
|
|
end;
|
|
|
|
function StrToBool(const S: string): Boolean;
|
|
begin
|
|
if not TryStrToBool(S, Result) then
|
|
ConvertErrorFmt(@SInvalidBoolean, [S]);
|
|
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;
|
|
{$ENDIF}
|
|
|
|
{$IFNDEF CLR}
|
|
function TryEncodeDate(Year, Month, Day: Word; var 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; var Time: TDateTime): Boolean;
|
|
begin
|
|
Result := False;
|
|
if (Hour < 24) and (Min < 60) and (Sec < 60) and (MSec < 1000) then
|
|
begin
|
|
Time := (Hour * 3600000 + 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 VER8}
|
|
function UTF8Encode(const WS: WideString): UTF8String;
|
|
begin
|
|
Result := UTF8String(System.Array(nil));
|
|
if Assigned(WS) then
|
|
Result := System.Text.Encoding.UTF8.GetBytes(WS);
|
|
end;
|
|
|
|
function UTF8Decode(const S: UTF8String): WideString;
|
|
begin
|
|
Result := WideString(System.String(nil));
|
|
if Assigned(S) then
|
|
Result := System.Text.Encoding.UTF8.GetString(TBytes(S), 0, High(TBytes(S)) + 1);
|
|
end;
|
|
{$ENDIF}
|
|
|
|
{$IFDEF HAVE_COMPRESS}
|
|
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;
|
|
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;
|
|
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;
|
|
|
|
initialization
|
|
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.
|