home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 November / Chip_2002-11_cd1.bin / zkuste / delphi / kompon / d3456 / SYNAPSE.ZIP / source / lib / SynaUtil.pas < prev    next >
Pascal/Delphi Source File  |  2002-07-17  |  29KB  |  1,065 lines
  1. {==============================================================================|
  2. | Project : Delphree - Synapse                                   | 003.002.001 |
  3. |==============================================================================|
  4. | Content: support procedures and functions                                    |
  5. |==============================================================================|
  6. | Copyright (c)1999-2002, 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-2002.               |
  37. | Portions created by Hernan Sanchez are Copyright (c) 2000.                   |
  38. | All Rights Reserved.                                                         |
  39. |==============================================================================|
  40. | Contributor(s):                                                              |
  41. |   Hernan Sanchez (hernan.sanchez@iname.com)                                  |
  42. |==============================================================================|
  43. | History: see HISTORY.HTM from distribution package                           |
  44. |          (Found at URL: http://www.ararat.cz/synapse/)                       |
  45. |==============================================================================}
  46.  
  47. {$Q-}
  48.  
  49. unit SynaUtil;
  50.  
  51. interface
  52.  
  53. uses
  54.   SysUtils, Classes,
  55. {$IFDEF LINUX}
  56.   Libc;
  57. {$ELSE}
  58.   Windows;
  59. {$ENDIF}
  60.  
  61. function TimeZoneBias: integer;
  62. function TimeZone: string;
  63. function Rfc822DateTime(t: TDateTime): string;
  64. function CDateTime(t: TDateTime): string;
  65. function SimpleDateTime(t: TDateTime): string;
  66. function AnsiCDateTime(t: TDateTime): string;
  67. function GetMonthNumber(Value: string): integer;
  68. function GetTimeFromStr(Value: string): TDateTime;
  69. function GetDateMDYFromStr(Value: string): TDateTime;
  70. function DecodeRfcDateTime(Value: string): TDateTime;
  71. function GetUTTime: TDateTime;
  72. function SetUTTime(Newdt: TDateTime): Boolean;
  73. function GetTick: Cardinal;
  74. function CodeInt(Value: Word): string;
  75. function DecodeInt(const Value: string; Index: Integer): Word;
  76. function IsIP(const Value: string): Boolean;
  77. function ReverseIP(Value: string): string;
  78. function IPToID(Host: string): string;
  79. procedure Dump(const Buffer, DumpFile: string);
  80. procedure DumpEx(const Buffer, DumpFile: string);
  81. function SeparateLeft(const Value, Delimiter: string): string;
  82. function SeparateRight(const Value, Delimiter: string): string;
  83. function GetParameter(const Value, Parameter: string): string;
  84. procedure ParseParameters(Value: string; const Parameters: TStrings);
  85. function IndexByBegin(Value: string; const List: TStrings): integer;
  86. function GetEmailAddr(const Value: string): string;
  87. function GetEmailDesc(Value: string): string;
  88. function StrToHex(const Value: string): string;
  89. function IntToBin(Value: Integer; Digits: Byte): string;
  90. function BinToInt(const Value: string): Integer;
  91. function ParseURL(URL: string; var Prot, User, Pass, Host, Port, Path,
  92.   Para: string): string;
  93. function StringReplace(Value, Search, Replace: string): string;
  94. function RPosEx(const Sub, Value: string; From: integer): Integer;
  95. function RPos(const Sub, Value: String): Integer;
  96. function Fetch(var Value: string; const Delimiter: string): string;
  97. function IsBinaryString(const Value: string): Boolean;
  98. function PosCRLF(const Value: string; var Terminator: string): integer;
  99. Procedure StringsTrim(const value: TStrings);
  100. function PosFrom(const SubStr, Value: String; From: integer): integer;
  101.  
  102. implementation
  103.  
  104. {==============================================================================}
  105.  
  106. const
  107.   MyDayNames: array[1..7] of string =
  108.     ('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat');
  109.   MyMonthNames: array[1..12] of string =
  110.     ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
  111.      'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');
  112.  
  113. {==============================================================================}
  114.  
  115. function TimeZoneBias: integer;
  116. {$IFDEF LINUX}
  117. var
  118.   t: TTime_T;
  119.   UT: TUnixTime;
  120. begin
  121.   __time(@T);
  122.   localtime_r(@T, UT);
  123.   Result := ut.__tm_gmtoff div 60;
  124. {$ELSE}
  125. var
  126.   zoneinfo: TTimeZoneInformation;
  127.   bias: Integer;
  128. begin
  129.   case GetTimeZoneInformation(Zoneinfo) of
  130.     2:
  131.       bias := zoneinfo.Bias + zoneinfo.DaylightBias;
  132.     1:
  133.       bias := zoneinfo.Bias + zoneinfo.StandardBias;
  134.   else
  135.     bias := zoneinfo.Bias;
  136.   end;
  137.   Result := bias * (-1);
  138. {$ENDIF}
  139. end;
  140.  
  141. {==============================================================================}
  142.  
  143. function TimeZone: string;
  144. var
  145.   bias: Integer;
  146.   h, m: Integer;
  147. begin
  148.   bias := TimeZoneBias;
  149.   if bias >= 0 then
  150.     Result := '+'
  151.   else
  152.     Result := '-';
  153.   bias := Abs(bias);
  154.   h := bias div 60;
  155.   m := bias mod 60;
  156.   Result := Result + Format('%.2d%.2d', [h, m]);
  157. end;
  158.  
  159. {==============================================================================}
  160.  
  161. function Rfc822DateTime(t: TDateTime): string;
  162. var
  163.   wYear, wMonth, wDay: word;
  164. begin
  165.   DecodeDate(t, wYear, wMonth, wDay);
  166.   Result := Format('%s, %d %s %s %s', [MyDayNames[DayOfWeek(t)], wDay,
  167.     MyMonthNames[wMonth], FormatDateTime('yyyy hh:nn:ss', t), TimeZone]);
  168. end;
  169.  
  170. {==============================================================================}
  171.  
  172. function CDateTime(t: TDateTime): string;
  173. var
  174.   wYear, wMonth, wDay: word;
  175. begin
  176.   DecodeDate(t, wYear, wMonth, wDay);
  177.   Result:= Format('%s %2d %s', [MyMonthNames[wMonth], wDay,
  178.     FormatDateTime('hh:nn:ss', t)]);
  179. end;
  180.  
  181. {==============================================================================}
  182.  
  183. function SimpleDateTime(t: TDateTime): string;
  184. begin
  185.   Result := FormatDateTime('yymmdd hhnnss', t);
  186. end;
  187.  
  188. {==============================================================================}
  189.  
  190. function AnsiCDateTime(t: TDateTime): string;
  191. var
  192.   wYear, wMonth, wDay: word;
  193. begin
  194.   DecodeDate(t, wYear, wMonth, wDay);
  195.   Result := Format('%s %s %d %s', [MyDayNames[DayOfWeek(t)], MyMonthNames[wMonth],
  196.     wDay, FormatDateTime('hh:nn:ss yyyy ', t)]);
  197. end;
  198.  
  199. {==============================================================================}
  200.  
  201. function DecodeTimeZone(Value: string; var Zone: integer): Boolean;
  202. var
  203.   x: integer;
  204.   zh, zm: integer;
  205.   s: string;
  206. begin
  207.   Result := false;
  208.   s := Value;
  209.   if (Pos('+', s) = 1) or (Pos('-',s) = 1) then
  210.   begin
  211.     if s = '-0000' then
  212.       Zone := TimeZoneBias
  213.     else
  214.       if Length(s) > 4 then
  215.       begin
  216.         zh := StrToIntdef(s[2] + s[3], 0);
  217.         zm := StrToIntdef(s[4] + s[5], 0);
  218.         zone := zh * 60 + zm;
  219.         if s[1] = '-' then
  220.           zone := zone * (-1);
  221.       end;
  222.     Result := True;
  223.   end
  224.   else
  225.   begin
  226.     x := 32767;
  227.     if s = 'NZDT' then x := 13;
  228.     if s = 'IDLE' then x := 12;
  229.     if s = 'NZST' then x := 12;
  230.     if s = 'NZT' then x := 12;
  231.     if s = 'EADT' then x := 11;
  232.     if s = 'GST' then x := 10;
  233.     if s = 'JST' then x := 9;
  234.     if s = 'CCT' then x := 8;
  235.     if s = 'WADT' then x := 8;
  236.     if s = 'WAST' then x := 7;
  237.     if s = 'ZP6' then x := 6;
  238.     if s = 'ZP5' then x := 5;
  239.     if s = 'ZP4' then x := 4;
  240.     if s = 'BT' then x := 3;
  241.     if s = 'EET' then x := 2;
  242.     if s = 'MEST' then x := 2;
  243.     if s = 'MESZ' then x := 2;
  244.     if s = 'SST' then x := 2;
  245.     if s = 'FST' then x := 2;
  246.     if s = 'CEST' then x := 2;
  247.     if s = 'CET' then x := 1;
  248.     if s = 'FWT' then x := 1;
  249.     if s = 'MET' then x := 1;
  250.     if s = 'MEWT' then x := 1;
  251.     if s = 'SWT' then x := 1;
  252.     if s = 'UT' then x := 0;
  253.     if s = 'UTC' then x := 0;
  254.     if s = 'GMT' then x := 0;
  255.     if s = 'WET' then x := 0;
  256.     if s = 'WAT' then x := -1;
  257.     if s = 'BST' then x := -1;
  258.     if s = 'AT' then x := -2;
  259.     if s = 'ADT' then x := -3;
  260.     if s = 'AST' then x := -4;
  261.     if s = 'EDT' then x := -4;
  262.     if s = 'EST' then x := -5;
  263.     if s = 'CDT' then x := -5;
  264.     if s = 'CST' then x := -6;
  265.     if s = 'MDT' then x := -6;
  266.     if s = 'MST' then x := -7;
  267.     if s = 'PDT' then x := -7;
  268.     if s = 'PST' then x := -8;
  269.     if s = 'YDT' then x := -8;
  270.     if s = 'YST' then x := -9;
  271.     if s = 'HDT' then x := -9;
  272.     if s = 'AHST' then x := -10;
  273.     if s = 'CAT' then x := -10;
  274.     if s = 'HST' then x := -10;
  275.     if s = 'EAST' then x := -10;
  276.     if s = 'NT' then x := -11;
  277.     if s = 'IDLW' then x := -12;
  278.     if x <> 32767 then
  279.     begin
  280.       zone := x * 60;
  281.       Result := True;
  282.     end;
  283.   end;
  284. end;
  285.  
  286. {==============================================================================}
  287.  
  288. function GetMonthNumber(Value: string): integer;
  289. var
  290.   n: integer;
  291. begin
  292.   Result := 0;
  293.   Value := Uppercase(Value);
  294.   for n := 1 to 12 do
  295.     if Value = uppercase(MyMonthNames[n]) then
  296.     begin
  297.       Result := n;
  298.       Break;
  299.     end;
  300. end;
  301.  
  302. {==============================================================================}
  303.  
  304. function GetTimeFromStr(Value: string): TDateTime;
  305. var
  306.   x: integer;
  307. begin
  308.   x := rpos(':', Value);
  309.   if (x > 0) and ((Length(Value) - x) > 2) then
  310.     Value := Copy(Value, 1, x + 2);
  311.   Value := StringReplace(Value, ':', TimeSeparator);
  312.   Result := 0;
  313.   try
  314.     Result := StrToTime(Value);
  315.   except
  316.     on Exception do ;
  317.   end;
  318. end;
  319.  
  320. {==============================================================================}
  321.  
  322. function GetDateMDYFromStr(Value: string): TDateTime;
  323. var
  324.   wYear, wMonth, wDay: word;
  325.   s: string;
  326. begin
  327.   Result := 0;
  328.   s := Fetch(Value, '-');
  329.   wMonth := StrToIntDef(s, 12);
  330.   s := Fetch(Value, '-');
  331.   wDay := StrToIntDef(s, 30);
  332.   wYear := StrToIntDef(Value, 1899);
  333.   if wYear < 1000 then
  334.     if (wYear > 99) then
  335.       wYear := wYear + 1900
  336.     else
  337.       if wYear > 50 then
  338.         wYear := wYear + 1900
  339.       else
  340.         wYear := wYear + 2000;
  341.   try
  342.     Result := EncodeDate(wYear, wMonth, wDay);
  343.   except
  344.     on Exception do ;
  345.   end;
  346. end;
  347.  
  348. {==============================================================================}
  349.  
  350. function DecodeRfcDateTime(Value: string): TDateTime;
  351. var
  352.   day, month, year: Word;
  353.   zone: integer;
  354.   x, y: integer;
  355.   s: string;
  356.   t: TDateTime;
  357. begin
  358. // ddd, d mmm yyyy hh:mm:ss
  359. // ddd, d mmm yy hh:mm:ss
  360. // ddd, mmm d yyyy hh:mm:ss
  361. // ddd mmm dd hh:mm:ss yyyy
  362. // Sun, 06 Nov 1994 08:49:37 GMT    ; RFC 822, updated by RFC 1123
  363. // Sunday, 06-Nov-94 08:49:37 GMT   ; RFC 850, obsoleted by RFC 1036
  364. // Sun Nov  6 08:49:37 1994         ; ANSI C's asctime() Format
  365.  
  366.   Result := 0;
  367.   if Value = '' then
  368.     Exit;
  369.   day := 0;
  370.   month := 0;
  371.   year := 0;
  372.   zone := 0;
  373.   Value := StringReplace(Value, ' -', ' #');
  374.   Value := StringReplace(Value, '-', ' ');
  375.   Value := StringReplace(Value, ' #', ' -');
  376.   while Value <> '' do
  377.   begin
  378.     s := Fetch(Value, ' ');
  379.     s := uppercase(s);
  380.     // timezone
  381.     if DecodetimeZone(s, x) then
  382.     begin
  383.       zone := x;
  384.       continue;
  385.     end;
  386.     x := StrToIntDef(s, 0);
  387.     // day or year
  388.     if x > 0 then
  389.       if (x < 32) and (day = 0) then
  390.       begin
  391.         day := x;
  392.         continue;
  393.       end
  394.       else
  395.       begin
  396.         year := x;
  397.         if year < 32 then
  398.           year := year + 2000;
  399.         if year < 1000 then
  400.          year := year + 1900;
  401.         continue;
  402.       end;
  403.     // time
  404.     if rpos(':', s) > Pos(':', s) then
  405.     begin
  406.       t := GetTimeFromStr(s);
  407.       if t <> 0 then
  408.         Result := t;
  409.       continue;
  410.     end;
  411.     //timezone daylight saving time
  412.     if s = 'DST' then
  413.     begin
  414.       zone := zone + 60;
  415.       continue;
  416.     end;
  417.     // month
  418.     y := GetMonthNumber(s);
  419.     if y > 0 then
  420.       month := y;
  421.   end;
  422.   if (month < 1) or (month > 12) then
  423.     month := 1;
  424.   if (day < 1) or (day > 31) then
  425.     day := 1;
  426.   Result := Result + Encodedate(year, month, day);
  427.   zone := zone - TimeZoneBias;
  428.   t := EncodeTime(Abs(zone) div 60, Abs(zone) mod 60, 0, 0);
  429.   if zone < 0 then
  430.     t := 0 - t;
  431.   Result := Result - t;
  432. end;
  433.  
  434. {==============================================================================}
  435.  
  436. function GetUTTime: TDateTime;
  437. {$IFNDEF LINUX}
  438. var
  439.   st: TSystemTime;
  440. begin
  441.  GetSystemTime(st);
  442.  result:=SystemTimeToDateTime(st);
  443. {$ELSE}
  444. var
  445.   TV: TTimeVal;
  446. begin
  447.   gettimeofday(TV, nil);
  448.   Result:=UnixDateDelta + (TV.tv_sec + TV.tv_usec / 1000000) / 86400;
  449. {$ENDIF}
  450. end;
  451.  
  452. {==============================================================================}
  453.  
  454. function SetUTTime(Newdt: TDateTime): Boolean;
  455. {$IFNDEF LINUX}
  456. var
  457.   st: TSystemTime;
  458. begin
  459.  DateTimeToSystemTime(newdt,st);
  460.  Result:=SetSystemTime(st);
  461. {$ELSE}
  462. var
  463.   TV: TTimeVal;
  464.   d: double;
  465.   TZ: Ttimezone;
  466. begin
  467.   Result := false;
  468.   gettimeofday(TV, TZ);
  469.   d := (newdt - UnixDateDelta) * 86400;
  470.   TV.tv_sec := trunc(d);
  471.   TV.tv_usec := trunc(frac(d) * 1000000);
  472.   Result := settimeofday(TV, TZ) <> -1;
  473. {$ENDIF}
  474. end;
  475.  
  476. {==============================================================================}
  477.  
  478. {$IFDEF LINUX}
  479. function GetTick: Cardinal;
  480. var
  481.   Stamp: TTimeStamp;
  482. begin
  483.   Stamp := DateTimeToTimeStamp(Now);
  484.   Result := Stamp.Time;
  485. end;
  486. {$ELSE}
  487. function GetTick: Cardinal;
  488. begin
  489.   Result := Windows.GetTickCount;
  490. end;
  491. {$ENDIF}
  492.  
  493. {==============================================================================}
  494.  
  495. function CodeInt(Value: Word): string;
  496. begin
  497.   Result := Chr(Hi(Value)) + Chr(Lo(Value))
  498. end;
  499.  
  500. {==============================================================================}
  501.  
  502. function DecodeInt(const Value: string; Index: Integer): Word;
  503. var
  504.   x, y: Byte;
  505. begin
  506.   if Length(Value) > Index then
  507.     x := Ord(Value[Index])
  508.   else
  509.     x := 0;
  510.   if Length(Value) >= (Index + 1) then
  511.     y := Ord(Value[Index + 1])
  512.   else
  513.     y := 0;
  514.   Result := x * 256 + y;
  515. end;
  516.  
  517. {==============================================================================}
  518.  
  519. function IsIP(const Value: string): Boolean;
  520. var
  521.   TempIP: string;
  522.  
  523.   function ByteIsOk(const Value: string): Boolean;
  524.   var
  525.     x, n: integer;
  526.   begin
  527.     x := StrToIntDef(Value, -1);
  528.     Result := (x >= 0) and (x < 256);
  529.     // X may be in correct range, but value still may not be correct value!
  530.     // i.e. "$80"
  531.     if Result then
  532.       for n := 1 to length(Value) do
  533.         if not (Value[n] in ['0'..'9']) then
  534.         begin
  535.           Result := False;
  536.           Break;
  537.         end;
  538.   end;
  539.  
  540. begin
  541.   TempIP := Value;
  542.   Result := False;
  543.   if not ByteIsOk(Fetch(TempIP, '.')) then
  544.     Exit;
  545.   if not ByteIsOk(Fetch(TempIP, '.')) then
  546.     Exit;
  547.   if not ByteIsOk(Fetch(TempIP, '.')) then
  548.     Exit;
  549.   if ByteIsOk(TempIP) then
  550.     Result := True;
  551. end;
  552.  
  553. {==============================================================================}
  554.  
  555. function ReverseIP(Value: string): string;
  556. var
  557.   x: Integer;
  558. begin
  559.   Result := '';
  560.   repeat
  561.     x := LastDelimiter('.', Value);
  562.     Result := Result + '.' + Copy(Value, x + 1, Length(Value) - x);
  563.     Delete(Value, x, Length(Value) - x + 1);
  564.   until x < 1;
  565.   if Length(Result) > 0 then
  566.     if Result[1] = '.' then
  567.       Delete(Result, 1, 1);
  568. end;
  569.  
  570. {==============================================================================}
  571. //Hernan Sanchez
  572. function IPToID(Host: string): string;
  573. var
  574.   s, t: string;
  575.   i, x: Integer;
  576. begin
  577.   Result := '';
  578.   for x := 1 to 3 do
  579.   begin
  580.     t := '';
  581.     s := StrScan(PChar(Host), '.');
  582.     t := Copy(Host, 1, (Length(Host) - Length(s)));
  583.     Delete(Host, 1, (Length(Host) - Length(s) + 1));
  584.     i := StrToIntDef(t, 0);
  585.     Result := Result + Chr(i);
  586.   end;
  587.   i := StrToIntDef(Host, 0);
  588.   Result := Result + Chr(i);
  589. end;
  590.  
  591. {==============================================================================}
  592.  
  593. procedure Dump(const Buffer, DumpFile: string);
  594. var
  595.   n: Integer;
  596.   s: string;
  597.   f: Text;
  598. begin
  599.   s := '';
  600.   for n := 1 to Length(Buffer) do
  601.     s := s + ' +#$' + IntToHex(Ord(Buffer[n]), 2);
  602.   AssignFile(f, DumpFile);
  603.   if FileExists(DumpFile) then
  604.     DeleteFile(PChar(DumpFile));
  605.   Rewrite(f);
  606.   try
  607.     Writeln(f, s);
  608.   finally
  609.     CloseFile(f);
  610.   end;
  611. end;
  612.  
  613. {==============================================================================}
  614.  
  615. procedure DumpEx(const Buffer, DumpFile: string);
  616. var
  617.   n: Integer;
  618.   x: Byte;
  619.   s: string;
  620.   f: Text;
  621. begin
  622.   s := '';
  623.   for n := 1 to Length(Buffer) do
  624.   begin
  625.     x := Ord(Buffer[n]);
  626.     if x in [65..90, 97..122] then
  627.       s := s + ' +''' + char(x) + ''''
  628.     else
  629.       s := s + ' +#$' + IntToHex(Ord(Buffer[n]), 2);
  630.   end;
  631.   AssignFile(f, DumpFile);
  632.   if FileExists(DumpFile) then
  633.     DeleteFile(PChar(DumpFile));
  634.   Rewrite(f);
  635.   try
  636.     Writeln(f, s);
  637.   finally
  638.     CloseFile(f);
  639.   end;
  640. end;
  641.  
  642. {==============================================================================}
  643.  
  644. function SeparateLeft(const Value, Delimiter: string): string;
  645. var
  646.   x: Integer;
  647. begin
  648.   x := Pos(Delimiter, Value);
  649.   if x < 1 then
  650.     Result := Trim(Value)
  651.   else
  652.     Result := Trim(Copy(Value, 1, x - 1));
  653. end;
  654.  
  655. {==============================================================================}
  656.  
  657. function SeparateRight(const Value, Delimiter: string): string;
  658. var
  659.   x: Integer;
  660. begin
  661.   x := Pos(Delimiter, Value);
  662.   if x > 0 then
  663.     x := x + Length(Delimiter) - 1;
  664.   Result := Trim(Copy(Value, x + 1, Length(Value) - x));
  665. end;
  666.  
  667. {==============================================================================}
  668.  
  669. function GetParameter(const Value, Parameter: string): string;
  670. var
  671.   x, x1: Integer;
  672.   s: string;
  673. begin
  674.   x := Pos(UpperCase(Parameter), UpperCase(Value));
  675.   Result := '';
  676.   if x > 0 then
  677.   begin
  678.     s := Copy(Value, x + Length(Parameter), Length(Value)
  679.       - (x + Length(Parameter)) + 1);
  680.     s := Trim(s);
  681.     x1 := Length(s);
  682.     if Length(s) > 1 then
  683.     begin
  684.       if s[1] = '"' then
  685.       begin
  686.         s := Copy(s, 2, Length(s) - 1);
  687.         x := Pos('"', s);
  688.         if x > 0 then
  689.           x1 := x - 1;
  690.       end
  691.       else
  692.       begin
  693.         x := Pos(' ', s);
  694.         if x > 0 then
  695.           x1 := x - 1;
  696.       end;
  697.     end;
  698.     Result := Copy(s, 1, x1);
  699.   end;
  700. end;
  701.  
  702. {==============================================================================}
  703.  
  704. procedure ParseParameters(Value: string; const Parameters: TStrings);
  705. var
  706.   s: string;
  707. begin
  708.   Parameters.Clear;
  709.   while Value <> '' do
  710.   begin
  711.     s := Fetch(Value, ';');
  712.     Parameters.Add(s);
  713.   end;
  714. end;
  715.  
  716. {==============================================================================}
  717.  
  718. function IndexByBegin(Value: string; const List: TStrings): integer;
  719. var
  720.   n: integer;
  721.   s: string;
  722. begin
  723.   Result := -1;
  724.   Value := uppercase(Value);
  725.   for n := 0 to List.Count -1 do
  726.   begin
  727.     s := UpperCase(List[n]);
  728.     if Pos(Value, s) = 1 then
  729.     begin
  730.       Result := n;
  731.       Break;
  732.     end;
  733.   end;
  734. end;
  735.  
  736. {==============================================================================}
  737.  
  738. function GetEmailAddr(const Value: string): string;
  739. var
  740.   s: string;
  741. begin
  742.   s := SeparateRight(Value, '<');
  743.   s := SeparateLeft(s, '>');
  744.   Result := Trim(s);
  745. end;
  746.  
  747. {==============================================================================}
  748.  
  749. function GetEmailDesc(Value: string): string;
  750. var
  751.   s: string;
  752. begin
  753.   Value := Trim(Value);
  754.   s := SeparateRight(Value, '"');
  755.   if s <> Value then
  756.     s := SeparateLeft(s, '"')
  757.   else
  758.   begin
  759.     s := SeparateLeft(Value, '<');
  760.     if s = Value then
  761.     begin
  762.       s := SeparateRight(Value, '(');
  763.       if s <> Value then
  764.         s := SeparateLeft(s, ')')
  765.       else
  766.         s := '';
  767.     end;
  768.   end;
  769.   Result := Trim(s);
  770. end;
  771.  
  772. {==============================================================================}
  773.  
  774. function StrToHex(const Value: string): string;
  775. var
  776.   n: Integer;
  777. begin
  778.   Result := '';
  779.   for n := 1 to Length(Value) do
  780.     Result := Result + IntToHex(Byte(Value[n]), 2);
  781.   Result := LowerCase(Result);
  782. end;
  783.  
  784. {==============================================================================}
  785.  
  786. function IntToBin(Value: Integer; Digits: Byte): string;
  787. var
  788.   x, y, n: Integer;
  789. begin
  790.   Result := '';
  791.   x := Value;
  792.   repeat
  793.     y := x mod 2;
  794.     x := x div 2;
  795.     if y > 0 then
  796.       Result := '1' + Result
  797.     else
  798.       Result := '0' + Result;
  799.   until x = 0;
  800.   x := Length(Result);
  801.   for n := x to Digits - 1 do
  802.     Result := '0' + Result;
  803. end;
  804.  
  805. {==============================================================================}
  806.  
  807. function BinToInt(const Value: string): Integer;
  808. var
  809.   n: Integer;
  810. begin
  811.   Result := 0;
  812.   for n := 1 to Length(Value) do
  813.   begin
  814.     if Value[n] = '0' then
  815.       Result := Result * 2
  816.     else
  817.       if Value[n] = '1' then
  818.         Result := Result * 2 + 1
  819.       else
  820.         Break;
  821.   end;
  822. end;
  823.  
  824. {==============================================================================}
  825.  
  826. function ParseURL(URL: string; var Prot, User, Pass, Host, Port, Path,
  827.   Para: string): string;
  828. var
  829.   x: Integer;
  830.   sURL: string;
  831.   s: string;
  832.   s1, s2: string;
  833. begin
  834.   Prot := 'http';
  835.   User := '';
  836.   Pass := '';
  837.   Port := '80';
  838.   Para := '';
  839.  
  840.   x := Pos('://', URL);
  841.   if x > 0 then
  842.   begin
  843.     Prot := SeparateLeft(URL, '://');
  844.     sURL := SeparateRight(URL, '://');
  845.   end
  846.   else
  847.     sURL := URL;
  848.   if UpperCase(Prot) = 'HTTPS' then
  849.     Port := '443';
  850.   if UpperCase(Prot) = 'FTP' then
  851.     Port := '21';
  852.   x := Pos('@', sURL);
  853.   if (x > 0) and (x < Pos('/', sURL)) then
  854.   begin
  855.     s := SeparateLeft(sURL, '@');
  856.     sURL := SeparateRight(sURL, '@');
  857.     x := Pos(':', s);
  858.     if x > 0 then
  859.     begin
  860.       User := SeparateLeft(s, ':');
  861.       Pass := SeparateRight(s, ':');
  862.     end
  863.     else
  864.       User := s;
  865.   end;
  866.   x := Pos('/', sURL);
  867.   if x > 0 then
  868.   begin
  869.     s1 := SeparateLeft(sURL, '/');
  870.     s2 := SeparateRight(sURL, '/');
  871.   end
  872.   else
  873.   begin
  874.     s1 := sURL;
  875.     s2 := '';
  876.   end;
  877.   x := Pos(':', s1);
  878.   if x > 0 then
  879.   begin
  880.     Host := SeparateLeft(s1, ':');
  881.     Port := SeparateRight(s1, ':');
  882.   end
  883.   else
  884.     Host := s1;
  885.   Result := '/' + s2;
  886.   x := Pos('?', s2);
  887.   if x > 0 then
  888.   begin
  889.     Path := '/' + SeparateLeft(s2, '?');
  890.     Para := SeparateRight(s2, '?');
  891.   end
  892.   else
  893.     Path := '/' + s2;
  894.   if Host = '' then
  895.     Host := 'localhost';
  896. end;
  897.  
  898. {==============================================================================}
  899.  
  900. function StringReplace(Value, Search, Replace: string): string;
  901. var
  902.   x, l, ls, lr: Integer;
  903. begin
  904.   if (Value = '') or (Search = '') then
  905.   begin
  906.     Result := Value;
  907.     Exit;
  908.   end;
  909.   ls := Length(Search);
  910.   lr := Length(Replace);
  911.   Result := '';
  912.   x := Pos(Search, Value);
  913.   while x > 0 do
  914.   begin
  915.     l := Length(Result);
  916.     SetLength(Result, l + x - 1);
  917.     Move(Pointer(Value)^, Pointer(@Result[l + 1])^, x - 1);
  918. //      Result:=Result+Copy(Value,1,x-1);
  919.     l := Length(Result);
  920.     SetLength(Result, l + lr);
  921.     Move(Pointer(Replace)^, Pointer(@Result[l + 1])^, lr);
  922. //      Result:=Result+Replace;
  923.     Delete(Value, 1, x - 1 + ls);
  924.     x := Pos(Search, Value);
  925.   end;
  926.   Result := Result + Value;
  927. end;
  928.  
  929. {==============================================================================}
  930.  
  931. function RPosEx(const Sub, Value: string; From: integer): Integer;
  932. var
  933.   n: Integer;
  934.   l: Integer;
  935. begin
  936.   result := 0;
  937.   l := Length(Sub);
  938.   for n := From - l + 1 downto 1 do
  939.   begin
  940.     if Copy(Value, n, l) = Sub then
  941.     begin
  942.       result := n;
  943.       break;
  944.     end;
  945.   end;
  946. end;
  947.  
  948. {==============================================================================}
  949.  
  950. function RPos(const Sub, Value: String): Integer;
  951. begin
  952.   Result := RPosEx(Sub, Value, Length(Value));
  953. end;
  954.  
  955. {==============================================================================}
  956.  
  957. function Fetch(var Value: string; const Delimiter: string): string;
  958. var
  959.   s: string;
  960. begin
  961.   Result := SeparateLeft(Value, Delimiter);
  962.   s := SeparateRight(Value, Delimiter);
  963.   if s = Value then
  964.     Value := ''
  965.   else
  966.     Value := Trim(s);
  967.   Result := Trim(Result);
  968. end;
  969.  
  970. {==============================================================================}
  971.  
  972. function IsBinaryString(const Value: string): Boolean;
  973. var
  974.   n: integer;
  975. begin
  976.   Result := False;
  977.   for n := 1 to Length(Value) do
  978.     if Value[n] in [#0..#8, #10..#31] then
  979.     begin
  980.       Result := True;
  981.       Break;
  982.     end;
  983. end;
  984.  
  985. {==============================================================================}
  986.  
  987. function PosCRLF(const Value: string; var Terminator: string): integer;
  988. var
  989.   p1, p2, p3, p4: integer;
  990. const
  991.   t1 = #$0d + #$0a;
  992.   t2 = #$0a + #$0d;
  993.   t3 = #$0d;
  994.   t4 = #$0a;
  995. begin
  996.   Terminator := '';
  997.   p1 := Pos(t1, Value);
  998.   p2 := Pos(t2, Value);
  999.   p3 := Pos(t3, Value);
  1000.   p4 := Pos(t4, Value);
  1001.   if p1 > 0 then
  1002.     Terminator := t1;
  1003.   Result := p1;
  1004.   if (p2 > 0) then
  1005.     if (Result = 0) or (p2 < Result) then
  1006.     begin
  1007.       Result := p2;
  1008.       Terminator := t2;
  1009.     end;
  1010.   if (p3 > 0) then
  1011.     if (Result = 0) or (p3 < Result) then
  1012.     begin
  1013.       Result := p3;
  1014.       Terminator := t3;
  1015.     end;
  1016.   if (p4 > 0) then
  1017.     if (Result = 0) or (p4 < Result) then
  1018.     begin
  1019.       Result := p4;
  1020.       Terminator := t4;
  1021.     end;
  1022. end;
  1023.  
  1024. {==============================================================================}
  1025.  
  1026. Procedure StringsTrim(const Value: TStrings);
  1027. var
  1028.   n: integer;
  1029. begin
  1030.   for n := Value.Count - 1 downto 0 do
  1031.     if Value[n] = '' then
  1032.       Value.Delete(n)
  1033.     else
  1034.       Break;
  1035. end;
  1036.  
  1037. {==============================================================================}
  1038.  
  1039. function PosFrom(const SubStr, Value: String; From: integer): integer;
  1040. var
  1041.   ls,lv: integer;
  1042. begin
  1043.   Result := 0;
  1044.   ls := Length(SubStr);
  1045.   lv := Length(Value);
  1046.   if (ls = 0) or (lv = 0) then
  1047.     Exit;
  1048.   if From < 1 then
  1049.     From := 1;
  1050.   while (ls + from - 1) <= (lv) do
  1051.   begin
  1052.     if CompareMem(@SubStr[1],@Value[from],ls) then
  1053.     begin
  1054.       result := from;
  1055.       break;
  1056.     end
  1057.     else
  1058.       inc(from);
  1059.   end;
  1060. end;
  1061.  
  1062. {==============================================================================}
  1063.  
  1064. end.
  1065.