CD Shareware Magazine 1996 December/CD_shareware_12-96.iso/WIN/INTERNET/MLUTL110.ZIP/ML_INC.PAS

Pascal/Delphi Source File | 1996-10-16 | 9.5 KB | 360 lines

(* This is an "INCLUDE" file for "MLAdd.pas" and "MLDrop.pas", by DDA *)

TYPE
  ListLink = ^NameRecord;
  NameRecord = RECORD
                 Name   : STRING[70];
                 Next   : ListLink;
               END;

{$IFDEF MLDROP}

PROCEDURE ExitOnError (err : BYTE; msg : STRING);
CONST
  NL = #13#10;
BEGIN
  WriteLn ('MLDrop v1.10 - Free DOS utility: Drop names from an Internet mailing list.');
  WriteLn ('Oct. 16th, 1996. Copyright (c) 1996 by David Daniel Anderson - Reign Ware.'+NL);
  WriteLn ('Usage:   MLDrop  MasterList  drop_list(s)'+NL);
  WriteLn ('Example: MLDrop  friends  enemies'+NL);
  IF err > 0 THEN BEGIN
    IF err > 1 THEN Write(#7);
    WriteLn ('Error encountered (#', err, '):');
    WriteLn (msg);
  END;
  Halt (err);
END;

{$ENDIF}
{$IFDEF MLADD}

PROCEDURE ExitOnError (err : BYTE; msg : STRING);
CONST
  NL = #13#10;
BEGIN
  WriteLn ('MLAdd v1.10 - Free DOS utility: Add names to an Internet mailing list.');
  WriteLn ('Oct. 16th, 1996. Copyright (c) 1996 by David Daniel Anderson - Reign Ware.'+NL);
  WriteLn ('Usage:   MLAdd  MasterList  [add_list(s)]'+NL);
  WriteLn ('Example: MLAdd  friends  buddies'+NL);
  IF err > 0 THEN BEGIN
    IF err > 1 THEN Write(#7);
    WriteLn ('Error encountered (#', err, '):');
    WriteLn (msg);
  END;
  Halt (err);
END;

{$ENDIF}

PROCEDURE CheckIO;
BEGIN
  IF IOResult <> 0 THEN ExitOnError (7, 'File handling error.');
END;

FUNCTION Upper (lstr : STRING): STRING;
  PROCEDURE UpFast (VAR Str: STRING);  {** from SWAG **}
  INLINE($8C/$DA/$5E/$1F/$FC/$AC/$30/$E4/$89/$C1/$E3/$12/$BB/Ord('a')/Ord('z')/
       $AC/$38/$D8/$72/$08/$38/$F8/$77/$04/$80/$6C/$FF/$20/$E2/$F1/$8E/$DA);
BEGIN
  UpFast (lstr);
  Upper := lstr;
END;

FUNCTION IsFile (CONST FileName: PATHSTR): BOOLEAN;
VAR
  Attr  : WORD;
  cFile : FILE;
BEGIN
  Assign (cFile, FileName);
  GetFAttr (cFile, Attr);
  IF (DosError = 0) AND ((Attr AND Directory) <> Directory)
    THEN IsFile := TRUE
    ELSE IsFile := FALSE;
END;

FUNCTION IsDir (CONST FileName: PATHSTR): BOOLEAN;
VAR
  Attr  : WORD;
  cFile : FILE;
BEGIN
  Assign (cFile, FileName);
  GetFAttr (cFile, Attr);
  IF (DosError = 0) AND ((Attr AND Directory) = Directory)
    THEN IsDir := TRUE
    ELSE IsDir := FALSE;
END;

PROCEDURE EraseFile (CONST FileName : STRING);
VAR
  cFile : FILE;
BEGIN
  IF IsFile (FileName) THEN BEGIN
    Assign (cFile, FileName);
    SetFAttr (cFile, 0);
    Erase (cFile); CheckIO;
  END;
END;

FUNCTION GetFilePath (CONST PSTR: STRING; VAR sDir: DIRSTR): PATHSTR;
VAR
  jPath     : PATHSTR;  { file path,       }
  jDir      : DIRSTR;   {      directory,  }
  jName     : NAMESTR;  {      name,       }
  jExt      : EXTSTR;   {      extension.  }
BEGIN
  jPath := PSTR;
  IF jPath = '' THEN jPath := '*.*';
  IF (NOT (jPath [Length (jPath)] IN [':', '\'])) AND IsDir (jPath) THEN
    jPath := jPath + '\';
  IF (jPath [Length (jPath)] IN [':', '\']) THEN
    jPath := jPath + '*.*';

  FSplit (FExpand (jPath), jDir, jName, jExt);
  jPath := jDir + jName+ jExt;

  sDir := jDir;
  GetFilePath := jPath;
END;

FUNCTION FindName (Address: STRING): STRING;
(*
│ Allowed characters:                │ Disallowed characters:
├────────────────────────────────────┼──────────────────────────────
│                                    │   0-32   Control chars + Space
│                                    │  33-34   !"
│#                            35     │  36-44   $%&'()*+,
│-.                           45- 46 │  47      /
│0123456789                   48- 57 │  58-63   :;<=>?
│@                            64     │  64      @       (valid ONCE)
│ABCDEFGHIJKLMNOPQRSTUVWXYZ   65- 90 │  91-94   [\]^
│_                            95     │  96      `
│abcdefghijklmnopqrstuvwxyz   97-122 │ 123-126  {|}~
│                                    │ 127-255  Upper ASCII
*)
VAR
  EmailChars,
  NoDelimits : SET OF CHAR;
  aPos, first, last : BYTE;
  DONE : BOOLEAN;

BEGIN
  EmailChars := ['#','-','.','0'..'9','A'..'Z','_','a'..'z'];
  NoDelimits := ['#','-','.','_'];

  aPos := Pos ('@', Address);
  IF aPos > 0 THEN
  BEGIN
    first := aPos;
    DONE := FALSE;
    WHILE NOT DONE DO
      IF ((first-1) = 0) OR (NOT (Address[first-1] IN EmailChars))
        THEN DONE := TRUE
        ELSE Dec (first);

    last := aPos;
    DONE := FALSE;
    WHILE NOT DONE DO
      IF ((last+1) > Length (Address)) OR (NOT (Address[last+1] IN EmailChars))
        THEN DONE := TRUE
        ELSE Inc (last);

    Address := Copy (Address, first, 1+last-first);

    WHILE Address[1] IN NoDelimits DO
      Address := Copy (Address, 2, Length (Address) - 1);
    WHILE Address[Length (Address)] IN NoDelimits DO
      Address := Copy (Address, 1, Length (Address) - 1);

    IF (Address[1] = '@') OR (Address[Length (Address)] = '@') THEN
      Address := '';

    IF Address <> '' THEN
    BEGIN
      aPos := Pos ('@', Address) + 2;
      last := Length (Address);
      DONE := FALSE;
      WHILE (aPos <= last) AND (NOT DONE) DO
      BEGIN
        IF Address[aPos] = '.' THEN DONE := TRUE;
        Inc (aPos);
      END;
      IF NOT DONE THEN Address := '';
    END;
  END
  ELSE
    Address := '';

  FindName := Address;
END;

PROCEDURE AddToList (VAR NameList: ListLink; fName: STRING; VAR TotalMems: WORD);
VAR
  NewName    : STRING;
  Anchor,
  NameNode : ListLink;
  InFile     : TEXT;

BEGIN
  Anchor := NameList;
  IF NameList <> NIL THEN    { advance to end of list }
    WHILE (NameList^.Next) <> NIL DO NameList := NameList^.Next;

  NameNode := NIL;

  IF IsFile (fName) THEN BEGIN
    Assign (InFile, fName);
    Reset (InFile); CheckIO;
    Write ('Reading names to add from: ', fName, ', please wait ... ');

    WHILE NOT SeekEof (InFile) DO
    BEGIN
      ReadLn (InFile, NewName); CheckIO;   { fill in new data }
      NewName := FindName (NewName);       { extract email address from line }

      IF (Length (NewName) > 1) AND (NewName[1] <> '@') THEN
      BEGIN

        Inc (TotalMems);
        New (NameNode);

        NameNode^.Name := Copy (NewName, 1, 80);
        NameNode^.Next := NIL;

        IF NameList = NIL                    { add to end of list }
          THEN Anchor := NameNode            { point to first node }
          ELSE NameList^.Next := NameNode;

        NameList := NameNode;                { point to last node }
      END;
    END; {while}

    Close (InFile); CheckIO;
    NameList := Anchor;
  END;

  WriteLn ('done!');
  NameList := Anchor;
END;

PROCEDURE EditList (VAR NameList: ListLink; VAR TotalMems: WORD);
VAR
  TempName : STRING;
  Anchor,
  TempNode,
  Chain : ListLink;
BEGIN
  Anchor := NameList;

  WHILE (NameList <> NIL) AND (NameList^.Next <> NIL) DO
  BEGIN
    { Take one name at a time, and go through rest of list, deleting dups }

    TempName := Upper (NameList^.Name);

    Chain := NameList;
    WHILE (Chain <> NIL) AND (Chain^.Next <> NIL) DO
    BEGIN
      IF Upper (Chain^.Next^.Name) = TempName THEN
      BEGIN
        TempNode := Chain^.Next;
        Chain^.Next := Chain^.Next^.Next;
        Dispose (TempNode);
        Dec (TotalMems, 1);
      END
      ELSE
        Chain := Chain^.Next;
    END;

    NameList := NameList^.Next;
  END;
  NameList := Anchor;
END;

PROCEDURE WriteList (VAR NameList: ListLink; fName: STRING; VAR TotalMems: WORD);
VAR
  MemList : TEXT;
  Chain : ListLink;
BEGIN
  Assign (MemList, fName);
  Rewrite (MemList);
  IF (IOResult <> 0) THEN
    ExitOnError (4, 'Cannot create file for new master mailing list.');

  WHILE NameList <> NIL DO
  BEGIN
    WriteLn (MemList, NameList^.Name);
    Chain := NameList;
    NameList := NameList^.Next;
    Dispose (Chain);
  END;
  Close (MemList); CheckIO;
END;

PROCEDURE DropFromList (VAR NameList: ListLink; fName: STRING; VAR TotalMems: WORD);
VAR
  TempName    : STRING;
  Anchor,
  TempNode,
  Chain : ListLink;
  InFile     : TEXT;

BEGIN
  Anchor := NameList;

  IF IsFile (fName) THEN BEGIN
    Assign (InFile, fName);
    Reset (InFile); CheckIO;
    WriteLn ('Reading names to drop from: ', fName);

    WHILE NOT SeekEof (InFile) DO
    BEGIN
      ReadLn (InFile, TempName); CheckIO;   { fill in new data }
      TempName := FindName (TempName);       { extract email address from line }

      IF (Length (TempName) > 1) AND (TempName[1] <> '@') THEN
      BEGIN
        TempName := Upper (TempName);

        NameList := Anchor;
        IF (NameList <> NIL) THEN
        BEGIN
          Chain := NameList;
          { Take temp name, and go through entire list, deleting dups }

          WHILE (Chain <> NIL) AND (Upper (Chain^.Name) = TempName) DO
          BEGIN
            TempNode := Chain;

            Chain := Chain^.Next;  { advance EVERYTHING! }
            NameList := Chain;
            Anchor := Chain;

            Dispose (TempNode);
            Dec (TotalMems, 1);
          END;

          WHILE (Chain <> NIL) AND (Chain^.Next <> NIL) DO
          BEGIN
            IF Upper (Chain^.Next^.Name) = TempName THEN
            BEGIN
              WriteLn ('Dropped "', Chain^.Next^.Name, '" from list.');
              TempNode := Chain^.Next;
              Chain^.Next := Chain^.Next^.Next;
              Dispose (TempNode);
              Dec (TotalMems, 1);
            END
            ELSE
              Chain := Chain^.Next;
          END;

        END;
      END;
    END;

    WriteLn ('Finished dropping names.');
    Close (InFile); CheckIO;
  END;

  NameList := Anchor;
END;