source: trunk/Packages/synapse/synaip.pas

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