midasmempatch.pas

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

//////////////////////////////////////////////////////////////////////////////////////
//
//    ----- MIDAS PATCH -----
//  Version 2.07
//
//  Read this information carefully before using this patch!!!
//
//
//  FUNCTION
//
//    This unit is a patch for the midas.dll. It is build to eliminate the
//    'Insufficient memory for this operation'-error which can occur in midas
//    communication.
//    An interesting side-effect of the patch is nice performance improvement.
//    (see the test results below)
//
//  TECH DETAILS
//
//    The reason for the error in midas.dll is the usage of the -GlobalAlloc-
//    Api call, for allocating memory. This api call has only got 65K handles,
//    and will return a no-more-memory message when there are no more free handles,
//    although there is more free memory.
//    The solution is to use the default Delphi memory manager or HeapAlloc(), or
//    some other  memory manager for memory allocation.
//    Using another memory manager can even result in better performance!!
//    (see the test results below)
//
//  USAGE
//
//    Just include this unit in your at the top of the uses clause in your project.
//    If you are using another memory manager like ShareMem, which also has to be at the
//    top in the uses clause, then put it right after that one.
//
//          Example 1:
//               program Project27;
//                 uses
//                   MidasMemPatch in 'MidasMemPatch.pas',
//                   Forms,
//                   {...}
//          Example 2:
//               program Project27;
//                 uses
//                   MidasMemPatch in 'MidasMemPatch.pas',
//                   MidasLib,
//                   Forms,
//                   {...}
//          Example 3:
//               program Project27;
//                 uses
//                   Sharemem,
//                   MidasMemPatch in 'MidasMemPatch.pas',
//                   Forms,
//                   {...}
//
//  SELECTING MEMORY MANAGER
//
//    You can select the memory manager to use by changing the DEFINE statements.
//       Delphi Memory Manager:             [ Selected by DEFAULT ]
//               {DEFINE  HEAPALLOC}
//               {$DEFINE MEMMGR}
//       HeapAlloc:
//               {$DEFINE HEAPALLOC}
//               {DEFINE MEMMGR}
//       GlobalAlloc:                       ( is the old situation )
//               {DEFINE HEAPALLOC}
//               {DEFINE MEMMGR}
//    When using an other memory manager like ShareMem, use the Default (DelphiMM)
//    settings!
//
//  CHECKING WHETHER PATCH IS APPLIED OR NOT
//    To check whether patch is applied or not you can query the PatchApllied
//    in this unit.
//
//  NOTES
//
//    When using the patch in a project which links the midas-library using the
//    'MidasLib' include, you can get poor performance when you use the Default
//    Memory Manager.
//    In this case it is better to use the HeapAlloc option, or use Delphi Memory
//    Manager option with another memory manager Like ShareMem or MultiMM.
//
//  2003-08-27
//  (c) Manuel Eduardo Parma
//  Argentina
//  [e-mail]
//  Any feedback is welcome!
//
//  Disclaimer:
//    The code and text in this unit are not associated with Borland. This unit is
//    provided "as is"! The author takes no responsibility for use, or misuse, of
//    this unit. Usage of this code is at your own risk.
//  License:
//    You are free to use this unit in any way, but beware that the midas.dll is an
//    official Borland product, and therefore bound by the terms and conditions of
//    the Borland product license.
//
//////////////////////////////////////////////////////////////////////////////////////
// Thanks to:
//         Adrian Gallero for your version code!
//         Robert Lee for your MultiMM and patch code!
//         Janne Timmerbacka for your "Overflow checking" observation.
//         Dave Rowntree for guide me with Raid and QC.
//  And specially to:
//         Michiel Spoor for your help to re-write this explanation!
//         Dan Miser for support me all these years!!! :)
////////////////////////////////////////////////////////////////////////////////////////
//
//
//  What's New?
//    2.07 Support for Delphi 7 Service Pack 1 Public Beta Midas.dll 7.1.1692.668
//         and Automatic detect for different midaslib in version 7
//    2.06 Fix for bad midaslib compilation
//    2.05 Support for Delphi 7 Service Pack 1 Midas.dll 7.1.1692.666
//    2.04 Fix Default Memory Manger to Internal Delphi
//    2.03 Change assembly code. More clear functions
//    2.02 Fix compile error problem in Delphi 5. 
//    2.01 Support MidasLIb RTLVersion = 14.31 and Optimization Off for Project
//         Compile
//    2.00 MidasMemPatch choose automaticaly the correct midas version to patch.
//         The patch is not applied for others not supported midas.dll.
//
//         Midas Patch take care about Re-Patching when this unit is included in
//         both .exe and dll. and about using MidasLib
//
//         MidasLib Support for Delphi 6 SP2 and Delphi 7.0
//
//    1.00 Support Midas.dll ver 7.0.4.453 or 7.0.1.716 (Delphi 7),
//         6.0.10.157 (Delphi 6) and 5.0.6.18 (Delphi 5)
//
//  Test
//      Memory patch can improve perfomace from 1.2 to 2.8 times, because
//      Realloc routine is more quickly.
//
//
//      {Perfomance Test PIII 600 Mhs 1GB RAM
//
//  Code 1:
//  var
//    I : Integer;
//    a : cardinal;
//  begin
//    a := GetTickCount;
//
//    with ClientDataSet1.FieldDefs do
//    begin
//      Add('Name', ftInteger, 0, False);
//    end;
//
//    ClientDataSet1.CreateDataSet;
//    ClientDataSet1.LogChanges := True;
//
//    for I := 0 to 65530 do
//    begin
//      ClientDataSet1.Append;
//      ClientDataSet1.Fields[0].Asstring := inttostr(i);
//      ClientDataSet1.post;
//    end;
//
//    Label1.Caption := InttoStr(GetTickCount - a);
//////////////////////////////////////////////////////////////////////////////////////
//
//  Code 2:
//  var
//    I : Integer;
//    a : cardinal;
//    v: olevariant;
//  begin
//    a := GetTickCount;
//
//    with ClientDataSet1.FieldDefs do
//    begin
//      Add('Name', ftInteger, 0, False);
//      Add('Blob', ftMemo, 0, False);
//    end;
//
//    ClientDataSet1.CreateDataSet;
//    ClientDataSet1.LogChanges := True;
//
//    for I := 0 to 65530 do
//    begin
//      ClientDataSet1.Append;
//      ClientDataSet1.Fields[0].Asstring := inttostr(i);
//      ClientDataSet1.Fields[1].asstring:= 'test '+ inttostr(I);
//      ClientDataSet1.post;
//    end;
//
//    Label1.Caption := InttoStr(GetTickCount - a);
//    exit;
//////////////////////////////////////////////////////////////////////////////////////
//
//  Results:
//  Note: Times in miliseconds
//        Midas.dll Native is internal midas.dll memory manager
//
//  (Code 1)
//  Records   Midas.dll Native  HeapAlloc       Delphi MM
//  65530     33708 (180.9%)    18777 (100.8%)  18627 (100%)
//  50000     19387 (186.5%)    10836 (104.2%)  10395 (100%)
//  25000      4587 (171.6%)     2844 (106.4%)   2673 (100%)
//  10000       711 (157.6%)      511 (113.3%)    451 (100%)
//   1000        40 (200.0%)       20 (100.0%)     20 (100%)
//
//  Results: Delphi MM is 1.5 to 2 times more quickly than midas native MM
//
//  (Code 2) Records with blobs
//  Records   Midas.dll Native      HeapAlloc       Delphi MM
//  65530     Insufficient memory   44204 (100.8%)  38986 (100%)
//  50000     32817 (147.6%)        25367 (114.1%)  22231 (100%)
//  25000      8242 (148.8%)         6459 (116.6%)   5538 (100%)
//  10000      1462 (163.9%)         1172 (131.4%)    892 (100%)
//   1000        60 (150.0%)           50 (125.0%)     40 (100%)
//
//  Results: Delphi MM is 1.5 times more quickly than midas native MM with Bolbs
//////////////////////////////////////////////////////////////////////////////////////


{$OPTIMIZATION ON}

{Default Memory manager is Delphi Memory Manager with
 DEFINE HEAPALLOC = OFF   and  DEFINE MEMMGR = ON}

{DEFINE HEAPALLOC}
{$DEFINE MEMMGR}

{ACTIVATE OR DEACTIVATE PATCH}
{$DEFINE ACTIVEPATCH}



unit MidasMemPatch;

interface

var
  PatchApllied: boolean = False;

implementation

uses
  Windows, SysUtils, MidConst, ComObj, DsIntf;


type
  PPatch = ^TPatch;
  TPatch = packed record
    Operator: byte;
    Distance: integer;
  end;


var
  MidAllocMem, MidFreeMem, MidReAllocMem, MidCallocMem: Pointer;
  NewCode: TPatch = (Operator:$E9; Distance:0);
  hLibrary: HMODULE = 0;

  {$IFDEF HEAPALLOC}
  Heap: Cardinal;
  {$ENDIF}

  AddAllocMem, AddCallocMem, AddFreeMem, AddReAllocMem: cardinal;


{$IFDEF HEAPALLOC}
const
//  HEAP_NO_SERIALIZE = $00000001; {verdadero}
  HEAP_NO_SERIALIZE = $00000000; {serializado}
  HEAP_ZERO_MEMORY = $00000008;
  HEAP_GENERATE_EXCEPTIONS = $00000004;
  (*
#define HEAP_GROWABLE                   0x00000002
#define HEAP_GENERATE_EXCEPTIONS        0x00000004
#define HEAP_ZERO_MEMORY                0x00000008
#define HEAP_REALLOC_IN_PLACE_ONLY      0x00000010
#define HEAP_TAIL_CHECKING_ENABLED      0x00000020
#define HEAP_FREE_CHECKING_ENABLED      0x00000040
#define HEAP_DISABLE_COALESCE_ON_FREE   0x00000080
#define HEAP_CREATE_ALIGN_16            0x00010000
#define HEAP_CREATE_ENABLE_TRACING      0x00020000
#define HEAP_MAXIMUM_TAG                0x0FFF
#define HEAP_PSEUDO_TAG_FLAG            0x8000
#define HEAP_TAG_SHIFT                  18
#define HEAP_MAKE_TAG_FLAGS( b, o ) ((DWORD)((b) + ((o) << 18)))
  *)

procedure AllocateHeap;
begin
  Heap := HeapCreate(HEAP_NO_SERIALIZE OR HEAP_GENERATE_EXCEPTIONS, 0, 0);
end;

procedure DeallocateHeap;
begin
  HeapDestroy(Heap);
end;

{$ENDIF}

function NewMidAllocMem(Bytes: cardinal): Pointer; stdcall;
{$IFNDEF HEAPALLOC}
{$IFDEF MEMMGR}
var
  Res: Pointer;
{$ENDIF}
{$ENDIF}
begin
  {$IFDEF HEAPALLOC}
    result := HeapAlloc(Heap, HEAP_NO_SERIALIZE OR HEAP_GENERATE_EXCEPTIONS	, Bytes);
  {$ELSE}
      {$IFDEF MEMMGR}
        GetMem(Res, Bytes);
        result := Res;
      {$ELSE}
        result := GlobalAllocPtr(HeapAllocFlags, Bytes);
      {$ENDIF}
  {$ENDIF}
end;

function NewMidFreeMem(Mem: Pointer): integer; stdcall;
begin
  {$IFDEF HEAPALLOC}
    HeapFree(Heap, HEAP_NO_SERIALIZE, Mem);
  {$ELSE}
    {$IFDEF MEMMGR}
      FreeMem(Mem);
    {$ELSE}
      GlobalFreePtr(Mem);
    {$ENDIF}
  {$ENDIF}

  result := 1;
end;

function NewMidReallocMem(Mem: Pointer; Size: Cardinal; NewSize: Cardinal): Pointer; stdcall;
{$IFNDEF HEAPALLOC}
{$IFDEF MEMMGR}
var
  Res: Pointer;
{$ENDIF}
{$ENDIF}
begin
  if Mem = nil then
  begin
    {$IFDEF HEAPALLOC}
      result := HeapAlloc(Heap, HEAP_NO_SERIALIZE or HEAP_ZERO_MEMORY or
                                HEAP_GENERATE_EXCEPTIONS, NewSize);
    {$ELSE}
      {$IFDEF MEMMGR}
        GetMem(Res, NewSize);
        result := Res;
      {$ELSE}
        result := GlobalAllocPtr(HeapAllocFlags, NewSize);
      {$ENDIF}
      if (NewSize) > 0 then
        FillChar((result)^, NewSize, 0);
    {$ENDIF}
  end
  else
  begin
    {$IFDEF HEAPALLOC}
      result := HeapReAlloc(Heap, HEAP_NO_SERIALIZE or HEAP_ZERO_MEMORY or
                                  HEAP_GENERATE_EXCEPTIONS, Mem, NewSize);
    {$ELSE}
      {$IFDEF MEMMGR}
        ReallocMem(Mem, NewSize);
        result := Mem;
      {$ELSE}
        result := GlobalReAllocPtr(Mem, NewSize, HeapAllocFlags);
      {$ENDIF}

      if (NewSize - Size) > 0 then
        FillChar(Pointer(Cardinal(result) + Size)^, NewSize - Size , 0);
    {$ENDIF}