ViewVC Help

View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing

root/public/ibx/branches/udr/client/IBUtils.pas

Comparing ibx/trunk/fbintf/IBUtils.pas (file contents):
Revision 270 by tony, Fri Jan 18 11:10:37 2019 UTC vs.
Revision 315 by tony, Thu Feb 25 11:56:36 2021 UTC

#	Line 39 | Line 39 | unit IBUtils;
39		{$IFDEF FPC}
40		{$Mode Delphi}
41		{$codepage UTF8}
42	–	{$define HASREQEX}
42		{$ENDIF}
43
44	+	{ $IF declared(CompilerVersion) and (CompilerVersion >= 22)}
45	+	{ $define HASDELPHIREQEX}
46	+	{ $IFEND}
47
48		interface
49
#	Line 280 | Line 282 | type
282		sqltOpenBracket,
283		sqltCloseBracket,
284		sqltPipe,
285	+	sqltMinus,
286		sqltConcatSymbol,
287		sqltLT,
288		sqltGT,
#	Line 633 | Line 636 | function ParseConnectString(ConnectStrin
636		var PortNo: AnsiString): boolean;
637		function GetProtocol(ConnectString: AnsiString): TProtocolAll;
638
639	+	{$IF declared(TFormatSettings)}
640	+	function ParseDateTimeTZString(aDateTimeStr: Ansistring; var aDateTime: TDateTime;
641	+	var aTimezone: AnsiString; aFormatSettings: TFormatSettings; TimeOnly: boolean=false): boolean; overload;
642	+	{$IFEND}
643	+	function ParseDateTimeTZString(aDateTimeStr: Ansistring; var aDateTime: TDateTime;
644	+	var aTimezone: AnsiString; TimeOnly: boolean=false): boolean;  overload;
645	+	procedure FBDecodeTime(aTime: TDateTime; var Hour, Minute, Second: word; var DeciMillisecond: cardinal);
646	+	function FBEncodeTime(Hour, Minute, Second, DeciMillisecond: cardinal): TDateTime;
647	+	function FBFormatDateTime(fmt: AnsiString; aDateTime: TDateTime): AnsiString;
648	+	function FormatTimeZoneOffset(EffectiveTimeOffsetMins: integer): AnsiString;
649	+	function DecodeTimeZoneOffset(TZOffset: AnsiString; var dstOffset: integer): boolean;
650	+	function StripLeadingZeros(Value: AnsiString): AnsiString;
651	+
652		implementation
653
654		uses FBMessages
655
656	<	{$IFDEF HASREQEX}
656	>	{$IFDEF FPC}
657		,RegExpr
658	+	{$ELSE}
659	+	{$IF declared(CompilerVersion) and (CompilerVersion >= 22)}
660	+	, RegularExpressions
661	+	{$IFEND}
662		{$ENDIF};
663
664	+
665		function Max(n1, n2: Integer): Integer;
666		begin
667		if (n1 > n2) then
#	Line 736 | Line 757 | end;
757
758		function QuoteIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
759		begin
760	+	Value := TrimRight(Value);
761		if Dialect = 1 then
762	<	Value := AnsiUpperCase(Trim(Value))
762	>	Value := AnsiUpperCase(Value)
763		else
764		Value := '"' + StringReplace (Value, '""', '"', [rfReplaceAll]) + '"';
765		Result := Value;
#	Line 757 | Line 779 | begin
779		Result := true;
780		end;
781
782	+	function SchemeToProtocol(scheme: AnsiString): TProtocolAll;
783	+	begin
784	+	scheme := AnsiUpperCase(scheme);
785	+	if scheme = 'INET' then
786	+	Result := inet
787	+	else
788	+	if scheme = 'INET4' then
789	+	Result := inet4
790	+	else
791	+	if scheme = 'INET6' then
792	+	Result := inet6
793	+	else
794	+	if scheme = 'XNET' then
795	+	Result := xnet
796	+	else
797	+	if scheme = 'WNET' then
798	+	Result := wnet
799	+	end;
800	+
801		{Extracts the Database Connect string from a Create Database Statement}
802
803	<	{$IFDEF HASREQEX}
803	>	{$IF declared(TRegexpr)}
804		function ExtractConnectString(const CreateSQL: AnsiString;
805		var ConnectString: AnsiString): boolean;
806		var RegexObj: TRegExpr;
#	Line 782 | Line 823 | function ParseConnectString(ConnectStrin
823		DatabaseName: AnsiString; var Protocol: TProtocolAll; var PortNo: AnsiString
824		): boolean;
825
785	–	function GetProtocol(scheme: AnsiString): TProtocolAll;
786	–	begin
787	–	scheme := AnsiUpperCase(scheme);
788	–	if scheme = 'INET' then
789	–	Result := inet
790	–	else
791	–	if scheme = 'INET4' then
792	–	Result := inet4
793	–	else
794	–	if scheme = 'INET6' then
795	–	Result := inet6
796	–	else
797	–	if scheme = 'XNET' then
798	–	Result := xnet
799	–	else
800	–	if scheme = 'WNET' then
801	–	Result := wnet
802	–	end;
803	–
826		var RegexObj: TRegExpr;
827		begin
828		ServerName := '';
#	Line 816 | Line 838 | begin
838		if Result then
839		begin
840		{URL type connect string}
841	<	Protocol := GetProtocol(RegexObj.Match[1]);
841	>	Protocol := SchemeToProtocol(RegexObj.Match[1]);
842		ServerName := RegexObj.Match[2];
843		if RegexObj.MatchLen[3] > 0 then
844		PortNo := system.Copy(ConnectString,RegexObj.MatchPos[3]+1,RegexObj.MatchLen[3]-1);
#	Line 831 | Line 853 | begin
853		Result := RegexObj.Exec(ConnectString);
854		if Result then
855		begin
856	<	Protocol := GetProtocol(RegexObj.Match[1]);
856	>	Protocol := SchemeToProtocol(RegexObj.Match[1]);
857		DatabaseName := RegexObj.Match[2];
858		end
859		else
#	Line 880 | Line 902 | begin
902		end;
903		end;
904
905	<	function GetProtocol(ConnectString: AnsiString): TProtocolAll;
906	<	var ServerName,
907	<	DatabaseName: AnsiString;
908	<	PortNo: AnsiString;
905	>	{$ELSE}
906	>	{$IF declared(TRegex)}
907	>	function ExtractConnectString(const CreateSQL: AnsiString;
908	>	var ConnectString: AnsiString): boolean;
909	>	var Regex: TRegEx;
910	>	Match: TMatch;
911		begin
912	<	ParseConnectString(ConnectString,ServerName,DatabaseName,Result,PortNo);
912	>	Regex := TRegEx.Create('^ *CREATE +(DATABASE|SCHEMA) +''(.*)''',[roIgnoreCase]);
913	>	{extact database file spec}
914	>	Match := Regex.Match(CreateSQL);
915	>	Result := Match.Success and (Match.Groups.Count = 3);
916	>	if Result then
917	>	ConnectString := Match.Groups[2].Value;
918		end;
919
920	+	function ParseConnectString(ConnectString: AnsiString; var ServerName,
921	+	DatabaseName: AnsiString; var Protocol: TProtocolAll; var PortNo: AnsiString
922	+	): boolean;
923	+
924	+	var Regex: TRegEx;
925	+	Match: TMatch;
926	+	begin
927	+	ServerName := '';
928	+	DatabaseName := ConnectString;
929	+	PortNo := '';
930	+	Protocol := unknownProtocol;
931	+	{extact database file spec}
932	+	Match := Regex.Match(ConnectString,'^([a-zA-Z46]+)://([a-zA-Z0-9\-\.]*)(|:[0-9a-zA-Z\-]+)/(.*)$',[roIgnoreCase]);
933	+	Result := Match.Success and (Match.Groups.Count = 5);
934	+	if Result then
935	+	begin
936	+	{URL type connect string}
937	+	Protocol := SchemeToProtocol(Match.Groups[1].Value);
938	+	ServerName := Match.Groups[2].Value;
939	+	PortNo := Match.Groups[3].Value;
940	+	DatabaseName := Match.Groups[4].Value;
941	+	if ServerName = '' then
942	+	DatabaseName := '/' + DatabaseName;
943	+	end
944	+	else
945	+	begin
946	+	{URL type connect string - local loop}
947	+	Match := Regex.Match(ConnectString,'^([a-zA-Z46]+)://(.*)$',[roIgnoreCase]);
948	+	Result := Match.Success and (Match.Groups.Count = 3);
949	+	if Result then
950	+	begin
951	+	Protocol := SchemeToProtocol(Match.Groups[1].Value);
952	+	DatabaseName := Match.Groups[2].Value;
953	+	end
954	+	else
955	+	begin
956	+	Match := Regex.Match(ConnectString,'^([a-zA-Z]:\\.*)',[roIgnoreCase]);
957	+	Result := Match.Success;
958	+	if Result then
959	+	Protocol := Local {Windows with leading drive ID}
960	+	else
961	+	begin
962	+	Match := Regex.Match(ConnectString,'^([a-zA-Z0-9\-\.]+)(|/[0-9a-zA-Z\-]+):(.*)$',[roIgnoreCase]);
963	+	Result := Match.Success and (Match.Groups.Count = 4);
964	+	if Result then
965	+	begin
966	+	{Legacy TCP Format}
967	+	ServerName := Match.Groups[1].Value;
968	+	PortNo := Match.Groups[2].Value;
969	+	DatabaseName := Match.Groups[3].Value;
970	+	Protocol := TCP;
971	+	end
972	+	else
973	+	begin
974	+	Match := Regex.Match(ConnectString,'^\\\\([a-zA-Z0-9\-\.]+)(|@[0-9a-zA-Z\-]+)\\(.*)$',[roIgnoreCase]);
975	+	Result := Match.Success and (Match.Groups.Count = 4);
976	+	if Result then
977	+	begin
978	+	{Netbui}
979	+	ServerName := Match.Groups[1].Value;
980	+	PortNo := Match.Groups[2].Value;
981	+	DatabaseName := Match.Groups[3].Value;
982	+	Protocol := NamedPipe
983	+	end
984	+	else
985	+	begin
986	+	Result := true;
987	+	Protocol := Local; {Assume local}
988	+	end;
989	+	end;
990	+	end;
991	+	end;
992	+	end;
993	+	end;
994		{$ELSE}
995	<	{cruder version of above for Delphi. Older versions lack regular expression
995	>	{cruder version of above for Delphi < XE. Older versions lack regular expression
996		handling.}
997		function ExtractConnectString(const CreateSQL: AnsiString;
998		var ConnectString: AnsiString): boolean;
#	Line 910 | Line 1013 | begin
1013		end;
1014		end;
1015
913	–	function GetProtocol(ConnectString: AnsiString): TProtocolAll;
914	–	begin
915	–	Result := unknownProtocol; {not implemented for Delphi}
916	–	end;
917	–
1016		function ParseConnectString(ConnectString: AnsiString;
1017		var ServerName, DatabaseName: AnsiString; var Protocol: TProtocolAll;
1018		var PortNo: AnsiString): boolean;
#	Line 922 | Line 1020 | begin
1020		Result := false;
1021		end;
1022
1023	<	{$ENDIF}
1023	>	{$IFEND}
1024	>	{$IFEND}
1025	>
1026	>	function GetProtocol(ConnectString: AnsiString): TProtocolAll;
1027	>	var ServerName,
1028	>	DatabaseName: AnsiString;
1029	>	PortNo: AnsiString;
1030	>	begin
1031	>	if not ParseConnectString(ConnectString,ServerName,DatabaseName,Result,PortNo) then
1032	>	Result := unknownProtocol;
1033	>	end;
1034
1035		{Make a connect string in format appropriate protocol}
1036
#	Line 938 | Line 1046 | function MakeConnectString(ServerName, D
1046		end;
1047
1048		begin
1049	+	if ServerName = '' then ServerName := 'localhost';
1050		if PortNo <> '' then
1051		case Protocol of
1052		NamedPipe:
#	Line 968 | Line 1077 | end;
1077
1078		function QuoteIdentifierIfNeeded(Dialect: Integer; Value: AnsiString): AnsiString;
1079		begin
1080	+	Value := TrimRight(Value);
1081		if (Dialect = 3) and
1082		(IsReservedWord(Value) or not IsSQLIdentifier(Value) or (AnsiUpperCase(Value) <> Value)) then
1083		Result := '"' + StringReplace (TrimRight(Value), '"', '""', [rfReplaceAll]) + '"'
#	Line 1036 | Line 1146 | begin
1146		Result := Result + '/*' + TokenText + '*/';
1147
1148		sqltCommentLine:
1149	<	Result := Result + '//' + TokenText + LineEnding;
1149	>	Result := Result + '--' + TokenText + LineEnding;
1150
1151		sqltEOL:
1152		Result := Result + LineEnding;
#	Line 1210 | Line 1320 | begin
1320		Result := sqltOpenSquareBracket;
1321		']':
1322		Result := sqltCloseSquareBracket;
1323	+	'-':
1324	+	Result := sqltMinus;
1325		'<':
1326		Result := sqltLT;
1327		'>':
#	Line 1482 | Line 1594 | begin
1594		GetNext;
1595		FState := stInComment;
1596		end
1597	<	else
1598	<	if FNextToken = sqltForwardSlash then
1597	>	end;
1598	>
1599	>	sqltMinus:
1600	>	begin
1601	>	if FNextToken = sqltMinus then
1602		begin
1603		FString := '';
1604		GetNext;
#	Line 1519 | Line 1634 | begin
1634		until TokenFound(Result) or EOF;
1635		end;
1636
1637	+	function ParseDateTimeTZString(aDateTimeStr: Ansistring; var aDateTime: TDateTime;
1638	+	var aTimezone: AnsiString; TimeOnly: boolean): boolean;
1639	+	{$IF declared(TFormatSettings)}
1640	+	begin
1641	+	{$IF declared(DefaultFormatSettings)}
1642	+	Result := ParseDateTimeTZString(aDateTimeStr,aDateTime,aTimeZone,DefaultFormatSettings,TimeOnly);
1643	+	{$ELSE}
1644	+	{$IF declared(FormatSettings)}
1645	+	Result := ParseDateTimeTZString(aDateTimeStr,aDateTime,aTimeZone,FormatSettings,TimeOnly);
1646	+	{$IFEND} {$IFEND}
1647	+	end;
1648	+
1649	+	function ParseDateTimeTZString(aDateTimeStr: Ansistring; var aDateTime: TDateTime;
1650	+	var aTimezone: AnsiString; aFormatSettings: TFormatSettings; TimeOnly: boolean=false): boolean;
1651	+	{$IFEND}
1652	+	const
1653	+	whitespacechars = [' ',#$09,#$0A,#$0D];
1654	+	var i,j,l: integer;
1655	+	aTime: TDateTime;
1656	+	DMs: longint;
1657	+	begin
1658	+	Result := false;
1659	+	aTimezone := '';
1660	+	if aDateTimeStr <> '' then
1661	+	{$if declared(TFormatSettings)}
1662	+	with aFormatSettings do
1663	+	{$IFEND}
1664	+	begin
1665	+	aDateTime := 0;
1666	+	{Parse to get time zone info}
1667	+	i := 1;
1668	+	while (i <= length(aDateTimeStr)) and (aDateTimeStr[i] in whitespacechars) do inc(i); {skip white space}
1669	+	if not TimeOnly then
1670	+	begin
1671	+	{decode date}
1672	+	j := i;
1673	+	while (j <= length(aDateTimeStr)) and (aDateTimeStr[j] in ['0'..'9',DateSeparator]) do inc(j);
1674	+	if TryStrToDate(system.copy(aDateTimeStr,i,j-i),aDateTime) then
1675	+	i := j; {otherwise start again i.e. assume time only}
1676	+	end;
1677	+
1678	+	while (i <= length(aDateTimeStr)) and (aDateTimeStr[i] in whitespacechars) do inc(i); {skip white space}
1679	+	{decode time}
1680	+	j := i;
1681	+	while (j <= length(aDateTimeStr)) and (aDateTimeStr[j] in ['0'..'9',TimeSeparator]) do inc(j);
1682	+	Result := TryStrToTime(system.copy(aDateTimeStr,i,j-i),aTime);
1683	+	if not Result then Exit;
1684	+	aDateTime := aDateTime + aTime;
1685	+	i := j;
1686	+
1687	+	{is there a factional second part}
1688	+	if (i <= length(aDateTimeStr)) and (aDateTimeStr[i] = '.') then
1689	+	begin
1690	+	inc(i);
1691	+	inc(j);
1692	+	while (j <= Length(aDateTimeStr)) and (aDateTimeStr[j] in ['0'..'9']) do inc(j);
1693	+	if j > i then
1694	+	begin
1695	+	l := j-i;
1696	+	if l > 4 then l := 4;
1697	+	Result := TryStrToInt(system.copy(aDateTimeStr,i,l),DMs);
1698	+	if not Result then Exit;
1699	+
1700	+	{adjust for number of significant digits}
1701	+	case l of
1702	+	3:   DMs := DMs * 10;
1703	+	2:   DMs := DMs * 100;
1704	+	1:   DMs := DMs * 1000;
1705	+	end;
1706	+	aDateTime := aDateTime + (DMs / (MsecsPerDay*10));
1707	+	end;
1708	+	end;
1709	+	i := j;
1710	+
1711	+	while (i <= length(aDateTimeStr)) and (aDateTimeStr[i] in whitespacechars) do inc(i); {skip white space}
1712	+	{decode time zone}
1713	+	if i < length(aDateTimeStr) then
1714	+	begin
1715	+	j := i;
1716	+	while (j <= length(aDateTimeStr)) and not (aDateTimeStr[j] in whitespacechars) do inc(j);
1717	+	aTimezone := system.copy(aDateTimeStr,i,j-i);
1718	+	end;
1719	+	Result := true;
1720	+	end
1721	+	end;
1722	+
1723	+	{The following is similar to FPC DecodeTime except that the Firebird standard
1724	+	decimilliseconds is used instead of milliseconds for fractional seconds}
1725	+
1726	+	procedure FBDecodeTime(aTime: TDateTime; var Hour, Minute, Second: word;
1727	+	var DeciMillisecond: cardinal);
1728	+	var D : Double;
1729	+	l : cardinal;
1730	+	begin
1731	+	{conversion to decimilliseconds hacked from FPC DateTimeToTimeStamp}
1732	+	D := aTime * MSecsPerDay *10;
1733	+	if D < 0 then
1734	+	D := D - 0.5
1735	+	else
1736	+	D := D + 0.5;
1737	+	{rest hacked from FPC DecodeTIme}
1738	+	l := Abs(Trunc(D)) Mod (MSecsPerDay*10);
1739	+	Hour   := l div 36000000;
1740	+	l := l mod 36000000;
1741	+	Minute := l div 600000;
1742	+	l := l mod 600000;
1743	+	Second := l div 10000;
1744	+	DeciMillisecond := l mod 10000;
1745	+	end;
1746	+
1747	+	{The following is similar to FPC EncodeTime except that the Firebird standard
1748	+	decimilliseconds is used instead of milliseconds for fractional seconds}
1749	+
1750	+	function FBEncodeTime(Hour, Minute, Second, DeciMillisecond: cardinal): TDateTime;
1751	+	const DMSecsPerDay = MSecsPerDay*10;
1752	+	var DMs: cardinal;
1753	+	D: Double;
1754	+	begin
1755	+	if (Hour<24) and (Minute<60) and (Second<60) and (DeciMillisecond<10000) then
1756	+	begin
1757	+	DMs := Hour*36000000+Minute*600000+Second*10000+DeciMillisecond;
1758	+	D := DMs/DMSecsPerDay;
1759	+	Result:=TDateTime(d)
1760	+	end
1761	+	else
1762	+	IBError(ibxeBadTimeSpecification,[Hour, Minute, Second, DeciMillisecond]);
1763	+	end;
1764	+
1765	+	{The following is similar to FPC FormatDateTime except that it additionally
1766	+	allows the timstamp to have a fractional seconds component with a resolution
1767	+	of four decimal places. This is appended to the result for FormatDateTime
1768	+	if the format string contains a "zzzz' string.}
1769	+
1770	+	function FBFormatDateTime(fmt: AnsiString; aDateTime: TDateTime): AnsiString;
1771	+	var Hour, Minute, Second: word;
1772	+	DeciMillisecond: cardinal;
1773	+	begin
1774	+	if Pos('zzzz',fmt) > 0 then
1775	+	begin
1776	+	FBDecodeTime(aDateTime, Hour, Minute, Second, DeciMillisecond);
1777	+	fmt := StringReplace(fmt, 'zzzz', Format('%.4d',[DeciMillisecond]), [rfReplaceAll]);
1778	+	end;
1779	+	Result := FormatDateTime(fmt,aDateTime);
1780	+	end;
1781	+
1782	+	function FormatTimeZoneOffset(EffectiveTimeOffsetMins: integer): AnsiString;
1783	+	begin
1784	+	if EffectiveTimeOffsetMins > 0 then
1785	+	Result := Format('+%.2d:%.2d',[EffectiveTimeOffsetMins div 60,abs(EffectiveTimeOffsetMins mod 60)])
1786	+	else
1787	+	Result := Format('%.2d:%.2d',[EffectiveTimeOffsetMins div 60,abs(EffectiveTimeOffsetMins mod 60)]);
1788	+	end;
1789	+
1790	+	function DecodeTimeZoneOffset(TZOffset: AnsiString; var dstOffset: integer): boolean;
1791	+	var i: integer;
1792	+	begin
1793	+	Result := false;
1794	+	TZOffset := Trim(TZOffset);
1795	+	for i := 1 to Length(TZOffset) do
1796	+	if not (TZOffset[i] in ['0'..'9','-','+',':']) then Exit;
1797	+
1798	+	Result := true;
1799	+	i := Pos(':',TZOffset);
1800	+	if i > 0 then
1801	+	dstOffset := StrToInt(copy(TZOffset,1,i-1)) * 60 + StrToInt(copy(TZOffset,i + 1))
1802	+	else
1803	+	dstOffset := StrToInt(TZOffset) * 60;
1804	+	end;
1805	+
1806	+	function StripLeadingZeros(Value: AnsiString): AnsiString;
1807	+	var i: Integer;
1808	+	start: integer;
1809	+	begin
1810	+	Result := '';
1811	+	start := 1;
1812	+	if (Length(Value) > 0) and (Value[1] = '-') then
1813	+	begin
1814	+	Result := '-';
1815	+	start := 2;
1816	+	end;
1817	+	for i := start to Length(Value) do
1818	+	if Value[i] <> '0' then
1819	+	begin
1820	+	Result := Result + system.copy(Value, i, MaxInt);
1821	+	Exit;
1822	+	end;
1823	+	end;
1824	+
1825		end.

Diff Legend

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