1 {******************************************************************}
2 {* IPUTILS.PAS - Miscellaneous Constants, Types, and Routines *}
3 {******************************************************************}
4
5 (* ***** BEGIN LICENSE BLOCK *****
6 * Version: MPL 1.1
7 *
8 * The contents of this file are subject to the Mozilla Public License Version
9 * 1.1 (the "License"); you may not use this file except in compliance with
10 * the License. You may obtain a copy of the License at
11 * http://www.mozilla.org/MPL/
12 *
13 * Software distributed under the License is distributed on an "AS IS" basis,
14 * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
15 * for the specific language governing rights and limitations under the
16 * License.
17 *
18 * The Original Code is TurboPower Internet Professional
19 *
20 * The Initial Developer of the Original Code is
21 * TurboPower Software
22 *
23 * Portions created by the Initial Developer are Copyright (C) 2000-2002
24 * the Initial Developer. All Rights Reserved.
25 *
26 * Contributor(s):
27 *
28 * ***** END LICENSE BLOCK ***** *)
29
30 { Global defines potentially affecting this unit }
31 {$I IPDEFINE.INC}
32
33 unit IpUtils;
34
35 interface
36
37 uses
38 SysUtils, Classes, Registry,
39 LCLType, LCLIntf, LMessages, Controls, ComCtrls,
40 GraphType, LazFileUtils, LazStringUtils;
41
42 const
43 InternetProfessionalVersion = 1.15;
44 sShortVersion = 'v%.2f';
45
46 IpMsgBase = WM_USER + $0E90;
47
48 CM_IPASYNCRESULT = IpMsgBase + 0;
49 CM_IPSOCKMESSAGE = IpMsgBase + 1;
50 CM_IPSOCKETSTATUS = IpMsgBase + 2;
51 CM_IPFREESOCKET = IpMsgBase + 3;
52 CM_IPLINEMESSAGE = IpMsgBase + 4;
53 CM_IPTERMDATA = IpMsgBase + 5;
54 CM_IPTERMRESIZE = IpMsgBase + 6;
55 CM_IPICMPECHO = IpMsgBase + 7;
56 CM_IPHTTPGETREQUEST = IpMsgBase + 8;
57 CM_IPTIMESERVER = IpMsgBase + 9;
58 CM_IPTIMECLIENT = IpMsgBase + 10;
59 CM_IPSNTPCLIENT = IpMsgBase + 11;
60 CM_IPFTPREPLY = IpMsgBase + 12;
61 CM_IPFTPSTATUS = IpMsgBase + 13;
62 CM_IPFTPERROR = IpMsgBase + 14;
63 CM_IPFTPTIMEOUT = IpMsgBase + 15;
64 CM_IPTERMFORCESIZE = IpMsgBase + 16;
65 CM_IPTERMSTUFF = IpMsgBase + 17;
66 CM_IPRASSTATUS = IpMsgBase + 18;
67 CM_IPFINWHOSERVER = IpMsgBase + 19;
68 CM_IPUTILITYSERVER = IpMsgBase + 20;
69 CM_IPSMTPEVENT = IpMsgBase + 21;
70 CM_IPPOP3EVENT = IpMsgBase + 22;
71 CM_IPNNTPEVENT = IpMsgBase + 23;
72 CM_IPHOTINVOKE = IpMsgBase + 24;
73
74 type
75 TIpLineTerminator = (ltNone, ltCR, ltLF, ltCRLF, ltOther);
76
77 TIpCRCByteArray = array[0..Pred(High(LongInt))] of Byte;
78
79 TIpCharArray = array[0..Pred(High(LongInt))] of AnsiChar;
80
81 TIpMD5StateArray = array[0..3] of DWORD;
82 TIpMD5CountArray = array[0..1] of DWORD;
83
84 TIpMD5ByteBuf = array[0..63] of Byte;
85 TIpMD5LongBuf = array[0..15] of DWORD;
86
87 TIpMD5Context = record
88 State : TIpMD5StateArray;
89 Count : TIpMD5CountArray;
90 case Integer of
91 0 : (ByteBuf : TIpMD5ByteBuf);
92 1 : (LongBuf : TIpMD5LongBuf);
93 end;
94
95 TIpMD5Digest = array[0..15] of Byte;
96
97 EIpBaseException = class(Exception);
98
99 EIpAccessException = class(EIpBaseException);
100 EIpHtmlException = class(EIpBaseException);
101
102 TIpBaseAccess = class
103 private
104 baPropCS : TCriticalSection;
105 public
106 constructor Create; virtual;
107 destructor Destroy; override;
108 procedure LockProperties;
109 procedure UnlockProperties;
110 end;
111
112 TIpBasePersistent = class(TPersistent)
113 private
114 bpPropCS : TCriticalSection;
115 public
116 constructor Create; virtual;
117 destructor Destroy; override;
118 procedure LockProperties;
119 procedure UnlockProperties;
120 end;
121
122 TIpComponentClass = class of TIpBaseComponent;
123
124 TIpBaseComponent = class(TComponent)
125 protected
GetVersionnull126 function GetVersion : string;
127 procedure SetVersion(const Value : string);
128 public
GetLogStringnull129 class function GetLogString(const S, D1, D2, D3 : DWORD) : string; virtual;
130 published
131 property Version : string
132 read GetVersion write SetVersion stored False;
133 end;
134
135 TIpBaseWinControl = class(TWinControl)
136 protected
GetVersionnull137 function GetVersion : string;
138 procedure SetVersion(const Value : string);
139 published
140 property Version : string read GetVersion write SetVersion stored False;
141 end;
142
143 { Misc utility routines }
InClassAnull144 function InClassA(Addr : LongInt) : Boolean;
InClassBnull145 function InClassB(Addr : LongInt) : Boolean;
InClassCnull146 function InClassC(Addr : LongInt) : Boolean;
InClassDnull147 function InClassD(Addr : LongInt) : Boolean;
InMulticastnull148 function InMulticast(Addr : LongInt) : Boolean;
149
IpCharCountnull150 function IpCharCount(const Buffer; BufSize : DWORD; C : AnsiChar) : DWORD;
IpCompStructnull151 function IpCompStruct(const S1, S2; Size : Cardinal) : Integer;
IpMaxIntnull152 function IpMaxInt(A, B : Integer) : Integer;
IpMinIntnull153 function IpMinInt(A, B : Integer) : Integer;
154 procedure IpSafeFree(var Obj);
IpShortVersionnull155 function IpShortVersion : string;
156
157 { CRC routines }
InternetSumPrimnull158 function InternetSumPrim(var Data; DataSize, CurCrc : DWORD) : DWORD;
InternetSumOfStreamnull159 function InternetSumOfStream(Stream : TStream; CurCrc : DWORD) : DWORD;
InternetSumOfFilenull160 function InternetSumOfFile(const FileName : string) : DWORD;
MD5SumOfFilenull161 function MD5SumOfFile(const FileName : string) : string;
MD5SumOfStreamnull162 function MD5SumOfStream(Stream : TStream) : string;
MD5SumOfStreamDigestnull163 function MD5SumOfStreamDigest(Stream : TStream) : TIpMD5Digest;
MD5SumOfStringnull164 function MD5SumOfString(const S : string) : string;
MD5SumOfStringDigestnull165 function MD5SumOfStringDigest(const S : string) : TIpMD5Digest;
166
SafeYieldnull167 function SafeYield : LongInt; {-Allow other processes a chance to run}
AllTrimSpacesnull168 function AllTrimSpaces(Strng: string) : string;
CharPosnull169 function CharPos(C: AnsiChar; const S : string): Integer;
CharPosIdxnull170 function CharPosIdx(C: AnsiChar; const S : string; Idx: Integer): Integer;
NthCharPosnull171 function NthCharPos(C: AnsiChar; const S : string; Nth: Integer): Integer;
RCharPosnull172 function RCharPos(C: AnsiChar; const S : string): Integer;
RCharPosIdxnull173 function RCharPosIdx(C: AnsiChar; const S : string; Idx: Integer): Integer;
RNthCharPosnull174 function RNthCharPos(C: AnsiChar; const S : string; Nth: Integer): Integer;
RPosnull175 function RPos(const Substr: string; const S: string): Integer;
PosIdxnull176 function PosIdx(const SubStr, S: string; Idx: Integer): Integer;
177
178
179 {address handling}
180 type
181 CharSet = set of AnsiChar;
182
183 { Structure to hold pieces of a URI (Uniform Resource Identifier) }
184 { field names are derived from terminology used in: }
185 { RFC-2396 "Uniform Resource Identifiers (URI): Generic Syntax" }
186
187 TIpAddrRec = record
188 Scheme : string;
189 UserName : string;
190 Password : string;
191 Authority : string;
192 Port : string;
193 Path : string;
194 Fragment : string;
195 Query : string;
196 QueryDelim : AnsiChar;
197 end;
198
199 procedure Initialize(var AddrRec: TIpAddrRec);
200 procedure Finalize(var AddrRec: TIpAddrRec);
201
ExtractEntityNamenull202 function ExtractEntityName(const NamePath: string): string;
ExtractEntityPathnull203 function ExtractEntityPath(const NamePath: string): string;
IpParseURLnull204 function IpParseURL(const URL : string; var Rslt : TIpAddrRec) : Boolean;
BuildURLnull205 function BuildURL(const OldURL, NewURL: string): string;
PutEscapesnull206 function PutEscapes(const S : string; EscapeSet : CharSet) : string;
RemoveEscapesnull207 function RemoveEscapes(const S : string; EscapeSet : CharSet) : string;
208 procedure SplitParams(const Parms : string; Dest : TStrings);
NetToDOSPathnull209 function NetToDOSPath(const PathStr : string) : string;
DOSToNetPathnull210 function DOSToNetPath(const PathStr : string) : string;
211 procedure SplitHttpResponse(const S : string; var V, MsgID, Msg: string);
212 procedure FieldFix(Fields : TStrings);
AppendSlashnull213 function AppendSlash(APath : string) : string;
RemoveSlashnull214 function RemoveSlash(APath : string) : string;
GetParentPathnull215 function GetParentPath(const Path : string) : string;
216
217 { File/Directory Stuff }
GetLocalContentnull218 function GetLocalContent(const TheFileName: string): string;
DirExistsnull219 function DirExists(Dir : string): Boolean;
GetTemporaryFilenull220 function GetTemporaryFile(const Path : string) : string;
GetTemporaryPathnull221 function GetTemporaryPath: string;
AppendBackSlashnull222 function AppendBackSlash(APath : string) : string;
RemoveBackSlashnull223 function RemoveBackSlash(APath: string) : string;
224
225 { date stuff }
226
227 { convert Net date (as spec'ed in RFC 2616) to Delphi TDateTime }
INetDateStrToDateTimenull228 function INetDateStrToDateTime(const DateStr: string): TDateTime;
229 { convert Delphi TDateTime to Net date (as spec'ed in RFC 2616) }
DateTimeToINetDateTimeStrnull230 function DateTimeToINetDateTimeStr(DateTime: TDateTime): string;
231 { return the current local TimeZone "bias" in minutes from UTC (GMT) }
TimeZoneBiasnull232 function TimeZoneBias : Integer;
233
234 procedure SplitCookieFields(const Data: string; Fields: TStrings);
235
236 implementation
237 { misc utility routines }
238
239 { Allow other processes a chance to run }
SafeYieldnull240 function SafeYield : LongInt;
241 begin
242 SafeYield := 0;
243 writeln('ToDo: IpUtils.SafeYield');
244 (*
245 var
246 Msg : TMsg;
247 if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then begin
248 if Msg.Message = wm_Quit then
249 {Re-post quit message so main message loop will terminate}
250 PostQuitMessage(Msg.WParam)
251 else begin
252 TranslateMessage(Msg);
253 DispatchMessage(Msg);
254 end;
255 {Return message so caller can act on message if necessary}
256 SafeYield := MAKELONG(Msg.Message, Msg.hwnd);
257 *)
258 end;
259
260 { Trim leading and trailing spaces from a string }
AllTrimSpacesnull261 function AllTrimSpaces(Strng: string) : string;
262 var
263 StrStart, StrEnd: Cardinal;
264 begin
265 StrEnd := Length(Strng);
266 if StrEnd = 0 then begin { string is empty }
267 Result := '';
268 Exit;
269 end;
270
271 while (StrEnd > 0 ) and (Strng[StrEnd] = ' ') do begin
272 { find last non-space character }
273 Dec(StrEnd);
274 end;
275
276 if StrEnd = 0 then begin { string was all spaces }
277 Result := '';
278 Exit;
279 end;
280
281 StrStart := 1;
282 while (StrStart < StrEnd) and (Strng[StrStart] = ' ') do begin
283 { find first non-space character }
284 Inc(StrStart);
285 end;
286
287 Result := Copy(Strng, StrStart, StrEnd - StrStart + 1);
288 end;
289
290 { Find leftmost occurrence of character C in string S }
291 {* If C not found returns 0 }
CharPosnull292 function CharPos(C: AnsiChar; const S : string): Integer;
293 var
294 i : Integer;
295 begin
296 for i := 1 to length(S) do
297 if (S[i] = C) then begin
298 Result := i;
299 Exit;
300 end;
301 Result := 0;
302 end;
303
304 { Find leftmost occurrence of character C in string S past location Idx }
305 { * If C not found returns 0 }
CharPosIdxnull306 function CharPosIdx(C: AnsiChar; const S : string; Idx: Integer): Integer;
307 var
308 Len : Integer;
309 begin
310 Len := Length(S);
311 if (Idx > Len) or (Idx < 1) then begin
312 Result := 0;
313 Exit;
314 end;
315
316 Result := Idx;
317 while (Result <= Len) and (S[Result] <> C) do
318 Inc(Result);
319 if Result > Len then
320 Result := 0;
321 end;
322
323 { Find Nth occurrence of character C in string S }
324 { * If C not found returns 0 }
NthCharPosnull325 function NthCharPos(C: AnsiChar; const S : string; Nth: Integer): Integer;
326 var
327 Len, CharCt : Integer;
328 begin
329 if Nth <= 0 then begin
330 Result := 0;
331 Exit;
332 end;
333 Len := Length(S);
334 CharCt := 0;
335 Result := 1;
336
337 while (Result <= Len) and (CharCt < Nth) do begin
338 if S[Result] = C then
339 Inc(CharCt);
340 if CharCt < Nth then
341 Inc(Result);
342 end;
343 if Result > Len then
344 Result := 0;
345 end;
346
347 { Find rightmost occurrence of character C in string S }
348 { * If C not found returns 0 }
RCharPosnull349 function RCharPos(C: AnsiChar; const S : string): Integer;
350 begin
351 Result := Length(S);
352 while (Result > 0) and (S[Result] <> C) do
353 Dec(Result);
354 if (Result < 0) then
355 Result := 0;
356 end;
357
358 { Find rightmost occurrence of character C in string S prior to location Idx }
359 { * If C not found returns 0 }
RCharPosIdxnull360 function RCharPosIdx(C: AnsiChar; const S : string; Idx: Integer): Integer;
361 begin
362 Result := Length(S);
363
364 if (Idx > Result) or (Idx < 1) then begin
365 Result := 0;
366 Exit;
367 end;
368
369 Result := Idx;
370 while (Result > 0) and (S[Result] <> C) do
371 Dec(Result);
372 if (Result < 0) then
373 Result := 0;
374 end;
375
376 { Find Nth from the rightmost occurrence of character C in string S }
377 { * If C not found returns 0 }
RNthCharPosnull378 function RNthCharPos(C: AnsiChar; const S : string; Nth: Integer): Integer;
379 var
380 CharCt : Integer;
381 begin
382 if Nth <= 0 then begin
383 Result := 0;
384 Exit;
385 end;
386
387 CharCt := 0;
388 Result := Length(S);
389 while (Result > 0) and (CharCt < Nth) do begin
390 if S[Result] = C then
391 Inc(CharCt);
392 if CharCt < Nth then
393 Dec(Result);
394 end;
395 if (Result < 0) then
396 Result := 0;
397 end;
398
399 { Complement to RTL Pos() function, finds RIGHTmost }
400 { instance of a substring (SubStr) within a string (S) }
401 { * If Substr not found returns 0 }
RPosnull402 function RPos(const Substr: string; const S: string): Integer;
403 var
404 SL, i : Integer;
405 begin
406 SL := Length(Substr);
407 i := Length(S);
408 if (Substr = '') or (S = '') or (SL > i) then begin
409 Result := 0;
410 Exit;
411 end;
412
413 while i >= SL do begin
414 if S[i] = Substr[SL] then begin
415 if Copy(S, i - SL + 1, SL) = Substr then begin
416 Result := i - SL + 1;
417 Exit;
418 end;
419 end;
420 Dec(i);
421 end;
422 Result := i;
423 end;
424
425 { Find location of first occurrence of a substring (SubStr) in a string (S) }
426 { past a particular index (Idx) }
427 { * Result is relative to the start of the entire original string }
428 { * Returns 0 if substring not found }
PosIdxnull429 function PosIdx(const SubStr, S: string; Idx: Integer): Integer;
430 var
431 Temp : string;
432 begin
433 Temp := Copy(S, Idx, Length(S) - Idx - 1);
434 Result := Pos(SubStr, Temp);
435 if Result > 0 then
436 Result := Result + (Idx - 1);
437 end;
438
439 procedure Initialize(var AddrRec: TIpAddrRec);
440 begin
441 AddrRec.QueryDelim:=#0;
442 end;
443
444 procedure Finalize(var AddrRec: TIpAddrRec);
445 begin
446 with AddrRec do begin
447 Scheme :='';
448 UserName :='';
449 Password :='';
450 Authority :='';
451 Port :='';
452 Path :='';
453 Fragment :='';
454 Query :='';
455 end;
456 end;
457
458 const
459 CrcBufSize = 2048;
460 CrcFileMode = fmOpenRead or fmShareDenyWrite;
461
462 { Returns True if a given address is a Class A address }
InClassAnull463 function InClassA(Addr : LongInt) : Boolean;
464 begin
465 Result := (Addr and $80000000) = 0;
466 end;
467
468 { Returns True if a given address is a Class B address }
InClassBnull469 function InClassB(Addr : LongInt) : Boolean;
470 begin
471 Result := (Cardinal(Addr) and $C0000000) = $80000000;
472 end;
473
474 { Returns True if a given address is a Class C address }
InClassCnull475 function InClassC(Addr : LongInt) : Boolean;
476 begin
477 Result := (Cardinal(Addr) and $E0000000) = $C0000000;
478 end;
479
480 { Returns True if a given address is a Class D address }
InClassDnull481 function InClassD(Addr : LongInt) : Boolean;
482 begin
483 Result := (Cardinal(Addr) and $F0000000) = $E0000000;
484 end;
485
486 { Returns True if a given address is a multicast address }
InMulticastnull487 function InMulticast(Addr : LongInt) : Boolean;
488 begin
489 Result := InClassD(Addr);
490 end;
491
492 { Calculates the Internet Checksum of a block }
InternetSumPrimnull493 function InternetSumPrim(var Data; DataSize, CurCrc : DWORD) : DWORD;
494 var
495 I : Integer;
496 begin
497 Result := CurCrc;
498 if DataSize = 0 then Exit;
499 for I := 0 to (DataSize - 1) do begin
500 if Odd(I) then
501 Result := Result + (cardinal(TIpCRCByteArray(Data)[I]) shl 8)
502 else
503 Result := Result + TIpCRCByteArray(Data)[I];
504 end;
505 Result := (not((Result and $FFFF) + (Result shr 16))) and $FFFF;
506 end;
507
508 { Calculates the Internet Checksum of a stream }
InternetSumOfStreamnull509 function InternetSumOfStream(Stream : TStream; CurCrc : DWORD) : DWORD;
510 var
511 BufArray : array[0..(CrcBufSize-1)] of Byte;
512 Res : LongInt;
513 begin
514 {Initialize Crc}
515 Result := CurCrc;
516 repeat
517 Res := Stream.Read(BufArray, CrcBufSize);
518 Result := InternetSumPrim(BufArray, Res, Result);
519 until (Res <> CrcBufSize);
520 end;
521
522 { Calculates the Internet Checksum of a file }
InternetSumOfFilenull523 function InternetSumOfFile(const FileName : string) : DWORD;
524 var
525 FileSt : TFileStream;
526 begin
527 FileSt := TFileStream.Create(FileName, CrcFileMode);
528 try
529 Result := InternetSumOfStream(FileSt, 0);
530 finally
531 FileSt.Free;
532 end;
533 end;
534
535 { Initialize the MD5 context record }
536 procedure MD5Init(var Context : TIpMD5Context);
537 begin
538 { Zero out context }
539 FillChar(Context, SizeOf(TIpMD5Context), #0);
540
541 { Load magic initialization constants }
542 Context.State[0] := DWORD($67452301);
543 Context.State[1] := DWORD($efcdab89);
544 Context.State[2] := DWORD($98badcfe);
545 Context.State[3] := DWORD($10325476);
546 end;
547
548 { MD5 Basic Transformation -- Transforms State based on Buf }
549 procedure MD5Transform(var State : TIpMD5StateArray; const Buf : TIpMD5LongBuf);
550 const
551 S11 = 7; S12 = 12; S13 = 17; S14 = 22; S21 = 5; S22 = 9; S23 = 14;
552 S24 = 20; S31 = 4; S32 = 11; S33 = 16; S34 = 23; S41 = 6; S42 = 10;
553 S43 = 15; S44 = 21;
554 var
555 a, b, c, d : DWORD;
556
557 { Round 1 processing }
558 procedure FF(var W : DWORD; X, Y, Z : DWORD; S : Byte; Data : DWORD);
559 begin
560 Inc(W, (Z xor (X and (Y xor Z))) + Data);
561 W := (W shl S) or (W shr (32 - S));
562 Inc(W, X);
563 end;
564
565 { Round 2 processing }
566 procedure GG(var W : DWORD; X, Y, Z : DWORD; S : Byte; Data : DWORD);
567 begin
568 Inc(W, (Y xor (Z and (X xor Y))) + Data);
569 W := (W shl S) or (W shr (32 - S));
570 Inc(W, X);
571 end;
572
573 { Round 3 processing }
574 procedure HH(var W : DWORD; X, Y, Z : DWORD; S : Byte; Data : DWORD);
575 begin
576 Inc(W, (X xor Y xor Z) + Data);
577 W := (W shl S) or (W shr (32 - S));
578 Inc(W, X);
579 end;
580
581 { Round 4 processing }
582 procedure II(var W : DWORD; X, Y, Z : DWORD; S : Byte; Data : DWORD);
583 begin
584 Inc(W, (Y xor (X or not Z)) + Data);
585 W := (W shl S) or (W shr (32 - S));
586 Inc(W, X);
587 end;
588
589 begin
590 a := State[0];
591 b := State[1];
592 c := State[2];
593 d := State[3];
594
595 { Round 1 }
596 FF(a, b, c, d, S11, Buf[ 0] + DWORD($d76aa478)); { 1 }
597 FF(d, a, b, c, S12, Buf[ 1] + DWORD($e8c7b756)); { 2 }
598 FF(c, d, a, b, S13, Buf[ 2] + DWORD($242070db)); { 3 }
599 FF(b, c, d, a, S14, Buf[ 3] + DWORD($c1bdceee)); { 4 }
600 FF(a, b, c, d, S11, Buf[ 4] + DWORD($f57c0faf)); { 5 }
601 FF(d, a, b, c, S12, Buf[ 5] + DWORD($4787c62a)); { 6 }
602 FF(c, d, a, b, S13, Buf[ 6] + DWORD($a8304613)); { 7 }
603 FF(b, c, d, a, S14, Buf[ 7] + DWORD($fd469501)); { 8 }
604 FF(a, b, c, d, S11, Buf[ 8] + DWORD($698098d8)); { 9 }
605 FF(d, a, b, c, S12, Buf[ 9] + DWORD($8b44f7af)); { 10 }
606 FF(c, d, a, b, S13, Buf[10] + DWORD($ffff5bb1)); { 11 }
607 FF(b, c, d, a, S14, Buf[11] + DWORD($895cd7be)); { 12 }
608 FF(a, b, c, d, S11, Buf[12] + DWORD($6b901122)); { 13 }
609 FF(d, a, b, c, S12, Buf[13] + DWORD($fd987193)); { 14 }
610 FF(c, d, a, b, S13, Buf[14] + DWORD($a679438e)); { 15 }
611 FF(b, c, d, a, S14, Buf[15] + DWORD($49b40821)); { 16 }
612
613 { Round 2 }
614 GG(a, b, c, d, S21, Buf[ 1] + DWORD($f61e2562)); { 17 }
615 GG(d, a, b, c, S22, Buf[ 6] + DWORD($c040b340)); { 18 }
616 GG(c, d, a, b, S23, Buf[11] + DWORD($265e5a51)); { 19 }
617 GG(b, c, d, a, S24, Buf[ 0] + DWORD($e9b6c7aa)); { 20 }
618 GG(a, b, c, d, S21, Buf[ 5] + DWORD($d62f105d)); { 21 }
619 GG(d, a, b, c, S22, Buf[10] + DWORD($02441453)); { 22 }
620 GG(c, d, a, b, S23, Buf[15] + DWORD($d8a1e681)); { 23 }
621 GG(b, c, d, a, S24, Buf[ 4] + DWORD($e7d3fbc8)); { 24 }
622 GG(a, b, c, d, S21, Buf[ 9] + DWORD($21e1cde6)); { 25 }
623 GG(d, a, b, c, S22, Buf[14] + DWORD($c33707d6)); { 26 }
624 GG(c, d, a, b, S23, Buf[ 3] + DWORD($f4d50d87)); { 27 }
625 GG(b, c, d, a, S24, Buf[ 8] + DWORD($455a14ed)); { 28 }
626 GG(a, b, c, d, S21, Buf[13] + DWORD($a9e3e905)); { 29 }
627 GG(d, a, b, c, S22, Buf[ 2] + DWORD($fcefa3f8)); { 30 }
628 GG(c, d, a, b, S23, Buf[ 7] + DWORD($676f02d9)); { 31 }
629 GG(b, c, d, a, S24, Buf[12] + DWORD($8d2a4c8a)); { 32 }
630
631 { Round 3 }
632 HH(a, b, c, d, S31, Buf[ 5] + DWORD($fffa3942)); { 33 }
633 HH(d, a, b, c, S32, Buf[ 8] + DWORD($8771f681)); { 34 }
634 HH(c, d, a, b, S33, Buf[11] + DWORD($6d9d6122)); { 35 }
635 HH(b, c, d, a, S34, Buf[14] + DWORD($fde5380c)); { 36 }
636 HH(a, b, c, d, S31, Buf[ 1] + DWORD($a4beea44)); { 37 }
637 HH(d, a, b, c, S32, Buf[ 4] + DWORD($4bdecfa9)); { 38 }
638 HH(c, d, a, b, S33, Buf[ 7] + DWORD($f6bb4b60)); { 39 }
639 HH(b, c, d, a, S34, Buf[10] + DWORD($bebfbc70)); { 40 }
640 HH(a, b, c, d, S31, Buf[13] + DWORD($289b7ec6)); { 41 }
641 HH(d, a, b, c, S32, Buf[ 0] + DWORD($eaa127fa)); { 42 }
642 HH(c, d, a, b, S33, Buf[ 3] + DWORD($d4ef3085)); { 43 }
643 HH(b, c, d, a, S34, Buf[ 6] + DWORD($04881d05)); { 44 }
644 HH(a, b, c, d, S31, Buf[ 9] + DWORD($d9d4d039)); { 45 }
645 HH(d, a, b, c, S32, Buf[12] + DWORD($e6db99e5)); { 46 }
646 HH(c, d, a, b, S33, Buf[15] + DWORD($1fa27cf8)); { 47 }
647 HH(b, c, d, a, S34, Buf[ 2] + DWORD($c4ac5665)); { 48 }
648
649 { Round 4 }
650 II(a, b, c, d, S41, Buf[ 0] + DWORD($f4292244)); { 49 }
651 II(d, a, b, c, S42, Buf[ 7] + DWORD($432aff97)); { 50 }
652 II(c, d, a, b, S43, Buf[14] + DWORD($ab9423a7)); { 51 }
653 II(b, c, d, a, S44, Buf[ 5] + DWORD($fc93a039)); { 52 }
654 II(a, b, c, d, S41, Buf[12] + DWORD($655b59c3)); { 53 }
655 II(d, a, b, c, S42, Buf[ 3] + DWORD($8f0ccc92)); { 54 }
656 II(c, d, a, b, S43, Buf[10] + DWORD($ffeff47d)); { 55 }
657 II(b, c, d, a, S44, Buf[ 1] + DWORD($85845dd1)); { 56 }
658 II(a, b, c, d, S41, Buf[ 8] + DWORD($6fa87e4f)); { 57 }
659 II(d, a, b, c, S42, Buf[15] + DWORD($fe2ce6e0)); { 58 }
660 II(c, d, a, b, S43, Buf[ 6] + DWORD($a3014314)); { 59 }
661 II(b, c, d, a, S44, Buf[13] + DWORD($4e0811a1)); { 60 }
662 II(a, b, c, d, S41, Buf[ 4] + DWORD($f7537e82)); { 61 }
663 II(d, a, b, c, S42, Buf[11] + DWORD($bd3af235)); { 62 }
664 II(c, d, a, b, S43, Buf[ 2] + DWORD($2ad7d2bb)); { 63 }
665 II(b, c, d, a, S44, Buf[ 9] + DWORD($eb86d391)); { 64 }
666
667 Inc(State[0], a);
668 Inc(State[1], b);
669 Inc(State[2], c);
670 Inc(State[3], d);
671 end;
672
673 { MD5 finalization. Ends an MD5 message-digest operation, }
674 { writing the message digest and zeroing the context. }
675 procedure MD5Final(var Digest : TIpMD5Digest; var Context : TIpMD5Context);
676 var
677 I : Integer;
678 P : Byte;
679 begin
680 I := (Context.Count[0] shr 3) and $3F;
681 Context.ByteBuf[I] := $80;
682 P := Succ(I);
683 I := Pred(64)-I;
684
685 { Pad appropriately }
686 if I < 8 then begin
687 FillChar(Context.ByteBuf[P], I, #0);
688 MD5Transform(Context.State, Context.LongBuf);
689 FillChar(Context.ByteBuf, 56, #0);
690 end else begin
691 FillChar(Context.ByteBuf[P], I-8, #0);
692 end;
693
694 { Set count in context }
695 Context.LongBuf[14] := Context.Count[0];
696 Context.LongBuf[15] := Context.Count[1];
697
698 MD5Transform(Context.State, Context.LongBuf);
699 Move(Context.State, Digest, 16);
700
701 { Zero out Context }
702 FillChar(Context, SizeOf(TIpMD5Context), #0);
703 end;
704
705 { Calculates the MD5 Digest of a block -- RFC 1321 }
706 procedure MD5SumPrim(const Data; DataSize : DWORD; var Context : TIpMD5Context);
707 var
708 I, J : DWORD;
709 begin
710 J := Context.Count[0];
711 Inc(Context.Count[0], DWORD(DataSize) shl 3);
712 if Context.Count[0] < J then
713 Inc(Context.Count[1]);
714 Inc(Context.Count[1], DataSize shr 29);
715
716 J := (J shr 3) and $3F;
717 if J <> 0 then begin
718 I := J;
719 J := 64 - J;
720 if DataSize < J then begin
721 Move(Data, Context.ByteBuf[I], DataSize);
722 Exit;
723 end;
724 Move(Data, Context.ByteBuf[I], J);
725 MD5Transform(Context.State, Context.LongBuf);
726 Dec(DataSize, J);
727 end;
728
729 I := J;
730 while DataSize >= 64 do begin
731 Move(TByteArray(Data)[I], Context.ByteBuf, 64);
732 MD5Transform(Context.State, Context.LongBuf);
733 Inc(I, 64);
734 Dec(DataSize, 64);
735 end;
736
737 Move(TByteArray(Data)[I], Context.ByteBuf, DataSize);
738 end;
739
740 { Calculates the MD5 Digest of a file }
MD5SumOfFilenull741 function MD5SumOfFile(const FileName : string) : string;
742 var
743 FileSt : TFileStream;
744 begin
745 FileSt := TFileStream.Create(FileName, CrcFileMode);
746 try
747 Result := MD5SumOfStream(FileSt);
748 finally
749 FileSt.Free;
750 end;
751 end;
752
753 { Return hex string representing MD5 digest }
HexDigestnull754 function HexDigest(Digest : TIpMD5Digest) : string;
755 const
756 HexDigits : array[0..$F] of AnsiChar = '0123456789abcdef';
757 var
758 I : Integer;
759 begin
760 SetLength(Result, 32);
761
762 { Generate output string }
763 for I := 0 to 15 do begin
764 Result[(I shl 1) + 1] := HexDigits[Digest[I] shr 4];
765 Result[(I shl 1) + 2] := HexDigits[Digest[I] and $F];
766 end;
767 end;
768
769 { Calculates the MD5 Digest of a stream }
MD5SumOfStreamnull770 function MD5SumOfStream(Stream : TStream) : string;
771 begin
772 Result := HexDigest(MD5SumOfStreamDigest(Stream));
773 end;
774
775 { Calculates the MD5 Digest of a stream }
MD5SumOfStreamDigestnull776 function MD5SumOfStreamDigest(Stream : TStream) : TIpMD5Digest;
777 var
778 BufArray : array[0..(CrcBufSize-1)] of Byte;
779 Context : TIpMD5Context;
780 I, Res : Integer;
781 begin
782 { Init Digest }
783 for I := 0 to 15 do
784 Byte(Result[I]) := Succ(I);
785
786 { Init Context }
787 MD5Init(Context);
788 repeat
789 Res := Stream.Read(BufArray, CrcBufSize);
790 MD5SumPrim(BufArray, Res, Context);
791 until (Res <> CrcBufSize);
792
793 { Finalize }
794 MD5Final(Result, Context);
795 end;
796
797 { Calculates the MD5 Digest of a string }
MD5SumOfStringnull798 function MD5SumOfString(const S : string) : string;
799 var
800 Context : TIpMD5Context;
801 Digest : TIpMD5Digest;
802 I : Byte;
803 begin
804 Result := '';
805
806 { Init Digest }
807 for I := 0 to 15 do
808 Digest[I] := Succ(I);
809
810 { Init Context }
811 MD5Init(Context);
812 MD5SumPrim(S[1], Length(S), Context);
813
814 { Finalize }
815 MD5Final(Digest, Context);
816
817 { Generate output string }
818 Result := HexDigest(Digest);
819 end;
820
821 { Calculates the MD5 Digest of a string }
MD5SumOfStringDigestnull822 function MD5SumOfStringDigest(const S : string) : TIpMD5Digest;
823 var
824 Context : TIpMD5Context;
825 I : Byte;
826 begin
827 { Init Digest }
828 for I := 0 to 15 do
829 Result[I] := Succ(I);
830
831 { Init Context }
832 MD5Init(Context);
833 MD5SumPrim(S[1], Length(S), Context);
834
835 { Finalize }
836 MD5Final(Result, Context);
837 end;
838
839 { Compares two fixed size structures }
IpCompStructnull840 function IpCompStruct(const S1, S2; Size : Cardinal) : Integer;
841 {$IFDEF CPUI386}
842 asm
843 push edi
844 push esi
845 mov esi, eax
846 mov edi, edx
847 xor eax, eax
848 or ecx, ecx
849 jz @@CSDone
850
851 repe cmpsb
852 je @@CSDone
853
854 inc eax
855 ja @@CSDone
856 or eax, -1
857
858 @@CSDone:
859 pop esi
860 pop edi
861 end;
862 {$ELSE}
863 begin
864 Result := CompareMemRange(@S1, @S2, Size);
865 end;
866 {$ENDIF}
867
IpCharCountnull868 function IpCharCount(const Buffer; BufSize : DWORD; C : AnsiChar) : DWORD;
869 register;
870 {$IFDEF CPUI386}
871 asm
872 push ebx
873 xor ebx, ebx
874 or edx, edx
875 jz @@Done
876 jmp @@5
877
878 @@Loop:
879 cmp cl, [eax+3]
880 jne @@1
881 inc ebx
882
883 @@1:
884 cmp cl, [eax+2]
885 jne @@2
886 inc ebx
887
888 @@2:
889 cmp cl, [eax+1]
890 jne @@3
891 inc ebx
892
893 @@3:
894 cmp cl, [eax+0]
895 jne @@4
896 inc ebx
897
898 @@4:
899 add eax, 4
900 sub edx, 4
901
902 @@5:
903 cmp edx, 4
904 jge @@Loop
905
906 cmp edx, 3
907 je @@1
908
909 cmp edx, 2
910 je @@2
911
912 cmp edx, 1
913 je @@3
914
915 @@Done:
916 mov eax, ebx
917 pop ebx
918 end;
919 {$ELSE}
920 var
921 X: Integer;
922 begin
923 Result := 0;
924 for X := 0 to Bufsize-1 do begin
925 if PChar(@Buffer)[X] = C then Inc(Result);
926 end;
927 end;
928 {$ENDIF}
929
930
IpMaxIntnull931 function IpMaxInt(A, B : Integer) : Integer;
932 begin
933 if A >= B then
934 Result := A
935 else
936 Result := B;
937 end;
938
IpMinIntnull939 function IpMinInt(A, B : Integer) : Integer;
940 begin
941 if A <= B then
942 Result := A
943 else
944 Result := B;
945 end;
946
947
948
949 { Thread safe object free }
950 procedure IpSafeFree(var Obj);
951 var
952 P : TObject;
953 begin
954 P := TObject(Obj);
955 { Clear reference }
956 TObject(Obj) := nil;
957 { Destroy object }
958 P.Free;
959 end;
960
961 { Return short version string }
IpShortVersionnull962 function IpShortVersion : string;
963 begin
964 Result := Format(sShortVersion, [InternetProfessionalVersion]);
965 end;
966
967 { TIpBaseAccess }
968
969 { Create instance of TIpBaseAccess }
970 constructor TIpBaseAccess.Create;
971 begin
972 inherited;
973 InitializeCriticalSection(baPropCS);
974 end;
975
976 { Destroy instance of TIpBaseAccess }
977 destructor TIpBaseAccess.Destroy;
978 begin
979 DeleteCriticalSection(baPropCS);
980 inherited;
981 end;
982
983 { Enters TIpBaseAccess critical section }
984 procedure TIpBaseAccess.LockProperties;
985 begin
986 if IsMultiThread then
987 EnterCriticalSection(baPropCS);
988 end;
989
990 { Leaves TIpBaseAccess critical section }
991 procedure TIpBaseAccess.UnlockProperties;
992 begin
993 if IsMultiThread then
994 LeaveCriticalSection(baPropCS);
995 end;
996
997 { TIpBasePersistent }
998
999 { Create instance of TIpBasePersistent }
1000 constructor TIpBasePersistent.Create;
1001 begin
1002 inherited;
1003 InitializeCriticalSection(bpPropCS);
1004 end;
1005
1006 { Destroy instance of TIpBasePersistent }
1007 destructor TIpBasePersistent.Destroy;
1008 begin
1009 DeleteCriticalSection(bpPropCS);
1010 inherited;
1011 end;
1012
1013 { Enters TIpBasePersistent critical section }
1014 procedure TIpBasePersistent.LockProperties;
1015 begin
1016 if IsMultiThread then
1017 EnterCriticalSection(bpPropCS);
1018 end;
1019
1020 { Leaves TIpBasePersistent critical section }
1021 procedure TIpBasePersistent.UnlockProperties;
1022 begin
1023 if IsMultiThread then
1024 LeaveCriticalSection(bpPropCS);
1025 end;
1026
1027 { TIpBaseComponent }
1028
TIpBaseComponent.GetVersionnull1029 function TIpBaseComponent.GetVersion: string;
1030 begin
1031 Result := IpShortVersion;
1032 end;
1033
1034 { Returns an appropriate string for the given parameters }
TIpBaseComponent.GetLogStringnull1035 class function TIpBaseComponent.GetLogString(const S, D1, D2, D3: DWORD): string;
1036 begin
1037 if (S=0) or (D1=0) or (D2=0) or (D3=0) then ; // avoid hints
1038 Result := '!!!! Unhandled log entry'#10#13;
1039 end;
1040
1041 procedure TIpBaseComponent.SetVersion(const Value: string);
1042 begin
1043 if (Value='') then ; // avoid hints
1044 { Intentionally empty }
1045 end;
1046
1047 { TIpBaseWinControl }
1048
TIpBaseWinControl.GetVersionnull1049 function TIpBaseWinControl.GetVersion : string;
1050 begin
1051 Result := IpShortVersion;
1052 end;
1053
1054 procedure TIpBaseWinControl.SetVersion(const Value : string);
1055 begin
1056 if (Value='') then ; // avoid hints
1057 { Intentionally empty }
1058 end;
1059
1060 { address handling }
1061
1062 { Apply Internet escaping (%nn) to characters in EscapeSet found in S }
PutEscapesnull1063 function PutEscapes(const S : string; EscapeSet : CharSet) : string;
1064 var
1065 Temp, Rep : string;
1066 i : Integer;
1067 begin
1068 Temp := S;
1069
1070 i := 1;
1071 while i <= Length(Temp) do begin
1072 if Temp[i] in EscapeSet then begin
1073 { Internet escapes of the form %nn where }
1074 { n is the ASCII character number in Hex }
1075 Rep := '%' + Format('%2x', [Ord(Temp[i])]);
1076 Delete(Temp, i, 1);
1077 Insert(Rep, Temp, i);
1078 Inc(i, 3);
1079 end
1080 else
1081 Inc(i);
1082 end;
1083 Result := Temp;
1084 end;
1085
1086 { Convert Internet escapes to ASCII equivalents }
RemoveEscapesnull1087 function RemoveEscapes(const S : string; EscapeSet : CharSet) : string;
1088 var
1089 Temp, Start, EscStr : string;
1090 P : Integer;
1091 C : AnsiChar;
1092 begin
1093 Temp := S;
1094 Start := '';
1095
1096 P := CharPos('%', Temp);
1097
1098 while P > 0 do begin
1099 Start := Start + Copy(Temp, 1, P-1);
1100 EscStr := Copy(Temp, P + 1, 2);
1101 C := Chr(StrToInt('$' + EscStr));
1102
1103 if C in EscapeSet then begin
1104 Start := Start + C;
1105 end
1106 else begin
1107 Start := Start + EscStr;
1108 end;
1109
1110 Temp := Copy(Temp, P + 3, Length(Temp) - 3);
1111 P := CharPos('%', Temp);
1112 end;
1113
1114 Result := Start + Temp;
1115 end;
1116
1117 { Convert Internet file characters to DOS }
1118 { * maps '|' -> ':' }
1119 { '/' -> '\' }
NetToDOSPathnull1120 function NetToDOSPath(const PathStr : string) : string;
1121 var
1122 i : Integer;
1123 begin
1124 Result := PathStr;
1125 for i := 1 to Length(Result) do begin
1126 case Result[i] of
1127 '|': Result[i] := ':';
1128 '/': Result[i] := DirectorySeparator;
1129 else
1130 { leave it alone };
1131 end;
1132 end;
1133
1134 if (CharPos('\', Result) = 1) and (CharPos(':', Result) > 0) then
1135 Result := Copy(Result, 2, Length(Result) - 1);
1136 end;
1137
DOSToNetPathnull1138 function DOSToNetPath(const PathStr : string) : string;
1139 { Convert DOS file characters to Internet }
1140 { * maps ':' -> '|' }
1141 { '\' -> '/' }
1142 var
1143 i : Integer;
1144 begin
1145 Result := PathStr;
1146 for i := 1 to Length(Result) do begin
1147 case Result[i] of
1148 ':': Result[i] := '|';
1149 DirectorySeparator: Result[i] := '/';
1150 else
1151 { leave it alone };
1152 end;
1153 end;
1154 end;
1155
1156
IpParseURLnull1157 function IpParseURL(const URL : string; var Rslt : TIpAddrRec) : Boolean;
1158 { Splits URL into components }
1159
1160 { -- rewritten
1161 - Parsing UserName and Password fields out of Mailto: urls of the form:
1162 mailto:user:pass@myserver.net
1163 - Username and Password fields added to TIpAddrRec in support of
1164 additional IpParseUrl capabilities
1165 - Handling URL Fragments and Queries on local files
1166 - Improved recognition of relative paths
1167 - Improved recognition of "LocalHost" style Authorities
1168 }
1169
1170 {
1171 Algorithm:
1172 1. Leading spaces ignored
1173 2. Start of string:
1174 - Any starting alphabetic character is accumulated into a "Potential
1175 Authority" (PA) string
1176 - If the first character is a digit URL is assumed to be starting with a
1177 numeric format IP address
1178 - If the first character is a period ('.') or a slash ('/', '\') the URL is
1179 considered to be a relative path
1180 4. If a PA has been started:
1181 - alphanumeric characters are accumulated into the PA
1182 - if a ':' or '|' are encountered and there is only one character in
1183 the preceding PA, the PA is assumed to be a drive letter for a local
1184 file and the rest of the URL is handled accordingly
1185 - if there is more than one character in the PA when the ':' is encountered,
1186 and if the PA contains at least one period ('.') it is assumed to be an
1187 authority, otherwise it is assumed to be a scheme (e.g. HTTP), the ':' is
1188 assumed to be delimiting between an authority and a port ID and the PA
1189 string is handled accordingly
1190 - if a '.' is encountered prior to seeing a '/' then the PA is assumed to be
1191 an authority.
1192 - if a '/' is encountered, the PA is assumed to be an authority
1193 - if a '@' is encountered the present PA is assumed to be a username, and
1194 PA accumulation is re-started
1195 - any other non-specified character is assumed to indicate an Authority
1196 5. If a character indicating the end of the PA has been encountered:
1197 - if numeric characters are seen after a ':' these are assumed to be a port ID
1198 - if alphabetic characters are seen they are assumed to be part of a password
1199 - if a slash is encountered the PA is assumed to be a scheme
1200 - if an '@' or ':' is encountered the PA is assumed to be a UserName.
1201 On '@' the assumption is the Authority is starting.
1202 On ':' the assumption is a password is starting.
1203 6. Slashes following a scheme:
1204 - all forward slashes (if any) following a scheme are ignored
1205 - if a '.' or '\' is found immediately after the scheme slashes, it's assumed
1206 to indicate the start of a local relative path
1207 7. Password accumulation:
1208 - non-'@' characters are considered part of the password
1209 - if an '@' is encountered it's considered the start of the authority and
1210 actual authority accumulatino is started
1211 8. Authority Accumulation:
1212 - characters in the set ['A'..'Z', 'a'..'z', '0'..'9', '.', '-', '_'] are
1213 accumulated into the authority
1214 - a ':' is assumed to indicate the end of the authority and the start of a
1215 Port ID
1216 - a '/' is assumed to indicate the end of the authority and the start of a
1217 path
1218 - a space (' ') is assumed to indicate trailing spaces on the URL
1219 9. Port has started:
1220 - numeric characters are accumulated into the Port
1221 - a '/' is assumed to indicate the start of a path
1222 - a ' ' is assumed to indicate trailing spaces on the url
1223 10. Path has started:
1224 - characters not in the set ['#', '?', '&'] are accumulated into the Path
1225 - a '#' is assumed to indicate the start of a Fragment
1226 - a '?' or '&' is assumed to indicate the start of a Query
1227 11. Fragment has started:
1228 - characters not in the set ['?', '&', ' '] are accumulated into the Fragment
1229 - a '?' or '&' is assumed to indicate the start of a Query
1230 - a ' ' is assumed to indicate trailing spaces on the url
1231 12. Query has started:
1232 - non space characters are accumulated into the Fragment
1233 - a ' ' is assumed to indicate trailing spaces on the url
1234 13. Trailing spaces
1235 - ignored
1236 }
1237
1238 type
1239 TUrlParseState = (
1240 psStart, psError, psStartSp, psPotAuth, psEoPotAuth, psSchemeSlashes,
1241 psLocalPath, psAuthority, psUserName, psPassword, psPort, psPath,
1242 psFragment, psQuery, psEndSp
1243 );
1244 const
1245 UrlStops : set of TUrlParseState = [psPath, psLocalPath, psAuthority, psPort,
1246 psFragment, psQuery, psEndSp];
1247
1248 var
1249 P : PChar;
1250 i : Integer;
1251 State : TUrlParseState;
1252 PotAuth, PotPath : string;
1253 SchemeSeen: Boolean;
1254 SlashCount: integer;
1255
1256 procedure ProcessChar;
1257 begin
1258 case State of
1259 psStart: begin
1260 case P^ of
1261 ' ': begin
1262 State := psStartSp;
1263 end;
1264
1265 'A'..'Z', 'a'..'z': begin
1266 PotAuth := PotAuth + P^;
1267 State := psPotAuth;
1268 end;
1269
1270 '0'..'9': begin
1271 Rslt.Authority := Rslt.Authority + P^;
1272 State := psAuthority;
1273 end;
1274
1275 '.', '/', '\' : begin
1276 PotPath := PotPath + P^;
1277 State := psPath;
1278 end;
1279
1280 else
1281 State := psError;
1282 end;
1283 end;
1284
1285 psStartSp: begin
1286 case P^ of
1287 ' ': { ignore };
1288
1289 'A'..'Z', 'a'..'z', '-', '_': begin
1290 PotAuth := PotAuth + P^;
1291 State := psPotAuth;
1292 end;
1293
1294 '0'..'9': begin
1295 Rslt.Authority := Rslt.Authority + P^;
1296 State := psAuthority;
1297 end;
1298
1299 '.', '/', '\' : begin
1300 PotPath := PotPath + P^;
1301 State := psPath;
1302 end;
1303
1304 else
1305 State := psError;
1306 end;
1307 end;
1308
1309 psPotAuth: begin
1310 case P^ of
1311 'A'..'Z', 'a'..'z', '0'..'9', '.', '-', '_': begin
1312 PotAuth := PotAuth + P^;
1313 end;
1314
1315 ':', '|': begin
1316 if Length(PotAuth) = 1 then begin
1317 PotPath := PotAuth + P^;
1318 PotAuth := '';
1319 State := psLocalPath;
1320 end
1321 else begin
1322
1323 if Pos('.', PotAuth) > 0 then begin
1324 Rslt.Authority := PotAuth;
1325 State := psPort;
1326 end
1327 else
1328 if (Rslt.Scheme = '') then begin
1329 Rslt.Scheme := PotAuth;
1330 SchemeSeen := True;
1331 PotAuth := '';
1332 State := psSchemeSlashes;
1333 SlashCount := 0;
1334 end
1335 else begin
1336
1337 State := psEoPotAuth;
1338 end;
1339 end;
1340 end;
1341
1342
1343 '/', '\': begin
1344 if SchemeSeen then
1345 Rslt.Authority := PotAuth
1346 else begin
1347 if Pos('.', PotAuth) > 0 then
1348 Rslt.Authority := PotAuth
1349 else
1350 PotPath := PotAuth;
1351 end;
1352 PotAuth := '';
1353 PotPath := PotPath + P^;
1354 State := psPath;
1355 end;
1356
1357 '@': begin
1358 Rslt.UserName := PotAuth;
1359 PotAuth := '';
1360 State := psAuthority;
1361 end;
1362
1363 else begin
1364 Rslt.Authority := PotAuth;
1365 PotAuth := '';
1366 State := psAuthority;
1367 end;
1368
1369 end;
1370
1371 end;
1372
1373 psEoPotAuth: begin
1374 case P^ of
1375 '0'..'9': begin
1376 Rslt.Authority := PotAuth;
1377 PotAuth := '';
1378 Rslt.Port := Rslt.Port + P^;
1379 State := psPort;
1380 end;
1381
1382 '/', '\': begin
1383 Rslt.Scheme := PotAuth;
1384 SchemeSeen := True;
1385 PotAuth := '';
1386 State := psSchemeSlashes;
1387 SlashCount := 0;
1388 end;
1389
1390 'A'..'Z', 'a'..'z': begin
1391 Rslt.UserName := PotAuth;
1392 PotAuth := '';
1393 Rslt.Password := Rslt.Password + P^;
1394 State := psPassword;
1395 end;
1396
1397 '@': begin
1398 Rslt.UserName := PotAuth;
1399 PotAuth := '';
1400 State := psAuthority;
1401 end;
1402
1403 ':': begin
1404 Rslt.UserName := PotAuth;
1405 PotAuth := '';
1406 State := psPassword;
1407 end;
1408
1409 end;
1410
1411 end;
1412
1413 psSchemeSlashes: begin
1414 inc(SlashCount);
1415 if (p^ <> '/') or (SlashCount > 2) then
1416 case P^ of
1417 '.', '\','/': begin { start of a local path }
1418 PotPath := PotPath + P^;
1419 State := psLocalPath;
1420 end;
1421
1422 else begin
1423 if CharPos('@', URL) > 0 then begin
1424 PotAuth := P^;
1425 State := psUserName;
1426 end
1427 else begin
1428 PotAuth := P^;
1429 State := psPotAuth;
1430 end;
1431 end;
1432 end;
1433 end;
1434
1435
1436 psLocalPath: begin
1437 case P^ of
1438 '#': begin
1439 if PotPath <> '' then
1440 Rslt.Path := AllTrimSpaces(PotPath);
1441 State := psFragment;
1442 end;
1443
1444 '?', '&': begin
1445 if PotPath <> '' then
1446 Rslt.Path := AllTrimSpaces(PotPath);
1447 Rslt.QueryDelim := P^;
1448 State := psQuery;
1449 end;
1450
1451 else
1452 PotPath := PotPath + P^;
1453 end;
1454 end;
1455
1456 psAuthority: begin
1457 case P^ of
1458 'A'..'Z', 'a'..'z', '0'..'9', '.', '-', '_' : begin
1459 Rslt.Authority := Rslt.Authority + P^;
1460 end;
1461
1462 ':': begin
1463 State := psPort;
1464 end;
1465
1466 ' ': begin
1467 State := psEndSp;
1468 end;
1469
1470 '/', '\': begin
1471 PotPath := PotPath + P^;
1472 State := psPath;
1473 end;
1474 end;
1475 end;
1476
1477 psUserName: begin
1478 case P^ of
1479 '@': begin
1480 Rslt.UserName := PotAuth;
1481 PotAuth := '';
1482 State := psAuthority;
1483 end;
1484
1485 ':', '|': begin
1486 if Length(PotAuth) = 1 then begin
1487 PotPath := PotAuth + P^;
1488 PotAuth := '';
1489 State := psLocalPath;
1490 end
1491 else begin
1492 Rslt.UserName := PotAuth;
1493 PotAuth := '';
1494 State := psPassword;
1495 end;
1496 end;
1497
1498 else
1499 PotAuth := PotAuth + P^;
1500 end;
1501 end;
1502
1503 psPassword: begin
1504 case P^ of
1505 '@': begin
1506 State := psAuthority;
1507 end;
1508
1509 else begin
1510 Rslt.Password := Rslt.Password + P^;
1511 end;
1512 end;
1513 end;
1514
1515 psPort: begin
1516 case P^ of
1517 '0'..'9': begin
1518 Rslt.Port := Rslt.Port + P^;
1519 end;
1520
1521 '/', '\': begin
1522 PotPath := PotPath + P^;
1523 State := psPath;
1524 end;
1525
1526 ' ': begin
1527 State := psEndSp;
1528 end;
1529
1530 else
1531 State := psError;
1532 end;
1533 end;
1534
1535 psPath: begin
1536 case P^ of
1537 '#': begin
1538 if PotPath <> '' then begin
1539 Rslt.Path := AllTrimSpaces(PotPath);
1540 PotPath := '';
1541 end;
1542 State := psFragment;
1543 end;
1544
1545 '?', '&' : begin
1546 if PotPath <> '' then begin
1547 Rslt.Path := AllTrimSpaces(PotPath);
1548 PotPath := '';
1549 end;
1550 Rslt.QueryDelim := P^;
1551 State := psQuery;
1552 end;
1553
1554 ' ': begin
1555 State := psEndSp;
1556 end;
1557
1558 else
1559 PotPath := PotPath + P^;
1560 end;
1561 end;
1562
1563 { Extract "Fragment" (in-page reference) portion of URL }
1564
1565 { - If URL contains an Entity name then Fragment should be delimited by a '#' }
1566 { - If URL does not contain Entity name then Fragment may immediately follow a }
1567 { final slash in the URL's "Path" component, but must still be delimited by }
1568 { a '#' to indicate that it is a Fragment. In this case the assumption is }
1569 { that the Fragment refers to the current page }
1570
1571 psFragment: begin
1572 case P^ of
1573 '?', '&': begin
1574 if PotPath <> '' then begin
1575 Rslt.Path := AllTrimSpaces(PotPath);
1576 PotPath := '';
1577 end;
1578 Rslt.QueryDelim := P^;
1579 State := psQuery;
1580 end;
1581
1582 else
1583 Rslt.Fragment := Rslt.Fragment + P^;
1584 end;
1585 end;
1586
1587 { Extract "Query" portion of URL }
1588
1589 { - If URL contains an Entity name and/or Fragment then Query should }
1590 { be delimited by a '?' }
1591 { - If URL does not contain Entity name and/or Fragment then Query may or may }
1592 { not be delimited by a '?' }
1593 { - Individual elements/parameters within the query typically appear in }
1594 { <name>=<value> pairs separated by '&' characters }
1595 { See also: SplitParams() and FieldFix() routines }
1596
1597 psQuery: begin
1598 case P^ of
1599 ' ': begin
1600 State := psEndSp;
1601 end;
1602
1603 else
1604 Rslt.Query := Rslt.Query + P^;
1605 end;
1606 end;
1607
1608 psEndSp: begin
1609 case P^ of
1610 ' ' : { ignore };
1611
1612 else
1613 State := psError;
1614 end;
1615 end;
1616
1617 psError: begin
1618 end;
1619 end {case State };
1620 end;
1621
1622
1623 begin
1624 Rslt.Scheme := '';
1625 Rslt.Authority := '';
1626 Rslt.UserName := '';
1627 Rslt.Password := '';
1628 Rslt.Port := '';
1629 Rslt.Path := '';
1630 Rslt.Fragment := '';
1631 Rslt.Query := '';
1632
1633 P := @URL[1];
1634 State := psStart;
1635
1636 // Result := False;
1637 PotAuth := '';
1638 PotPath := '';
1639
1640 SchemeSeen := False;
1641 for i := 1 to Length(URL) do begin
1642 ProcessChar;
1643 if State = psError then
1644 Break;
1645 Inc(P);
1646 end;
1647
1648 if PotAuth <> '' then
1649 Rslt.Authority := PotAuth;
1650
1651
1652 if Rslt.Path = '' then begin
1653 if PotPath <> '' then
1654 Rslt.Path := AllTrimSpaces(PotPath)
1655 else
1656 Rslt.Path := '/';
1657 end;
1658
1659 Result := State in UrlStops;
1660 end;
1661
1662
1663 { Build absolute URL from a starting URL (Old) and a new URL (New) }
1664
1665 { * Old may be empty }
1666 { * New may be a full address or a path relative to Old }
1667 { * "FILE://" references are converted for Internet (':'=>'|', '\'=>'/') }
1668 { * Attempts to handle relative paths containing one or more "../" references }
1669 { intelligently, but does no error checking that there are sufficient higher }
1670 { levels in Old to account for the number of "../" levels in New }
1671 { Change for FPC: renamed Old, New to OldURL, NewURL }
BuildURLnull1672 function BuildURL(const OldURL, NewURL: string): string;
1673 var
1674 OldAddrRec : TIpAddrRec;
1675 NewAddrRec : TIpAddrRec;
1676 FoundPos : Integer;
1677 RelPos : Integer;
1678 ParentPos : Integer;
1679 Path : string;
1680 Scheme : string;
1681 Port : string;
1682 begin
1683 Result := '';
1684 Path := '';
1685
1686 { sanity checks }
1687 if (OldURL = '') and (NewURL = '') then begin
1688 Result := '';
1689 Exit;
1690 end;
1691
1692 if (OldURL = '') and (NewURL <> '') then begin
1693 Result := NewURL;
1694 Exit;
1695 end;
1696
1697 if (OldURL <> '') and (NewURL = '') then begin
1698 Result := OldURL;
1699 Exit;
1700 end;
1701
1702 { Main processing }
1703 Result := DOSToNetPath(OldURL);
1704
1705 Initialize(OldAddrRec);
1706 Initialize(NewAddrRec);
1707
1708 IpParseURL(OldURL, OldAddrRec);
1709 IpParseURL(NewURL, NewAddrRec);
1710
1711 if OldAddrRec.Scheme = '' then
1712 Scheme := ''
1713 else
1714 Scheme := OldAddrRec.Scheme + '://';
1715
1716 if OldAddrRec.Port = '' then
1717 Port := ''
1718 else
1719 Port := ':' + OldAddrRec.Port;
1720
1721 if CompareText(NewAddrRec.Scheme, 'FILE') = 0 then begin
1722 { New is a local file }
1723 Result := NewAddrRec.Scheme + '://' + NewAddrRec.Path;
1724 end else if NewAddrRec.Scheme <> '' then begin
1725 { New is a full address in its own right }
1726 Result := NewURL; { so just return that }
1727 end else if (NewAddrRec.Scheme = '') and (NewURL[1] = '/') then begin
1728 { New is probably a direct path off the Root }
1729 Result := Scheme + OldAddrRec.Authority + Port; { build Root }
1730 if (NewURL <> '') and (NewURL[1] <> '/') then
1731 Result := Result + '/';
1732 Result := Result + NewURL; { just append }
1733 end else if (NewAddrRec.Scheme = '') and (NewURL[1] <> '.') then begin
1734 { New is probably a direct path off the current path }
1735 if CompareText(OldAddrRec.Scheme, 'FILE') = 0 then begin
1736 Path := ExtractFilePath(OldAddrRec.Path);
1737 Result := Scheme + Path;
1738 end
1739 else begin
1740 Path := ExtractEntityPath(DosToNetPath(OldAddrRec.Path));
1741 if (Path <> '') and (Path[1] = '/') then
1742 Path := Copy(Path, 2, Length(Path) - 1);
1743 Result := Scheme;
1744
1745 if OldAddrRec.Authority <> '' then
1746 Result := Result + OldAddrRec.Authority + Port + '/';
1747
1748 if Path <> '' then
1749 Result := Result + AppendSlash(Path);
1750 end;
1751
1752 Result := Result + NewURL;
1753
1754 Exit;
1755 end else begin
1756 { otherwise New should be a relative path of Old }
1757 Path := AppendSlash(ExtractEntityPath(DOSToNetPath(OldAddrRec.Path)));
1758 FoundPos := PosIdx('../', NewURL, 1);
1759 RelPos := FoundPos + 3;
1760 ParentPos := RCharPosIdx('/', Path, Length(Path));
1761 while (FoundPos > 0) do begin
1762 FoundPos := PosIdx('../', NewURL, FoundPos + 3);
1763 if FoundPos > 0 then
1764 RelPos := FoundPos + 3;
1765 ParentPos := RCharPosIdx('/', Path, ParentPos - 1);
1766 end;
1767
1768 Path := AppendSlash(Copy(Path, 1, ParentPos));
1769 Result := Scheme + OldAddrRec.Authority + Path +
1770 Copy(NewURL, RelPos, Length(NewURL) - RelPos + 1);
1771
1772 { remove shorthand for current directory if it exists }
1773 FoundPos := Pos('/./', Result);
1774 if FoundPos > 0 then
1775 Delete(Result, FoundPos, 2);
1776 end;
1777
1778 Path := OldURL;
1779 Finalize(OldAddrRec);
1780 Finalize(NewAddrRec);
1781 end;
1782
1783 { Split Internet formated (ampersand '&' separated) parameters }
1784 { from Parms into Dest }
1785 procedure SplitParams(const Parms : string; Dest : TStrings);
1786 var
1787 P : Integer;
1788 Temp : string;
1789 begin
1790 if not Assigned(Dest) then
1791 Exit;
1792
1793 Dest.Clear;
1794
1795 Temp := Parms;
1796
1797 P := CharPos('&', Temp);
1798 while P > 0 do begin
1799 Dest.Add(Copy(Temp, 1, P - 1));
1800 Temp := Copy(Temp, P + 1, Length(Temp) - P);
1801 P := CharPos('&', Temp);
1802 end;
1803 Dest.Add(Temp);
1804 end;
1805
1806 { Divide HTTP response header line into individual fields }
1807 { - HTTP response in the form of: }
1808 { "HTTP/"<HTTP Version><SP><HTTP Message ID#><SP><HTTP Message String> }
1809 { for example, if "HTTP/1.1 200 OK" passed in S, procedure returns }
1810 { "1.1" in V }
1811 { "200" in MsgID }
1812 { "OK" in Msg }
1813 procedure SplitHttpResponse(const S: string; var V, MsgID, Msg: string);
1814 var
1815 P: Integer;
1816 Temp: string;
1817 begin
1818 Temp := S;
1819 P := CharPos(' ', Temp);
1820 V := Copy(Temp, 6, P - 6);
1821 Temp := Copy(Temp, P + 1, Length(Temp) - P);
1822 P := CharPos(' ', Temp);
1823 MsgID := Copy(Temp, 1, P - 1);
1824 Msg := Copy(Temp, P + 1, Length(Temp) - P);
1825 end;
1826
1827 { Convert HTTP Header into TStrings parseable by Name=Value mechanism }
1828 { - Basically just converts HTTP header fields of the form <NAME>: <VALUE> }
1829 { pairs into <NAME>=<VALUE> pairs. }
1830 { - Also parses HTTP header associating }
1831 { Full header -> "FullHead=" }
1832 { HTTP version -> "Version=" }
1833 { HTTP Message ID# -> "MsgID=" }
1834 { HTTP Message Text -> "Message=" }
1835 procedure FieldFix(Fields : TStrings);
1836 var
1837 i, P : Integer;
1838 S, Ver, ID, Msg : string;
1839 begin
1840 if Fields.Count > 0 then begin
1841 S := Fields[0];
1842 Fields.Delete(0);
1843
1844 SplitHttpResponse(S, Ver, ID, Msg);
1845 Fields.Insert(0, 'Message=' + Msg);
1846 Fields.Insert(0, 'MsgID=' + ID);
1847 Fields.Insert(0, 'Version=' + Ver);
1848 Fields.Insert(0, 'FullHead=' + S);
1849
1850
1851 for i := 4 to Pred(Fields.Count) do begin
1852 P := CharPos(':', Fields[i]);
1853 if P > 0 then begin
1854 S := Fields[i];
1855 Delete(S, P, 1);
1856 Insert('=', S, P);
1857 Fields.Delete(i);
1858 Fields.Insert(i,S);
1859 end;
1860 end;
1861 end;
1862 end;
1863
1864 { Append slash to Internet path if needed }
AppendSlashnull1865 function AppendSlash(APath : string) : string;
1866 begin
1867 Result := APath;
1868 if (Result <> '') and (Result[Length(APath)] <> '/') then
1869 Result := Result + '/';
1870 end;
1871
1872 { Drop trailing slash from Internet path if needed }
RemoveSlashnull1873 function RemoveSlash(APath : string) : string;
1874 begin
1875 Result := APath;
1876 if Result[Length(Result)] = '/' then
1877 Delete(Result, Length(Result), 1);
1878 end;
1879
1880 { Extract Entity (Filename) portion of Internet Path }
1881 { Parallel to SysUtils.ExtractFileName for Internet Paths }
ExtractEntityNamenull1882 function ExtractEntityName(const NamePath : string) : string;
1883 var
1884 P : Integer;
1885 Temp : string;
1886 begin
1887 Result := '';
1888 P := RCharPos('/', NamePath);
1889 if P > 0 then begin
1890 Temp := Copy(NamePath, P + 1, Length(NamePath) - P);
1891
1892 if CharPos('.', Temp) > 0 then
1893 Result := Temp
1894 else
1895 Result := '';
1896 end;
1897 end;
1898
1899 { Extract Path (non-filename) portion of Internet Path }
1900 { Parallel to SysUtils.ExtractFilePath for Internet Paths }
ExtractEntityPathnull1901 function ExtractEntityPath(const NamePath: string): string;
1902 var
1903 P : Integer;
1904 begin
1905 P := RCharPos('/', NamePath);
1906 if P = Length(NamePath) then { no file name on Path }
1907 Result := NamePath
1908 else
1909 Result := Copy(NamePath, 1, P);
1910 end;
1911
1912 { Return next highest level in Internet path }
1913 { e.g. if Path parameter contains "/default/pub/pics/jpgs" }
1914 { function would return "/default/pub/pics" }
GetParentPathnull1915 function GetParentPath(const Path : string) : string;
1916 var
1917 P : Integer;
1918 begin
1919 if Path = '/' then begin
1920 Result := Path;
1921 Exit;
1922 end;
1923 P := Length(Path);
1924 if Path[P] = '/' then
1925 Dec(P);
1926 while Path[P] <> '/' do
1927 Dec(P);
1928 Result := Copy(Path, 1, P);
1929 end;
1930
1931 { date stuff }
1932 const
1933 EpochYear = 70; { UNIX Julian time count starts in 1970 }
1934 EpochLowStr = '19';
1935 EpochHiStr = '20';
1936 CanonicalDate = '"%s", dd "%s" yyyy hh:mm:ss "%s00"';
1937
1938 {
1939 Note: The following strings and string arrays are used for
1940 interpreting/building canonical Internet dates and should
1941 NOT be internationalized!
1942 }
1943
1944 { DayString : string =
1945 'SUNDAY ' +
1946 'MONDAY ' +
1947 'TUESDAY ' +
1948 'WEDNESDAY' +
1949 'THURSDAY ' +
1950 'FRIDAY ' +
1951 'SATURDAY '; }
1952
1953 MonthString : string =
1954 'JANUARY ' +
1955 'FEBRUARY ' +
1956 'MARCH ' +
1957 'APRIL ' +
1958 'MAY ' +
1959 'JUNE ' +
1960 'JULY ' +
1961 'AUGUST ' +
1962 'SEPTEMBER' +
1963 'OCTOBER ' +
1964 'NOVEMBER ' +
1965 'DECEMBER ';
1966
1967 IpMonthsStrings: array[1..12] of string = (
1968 'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
1969 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');
1970 IpDOWStrings: array[1..7] of string = (
1971 'Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat');
1972
1973 type
1974 THttpDateType = (hdtUnknown, hdtRFC822, hdtRFC850, hdtANSIC);
1975
1976 { Returns numeric month index [1..12] from any unique string }
1977 { abbreviation of English month name, returns 0 if no match }
MonStrToIntnull1978 function MonStrToInt(MonStr : string) : Integer;
1979 var
1980 P : Integer;
1981 begin
1982 P := PosI(MonStr, MonthString);
1983 if P > 0 then
1984 Result := (P div 9) + 1
1985 else
1986 Result := 0;
1987 end;
1988
1989 { For two digit year string passed in returns }
1990 { four digit year string based on EpochYear constant. }
1991 { If converting YrStr to an integer yields > 99 then }
1992 { YrStr is returned unchanged }
EpochStrnull1993 function EpochStr(YrStr: string) : string;
1994 var
1995 Yr: Word;
1996 begin
1997 Yr := StrToInt(YrStr);
1998 if (Yr > 99) then begin { not a 2 digit year }
1999 Result := YrStr;
2000 Exit;
2001 end;
2002
2003 if (Yr < EpochYear) then begin
2004 Result := EpochHiStr + YrStr;
2005 end
2006 else begin
2007 Result := EpochLowStr + YrStr;
2008 end;
2009 end;
2010
2011
2012 {
2013 Convert an Internet Date string to a TDateTime
2014
2015 If the string isn't in one of the canonical formats (see below)
2016 the Internet start date of Jan 1, 1970 0:0:0:0 is returned
2017
2018 Canonical Internet header date strings are in one of three standard formats:
2019 Sun, 06 Nov 1994 08:49:37 GMT ; RFC 822, updated by RFC 1123
2020 Sunday, 06-Nov-94 08:49:37 GMT ; RFC 850, obsoleted by RFC 1036
2021 Sun Nov 6 08:49:37 1994 ; ANSI C's asctime() format
2022 }
2023
2024 {-- rewritten to handle common variants such as the Day or Month name
2025 to be fully spelled out where they are not in the canonical form, or to have
2026 a 4 digit year in the RFC 850 style
2027 }
INetDateStrToDateTimenull2028 function INetDateStrToDateTime(const DateStr: string): TDateTime;
2029 type
2030 TINetDateState = (idStart, idStartSp, idDow, idDowSp, idDay1, idDay1Sp,
2031 idMon1, idMon1Sp, idMon2, idMon2Sp, idDay2, idYr1,
2032 idPreTimeSp, idHrs, idMin, idSec, idPostTimeSp, {idGMT,} idYr2,
2033 idEndSp, idAM, idPM, idDaySpace1, IdTimeZoneNum, IdTimeZoneAlpha,
2034 idError);
2035
2036 const
2037 AcceptStates: set of TINetDateState = [{idGMT,} idYr2, idSec,
2038 idPostTimeSp, idEndSp,
2039 idTimeZoneAlpha,
2040 idTimeZoneNum];
2041 var
2042 Dow, Day, Mon, Year, Hrs, Min, Sec: string;
2043 Dy, Mo, Yr: Word;
2044 Hr, Mn, Sc: SmallInt;
2045 State: TINetDateState;
2046 P: PChar;
2047 i : Integer;
2048 AMPM : Boolean;
2049 PM : Boolean;
2050 TimeZone : string;
2051
2052 procedure ParseDate;
2053 begin
2054 case State of
2055 idStart: begin
2056 case P^ of
2057 ' ' : State := idStartSp;
2058
2059 'A'..'Z', 'a'..'z' : begin
2060 State := idDow;
2061 Dow := Dow + P^;
2062 end;
2063
2064 '0'..'9': begin
2065 State := idDay1;
2066 Day := Day + P^;
2067 end;
2068
2069 else
2070 State := idError;
2071 end;
2072 end;
2073
2074 idStartSp: begin { ignore initial spaces }
2075 case P^ of
2076 ' ': { ignore };
2077
2078 'A'..'Z', 'a'..'z' : begin
2079 State := idDow;
2080 Dow := Dow + P^;
2081 end;
2082 else
2083 State := idError;
2084 end;
2085 end;
2086
2087 idDow: begin { all formats start with a DOW string }
2088 case P^ of
2089 'A'..'Z', 'a'..'z' : begin
2090 Dow := Dow + P^;
2091 end;
2092
2093 ',', ' ': begin
2094 State := idDowSp;
2095 end;
2096 else
2097 State := idError;
2098 end;
2099 end;
2100
2101 idDowSp: begin { ignore spaces following DOW }
2102 case P^ of
2103 ' ': { ignore };
2104
2105 '0'..'9': begin
2106 State := idDay1;
2107 Day := Day + P^;
2108 end;
2109
2110 'A'..'Z', 'a'..'z' : begin
2111 State := idMon1;
2112 Mon := Mon + P^;
2113 end;
2114
2115 else
2116 State := idError;
2117 end;
2118 end;
2119
2120 idDay1: begin { RFC 822 and 850 formats start with day digit }
2121 case P^ of
2122 ' ': begin
2123 State := idDay1Sp;
2124 end;
2125
2126 '-': begin
2127 State := idMon2;
2128 end;
2129
2130 '0'..'9': begin
2131 Day := Day + P^;
2132 end;
2133
2134 else
2135 State := idError;
2136 end;
2137 end;
2138
2139 idDay1Sp: begin { ignore spaces following day digit }
2140 case P^ of
2141 ' ': { ignore };
2142
2143 'A'..'Z', 'a'..'z' : begin
2144 State := idMon2;
2145 Mon := Mon + P^;
2146 end;
2147
2148 else
2149 State := idError;
2150 end;
2151 end;
2152
2153 idMon1: begin { ANSI C format starts with month string }
2154 case P^ of
2155 ' ': begin
2156 State := idMon1Sp;
2157 end;
2158
2159 'A'..'Z', 'a'..'z' : begin
2160 Mon := Mon + P^;
2161 end;
2162
2163 else
2164 State := idError;
2165 end;
2166 end;
2167
2168 idMon1Sp: begin { ignore spaces after ANSI C month string }
2169 case P^ of
2170 ' ': { ignore };
2171
2172 '0'..'9': begin
2173 State := idDay2;
2174 Day := Day + P^;
2175 end;
2176
2177 else
2178 State := idError;
2179 end;
2180 end;
2181
2182 idMon2: begin { RFC 822 and 850 month string }
2183 case P^ of
2184 ' ' : begin
2185 State := idMon2Sp;
2186 end;
2187
2188 '-' : begin
2189 State := idYr1;
2190 end;
2191
2192 'A'..'Z', 'a'..'z' : begin
2193 Mon := Mon + P^;
2194 end;
2195
2196 else
2197 State := idError;
2198 end;
2199 end;
2200
2201 idMon2Sp: begin {ignore spaces after month string }
2202 case P^ of
2203 ' ': { ignore };
2204
2205 '0'..'9': begin
2206 State := idYr1;
2207 Year := Year + P^;
2208 end;
2209
2210 else
2211 State := idError;
2212 end;
2213 end;
2214
2215 idDay2: begin { ANSI C format Day string }
2216 case P^ of
2217 '0'..'9': begin
2218 Day := Day + P^;
2219 end;
2220
2221 ',' : begin
2222 State := idDaySpace1;
2223 end;
2224
2225 ' ': begin
2226 State := idPreTimeSp;
2227 end;
2228
2229 else
2230 State := idError;
2231 end;
2232 end;
2233
2234 idDaySpace1 : begin
2235 case P^ of
2236 ' ' : begin
2237 end;
2238
2239 '0'..'9' : begin
2240 Year := Year + P^;
2241 State := idYr1;
2242 end;
2243
2244 else
2245 State := idError;
2246 end;
2247 end;
2248
2249 idYr1: begin { RFC 822 and 850 year string }
2250 case P^ of
2251 '0'..'9': begin
2252 Year := Year + P^;
2253 end;
2254
2255 ' ': begin
2256 State := idPreTimeSp;
2257 end;
2258
2259 else
2260 State := idError;
2261 end;
2262 end;
2263
2264 idPreTimeSp: begin { ignore spaces before start of time string }
2265 case P^ of
2266 ' ': { ignore };
2267
2268 '0'..'9': begin
2269 State := idHrs;
2270 Hrs := Hrs + P^;
2271 end;
2272
2273 else
2274 State := idError;
2275 end;
2276 end;
2277
2278 idHrs: begin { hours string }
2279 case P^ of
2280 ':': begin
2281 State := idMin;
2282 end;
2283
2284 '0'..'9': begin
2285 Hrs := Hrs + P^;
2286 end;
2287
2288 else
2289 State := idError;
2290 end;
2291 end;
2292
2293 idMin: begin { minutes string }
2294 case P^ of
2295 ':': begin
2296 State := idSec;
2297 end;
2298
2299 '0'..'9': begin
2300 Min := Min + P^;
2301 end;
2302
2303 ' ' : begin
2304 State := idPostTimeSp;
2305 Sec := '00';
2306 end;
2307
2308 else
2309 State := idError;
2310 end;
2311 end;
2312
2313 idSec: begin { seconds string }
2314 case P^ of
2315 ' ': begin
2316 State := idPostTimeSp;
2317 end;
2318
2319 '0'..'9': begin
2320 Sec := Sec + P^;
2321 end;
2322
2323 'A', 'a' : begin
2324 AMPM := True;
2325 PM := False;
2326 State := idAM;
2327 end;
2328
2329 'P', 'p' : begin
2330 AMPM := True;
2331 PM := True;
2332 State := idPM;
2333 end;
2334
2335 else
2336 State := idError;
2337 end;
2338 end;
2339
2340 idAM : begin { AM string }
2341 case P^ of
2342 ' ' : begin
2343 State := idPostTimeSp
2344 end;
2345
2346 'M', 'm' : begin
2347 State := idPostTimeSp;
2348 end;
2349
2350 else
2351 State := idError;
2352 end;
2353 end;
2354
2355 idPM : begin { PM string }
2356 case P^ of
2357 ' ' : begin
2358 State := idPostTimeSp
2359 end;
2360
2361 'M', 'm' : begin
2362 State := idPostTimeSp;
2363 end;
2364
2365 else
2366 State := idError;
2367 end;
2368 end;
2369
2370 idPostTimeSp: begin { ignore spaces before after time string }
2371 case P^ of
2372 ' ': { ignore };
2373
2374 '0'..'9': begin
2375 State := idYr2;
2376 Year := Year + P^;
2377 end;
2378
2379 {'G', 'g': begin }
2380 { State := idGMT; }
2381 {end; }
2382
2383 '-' : begin
2384 TimeZone := TimeZone + P^;
2385 State := IdTimeZoneNum;
2386 end;
2387
2388 '+' : begin
2389 TimeZone := TimeZone + P^;
2390 State := IdTimeZoneNum;
2391 end;
2392
2393 'A'..'Z', 'a'..'z' : begin
2394 TimeZone := TimeZone + P^;
2395 State := IdTimeZoneAlpha;
2396 end;
2397
2398 else
2399 State := idError;
2400 end;
2401 end;
2402
2403 idTimeZoneNum : begin
2404 case P^ of
2405 '0'..'9' : begin
2406 TimeZone := TimeZone + P^;
2407 end;
2408
2409 ' ' : begin
2410 State := idEndSp;
2411 end;
2412
2413 else
2414 State := idError;
2415 end;
2416 end;
2417
2418 idTimeZoneAlpha : begin
2419 case P^ of
2420 'A'..'Z', 'a'..'z' : begin
2421 TimeZone := TimeZone + P^;
2422 end;
2423
2424 ' ' : begin
2425 if CompareText(TimeZone, 'AM') = 0 then begin
2426 AMPM := True;
2427 PM := False;
2428 State := IdTimeZoneAlpha;
2429 TimeZone := '';
2430 end else if CompareText(TimeZone, 'PM') = 0 then begin
2431 AMPM := True;
2432 PM := True;
2433 State := IdTimeZoneAlpha;
2434 TimeZone := '';
2435 end else
2436 State := idEndSp;
2437 end;
2438
2439 else
2440 State := idError;
2441 end;
2442 end;
2443
2444 {idGMT: begin } { RFC 822 and 850 should end with "GMT" }
2445 { case P^ of }
2446 { 'M', 'T': begin }
2447 { end; }
2448 { }
2449 { ' ': begin }
2450 { State := idEndSp; }
2451 { end; }
2452 { }
2453 { else }
2454 { State := idError; }
2455 { end; }
2456 {end; }
2457
2458 idYr2: begin { ANSI C time ends with Year }
2459 case P^ of
2460 '0'..'9': begin
2461 Year := Year + P^;
2462 end;
2463
2464 ' ': begin
2465 State := idEndSp;
2466 end;
2467
2468 else
2469 State := idError;
2470 end;
2471 end;
2472
2473 idEndSp: begin { ignore trailing spaces }
2474 case P^ of
2475 ' ': {ignore};
2476 else
2477 State := idError;
2478 end;
2479 end;
2480
2481 idError: begin
2482 end;
2483 end;
2484 end;
2485
2486
2487 begin
2488 Result := EncodeDate(1970, 1, 1);
2489 if DateStr = '' then Exit;
2490
2491 { clear parse strings }
2492 Dow := '';
2493 Day := '';
2494 Mon := '';
2495 Year := '';
2496 Hrs := '';
2497 Min := '';
2498 Sec := '';
2499 AMPM := False;
2500 PM := False;
2501 TimeZone := '';
2502
2503 { start at first character }
2504 P := @DateStr[1];
2505
2506 { iterate characters }
2507 for i := 1 to Length(DateStr) do begin
2508 ParseDate;
2509 if State = idError then
2510 Exit { error in date format, give up }
2511 else
2512 Inc(P);
2513 end;
2514
2515 if State = idTimeZoneAlpha then begin
2516 if CompareText(TimeZone, 'AM') = 0 then begin
2517 AMPM := True;
2518 PM := False;
2519 TimeZone := '';
2520 end else if CompareText(TimeZone, 'PM') = 0 then begin
2521 AMPM := True;
2522 PM := True;
2523 TimeZone := '';
2524 end;
2525 end;
2526
2527 if State = idMin then begin
2528 Sec := '00';
2529 State := idSec;
2530 end;
2531
2532 { date string terminated prematurely }
2533 if not (State in AcceptStates) then Exit;
2534
2535 { validate day of week and Month name vs. expected }
2536 // if not ((Pos(UpperCase(Dow), DayString) mod 9) = 1) then Exit; // !!!
2537 if not ((PosI(Mon, MonthString) mod 9) = 1) then Exit;
2538
2539 { correct two digit years }
2540 Year := EpochStr(Year);
2541
2542 { convert D-M-Y string representations to integers }
2543 Dy := StrToIntDef(Day, 0);
2544 Mo := MonStrToInt(Mon);
2545 Yr := StrToIntDef(Year, 0);
2546
2547 { check for errors or out of range }
2548 if (Dy = 0) or (Mo = 0) or (Yr = 0) then Exit;
2549 if (Dy > 31) or (Mo > 12) then Exit;
2550
2551 { convert H-M-S string representations to integers }
2552 Hr := StrToIntDef(Hrs, -1);
2553 Mn := StrToIntDef(Min, -1);
2554 Sc := StrToIntDef(Sec, -1);
2555
2556 if AMPM then begin
2557 if (Hr < 12) and (PM) then
2558 Hr := Hr + 12;
2559 if (Hr = 12) and (not PM) then
2560 Hr := 0;
2561 end;
2562
2563 { check for errors or out of range }
2564 if (Hr = -1) or (Mn = -1) or (Sc = -1) then Exit;
2565 if (Hr > 24) or (Mn > 60) or (Sc > 60) then Exit;
2566
2567 { tests passed, generate final result }
2568 Result := ComposeDateTime(EncodeDate(Yr, Mo, Dy),EncodeTime(Hr, Mn, Sc, 0));
2569 end;
2570
2571
2572 { increment TDateTime by supplied number of minutes }
IncMinsnull2573 function IncMins(const Date: TDateTime; NumberOfMins: Integer): TDateTime;
2574 begin
2575 Result := Date + NumberOfMins / 1440.0;
2576 end;
2577
2578
2579 { returns the current local TimeZone "bias" in minutes from UTC (GMT) }
TimeZoneBiasnull2580 function TimeZoneBias : Integer;
2581 begin
2582 Result:=0;
2583 writeln('TimeZoneBias ToDo');
2584 end;
2585
2586 (*
2587 const
2588 TIME_ZONE_ID_UNKNOWN = 0;
2589 TIME_ZONE_ID_STANDARD = 1;
2590 TIME_ZONE_ID_DAYLIGHT = 2;
2591 {$ENDIF}
2592 var
2593 TZI : TTimeZoneInformation;
2594 begin
2595 Result := 0;
2596 case GetTimeZoneInformation(TZI) of
2597 TIME_ZONE_ID_UNKNOWN : Result := 0;
2598 TIME_ZONE_ID_STANDARD : Result := TZI.Bias + TZI.StandardBias;
2599 TIME_ZONE_ID_DAYLIGHT : Result := TZI.Bias + TZI.DaylightBias;
2600 end;
2601 end;
2602 *)
2603
2604 { Format TDateTime to standard HTTP date string }
DateTimeToINetDateTimeStrnull2605 function DateTimeToINetDateTimeStr(DateTime: TDateTime): string;
2606 var
2607 Yr, Mo, Dy: Word;
2608 s: String;
2609 begin
2610 DecodeDate(DateTime, Yr, Mo, Dy);
2611 s := Format('%g', [Abs(TimeZoneBias/60)]);
2612 if Length(s) = 1 then
2613 s := '0' + s;
2614 if TimeZoneBias < 0 then s := '-' + s;
2615
2616 Result := FormatDateTime(CanonicalDate, DateTime);
2617 Result := Format(Result, [IpDOWStringS[DayOfWeek(DateTime)], IpMonthsStrings[Mo], s]);
2618 end;
2619
2620
2621 { File/Directory Stuff }
2622
2623 { Retreive Windows "MIME" type for a particular file extension }
2624 {$ifndef MSWindows}
2625 {define some basic mime types}
2626 const MimeTypeExt : Array[0..4] of String = ('.htm','.html','.txt','.jpg','.png');
2627 MimeTypes : Array[0..4] of String = ('text/html','text/html','text/plain','image/jpeg','image/png');
2628 {$endif}
2629
GetLocalContentnull2630 function GetLocalContent(const TheFileName: string): string;
2631 var
2632 Reg : TRegistry;
2633 Ext : string;
2634 {$ifndef MSWindows}
2635 i : integer;
2636 {$ENDIF}
2637 begin
2638 Result := '';
2639 Ext := ExtractFileExt(TheFileName);
2640 {$ifndef MSWindows}
2641 for i := 0 to high(MimeTypeExt) do
2642 if CompareText(MimeTypeExt[i], Ext) = 0 then
2643 begin
2644 result := MimeTypes[i];
2645 break;
2646 end;
2647 {$endif}
2648 if result = '' then
2649 begin
2650 Reg := nil;
2651 try
2652 Reg := TRegistry.Create;
2653 Reg.RootKey := HKEY_CLASSES_ROOT;
2654 if Reg.OpenKeyReadOnly(Ext) then
2655 Result := Reg.ReadString('Content Type');
2656 finally
2657 Reg.CloseKey;
2658 Reg.Free;
2659 end;
2660 end;
2661 //DebugLn('IpUtils.GetLocalContent File:'+TheFileName+' Result:'+result);
2662 end;
2663
2664 { Determine if a directory exists }
DirExistsnull2665 function DirExists(Dir : string): Boolean;
2666 begin
2667 Result:=DirPathExists(Dir);
2668 end;
2669
2670 { Get temporary filename as string }
GetTemporaryFilenull2671 function GetTemporaryFile(const Path : string) : string;
2672 begin
2673 Result:=GetTempFileNameUTF8(Path,'IP_');
2674 end;
2675
2676 { Get Windows system TEMP path in a string }
GetTemporaryPathnull2677 function GetTemporaryPath: string;
2678 begin
2679 writeln('ToDo: IpUtils.GetTemporaryPath');
2680 Result:='';
2681 end;
2682
2683 { Append backslash to DOS path if needed }
AppendBackSlashnull2684 function AppendBackSlash(APath : string) : string;
2685 begin
2686 Result := AppendPathDelim(APath);
2687 end;
2688
2689 { Remove trailing backslash from a DOS path if needed }
RemoveBackSlashnull2690 function RemoveBackSlash(APath: string) : string;
2691 begin
2692 Result := ChompPathDelim(APath);
2693 end;
2694
2695 {***********************************************}
2696
2697 {cookie support}
2698
2699 const
2700 CookieDefaults: array [1..5] of string[8] =
2701 ('Version=',
2702 'Path=',
2703 'Domain=',
2704 'Max-Age=',
2705 'Path=');
FixDefaultsnull2706 function FixDefaults(const S: string): string;
2707 var
2708 i : Integer;
2709 begin
2710 Result := S;
2711 for i := 1 to 5 do
2712 if Pos(CookieDefaults[i], S) = 1 then
2713 Result := '$' + S;
2714 end;
2715
2716 procedure SplitCookieFields(const Data: string; Fields: TStrings);
2717 {
2718 Split Cookie data fields into items in a TStrings instance, Cookie fields will
2719 be in Name="Value" pairs easily accessed via the associated TStrings properties
2720 routine automatically prepends '$' to default Cookie fields for response header
2721 }
2722 var
2723 P1, P2 : Integer;
2724 S, Temp : string;
2725 begin
2726 Temp := Data + ';';
2727 P1 := 1;
2728 P2 := CharPosIdx(';', Temp, P1);
2729 while P2 > 0 do begin
2730 S := Trim(Copy(Temp, P1, P2 - P1));
2731 Fields.Add(FixDefaults(S));
2732 P1 := P2 + 1;
2733 P2 := CharPosIdx(';', Temp, P1);
2734 end;
2735 end;
2736
2737
2738 end.
2739