[Admin]

Имя (Ник): Дмитрий Игнатьев
E-mail / Адрес сайта: dign@yandex.ru
Описание исходника: Быстрый WideString для ускорения операций со строковыми переменными для Delphi путем перехвата различных функций.

Код:

{*******************************************************}
{                                                       }
{         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.