IdURI.pas 23 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712
  1. {
  2. $Project$
  3. $Workfile$
  4. $Revision$
  5. $DateUTC$
  6. $Id$
  7. This file is part of the Indy (Internet Direct) project, and is offered
  8. under the dual-licensing agreement described on the Indy website.
  9. (http://www.indyproject.org/)
  10. Copyright:
  11. (c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
  12. }
  13. {
  14. $Log$
  15. }
  16. {
  17. Rev 1.9 10.10.2004 13:46:00 ARybin
  18. dont add default port to URI
  19. Rev 1.8 2004.02.03 5:44:40 PM czhower
  20. Name changes
  21. Rev 1.7 2004.01.22 5:27:24 PM czhower
  22. Fixed compile errors.
  23. Rev 1.6 1/22/2004 4:06:56 PM SPerry
  24. fixed set problems
  25. Rev 1.5 10/5/2003 11:44:24 PM GGrieve
  26. Use IsLeadChar
  27. Rev 1.4 6/9/2003 9:35:58 PM BGooijen
  28. %00 is valid now too
  29. Rev 1.3 2003.05.09 10:30:16 PM czhower
  30. Rev 1.2 2003.04.11 9:41:34 PM czhower
  31. Rev 1.1 29/11/2002 9:56:10 AM SGrobety Version: 1.1
  32. Changed URL encoding
  33. Rev 1.0 21/11/2002 12:42:52 PM SGrobety Version: Indy 10
  34. Rev 1.0 11/13/2002 08:04:10 AM JPMugaas
  35. }
  36. unit IdURI;
  37. {Details of implementation
  38. -------------------------
  39. 2002-Apr-14 Peter Mee
  40. - Fixed reset. Now resets FParams as well - wasn't before.
  41. 2001-Nov Doychin Bondzhev
  42. - Fixes in URLEncode. There is difference when encoding Path+Doc and Params
  43. 2001-Oct-17 Peter Mee
  44. - Minor speed improvement - removed use of NormalizePath in SetURI.
  45. - Fixed bug that was cutting off the first two chars of the host when a
  46. username / password present.
  47. - Fixed bug that prevented username and password being updated.
  48. - Fixed bug that was leaving the bookmark in the document when no ? or =
  49. parameters existed.
  50. 2001-Feb-18 Doychin Bondzhev
  51. - Added UserName and Password to support URI's like
  52. http://username:password@hostname:port/path/document#bookmark
  53. }
  54. interface
  55. {$i IdCompilerDefines.inc}
  56. uses
  57. IdException,
  58. IdGlobal;
  59. type
  60. TIdURIOptionalFields = (ofAuthInfo, ofBookmark);
  61. TIdURIOptionalFieldsSet = set of TIdURIOptionalFields;
  62. TIdURI = class
  63. protected
  64. FDocument: string;
  65. FProtocol: string;
  66. FURI: String;
  67. FPort: string;
  68. Fpath: string;
  69. FHost: string;
  70. FBookmark: string;
  71. FUserName: string;
  72. FPassword: string;
  73. FParams: string;
  74. FIPVersion: TIdIPVersion;
  75. //
  76. procedure SetURI(const Value: String);
  77. function GetURI: String;
  78. public
  79. constructor Create(const AURI: string = ''); virtual; {Do not Localize}
  80. function GetFullURI(const AOptionalFields: TIdURIOptionalFieldsSet = [ofAuthInfo, ofBookmark]): String;
  81. function GetPathAndParams: String;
  82. class procedure NormalizePath(var APath: string);
  83. class function URLDecode(ASrc: string; AByteEncoding: IIdTextEncoding = nil
  84. {$IFDEF STRING_IS_ANSI}; ADestEncoding: IIdTextEncoding = nil{$ENDIF}
  85. ): string;
  86. class function URLEncode(const ASrc: string; AByteEncoding: IIdTextEncoding = nil
  87. {$IFDEF STRING_IS_ANSI}; ASrcEncoding: IIdTextEncoding = nil{$ENDIF}
  88. ): string;
  89. class function ParamsEncode(const ASrc: string; AByteEncoding: IIdTextEncoding = nil
  90. {$IFDEF STRING_IS_ANSI}; ASrcEncoding: IIdTextEncoding = nil{$ENDIF}
  91. ): string;
  92. class function PathEncode(const ASrc: string; AByteEncoding: IIdTextEncoding = nil
  93. {$IFDEF STRING_IS_ANSI}; ASrcEncoding: IIdTextEncoding = nil{$ENDIF}
  94. ): string;
  95. //
  96. property Bookmark : string read FBookmark write FBookMark;
  97. property Document: string read FDocument write FDocument;
  98. property Host: string read FHost write FHost;
  99. property Password: string read FPassword write FPassword;
  100. property Path: string read FPath write FPath;
  101. property Params: string read FParams write FParams;
  102. property Port: string read FPort write FPort;
  103. property Protocol: string read FProtocol write FProtocol;
  104. property URI: string read GetURI write SetURI;
  105. property Username: string read FUserName write FUserName;
  106. property IPVersion : TIdIPVersion read FIPVersion write FIPVersion;
  107. end;
  108. EIdURIException = class(EIdException);
  109. implementation
  110. uses
  111. IdGlobalProtocols, IdResourceStringsProtocols, IdUriUtils,
  112. SysUtils;
  113. { TIdURI }
  114. constructor TIdURI.Create(const AURI: string = ''); {Do not Localize}
  115. begin
  116. inherited Create;
  117. if length(AURI) > 0 then begin
  118. URI := AURI;
  119. end;
  120. end;
  121. class procedure TIdURI.NormalizePath(var APath: string);
  122. var
  123. i, PathLen: Integer;
  124. LChar: Char;
  125. {$IFDEF STRING_IS_IMMUTABLE}
  126. LSB: TIdStringBuilder;
  127. {$ENDIF}
  128. begin
  129. {$IFDEF STRING_IS_IMMUTABLE}
  130. LSB := nil;
  131. {$ENDIF}
  132. // Normalize the directory delimiters to follow the UNIX syntax
  133. // RLebeau 8/10/2010: only normalize within the actual path,
  134. // nothing outside of it...
  135. i := Pos(':', APath); {do not localize}
  136. if i > 0 then begin
  137. Inc(i);
  138. // if the path does not already begin with '//', then do not
  139. // normalize the first two characters if they would produce
  140. // '//', as that will change the semantics of the URL...
  141. if CharIsInSet(APath, I, '\/') and CharIsInSet(APath, I+1, '\/') then begin
  142. Inc(i, 2);
  143. end;
  144. end else begin
  145. i := 1;
  146. end;
  147. PathLen := Length(APath);
  148. while i <= PathLen do begin
  149. LChar := APath[i];
  150. {$IFDEF STRING_IS_ANSI}
  151. if IsLeadChar(LChar) then begin
  152. Inc(i, 2);
  153. Continue;
  154. end;
  155. {$ENDIF}
  156. if (LChar = '?') or (LChar = '#') then begin {Do not Localize}
  157. // stop normalizing at query/fragment portion of the URL
  158. Break;
  159. end;
  160. if LChar = '\' then begin {Do not Localize}
  161. {$IFDEF STRING_IS_IMMUTABLE}
  162. if LSB = nil then begin
  163. LSB := TIdStringBuilder.Create(APath);
  164. end;
  165. LSB[i-1] := '/'; {Do not Localize}
  166. {$ELSE}
  167. APath[i] := '/'; {Do not Localize}
  168. {$ENDIF}
  169. end;
  170. Inc(i);
  171. end;
  172. {$IFDEF STRING_IS_IMMUTABLE}
  173. if LSB <> nil then begin
  174. APath := LSB.ToString;
  175. end;
  176. {$ENDIF}
  177. end;
  178. procedure TIdURI.SetURI(const Value: String);
  179. var
  180. LBuffer: string;
  181. LTokenPos: Integer;
  182. LURI: string;
  183. begin
  184. FURI := Value;
  185. NormalizePath(FURI);
  186. LURI := FURI;
  187. FHost := ''; {Do not Localize}
  188. FProtocol := ''; {Do not Localize}
  189. FPath := ''; {Do not Localize}
  190. FDocument := ''; {Do not Localize}
  191. FPort := ''; {Do not Localize}
  192. FBookmark := ''; {Do not Localize}
  193. FUsername := ''; {Do not Localize}
  194. FPassword := ''; {Do not Localize}
  195. FParams := ''; {Do not localise} //Peter Mee
  196. FIPVersion := Id_IPv4;
  197. LTokenPos := IndyPos('://', LURI); {Do not Localize}
  198. if (LTokenPos = 0) and TextStartsWith(LURI, '//') then begin {Do not Localize}
  199. LTokenPos := 1;
  200. end;
  201. if LTokenPos > 0 then begin
  202. // absolute URI
  203. // What to do when data don't match configuration ?? {Do not Localize}
  204. // Get the protocol
  205. if LURI[LTokenPos] = ':' then begin {Do not Localize}
  206. FProtocol := Copy(LURI, 1, LTokenPos - 1);
  207. Delete(LURI, 1, LTokenPos + 2);
  208. end else begin
  209. Delete(LURI, 1, LTokenPos + 1);
  210. end;
  211. // separate the path from the parameters
  212. LTokenPos := IndyPos('?', LURI); {Do not Localize}
  213. // RLebeau: this is BAD! It messes up JSP and similar URLs that use '=' characters in the document
  214. {if LTokenPos = 0 then begin
  215. LTokenPos := IndyPos('=', LURI); {Do not Localize
  216. end;}
  217. if LTokenPos > 0 then begin
  218. FParams := Copy(LURI, LTokenPos + 1, MaxInt);
  219. LURI := Copy(LURI, 1, LTokenPos - 1);
  220. // separate the bookmark from the parameters
  221. LTokenPos := IndyPos('#', FParams); {Do not Localize}
  222. if LTokenPos > 0 then begin {Do not Localize}
  223. FBookmark := FParams;
  224. FParams := Fetch(FBookmark, '#'); {Do not Localize}
  225. end;
  226. end else begin
  227. // separate the path from the bookmark
  228. LTokenPos := IndyPos('#', LURI); {Do not Localize}
  229. if LTokenPos > 0 then begin {Do not Localize}
  230. FBookmark := Copy(LURI, LTokenPos + 1, MaxInt);
  231. LURI := Copy(LURI, 1, LTokenPos - 1);
  232. end;
  233. end;
  234. // Get the user name, password, host and the port number
  235. LBuffer := Fetch(LURI, '/', True); {Do not Localize}
  236. // Get username and password
  237. LTokenPos := RPos('@', LBuffer); {Do not Localize}
  238. if LTokenPos > 0 then begin
  239. FPassword := Copy(LBuffer, 1, LTokenPos - 1);
  240. Delete(LBuffer, 1, LTokenPos);
  241. FUserName := Fetch(FPassword, ':'); {Do not Localize}
  242. // Ignore cases where there is only password (http://:password@host/pat/doc)
  243. if Length(FUserName) = 0 then begin
  244. FPassword := ''; {Do not Localize}
  245. end;
  246. end;
  247. // Get the host and the port number
  248. if (IndyPos('[', LBuffer) > 0) and (IndyPos(']', LBuffer) > IndyPos('[', LBuffer)) then begin {Do not Localize}
  249. //This is for IPv6 Hosts
  250. FHost := Fetch(LBuffer, ']'); {Do not Localize}
  251. Fetch(FHost, '['); {Do not Localize}
  252. Fetch(LBuffer, ':'); {Do not Localize}
  253. FIPVersion := Id_IPv6;
  254. end else begin
  255. FHost := Fetch(LBuffer, ':', True); {Do not Localize}
  256. end;
  257. FPort := LBuffer;
  258. // Get the path
  259. LTokenPos := RPos('/', LURI, -1);
  260. if LTokenPos > 0 then begin
  261. FPath := '/' + Copy(LURI, 1, LTokenPos); {Do not Localize}
  262. Delete(LURI, 1, LTokenPos);
  263. end else begin
  264. FPath := '/'; {Do not Localize}
  265. end;
  266. end else begin
  267. // received an absolute path, not an URI
  268. LTokenPos := IndyPos('?', LURI); {Do not Localize}
  269. // RLebeau: this is BAD! It messes up JSP and similar URLs that use '=' characters in the document
  270. {if LTokenPos = 0 then begin
  271. LTokenPos := IndyPos('=', LURI); {Do not Localize
  272. end;}
  273. if LTokenPos > 0 then begin // The case when there is parameters after the document name
  274. FParams := Copy(LURI, LTokenPos + 1, MaxInt);
  275. LURI := Copy(LURI, 1, LTokenPos - 1);
  276. // separate the bookmark from the parameters
  277. LTokenPos := IndyPos('#', FParams); {Do not Localize}
  278. if LTokenPos > 0 then begin
  279. FBookmark := FParams;
  280. FParams := Fetch(FBookmark, '#'); {Do not Localize}
  281. end;
  282. end else begin
  283. // separate the bookmark from the path
  284. LTokenPos := IndyPos('#', LURI); {Do not Localize}
  285. if LTokenPos > 0 then begin // The case when there is a bookmark after the document name
  286. FBookmark := Copy(LURI, LTokenPos + 1, MaxInt);
  287. LURI := Copy(LURI, 1, LTokenPos - 1);
  288. end;
  289. end;
  290. // Get the path
  291. LTokenPos := RPos('/', LURI, -1); {Do not Localize}
  292. if LTokenPos > 0 then begin
  293. FPath := Copy(LURI, 1, LTokenPos);
  294. Delete(LURI, 1, LTokenPos);
  295. end;
  296. end;
  297. // Get the document
  298. FDocument := LURI;
  299. end;
  300. function TIdURI.GetURI: String;
  301. begin
  302. FURI := GetFullURI;
  303. // Result must contain only the proto://host/path/document
  304. // If you need the full URI then you have to call GetFullURI
  305. Result := GetFullURI([]);
  306. end;
  307. class function TIdURI.URLDecode(ASrc: string; AByteEncoding: IIdTextEncoding = nil
  308. {$IFDEF STRING_IS_ANSI}; ADestEncoding: IIdTextEncoding = nil{$ENDIF}
  309. ): string;
  310. var
  311. i, SrcLen: Integer;
  312. ESC: string;
  313. LChars: TIdWideChars;
  314. LBytes: TIdBytes;
  315. begin
  316. Result := ''; {Do not Localize}
  317. LChars := nil;
  318. LBytes := nil;
  319. EnsureEncoding(AByteEncoding, encUTF8);
  320. // S.G. 27/11/2002: Spaces is NOT to be encoded as "+".
  321. // S.G. 27/11/2002: "+" is a field separator in query parameter, space is...
  322. // S.G. 27/11/2002: well, a space
  323. // ASrc := ReplaceAll(ASrc, '+', ' '); {do not localize}
  324. i := 1;
  325. SrcLen := Length(ASrc);
  326. while i <= SrcLen do begin
  327. if ASrc[i] <> '%' then begin {do not localize}
  328. AppendByte(LBytes, Ord(ASrc[i])); // Copy the char
  329. Inc(i); // Then skip it
  330. end else begin
  331. Inc(i); // skip the % char
  332. if not CharIsInSet(ASrc, i, 'uU') then begin {do not localize}
  333. // simple ESC char
  334. ESC := Copy(ASrc, i, 2); // Copy the escape code
  335. Inc(i, 2); // Then skip it.
  336. try
  337. AppendByte(LBytes, Byte(IndyStrToInt('$' + ESC))); {do not localize}
  338. except end;
  339. end else
  340. begin
  341. // unicode ESC code
  342. // RLebeau 5/10/2006: under Win32, the character will likely end
  343. // up as '?' in the Result when converted from Unicode to Ansi,
  344. // but at least the URL will be parsed properly
  345. ESC := Copy(ASrc, i+1, 4); // Copy the escape code
  346. Inc(i, 5); // Then skip it.
  347. try
  348. if LChars = nil then begin
  349. SetLength(LChars, 1);
  350. end;
  351. LChars[0] := WideChar(IndyStrToInt('$' + ESC)); {do not localize}
  352. AppendBytes(LBytes, AByteEncoding.GetBytes(LChars));
  353. except end;
  354. end;
  355. end;
  356. end;
  357. {$IFDEF STRING_IS_UNICODE}
  358. Result := AByteEncoding.GetString(LBytes);
  359. {$ELSE}
  360. EnsureEncoding(ADestEncoding, encOSDefault);
  361. CheckByteEncoding(LBytes, AByteEncoding, ADestEncoding);
  362. SetString(Result, PAnsiChar(LBytes), Length(LBytes));
  363. {$IFDEF HAS_SetCodePage}
  364. // on compilers that support AnsiString codepages,
  365. // set the string's codepage to match ADestEncoding...
  366. SetCodePage(PRawByteString(@Result)^, GetEncodingCodePage(ADestEncoding), False);
  367. {$ENDIF}
  368. {$ENDIF}
  369. end;
  370. {$IFNDEF STRING_IS_UNICODE}
  371. // RLebeau 6/16/2017: IdGlobal.IsHexidecimal() expects Ansi input, but we need
  372. // a Unicode version here, so we don't truncate wide characters into something
  373. // that happen to be valid hex characters...
  374. function IsHexidecimal(const AChar: TIdWideChar): Boolean; overload;
  375. {$IFDEF USE_INLINE}inline;{$ENDIF}
  376. begin
  377. Result := ((AChar >= '0') and (AChar <= '9')) {Do not Localize}
  378. or ((AChar >= 'A') and (AChar <= 'F')) {Do not Localize}
  379. or ((AChar >= 'a') and (AChar <= 'f')); {Do not Localize}
  380. end;
  381. {$ENDIF}
  382. function IsPercentEncoded(const ASrc: {$IFDEF STRING_IS_UNICODE}string{$ELSE}TIdWideChars{$ENDIF}; AIndex: Integer): Boolean;
  383. begin
  384. {$IFDEF STRING_IS_UNICODE}
  385. Result := (AIndex + 2) <= Length(ASrc);
  386. {$ELSE}
  387. Result := (AIndex + 2) < Length(ASrc);
  388. {$ENDIF}
  389. if Result then begin
  390. Result := (ASrc[AIndex] = '%') {Do not Localize}
  391. and IsHexidecimal(ASrc[AIndex+1])
  392. and IsHexidecimal(ASrc[AIndex+2]);
  393. end;
  394. end;
  395. class function TIdURI.ParamsEncode(const ASrc: string; AByteEncoding: IIdTextEncoding = nil
  396. {$IFDEF STRING_IS_ANSI}; ASrcEncoding: IIdTextEncoding = nil{$ENDIF}
  397. ): string;
  398. const
  399. UnsafeChars: TIdUnicodeString = '*<>#%"{}|\^[]`'; {do not localize}
  400. var
  401. I, J, SrcLen, CharLen, ByteLen: Integer;
  402. Buf: TIdBytes;
  403. {$IFDEF STRING_IS_ANSI}
  404. LChars: TIdWideChars;
  405. {$ENDIF}
  406. LChar: WideChar;
  407. begin
  408. Result := ''; {Do not Localize}
  409. // keep the compiler happy
  410. Buf := nil;
  411. {$IFDEF STRING_IS_ANSI}
  412. LChars := nil;
  413. {$ENDIF}
  414. if ASrc = '' then begin
  415. Exit;
  416. end;
  417. EnsureEncoding(AByteEncoding, encUTF8);
  418. {$IFDEF STRING_IS_ANSI}
  419. EnsureEncoding(ASrcEncoding, encOSDefault);
  420. LChars := ASrcEncoding.GetChars(
  421. {$IFNDEF VCL_6_OR_ABOVE}
  422. // RLebeau: for some reason, Delphi 5 causes a "There is no overloaded
  423. // version of 'GetChars' that can be called with these arguments" compiler
  424. // error if the PByte type-cast is used, even though GetChars() actually
  425. // expects a PByte as input. Must be a compiler bug, as it compiles fine
  426. // in Delphi 6. So, converting to TIdBytes until I find a better solution...
  427. RawToBytes(PAnsiChar(ASrc)^, Length(ASrc))
  428. {$ELSE}
  429. PByte(PAnsiChar(ASrc)), Length(ASrc)
  430. {$ENDIF}
  431. );
  432. {$ENDIF}
  433. // 2 Chars to handle UTF-16 surrogates
  434. SetLength(Buf, AByteEncoding.GetMaxByteCount(2));
  435. I := 0;
  436. SrcLen := Length({$IFDEF STRING_IS_UNICODE}ASrc{$ELSE}LChars{$ENDIF});
  437. while I < SrcLen do
  438. begin
  439. // RLebeau 6/9/2017: if LChar is '%', check if it belongs to a pre-encoded
  440. // '%HH' octet, and if so then preserve the whole sequence as-is...
  441. if IsPercentEncoded({$IFDEF STRING_IS_UNICODE}ASrc, I+1{$ELSE}LChars, I{$ENDIF}) then begin
  442. {$IFDEF STRING_IS_UNICODE}
  443. Result := Result + Copy(ASrc, I+1, 3);
  444. {$ELSE}
  445. for J := 0 to 2 do begin
  446. Result := Result + Char(LChars[I+J]); {do not localize}
  447. end;
  448. {$ENDIF}
  449. Inc(I, 3);
  450. end else
  451. begin
  452. LChar := {$IFDEF STRING_IS_UNICODE}ASrc[I+1]{$ELSE}LChars[I]{$ENDIF};
  453. // S.G. 27/11/2002: Changed the parameter encoding: Even in parameters, a space
  454. // S.G. 27/11/2002: is much more likely to be meaning "space" than "this is
  455. // S.G. 27/11/2002: a new parameter"
  456. // S.G. 27/11/2002: ref: Message-ID: <[email protected]> borland.public.delphi.internet.winsock
  457. // S.G. 27/11/2002: Most low-ascii is actually Ok in parameters encoding.
  458. // RLebeau 1/7/09: using Char() for #128-#255 because in D2009, the compiler
  459. // may change characters >= #128 from their Ansi codepage value to their true
  460. // Unicode codepoint value, depending on the codepage used for the source code.
  461. // For instance, #128 may become #$20AC...
  462. if WideCharIsInSet(UnsafeChars, LChar) or (Ord(LChar) < 33) or (Ord(LChar) > 127) then
  463. begin
  464. CharLen := CalcUTF16CharLength(
  465. {$IFDEF STRING_IS_UNICODE}ASrc, I+1{$ELSE}LChars, I{$ENDIF}
  466. ); // calculate length including surrogates
  467. ByteLen := AByteEncoding.GetBytes(
  468. {$IFDEF STRING_IS_UNICODE}ASrc, I+1{$ELSE}LChars, I{$ENDIF},
  469. CharLen, Buf, 0); // explicit Unicode->Ansi conversion
  470. for J := 0 to ByteLen-1 do begin
  471. Result := Result + '%' + IntToHex(Ord(Buf[J]), 2); {do not localize}
  472. end;
  473. Inc(I, CharLen);
  474. end else
  475. begin
  476. Result := Result + Char(LChar);
  477. Inc(I);
  478. end;
  479. end;
  480. end;
  481. end;
  482. class function TIdURI.PathEncode(const ASrc: string; AByteEncoding: IIdTextEncoding = nil
  483. {$IFDEF STRING_IS_ANSI}; ASrcEncoding: IIdTextEncoding = nil{$ENDIF}
  484. ): string;
  485. const
  486. UnsafeChars: TIdUnicodeString = '*<>#%"{}|\^[]`+'; {do not localize}
  487. var
  488. I, J, SrcLen, CharLen, ByteLen: Integer;
  489. Buf: TIdBytes;
  490. {$IFDEF STRING_IS_ANSI}
  491. LChars: TIdWideChars;
  492. {$ENDIF}
  493. LChar: WideChar;
  494. begin
  495. Result := ''; {Do not Localize}
  496. // keep the compiler happy
  497. Buf := nil;
  498. {$IFDEF STRING_IS_ANSI}
  499. LChars := nil;
  500. {$ENDIF}
  501. if ASrc = '' then begin
  502. Exit;
  503. end;
  504. EnsureEncoding(AByteEncoding, encUTF8);
  505. {$IFDEF STRING_IS_ANSI}
  506. EnsureEncoding(ASrcEncoding, encOSDefault);
  507. LChars := ASrcEncoding.GetChars(
  508. {$IFNDEF VCL_6_OR_ABOVE}
  509. // RLebeau: for some reason, Delphi 5 causes a "There is no overloaded
  510. // version of 'GetChars' that can be called with these arguments" compiler
  511. // error if the PByte type-cast is used, even though GetChars() actually
  512. // expects a PByte as input. Must be a compiler bug, as it compiles fine
  513. // in Delphi 6. So, converting to TIdBytes until I find a better solution...
  514. RawToBytes(PAnsiChar(ASrc)^, Length(ASrc))
  515. {$ELSE}
  516. PByte(PAnsiChar(ASrc)), Length(ASrc)
  517. {$ENDIF}
  518. );
  519. {$ENDIF}
  520. // 2 Chars to handle UTF-16 surrogates
  521. SetLength(Buf, AByteEncoding.GetMaxByteCount(2));
  522. I := 0;
  523. SrcLen := Length({$IFDEF STRING_IS_UNICODE}ASrc{$ELSE}LChars{$ENDIF});
  524. while I < SrcLen do
  525. begin
  526. // RLebeau 6/9/2017: if LChar is '%', check if it belongs to a pre-encoded
  527. // '%HH' octet, and if so then preserve the whole sequence as-is...
  528. if IsPercentEncoded({$IFDEF STRING_IS_UNICODE}ASrc, I+1{$ELSE}LChars, I{$ENDIF}) then begin
  529. {$IFDEF STRING_IS_UNICODE}
  530. Result := Result + Copy(ASrc, I+1, 3);
  531. {$ELSE}
  532. for J := 0 to 2 do begin
  533. Result := Result + Char(LChars[I+J]); {do not localize}
  534. end;
  535. {$ENDIF}
  536. Inc(I, 3);
  537. end else
  538. begin
  539. LChar := {$IFDEF STRING_IS_UNICODE}ASrc[I+1]{$ELSE}LChars[I]{$ENDIF};
  540. if WideCharIsInSet(UnsafeChars, LChar) or (Ord(LChar) < 33) or (Ord(LChar) > 127) then
  541. begin
  542. CharLen := CalcUTF16CharLength(
  543. {$IFDEF STRING_IS_UNICODE}ASrc, I+1{$ELSE}LChars, I{$ENDIF}
  544. ); // calculate length including surrogates
  545. ByteLen := AByteEncoding.GetBytes(
  546. {$IFDEF STRING_IS_UNICODE}ASrc, I+1{$ELSE}LChars, I{$ENDIF},
  547. CharLen, Buf, 0); // explicit Unicode->Ansi conversion
  548. for J := 0 to ByteLen-1 do begin
  549. Result := Result + '%' + IntToHex(Ord(Buf[J]), 2); {do not localize}
  550. end;
  551. Inc(I, CharLen);
  552. end else
  553. begin
  554. Result := Result + Char(LChar);
  555. Inc(I);
  556. end;
  557. end;
  558. end;
  559. end;
  560. class function TIdURI.URLEncode(const ASrc: string; AByteEncoding: IIdTextEncoding = nil
  561. {$IFDEF STRING_IS_ANSI}; ASrcEncoding: IIdTextEncoding = nil{$ENDIF}
  562. ): string;
  563. var
  564. LUri: TIdURI;
  565. begin
  566. LUri := TIdURI.Create(ASrc);
  567. try
  568. LUri.Path := PathEncode(LUri.Path, AByteEncoding
  569. {$IFDEF STRING_IS_ANSI}, ASrcEncoding{$ENDIF}
  570. );
  571. LUri.Document := PathEncode(LUri.Document, AByteEncoding
  572. {$IFDEF STRING_IS_ANSI}, ASrcEncoding{$ENDIF}
  573. );
  574. LUri.Params := ParamsEncode(LUri.Params, AByteEncoding
  575. {$IFDEF STRING_IS_ANSI}, ASrcEncoding{$ENDIF}
  576. );
  577. Result := LUri.URI;
  578. finally
  579. LUri.Free;
  580. end;
  581. end;
  582. function TIdURI.GetFullURI(const AOptionalFields: TIdURIOptionalFieldsSet): String;
  583. var
  584. LURI: String;
  585. begin
  586. if FProtocol = '' then begin
  587. raise EIdURIException.Create(RSURINoProto);
  588. end;
  589. if FHost = '' then begin
  590. raise EIdURIException.Create(RSURINoHost);
  591. end;
  592. LURI := FProtocol + '://'; {Do not Localize}
  593. if (FUserName <> '') and (ofAuthInfo in AOptionalFields) then begin
  594. LURI := LURI + FUserName;
  595. if FPassword <> '' then begin
  596. LURI := LURI + ':' + FPassword; {Do not Localize}
  597. end;
  598. LURI := LURI + '@'; {Do not Localize}
  599. end;
  600. if IPVersion = Id_IPv6 then begin
  601. LURI := LURI + '[' + FHost + ']'; {Do not Localize}
  602. end else begin
  603. LURI := LURI + FHost;
  604. end;
  605. if FPort <> '' then begin
  606. case PosInStrArray(FProtocol, ['HTTP', 'HTTPS', 'FTP'], False) of {Do not Localize}
  607. 0:
  608. begin
  609. if FPort <> '80' then begin
  610. LURI := LURI + ':' + FPort; {Do not Localize}
  611. end;
  612. end;
  613. 1:
  614. begin
  615. if FPort <> '443' then begin
  616. LURI := LURI + ':' + FPort; {Do not Localize}
  617. end;
  618. end;
  619. 2:
  620. begin
  621. if FPort <> '21' then begin
  622. LURI := LURI + ':' + FPort; {Do not Localize}
  623. end;
  624. end;
  625. else
  626. begin
  627. LURI := LURI + ':' + FPort; {Do not Localize}
  628. end;
  629. end;
  630. end;
  631. LURI := LURI + GetPathAndParams;
  632. if (FBookmark <> '') and (ofBookmark in AOptionalFields) then begin
  633. LURI := LURI + '#' + FBookmark; {Do not Localize}
  634. end;
  635. Result := LURI;
  636. end;
  637. function TIdURI.GetPathAndParams: String;
  638. begin
  639. Result := FPath + FDocument;
  640. if FParams <> '' then begin
  641. Result := Result + '?' + FParams; {Do not Localize}
  642. end;
  643. end;
  644. end.