POINT Software Programming/PPROG1.ISO/pascal/swag/textfile.swg/0002_HEXDUMP.PAS.pas

Pascal/Delphi Source File | 1993-05-28 | 11.4 KB | 332 lines

{   In the following message is a Complete Program I just wrote
(including 3 routines from TeeCee's hints) which solves a particular
problem I was having, but also demonstrates some things I see queried
here.  So, there are a number of useful routines in it, as well as a
whole Program which may help.
   This Program dumps a Dos File to Hex and (modified) BCD.  It is
patterned after Vernon Buerg's LIST display (using Alt-H), which I find
useful to look at binary Files.  The problem is (was) I couldn't PrtSc
the screens, due to numerous special Characters which often hung my
Printer.  So, I wrote this Program to "dump" such Files to either the
Printer or a Printer File.  It substitutes an underscore For most
special Characters (you can change this, of course).
   note, too, that it demonstates the use of a C-like Character stream
i/o, which is a Variation of the "stream i/o" which is discussed here.
This allows fast i/o of any Type of File, and could be modified to
provide perFormant i/o For Text Files.
   A number of the internal routines are a bit clumsy, since I had to
(107 min left), (H)elp, More? make them "generic" For this post, rather than make use of after-market
libraries that I use (TTT, in my Case).
   Enjoy!...
}

Program Hex_Dump;        { Dump a File in Hex and BCD   930107 }
Uses Crt, Dos, Printer;
{$M 8192,0,8192}
   {  Public Domain, by Mike Copeland and Trevor Carlsen  1993 }
Const VERSION = '1.1';
      BSize   = 32768;                           { Buffer Size }
      ifLinE  = 4;                          { InFormation Line }
      PRLinE  = 24;                              { Prompt Line }
      ERLinE  = 25;                               { Error Line }
      DSLinE  = 22;                             { Display Line }
      PL      = 1;                          { partial line o/p }
      WL      = 2;                            { whole line o/p }
      B40     = '                                        ';
Var   CP      : Word;                      { Character Pointer }
      BLKNO   : Word;                                { Block # }
      L,N     : Word;
      RES     : Word;
      LONG    : LongInt;
      NCP     : LongInt;              { # Characters Processed }
      FSize   : LongInt;                  { Computed File Size }
      BV      : Byte;                  { generic Byte Variable }
      PRtoK   : Boolean;
      PFP     : Boolean;
      REGS    : Registers;
      PRTFile : String;
      F1      : String;
      MSTR,S1 : String;
      PFV1    : Text;
      F       : File;
      B       : Array[0..BSize-1] of Byte;
      CH      : Char;

Procedure WPROM (S : String);             { generalized Prompt }
begin
  GotoXY (1,PRLinE); Write (S); ClrEol; GotoXY (Length(S)+1,PRLinE);
end;  { WPROM }

Procedure CLEARBOT;                   { clear bottom of screen }
begin
  GotoXY (1,PRLinE); ClrEol; GotoXY (1,ERLinE); ClrEol
end;  { CLEARBOT }

Function GETYN : Char;               { get Single-key response }
Var CH : Char;
begin
  CH := UpCase(ReadKey); if CH = #0 then CH := ReadKey;
  CLEARBOT; GETYN := CH;
end;  { GETYN }

Procedure PAUSE;              { Generalized Pause processing }
Var CH : Char;
begin
  WPROM ('Press any key to continue...'); CH := GETYN
end;  { PAUSE }

Procedure ERRor1 (S : String);       { General Error process }
Var CH : Char;
begin
  GotoXY (1,ERLinE); Write (^G,S); ClrEol; PAUSE
end;  { ERRor1 }

Procedure FATAL (S : String);      { Fatal error - Terminate }
begin
  ERRor1 (S); Halt
end;  { FATAL }

Function TEStoNLinE : Byte;      { Tests For Printer On Line }
Var  REGS : Registers;
begin
  With REGS do
    begin
      AH := 2; DX := 0;
      Intr($17, Dos.Registers(REGS));
      TEStoNLinE := AH;
    end
end;  { TEStoNLinE }

Function SYS_DATE : String;   { Format System Date as YY/MM/DD }
Var S1, S2, S3 : String[2];
begin
  REGS.AX := $2A00;                                 { Function }
  MsDos (Dos.Registers(REGS));             { fetch System Date }
  With REGS do
    begin
      Str((CX mod 100):2,S1); Str(Hi(DX):2,S2); Str(Lo(DX):2,S3);
    end;
  if S2[1] = ' ' then S2[1] := '0';           { fill in blanks }
  if S3[1] = ' ' then S3[1] := '0';
  SYS_DATE := S1+'/'+S2+'/'+S3
end;  { SYS_DATE }

Function SYS_TIME : String;               { Format System Time }
Var S1, S2, S3 : String[2];
begin
  REGS.AX := $2C00;                                 { Function }
  MsDos (Dos.Registers(REGS));             { fetch System Time }
  With REGS do
    begin
      Str(Hi(CX):2,S1); Str(Lo(CX):2,S2); Str(Hi(DX):2,S3);
    end;
  if S2[1] = ' ' then S2[1] := '0';           { fill in blanks }
  if S3[1] = ' ' then S3[1] := '0';
  if S1[1] = ' ' then S1[1] := '0';
  SYS_TIME := S1+':'+S2+':'+S3
end;  { SYS_TIME }

Function EXISTS ( FN : String): Boolean;  { test File existance }
Var F : SearchRec;
begin
  FindFirst (FN,AnyFile,F); EXISTS := DosError = 0
end;  { EXISTS }

Function UPPER (S : String) : String;
Var I : Integer;
begin
  For I := 1 to Length(S) do
    S[I] := UpCase(S[I]);
  UPPER := S;
end;  { UPPER }

Procedure SET_File (FN : String);      { File Output For PRinT }
begin
  PRTFile := FN; PFP := False; PRtoK := False;
end;  { SET_File }

Procedure PRinT_inIT (S : String);  { Initialize Printer/File Output }
Var X,Y : Word;
begin
  PRtoK := TestOnLine = 144; PFP := False; X := WhereX; Y := WhereY;
  if PRtoK then
    begin
      WPROM ('Printer is Online - do you wish Printer or File? (P/f) ');

      if GETYN = 'F' then SET_File (S)
      else
        begin
          WPROM ('Please align Printer'); PAUSE
        end
    end
  else SET_File (S);
  GotoXY (X,Y)                            { restore cursor }
end;  { PRinT_inIT }

Function OPENF (Var FV : Text; FN : String; MODE : Char) : Boolean;
Var FLAG  : Boolean;
begin
  FLAG := True;                             { set default }
  Assign (FV, FN);                        { allocate File }
  Case UpCase(MODE) of                        { open mode }
    'W' : begin                                  { output }
            {$I-} ReWrite (FV); {$I+}
          end;
    'R' : begin                                   { input }
            {$I-} Reset (FV); {$I+}
          end;
    'A' : begin                            { input/extend }
            {$I-} Append (FV); {$I+}
          end;
    else
  end; { of Case }
  if Ioresult <> 0 then          { test For error on OPEN }
    begin
      FLAG := False;           { set Function result flag }
      ERRor1 ('*** Unable to OPEN '+FN);
    end;
  OPENF := FLAG                        { set return value }
end;  { OPENF }

Procedure PRinT (inD : Integer; X : String); { Print Report Line }
Var AF : Char;                              { Append Flag }
    XX,Y : Word;
begin
  if PRtoK then                         { Printer online? }
    begin
      Case inD of              { what Type of print line? }
        PL  : Write (LST, X);              { partial line }
        WL  : Writeln (LST, X);              { whole line }
      end
    end  { Printer o/p }
  else                                     { use o/p File }
    begin
      XX := WhereX; Y := WhereY;
      if not PFP then                   { File not opened }
        begin
          AF := 'W';                            { default }
          if EXISTS (PRTFile) then
            begin
              WPROM ('** Print File '+PRTFile+' exists - Append to it? (Y/n) ');
              if GETYN <> 'N' then AF := 'A';
            end;
          if OPENF (PFV1, PRTFile, AF) then PFP := True { set flag }
          else FATAL ('*** Cannot Open Printer O/P File - Terminating');

        end;  { of if }
      GotoXY (XX,Y);                      { restore cursor }
      Case inD of
        PL  : Write (PFV1, X);                   { partial }
        WL  : Writeln (PFV1, X);                   { whole }
      end;
    end;  { else }
end;  { PRinT }

Function FSI (N : LongInt; W : Byte) : String; { LongInt->String }
Var S : String;
begin
  if W > 0 then Str (N:W,S)
  else          Str (N,S);
  FSI := S;
end;  { FSI }

Procedure CLOSEF (Var FYL : Text);  { Close a File - open or not }
begin
{$I-} Close (FYL); {$I+} if Ioresult <> 0 then;
end;  { CLOSEF }

Function CENTER (S : String; N : Byte): String;  { center N Char line }
begin
  CENTER := Copy(B40+B40,1,(N-Length(S)) Shr 1)+S
end;  { CENTER }

Procedure SSL;                              { System Status Line }
{  This routine is just For "flash"; it can be omitted... }
Const DLM = #32#179#32;
begin
  GotoXY (1,1); Write (F1+DLM+'Fsz: '+FSI(FSize,1)+DLM+
                             'Blk: '+FSI(BLKNO,1)+DLM+
                             'C# '+FSI(CP,1));
end;  { SSL }

           {  The following 3 routines are by Trevor Carlsen }
Function Byte2Hex(numb : Byte): String; { Byte to hex String }
Const HexChars : Array[0..15] of Char = '0123456789ABCDEF';
begin
  Byte2Hex[0] := #2; Byte2Hex[1] := HexChars[numb shr 4];
  Byte2Hex[2] := HexChars[numb and 15];
end; { Byte2Hex }

Function Numb2Hex(numb: Word): String;  { Word to hex String.}
begin
  Numb2Hex := Byte2Hex(hi(numb))+Byte2Hex(lo(numb));
end; { Numb2Hex }

Function Long2Hex(L: LongInt): String; { LongInt to hex String }
begin
  Long2Hex := Numb2Hex(L shr 16) + Numb2Hex(L);
end; { Long2Hex }

Function GET_Byte: Byte;         { fetch Byte from buffer data }
begin
  GET_Byte := Byte(B[CP]); Inc (CP); Inc (NCP)
end;  { GET_Byte }

Function EOS (Var FV : File): Boolean; { Eof on String File Function }
begin
  if CP >= RES then                    { data still in buffer? }
    if NCP < FSize then
      begin                               { no - get new block }
        BLKNO := (NCP div BSize);
        FillChar(B,BSize,#0);                  { block to read }
        Seek (F,BLKNO*BSize); BlockRead (F,B,BSize,RES); CP := 0;
      end
    else RES := 0;
  EOS := RES = 0;
end;  { EOS }

begin
  ClrScr; GotoXY (1,2);
  Write (CENTER('--- Hex Dump - Version '+VERSION+' ---',80));
  if ParamCount > 0 then F1 := ParamStr(1)
  else
    begin
      WPROM ('Filename to be dumped: '); readln (F1); CLEARBOT
    end;
  if not EXISTS (F1) then FATAL ('*** '+F1+' File not present - Terminating! ***');
  PRinT_inIT ('HEXDUMP.TXT'); F1 := UPPER(F1);
  PRinT (WL,CENTER('Hex Dump of '+F1+'  '+SYS_DATE+' '+SYS_TIME,80));
  Assign (F,F1); GotoXY (1,ifLinE); Write ('Processing ',F1);
  Reset (F,1); FSize := FileSize(F); CP := BSize; NCP := 0; RES :=
BSize;
  PRinT (WL,'offset  Addr  1  2  3  4  5  6  7  8  9 10  A  B  C  D  E  F  1234567890abcdef');
  While not EOS (F) do
    begin
      if (NCP mod 16) = 0 then
        begin
          if NCP > 0 then
            begin
              PRinT (WL,MSTR+S1); SSL
            end;
          MSTR := FSI(NCP,6)+'  '+Numb2Hex(NCP); { offset & Address }
          S1 := '  ';
        end;
      BV := GET_Byte;                 { fetch next Byte from buffer }
      MSTR := MSTR+' '+Byte2Hex(BV);                     { Hex info }
      if BV in [32..126] then S1 := S1+Chr(BV)           { BCD info }
      else                    S1 := S1+'_';
    end;
  Close (F);
  While (NCP mod 16) > 0 do
    begin
      MSTR := MSTR+'   '; Inc (NCP);           { fill out last line }
    end;
  PRinT (WL,MSTR+S1); SSL; MSTR := 'Printer';
  if PFP then
    begin
      CLOSEF (PFV1); MSTR := PRTFile
    end;
  GotoXY (1,ifLinE+1); Write ('Formatted output is on ',MSTR);
  GotoXY (1,ERLinE); Write (CENTER('Finis...',80))
end.