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

Pascal/Delphi Source File | 1997-11-25 | 5.9 KB | 241 lines

(*
 * ApiErr.PAS
 * $Header: /BoundsChecker/Examples/BUGBNCHX/DLPHIERR/APIERR.PAS 6     4/21/97 10:05a Bob $
 *
 * Description:
 *    File includes routines for the ApiCheck option 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.
 *
 ***********************************************************************
 *
 **********************************************************************)
(*
   LoadBitmapFail tries to load a non-existant bitmap.  LoadBitmap will
   fail causing a BoundsChecker popup.
*)
procedure LoadBitmapFail;
var
   Penguin: HBITMAP;
begin
   try
      Penguin := LoadBitmap (  GetModuleHandle(NIL), 'HappyHappy');
   except
   end;
end;

(*
   LoadMenu will fail because there is no menu selection Hello in
   bugbnchx.exe
*)
procedure LoadMenu_Fail;
var
   hMenu : THandle;
begin
   try
      hMenu := LoadMenu( GetModuleHandle('bugbnchx.exe'), 'Hello');
   except
   end;
end;

(*
   HandleLocked allocates a pointer, locks it, then frees it.  While
   GlobalFree will free a locked pointer, chances are it was locked for
   a reason and should be checked.
*)
procedure HandleLocked;
var
   Flip: HGLOBAL;
   Flap: PChar;

begin
   try
      Flip := GlobalAlloc(GHND, $100);
      Flap := GlobalLock ( Flip );
      GlobalFree ( Flip );
   except
   end;
end;

(*
   HandleUnlocked unlocks a GlobalPointer whose reference count was already
   0.  While this causes no major problems in itself, it the handle might
   have been unlocked before it should have.
*)
procedure HandleUnlocked;
var
   Flip: HGLOBAL;
begin
   Flip := GlobalAlloc(GHND, $100);
   GlobalUnlock( Flip );
   GlobalFree( Flip );
end;

procedure BadDestPtr;
var
   buffer, destination :PChar;
begin
   if ( IDNO = MessageBox ( GetActiveWindow() ,
                  'This function attempts to copy a string into a NIL pointer. '+
                    'This will probably lead to an '+
                    'exception condition.   '+ #13#10#13#10 +
                    'Do you wish to skip this function?',
                  'BugBench Warning',
                    MB_YESNO OR MB_APPLMODAL) )
   then
      try
        destination := nil;
        buffer := StrNew ( 'Valid source buffer');
        StrCopy ( destination, buffer );
        StrDispose ( buffer );
      except
      end;
end;

(*
   BadFreeMem calls FreeMem twice with the same pointer.  The side effects
   of this action could cause GPFs within a program.
*)
procedure BadFreeMem;
var
   MemoryBlock: Pointer;
begin
   try
      MemoryBlock := AllocMem(50);
      FreeMem(MemoryBlock,50);
      FreeMem(MemoryBlock,50);
   except
   end;
end;

(*
   The following call to ReallocMem generates no compiler warning, but
   will cause the program to fault.  BoundsChecker will pop up informing
   you that there was a bad address passed to ReallocMem
*)
procedure BadReallocMem;
var
   MemoryBlock : PChar;
begin
   try
      MemoryBlock := 'Not an allocated block';
      ReallocMem ( Pointer(MemoryBlock), 50 );
   except
   end;
end;

procedure BadSourcePointer;
var
   Flip : array [0..12] of Char;
begin
   if ( IDNO = MessageBox ( GetActiveWindow() ,
                  'This function attempts to copy from a NIL pointer. '+
                    'This will probably lead to an '+
                    'exception condition.   '+ #13#10#13#10 +
                    'Do you wish to skip this function?',
                  'BugBench Warning',
                    MB_YESNO OR MB_APPLMODAL) )
   then

   try
      StrLCopy ( Flip, NIL, 4 );
   except
   end;

end;

(*
   Several Windows API functions require that the size field be initialized before
   the API is called.  In these cases, the API will fail.  GetVersionEx is an example
   of this type of API.  BoundsChecker knows all of these APIs and validates the size
   field for you.
*)
procedure UninitSizeField;
var
   stOSVI : TOSVersionInfo;
begin
   try
      FillChar (stOSVI, Sizeof(stOSVI), 0 );
      GetVersionEx(stOSVI);
   except
   end;
end;

(*
   Windows API expect certain types for parameters ( i.e. valid HANDLEs, HDCs etc ).
   BoundsChecker validates all API calls to verify that the parameters passed meet
   the criteria for the API.  If there is a problem, BoundsChecker will pop up with
   and error.  The following two routines show examples of this behavior.
*)
procedure GetTextColor_Bad_Param;
var
   color : COLORREF;
begin
   color := GetTextColor ( HDC($abcd));
end;

procedure DeleteMenu_Bad_Param;
begin
   DeleteMenu ( HMENU($FF00), 0, MF_BYPOSITION);
end;

(*
   Argument out of range, GetKeyState
*)
procedure OutOfRange_GetKeyState;
begin
   try
      GetKeyState( $FFFF );
   except
   end;
end;

(*
  API functions like AppendMenu allow certain flags to be passed describing
  actions that the API should take.  If a flag is passed that the API knows
  nothing about, BoundsChecker will pop up with an error
*)

procedure IllegalFlags_AppendMenu;
var
   TestMenu :HMENU;
begin
   try
      TestMenu := CreateMenu ( );
      AppendMenu ( TestMenu,
                   $80000000,
                   $100,
                   '&New Item' );
      DestroyMenu ( TestMenu );
   except
   end;
end;

procedure ConflictingFlags_GetStringType;
var
   szSource : PChar;
   szDest : string[12];
begin
   try
      szSource := 'Happy String';
      GetStringTypeEx ( GetUserDefaultLCID(),
                        CT_CTYPE1 OR CT_CTYPE2,
                        szSource,
                        -1,
                        szDest        );
   except
   end;
end;