CP/M/CPM_CDROM.iso/simtel/sigm/vols000/vol063/fcount.pas

Pascal/Delphi Source File | 1985-02-09 | 10KB | 450 lines

PROGRAM fcount;

 {Program to read a disk file }
 {and count the number of chars and lines. }
 {Program will also allow splitting a long file }
 {into several pieces. }


CONST
   version = '1.0';
   sector_size = 128;   {#bytes in a sector}

   carriage_return = 13; {^M}
   line_feed  = 10;      {^J}
   eof_char  = 26;       {^Z}

TYPE
   byte = 0..255;
   sector_array = PACKED ARRAY [1..sector_size] OF byte;
   sector_file  = FILE OF sector_array;

   ctr_array  = PACKED ARRAY [1..2] OF INTEGER;  {1=units, 2=thousands}

   outch_array = PACKED ARRAY [1..3] OF byte;
   char12 = PACKED ARRAY [1..12] OF CHAR;

VAR
   infile   :sector_file;
   infilename   :char12;

   outf_flag   :BOOLEAN;  {true if outfile present}
   outfile   :sector_file;
   outfilename   :char12;

   list_flag   :BOOLEAN;    {list output}


   in_buffer   :sector_array;
   in_bufptr   :INTEGER;

   out_buffer   :sector_array;
   out_bufptr   :INTEGER;

   char_ctr   :ctr_array;
   line_ctr   :ctr_array;
   line_mod_ctr   :ctr_array;
   line_thousands_limit  :INTEGER;


   status   :INTEGER;
   i        :INTEGER;

{----------------------------------------------------------}
{----------------------------------------------------------}
{ Increment a symbolic name.  Eg  XXX021 to XXX022. }

PROCEDURE incr_name (VAR name :char12);

VAR
   i    :INTEGER;
   col   :INTEGER;
   flag   :BOOLEAN;

BEGIN{PROCEDURE}
   col := 12;
   WHILE (col>=1) AND (name[col]=' ') DO  col := col - 1;

   flag := TRUE;
   WHILE flag AND (col>=1) DO BEGIN
      i := ORD (name[col]) + 1;
      IF i <= ORD('9') THEN BEGIN
         flag := FALSE;
         name[col] := CHR(i);
        END
      ELSE  BEGIN
         name[col] := '0';
         col := col - 1;
      END{IF};
   END{WHILE};
END{PROCEDURE};


{--------------------------------------------------}
{Reset a big-counter to zero }

PROCEDURE ctr_reset (VAR ctr :ctr_array);

BEGIN{PROCEDURE}
   ctr[1] := 0;
   ctr[2] := 0;
END{PROCEDURE};

{--------------------------------------------------}
{Increments a big-counter. }

PROCEDURE ctr_count  (VAR ctr :ctr_array);

BEGIN{PROCEDURE}
   ctr[1] := ctr[1] + 1;
   IF ctr[1] >= 1000 THEN BEGIN
      ctr[2] := ctr[2] + 1;
      ctr[1] := 0;
   END{IF};
END{PROCEDURE};


{-------------------------------------------------------------}
{Test a counter against another counter}
{Returns TRUE if counter A is bigger than counter B}

FUNCTION ctr_gtr (ctra :ctr_array;
                  ctrb :ctr_array )
                 : BOOLEAN;
BEGIN{FUNCTION}
   ctr_gtr := FALSE;

   IF ctra[2] > ctrb[2] THEN ctr_gtr := TRUE;

   IF ctra[2] = ctrb[2] THEN ctr_gtr :=  ctra[1] > ctrb[1];
END{FUNCTION};


{-------------------------------------------------------------}
{Print a big-counter }

PROCEDURE ctr_print (ctr :ctr_array);

BEGIN{PROCEDURE}
   WRITE (ctr[2], ',' ,  ctr[1]:3 );
END{PROCEDURE};


{-------------------------------------------------------------}
PROCEDURE get_outfilename;

BEGIN{PROCEDURE}
   WRITE('Enter the output filename: ');
   outfilename := '            ';
   READLN (outfilename);

   outf_flag := TRUE;
   IF outfilename = '            '  THEN outf_flag := FALSE;

END{PROCEDURE};

{-------------------------------------------------------------}
PROCEDURE get_infilename;

BEGIN{PROCEDURE}
   WRITE('Enter the input filename: ');
   infilename := '            ';
   READLN (infilename);
END{PROCEDURE};

{------------------------------------------------------------}
FUNCTION get_limit  :INTEGER;

VAR
   result   :INTEGER;

BEGIN{FUNCTION}
   READLN (result);
   IF result=0 THEN result := MAXINT-1;
   get_limit := result;
END{FUNCTION};


{------------------------------------------------------------}

FUNCTION open_infile  :INTEGER;

VAR
   result   :INTEGER;

BEGIN{FUNCTION}
   RESET(infilename,infile);

   in_bufptr := sector_size + 1;

   result := 0;
   IF EOF(infile) THEN result := -1;

   WRITELN('Open input file: ',infilename:12,
           '   result=', result );

   open_infile := result;

END{FUNCTION};

{-------------------------------------------------------------}

FUNCTION open_outfile   :INTEGER;

VAR
   result   :INTEGER;

BEGIN{FUNCTION}
   REWRITE (outfilename, outfile);

   out_bufptr := 0;

   result := 0;

   WRITELN('Open output file: ', outfilename,
           '   result=', result );

END{FUNCTION};

{--------------------------------------------------------}
{Opens the next output file in sequence.}
{Returns 0 if no error, <0 if error. }

FUNCTION open_next_outfile  :INTEGER;

VAR
   result   :INTEGER;

BEGIN{FUNCTION}
   incr_name (outfilename);

   result := open_outfile;

   open_next_outfile := result;
END{FUNCTION};


{--------------------------------------------------------}
{Reads the next sector from the input file. }
{Returns 0 = normal;  -1 = error or EOF. }

FUNCTION read_infile  :INTEGER;

BEGIN{FUNCTION}
   IF EOF(infile) THEN BEGIN
      read_infile := -1;
      in_bufptr := sector_size + 1;
      END
   ELSE BEGIN
      READ (infile, in_buffer);
      in_bufptr := 0;
      read_infile := 0;
   END{IF};
END{FUNCTION};

{--------------------------------------------------------}
{Writes the next sector into the output file. }
{Returns 0 = normal,  <0 if error. }

FUNCTION write_outfile    :INTEGER;

BEGIN{FUNCTION}
   WRITE(outfile, out_buffer);
   out_bufptr := 0;
   write_outfile := 0;
END{FUNCTION};


{--------------------------------------------------------}

FUNCTION close_infile  :INTEGER;

BEGIN{FUNCTION}
   close_infile := 0;
END{FUNCTION};


{--------------------------------------------------------}

FUNCTION close_outfile  :INTEGER;
BEGIN{FUNCTION}
   close_outfile := 0;
END{FUNCTION};


{--------------------------------------------------------}
{Gets the next char (pseudochar, a byte) from the input buffer.}
{Signals EOF by returning -1.  Returns 0 if get a char. }


FUNCTION get_char ( VAR in_char :byte )  :INTEGER;

VAR
   status   :INTEGER;

BEGIN{FUNCTION}
   status := 0;
   IF in_bufptr >= sector_size THEN BEGIN
      status := read_infile;
   END{IF};

   IF status = 0 THEN BEGIN
      in_bufptr := in_bufptr + 1;
      in_char := in_buffer[in_bufptr];
      IF in_char = eof_char THEN status := -1;
   END{IF};

   get_char := status;
END{FUNCTION};

{--------------------------------------------------------}

FUNCTION put_char (out_char :byte)  :INTEGER;

VAR
   status   :INTEGER;

BEGIN
   status := 0;

   out_bufptr := out_bufptr + 1;
   out_buffer[out_bufptr] := out_char;

   IF out_bufptr >= sector_size THEN BEGIN
      status := write_outfile;
   END{IF};

   put_char := status;
END{FUNCTION};


{--------------------------------------------------------}
{Purge any chars still remaining in the output buffer}

PROCEDURE put_purge;

VAR
   i       :INTEGER;
   remaining   :INTEGER;
   status   :INTEGER;

BEGIN{PROCEDURE}
   status := put_char (eof_char);  {ensure at least 1 EOL}
   remaining := sector_size - out_bufptr;
   FOR i:= 1 TO remaining DO BEGIN
      status := put_char (eof_char);
   END{FOR};
END{PROCEDURE};


{--------------------------------------------------------}

PROCEDURE putout_char (in_char :byte);

VAR
   result   :INTEGER;

BEGIN{PROCEDURE}
   IF outf_flag THEN BEGIN
      result := put_char (in_char);
      IF line_mod_ctr[2] > line_thousands_limit THEN BEGIN
         put_purge;
         result := open_next_outfile;
         ctr_reset (line_mod_ctr);
      END{IF};
   END{IF};
END{PROCEDURE};

{----------------------------------------------------}

PROCEDURE count_char (in_char :byte);

BEGIN{PROCEDURE}
   ctr_count (char_ctr);

   IF in_char = carriage_return THEN BEGIN
      ctr_count (line_ctr);
      ctr_count (line_mod_ctr);
   END{IF};
END{PROCEDURE};


{--------------------------------------------------}

FUNCTION count_file   :INTEGER;

VAR
   i        :INTEGER;
   status   :INTEGER;
   in_char  :byte;
   out_chars :outch_array;
   εchars   :INTEGER;

BEGIN{FUNCTION}
   status := 0;
   ctr_reset (line_ctr);
   ctr_reset (line_mod_ctr);
   ctr_reset (char_ctr);

   WHILE status = 0  DO BEGIN
      status := get_char (in_char);
      IF (status<>0) AND outf_flag THEN BEGIN
         put_purge;
        END
      ELSE BEGIN
         count_char (in_char);
         IF outf_flag THEN putout_char (in_char);
      END{IF};
   END{WHILE};
   count_file := status;
END{FUNCTION};


{--------------------------------------------}
{--------------------------------------------}

BEGIN{PROGRAM}
   WRITELN ('Fcount  Version ', version);

   get_infilename;
   status := open_infile;
   IF status<>0 THEN BEGIN
      WRITELN('*** Could not open input file ', infilename);
   END{IF};

   IF status=0  THEN BEGIN
      get_outfilename;
      IF outf_flag THEN BEGIN
         status := open_outfile;
         IF status<>0 THEN BEGIN
            WRITELN('*** Could not open ouput file ', outfilename);
         END{IF};
      END{IF};
   END{IF};

   IF status=0 THEN BEGIN
      WRITE('Enter max #lines per file (in thousands: ');
      line_thousands_limit := get_limit;
      IF line_thousands_limit > 0 THEN BEGIN
         WRITELN('NOTE that filename should be xxxxx.001');
      END{IF};
   END{IF};

   IF status=0 THEN BEGIN
      status := count_file;
   END{IF};

   ctr_print (line_ctr);
   WRITE (' lines. ');
   ctr_print (char_ctr);
   WRITE (' characters.');
   WRITELN;

   status := close_input;

   IF outf_flag THEN BEGIN
      status := close_output;
   END{IF};

END{PROGRAM}.