Программа для прослушивания журнала АРК Томск http://blindage.org/?p=6627
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

synaip.pas 12KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422
  1. {==============================================================================|
  2. | Project : Ararat Synapse | 001.002.001 |
  3. |==============================================================================|
  4. | Content: IP address support procedures and functions |
  5. |==============================================================================|
  6. | Copyright (c)2006-2010, Lukas Gebauer |
  7. | All rights reserved. |
  8. | |
  9. | Redistribution and use in source and binary forms, with or without |
  10. | modification, are permitted provided that the following conditions are met: |
  11. | |
  12. | Redistributions of source code must retain the above copyright notice, this |
  13. | list of conditions and the following disclaimer. |
  14. | |
  15. | Redistributions in binary form must reproduce the above copyright notice, |
  16. | this list of conditions and the following disclaimer in the documentation |
  17. | and/or other materials provided with the distribution. |
  18. | |
  19. | Neither the name of Lukas Gebauer nor the names of its contributors may |
  20. | be used to endorse or promote products derived from this software without |
  21. | specific prior written permission. |
  22. | |
  23. | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
  24. | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
  25. | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
  26. | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
  27. | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
  28. | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
  29. | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
  30. | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
  31. | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
  32. | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
  33. | DAMAGE. |
  34. |==============================================================================|
  35. | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
  36. | Portions created by Lukas Gebauer are Copyright (c) 2006-2010. |
  37. | All Rights Reserved. |
  38. |==============================================================================|
  39. | Contributor(s): |
  40. |==============================================================================|
  41. | History: see HISTORY.HTM from distribution package |
  42. | (Found at URL: http://www.ararat.cz/synapse/) |
  43. |==============================================================================}
  44. {:@abstract(IP adress support procedures and functions)}
  45. {$IFDEF FPC}
  46. {$MODE DELPHI}
  47. {$ENDIF}
  48. {$Q-}
  49. {$R-}
  50. {$H+}
  51. {$IFDEF UNICODE}
  52. {$WARN IMPLICIT_STRING_CAST OFF}
  53. {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
  54. {$WARN SUSPICIOUS_TYPECAST OFF}
  55. {$ENDIF}
  56. unit synaip;
  57. interface
  58. uses
  59. SysUtils, SynaUtil;
  60. type
  61. {:binary form of IPv6 adress (for string conversion routines)}
  62. TIp6Bytes = array [0..15] of Byte;
  63. {:binary form of IPv6 adress (for string conversion routines)}
  64. TIp6Words = array [0..7] of Word;
  65. {:Returns @TRUE, if "Value" is a valid IPv4 address. Cannot be a symbolic Name!}
  66. function IsIP(const Value: string): Boolean;
  67. {:Returns @TRUE, if "Value" is a valid IPv6 address. Cannot be a symbolic Name!}
  68. function IsIP6(const Value: string): Boolean;
  69. {:Returns a string with the "Host" ip address converted to binary form.}
  70. function IPToID(Host: string): Ansistring;
  71. {:Convert IPv6 address from their string form to binary byte array.}
  72. function StrToIp6(value: string): TIp6Bytes;
  73. {:Convert IPv6 address from binary byte array to string form.}
  74. function Ip6ToStr(value: TIp6Bytes): string;
  75. {:Convert IPv4 address from their string form to binary.}
  76. function StrToIp(value: string): integer;
  77. {:Convert IPv4 address from binary to string form.}
  78. function IpToStr(value: integer): string;
  79. {:Convert IPv4 address to reverse form.}
  80. function ReverseIP(Value: AnsiString): AnsiString;
  81. {:Convert IPv6 address to reverse form.}
  82. function ReverseIP6(Value: AnsiString): AnsiString;
  83. {:Expand short form of IPv6 address to long form.}
  84. function ExpandIP6(Value: AnsiString): AnsiString;
  85. implementation
  86. {==============================================================================}
  87. function IsIP(const Value: string): Boolean;
  88. var
  89. TempIP: string;
  90. function ByteIsOk(const Value: string): Boolean;
  91. var
  92. x, n: integer;
  93. begin
  94. x := StrToIntDef(Value, -1);
  95. Result := (x >= 0) and (x < 256);
  96. // X may be in correct range, but value still may not be correct value!
  97. // i.e. "$80"
  98. if Result then
  99. for n := 1 to length(Value) do
  100. if not (AnsiChar(Value[n]) in ['0'..'9']) then
  101. begin
  102. Result := False;
  103. Break;
  104. end;
  105. end;
  106. begin
  107. TempIP := Value;
  108. Result := False;
  109. if not ByteIsOk(Fetch(TempIP, '.')) then
  110. Exit;
  111. if not ByteIsOk(Fetch(TempIP, '.')) then
  112. Exit;
  113. if not ByteIsOk(Fetch(TempIP, '.')) then
  114. Exit;
  115. if ByteIsOk(TempIP) then
  116. Result := True;
  117. end;
  118. {==============================================================================}
  119. function IsIP6(const Value: string): Boolean;
  120. var
  121. TempIP: string;
  122. s,t: string;
  123. x: integer;
  124. partcount: integer;
  125. zerocount: integer;
  126. First: Boolean;
  127. begin
  128. TempIP := Value;
  129. Result := False;
  130. if Value = '::' then
  131. begin
  132. Result := True;
  133. Exit;
  134. end;
  135. partcount := 0;
  136. zerocount := 0;
  137. First := True;
  138. while tempIP <> '' do
  139. begin
  140. s := fetch(TempIP, ':');
  141. if not(First) and (s = '') then
  142. Inc(zerocount);
  143. First := False;
  144. if zerocount > 1 then
  145. break;
  146. Inc(partCount);
  147. if s = '' then
  148. Continue;
  149. if partCount > 8 then
  150. break;
  151. if tempIP = '' then
  152. begin
  153. t := SeparateRight(s, '%');
  154. s := SeparateLeft(s, '%');
  155. x := StrToIntDef('$' + t, -1);
  156. if (x < 0) or (x > $ffff) then
  157. break;
  158. end;
  159. x := StrToIntDef('$' + s, -1);
  160. if (x < 0) or (x > $ffff) then
  161. break;
  162. if tempIP = '' then
  163. if not((PartCount = 1) and (ZeroCount = 0)) then
  164. Result := True;
  165. end;
  166. end;
  167. {==============================================================================}
  168. function IPToID(Host: string): Ansistring;
  169. var
  170. s: string;
  171. i, x: Integer;
  172. begin
  173. Result := '';
  174. for x := 0 to 3 do
  175. begin
  176. s := Fetch(Host, '.');
  177. i := StrToIntDef(s, 0);
  178. Result := Result + AnsiChar(i);
  179. end;
  180. end;
  181. {==============================================================================}
  182. function StrToIp(value: string): integer;
  183. var
  184. s: string;
  185. i, x: Integer;
  186. begin
  187. Result := 0;
  188. for x := 0 to 3 do
  189. begin
  190. s := Fetch(value, '.');
  191. i := StrToIntDef(s, 0);
  192. Result := (256 * Result) + i;
  193. end;
  194. end;
  195. {==============================================================================}
  196. function IpToStr(value: integer): string;
  197. var
  198. x1, x2: word;
  199. y1, y2: byte;
  200. begin
  201. Result := '';
  202. x1 := value shr 16;
  203. x2 := value and $FFFF;
  204. y1 := x1 div $100;
  205. y2 := x1 mod $100;
  206. Result := inttostr(y1) + '.' + inttostr(y2) + '.';
  207. y1 := x2 div $100;
  208. y2 := x2 mod $100;
  209. Result := Result + inttostr(y1) + '.' + inttostr(y2);
  210. end;
  211. {==============================================================================}
  212. function ExpandIP6(Value: AnsiString): AnsiString;
  213. var
  214. n: integer;
  215. s: ansistring;
  216. x: integer;
  217. begin
  218. Result := '';
  219. if value = '' then
  220. exit;
  221. x := countofchar(value, ':');
  222. if x > 7 then
  223. exit;
  224. if value[1] = ':' then
  225. value := '0' + value;
  226. if value[length(value)] = ':' then
  227. value := value + '0';
  228. x := 8 - x;
  229. s := '';
  230. for n := 1 to x do
  231. s := s + ':0';
  232. s := s + ':';
  233. Result := replacestring(value, '::', s);
  234. end;
  235. {==============================================================================}
  236. function StrToIp6(Value: string): TIp6Bytes;
  237. var
  238. IPv6: TIp6Words;
  239. Index: Integer;
  240. n: integer;
  241. b1, b2: byte;
  242. s: string;
  243. x: integer;
  244. begin
  245. for n := 0 to 15 do
  246. Result[n] := 0;
  247. for n := 0 to 7 do
  248. Ipv6[n] := 0;
  249. Index := 0;
  250. Value := ExpandIP6(value);
  251. if value = '' then
  252. exit;
  253. while Value <> '' do
  254. begin
  255. if Index > 7 then
  256. Exit;
  257. s := fetch(value, ':');
  258. if s = '@' then
  259. break;
  260. if s = '' then
  261. begin
  262. IPv6[Index] := 0;
  263. end
  264. else
  265. begin
  266. x := StrToIntDef('$' + s, -1);
  267. if (x > 65535) or (x < 0) then
  268. Exit;
  269. IPv6[Index] := x;
  270. end;
  271. Inc(Index);
  272. end;
  273. for n := 0 to 7 do
  274. begin
  275. b1 := ipv6[n] div 256;
  276. b2 := ipv6[n] mod 256;
  277. Result[n * 2] := b1;
  278. Result[(n * 2) + 1] := b2;
  279. end;
  280. end;
  281. {==============================================================================}
  282. //based on routine by the Free Pascal development team
  283. function Ip6ToStr(value: TIp6Bytes): string;
  284. var
  285. i, x: byte;
  286. zr1,zr2: set of byte;
  287. zc1,zc2: byte;
  288. have_skipped: boolean;
  289. ip6w: TIp6words;
  290. begin
  291. zr1 := [];
  292. zr2 := [];
  293. zc1 := 0;
  294. zc2 := 0;
  295. for i := 0 to 7 do
  296. begin
  297. x := i * 2;
  298. ip6w[i] := value[x] * 256 + value[x + 1];
  299. if ip6w[i] = 0 then
  300. begin
  301. include(zr2, i);
  302. inc(zc2);
  303. end
  304. else
  305. begin
  306. if zc1 < zc2 then
  307. begin
  308. zc1 := zc2;
  309. zr1 := zr2;
  310. zc2 := 0;
  311. zr2 := [];
  312. end;
  313. end;
  314. end;
  315. if zc1 < zc2 then
  316. begin
  317. zr1 := zr2;
  318. end;
  319. SetLength(Result, 8*5-1);
  320. SetLength(Result, 0);
  321. have_skipped := false;
  322. for i := 0 to 7 do
  323. begin
  324. if not(i in zr1) then
  325. begin
  326. if have_skipped then
  327. begin
  328. if Result = '' then
  329. Result := '::'
  330. else
  331. Result := Result + ':';
  332. have_skipped := false;
  333. end;
  334. Result := Result + IntToHex(Ip6w[i], 1) + ':';
  335. end
  336. else
  337. begin
  338. have_skipped := true;
  339. end;
  340. end;
  341. if have_skipped then
  342. if Result = '' then
  343. Result := '::0'
  344. else
  345. Result := Result + ':';
  346. if Result = '' then
  347. Result := '::0';
  348. if not (7 in zr1) then
  349. SetLength(Result, Length(Result)-1);
  350. Result := LowerCase(result);
  351. end;
  352. {==============================================================================}
  353. function ReverseIP(Value: AnsiString): AnsiString;
  354. var
  355. x: Integer;
  356. begin
  357. Result := '';
  358. repeat
  359. x := LastDelimiter('.', Value);
  360. Result := Result + '.' + Copy(Value, x + 1, Length(Value) - x);
  361. Delete(Value, x, Length(Value) - x + 1);
  362. until x < 1;
  363. if Length(Result) > 0 then
  364. if Result[1] = '.' then
  365. Delete(Result, 1, 1);
  366. end;
  367. {==============================================================================}
  368. function ReverseIP6(Value: AnsiString): AnsiString;
  369. var
  370. ip6: TIp6bytes;
  371. n: integer;
  372. x, y: integer;
  373. begin
  374. ip6 := StrToIP6(Value);
  375. x := ip6[15] div 16;
  376. y := ip6[15] mod 16;
  377. Result := IntToHex(y, 1) + '.' + IntToHex(x, 1);
  378. for n := 14 downto 0 do
  379. begin
  380. x := ip6[n] div 16;
  381. y := ip6[n] mod 16;
  382. Result := Result + '.' + IntToHex(y, 1) + '.' + IntToHex(x, 1);
  383. end;
  384. end;
  385. {==============================================================================}
  386. end.