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