{----------------------------------------------------------------------*
*                            Program Thread                            *
*                            March 15, 1993                            *
* -------------------------------------------------------------------- *
* This program has been placed in the public domain.  The author will  *
* accept no responsibility or liability for the software or its use.   *
* Legal issues aside, I'd be happy to receive any comments or sugges-  *
* tions concerning the software.                                       *
* -------------------------------------------------------------------- *
* AUTHOR:  Tom Kaltenbach                                              *
*          429 Woodsong Lane                                           *
*          Rochester, New York 14612                                   *
*          Email:  tom@kalten.bach1.sai.com                            *
* -------------------------------------------------------------------- *
*                                                                      *
* SUMMARY:                                                             *
*                                                                      *
*     THREAD is designed to search back issues of the Homebrew digest  *
* and extract those messages making up a given "thread" of conversa-   *
* tion.  It is also useful to extract all discussion on a particular   *
* subject.  The user supplies key words or phrases for the search, and *
* logical operators (AND, OR, NOT) for combining the key words.  Case  *
* sensitivity of key words is optional.  THREAD searches through a set *
* of digest files input by the user (wildcard filenames are okay)      *
* until it finds a message that meets the key word specifications.     *
* The message is then displayed on the screen, and the user is allowed *
* to read it and decide whether to skip that message (and continue     *
* looking), keep that message (write it to the output file), quit the  *
* program, or enable automatic processing.  If automatic processing is *
* enabled, the user is no longer prompted, and every message meeting   *
* the key word specification is written to the output file.            *
*                                                                      *
* -------------------------------------------------------------------- *
*                                                                      *
* SYSTEM REQUIREMENTS:                                                 *
*                                                                      *
*     THREAD is written in Turbo Pascal 5.5/6.0 for the IBM PC and     *
* compatible 80x86 microcomputers running the MS-DOS (or compatible)   *
* operating system, version 3.x or higher.  The digest issues should   *
* be present as plain, standard ASCII files on the computer's hard     *
* disk.  NOTE:  each line of a standard ASCII file must end in a CR-LF *
* (carriage return - linefeed);  files transferred from non-DOS        *
* computers sometimes end in only a LF.  Such files must be converted  *
* to standard MS-DOS ASCII format.                                     *
*                                                                      *
* -------------------------------------------------------------------- *
*                                                                      *
*  REVISION HISTORY:                                                   *
*                                                                      *
*   Ver    Date/Author/Comments                                        *
*  -----  ---------------------------------------------------          *
*   1.0    18 Jul 1992 -- T. Kaltenbach -- First working version       *
*                                                                      *
*   1.1    20 Jul 1992 -- T. Kaltenbach -- Rewrote section handling    *
*          the logical operators combining the search fields to solve  *
*          problems with complex searches.  Enhanced the user inter-   *
*          face somewhat.                                              *
*                                                                      *
*   1.2    22 Jul 1992 -- T. Kaltenbach -- Improved handling of input  *
*          files, added header to output that records the search para- *
*          meters, etc.  Added procedure-level documentation.  This is *
*          the first version released to the general public.           *
*                                                                      *
*   1.2b   24 Jul 1992 -- T. Kaltenbach -- Added delimiter to begin-   *
*          ing of output file, before first message written, to allow  *
*          later searching of output file.                             *
*                                                                      *
*   1.2c   26 Jul 1992 -- T. Kaltenbach -- Custom version for Chris    *
*          Karras (rkarras@pennsas.upenn.edu) to deal with the pres-   *
*          cence of space in the beginning of each line of the digest  *
*          files.  *DEAD END VERSION -- NO SUBSEQUENT REVISIONS*       *
*                                                                      *
*   1.2d   5 Aug 1992 -- T. Kaltenbach -- Fixed minor bug which pre-   *
*          vented display of "*" next to message lines containing the  *
*          target.  This bug occurred in lines after a line containing *
*          multiple targets.                                           *
*                                                                      *
*   1.2e   21 Sep 1992 -- T. Kaltenbach -- Fixed 2 minor bugs in which *
*          directories and the output file were not excluded from the  *
*          wildcard input filespec.                                    *
*                                                                      *
*   1.2f   23 Sep 1992 -- T. Kaltenbach -- Improved message display on *
*          screen:  added highlighting of all target phrases that      *
*          appear in the message, removed line numbers, etc.           *
*                                                                      *
*   1.2g   25 Sep 1992 -- T. Kaltenbach -- Improved screen display,    *
*          now includes color bar at top, displays found message and   *
*          files being scanned on same screen, etc.                    *
*                                                                      *
*   2.0    05 Oct 1992 -- T. Kaltenbach -- Added many features, incl-  *
*          ding second message buffer and code to search ahead during  *
*          display of message matching target spec, checking for an    *
*          already-existent output file, display of search statistics  *
*          at termination of program and during automatic mode, output *
*          file now includes source and output filespecs in header,    *
*          trapping of extended keys (PgUp, etc).                      *
*                                                                      *
*   2.0a   12 Oct 1992 -- T. Kaltenbach -- Added code to expand TAB    *
*          characters into a series of spaces for proper screen and    *
*          printer display of messages.                                *
*                                                                      *
*   2.0b   08 Mar 1993 -- T. Kaltenbach -- Added better display con-   *
*          trol, including support for PgUp, PgDn, UpArrow, DownArrow, *
*          Home and End keys.                                          *
*                                                                      *
*   2.0c   09 Mar 1993 -- T. Kaltenbach -- Added code to trim off any  *
*          trailing blank lines from displayed messages and to display *
*          "End of message" to let users know they're at the bottom of *
*          the current message.  Updated bottom line of display to     *
*          reflect new scrolling options introduced in v2.0b.  Added   *
*          check to ignore output file existence if a DOS device is    *
*          specified as output filename.                               *
*                                                                      *
*   2.1    12 Mar 1993 -- T. Kaltenbach -- Added code to read in names *
*          of all input files, sort them, and then search the files in *
*          ascending order.  This version is deemed to now be full-    *
*          featured and will be the second public release of the       *
*          program.                                                    *
*                                                                      *
*   2.1a   15 Mar 1993 -- T. Kaltenbach -- Added output of names of    *
*          first and last files scanned (output to screen and output   *
*          file).                                                      *
*                                                                      *
*----------------------------------------------------------------------}

PROGRAM Thread;

USES Dos,Crt;

LABEL Quit, Abort;

CONST MaxBuff   = 1000;    {** No. of lines allocated for single message **}
      MaxTxtBuf = 16386;   {** No. of bytes per I/O disk buffer **}
      MaxFields = 10;      {** No. of search fields **}
      MaxFiles  = 2000;    {** Max. no of files to be searched **}
      Ver       = '2.1a';
      LastMod   = '15-Mar-93';
      AllFiles = AnyFile - Directory;
      TempFile = '$$thread.$$$';

TYPE BuffStrng = ^String;
     BuffType   = ARRAY[1..2,1..MaxBuff] of BuffStrng;
     TxtBuffer = ARRAY[1..MaxTxtBuf] of BYTE;
     TargetRec  = RECORD
                     Str     : String;
                     Logical : String[3];
                     AnyCase : boolean;
                  END;
     TargetType = ARRAY[0..MaxFields] of TargetRec;
     TargetIndex = ARRAY[1..MaxFields] of Integer;
     String12 = String[12];
     StringPtr = ^String12;
     StringArray = ARRAY[1..MaxFiles] of StringPtr;

VAR Buffer : BuffType;
    BuffPtr : array[1..2] of integer;
    TxtInBuf, TxtOutBuf : TxtBuffer;
    Target : TargetType;
    SrchName : StringArray;
    SrcSpec, OutName, FirstFile, LastFile : PathStr;
    InDir : DirStr;
    Name : NameStr;
    Ext : ExtStr;
    InFileRec : SearchRec;
    I, J, K, Error, SearchPtr, DisplayPtr, MaxLines, NumFields,
       NumLines, MsgCt, MsgTotal, FileCt, HitCt, WrtCt, LastDispLine,
       Temp, FileSpace, NumFiles : INTEGER;
    Success, Done, Found, Automatic, FilesLeft, WaitingForUser,
       NextFound : Boolean;
    Line, Delim, Border, UpperStr, TempStr : String[80];
    InFile, OutFile, NameFile : text;
    CrntName : String12;
    CrntMode : String[3];
    Answer : char;
    TopLeft, BottomRight : Word;
    Xpos, Ypos : byte;

{** ---------------------------------------------------------------- **}

function FileExists (FileName: string) : Boolean;
{ Returns True if file exists; otherwise, it returns False. Closes the
  file if it exists. }
var
  f: file;
begin
  {$I-}
  Assign(f, FileName);
  Reset(f);
  Close(f);
  {$I+}
  FileExists := (IOResult = 0) and (FileName <> '');
end;  { FileExists }

{** ---------------------------------------------------------------- **}

Function LTrim (S : String) : String;

var i, Len : integer;

begin

  Len := Length(S);
  if ((S[1] = ' ') and (Len > 1)) then
    begin
      i := 1;
      while ((S[i] = ' ') and (i <= Len)) do
        i := i + 1;
      delete(S,1,(i-1));
    end;

  LTrim := S;

end;

{** ---------------------------------------------------------------- **}

Function RTrim (S : String) : String;

var i, Len : integer;

begin

  Len := Length(S);
  if ((S[Len] = ' ') and (Len >= 1)) then
    begin
      i := Len;
      while ((S[i] = ' ') and (i >= 1)) do
        i := i - 1;
      delete(S,(i+1),Len);
    end;

  RTrim := S;

end;

{----------------------------------------------------------------------*
*                          Procedure Write80                           *
*                            July 18, 1992                             *
* -------------------------------------------------------------------- *
* AUTHOR:  Tom Kaltenbach                                              *
*          429 Woodsong Lane                                           *
*          Rochester, New York 14612                                   *
*          Email:  tom@kalten.bach1.sai.com                            *
* -------------------------------------------------------------------- *
*                                                                      *
* SUMMARY:                                                             *
*                                                                      *
*    This procedure writes a string to the current CRT output device   *
* which is truncated if longer than 80 characters.  A "+" is displayed *
* in column 80 if a line is truncated.                                 *
*                                                                      *
*----------------------------------------------------------------------}

Procedure Write80 (S : String);

var i : integer;

begin

  i := WhereX;
  if ((Length(S)+i) >= 80) then
    begin
      write(copy(s,1,(79 - i)));
      write('+');
    end
  else
    write(S);

end;

{----------------------------------------------------------------------*
*                           Function Upper                             *
*                            July 18, 1992                             *
* -------------------------------------------------------------------- *
* AUTHOR:  Tom Kaltenbach                                              *
*          429 Woodsong Lane                                           *
*          Rochester, New York 14612                                   *
*          Email:  tom@kalten.bach1.sai.com                            *
* -------------------------------------------------------------------- *
*                                                                      *
* SUMMARY:                                                             *
*                                                                      *
*    This function takes an input STRING parameter, converts all lower *
* case letters to uppercase, and returns the string as the function    *
* return value.                                                        *
*                                                                      *
*----------------------------------------------------------------------}

Function Upper (S : String) : String;
var i,j : integer;
begin
  upper := s;
  i := length(s);
  for j := 1 to i do
    upper[j] := upcase(s[j]);
end;

{----------------------------------------------------------------------*
*                         Procedure DisplayLine                        *
*                            Sept 18, 1992                             *
* -------------------------------------------------------------------- *
* AUTHOR:  Tom Kaltenbach                                              *
*          429 Woodsong Lane                                           *
*          Rochester, New York 14612                                   *
*          Email:  tom@kalten.bach1.sai.com                            *
* -------------------------------------------------------------------- *
*                                                                      *
* SUMMARY:                                                             *
*                                                                      *
*    This function takes an input STRING parameter and the <Target>    *
* variable and displays the line with any occurrences of the target    *
* substrings highlighted.                                              *
*                                                                      *
*----------------------------------------------------------------------}

Procedure DisplayLine (OrigLine : String; Target : TargetType; NumFields :
                       integer);
const MaxPos = 9999;

var Line, TempLine, TargStr : string;
    i, j, TruPos, MinPos, TargPtr : integer;

begin

  Line := OrigLine;
  TruPos := 0;

  if (Length(Line) = 0) then writeln;

  while (Length(Line) > 0) do
    begin

      MinPos := MaxPos;
      for i := 1 to NumFields do
        begin
          if (Target[i].AnyCase) then
            begin
              TargStr := Upper(Target[i].Str);
              TempLine := Upper(Line);
            end
          else
            begin
              TargStr := Target[i].Str;
              TempLine := Line;
            end;

         j := Pos(TargStr,TempLine);

         if (j > 0) then
           if (j < MinPos) then
             begin
               MinPos := j;
               TargPtr := i;
             end
           else
             if ((j = MinPos) and (Length(Target[i].Str) >
             Length(Target[TargPtr].Str))) then
               begin
                 MinPos := j;
                 TargPtr := i;
               end;

        end;  {** of "for i := 1 to NumFields" **}

      if (MinPos < MaxPos) then
        begin
          if (MinPos > 1) then write80 (copy(Line,1,(MinPos-1)));

          TextColor(Black);
          TextBackground(White);

          j := Length(Target[TargPtr].Str);
          write80 (copy(Line,MinPos,j));

          TextColor(LightGreen);
          TextBackground(Black);

          if ((j + MinPos - 1) = Length(Line)) then
            begin
              Line := '';
              writeln;
            end
          else
            Line := copy(Line,(j+MinPos),Length(Line));

        end
      else
        begin
          write80 (Line);
          writeln;
          Line := '';
        end;

    end; {** of "while (Length(Line) < 0) do ..." **}

end; {** of Procedure DisplayLine **}

{----------------------------------------------------------------------*
*                         Procedure FindDelim                          *
*                            Sept 28, 1992                             *
* -------------------------------------------------------------------- *
* AUTHOR:  Tom Kaltenbach                                              *
*          429 Woodsong Lane                                           *
*          Rochester, New York 14612                                   *
*          Email:  tom@kalten.bach1.sai.com                            *
* -------------------------------------------------------------------- *
*                                                                      *
* SUMMARY:                                                             *
*                                                                      *
*    This procedure finds the first delimiter <Delim> in the input     *
* file <InFile>.  <InFile> must be already open.                       *
*                                                                      *
*----------------------------------------------------------------------}

Procedure FindDelim (var Error : integer);

begin

  {** Search for first delimiter **}

  Line := '';
  Found := False;
  while (not(eof(InFile)) and not(Found)) do
    begin
      readln (InFile,Line);
      if (Pos(Delim,Line) = 1) then Found := True;
    end;

  if eof(Infile) then
    begin
      writeln ('Error!  EOF reached searching for first delimiter',
               ' in the');
      writeln ('file ',InDir,CrntName);
      close (InFile);
      Error := 2;    {** Set flag to terminate program with error **}
    end;

end;  {** of procedure FindDelim **}

{----------------------------------------------------------------------*
*                        Procedure DisplayScan                         *
*                            Sept 28, 1992                             *
* -------------------------------------------------------------------- *
* AUTHOR:  Tom Kaltenbach                                              *
*          429 Woodsong Lane                                           *
*          Rochester, New York 14612                                   *
*          Email:  tom@kalten.bach1.sai.com                            *
* -------------------------------------------------------------------- *
*                                                                      *
* SUMMARY:                                                             *
*                                                                      *
*    This procedure displays the name of the file currently being      *
* scanned on the user's terminal screen.                               *
*                                                                      *
*----------------------------------------------------------------------}

Procedure DisplayScan (S : String);

begin

  TopLeft := WindMin;
  BottomRight := WindMax;
  Xpos := WhereX;
  Ypos := WhereY;
  window (1,1,80,25);
  GotoXY (54,1);
  TextColor(White);
  TextBackGround(Blue);
  write (S,CrntName);
  window (1,(hi(TopLeft)+1),80,(hi(BottomRight)+1));
  GotoXY (Xpos,Ypos);
  TextColor(LightGreen);
  TextBackground(Black);

end; {** of procedure DisplayScan **}

{----------------------------------------------------------------------*
*                         Procedure BubbleSort                         *
*                            July 18, 1992                             *
* -------------------------------------------------------------------- *
* From the text "Data Structures Using Pascal", by A.M. Tenenbaum and  *
* M.J. Augenstein.  Prentice-Hall, Englewood Cliffs, NJ, 1981, p. 376  *
* -------------------------------------------------------------------- *
*                                                                      *
* SUMMARY:                                                             *
*                                                                      *
*    This procedure sorts an input array <X> containing <N> values in  *
* ascending order.                                                     *
*                                                                      *
*----------------------------------------------------------------------}

Procedure BubbleSort (VAR X : TargetIndex; N : INTEGER);

var pass, j, hold : integer;
    intchnge : boolean;

begin

  intchnge := true;
  pass := 1;
  while ((pass < n) and (intchnge)) do
    begin
      intchnge := false;
      for j:= 1 to (n - pass) do
        if (X[j] > X[j+1]) then
          begin
            intchnge := true;
            hold := x[j];
            x[j] := x[j+1];
            x[j+1] := hold;
          end;
      pass := pass + 1;
    end;

end; {** of procedure Bubble **}

{----------------------------------------------------------------------*
*                         Procedure SortString                         *
*                          December 31, 1992                           *
* -------------------------------------------------------------------- *
* From the text "Data Structures Using Pascal", by A.M. Tenenbaum and  *
* M.J. Augenstein.  Prentice-Hall, Englewood Cliffs, NJ, 1981, p. 376  *
* -------------------------------------------------------------------- *
*                                                                      *
* SUMMARY:                                                             *
*                                                                      *
*    This procedure sorts an array <X> of the String type which        *
* contains <N> strings.  The strings are sorted in ascending order.    *
*                                                                      *
*----------------------------------------------------------------------}

Procedure SortString (VAR X : StringArray; N : INTEGER; CaseInsens : boolean);

var Hold, Temp1, Temp2 : String;
    pass, j : integer;
    LessOrEqual, intchnge : boolean;

begin

  intchnge := true;
  pass := 1;
  while ((pass < n) and (intchnge)) do
    begin
      intchnge := false;
      for j:= 1 to (n - pass) do
        begin

          if (CaseInsens) then
            begin
              Temp1 := Upper(x[j]^);
              Temp2 := Upper(x[j+1]^);
              LessOrEqual := (Temp1 <= Temp2);
            end
          else
            LessOrEqual := (x[j]^ <= x[j+1]^);

          if not(LessOrEqual) then
            begin
              intchnge := true;
              hold := x[j]^;
              x[j]^ := x[j+1]^;
              x[j+1]^ := hold;
            end;
        end;

      pass := pass + 1;
    end;

end; {** of procedure SortString **}

{----------------------------------------------------------------------*
*                        Procedure GetUserInput                        *
*                            July 18, 1992                             *
* -------------------------------------------------------------------- *
* AUTHOR:  Tom Kaltenbach                                              *
*          429 Woodsong Lane                                           *
*          Rochester, New York 14612                                   *
*          Email:  tom@kalten.bach1.sai.com                            *
* -------------------------------------------------------------------- *
*                                                                      *
* SUMMARY:                                                             *
*                                                                      *
*    This procedure prompts the user for the necessary input para-     *
* meters.  It performs SOME error-checking on the input parameters and *
* filenames.                                                           *
*                                                                      *
*----------------------------------------------------------------------}

Procedure GetUserInput (var Error : integer);

label Abort;

var i : integer;
    Done, Out2DosDev : Boolean;
    Answer : char;

begin

  write ('Enter filespec for digests (wild ok): ');
  readln (SrcSpec);
  SrcSpec := LTrim(RTrim(SrcSpec));
  if (Length(SrcSpec) = 0) then
    begin
      writeln;
      writeln ('No input filespec entered.');
      Error := 3;
      goto Abort;
    end;
  SrcSpec := FExpand(SrcSpec);
  FSplit (SrcSpec,InDir,Name,Ext);
  FindFirst(SrcSpec,AllFiles,InFileRec);
  if (DosError <> 0) then
    begin
      writeln;
      writeln ('No matching files or bad filespec.');
      Error := 3;
      goto Abort;
    end;
  write ('Enter name for output file:           ');
  readln (OutName);
  OutName := Upper(LTrim(RTrim(OutName)));

  {** Check for no file specified **}

  if (Length(OutName) = 0) then
    begin
      writeln;
      writeln ('No output filename entered.');
      Error := 3;
      goto Abort;
    end
  else
    begin

      {** Check if output file is a DOS device **}

      if ((OutName = 'PRN') or (OutName = 'LPT1') or (OutName = 'LPT2') or
        (OutName = 'NUL')) then
        Out2DosDev := TRUE
      else
        begin
          Out2DosDev := FALSE;
          OutName := FExpand(OutName);
        end;
    end;

  {** Abort if first input file is the same as output file **}

  if (Concat(InDir,InFileRec.Name) = OutName) then
    begin
      writeln;
      writeln ('Input file is the same as output file.');
      Error := 3;
      goto Abort;
    end;

  Assign (OutFile,OutName);
  SetTextBuf(InFile,TxtOutBuf,SizeOf(TxtOutBuf));

  if (not(Out2DosDev) and FileExists(OutName)) then
    begin
      writeln;
      writeln ('File "',OutName,'" already exists.');
      write ('Select option to [O]verwrite, [A]ppend or [Q]uit: ');
      Readln (TempStr);
      TempStr := LTrim(TempStr);
      if (Length(TempStr) = 0) then
        Answer := 'Q'
      else
        Answer := UpCase(TempStr[1]);
      case Answer of
        'O' : rewrite (OutFile);
        'A' : append (OutFile);
        else
          begin
            Error := 3;
            goto Abort;
          end;
      end;
    end
  else
    rewrite (OutFile);

  writeln;

  {------------------------------------------
  Get target string(s) and logical operators
  ------------------------------------------}

  i := 1;
  Done := false;
  while (not(Done) and (i <= MaxFields)) do
    begin
      write ('Enter target string #',i:1,':  ');
      readln (Target[i].Str);

      {** User entered non-blank string, get more info **}

      if (Length(RTrim(Target[i].Str)) > 0) then
        begin

          {** Ask user about how to handle case **}

          write ('Ignore case? (Y/N):  ');
          readln (Answer);
          if (UpCase(Answer) = 'N') then
            Target[i].AnyCase := False
          else
            Target[i].AnyCase := True;

          {** Get logical operator for this search field **}

          Answer := 'X';
          while NOT(Answer IN ['A','O','N','E']) do
            begin
              write ('Enter logical operator ([A]nd, [O]r, [N]ot,',
                     ' or [E]nd):  ');
              readln (Answer);
              Answer := UpCase(Answer);
             end;

          case Answer of
            'A' : Target[i].Logical := 'AND';
            'O' : Target[i].Logical := 'OR';
            'N' : Target[i].Logical := 'NOT';
            'E' : begin
                    Target[i].Logical := 'OR';
                    Done := True;
                  end;
          end;

          i := i + 1;
        end {** of if **}

     {** Handle situation if user entered blank target field **}

      else
        if (i = 1) then
          writeln ('Error -- blank field entered')
        else
          begin
            writeln;
            writeln ('Blank search field aborted -- logical operator from previous field ignored.');
            writeln;
            write ('Press ENTER to continue: ');
            readln;
            Done := True;
          end;

    end; {** of while not(Done) ... **}

  NumFields := i - 1;
  Target[NumFields].Logical := 'OR';

Abort:

end; {** of procedure GetUserInput **}

{----------------------------------------------------------------------*
*                          Procedure ReadMsg                           *
*                            July 18, 1992                             *
* -------------------------------------------------------------------- *
* AUTHOR:  Tom Kaltenbach                                              *
*          429 Woodsong Lane                                           *
*          Rochester, New York 14612                                   *
*          Email:  tom@kalten.bach1.sai.com                            *
* -------------------------------------------------------------------- *
*                                                                      *
* SUMMARY:                                                             *
*                                                                      *
*    This procedure reads a message from the current input file.  It   *
* extracts a single message by searching for the delimeter between     *
* messages.  If EOF is reached on the input file, the next file in the *
* series is opened.  If no more files are left, a flag is set and the  *
* program terminates.                                                  *
*                                                                      *
*----------------------------------------------------------------------}

Procedure ReadMsg (VAR Found : Boolean; VAR Error : INTEGER);

label ReadIt, EndProc;

begin

  {--------------------------------------------------------------
  Read message into Buffer until delimiter found, EOF reached, or
  buffer overflows
  ---------------------------------------------------------------}

  {** Make sure there are files left **}

  if not(FilesLeft) then
    begin
      Error := 1;    {** Set flag for normal program termination **}
      goto EndProc;
    end;

  {** Read next message into Buffer **}

ReadIt:

  BuffPtr[SearchPtr] := 0;
  Found := False;
  while (not(Found) and not(EOF(InFile)) and (BuffPtr[SearchPtr] < MaxLines)
    and FilesLeft) do
    begin
      BuffPtr[SearchPtr] := BuffPtr[SearchPtr] + 1;
      readln (InFile,Buffer[SearchPtr,BuffPtr[SearchPtr]]^);
      if (Pos(Delim,Buffer[SearchPtr,BuffPtr[SearchPtr]]^) = 1) then
        begin
          BuffPtr[SearchPtr] := BuffPtr[SearchPtr] - 1;
          Found := True;
        end;
    end;

  {** If EOF detected, get next file ready for reading **}

  if (eof(InFile)) then
    begin
      close (InFile);
      if (eof(NameFile)) then
        FilesLeft := FALSE
      else
        begin
          readln(NameFile,CrntName);
          LastFile := concat(InDir,CrntName);

          if (concat(InDir,CrntName) = OutName) then
            begin
              if not(eof(NameFile)) then
                begin
                  readln (NameFile,CrntName);
                  LastFile := concat(InDir,CrntName);
                end
              else
                FilesLeft := False;
            end
          else
            begin
              Assign (InFile,Concat(InDir,CrntName));
              SetTextBuf(InFile,TxtInBuf,SizeOf(TxtInBuf));
              Reset (InFile);
              FileCt := FileCt + 1;
              MsgTotal := MsgTotal + MsgCt;
              MsgCt := 0;

              {** Display file being scanned on user screen **}

              DisplayScan('Scanning file: ');

              {** Search for first delimiter **}

              FindDelim (Error);
              if (Error <> 0) then goto EndProc;

            end; {** of "if (DosError <> 0) ... else ..." **}

        end; {** of "if (eof(NameFile)) ... else ..." **}

      if ((BuffPtr[SearchPtr] = 0) and FilesLeft) then goto ReadIt;

    end; {** of "if EOF(InFile) ..." **}

  {** Increment message counter **}

  MsgCt := MsgCt + 1;

  {** Warn user if buffer full **}

  If (BuffPtr[SearchPtr] = MaxLines) then
    begin
      writeln ('Warning:  message longer than buffer limit of ',
                MaxLines:1,' lines.  Message split.');
      write ('Press ENTER to continue: ');
      Answer := ' ';
      while (ord(Answer) <> 13) do
        Answer := ReadKey;
      writeln;
    end;

EndProc:

end; {** of procedure ReadMsg **}

{----------------------------------------------------------------------*
*                          Procedure FindTarg                          *
*                            July 18, 1992                             *
* -------------------------------------------------------------------- *
* AUTHOR:  Tom Kaltenbach                                              *
*          429 Woodsong Lane                                           *
*          Rochester, New York 14612                                   *
*          Email:  tom@kalten.bach1.sai.com                            *
* -------------------------------------------------------------------- *
*                                                                      *
* SUMMARY:                                                             *
*                                                                      *
*    This procedure searches the message buffer for a single user-     *
* supplied search fields.  If search field is case-insensitive, the    *
* strings are converted to uppercase prior to searching.               *
*                                                                      *
*----------------------------------------------------------------------}

Function FindTarg (TargPtr : INTEGER) : Boolean;

var Found : boolean;
    j : integer;

begin

  {** For case-insensitive match, change to target to upper case **}

  if (Target[TargPtr].AnyCase) then
    UpperStr := Upper(Target[TargPtr].Str);

  {** Scan buffer for target string number <TargPtr> **}

  j := 0;
  Found := False;
  while ((j < BuffPtr[SearchPtr]) AND NOT(Found)) do
    begin
      j := j + 1;
      if (Target[TargPtr].AnyCase) then
        begin
          TempStr := Upper(Buffer[SearchPtr,j]^);
          if (Pos(UpperStr,TempStr) > 0) then Found := True;
        end
      else
        if (Pos(Target[TargPtr].Str,Buffer[SearchPtr,j]^) > 0) then
           Found := True;
    end;

  FindTarg := Found;

end; {** of procedure FindTarg **}

{----------------------------------------------------------------------*
*                         Procedure TabExpand                          *
*                            July 18, 1992                             *
* -------------------------------------------------------------------- *
* AUTHOR:  Tom Kaltenbach                                              *
*          429 Woodsong Lane                                           *
*          Rochester, New York 14612                                   *
*          Email:  tom@kalten.bach1.sai.com                            *
* -------------------------------------------------------------------- *
*                                                                      *
* SUMMARY:                                                             *
*                                                                      *
*    This procedure expands the tab characters in the display buffer   *
* to a sequence of spaces.  Tab stops are set to every 8 characters.   *
*                                                                      *
*----------------------------------------------------------------------}

Procedure TabExpand;

const Space = ' ';
      Tab = CHR(9);

var i, j, k, m : integer;
    TempStr : String;

begin

  for i := 1 to BuffPtr[DisplayPtr] do
    begin
      j := 1;
      while (j > 0) do
        begin
          j := Pos(Tab,Buffer[DisplayPtr,i]^);
          if (j > 0) then
            begin

              {** Convert tab character to space **}

              Buffer[DisplayPtr,i]^[j] := ' ';

              {** Expand tab character **}

              k := j mod 8;
              if (k > 0) then
                begin
                  TempStr := '';
                  for m := 1 to ((k*8)-1) do
                    TempStr := concat(TempStr,Space);
                  Insert(TempStr,Buffer[DisplayPtr,i]^,j);
                end;
            end; {** of "if (j > 0) then ..." **}
        end; {** of "while (j > 0) do ..." **}
    end; {** of "for i = 1 to BuffPtr[DisplayPtr] do ..." **}

end;  {** of procedure TabExpand **}

{----------------------------------------------------------------------*
*                       Procedure DisplayBuffer                        *
*                            July 18, 1992                             *
* -------------------------------------------------------------------- *
* AUTHOR:  Tom Kaltenbach                                              *
*          429 Woodsong Lane                                           *
*          Rochester, New York 14612                                   *
*          Email:  tom@kalten.bach1.sai.com                            *
* -------------------------------------------------------------------- *
*                                                                      *
* SUMMARY:                                                             *
*                                                                      *
*    This procedure displays the current message on the screen, and    *
* allows the user to read it and decide whether to skip that message   *
* (and continue looking), keep that message (write it to the output    *
* file), quit the program, or enable automatic processing.             *
*                                                                      *
*----------------------------------------------------------------------}

Procedure DisplayBuffer;

label EndProc;

var Temp, CurPos, i, j, k : integer;

begin

  {** Make alternate buffer available for next search **}

  Temp := SearchPtr;
  SearchPtr := DisplayPtr;
  DisplayPtr := Temp;

  {** Call TabExpand to expand tabs to spaces in buffer **}

  TabExpand;

  if (Automatic) then goto EndProc;

  {** Trim off trailing spaces from Buffer lines **}

  for i := 1 to BuffPtr[DisplayPtr] do
    Buffer[DisplayPtr,i]^ := RTrim(Buffer[DisplayPtr,i]^);

  {** Trim off trailing blank lines from Buffer, add on "end of buffer" **}

  i := BuffPtr[DisplayPtr];
  while (Length(Buffer[DisplayPtr,i]^) = 0) do
    i := i - 1;

  if ((i+2) <= MaxBuff) then
    begin
      Buffer[DisplayPtr,(i+1)]^ := ' ';
      Buffer[DisplayPtr,(i+2)]^ := '* * * End of message * * *';
      i := i + 2;
    end;

  BuffPtr[DisplayPtr] := i;

  {** Display first screen of message for user to review **}

  j := 19;
  if (j > BuffPtr[DisplayPtr]) then j := BuffPtr[DisplayPtr];
  window (1,2,80,25);
  ClrScr;
  writeln;
  writeln ('Message #',MsgCt:1,' from file #',FileCt:1,':  ',InDir,
    CrntName);
  CurPos := WhereY;
  write (Border);
  GotoXY(1,CurPos);
  window (1,5,80,25);

  for k := 1 to j do
    DisplayLine(Buffer[DisplayPtr,k]^,Target,NumFields);

  LastDispLine := 1;

  writeln;
  GotoXY(1,(hi(WindMax)-hi(WindMin)));
  write(Border);
  GotoXY(1,(hi(WindMax)-hi(WindMin)+1));

  Flush(output);
  TextColor (LightGreen);
  Write ('[');
  TextColor(White);
  write ('S');
  textcolor(LightGreen);
  write (']kip msg [');
  TextColor(White);
  write ('K');
  TextColor (LightGreen);
  write (']eep msg [');
  TextColor(White);
  write ('A');
  Flush(output);
  TextColor (LightGreen);
  write (']uto (keep all) [');
  TextColor(White);
  write ('Q');
  TextColor (LightGreen);
  write (']uit ');
  TextColor(White);
  write (chr(24),chr(25),' PgUp PgDn');
  TextColor (LightGreen);
  write (' or display [');
  TextColor(White);
  write ('M');
  TextColor (LightGreen);
  write (']ore:');

EndProc:

  WaitingForUser := TRUE;

end;  {** of procedure DisplayBuffer **}

{----------------------------------------------------------------------*
*                       Procedure DisplayStats                         *
*                            July 18, 1992                             *
* -------------------------------------------------------------------- *
* AUTHOR:  Tom Kaltenbach                                              *
*          429 Woodsong Lane                                           *
*          Rochester, New York 14612                                   *
*          Email:  tom@kalten.bach1.sai.com                            *
* -------------------------------------------------------------------- *
*                                                                      *
* SUMMARY:                                                             *
*                                                                      *
*    This procedure displays the search statistics when the program    *
* terminates.  Statistics displayed include no. of files searched,     *
* number of messages scanned, number of messages containing target(s), *
* number of messages written to output file, name of output file, etc. *
*                                                                      *
*----------------------------------------------------------------------}

Procedure DisplayStats (var f : text);

begin

  ClrScr;
  if (Automatic) then
    begin
      writeln;
      writeln ('Automatic search mode enabled.');
    end;
  writeln (f);
  writeln (f,'First file scanned:  ',FirstFile);
  writeln (f,'Last file scanned:   ',LastFile);
  writeln (f);
  Writeln (f,'Search statistics: ');
  writeln (f);
  writeln (f,'   ',FileCt:5,' files (',(MsgTotal+MsgCt):1,' messages) were scanned.');
  writeln (f,'   ',HitCt:5,' messages matched target specs.');
  writeln (f,'   ',WrtCt:5,' messages written to output file "',OutName,'"');
  writeln (f);

end;  {** of procedure DisplayStats **}

{----------------------------------------------------------------------*
*                       Procedure GetUserOption                        *
*                            July 18, 1992                             *
* -------------------------------------------------------------------- *
* AUTHOR:  Tom Kaltenbach                                              *
*          429 Woodsong Lane                                           *
*          Rochester, New York 14612                                   *
*          Email:  tom@kalten.bach1.sai.com                            *
* -------------------------------------------------------------------- *
*                                                                      *
* SUMMARY:                                                             *
*                                                                      *
*    This procedure displays the current message on the screen, and    *
* allows the user to read it and decide whether to skip that message   *
* (and continue looking), keep that message (write it to the output    *
* file), quit the program, or enable automatic processing.             *
*                                                                      *
*----------------------------------------------------------------------}

Procedure GetUserOption (var Error : integer);

var CurPos, i, j, k : integer;
    x, y : byte;
    Answer : char;
    ScanCode : boolean;

{** ---------------------------------------------------------------- **}

Procedure UpdateDisplay (StartLine : integer);

var i, j, k : integer;

begin

  i := StartLine;
  if (i < 1) then i := 1;

  {** ignore past end-of-screen **}

  if (i >= BuffPtr[DisplayPtr]) then Exit;

  {** Clear screen and display selected buffer region **}

  ClrScr;
  j := i + 18;
  if (j > BuffPtr[DisplayPtr]) then j := BuffPtr[DisplayPtr];
  for k := i to j do
    DisplayLine(Buffer[DisplayPtr,k]^,Target,NumFields);

  writeln;
  LastDispLine := i;
  GotoXY(1,(hi(WindMax)-hi(WindMin)));
  write(Border);
  GotoXY(1,(hi(WindMax)-hi(WindMin)+1));

  TextColor (LightGreen);
  Write ('[');
  TextColor(White);
  write ('S');
  textcolor(LightGreen);
  write (']kip msg [');
  TextColor(White);
  write ('K');
  TextColor (LightGreen);
  write (']eep msg [');
  TextColor(White);
  write ('A');
  TextColor (LightGreen);
  write (']uto (keep all) [');
  TextColor(White);
  write ('Q');
  TextColor (LightGreen);
  write (']uit ');
  TextColor(White);
  write (chr(24),chr(25),' PgUp PgDn');
  TextColor (LightGreen);
  write (' or display [');
  TextColor(White);
  write ('M');
  TextColor (LightGreen);
  write (']ore:');

end;

{** ---------------------------------------------------------------- **}

begin {** procedure GetUserOption **}

  ScanCode := FALSE;
  if (Automatic) then
    Answer := 'K'
  else
    begin

      {** Get user's keypress **}

      Answer := ReadKey;
      If (Answer = CHR(0)) then
        begin
          ScanCode := TRUE;
          Answer := ReadKey;
          if (ord(Answer) in [71,72,73,79,80,81]) then
            Answer := chr(ord(Answer) + 32)
          else
            Answer := 'Z';
        end
      else
        Answer := UpCase(Answer);
    end;

  case Answer of

    'K' : begin

            {** Trim off "End of Message" line, if any **}

            if (Buffer[DisplayPtr,BuffPtr[DisplayPtr]]^ =
              '* * * End of message * * *') then dec(BuffPtr[DisplayPtr]);

            {** Write out message to output file **}

            writeln (OutFile);
            writeln (OutFile,'- - - - - - - - - - - - - - - - - - - - - - - ',
               '- - - - - - - - - - - - -');
            writeln (OutFile,'Extracted from file:  ',InDir,CrntName);
            writeln (OutFile,'- - - - - - - - - - - - - - - - - - - - - - - ',
               '- - - - - - - - - - - - -');
            for i := 1 to BuffPtr[DisplayPtr] do
              writeln (OutFile,Buffer[DisplayPtr,i]^);
            writeln (OutFile,Delim,Delim);
            WaitingForUser := FALSE;
            WrtCt := WrtCt + 1;

            if not(NextFound) then
              begin
                x := WhereX;
                y := WhereY;
                TextColor(White);
                TextBackground(Red);
                GotoXY(28,8);
                writeln (' ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ ');
                GotoXY(28,9);
                writeln (' ³  Please wait...  ³ ');
                GotoXY(28,10);
                writeln (' ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ ');
                TextColor(LightGreen);
                TextBackground(Black);
                GotoXY(x,y);
              end;
          end;

    'S' : begin

            WaitingForUser := FALSE;
            if not(NextFound) then
              begin
                x := WhereX;
                y := WhereY;
                TextColor(White);
                TextBackground(Red);
                GotoXY(28,8);
                writeln (' ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿ ');
                GotoXY(28,9);
                writeln (' ³  Please wait...  ³ ');
                GotoXY(28,10);
                writeln (' ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ ');
                TextColor(LightGreen);
                TextBackground(Black);
                GotoXY(x,y);
              end;

          end;

    'Q' : begin
            writeln;
            writeln ('Program terminated at user request.');
            close (InFile);
            Error := 2;
          end;

    'M' : begin  {** same as [PgDn], except wraps back to top-of-message **}
            i := LastDispLine + 18;
            if (i > BuffPtr[DisplayPtr]) then i := 1;
            UpdateDisplay(i);
          end;

    'g' : begin {** [Home] key pressed **}
            i := 1;
            UpdateDisplay(i);
          end;

    'h' : begin {** [UpArrow] key pressed **}
            i := LastDispLine - 1;
            UpdateDisplay(i);
          end;

    'i' : begin {** [PgUp] key pressed **}
            i := LastDispLine - 18;
            UpdateDisplay(i);
          end;

    'o' : begin {** [End] key pressed **}
            i := BuffPtr[DisplayPtr] - 18;
            UpdateDisplay(i);
          end;

    'p' : begin {** [DownArrow] key pressed **}
            i := LastDispLine + 1;
            UpdateDisplay(i);
          end;

    'q' : begin {** [PgDn] key pressed **}
            i := LastDispLine + 18;
            UpdateDisplay(i);
          end;

    'A' : begin
            Automatic := TRUE;
            ClrScr;
            GotoXY(25,10);
            writeln ('Automatic processing enabled');
            GotoXY(1,24);

            {** Make recursive call to "[K]eep" current message **}

            GetUserOption(Error);
          end;
     else
       {** do nothing **} ;

  end; {** of case **}

end;  {** of procedure GetUserOption **}

{----------------------------------------------------------------------*
*                       Procedure GetSortedNames                       *
*                            March 12, 1992                            *
* -------------------------------------------------------------------- *
* AUTHOR:  Tom Kaltenbach                                              *
*          429 Woodsong Lane                                           *
*          Rochester, New York 14612                                   *
*          Email:  tom@kalten.bach1.sai.com                            *
* -------------------------------------------------------------------- *
*                                                                      *
* SUMMARY:                                                             *
*                                                                      *
*    This procedure gets a list of all files matching the input file-  *
* spec, sorts the list, and writes the list to a temporary file.  The  *
* memory required for sorting the list is allocated within this proc-  *
* edure and de-allocated before this procedure terminates.             *
*                                                                      *
*----------------------------------------------------------------------}

Procedure GetSortedNames (var F : text; var Error : integer);

var i : integer;

begin

  {--------------------------------------------------------
  Allocate dynamic memory for list of input files
  --------------------------------------------------------}

  i := 0;
  while ((i < MaxFiles) and (MaxAvail > (SizeOf(String12)))) do
    begin
      i := i + 1;
      NEW(SrchName[i]);
    end;

  FileSpace := i;

  SrchName[1]^ := InFileRec.Name;
  i := 1;
  while ((DosError = 0) and (i <= FileSpace)) do
    begin
      i := i + 1;
      SrchName[i-1]^ := InFileRec.Name;
      FindNext(InFileRec);
    end;
  NumFiles := i - 1;

  SortString (SrchName,NumFiles,false);

  {** Write names to temporary file **}

  for i := 1 to NumFiles do
    writeln(F,SrchName[i]^);

  {** Free up allocated memory **}

  i := 1;
  while (i <= FileSpace) do
    begin
      dispose(SrchName[i]);
      i := i + 1;
    end;

end; {** of procedure GetSortedNames **}

{** ------------------------------------------------------------ **}

BEGIN  {** Main program **}

  rewrite (output);
  reset (input);
  Randomize;

  TextColor(LightGreen);
  TextBackGround(Black);
  ClrScr;

  {** Greet user **}

  TextColor(Yellow);
  TextBackground(Blue);
  write ('THREAD v',Ver,' by Tom Kaltenbach - Modified ',LastMod);
  ClrEOL;
  writeln;
  Window (1,2,80,25);
  TextColor(LightGreen);
  TextBackGround(Black);

  writeln;

  {** Initialize variables **}

  SearchPtr := 1;
  DisplayPtr := 2;
  CheckBreak := True;
  Delim := '------------';
  Border := '';
  for i := 1 to 80 do
    Border := concat(Border,chr(196));

  Error := 0;
  FilesLeft := True;
  Automatic := False;
  Target[0].Logical := 'OR';

  {** Prompt user for filenames **}

  GetUserInput(Error);

  if (Error <> 0) then goto Quit;

  {--------------------------------------------------------
  Create sorted list of input filenames in temporary file
  --------------------------------------------------------}

  assign (NameFile,TempFile);
  rewrite(NameFile);

  GetSortedNames(NameFile,Error);

  if (Error <> 0) then goto Quit;

  close(NameFile);
  reset(NameFile);
  if not(eof(NameFile)) then
    readln(NameFile,CrntName)
  else
    begin
      writeln;
      writeln ('No input files found.');
      goto Abort;
    end;
    
  {--------------------------------------------------------
  Allocate dynamic memory for message buffer:  if <MaxBuff>
  lines aren't available to us, take what we can get
  --------------------------------------------------------}

  i := 0;
  while ((i < MaxBuff) and (MaxAvail > (2 * SizeOf(String)))) do
    begin
      i := i + 1;
      NEW(Buffer[1,i]);
      NEW(Buffer[2,i]);
    end;

  MaxLines := i;

  {----------------------------------------
  Open first file and find first delimiter
  -----------------------------------------}

  FirstFile := concat(InDir,CrntName);
  LastFile := FirstFile;
  Assign (InFile,FirstFile);
  SetTextBuf(InFile,TxtInBuf,SizeOf(TxtInBuf));
  reset (InFile);
  FileCt := 1;
  MsgCt := 0;
  MsgTotal := 0;
  HitCt := 0;
  WrtCt := 0;
  writeln (OutFile);
  writeln (OutFile,'Output from THREAD v',Ver,
           ' By Tom Kaltenbach -- Modified ',LastMod);
  writeln (OutFile);
  writeln (OutFile,'Output file (this file):       ',OutName);
  writeln (OutFile,'Input file spec (for search):  ',SrcSpec);
  writeln (OutFile);
  writeln (OutFile,'Search terms:   (c) = case-specific');
  write (OutFile,'   ');
  for i := 1 to (NumFields-1) do
    begin
      write (OutFile,'"',Target[i].Str,'"');
      if not(Target[i].AnyCase) then write (OutFile,' (c)');
      write (OutFile,' ',Target[i].Logical,' ');
    end;
  write (OutFile,'"',Target[NumFields].Str,'"');
  if not(Target[NumFields].AnyCase) then writeln (OutFile,' (c)');
  writeln (OutFile);
  writeln (OutFile,Delim,Delim);
  writeln (OutFile);

  {** Display file being scanned on user screen **}

  DisplayScan('Scanning file: ');

  {** Search for first delimiter **}

  FindDelim (Error);

  WaitingForUser := FALSE;
  while ((FilesLeft) and (Error = 0)) do
    begin

      {** Read next message in current file **}

      ReadMsg (Found,Error);

      {** Check for read errors **}

      if (Error > 1) then goto Quit;

      {** If waiting for user input, check for keypress **}

      if ((WaitingForUser) and (KeyPressed)) then
        begin
          GetUserOption(Error);
          if (Error <> 0) then goto Quit;
        end;


      {** ------------ **}

      CrntMode := 'OR';
      Success := False;

      for i := 1 to NumFields do
        begin

          {** If waiting for user input, check for keypress **}

          if ((WaitingForUser) and (KeyPressed)) then
            begin
              GetUserOption(Error);
              if (Error <> 0) then goto Quit;
            end;

          Found := FindTarg(i);
          if (Target[i-1].Logical = 'AND') then Success := Success AND Found;
          if (Target[i-1].Logical = 'OR') then  Success := Success OR Found;
          if (Target[i-1].Logical = 'NOT') then Success := Success AND NOT(Found);
        end;

      {** ------------ **}

      if (Success) then
        begin

          HitCt := HitCt + 1;

          DisplayScan('Found next in: ');
          if (WaitingForUser) then NextFound := TRUE;

          {** If automatic mode enabled, write to disk **}

          if (Automatic) then
            begin
              GetUserOption(Error);
              if (Error > 1) then goto Quit;
            end;

          {** If user input is still pending from last found message,
              wait until user clears display buffer (and swaps with
              search buffer) before continuing with scan for next
              buffer **}

          while (WaitingForUser) do
            if (KeyPressed) then
              begin
                GetUserOption(Error);
                if (Error > 1) then goto Quit;
              end;

          NextFound := FALSE;

          {** Display next buffer **}

          if (Automatic) then DisplayStats(Output);

          DisplayBuffer;

        end;

      if (Not(FilesLeft) and WaitingForUser) then
        begin
          DisplayScan('Last found in: ');
          while (WaitingForUser) do
            if ((KeyPressed) or (Automatic)) then
              begin
                GetUserOption(Error);
              end;

        end;

    end; {** of "while(FilesLeft) do..." **}

Quit:

if (Error < 3) then
  begin
    DisplayStats (OutFile);
    writeln (OutFile,Delim,Delim);
    close (OutFile);
    DisplayStats (Output);
  end;

If (Error < 2) then
  begin
    writeln;
    writeln ('File search complete -- program terminated normally.');
  end;

Abort:

  if (FileExists(TempFile)) then
    begin
      close(NameFile);
      erase(NameFile);
    end;
  writeln;

END. {** of program Thread **}