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