// JJAddAndRemoveHeadersWhileDoubleCheckingIdentityNgAndServers
// <http://pastebin.com/fcYjL9Vb> newer version
// <http://pastebin.com/2tMYRKM4> older version
// From: JJ <jj4public@vfemail.net>
// Newsgroups: news.software.readers,alt.windows7.general
// Subject: Re: Request help with 40tude dialog program syntax
// Date: Thu, 5 Jan 2017 23:06:19 +0700
// Message-ID: <7vpx5y09pu98.1sukl5d600sda$.dlg@40tude.net>
// Original code for checking identity:
// http://dialog.datalist.org/scripts/CheckingIdentity.html
// Original code for modifying headers:
// http://dialog.datalist.org/scripts/RemoveHeaders.html
// NOTES:
// The StrMatch fct is case sensitive and only matches the first item found!
// Define a StrContains fct to match multiple either/or newsgroups.
// If you don't set Remove_Header, then none will be removed.
// If you don't set Add_Header, then none will be added.
// For some headers you have to remove them first, then add them back.
// Dialog will error when sending if you add headers sans (CR+LF) syntax!
// WriteLn doesn't seem to do anything.
// CUSTOMIZATION ORDER OF OPERATIONS:
// 1. Set the "ForNewsgroup" Boolean as desired (search for "ForNewsgroup :")
// 2. Set the "ForEmail" Boolean as desired (search for "ForEmail :")
// 3. Change identity(ies) as desired (search for "from,")
// 4. Change newsgroup(s) as desired (search for "newsgroup,")
// 5. Change server(s) as desired (search for "server,")
// 6. Change remove header(s) as desired (search for "Remove_Headers :")
// 7. Change add header(s) as desired (search for "Add_Headers :")
// End of initial comments.

program OnBeforeSendingMessage;

(*
Format for Remove_Headers: {} = required, [] = optional
  {HeaderName: }[,HeaderName: ][,HeaderName: ][...]
Examples:
- Single header: 'User-Agent: '
- Multiple headers: 'User-Agent: ,X-Face: '
*)
procedure RemoveHeaders(Message : TStringlist;
                        const Remove_Headers: String
);
var i                : integer;
    k                : integer;
    s                : string;
    CommaPos         : integer;
    DelHeader        : TStringlist;
    RemoveH          : String;
begin
   RemoveH := Remove_Headers;
   i := 0;
   If ( RemoveH <> '' ) then begin
      try
         DelHeader := TStringlist.Create;
         if ansipos ( ',', RemoveH) = 0 then begin
            DelHeader.Add ( LowerCase ( TrimLeft( RemoveH )));
         end // if
         else begin
            CommaPos := 0;
            for k := 1 to length ( RemoveH ) do begin
               If RemoveH[k] = ',' then begin
                  DelHeader.Add ( LowerCase ( TrimLeft (copy ( RemoveH, CommaPos + 1, k - ( CommaPos + 1 )))));
                  CommaPos := k;
               end; // if
               if k = length ( RemoveH ) then
                  DelHeader.Add ( LowerCase ( TrimLeft (copy ( RemoveH, CommaPos + 1, k - CommaPos ))));
               end; // for
            end; // else
            s:= Message.text;
            while (Message.Strings[i]<>'') do begin
               k := 0;
               while k <= ( DelHeader.Count - 1 ) do begin
                  if pos( DelHeader[k], LowerCase ( Message.Strings[i] )) = 1 then
                  begin
                     delete ( s, pos(DelHeader[k], LowerCase (s) ), length (Message.Strings[i] ) + 2 );
                     i := i - 1;
                     k := DelHeader.Count - 1;
                     message.text := s;
                  end; // if
                  k := k + 1;
               end; // while
               i := i + 1;
            end; //while
            message.text:=s;
         finally
            DelHeader.Free;
         end; // try - finally
      end; // if
end; // RemoveHeaders

(*
Format for Add_Headers: {} = required, [] = optional
  {HeaderName: HeaderValue{#13#10}}[HeaderName: HeaderValue{#13#10}][...]
Examples: (each header must end with CR+LF)
- Single header: 'User-Agent: '#13#10
- Multiple headers: 'User-Agent: MyNewsClient'#13#10'X-Comment: To be, or not to be'#13#10

WARNING: For the Add_Header, you MUST add the pound13-Pound10 as shown in the examples!
If you forget to add the #13#10, then Dialog will error when you send news saying something like:
Posting article failed: 437 Space before colon in "On Fri, 6 Jan 2017" header;
*)
procedure AddHeaders(var Message : TStringlist;
                     const Add_Headers: String
);
var
  SeparatorIndex: integer;
  s: string;
begin
  s:= Message.Text;
//  writetolog('***before***'#13#10+s, 7);
  SeparatorIndex:= pos(#13#10#13#10, s);
  Insert(Add_Headers, s, SeparatorIndex+2);
  Message.Text:= s;
//  writetolog('***after***'#13#10+s, 7);
end;

function StrMatch(str: String; pattern: String):Boolean;
var
  patternSize : Integer;
  subStr : String;
  compareRes : Integer;
begin
  patternSize := Length(pattern);
  subStr := Copy(str, 1, patternSize);
  compareRes := CompareStr(pattern, subStr);
  if (compareRes = 0) then
    result := true
  else
    result := false;
end;

//the xxx2Identity() functions must return an empty string if specified string is not identified
// Customize your identity below for personal or business use as needed.
// The string match is probably case sensitive!
function From2Identity(from: String): String;
begin
if (StrMatch(from, 'First1 Last1 <email1@domain.net>')) then
    result := 'id1'
  else if (StrMatch(from, 'First2 Last2 <email2@domain.net>')) then
    result := 'id2'
  else if (StrMatch(from, 'First3 Last3 <email3@domain.net>')) then
    result := 'id3'
  else
    result := '';
end;

// WARNING: The StrMatch function can only check the first listed newsgroup!
// Define a StrContains function if you want to match either/or newsgroups!
// function StrContains(const Str: string; const Pattern: string): boolean;
// begin
//    result:= pos(Pattern, Str) > 0;
// end;
// EXAMPLE: This StrMatch will only match the first newsgroup in the outgoing Newsgroup header!
// if (StrMatch (newsgroup, 'news.software.readers') or StrMatch(newsgroup, 'alt.free.newsservers')) then result := 'id1'
// If defined, this StrContains will match either newsgroup or both in the outgoing Newsgroup header:
// if StrContains(newsgroup, 'news.software.readers') or StrContains(newsgroup, 'alt.free.newssservers') then result := 'id1'
// End of comments

function StrContains(const Str: string; const Pattern: string): boolean;
begin
   result:= pos(Pattern, Str) > 0;
end;

function NewsGroup2Identity(newsgroup: String): String;
begin
    if StrContains(newsgroup, 'ng1') or StrContains(newsgroup, 'ng2') then
    result := 'id1'
  else if StrMatch(newsgroup, 'ng3') then
    result := 'id2'
  else if StrMatch(newsgroup, 'ng4') then
    result := 'id3'
  else
    result := '';
end;

// The name of the server is what Dialog lists in the "Available Servers" UI.
function Server2Identity(server: String): String;
begin
  if (CompareStr(server, 'aioe_119') = 0) then
    result := 'id1'
  else if (CompareStr(server, 'albasani_563') = 0) then
    result := 'id2'
  else
    result := '';
end;

procedure GetIdentities(var message: TStringlist; servername: string;
  isEmail: boolean; var FromIdentity: String; var NewsgroupIdentity: String;
  var ServerIdentity: String);
var i : Integer;
begin
  FromIdentity := '';
  NewsgroupIdentity := '';
  ServerIdentity := '';
  if (not IsEmail) then
  begin
    for i := 0 to Message.Count - 1 do
    begin
      if (strMatch(Message[i], 'From:')) then
        fromIdentity := Copy(Message[i], 7, Length(Message[i]) - 6);
      if (strMatch(Message[i], 'Newsgroups:')) then
        newsgroupIdentity := Copy(Message[i], 13, Length(Message[i]) - 12);
    end;
    fromIdentity := From2Identity(fromIdentity);
    newsgroupIdentity := NewsGroup2Identity(newsgroupIdentity);
    serverIdentity := Server2Identity(servername);
    // The default log file is C:/Program Files/40tude/logs/YYYYMMDD.log
    WriteToLog('  fromIdentity = ' + fromIdentity, 7);
    WriteToLog('  newsgroupIdentity = ' + newsgroupIdentity, 7);
    WriteToLog('  serverIdentity = ' + serverIdentity, 7);
  end;
end;

procedure LogHeaders(var Message: TStringlist);
var
  i: integer;
  s: string;
begin
  s:= '';
  for i:= 0 to message.count-1 do
  begin
    if message[i] <> '' then s:= s+message[i]+#13#10
    else break;
  end;
  writetolog(s, 7);
end;

function OnBeforeSendingMessage(var Message     : TStringlist;
                                    Servername  : string;
                                    IsEmail     : boolean
):boolean;
var
  ForEmail: boolean;
  ForNewsgroup : boolean;
  FromIdentity: String;
  NewsgroupIdentity: String;
  ServerIdentity: String;
  Remove_Headers: String;
  Add_Headers: String;
begin
  //get the identities of the message
  GetIdentities(message, servername, isEmail, FromIdentity, NewsgroupIdentity, ServerIdentity);

// Four program decisions to be made if you wish to change the program defaults:
// 1. This Boolean sets whether email headers are modified:
//    ForEmail := false;    //false means don't do email message by default
//    ForEmail := true;     //true means do email headers
// 2. This Boolean sets whether newsgroup headers are modified:
//    ForNewsgroup := false; //false means don't do newsgroup message by default
//    ForNewsgroup := true; //true means do newsgroup messages
// 3. This string syntax sets the default headers to remove (if not redefined):
//    Remove_Headers := '';  //null means don't remove any header by default
//    Remove_Headers := 'User-Agent: ,Message-ID: ';  //string means remove these headers
// 4. This string syntax sets the default headers to add (if not redefined):
//    Add_Headers := '';     //null means don't add any header by default
//    Add_Headers := 'X-Comment: John Doe was here'; //string means add these header strings
//
ForEmail := false;     //false means don't do email message by default
ForNewsgroup := true; //true means do newsgroup messages
Remove_Headers := '';  //null means don't remove any header by default
Remove_Headers := 'User-Agent: ,Message-ID: ,Date: '; //remove these outgoing headers
Add_Headers := '';     //null means don't add any header by default

  {The main decision.

   For FromIdentity, comparison must match against string returned by From2Identity() function.
   Same applies to NewsgroupIdentity and ServerIdentity.
   Note that identities may be an empty string.

   Set Remove_Header to remove header(s).
   Set Add_Header to add header(s).
   Set ForEmail and/or ForNewsgroup to `true` to add/remove header for email/newsgroup messages.
  }

// EXAMPLES:
// Remove_Headers := 'User-Agent: ,Message-ID: ,Date: ,Mime-Version: ,Content-Type: ,Content-Transfer-Encoding: ';
// Add_Headers := 'Organization: none whatsoever'#13#10;
// Add_Headers := 'X-Comment: Jane Doe was here'#13#10 + 'X-Greeting: Hello there!'#13#10;
// Note that some headers cannot be set (for example, NNTP Posting Host or Newsgroups)
//
  if FromIdentity = 'id1' then
  begin
    ForNewsgroup := true;
    Remove_Headers := 'User-Agent: ,Message-ID: ';
//  Add_Headers := 'X-Comment: Jane Doe was here'#13#10 + 'X-Greeting: Hello there!'#13#10;

  end
  else if (FromIdentity = 'id2') and (NewsgroupIdentity = 'id2') then
  begin
    ForNewsgroup := true;
//  Remove_Headers := 'User-Agent: ,Content-Transfer-Encoding: '
    Add_Headers := 'Organization: none whatsoever'#13#10;
  end

  else if (FromIdentity = 'id3') and (ServerIdentity = 'id1') then
  begin    // id3
    ForEmail := true;
    ForNewsgroup := true;
    Remove_Headers := 'User-Agent: ,Mime-Version: ';
    Add_Headers := 'User-Agent: My user agent is 40Tude Dialog on Windows 10'#13#10;
// WriteLn(Remove_Headers); // This WriteLn command does not seem to do anything.
// WriteLn(Add_Headers); // This WriteLn command does not seem to do anything.
  end;    // id3

  if (IsEmail and ForEmail) or ((not IsEmail) and ForNewsgroup) then
  begin
    if Remove_Headers <> '' then RemoveHeaders(Message, Remove_Headers);
    if Add_Headers <> '' then AddHeaders(Message, Add_Headers);
  end;

  result := true;
//  result := false; //uncomment this line for testing purposes (doesn't send the message)
end;
// ----------------------------------------------------------------------
begin
end.