home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / Pascal / Snippets / PNL Libraries / MyDumping.p < prev    next >
Encoding:
Text File  |  1996-10-12  |  7.3 KB  |  364 lines  |  [TEXT/CWIE]
  1. unit MyDumping;
  2.  
  3. interface
  4.  
  5.     uses
  6.         Types, Memory;
  7.  
  8.     const
  9.         dump_name = 'Dumping_dump_file';
  10.  
  11.     procedure InitDumping (safe, clean, tofile, totext: boolean);
  12.     procedure Dumping (safe, clean, tofile, totext: boolean);
  13.     procedure FinishDumping;
  14.  
  15.     procedure DumpLine (s: Str255);
  16.     procedure DumpStr (s: Str255);
  17.     procedure DumpNum (n: longint);
  18.     procedure DumpValue (s: Str255; n: longint);
  19.     procedure DumpByte (n: integer);
  20.     procedure DumpWord (n: longint);
  21.     procedure DumpLong (n: longint);
  22.     procedure DumpData (p: Ptr; len: longint);
  23.     procedure DumpText (p: Ptr; len: longint);
  24.     procedure DumpHeap (hz: THz);
  25.  
  26. implementation
  27.  
  28.     uses
  29.         TextUtils, Files, Resources,
  30.         MyTypes, MyStrings;
  31.         
  32.     var
  33.         dump_tofile, dump_totext, dump_safe: boolean;
  34.         dump: integer;
  35.  
  36. {$IFC undefined BackgroundOnly}
  37. {$SETC BackgroundOnly = FALSE}
  38. {$ENDC}
  39.  
  40.     function NumToStr (n: longint): Str31;
  41.         var
  42.             s: Str255;
  43.     begin
  44.         NumToString(n, s);
  45.         NumToStr := s;
  46.     end;
  47.  
  48.     procedure InitDumping (safe, clean, tofile, totext: boolean);
  49.         var
  50.             oe: OSErr;
  51.     begin
  52. {    oe := FSDelete(dump_name, 0);}
  53.         oe := Create(dump_name, 0, 'R*ch', 'TEXT');
  54.         oe := FSOpen(dump_name, 0, dump);
  55.         oe := SetFPos(dump, fsFromLEOF, 0);
  56.         Dumping(safe, clean, tofile, totext);
  57.         if not clean and tofile then begin
  58.             DumpLine('');
  59.             DumpLine('Dump File');
  60.             DumpLine('');
  61.         end;
  62.     end;
  63.  
  64.     procedure Dumping (safe, clean, tofile, totext: boolean);
  65.         var
  66.             oe: OSErr;
  67.     begin
  68.         if clean then begin
  69.             oe := SetEOF(dump, 0);
  70.             oe := SetFPos(dump, fsFromLEOF, 0);
  71.         end;
  72.         dump_safe := safe;
  73.         dump_tofile := tofile;
  74.         dump_totext := totext;
  75. {$IFC  not BackgroundOnly}
  76.         if dump_totext then begin
  77. {            ShowText;}
  78.         end;
  79. {$ENDC}
  80.     end;
  81.  
  82.     procedure FinishDumping;
  83.         var
  84.             oe: OSErr;
  85.     begin
  86.         oe := FSClose(dump);
  87.         dump := 0;
  88.         dump_tofile := false;
  89.         dump_totext := false;
  90.     end;
  91.  
  92.     procedure DumpStr (s: Str255);
  93.         var
  94.             oe: OSErr;
  95.             pb: ParamBlockRec;
  96.             count: longint;
  97.     begin
  98.         if dump_tofile then begin
  99.             count := length(s);
  100.             oe := FSWrite(dump, count, @s[1]);
  101.             if dump_safe then begin
  102.                 pb.ioRefNum := dump;
  103.                 oe := PBFlushFileSync(@pb);
  104.                 pb.ioNamePtr := nil;
  105.                 pb.ioVRefNum := 0;
  106.                 oe := PBFlushVolSync(@pb);
  107.             end;
  108.         end;
  109. {$IFC not BackgroundOnly}
  110.         if dump_totext then begin
  111.             if s[length(s)] = cr then begin
  112.                 Delete( s, length(s), 1 );
  113.                 writeln( s );
  114.             end else begin
  115.                 write(s);
  116.             end;
  117.         end;
  118. {$ENDC}
  119.     end;
  120.  
  121.     procedure DumpLine (s: Str255);
  122.     begin
  123.         DumpStr(concat(s, chr(13)));
  124.     end;
  125.  
  126.     procedure DumpNum (n: longint);
  127.     begin
  128.         DumpStr(NumToStr(n));
  129.     end;
  130.  
  131.     procedure DumpValue (s: Str255; n: longint);
  132.     begin
  133.         DumpStr(concat(s, ' ', NumToStr(n), chr(13)));
  134.     end;
  135.  
  136.     function HexN (n: integer): char;
  137.     begin
  138.         n := BAND(n, $F);
  139.         if n > 9 then
  140.             n := n + 7;
  141.         HexN := chr(n + 48);
  142.     end;
  143.  
  144.     function HexB (n: integer): Str15;
  145.     begin
  146.         n := BAND(n, $FF);
  147.         HexB := concat(HexN(BSR(n, 4)), HexN(n));
  148.     end;
  149.  
  150.     procedure DumpByte (n: integer);
  151.     begin
  152.         DumpStr(HexB(n));
  153.     end;
  154.  
  155.     procedure DumpWord (n: longint);
  156.     begin
  157.         DumpStr(concat(HexB(BSR(n, 8)), HexB(n)));
  158.     end;
  159.  
  160.     procedure DumpLong (n: longint);
  161.     begin
  162.         DumpStr(concat(HexB(BSR(n, 24)), HexB(BSR(n, 16)), HexB(BSR(n, 8)), HexB(n)));
  163.     end;
  164.  
  165.     procedure DumpData (p: Ptr; len: longint);
  166.         var
  167.             offset: longint;
  168.         procedure D (p: Ptr; n: integer);
  169.             var
  170.                 s: Str255;
  171.                 i, b: integer;
  172.         begin
  173.             s := concat(HexB(BSR(offset, 16)), HexB(BSR(offset, 8)), HexB(offset), ': ');
  174.             for i := 1 to 16 do begin
  175.                 if i <= n then
  176.                     s := concat(s, HexB(Ptr(ord(p) + i - 1)^))
  177.                 else
  178.                     s := concat(s, '  ');
  179.                 s := concat(s, ' ');
  180.                 if i mod 4 = 0 then
  181.                     s := concat(s, ' ');
  182.             end;
  183.             for i := 1 to n do begin
  184.                 b := BAND(Ptr(ord(p) + i - 1)^, $FF);
  185.                 if (b < 32) | (b >= 127) then
  186.                     b := ord('.');
  187.                 s := concat(s, chr(b));
  188.             end;
  189.             DumpLine(s);
  190.         end;
  191.     begin
  192.         offset := 0;
  193.         while (len > 16) do begin
  194.             D(p, 16);
  195.             p := Ptr(ord(p) + 16);
  196.             len := len - 16;
  197.             offset := offset + 16;
  198.         end;
  199.         if len > 0 then
  200.             D(p, len);
  201.     end;
  202.  
  203.     procedure DumpText (p: Ptr; len: longint);
  204.         var
  205.             offset: longint;
  206.             l, i: integer;
  207.             s: Str255;
  208.     begin
  209.         offset := 0;
  210.         while len > 0 do begin
  211.             l := 64;
  212.             if l > len then
  213.                 l := len;
  214.             BlockMove(p, @s[1], l);
  215.             s[0] := chr(l);
  216.             for i := 1 to length(s) do begin
  217.                 if (s[i] < chr(32)) or (s[i] >= chr(127)) then begin
  218.                     s[i] := '.';
  219.                 end;
  220.             end;
  221.             s := concat(HexB(BSR(offset, 16)), HexB(BSR(offset, 8)), HexB(offset), ': ', s);
  222.             DumpLine(s);
  223.             len := len - l;
  224.             p := Ptr(ord(p) + l);
  225.         end;
  226.     end;
  227.  
  228.     procedure DumpHeap (hz: THz);
  229. {$PUSH}
  230. {$ALIGN MAC68K}
  231.  
  232.         type
  233.             ExpandedBlockHeader = record
  234.                     typ: integer; { 0 = free, 1 = nonrel, 2 = rel }
  235.                     flags: integer; {res, purgeable, locked }
  236.                     correct: integer;
  237.                     hsize: integer;
  238.                     psize: longint;
  239.                     other: longint;
  240.                 end;
  241.         type
  242.             blockHeader = record
  243.                     l1: longint;
  244.                     l2: longint;
  245.                     l3: longint;
  246.                 end;
  247.             blockHeaderPtr = ^blockHeader;
  248. {$ALIGN RESET}
  249. {$POP}
  250.  
  251.         procedure ConvertHeader (p: blockHeaderPtr; var ebh: ExpandedBlockHeader);
  252.         begin
  253.             if false then begin
  254.                 ebh.typ := BAND(BSR(p^.l1, 30), $03);
  255.                 ebh.flags := 0;
  256.                 ebh.correct := BAND(BSR(p^.l1, 24), $0F);
  257.                 ebh.psize := BAND(p^.l1, $00FFFFFF);
  258.                 ebh.other := p^.l2;
  259.                 ebh.hsize := 8;
  260.             end
  261.             else begin
  262.                 ebh.typ := BAND(BSR(p^.l1, 30), $03);
  263.                 ebh.flags := BAND(BSR(p^.l1, 21), $07);
  264.                 ebh.correct := BAND(p^.l1, $00FF);
  265.                 ebh.psize := p^.l2;
  266.                 ebh.other := p^.l3;
  267.                 ebh.hsize := 12;
  268.             end;
  269.         end;
  270.  
  271.         var
  272.             p, data: Ptr;
  273.             h: Handle;
  274.             ebh: ExpandedBlockHeader;
  275.             s: Str255;
  276.             lsize: longint;
  277.             state: integer;
  278.             resfile: integer;
  279.             resid: integer;
  280.             restyp: ResType;
  281.             resname: Str255;
  282.             resfilename: Str255;
  283.             pb: FCBPBRec;
  284.             err: OSErr;
  285.     begin
  286.         DumpLine(StringOf('Heap Dump ', hz, '-', hz^.bkLim, ' ', hz^.zcbFree));
  287.         p := @hz^.heapData;
  288.         while OSType(p) < OSType(hz^.bkLim) do begin
  289.             ConvertHeader(blockHeaderPtr(p), ebh);
  290.             lsize := ebh.psize - ebh.correct - ebh.hsize;
  291.             data := Ptr(ord(p) + ebh.hsize);
  292.             s := StringOf(data, lsize : 10, ' ');
  293.             case ebh.typ of
  294.                 0: 
  295.                     s := concat(s, 'F');
  296.                 1: 
  297.                     s := concat(s, 'P');
  298.                 2:  begin
  299.                     h := RecoverHandle(data);
  300.                     s := StringOf(s, 'H ', h, ' ');
  301.                     state := HGetState(h);
  302.                     if BAND(state, $20) <> 0 then
  303.                         s := concat(s, 'R')
  304.                     else
  305.                         s := concat(s, ' ');
  306.                     if BAND(state, $40) <> 0 then
  307.                         s := concat(s, 'P')
  308.                     else
  309.                         s := concat(s, ' ');
  310.                     if BAND(state, $80) <> 0 then
  311.                         s := concat(s, 'L')
  312.                     else
  313.                         s := concat(s, ' ');
  314.                     if BAND(state, $20) <> 0 then begin
  315.                         resfile := HomeResFile(h);
  316.                         resfilename := 'Unknown resource file';
  317.                         if resfile <> -1 then begin
  318.                             pb.ioNamePtr := @resfilename;
  319.                             pb.ioVRefNum := 0;
  320.                             pb.ioRefNum := resfile;
  321.                             pb.ioFCBIndx := 0;
  322.                             err := PBGetFCBInfoSync(@pb);
  323.                         end;
  324.                         GetResInfo(h, resid, restyp, resname);
  325.                         s := StringOf(s, ' ', OSTypeToString(restyp), '=', resid : 1);
  326.                         if resname <> '' then
  327.                             s := concat(s, ' "', resname, '"');
  328.                         s := concat(s, ' [', resfilename, ']');
  329.                     end;
  330.                 end;
  331.             end;
  332.             DumpLine(s);
  333.             if lsize > 16 then
  334.                 lsize := 16;
  335.             DumpData(Ptr(ord(p) + ebh.hsize), lsize);
  336.             p := Ptr(ord(p) + ebh.psize);
  337.         end;
  338.         if Ptr(p) <> Ptr(hz^.bkLim) then begin
  339.             DumpLine('Hmmm, end of last block isn''t at the end of the heap!');
  340.         end;
  341.     end;
  342.  
  343.  
  344.  
  345.  
  346.  
  347.  
  348.  
  349.  
  350.  
  351.  
  352.  
  353.  
  354.  
  355.  
  356.  
  357.  
  358.  
  359.  
  360.  
  361.  
  362.  
  363.  
  364. end.