1 {==============================================================================|
2 | Project : Ararat Synapse | 004.015.007 |
3 |==============================================================================|
4 | Content: support procedures and functions |
5 |==============================================================================|
6 | Copyright (c)1999-2017, 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) 1999-2017. |
37 | Portions created by Hernan Sanchez are Copyright (c) 2000. |
38 | Portions created by Petr Fejfar are Copyright (c)2011-2012. |
39 | All Rights Reserved. |
40 |==============================================================================|
41 | Contributor(s): |
42 | Hernan Sanchez (hernan.sanchez@iname.com) |
43 | Tomas Hajny (OS2 support) |
44 | Radek Cervinka (POSIX support) |
45 |==============================================================================|
46 | History: see HISTORY.HTM from distribution package |
47 | (Found at URL: http://www.ararat.cz/synapse/) |
48 |==============================================================================}
49
50 {:@abstract(Support procedures and functions)}
51
52 {$I jedi.inc} // load common compiler defines
53
54 {$Q-}
55 {$R-}
56 {$H+}
57
58 {$IFDEF UNICODE}
59 {$WARN IMPLICIT_STRING_CAST OFF}
60 {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
61 {$WARN SUSPICIOUS_TYPECAST OFF}
62 {$ENDIF}
63
64 unit synautil;
65
66 interface
67
68 uses
69 {$IFDEF MSWINDOWS}
70 Windows,
71 {$ELSE MSWINDOWS}
72 {$IFDEF FPC}
73 {$IFDEF OS2}
74 Dos, TZUtil,
75 {$ELSE OS2}
76 UnixUtil, Unix, BaseUnix,
77 {$ENDIF OS2}
78 {$ELSE FPC}
79 {$IFDEF POSIX}
80 Posix.Base, Posix.Time, Posix.SysTypes, Posix.SysTime, Posix.Stdio,
81 {$ELSE}
82 Libc,
83 {$ENDIF}
84 {$ENDIF}
85 {$ENDIF}
86 {$IFDEF CIL}
87 System.IO,
88 {$ENDIF}
89 SysUtils, Classes, SynaFpc;
90
91 {$IFDEF VER100}
92 type
93 int64 = integer;
94 {$ENDIF}
95 {$IFDEF POSIX}
96 type
97 TTimeVal = Posix.SysTime.timeval;
98 Ttimezone = record
99 tz_minuteswest: Integer ; // minutes west of Greenwich
100 tz_dsttime: integer ; // type of DST correction
101 end;
102
103 PTimeZone = ^Ttimezone;
104 {$ENDIF}
105
106
107 {:Return your timezone bias from UTC time in minutes.}
TimeZoneBiasnull108 function TimeZoneBias: integer;
109
110 {:Return your timezone bias from UTC time in string representation like "+0200".}
TimeZonenull111 function TimeZone: string;
112
113 {:Returns current time in format defined in RFC-822. Useful for SMTP messages,
114 but other protocols use this time format as well. Results contains the timezone
115 specification. Four digit year is used to break any Y2K concerns. (Example
116 'Fri, 15 Oct 1999 21:14:56 +0200')}
Rfc822DateTimenull117 function Rfc822DateTime(t: TDateTime): string;
118
119 {:Returns date and time in format defined in C compilers in format "mmm dd hh:nn:ss"}
CDateTimenull120 function CDateTime(t: TDateTime): string;
121
122 {:Returns date and time in format defined in format 'yymmdd hhnnss'}
SimpleDateTimenull123 function SimpleDateTime(t: TDateTime): string;
124
125 {:Returns date and time in format defined in ANSI C compilers in format
126 "ddd mmm d hh:nn:ss yyyy" }
AnsiCDateTimenull127 function AnsiCDateTime(t: TDateTime): string;
128
129 {:Decode three-letter string with name of month to their month number. If string
130 not match any month name, then is returned 0. For parsing are used predefined
131 names for English, French and German and names from system locale too.}
GetMonthNumbernull132 function GetMonthNumber(Value: String): integer;
133
134 {:Return decoded time from given string. Time must be witch separator ':'. You
135 can use "hh:mm" or "hh:mm:ss".}
GetTimeFromStrnull136 function GetTimeFromStr(Value: string): TDateTime;
137
138 {:Decode string representation of TimeZone (CEST, GMT, +0200, -0800, etc.)
139 to timezone offset.}
DecodeTimeZonenull140 function DecodeTimeZone(Value: string; var Zone: integer): Boolean;
141
142 {:Decode string in format "m-d-y" to TDateTime type.}
GetDateMDYFromStrnull143 function GetDateMDYFromStr(Value: string): TDateTime;
144
145 {:Decode various string representations of date and time to Tdatetime type.
146 This function do all timezone corrections too! This function can decode lot of
147 formats like:
148 @longcode(#
149 ddd, d mmm yyyy hh:mm:ss
150 ddd, d mmm yy hh:mm:ss
151 ddd, mmm d yyyy hh:mm:ss
152 ddd mmm dd hh:mm:ss yyyy #)
153
154 and more with lot of modifications, include:
155 @longcode(#
156 Sun, 06 Nov 1994 08:49:37 GMT ; RFC 822, updated by RFC 1123
157 Sunday, 06-Nov-94 08:49:37 GMT ; RFC 850, obsoleted by RFC 1036
158 Sun Nov 6 08:49:37 1994 ; ANSI C's asctime() Format
159 #)
160 Timezone corrections known lot of symbolic timezone names (like CEST, EDT, etc.)
161 or numeric representation (like +0200). By convention defined in RFC timezone
162 +0000 is GMT and -0000 is current your system timezone.}
DecodeRfcDateTimenull163 function DecodeRfcDateTime(Value: string): TDateTime;
164
165 {:Return current system date and time in UTC timezone.}
GetUTTimenull166 function GetUTTime: TDateTime;
167
168 {:Set Newdt as current system date and time in UTC timezone. This function work
169 only if you have administrator rights!}
SetUTTimenull170 function SetUTTime(Newdt: TDateTime): Boolean;
171
172 {:Return current value of system timer with precizion 1 millisecond. Good for
173 measure time difference.}
GetTicknull174 function GetTick: LongWord;
175
176 {:Return difference between two timestamps. It working fine only for differences
177 smaller then maxint. (difference must be smaller then 24 days.)}
TickDeltanull178 function TickDelta(TickOld, TickNew: LongWord): LongWord;
179
180 {:Return two characters, which ordinal values represents the value in byte
181 format. (High-endian)}
CodeIntnull182 function CodeInt(Value: Word): Ansistring;
183
184 {:Decodes two characters located at "Index" offset position of the "Value"
185 string to Word values.}
DecodeIntnull186 function DecodeInt(const Value: Ansistring; Index: Integer): Word;
187
188 {:Return four characters, which ordinal values represents the value in byte
189 format. (High-endian)}
CodeLongIntnull190 function CodeLongInt(Value: LongInt): Ansistring;
191
192 {:Decodes four characters located at "Index" offset position of the "Value"
193 string to LongInt values.}
DecodeLongIntnull194 function DecodeLongInt(const Value: Ansistring; Index: Integer): LongInt;
195
196 {:Dump binary buffer stored in a string to a result string.}
DumpStrnull197 function DumpStr(const Buffer: Ansistring): string;
198
199 {:Dump binary buffer stored in a string to a result string. All bytes with code
200 of character is written as character, not as hexadecimal value.}
DumpExStrnull201 function DumpExStr(const Buffer: Ansistring): string;
202
203 {:Dump binary buffer stored in a string to a file with DumpFile filename.}
204 procedure Dump(const Buffer: AnsiString; DumpFile: string);
205
206 {:Dump binary buffer stored in a string to a file with DumpFile filename. All
207 bytes with code of character is written as character, not as hexadecimal value.}
208 procedure DumpEx(const Buffer: AnsiString; DumpFile: string);
209
210 {:Like TrimLeft, but remove only spaces, not control characters!}
TrimSPLeftnull211 function TrimSPLeft(const S: string): string;
212
213 {:Like TrimRight, but remove only spaces, not control characters!}
TrimSPRightnull214 function TrimSPRight(const S: string): string;
215
216 {:Like Trim, but remove only spaces, not control characters!}
TrimSPnull217 function TrimSP(const S: string): string;
218
219 {:Returns a portion of the "Value" string located to the left of the "Delimiter"
220 string. If a delimiter is not found, results is original string.}
SeparateLeftnull221 function SeparateLeft(const Value, Delimiter: string): string;
222
223 {:Returns the portion of the "Value" string located to the right of the
224 "Delimiter" string. If a delimiter is not found, results is original string.}
SeparateRightnull225 function SeparateRight(const Value, Delimiter: string): string;
226
227 {:Returns parameter value from string in format:
228 parameter1="value1"; parameter2=value2}
GetParameternull229 function GetParameter(const Value, Parameter: string): string;
230
231 {:parse value string with elements differed by Delimiter into stringlist.}
232 procedure ParseParametersEx(Value, Delimiter: string; const Parameters: TStrings);
233
234 {:parse value string with elements differed by ';' into stringlist.}
235 procedure ParseParameters(Value: string; const Parameters: TStrings);
236
237 {:Index of string in stringlist with same beginning as Value is returned.}
IndexByBeginnull238 function IndexByBegin(Value: string; const List: TStrings): integer;
239
240 {:Returns only the e-mail portion of an address from the full address format.
241 i.e. returns 'nobody@@somewhere.com' from '"someone" <nobody@@somewhere.com>'}
GetEmailAddrnull242 function GetEmailAddr(const Value: string): string;
243
244 {:Returns only the description part from a full address format. i.e. returns
245 'someone' from '"someone" <nobody@@somewhere.com>'}
GetEmailDescnull246 function GetEmailDesc(Value: string): string;
247
248 {:Returns a string with hexadecimal digits representing the corresponding values
249 of the bytes found in "Value" string.}
StrToHexnull250 function StrToHex(const Value: Ansistring): string;
251
252 {:Returns a string of binary "Digits" representing "Value".}
IntToBinnull253 function IntToBin(Value: Integer; Digits: Byte): string;
254
255 {:Returns an integer equivalent of the binary string in "Value".
256 (i.e. ('10001010') returns 138)}
BinToIntnull257 function BinToInt(const Value: string): Integer;
258
259 {:Parses a URL to its various components.}
ParseURLnull260 function ParseURL(URL: string; var Prot, User, Pass, Host, Port, Path,
261 Para: string): string;
262
263 {:Replaces all "Search" string values found within "Value" string, with the
264 "Replace" string value.}
ReplaceStringnull265 function ReplaceString(Value, Search, Replace: AnsiString): AnsiString;
266
267 {:It is like RPos, but search is from specified possition.}
RPosExnull268 function RPosEx(const Sub, Value: string; From: integer): Integer;
269
270 {:It is like POS function, but from right side of Value string.}
RPosnull271 function RPos(const Sub, Value: String): Integer;
272
273 {:Like @link(fetch), but working with binary strings, not with text.}
FetchBinnull274 function FetchBin(var Value: string; const Delimiter: string): string;
275
276 {:Fetch string from left of Value string.}
Fetchnull277 function Fetch(var Value: string; const Delimiter: string): string;
278
279 {:Fetch string from left of Value string. This function ignore delimitesr inside
280 quotations.}
FetchExnull281 function FetchEx(var Value: string; const Delimiter, Quotation: string): string;
282
283 {:If string is binary string (contains non-printable characters), then is
284 returned true.}
IsBinaryStringnull285 function IsBinaryString(const Value: AnsiString): Boolean;
286
287 {:return position of string terminator in string. If terminator found, then is
288 returned in terminator parameter.
289 Possible line terminators are: CRLF, LFCR, CR, LF}
PosCRLFnull290 function PosCRLF(const Value: AnsiString; var Terminator: AnsiString): integer;
291
292 {:Delete empty strings from end of stringlist.}
293 Procedure StringsTrim(const value: TStrings);
294
295 {:Like Pos function, buf from given string possition.}
PosFromnull296 function PosFrom(const SubStr, Value: String; From: integer): integer;
297
298 {$IFNDEF CIL}
299 {:Increase pointer by value.}
IncPointnull300 function IncPoint(const p: pointer; Value: integer): pointer;
301 {$ENDIF}
302
303 {:Get string between PairBegin and PairEnd. This function respect nesting.
304 For example:
305 @longcode(#
306 Value is: 'Hi! (hello(yes!))'
307 pairbegin is: '('
308 pairend is: ')'
309 In this case result is: 'hello(yes!)'#)}
GetBetweennull310 function GetBetween(const PairBegin, PairEnd, Value: string): string;
311
312 {:Return count of Chr in Value string.}
CountOfCharnull313 function CountOfChar(const Value: string; Chr: char): integer;
314
315 {:Remove quotation from Value string. If Value is not quoted, then return same
316 string without any modification. }
UnquoteStrnull317 function UnquoteStr(const Value: string; Quote: Char): string;
318
319 {:Quote Value string. If Value contains some Quote chars, then it is doubled.}
QuoteStrnull320 function QuoteStr(const Value: string; Quote: Char): string;
321
322 {:Convert lines in stringlist from 'name: value' form to 'name=value' form.}
323 procedure HeadersToList(const Value: TStrings);
324
325 {:Convert lines in stringlist from 'name=value' form to 'name: value' form.}
326 procedure ListToHeaders(const Value: TStrings);
327
328 {:swap bytes in integer.}
SwapBytesnull329 function SwapBytes(Value: integer): integer;
330
331 {:read string with requested length form stream.}
ReadStrFromStreamnull332 function ReadStrFromStream(const Stream: TStream; len: integer): AnsiString;
333
334 {:write string to stream.}
335 procedure WriteStrToStream(const Stream: TStream; Value: AnsiString);
336
337 {:Return filename of new temporary file in Dir (if empty, then default temporary
338 directory is used) and with optional filename prefix.}
GetTempFilenull339 function GetTempFile(const Dir, prefix: String): String;
340
341 {:Return padded string. If length is greater, string is truncated. If length is
342 smaller, string is padded by Pad character.}
PadStringnull343 function PadString(const Value: AnsiString; len: integer; Pad: AnsiChar): AnsiString;
344
345 {:XOR each byte in the strings}
XorStringnull346 function XorString(Indata1, Indata2: AnsiString): AnsiString;
347
348 {:Read header from "Value" stringlist beginning at "Index" position. If header
349 is Splitted into multiple lines, then this procedure de-split it into one line.}
NormalizeHeadernull350 function NormalizeHeader(Value: TStrings; var Index: Integer): string;
351
352 {pf}
353 {:Search for one of line terminators CR, LF or NUL. Return position of the
354 line beginning and length of text.}
355 procedure SearchForLineBreak(var APtr:PANSIChar; AEtx:PANSIChar; out ABol:PANSIChar; out ALength:integer);
356 {:Skip both line terminators CR LF (if any). Move APtr position forward.}
357 procedure SkipLineBreak(var APtr:PANSIChar; AEtx:PANSIChar);
358 {:Skip all blank lines in a buffer starting at APtr and move APtr position forward.}
359 procedure SkipNullLines (var APtr:PANSIChar; AEtx:PANSIChar);
360 {:Copy all lines from a buffer starting at APtr to ALines until empty line
361 or end of the buffer is reached. Move APtr position forward).}
362 procedure CopyLinesFromStreamUntilNullLine(var APtr:PANSIChar; AEtx:PANSIChar; ALines:TStrings);
363 {:Copy all lines from a buffer starting at APtr to ALines until ABoundary
364 or end of the buffer is reached. Move APtr position forward).}
365 procedure CopyLinesFromStreamUntilBoundary(var APtr:PANSIChar; AEtx:PANSIChar; ALines:TStrings; const ABoundary:ANSIString);
366 {:Search ABoundary in a buffer starting at APtr.
367 Return beginning of the ABoundary. Move APtr forward behind a trailing CRLF if any).}
SearchForBoundarynull368 function SearchForBoundary (var APtr:PANSIChar; AEtx:PANSIChar; const ABoundary:ANSIString): PANSIChar;
369 {:Compare a text at position ABOL with ABoundary and return position behind the
370 match (including a trailing CRLF if any).}
MatchBoundarynull371 function MatchBoundary (ABOL,AETX:PANSIChar; const ABoundary:ANSIString): PANSIChar;
372 {:Compare a text at position ABOL with ABoundary + the last boundary suffix
373 and return position behind the match (including a trailing CRLF if any).}
MatchLastBoundarynull374 function MatchLastBoundary (ABOL,AETX:PANSIChar; const ABoundary:ANSIString): PANSIChar;
375 {:Copy data from a buffer starting at position APtr and delimited by AEtx
376 position into ANSIString.}
BuildStringFromBuffernull377 function BuildStringFromBuffer (AStx,AEtx:PANSIChar): ANSIString;
378 {/pf}
379
380 var
381 {:can be used for your own months strings for @link(getmonthnumber)}
382 CustomMonthNames: array[1..12] of string;
383
384 implementation
385
386 {==============================================================================}
387
388 const
389 MyDayNames: array[1..7] of AnsiString =
390 ('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat');
391 var
392 MyMonthNames: array[0..6, 1..12] of String =
393 (
394 ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', //rewrited by system locales
395 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'),
396 ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', //English
397 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'),
398 ('jan', 'f�v', 'mar', 'avr', 'mai', 'jun', //French
399 'jul', 'ao�', 'sep', 'oct', 'nov', 'd�c'),
400 ('jan', 'fev', 'mar', 'avr', 'mai', 'jun', //French#2
401 'jul', 'aou', 'sep', 'oct', 'nov', 'dec'),
402 ('Jan', 'Feb', 'Mar', 'Apr', 'Mai', 'Jun', //German
403 'Jul', 'Aug', 'Sep', 'Okt', 'Nov', 'Dez'),
404 ('Jan', 'Feb', 'M�r', 'Apr', 'Mai', 'Jun', //German#2
405 'Jul', 'Aug', 'Sep', 'Okt', 'Nov', 'Dez'),
406 ('Led', '�no', 'B�e', 'Dub', 'Kv�', '�en', //Czech
407 '�ec', 'Srp', 'Z��', '��j', 'Lis', 'Pro')
408 );
409
410
411 {==============================================================================}
412
TimeZoneBiasnull413 function TimeZoneBias: integer;
414 {$IFNDEF MSWINDOWS}
415 {$IFNDEF FPC}
416 var
417 {$IFDEF POSIX}
418 t: Posix.SysTypes.time_t;
419 UT: Posix.time.tm;
420 {$ELSE}
421 t: TTime_T;
422 UT: TUnixTime;
423 {$ENDIF}
424 begin
425 {$IFDEF POSIX}
426 __time(T);
427 localtime_r(T, UT);
428 Result := UT.tm_gmtoff div 60;
429 {$ELSE}
430 __time(@T);
431 localtime_r(@T, UT);
432 Result := ut.__tm_gmtoff div 60;
433 {$ENDIF}
434 {$ELSE}
435 begin
436 Result := TZSeconds div 60;
437 {$ENDIF}
438 {$ELSE}
439 var
440 zoneinfo: TTimeZoneInformation;
441 bias: Integer;
442 begin
443 case GetTimeZoneInformation(Zoneinfo) of
444 2:
445 bias := zoneinfo.Bias + zoneinfo.DaylightBias;
446 1:
447 bias := zoneinfo.Bias + zoneinfo.StandardBias;
448 else
449 bias := zoneinfo.Bias;
450 end;
451 Result := bias * (-1);
452 {$ENDIF}
453 end;
454
455 {==============================================================================}
456
TimeZonenull457 function TimeZone: string;
458 var
459 bias: Integer;
460 h, m: Integer;
461 begin
462 bias := TimeZoneBias;
463 if bias >= 0 then
464 Result := '+'
465 else
466 Result := '-';
467 bias := Abs(bias);
468 h := bias div 60;
469 m := bias mod 60;
470 Result := Result + Format('%.2d%.2d', [h, m]);
471 end;
472
473 {==============================================================================}
474
Rfc822DateTimenull475 function Rfc822DateTime(t: TDateTime): string;
476 var
477 wYear, wMonth, wDay: word;
478 begin
479 DecodeDate(t, wYear, wMonth, wDay);
480 Result := Format('%s, %d %s %s %s', [MyDayNames[DayOfWeek(t)], wDay,
481 MyMonthNames[1, wMonth], FormatDateTime('yyyy hh":"nn":"ss', t), TimeZone]);
482 end;
483
484 {==============================================================================}
485
CDateTimenull486 function CDateTime(t: TDateTime): string;
487 var
488 wYear, wMonth, wDay: word;
489 begin
490 DecodeDate(t, wYear, wMonth, wDay);
491 Result:= Format('%s %2d %s', [MyMonthNames[1, wMonth], wDay,
492 FormatDateTime('hh":"nn":"ss', t)]);
493 end;
494
495 {==============================================================================}
496
SimpleDateTimenull497 function SimpleDateTime(t: TDateTime): string;
498 begin
499 Result := FormatDateTime('yymmdd hhnnss', t);
500 end;
501
502 {==============================================================================}
503
AnsiCDateTimenull504 function AnsiCDateTime(t: TDateTime): string;
505 var
506 wYear, wMonth, wDay: word;
507 begin
508 DecodeDate(t, wYear, wMonth, wDay);
509 Result := Format('%s %s %d %s', [MyDayNames[DayOfWeek(t)], MyMonthNames[1, wMonth],
510 wDay, FormatDateTime('hh":"nn":"ss yyyy ', t)]);
511 end;
512
513 {==============================================================================}
514
DecodeTimeZonenull515 function DecodeTimeZone(Value: string; var Zone: integer): Boolean;
516 var
517 x: integer;
518 zh, zm: integer;
519 s: string;
520 begin
521 Result := false;
522 s := Value;
523 if (Pos('+', s) = 1) or (Pos('-',s) = 1) then
524 begin
525 if s = '-0000' then
526 Zone := TimeZoneBias
527 else
528 if Length(s) > 4 then
529 begin
530 zh := StrToIntdef(s[2] + s[3], 0);
531 zm := StrToIntdef(s[4] + s[5], 0);
532 zone := zh * 60 + zm;
533 if s[1] = '-' then
534 zone := zone * (-1);
535 end;
536 Result := True;
537 end
538 else
539 begin
540 x := 32767;
541 if s = 'NZDT' then x := 13;
542 if s = 'IDLE' then x := 12;
543 if s = 'NZST' then x := 12;
544 if s = 'NZT' then x := 12;
545 if s = 'EADT' then x := 11;
546 if s = 'GST' then x := 10;
547 if s = 'JST' then x := 9;
548 if s = 'CCT' then x := 8;
549 if s = 'WADT' then x := 8;
550 if s = 'WAST' then x := 7;
551 if s = 'ZP6' then x := 6;
552 if s = 'ZP5' then x := 5;
553 if s = 'ZP4' then x := 4;
554 if s = 'BT' then x := 3;
555 if s = 'EET' then x := 2;
556 if s = 'MEST' then x := 2;
557 if s = 'MESZ' then x := 2;
558 if s = 'SST' then x := 2;
559 if s = 'FST' then x := 2;
560 if s = 'CEST' then x := 2;
561 if s = 'CET' then x := 1;
562 if s = 'FWT' then x := 1;
563 if s = 'MET' then x := 1;
564 if s = 'MEWT' then x := 1;
565 if s = 'SWT' then x := 1;
566 if s = 'UT' then x := 0;
567 if s = 'UTC' then x := 0;
568 if s = 'GMT' then x := 0;
569 if s = 'WET' then x := 0;
570 if s = 'WAT' then x := -1;
571 if s = 'BST' then x := -1;
572 if s = 'AT' then x := -2;
573 if s = 'ADT' then x := -3;
574 if s = 'AST' then x := -4;
575 if s = 'EDT' then x := -4;
576 if s = 'EST' then x := -5;
577 if s = 'CDT' then x := -5;
578 if s = 'CST' then x := -6;
579 if s = 'MDT' then x := -6;
580 if s = 'MST' then x := -7;
581 if s = 'PDT' then x := -7;
582 if s = 'PST' then x := -8;
583 if s = 'YDT' then x := -8;
584 if s = 'YST' then x := -9;
585 if s = 'HDT' then x := -9;
586 if s = 'AHST' then x := -10;
587 if s = 'CAT' then x := -10;
588 if s = 'HST' then x := -10;
589 if s = 'EAST' then x := -10;
590 if s = 'NT' then x := -11;
591 if s = 'IDLW' then x := -12;
592 if x <> 32767 then
593 begin
594 zone := x * 60;
595 Result := True;
596 end;
597 end;
598 end;
599
600 {==============================================================================}
601
GetMonthNumbernull602 function GetMonthNumber(Value: String): integer;
603 var
604 n: integer;
TestMonthnull605 function TestMonth(Value: String; Index: Integer): Boolean;
606 var
607 n: integer;
608 begin
609 Result := False;
610 for n := 0 to 6 do
611 if Value = AnsiUppercase(MyMonthNames[n, Index]) then
612 begin
613 Result := True;
614 Break;
615 end;
616 end;
617 begin
618 Result := 0;
619 Value := AnsiUppercase(Value);
620 for n := 1 to 12 do
621 if TestMonth(Value, n) or (Value = AnsiUppercase(CustomMonthNames[n])) then
622 begin
623 Result := n;
624 Break;
625 end;
626 end;
627
628 {==============================================================================}
629
GetTimeFromStrnull630 function GetTimeFromStr(Value: string): TDateTime;
631 var
632 x: integer;
633 begin
634 x := rpos(':', Value);
635 if (x > 0) and ((Length(Value) - x) > 2) then
636 Value := Copy(Value, 1, x + 2);
637 Value := ReplaceString(Value, ':', {$IFDEF COMPILER15_UP}FormatSettings.{$ENDIF}TimeSeparator);
638 Result := -1;
639 try
640 Result := StrToTime(Value);
641 except
642 on Exception do ;
643 end;
644 end;
645
646 {==============================================================================}
647
GetDateMDYFromStrnull648 function GetDateMDYFromStr(Value: string): TDateTime;
649 var
650 wYear, wMonth, wDay: word;
651 s: string;
652 begin
653 Result := 0;
654 s := Fetch(Value, '-');
655 wMonth := StrToIntDef(s, 12);
656 s := Fetch(Value, '-');
657 wDay := StrToIntDef(s, 30);
658 wYear := StrToIntDef(Value, 1899);
659 if wYear < 1000 then
660 if (wYear > 99) then
661 wYear := wYear + 1900
662 else
663 if wYear > 50 then
664 wYear := wYear + 1900
665 else
666 wYear := wYear + 2000;
667 try
668 Result := EncodeDate(wYear, wMonth, wDay);
669 except
670 on Exception do ;
671 end;
672 end;
673
674 {==============================================================================}
675
DecodeRfcDateTimenull676 function DecodeRfcDateTime(Value: string): TDateTime;
677 var
678 day, month, year: Word;
679 zone: integer;
680 x, y: integer;
681 s: string;
682 t: TDateTime;
683 begin
684 // ddd, d mmm yyyy hh:mm:ss
685 // ddd, d mmm yy hh:mm:ss
686 // ddd, mmm d yyyy hh:mm:ss
687 // ddd mmm dd hh:mm:ss yyyy
688 // Sun, 06 Nov 1994 08:49:37 GMT ; RFC 822, updated by RFC 1123
689 // Sunday, 06-Nov-94 08:49:37 GMT ; RFC 850, obsoleted by RFC 1036
690 // Sun Nov 6 08:49:37 1994 ; ANSI C's asctime() Format
691
692 Result := 0;
693 if Value = '' then
694 Exit;
695 day := 0;
696 month := 0;
697 year := 0;
698 zone := 0;
699 Value := ReplaceString(Value, ' -', ' #');
700 Value := ReplaceString(Value, '-', ' ');
701 Value := ReplaceString(Value, ' #', ' -');
702 while Value <> '' do
703 begin
704 s := Fetch(Value, ' ');
705 s := uppercase(s);
706 // timezone
707 if DecodetimeZone(s, x) then
708 begin
709 zone := x;
710 continue;
711 end;
712 x := StrToIntDef(s, 0);
713 // day or year
714 if x > 0 then
715 if (x < 32) and (day = 0) then
716 begin
717 day := x;
718 continue;
719 end
720 else
721 begin
722 if (year = 0) and ((month > 0) or (x > 12)) then
723 begin
724 year := x;
725 if year < 32 then
726 year := year + 2000;
727 if year < 1000 then
728 year := year + 1900;
729 continue;
730 end;
731 end;
732 // time
733 if rpos(':', s) > Pos(':', s) then
734 begin
735 t := GetTimeFromStr(s);
736 if t <> -1 then
737 Result := t;
738 continue;
739 end;
740 //timezone daylight saving time
741 if s = 'DST' then
742 begin
743 zone := zone + 60;
744 continue;
745 end;
746 // month
747 y := GetMonthNumber(s);
748 if (y > 0) and (month = 0) then
749 month := y;
750 end;
751 if year = 0 then
752 year := 1980;
753 if month < 1 then
754 month := 1;
755 if month > 12 then
756 month := 12;
757 if day < 1 then
758 day := 1;
759 x := MonthDays[IsLeapYear(year), month];
760 if day > x then
761 day := x;
762 Result := Result + Encodedate(year, month, day);
763 zone := zone - TimeZoneBias;
764 x := zone div 1440;
765 Result := Result - x;
766 zone := zone mod 1440;
767 t := EncodeTime(Abs(zone) div 60, Abs(zone) mod 60, 0, 0);
768 if zone < 0 then
769 t := 0 - t;
770 Result := Result - t;
771 end;
772
773 {==============================================================================}
774
775 function GetUTTime: TDateTime;
776 {$IFDEF MSWINDOWS}
777 {$IFNDEF FPC}
778 var
779 st: TSystemTime;
780 begin
781 GetSystemTime(st);
782 result := SystemTimeToDateTime(st);
783 {$ELSE}
784 var
785 st: SysUtils.TSystemTime;
786 stw: Windows.TSystemTime;
787 begin
788 GetSystemTime(stw);
789 st.Year := stw.wYear;
790 st.Month := stw.wMonth;
791 st.Day := stw.wDay;
792 st.Hour := stw.wHour;
793 st.Minute := stw.wMinute;
794 st.Second := stw.wSecond;
795 st.Millisecond := stw.wMilliseconds;
796 result := SystemTimeToDateTime(st);
797 {$ENDIF}
798 {$ELSE MSWINDOWS}
799 {$IFNDEF FPC}
800 var
801 TV: TTimeVal;
802 begin
803 gettimeofday(TV, nil);
804 Result := UnixDateDelta + (TV.tv_sec + TV.tv_usec / 1000000) / 86400;
805 {$ELSE FPC}
806 {$IFDEF UNIX}
807 var
808 TV: TimeVal;
809 begin
810 fpgettimeofday(@TV, nil);
811 Result := UnixDateDelta + (TV.tv_sec + TV.tv_usec / 1000000) / 86400;
812 {$ELSE UNIX}
813 {$IFDEF OS2}
814 var
815 ST: TSystemTime;
816 begin
817 GetLocalTime (ST);
818 Result := SystemTimeToDateTime (ST);
819 {$ENDIF OS2}
820 {$ENDIF UNIX}
821 {$ENDIF FPC}
822 {$ENDIF MSWINDOWS}
823 end;
824
825 {==============================================================================}
826
827 function SetUTTime(Newdt: TDateTime): Boolean;
828 {$IFDEF MSWINDOWS}
829 {$IFNDEF FPC}
830 var
831 st: TSystemTime;
832 begin
833 DateTimeToSystemTime(newdt,st);
834 Result := SetSystemTime(st);
835 {$ELSE}
836 var
837 st: SysUtils.TSystemTime;
838 stw: Windows.TSystemTime;
839 begin
840 DateTimeToSystemTime(newdt,st);
841 stw.wYear := st.Year;
842 stw.wMonth := st.Month;
843 stw.wDay := st.Day;
844 stw.wHour := st.Hour;
845 stw.wMinute := st.Minute;
846 stw.wSecond := st.Second;
847 stw.wMilliseconds := st.Millisecond;
848 Result := SetSystemTime(stw);
849 {$ENDIF}
850 {$ELSE MSWINDOWS}
851 {$IFNDEF FPC}
852 var
853 TV: TTimeVal;
854 d: double;
855 TZ: Ttimezone;
856 PZ: PTimeZone;
857 begin
858 TZ.tz_minuteswest := 0;
859 TZ.tz_dsttime := 0;
860 PZ := @TZ;
861 gettimeofday(TV, PZ);
862 d := (newdt - UnixDateDelta) * 86400;
863 TV.tv_sec := trunc(d);
864 TV.tv_usec := trunc(frac(d) * 1000000);
865 {$IFNDEF POSIX}
866 Result := settimeofday(TV, TZ) <> -1;
867 {$ELSE}
868 Result := False; // in POSIX settimeofday is not defined? http://www.kernel.org/doc/man-pages/online/pages/man2/gettimeofday.2.html
869 {$ENDIF}
870 {$ELSE FPC}
871 {$IFDEF UNIX}
872 var
873 TV: TimeVal;
874 d: double;
875 begin
876 d := (newdt - UnixDateDelta) * 86400;
877 TV.tv_sec := trunc(d);
878 TV.tv_usec := trunc(frac(d) * 1000000);
879 Result := fpsettimeofday(@TV, nil) <> -1;
880 {$ELSE UNIX}
881 {$IFDEF OS2}
882 var
883 ST: TSystemTime;
884 begin
885 DateTimeToSystemTime (NewDT, ST);
886 SetTime (ST.Hour, ST.Minute, ST.Second, ST.Millisecond div 10);
887 Result := true;
888 {$ENDIF OS2}
889 {$ENDIF UNIX}
890 {$ENDIF FPC}
891 {$ENDIF MSWINDOWS}
892 end;
893
894 {==============================================================================}
895
896 {$IFNDEF MSWINDOWS}
897 function GetTick: LongWord;
898 var
899 Stamp: TTimeStamp;
900 begin
901 Stamp := DateTimeToTimeStamp(Now);
902 Result := Stamp.Time;
903 end;
904 {$ELSE}
905 function GetTick: LongWord;
906 var
907 tick, freq: TLargeInteger;
908 {$IFDEF VER100}
909 x: TLargeInteger;
910 {$ENDIF}
911 begin
912 if Windows.QueryPerformanceFrequency(freq) then
913 begin
914 Windows.QueryPerformanceCounter(tick);
915 {$IFDEF VER100}
916 x.QuadPart := (tick.QuadPart / freq.QuadPart) * 1000;
917 Result := x.LowPart;
918 {$ELSE}
919 Result := Trunc((tick / freq) * 1000) and High(LongWord)
920 {$ENDIF}
921 end
922 else
923 Result := Windows.GetTickCount;
924 end;
925 {$ENDIF}
926
927 {==============================================================================}
928
929 function TickDelta(TickOld, TickNew: LongWord): LongWord;
930 begin
931 //if DWord is signed type (older Deplhi),
932 // then it not work properly on differencies larger then maxint!
933 Result := 0;
934 if TickOld <> TickNew then
935 begin
936 if TickNew < TickOld then
937 begin
938 TickNew := TickNew + LongWord(MaxInt) + 1;
939 TickOld := TickOld + LongWord(MaxInt) + 1;
940 end;
941 Result := TickNew - TickOld;
942 if TickNew < TickOld then
943 if Result > 0 then
944 Result := 0 - Result;
945 end;
946 end;
947
948 {==============================================================================}
949
950 function CodeInt(Value: Word): Ansistring;
951 begin
952 setlength(result, 2);
953 result[1] := AnsiChar(Value div 256);
954 result[2] := AnsiChar(Value mod 256);
955 // Result := AnsiChar(Value div 256) + AnsiChar(Value mod 256)
956 end;
957
958 {==============================================================================}
959
960 function DecodeInt(const Value: Ansistring; Index: Integer): Word;
961 var
962 x, y: Byte;
963 begin
964 if Length(Value) > Index then
965 x := Ord(Value[Index])
966 else
967 x := 0;
968 if Length(Value) >= (Index + 1) then
969 y := Ord(Value[Index + 1])
970 else
971 y := 0;
972 Result := x * 256 + y;
973 end;
974
975 {==============================================================================}
976
977 function CodeLongInt(Value: Longint): Ansistring;
978 var
979 x, y: word;
980 begin
981 // this is fix for negative numbers on systems where longint = integer
982 x := (Value shr 16) and integer($ffff);
983 y := Value and integer($ffff);
984 setlength(result, 4);
985 result[1] := AnsiChar(x div 256);
986 result[2] := AnsiChar(x mod 256);
987 result[3] := AnsiChar(y div 256);
988 result[4] := AnsiChar(y mod 256);
989 end;
990
991 {==============================================================================}
992
993 function DecodeLongInt(const Value: Ansistring; Index: Integer): LongInt;
994 var
995 x, y: Byte;
996 xl, yl: Byte;
997 begin
998 if Length(Value) > Index then
999 x := Ord(Value[Index])
1000 else
1001 x := 0;
1002 if Length(Value) >= (Index + 1) then
1003 y := Ord(Value[Index + 1])
1004 else
1005 y := 0;
1006 if Length(Value) >= (Index + 2) then
1007 xl := Ord(Value[Index + 2])
1008 else
1009 xl := 0;
1010 if Length(Value) >= (Index + 3) then
1011 yl := Ord(Value[Index + 3])
1012 else
1013 yl := 0;
1014 Result := ((x * 256 + y) * 65536) + (xl * 256 + yl);
1015 end;
1016
1017 {==============================================================================}
1018
1019 function DumpStr(const Buffer: Ansistring): string;
1020 var
1021 n: Integer;
1022 begin
1023 Result := '';
1024 for n := 1 to Length(Buffer) do
1025 Result := Result + ' +#$' + IntToHex(Ord(Buffer[n]), 2);
1026 end;
1027
1028 {==============================================================================}
1029
1030 function DumpExStr(const Buffer: Ansistring): string;
1031 var
1032 n: Integer;
1033 x: Byte;
1034 begin
1035 Result := '';
1036 for n := 1 to Length(Buffer) do
1037 begin
1038 x := Ord(Buffer[n]);
1039 if x in [65..90, 97..122] then
1040 Result := Result + ' +''' + char(x) + ''''
1041 else
1042 Result := Result + ' +#$' + IntToHex(Ord(Buffer[n]), 2);
1043 end;
1044 end;
1045
1046 {==============================================================================}
1047
1048 procedure Dump(const Buffer: AnsiString; DumpFile: string);
1049 var
1050 f: Text;
1051 begin
1052 AssignFile(f, DumpFile);
1053 if FileExists(DumpFile) then
1054 DeleteFile(DumpFile);
1055 Rewrite(f);
1056 try
1057 Writeln(f, DumpStr(Buffer));
1058 finally
1059 CloseFile(f);
1060 end;
1061 end;
1062
1063 {==============================================================================}
1064
1065 procedure DumpEx(const Buffer: AnsiString; DumpFile: string);
1066 var
1067 f: Text;
1068 begin
1069 AssignFile(f, DumpFile);
1070 if FileExists(DumpFile) then
1071 DeleteFile(DumpFile);
1072 Rewrite(f);
1073 try
1074 Writeln(f, DumpExStr(Buffer));
1075 finally
1076 CloseFile(f);
1077 end;
1078 end;
1079
1080 {==============================================================================}
1081
1082 function TrimSPLeft(const S: string): string;
1083 var
1084 I, L: Integer;
1085 begin
1086 Result := '';
1087 if S = '' then
1088 Exit;
1089 L := Length(S);
1090 I := 1;
1091 while (I <= L) and (S[I] = ' ') do
1092 Inc(I);
1093 Result := Copy(S, I, Maxint);
1094 end;
1095
1096 {==============================================================================}
1097
1098 function TrimSPRight(const S: string): string;
1099 var
1100 I: Integer;
1101 begin
1102 Result := '';
1103 if S = '' then
1104 Exit;
1105 I := Length(S);
1106 while (I > 0) and (S[I] = ' ') do
1107 Dec(I);
1108 Result := Copy(S, 1, I);
1109 end;
1110
1111 {==============================================================================}
1112
1113 function TrimSP(const S: string): string;
1114 begin
1115 Result := TrimSPLeft(s);
1116 Result := TrimSPRight(Result);
1117 end;
1118
1119 {==============================================================================}
1120
1121 function SeparateLeft(const Value, Delimiter: string): string;
1122 var
1123 x: Integer;
1124 begin
1125 x := Pos(Delimiter, Value);
1126 if x < 1 then
1127 Result := Value
1128 else
1129 Result := Copy(Value, 1, x - 1);
1130 end;
1131
1132 {==============================================================================}
1133
1134 function SeparateRight(const Value, Delimiter: string): string;
1135 var
1136 x: Integer;
1137 begin
1138 x := Pos(Delimiter, Value);
1139 if x > 0 then
1140 x := x + Length(Delimiter) - 1;
1141 Result := Copy(Value, x + 1, Length(Value) - x);
1142 end;
1143
1144 {==============================================================================}
1145
1146 function GetParameter(const Value, Parameter: string): string;
1147 var
1148 s: string;
1149 v: string;
1150 begin
1151 Result := '';
1152 v := Value;
1153 while v <> '' do
1154 begin
1155 s := Trim(FetchEx(v, ';', '"'));
1156 if Pos(Uppercase(parameter), Uppercase(s)) = 1 then
1157 begin
1158 Delete(s, 1, Length(Parameter));
1159 s := Trim(s);
1160 if s = '' then
1161 Break;
1162 if s[1] = '=' then
1163 begin
1164 Result := Trim(SeparateRight(s, '='));
1165 Result := UnquoteStr(Result, '"');
1166 break;
1167 end;
1168 end;
1169 end;
1170 end;
1171
1172 {==============================================================================}
1173
1174 procedure ParseParametersEx(Value, Delimiter: string; const Parameters: TStrings);
1175 var
1176 s: string;
1177 begin
1178 Parameters.Clear;
1179 while Value <> '' do
1180 begin
1181 s := Trim(FetchEx(Value, Delimiter, '"'));
1182 Parameters.Add(s);
1183 end;
1184 end;
1185
1186 {==============================================================================}
1187
1188 procedure ParseParameters(Value: string; const Parameters: TStrings);
1189 begin
1190 ParseParametersEx(Value, ';', Parameters);
1191 end;
1192
1193 {==============================================================================}
1194
1195 function IndexByBegin(Value: string; const List: TStrings): integer;
1196 var
1197 n: integer;
1198 s: string;
1199 begin
1200 Result := -1;
1201 Value := uppercase(Value);
1202 for n := 0 to List.Count -1 do
1203 begin
1204 s := UpperCase(List[n]);
1205 if Pos(Value, s) = 1 then
1206 begin
1207 Result := n;
1208 Break;
1209 end;
1210 end;
1211 end;
1212
1213 {==============================================================================}
1214
1215 function GetEmailAddr(const Value: string): string;
1216 var
1217 s: string;
1218 begin
1219 s := SeparateRight(Value, '<');
1220 s := SeparateLeft(s, '>');
1221 Result := Trim(s);
1222 end;
1223
1224 {==============================================================================}
1225
1226 function GetEmailDesc(Value: string): string;
1227 var
1228 s: string;
1229 begin
1230 Value := Trim(Value);
1231 s := SeparateRight(Value, '"');
1232 if s <> Value then
1233 s := SeparateLeft(s, '"')
1234 else
1235 begin
1236 s := SeparateLeft(Value, '<');
1237 if s = Value then
1238 begin
1239 s := SeparateRight(Value, '(');
1240 if s <> Value then
1241 s := SeparateLeft(s, ')')
1242 else
1243 s := '';
1244 end;
1245 end;
1246 Result := Trim(s);
1247 end;
1248
1249 {==============================================================================}
1250
1251 function StrToHex(const Value: Ansistring): string;
1252 var
1253 n: Integer;
1254 begin
1255 Result := '';
1256 for n := 1 to Length(Value) do
1257 Result := Result + IntToHex(Byte(Value[n]), 2);
1258 Result := LowerCase(Result);
1259 end;
1260
1261 {==============================================================================}
1262
1263 function IntToBin(Value: Integer; Digits: Byte): string;
1264 var
1265 x, y, n: Integer;
1266 begin
1267 Result := '';
1268 x := Value;
1269 repeat
1270 y := x mod 2;
1271 x := x div 2;
1272 if y > 0 then
1273 Result := '1' + Result
1274 else
1275 Result := '0' + Result;
1276 until x = 0;
1277 x := Length(Result);
1278 for n := x to Digits - 1 do
1279 Result := '0' + Result;
1280 end;
1281
1282 {==============================================================================}
1283
1284 function BinToInt(const Value: string): Integer;
1285 var
1286 n: Integer;
1287 begin
1288 Result := 0;
1289 for n := 1 to Length(Value) do
1290 begin
1291 if Value[n] = '0' then
1292 Result := Result * 2
1293 else
1294 if Value[n] = '1' then
1295 Result := Result * 2 + 1
1296 else
1297 Break;
1298 end;
1299 end;
1300
1301 {==============================================================================}
1302
1303 function ParseURL(URL: string; var Prot, User, Pass, Host, Port, Path,
1304 Para: string): string;
1305 var
1306 x, y: Integer;
1307 sURL: string;
1308 s: string;
1309 s1, s2: string;
1310 begin
1311 Prot := 'http';
1312 User := '';
1313 Pass := '';
1314 Port := '80';
1315 Para := '';
1316
1317 x := Pos('://', URL);
1318 if x > 0 then
1319 begin
1320 Prot := SeparateLeft(URL, '://');
1321 sURL := SeparateRight(URL, '://');
1322 end
1323 else
1324 sURL := URL;
1325 if UpperCase(Prot) = 'HTTPS' then
1326 Port := '443';
1327 if UpperCase(Prot) = 'FTP' then
1328 Port := '21';
1329 x := Pos('@', sURL);
1330 y := Pos('/', sURL);
1331 if (x > 0) and ((x < y) or (y < 1))then
1332 begin
1333 s := SeparateLeft(sURL, '@');
1334 sURL := SeparateRight(sURL, '@');
1335 x := Pos(':', s);
1336 if x > 0 then
1337 begin
1338 User := SeparateLeft(s, ':');
1339 Pass := SeparateRight(s, ':');
1340 end
1341 else
1342 User := s;
1343 end;
1344 x := Pos('/', sURL);
1345 if x > 0 then
1346 begin
1347 s1 := SeparateLeft(sURL, '/');
1348 s2 := SeparateRight(sURL, '/');
1349 end
1350 else
1351 begin
1352 s1 := sURL;
1353 s2 := '';
1354 end;
1355 if Pos('[', s1) = 1 then
1356 begin
1357 Host := Separateleft(s1, ']');
1358 Delete(Host, 1, 1);
1359 s1 := SeparateRight(s1, ']');
1360 if Pos(':', s1) = 1 then
1361 Port := SeparateRight(s1, ':');
1362 end
1363 else
1364 begin
1365 x := Pos(':', s1);
1366 if x > 0 then
1367 begin
1368 Host := SeparateLeft(s1, ':');
1369 Port := SeparateRight(s1, ':');
1370 end
1371 else
1372 Host := s1;
1373 end;
1374 Result := '/' + s2;
1375 x := Pos('?', s2);
1376 if x > 0 then
1377 begin
1378 Path := '/' + SeparateLeft(s2, '?');
1379 Para := SeparateRight(s2, '?');
1380 end
1381 else
1382 Path := '/' + s2;
1383 if Host = '' then
1384 Host := 'localhost';
1385 end;
1386
1387 {==============================================================================}
1388
1389 function ReplaceString(Value, Search, Replace: AnsiString): AnsiString;
1390 var
1391 x, l, ls, lr: Integer;
1392 begin
1393 if (Value = '') or (Search = '') then
1394 begin
1395 Result := Value;
1396 Exit;
1397 end;
1398 ls := Length(Search);
1399 lr := Length(Replace);
1400 Result := '';
1401 x := Pos(Search, Value);
1402 while x > 0 do
1403 begin
1404 {$IFNDEF CIL}
1405 l := Length(Result);
1406 SetLength(Result, l + x - 1);
1407 Move(Pointer(Value)^, Pointer(@Result[l + 1])^, x - 1);
1408 {$ELSE}
1409 Result:=Result+Copy(Value,1,x-1);
1410 {$ENDIF}
1411 {$IFNDEF CIL}
1412 l := Length(Result);
1413 SetLength(Result, l + lr);
1414 Move(Pointer(Replace)^, Pointer(@Result[l + 1])^, lr);
1415 {$ELSE}
1416 Result:=Result+Replace;
1417 {$ENDIF}
1418 Delete(Value, 1, x - 1 + ls);
1419 x := Pos(Search, Value);
1420 end;
1421 Result := Result + Value;
1422 end;
1423
1424 {==============================================================================}
1425
1426 function RPosEx(const Sub, Value: string; From: integer): Integer;
1427 var
1428 n: Integer;
1429 l: Integer;
1430 begin
1431 result := 0;
1432 l := Length(Sub);
1433 for n := From - l + 1 downto 1 do
1434 begin
1435 if Copy(Value, n, l) = Sub then
1436 begin
1437 result := n;
1438 break;
1439 end;
1440 end;
1441 end;
1442
1443 {==============================================================================}
1444
1445 function RPos(const Sub, Value: String): Integer;
1446 begin
1447 Result := RPosEx(Sub, Value, Length(Value));
1448 end;
1449
1450 {==============================================================================}
1451
1452 function FetchBin(var Value: string; const Delimiter: string): string;
1453 var
1454 s: string;
1455 begin
1456 Result := SeparateLeft(Value, Delimiter);
1457 s := SeparateRight(Value, Delimiter);
1458 if s = Value then
1459 Value := ''
1460 else
1461 Value := s;
1462 end;
1463
1464 {==============================================================================}
1465
1466 function Fetch(var Value: string; const Delimiter: string): string;
1467 begin
1468 Result := FetchBin(Value, Delimiter);
1469 Result := TrimSP(Result);
1470 Value := TrimSP(Value);
1471 end;
1472
1473 {==============================================================================}
1474
1475 function FetchEx(var Value: string; const Delimiter, Quotation: string): string;
1476 var
1477 b: Boolean;
1478 begin
1479 Result := '';
1480 b := False;
1481 while Length(Value) > 0 do
1482 begin
1483 if b then
1484 begin
1485 if Pos(Quotation, Value) = 1 then
1486 b := False;
1487 Result := Result + Value[1];
1488 Delete(Value, 1, 1);
1489 end
1490 else
1491 begin
1492 if Pos(Delimiter, Value) = 1 then
1493 begin
1494 Delete(Value, 1, Length(delimiter));
1495 break;
1496 end;
1497 b := Pos(Quotation, Value) = 1;
1498 Result := Result + Value[1];
1499 Delete(Value, 1, 1);
1500 end;
1501 end;
1502 end;
1503
1504 {==============================================================================}
1505
1506 function IsBinaryString(const Value: AnsiString): Boolean;
1507 var
1508 n: integer;
1509 begin
1510 Result := False;
1511 for n := 1 to Length(Value) do
1512 if Value[n] in [#0..#8, #10..#31] then
1513 //ignore null-terminated strings
1514 if not ((n = Length(value)) and (Value[n] = AnsiChar(#0))) then
1515 begin
1516 Result := True;
1517 Break;
1518 end;
1519 end;
1520
1521 {==============================================================================}
1522
1523 function PosCRLF(const Value: AnsiString; var Terminator: AnsiString): integer;
1524 var
1525 n, l: integer;
1526 begin
1527 Result := -1;
1528 Terminator := '';
1529 l := length(value);
1530 for n := 1 to l do
1531 if value[n] in [#$0d, #$0a] then
1532 begin
1533 Result := n;
1534 Terminator := Value[n];
1535 if n <> l then
1536 case value[n] of
1537 #$0d:
1538 if value[n + 1] = #$0a then
1539 Terminator := #$0d + #$0a;
1540 #$0a:
1541 if value[n + 1] = #$0d then
1542 Terminator := #$0a + #$0d;
1543 end;
1544 Break;
1545 end;
1546 end;
1547
1548 {==============================================================================}
1549
1550 Procedure StringsTrim(const Value: TStrings);
1551 var
1552 n: integer;
1553 begin
1554 for n := Value.Count - 1 downto 0 do
1555 if Value[n] = '' then
1556 Value.Delete(n)
1557 else
1558 Break;
1559 end;
1560
1561 {==============================================================================}
1562
1563 function PosFrom(const SubStr, Value: String; From: integer): integer;
1564 var
1565 ls,lv: integer;
1566 begin
1567 Result := 0;
1568 ls := Length(SubStr);
1569 lv := Length(Value);
1570 if (ls = 0) or (lv = 0) then
1571 Exit;
1572 if From < 1 then
1573 From := 1;
1574 while (ls + from - 1) <= (lv) do
1575 begin
1576 {$IFNDEF CIL}
1577 if CompareMem(@SubStr[1],@Value[from],ls) then
1578 {$ELSE}
1579 if SubStr = copy(Value, from, ls) then
1580 {$ENDIF}
1581 begin
1582 result := from;
1583 break;
1584 end
1585 else
1586 inc(from);
1587 end;
1588 end;
1589
1590 {==============================================================================}
1591
1592 {$IFNDEF CIL}
1593 function IncPoint(const p: pointer; Value: integer): pointer;
1594 begin
1595 Result := PAnsiChar(p) + Value;
1596 end;
1597 {$ENDIF}
1598
1599 {==============================================================================}
1600 //improved by 'DoggyDawg'
1601 function GetBetween(const PairBegin, PairEnd, Value: string): string;
1602 var
1603 n: integer;
1604 x: integer;
1605 s: string;
1606 lenBegin: integer;
1607 lenEnd: integer;
1608 str: string;
1609 max: integer;
1610 begin
1611 lenBegin := Length(PairBegin);
1612 lenEnd := Length(PairEnd);
1613 n := Length(Value);
1614 if (Value = PairBegin + PairEnd) then
1615 begin
1616 Result := '';//nothing between
1617 exit;
1618 end;
1619 if (n < lenBegin + lenEnd) then
1620 begin
1621 Result := Value;
1622 exit;
1623 end;
1624 s := SeparateRight(Value, PairBegin);
1625 if (s = Value) then
1626 begin
1627 Result := Value;
1628 exit;
1629 end;
1630 n := Pos(PairEnd, s);
1631 if (n = 0) then
1632 begin
1633 Result := Value;
1634 exit;
1635 end;
1636 Result := '';
1637 x := 1;
1638 max := Length(s) - lenEnd + 1;
1639 for n := 1 to max do
1640 begin
1641 str := copy(s, n, lenEnd);
1642 if (str = PairEnd) then
1643 begin
1644 Dec(x);
1645 if (x <= 0) then
1646 Break;
1647 end;
1648 str := copy(s, n, lenBegin);
1649 if (str = PairBegin) then
1650 Inc(x);
1651 Result := Result + s[n];
1652 end;
1653 end;
1654
1655 {==============================================================================}
1656
1657 function CountOfChar(const Value: string; Chr: char): integer;
1658 var
1659 n: integer;
1660 begin
1661 Result := 0;
1662 for n := 1 to Length(Value) do
1663 if Value[n] = chr then
1664 Inc(Result);
1665 end;
1666
1667 {==============================================================================}
1668 // ! do not use AnsiExtractQuotedStr, it's very buggy and can crash application!
UnquoteStrnull1669 function UnquoteStr(const Value: string; Quote: Char): string;
1670 var
1671 n: integer;
1672 inq, dq: Boolean;
1673 c, cn: char;
1674 begin
1675 Result := '';
1676 if Value = '' then
1677 Exit;
1678 if Value = Quote + Quote then
1679 Exit;
1680 inq := False;
1681 dq := False;
1682 for n := 1 to Length(Value) do
1683 begin
1684 c := Value[n];
1685 if n <> Length(Value) then
1686 cn := Value[n + 1]
1687 else
1688 cn := #0;
1689 if c = quote then
1690 if dq then
1691 dq := False
1692 else
1693 if not inq then
1694 inq := True
1695 else
1696 if cn = quote then
1697 begin
1698 Result := Result + Quote;
1699 dq := True;
1700 end
1701 else
1702 inq := False
1703 else
1704 Result := Result + c;
1705 end;
1706 end;
1707
1708 {==============================================================================}
1709
QuoteStrnull1710 function QuoteStr(const Value: string; Quote: Char): string;
1711 var
1712 n: integer;
1713 begin
1714 Result := '';
1715 for n := 1 to length(value) do
1716 begin
1717 Result := result + Value[n];
1718 if value[n] = Quote then
1719 Result := Result + Quote;
1720 end;
1721 Result := Quote + Result + Quote;
1722 end;
1723
1724 {==============================================================================}
1725
1726 procedure HeadersToList(const Value: TStrings);
1727 var
1728 n, x, y: integer;
1729 s: string;
1730 begin
1731 for n := 0 to Value.Count -1 do
1732 begin
1733 s := Value[n];
1734 x := Pos(':', s);
1735 if x > 0 then
1736 begin
1737 y:= Pos('=',s);
1738 if not ((y > 0) and (y < x)) then
1739 begin
1740 s[x] := '=';
1741 Value[n] := s;
1742 end;
1743 end;
1744 end;
1745 end;
1746
1747 {==============================================================================}
1748
1749 procedure ListToHeaders(const Value: TStrings);
1750 var
1751 n, x: integer;
1752 s: string;
1753 begin
1754 for n := 0 to Value.Count -1 do
1755 begin
1756 s := Value[n];
1757 x := Pos('=', s);
1758 if x > 0 then
1759 begin
1760 s[x] := ':';
1761 Value[n] := s;
1762 end;
1763 end;
1764 end;
1765
1766 {==============================================================================}
1767
SwapBytesnull1768 function SwapBytes(Value: integer): integer;
1769 var
1770 s: AnsiString;
1771 x, y, xl, yl: Byte;
1772 begin
1773 s := CodeLongInt(Value);
1774 x := Ord(s[4]);
1775 y := Ord(s[3]);
1776 xl := Ord(s[2]);
1777 yl := Ord(s[1]);
1778 Result := ((x * 256 + y) * 65536) + (xl * 256 + yl);
1779 end;
1780
1781 {==============================================================================}
1782
ReadStrFromStreamnull1783 function ReadStrFromStream(const Stream: TStream; len: integer): AnsiString;
1784 var
1785 x: integer;
1786 {$IFDEF CIL}
1787 buf: Array of Byte;
1788 {$ENDIF}
1789 begin
1790 {$IFDEF CIL}
1791 Setlength(buf, Len);
1792 x := Stream.read(buf, Len);
1793 SetLength(buf, x);
1794 Result := StringOf(Buf);
1795 {$ELSE}
1796 Setlength(Result, Len);
1797 x := Stream.read(PAnsiChar(Result)^, Len);
1798 SetLength(Result, x);
1799 {$ENDIF}
1800 end;
1801
1802 {==============================================================================}
1803
1804 procedure WriteStrToStream(const Stream: TStream; Value: AnsiString);
1805 {$IFDEF CIL}
1806 var
1807 buf: Array of Byte;
1808 {$ENDIF}
1809 begin
1810 {$IFDEF CIL}
1811 buf := BytesOf(Value);
1812 Stream.Write(buf,length(Value));
1813 {$ELSE}
1814 Stream.Write(PAnsiChar(Value)^, Length(Value));
1815 {$ENDIF}
1816 end;
1817
1818 {==============================================================================}
1819
1820 {$IFDEF POSIX}
tempnamnull1821 function tempnam(const Path: PAnsiChar; const Prefix: PAnsiChar): PAnsiChar; cdecl;
1822 external libc name _PU + 'tempnam';
1823 {$ENDIF}
1824
GetTempFilenull1825 function GetTempFile(const Dir, prefix: String): String;
1826 {$IFNDEF FPC}
1827 {$IFDEF MSWINDOWS}
1828 var
1829 Path: String;
1830 x: integer;
1831 {$ENDIF}
1832 {$ENDIF}
1833 begin
1834 {$IFDEF FPC}
1835 Result := GetTempFileName(Dir, Prefix);
1836 {$ELSE}
1837 {$IFNDEF MSWINDOWS}
1838 Result := tempnam(Pointer(Dir), Pointer(prefix));
1839 {$ELSE}
1840 {$IFDEF CIL}
1841 Result := System.IO.Path.GetTempFileName;
1842 {$ELSE}
1843 if Dir = '' then
1844 begin
1845 Path := StringOfChar(#0, MAX_PATH);
1846 x := GetTempPath(Length(Path), PChar(Path));
1847 Path := PChar(Path);
1848 end
1849 else
1850 Path := Dir;
1851 x := Length(Path);
1852 if Path[x] <> '\' then
1853 Path := Path + '\';
1854 Result := StringOfChar(#0, MAX_PATH);
1855 GetTempFileName(PChar(Path), PChar(Prefix), 0, PChar(Result));
1856 Result := PChar(Result);
1857 SetFileattributes(PChar(Result), GetFileAttributes(PChar(Result)) or FILE_ATTRIBUTE_TEMPORARY);
1858 {$ENDIF}
1859 {$ENDIF}
1860 {$ENDIF}
1861 end;
1862
1863 {==============================================================================}
1864
PadStringnull1865 function PadString(const Value: AnsiString; len: integer; Pad: AnsiChar): AnsiString;
1866 begin
1867 if length(value) >= len then
1868 Result := Copy(value, 1, len)
1869 else
1870 Result := Value + StringOfChar(Pad, len - length(value));
1871 end;
1872
1873 {==============================================================================}
1874
XorStringnull1875 function XorString(Indata1, Indata2: AnsiString): AnsiString;
1876 var
1877 i: integer;
1878 begin
1879 Indata2 := PadString(Indata2, length(Indata1), #0);
1880 Result := '';
1881 for i := 1 to length(Indata1) do
1882 Result := Result + AnsiChar(ord(Indata1[i]) xor ord(Indata2[i]));
1883 end;
1884
1885 {==============================================================================}
1886
NormalizeHeadernull1887 function NormalizeHeader(Value: TStrings; var Index: Integer): string;
1888 var
1889 s, t: string;
1890 n: Integer;
1891 begin
1892 s := Value[Index];
1893 Inc(Index);
1894 if s <> '' then
1895 while (Value.Count - 1) > Index do
1896 begin
1897 t := Value[Index];
1898 if t = '' then
1899 Break;
1900 for n := 1 to Length(t) do
1901 if t[n] = #9 then
1902 t[n] := ' ';
1903 if not(AnsiChar(t[1]) in [' ', '"', ':', '=']) then
1904 Break
1905 else
1906 begin
1907 s := s + ' ' + Trim(t);
1908 Inc(Index);
1909 end;
1910 end;
1911 Result := TrimRight(s);
1912 end;
1913
1914 {==============================================================================}
1915
1916 {pf}
1917 procedure SearchForLineBreak(var APtr:PANSIChar; AEtx:PANSIChar; out ABol:PANSIChar; out ALength:integer);
1918 begin
1919 ABol := APtr;
1920 while (APtr<AEtx) and not (APtr^ in [#0,#10,#13]) do
1921 inc(APtr);
1922 ALength := APtr-ABol;
1923 end;
1924 {/pf}
1925
1926 {pf}
1927 procedure SkipLineBreak(var APtr:PANSIChar; AEtx:PANSIChar);
1928 begin
1929 if (APtr<AEtx) and (APtr^=#13) then
1930 inc(APtr);
1931 if (APtr<AEtx) and (APtr^=#10) then
1932 inc(APtr);
1933 end;
1934 {/pf}
1935
1936 {pf}
1937 procedure SkipNullLines(var APtr:PANSIChar; AEtx:PANSIChar);
1938 var
1939 bol: PANSIChar;
1940 lng: integer;
1941 begin
1942 while (APtr<AEtx) do
1943 begin
1944 SearchForLineBreak(APtr,AEtx,bol,lng);
1945 SkipLineBreak(APtr,AEtx);
1946 if lng>0 then
1947 begin
1948 APtr := bol;
1949 Break;
1950 end;
1951 end;
1952 end;
1953 {/pf}
1954
1955 {pf}
1956 procedure CopyLinesFromStreamUntilNullLine(var APtr:PANSIChar; AEtx:PANSIChar; ALines:TStrings);
1957 var
1958 bol: PANSIChar;
1959 lng: integer;
1960 s: ANSIString;
1961 begin
1962 // Copying until body separator will be reached
1963 while (APtr<AEtx) and (APtr^<>#0) do
1964 begin
1965 SearchForLineBreak(APtr,AEtx,bol,lng);
1966 SkipLineBreak(APtr,AEtx);
1967 if lng=0 then
1968 Break;
1969 SetString(s,bol,lng);
1970 ALines.Add(s);
1971 end;
1972 end;
1973 {/pf}
1974
1975 {pf}
1976 procedure CopyLinesFromStreamUntilBoundary(var APtr:PANSIChar; AEtx:PANSIChar; ALines:TStrings; const ABoundary:ANSIString);
1977 var
1978 bol: PANSIChar;
1979 lng: integer;
1980 s: ANSIString;
1981 BackStop: ANSIString;
1982 eob1: PANSIChar;
1983 eob2: PANSIChar;
1984 begin
1985 BackStop := '--'+ABoundary;
1986 eob2 := nil;
1987 // Copying until Boundary will be reached
1988 while (APtr<AEtx) do
1989 begin
1990 SearchForLineBreak(APtr,AEtx,bol,lng);
1991 SkipLineBreak(APtr,AEtx);
1992 eob1 := MatchBoundary(bol,APtr,ABoundary);
1993 if Assigned(eob1) then
1994 eob2 := MatchLastBoundary(bol,AEtx,ABoundary);
1995 if Assigned(eob2) then
1996 begin
1997 APtr := eob2;
1998 Break;
1999 end
2000 else if Assigned(eob1) then
2001 begin
2002 APtr := eob1;
2003 Break;
2004 end
2005 else
2006 begin
2007 SetString(s,bol,lng);
2008 ALines.Add(s);
2009 end;
2010 end;
2011 end;
2012 {/pf}
2013
2014 {pf}
SearchForBoundarynull2015 function SearchForBoundary(var APtr:PANSIChar; AEtx:PANSIChar; const ABoundary:ANSIString): PANSIChar;
2016 var
2017 eob: PANSIChar;
2018 Step: integer;
2019 begin
2020 Result := nil;
2021 // Moving Aptr position forward until boundary will be reached
2022 while (APtr<AEtx) do
2023 begin
2024 if strlcomp(APtr,#13#10'--',4)=0 then
2025 begin
2026 eob := MatchBoundary(APtr,AEtx,ABoundary);
2027 Step := 4;
2028 end
2029 else if strlcomp(APtr,'--',2)=0 then
2030 begin
2031 eob := MatchBoundary(APtr,AEtx,ABoundary);
2032 Step := 2;
2033 end
2034 else
2035 begin
2036 eob := nil;
2037 Step := 1;
2038 end;
2039 if Assigned(eob) then
2040 begin
2041 Result := APtr; // boundary beginning
2042 APtr := eob; // boundary end
2043 exit;
2044 end
2045 else
2046 inc(APtr,Step);
2047 end;
2048 end;
2049 {/pf}
2050
2051 {pf}
MatchBoundarynull2052 function MatchBoundary(ABol,AEtx:PANSIChar; const ABoundary:ANSIString): PANSIChar;
2053 var
2054 MatchPos: PANSIChar;
2055 Lng: integer;
2056 begin
2057 Result := nil;
2058 MatchPos := ABol;
2059 Lng := length(ABoundary);
2060 if (MatchPos+2+Lng)>AETX then
2061 exit;
2062 if strlcomp(MatchPos,#13#10,2)=0 then
2063 inc(MatchPos,2);
2064 if (MatchPos+2+Lng)>AETX then
2065 exit;
2066 if strlcomp(MatchPos,'--',2)<>0 then
2067 exit;
2068 inc(MatchPos,2);
2069 if strlcomp(MatchPos,PANSIChar(ABoundary),Lng)<>0 then
2070 exit;
2071 inc(MatchPos,Lng);
2072 if ((MatchPos+2)<=AEtx) and (strlcomp(MatchPos,#13#10,2)=0) then
2073 inc(MatchPos,2);
2074 Result := MatchPos;
2075 end;
2076 {/pf}
2077
2078 {pf}
MatchLastBoundarynull2079 function MatchLastBoundary(ABOL,AETX:PANSIChar; const ABoundary:ANSIString): PANSIChar;
2080 var
2081 MatchPos: PANSIChar;
2082 begin
2083 Result := nil;
2084 MatchPos := MatchBoundary(ABOL,AETX,ABoundary);
2085 if not Assigned(MatchPos) then
2086 exit;
2087 if strlcomp(MatchPos,'--',2)<>0 then
2088 exit;
2089 inc(MatchPos,2);
2090 if (MatchPos+2<=AEtx) and (strlcomp(MatchPos,#13#10,2)=0) then
2091 inc(MatchPos,2);
2092 Result := MatchPos;
2093 end;
2094 {/pf}
2095
2096 {pf}
BuildStringFromBuffernull2097 function BuildStringFromBuffer(AStx,AEtx:PANSIChar): ANSIString;
2098 var
2099 lng: integer;
2100 begin
2101 Lng := 0;
2102 if Assigned(AStx) and Assigned(AEtx) then
2103 begin
2104 Lng := AEtx-AStx;
2105 if Lng<0 then
2106 Lng := 0;
2107 end;
2108 SetString(Result,AStx,lng);
2109 end;
2110 {/pf}
2111
2112
2113
2114
2115 {==============================================================================}
2116 var
2117 n: integer;
2118 begin
2119 for n := 1 to 12 do
2120 begin
2121 CustomMonthNames[n] := {$IFDEF COMPILER15_UP}FormatSettings.{$ENDIF}ShortMonthNames[n];
2122 MyMonthNames[0, n] := {$IFDEF COMPILER15_UP}FormatSettings.{$ENDIF}ShortMonthNames[n];
2123 end;
2124 end.
2125