Rudolph Rhein <
RudolphRhein@nospam.net> wrote:
40tude Dialog pascal-based delphi scripts are hard to find.
I just found this on pastebin after a long set of searches.
It seems to be an update to RemoveHeaders.ds with more flexibility.
It allows you to separate work and personal messages for example.
// 40tude Dialog AddRemoveHeaders.ds
// Highly configurable Delphi script to add or remove headers
// Based on
http://dialog.datalist.org/scripts/RemoveHeaders.html
// Located at
http://dialog.datalist.org/scripts/script_library.html
// This script will add & remove headers based on a decision tree.
// It will also check for mistakes between business & personal use.
// 1. Set the "ForNewsgroup" Boolean as desired (search for "ForNewsgroup :")
// Generic default is: true
// 2. Set the "ForEmail" Boolean as desired (search for "ForEmail :")
// Generic default is: false
// 3. Change identity(ies) as desired (search for "from,")
// Generic defaults are set to: id##
// A sample value is: Kilroy <
kilroy@example.com>
// 4. Change newsgroup(s) as desired (search for "newsgroup,")
// Generic defaults are set to: ng1, ng2, ng3, ng4, & ng5
// A sample value is: news.software.readers
// 5. Change server(s) as desired (search for "server,")
// Generic defaults are set to: server1, server2, server3, server4, server5
// A sample value is: aioe
// 6. Change header(s) to remove as desired (search for "Remove_Headers :")
// A sample value is: Remove_Headers := 'User-Agent: '
// 7. Change header(s) to add as desired (search for "Add_Headers :")
// 8. Modify the if-then-else program control as needed.
//
// 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 without (CR+LF) syntax!
// The original StrMatch fct is case sensitive & matches only the 1st item found!
// Instead, we define a StrContains fct to match multiple either/or newsgroups.
// CASE-SENSITIVITY:
// Headerfield names are case insensitive as per RFC 5322 & RFC 5234.
// MIME headerfields above the media types & transfer encodings are not
// case sensitive as per RFC 2045.
// In general, parameter names are case insensitive while the
// value of the parameter is case sensitive.
// The "charset" parameter defines an exception as per RFC 2046 so
// that the value of the charset parameter is case insensitive
// This means that both "US-ASCII" & "us-ascii" have the same meaning.
// The "charset" parameter is allowed to contain "quoted-string" values
// as per RFC 2045 where the value of a quoted string parameter does not
// include the quote delimiters.
// Therefore: charset="US-ASCII" is the same as charset=US-ASCII.
// Quote delimiters are used for values containing forbidden characters.
program OnBeforeSendingMessage;
(*
Format for Remove_Headers: {} = required, [] = optional
{HeaderName: }[,HeaderName: ][,HeaderName: ][...]
Examples:
- Single header: 'User-Agent: '
- Multiple headers: 'User-Agent: ,X-Face: '
*)
// The user is not expected to need to customize "RemoveHeaders()".
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
*)
// The user is not expected to need to customize "AddHeaders()".
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;
// The user is not expected to need to customize "StrMatch()".
// 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;
// These will return `true`:
// StrMatch('abc', 'abc') //"abc" is at start of "abc"
// StrMatch('abc', 'ab') //"ab" is at start of "abc"
// StrMatch('abc', 'a') //"a" is at start of "abc"
// These will return `false`:
// StrMatch('abc', 'abcd') //"abcd" is not at start of "abc"
// StrMatch('abc', 'bc') //"bc" is not at start of "abc"
// StrMatch('abc', 'b') //"b" is not at start of "abc"
// StrMatch('abc', 'c') //"c" is not at start of "abc"
// EXAMPLE: This StrMatch will only match if either n.s.r or a.f.n is the *first* ng in the Newsgroups header:
// if (StrMatch (newsgroup, 'news.software.readers') or StrMatch(newsgroup, 'alt.free.newsservers')) then result := 'id01'
// 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 := 'id01'
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;
////////////////////////////////////////////////////////////////////////////
// CAVEAT: You can't use % or ; in identity names.
// WARNING: With special characters (including a period) Dialog adds doublequotes automatically!
// For example, if your user name is John Doe, the search is for John Doe
// and if your user name is John A Doe, the search is for John A Doe
// But if you use a name of John A. Doe, the search is for "John A. Doe"
// WRONG: else if (StrMatch(from, 'John A. Doe <
jad@is.invalid>')) then result := 'id01'
// RIGHT: else if (StrMatch(from, '"John A. Doe" <
jad@is.invalid>')) then result := 'id01'
////////////////////////////////////////////////////////////////////////////
function From2Identity(from: String): String;
begin
if (StrMatch(from, '"John A. Doe" <
jad@is.invalid>')) then result := 'id01'
else if (StrMatch(from, '"J.Doe" <
j.doe@nospam.net>')) then result := 'id02'
else if (StrMatch(from, 'j doe <
jdoe@jdoe.com>')) then result := 'id03'
else
result := '';
end;
// The user is not expected to need to customize "StrContains()".
function StrContains(const Str: string; const Pattern: string): boolean;
begin
result:= pos(Pattern, Str) > 0;
end;
// The user is expected to modify to their own newsgroup(s) below.
function NewsGroup2Identity(newsgroup: String): String;
begin
if StrContains(newsgroup, 'news.software.readers') or StrContains(newsgroup, 'alt.free.newssservers') then
result := 'id01'
else if StrContains(newsgroup, 'alt.privacy') then
result := 'id02'
else if StrContains(newsgroup, 'alt.privacy.anon-server') then
result := 'id03'
else
result := '';
end;
// CUSTOMIZATION: servers server1, server2, etc.
// The user is expected to modify to their own server(s) below.
// The name of the server is what 40tude Dialog lists in the "Available Servers" GUI
function Server2Identity(server: String): String;
begin
if (CompareStr(server, 'aioe') = 0) then result := 'id01'
else if (CompareStr(server, 'mixmin') = 0) then result := 'id02'
else if (CompareStr(server, 'eternalsept') = 0) then result := 'id03'
else result := '';
end;
// The user is not expected to need to customize "GetIdentities()".
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);
// fromIdentity = id02
WriteToLog(' newsgroupIdentity = ' + newsgroupIdentity, 7);
// newsgroupIdentity =
WriteToLog(' serverIdentity = ' + serverIdentity, 7);
// serverIdentity = id07
end;
end;
// The user is not expected to need to customize "LogHeaders()".
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
// CUSTOMIZATION: main decision tree
// The user may wish to customize this main decision tree.
// 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
// NOTE: By default, 40Tude-Dialog generates a dialog-specific message id.
// You can turn off this message-id autogeneration in the Dialog GUI.
// Or you can remove that message-id after the fact in this script.
// NOTE: By default, 40Tude-Dialog sends the system date to the news server.
// The news server will use that system date in the Date: header.
// The news server will generate a GMT date if there is no Date: header.
GetIdentities(message, servername, isEmail, FromIdentity, NewsgroupIdentity, ServerIdentity);
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: ,Mime-Version: ,Content-Type: ,Content-Transfer-Encoding: ';
//Remove_Headers := 'Organization: ,User-Agent: ,Message-ID: ,Mime-Version: ,Content-Type: ,Content-Transfer-Encoding: ';
Add_Headers := ''; //null means don't add any header by default
// If nothing below matches, the defaults above are used for the headers.
{The main decision.
// Add_Headers := 'User-Agent: tin'#13#10 + 'X-Abuse-and-DMCA-Info: Please be sure to forward a copy of ALL headers'#13#10;
For FromIdentity, comparison must match against string returned by From2Identity() function.
Same applies to NewsgroupIdentity and ServerIdentity.
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.
}
////////////////////////////////////////////////////////////////////////////////
if (ServerIdentity = 'id01') then
begin
ForNewsgroup := true;
Remove_Headers := 'User-Agent: ';
Add_Headers := 'User-Agent: Foobar'#13#10;
end // id01
else
if (FromIdentity = 'id02') and (NewsgroupIdentity = 'id02') then
begin
ForNewsgroup := true;
Remove_Headers := 'User-Agent: ,Message-ID: ,Date: ';
Add_Headers := 'User-Agent: Foobar'#13#10 + 'Situation: Snafu'#13#10;
end // id02
else
if (ServerIdentity = 'id01') and (NewsgroupIdentity = 'id02') and (FromIdentity = 'id03') then
begin
ForEmail := false;
ForNewsgroup := true;
Remove_Headers := 'User-Agent: ,Message-ID: ,Date: ,Mime-Version: ,Content-Type: ,Content-Transfer-Encoding: ';
Add_Headers := 'User-Agent: Foobar'#13#10 + 'Situation: Snafu'#13#10 + 'Organization: None'#13#10;
end; // id03
// That last "end" above must conclude with a semicolon!
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)
// At the moment, if nothing matches, the defaults apply (which is set to remove all and add none).
end;
// ----------------------------------------------------------------------
begin
end.
--- SoupGate-Win32 v1.05
* Origin: fsxNet Usenet Gateway (21:1/5)