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

    {***********************************************************************}
    {$M 16384,0,0}                  { Save memory for Calling PKUNZIP.      }
    PROGRAM NMembers;               { May 16/94, Greg Estabrooks.           }
    USES
         DOS;
    CONST
         Ver      = 'V0.2á';        { Current Version of program.           }
         ProgTitle= 'NMem '+Ver+'- Conference Member Tracking Program. ';
         Author   = 'CopyRight (C) 1994, Greg Estabrooks.';
    TYPE
        Direction = (Left,Right);

        MsgDHdr = RECORD            { Structre of QWK Message Header.       }
                   Status    :CHAR;
                   MNum      :ARRAY[1..7] OF CHAR;
                   Date      :ARRAY[1..8] OF CHAR;
                   Time      :ARRAY[1..5] OF CHAR;
                   MTo       :ARRAY[1..25] OF CHAR;
                   MFrom     :ARRAY[1..25] OF CHAR;
                   MSubj     :ARRAY[1..25] OF CHAR;
                   Pass      :ARRAY[1..12] OF CHAR;
                   MRefer    :ARRAY[1..8] OF CHAR;
                   NChunks   :ARRAY[1..6] OF CHAR;
                   Active    :CHAR;
                   MConf     :WORD;
                   Fill      :ARRAY[1..3] OF CHAR;
                 END;{MsgDHdr}

        NDXType = RECORD
                    Offset :LONGINT;
                    Misc   :BYTE;
                  END;

        MessInfType = RECORD
                       Name  :STRING[25];   { Name of person message FROM.  }
                       Origin:STRING[80];   { Origin line from message.     }
                      END;

    VAR
      QWKName :STRING[128];         { QWK File to process.                  }
      OutFile :STRING[128];         { File to place new member names.       }
      WorkDir :STRING[128];         { Holds the name of our work directory. }
      OutHan  :TEXT;                { File handle for output file.          }
      MessDat :FILE;                { File handle for MESSAGES.DAT.         }

      NumMess :WORD;                { Number of messages in conference.     }
      NewMems :WORD;                { Number of new members found.          }
      NumFound:WORD;                { Holds number of different names found.}

      fOfs    :ARRAY[1..500] OF LONGINT;{ Holds offset info from NDX file.  }
      FInf    :ARRAY[1..500] OF MessInfType;

    FUNCTION PadStr( Dir :Direction; Str2Pad :STRING; Til :BYTE;
                                                     Ch :CHAR ) :STRING;
                             { Function to pad a string with 'Ch' until it  }
                             { is 'Til' long.                               }
    VAR
       Temp :STRING;                { Temporary String info.                }
    BEGIN
      Temp := Str2Pad;              { Initialize 'Temp' to users string.    }
      IF Length(Temp) < Til THEN    { If its smaller than 'Til' add padding.}
      WHILE (Length(Temp) < Til) DO { Loop until proper length reached.     }
       BEGIN
         CASE Dir OF
          Right :Temp := Temp + Ch; { If Right then add to end of string.   }
          Left  :Temp := Ch + Temp; { If Left then add to begining.         }
         END;
       END;
      PadStr := Temp;               { Return proper result.                 }
    END;

    PROCEDURE InitVars;
                            { Procedure to initialize program variables.    }
    VAR
       Temp :STRING[4];             { Temporary String value.               }
    BEGIN
      FillChar(FInf,SizeOf(FInf),#0); { Clear FInf.                         }
      NumMess := 0;                 { Clear number of messages.             }
      NewMems := 0;                 { Clear number of new members found.    }
      QWKName := ParamStr(1);       { Get QWK Name from command line.       }
      NumFound := 1;                { Initialize 'NumFound.'                }
      Temp := ParamStr(2);          { Get Conf Number from command line.    }
      OutFile := 'CNF'+PadStr(Left,Temp,5,'0')+'.LST';
                                    { Prepare output file name.             }

      GetDir(0,WorkDir);            { Save current directory.               }
      IF WorkDir[Length(WorkDir)] = '\' THEN
       WorkDir := WorkDir +'NMEM'
      ELSE
       WorkDir := WorkDir +'\NMEM';
    END;{InitVars}

    PROCEDURE Syntax_Error;
                           { Display proper command line syntax to user.    }
    BEGIN
      Writeln;                      { Skip a line.                          }
      Writeln(
         'Syntax: NMEM [drive]:[path]PacketName ConfNum');
                                    { Show syntax for user.                 }
      Writeln;                      { Skip a line.                          }
                                    { Show an example usage.                }
      Writeln('EXAMPLE : NMEM C:\QWK\MYBBS.QWK 123');
      Writeln(' Scans MYBBS.QWK and generates CNF00123.LST');
      Halt(1);                      { Halt program with and ERRORLEVEL of 1.}
    END;{Syntax_Error}

    FUNCTION fExist( FName :STRING ) :BOOLEAN;
                            { Routine to determine whether or not 'FName'   }
                            { really exists.                                }
    BEGIN
      fExist := (fSearch(FName,'') <> '');
    END;{fExist}

    FUNCTION DirExist( DName :STRING ) :BOOLEAN;
                             { Routine to determine whether or not the      }
                             { Directory 'DName' exists.                    }
    VAR
       DirInf :SearchRec;           { Hold info if dir found.               }
    BEGIN
      FindFirst(DName,Directory,DirInf);
      DirExist := (DosError = 0);
    END;{DirExist}

    PROCEDURE DelWorkDir;
                             { Routine to delete files in the work directory}
                             { and them remove the directory.               }
    VAR
       FileInf :SEARCHREC;          { Holds file names for erasure.         }
       fVar    :FILE;               { Handle of file to delete.             }
    BEGIN
      FindFirst(WorkDir+'\*.*',Archive,FileInf); { Get File Name.           }
      WHILE (DosError = 0) DO       { Loop until all file names read.       }
      BEGIN
        Assign(fVar,WorkDir+'\'+FileInf.Name);
                                    { Assign file name to handle.           }
        Erase(fVar);                { Erase File.                           }
        FindNext(FileInf);          { Get next file name.                   }
      END;
    END;{DelWorkDir}

    PROCEDURE OpenPacket( QName :STRING );
                             { Routine open mail packets.                   }
    VAR
       PKPath :STRING;              { Holds location of PKUNZIP.EXE         }
    BEGIN
      IF NOT DirExist(WorkDir) THEN { If dir doesn't exist then make it.    }
       BEGIN
        {$I-}                       { Turn I/O checking off.                }
        MKDir(WorkDir);             { Create our work directory.            }
        {$I+}                       { Turn I/O checking off.                }

        IF IOResult <>0 THEN        { If I/O error then                     }
         BEGIN                      { Display error message.                }
          Writeln('Error creating work directory',^G);
          Halt(1);                  { Now halt program.                     }
         END;

       END
      ELSE
       DelWorkDir;                  { If it does exist then clear it.       }

      IF NOT fExist('PKUNZIP.EXE') THEN { If it's not in the current dir    }
       BEGIN                        { then search the %PATH%.               }
        PKPath := fSearch('PKUNZIP.EXE',GetEnv('PATH'));
        IF PKPath = '' THEN         { If it's nowhere to be found then      }
         BEGIN                      { Display error message.                }
          Writeln('Cannot find PKUNZIP.EXE!',^G);
          Writeln('It must be located either in the ',
                     'current directory or along your %PATH%');
          Halt(1);                  { Now halt program.                     }
         END;
       END;

      SwapVectors;                  { Swap to proper Interrupt vectors.     }
      Exec(GetEnv('COMSPEC'),'/C '+PKPath+' '+QWKName+' '+WorkDir+' >NUL');
      SwapVectors;                  { Swap em back.                         }

      IF DosError <> 0 THEN         { If there was an 'Exec' error then     }
       BEGIN                        { Display error message.                }
        Writeln('Error #',DosError,' occured executing ',PKPath,^G);
        Halt(1);                    { Now Halt program.                     }
       END;

      IF DosExitCode <> 0 THEN      { Check for a program error.            }
       Writeln(PKPath,' returned an ERRORLEVEL of ',DosExitCode,^G);
    END;{OpenPacket}

    FUNCTION NotNumber( NumStr :STRING ) :BOOLEAN;
                             { Routine to determine whether or not 'NumStr' }
                             { is a valid number.                           }
                             { Returns TRUE if not a number FALSE if a num. }
    VAR
       Result :BOOLEAN;             { Holds Function result.                }
       StrPos :BYTE;                { Position withing string.              }
    BEGIN
      Result := FALSE;              { Defaults to false.                    }
      FOR StrPos := 1 TO Length(NumStr) DO { Loop through entire string.    }
       IF NOT (NumStr[StrPos] IN
                ['0','1','2','3','4','5','6','7','8','9']) THEN
         Result := TRUE;

      NotNumber := Result;          { Return proper result.                 }
    END;{NotNumber}

    FUNCTION ReadNDX :BOOLEAN;
                             { Routine to read proper NDX file for conference.}
    VAR
       Result :BOOLEAN;             { Holds Function result.                }
       NDX    :FILE;                { File handle for NDX file.             }
       Info   :NDXType;             { Hold info read from NDX file.         }
       NumRead:WORD;                { Holds number of bytes read from NDX.  }
    BEGIN
      Result := TRUE;               { Default to success.                   }
      Assign(NDX,WorkDir+'\'+PadStr(Left,ParamStr(2),3,'0')+'.NDX');
      {$I-}                         { Turn off I/O checking.                }
      Reset(NDX,1);                 { Open NDX for reading.                 }
      {$I+}                         { Turn on I/O checking.                 }
      WHILE NOT EOF(NDX) DO         { Loop until end of file.               }
       BEGIN
         BlockRead(NDX,Info,SizeOf(Info),NumRead); { Read offset of message.}
         IF (NumRead = Sizeof(Info)) AND (NumMess <501) THEN
                                    { If proper amount read then            }
          BEGIN                     { Convert it to a proper LONGINT.       }
            INC(NumMess);           { Increase message total.               }
                                    { Now convert offset.                   }
            fOfs[NumMess] := ((Info.Offset AND NOT $FF000000) OR $00800000)
                              SHR (24 - ((Info.Offset SHR 24) AND $7F));
            fOfs[NumMess] := (fOfs[NumMess]-1) SHL 7;
          END
         ELSE
          Result := FALSE;          { Otherwise return FALSE result.        }
       END;
      Close(NDX);                   { Close NDX File.                       }
      ReadNDX := Result;            { Return proper result.                 }
    END;{ReadNDX}

    PROCEDURE RemoveSpaces(VAR Str2Rem :STRING);
                             { Routine to remove any spaces from 'Str2Rem'. }
    VAR
       StrPos :WORD;                { Position within string.               }
       Temp   :STRING;              { Temporary string work space.          }
    BEGIN
      Temp := '';                   { Clear string.                         }
      FOR StrPos := 1 TO Length(Str2Rem) DO { Loop through all characters.  }
       IF Str2Rem[StrPos] <> #32 THEN   { If its not a space then           }
        Temp := Temp + Str2Rem[StrPos]; { add it to our string.             }

      Str2Rem := Temp;              { Return newly changed string.          }
    END;{RemoveSpaces}

    FUNCTION Compare( Str1,Str2 :STRING ) :BOOLEAN;
                             { Routine to compare to strings after removing }
                             { any spaces from it.Case INSENSITIVE.         }
    VAR
       Result :BOOLEAN;             { Result from comparing.                }
       StrPos :BYTE;                { Position within 2 strings.            }
    BEGIN
      Result := TRUE;               { Default result to TRUE.               }
      RemoveSpaces(Str1);           { Trim spaces from the strings.         }
      RemoveSpaces(Str2);
      IF Length(Str1) <> Length(Str2) THEN { If different lengths then they }
       Result := FALSE                     { must be different.             }
      ELSE
       BEGIN
        StrPos := 0;                { Initialize 'StrPos' to 0.             }
        REPEAT                      { Loop until every char checked.        }
         INC(StrPos);               { Point to next char.                   }
         IF UpCase(Str1[StrPos]) <> UpCase(Str2[StrPos]) THEN
          BEGIN
           Result := FALSE;         { If there not the same then return     }
                                    { a FALSE result.                       }
           StrPos := Length(Str2);  { Now set loop exit condition.          }
          END;
        UNTIL StrPos = Length(Str2);
       END;

      Compare := Result;            { Return proper result.                 }
    END;{Compare}

    FUNCTION Arr2String( VAR Arr; Len :BYTE ) :STRING;
                             { Routine to convert 'Len' bytes of the array  }
                             { 'Arr' into a string.                         }
    VAR
       Result :STRING;              { Holds function result.                }
    BEGIN
      MOVE(Arr,Result[1],Len);      { Move bytes into our result string.    }
      Result[0] := CHR(Len);        { Set string length byte.               }

      Arr2String := Result;         { Return proper result.                 }
    END;{Arr2String}

    FUNCTION Fmt( Info :WORD ) :STRING;
                             { Routine to create a String with info int the }
                             { format '00'.                                 }
    VAR
       Temp :STRING;                { Hold temporary string info.           }
    BEGIN
      Str(Info,Temp);               { Convert info to a string.             }
      IF Length(Temp) = 1 THEN      { if its only a single digit then add   }
        Fmt := '0'+Temp             { leading zero.                         }
      ELSE
        Fmt := Temp;
    END;{Fmt}

    FUNCTION TimeStr :STRING;
    VAR
       Hour,Min,Sec,Sec100 :WORD;   { Holds temporary time info.            }
       Year,Mon,Day,DoWeek :WORD;   { Holds temporary date info.            }
       TempTime :STRING;            { Holds temporary TimeStr.              }
    BEGIN
      GetDate(Year,Mon,Day,DoWeek);
      TempTime := Fmt(Mon)+'-'+Fmt(Day)+'-'+Fmt(Year-1900)+' at ';
      GetTime(Hour,Min,Sec,Sec100); { Get Current Time.                     }
      IF Hour >= 12 THEN
        TempTime := TempTime+Fmt(Hour-12)+':'+Fmt(Min)+'pm'
      ELSE
        IF Hour = 0 THEN
          TempTime := TempTime+'12:'+Fmt(Min)+'am'
        ELSE
          TempTime := TempTime+Fmt(Hour)+':'+Fmt(Min)+'pm';
      TimeStr := TempTime;
    END;

    FUNCTION GetOrigin( Chunks :WORD ) :STRING;
                             { Routine to get message origin line if any.   }
    VAR
       Result :STRING;              { Holds function result.                }
       CurChnk:WORD;                { Holds current chunk being read.       }
       BufPos :WORD;                { Position within buffer.               }
       Temp   :STRING;
       NumRead:WORD;                { Holds number of bytes read from file. }
       Buffer :ARRAY[1..128] OF CHAR;{ Buffer for info read from file.      }
       TareLin:BOOLEAN;             { Holds whether or not we've past the   }
                                    { tear line.                            }
    BEGIN
      Result := '';                 { Clear result.                         }
      Temp := '';                   { Clear temporary storage space.        }
      TareLin := FALSE;             { Default to FALSE.                     }
      FOR CurChnk := 1 TO Chunks-1 DO { Loop through all the 128 byte chunks.}
       BEGIN
        BlockRead(MessDat,Buffer,128,NumRead); { Read message info.         }
        FOR BufPos := 1 TO 128 DO
         BEGIN
          IF Buffer[BufPos] = #227 THEN
           BEGIN
            IF Temp = '---' THEN
             TareLin := TRUE
            ELSE
             IF TareLin AND (Temp <> PadStr(Right,'',Length(Temp),' ')) THEN
              Result := Temp;
            Temp := ''
           END
          ELSE
           Temp := Temp + Buffer[BufPos];
         END;
       END;

      IF (Result = '') OR (Pos('ILink:',Result) = 0) THEN
       Result := ' þ Origin Line Unavailable þ ';

      GetOrigin := Result;          { Return proper result.                 }
    END;

    PROCEDURE ReadMsgs;
                             { Routine to read Messages and save new members}
                             { to disk.                                     }
    VAR
      MessBuf :MsgDHdr;             { Holds header info read from file.     }
      InfPos  :WORD;                { Loop variable for searching 'FileInf'.}
      CurMess :WORD;                { Loop variable for reading messages.   }
      NumRead :WORD;                { Holds number of bytes read from file. }
      Found   :BOOLEAN;             { Holds whether or not name was already }
                                    { read.                                 }
      FoundPos:WORD;                { Holds position in array name was found.}
      Temp    :STRING;              { Holds temporary string info.          }
      Chunks  :WORD;                { Holds number of 128 byte chunks message}
                                    { takes up in file.                     }
      ErrCode :WORD;                { Holds error codes returned from 'Val'.}
      Create  :BOOLEAN;
    BEGIN
      Create  := NOT fExist(OutFile);
      IF NumFound = 0 THEN NumFound := 1;
      Assign(MessDat,WorkDir+'\MESSAGES.DAT');{ Assign handle to message file.}
      {$I-}                         { Turn I/O checking off.                }
      Reset(MessDat,1);             { Open file for reading.                }
      {$I+}                         { Turn I/O checking back on.            }
      FOR CurMess := 1 TO NumMess DO { Loop through all the messages.       }
       BEGIN
         Seek(MessDat,fOfs[CurMess]);{ Move to current message position.    }
         BlockRead(MessDat,MessBuf,SizeOf(MessBuf),NumRead); { Read Header. }
         FOR InfPos := 1 TO NumFound DO
          BEGIN
           Found := Compare(FInf[InfPos].Name,Arr2String(MessBuf.MFrom,25));
           IF Found THEN
            InfPos := NumFound;
          END;
         IF NOT Found THEN
          BEGIN
           INC(NewMems);            { Increase number of new members.       }
           IF Create AND (NumFound = 1) THEN
            BEGIN
              NumFound := 0;
              Create := FALSE;
            END;
           INC(NumFound);           { Increase number found.                }

           FInf[NumFound].Name := Arr2String(MessBuf.MFrom,25);
           Temp := Arr2String(MessBuf.NChunks,6);
           RemoveSpaces(Temp);
           Val(Temp,Chunks,ErrCode);
           FInf[NumFound].Origin := GetOrigin(Chunks);
          END;
       END;
      Close(MessDat);               { Close message file.                   }
    END;{ReadMsgs}

    PROCEDURE SaveList;
                             { Routine to write our list to the list file.  }
    VAR
       ListPos :WORD;               { Position withing list being written.  }
    BEGIN
      Assign(OutHan,OutFile);       { Assign handle to file name.           }
      {$I-}                         { I/O off.                              }
      Rewrite(OutHan);              { Open file for writing.                }
      {$I+}                         { I/O on.                               }
      IF IOResult <> 0 THEN         { If there was an error.                }
       Writeln('-Error! Unable to Open ',OutFile,^G)
      ELSE
       BEGIN
        Writeln(OutHan,'');         { Write a blank line to file.           }
        Writeln(OutHan,'/*'+PadStr(Right,'',75,'-')+'*/');

        Writeln(OutHan,'                         Conference [',ParamStr(2),
                       '] Members list.');
        Writeln(OutHan,PadStr(Right,'',24,' ')+'Last Change '+TimeStr);
        Writeln(OutHan,'/*'+PadStr(Right,'',75,'-')+'*/');
        FOR ListPos := 1 TO NumFound DO
         BEGIN
          Writeln(OutHan,'');       { Writeln a blank line.                 }
          Writeln(OutHan,'User : '+FInf[ListPos].Name); { Writeln user name.}
          Writeln(OutHan,FInf[ListPos].Origin); { Write users origin line.  }
         END;
        Close(OutHan);                { Close file.                           }
       END;
    END;{SaveList}

    PROCEDURE ReadList;
                             { Routine to read in the conf members list.    }
    VAR
       InFile :TEXT;                { Text handle for conference list.      }
       Temp   :STRING;              { Holds string read from file.          }
    BEGIN
      NumFound := 0;
      Assign(InFile,OutFile);       { Assign handle to file name.           }
      {$I-}                         { I/O checking off.                     }
      Reset(Infile);                { Open file for reading.                }
      {$I+}                         { I/O checking on.                      }
      WHILE (NOT EOF(InFile)) AND (NumFound <500) DO
       BEGIN
        ReadLn(InFile,Temp);        { Read a line from the file.            }
        IF Copy(Temp,1,7) = 'User : ' THEN { If its the user name then.     }
         BEGIN                      { Save Name to array and read origin.   }
          INC(NumFound);
          FInf[NumFound].Name := Copy(Temp,8,Length(Temp));
          ReadLn(InFile,FInf[NumFound].Origin);
         END;
       END;
      IF NumFound = 0 THEN
       NumFound := 1;
      Close(InFile);                { Close file.                           }
    END;{ReadList}

    PROCEDURE SortList;
                             { Routine to sort the list of conference       }
                             { members using a simple bubble sort.          }
    VAR
       Temp  :MessInfType;          { Temporary record for swapping.        }
       Index1,Index2:WORD;          { Sort loop variables.                  }
    BEGIN
      FOR Index1 := NumFound DOWNTO 1 DO
       FOR Index2 := 2 TO Index1 DO
        IF FInf[Index2-1].Name > FInf[Index2].Name THEN
         BEGIN
          Temp := FInf[Index2];
          FInf[Index2] := FInf[Index2-1];
          FInf[Index2-1] := Temp;
         END;
    END;{SortList}

    BEGIN
      Writeln(ProgTitle);           { Display program title.                }

      IF (ParamCount <> 2) OR NotNumber(ParamStr(2)) THEN
                                    { If wrong command argument show proper }
        Syntax_Error                { syntax to use.                        }
      ELSE
       BEGIN
        InitVars;                   { Initialize variables.                 }
        IF fExist(QWKName) THEN     { If it exists begin processing.        }
         BEGIN
          Writeln('-Opening Packet');
          OpenPacket(QWKName);      { Open mail packet.                     }
          IF fExist(WorkDir+'\'+PadStr(Left,ParamStr(2),3,'0')+'.NDX') THEN
           BEGIN                    { IF there are any Messages in conf then}
                                    { Attempt to read NDX files.            }
            Writeln('-Reading NDX file');

            IF ReadNDX THEN         { IF there is no error, read messages.  }
             BEGIN

              IF fExist(OutFile) THEN{ IF Conf list already exist then read.}
               BEGIN
                Writeln('-Reading ',OutFile);
                ReadList;

               END;

              Writeln('-Reading Messages in conference [',ParamStr(2),']');
              ReadMsgs;

              IF NewMems > 0 THEN
               BEGIN

                IF fExist(OutFile) THEN
                 BEGIN
                  Writeln('-Renaming ',OutFile,' to ',Copy(OutFile,1,8)+'.BAK');

                  IF fExist(Copy(OutFile,1,8)+'.BAK') THEN
                   BEGIN
                    Assign(OutHan,Copy(OutFile,1,8)+'.BAK');
                    Erase(OutHan);
                   END;

                  Assign(OutHan,OutFile);
                  Rename(OutHan,Copy(OutFile,1,8)+'.BAK');
                 END
                ELSE
                 BEGIN
                  Writeln('-Creating ',OutFile);
                  Assign(OutHan,OutFile);
                  {$I-}
                  Rewrite(OutHan);
                  {$I+}
                  Close(OutHan);
                 END;
                Writeln('-Sorting member list');
                SortList;
                Writeln('-Saving ',NewMems,
                        ' new members for a total of ',NumFound,' members');
                SaveList;
               END
              ELSE
               Writeln('-No new members found');
             END
            ELSE
             Writeln('-Error reading NDX file',^G);
           END
          ELSE                      { Other wise let user know its not there.}
           Writeln('-NDX file for conference [',ParamStr(2),
                   '] does not exist. No new messages?'^G);

          Writeln('-Deleteing Work Directory');
          DelWorkDir;               { Delete Work Directory.                }
          {$I-}                     { Turn I/O checking off.                }
          RMDir(WorkDir);           { Remove work Directory.                }
          {$I+}                     { Turn I/O checking on.                 }
          IF IOResult <> 0 THEN     { If and error occurs then              }
          Writeln('Error Removing work directory.',^G);

         END
        ELSE                        { .... Otherwise ......                 }
         BEGIN                      { Show error message and beep.          }
          Writeln(^G,'Cannot find ',QWKName);
          Writeln('Tracking aborted!!');
         END;
       END;
    END.{NMembers}
    {***********************************************************************}

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