tntsystem.pas

TNT Components Source

  end;
  // check calling code pattern
  if CodeMatchesPatternForUnicode(ReturnAddr) then begin
    // result will probably be assigned to an intermediate AnsiString
    //   on its way to either a WideString or Variant.
    LastWideResString := WideLoadResString(ResStringRec);
    Result := LastWideResString;
    LastResStringValue := Result;
    if Result = '' then
      PLastResString := nil
    else
      PLastResString := PAnsiChar(Result);
  end else begin
    // result will probably be assigned to an actual AnsiString variable.
    PLastResString := nil;
    Result := WideLoadResString(ResStringRec);
  end;
end;

//--------------------------------------------------------------------
//                WStrFromPCharLen()
//
//  This system function is used to assign an AnsiString to a WideString.
//   It has been modified to assign Unicode results from LoadResString.
//     Another purpose of this function is to specify the code page.
//--------------------------------------------------------------------

procedure Custom_System_WStrFromPCharLen(var Dest: WideString; Source: PAnsiChar; Length: Integer);
var
  DestLen: Integer;
  Buffer: array[0..2047] of WideChar;
  Local_PLastResString: Pointer;
begin
  Local_PLastResString := PLastResString;
  if  (Local_PLastResString <> nil)
  and (Local_PLastResString = Source)
  and (System.Length(LastResStringValue) = Length)
  and (LastResStringValue = Source) then begin
    // use last unicode resource string
    PLastResString := nil; { clear for further use }
    Dest := LastWideResString;
  end else begin
    if Local_PLastResString <> nil then
      PLastResString := nil; { clear for further use }
    if Length <= 0 then
    begin
      Dest := '';
      Exit;
    end;
    if Length + 1 < High(Buffer) then
    begin
      DestLen := MultiByteToWideChar(DefaultSystemCodePage, 0, Source, Length, Buffer,
        High(Buffer));
      if DestLen > 0 then
      begin
        SetLength(Dest, DestLen);
        Move(Pointer(@Buffer[0])^, Pointer(Dest)^, DestLen * SizeOf(WideChar));
        Exit;
      end;
    end;
    DestLen := (Length + 1);
    SetLength(Dest, DestLen); // overallocate, trim later
    DestLen := MultiByteToWideChar(DefaultSystemCodePage, 0, Source, Length, Pointer(Dest),
      DestLen);
    if DestLen < 0 then
      DestLen := 0;
    SetLength(Dest, DestLen);
  end;
end;

{$IFNDEF COMPILER_9_UP}

//--------------------------------------------------------------------
//                LStrFromPWCharLen()
//
//  This system function is used to assign an WideString to an AnsiString.
//   It has not been modified from its original purpose other than to specify the code page.
//--------------------------------------------------------------------

procedure Custom_System_LStrFromPWCharLen(var Dest: AnsiString; Source: PWideChar; Length: Integer);
var
  DestLen: Integer;
  Buffer: array[0..4095] of AnsiChar;
begin
  if Length <= 0 then
  begin
    Dest := '';
    Exit;
  end;
  if Length + 1 < (High(Buffer) div sizeof(WideChar)) then
  begin
    DestLen := WideCharToMultiByte(DefaultSystemCodePage, 0, Source,
      Length, Buffer, High(Buffer),
      nil, nil);
    if DestLen >= 0 then
    begin
      SetLength(Dest, DestLen);
      Move(Pointer(@Buffer[0])^, PAnsiChar(Dest)^, DestLen);
      Exit;
    end;
  end;

  DestLen := (Length + 1) * sizeof(WideChar);
  SetLength(Dest, DestLen); // overallocate, trim later
  DestLen := WideCharToMultiByte(DefaultSystemCodePage, 0, Source, Length, Pointer(Dest), DestLen,
    nil, nil);
  if DestLen < 0 then
    DestLen := 0;
  SetLength(Dest, DestLen);
end;

//--------------------------------------------------------------------
//                WStrToString()
//
//  This system function is used to assign an WideString to an short string.
//   It has not been modified from its original purpose other than to specify the code page.
//--------------------------------------------------------------------

procedure Custom_System_WStrToString(Dest: PShortString; const Source: WideString; MaxLen: Integer);
var
  SourceLen, DestLen: Integer;
  Buffer: array[0..511] of AnsiChar;
begin
  if MaxLen > 255 then MaxLen := 255;
  SourceLen := Length(Source);
  if SourceLen >= MaxLen then SourceLen := MaxLen;
  if SourceLen = 0 then
    DestLen := 0
  else begin
    DestLen := WideCharToMultiByte(DefaultSystemCodePage, 0, Pointer(Source), SourceLen,
      Buffer, SizeOf(Buffer), nil, nil);
    if DestLen > MaxLen then DestLen := MaxLen;
  end;
  Dest^[0] := Chr(DestLen);
  if DestLen > 0 then Move(Buffer, Dest^[1], DestLen);
end;

{$ENDIF}

//--------------------------------------------------------------------
//                VarFromLStr()
//
//  This system function is used to assign an AnsiString to a Variant.
//   It has been modified to assign Unicode results from LoadResString.
//--------------------------------------------------------------------

procedure Custom_System_VarFromLStr(var V: TVarData; const Value: AnsiString);
const
  varDeepData = $BFE8;
var
  Local_PLastResString: Pointer;
begin
  if (V.VType and varDeepData) <> 0 then
    VarClear(PVariant(@V)^);

  Local_PLastResString := PLastResString;
  if  (Local_PLastResString <> nil)
  and (Local_PLastResString = PAnsiChar(Value))
  and (LastResStringValue = Value) then begin
    // use last unicode resource string
    PLastResString := nil; { clear for further use }
    V.VOleStr := nil;
    V.VType := varOleStr;
    WideString(Pointer(V.VOleStr)) := Copy(LastWideResString, 1, MaxInt);
  end else begin
    if Local_PLastResString <> nil then
      PLastResString := nil; { clear for further use }
    V.VString := nil;
    V.VType := varString;
    AnsiString(V.VString) := Value;
  end;
end;

{$IFNDEF COMPILER_9_UP}

//--------------------------------------------------------------------
//                WStrCat3()     A := B + C;
//
//  This system function is used to concatenate two strings into one result.
//    This function is added because A := '' + '' doesn't necessarily result in A = '';
//--------------------------------------------------------------------

procedure Custom_System_WStrCat3(var Dest: WideString; const Source1, Source2: WideString);

  function NewWideString(CharLength: Longint): Pointer;
  var
    _NewWideString: function(CharLength: Longint): Pointer;
  begin
    asm
      PUSH   ECX
      MOV    ECX, offset System.@NewWideString;
      MOV    _NewWideString, ECX
      POP    ECX
    end;
    Result := _NewWideString(CharLength);
  end;

  procedure WStrSet(var S: WideString; P: PWideChar);
  var
    Temp: Pointer;
  begin
    Temp := Pointer(InterlockedExchange(Integer(S), Integer(P)));
    if Temp <> nil then
      WideString(Temp) := '';
  end;

var
  Source1Len, Source2Len: Integer;
  NewStr: PWideChar;
begin
  Source1Len := Length(Source1);
  Source2Len := Length(Source2);
  if (Source1Len <> 0) or (Source2Len <> 0) then
  begin
    NewStr := NewWideString(Source1Len + Source2Len);
    Move(Pointer(Source1)^, Pointer(NewStr)^, Source1Len * sizeof(WideChar));
    Move(Pointer(Source2)^, NewStr[Source1Len], Source2Len * sizeof(WideChar));
    WStrSet(Dest, NewStr);
  end else
    Dest := '';
end;

{$ENDIF}

//--------------------------------------------------------------------
//                System proc replacements
//--------------------------------------------------------------------

type
  POverwrittenData = ^TOverwrittenData;
  TOverwrittenData = record
    Location: Pointer;
    OldCode: array[0..6] of Byte;
  end;

procedure OverwriteProcedure(OldProcedure, NewProcedure: pointer; Data: POverwrittenData = nil);
{ OverwriteProcedure originally from Igor Siticov }
{ Modified by Jacques Garcia Vazquez }
var
  x: PAnsiChar;
  y: integer;
  ov2, ov: cardinal;
  p: pointer;
begin
  if Assigned(Data) and (Data.Location <> nil) then
    exit; { procedure already overwritten }

  // need six bytes in place of 5
  x := PAnsiChar(OldProcedure);
  if not VirtualProtect(Pointer(x), 6, PAGE_EXECUTE_READWRITE, @ov) then
    RaiseLastOSError;

  // if a jump is present then a redirect is found
  // $FF25 = jmp dword ptr [xxx]
  // This redirect is normally present in bpl files, but not in exe files
  p := OldProcedure;

  if Word(p^) = $25FF then
  begin
    Inc(Integer(p), 2); // skip the jump
    // get the jump address p^ and dereference it p^^
    p := Pointer(Pointer(p^)^);

    // release the memory
    if not VirtualProtect(Pointer(x), 6, ov, @ov2) then
      RaiseLastOSError;

    // re protect the correct one
    x := PAnsiChar(p);
    if not VirtualProtect(Pointer(x), 6, PAGE_EXECUTE_READWRITE, @ov) then
      RaiseLastOSError;
  end;

  if Assigned(Data) then
  begin
    Move(x^, Data.OldCode, 6);
    { Assign Location last so that Location <> nil only if OldCode is properly initialized. }
    Data.Location := x;
  end;

  x[0] := AnsiChar($E9);
  y := integer(NewProcedure) - integer(p) - 5;
  x[1] := AnsiChar(y and 255);
  x[2] := AnsiChar((y shr 8) and 255);
  x[3] := AnsiChar((y shr 16) and 255);
  x[4] := AnsiChar((y shr 24) and 255);

  if not VirtualProtect(Pointer(x), 6, ov, @ov2) then
    RaiseLastOSError;
end;

procedure RestoreProcedure(OriginalProc: Pointer; Data: TOverwrittenData);
var
  ov, ov2: Cardinal;
begin
  if Data.Location <> nil then begin
    if not VirtualProtect(Data.Location, 6, PAGE_EXECUTE_READWRITE, @ov) then
      RaiseLastOSError;
    Move(Data.OldCode, Data.Location^, 6);
    if not VirtualProtect(Data.Location, 6, ov, @ov2) then
      RaiseLastOSError;
  end;
end;

function Addr_System_EndThread: Pointer;
begin
  Result := @System.EndThread;
end;

function Addr_System_LoadResString: Pointer;
begin
  Result := @System.LoadResString{TNT-ALLOW LoadResString};
end;

function Addr_System_WStrFromPCharLen: Pointer;
asm
  mov eax, offset System.@WStrFromPCharLen;
end;

{$IFNDEF COMPILER_9_UP}
function Addr_System_LStrFromPWCharLen: Pointer;
asm
  mov eax, offset System.@LStrFromPWCharLen;
end;

function Addr_System_WStrToString: Pointer;
asm
  mov eax, offset System.@WStrToString;
end;
{$ENDIF}

function Addr_System_VarFromLStr: Pointer;
asm
  mov eax, offset System.@VarFromLStr;
end;

function Addr_System_WStrCat3: Pointer;
asm
  mov eax, offset System.@WStrCat3;
end;

var
  System_EndThread_Code,
  System_LoadResString_Code,
  System_WStrFromPCharLen_Code,
  {$IFNDEF COMPILER_9_UP}
  System_LStrFromPWCharLen_Code,
  System_WStrToString_Code,
  {$ENDIF}
  System_VarFromLStr_Code
  {$IFNDEF COMPILER_9_UP}
  ,
  System_WStrCat3_Code,
  SysUtils_WideFmtStr_Code
  {$ENDIF}
  : TOverwrittenData;

procedure InstallEndThreadOverride;
begin
  OverwriteProcedure(Addr_System_EndThread,  @Custom_System_EndThread,  @System_EndThread_Code);
end;

procedure InstallStringConversionOverrides;
begin
  OverwriteProcedure(Addr_System_WStrFromPCharLen,  @Custom_System_WStrFromPCharLen,  @System_WStrFromPCharLen_Code);
  {$IFNDEF COMPILER_9_UP}
  OverwriteProcedure(Addr_System_LStrFromPWCharLen, @Custom_System_LStrFromPWCharLen, @System_LStrFromPWCharLen_Code);
  OverwriteProcedure(Addr_System_WStrToString,      @Custom_System_WStrToString,      @System_WStrToString_Code);
  {$ENDIF}
end;

procedure InstallWideResourceStrings;
begin
  OverwriteProcedure(Addr_System_LoadResString,     @Custom_System_LoadResString,     @System_LoadResString_Code);
  OverwriteProcedure(Addr_System_VarFromLStr,       @Custom_System_VarFromLStr,       @System_VarFromLStr_Code);
end;

{$IFNDEF COMPILER_9_UP}
procedure InstallWideStringConcatenationFix;
begin
  OverwriteProcedure(Addr_System_WStrCat3,          @Custom_System_WStrCat3,          @System_WStrCat3_Code);
end;

procedure InstallWideFormatFixes;
begin
  OverwriteProcedure(@SysUtils.WideFmtStr, @TntSysUtils.Tnt_WideFmtStr, @SysUtils_WideFmtStr_Code);
end;
{$ENDIF}

procedure InstallTntSystemUpdates(Updates: TTntSystemUpdateSet = AllTntSystemUpdates);
begin
  InstallEndThreadOverride;
  if tsWideResourceStrings in Updates then begin
    InstallStringConversionOverrides;
    InstallWideResourceStrings;
  end;
  {$IFNDEF COMPILER_9_UP}
    if tsFixImplicitCodePage in Updates then begin
      InstallStringConversionOverrides;
      { CP_ACP is the code page used by the non-Unicode Windows API. }
      GDefaultSystemCodePage := CP_ACP{TNT-ALLOW CP_ACP};
    end;
    if tsFixWideStrConcat in Updates then begin
      InstallWideStringConcatenationFix;
    end;
    if tsFixWideFormat in Updates then begin
      InstallWideFormatFixes;
    end;
  {$ENDIF}
end;

{$IFNDEF COMPILER_9_UP}
var
  StartupDefaultUserCodePage: Cardinal;
{$ENDIF}

procedure UninstallSystemOverrides;
begin
  RestoreProcedure(Addr_System_EndThread,  System_EndThread_Code);
  // String Conversion
  RestoreProcedure(Addr_System_WStrFromPCharLen,  System_WStrFromPCharLen_Code);
  {$IFNDEF COMPILER_9_UP}
  RestoreProcedure(Addr_System_LStrFromPWCharLen, System_LStrFromPWCharLen_Code);
  RestoreProcedure(Addr_System_WStrToString,      System_WStrToString_Code);
  GDefaultSystemCodePage := StartupDefaultUserCodePage;
  {$ENDIF}
  // Wide resourcestring
  RestoreProcedure(Addr_System_LoadResString,     System_LoadResString_Code);
  RestoreProcedure(Addr_System_VarFromLStr,       System_VarFromLStr_Code);
  {$IFNDEF COMPILER_9_UP}
  // WideString concat fix
  RestoreProcedure(Addr_System_WStrCat3,          System_WStrCat3_Code);
  // WideFormat fixes
  RestoreProcedure(@SysUtils.WideFmtStr, SysUtils_WideFmtStr_Code);
  {$ENDIF}
end;

initialization
  {$IFDEF COMPILER_9_UP}
  GDefaultSystemCodePage := GetACP;
  {$ELSE}
    {$IFDEF COMPILER_7_UP}
    if (Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion >= 5) then
      GDefaultSystemCodePage := CP_THREAD_ACP // Win 2K/XP/...
    else
      GDefaultSystemCodePage := LCIDToCodePage(GetThreadLocale); // Win NT4/95/98/ME
    {$ELSE}
    GDefaultSystemCodePage := CP_ACP{TNT-ALLOW CP_ACP};
    {$ENDIF}
  {$ENDIF}
  {$IFNDEF COMPILER_9_UP}
  StartupDefaultUserCodePage := DefaultSystemCodePage;
  {$ENDIF}
  IsDebugging := DebugHook > 0;

finalization
  UninstallSystemOverrides;
  FreeTntSystemThreadVars; { Make MemorySleuth happy. }

end.