Oakland CPM Archive/oakcpm.iso/sigm/vol293/toc.lbr/TBLCTENT.PAS

Pascal/Delphi Source File | 1986-12-17 | 17.3 KB | 510 lines

program tblctent(input, output, infile, outfile);

(* WordStar file utility  --  9-21-85  Ver 1.0P *)
(* Copyright  1985  by Dean A. Fields           *)
(*                                              *)
(* Written in TURBO PASCAL Ver. 3.0             *)
(*     on a COMPAQ                              *)
(*                                              *)
(* Creates a Table of Contents  for  a WordStar *)
(*   document file.  TBLCTENT looks for control *)
(*   codes, and takes whatever is between them  *)
(*   and places it in the table of contents     *)
(*   file.  The control codes are, ^R to start  *)
(*   and stop inclusion into the table of       *)
(*   contents file.  They are placed in the     *)
(*   file by entering a ^P^R at the begining    *)
(*   and end of the text you want included into *)
(*   the table of contents file.  The ^R's      *)
(*   should never have WordStar dot commands    *)
(*   between them.  The name of the table of    *)
(*   contents file is the same as the input     *)
(*   document, except the file type which is    *)
(*   ".TBC".                                    *)
(*                                              *)

Const
    MaxLineLen = 255;              (* max. input line length *)
    version = '1.0P';              (* version number *)
    date = 'September 21, 1985';   (* release date *)
    MaxNum = 4;                    (* maximum number of digits for .PN n *)
    space = $20;
    bell = 07;
    lf = 10;
    cr = $0D;
    ctlr = 18;
    period = 46;
    tens = 10;
    hundreds = 100;
    thous = 1000;
    MaxChrs = 55;                  (* max. char.s allowed for TBC entry *)
    PageLen = 55;                  (* number of lines per page *)
    ControlR_1 : boolean = false;
    ControlR_2 : boolean = false;
    dop : boolean = false;
    ChNum : integer = 1;
    page_num : integer = 0;
    line : integer = 0; (* variable that contains the current *)
                        (*     TBC line # being output for    *)
                        (*     the current TBC page           *)
(*
 * TblLine is the next line to be printed to the .TBC file
 *)
    TblLine : integer = 7; (* initialize TblLine to 7 *)

TYPE
    AnyString= string[255];

VAR
    infile, outfile : text;
    LineIn : array[1..MaxLineLen] of byte;
    LoopCntr, chrcnt, indx : integer;
    dot_cmnd, cancel : boolean;
    page_num_print : array[1..4] of byte;
    ch : char;    (* character read from input file *)

(*
 * The following function converts any lower case characters in a string
 * to upper case, and was copied from TURBO PASCAL manual (v3.0) page 146.
 *)
FUNCTION StUpCase(st:anystring):anystring;
VAR
    I : integer;
begin (* FUNCTION StUpCase *)
    for i:= 1 to length(st) do
        st[i] := upcase(st[i]);
    stupcase := st;
end;


(*
 * This procedure opens the input and output files
 *)
PROCEDURE open_files;
VAR
    infname : string[20];
    outfname : string[20];
    ans : string[10];
    goodfile : boolean;
    dotpos, FileNmeEnd : integer;

BEGIN
    repeat
        write('Enter input filename  --> ');
        readln(infname);
        infname := StUpCase(infname);
        assign(infile, infname);
        {$I-} reset(infile) {$I+};
        goodfile := (IOresult = 0);
        if not goodfile then
        begin
            clrscr;
            GotoXY(1,6);
            write (chr(bell));
            writeln('FILE ', infname, 'NOT FOUND!!!');
            delay(6000);
        end;
    until goodfile;
    repeat
        dotpos := 0;
        FileNmeEnd := length(infname);
        dotpos := POS('.', infname);
        if (dotpos > 0) then
        begin
            dotpos := pred(dotpos);
            outfname := copy(infname, 1, dotpos);
        end
        else
            outfname := copy(infname, 1, FileNmeEnd);
        insert('.TBC', outfname, (FileNmeEnd+1));
        FileNmeEnd := 20 - (FileNmeEnd+4);
        delete(outfname, (FileNmeEnd+5), FileNmeEnd);
        assign(outfile, outfname);
        {$I-} reset(outfile) {$I+};
        goodfile := (IOresult <> 0);
        if not goodfile then
        begin
            write(chr(bell), 'FILE ', outfname, ' EXISTS, OVERWRITE? (Y/N) ');
            readln(ans);
            goodfile := (UpCase(ans[1]) = 'Y');
            gotoxy(1, 7);
            write('                                            ');
(*
 * the following code allows a to return to DOS, after
 * closing the input file; in the event that goodfile comes
 * back as an 'N'.
 *)
            if not goodfile then
            begin
                cancel := true;
            end
        end;
    until goodfile;
    rewrite(outfile);
(*
 * output standard Table of Content header to output file
 *)
    writeln(outfile, '.op');
    writeln(outfile);
    writeln(outfile);
    writeln(outfile, '                        Table of Content');
    writeln(outfile);
    writeln(outfile);
    writeln(outfile);
    end; (* procedure open_files *)


(*
 * The following procedure reads a line of input, ended by CRLF, into an
 * internal buffer, for further processing. As the input characters are
 * read they are anded with decimal 127 to strip of the 8th bit, if it's
 * set.
 *)
    PROCEDURE get_line;
    VAR
        lonum : byte;    (* variable used to strip 8th bit *)

    begin
        ch := chr(0);
        lonum := 0;
        chrcnt := 0;
        while not eof(infile) and (lonum <> lf) do
        begin
            chrcnt := succ(chrcnt);
            read(infile, ch);
            lonum := (ord(ch) and 127);
            LineIn[chrcnt] := lonum;
        end
    end; (* procedure get_line *)


(*
 * Procedure test_line searches the input line, that has been read in
 * by get_line, for the following conditions:
 *        .OP  -> which causes the program to stop searching for Table
 *                of Content information, because .OP turns off page
 *                number and therefore there is no page number to
 *                associate to the Table of Content entry, and thus
 *                no reason to report a Table of Content entry.
 *
 *        .PA     which causes the page number variable to be
 *                inceremented
 *        .PN n   which causes the page number variable to be set
 *                to number n of the .PN n command.  n can not be
 *                larger than 9999.
 *)
    PROCEDURE test_line;
    VAR
        pndx : integer;    (* index for page_num_print array *)

    begin
        dot_cmnd := false; (* initialize dot_cmnd to false *)
(*
 * search for .OP
 *)
        if LineIn[1] = period then
        begin
            ch := chr(LineIn[2]);
            if UpCase(ch) = 'O' then
            begin
                ch := chr(LineIn[3]);
                if UpCase(ch) = 'P' then
                begin
                    line := 0;
                    dop := true;
                end
            end
        end;
(*
 * search for .PA
 *)
        if LineIn[1] = period then
        begin
            ch := chr(LineIn[2]);
            if UpCase(ch) = 'P' then
            begin
                ch := chr(LineIn[3]);
                if UpCase(ch) = 'A' then
                begin
                    line := 0;
                    dot_cmnd := true;
                    page_num := succ(page_num);
                end
            end
        end;
(*
 * search for .PN n
 *)
        if LineIn[1] = period then
        begin
           ch := chr(LineIn[2]);
           if UpCase(ch) = 'P' then
           begin
               ch := chr(LineIn[3]);
               if Upcase(ch) = 'N' then
               begin
                   line := 0;
                   dop := false; (* reset dop flag *)
                   dot_cmnd := true;
                   indx := 4;
(*
 * ignore spaces between .pn and number, if any
 *)
                   while LineIn[indx] = space do indx := succ(indx);
                   pndx := 0;
                   repeat
                       pndx := succ(pndx);
                       page_num_print[pndx] := LineIn[indx];
                       indx := succ(indx);
                       if pndx > MaxNum then
                       begin
                           if LineIn[indx] <> cr then
                           begin
                               ClrScr;
                               gotoxy(1,10);
                               writeln(chr(bell),'Invalid .PN command, number is too large');
                               writeln('Last valid page number was ', page_num);
                               writeln('Table of Content program ABORTING!!');
                               delay(6000);
                               cancel := true;
                               LineIn[indx] := cr;  (* force repeat until to end *)
                           end
                       end;
                   until LineIn[indx] = cr;
(*
 * the follow code converts the n, of the .PN n command, from a text number
 * to an integer number
 *)
                   page_num := page_num_print[pndx] - 48;
                   Case pndx of
                       2 : begin
                           page_num := page_num + ((page_num_print[pndx-1] - 48) * tens);
                           end;
                       3 : begin
                           page_num := page_num + ((page_num_print[pndx-1] - 48) * tens);
                           page_num := page_num + ((page_num_print[pndx-2] - 48)* hundreds);
                           end;
                       4 : begin
                           page_num := page_num + ((page_num_print[pndx-1] - 48) * tens);
                           page_num := page_num + ((page_num_print[pndx-2] - 48) * hundreds);
                           page_num := page_num + ((page_num_print[pndx-3] - 48) * thous);
                           end;
                   end (* case *)
               end (* if *)
           end (* if *)
       end (* if *)
     end; (* procedure test_line *)


(*
 * Procedure translate_line translates fenced Table of Content entries
 * into Table of Content entries in the Table of Content file. (if you
 * can figure out that last sentence, you'll have no problem with the
 * this program) Control R is the fence character. This procedure
 * searches for a Control R. When the first Control R is encountered, a
 * flag (ControlR_1) is set true and the following characters are written
 * to the Table of Content file. When a second control R is found then a
 * flag (ControlR_2) is set true, which ends character writting to the
 * Table of Content file, clears both Control R flags, formats the rest
 * of the Table of Content line, and puts in the page number for that
 * entry.
 *)
    PROCEDURE translate_line;
    VAR
        indx1 : integer;         (* index used to step thru the input line *)
        RemainChrs : integer;    (* variable to contain the number of   *)
                                 (*    characters remaining in the TBC  *)
                                 (*    line being printed. Used for     *)
                                 (*    formatting TBC lines so that     *)
                                 (*    they look uniform.               *)

    begin (* procedure translate_line *)
        for indx1 := 1 to chrcnt do    (* process every character in the line *)
        begin
(*
 * check for a ^R
 *)
            if LineIn[indx1] = ctlr then
            begin
                indx1 := succ(indx1);
(*
 * if a ^R found, then determine which one
 *)
                if (ControlR_1) then ControlR_2 := true
                else ControlR_1 := true;
            end;
(*
 * the follwoing code is executed if the 2nd ^R is found
 *)
            if ControlR_2 then
            begin
                ControlR_1 := false;
                ControlR_2 := false;
(*
 * keep TBC lines to 55 characters wide, max
 *)
                if ChNum > MaxChrs then ChNum := MaxChrs;
(*  determine the number of characters not used, out of a max. of 55 *)
                    RemainChrs := MaxChrs - ChNum;
(*  if RemainChrs does not divide evenly by 2, then a space is       *)
(*  needed before you can start putting the dots on the TBC line     *)
                    if (RemainChrs MOD 2) > 0 then
                        write(outfile, ' ');
(*  integer div. of RemainChrs by 2 yields the number of dots to be  *)
(*  printed                                                          *)
                RemainChrs := RemainChrs DIV 2;
                write(outfile, ' ');
(*  print the dots                                                   *)
                for LoopCntr := 1 to RemainChrs do
                    write(outfile, '. ');
(*  print the page number                                            *)
                write(outfile, page_num:4);
                writeln(outfile);
(* incerement the TBC line counter and reset the TBC character       *)
(*  counter to 1                                                     *)
                TblLine := succ(TblLine);
                ChNum := 1
            end;
(*
 * the follwoing code is executed if the 1st ^R is found
 *)
            if ControlR_1 then
            begin
                if ChNum = 1 then
                begin
                    write(outfile, '   ');    (* indent each TBC line by 3 char.s *)
                end;
                if ChNum < MaxChrs then
                begin
(*
 * CR and LF are filtered from Table of Content entries, in the event
 * that an entry spans a line.
 *)
                    if LineIn[indx1] <> cr then
                    begin
                        if LineIn[indx1] <> lf then
                        begin
(*
 * filter out control characters
 *)
                            if LineIn[indx1] > 31 then
                            begin
                                ch := chr(LineIn[indx1]);
                                write(outfile, UpCase(ch));
                                ChNum := succ(ChNum)
                            end (* if > 31 *)
                        end (* if lf *)
                    end (* if cr *)
                end (* if ChNum *)
            end (* if *)
        end; (* for *)
    end; (* procedure translate_line *)


(*
 * The following function returns a true value if the
 * character input was a "Y" or "y"
 *)
    FUNCTION inyn : boolean;
    VAR
        ans : string[10];

    begin
        write('Y/N  ');
        readln(ans);
        inyn := (UpCase(ans[1]) = 'Y')
    end; (* function inyn *)


  (*
   * The process procedure controls Table of Content processing,
   * if the program is not canceled at the open_file procedure.
   * This procedure executes get_line to retrieve a line from
   * the input file; executes test_line to search for WordStar
   * dot commands; executes translate_line, depending on the
   * results of test_line, and counts the number of pages of
   * input to be scanned for Table of Content entries.
   *)
    PROCEDURE process;
    VAR
        contnu : boolean;   (* set false if program is to be *)
                            (*     abnormally ended *)

    BEGIN
        contnu := true;
        gotoxy(1,12);
        write('Page # ');
        while contnu do
        begin
            get_line;
            test_line;
            if not cancel then
            begin
                if not dop then
                begin
                    if not dot_cmnd then
                    begin
                        line := succ(line);
                        if line > PageLen then
                        begin
                            line := 0;
                            page_num := succ(page_num)
                        end; (* if line > PageLen *)
                        translate_line;
                        gotoxy(8, 12);
                        write(page_num:5)
                    end (* if not dot_cmnd *)
                end (* if not dop *)
            end
            else
                contnu := false;
        if eof(infile) then
            contnu := false;
        end (* while contnu *)
    end; (* procedure process *)


(*
 * The exit procedure displays an end of processing message, closes
 * all open files, and returns to DOS
 *)
    PROCEDURE exit;
    begin
        ClrScr;
        gotoxy(1, 11);
        if cancel then
        begin
            writeln('Table of Contents program Aborted!!');
            close(infile);
            close(outfile)
        end
        else
        begin
            writeln('Table of Content program completed!');
            writeln(outfile);
            close(infile);
            close(outfile)
        end
    end; (* procedure exit *)


(*
 * MAIN is the actual Table of Content program. It announces
 * the start of the program, and ask for the name of the file
 * to be scanned for Table of Content entries.
 *)
    BEGIN (* main *)
        ClrScr;
        cancel := false;
        writeln;
        writeln('WordStar Table of Content generator Program');
        writeln('Copyright 1985 by Dean A. Fields');
        writeln('Version # ', version, ' of ', date, '.');
        writeln;
        gotoxy(1, 6);
        open_files;
        if not cancel then
            process;
        exit
    end. (* main *)
   COM MÇ