Boxquote-fup2warning-xnowplaying-cancellock-useragent

From 40tude Dialog Wiki

This script is a merged OnBeforeSending-Script, containing the following scripts:

Please read the introductions for every script linked above, to configure this merged script correctly. Otherwise it may not work! For help on using boxquotes, have a look here.


program OnBeforeSendingMessage;

uses Textfile;

// ** Introduction for XPost/Fup2-Message
// ** change message as you want to
const
  MessageXPost = 'X'+#39+'Posted to:';
  MessageFup2  = 'F'+#39+'up2:';

// Path for X-Now-Playing with AMIP
  path='c:\programme\winamp5\plugins\np\winamp_sig.txt'; //should reflect your configuration

// Boxquote-Config

const
        StartLine_close_box = 'box:';
        StartLine_open_box = 'box_o:';
        Separator = '-';

        bq1a=',';
        bq1b='-';
        bq1c='.';
        bq2a='|';
        bq2c='|';
        bq3a=''+#39+'';
        bq3b='-';
        bq3c=''+#39+'';

        LineWidthTop    = 4;
        LineWidthBottom = 4;

        maxint= 2147483647;
        s_no_bq=0;
        s_bq_title=1;
        s_bq_content=2;


// Change User-Agent
const
// set the header you want to change here, e.g. 'User-Agent'
    ChangeHeader = 'User-Agent:';
    AddOnChangeHeader = ' Your text goes here'; //DEFINE YOUR TEXT

// change header in emails and/or postings
// set 'true' or 'false'
    ChangeInEmails=true;
    ChangeInNews=true;

// Cancel-Lock-Skript
 const
   CLSecret = ''; //must be filled with some password
 type
   hashsum = array[1..20] of byte;
   
 function CLalfab64(num: byte):char;
 begin
   if num < 26 then
     result := chr(num+ord('A'))
   else if  num < 52 then
       result := chr(num+ord('a')-26)
     else if num < 62 then
          result := chr(num+ord('0')-52)
       else if num = 62 then
            result := '+'
         else result := '/';
 end;
 
 function CLb64enc(var buf: hashsum): string;
 var
   wynik: string;
   i: byte;
 begin
   wynik := '123456789012345678901234567=';
   for i := 0 to 5 do
     begin
       wynik[4*i+1]:=CLalfab64(buf[3*i+1] div 4);
       wynik[4*i+2]:=CLalfab64((buf[3*i+1] mod 4)*16 + buf[3*i+2] div 16);
       wynik[4*i+3]:=CLalfab64((buf[3*i+2] mod 16)*4 + buf[3*i+3] div 64);
       wynik[4*i+4]:=CLalfab64(buf[3*i+3] mod 64);
     end;
   wynik[25]:=CLalfab64(buf[19] div 4);
   wynik[26]:=CLalfab64((buf[19] mod 4)*16 + buf[20] div 16);
   wynik[27]:=CLalfab64((buf[20] mod 16)*4);
   result := wynik;
 end;
 
 function GetLastError(): Integer;
                      external 'GetLastError@kernel32.dll stdcall';
 procedure Blad(var Message: TStringList; nazwa: string);
 var
   i,nrbledu: Integer;
 begin              
   nrbledu := GetLastError;
   for i:=0 to Message.count-1 do
     if Message.strings[i] = '' then
       begin
         Message.Insert(i,'X-CL-Error: '+nazwa+' '+IntToStr(nrbledu));
         break;
       end;
 end;
 
 function CryptAcquireContext (var hProv: LongWord; pszContainer,pszProvider: PChar;
                               dwProvType,dwFlags: LongWord): Boolean;
                      external 'CryptAcquireContextA@advapi32.dll stdcall';
 function CryptCreateHash (hProv: LongWord;Algid: Integer;hKey: LongWord;
                           dwFlags: LongWord;var hHash: LongWord): Boolean;
                      external 'CryptCreateHash@advapi32.dll stdcall';
 function CryptHashData(hHash: LongWord; pbData: PChar;
                        dwDataLen: LongWord; dwFlags: LongWord): Boolean;
                      external 'CryptHashData@advapi32.dll stdcall';
 function CryptGetHashParam (hHash: LongWord;dwParam: LongWord;var pbData: hashsum;
                             var pdwDataLen: LongWord;dwFlags: LongWord): Boolean;
                      external 'CryptGetHashParam@advapi32.dll stdcall';
 function CryptDestroyHash (hHash: LongWord): Boolean;
                      external 'CryptDestroyHash@advapi32.dll stdcall';
 function CryptReleaseContext (hProv: LongWord;dwFlags: LongWord): Boolean;
                      external 'CryptReleaseContext@advapi32.dll stdcall';
 function CLsha1 (var Message: TStringList; tekst: string; var hash: hashsum): Boolean;
 var
   pProv,pHash: LongWord;
   dlugosc: LongWord;
 begin
   result := false;
   if not CryptAcquireContext(pProv, '', '', 1, 0) then
     if not CryptAcquireContext(pProv, '', '', 1, 8) then
       begin
         Blad(Message,'CryptAcquireContext');
         exit;
       end;
   if not CryptCreateHash(pProv,32772,0,0,pHash) then
     Blad(Message,'CryptCreateHash')
   else
     begin
       dlugosc := strlen(tekst);
       if not CryptHashData(pHash,tekst,dlugosc,0) then
         Blad(Message,'CryptHashData')
       else
         begin
           dlugosc := 20;
           if not CryptGetHashParam(pHash,2,hash,dlugosc,0) then
             Blad(Message,'CryptGetHashParam')
           else
             if dlugosc = 20 then
               result := true
             else
               Blad(Message,'BadHashLength'+' '+IntToStr(dlugosc));
         end;
       if pHash = 0 then
         Blad(Message,'HashIsZero')
       else
         if not CryptDestroyHash(pHash) then
           Blad(Message,'CryptDestroyHash');
     end;
   if pProv = 0 then
     Blad(Message,'ProviderIsZero')
   else
     if not CryptReleaseContext(pProv, 0) then
       Blad(Message,'CryptReleaseContext');
 end;
 
 procedure CLAdd(var Message: TStringList; i: Integer; lock: Boolean);
 var
   j: integer;
   mid,pom: string;
   hash: hashsum;
   sum: string;
 begin
   j := pos('<',Message.strings[i]);
   pom := copy(Message.strings[i],j+1,pos('>',Message.strings[i])-j-1);
   mid:=StringOfChar(' ',Length(pom)+Length(CLSecret));
   StrCopy(mid,pom);
   StrCat(mid,CLSecret);
   if not CLSHA1(Message,mid,hash) then
     exit;
   sum:=CLb64enc(hash);
   if lock then
     begin
       mid := sum;
       if not CLSHA1(Message,mid,hash) then
         exit;
       sum:=CLb64enc(hash);
     end;
   for j:=0 to Message.count-1 do
     if Message.strings[j] = '' then
       begin
         if lock then
           Message.Insert(j,'Cancel-Lock: sha1:'+sum)
         else
           Message.Insert(j,'Cancel-Key: sha1:'+sum);
         break;
       end;
 end;
 
 procedure CLMain (var Message : TStringlist);
 var
   i: integer;
 begin
   if Length(CLSecret) = 0 then
     begin
       Blad(Message,'EmptyPassword');
       exit;
     end;
   for i:=0 to Message.count-1 do
     if pos('Subject: [Cancel control message]', Message.strings[i]) = 1 then
       break; 
   if i < Message.count-1 then
     begin
       CLAdd(Message,i,false);
       exit;
     end;
   for i:=0 to Message.count-1 do
     if pos('Message-ID:', Message.strings[i]) = 1 then
       break; 
   if i < Message.count-1 then
     CLAdd(Message,i,true);
   for i:=0 to Message.count-1 do
     if pos('Supersedes:', Message.strings[i]) = 1 then
       break; 
   if i < Message.count-1 then
     CLAdd(Message,i,false);
 end;
 
 // Change User-Agent

procedure ChangeAnyHeader(Message:TStringlist;IsEmail:boolean);
var i:integer;
    s:string;
begin
  if ((IsEmail=true)  and (ChangeInEmails=true)) or
     ((IsEmail=false) and (ChangeInNews=true)) then
  begin
    s := Message.text;
    i := 1;
    while (Message.Strings[i]<>'') do
    begin
      if pos(ChangeHeader,Message.Strings[i]) = 1 then
      begin
       Message.Strings[i] := Message.Strings[i] + AddOnChangeHeader;
       s := Message.text; 
      end;
      i := i + 1;
    end; {end of while}
    message.text := s;
  end;
end;

// f'up2 warning
// ** Begin of code
Procedure XPost_and_FUp2_Information (var Message: TStringlist;
Servername: string; IsEmail: boolean);
var
  FUP2,
  XPost,
  Header: boolean;
  i,
  SigLine: integer;
  s,
  Fup2Group,
  XPostGroups: string;
begin
  if IsEmail=true then exit;
  FUP2:=false;
  XPost:=false;
  Header:=true;
  SigLine:=0;
  for i:=0 to Message.count-1 do
    begin;
    s:= message.strings[i];
    if s='' then header:=false;
    if header=true then
      begin;
      if Pos('Followup-To:',s)>0 then
        begin;
        FUP2:=true;
        Fup2Group:=copy(s,13,length(s)-12);
//      WriteToLog(MessageFup2+Fup2Group,1);
        end;
      if Pos('Newsgroups:',s)>0 then
        if Pos(',',s)>0 then
          begin;
          XPost:=true;
          XPostGroups:=copy(s,12,length(s)-11);
//        WriteToLog(MessageXPost+XPostGroups,1);
          end;
      end
    else
      if s='-- ' then
        SigLine:=i;
//  WriteToLog('Analysierte Zeile: '+s,1);
    end;
  if FUP2=true then
    if Sigline=0 then
      Message.Add(MessageFup2+Fup2Group)
    else
      Message.Insert(Sigline,MessageFup2+Fup2Group);
  if XPost=true then
    if Sigline=0 then
      Message.Add(MessageXPost+XPostGroups)
    else
      Message.Insert(Sigline,MessageXPost+XPostGroups);
  if (FUP2=true) or (XPost=true) then
    if Sigline=0 then
      Message.Add('')
    else
      Message.Insert(SigLine,'');
end;

// Path for X-Now-Playing with AMIP
procedure XNowPlaying_with_AMIP(var Message: TStringlist);
var
  fi: Textfile;
  st: string;
begin
  if FileExists(path) then
  begin
    AssignFile (fi,path);
    Reset(fi);
    TextReadln (fi,st);
    CloseFile (fi);
    message.insert (1, 'X-Now-Playing: ' + st);
  end;
end;

// Boxquote-Script
                   function StringReplaceM(S, OldPattern, NewPattern: string;replaceall,ignorecase:boolean): string;
var
  SearchStr, Patt, NewStr: string;
  Offset: Integer;
begin
  if IgnoreCase then
  begin
    SearchStr := AnsiUpperCase(S);
    Patt := AnsiUpperCase(OldPattern);
  end else
  begin
    SearchStr := S;
    Patt := OldPattern;
  end;
  NewStr := S;
  Result := '';
  while SearchStr <> '' do
  begin
    Offset := AnsiPos(Patt, SearchStr);
    if Offset = 0 then
    begin
      Result := Result + NewStr;
      Break;
    end;
    Result := Result + Copy(NewStr, 1, Offset - 1) + NewPattern;
    NewStr := Copy(NewStr, Offset + Length(OldPattern), MaxInt);
    if not (ReplaceAll) then
    begin
      Result := Result + NewStr;
      Break;
    end;
    SearchStr := Copy(SearchStr, Offset + Length(Patt), MaxInt);
  end;
end;

function RepeatChar(c : char;Count : integer) : string;
var i:integer;
begin
  if count<0 then count:=0;
  SetLength(Result,Count);
  for i:=1 to count do Result[i]:=c;
end;


function CountChars(s : string;c:char) : integer;
var i : integer;
begin
  Result := 0;
  for i := 1 to Length(s) do if s[i]=c then Result:=result+1;
end;

procedure boxquote(var Message: TStringlist);
var i,j,k:integer;
    state:word;
    bq_startline:integer;
    bq_title:string;
    bq_content:string;
    maxwidth:integer;
    sl:Tstringlist;
    CloseBox:Boolean;
    
begin
state:=s_no_bq;
i:=0;
bq_startline:=-1;
while i<=message.count-1 do
    begin
    case state of
    s_no_bq: begin
             if (message.strings[i]=StartLine_close_box) or (message.strings[i]=StartLine_open_box) then
                begin
                 if message.strings[i] = StartLine_close_box then
                  CloseBox := true
                  else
                  CloseBox := false;
                 bq_startline:=i;
                 bq_title:='';
                 bq_content:='';
                 maxwidth:=1;
                 state:=s_bq_title;
                end
             end;
    s_bq_title: begin
                if message.strings[i]=Separator then state:=s_bq_content
                                                else bq_title:=trim(bq_title+' '+message.strings[i]);
                end;
    s_bq_content: begin
                  if message.strings[i]=Separator then
                        begin
                        state:=s_no_bq;
                        if length('['+bq_title+']')>maxwidth then maxwidth:=length('['+bq_title+']') + 6;
                        //delete the raw boxquote
                        for j:=bq_startline to i do message.delete(bq_startline);
                        //middle part
                        bq_content:=stringreplacem(#13#10+bq_content,#13#10,#13#10+bq2a+' ',true,false);
                        delete(bq_content,1,2);
                        //first line
                        if bq_title<>'' then bq_content:=bq1a+RepeatChar(bq1b,LineWidthTop)+' ['+bq_title+'] '+#13#10+bq_content
                                        else bq_content:=bq1a+RepeatChar(bq1b,LineWidthTop)+#13#10+bq_content;
                        //last line
                        bq_content:=bq_content+#13#10+bq3a+RepeatChar(bq3b,LineWidthBottom);
                        sl:=Tstringlist.create;
                        try
                        sl.text:=bq_content;
                        //close the box
                        if CloseBox then
                         for j:=0 to sl.count-1 do
                            begin
                            k:=maxwidth-length(sl.strings[j]);
                            if j=0 then sl.strings[j]:=sl.strings[j]+repeatchar(bq1b,k+3)+bq1c
                            else if j=sl.count-1 then sl.strings[j]:=sl.strings[j]+repeatchar(bq3b,k+3)+bq3c
                            else sl.strings[j]:=sl.strings[j]+repeatchar(' ',k+3)+bq2c;
                            end;
                        message.insert(bq_startline,trim(sl.text));
                        i:=bq_startline;
                        finally
                        sl.free;
                        end;
                        end
                        else
                        begin
                        if bq_content='' then bq_content:=message.strings[i]
                                         else bq_content:=bq_content+#13#10+message.strings[i];
                        if length(message.strings[i])>maxwidth then maxwidth:=length(message.strings[i]);
                        end;
                  end;
    end; //case
    i:=i+1;
    end;
end;

// Event OnBeforeSendingMessage
function OnBeforeSendingMessage(var Message: TStringlist; Servername:
string; IsEmail: boolean):boolean;
begin;
  ChangeAnyHeader(Message,IsEmail);
  result:=true;
  if message.count<500 then boxquote(message);
   if not IsEmail then
     begin
       CLMain (Message);
     end;
  XPost_and_FUp2_Information(Message, Servername, IsEmail);
  XNowPlaying_with_AMIP(Message);
end;
 begin
 end.

René Fischer