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 263 by tony, Thu Dec 6 15:55:01 2018 UTC vs.
Revision 359 by tony, Tue Dec 7 09:37:32 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 258 | Line 260 | type
260		sqltPlaceholder,
261		sqltSingleQuotes,
262		sqltDoubleQuotes,
263	+	sqltBackslash,
264		sqltComma,
265		sqltPeriod,
266		sqltEquals,
#	Line 279 | Line 282 | type
282		sqltOpenBracket,
283		sqltCloseBracket,
284		sqltPipe,
285	+	sqltMinus,
286		sqltConcatSymbol,
287		sqltLT,
288		sqltGT,
#	Line 554 | Line 558 | type
558		function TokenFound(var token: TSQLTokens): boolean; virtual;
559		function InternalGetNextToken: TSQLTokens; virtual;
560		procedure Reset; virtual;
561	+	function ReadCharacters(NumOfChars: integer): AnsiString;
562
563		{Token stack}
564		procedure QueueToken(token: TSQLTokens; text:AnsiString); overload;
#	Line 592 | Line 597 | type
597		function TokenFound(var token: TSQLTokens): boolean; override;
598		end;
599
600	+	{ TSQLParamProcessor }
601	+
602	+	TSQLParamProcessor = class(TSQLwithNamedParamsTokeniser)
603	+	private
604	+	const
605	+	sIBXParam = 'IBXParam';  {do not localize}
606	+	private
607	+	FInString: AnsiString;
608	+	FIndex: integer;
609	+	function DoExecute(GenerateParamNames: boolean;
610	+	var slNames: TStrings): AnsiString;
611	+	protected
612	+	function GetChar: AnsiChar; override;
613	+	public
614	+	class function Execute(sSQL: AnsiString; GenerateParamNames: boolean;
615	+	var slNames: TStrings): AnsiString;
616	+	end;
617	+
618	+
619		function Max(n1, n2: Integer): Integer;
620		function Min(n1, n2: Integer): Integer;
621		function RandomString(iLength: Integer): AnsiString;
#	Line 613 | Line 637 | function ParseConnectString(ConnectStrin
637		var PortNo: AnsiString): boolean;
638		function GetProtocol(ConnectString: AnsiString): TProtocolAll;
639
640	+	{$IF declared(TFormatSettings)}
641	+	function ParseDateTimeTZString(aDateTimeStr: Ansistring; var aDateTime: TDateTime;
642	+	var aTimezone: AnsiString; aFormatSettings: TFormatSettings; TimeOnly: boolean=false): boolean; overload;
643	+	{$IFEND}
644	+	function ParseDateTimeTZString(aDateTimeStr: Ansistring; var aDateTime: TDateTime;
645	+	var aTimezone: AnsiString; TimeOnly: boolean=false): boolean;  overload;
646	+	procedure FBDecodeTime(aTime: TDateTime; var Hour, Minute, Second: word; var DeciMillisecond: cardinal);
647	+	function FBEncodeTime(Hour, Minute, Second, DeciMillisecond: cardinal): TDateTime;
648	+	function FBFormatDateTime(fmt: AnsiString; aDateTime: TDateTime): AnsiString;
649	+	function FormatTimeZoneOffset(EffectiveTimeOffsetMins: integer): AnsiString;
650	+	function DecodeTimeZoneOffset(TZOffset: AnsiString; var dstOffset: integer): boolean;
651	+	function StripLeadingZeros(Value: AnsiString): AnsiString;
652	+	function TryStrToNumeric(S: Ansistring; out Value: int64; out scale: integer): boolean;
653	+	function NumericToDouble(aValue: Int64; aScale: integer): double;
654	+
655	+
656		implementation
657
658	<	uses FBMessages
658	>	uses FBMessages, Math
659
660	<	{$IFDEF HASREQEX}
660	>	{$IFDEF FPC}
661		,RegExpr
662	+	{$ELSE}
663	+	{$IF declared(CompilerVersion) and (CompilerVersion >= 22)}
664	+	, RegularExpressions
665	+	{$IFEND}
666		{$ENDIF};
667
668	+
669		function Max(n1, n2: Integer): Integer;
670		begin
671		if (n1 > n2) then
#	Line 716 | Line 761 | end;
761
762		function QuoteIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
763		begin
764	+	Value := TrimRight(Value);
765		if Dialect = 1 then
766	<	Value := AnsiUpperCase(Trim(Value))
766	>	Value := AnsiUpperCase(Value)
767		else
768		Value := '"' + StringReplace (Value, '""', '"', [rfReplaceAll]) + '"';
769		Result := Value;
#	Line 737 | Line 783 | begin
783		Result := true;
784		end;
785
786	+	function SchemeToProtocol(scheme: AnsiString): TProtocolAll;
787	+	begin
788	+	scheme := AnsiUpperCase(scheme);
789	+	if scheme = 'INET' then
790	+	Result := inet
791	+	else
792	+	if scheme = 'INET4' then
793	+	Result := inet4
794	+	else
795	+	if scheme = 'INET6' then
796	+	Result := inet6
797	+	else
798	+	if scheme = 'XNET' then
799	+	Result := xnet
800	+	else
801	+	if scheme = 'WNET' then
802	+	Result := wnet
803	+	end;
804	+
805		{Extracts the Database Connect string from a Create Database Statement}
806
807	<	{$IFDEF HASREQEX}
807	>	{$IF declared(TRegexpr)}
808		function ExtractConnectString(const CreateSQL: AnsiString;
809		var ConnectString: AnsiString): boolean;
810		var RegexObj: TRegExpr;
#	Line 762 | Line 827 | function ParseConnectString(ConnectStrin
827		DatabaseName: AnsiString; var Protocol: TProtocolAll; var PortNo: AnsiString
828		): boolean;
829
765	–	function GetProtocol(scheme: AnsiString): TProtocolAll;
766	–	begin
767	–	scheme := AnsiUpperCase(scheme);
768	–	if scheme = 'INET' then
769	–	Result := inet
770	–	else
771	–	if scheme = 'INET4' then
772	–	Result := inet4
773	–	else
774	–	if scheme = 'INET6' then
775	–	Result := inet6
776	–	else
777	–	if scheme = 'XNET' then
778	–	Result := xnet
779	–	else
780	–	if scheme = 'WNET' then
781	–	Result := wnet
782	–	end;
783	–
830		var RegexObj: TRegExpr;
831		begin
832		ServerName := '';
#	Line 796 | Line 842 | begin
842		if Result then
843		begin
844		{URL type connect string}
845	<	Protocol := GetProtocol(RegexObj.Match[1]);
845	>	Protocol := SchemeToProtocol(RegexObj.Match[1]);
846		ServerName := RegexObj.Match[2];
847		if RegexObj.MatchLen[3] > 0 then
848		PortNo := system.Copy(ConnectString,RegexObj.MatchPos[3]+1,RegexObj.MatchLen[3]-1);
#	Line 811 | Line 857 | begin
857		Result := RegexObj.Exec(ConnectString);
858		if Result then
859		begin
860	<	Protocol := GetProtocol(RegexObj.Match[1]);
860	>	Protocol := SchemeToProtocol(RegexObj.Match[1]);
861		DatabaseName := RegexObj.Match[2];
862		end
863		else
#	Line 860 | Line 906 | begin
906		end;
907		end;
908
909	<	function GetProtocol(ConnectString: AnsiString): TProtocolAll;
910	<	var ServerName,
911	<	DatabaseName: AnsiString;
912	<	PortNo: AnsiString;
909	>	{$ELSE}
910	>	{$IF declared(TRegex)}
911	>	function ExtractConnectString(const CreateSQL: AnsiString;
912	>	var ConnectString: AnsiString): boolean;
913	>	var Regex: TRegEx;
914	>	Match: TMatch;
915		begin
916	<	ParseConnectString(ConnectString,ServerName,DatabaseName,Result,PortNo);
916	>	Regex := TRegEx.Create('^ *CREATE +(DATABASE|SCHEMA) +''(.*)''',[roIgnoreCase]);
917	>	{extact database file spec}
918	>	Match := Regex.Match(CreateSQL);
919	>	Result := Match.Success and (Match.Groups.Count = 3);
920	>	if Result then
921	>	ConnectString := Match.Groups[2].Value;
922		end;
923
924	+	function ParseConnectString(ConnectString: AnsiString; var ServerName,
925	+	DatabaseName: AnsiString; var Protocol: TProtocolAll; var PortNo: AnsiString
926	+	): boolean;
927	+
928	+	var Regex: TRegEx;
929	+	Match: TMatch;
930	+	begin
931	+	ServerName := '';
932	+	DatabaseName := ConnectString;
933	+	PortNo := '';
934	+	Protocol := unknownProtocol;
935	+	{extact database file spec}
936	+	Match := Regex.Match(ConnectString,'^([a-zA-Z46]+)://([a-zA-Z0-9\-\.]*)(|:[0-9a-zA-Z\-]+)/(.*)$',[roIgnoreCase]);
937	+	Result := Match.Success and (Match.Groups.Count = 5);
938	+	if Result then
939	+	begin
940	+	{URL type connect string}
941	+	Protocol := SchemeToProtocol(Match.Groups[1].Value);
942	+	ServerName := Match.Groups[2].Value;
943	+	PortNo := Match.Groups[3].Value;
944	+	DatabaseName := Match.Groups[4].Value;
945	+	if ServerName = '' then
946	+	DatabaseName := '/' + DatabaseName;
947	+	end
948	+	else
949	+	begin
950	+	{URL type connect string - local loop}
951	+	Match := Regex.Match(ConnectString,'^([a-zA-Z46]+)://(.*)$',[roIgnoreCase]);
952	+	Result := Match.Success and (Match.Groups.Count = 3);
953	+	if Result then
954	+	begin
955	+	Protocol := SchemeToProtocol(Match.Groups[1].Value);
956	+	DatabaseName := Match.Groups[2].Value;
957	+	end
958	+	else
959	+	begin
960	+	Match := Regex.Match(ConnectString,'^([a-zA-Z]:\\.*)',[roIgnoreCase]);
961	+	Result := Match.Success;
962	+	if Result then
963	+	Protocol := Local {Windows with leading drive ID}
964	+	else
965	+	begin
966	+	Match := Regex.Match(ConnectString,'^([a-zA-Z0-9\-\.]+)(|/[0-9a-zA-Z\-]+):(.*)$',[roIgnoreCase]);
967	+	Result := Match.Success and (Match.Groups.Count = 4);
968	+	if Result then
969	+	begin
970	+	{Legacy TCP Format}
971	+	ServerName := Match.Groups[1].Value;
972	+	PortNo := Match.Groups[2].Value;
973	+	DatabaseName := Match.Groups[3].Value;
974	+	Protocol := TCP;
975	+	end
976	+	else
977	+	begin
978	+	Match := Regex.Match(ConnectString,'^\\\\([a-zA-Z0-9\-\.]+)(|@[0-9a-zA-Z\-]+)\\(.*)$',[roIgnoreCase]);
979	+	Result := Match.Success and (Match.Groups.Count = 4);
980	+	if Result then
981	+	begin
982	+	{Netbui}
983	+	ServerName := Match.Groups[1].Value;
984	+	PortNo := Match.Groups[2].Value;
985	+	DatabaseName := Match.Groups[3].Value;
986	+	Protocol := NamedPipe
987	+	end
988	+	else
989	+	begin
990	+	Result := true;
991	+	Protocol := Local; {Assume local}
992	+	end;
993	+	end;
994	+	end;
995	+	end;
996	+	end;
997	+	end;
998		{$ELSE}
999	<	{cruder version of above for Delphi. Older versions lack regular expression
999	>	{cruder version of above for Delphi < XE. Older versions lack regular expression
1000		handling.}
1001		function ExtractConnectString(const CreateSQL: AnsiString;
1002		var ConnectString: AnsiString): boolean;
#	Line 890 | Line 1017 | begin
1017		end;
1018		end;
1019
893	–	function GetProtocol(ConnectString: AnsiString): TProtocolAll;
894	–	begin
895	–	Result := unknownProtocol; {not implemented for Delphi}
896	–	end;
897	–
1020		function ParseConnectString(ConnectString: AnsiString;
1021		var ServerName, DatabaseName: AnsiString; var Protocol: TProtocolAll;
1022		var PortNo: AnsiString): boolean;
#	Line 902 | Line 1024 | begin
1024		Result := false;
1025		end;
1026
1027	<	{$ENDIF}
1027	>	{$IFEND}
1028	>	{$IFEND}
1029	>
1030	>	function GetProtocol(ConnectString: AnsiString): TProtocolAll;
1031	>	var ServerName,
1032	>	DatabaseName: AnsiString;
1033	>	PortNo: AnsiString;
1034	>	begin
1035	>	if not ParseConnectString(ConnectString,ServerName,DatabaseName,Result,PortNo) then
1036	>	Result := unknownProtocol;
1037	>	end;
1038
1039		{Make a connect string in format appropriate protocol}
1040
#	Line 918 | Line 1050 | function MakeConnectString(ServerName, D
1050		end;
1051
1052		begin
1053	+	if ServerName = '' then ServerName := 'localhost';
1054		if PortNo <> '' then
1055		case Protocol of
1056		NamedPipe:
#	Line 948 | Line 1081 | end;
1081
1082		function QuoteIdentifierIfNeeded(Dialect: Integer; Value: AnsiString): AnsiString;
1083		begin
1084	+	Value := TrimRight(Value);
1085		if (Dialect = 3) and
1086		(IsReservedWord(Value) or not IsSQLIdentifier(Value) or (AnsiUpperCase(Value) <> Value)) then
1087		Result := '"' + StringReplace (TrimRight(Value), '"', '""', [rfReplaceAll]) + '"'
#	Line 974 | Line 1108 | begin
1108		Result := StringReplace(s,'''','''''',[rfReplaceAll]);
1109		end;
1110
1111	+	{ TSQLParamProcessor }
1112	+
1113	+	function TSQLParamProcessor.DoExecute(GenerateParamNames: boolean;
1114	+	var slNames: TStrings): AnsiString;
1115	+	var token: TSQLTokens;
1116	+	iParamSuffix: Integer;
1117	+	begin
1118	+	Result := '';
1119	+	iParamSuffix := 0;
1120	+
1121	+	while not EOF do
1122	+	begin
1123	+	token := GetNextToken;
1124	+	case token of
1125	+	sqltParam,
1126	+	sqltQuotedParam:
1127	+	begin
1128	+	Result := Result + '?';
1129	+	slNames.Add(TokenText);
1130	+	end;
1131	+
1132	+	sqltPlaceHolder:
1133	+	if GenerateParamNames then
1134	+	begin
1135	+	Inc(iParamSuffix);
1136	+	slNames.AddObject(sIBXParam + IntToStr(iParamSuffix),self); //Note local convention
1137	+	//add pointer to self to mark entry
1138	+	Result := Result + '?';
1139	+	end
1140	+	else
1141	+	IBError(ibxeSQLParseError, [SParamNameExpected]);
1142	+
1143	+	sqltQuotedString:
1144	+	Result := Result + '''' + SQLSafeString(TokenText) + '''';
1145	+
1146	+	sqltIdentifierInDoubleQuotes:
1147	+	Result := Result + '"' + StringReplace(TokenText,'"','""',[rfReplaceAll]) + '"';
1148	+
1149	+	sqltComment:
1150	+	Result := Result + '/*' + TokenText + '*/';
1151	+
1152	+	sqltCommentLine:
1153	+	Result := Result + '--' + TokenText + LineEnding;
1154	+
1155	+	sqltEOL:
1156	+	Result := Result + LineEnding;
1157	+
1158	+	else
1159	+	Result := Result + TokenText;
1160	+	end;
1161	+	end;
1162	+	end;
1163	+
1164	+	function TSQLParamProcessor.GetChar: AnsiChar;
1165	+	begin
1166	+	if FIndex <= Length(FInString) then
1167	+	begin
1168	+	Result := FInString[FIndex];
1169	+	Inc(FIndex);
1170	+	end
1171	+	else
1172	+	Result := #0;
1173	+	end;
1174	+
1175	+	class function TSQLParamProcessor.Execute(sSQL: AnsiString;
1176	+	GenerateParamNames: boolean; var slNames: TStrings): AnsiString;
1177	+	begin
1178	+	with self.Create do
1179	+	try
1180	+	FInString := sSQL;
1181	+	FIndex := 1;
1182	+	Result := DoExecute(GenerateParamNames,slNames);
1183	+	finally
1184	+	Free;
1185	+	end;
1186	+	end;
1187	+
1188		{ TSQLwithNamedParamsTokeniser }
1189
1190		procedure TSQLwithNamedParamsTokeniser.Assign(source: TSQLTokeniser);
#	Line 1042 | Line 1253 | begin
1253		stInBlock:
1254		begin
1255		case token of
1256	<	sqltBegin:
1256	>	sqltBegin,
1257	>	sqltCase:
1258		Inc(FNested);
1259
1260		sqltEnd:
#	Line 1093 | Line 1305 | begin
1305		Result := sqltSingleQuotes;
1306		'/':
1307		Result := sqltForwardSlash;
1308	+	'\':
1309	+	Result := sqltBackslash;
1310		'*':
1311		Result := sqltAsterisk;
1312		'(':
#	Line 1111 | Line 1325 | begin
1325		Result := sqltOpenSquareBracket;
1326		']':
1327		Result := sqltCloseSquareBracket;
1328	+	'-':
1329	+	Result := sqltMinus;
1330		'<':
1331		Result := sqltLT;
1332		'>':
#	Line 1236 | Line 1452 | begin
1452		ResetQueue;
1453		end;
1454
1455	+	function TSQLTokeniser.ReadCharacters(NumOfChars: integer): AnsiString;
1456	+	var i: integer;
1457	+	begin
1458	+	Result := FLastChar;
1459	+	for i := 2 to NumOfChars do
1460	+	begin
1461	+	if GetNext = sqltEOF then break;
1462	+	Result := Result + FLastChar;
1463	+	end;
1464	+	end;
1465	+
1466		function TSQLTokeniser.GetNextToken: TSQLTokens;
1467		begin
1468		if FQueueState = tsRelease then
#	Line 1260 | Line 1487 | begin
1487		GetNext;
1488
1489		repeat
1490	+	if FSkipNext then
1491	+	begin
1492	+	FSkipNext := false;
1493	+	GetNext;
1494	+	end;
1495	+
1496		Result := FNextToken;
1497		C := FLastChar;
1498		GetNext;
1499
1500	<	if FSkipNext then
1500	>	if (Result = sqltCR) and (FNextToken = sqltEOL) then
1501		begin
1502	<	FSkipNext := false;
1503	<	continue;
1502	>	FSkipNext := true;
1503	>	Result := sqltEOL;
1504	>	C := LF;
1505		end;
1506
1507		case FState of
#	Line 1280 | Line 1514 | begin
1514		GetNext;
1515		end
1516		else
1517	+	if Result = sqltEOL then
1518	+	FString := FString + LineEnding
1519	+	else
1520		FString := FString + C;
1521		end;
1522
#	Line 1292 | Line 1529 | begin
1529		Result := sqltCommentLine;
1530		end;
1531
1295	–	sqltCR: {ignore};
1296	–
1532		else
1533		FString := FString + C;
1534		end;
#	Line 1315 | Line 1550 | begin
1550		end;
1551		end
1552		else
1553	+	if Result = sqltEOL then
1554	+	FString := FString + LineEnding
1555	+	else
1556		FString := FString + C;
1557		end;
1558
#	Line 1334 | Line 1572 | begin
1572		end;
1573		end
1574		else
1575	+	if Result = sqltEOL then
1576	+	FString := FString + LineEnding
1577	+	else
1578		FString := FString + C;
1579		end;
1580
#	Line 1383 | Line 1624 | begin
1624		GetNext;
1625		FState := stInComment;
1626		end
1627	<	else
1628	<	if FNextToken = sqltForwardSlash then
1627	>	end;
1628	>
1629	>	sqltMinus:
1630	>	begin
1631	>	if FNextToken = sqltMinus then
1632		begin
1633		FString := '';
1634		GetNext;
#	Line 1405 | Line 1649 | begin
1649		end;
1650
1651		sqltIdentifier:
1652	<	if FNextToken = sqltIdentifier then
1652	>	if FNextToken in [sqltIdentifier,sqltNumberString] then
1653		FState := stInIdentifier;
1654
1655		sqltNumberString:
1656		if FNextToken in [sqltNumberString,sqltPeriod] then
1657		FState := stInNumeric;
1658	+
1659	+	sqltEOL:
1660	+	FString := LineEnding;
1661		end;
1662		end;
1663		end;
#	Line 1420 | Line 1667 | begin
1667		until TokenFound(Result) or EOF;
1668		end;
1669
1670	+	function ParseDateTimeTZString(aDateTimeStr: Ansistring; var aDateTime: TDateTime;
1671	+	var aTimezone: AnsiString; TimeOnly: boolean): boolean;
1672	+	{$IF declared(TFormatSettings)}
1673	+	begin
1674	+	{$IF declared(DefaultFormatSettings)}
1675	+	Result := ParseDateTimeTZString(aDateTimeStr,aDateTime,aTimeZone,DefaultFormatSettings,TimeOnly);
1676	+	{$ELSE}
1677	+	{$IF declared(FormatSettings)}
1678	+	Result := ParseDateTimeTZString(aDateTimeStr,aDateTime,aTimeZone,FormatSettings,TimeOnly);
1679	+	{$IFEND} {$IFEND}
1680	+	end;
1681	+
1682	+	function ParseDateTimeTZString(aDateTimeStr: Ansistring; var aDateTime: TDateTime;
1683	+	var aTimezone: AnsiString; aFormatSettings: TFormatSettings; TimeOnly: boolean=false): boolean;
1684	+	{$IFEND}
1685	+	const
1686	+	whitespacechars = [' ',#$09,#$0A,#$0D];
1687	+	var i,j,l: integer;
1688	+	aTime: TDateTime;
1689	+	DMs: longint;
1690	+	begin
1691	+	Result := false;
1692	+	aTimezone := '';
1693	+	if aDateTimeStr <> '' then
1694	+	{$if declared(TFormatSettings)}
1695	+	with aFormatSettings do
1696	+	{$IFEND}
1697	+	begin
1698	+	aDateTime := 0;
1699	+	{Parse to get time zone info}
1700	+	i := 1;
1701	+	while (i <= length(aDateTimeStr)) and (aDateTimeStr[i] in whitespacechars) do inc(i); {skip white space}
1702	+	if not TimeOnly then
1703	+	begin
1704	+	{decode date}
1705	+	j := i;
1706	+	while (j <= length(aDateTimeStr)) and (aDateTimeStr[j] in ['0'..'9',DateSeparator]) do inc(j);
1707	+	if TryStrToDate(system.copy(aDateTimeStr,i,j-i),aDateTime) then
1708	+	i := j; {otherwise start again i.e. assume time only}
1709	+	end;
1710	+
1711	+	while (i <= length(aDateTimeStr)) and (aDateTimeStr[i] in whitespacechars) do inc(i); {skip white space}
1712	+	{decode time}
1713	+	j := i;
1714	+	while (j <= length(aDateTimeStr)) and (aDateTimeStr[j] in ['0'..'9',TimeSeparator]) do inc(j);
1715	+	Result := TryStrToTime(system.copy(aDateTimeStr,i,j-i),aTime);
1716	+	if not Result then Exit;
1717	+	aDateTime := aDateTime + aTime;
1718	+	i := j;
1719	+
1720	+	{is there a factional second part}
1721	+	if (i <= length(aDateTimeStr)) and (aDateTimeStr[i] = '.') then
1722	+	begin
1723	+	inc(i);
1724	+	inc(j);
1725	+	while (j <= Length(aDateTimeStr)) and (aDateTimeStr[j] in ['0'..'9']) do inc(j);
1726	+	if j > i then
1727	+	begin
1728	+	l := j-i;
1729	+	if l > 4 then l := 4;
1730	+	Result := TryStrToInt(system.copy(aDateTimeStr,i,l),DMs);
1731	+	if not Result then Exit;
1732	+
1733	+	{adjust for number of significant digits}
1734	+	case l of
1735	+	3:   DMs := DMs * 10;
1736	+	2:   DMs := DMs * 100;
1737	+	1:   DMs := DMs * 1000;
1738	+	end;
1739	+	aDateTime := aDateTime + (DMs / (MsecsPerDay*10));
1740	+	end;
1741	+	end;
1742	+	i := j;
1743	+
1744	+	while (i <= length(aDateTimeStr)) and (aDateTimeStr[i] in whitespacechars) do inc(i); {skip white space}
1745	+	{decode time zone}
1746	+	if i < length(aDateTimeStr) then
1747	+	begin
1748	+	j := i;
1749	+	while (j <= length(aDateTimeStr)) and not (aDateTimeStr[j] in whitespacechars) do inc(j);
1750	+	aTimezone := system.copy(aDateTimeStr,i,j-i);
1751	+	end;
1752	+	Result := true;
1753	+	end
1754	+	end;
1755	+
1756	+	{The following is similar to FPC DecodeTime except that the Firebird standard
1757	+	decimilliseconds is used instead of milliseconds for fractional seconds}
1758	+
1759	+	procedure FBDecodeTime(aTime: TDateTime; var Hour, Minute, Second: word;
1760	+	var DeciMillisecond: cardinal);
1761	+	var D : Double;
1762	+	l : cardinal;
1763	+	begin
1764	+	{conversion to decimilliseconds hacked from FPC DateTimeToTimeStamp}
1765	+	D := aTime * MSecsPerDay *10;
1766	+	if D < 0 then
1767	+	D := D - 0.5
1768	+	else
1769	+	D := D + 0.5;
1770	+	{rest hacked from FPC DecodeTIme}
1771	+	l := Abs(Trunc(D)) Mod (MSecsPerDay*10);
1772	+	Hour   := l div 36000000;
1773	+	l := l mod 36000000;
1774	+	Minute := l div 600000;
1775	+	l := l mod 600000;
1776	+	Second := l div 10000;
1777	+	DeciMillisecond := l mod 10000;
1778	+	end;
1779	+
1780	+	{The following is similar to FPC EncodeTime except that the Firebird standard
1781	+	decimilliseconds is used instead of milliseconds for fractional seconds}
1782	+
1783	+	function FBEncodeTime(Hour, Minute, Second, DeciMillisecond: cardinal): TDateTime;
1784	+	const DMSecsPerDay = MSecsPerDay*10;
1785	+	var DMs: cardinal;
1786	+	D: Double;
1787	+	begin
1788	+	if (Hour<24) and (Minute<60) and (Second<60) and (DeciMillisecond<10000) then
1789	+	begin
1790	+	DMs := Hour*36000000+Minute*600000+Second*10000+DeciMillisecond;
1791	+	D := DMs/DMSecsPerDay;
1792	+	Result:=TDateTime(d)
1793	+	end
1794	+	else
1795	+	IBError(ibxeBadTimeSpecification,[Hour, Minute, Second, DeciMillisecond]);
1796	+	end;
1797	+
1798	+	{The following is similar to FPC FormatDateTime except that it additionally
1799	+	allows the timstamp to have a fractional seconds component with a resolution
1800	+	of four decimal places. This is appended to the result for FormatDateTime
1801	+	if the format string contains a "zzzz' string.}
1802	+
1803	+	function FBFormatDateTime(fmt: AnsiString; aDateTime: TDateTime): AnsiString;
1804	+	var Hour, Minute, Second: word;
1805	+	DeciMillisecond: cardinal;
1806	+	begin
1807	+	if Pos('zzzz',fmt) > 0 then
1808	+	begin
1809	+	FBDecodeTime(aDateTime, Hour, Minute, Second, DeciMillisecond);
1810	+	fmt := StringReplace(fmt, 'zzzz', Format('%.4d',[DeciMillisecond]), [rfReplaceAll]);
1811	+	end;
1812	+	Result := FormatDateTime(fmt,aDateTime);
1813	+	end;
1814	+
1815	+	function FormatTimeZoneOffset(EffectiveTimeOffsetMins: integer): AnsiString;
1816	+	begin
1817	+	if EffectiveTimeOffsetMins > 0 then
1818	+	Result := Format('+%.2d:%.2d',[EffectiveTimeOffsetMins div 60,abs(EffectiveTimeOffsetMins mod 60)])
1819	+	else
1820	+	Result := Format('%.2d:%.2d',[EffectiveTimeOffsetMins div 60,abs(EffectiveTimeOffsetMins mod 60)]);
1821	+	end;
1822	+
1823	+	function DecodeTimeZoneOffset(TZOffset: AnsiString; var dstOffset: integer): boolean;
1824	+	var i: integer;
1825	+	begin
1826	+	Result := false;
1827	+	TZOffset := Trim(TZOffset);
1828	+	for i := 1 to Length(TZOffset) do
1829	+	if not (TZOffset[i] in ['0'..'9','-','+',':']) then Exit;
1830	+
1831	+	Result := true;
1832	+	i := Pos(':',TZOffset);
1833	+	if i > 0 then
1834	+	dstOffset := StrToInt(copy(TZOffset,1,i-1)) * 60 + StrToInt(copy(TZOffset,i + 1))
1835	+	else
1836	+	dstOffset := StrToInt(TZOffset) * 60;
1837	+	end;
1838	+
1839	+	function StripLeadingZeros(Value: AnsiString): AnsiString;
1840	+	var i: Integer;
1841	+	start: integer;
1842	+	begin
1843	+	Result := '';
1844	+	start := 1;
1845	+	if (Length(Value) > 0) and (Value[1] = '-') then
1846	+	begin
1847	+	Result := '-';
1848	+	start := 2;
1849	+	end;
1850	+	for i := start to Length(Value) do
1851	+	if Value[i] <> '0' then
1852	+	begin
1853	+	Result := Result + system.copy(Value, i, MaxInt);
1854	+	Exit;
1855	+	end;
1856	+	end;
1857	+
1858	+	function TryStrToNumeric(S: Ansistring; out Value: int64; out scale: integer): boolean;
1859	+	var i: integer;
1860	+	ds: integer;
1861	+	exponent: integer;
1862	+	begin
1863	+	Result := false;
1864	+	ds := 0;
1865	+	exponent := 0;
1866	+	S := Trim(S);
1867	+	Value := 0;
1868	+	scale := 0;
1869	+	if Length(S) = 0 then
1870	+	Exit;
1871	+	{$IF declared(DefaultFormatSettings)}
1872	+	with DefaultFormatSettings do
1873	+	{$ELSE}
1874	+	{$IF declared(FormatSettings)}
1875	+	with FormatSettings do
1876	+	{$IFEND}
1877	+	{$IFEND}
1878	+	begin
1879	+	for i := length(S) downto 1 do
1880	+	begin
1881	+	if S[i] = AnsiChar(DecimalSeparator) then
1882	+	begin
1883	+	if ds <> 0 then Exit; {only one allowed}
1884	+	ds := i;
1885	+	dec(exponent);
1886	+	system.Delete(S,i,1);
1887	+	end
1888	+	else
1889	+	if S[i] in ['+','-'] then
1890	+	begin
1891	+	if (i > 1) and not (S[i-1] in ['e','E']) then
1892	+	Exit; {malformed}
1893	+	end
1894	+	else
1895	+	if S[i] in ['e','E'] then {scientific notation}
1896	+	begin
1897	+	if ds <> 0 then Exit; {not permitted in exponent}
1898	+	if exponent <> 0 then Exit; {only one allowed}
1899	+	exponent := i;
1900	+	end
1901	+	else
1902	+	if not (S[i] in ['0'..'9']) then
1903	+	{Note: ThousandSeparator not allowed by Delphi specs}
1904	+	Exit; {bad character}
1905	+	end;
1906	+
1907	+	if exponent > 0 then
1908	+	begin
1909	+	Result := TryStrToInt(system.copy(S,exponent+1,maxint),Scale);
1910	+	if Result then
1911	+	begin
1912	+	{adjust scale for decimal point}
1913	+	if ds <> 0 then
1914	+	Scale := Scale - (exponent - ds);
1915	+	Result := TryStrToInt64(system.copy(S,1,exponent-1),Value);
1916	+	end;
1917	+	end
1918	+	else
1919	+	begin
1920	+	if ds <> 0 then
1921	+	scale := ds - Length(S) - 1;
1922	+	Result := TryStrToInt64(S,Value);
1923	+	end;
1924	+	end;
1925	+	end;
1926	+
1927	+	function NumericToDouble(aValue: Int64; aScale: integer): double;
1928	+	begin
1929	+	Result := aValue * IntPower(10,aScale)
1930	+	end;
1931	+
1932		end.

Diff Legend

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