midasmempatch.pas

成本系统三层结构源码 开发工具：Delphi 7.0+SQLServer 2005 主要技术：Midas、COM+ 所用第三方控件： FastReport V2.47 D7 Inforp

  end;
end;

function NewMidCallocMem(Cant: cardinal; Size: Cardinal): Pointer; stdcall;
{$IFNDEF HEAPALLOC}
var
  i: Cardinal;
{$IFDEF MEMMGR}
  Res: Pointer;
{$ENDIF}
{$ENDIF}
begin
  {$IFDEF HEAPALLOC}
    result := HeapAlloc(Heap, HEAP_NO_SERIALIZE or HEAP_ZERO_MEMORY or
                              HEAP_GENERATE_EXCEPTIONS, Size * Cant);
  {$ELSE}
    i := Size * Cant;
    {$IFDEF MEMMGR}
      GetMem(Res, i);
      result := Res;
    {$ELSE}
      result := GlobalAllocPtr(HeapAllocFlags, i);
    {$ENDIF}
    if result <> nil then
      FillChar((result)^, i, 0);
  {$ENDIF}
end;



procedure CommonPatch(Address, DestAddress: Pointer);
var
  AuxAddr: PPatch;
	OldProtect, Protect: DWord;
  IntAux: Int64;
begin
  if Address <> nil then
  begin
    OldProtect := 0;
    Protect := 0;
    AuxAddr := Address;
    if VirtualProtect(AuxAddr, 5, PAGE_READWRITE, @OldProtect) then
    begin
      IntAux := Int64(DestAddress) - (Int64(AuxAddr) + 5);
      NewCode.Distance := IntAux;
      {Protect for repatch}
      if (AuxAddr^.Operator <> NewCode.Operator) then
      begin
        AuxAddr^ := NewCode;
      end;

      if VirtualProtect(AuxAddr, 5, OldProtect, @Protect) then
        FlushInstructionCache(GetCurrentProcess, AuxAddr, 5);
    end;
  end;
end;


procedure GetAppBuildInfo(const AppName: string);
var
  v1, v2, v3, v4: Word;
  VerInfoSize: DWord;
  VerInfo: Pointer;
  VerValueSize: DWord;
  VerValue: PVSFixedFileInfo;
  Dummy: DWord;
begin
  VerInfoSize := GetFileVersionInfoSize(PChar(AppName), dummy);

  if VerInfoSize <> 0 then
  begin
    GetMem(VerInfo, VerInfoSize);
    try
      GetFileVersionInfo(PChar(AppName), 0, VerInfoSize, VerInfo);
      VerQueryValue(VerInfo, '\', Pointer(VerValue), VerValueSize);

      with VerValue^ do
      begin
        v1 := dwFileVersionMS shr 16;
        v2 := dwFileVersionMS and $FFFF;
        v3 := dwFileVersionLS shr 16;
        v4 := dwFileVersionLS and $FFFF;
      end;

      if (v1 = 7) and (v2 = 1) and (v3 = 1692) and (v4 = 668) then
      begin
        {MIDAS7.1.1692.668}
        AddAllocMem := $28F7C;
        AddCallocMem := $28FB8;
        AddFreeMem := $28FE4;
        AddReAllocMem := $2900C;
      end
      else if (v1 = 7) and (v2 = 1) and (v3 = 1692) and (v4 = 666) then
      begin
        {MIDAS7.1.1692.666}
        AddAllocMem := $28F28;
        AddCallocMem := $28F64;
        AddFreeMem := $28F90;
        AddReAllocMem := $28FB8;
      end
      else if (v1 = 7) and (v2 = 0) and (v3 = 4) and (v4 = 453) then
      begin
        {MIDAS7.0.4.453}
        AddAllocMem := $28764;
        AddCallocMem := $287a0;
        AddFreeMem := $287cc;
        AddReAllocMem := $287f4;
      end
      else if (v1 = 7) and (v2 = 0) and (v3 = 1) and (v4 = 716) then
      begin
        {MIDAS7.0.1.716}
        AddAllocMem := $2855C;
        AddCallocMem := $28598;
        AddFreeMem := $285C4;
        AddReAllocMem := $285EC;
      end
      else if (v1 = 6) and (v2 = 0) and (v3 = 10) and (v4 = 157) then
      begin
        {MIDAS6.0.10.157}
        AddAllocMem := $282d8;
        AddCallocMem := $28314;
        AddFreeMem := $28340;
        AddReAllocMem := $28368;
      end
      else if (v1 = 5) and (v2 = 0) and (v3 = 6) and (v4 = 18) then
      begin
        {MIDAS5.0.6.18}
        AddAllocMem := $25f44;
        AddCallocMem := $25f80;
        AddFreeMem := $25fac;
        AddReAllocMem := $25fd4;
      end;
    finally
      FreeMem(VerInfo, VerInfoSize );
    end;
  end;
end;


procedure PatchMidasLib;
begin
  if MidAllocMem <> nil then
  begin
    CommonPatch(MidAllocMem,@NewMidAllocMem);
    CommonPatch(MidFreeMem,@NewMidFreeMem);
    CommonPatch(MidReAllocMem,@NewMidReAllocMem);
    CommonPatch(MidCallocMem,@NewMidCallocMem);
    PatchApllied := True;
  end;
end;



function LoadExternalDll(const DllName: string; var Handle: HMODULE): Boolean;
begin
  result := False;
  if Handle = 0 then
  begin
    if FileExists(DllName) then
    begin
      try
        Handle := LoadLibrary(PChar(DllName));
        GetAppBuildInfo(DllName);
        result := True;
      except
      end;
    end;
  end;
end;

{$IFDEF VER120} { Borland Delphi 4.0 }
const
  RTLVersion = 12.0;
{$ENDIF}

{$IFDEF VER130} { Borland Delphi 5.0 }
const
  RTLVersion = 13.0;
{$ENDIF}



function CheckRegisterMidasLib: boolean;
{$IFNDEF VER120} { Borland Delphi 4.0 }
  {$IFNDEF VER130} { Borland Delphi 5.0 }
  var
    Address, BaseHandle: Cardinal;
    Pbt: PByteArray;
    Bt: Byte;
    sVersion: string;
  {$ENDIF}
{$ENDIF}
begin
  if (RTLVersion >= 14.0) then
  begin
    {$IFNDEF VER120} { Borland Delphi 4.0 }
      {$IFNDEF VER130} { Borland Delphi 5.0 }
        Address := Cardinal(@RegisterMidasLib);
        Pbt := Pointer(Address);
        Bt := Pbt^[0];
        {Check if optimization is on}
        if Bt = $A3 then
          Inc(Address, 1)
        else if Bt = $55 then
          Inc(Address, 11)
        else
          Address := 0; {Error you need to remove all break points and to do "Build ALL project"}

        if Address <> 0 then
        begin
          {SearchFor DllGetClassObject}
          hLibrary := Cardinal(Pointer(Pointer(Address)^)^);
          {Search for DbClientHandle}
          Inc(Address, 6);
          BaseHandle := Cardinal(Pointer(Pointer(Address)^)^);
          result := BaseHandle = 1;
        end
        else {#New}
          result := False; {#New}

        if result then
        begin
          if (RTLVersion >= 14.2) and (RTLVersion <= 14.31) then
          begin
            {MidasLib for Delphi 6 SP 2 Build 6.240}
            AddAllocMem := $22a9F;
            AddCallocMem := $22ad8;
            AddFreeMem := $22b04;
            AddReAllocMem := $22b2c;
          end
          else if (RTLVersion = 15.0) then
          begin
//            VerInfoSize := GetFileVersionInfoSize(PChar(AppName), dummy);
            {MidasLib for Delphi 7.0 Build 4.453}
            if PByteArray(Cardinal(hLibrary) + $22f50)^[0] = 85 then
              sVersion := '7.0.'
            else if PByteArray(Cardinal(hLibrary) + $236E2)^[0] = 85 then
              sVersion := '7.1.1692.666'
            else if PByteArray(Cardinal(hLibrary) + $2371F)^[0] = 85 then
              sVersion := '7.1.1692.668'
            else
              sVersion := '';


            if sVersion = '7.0' then
            begin
              AddAllocMem := $22f50;
              AddCallocMem := $22f89;
              AddFreeMem := $22fb5;
              AddReAllocMem := $22fdd;
            end
            else if sVersion = '7.1.1692.666' then
            begin
              AddAllocMem := $236E2;
              AddCallocMem := $2371B;
              AddFreeMem := $23747;
              AddReAllocMem := $2376f;
            end
            else if sVersion = '7.1.1692.668' then
            begin
              AddAllocMem := $2371F;
              AddCallocMem := $23758;
              AddFreeMem := $23784;
              AddReAllocMem := $237AC;
            end;
          end;
        end;
      {$ENDIF}
    {$ENDIF}
  end
  else
    result := False;
end;


procedure LoadLibrary;
var
  Size: Integer;
  FileName: string;
begin
  if not CheckRegisterMidasLib then
  begin
    Size := 256;
    SetLength(FileName, Size);
    if RegQueryValue(HKEY_CLASSES_ROOT, PChar(Format('CLSID\%s\InProcServer32',
      [GUIDToString(CLSID_DSBase)])), PChar(FileName), Size) = ERROR_SUCCESS then
      SetLength(FileName, Size) else
    begin
      FileName := MIDAS_DLL;
      try
        RegisterComServer(FileName);
      except
      end;
    end;

    if LoadExternalDll(FileName, hLibrary) and (hLibrary <> 0) then
    begin
      if AddAllocMem <> 0 then
      begin
        MidAllocMem := Pointer(Cardinal(hLibrary) + AddAllocMem);
        MidCallocMem := Pointer(Cardinal(hLibrary) + AddCallocMem);
        MidFreeMem := Pointer(Cardinal(hLibrary) + AddFreeMem);
        MidReAllocMem := Pointer(Cardinal(hLibrary) + AddReAllocMem);
      end;
    end;
  end
  else
  begin
    {Don't patch}
    if AddAllocMem <> 0 then
    begin
      MidAllocMem := Pointer(Cardinal(hLibrary) + AddAllocMem);
      MidCallocMem := Pointer(Cardinal(hLibrary) + AddCallocMem);
      MidFreeMem := Pointer(Cardinal(hLibrary) + AddFreeMem);
      MidReAllocMem := Pointer(Cardinal(hLibrary) + AddReAllocMem);
    end;
  end;
end;

procedure UnLoadLibrary;
begin
  if hLibrary <> 0 then
  begin
    try
      FreeLibrary(hLibrary);
      hLibrary := 0;
    except
    end;
  end;
end;


var
  OldInit: Pointer;

procedure Initialize;
begin
  try
  {$IFDEF ACTIVEPATCH}
  	LoadLibrary;
    {$IFDEF HEAPALLOC}
      AllocateHeap;
    {$ENDIF}
	  PatchMidasLib;
  {$ENDIF}
  except
  end;
  if OldInit <> nil then TProcedure(OldInit);
end;



initialization
  if RTLVersion < 14.0 then
    Initialize
  else
  begin
    OldInit := InitProc;
    InitProc := @Initialize;
  end;

finalization
  {$IFDEF ACTIVEPATCH}
  	UnLoadLibrary;
    {$IFDEF HEAPALLOC}
      DeallocateHeap;
    {$ENDIF}
  {$ENDIF}
end.