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;
// Cancel-Lock Script
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;
// 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;
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