{ +-------------------------------------------------------------+ }
{ |                                                             | }
{ |   GM-Software                                               | }
{ |   ===========                                               | }
{ |                                                             | }
{ |   Project: All Projects                                     | }
{ |                                                             | }
{ |   Description: Override the system LoadResStr routine       | }
{ |                                                             | }
{ |                                                             | }
{ |   Copyright (C) - 2003 - Gerrit Moeller.                    | }
{ |                                                             | }
{ |   Source code distributed under MIT license.                | }
{ |                                                             | }
{ |   See: https://www.gm-software.de                           | }
{ |                                                             | }
{ +-------------------------------------------------------------+ }

{$INCLUDE GMCompilerSettings.inc}

unit GMLoadResStr;

//
// String resources in different languages can be linked all together to the same module.
// So there is no need for Borlands stupid resource DLL's at all.
// But Borlands System.LoadResStr doesn't recognize languages and always loads the
// String resource with the neutral language.
//
// This unit replaces System.LoadResStr by a function that loads the String resource
// in the language set by vResStrLangId. If there is no String in that language the
// String with the neutral language will be loaded. The neutral strings are always linked
// to the module by Delphi. Additional languages can be linked via $R directives.
//
// See also: http://dybdahl.dk/dxgettext/
//


//
// TGMSimpleCodeHook
// =================
// Original code cannot be called from hooked code because it was overwritten.
// To be able to call then original code the following is needed:
//  - Copy original code to some memory before patching it
//  - Make this memory executable via virtualProtect
//  - Relocate all absolute jumps in the code to respect the new memory location of the code
//  - Relocate all relative jumps to places outside the code to respect the new memory location of the code
//  - Patch original code witch jump to new some routine
//  - Call relocated original code from this new routine
//
// code relocation strongly depends on 8086 processor instruction set.
// It is a lot of work, but I saw implementations doing that ..
//


interface

uses {$IFNDEF JEDIAPI}Windows{$ELSE}jwaWinType{$ENDIF};

type

  TGMHookJumpCode = array [0..4] of Byte;

  TGMSimpleCodeHook = class(TObject)
   // Replaces an existing routine that cannot by changed by another one at runtime.
   // Assumes original code is larger than 5 Bytes (size of a Jump that we patch over it).
   // NOTE: Parameterlists and calling conventions of AOrgRoutine and ANewRoutine must be identical!
   // NOTE: This code works only on i386 compatible processors.
   protected
    FOrgRoutine, FNewRoutine: Pointer;
    FPatchCode, FOriginalCode: TGMHookJumpCode;
    FPatchPtr: Pointer;
    procedure CreatePatchCode(const AFollowJump: Boolean = True);
    procedure WriteCode(const Code: TGMHookJumpCode);

   public
    constructor Create(const AOrgRoutine, ANewRoutine: Pointer; const AInstallHook: Boolean = True; const AFollowJump: Boolean = True);
    destructor Destroy; override;
    procedure InstallHook;
    procedure UnInstallHook;
  end;


const

  cMajorLangMask = $00FF;


  //TCalcLangIdFunc = function: LANGID;

//function CalcDfltLangId: LANGID;

function LoadResStringHook: TGMSimpleCodeHook;


var

  vResStrLangId: LANGID = 0;
  //vfCalcLangId: TCalcLangIdFunc = CalcDfltLangId;


implementation

{$IFDEF JEDIAPI}uses jwaWinBase, jwaWinNT, jwaWinUser, jwaWinNLS;{$ENDIF}

var

  vLoadResStringHook: TGMSimpleCodeHook = nil;


{ --------------------------- }
{ ---- TGMSimpleCodeHook ---- }
{ --------------------------- }

constructor TGMSimpleCodeHook.Create(const AOrgRoutine, ANewRoutine: Pointer; const AInstallHook: Boolean; const AFollowJump: Boolean);
begin
  inherited Create;
  FOrgRoutine := AOrgRoutine;
  FNewRoutine := ANewRoutine;
  CreatePatchCode(AFollowJump);
  if AInstallHook then InstallHook;
end;

destructor TGMSimpleCodeHook.Destroy;
begin
  UnInstallHook;
  FPatchPtr := nil;
  inherited Destroy;
end;

procedure TGMSimpleCodeHook.CreatePatchCode(const AFollowJump: Boolean);
var Offset: LongInt;
begin
  {$IFNDEF CPU386} 'The following code only works on Intel i386 compatible processors.' {$ENDIF}
  UnInstallHook;

  FPatchPtr := FOrgRoutine;
  if AFollowJump and (Word(FOrgRoutine^) = $25FF) then
   begin
    // This finds the correct procedure if a virtual jump has been inserted at the procedure address
    Inc(LongInt(FPatchPtr), 2); // skip the jump
    FPatchPtr := Pointer(Pointer(FPatchPtr^)^);
   end;

  Offset := LongInt(FNewRoutine) - LongInt(FPatchPtr) - SizeOf(TGMHookJumpCode);
  FPatchCode[0] := $E9;
  Move(Offset, FPatchCode[1], SizeOf(Offset));
  Move(FPatchPtr^, FOriginalCode, SizeOf(FOriginalCode));
end;

procedure TGMSimpleCodeHook.WriteCode(const Code: TGMHookJumpCode);
var OldProtect: LongWord;
begin
  if FPatchPtr = nil then Exit;
  if not VirtualProtect(FPatchPtr, SizeOf(Code), PAGE_EXECUTE_READWRITE, {$IFDEF JEDIAPI}@{$ENDIF}OldProtect) then Exit;
  Move(Code, FPatchPtr^, SizeOf(Code));
  if not VirtualProtect(FPatchPtr, SizeOf(Code), OldProtect, {$IFDEF JEDIAPI}@{$ENDIF}OldProtect) then Exit;
  FlushInstructionCache(GetCurrentProcess, FPatchPtr, SizeOf(Code));
end;

procedure TGMSimpleCodeHook.InstallHook;
begin
  WriteCode(FPatchCode);
end;

procedure TGMSimpleCodeHook.UnInstallHook;
begin
  WriteCode(FOriginalCode);
end;


{ ------------------------- }
{ ---- Global Routines ---- }
{ ------------------------- }

{function GMGetLanguage: Word;
begin
  //Language: Word = LANG_GERMAN or SUBLANG_NEUTRAL shl 8;
  // MakeWord(LANG_FRENCH, SUBLANG_NEUTRAL)  LANG_GERMAN, SUBLANG_GERMAN_SWISS
  Result := GetUserDefaultLangID and $FF;
end;}

function LoadResStringHook: TGMSimpleCodeHook;
begin
  Result := vLoadResStringHook;
end;

function AddPtr(const Ptr: Pointer; const Offset: LongInt): Pointer;
begin
  Result := Pointer(LongInt(Ptr) + Offset)
end;

{function CalcDfltLangId: LANGID;
begin
  //vResStrLangId := LoWord(GetThreadLocale) and cMajorLangMask;
  //vResStrLangId := GetUserDefaultLangID and cMajorLangMask; // <- Only use major-Language and set sub-language to SUBLANG_NEUTRAL
  Result := GetUserDefaultLangID and cMajorLangMask;
end;}

function GMLoadResStringA(ResStringRec: PResStringRec): AnsiString;
const cResStrSectionSize = 16; cBufSize = 4096;
var i: LongInt; ResModule: LongWord; HFindRes: HRSRC; HResData: HGLOBAL; PResData: Pointer; PBuf: PAnsiChar;
    //Buffer: array[0..2047] of AnsiChar;
begin
  Result := '';
  if (ResStringRec = nil) then Exit;
  if (ResStringRec.Identifier > $FFFF) then begin Result := PChar(ResStringRec.Identifier); Exit; end;

  ResModule := FindResourceHInstance(ResStringRec.Module^);
  HFindRes := FindResourceEx(ResModule, RT_STRING, MakeIntResource(ResStringRec.Identifier div cResStrSectionSize + 1), vResStrLangId);
  if HFindRes <> 0 then
   begin
    HResData := LoadResource(ResModule, HFindRes);
    if HResData <> 0 then
     try
      PResData := LockResource(HResData);
      if PResData <> nil then
       try
        for i:=1 to ResStringRec.Identifier mod cResStrSectionSize do PResData := AddPtr(PResData, (Word(PResData^) + 1) * SizeOf(WideChar));
        SetLength(Result, WideCharToMultiByte(0, 0, AddPtr(PResData, SizeOf(WideChar)), Word(PResData^), nil, 0, nil, nil));
        WideCharToMultiByte(0, 0, AddPtr(PResData, SizeOf(WideChar)), Word(PResData^), PAnsiChar(Result), Length(Result) + SizeOf(AnsiChar), nil, nil);
        //Exit;
       finally
        UnlockResource(HResData);
       end;
     finally
      FreeResource(HResData);
     end;
   end;

  // This is the Borland default code, will normally be skipped by Exit before
  // Load the String from default String-table if empty
  if Result = '' then
   begin
    GetMem(PBuf, cBufSize);
    try
     SetString(Result, PBuf, LoadStringA(ResModule, ResStringRec.Identifier, PBuf, cBufSize));
    finally
     FreeMem(PBuf);
    end;
   end;
end;

{procedure InitLangId;
begin
  try
   vResStrLangId := CalcLang.CalcLangId;
  except
   vResStrLangId := GetUserDefaultLangID and cMajorLangMask;
  end;
end;}

initialization

  vResStrLangId := GetUserDefaultLangID and cMajorLangMask;
  vLoadResStringHook := TGMSimpleCodeHook.Create(@System.LoadResString, @GMLoadResStringA, True, True);

finalization

  if vLoadResStringHook <> nil then begin vLoadResStringHook.Free; vLoadResStringHook := nil; end;

end.