--- ibx/trunk/fbintf/IBUtils.pas 2020/08/24 09:32:58 311 +++ ibx/trunk/fbintf/IBUtils.pas 2021/02/25 11:56:36 315 @@ -39,9 +39,11 @@ unit IBUtils; {$IFDEF FPC} {$Mode Delphi} {$codepage UTF8} -{$define HASREQEX} {$ENDIF} +{ $IF declared(CompilerVersion) and (CompilerVersion >= 22)} +{ $define HASDELPHIREQEX} +{ $IFEND} interface @@ -634,14 +636,32 @@ function ParseConnectString(ConnectStrin 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 @@ -759,9 +779,28 @@ begin 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; @@ -784,25 +823,6 @@ function ParseConnectString(ConnectStrin 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 := ''; @@ -818,7 +838,7 @@ begin 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); @@ -833,7 +853,7 @@ begin Result := RegexObj.Exec(ConnectString); if Result then begin - Protocol := GetProtocol(RegexObj.Match[1]); + Protocol := SchemeToProtocol(RegexObj.Match[1]); DatabaseName := RegexObj.Match[2]; end else @@ -882,16 +902,97 @@ begin 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; @@ -912,11 +1013,6 @@ begin 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; @@ -924,7 +1020,17 @@ begin 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} @@ -940,6 +1046,7 @@ function MakeConnectString(ServerName, D end; begin + if ServerName = '' then ServerName := 'localhost'; if PortNo <> '' then case Protocol of NamedPipe: @@ -1527,4 +1634,192 @@ begin 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 + 3: DMs := DMs * 10; + 2: DMs := DMs * 100; + 1: 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.