Mastering Visual Basic 6/mastvb6.iso/numega/sc501.exe/data1.cab/Examples/MEMORY.PAS

Pascal/Delphi Source File | 1997-11-25 | 5.1 KB | 217 lines

(*
 * Memory.PAS
 * $Header: /Old/bcsample/BUGBNCHX/DLPHIERR/MEMORY.PAS 2     8/28/96 11:02a Bob $
 *
 * Description:
 *     File includes routines for the LeakCheck and WriteCheck options
 *     on the tree control.
 *
 * Notes:
 *  <implementation notes go here>
 *
 ***********************************************************************
 *
 * Nu-Mega Technologies, Inc.
 * P.O. Box 7780
 * Nashua, NH 03060
 *
 * (c) Copyright 1994, 1995 Nu-Mega Technologies, Inc.
 * ALL RIGHTS RESERVED.
 *
 ***********************************************************************
 *
 **********************************************************************)

(*
   AllocMem_Leak allocates a pointer using the function AllocMem and does
   not free it.  This error will appear at the end of the BoundsChecker
   session.
*)
procedure AllocMem_Leak;
var
  testPointer: Pointer;
begin
  testPointer := AllocMem ( 25 );
end;

(*
   StrAlloc_Leak allocates a string through StrAlloc.  This string is not
   freed.  This error will appear at the end of the BoundsChecker session.
*)
procedure StrAlloc_Leak;
var
  testPChar: PChar;
begin
  testPChar := StrAlloc ( 5 );
end;

(*
   StrNew allocates a string that the user must free.  If the user does
   not, it is reported as a memory leak by BoundsChecker.
*)
procedure MemoryLeak_StrNew;
var
   testString :PChar;
begin
   testString := StrNew ( 'This is a leak ');
end;


(*
   BitmapLeak creates/loads a bitmap which is not destroyed upon program
   termination.  This leads to low resources.  This error is reported at the
   end of the BoundsChecker session.
*)
procedure BitmapLeak;
var
   hBitmap: THandle;
begin
   hBitmap := CreateBitmap(80,80,1,8,NIL);
end;

(*
   MenuLeak creates/loads a menu which is not destroyed upon program
   termination.  This leads to low resources.  This error is reported at the
   end of the BoundsChecker session.
*)
procedure MenuLeak;
var
   hMenu: THandle;
begin
   hMenu := CreateMenu;
end;

(*
   DynamicOverrun is when a dynamically allocated piece of memory is overrun.
   BoundsChecker will catch this type of overrun, reporting which allocated
   block was overrun.
*)
procedure DynamicOverrun;
var
   count : Integer;
   Overrun2: PChar;
begin
   try
      Overrun2 := StrAlloc (4);
      for count := 1 TO 5 do
         Overrun2[count] := 'x';
      StrDispose ( Overrun2 );
   except
   end;
end;

(*
   Stack variables can be overrun as well, causing stack corruption leading
   to GPFs.  BoundsChecker will catch this error before the offending
   instruction is actually executed.
*)
procedure StackOverrun;
var
  FrontBuffer: array[0..8] of char;
  ToOverrun : array[0..5] of char;
  BackBuffer:array[0..8] of char;
begin
   try
      FrontBuffer[0] := 'a';
      FrontBuffer[1] := 'b';
      FrontBuffer[2] := 'a';
      FrontBuffer[3] := 'b';
      FrontBuffer[4] := 'a';
      FrontBuffer[5] := 'b';
      FrontBuffer[6] := 'a';
      FrontBuffer[7] := 'b';
      FrontBuffer[8] := 'a';
      StrCopy ( ToOverrun, 'Overrun');
      BackBuffer[0] := 'a';
      BackBuffer[1] := 'b';
      BackBuffer[2] := 'a';
      BackBuffer[3] := 'b';
      BackBuffer[4] := 'a';
      BackBuffer[5] := 'b';
      BackBuffer[6] := 'a';
      BackBuffer[7] := 'b';
      BackBuffer[8] := 'a';
   except
   end;
end;

(*
   Overrun a stack variable using the FillChar routine.  Simply copying
   too many bytes to the stack variable.
*)
procedure StackOverrun_FillChar;
var
  FrontBuffer: array[0..8] of char;
   ToOverrun :array[0..5] of char;
  BackBuffer:array[0..8] of char;
begin
   try
      FrontBuffer[0] := 'a';
      FrontBuffer[1] := 'b';
      FrontBuffer[2] := 'a';
      FrontBuffer[3] := 'b';
      FrontBuffer[4] := 'a';
      FrontBuffer[5] := 'b';
      FrontBuffer[6] := 'a';
      FrontBuffer[7] := 'b';
      FrontBuffer[8] := 'a';
      FillChar ( ToOverrun, 7, ' ');
      BackBuffer[0] := 'a';
      BackBuffer[1] := 'b';
      BackBuffer[2] := 'a';
      BackBuffer[3] := 'b';
      BackBuffer[4] := 'a';
      BackBuffer[5] := 'b';
      BackBuffer[6] := 'a';
      BackBuffer[7] := 'b';
      BackBuffer[8] := 'a';
   except
   end;
end;

procedure Overrun_Record_Element;
type
  recordtype = Record
             Element1 :string[4];
             Element2 :array[0..4] of char;
             Element3 :DWORD;
             Element4 :string;
   end;
var
   myrec : recordtype;
begin
   try
      StrLCopy ( PChar(Addr(myrec.Element1)), 'Overrun', 6);
   except
   end;
end;

procedure Ptr_Refs_Unlocked_Block;
var
   Flip: HGLOBAL;
   Flap: PChar;
begin
   try
      Flip := GlobalAlloc ( GHND, $100 );
      Flap := GlobalLock ( Flip );
      GlobalUnlock ( Flip );
      StrCopy ( Flap, 'Block is unlocked');
      GlobalFree ( Flip );
   except
   end;
end;


procedure Use_Block_After_Free;
var
   String1 : Pointer;
   Destination : array[0..5] of char;
begin
   try
      GetMem ( String1, 10 );
      FreeMem ( String1 );
      StrCopy ( Destination, String1 );
   except
   end;
end;