[Back to TEXTFILE SWAG index] [Back to Main SWAG index] [Original]

    {   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.

[Back to TEXTFILE SWAG index] [Back to Main SWAG index] [Original]