home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 March / Chip_2002-03_cd1.bin / zkuste / delphi / nastroje / d23456 / PRODEL.ZIP / PROFINT.PAS < prev    next >
Pascal/Delphi Source File  |  2001-05-05  |  16KB  |  479 lines
  1. //PROFILE-NO
  2. {$O-}
  3. {$D-}
  4. {$B-}
  5. {$Q-}
  6. {$I-}
  7. {$R-}
  8. {$X+}
  9.  
  10. unit Profint;
  11.  
  12. interface
  13.  
  14. USES
  15.   Dialogs, Windows;
  16.  
  17. TYPE
  18.  
  19. {$IFDEF VER90 }
  20.   TMyComp  = Comp;
  21. {$ELSE }
  22.   {$IFDEF VER100 }
  23.     TMyComp  = Comp;
  24.   {$ELSE }
  25.     TMyComp  = Int64;
  26.   {$ENDIF }
  27. {$ENDIF }
  28.  
  29.   TMyLargeInteger = RECORD
  30.                     CASE Byte OF
  31.                      0 : ( LowPart  : DWord; HighPart : LongInt );
  32.                      1 : ( QuadPart : TMyComp );
  33.                   END;
  34.   TPLargeInteger = ^TMyLargeInteger;
  35.  
  36. {$IFDEF VER100} {$DEFINE PROFD3ORD4} {$ENDIF }
  37. {$IFDEF VER120} {$DEFINE PROFD3ORD4} {$ENDIF }
  38. {$IFDEF VER90}  { Delphi 2 }
  39.   TObjFunction = FUNCTION ( Text, Caption : PChar;
  40.                             Flags : Word ) : Integer OF Object;
  41. {$ELSE}
  42.   {$IFDEF PROFD3ORD4} { Delphi 3 or 4 }
  43.     TObjFunction = FUNCTION ( Text, Caption : PChar;
  44.                                 Flags : Longint ) : Integer OF Object;
  45.   {$ELSE }  { Delphi 5 OR Better }
  46.      TObjFunction = FUNCTION ( CONST Text, Caption : PChar;
  47.                                 Flags : Longint ) : Integer OF Object;
  48.   {$ENDIF}
  49. {$ENDIF}
  50.  
  51. // Profiler-Measurement-Functions
  52. PROCEDURE ProfStop  ( l : DWord; h : Integer);    external 'PROFMEAS.DLL';
  53. FUNCTION  ProfEnter ( mptr : Pointer; prozNr : Integer ) : TPLargeInteger; external 'PROFMEAS.DLL';
  54. FUNCTION  ProfExit  ( lc   : DWord;   hc : Integer; prozNr : Integer ) : TPLargeInteger; external 'PROFMEAS.DLL';
  55. PROCEDURE ProfActivate;     external 'PROFMEAS.DLL';
  56. PROCEDURE ProfDeActivate;   external 'PROFMEAS.DLL';
  57. PROCEDURE ProfSetComment  ( comm   : PChar );     external 'PROFMEAS.DLL';
  58. PROCEDURE ProfAppendResults ( progEnd : Boolean );external 'PROFMEAS.DLL';
  59.  
  60. // Post-Mortem-Review-Functions
  61. PROCEDURE PomoEnter       ( prozNr : SmallInt );  external 'PROFMEAS.DLL';
  62. PROCEDURE PomoExceStr     ( name   : pChar    );  external 'PROFMEAS.DLL';
  63. PROCEDURE PomoExce;
  64. PROCEDURE PomoExit        ( prozNr : SmallInt );  external 'PROFMEAS.DLL';
  65.  
  66. // Functions to interrupt and continue measurement for calls which could set the
  67. //  Process idle. Use these calls to implement own Non-measured Calls. If METHODS
  68. //  can set a process idle, the only possibility is, to put these calls into your
  69. //  sources (included by an IFDEF-statement).
  70. //  USE 2 or more spaces between IFDEF and PROFILE, otherwise it will be deleted
  71. //  by the ProDelphi. Example:
  72. //  {$IFDEF     PROFILE } StopCounting;     {$ENDIF }
  73. //    ObjectReference.MethodThatMightSetProcessIdle;
  74. //  {$IFDEF     PROFILE } ContinueCounting; {$ENDIF }
  75.  
  76. // Normal procedures that set the process idle can be handled like the Sleep-
  77. //  function in this unit.
  78. PROCEDURE StopCounting;                           external 'PROFMEAS.DLL';
  79. PROCEDURE ContinueCounting;                       external 'PROFMEAS.DLL';
  80.  
  81. // Delphi-Functions that set process idle
  82. PROCEDURE ShowMessage ( CONST Msg  : String );
  83. {$IFNDEF VER90 }
  84. PROCEDURE ShowMessageFmt(const Msg : string; Params : array of const );
  85. {$ENDIF}
  86.           // If you need to compile the VCL, the next function must be deleted,
  87.           // Sorry ! The USES statement for Dialogs has to be moved to the
  88.           // Implementation part !!!
  89. function  MessageDlg( const Msg : string;         AType   : TMsgDlgType;
  90.                       AButtons  : TMsgDlgButtons; HelpCtx : Longint ) : Word;
  91.  
  92. function  MessageDlgPos( const Msg : string;         DlgType : TMsgDlgType;
  93.                          Buttons   : TMsgDlgButtons; HelpCtx: Longint;
  94.                          X, Y      : Integer) : Word;
  95.  
  96. function MessageDlgPosHelp( const Msg : string;         DlgType : TMsgDlgType;
  97.                             Buttons   : TMsgDlgButtons; HelpCtx : Longint;
  98.                             X, Y      : Integer;        const HelpFileName : string)
  99.                            : Integer;
  100.  
  101.  
  102. // Delphi-TApplication-Functions that set process idle (handled in DLL)
  103. PROCEDURE ProcessMessages;
  104. PROCEDURE HandleMessage;
  105. {$IFDEF VER90 }
  106. FUNCTION  AMessageBox( Text, Caption  : PChar;
  107.                        Flags : Word ) : Integer;
  108. {$ELSE }
  109. FUNCTION  AMessageBox( Text, Caption   : PChar;
  110.                        Flags : Longint): Integer;
  111. {$ENDIF }
  112.  
  113. // Windows-Functions that set process idle
  114. FUNCTION  DispatchMessage(CONST lpMsg  : TMsg) : Longint;
  115. FUNCTION  DialogBox( hInstance  : HINST; lpTemplate   : PChar;
  116.                      hWndParent : HWND;  lpDialogFunc : TFNDlgProc): Integer;
  117. FUNCTION  DialogBoxIndirect( hInstance  : HINST; const lpDialogTemplate : TDlgTemplate;
  118.                              hWndParent : HWND;        lpDialogFunc     : TFNDlgProc): Integer;
  119. FUNCTION  MessageBox ( hWnd : HWND; lpText, lpCaption: PChar; uType : UINT ) : Integer;
  120. FUNCTION  MessageBoxEx( hWnd : HWND; lpText, lpCaption: PChar; uType : UINT; lang : Word ) : Integer;
  121. {$IFNDEF VER90 }
  122. FUNCTION  SignalObjectAndWait ( h1, h2 : THandle;
  123.                                 ms     : DWord;
  124.                                 al     : BOOL) : BOOL;
  125. {$ENDIF}
  126. FUNCTION  WaitForSingleObject ( h1     : THandle;
  127.                                 MS     : DWORD ) : DWORD;
  128. FUNCTION  WaitForSingleObjectEx ( h1   : THandle;
  129.                                   MS   : DWORD;
  130.                                   al   : BOOL ) : DWORD;
  131.  
  132. FUNCTION  WaitForMultipleObjects ( ct  : DWORD;
  133.                                    CONST pH : PWOHandleArray;
  134.                                    wait     : BOOL;
  135.                                    ms       : DWORD ) : DWORD;
  136. FUNCTION  WaitForMultipleObjectsEx ( ct  : DWORD;
  137.                                      CONST pH : PWOHandleArray;
  138.                                      wait     : BOOL;
  139.                                      ms       : DWORD;
  140.                                      al       : Boolean) : DWORD;
  141. FUNCTION  MsgWaitForMultipleObjects ( ct      : DWORD;
  142.                                       VAR pHandles;
  143.                                       wait    : BOOL;
  144.                                       ms      : DWORD;
  145.                                       wm      : DWORD ) : DWORD;
  146. {$IFNDEF VER90 }
  147. FUNCTION  MsgWaitForMultipleObjectsEx ( ct     : DWORD;
  148.                                         VAR pHandles;
  149.                                         ms     : DWORD;
  150.                                         wm     : DWORD;
  151.                                         fl     : DWORD ) : DWORD;
  152. {$ENDIF}
  153. PROCEDURE Sleep   (zeit : DWORD );
  154. PROCEDURE SleepEx (zeit : DWORD; alertable : BOOL );
  155. FUNCTION  WaitCommEvent ( hd  : THandle; VAR em : DWORD;
  156.                           lpo : POverlapped ) : BOOL;
  157. FUNCTION  WaitForInputIdle ( hp : THandle; ms : DWORD ) : DWORD;
  158. FUNCTION  WaitMessage : BOOL;
  159. FUNCTION  WaitNamedPipe ( np : PAnsiChar; ms : DWORD ) : BOOL;
  160.  
  161. IMPLEMENTATION
  162. USES
  163.   Forms,
  164.   SysUtils;
  165.  
  166. TYPE
  167.   TObjProzedur = PROCEDURE OF Object;
  168.  
  169. // Profiler-Internal-Functions, DO NOT USE
  170. FUNCTION  ProfGlobalInit1 : Boolean;              external 'PROFMEAS.DLL';
  171. PROCEDURE ProfGlobalInit2 ( j : Integer );        external 'PROFMEAS.DLL';
  172. PROCEDURE ProfUnInitTimer;                        external 'PROFMEAS.DLL';
  173. FUNCTION  ProfIsInitialised : Integer;            external 'PROFMEAS.DLL';
  174. FUNCTION  ProfMustBeUnInitialised : Integer;      external 'PROFMEAS.DLL';
  175.  
  176. // Calibration - Function - DO NOT USE
  177. PROCEDURE CalcQPCTime802; external 'PROFCALI.DLL';
  178. PROCEDURE ProfSetDelphiVersion ( vers : Integer ); external 'PROFCALI.DLL';
  179.  
  180. // Check if CPU is intel-Compatible
  181. PROCEDURE PruefeKompatibilitaet;
  182. VAR
  183.   tsh, tsl : DWORD;
  184. BEGIN
  185.   Try
  186.     asm
  187.       DW 310FH;
  188.       mov tsh,edx
  189.       mov tsl,eax
  190.     end;
  191.   Except
  192.     Windows.MessageBox(0, 'This CPU is not Intel-Compatible', 'ProDelphi - ERROR', MB_OK);
  193.     halt(0);
  194.   End;
  195. END;
  196.  
  197. PROCEDURE ShowMessage ( CONST Msg  : String );
  198. BEGIN
  199.   StopCounting;
  200.   Dialogs.ShowMessage(Msg);
  201.   ContinueCounting;
  202. END;
  203.  
  204. {$IFNDEF VER90 }
  205. PROCEDURE ShowMessageFmt(const Msg : string; Params : array of const );
  206. BEGIN
  207.   StopCounting;
  208.   Dialogs.ShowMessageFmt(Msg, Params);
  209.   ContinueCounting;
  210. END;
  211.  
  212. FUNCTION AMessageBox( Text, Caption     : PChar;
  213.                       Flags : LongInt ) : Integer;
  214. BEGIN
  215.   StopCounting;
  216.   Result := Application.MessageBox(Text, Caption,Flags);
  217.   ContinueCounting;
  218. END;
  219.  
  220. {$ELSE }
  221.  
  222. FUNCTION AMessageBox( Text, Caption    : PChar;
  223.                       Flags : Word  )  : Integer;
  224. BEGIN
  225.   StopCounting;
  226.   Result := Application.MessageBox(Text, Caption,Flags);
  227.   ContinueCounting;
  228. END;
  229. {$ENDIF }
  230.  
  231. FUNCTION MessageDlg( const Msg : string;         AType   : TMsgDlgType;
  232.                      AButtons  : TMsgDlgButtons; HelpCtx : Longint ) : Word;
  233. BEGIN
  234.   StopCounting;
  235.   Result := Dialogs.MessageDlg(Msg, AType, AButtons, HelpCtx);
  236.   ContinueCounting;
  237. END;
  238.  
  239. FUNCTION MessageDlgPos( const Msg : string;         DlgType : TMsgDlgType;
  240.                         Buttons   : TMsgDlgButtons; HelpCtx: Longint;
  241.                         X, Y      : Integer) : Word;
  242. BEGIN
  243.   StopCounting;
  244.   Result := Dialogs.MessageDlgPos(Msg, DlgType, Buttons, HelpCtx, X, Y);
  245.   ContinueCounting;
  246. END;
  247.  
  248. function MessageDlgPosHelp( const Msg : string;         DlgType : TMsgDlgType;
  249.                             Buttons   : TMsgDlgButtons; HelpCtx : Longint;
  250.                             X, Y      : Integer;        const HelpFileName : string)
  251.                            : Integer;
  252. BEGIN
  253.   StopCounting;
  254.   Result := Dialogs.MessageDlgPosHelp(Msg, DlgType, Buttons, HelpCtx,
  255.                                       X, Y, HelpFileName);
  256.   ContinueCounting;
  257. END;
  258.  
  259.  
  260. FUNCTION  DialogBox( hInstance  : HINST; lpTemplate   : PChar;
  261.                      hWndParent : HWND;  lpDialogFunc : TFNDlgProc): Integer;
  262. BEGIN
  263.   StopCounting;
  264.   Result := Windows.DialogBox(hInstance, lpTemplate, hWndParent, lpDialogFunc);
  265.   ContinueCounting;
  266. END;
  267.  
  268. FUNCTION  DialogBoxIndirect( hInstance  : HINST; const lpDialogTemplate : TDlgTemplate;
  269.                              hWndParent : HWND;        lpDialogFunc     : TFNDlgProc): Integer;
  270. BEGIN
  271.   StopCounting;
  272.   Result := Windows.DialogBoxIndirect(hInstance, lpDialogTemplate, hWndParent, lpDialogFunc);
  273.   ContinueCounting;
  274. END;
  275.  
  276. FUNCTION MessageBox ( hWnd : HWND; lpText, lpCaption: PChar; uType : UINT ) : Integer;
  277. BEGIN
  278.   StopCounting;
  279.   Result := Windows.MessageBox(hWnd, lpText, lpCaption, uType);
  280.   ContinueCounting;
  281. END;
  282.  
  283. FUNCTION MessageBoxEx ( hWnd : HWND; lpText, lpCaption: PChar; uType : UINT; lang : Word ) : Integer;
  284. BEGIN
  285.   StopCounting;
  286.   Result := Windows.MessageBoxEx(hWnd, lpText, lpCaption, uType, lang);
  287.   ContinueCounting;
  288. END;
  289.  
  290. FUNCTION DispatchMessage( CONST lpMsg: TMsg ) : Longint;
  291. BEGIN
  292.   StopCounting;
  293.   Result := Windows.DispatchMessage(lpMsg);
  294.   ContinueCounting;
  295. END;
  296.  
  297. PROCEDURE HandleMessage;
  298. BEGIN
  299.   StopCounting;
  300.   Application.HandleMessage;
  301.   ContinueCounting;
  302. END;
  303.  
  304. PROCEDURE ProcessMessages;
  305. BEGIN
  306.   StopCounting;
  307.   Application.ProcessMessages;
  308.   ContinueCounting;
  309. END;
  310.  
  311. PROCEDURE Sleep( zeit : DWORD );
  312. BEGIN
  313.   StopCounting;
  314.   Windows.Sleep(zeit);
  315.   ContinueCounting;
  316. END;
  317.  
  318. PROCEDURE SleepEx( zeit : DWORD; alertable : BOOL );
  319. BEGIN
  320.   StopCounting;
  321.   Windows.SleepEx(zeit, alertable);
  322.   ContinueCounting;
  323. END;
  324. {$IFNDEF VER90 }
  325. FUNCTION SignalObjectAndWait ( h1, h2 : THandle;
  326.                                ms     : DWord;
  327.                                al     : BOOL) : BOOL;
  328. BEGIN
  329.   StopCounting;
  330.   Result := Windows.SignalObjectAndWait(h1, h2, ms, al);
  331.   ContinueCounting;
  332. END;
  333. {$ENDIF }
  334.  
  335. FUNCTION WaitForSingleObject ( h1     : THandle;
  336.                                MS     : DWORD ) : DWORD;
  337. BEGIN
  338.   StopCounting;
  339.   Result := Windows.WaitForSingleObject ( h1, MS );
  340.   ContinueCounting;
  341. END;
  342.  
  343. FUNCTION WaitForSingleObjectEx ( h1   : THandle;
  344.                                  MS   : DWORD;
  345.                                  al   : BOOL ) : DWORD;
  346. BEGIN
  347.   StopCounting;
  348.   Result := Windows.WaitForSingleObjectEx (h1, MS, al);
  349.   ContinueCounting;
  350. END;
  351.  
  352. FUNCTION WaitForMultipleObjects ( ct  : DWORD;
  353.                                   CONST pH : PWOHandleArray;
  354.                                   wait     : BOOL;
  355.                                   ms       : DWORD ) : DWORD;
  356. BEGIN
  357.   StopCounting;
  358.   Result := Windows.WaitForMultipleObjects(ct, pH, wait, ms);
  359.   ContinueCounting;
  360. END;
  361.  
  362. FUNCTION WaitForMultipleObjectsEx ( ct  : DWORD;
  363.                                     CONST pH : PWOHandleArray;
  364.                                     wait     : BOOL;
  365.                                     ms       : DWORD;
  366.                                     al       : Boolean ) : DWORD;
  367. BEGIN
  368.   StopCounting;
  369.   Result := Windows.WaitForMultipleObjectsEx(ct, pH, wait, ms, al);
  370.   ContinueCounting;
  371. END;
  372.  
  373. FUNCTION MsgWaitForMultipleObjects ( ct     : DWORD;
  374.                                      VAR pHandles;
  375.                                      wait   : BOOL;
  376.                                      ms     : DWORD;
  377.                                      wm     : DWORD ) : DWORD;
  378. BEGIN
  379.   StopCounting;
  380.   Result := Windows.MsgWaitForMultipleObjects(ct, pHandles, wait, ms, wm);
  381.   ContinueCounting;
  382. END;
  383.  
  384. {$IFNDEF VER90 }
  385. FUNCTION MsgWaitForMultipleObjectsEx ( ct     : DWORD;
  386.                                        VAR pHandles;
  387.                                        ms     : DWORD;
  388.                                        wm     : DWORD;
  389.                                        fl     : DWORD ) : DWORD;
  390. BEGIN
  391.   StopCounting;
  392.   Result := Windows.MsgWaitForMultipleObjectsEx(ct, pHandles, ms, wm, fl);
  393.   ContinueCounting;
  394. END;
  395. {$ENDIF}
  396. FUNCTION WaitCommEvent ( hd : THandle; VAR em : DWORD; lpo : POverlapped ) : BOOL;
  397. BEGIN
  398.   StopCounting;
  399.   Result := Windows.WaitCommEvent(hd, em, lpo);
  400.   ContinueCounting;
  401. END;
  402.  
  403. FUNCTION WaitForInputIdle ( hp : THandle; ms : DWORD ) : DWORD;
  404. BEGIN
  405.   StopCounting;
  406.   Result := Windows.WaitForInputIdle(hp, ms);
  407.   ContinueCounting;
  408. END;
  409.  
  410. FUNCTION WaitMessage : BOOL;
  411. BEGIN
  412.   StopCounting;
  413.   Result := Windows.WaitMessage;
  414.   ContinueCounting;
  415. END;
  416.  
  417. FUNCTION WaitNamedPipe ( np : PAnsiChar; ms : DWORD ) : BOOL;
  418. BEGIN
  419.   StopCounting;
  420.   Result := Windows.WaitNamedPipe(np, ms);
  421.   ContinueCounting;
  422. END;
  423.  
  424. PROCEDURE PomoExce;
  425. VAR
  426.   exname : Array[0..100] OF Char;
  427.   ExOb   : TObject;
  428. BEGIN
  429.   exname[0] := Char(0);
  430.   ExOb := ExceptObject;
  431.   IF Assigned(ExOb) THEN BEGIN
  432.     IF ExceptObject IS Exception THEN
  433.       StrPLCopy(exname, Exception(ExceptObject).Message, SizeOf(exname));
  434.   END;
  435.   PomoExceStr(exname);
  436. END;
  437.  
  438. INITIALIZATION
  439.   IF ProfIsInitialised = 1 THEN BEGIN
  440.     PruefeKompatibilitaet;
  441.     IF ProfGlobalInit1 = TRUE THEN BEGIN
  442. {$IFDEF VER90 }
  443.       ProfSetDelphiVersion( 2 );
  444. {$ELSE }
  445.   {$IFDEF VER100 }
  446.       ProfSetDelphiVersion( 3 );
  447.   {$ELSE }
  448.     {$IFDEF VER120 }
  449.       ProfSetDelphiVersion( 4 );
  450.     {$ELSE }
  451.       {$IFDEF VER130 }
  452.         ProfSetDelphiVersion( 5 );
  453.       {$ELSE }
  454.         {$IFDEF VER140 }
  455.           ProfSetDelphiVersion( 6 );
  456.         {$ELSE }
  457.           {$IFDEF VER150 }
  458.             ProfSetDelphiVersion( 7 );
  459.           {$ELSE }
  460.             ProfSetDelphiVersion( 8 );
  461.           {$ENDIF }
  462.         {$ENDIF }
  463.       {$ENDIF }
  464.     {$ENDIF }
  465.   {$ENDIF }
  466. {$ENDIF }
  467.       CalcQPCTime802;
  468.     END;
  469.     ProfGlobalInit2(0);
  470.   END;
  471. FINALIZATION
  472.   IF ProfMustBeUnInitialised = 1 THEN BEGIN
  473.     ProfSetComment('At finishing application');
  474.     ProfAppendResults(TRUE);
  475.     ProfUnInitTimer;
  476.   END;
  477. end.
  478.  
  479.