{==============================================================================|
| Project : Ararat Synapse                                       | 004.006.009 |
|==============================================================================|
| Content: support procedures and functions                                    |
|==============================================================================|
| Copyright (c)1999-2004, Lukas Gebauer                                        |
| All rights reserved.                                                         |
|                                                                              |
| Redistribution and use in source and binary forms, with or without           |
| modification, are permitted provided that the following conditions are met:  |
|                                                                              |
| Redistributions of source code must retain the above copyright notice, this  |
| list of conditions and the following disclaimer.                             |
|                                                                              |
| Redistributions in binary form must reproduce the above copyright notice,    |
| this list of conditions and the following disclaimer in the documentation    |
| and/or other materials provided with the distribution.                       |
|                                                                              |
| Neither the name of Lukas Gebauer nor the names of its contributors may      |
| be used to endorse or promote products derived from this software without    |
| specific prior written permission.                                           |
|                                                                              |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
| DAMAGE.                                                                      |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 1999-2004.               |
| Portions created by Hernan Sanchez are Copyright (c) 2000.                   |
| All Rights Reserved.                                                         |
|==============================================================================|
| Contributor(s):                                                              |
|   Hernan Sanchez (hernan.sanchez@iname.com)                                  |
|==============================================================================|
| History: see HISTORY.HTM from distribution package                           |
|          (Found at URL: http://www.ararat.cz/synapse/)                       |
|==============================================================================}

{:@abstract(Support procedures and functions)}

{$IFDEF FPC}
  {$MODE DELPHI}
{$ENDIF}
{$Q-}
{$R-}
{$H+}

unit synautil;

interface

uses
{$IFDEF LINUX}
  Libc,
{$ELSE}
  Windows,
{$ENDIF}
  SysUtils, Classes;

{:Return your timezone bias from UTC time in minutes.}
function TimeZoneBias: integer;

{:Return your timezone bias from UTC time in string representation like "+0200".}
function TimeZone: string;

{:Returns current time in format defined in RFC-822. Useful for SMTP messages,
 but other protocols use this time format as well. Results contains the timezone
 specification. Four digit year is used to break any Y2K concerns. (Example
 'Fri, 15 Oct 1999 21:14:56 +0200')}
function Rfc822DateTime(t: TDateTime): string;

{:Returns date and time in format defined in C compilers in format "mmm dd hh:nn:ss"}
function CDateTime(t: TDateTime): string;

{:Returns date and time in format defined in format 'yymmdd hhnnss'}
function SimpleDateTime(t: TDateTime): string;

{:Returns date and time in format defined in ANSI C compilers in format
 "ddd mmm d hh:nn:ss yyyy" }
function AnsiCDateTime(t: TDateTime): string;

{:Decode three-letter string with name of month to their month number. If string
 not match any month name, then is returned 0. For parsing are used predefined
 names for English, French and German and names from system locale too.}
function GetMonthNumber(Value: AnsiString): integer;

{:Return decoded time from given string. Time must be witch separator ':'. You
 can use "hh:mm" or "hh:mm:ss".}
function GetTimeFromStr(Value: string): TDateTime;

{:Decode string in format "m-d-y" to TDateTime type.}
function GetDateMDYFromStr(Value: string): TDateTime;

{:Decode various string representations of date and time to Tdatetime type.
 This function do all timezone corrections too! This function can decode lot of
  formats like:
 @longcode(#
 ddd, d mmm yyyy hh:mm:ss
 ddd, d mmm yy hh:mm:ss
 ddd, mmm d yyyy hh:mm:ss
 ddd mmm dd hh:mm:ss yyyy #)

and more with lot of modifications, include:
@longcode(#
Sun, 06 Nov 1994 08:49:37 GMT    ; RFC 822, updated by RFC 1123
Sunday, 06-Nov-94 08:49:37 GMT   ; RFC 850, obsoleted by RFC 1036
Sun Nov  6 08:49:37 1994         ; ANSI C's asctime() Format
#)
Timezone corrections known lot of symbolic timezone names (like CEST, EDT, etc.)
or numeric representation (like +0200). By convention defined in RFC timezone
 +0000 is GMT and -0000 is current your system timezone.}
function DecodeRfcDateTime(Value: string): TDateTime;

{:Return current system date and time in UTC timezone.}
function GetUTTime: TDateTime;

{:Set Newdt as current system date and time in UTC timezone. This function work
 only if you have administrator rights!}
function SetUTTime(Newdt: TDateTime): Boolean;

{:Return current value of system timer with precizion 1 millisecond. Good for
 measure time difference.}
function GetTick: ULong;

{:Return difference between two timestamps. It working fine only for differences
 smaller then maxint. (difference must be smaller then 24 days.)}
function TickDelta(TickOld, TickNew: ULong): ULong;

{:Return two characters, which ordinal values represents the value in byte
 format. (High-endian)}
function CodeInt(Value: Word): Ansistring;

{:Decodes two characters located at "Index" offset position of the "Value"
 string to Word values.}
function DecodeInt(const Value: Ansistring; Index: Integer): Word;

{:Return four characters, which ordinal values represents the value in byte
 format. (High-endian)}
function CodeLongInt(Value: LongInt): Ansistring;

{:Decodes four characters located at "Index" offset position of the "Value"
 string to LongInt values.}
function DecodeLongInt(const Value: Ansistring; Index: Integer): LongInt;

{:Returns @TRUE, if "Value" is a valid IPv4 address. Cannot be a symbolic Name!}
function IsIP(const Value: string): Boolean;

{:Returns @TRUE, if "Value" is a valid IPv6 address. Cannot be a symbolic Name!}
function IsIP6(const Value: string): Boolean;

{:Returns a string with the "Host" ip address converted to binary form.}
function IPToID(Host: string): string;

{:Dump binary buffer stored in a string to a result string.}
function DumpStr(const Buffer: Ansistring): string;

{:Dump binary buffer stored in a string to a result string. All bytes with code
 of character is written as character, not as hexadecimal value.}
function DumpExStr(const Buffer: Ansistring): string;

{:Dump binary buffer stored in a string to a file with DumpFile filename.}
procedure Dump(const Buffer: AnsiString; DumpFile: string);

{:Dump binary buffer stored in a string to a file with DumpFile filename. All
 bytes with code of character is written as character, not as hexadecimal value.}
procedure DumpEx(const Buffer: AnsiString; DumpFile: string);

{:Like TrimLeft, but remove only spaces, not control characters!}
function TrimSPLeft(const S: string): string;

{:Like TrimRight, but remove only spaces, not control characters!}
function TrimSPRight(const S: string): string;

{:Like Trim, but remove only spaces, not control characters!}
function TrimSP(const S: string): string;

{:Returns a portion of the "Value" string located to the left of the "Delimiter"
 string. If a delimiter is not found, results is original string.}
function SeparateLeft(const Value, Delimiter: string): string;

{:Returns the portion of the "Value" string located to the right of the
 "Delimiter" string. If a delimiter is not found, results is original string.}
function SeparateRight(const Value, Delimiter: string): string;

{:Returns parameter value from string in format:
 parameter1="value1"; parameter2=value2}
function GetParameter(const Value, Parameter: string): string;

{:parse value string with elements differed by Delimiter into stringlist.}
procedure ParseParametersEx(Value, Delimiter: string; const Parameters: TStrings);

{:parse value string with elements differed by ';' into stringlist.}
procedure ParseParameters(Value: string; const Parameters: TStrings);

{:Index of string in stringlist with same beginning as Value is returned.}
function IndexByBegin(Value: string; const List: TStrings): integer;

{:Returns only the e-mail portion of an address from the full address format.
 i.e. returns 'nobody@@somewhere.com' from '"someone" <nobody@@somewhere.com>'}
function GetEmailAddr(const Value: string): string;

{:Returns only the description part from a full address format. i.e. returns
 'someone' from '"someone" <nobody@@somewhere.com>'}
function GetEmailDesc(Value: string): string;

{:Returns a string with hexadecimal digits representing the corresponding values
 of the bytes found in "Value" string.}
function StrToHex(const Value: Ansistring): string;

{:Returns a string of binary "Digits" representing "Value".}
function IntToBin(Value: Integer; Digits: Byte): string;

{:Returns an integer equivalent of the binary string in "Value".
 (i.e. ('10001010') returns 138)}
function BinToInt(const Value: string): Integer;

{:Parses a URL to its various components.}
function ParseURL(URL: string; var Prot, User, Pass, Host, Port, Path,
  Para: string): string;

{:Replaces all "Search" string values found within "Value" string, with the
 "Replace" string value.}
function ReplaceString(Value, Search, Replace: string): string;

{:It is like RPos, but search is from specified possition.}
function RPosEx(const Sub, Value: string; From: integer): Integer;

{:It is like POS function, but from right side of Value string.}
function RPos(const Sub, Value: String): Integer;

{:Like @link(fetch), but working with binary strings, not with text.}
function FetchBin(var Value: string; const Delimiter: string): string;

{:Fetch string from left of Value string.}
function Fetch(var Value: string; const Delimiter: string): string;

{:Fetch string from left of Value string. This function ignore delimitesr inside
 quotations.}
function FetchEx(var Value: string; const Delimiter, Quotation: string): string;

{:If string is binary string (contains non-printable characters), then is
 returned true.}
function IsBinaryString(const Value: string): Boolean;

{:return position of string terminator in string. If terminator found, then is
 returned in terminator parameter.
 Possible line terminators are: CRLF, LFCR, CR, LF}
function PosCRLF(const Value: AnsiString; var Terminator: AnsiString): integer;

{:Delete empty strings from end of stringlist.}
Procedure StringsTrim(const value: TStrings);

{:Like Pos function, buf from given string possition.}
function PosFrom(const SubStr, Value: String; From: integer): integer;

{$IFNDEF CIL}
{:Increase pointer by value.}
function IncPoint(const p: pointer; Value: integer): pointer;
{$ENDIF}

{:Get string between PairBegin and PairEnd. This function respect nesting.
 For example:
 @longcode(#
 Value is: 'Hi! (hello(yes!))'
 pairbegin is: '('
 pairend is: ')'
 In this case result is: 'hello(yes!)'#)}
function GetBetween(const PairBegin, PairEnd, Value: string): string;

{:Return count of Chr in Value string.}
function CountOfChar(const Value: string; Chr: char): integer;

{:Remove quotation from Value string. If Value is not quoted, then return same
 string without any modification. }
function UnquoteStr(Value: string; Quote: Char): string;

{:Convert lines in stringlist from 'name: value' form to 'name=value' form.}
procedure HeadersToList(const Value: TStrings);

{:Convert lines in stringlist from 'name=value' form to 'name: value' form.}
procedure ListToHeaders(const Value: TStrings);

{:swap bytes in integer.}
function SwapBytes(Value: integer): integer;

{:read string with requested length form stream.}
function ReadStrFromStream(const Stream: TStream; len: integer): AnsiString;

{:write string to stream.}
procedure WriteStrToStream(const Stream: TStream; Value: AnsiString);

var
  {:can be used for your own months strings for @link(getmonthnumber)}
  CustomMonthNames: array[1..12] of string;

implementation

{==============================================================================}

const
  MyDayNames: array[1..7] of AnsiString =
    ('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat');
var
  MyMonthNames: array[0..6, 1..12] of AnsiString =
    (
    ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',  //rewrited by system locales
     'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'),
    ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',  //English
     'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'),
    ('jan', 'fév', 'mar', 'avr', 'mai', 'jun', //French
     'jul', 'aoû', 'sep', 'oct', 'nov', 'déc'),
    ('jan', 'fev', 'mar', 'avr', 'mai', 'jun',  //French#2
     'jul', 'aou', 'sep', 'oct', 'nov', 'dec'),
    ('Jan', 'Feb', 'Mar', 'Apr', 'Mai', 'Jun',  //German
     'Jul', 'Aug', 'Sep', 'Okt', 'Nov', 'Dez'),
    ('Jan', 'Feb', 'Mär', 'Apr', 'Mai', 'Jun',  //German#2
     'Jul', 'Aug', 'Sep', 'Okt', 'Nov', 'Dez'),
    ('Led', 'Úno', 'Bøe', 'Dub', 'Kvì', 'Èen',  //Czech
     'Èec', 'Srp', 'Záø', 'Øíj', 'Lis', 'Pro')
     );


{==============================================================================}

function TimeZoneBias: integer;
{$IFDEF LINUX}
var
  t: TTime_T;
  UT: TUnixTime;
begin
{$IFNDEF FPC}
  __time(@T);
  localtime_r(@T, UT);
{$ELSE}
  __time(T);
  localtime_r(T, UT);
{$ENDIF}
  Result := ut.__tm_gmtoff div 60;
{$ELSE}
var
  zoneinfo: TTimeZoneInformation;
  bias: Integer;
begin
  case GetTimeZoneInformation(Zoneinfo) of
    2:
      bias := zoneinfo.Bias + zoneinfo.DaylightBias;
    1:
      bias := zoneinfo.Bias + zoneinfo.StandardBias;
  else
    bias := zoneinfo.Bias;
  end;
  Result := bias * (-1);
{$ENDIF}
end;

{==============================================================================}

function TimeZone: string;
var
  bias: Integer;
  h, m: Integer;
begin
  bias := TimeZoneBias;
  if bias >= 0 then
    Result := '+'
  else
    Result := '-';
  bias := Abs(bias);
  h := bias div 60;
  m := bias mod 60;
  Result := Result + Format('%.2d%.2d', [h, m]);
end;

{==============================================================================}

function Rfc822DateTime(t: TDateTime): string;
var
  wYear, wMonth, wDay: word;
begin
  DecodeDate(t, wYear, wMonth, wDay);
  Result := Format('%s, %d %s %s %s', [MyDayNames[DayOfWeek(t)], wDay,
    MyMonthNames[1, wMonth], FormatDateTime('yyyy hh":"nn":"ss', t), TimeZone]);
end;

{==============================================================================}

function CDateTime(t: TDateTime): string;
var
  wYear, wMonth, wDay: word;
begin
  DecodeDate(t, wYear, wMonth, wDay);
  Result:= Format('%s %2d %s', [MyMonthNames[1, wMonth], wDay,
    FormatDateTime('hh":"nn":"ss', t)]);
end;

{==============================================================================}

function SimpleDateTime(t: TDateTime): string;
begin
  Result := FormatDateTime('yymmdd hhnnss', t);
end;

{==============================================================================}

function AnsiCDateTime(t: TDateTime): string;
var
  wYear, wMonth, wDay: word;
begin
  DecodeDate(t, wYear, wMonth, wDay);
  Result := Format('%s %s %d %s', [MyDayNames[DayOfWeek(t)], MyMonthNames[1, wMonth],
    wDay, FormatDateTime('hh":"nn":"ss yyyy ', t)]);
end;

{==============================================================================}

function DecodeTimeZone(Value: string; var Zone: integer): Boolean;
var
  x: integer;
  zh, zm: integer;
  s: string;
begin
  Result := false;
  s := Value;
  if (Pos('+', s) = 1) or (Pos('-',s) = 1) then
  begin
    if s = '-0000' then
      Zone := TimeZoneBias
    else
      if Length(s) > 4 then
      begin
        zh := StrToIntdef(s[2] + s[3], 0);
        zm := StrToIntdef(s[4] + s[5], 0);
        zone := zh * 60 + zm;
        if s[1] = '-' then
          zone := zone * (-1);
      end;
    Result := True;
  end
  else
  begin
    x := 32767;
    if s = 'NZDT' then x := 13;
    if s = 'IDLE' then x := 12;
    if s = 'NZST' then x := 12;
    if s = 'NZT' then x := 12;
    if s = 'EADT' then x := 11;
    if s = 'GST' then x := 10;
    if s = 'JST' then x := 9;
    if s = 'CCT' then x := 8;
    if s = 'WADT' then x := 8;
    if s = 'WAST' then x := 7;
    if s = 'ZP6' then x := 6;
    if s = 'ZP5' then x := 5;
    if s = 'ZP4' then x := 4;
    if s = 'BT' then x := 3;
    if s = 'EET' then x := 2;
    if s = 'MEST' then x := 2;
    if s = 'MESZ' then x := 2;
    if s = 'SST' then x := 2;
    if s = 'FST' then x := 2;
    if s = 'CEST' then x := 2;
    if s = 'CET' then x := 1;
    if s = 'FWT' then x := 1;
    if s = 'MET' then x := 1;
    if s = 'MEWT' then x := 1;
    if s = 'SWT' then x := 1;
    if s = 'UT' then x := 0;
    if s = 'UTC' then x := 0;
    if s = 'GMT' then x := 0;
    if s = 'WET' then x := 0;
    if s = 'WAT' then x := -1;
    if s = 'BST' then x := -1;
    if s = 'AT' then x := -2;
    if s = 'ADT' then x := -3;
    if s = 'AST' then x := -4;
    if s = 'EDT' then x := -4;
    if s = 'EST' then x := -5;
    if s = 'CDT' then x := -5;
    if s = 'CST' then x := -6;
    if s = 'MDT' then x := -6;
    if s = 'MST' then x := -7;
    if s = 'PDT' then x := -7;
    if s = 'PST' then x := -8;
    if s = 'YDT' then x := -8;
    if s = 'YST' then x := -9;
    if s = 'HDT' then x := -9;
    if s = 'AHST' then x := -10;
    if s = 'CAT' then x := -10;
    if s = 'HST' then x := -10;
    if s = 'EAST' then x := -10;
    if s = 'NT' then x := -11;
    if s = 'IDLW' then x := -12;
    if x <> 32767 then
    begin
      zone := x * 60;
      Result := True;
    end;
  end;
end;

{==============================================================================}

function GetMonthNumber(Value: AnsiString): integer;
var
  n: integer;
  function TestMonth(Value: AnsiString; Index: Integer): Boolean;
  var
    n: integer;
  begin
    Result := False;
    for n := 0 to 6 do
      if Value = AnsiUppercase(MyMonthNames[n, Index]) then
      begin
        Result := True;
        Break;
      end;
  end;
begin
  Result := 0;
  Value := AnsiUppercase(Value);
  for n := 1 to 12 do
    if TestMonth(Value, n) or (Value = AnsiUppercase(CustomMonthNames[n])) then
    begin
      Result := n;
      Break;
    end;
end;

{==============================================================================}

function GetTimeFromStr(Value: string): TDateTime;
var
  x: integer;
begin
  x := rpos(':', Value);
  if (x > 0) and ((Length(Value) - x) > 2) then
    Value := Copy(Value, 1, x + 2);
  Value := ReplaceString(Value, ':', TimeSeparator);
  Result := -1;
  try
    Result := StrToTime(Value);
  except
    on Exception do ;
  end;
end;

{==============================================================================}

function GetDateMDYFromStr(Value: string): TDateTime;
var
  wYear, wMonth, wDay: word;
  s: string;
begin
  Result := 0;
  s := Fetch(Value, '-');
  wMonth := StrToIntDef(s, 12);
  s := Fetch(Value, '-');
  wDay := StrToIntDef(s, 30);
  wYear := StrToIntDef(Value, 1899);
  if wYear < 1000 then
    if (wYear > 99) then
      wYear := wYear + 1900
    else
      if wYear > 50 then
        wYear := wYear + 1900
      else
        wYear := wYear + 2000;
  try
    Result := EncodeDate(wYear, wMonth, wDay);
  except
    on Exception do ;
  end;
end;

{==============================================================================}

function DecodeRfcDateTime(Value: string): TDateTime;
var
  day, month, year: Word;
  zone: integer;
  x, y: integer;
  s: string;
  t: TDateTime;
begin
// ddd, d mmm yyyy hh:mm:ss
// ddd, d mmm yy hh:mm:ss
// ddd, mmm d yyyy hh:mm:ss
// ddd mmm dd hh:mm:ss yyyy
// Sun, 06 Nov 1994 08:49:37 GMT    ; RFC 822, updated by RFC 1123
// Sunday, 06-Nov-94 08:49:37 GMT   ; RFC 850, obsoleted by RFC 1036
// Sun Nov  6 08:49:37 1994         ; ANSI C's asctime() Format

  Result := 0;
  if Value = '' then
    Exit;
  day := 0;
  month := 0;
  year := 0;
  zone := 0;
  Value := ReplaceString(Value, ' -', ' #');
  Value := ReplaceString(Value, '-', ' ');
  Value := ReplaceString(Value, ' #', ' -');
  while Value <> '' do
  begin
    s := Fetch(Value, ' ');
    s := uppercase(s);
    // timezone
    if DecodetimeZone(s, x) then
    begin
      zone := x;
      continue;
    end;
    x := StrToIntDef(s, 0);
    // day or year
    if x > 0 then
      if (x < 32) and (day = 0) then
      begin
        day := x;
        continue;
      end
      else
      begin
        if (year = 0) and ((month > 0) or (x > 12)) then
        begin
          year := x;
          if year < 32 then
            year := year + 2000;
          if year < 1000 then
           year := year + 1900;
          continue;
        end;
      end;
    // time
    if rpos(':', s) > Pos(':', s) then
    begin
      t := GetTimeFromStr(s);
      if t <> -1 then
        Result := t;
      continue;
    end;
    //timezone daylight saving time
    if s = 'DST' then
    begin
      zone := zone + 60;
      continue;
    end;
    // month
    y := GetMonthNumber(s);
    if (y > 0) and (month = 0) then
      month := y;
  end;
  if year = 0 then
    year := 1980;
  if (month < 1) or (month > 12) then
    month := 1;
  if (day < 1) or (day > 31) then
    day := 1;
  Result := Result + Encodedate(year, month, day);
  zone := zone - TimeZoneBias;
  x := zone div 1440;
  Result := Result - x;
  zone := zone mod 1440;
  t := EncodeTime(Abs(zone) div 60, Abs(zone) mod 60, 0, 0);
  if zone < 0 then
    t := 0 - t;
  Result := Result - t;
end;

{==============================================================================}

function GetUTTime: TDateTime;
{$IFNDEF LINUX}
{$IFNDEF FPC}
var
  st: TSystemTime;
begin
  GetSystemTime(st);
  result := SystemTimeToDateTime(st);
{$ELSE}
var
  st: SysUtils.TSystemTime;
  stw: Windows.TSystemTime;
begin
  GetSystemTime(stw);
  st.Year := stw.wYear;
  st.Month := stw.wMonth;
  st.Day := stw.wDay;
  st.Hour := stw.wHour;
  st.Minute := stw.wMinute;
  st.Second := stw.wSecond;
  st.Millisecond := stw.wMilliseconds;
  result := SystemTimeToDateTime(st);
{$ENDIF}
{$ELSE}
var
  TV: TTimeVal;
  TZ: Ttimezone;
  PZ: PTimeZone;
begin
  TZ.tz_minuteswest := 0;
  TZ.tz_dsttime := 0;
  PZ := @TZ;
  gettimeofday(TV, PZ);
  Result := UnixDateDelta + (TV.tv_sec + TV.tv_usec / 1000000) / 86400;
{$ENDIF}
end;

{==============================================================================}

function SetUTTime(Newdt: TDateTime): Boolean;
{$IFNDEF LINUX}
{$IFNDEF FPC}
var
  st: TSystemTime;
begin
  DateTimeToSystemTime(newdt,st);
  Result := SetSystemTime(st);
{$ELSE}
var
  st: SysUtils.TSystemTime;
  stw: Windows.TSystemTime;
begin
  DateTimeToSystemTime(newdt,st);
  stw.wYear := st.Year;
  stw.wMonth := st.Month;
  stw.wDay := st.Day;
  stw.wHour := st.Hour;
  stw.wMinute := st.Minute;
  stw.wSecond := st.Second;
  stw.wMilliseconds := st.Millisecond;
  Result := SetSystemTime(stw);
{$ENDIF}
{$ELSE}
var
  TV: TTimeVal;
  d: double;
  TZ: Ttimezone;
  PZ: PTimeZone;
begin
  Result := false;
  TZ.tz_minuteswest := 0;
  TZ.tz_dsttime := 0;
  PZ := @TZ;
  gettimeofday(TV, PZ);
  d := (newdt - UnixDateDelta) * 86400;
  TV.tv_sec := trunc(d);
  TV.tv_usec := trunc(frac(d) * 1000000);
  Result := settimeofday(TV, TZ) <> -1;
{$ENDIF}
end;

{==============================================================================}

{$IFDEF LINUX}
function GetTick: ULong;
var
  Stamp: TTimeStamp;
begin
  Stamp := DateTimeToTimeStamp(Now);
  Result := Stamp.Time;
end;
{$ELSE}
function GetTick: ULong;
begin
  Result := Windows.GetTickCount;
end;
{$ENDIF}

{==============================================================================}

function TickDelta(TickOld, TickNew: ULong): ULong;
begin
//if DWord is signed type (older Deplhi),
// then it not work properly on differencies larger then maxint!
  Result := 0;
  if TickOld <> TickNew then
  begin
    if TickNew < TickOld then
    begin
      TickNew := TickNew + ULong(MaxInt) + 1;
      TickOld := TickOld + ULong(MaxInt) + 1;
    end;
    Result := TickNew - TickOld;
    if TickNew < TickOld then
      if Result > 0 then
        Result := 0 - Result;
  end;
end;

{==============================================================================}

function CodeInt(Value: Word): Ansistring;
begin
  setlength(result, 2);
  result[1] := AnsiChar(Value div 256);
  result[2] := AnsiChar(Value mod 256);
//  Result := AnsiChar(Value div 256) + AnsiChar(Value mod 256)
end;

{==============================================================================}

function DecodeInt(const Value: Ansistring; Index: Integer): Word;
var
  x, y: Byte;
begin
  if Length(Value) > Index then
    x := Ord(Value[Index])
  else
    x := 0;
  if Length(Value) >= (Index + 1) then
    y := Ord(Value[Index + 1])
  else
    y := 0;
  Result := x * 256 + y;
end;

{==============================================================================}

function CodeLongInt(Value: Longint): Ansistring;
var
  x, y: word;
begin
  // this is fix for negative numbers on systems where longint = integer
  x := (Value shr 16) and integer($ffff);
  y := Value and integer($ffff);
  setlength(result, 4);
  result[1] := AnsiChar(x div 256);
  result[2] := AnsiChar(x mod 256);
  result[3] := AnsiChar(y div 256);
  result[4] := AnsiChar(y mod 256);
end;

{==============================================================================}

function DecodeLongInt(const Value: Ansistring; Index: Integer): LongInt;
var
  x, y: Byte;
  xl, yl: Byte;
begin
  if Length(Value) > Index then
    x := Ord(Value[Index])
  else
    x := 0;
  if Length(Value) >= (Index + 1) then
    y := Ord(Value[Index + 1])
  else
    y := 0;
  if Length(Value) >= (Index + 2) then
    xl := Ord(Value[Index + 2])
  else
    xl := 0;
  if Length(Value) >= (Index + 3) then
    yl := Ord(Value[Index + 3])
  else
    yl := 0;
  Result := ((x * 256 + y) * 65536) + (xl * 256 + yl);
end;

{==============================================================================}

function IsIP(const Value: string): Boolean;
var
  TempIP: string;
  function ByteIsOk(const Value: string): Boolean;
  var
    x, n: integer;
  begin
    x := StrToIntDef(Value, -1);
    Result := (x >= 0) and (x < 256);
    // X may be in correct range, but value still may not be correct value!
    // i.e. "$80"
    if Result then
      for n := 1 to length(Value) do
        if not (Value[n] in ['0'..'9']) then
        begin
          Result := False;
          Break;
        end;
  end;
begin
  TempIP := Value;
  Result := False;
  if not ByteIsOk(Fetch(TempIP, '.')) then
    Exit;
  if not ByteIsOk(Fetch(TempIP, '.')) then
    Exit;
  if not ByteIsOk(Fetch(TempIP, '.')) then
    Exit;
  if ByteIsOk(TempIP) then
    Result := True;
end;

{==============================================================================}

function IsIP6(const Value: string): Boolean;
var
  TempIP: string;
  s,t: string;
  x: integer;
  partcount: integer;
  zerocount: integer;
  First: Boolean;
begin
  TempIP := Value;
  Result := False;
  partcount := 0;
  zerocount := 0;
  First := True;
  while tempIP <> '' do
  begin
    s := fetch(TempIP, ':');
    if not(First) and (s = '') then
      Inc(zerocount);
    First := False;
    if zerocount > 1 then
      break;
    Inc(partCount);
    if s = '' then
      Continue;
    if partCount > 8 then
      break;
    if tempIP = '' then
    begin
      t := SeparateRight(s, '%');
      s := SeparateLeft(s, '%');
      x := StrToIntDef('$' + t, -1);
      if (x < 0) or (x > $ffff) then
        break;
    end;
    x := StrToIntDef('$' + s, -1);
    if (x < 0) or (x > $ffff) then
      break;
    if tempIP = '' then
      Result := True;
  end;
end;

{==============================================================================}
//Hernan Sanchez
function IPToID(Host: string): string;
var
  s, t: string;
  i, x: Integer;
begin
  Result := '';
  for x := 1 to 3 do
  begin
    t := '';
    s := Fetch(Host, '.');
    i := StrToIntDef(s, 0);
    Result := Result + Chr(i);
  end;
  i := StrToIntDef(Host, 0);
  Result := Result + Chr(i);
end;

{==============================================================================}

function DumpStr(const Buffer: Ansistring): string;
var
  n: Integer;
begin
  Result := '';
  for n := 1 to Length(Buffer) do
    Result := Result + ' +#$' + IntToHex(Ord(Buffer[n]), 2);
end;

{==============================================================================}

function DumpExStr(const Buffer: Ansistring): string;
var
  n: Integer;
  x: Byte;
begin
  Result := '';
  for n := 1 to Length(Buffer) do
  begin
    x := Ord(Buffer[n]);
    if x in [65..90, 97..122] then
      Result := Result + ' +''' + char(x) + ''''
    else
      Result := Result + ' +#$' + IntToHex(Ord(Buffer[n]), 2);
  end;
end;

{==============================================================================}

procedure Dump(const Buffer: AnsiString; DumpFile: string);
var
  f: Text;
begin
  AssignFile(f, DumpFile);
  if FileExists(DumpFile) then
    DeleteFile(DumpFile);
  Rewrite(f);
  try
    Writeln(f, DumpStr(Buffer));
  finally
    CloseFile(f);
  end;
end;

{==============================================================================}

procedure DumpEx(const Buffer: AnsiString; DumpFile: string);
var
  f: Text;
begin
  AssignFile(f, DumpFile);
  if FileExists(DumpFile) then
    DeleteFile(DumpFile);
  Rewrite(f);
  try
    Writeln(f, DumpExStr(Buffer));
  finally
    CloseFile(f);
  end;
end;

{==============================================================================}

function TrimSPLeft(const S: string): string;
var
  I, L: Integer;
begin
  L := Length(S);
  I := 1;
  while (I <= L) and (S[I] = ' ') do
    Inc(I);
  Result := Copy(S, I, Maxint);
end;

{==============================================================================}

function TrimSPRight(const S: string): string;
var
  I: Integer;
begin
  I := Length(S);
  while (I > 0) and (S[I] = ' ') do
    Dec(I);
  Result := Copy(S, 1, I);
end;

{==============================================================================}

function TrimSP(const S: string): string;
begin
  Result := TrimSPLeft(s);
  Result := TrimSPRight(Result);
end;

{==============================================================================}

function SeparateLeft(const Value, Delimiter: string): string;
var
  x: Integer;
begin
  x := Pos(Delimiter, Value);
  if x < 1 then
    Result := Value
  else
    Result := Copy(Value, 1, x - 1);
end;

{==============================================================================}

function SeparateRight(const Value, Delimiter: string): string;
var
  x: Integer;
begin
  x := Pos(Delimiter, Value);
  if x > 0 then
    x := x + Length(Delimiter) - 1;
  Result := Copy(Value, x + 1, Length(Value) - x);
end;

{==============================================================================}

function GetParameter(const Value, Parameter: string): string;
var
  s: string;
  v: string;
begin
  Result := '';
  v := Value;
  while v <> '' do
  begin
    s := Trim(FetchEx(v, ';', '"'));
    if Pos(Uppercase(parameter), Uppercase(s)) = 1 then
    begin
      Delete(s, 1, Length(Parameter));
      s := Trim(s);
      if s = '' then
        Break;
      if s[1] = '=' then
      begin
        Result := Trim(SeparateRight(s, '='));
        Result := UnquoteStr(Result, '"');
        break;
      end;
    end;
  end;
end;

{==============================================================================}

procedure ParseParametersEx(Value, Delimiter: string; const Parameters: TStrings);
var
  s: string;
begin
  Parameters.Clear;
  while Value <> '' do
  begin
    s := Trim(FetchEx(Value, Delimiter, '"'));
    Parameters.Add(s);
  end;
end;

{==============================================================================}

procedure ParseParameters(Value: string; const Parameters: TStrings);
begin
  ParseParametersEx(Value, ';', Parameters);
end;

{==============================================================================}

function IndexByBegin(Value: string; const List: TStrings): integer;
var
  n: integer;
  s: string;
begin
  Result := -1;
  Value := uppercase(Value);
  for n := 0 to List.Count -1 do
  begin
    s := UpperCase(List[n]);
    if Pos(Value, s) = 1 then
    begin
      Result := n;
      Break;
    end;
  end;
end;

{==============================================================================}

function GetEmailAddr(const Value: string): string;
var
  s: string;
begin
  s := SeparateRight(Value, '<');
  s := SeparateLeft(s, '>');
  Result := Trim(s);
end;

{==============================================================================}

function GetEmailDesc(Value: string): string;
var
  s: string;
begin
  Value := Trim(Value);
  s := SeparateRight(Value, '"');
  if s <> Value then
    s := SeparateLeft(s, '"')
  else
  begin
    s := SeparateLeft(Value, '<');
    if s = Value then
    begin
      s := SeparateRight(Value, '(');
      if s <> Value then
        s := SeparateLeft(s, ')')
      else
        s := '';
    end;
  end;
  Result := Trim(s);
end;

{==============================================================================}

function StrToHex(const Value: Ansistring): string;
var
  n: Integer;
begin
  Result := '';
  for n := 1 to Length(Value) do
    Result := Result + IntToHex(Byte(Value[n]), 2);
  Result := LowerCase(Result);
end;

{==============================================================================}

function IntToBin(Value: Integer; Digits: Byte): string;
var
  x, y, n: Integer;
begin
  Result := '';
  x := Value;
  repeat
    y := x mod 2;
    x := x div 2;
    if y > 0 then
      Result := '1' + Result
    else
      Result := '0' + Result;
  until x = 0;
  x := Length(Result);
  for n := x to Digits - 1 do
    Result := '0' + Result;
end;

{==============================================================================}

function BinToInt(const Value: string): Integer;
var
  n: Integer;
begin
  Result := 0;
  for n := 1 to Length(Value) do
  begin
    if Value[n] = '0' then
      Result := Result * 2
    else
      if Value[n] = '1' then
        Result := Result * 2 + 1
      else
        Break;
  end;
end;

{==============================================================================}

function ParseURL(URL: string; var Prot, User, Pass, Host, Port, Path,
  Para: string): string;
var
  x, y: Integer;
  sURL: string;
  s: string;
  s1, s2: string;
begin
  Prot := 'http';
  User := '';
  Pass := '';
  Port := '80';
  Para := '';

  x := Pos('://', URL);
  if x > 0 then
  begin
    Prot := SeparateLeft(URL, '://');
    sURL := SeparateRight(URL, '://');
  end
  else
    sURL := URL;
  if UpperCase(Prot) = 'HTTPS' then
    Port := '443';
  if UpperCase(Prot) = 'FTP' then
    Port := '21';
  x := Pos('@', sURL);
  y := Pos('/', sURL);
  if (x > 0) and ((x < y) or (y < 1))then
  begin
    s := SeparateLeft(sURL, '@');
    sURL := SeparateRight(sURL, '@');
    x := Pos(':', s);
    if x > 0 then
    begin
      User := SeparateLeft(s, ':');
      Pass := SeparateRight(s, ':');
    end
    else
      User := s;
  end;
  x := Pos('/', sURL);
  if x > 0 then
  begin
    s1 := SeparateLeft(sURL, '/');
    s2 := SeparateRight(sURL, '/');
  end
  else
  begin
    s1 := sURL;
    s2 := '';
  end;
  if Pos('[', s1) = 1 then
  begin
    Host := Separateleft(s1, ']');
    Delete(Host, 1, 1);
    s1 := SeparateRight(s1, ']');
    if Pos(':', s1) = 1 then
      Port := SeparateRight(s1, ':');
  end
  else
  begin
    x := Pos(':', s1);
    if x > 0 then
    begin
      Host := SeparateLeft(s1, ':');
      Port := SeparateRight(s1, ':');
    end
    else
      Host := s1;
  end;
  Result := '/' + s2;
  x := Pos('?', s2);
  if x > 0 then
  begin
    Path := '/' + SeparateLeft(s2, '?');
    Para := SeparateRight(s2, '?');
  end
  else
    Path := '/' + s2;
  if Host = '' then
    Host := 'localhost';
end;

{==============================================================================}

function ReplaceString(Value, Search, Replace: string): string;
var
  x, l, ls, lr: Integer;
begin
  if (Value = '') or (Search = '') then
  begin
    Result := Value;
    Exit;
  end;
  ls := Length(Search);
  lr := Length(Replace);
  Result := '';
  x := Pos(Search, Value);
  while x > 0 do
  begin
    {$IFNDEF CIL}
    l := Length(Result);
    SetLength(Result, l + x - 1);
    Move(Pointer(Value)^, Pointer(@Result[l + 1])^, x - 1);
    {$ELSE}
    Result:=Result+Copy(Value,1,x-1);
    {$ENDIF}
    {$IFNDEF CIL}
    l := Length(Result);
    SetLength(Result, l + lr);
    Move(Pointer(Replace)^, Pointer(@Result[l + 1])^, lr);
    {$ELSE}
    Result:=Result+Replace;
    {$ENDIF}
    Delete(Value, 1, x - 1 + ls);
    x := Pos(Search, Value);
  end;
  Result := Result + Value;
end;

{==============================================================================}

function RPosEx(const Sub, Value: string; From: integer): Integer;
var
  n: Integer;
  l: Integer;
begin
  result := 0;
  l := Length(Sub);
  for n := From - l + 1 downto 1 do
  begin
    if Copy(Value, n, l) = Sub then
    begin
      result := n;
      break;
    end;
  end;
end;

{==============================================================================}

function RPos(const Sub, Value: String): Integer;
begin
  Result := RPosEx(Sub, Value, Length(Value));
end;

{==============================================================================}

function FetchBin(var Value: string; const Delimiter: string): string;
var
  s: string;
begin
  Result := SeparateLeft(Value, Delimiter);
  s := SeparateRight(Value, Delimiter);
  if s = Value then
    Value := ''
  else
    Value := s;
end;

{==============================================================================}

function Fetch(var Value: string; const Delimiter: string): string;
begin
  Result := FetchBin(Value, Delimiter);
  Result := TrimSP(Result);
  Value := TrimSP(Value);
end;

{==============================================================================}

function FetchEx(var Value: string; const Delimiter, Quotation: string): string;
var
  n: integer;
  b: Boolean;
begin
  Result := '';
  b := False;
  n := 1;
  while n <= Length(Value) do
  begin
    if b then
    begin
      if Pos(Quotation, Value) = 1 then
        b := False;
      Result := Result + Value[1];
      Delete(Value, 1, 1);
    end
    else
    begin
      if Pos(Delimiter, Value) = 1 then
      begin
        Delete(Value, 1, Length(delimiter));
        break;
      end;
      b := Pos(Quotation, Value) = 1;
      Result := Result + Value[1];
      Delete(Value, 1, 1);
    end;
  end;
end;

{==============================================================================}

function IsBinaryString(const Value: string): Boolean;
var
  n: integer;
begin
  Result := False;
  for n := 1 to Length(Value) do
    if Value[n] in [#0..#8, #10..#31] then
    begin
      Result := True;
      Break;
    end;
end;

{==============================================================================}

function PosCRLF(const Value: AnsiString; var Terminator: AnsiString): integer;
var
  p1, p2, p3, p4: integer;
const
  t1 = #$0d + #$0a;
  t2 = #$0a + #$0d;
  t3 = #$0d;
  t4 = #$0a;
begin
  Terminator := '';
  p1 := Pos(t1, Value);
  p2 := Pos(t2, Value);
  p3 := Pos(t3, Value);
  p4 := Pos(t4, Value);
  if p1 > 0 then
    Terminator := t1;
  Result := p1;
  if (p2 > 0) then
    if (Result = 0) or (p2 < Result) then
    begin
      Result := p2;
      Terminator := t2;
    end;
  if (p3 > 0) then
    if (Result = 0) or (p3 < Result) then
    begin
      Result := p3;
      Terminator := t3;
    end;
  if (p4 > 0) then
    if (Result = 0) or (p4 < Result) then
    begin
      Result := p4;
      Terminator := t4;
    end;
end;

{==============================================================================}

Procedure StringsTrim(const Value: TStrings);
var
  n: integer;
begin
  for n := Value.Count - 1 downto 0 do
    if Value[n] = '' then
      Value.Delete(n)
    else
      Break;
end;

{==============================================================================}

function PosFrom(const SubStr, Value: String; From: integer): integer;
var
  ls,lv: integer;
begin
  Result := 0;
  ls := Length(SubStr);
  lv := Length(Value);
  if (ls = 0) or (lv = 0) then
    Exit;
  if From < 1 then
    From := 1;
  while (ls + from - 1) <= (lv) do
  begin
    {$IFNDEF CIL}
    if CompareMem(@SubStr[1],@Value[from],ls) then
    {$ELSE}
    if SubStr = copy(Value, from, ls) then
    {$ENDIF}
    begin
      result := from;
      break;
    end
    else
      inc(from);
  end;
end;

{==============================================================================}

{$IFNDEF CIL}
function IncPoint(const p: pointer; Value: integer): pointer;
begin
  Result := pointer(integer(p) + Value);
end;
{$ENDIF}

{==============================================================================}

function GetBetween(const PairBegin, PairEnd, Value: string): string;
var
  n: integer;
  x: integer;
  s: string;
begin
  Result := '';
  s := SeparateRight(Value, PairBegin);
  x := 1;
  for n := 1 to Length(s) do
  begin
    if s[n] = PairBegin then
      Inc(x);
    if s[n] = PairEnd then
    begin
      Dec(x);
      if x <= 0 then
        Break;
    end;
    Result := Result + s[n];
  end;
end;

{==============================================================================}

function CountOfChar(const Value: string; Chr: char): integer;
var
  n: integer;
begin
  Result := 0;
  for n := 1 to Length(Value) do
    if Value[n] = chr then
      Inc(Result);
end;

{==============================================================================}

function UnquoteStr(Value: string; Quote: Char): string;
  {$IFNDEF CIL}
var
  LText: PChar;
  {$ENDIF}
begin
  if Value = '' then
  begin
    Result := '';
    Exit;
  end;
  if Value = Quote + Quote then
  begin
    Result := '';
    Exit;
  end;
  //workaround for bug in AnsiExtractQuotedStr
  //...if string begin by Quote, but not ending by Quote, then it eat last char.
  if length(Value) > 1 then
    if (Value[1] = Quote) and (Value[Length(value)] <> Quote) then
      Value := Value + Quote;
  {$IFNDEF CIL}
  LText := PChar(Value);
  Result := AnsiExtractQuotedStr(LText, Quote);
  {$ELSE}
  Result := DequotedStr(Value, Quote);
  {$ENDIF}
  if Result = '' then
    Result := Value;
end;

{==============================================================================}

procedure HeadersToList(const Value: TStrings);
var
  n, x: integer;
  s: string;
begin
  for n := 0 to Value.Count -1 do
  begin
    s := Value[n];
    x := Pos(':', s);
    if x > 0 then
    begin
      s[x] := '=';
      Value[n] := s;
    end;
  end;
end;

{==============================================================================}

procedure ListToHeaders(const Value: TStrings);
var
  n, x: integer;
  s: string;
begin
  for n := 0 to Value.Count -1 do
  begin
    s := Value[n];
    x := Pos('=', s);
    if x > 0 then
    begin
      s[x] := ':';
      Value[n] := s;
    end;
  end;
end;

{==============================================================================}

function SwapBytes(Value: integer): integer;
var
  s: string;
  x, y, xl, yl: Byte;
begin
  s := CodeLongInt(Value);
  x := Ord(s[4]);
  y := Ord(s[3]);
  xl := Ord(s[2]);
  yl := Ord(s[1]);
  Result := ((x * 256 + y) * 65536) + (xl * 256 + yl);
end;

{==============================================================================}

function ReadStrFromStream(const Stream: TStream; len: integer): AnsiString;
var
  x: integer;
{$IFDEF CIL}
  buf: Array of Byte;
{$ENDIF}
begin
{$IFDEF CIL}
  Setlength(buf, Len);
  x := Stream.read(buf, Len);
  SetLength(buf, x);
  Result := StringOf(Buf);
{$ELSE}
  Setlength(Result, Len);
  x := Stream.read(Pchar(Result)^, Len);
  SetLength(Result, x);
{$ENDIF}
end;

{==============================================================================}

procedure WriteStrToStream(const Stream: TStream; Value: AnsiString);
{$IFDEF CIL}
var
  buf: Array of Byte;
{$ENDIF}
begin
{$IFDEF CIL}
  buf := BytesOf(Value);
  Stream.Write(buf,length(Value));
{$ELSE}
  Stream.Write(PChar(Value)^, Length(Value));
{$ENDIF}
end;

{==============================================================================}
var
  n: integer;
begin
  for n :=  1 to 12 do
  begin
    CustomMonthNames[n] := ShortMonthNames[n];
    MyMonthNames[0, n] := ShortMonthNames[n];
  end;
end.