开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > Delphi控件源码 > 查看源码
Mmdebug.pas
资源名称：qqdelphiprog.rar　[点击查看]
上传用户：hylc_2004
上传日期：2014-01-23
资源大小：46800k
文件大小：15k
源码类别：

Delphi控件源码

开发平台：

Delphi

Mmdebug.pas：源码内容
  1. {========================================================================}
  2. {=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
  3. {========================================================================}
  4. {=                          All Rights Reserved                         =}
  5. {========================================================================}
  6. {=  D 01099 Dresden             = Fax.: +49(0)351-8037944               =}
  7. {=  Loewenstr.7a                = info@swiftsoft.de                     =}
  8. {========================================================================}
  9. {=  Actual versions on http://www.swiftsoft.de/index.html               =}
  10. {========================================================================}
  11. {=  This code is for reference purposes only and may not be copied or   =}
  12. {=  distributed in any format electronic or otherwise except one copy   =}
  13. {=  for backup purposes.                                                =}
  14. {=                                                                      =}
  15. {=  No Delphi Component Kit or Component individually or in a collection=}
  16. {=  subclassed or otherwise from the code in this unit, or associated   =}
  17. {=  .pas, .dfm, .dcu, .asm or .obj files may be sold or distributed     =}
  18. {=  without express permission from SwiftSoft.                          =}
  19. {=                                                                      =}
  20. {=  For more licence informations please refer to the associated        =}
  21. {=  HelpFile.                                                           =}
  22. {========================================================================}
  23. {=  $Date: 11.10.98 - 19:25:53 $                                        =}
  24. {========================================================================}
  25. unit MMDebug;
  27. {$D-,L-}
  29. interface
  31. uses
  32. {$IFDEF WIN32}
  33.   Windows,
  34. {$ELSE}
  35.   WinTypes,
  36.   WinProcs,
  37. {$ENDIF}
  38.   MMUtils,
  39.   Messages,
  40.   SysUtils,
  41.   Classes;
  43. function  DB_Open: Boolean;             { open the debug terminal     }
  44. procedure DB_Clear;                     { clear the debug terminal    }
  45. procedure DB_Close;                     { close the debug terminal    }
  47. procedure DB_Level(Level: integer);     { set the general debug level }
  48. procedure DB_Enable(Enable: Boolean);   { enable the debug output     }
  49. procedure DB_Numerate(Enable: Boolean); { numerate messages or not    }
  50. procedure DB_Flush;                     { flushes all pending messages}
  52. { assertion: raise a exception and display string if condition False }
  53. procedure DB_Assert(Condition: Boolean; const S: String);
  55. { some debug output functions }
  56. procedure DB_Format(Level: integer; const Format: String; const Args: array of const);
  57. procedure DB_FormatLn(Level: integer; const Format: string; const Args: array of const);
  58. procedure DB_WriteBool(Level: integer; B: Boolean);
  59. procedure DB_WriteBoolLn(Level: integer; B: Boolean);
  60. procedure DB_WriteChar(Level: integer; C: Char);
  61. procedure DB_WriteCharLn(Level: integer; C: Char);
  62. procedure DB_WriteHexByte(Level: integer; B: Byte);
  63. procedure DB_WriteHexByteLn(Level: integer; B: Byte);
  64. procedure DB_WriteHex(Level: integer; L: LongInt);
  65. procedure DB_WriteHexLn(Level: integer; L: LongInt);
  66. procedure DB_WriteHexBuffer(Level: integer; const Buffer; BufLen: Cardinal);
  67. procedure DB_WriteHexBufferLn(Level: integer; const Buffer; BufLen: Cardinal);
  68. procedure DB_WriteInt(Level: integer; I: DWORD);
  69. procedure DB_WriteIntLn(Level: integer; I: DWORD);
  70. procedure DB_WriteInt64(Level: integer; I: int64);
  71. procedure DB_WriteInt64Ln(Level: integer; I: int64);
  72. procedure DB_WriteLn;
  73. procedure DB_WritePChar(Level: integer; Buf: PChar);
  74. procedure DB_WritePCharLn(Level: integer; Buf: PChar);
  75. procedure DB_WritePtr(Level: integer; P: Pointer);
  76. procedure DB_WritePtrLn(Level: integer; P: Pointer);
  77. procedure DB_WriteFloat(Level: integer; E: Extended);
  78. procedure DB_WriteFloatLn(Level: integer; E: Extended);
  79. procedure DB_WriteStr(Level: integer; const Str: String);
  80. procedure DB_WriteStrLn(Level: integer; const Str: String);
  81. {$IFDEF WIN32}
  82. procedure DB_WriteVar(Level: integer; V: Variant);
  83. procedure DB_WriteVarLn(Level: integer; V: Variant);
  84. {$ENDIF}
  86. implementation
  88. var
  89.    MM_CLOSE    : integer;
  90.    MM_LOGGIT   : integer;
  91.    MM_Clear    : integer;
  93.    DBEnabled   : Boolean;
  94.    DBLevel     : integer;
  95.    DBNumerate  : Boolean;
  96.    MsgNumber   : Longint;
  97.    MsgList     : TStringList;
  98.    NonLFMsg    : string;
  100. {------------------------------------------------------------------------}
  101. procedure LoggitEx(s: String; LF: Boolean);
  102. var
  103.    Buf: array[0..255] of Char;
  104.    aAtom: TAtom;
  105.    Wnd: HWND;
  106. begin
  107.    if DBEnabled then
  108.    begin
  109.       Wnd := FindWindow('TDebugForm',nil);
  110.       if (Wnd <> 0) then
  111.       begin
  112.          if DBNumerate and (s <> ' ') then
  113.          begin
  114.             s := IntToStr(MsgNumber)+': '+s;
  115.             inc(MsgNumber);
  116.          end;
  117.          if LF then s := s+#13#10;
  118.          aAtom := GlobalAddAtom(StrPLCopy(Buf,s,sizeOf(Buf)-1));
  119.          SendMessage(Wnd, MM_LOGGIT, aAtom, 0);
  120.          GlobalDeleteAtom(aAtom);
  121.       end;
  122.    end;
  123. end;
  125. {------------------------------------------------------------------------}
  126. procedure Loggit(Level: integer; s: String; LF: Boolean);
  127. begin
  128.    if DBEnabled and (Level <= DBLevel) or (DBLevel = -1) then
  129.    begin
  130.       if (DBLevel = -1) then
  131.       begin
  132.          if LF then
  133.          begin
  134.             MsgList.Add(NonLFMsg+s);
  135.             NonLFMsg := '';
  136.          end
  137.          else NonLFMsg := NonLFMsg+s;
  138.       end
  139.       else LoggitEx(s,LF);
  140.    end;
  141. end;
  143. {------------------------------------------------------------------------}
  144. function DB_Open: Boolean;
  145. var
  146.    {$IFDEF WIN32}
  147.    StartupInfo: TStartupInfo;
  148.    ProcessInfo: TProcessInformation;
  149.    {$ELSE}
  150.    hAppInstance: THandle;
  151.    {$ENDIF}
  153. begin
  154.    {$IFNDEF WIN32}
  155.    Result := (WinExec('MMDEBUG.EXE', SW_NORMAL) >= HINSTANCE_ERROR);
  156.    {$ELSE}
  157.    FillChar(StartupInfo, SizeOf(TStartupInfo), 0);
  158.    with StartupInfo do
  159.    begin
  160.       cb := SizeOf(TStartupInfo);
  161.       dwFlags := STARTF_USESHOWWINDOW;
  162.       wShowWindow := SW_NORMAL;
  163.    end;
  164.    Result := CreateProcess(nil,'MMDEBUG.EXE',nil,nil,False,NORMAL_PRIORITY_CLASS,
  165.                            nil,nil,StartupInfo,ProcessInfo);
  166.    {$ENDIF}
  167. end;
  169. {------------------------------------------------------------------------}
  170. procedure DB_CLose;
  171. var
  172.    Wnd: HWND;
  173. begin
  174.    Wnd := FindWindow('TDebugForm',nil);
  175.    if (Wnd <> 0) then
  176.       SendMessage(Wnd, MM_CLOSE, 0, 0);
  177. end;
  179. {------------------------------------------------------------------------}
  180. procedure DB_Clear;
  181. var
  182.    Wnd: HWND;
  183. begin
  184.    Wnd := FindWindow('TDebugForm',nil);
  185.    if (Wnd <> 0) then
  186.       SendMessage(Wnd, MM_CLEAR, 0, 0);
  187.    MsgNumber := 0;
  188. end;
  190. {------------------------------------------------------------------------}
  191. procedure DB_Enable(Enable: Boolean);
  192. begin
  193.    DBEnabled := Enable;
  194. end;
  196. {------------------------------------------------------------------------}
  197. procedure DB_Level(Level: integer);
  198. begin
  199.    if (Level < 0) then DBLevel := -1
  200.    else DBLevel := Level;
  201. end;
  203. {------------------------------------------------------------------------}
  204. procedure DB_Numerate(Enable: Boolean);
  205. begin
  206.    DBNumerate := Enable;
  207. end;
  209. {------------------------------------------------------------------------}
  210. procedure DB_Flush;
  211. var
  212.    i: integer;
  213. begin
  214.    for i := 0 to MsgList.Count-1 do
  215.    begin
  216.       LoggitEx(MsgList[i],True);
  217.    end;
  218.    MsgList.Clear;
  219.    if (NonLFMsg <> '') then
  220.    begin
  221.       LoggitEx(NonLFMsg,True);
  222.       NonLFMsg := '';
  223.    end;
  224. end;
  226. {$IFNDEF WIN32}
  227. function ConvertAddr(Address: Pointer): Pointer; assembler;
  228. { Convert physical address to logical address }
  229. asm
  230.         MOV     AX,Address.Word[0]
  231.         MOV     DX,Address.Word[2]
  232.         MOV     CX,DX                   { Don't convert 0000:0000 }
  233.         OR      CX,AX
  234.         JE      @@1
  235.         CMP     DX,0FFFFH               { Don't convert FFFF:xxxx }
  236.         JE      @@1
  237.         MOV     ES,DX
  238.         MOV     DX,ES:Word[0]
  239. @@1:
  240. end;
  241. {$ENDIF}
  243. {------------------------------------------------------------------------}
  244. procedure DB_Assert(Condition: Boolean; const S: String);
  245. var
  246.    Address: Pointer;
  247. begin
  248.    if not Condition then
  249.    begin
  250.       asm
  251.          {$IFDEF WIN32}
  252.          mov   eax, [ebp+04]
  253.          dec   eax
  254.          mov   [Address], eax
  255.          {$ELSE}
  256.          mov   ax, [bp+02]
  257.          mov   word ptr [Address], ax
  258.          mov   ax, [bp+04]
  259.          mov   word ptr [Address+2], ax
  260.          {$ENDIF}
  261.       end;
  262.       {$IFNDEF WIN32}
  263.       Address := ConvertAddr(Address);
  264.       {$ENDIF}
  265.       raise Exception.CreateFmt('Assertion at address $%p'#10#13'%s', [Address,S]);
  266.    end;
  267. end;
  269. {------------------------------------------------------------------------}
  270. procedure DB_Format(Level: integer; const Format: String; const Args: array of const);
  271. begin
  272.    Loggit(Level,Sysutils.Format(Format,Args),False);
  273. end;
  275. {------------------------------------------------------------------------}
  276. procedure DB_FormatLn(Level: integer; const Format: string; const Args: array of const);
  277. begin
  278.    Loggit(Level,Sysutils.Format(Format,Args),True);
  279. end;
  281. {------------------------------------------------------------------------}
  282. procedure DB_WriteBool(Level: integer; B: Boolean);
  283. begin
  284.    if B then
  285.       Loggit(Level,'True',False)
  286.    else
  287.       Loggit(Level,'False',False);
  288. end;
  290. {------------------------------------------------------------------------}
  291. procedure DB_WriteBoolLn(Level: integer; B: Boolean);
  292. begin
  293.    if B then
  294.       Loggit(Level,'True',True)
  295.    else
  296.       Loggit(Level,'False',True);
  297. end;
  299. {------------------------------------------------------------------------}
  300. procedure DB_WriteChar(Level: integer; C: Char);
  301. begin
  302.    Loggit(Level,C,False);
  303. end;
  305. {------------------------------------------------------------------------}
  306. procedure DB_WriteCharLn(Level: integer; C: Char);
  307. begin
  308.    Loggit(Level,C,True);
  309. end;
  311. {------------------------------------------------------------------------}
  312. procedure DB_WriteHexByte(Level: integer; B: Byte);
  313. begin
  314.    Loggit(Level,Format('%.2x',[B]),False);
  315. end;
  317. {------------------------------------------------------------------------}
  318. procedure DB_WriteHexByteLn(Level: integer; B: Byte);
  319. begin
  320.    Loggit(Level,Format('%.2x',[B]),True);
  321. end;
  323. {------------------------------------------------------------------------}
  324. procedure DB_WriteHex(Level: integer; L: LongInt);
  325. begin
  326.    Loggit(Level,Format('%.8x',[L]),False);
  327. end;
  329. {------------------------------------------------------------------------}
  330. procedure DB_WriteHexLn(Level: integer; L: LongInt);
  331. begin
  332.    Loggit(Level,Format('%.8x',[L]),True);
  333. end;
  335. {------------------------------------------------------------------------}
  336. procedure DB_WriteHexBuffer(Level: integer; const Buffer; BufLen: Cardinal);
  337. var
  338.    s: String;
  339.    i: integer;
  340. begin
  341.    s := '';
  342.    for i := 0 to BufLen-1 do s := s+Format('%.2x',[PByte(PChar(@Buffer)+i)^]);
  343.    Loggit(Level,s,False);
  344. end;
  346. {------------------------------------------------------------------------}
  347. procedure DB_WriteHexBufferLn(Level: integer; const Buffer; BufLen: Cardinal);
  348. var
  349.    s: String;
  350.    i: integer;
  351. begin
  352.    s := '';
  353.    for i := 0 to BufLen-1 do s := s+Format('%.2x',[PByte(PChar(@Buffer)+i)^]);
  354.    Loggit(Level,s,True);
  355. end;
  357. {------------------------------------------------------------------------}
  358. procedure DB_WriteInt(Level: integer; I: DWORD);
  359. begin
  360.    Loggit(Level,IntToStr(I),False);
  361. end;
  363. {------------------------------------------------------------------------}
  364. procedure DB_WriteIntLn(Level: integer; I: DWORD);
  365. begin
  366.    Loggit(Level,IntToStr(I),True);
  367. end;
  369. {------------------------------------------------------------------------}
  370. procedure DB_WriteInt64(Level: integer; I: int64);
  371. begin
  372.    Loggit(Level,Format('%g',[I]),False);
  373. end;
  375. {------------------------------------------------------------------------}
  376. procedure DB_WriteInt64Ln(Level: integer; I: int64);
  377. begin
  378.    Loggit(Level,Format('%g',[I]),True);
  379. end;
  381. {------------------------------------------------------------------------}
  382. procedure DB_WriteLn;
  383. begin
  384.    Loggit(0,'',True);
  385. end;
  387. {------------------------------------------------------------------------}
  388. procedure DB_WritePChar(Level: integer; Buf: PChar);
  389. begin
  390.    Loggit(Level,StrPas(Buf),False);
  391. end;
  393. {------------------------------------------------------------------------}
  394. procedure DB_WritePCharLn(Level: integer; Buf: PChar);
  395. begin
  396.    Loggit(Level,StrPas(Buf),True);
  397. end;
  399. {------------------------------------------------------------------------}
  400. procedure DB_WritePtr(Level: integer; P: Pointer);
  401. begin
  402.    Loggit(Level,Format('%p',[P]),False);
  403. end;
  405. {------------------------------------------------------------------------}
  406. procedure DB_WritePtrLn(Level: integer; P: Pointer);
  407. begin
  408.    Loggit(Level,Format('%p',[P]),True);
  409. end;
  411. {------------------------------------------------------------------------}
  412. procedure DB_WriteFloat(Level: integer; E: Extended);
  413. begin
  414.    Loggit(Level,Format('%g',[E]),False);
  415. end;
  417. {------------------------------------------------------------------------}
  418. procedure DB_WriteFloatLn(Level: integer; E: Extended);
  419. begin
  420.    Loggit(Level,Format('%g',[E]),True);
  421. end;
  423. {------------------------------------------------------------------------}
  424. procedure DB_WriteStr(Level: integer; const Str: String);
  425. begin
  426.    Loggit(Level,Str,False);
  427. end;
  429. {------------------------------------------------------------------------}
  430. procedure DB_WriteStrLn(Level: integer; const Str: String);
  431. begin
  432.    Loggit(Level,Str,True);
  433. end;
  435. {$IFDEF WIN32}
  436. {------------------------------------------------------------------------}
  437. procedure DB_WriteVar(Level: integer; V: Variant);
  438. var
  439.    vTyp: integer;
  440. begin
  441.    vTyp := VarType(V);
  442.    if (vTyp = varBoolean) then
  443.       DB_WriteBool(Level,VarAsType(V, varBoolean))
  444.    else
  445.       Loggit(Level,VarAsType(V, varString),False);
  446. end;
  448. procedure DB_WriteVarLn(Level: integer; V: Variant);
  449. var
  450.    vTyp: integer;
  451. begin
  452.    vTyp := VarType(V);
  453.    if vTyp = varBoolean then
  454.       DB_WriteBoolLn(Level,VarAsType(V, varBoolean))
  455.    else
  456.       Loggit(Level,VarAsType(V, varString),True);
  457. end;
  458. {$ENDIF}
  460. {------------------------------------------------------------------------}
  461. initialization
  462.   MM_CLOSE  := RegisterWindowMessage('MM_CLOSE');
  463.   MM_LOGGIT := RegisterWindowMessage('MM_LOGGIT');
  464.   MM_CLEAR  := RegisterWindowMessage('MM_CLEAR');
  465.   DBEnabled := True;
  466.   DBLevel   := 0;
  467.   DBNumerate:= False;
  468.   MsgNumber := 0;
  469.   MsgList   := TStringList.Create;
  470.   NonLFMsg  := '';
  471. {$IFDEF WIN32}
  472. finalization
  473.   MsgList.Free;
  474. {$ENDIF}
  475. end.