[UPDATE] @Karl-Heinz - http://kh-rademacher.de/4d/CancelLock_include.html

05/01/2009 - 15:20 von Hermann Hippen | Report spam
http://kh-rademacher.de/4d/CancelLock_include.html

Das übliche :-) bis auf eine Kleinigkeit:

| Der Aufruf in, OnBeforeSendingMessage, muss jetzt:
|
| If Not IsEmail Then CLMain_CancelLock( Message );
|
| lauten.

So langsam müssten wir aber durch sein, oder?
8<[ CancelLock_include.ds ]->8
Type
CancelLock_hashsum = Array[1..20] of Byte;
//
Const
CLSecret = 'scriptwerkstatt05012009';
//
Function GetLastError(): Integer;
external 'GetLastError@kernel32.dll stdcall';
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: CancelLock_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 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: CancelLock_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;
//
Procedure Blad(var Message: TStringList; nazwa: String);
Var
i,nrbledu: Integer;
Begin
nrbledu := GetLastError;
For i := 0 to Message.count-1 do If Message[i] = '' Then
Begin
Message.Insert(i,'X-CL-Error: '+nazwa+' '+IntToStr(nrbledu));
Break;
End;
End;
//
Function CLsha1 (Var Message:TStringList;tekst:String;Var hash:CancelLock_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; Secret : String; lock: Boolean);
Var
j : Integer;
mid, pom, sum : String;
hash : CancelLock_hashsum;
Begin
j := Pos('<',Message[i]);
pom := Copy(Message[i], j+1, Pos('>',Message[i])-j-1);
mid := StringOfChar(' ',Length( pom ) + Length( Secret ));
StrCopy( mid, pom);
StrCat ( mid, Secret);
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[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_CancelLock (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[i]) = 1 Then Break;
If i < Message.count-1 Then
Begin
CLAdd(Message,i,CLSecret,False);
Exit;
End;
For i:=0 to Message.count-1 do If Pos('Message-ID:', Message[i]) = 1 Then Break;
If i < Message.count-1 Then CLAdd(Message,i,CLSecret,True);
For i:=0 to Message.count-1 do If Pos('Supersedes:', Message[i]) = 1 Then Break;
If i < Message.count-1 Then CLAdd(Message,i,CLSecret,false);
End;
8<-->8
ž' š°º€ø?žžžžž?ø€º°š 'ž
ø€º° '<http://4ds.siteboard.eu>' °º€ø
'ž '40tude-Dialog Scriptwerkstatt' ž'
ø€º°' ž ž ø€º°ššššššš°º€øšž ž '°º€ø
 

Lesen sie die antworten

#1 Reinhard Irmer
05/01/2009 - 16:59 | Warnen spam
Hallo */hiPP€r hErrMAnn/*,

*_Hermann Hippen_* schrieb:
Supersedes
http://kh-rademacher.de/4d/CancelLock_include.html
Das übliche :-) bis auf eine Kleinigkeit:
| Der Aufruf in, OnBeforeSendingMessage, muss jetzt:
|
| If Not IsEmail Then CLMain_CancelLock( Message );
|
| lauten.
So langsam müssten wir aber durch sein, oder?


[...]
Ich bin so langsam durchunddurch. Habe übers Jahresende eine Usenetpause
eingelegt und jetzt hab ich den Salat: haufenweise neue, upgedatete
scripte.

Wie kann man nur gar so fleißig sein ;-)) . aber nicht nachlassen
: -)


Viele Gruesse
Rεìñhατδ

Waere Gott Kfz Mechaniker, wuerde dein Roller nicht
mit teurem Benzin laufen, sondern mit Heiligem Geist
(Werner B. in de.alt.soc.verschwoerung)

Ähnliche fragen