Download fixed idcoderheader.pas

  1. unit IdCoderHeader;
  2.  
  3. interface
  4.  
  5. uses
  6. IdEMailAddress;
  7.  
  8. type
  9. TTransfer = (bit7, bit8, iso2022jp);
  10. CSET = set of AnsiChar;
  11.  
  12. // Procs
  13. function EncodeAddressItem(EmailAddr: TIdEmailAddressItem; const HeaderEncoding: Char;
  14. TransferHeader: TTransfer; MimeCharSet: string; AUseAddressForNameIfNameMissing: Boolean = False): string;
  15. function EncodeHeader(const Header: string; specials: CSET; const HeaderEncoding: Char;
  16. TransferHeader: TTransfer; MimeCharSet: string): string;
  17. function Encode2022JP(const S: ansistring): string;
  18. function EncodeAddress(EmailAddr: TIdEMailAddressList; const HeaderEncoding: Char;
  19. TransferHeader: TTransfer; MimeCharSet: string; AUseAddressForNameIfNameMissing: Boolean = False): string;
  20. function DecodeHeader(Header: string): string;
  21. function WideDecodeHeader(Header: widestring): Widestring;
  22. function Decode2022JP(const S: string): string;
  23. procedure DecodeAddress(EMailAddr: TIdEmailAddressItem);
  24. procedure DecodeAddresses(AEMails: string; EMailAddr: TIdEmailAddressList);
  25.  
  26. implementation
  27.  
  28. uses
  29. IdGlobal,
  30. IdGlobalProtocols,
  31. SysUtils,
  32. Charsetconvertors;
  33.  
  34. const
  35. csSPECIALS: CSET = ['(', ')', '[', ']', '<', '>', ':', ';', '.', ',', '@', '\', '"']; {Do not Localize}
  36.  
  37. kana_tbl: array[#$A1..#$DF] of Word = (
  38. $2123, $2156, $2157, $2122, $2126, $2572, $2521, $2523, $2525, $2527,
  39. $2529, $2563, $2565, $2567, $2543, $213C, $2522, $2524, $2526, $2528,
  40. $252A, $252B, $252D, $252F, $2531, $2533, $2535, $2537, $2539, $253B,
  41. $253D, $253F, $2541, $2544, $2546, $2548, $254A, $254B, $254C, $254D,
  42. $254E, $254F, $2552, $2555, $2558, $255B, $255E, $255F, $2560, $2561,
  43. $2562, $2564, $2566, $2568, $2569, $256A, $256B, $256C, $256D, $256F,
  44. $2573, $212B, $212C);
  45.  
  46. vkana_tbl: array[#$A1..#$DF] of Word = (
  47. $0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000,
  48. $0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000, $2574, $0000,
  49. $0000, $252C, $252E, $2530, $2532, $2534, $2536, $2538, $253A, $253C,
  50. $253E, $2540, $2542, $2545, $2547, $2549, $0000, $0000, $0000, $0000,
  51. $0000, $2550, $2553, $2556, $2559, $255C, $0000, $0000, $0000, $0000,
  52. $0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000,
  53. $0000, $0000, $0000);
  54.  
  55. sj1_tbl: array[#128..#255] of Byte = (
  56. $00, $21, $23, $25, $27, $29, $2B, $2D, $2F, $31, $33, $35, $37, $39, $3B, $3D,
  57. $3F, $41, $43, $45, $47, $49, $4B, $4D, $4F, $51, $53, $55, $57, $59, $5B, $5D,
  58. $00, $01, $01, $01, $01, $01, $01, $01, $01, $01, $01, $01, $01, $01, $01, $01,
  59. $01, $01, $01, $01, $01, $01, $01, $01, $01, $01, $01, $01, $01, $01, $01, $01,
  60. $01, $01, $01, $01, $01, $01, $01, $01, $01, $01, $01, $01, $01, $01, $01, $01,
  61. $01, $01, $01, $01, $01, $01, $01, $01, $01, $01, $01, $01, $01, $01, $01, $01,
  62. $5F, $61, $63, $65, $67, $69, $6B, $6D, $6F, $71, $73, $75, $77, $79, $7B, $7D,
  63. $02, $02, $02, $02, $02, $02, $02, $02, $02, $02, $02, $02, $02, $00, $00, $00);
  64.  
  65. sj2_tbl: array[AnsiChar] of Word = (
  66. $0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000,
  67. $0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000,
  68. $0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000,
  69. $0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000,
  70. $0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000,
  71. $0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000, $0000,
  72. $0000, $0000, $0000, $0000, $0021, $0022, $0023, $0024, $0025, $0026,
  73. $0027, $0028, $0029, $002A, $002B, $002C, $002D, $002E, $002F, $0030,
  74. $0031, $0032, $0033, $0034, $0035, $0036, $0037, $0038, $0039, $003A,
  75. $003B, $003C, $003D, $003E, $003F, $0040, $0041, $0042, $0043, $0044,
  76. $0045, $0046, $0047, $0048, $0049, $004A, $004B, $004C, $004D, $004E,
  77. $004F, $0050, $0051, $0052, $0053, $0054, $0055, $0056, $0057, $0058,
  78. $0059, $005A, $005B, $005C, $005D, $005E, $005F, $0000, $0060, $0061,
  79. $0062, $0063, $0064, $0065, $0066, $0067, $0068, $0069, $006A, $006B,
  80. $006C, $006D, $006E, $006F, $0070, $0071, $0072, $0073, $0074, $0075,
  81. $0076, $0077, $0078, $0079, $007A, $007B, $007C, $007D, $007E, $0121,
  82. $0122, $0123, $0124, $0125, $0126, $0127, $0128, $0129, $012A, $012B,
  83. $012C, $012D, $012E, $012F, $0130, $0131, $0132, $0133, $0134, $0135,
  84. $0136, $0137, $0138, $0139, $013A, $013B, $013C, $013D, $013E, $013F,
  85. $0140, $0141, $0142, $0143, $0144, $0145, $0146, $0147, $0148, $0149,
  86. $014A, $014B, $014C, $014D, $014E, $014F, $0150, $0151, $0152, $0153,
  87. $0154, $0155, $0156, $0157, $0158, $0159, $015A, $015B, $015C, $015D,
  88. $015E, $015F, $0160, $0161, $0162, $0163, $0164, $0165, $0166, $0167,
  89. $0168, $0169, $016A, $016B, $016C, $016D, $016E, $016F, $0170, $0171,
  90. $0172, $0173, $0174, $0175, $0176, $0177, $0178, $0179, $017A, $017B,
  91. $017C, $017D, $017E, $0000, $0000, $0000);
  92.  
  93. base64_tbl: array[0..63] of Char = (
  94. 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', {Do not Localize}
  95. 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', {Do not Localize}
  96. 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', {Do not Localize}
  97. 'Y', 'Z', 'a', 'b', 'c', 'd', 'e', 'f', {Do not Localize}
  98. 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', {Do not Localize}
  99. 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', {Do not Localize}
  100. 'w', 'x', 'y', 'z', '0', '1', '2', '3', {Do not Localize}
  101. '4', '5', '6', '7', '8', '9', '+', '/'); {Do not Localize}
  102.  
  103. function EncodeAddressItem(EmailAddr: TIdEmailAddressItem; const HeaderEncoding: Char;
  104. TransferHeader: TTransfer; MimeCharSet: string; AUseAddressForNameIfNameMissing: Boolean = False): string;
  105. var
  106. S: string;
  107. I: Integer;
  108. NeedEncode: Boolean;
  109. begin
  110. if ((AUseAddressForNameIfNameMissing = True) and (EmailAddr.Name = '')) then begin
  111. {CC: Use Address as Name...}
  112. EmailAddr.Name := EmailAddr.Address;
  113. end;
  114. if EmailAddr.Name <> '' then {Do not Localize}
  115. begin
  116. NeedEncode := False;
  117. for I := 1 to Length(EmailAddr.Name) do
  118. begin
  119. if (EmailAddr.Name[I] < #32) or (EmailAddr.Name[I] >= #127) then
  120. begin
  121. NeedEncode := True;
  122. Break;
  123. end;
  124. end;
  125. if NeedEncode then
  126. S := EncodeHeader(EmailAddr.Name, csSPECIALS, HeaderEncoding, TransferHeader, MimeCharSet)
  127. else
  128. begin { quoted string }
  129. S := '"'; {Do not Localize}
  130. for I := 1 to Length(EmailAddr.Name) do
  131. begin { quote special characters }
  132. if (EmailAddr.Name[I] = '\') or (EmailAddr.Name[I] = '"') then S := S + '\'; {Do not Localize}
  133. S := S + EmailAddr.Name[I];
  134. end;
  135. S := S + '"'; {Do not Localize}
  136. end;
  137. Result := Format('%s <%s>', [S, EmailAddr.Address]) {Do not Localize}
  138. end
  139. else Result := Format('%s', [EmailAddr.Address]); {Do not Localize}
  140. end;
  141.  
  142. function B64(AChar: Char): Byte;
  143. //TODO: Make this use the more efficient MIME Coder
  144. var
  145. i: Integer;
  146. begin
  147. for i := Low(base64_tbl) to High(base64_tbl) do begin
  148. if AChar = base64_tbl[i] then begin
  149. Result := i;
  150. exit;
  151. end;
  152. end;
  153. Result := 0;
  154. end;
  155.  
  156.  
  157. { convert Shift_JIS to ISO-2022-JP (RFC 1468) }
  158.  
  159. function Decode2022JP(const S: string): string;
  160. var
  161. T: string;
  162. I, L: integer;
  163. isK: Boolean;
  164. K1, K2: byte;
  165. K3: byte;
  166. begin
  167. T := ''; {Do not Localize}
  168. isK := False;
  169. L := length(S);
  170. I := 1;
  171. while I <= L do
  172. begin
  173. if S[I] = #27 then
  174. begin
  175. Inc(I);
  176. if I + 1 <= L then
  177. begin
  178. if Copy(S, I, 2) = '$B' then {Do not Localize}
  179. begin
  180. isK := True;
  181. end
  182. else
  183. begin
  184. if Copy(S, I, 2) = '(B' then {Do not Localize}
  185. begin
  186. isK := False;
  187. end;
  188. end;
  189. Inc(I, 2); { TODO -oTArisawa : Check RFC 1468}
  190. end;
  191. end
  192. else
  193. begin
  194. if isK then
  195. begin
  196. if I + 1 <= L then
  197. begin
  198. K1 := byte(S[I]);
  199. K2 := byte(S[I + 1]);
  200.  
  201. K3 := (K1 - 1) shr 1;
  202. if K1 < 95 then
  203. K3 := K3 + 113
  204. else
  205. K3 := K3 + 177;
  206.  
  207. if (K1 mod 2) = 1 then
  208. begin
  209. if K2 < 96 then
  210. K2 := K2 + 31
  211. else
  212. K2 := K2 + 32
  213. end
  214. else
  215. K2 := K2 + 126;
  216.  
  217. T := T + char(K3) + char(k2);
  218. Inc(I, 2);
  219. end
  220. else
  221. Inc(I); { invalid DBCS }
  222. end
  223. else
  224. begin
  225. T := T + S[I];
  226. Inc(I);
  227. end;
  228. end;
  229. end;
  230. Result := T;
  231. end;
  232.  
  233. procedure DecodeAddress(EMailAddr: TIdEmailAddressItem);
  234. begin
  235. EMailAddr.Name := DecodeHeader(EMailAddr.Name);
  236. end;
  237.  
  238. procedure DecodeAddresses(AEMails: string; EMailAddr: TIdEmailAddressList);
  239. var idx: Integer;
  240. begin
  241. idx := 0;
  242. EMailAddr.EMailAddresses := AEMails;
  243. while idx < EMailAddr.Count do
  244. begin
  245. DecodeAddress(EMailAddr[idx]);
  246. inc(idx);
  247. end;
  248. end;
  249.  
  250. function EncodeAddress(EmailAddr: TIdEMailAddressList; const HeaderEncoding: Char;
  251. TransferHeader: TTransfer; MimeCharSet: string; AUseAddressForNameIfNameMissing: Boolean = False): string;
  252. var idx: Integer;
  253. begin
  254. Result := ''; {Do not Localize}
  255. idx := 0;
  256. while (idx < EmailAddr.Count) do
  257. begin
  258. Result := Result + ', ' + EncodeAddressItem(EMailAddr[idx], HeaderEncoding, TransferHeader, MimeCharSet, AUseAddressForNameIfNameMissing); {Do not Localize}
  259. Inc(idx);
  260. end; // while ( idx < EncodeAddress.Count ) do
  261. {Remove the first comma and the following space ', ' }{Do not Localize}
  262. IdDelete(Result, 1, 2);
  263. end;
  264.  
  265. { convert Shift_JIS to ISO-2022-JP (RFC 1468) }
  266.  
  267. function Encode2022JP(const S: ansistring): string;
  268. const
  269. desig_asc = #27'(B'; {Do not Localize}
  270. desig_jis = #27'$B'; {Do not Localize}
  271. var
  272. T: string;
  273. I, L: Integer;
  274. isK: Boolean;
  275. K1: Byte;
  276. K2, K3: Word;
  277. begin
  278. T := ''; {Do not Localize}
  279. isK := False;
  280. L := Length(S);
  281. I := 1;
  282. while I <= L do
  283. begin
  284. if Ord(S[I]) < 128 then {Do not Localize}
  285. begin
  286. if isK then
  287. begin
  288. T := T + desig_asc;
  289. isK := False;
  290. end;
  291. T := T + S[I];
  292. INC(I);
  293. end else begin
  294. K1 := sj1_tbl[S[I]];
  295. case K1 of
  296. 0: INC(I); { invalid SBCS }
  297. 2: INC(I, 2); { invalid DBCS }
  298. 1:
  299. begin { halfwidth katakana }
  300. if not isK then begin
  301. T := T + desig_jis;
  302. isK := True;
  303. end;
  304. { simple SBCS -> DBCS conversion }
  305. K2 := kana_tbl[S[I]];
  306. if (I < L) and (Ord(S[I + 1]) and $FE = $DE) then
  307. begin { convert kana + voiced mark to voiced kana }
  308. K3 := vkana_tbl[S[I]];
  309. // This is an if and not a case because of a D8 bug, return to
  310. // case when d8 patch is released
  311. if S[I + 1] = #$DE then begin { voiced }
  312. if K3 <> 0 then
  313. begin
  314. K2 := K3;
  315. INC(I);
  316. end;
  317. end else if S[I + 1] = #$DF then begin { semivoiced }
  318. if (K3 >= $2550) and (K3 <= $255C) then
  319. begin
  320. K2 := K3 + 1;
  321. INC(I);
  322. end;
  323. end;
  324. end;
  325. T := T + Chr(K2 shr 8) + Chr(K2 and $FF);
  326. INC(I);
  327. end;
  328. else { DBCS }
  329. if (I < L) then begin
  330. K2 := sj2_tbl[S[I + 1]];
  331. if K2 <> 0 then
  332. begin
  333. if not isK then begin
  334. T := T + desig_jis;
  335. isK := True;
  336. end;
  337. T := T + Chr(K1 + K2 shr 8) + Chr(K2 and $FF);
  338. end;
  339. end;
  340. INC(I, 2);
  341. end;
  342. end;
  343. end;
  344. if isK then
  345. T := T + desig_asc;
  346. Result := T;
  347. end;
  348.  
  349. { encode a header field if non-ASCII characters are used }
  350.  
  351. function EncodeHeader(const Header: string; specials: CSET; const HeaderEncoding: Char;
  352. TransferHeader: TTransfer; MimeCharSet: string): string;
  353. const
  354. SPACES: set of AnsiChar = [' ', #9, #10, #13]; {Do not Localize}
  355.  
  356. var
  357. S, T: string;
  358. L, P, Q, R: Integer;
  359. B0, B1, B2: Integer;
  360. InEncode: Integer;
  361. NeedEncode: Boolean;
  362. csNeedEncode, csReqQuote: CSET;
  363. BeginEncode, EndEncode: string;
  364.  
  365. procedure EncodeWord(P: Integer);
  366. const
  367. MaxEncLen = 75;
  368. var
  369. Q: Integer;
  370. EncLen: Integer;
  371. Enc1: string;
  372. begin
  373. T := T + BeginEncode;
  374. if L < P then P := L + 1;
  375. Q := InEncode;
  376. InEncode := 0;
  377. EncLen := Length(BeginEncode) + 2;
  378.  
  379. if TextIsSame(HeaderEncoding, 'Q') then { quoted-printable } {Do not Localize}
  380. begin
  381. while Q < P do
  382. begin
  383. if not (CharIsInSet(S, Q, csReqQuote)) then
  384. begin
  385. Enc1 := S[Q]
  386. end
  387. else
  388. begin
  389. if S[Q] = ' ' then {Do not Localize}
  390. Enc1 := '_' {Do not Localize}
  391. else
  392. Enc1 := '=' + IntToHex(Ord(S[Q]), 2); {Do not Localize}
  393. end;
  394. if EncLen + Length(Enc1) > MaxEncLen then
  395. begin
  396. //T := T + EndEncode + #13#10#9 + BeginEncode;
  397. //CC: The #13#10#9 above caused the subsequent call to FoldWrapText to
  398. //insert an extra #13#10 which, being a blank line in the headers,
  399. //was interpreted by email clients, etc., as the end of the headers
  400. //and the start of the message body. FoldWrapText seems to look for
  401. //and treat correctly the sequence #13#10 + ' ' however...
  402. T := T + EndEncode + #13#10 + ' ' + BeginEncode;
  403. EncLen := Length(BeginEncode) + 2;
  404. end;
  405. T := T + Enc1;
  406. INC(EncLen, Length(Enc1));
  407. INC(Q);
  408. end;
  409. end
  410. else
  411. begin { base64 }
  412. while Q < P do
  413. begin
  414. if EncLen + 4 > MaxEncLen then
  415. begin
  416. //T := T + EndEncode + #13#10#9 + BeginEncode;
  417. //CC: The #13#10#9 above caused the subsequent call to FoldWrapText to
  418. //insert an extra #13#10 which, being a blank line in the headers,
  419. //was interpreted by email clients, etc., as the end of the headers
  420. //and the start of the message body. FoldWrapText seems to look for
  421. //and treat correctly the sequence #13#10 + ' ' however...
  422. T := T + EndEncode + #13#10 + ' ' + BeginEncode;
  423. EncLen := Length(BeginEncode) + 2;
  424. end;
  425.  
  426. B0 := Ord(S[Q]);
  427. case P - Q of
  428. 1: T := T + base64_tbl[B0 shr 2] + base64_tbl[B0 and $03 shl 4] + '=='; {Do not Localize}
  429. 2:
  430. begin
  431. B1 := Ord(S[Q + 1]);
  432. T := T + base64_tbl[B0 shr 2] +
  433. base64_tbl[B0 and $03 shl 4 + B1 shr 4] +
  434. base64_tbl[B1 and $0F shl 2] + '='; {Do not Localize}
  435. end;
  436. else
  437. B1 := Ord(S[Q + 1]);
  438. B2 := Ord(S[Q + 2]);
  439. T := T + base64_tbl[B0 shr 2] +
  440. base64_tbl[B0 and $03 shl 4 + B1 shr 4] +
  441. base64_tbl[B1 and $0F shl 2 + B2 shr 6] +
  442. base64_tbl[B2 and $3F];
  443. end;
  444. INC(EncLen, 4);
  445. INC(Q, 3);
  446. end;
  447. end;
  448. T := T + EndEncode;
  449. end;
  450.  
  451. begin
  452. case TransferHeader of
  453. iso2022jp:
  454. S := Encode2022JP(Header);
  455. else
  456. S := Header;
  457. end;
  458.  
  459. {Suggested by Andrew P.Rybin for easy 8bit support}
  460. if HeaderEncoding = '8' then begin //UpCase('8')='8' {Do not Localize}
  461. Result := S;
  462. EXIT;
  463. end; //if
  464. csNeedEncode := [#0..#31, #127..#255] + specials;
  465. csReqQuote := csNeedEncode + ['?', '=', '_']; {Do not Localize}
  466. BeginEncode := '=?' + MimeCharSet + '?' + HeaderEncoding + '?'; {Do not Localize}
  467. EndEncode := '?='; {Do not Localize}
  468.  
  469. // JMBERG: We want to encode stuff that the user typed
  470. // as if it already is encoded!!
  471. if DecodeHeader(Header) <> Header then begin
  472. csNeedEncode := csNeedEncode + ['='];
  473. end;
  474.  
  475. L := Length(S);
  476. P := 1;
  477. T := ''; {Do not Localize}
  478. InEncode := 0;
  479. while P <= L do
  480. begin
  481. Q := P;
  482. while (P <= L) and (CharIsInSet(S, P, SPACES)) do
  483. INC(P);
  484. R := P;
  485. NeedEncode := False;
  486. while (P <= L) and not (CharIsInSet(S, P, SPACES)) do
  487. begin
  488. if CharIsInSet(S, P, csNeedEncode) then
  489. begin
  490. NeedEncode := True;
  491. end;
  492. INC(P);
  493. end;
  494. if NeedEncode then
  495. begin
  496. if InEncode = 0 then
  497. begin
  498. T := T + Copy(S, Q, R - Q);
  499. InEncode := R;
  500. end;
  501. end
  502. else
  503. begin
  504. if InEncode <> 0 then
  505. begin
  506. EncodeWord(Q);
  507. end;
  508. T := T + Copy(S, Q, P - Q);
  509. end;
  510. end;
  511. if InEncode <> 0 then
  512. begin
  513. EncodeWord(P);
  514. end;
  515. Result := T;
  516. end;
  517.  
  518. function DecodeHeader(Header: string): string;
  519. const
  520. WhiteSpace = [LF, CR, CHAR32, TAB];
  521. var
  522. i, l: Integer;
  523. HeaderEncoding,
  524. HeaderCharSet,
  525. s: string;
  526. a3: array[1..3] of byte;
  527. a4: array[1..4] of byte;
  528. LEncodingStartPos, encodingendpos: Integer;
  529. LPreviousEncodingStartPos: integer;
  530. substring: string;
  531. EncodingFound: Boolean;
  532. OnlyWhitespace: boolean;
  533. EncodingBeforeEnd: integer;
  534. // мое добавление для ускорения UpHeader := UpperCase(Header)
  535. UpHeader: string;
  536.  
  537. begin
  538. UpHeader := UpperCase(Header);
  539. S := '';
  540. // Get the Charset part.
  541. EncodingBeforeEnd := -1;
  542. // мой риск кодировок 850 в 10 версии инди, задолбаешься все их перечислять
  543. // поэтому иду на риск определение начала кодировки как =? без названия кодировки
  544. LEncodingStartPos := PosIdx('=?', UpHeader, 1); {do not localize}
  545. (* закавычил три кодировки
  546. LEncodingStartPos := PosIdx('=?ISO', UpHeader, 1); {do not localize}
  547. if LEncodingStartPos = 0 then begin
  548. LEncodingStartPos := PosIdx('=?WINDOWS', UpHeader, 1); {do not localize}
  549. end;
  550. if LEncodingStartPos = 0 then begin
  551. LEncodingStartPos := PosIdx('=?KOI8', UpHeader, 1); {do not localize}
  552. end;
  553. *)
  554. while LEncodingStartPos > 0 do begin
  555. // Assume we will find the encoding
  556. EncodingFound := True;
  557.  
  558. //we need 3 more question marks first and after that a '?=' {Do not Localize}
  559. //to find the end of the substring, we can't just search for '?=', {Do not Localize}
  560. //example: '=?ISO-8859-1?Q?=E4?=' {Do not Localize}
  561. encodingendpos := PosIdx('?', UpHeader, LEncodingStartPos + 5); {Do not Localize}
  562. if encodingendpos = 0 then begin
  563. EncodingFound := False;
  564. end else begin
  565. // valid encoded words can not contain spaces
  566. // if the user types something *almost* like an encoded word,
  567. // and its sent as-is, we need to find this!!
  568. for i := LEncodingStartPos to encodingendpos - 1 do begin
  569. if CharIsInSet(Header, i, Whitespace) then begin
  570. EncodingFound := false;
  571. break;
  572. end;
  573. end;
  574. end;
  575.  
  576. if EncodingFound then
  577. begin
  578. encodingendpos := PosIdx('?', UpHeader, encodingendpos + 1); {Do not Localize}
  579. if encodingendpos = 0 then
  580. begin
  581. EncodingFound := false;
  582. end else begin
  583. for i := LEncodingStartPos to encodingendpos - 1 do begin
  584. if CharIsInSet(Header, i, Whitespace) then begin
  585. EncodingFound := false;
  586. break;
  587. end;
  588. end;
  589. end;
  590. end;
  591.  
  592. if EncodingFound then
  593. begin
  594. encodingendpos := PosIdx('?=', UpHeader, encodingendpos + 1); {Do not Localize}
  595. if encodingendpos > 0 then
  596. begin
  597. for i := LEncodingStartPos to encodingendpos - 1 do begin
  598. if CharIsInSet(Header, i, Whitespace) then begin
  599. EncodingFound := false;
  600. break;
  601. end;
  602. end;
  603.  
  604. if EncodingFound then begin
  605. substring := Copy(Header, LEncodingStartPos, encodingendpos - LEncodingStartPos + 2);
  606. //now decode the substring
  607. for i := 1 to 3 do
  608. begin
  609. l := Pos('?', substring); {Do not Localize}
  610. substring := Copy(substring, l + 1, Length(substring) - l + 1);
  611. if i = 1 then
  612. begin
  613. HeaderCharSet := Copy(substring, 1, Pos('?', substring) - 1) {Do not Localize}
  614. end else if i = 2 then
  615. begin
  616. HeaderEncoding := copy(substring, 1, 1);
  617. end;
  618. end;
  619.  
  620. //now Substring needs to end with '?=' otherwise give up! {Do not Localize}
  621. if Copy(substring, Length(substring) - 1, 2) <> '?=' then {Do not Localize}
  622. begin
  623. EncodingFound := false;
  624. end;
  625. end;
  626.  
  627. if (EncodingBeforeEnd >= 0) and EncodingFound and (LEncodingStartPos > 0) then begin
  628. OnlyWhitespace := true;
  629. for i := EncodingBeforeEnd to LEncodingStartPos - 1 do begin
  630. if not (CharIsInSet(Header, i, WhiteSpace)) then begin
  631. OnlyWhitespace := false;
  632. break;
  633. end;
  634. end;
  635. if OnlyWhitespace then begin
  636. Delete(Header, EncodingBeforeEnd, LEncodingStartPos - EncodingBeforeEnd);
  637. encodingendpos := encodingendpos - (LEncodingStartPos - encodingbeforeend);
  638. LEncodingStartPos := EncodingBeforeEnd;
  639. end;
  640. end;
  641.  
  642. // Get the HeaderEncoding
  643. if TextIsSame(HeaderEncoding, 'Q') {Do not Localize}
  644. and EncodingFound then begin
  645. i := 1;
  646. s := ''; {Do not Localize}
  647. repeat // substring can be accessed by index here, because we know that it ends with '?=' {Do not Localize}
  648. if substring[i] = '_' then {Do not Localize}
  649. begin
  650. s := s + ' '; {Do not Localize}
  651. end else if (substring[i] = '=') and (Length(substring) >= i + 2 + 2) then //make sure we can access i+2 and '?=' is still beyond {Do not Localize}
  652. begin
  653. s := s + chr(StrToInt('$' + substring[i + 1] + substring[i + 2])); {Do not Localize}
  654. inc(i, 2);
  655. end else
  656. begin
  657. s := s + substring[i];
  658. end;
  659. inc(i);
  660. until (substring[i] = '?') and (substring[i + 1] = '=') {Do not Localize}
  661. end else if EncodingFound then
  662. begin
  663. while Length(substring) >= 4 do
  664. begin
  665. a4[1] := b64(substring[1]);
  666. a4[2] := b64(substring[2]);
  667. a4[3] := b64(substring[3]);
  668. a4[4] := b64(substring[4]);
  669. a3[1] := Byte((a4[1] shl 2) or (a4[2] shr 4));
  670. a3[2] := Byte((a4[2] shl 4) or (a4[3] shr 2));
  671. a3[3] := Byte((a4[3] shl 6) or (a4[4] shr 0));
  672. substring := Copy(substring, 5, Length(substring));
  673. s := s + CHR(a3[1]) + CHR(a3[2]) + CHR(a3[3]);
  674. end;
  675. end;
  676.  
  677. if EncodingFound then
  678. begin
  679. if TextIsSame(HeaderCharSet, 'ISO-2022-JP') then {Do not Localize}
  680. begin
  681. substring := Decode2022JP(s);
  682. end else
  683. begin
  684. substring := s;
  685. end;
  686.  
  687. //replace old substring in header with decoded one:
  688. header := Copy(header, 1, LEncodingStartPos - 1)
  689. + substring + Copy(header, encodingendpos + 2, Length(Header));
  690. encodingendpos := length(substring);
  691. substring := ''; {Do not Localize}
  692. S := '';
  693. UpHeader := UpperCase(Header);
  694. end;
  695.  
  696. end;
  697. end;
  698. encodingendpos := LEncodingStartPos + encodingendpos;
  699. {CC: Bug fix - changed LEncodingStartPos to LPreviousEncodingStartPos because
  700. LEncodingStartPos gets overwritten by return value from PosIdx.}
  701. LPreviousEncodingStartPos := LEncodingStartPos;
  702. LEncodingStartPos := PosIdx('=?', UpHeader, LPreviousEncodingStartPos + 1); {do not localize}
  703. (*
  704. LEncodingStartPos := PosIdx('=?ISO', UpHeader, LPreviousEncodingStartPos + 1); {do not localize}
  705. if LEncodingStartPos = 0 then begin
  706. LEncodingStartPos := PosIdx('=?WINDOWS', UpHeader, LPreviousEncodingStartPos + 1); {do not localize}
  707. end;
  708. if LEncodingStartPos = 0 then begin
  709. LEncodingStartPos := PosIdx('=?KOI8', UpHeader, LPreviousEncodingStartPos + 1); {do not localize}
  710. end;
  711. *)
  712. // delete whitespace between adjacent encoded words, but only
  713. // if we had an encoding before
  714. if EncodingFound then begin
  715. EncodingBeforeEnd := encodingendpos;
  716. end else begin
  717. EncodingBeforeEnd := -1;
  718. end;
  719. end;
  720. //There might be #0's in header when this it b64 encoded, e.g with:
  721. //decodeheader('"Fernando Corti=?ISO-8859-1?B?8Q==?=a" <fernando@nowhere.com>');
  722. while Pos(#0, header) > 0 do begin
  723. Delete(header, Pos(#0, header), 1);
  724. end;
  725. Result := Header;
  726. end;
  727.  
  728. function WideDecodeHeader(Header: widestring): Widestring;
  729. const
  730. WhiteSpace = [LF, CR, CHAR32, TAB];
  731. var
  732. i, l: Integer;
  733. HeaderEncoding,
  734. HeaderCharSet,
  735. s: string;
  736. a3: array[1..3] of byte;
  737. a4: array[1..4] of byte;
  738. LEncodingStartPos, encodingendpos: Integer;
  739. LPreviousEncodingStartPos: integer;
  740. substring: string;
  741. EncodingFound: Boolean;
  742. OnlyWhitespace: boolean;
  743. EncodingBeforeEnd: integer;
  744. // мое добавление для ускорения UpHeader := UpperCase(Header)
  745. UpHeader: string;
  746.  
  747. begin
  748. UpHeader := UpperCase(Header);
  749. S := '';
  750. // Get the Charset part.
  751. EncodingBeforeEnd := -1;
  752. // мой риск кодировок 850 в 10 версии инди, задолбаешься все их перечислять
  753. // поэтому иду на риск определение начала кодировки как =? без названия кодировки
  754. LEncodingStartPos := PosIdx('=?', UpHeader, 1); {do not localize}
  755. (* закавычил три кодировки
  756. LEncodingStartPos := PosIdx('=?ISO', UpHeader, 1); {do not localize}
  757. if LEncodingStartPos = 0 then begin
  758. LEncodingStartPos := PosIdx('=?WINDOWS', UpHeader, 1); {do not localize}
  759. end;
  760. if LEncodingStartPos = 0 then begin
  761. LEncodingStartPos := PosIdx('=?KOI8', UpHeader, 1); {do not localize}
  762. end;
  763. *)
  764. while LEncodingStartPos > 0 do begin
  765. // Assume we will find the encoding
  766. EncodingFound := True;
  767.  
  768. //we need 3 more question marks first and after that a '?=' {Do not Localize}
  769. //to find the end of the substring, we can't just search for '?=', {Do not Localize}
  770. //example: '=?ISO-8859-1?Q?=E4?=' {Do not Localize}
  771. encodingendpos := PosIdx('?', UpHeader, LEncodingStartPos + 5); {Do not Localize}
  772. if encodingendpos = 0 then begin
  773. EncodingFound := False;
  774. end else begin
  775. // valid encoded words can not contain spaces
  776. // if the user types something *almost* like an encoded word,
  777. // and its sent as-is, we need to find this!!
  778. for i := LEncodingStartPos to encodingendpos - 1 do begin
  779. if CharIsInSet(Header, i, Whitespace) then begin
  780. EncodingFound := false;
  781. break;
  782. end;
  783. end;
  784. end;
  785.  
  786. if EncodingFound then
  787. begin
  788. encodingendpos := PosIdx('?', UpHeader, encodingendpos + 1); {Do not Localize}
  789. if encodingendpos = 0 then
  790. begin
  791. EncodingFound := false;
  792. end else begin
  793. for i := LEncodingStartPos to encodingendpos - 1 do begin
  794. if CharIsInSet(Header, i, Whitespace) then begin
  795. EncodingFound := false;
  796. break;
  797. end;
  798. end;
  799. end;
  800. end;
  801.  
  802. if EncodingFound then
  803. begin
  804. encodingendpos := PosIdx('?=', UpHeader, encodingendpos + 1); {Do not Localize}
  805. if encodingendpos > 0 then
  806. begin
  807. for i := LEncodingStartPos to encodingendpos - 1 do begin
  808. if CharIsInSet(Header, i, Whitespace) then begin
  809. EncodingFound := false;
  810. break;
  811. end;
  812. end;
  813.  
  814. if EncodingFound then begin
  815. substring := Copy(Header, LEncodingStartPos, encodingendpos - LEncodingStartPos + 2);
  816. //now decode the substring
  817. for i := 1 to 3 do
  818. begin
  819. l := Pos('?', substring); {Do not Localize}
  820. substring := Copy(substring, l + 1, Length(substring) - l + 1);
  821. if i = 1 then
  822. begin
  823. HeaderCharSet := Copy(substring, 1, Pos('?', substring) - 1) {Do not Localize}
  824. end else if i = 2 then
  825. begin
  826. HeaderEncoding := copy(substring, 1, 1);
  827. end;
  828. end;
  829.  
  830. //now Substring needs to end with '?=' otherwise give up! {Do not Localize}
  831. if Copy(substring, Length(substring) - 1, 2) <> '?=' then {Do not Localize}
  832. begin
  833. EncodingFound := false;
  834. end;
  835. end;
  836.  
  837. if (EncodingBeforeEnd >= 0) and EncodingFound and (LEncodingStartPos > 0) then begin
  838. OnlyWhitespace := true;
  839. for i := EncodingBeforeEnd to LEncodingStartPos - 1 do begin
  840. if not (CharIsInSet(Header, i, WhiteSpace)) then begin
  841. OnlyWhitespace := false;
  842. break;
  843. end;
  844. end;
  845. if OnlyWhitespace then begin
  846. Delete(Header, EncodingBeforeEnd, LEncodingStartPos - EncodingBeforeEnd);
  847. encodingendpos := encodingendpos - (LEncodingStartPos - encodingbeforeend);
  848. LEncodingStartPos := EncodingBeforeEnd;
  849. end;
  850. end;
  851.  
  852. // Get the HeaderEncoding
  853. if TextIsSame(HeaderEncoding, 'Q') {Do not Localize}
  854. and EncodingFound then begin
  855. i := 1;
  856. s := ''; {Do not Localize}
  857. repeat // substring can be accessed by index here, because we know that it ends with '?=' {Do not Localize}
  858. if substring[i] = '_' then {Do not Localize}
  859. begin
  860. s := s + ' '; {Do not Localize}
  861. end else if (substring[i] = '=') and (Length(substring) >= i + 2 + 2) then //make sure we can access i+2 and '?=' is still beyond {Do not Localize}
  862. begin
  863. s := s + chr(StrToInt('$' + substring[i + 1] + substring[i + 2])); {Do not Localize}
  864. inc(i, 2);
  865. end else
  866. begin
  867. s := s + substring[i];
  868. end;
  869. inc(i);
  870. until (substring[i] = '?') and (substring[i + 1] = '=') {Do not Localize}
  871. end else if EncodingFound then
  872. begin
  873. while Length(substring) >= 4 do
  874. begin
  875. a4[1] := b64(substring[1]);
  876. a4[2] := b64(substring[2]);
  877. a4[3] := b64(substring[3]);
  878. a4[4] := b64(substring[4]);
  879. a3[1] := Byte((a4[1] shl 2) or (a4[2] shr 4));
  880. a3[2] := Byte((a4[2] shl 4) or (a4[3] shr 2));
  881. a3[3] := Byte((a4[3] shl 6) or (a4[4] shr 0));
  882. substring := Copy(substring, 5, Length(substring));
  883. s := s + CHR(a3[1]) + CHR(a3[2]) + CHR(a3[3]);
  884. end;
  885. end;
  886.  
  887. if EncodingFound then
  888. begin
  889. if TextIsSame(HeaderCharSet, 'ISO-2022-JP') then {Do not Localize}
  890. begin
  891. substring := Decode2022JP(s);
  892. end else
  893. begin
  894. substring := ConvertToWide(s, HeaderCharSet);
  895. end;
  896.  
  897. //replace old substring in header with decoded one:
  898. header := Copy(header, 1, LEncodingStartPos - 1)
  899. + substring + Copy(header, encodingendpos + 2, Length(Header));
  900. encodingendpos := length(substring);
  901. substring := ''; {Do not Localize}
  902. S := '';
  903. UpHeader := UpperCase(Header);
  904. end;
  905.  
  906. end;
  907. end;
  908. encodingendpos := LEncodingStartPos + encodingendpos;
  909. {CC: Bug fix - changed LEncodingStartPos to LPreviousEncodingStartPos because
  910. LEncodingStartPos gets overwritten by return value from PosIdx.}
  911. LPreviousEncodingStartPos := LEncodingStartPos;
  912. LEncodingStartPos := PosIdx('=?', UpHeader, LPreviousEncodingStartPos + 1); {do not localize}
  913. (*
  914. LEncodingStartPos := PosIdx('=?ISO', UpHeader, LPreviousEncodingStartPos + 1); {do not localize}
  915. if LEncodingStartPos = 0 then begin
  916. LEncodingStartPos := PosIdx('=?WINDOWS', UpHeader, LPreviousEncodingStartPos + 1); {do not localize}
  917. end;
  918. if LEncodingStartPos = 0 then begin
  919. LEncodingStartPos := PosIdx('=?KOI8', UpHeader, LPreviousEncodingStartPos + 1); {do not localize}
  920. end;
  921. *)
  922. // delete whitespace between adjacent encoded words, but only
  923. // if we had an encoding before
  924. if EncodingFound then begin
  925. EncodingBeforeEnd := encodingendpos;
  926. end else begin
  927. EncodingBeforeEnd := -1;
  928. end;
  929. end;
  930. //There might be #0's in header when this it b64 encoded, e.g with:
  931. //decodeheader('"Fernando Corti=?ISO-8859-1?B?8Q==?=a" <fernando@nowhere.com>');
  932. while Pos(#0, header) > 0 do begin
  933. Delete(header, Pos(#0, header), 1);
  934. end;
  935. Result := Header;
  936. end;
  937.  
  938. end.
  939.