//********************************************************************* //* CESU8_to_UTF8_Converter 2020-07-29 * //* >> OnBeforeSendingMessage << * //* * //* Dieses Script wandelt CESU8 in UTF8 und verschickt das Posting in * //* UTF8! DIALOG selbst beherrscht UTF8 nur bis U+FFFF! Danach * //* produziert dieses Programm nur noch "komische Zeichen" (CESU-8), * //* welche bzw. welches nur DIALOG entschlüsseln kann! * //* * //* !! DIESES SCRIPT BEHEBT DIESEN GRAVIERENDEN FEHLER !! * //* * //* Funktionalitaet: [x] neutral * //* [ ] nur Basis_Modul * //* [ ] nur Pathfinder * //* * //* Datum : 29.07.2020 (Corona-Zeit) * //* Autor : Thomas Barghahn * //* * //* DateiName : _i_OBSendM_CESU8_to_UTF8_Converter.ds * //* Einbindung: {$I _i_OBSendM_CESU8_to_UTF8_Converter.ds} * //* Aufruf : * //* Result := Convert_CESU8_to_UTF8 (Result, Message, Error_Func); * //********************************************************************* //{-------------------------------------------------------------------} //{ KONFIGURATIONSBEISPIEL (OnBeforSendingMessage) } //{-------------------------------------------------------------------} // Dieses Beispiel zeigt eine Minimalkonfiguration für den // "CESU-8 to UTF-8 Converter. // // Dieses Script benötigt die Include_Files: // Dialog_Functions.ds, _i_OBSendM_UTF7_To_UTF8_Functions.ds // Letzteres ist Bestandzeil des "UTF7 to UTF8 Converters"! // Aenderungen in der Konfiguration von Dialog muessen nicht // vorgenommen werden, *wenn* folgende Situation gegeben ist: // Einstellungen --> Allgemeine Eistellungen --> Zeichensaetze --> // Geeignetesten Zeichensatz waehlen aus: // ---------------- // | usascii | // | iso-8859-1 | // | iso-8859-15 | // | UTF8 | <-- UTF8 KANN AUCH UNTER usascii platziert sein, // | ... | dann wird auch bei Umlauten in UTF8 gesendet! // | UTF7 | <-- UTF7 muss hier am Schluss stehen!! // ---------------- // BEISPIEL: // --- SNIP ---------------------------------------------------------- // program OnBeforeSendingMessage; // uses TextFile; // {$I Dialog_Functions.ds} // {$I _i_OBSendM_UTF7_To_UTF8_Functions.ds} // {$I _i_OBSendM_CESU8_to_UTF8_Converter.ds} // Function OnBeforeSendingMessage( var Message : TStringlist; // const Servername : string; // const IsEmail : boolean) // : boolean; // // var Error_Func : String; // // begin // // Result := True; // Error_Func := ''; // // Result := Convert_CESU8_to_UTF8 (Result, Message, Error_Func); // end; // Function // --- SNIP ---------------------------------------------------------- //{-------------------------------------------------------------------} //{ Anwenderspezifische Einstellungen } //{-------------------------------------------------------------------} // KEINE! :-) //{-------------------------------------------------------------------} //{ Ende der Einstellungen } //{-------------------------------------------------------------------} //{===================================================================} //{ !!! Ab hier bitte nichts mehr ändern !!! } //{===================================================================} Function Convert_CESU8_to_UTF8 (fbkResult : Boolean; Msg : TStringList; Error_Func : String) : Boolean; var Intz : Integer; // allgemeiner Zeilen_Zaehler Ints : Integer; // allgemeiner Spalten_Zaehler Inti : Integer; // allgemeiner Zaehler Str_Cesu : String; // CESU-8 String Str_Bin_UTF8 : String; // binaerer UTF-8 String Str_Hex_Temp : String; // temporaerer Hex String Str_Replace : String; // tauscht CESU-8 gegen UTF-8 begin // Rückgabewert entsprechend vorheriger Scriptprobleme setzen Result := fbkResult; // Wenn bereits irgendein Script einen Fehler verursacht hat, // dann braucht dieses hier nicht mehr ausgeführt werden If Not Result Then begin WriteToLog ('==== ANFANG =======================================' ,4); WriteToLog ('Script *** CESU8_to_UTF8_Converter *** wurde nicht mehr ausgefuehrt' ,4); WriteToLog ('Script ' + Error_Func + ' hat diesen Fehler verursacht!' ,4); WriteToLog ('==== ENDE =========================================' ,4); Exit; end; Intz := Msg.IndexOf('') + 1; Ints := 1; Try while Intz < Msg.Count do begin while Ints < length (Msg.Strings[Intz]) do begin If ord(Msg.Strings[Intz][Ints]) = 237 then begin If (ord(Msg.Strings[Intz][Ints + 1]) >= 160) and (ord(Msg.Strings[Intz][Ints + 1]) <= 191) then begin Str_Cesu := Math_DecToBin (ord(Msg.Strings[Intz][Ints]), 8) + Math_DecToBin (ord(Msg.Strings[Intz][Ints + 1]), 8) + Math_DecToBin (ord(Msg.Strings[Intz][Ints + 2]), 8) + Math_DecToBin (ord(Msg.Strings[Intz][Ints + 3]), 8) + Math_DecToBin (ord(Msg.Strings[Intz][Ints + 4]), 8) + Math_DecToBin (ord(Msg.Strings[Intz][Ints + 5]), 8); Str_Cesu := copy (Str_Cesu, 13, 4) + copy (Str_Cesu, 19, 6) + copy (Str_Cesu, 37, 4) + copy (Str_Cesu, 43, 6); Str_Cesu := Math_DecToBin (Math_BinaryToDec (Str_Cesu, 3) + 65536, 21); Str_Bin_UTF8 := '11110' + copy(Str_Cesu, 1, 3) + '10' + copy(Str_Cesu, 4, 6) + '10' + copy(Str_Cesu, 10, 6) + '10' + copy(Str_Cesu, 16, 6); Str_Hex_Temp := 'chr($' + Math_BinarytoHex(copy(Str_Bin_UTF8, 1, 4),2) + Math_BinarytoHex(copy(Str_Bin_UTF8, 5, 4),2) + ')+chr($' + Math_BinarytoHex(copy(Str_Bin_UTF8, 9, 4),2) + Math_BinarytoHex(copy(Str_Bin_UTF8, 13, 4),2) + ')+chr($' + Math_BinarytoHex(copy(Str_Bin_UTF8, 17, 4),2) + Math_BinarytoHex(copy(Str_Bin_UTF8, 21, 4),2) + ')+chr($' + Math_BinarytoHex(copy(Str_Bin_UTF8, 25, 4),2) + Math_BinarytoHex(copy(Str_Bin_UTF8, 29, 4),2) + ')+'; Str_Replace := GetUTF8_CharSet (Str_Hex_Temp, 3); Msg.Strings[Intz] := StringReplace(Msg[Intz], copy(Msg[Intz], Ints, 6), Str_Replace, [rfIgnoreCase]); Ints := Ints + 3; end; end; Ints := Ints + 1; end; // while Intz := Intz + 1; Ints := 1; end; // while Inti := GetHeaderLine ('Content-Type:',Msg); If (Inti > -1) and (Ansipos('utf-8',Getheader('Content-Type:', Msg)) > 0) then begin Msg := RemoveHeader ('Content-Type:', Msg ); Msg.insert (Inti, 'Content-Type: text/plain; charset=' + '"' + 'utf-8' + '"; format=fixed'); end; // If If GetHeader ('User-Agent:', Msg) <> '' Then begin Inti := GetHeaderLine ('User-Agent:',Msg); Msg[Inti] := Msg[Inti] + ' CU_Conv/20.07.29'; end; // If Except // Bei Problemen das Senden der Nachricht unterbinden begin WriteToLog ('FEHLER im Script *** Convert_CESU8_to_UTF8 ***' ,5); Error_Func := '*** CESU8_UTF8_Converter ***'; Result := false; end; // Except Finally // FreeMem; end; // Try ... Except ... Finally end; // function