Program TOC2;
{ Turbo Pascal Table of Contents Program, }
{ Version 2.  Based on TBLCTENT.PAS by    }
{ Dean A. Fields, 1985.                   }
{ See TOC2.DOC for purpose and usage      }
{ compiles with ending address of $7100   }

Const
  cr         = ^M;
  lf         = ^J;
  MaxLineLen = 255;                 (* max. input line length *)
  version    = '2.3';               (* version number *)
  date       = 'July 16, 1990';     (* version date *)
  MaxChars   = 59;                  (* max. chars. allowed for TOC entry *)
  digits     = 4;                   { max digits for page numbers }
  LineLen    = 65;                  { length of an output line }
                                    { = MaxChars + digits + 1 }
  BufLines   = 200;                 { # of lines before buffer write }

  PatchPtr   : string[7] = '[PATCH>'; { for patching with DDT  }
  FenceChr   : char    = ^K;          { stop/start TOC entry   }
                                      {  use ":" to index assembler labels }
  LinesPP    : integer = 54;          { default lines per page }
  StartPg    : integer = 1;           { default starting page  }
  IndCon     : char    = 'C';         { generate contents      }

  debug      : boolean = false;
  suspend    : boolean = false;
  line       : integer = 1; (*     TOC line # being output for    *)
                            (*     the current TOC page           *)
type
  AnyString = string[255];
  TOCLine   = string[LineLen];

var
  rawch    : char;             { holds "raw" input in case WS $8A }
  PageStr  : string[digits];   { holds page number string }
  infname  : string[14];
  outfname : string[14];
  LineBuf                : TOCLine;
  TOCBuf                 : array[1..BufLines] of TOCLine;
  BufPoint               : integer;                   { current buffer line }
  infile, outfile        : text;
  LineIn                 : string[MaxLineLen];
  PageNum,
  PageLen,
  LoopCntr, chrcnt, indx : integer;
  Prompt,
  tcline,
  fence,
  dot_cmnd               : boolean;
  response,
  ch                     : char;    (* character read from input file *)

{$I EXIST.INC }
{$I YES.INC   }

procedure WriteCtl(ctlchr : char);   { prints out control character with '^' }
  begin
  if ord(ctlchr) >= ord(' ') then
    write(ctlchr)
  else
    begin
    write('^');
    write(chr(ord(ctlchr) + ord('@')));
    end;
  end;

procedure FlushBuf;   { flush to disk file }
  var index : integer;
  begin
  {$I-}
  for index := 1 to BufPoint do
    writeln(outfile,TOCBuf[index]);   { adds CRLFs }
  {$I+}
  if IOResult = $F0 then
    begin
    writeln;
    write('Disk full.  Saving what we have . . . ');
    close(infile);
    close(outfile);
    writeln('TOC2 aborting.');
    halt;
    end;
  BufPoint := 0;
  end;

procedure finish;
  begin
  StartPg := PageNum;   { Start with current page for ZCPR GO & mult. files }
  line    := 1;
  LinesPP := PageLen;   {  For ZCPR GO }
  FlushBuf;
  writeln;
  write('Closing ',infname,' and ',outfname,' . . .');
  close(infile);
  close(outfile);
  writeln(' Done.');
  end;

function StUpCase(st : anystring) : anystring;
  var I : integer;
  begin
  for i := 1 to length(st) do
    st[i] := upcase(st[i]);
  stupcase := st;
  end;

procedure CheckHlp;
  begin
  if (paramstr(1) = '/') or (paramstr(1) = '//') or (paramstr(1) = '?') then
    begin
    writeln('  Usage:');
    writeln('       TOC2 [ufn] - interactive mode');
    writeln('       TOC2 ufn * - expert mode');
    writeln;
    halt;       { return to OS }
    end;
  end;

procedure open_files;
  var
    filefound,
    redo     : boolean;
    dotpos   : integer;
  label
    SysIn,
    Again;

  begin
  FileFound := false;
  Prompt    := true;
  if paramcount > 0 then      { get filename from operating system }
    begin
    infname := paramstr(1);
    if paramstr(2) = '*' then
      Prompt := false;        { skip all prompts }
    goto SysIn;
    end;
  repeat
    write(^M,'                                            ');
                       { clear line without terminal install }
    write(^M,'Enter input filename ==> ');
    buflen := 14;   { d:filename.typ }
    read(infname);
    infname := StUpCase(infname);

    SysIn:

    assign(infile, infname);
    if Exist(infname) then
      begin
      redo      := false;
      FileFound := true;
      end
    else
      begin
      write(^G^M,infname,' not found.  Re-enter');
      redo := Yes;               { prompt for y/n }
      end
  until not redo;
  writeln;
  writeln;
  if FileFound then
    begin

    PageLen := LinesPP;
    PageNum := StartPg;

    Again:

    if Prompt then
      begin                   { prompt for parameters }
      writeln;
      writeln;
      write('   Lines per page (',PageLen : digits,'): ');
      {$I-}
      buflen := 4;
      read(PageLen);
      {$I+}
      if IOResult <> 0 then PageLen := LinesPP;
      writeln(' --> ',PageLen);
      write('    Starting page (',PageNum : digits,'): ');
      {$I-}
      buflen := 4;
      read(PageNum);
      {$I+}
      if IOResult <> 0 then PageNum := StartPg;
      writeln(' --> ',PageNum);
      write('  Fence character ');
      write('(' : digits - 1);
      WriteCtl(FenceChr);
      write('): ');
      read(kbd,response);
      if response <> ^M then
        begin
        FenceChr := response;
        write(' --> ');
        WriteCtl(response);
        end;
      writeln;
      write('Contents or Index ');
      write('(' : digits, IndCon,'): ');
      read(kbd,response);
      response := upcase(response);
      if (response <> ^M) and (response in ['C','I']) then
        begin
        IndCon := response;
        write(' --> ',response);
        end;
      writeln;
      writeln;
      writeln('Verifying Selections:   Page length ',PageLen);
      writeln('                      Start at page ',PageNum);
      write  ('                    Fence character ');
      WriteCtl(FenceChr);
      writeln;
      writeln('                  Contents or Index ',indcon);
      write  ('                  Is this OK');
      if not Yes then goto Again;
      writeln;
      writeln;
      end;  { if }
    outfname := infname;            { build output filename }
    dotpos   := pos('.', outfname);
    if dotpos <> 0 then
      delete(outfname, dotpos, 4);
    case IndCon of
      'C' : outfname := outfname + '.TOC';
      'I' : outfname := outfname + '.IDX';
      end;
    assign(outfile, outfname);
    if Exist(outfname) and Prompt then
      begin
      write(outfname,' exists.  Overwrite');
      if not Yes then
        begin
        writeln;
        writeln('TOC2 aborting.');
        halt;
        end;
      writeln;
      end;
    reset  (infile);
    rewrite(outfile);              { erases any existing files }
    if IndCon = 'C' then
      begin
      writeln(outfile, '.op');
      writeln(outfile);
      writeln(outfile, '                       Table of Contents');
      writeln(outfile);
      end;
    end  { if FileFound }
  else
    begin
    write('TOC2 aborting.');
    halt;
    end;
  end;  { procedure open_files }

procedure get_line;
 { Get next line from file, ended by LF, into internal buffer.
   And input with decimal 127 to strip off 8th bit.
   We can't use Turbo's EOLN here because it does not detect WS eoln
   Also, can't READLN a WS file--Turbo reads >1 line if line ends in $8a
 }
  begin
  linein    := '';
  ch        := ^@;
  while not (eof(infile) or (ch = lf)) do
    begin
    read(infile,ch);
    rawch := ch;
    if ch > '~' then ch := char(ord(ch) and 127);       { strip if needed }
    if not (ch in [cr,lf]) then                  { don't include cr or lf }
      linein := linein + ch;
    end;
if debug then writeln('Line ',line,':',^M^J,linein);
  end; { procedure get_line }

procedure TestLine;
  { Search input line for formfeed, .TC, .OP, .PA, .PN n      }
  { NOTE: lines beginning with a formfeed or unidentified dot }
  { command are skipped }
  { .CP lines only work if file was created with WordStar/NewWord }
  var
    code, tempval : integer;   { for procedure val }
    index         : integer;
    char2, char3  : char;
    newpgstr      : string[digits];

  procedure WSTOC;    { process .TC lines differently }
    var
      hashpos : byte;
    begin
    BufPoint := succ(BufPoint);             { add a line to buffer }
    LineIn   := copy(LineIn,5,MaxLineLen);  { Remove ".tc " }
    hashpos  := pos('#',LineIn);
    if hashpos > 0 then                     { put line number where hash is }
      begin
      LineIn := copy(Linein,1,hashpos-1); { Remove "#" and trailing chars. }
      str(PageNum, PageStr);
      LineIn := LineIn + PageStr;         { add page number }
      end;
    TOCBuf[BufPoint] := LineIn;           { add .tc line to buffer }
    if BufPoint = BufLines then FlushBuf;
    end;

  begin  { procedure TestLine }
  dot_cmnd := false; (* initialize dot_cmnd to false *)
  if length(LineIn) > 0 then
    case LineIn[1] of
      ^L : begin           { formfeed? }
           line := 1;
           dot_cmnd := true;
           PageNum := succ(PageNum);
           write(^M,'At page ',PageNum : digits,' ')
           end;
     '.' : begin
           dot_cmnd := true;            { skip this line }
           char2 := UpCase(LineIn[2]);
           char3 := UpCase(LineIn[3]);
           case char2 of
             'C' : if (char3 = 'P') and (ord(rawch) = $8A) then    { .CP }
                      begin             { WS/NW files only }
                      line := 1;
                      PageNum := succ(PageNum);
                      write(^M,'At page ',PageNum : digits,' ')
                      end;
             'T' : if (char3 = 'C') and (indcon = 'C') then WSTOC;  { .TC }
             'O' : if char3 = 'P' then   { .OP }
                     begin
                     line := 1;
                     suspend  := true;               { stop paging until .pn }
                     end;
             'P' : begin
                   if char3 = 'A' then   { .PA }
                      begin
                      line := 1;
                      PageNum := succ(PageNum);
                      write(^M,'At page ',PageNum : digits,' ')
                      end;
                   if char3 = 'N' then   { .PN n? }
                      begin
                      suspend  := false;
                      line     := 1;
                      index    := 4;
                      repeat
                        index := succ(index);   { absorb spaces after .PN }
                      until (LineIn[index] <> ' ') or (index > length(linein));
                      newpgstr := copy(linein, index, digits);
                      val(newpgstr, tempval, code);
                      if code = 0 then
                        PageNum := tempval
                      else
                        begin
                        writeln;
                        writeln('Illegal .PN command : ',LineIn);
                        write('TOC2 aborting.');
                        finish;
                        halt;
                        end;
                      end (* if *)
                   end (* case P *)
             end { inner case }
           end (* case period *)
      end (* outer case *)
  end; (* procedure TestLine *)


procedure Translate;
  { Translate fenced entries in text file into Table of Contents entries. }
  var
    index      : integer;

  procedure WriteTOC;
    var
      counter, remain : integer;
    begin
    BufPoint := succ(BufPoint);     { next line in array }
    remain   := maxchars - length(LineBuf);
    if (remain > 0) and (indcon = 'C') then
      begin                            { fill out rest of line }
      LineBuf := LineBuf + ' ';
      if remain > 1 then
        if not odd(remain) then
          begin
          LineBuf := LineBuf + '.';
          remain  := pred(remain);
          end;
      end;
    if indcon = 'C' then
      for counter := 1 to remain div 2 do
        LineBuf := LineBuf + ' .';
    LineBuf   := LineBuf + ' ';
    if indcon = 'I' then Linebuf := LineBuf + ' ';
    if indcon = 'C' then
      case PageNum of                  { write page flush right }
            0..9 : LineBuf := LineBuf + '   ';
          10..99 : LineBuf := LineBuf + '  ';
        100..999 : LineBuf := LineBuf + ' ';
        end;
    str(PageNum, PageStr);
    LineBuf := LineBuf + PageStr;
    TOCBuf[BufPoint] := LineBuf;
    LineBuf := '';                  { initialize }
    if BufPoint = BufLines then
      FlushBuf;
    end;  { of procedure WriteTOC }

  begin   { procedure Translate }
  index := 1;
  if (not Fence) and                       { we are not in a fenced passage }
    (pos(FenceChr,LineIn) = 0) then        { quick Turbo pre-scan }
    exit
  else                                     { test entire line & build entry }
    if FenceChr = ':' then                { special case for assembler labels }
      begin
      while (not (LineIn[index] in [FenceChr,';',' ',^I])) { word before ":" }
      and   (length(LineBuf) < MaxChars) do
        begin
        LineBuf := LineBuf + LineIn[index];
        index := succ(index);
        end;
      if LineIn[index] = FenceChr then WriteTOC;  { skip comments }
      end
    else
      for index := 1 to length(LineIn) do
        if LineIn[index] = FenceChr then
          begin
          fence := not(fence);
          if not fence then     { 2nd fence, so end of TOC entry found }
            WriteTOC            { Finish entry with ... + number & write to disk }
          end
        else
          if fence
            and (length(LineBuf) < MaxChars)
            and (LineIn[index] >= ' ')          { filter formfeeds }
          then
            LineBuf := LineBuf + LineIn[index];
  end; (* procedure Translate *)


procedure process;
  (*
   * 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 TestLine to search for WordStar
   * dot commands; executes Translate, depending on the
   * results of TestLine, and counts the number of pages of
   * input to be scanned for Table of Content entries.
   *)
  begin
  while not eof(infile) do    { do whole file }
    begin
    get_line;
    TestLine;                           { check for ^L or dot command }
                                        { and process .tc commands    }
    if not (suspend or dot_cmnd) then   { increment line or page }
      begin
      Translate;                        { parse to .TOC or .IDX entry }
      line := succ(line);               { increment line for next Translate }
      if line > PageLen then            { increment page  "    "      "     }
        begin
        line    := 1;
        PageNum := succ(PageNum);
        write(^M,'At page ',PageNum : digits,' ');
        end;
      end   (* if *)
    end;  { while }
  writeln;
  end; (* procedure process *)


BEGIN
writeln;
writeln('TOC2 - Table of Contents Generator');
writeln('  Version ',version,', Copr. ',date,'  by Carson Wilson.');
writeln;
checkhlp;
open_files;
BufPoint := 0;         { initialize write buffer pointer }
LineBuf  := '';        { initialize TOC line }
fence    := false;     { not in fenced entry }
process;
finish;
END.