source: trunk/Packages/synapse/source/lib/synaip.pas

Last change on this file was 2, checked in by chronos, 13 years ago
  • Přidáno: Základní kostra projektu.
  • Přidáno: Knihovna synapse.
File size: 12.0 KB
Line 
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
45{:@abstract(IP adress support procedures and functions)}
46
47{$IFDEF FPC}
48 {$MODE DELPHI}
49{$ENDIF}
50{$Q-}
51{$R-}
52{$H+}
53
54{$IFDEF UNICODE}
55 {$WARN IMPLICIT_STRING_CAST OFF}
56 {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
57 {$WARN SUSPICIOUS_TYPECAST OFF}
58{$ENDIF}
59
60unit synaip;
61
62interface
63
64uses
65 SysUtils, SynaUtil;
66
67type
68{:binary form of IPv6 adress (for string conversion routines)}
69 TIp6Bytes = array [0..15] of Byte;
70{:binary form of IPv6 adress (for string conversion routines)}
71 TIp6Words = array [0..7] of Word;
72
73{:Returns @TRUE, if "Value" is a valid IPv4 address. Cannot be a symbolic Name!}
74function IsIP(const Value: string): Boolean;
75
76{:Returns @TRUE, if "Value" is a valid IPv6 address. Cannot be a symbolic Name!}
77function IsIP6(const Value: string): Boolean;
78
79{:Returns a string with the "Host" ip address converted to binary form.}
80function IPToID(Host: string): Ansistring;
81
82{:Convert IPv6 address from their string form to binary byte array.}
83function StrToIp6(value: string): TIp6Bytes;
84
85{:Convert IPv6 address from binary byte array to string form.}
86function Ip6ToStr(value: TIp6Bytes): string;
87
88{:Convert IPv4 address from their string form to binary.}
89function StrToIp(value: string): integer;
90
91{:Convert IPv4 address from binary to string form.}
92function IpToStr(value: integer): string;
93
94{:Convert IPv4 address to reverse form.}
95function ReverseIP(Value: AnsiString): AnsiString;
96
97{:Convert IPv6 address to reverse form.}
98function ReverseIP6(Value: AnsiString): AnsiString;
99
100{:Expand short form of IPv6 address to long form.}
101function ExpandIP6(Value: AnsiString): AnsiString;
102
103
104implementation
105
106{==============================================================================}
107
108function IsIP(const Value: string): Boolean;
109var
110 TempIP: string;
111 function ByteIsOk(const Value: string): Boolean;
112 var
113 x, n: integer;
114 begin
115 x := StrToIntDef(Value, -1);
116 Result := (x >= 0) and (x < 256);
117 // X may be in correct range, but value still may not be correct value!
118 // i.e. "$80"
119 if Result then
120 for n := 1 to length(Value) do
121 if not (AnsiChar(Value[n]) in ['0'..'9']) then
122 begin
123 Result := False;
124 Break;
125 end;
126 end;
127begin
128 TempIP := Value;
129 Result := False;
130 if not ByteIsOk(Fetch(TempIP, '.')) then
131 Exit;
132 if not ByteIsOk(Fetch(TempIP, '.')) then
133 Exit;
134 if not ByteIsOk(Fetch(TempIP, '.')) then
135 Exit;
136 if ByteIsOk(TempIP) then
137 Result := True;
138end;
139
140{==============================================================================}
141
142function IsIP6(const Value: string): Boolean;
143var
144 TempIP: string;
145 s,t: string;
146 x: integer;
147 partcount: integer;
148 zerocount: integer;
149 First: Boolean;
150begin
151 TempIP := Value;
152 Result := False;
153 if Value = '::' then
154 begin
155 Result := True;
156 Exit;
157 end;
158 partcount := 0;
159 zerocount := 0;
160 First := True;
161 while tempIP <> '' do
162 begin
163 s := fetch(TempIP, ':');
164 if not(First) and (s = '') then
165 Inc(zerocount);
166 First := False;
167 if zerocount > 1 then
168 break;
169 Inc(partCount);
170 if s = '' then
171 Continue;
172 if partCount > 8 then
173 break;
174 if tempIP = '' then
175 begin
176 t := SeparateRight(s, '%');
177 s := SeparateLeft(s, '%');
178 x := StrToIntDef('$' + t, -1);
179 if (x < 0) or (x > $ffff) then
180 break;
181 end;
182 x := StrToIntDef('$' + s, -1);
183 if (x < 0) or (x > $ffff) then
184 break;
185 if tempIP = '' then
186 if not((PartCount = 1) and (ZeroCount = 0)) then
187 Result := True;
188 end;
189end;
190
191{==============================================================================}
192function IPToID(Host: string): Ansistring;
193var
194 s: string;
195 i, x: Integer;
196begin
197 Result := '';
198 for x := 0 to 3 do
199 begin
200 s := Fetch(Host, '.');
201 i := StrToIntDef(s, 0);
202 Result := Result + AnsiChar(i);
203 end;
204end;
205
206{==============================================================================}
207
208function StrToIp(value: string): integer;
209var
210 s: string;
211 i, x: Integer;
212begin
213 Result := 0;
214 for x := 0 to 3 do
215 begin
216 s := Fetch(value, '.');
217 i := StrToIntDef(s, 0);
218 Result := (256 * Result) + i;
219 end;
220end;
221
222{==============================================================================}
223
224function IpToStr(value: integer): string;
225var
226 x1, x2: word;
227 y1, y2: byte;
228begin
229 Result := '';
230 x1 := value shr 16;
231 x2 := value and $FFFF;
232 y1 := x1 div $100;
233 y2 := x1 mod $100;
234 Result := inttostr(y1) + '.' + inttostr(y2) + '.';
235 y1 := x2 div $100;
236 y2 := x2 mod $100;
237 Result := Result + inttostr(y1) + '.' + inttostr(y2);
238end;
239
240{==============================================================================}
241
242function ExpandIP6(Value: AnsiString): AnsiString;
243var
244 n: integer;
245 s: ansistring;
246 x: integer;
247begin
248 Result := '';
249 if value = '' then
250 exit;
251 x := countofchar(value, ':');
252 if x > 7 then
253 exit;
254 if value[1] = ':' then
255 value := '0' + value;
256 if value[length(value)] = ':' then
257 value := value + '0';
258 x := 8 - x;
259 s := '';
260 for n := 1 to x do
261 s := s + ':0';
262 s := s + ':';
263 Result := replacestring(value, '::', s);
264end;
265{==============================================================================}
266
267function StrToIp6(Value: string): TIp6Bytes;
268var
269 IPv6: TIp6Words;
270 Index: Integer;
271 n: integer;
272 b1, b2: byte;
273 s: string;
274 x: integer;
275begin
276 for n := 0 to 15 do
277 Result[n] := 0;
278 for n := 0 to 7 do
279 Ipv6[n] := 0;
280 Index := 0;
281 Value := ExpandIP6(value);
282 if value = '' then
283 exit;
284 while Value <> '' do
285 begin
286 if Index > 7 then
287 Exit;
288 s := fetch(value, ':');
289 if s = '@' then
290 break;
291 if s = '' then
292 begin
293 IPv6[Index] := 0;
294 end
295 else
296 begin
297 x := StrToIntDef('$' + s, -1);
298 if (x > 65535) or (x < 0) then
299 Exit;
300 IPv6[Index] := x;
301 end;
302 Inc(Index);
303 end;
304 for n := 0 to 7 do
305 begin
306 b1 := ipv6[n] div 256;
307 b2 := ipv6[n] mod 256;
308 Result[n * 2] := b1;
309 Result[(n * 2) + 1] := b2;
310 end;
311end;
312
313{==============================================================================}
314//based on routine by the Free Pascal development team
315function Ip6ToStr(value: TIp6Bytes): string;
316var
317 i, x: byte;
318 zr1,zr2: set of byte;
319 zc1,zc2: byte;
320 have_skipped: boolean;
321 ip6w: TIp6words;
322begin
323 zr1 := [];
324 zr2 := [];
325 zc1 := 0;
326 zc2 := 0;
327 for i := 0 to 7 do
328 begin
329 x := i * 2;
330 ip6w[i] := value[x] * 256 + value[x + 1];
331 if ip6w[i] = 0 then
332 begin
333 include(zr2, i);
334 inc(zc2);
335 end
336 else
337 begin
338 if zc1 < zc2 then
339 begin
340 zc1 := zc2;
341 zr1 := zr2;
342 zc2 := 0;
343 zr2 := [];
344 end;
345 end;
346 end;
347 if zc1 < zc2 then
348 begin
349 zr1 := zr2;
350 end;
351 SetLength(Result, 8*5-1);
352 SetLength(Result, 0);
353 have_skipped := false;
354 for i := 0 to 7 do
355 begin
356 if not(i in zr1) then
357 begin
358 if have_skipped then
359 begin
360 if Result = '' then
361 Result := '::'
362 else
363 Result := Result + ':';
364 have_skipped := false;
365 end;
366 Result := Result + IntToHex(Ip6w[i], 1) + ':';
367 end
368 else
369 begin
370 have_skipped := true;
371 end;
372 end;
373 if have_skipped then
374 if Result = '' then
375 Result := '::0'
376 else
377 Result := Result + ':';
378
379 if Result = '' then
380 Result := '::0';
381 if not (7 in zr1) then
382 SetLength(Result, Length(Result)-1);
383 Result := LowerCase(result);
384end;
385
386{==============================================================================}
387function ReverseIP(Value: AnsiString): AnsiString;
388var
389 x: Integer;
390begin
391 Result := '';
392 repeat
393 x := LastDelimiter('.', Value);
394 Result := Result + '.' + Copy(Value, x + 1, Length(Value) - x);
395 Delete(Value, x, Length(Value) - x + 1);
396 until x < 1;
397 if Length(Result) > 0 then
398 if Result[1] = '.' then
399 Delete(Result, 1, 1);
400end;
401
402{==============================================================================}
403function ReverseIP6(Value: AnsiString): AnsiString;
404var
405 ip6: TIp6bytes;
406 n: integer;
407 x, y: integer;
408begin
409 ip6 := StrToIP6(Value);
410 x := ip6[15] div 16;
411 y := ip6[15] mod 16;
412 Result := IntToHex(y, 1) + '.' + IntToHex(x, 1);
413 for n := 14 downto 0 do
414 begin
415 x := ip6[n] div 16;
416 y := ip6[n] mod 16;
417 Result := Result + '.' + IntToHex(y, 1) + '.' + IntToHex(x, 1);
418 end;
419end;
420
421{==============================================================================}
422end.
Note: See TracBrowser for help on using the repository browser.