[ViewVC] Diff of: public/ibx/trunk/fbintf/IBUtils.pas

Comparing ibx/trunk/fbintf/IBUtils.pas (file contents):
Revision 314 by tony, Mon Aug 24 09:32:58 2020 UTC vs.
Revision 315 by tony, Thu Feb 25 11:56:36 2021 UTC

+{$IFDEF FPC}
+{$Mode Delphi}
+{$codepage UTF8}
-–
+{$define HASREQEX}
+{$ENDIF}
-+
+{ $IF declared(CompilerVersion) and (CompilerVersion >= 22)}
-+
+{ $define HASDELPHIREQEX}
-+
+{ $IFEND}
+interface
+              var PortNo: AnsiString): boolean;
+function GetProtocol(ConnectString: AnsiString): TProtocolAll;
-+
+{$IF declared(TFormatSettings)}
-+
+function ParseDateTimeTZString(aDateTimeStr: Ansistring; var aDateTime: TDateTime;
-+
+              var aTimezone: AnsiString; aFormatSettings: TFormatSettings; TimeOnly: boolean=false): boolean; overload;
-+
+{$IFEND}
-+
+function ParseDateTimeTZString(aDateTimeStr: Ansistring; var aDateTime: TDateTime;
-+
+              var aTimezone: AnsiString; TimeOnly: boolean=false): boolean;  overload;
-+
+procedure FBDecodeTime(aTime: TDateTime; var Hour, Minute, Second: word; var DeciMillisecond: cardinal);
-+
+function FBEncodeTime(Hour, Minute, Second, DeciMillisecond: cardinal): TDateTime;
-+
+function FBFormatDateTime(fmt: AnsiString; aDateTime: TDateTime): AnsiString;
-+
+function FormatTimeZoneOffset(EffectiveTimeOffsetMins: integer): AnsiString;
-+
+function DecodeTimeZoneOffset(TZOffset: AnsiString; var dstOffset: integer): boolean;
-+
+function StripLeadingZeros(Value: AnsiString): AnsiString;
-+
+implementation
+uses FBMessages
-<
+{$IFDEF HASREQEX}
->
+{$IFDEF FPC}
+,RegExpr
-+
+{$ELSE}
-+
+{$IF declared(CompilerVersion) and (CompilerVersion >= 22)}
-+
+, RegularExpressions
-+
+{$IFEND}
+{$ENDIF};
-+
+function Max(n1, n2: Integer): Integer;
+begin
+  if (n1 > n2) then
+  Result := true;
+end;
-+
+function SchemeToProtocol(scheme: AnsiString): TProtocolAll;
-+
+begin
-+
+  scheme := AnsiUpperCase(scheme);
-+
+  if scheme = 'INET' then
-+
+    Result := inet
-+
+  else
-+
+  if scheme = 'INET4' then
-+
+    Result := inet4
-+
+  else
-+
+  if scheme = 'INET6' then
-+
+    Result := inet6
-+
+  else
-+
+  if scheme = 'XNET' then
-+
+    Result := xnet
-+
+  else
-+
+  if scheme = 'WNET' then
-+
+    Result := wnet
-+
+end;
-+
+{Extracts the Database Connect string from a Create Database Statement}
-<
+{$IFDEF HASREQEX}
->
+{$IF declared(TRegexpr)}
+function ExtractConnectString(const CreateSQL: AnsiString;
+  var ConnectString: AnsiString): boolean;
+var RegexObj: TRegExpr;
+  DatabaseName: AnsiString; var Protocol: TProtocolAll; var PortNo: AnsiString
+  ): boolean;
-–
+  function GetProtocol(scheme: AnsiString): TProtocolAll;
-–
+  begin
-–
+    scheme := AnsiUpperCase(scheme);
-–
+    if scheme = 'INET' then
-–
+      Result := inet
-–
+    else
-–
+    if scheme = 'INET4' then
-–
+      Result := inet4
-–
+    else
-–
+    if scheme = 'INET6' then
-–
+      Result := inet6
-–
+    else
-–
+    if scheme = 'XNET' then
-–
+      Result := xnet
-–
+    else
-–
+    if scheme = 'WNET' then
-–
+      Result := wnet
-–
+  end;
-–
+var RegexObj: TRegExpr;
+begin
+  ServerName := '';
+    if Result then
+    begin
+      {URL type connect string}
-<
+      Protocol := GetProtocol(RegexObj.Match[1]);
->
+      Protocol := SchemeToProtocol(RegexObj.Match[1]);
+      ServerName := RegexObj.Match[2];
+      if RegexObj.MatchLen[3] > 0 then
+        PortNo := system.Copy(ConnectString,RegexObj.MatchPos[3]+1,RegexObj.MatchLen[3]-1);
+      Result := RegexObj.Exec(ConnectString);
+      if Result then
+      begin
-<
+        Protocol := GetProtocol(RegexObj.Match[1]);
->
+        Protocol := SchemeToProtocol(RegexObj.Match[1]);
+        DatabaseName := RegexObj.Match[2];
+      end
+      else
+  end;
+end;
-<
+function GetProtocol(ConnectString: AnsiString): TProtocolAll;
-<
+var ServerName,
-<
+    DatabaseName: AnsiString;
-<
+    PortNo: AnsiString;
->
+{$ELSE}
->
+{$IF declared(TRegex)}
->
+function ExtractConnectString(const CreateSQL: AnsiString;
->
+  var ConnectString: AnsiString): boolean;
->
+var Regex: TRegEx;
->
+    Match: TMatch;
+begin
-<
+  ParseConnectString(ConnectString,ServerName,DatabaseName,Result,PortNo);
->
+  Regex := TRegEx.Create('^ *CREATE +(DATABASE|SCHEMA) +''(.*)''',[roIgnoreCase]);
->
+  {extact database file spec}
->
+  Match := Regex.Match(CreateSQL);
->
+  Result := Match.Success and (Match.Groups.Count = 3);
->
+  if Result then
->
+    ConnectString := Match.Groups[2].Value;
+end;
-+
+function ParseConnectString(ConnectString: AnsiString; var ServerName,
-+
+  DatabaseName: AnsiString; var Protocol: TProtocolAll; var PortNo: AnsiString
-+
+  ): boolean;
-+
-+
+var Regex: TRegEx;
-+
+    Match: TMatch;
-+
+begin
-+
+  ServerName := '';
-+
+  DatabaseName := ConnectString;
-+
+  PortNo := '';
-+
+  Protocol := unknownProtocol;
-+
+  {extact database file spec}
-+
+  Match := Regex.Match(ConnectString,'^([a-zA-Z46]+)://([a-zA-Z0-9\-\.]*)(|:[0-9a-zA-Z\-]+)/(.*)$',[roIgnoreCase]);
-+
+  Result := Match.Success and (Match.Groups.Count = 5);
-+
+  if Result then
-+
+  begin
-+
+    {URL type connect string}
-+
+    Protocol := SchemeToProtocol(Match.Groups[1].Value);
-+
+    ServerName := Match.Groups[2].Value;
-+
+    PortNo := Match.Groups[3].Value;
-+
+    DatabaseName := Match.Groups[4].Value;
-+
+    if ServerName = '' then
-+
+      DatabaseName := '/' + DatabaseName;
-+
+  end
-+
+  else
-+
+  begin
-+
+    {URL type connect string - local loop}
-+
+    Match := Regex.Match(ConnectString,'^([a-zA-Z46]+)://(.*)$',[roIgnoreCase]);
-+
+    Result := Match.Success and (Match.Groups.Count = 3);
-+
+    if Result then
-+
+    begin
-+
+      Protocol := SchemeToProtocol(Match.Groups[1].Value);
-+
+      DatabaseName := Match.Groups[2].Value;
-+
+    end
-+
+    else
-+
+    begin
-+
+      Match := Regex.Match(ConnectString,'^([a-zA-Z]:\\.*)',[roIgnoreCase]);
-+
+      Result := Match.Success;
-+
+      if Result then
-+
+        Protocol := Local {Windows with leading drive ID}
-+
+      else
-+
+      begin
-+
+        Match := Regex.Match(ConnectString,'^([a-zA-Z0-9\-\.]+)(|/[0-9a-zA-Z\-]+):(.*)$',[roIgnoreCase]);
-+
+        Result := Match.Success and (Match.Groups.Count = 4);
-+
+        if Result then
-+
+        begin
-+
+          {Legacy TCP Format}
-+
+          ServerName := Match.Groups[1].Value;
-+
+          PortNo := Match.Groups[2].Value;
-+
+          DatabaseName := Match.Groups[3].Value;
-+
+          Protocol := TCP;
-+
+        end
-+
+        else
-+
+        begin
-+
+          Match := Regex.Match(ConnectString,'^\\\\([a-zA-Z0-9\-\.]+)(|@[0-9a-zA-Z\-]+)\\(.*)$',[roIgnoreCase]);
-+
+          Result := Match.Success and (Match.Groups.Count = 4);
-+
+          if Result then
-+
+          begin
-+
+            {Netbui}
-+
+            ServerName := Match.Groups[1].Value;
-+
+            PortNo := Match.Groups[2].Value;
-+
+            DatabaseName := Match.Groups[3].Value;
-+
+            Protocol := NamedPipe
-+
+          end
-+
+          else
-+
+          begin
-+
+            Result := true;
-+
+            Protocol := Local; {Assume local}
-+
+          end;
-+
+        end;
-+
+      end;
-+
+    end;
-+
+  end;
-+
+end;
+{$ELSE}
-<
+{cruder version of above for Delphi. Older versions lack regular expression
->
+{cruder version of above for Delphi < XE. Older versions lack regular expression
+ handling.}
+function ExtractConnectString(const CreateSQL: AnsiString;
+  var ConnectString: AnsiString): boolean;
+  end;
+end;
-–
+function GetProtocol(ConnectString: AnsiString): TProtocolAll;
-–
+begin
-–
+  Result := unknownProtocol; {not implemented for Delphi}
-–
+end;
-–
+function ParseConnectString(ConnectString: AnsiString;
+              var ServerName, DatabaseName: AnsiString; var Protocol: TProtocolAll;
+              var PortNo: AnsiString): boolean;
+  Result := false;
+end;
-<
+{$ENDIF}
->
+{$IFEND}
->
+{$IFEND}
->
->
+function GetProtocol(ConnectString: AnsiString): TProtocolAll;
->
+var ServerName,
->
+    DatabaseName: AnsiString;
->
+    PortNo: AnsiString;
->
+begin
->
+  if not ParseConnectString(ConnectString,ServerName,DatabaseName,Result,PortNo) then
->
+    Result := unknownProtocol;
->
+end;
+{Make a connect string in format appropriate protocol}
+  end;
+begin
-+
+  if ServerName = '' then ServerName := 'localhost';
+  if PortNo <> '' then
+    case Protocol of
+    NamedPipe:
+  until TokenFound(Result) or EOF;
+end;
-+
+function ParseDateTimeTZString(aDateTimeStr: Ansistring; var aDateTime: TDateTime;
-+
+  var aTimezone: AnsiString; TimeOnly: boolean): boolean;
-+
+{$IF declared(TFormatSettings)}
-+
+begin
-+
+    {$IF declared(DefaultFormatSettings)}
-+
+    Result := ParseDateTimeTZString(aDateTimeStr,aDateTime,aTimeZone,DefaultFormatSettings,TimeOnly);
-+
+    {$ELSE}
-+
+    {$IF declared(FormatSettings)}
-+
+    Result := ParseDateTimeTZString(aDateTimeStr,aDateTime,aTimeZone,FormatSettings,TimeOnly);
-+
+    {$IFEND} {$IFEND}
-+
+end;
-+
-+
+function ParseDateTimeTZString(aDateTimeStr: Ansistring; var aDateTime: TDateTime;
-+
+              var aTimezone: AnsiString; aFormatSettings: TFormatSettings; TimeOnly: boolean=false): boolean;
-+
+{$IFEND}
-+
+const
-+
+  whitespacechars = [' ',#$09,#$0A,#$0D];
-+
+var i,j,l: integer;
-+
+    aTime: TDateTime;
-+
+    DMs: longint;
-+
+begin
-+
+  Result := false;
-+
+  aTimezone := '';
-+
+  if aDateTimeStr <> '' then
-+
+  {$if declared(TFormatSettings)}
-+
+  with aFormatSettings do
-+
+  {$IFEND}
-+
+  begin
-+
+    aDateTime := 0;
-+
+    {Parse to get time zone info}
-+
+    i := 1;
-+
+    while (i <= length(aDateTimeStr)) and (aDateTimeStr[i] in whitespacechars) do inc(i); {skip white space}
-+
+    if not TimeOnly then
-+
+    begin
-+
+      {decode date}
-+
+      j := i;
-+
+      while (j <= length(aDateTimeStr)) and (aDateTimeStr[j] in ['0'..'9',DateSeparator]) do inc(j);
-+
+      if TryStrToDate(system.copy(aDateTimeStr,i,j-i),aDateTime) then
-+
+        i := j; {otherwise start again i.e. assume time only}
-+
+    end;
-+
-+
+    while (i <= length(aDateTimeStr)) and (aDateTimeStr[i] in whitespacechars) do inc(i); {skip white space}
-+
+    {decode time}
-+
+    j := i;
-+
+    while (j <= length(aDateTimeStr)) and (aDateTimeStr[j] in ['0'..'9',TimeSeparator]) do inc(j);
-+
+    Result := TryStrToTime(system.copy(aDateTimeStr,i,j-i),aTime);
-+
+    if not Result then Exit;
-+
+    aDateTime := aDateTime + aTime;
-+
+    i := j;
-+
-+
+    {is there a factional second part}
-+
+    if (i <= length(aDateTimeStr)) and (aDateTimeStr[i] = '.') then
-+
+    begin
-+
+      inc(i);
-+
+      inc(j);
-+
+      while (j <= Length(aDateTimeStr)) and (aDateTimeStr[j] in ['0'..'9']) do inc(j);
-+
+      if j > i then
-+
+      begin
-+
+        l := j-i;
-+
+        if l > 4 then l := 4;
-+
+        Result := TryStrToInt(system.copy(aDateTimeStr,i,l),DMs);
-+
+        if not Result then Exit;
-+
-+
+        {adjust for number of significant digits}
-+
+        case l of
-+
+:   DMs := DMs * 10;
-+
+:   DMs := DMs * 100;
-+
+:   DMs := DMs * 1000;
-+
+        end;
-+
+       aDateTime := aDateTime + (DMs / (MsecsPerDay*10));
-+
+      end;
-+
+    end;
-+
+    i := j;
-+
-+
+    while (i <= length(aDateTimeStr)) and (aDateTimeStr[i] in whitespacechars) do inc(i); {skip white space}
-+
+    {decode time zone}
-+
+    if i < length(aDateTimeStr) then
-+
+    begin
-+
+      j := i;
-+
+      while (j <= length(aDateTimeStr)) and not (aDateTimeStr[j] in whitespacechars) do inc(j);
-+
+      aTimezone := system.copy(aDateTimeStr,i,j-i);
-+
+    end;
-+
+    Result := true;
-+
+  end
-+
+end;
-+
-+
+{The following is similar to FPC DecodeTime except that the Firebird standard
-+
+ decimilliseconds is used instead of milliseconds for fractional seconds}
-+
-+
+procedure FBDecodeTime(aTime: TDateTime; var Hour, Minute, Second: word;
-+
+  var DeciMillisecond: cardinal);
-+
+var D : Double;
-+
+    l : cardinal;
-+
+begin
-+
+  {conversion to decimilliseconds hacked from FPC DateTimeToTimeStamp}
-+
+  D := aTime * MSecsPerDay *10;
-+
+  if D < 0 then
-+
+    D := D - 0.5
-+
+  else
-+
+    D := D + 0.5;
-+
+  {rest hacked from FPC DecodeTIme}
-+
+  l := Abs(Trunc(D)) Mod (MSecsPerDay*10);
-+
+  Hour   := l div 36000000;
-+
+  l := l mod 36000000;
-+
+  Minute := l div 600000;
-+
+  l := l mod 600000;
-+
+  Second := l div 10000;
-+
+  DeciMillisecond := l mod 10000;
-+
+end;
-+
-+
+{The following is similar to FPC EncodeTime except that the Firebird standard
-+
+ decimilliseconds is used instead of milliseconds for fractional seconds}
-+
-+
+function FBEncodeTime(Hour, Minute, Second, DeciMillisecond: cardinal): TDateTime;
-+
+const DMSecsPerDay = MSecsPerDay*10;
-+
+var DMs: cardinal;
-+
+    D: Double;
-+
+begin
-+
+  if (Hour<24) and (Minute<60) and (Second<60) and (DeciMillisecond<10000) then
-+
+  begin
-+
+    DMs := Hour*36000000+Minute*600000+Second*10000+DeciMillisecond;
-+
+    D := DMs/DMSecsPerDay;
-+
+    Result:=TDateTime(d)
-+
+  end
-+
+  else
-+
+    IBError(ibxeBadTimeSpecification,[Hour, Minute, Second, DeciMillisecond]);
-+
+end;
-+
-+
+{The following is similar to FPC FormatDateTime except that it additionally
-+
+ allows the timstamp to have a fractional seconds component with a resolution
-+
+ of four decimal places. This is appended to the result for FormatDateTime
-+
+ if the format string contains a "zzzz' string.}
-+
-+
+function FBFormatDateTime(fmt: AnsiString; aDateTime: TDateTime): AnsiString;
-+
+var Hour, Minute, Second: word;
-+
+    DeciMillisecond: cardinal;
-+
+begin
-+
+  if Pos('zzzz',fmt) > 0 then
-+
+  begin
-+
+    FBDecodeTime(aDateTime, Hour, Minute, Second, DeciMillisecond);
-+
+    fmt := StringReplace(fmt, 'zzzz', Format('%.4d',[DeciMillisecond]), [rfReplaceAll]);
-+
+  end;
-+
+  Result := FormatDateTime(fmt,aDateTime);
-+
+end;
-+
-+
+function FormatTimeZoneOffset(EffectiveTimeOffsetMins: integer): AnsiString;
-+
+begin
-+
+  if EffectiveTimeOffsetMins > 0 then
-+
+    Result := Format('+%.2d:%.2d',[EffectiveTimeOffsetMins div 60,abs(EffectiveTimeOffsetMins mod 60)])
-+
+  else
-+
+    Result := Format('%.2d:%.2d',[EffectiveTimeOffsetMins div 60,abs(EffectiveTimeOffsetMins mod 60)]);
-+
+end;
-+
-+
+function DecodeTimeZoneOffset(TZOffset: AnsiString; var dstOffset: integer): boolean;
-+
+var i: integer;
-+
+begin
-+
+  Result := false;
-+
+  TZOffset := Trim(TZOffset);
-+
+  for i := 1 to Length(TZOffset) do
-+
+    if not (TZOffset[i] in ['0'..'9','-','+',':']) then Exit;
-+
-+
+  Result := true;
-+
+  i := Pos(':',TZOffset);
-+
+  if i > 0 then
-+
+    dstOffset := StrToInt(copy(TZOffset,1,i-1)) * 60 + StrToInt(copy(TZOffset,i + 1))
-+
+  else
-+
+    dstOffset := StrToInt(TZOffset) * 60;
-+
+end;
-+
-+
+function StripLeadingZeros(Value: AnsiString): AnsiString;
-+
+var i: Integer;
-+
+    start: integer;
-+
+begin
-+
+  Result := '';
-+
+  start := 1;
-+
+  if (Length(Value) > 0) and (Value[1] = '-') then
-+
+  begin
-+
+    Result := '-';
-+
+    start := 2;
-+
+  end;
-+
+  for i := start to Length(Value) do
-+
+    if Value[i] <> '0' then
-+
+    begin
-+
+      Result := Result + system.copy(Value, i, MaxInt);
-+
+      Exit;
-+
+    end;
-+
+end;
-+
+end.

Diff Legend

-–
+Removed lines
-+
+Added lines
-<
+Changed lines
->
+Changed lines

Comparing ibx/trunk/fbintf/IBUtils.pas (file contents): Revision 314 by tony, Mon Aug 24 09:32:58 2020 UTC vs. Revision 315 by tony, Thu Feb 25 11:56:36 2021 UTC

Diff Legend

Comparing ibx/trunk/fbintf/IBUtils.pas (file contents):
Revision 314 by tony, Mon Aug 24 09:32:58 2020 UTC vs.
Revision 315 by tony, Thu Feb 25 11:56:36 2021 UTC