{*******************************************************}
{ }
{ Fast WideString for Delphi 2007 }
{ }
{ Copyright (c) 2010 Dmitry Ignatyev }
{ email: dign@yander.ru }
{ }
{*******************************************************}
unit FastWideString;
interface
uses
Windows;
{ Инициализировать быстрые WideString }
procedure FastWideStringInit;
implementation
type
PPWideStr = ^PWideStr;
PWideStr = ^TWideStr;
TWideStr = record
refcnt : integer; //счетчик ссылок
id0 : integer; //наш идентификатор
id1 : integer; //наш идентификатор
id2 : integer; //наш идентификатор
length : integer; //размер строки (как и положено)
end;
POffsJmp = ^TOffsJmp;
TOffsJmp = packed record
code : byte; //$E9
offs : cardinal;
end;
const
size_str = sizeof(TWideStr);
str_id_0 = integer($96969696);
str_id_1 = integer($75757575);
str_id_2 = integer($38383838);
oleaut = 'oleaut32.dll';
procedure HookCode(Src, Dst: pointer); inline;
begin
if Assigned(Src) then begin
poffsjmp(Src).code := $E9;
poffsjmp(Src).offs := cardinal(Dst) - cardinal(Src) - 5;
end;
end;
procedure HookProc(handle: cardinal; Name: PAnsiChar; Hook: pointer); inline;
begin
HookCode(GetProcAddress(handle, Name), Hook);
end;
function WStrSize(s: PWideChar): integer; inline;
var
p : PWideChar;
begin
if s = nil then
result := 0
else begin
p := s;
while p^ <> #0 do inc(p);
result := cardinal(p) - cardinal(s)
end;
end;
function doWStrAlloc(len: Integer): PWideStr; inline;
begin
GetMem(result, size_str + len + 2);
result.refcnt := 1;
result.Id0 := str_id_0;
result.Id1 := str_id_1;
result.Id2 := str_id_2;
result.length := len;
PWideChar(@PAnsiChar(result)[size_str+len])^ := #0;
end;
function doWStrCopy(s: PWideStr): PWideStr; inline;
begin
if (s.Id2 = str_id_2) and
(s.Id1 = str_id_1) and
(s.Id0 = str_id_0)
then begin
InterlockedIncrement(s.refcnt);
result := s;
end
else begin
result := doWStrAlloc(s.length);
Move(PAnsiChar(s)[size_str], PAnsiChar(result)[size_str], s.length);
end;
end;
function WStrCopy(s: PWideStr): PWideStr; inline;
begin
if s = nil then
result := nil
else begin
Dec(S);
if (s.Id2 = str_id_2) and
(s.Id1 = str_id_1) and
(s.Id0 = str_id_0)
then begin
InterlockedIncrement(s.refcnt);
result := @PAnsiChar(s)[size_str];
end
else begin
result := @PAnsiChar(doWStrAlloc(s.length))[size_str];
Move(PAnsiChar(s)[size_str], result^, s.length);
end;
end;
end;
function WStrLCopy(s: PWideStr; len: integer): PWideStr; inline;
begin
result := doWStrAlloc(len);
Inc(result);
if Assigned(s) then
Move(s^, result^, len);
end;
procedure doWStrFree(s: PWideStr); inline;
begin
if (s.Id2 = str_id_2) and
(s.Id1 = str_id_1) and
(s.Id0 = str_id_0)
then
if InterlockedDecrement(s.refcnt) = 0 then
FreeMem(s);
end;
procedure WStrFree(s: PWideStr); inline;
begin
if Assigned(s) then begin
Dec(s);
if (s.Id2 = str_id_2) and
(s.Id1 = str_id_1) and
(s.Id0 = str_id_0)
then
if InterlockedDecrement(s.refcnt) = 0 then
FreeMem(s);
end;
end;
function xWStrClr(var S: PWideStr): PWideStr;
begin
result := @S;
WStrFree(s);
S := nil;
end;
procedure xWStrAsg(var Dest: PWideStr; Source: PWideStr);
var
t : PWideStr;
begin
t := Dest;
if t <> Source then begin
WStrFree(t);
if Source = nil then
Dest := nil
else begin
Dec(Source);
t := doWStrCopy(Source);
Dest := @PAnsiChar(t)[size_str];
end;
end;
end;
function xWStrAddRef(var s: PWideStr): Pointer;
begin
result := WStrCopy(s);
end;
procedure xWStrArrayClr(s: PPWideStr; Count: Integer);
var
t : PWideStr;
begin
while Count > 0 do begin
t := s^;
WStrFree(t);
Inc(s);
Dec(count);
end;
end;
procedure xWStrFromPWCharLen(var Dest: PWideStr; Source: PWideStr; Len: Integer);
begin
WStrFree(Dest);
Dest := WStrLCopy(Source, Len*2);
end;
procedure xWStrFromWChar(var Dest: PWideStr; Source: WideChar);
var
t : PWideStr;
begin
if (Dest = nil) or (PWideChar(Dest)^ <> Source) then begin
WStrFree(Dest);
t := doWStrAlloc(2);
Inc(t);
Move(Source, t^, 2);
Dest := t;
end;
end;
procedure xWStrFromPWChar(var Dest: PWideStr; Source: PWideStr);
var
t : PWideStr;
begin
t := WStrLCopy(Source, WStrSize(PWideChar(Source)));
WStrFree(Dest);
Dest := t;
end;
function xNewWideString(Len: Longint): PWideStr;
begin
result := doWStrAlloc(Len*2);
Inc(result);
end;
procedure xSysFreeString(s: PWideStr); stdcall;
begin
WStrFree(s);
end;
function xSysAllocString(s: PWideStr): PWideStr; stdcall;
begin
result := WStrLCopy(s, WStrSize(PWideChar(s)));
end;
function xSysAllocStringLen(s: PWideStr; len: Integer): PWideStr; stdcall;
begin
result := WStrLCopy(s, len * 2);
end;
function xSysAllocStringByteLen (s: pointer; len: Integer): PWideStr; stdcall;
begin
result := WStrLCopy(s, len);
end;
function xSysReAllocStringLen(var p: PWideStr; s: PWideStr; len: Integer): LongBool; stdcall;
begin
if s <> p then begin
WStrFree(p);
p := WStrLCopy(s, len * 2);
end;
result := true;
end;
function pWStrClr: pointer;
asm
mov eax, OFFSET System.@WStrClr
end;
function pWStrAddRef: pointer;
asm
mov eax, OFFSET System.@WStrAddRef
end;
function pWStrAsg: pointer;
asm
mov eax, OFFSET System.@WStrAsg
end;
function pWStrLAsg: pointer;
asm
mov eax, OFFSET System.@WStrLAsg
end;
function pWStrArrayClr : pointer;
asm
mov eax, OFFSET System.@WStrArrayClr
end;
function pWStrFromPWCharLen : pointer;
asm
mov eax, OFFSET System.@WStrFromPWCharLen
end;
function pWStrFromWChar : pointer;
asm
mov eax, OFFSET System.@WStrFromWChar
end;
function pWStrFromPWChar : pointer;
asm
mov eax, OFFSET System.@WStrFromPWChar
end;
function pNewWideString : pointer;
asm
mov eax, OFFSET System.@NewWideString
end;
procedure FastWideStringInit;
var
handle : cardinal;
protect : cardinal;
mem : TMemoryBasicInformation;
begin
VirtualQuery(pWStrAddRef, mem, sizeof(mem));
VirtualProtect(mem.AllocationBase, mem.RegionSize, PAGE_EXECUTE_READWRITE, protect);
HookCode(pWStrClr, @xWStrClr);
HookCode(pWStrAsg, @xWStrAsg);
HookCode(pWStrLAsg, @xWStrAsg);
HookCode(pWStrAddRef, @xWStrAddRef);
HookCode(pWStrArrayClr, @xWStrArrayClr);
HookCode(pWStrFromPWCharLen, @xWStrFromPWCharLen);
HookCode(pWStrFromWChar, @xWStrFromWChar);
HookCode(pWStrFromPWChar, @xWStrFromPWChar);
HookCode(pNewWideString, @xNewWideString);
VirtualProtect(mem.AllocationBase, mem.RegionSize, protect, protect);
handle := GetModuleHandle(oleaut);
if handle = 0 then
handle := LoadLibrary(oleaut);
VirtualQuery(GetProcAddress(handle, 'SysAllocString'), mem, sizeof(mem));
VirtualProtect(mem.AllocationBase, mem.RegionSize, PAGE_EXECUTE_READWRITE, protect);
HookProc(handle, 'SysAllocString', @xSysAllocString);
HookProc(handle, 'SysAllocStringLen', @xSysAllocStringLen);
HookProc(handle, 'SysAllocStringByteLen', @xSysAllocStringByteLen);
HookProc(handle, 'SysReAllocStringLen', @xSysReAllocStringLen);
HookProc(handle, 'SysFreeString', @xSysFreeString);
VirtualProtect(mem.AllocationBase, mem.RegionSize, protect, protect);
end;
initialization
//FastWideStringInit;
end.