diff --git a/src/Runtime/XSharp.Core/Language/Generic.resx b/src/Runtime/XSharp.Core/Language/Generic.resx index b2cb96f518..b15d5862c3 100644 --- a/src/Runtime/XSharp.Core/Language/Generic.resx +++ b/src/Runtime/XSharp.Core/Language/Generic.resx @@ -2831,19 +2831,11 @@ Keysort on {0} is not supported for collections ordered by {1} - - - - - - - - - - - - + + XML Parse error: {0} + + + Unable to infer XML schema. + - - \ No newline at end of file diff --git a/src/Runtime/XSharp.Data/FoxPro/Enums.prg b/src/Runtime/XSharp.Data/FoxPro/Enums.prg index d797a7995b..a678899c5e 100644 --- a/src/Runtime/XSharp.Data/FoxPro/Enums.prg +++ b/src/Runtime/XSharp.Data/FoxPro/Enums.prg @@ -43,4 +43,6 @@ ENUM XSharp.VFPErrors MEMBER VFP_INVALID_PARAMETER MEMBER VFP_FOR_CONDITION_MUST_BE_LOGIC MEMBER VFP_INVALID_DATE_SETTING + MEMBER VFP_XML_PARSE_ERROR + MEMBER VFP_XML_NOSCHEMA END ENUM diff --git a/src/Runtime/XSharp.VFP.Tests/XSharp.VFP.Tests.xsproj b/src/Runtime/XSharp.VFP.Tests/XSharp.VFP.Tests.xsproj index 06ab88e297..55f3f9c0ea 100644 --- a/src/Runtime/XSharp.VFP.Tests/XSharp.VFP.Tests.xsproj +++ b/src/Runtime/XSharp.VFP.Tests/XSharp.VFP.Tests.xsproj @@ -123,6 +123,7 @@ + diff --git a/src/Runtime/XSharp.VFP.Tests/XmlToCursorTests.prg b/src/Runtime/XSharp.VFP.Tests/XmlToCursorTests.prg new file mode 100644 index 0000000000..ab36183d1a --- /dev/null +++ b/src/Runtime/XSharp.VFP.Tests/XmlToCursorTests.prg @@ -0,0 +1,554 @@ +// +// Copyright (c) XSharp B.V. All Rights Reserved. +// Licensed under the Apache License, Version 2.0. +// See License.txt in the project root for license information. +// +USING System +USING System.IO +USING XUnit + +BEGIN NAMESPACE XSharp.VFP.Tests + + CLASS XmlToCursorTests + + STATIC CONSTRUCTOR + XSharp.RuntimeState.Dialect := XSharpDialect.FoxPro + END CONSTRUCTOR + + #region helpers + PRIVATE METHOD Stru(cAlias AS STRING) AS STRING + LOCAL aStru AS ARRAY + LOCAL cResult AS STRING + LOCAL n AS DWORD + DbSelectArea(cAlias) + aStru := DbStruct() + cResult := "" + FOR n := 1 UPTO ALen(aStru) + cResult += Upper(AllTrim(aStru[n, 1])) + " " + Upper(aStru[n, 2]) + ; + "(" + AllTrim(Str(aStru[n, 3])) + "," + AllTrim(Str(aStru[n, 4])) + ") " + NEXT + RETURN AllTrim(cResult) + END METHOD + + PRIVATE METHOD Close(cAlias AS STRING) AS VOID + IF Used(cAlias) + DbCloseArea(cAlias) + ENDIF + END METHOD + + PRIVATE METHOD Doc(cRows AS STRING) AS STRING + RETURN "" + cRows + "" + END METHOD + + PRIVATE METHOD OneCol(cValues AS STRING) AS STRING + LOCAL cResult AS STRING + cResult := "" + FOREACH cValue AS STRING IN cValues:Split(c'|') + cResult += "" + cValue + "" + NEXT + RETURN SELF:Doc(cResult) + END METHOD + + PRIVATE METHOD Infer(cValues AS STRING) AS STRING + LOCAL cAlias AS STRING + LOCAL cResult AS STRING + cAlias := "inf" + Right(Guid.NewGuid():ToString("N"), 6) + XmlToCursor(SELF:OneCol(cValues), cAlias, 0) + cResult := SELF:Stru(cAlias) + SELF:Close(cAlias) + RETURN cResult + END METHOD + + // The XML VFP 9 itself produces for a cursor holding one row of each + // interesting type plus one empty row. It is embedded verbatim rather than + // regenerated with CursorToXml(): our own writer emits every column as + // xs:string, so a round trip through it would prove nothing about the + // types XmlToCursor() is supposed to rebuild. + PRIVATE METHOD TypesXml(lSchema AS LOGIC) AS STRING + IF lSchema + RETURN SELF:VfpXmlWithSchema() + ENDIF + RETURN SELF:VfpXmlNoSchema() + END METHOD + + // Captured verbatim from VFP 9: one row of each type plus one empty row, with the inline schema + PRIVATE METHOD VfpXmlWithSchema() AS STRING + LOCAL oSb AS System.Text.StringBuilder + oSb := System.Text.StringBuilder{} + oSb:AppendLine("") + oSb:AppendLine("") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" hello") + oSb:AppendLine(" 123.45") + oSb:AppendLine(" true") + oSb:AppendLine(" 2024-01-15") + oSb:AppendLine(" 2024-01-15T10:30:45") + oSb:AppendLine(" 99.9999") + oSb:AppendLine(" 42") + oSb:AppendLine(" memo text") + oSb:AppendLine(" 3.142") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" 0.00") + oSb:AppendLine(" false") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" 0.0000") + oSb:AppendLine(" 0") + oSb:AppendLine(" ") + oSb:AppendLine(" 0.000") + oSb:AppendLine(" ") + oSb:AppendLine("") + RETURN oSb:ToString() + END METHOD + + // The same cursor, written by VFP 9 without a schema + PRIVATE METHOD VfpXmlNoSchema() AS STRING + LOCAL oSb AS System.Text.StringBuilder + oSb := System.Text.StringBuilder{} + oSb:AppendLine("") + oSb:AppendLine("") + oSb:AppendLine(" ") + oSb:AppendLine(" hello") + oSb:AppendLine(" 123.45") + oSb:AppendLine(" true") + oSb:AppendLine(" 2024-01-15") + oSb:AppendLine(" 2024-01-15T10:30:45") + oSb:AppendLine(" 99.9999") + oSb:AppendLine(" 42") + oSb:AppendLine(" memo text") + oSb:AppendLine(" 3.142") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" 0.00") + oSb:AppendLine(" false") + oSb:AppendLine(" ") + oSb:AppendLine(" ") + oSb:AppendLine(" 0.0000") + oSb:AppendLine(" 0") + oSb:AppendLine(" ") + oSb:AppendLine(" 0.000") + oSb:AppendLine(" ") + oSb:AppendLine("") + RETURN oSb:ToString() + END METHOD + #endregion + + #region round trip through the inline schema + + [Fact, Trait("Category", "XmlToCursor")]; + METHOD SchemaRebuildsEveryFieldType AS VOID + VAR cXml := SELF:TypesXml(TRUE) + SELF:Close("dst") + Assert.Equal(2, (INT) XmlToCursor(cXml, "dst", 0)) + Assert.Equal("CCHAR C(10,0) NNUM N(8,2) LLOG L(1,0) DDATE D(8,0) TTIME T(8,0) " + ; + "YCUR N(20,4) IINT I(4,0) MMEMO M(4,0) BDBL B(8,0)", SELF:Stru("dst")) + SELF:Close("dst") + END METHOD + + [Fact, Trait("Category", "XmlToCursor")]; + METHOD Flag2048RebuildsCurrency AS VOID + VAR cXml := SELF:TypesXml(TRUE) + SELF:Close("dst") + XmlToCursor(cXml, "dst", 2048) + DbSelectArea("dst") + Assert.Equal("Y", DbFieldInfo(DBS_TYPE, FieldPos("ycur"))) + SELF:Close("dst") + END METHOD + + [Fact, Trait("Category", "XmlToCursor")]; + METHOD SchemaRoundTripKeepsValues AS VOID + VAR cXml := SELF:TypesXml(TRUE) + SELF:Close("dst") + XmlToCursor(cXml, "dst", 0) + DbSelectArea("dst") + DbGoTop() + Assert.Equal("hello", AllTrim(dst->cchar)) + Assert.Equal(123.45, (REAL8) dst->nnum, 2) + Assert.True(dst->llog) + Assert.Equal(2024, (INT) Year(dst->ddate)) + Assert.Equal(42, (INT) dst->iint) + Assert.Equal("memo text", AllTrim(dst->mmemo)) + SELF:Close("dst") + END METHOD + + [Fact, Trait("Category", "XmlToCursor")]; + METHOD SchemaHandlesTheEmptyDateVfpWrites AS VOID + VAR cXml := SELF:TypesXml(TRUE) + SELF:Close("dst") + Assert.Equal(2, (INT) XmlToCursor(cXml, "dst", 0)) + DbSelectArea("dst") + DbGoBottom() + Assert.True(Empty(dst->ddate)) + SELF:Close("dst") + END METHOD + + #endregion + #region inference when there is no schema + + [Fact, Trait("Category", "XmlToCursor")]; + METHOD NoSchemaInfersFromTheValues AS VOID + VAR cXml := SELF:TypesXml(FALSE) + SELF:Close("dst") + Assert.Equal(2, (INT) XmlToCursor(cXml, "dst", 0)) + Assert.Equal("CCHAR C(5,0) NNUM N(6,2) LLOG L(1,0) DDATE C(10,0) TTIME C(19,0) " + ; + "YCUR N(7,4) IINT N(2,0) MMEMO C(9,0) BDBL N(5,3)", SELF:Stru("dst")) + SELF:Close("dst") + END METHOD + + [Fact, Trait("Category", "XmlToCursor")]; + METHOD WidthIsTheLongestValueSeen AS VOID + Assert.Equal("V C(10,0)", SELF:Infer("abc|abcdefghij")) + Assert.Equal("V N(7,3)", SELF:Infer("1|333.456")) + END METHOD + + [Fact, Trait("Category", "XmlToCursor")]; + METHOD BooleanValuesBecomeLogical AS VOID + Assert.Equal("V L(1,0)", SELF:Infer("true|false")) + Assert.Equal("V L(1,0)", SELF:Infer("TRUE|FALSE")) + Assert.Equal("V L(1,0)", SELF:Infer("1|0")) + Assert.Equal("V L(1,0)", SELF:Infer("1|true")) + Assert.Equal("V C(4,0)", SELF:Infer("true|xyz")) + Assert.Equal("V N(1,0)", SELF:Infer("1|2")) + END METHOD + + [Fact, Trait("Category", "XmlToCursor")]; + METHOD DatesAndDateTimesAreInferred AS VOID + Assert.Equal("V D(8,0)", SELF:Infer("2024-01-15|2024-02-20")) + Assert.Equal("V T(8,0)", SELF:Infer("2024-01-15T10:30:45")) + Assert.Equal("V C(19,0)", SELF:Infer("2024-01-15|2024-01-15T10:30:45")) + END METHOD + + [Fact, Trait("Category", "XmlToCursor")]; + METHOD LongTextBecomesMemo AS VOID + Assert.Equal("V C(254,0)", SELF:Infer(Replicate("y", 254))) + Assert.Equal("V M(4,0)", SELF:Infer(Replicate("z", 255))) + END METHOD + + [Fact, Trait("Category", "XmlToCursor")]; + METHOD EmptyColumnBecomesCharacterOfOne AS VOID + Assert.Equal("V C(1,0)", SELF:Infer("|")) + END METHOD + + #endregion + + #region inference quirks reproduced from VFP on purpose + + [Fact, Trait("Category", "XmlToCursor")]; + METHOD SignedNumbersAreInferredAsCharacter AS VOID + Assert.Equal("V C(2,0)", SELF:Infer("-5")) + Assert.Equal("V C(2,0)", SELF:Infer("+5")) + Assert.Equal("V C(7,0)", SELF:Infer("-123.45")) + Assert.Equal("V C(4,0)", SELF:Infer("-5|1234")) + Assert.Equal("V N(4,0)", SELF:Infer("1234")) + END METHOD + + [Fact, Trait("Category", "XmlToCursor")]; + METHOD ExponentsAreInferredAsCharacter AS VOID + Assert.Equal("V C(3,0)", SELF:Infer("1e3|25")) + END METHOD + + [Fact, Trait("Category", "XmlToCursor")]; + METHOD LeadingAndTrailingDotsAreStillNumeric AS VOID + Assert.Equal("V N(2,1)", SELF:Infer(".5|.7")) + Assert.Equal("V N(2,0)", SELF:Infer("5.|7.")) + END METHOD + + [Fact, Trait("Category", "XmlToCursor")]; + METHOD AnEmptyValueRulesOutLogicalButNotNumeric AS VOID + Assert.Equal("V N(1,0)", SELF:Infer("1|0|")) + Assert.Equal("V C(4,0)", SELF:Infer("true|")) + Assert.Equal("V N(4,1)", SELF:Infer("12.5|")) + END METHOD + + [Fact, Trait("Category", "XmlToCursor")]; + METHOD AnEmptyValueRulesOutDate AS VOID + Assert.Equal("V C(10,0)", SELF:Infer("2024-01-15|")) + END METHOD + + [Fact, Trait("Category", "XmlToCursor")]; + METHOD InferredWidthCanOverflow AS VOID + Assert.Equal("V N(5,1)", SELF:Infer("99999|0.1")) + END METHOD + + [Fact, Trait("Category", "XmlToCursor")]; + METHOD LeadingZerosAreLost AS VOID + Assert.Equal("V N(3,0)", SELF:Infer("007|12")) + Assert.Equal("V C(3,0)", SELF:Infer("007|ab")) + END METHOD + + #endregion + #region cursor name, work area and return value + + [Fact, Trait("Category", "XmlToCursor")]; + METHOD MissingNameCreatesXmlResult AS VOID + SELF:Close("XMLRESULT") + Assert.Equal(1, (INT) XmlToCursor(SELF:Doc("1"))) + Assert.True(Used("XMLRESULT")) + Assert.Equal("XMLRESULT", Alias()) + SELF:Close("XMLRESULT") + END METHOD + + [Fact, Trait("Category", "XmlToCursor")]; + METHOD EmptyNameCreatesXmlResult AS VOID + SELF:Close("XMLRESULT") + XmlToCursor(SELF:Doc("1"), "", 0) + Assert.True(Used("XMLRESULT")) + SELF:Close("XMLRESULT") + END METHOD + + [Fact, Trait("Category", "XmlToCursor")]; + METHOD TheNewCursorBecomesTheCurrentArea AS VOID + SELF:Close("parked") + SELF:Close("landed") + CREATE CURSOR parked (zz C(3)) + DbSelectArea("parked") + XmlToCursor(SELF:Doc("1"), "landed", 0) + Assert.Equal("LANDED", Alias()) + Assert.Equal(1, (INT) RecNo()) + SELF:Close("landed") + SELF:Close("parked") + END METHOD + + [Fact, Trait("Category", "XmlToCursor")]; + METHOD AnExistingCursorIsReplaced AS VOID + SELF:Close("reuse") + CREATE CURSOR reuse (zz C(3)) + INSERT INTO reuse VALUES ("aaa") + XmlToCursor(SELF:Doc("1"), "reuse", 0) + // "1" on its own is Logical, not Numeric: it is inside {0,1,true,false} + Assert.Equal("A L(1,0)", SELF:Stru("reuse")) + SELF:Close("reuse") + END METHOD + + [Fact, Trait("Category", "XmlToCursor")]; + METHOD EmptyDocumentCreatesNoCursor AS VOID + SELF:Close("nothing") + SELF:Close("norecords") + // the return is RecCount() of the current area, so it has to be a known one + CREATE CURSOR norecords (zz C(1)) + DbSelectArea("norecords") + Assert.Equal(0, (INT) XmlToCursor("", "nothing", 0)) + Assert.False(Used("nothing")) + SELF:Close("norecords") + END METHOD + + [Fact, Trait("Category", "XmlToCursor")]; + METHOD ReturnIsRecCountOfTheCurrentArea AS VOID + SELF:Close("target") + SELF:Close("parked") + CREATE CURSOR target (cchar C(20)) + INSERT INTO target VALUES ("pre1") + INSERT INTO target VALUES ("pre2") + CREATE CURSOR parked (zz C(3)) + DbSelectArea("parked") + Assert.Equal(0, (INT) XmlToCursor(SELF:Doc("ab"), "target", 8192)) + Assert.Equal("PARKED", Alias()) + Assert.Equal(4, (INT) RecCount("target")) + SELF:Close("target") + SELF:Close("parked") + END METHOD + + #endregion + + #region append mode + + [Fact, Trait("Category", "XmlToCursor")]; + METHOD AppendAddsRowsAndKeepsTheStructure AS VOID + SELF:Close("tgt") + CREATE CURSOR tgt (cchar C(20), nnum N(10,2), zzz C(5)) + INSERT INTO tgt VALUES ("preexisting", 9.99, "keep") + DbSelectArea("tgt") + Assert.Equal(3, (INT) XmlToCursor(SELF:TypesXml(TRUE), "tgt", 8192)) + Assert.Equal("CCHAR C(20,0) NNUM N(10,2) ZZZ C(5,0)", SELF:Stru("tgt")) + DbSelectArea("tgt") + DbGoTop() + Assert.Equal("preexisting", AllTrim(tgt->cchar)) + DbSkip(1) + Assert.Equal("hello", AllTrim(tgt->cchar)) + Assert.Equal(123.45, (REAL8) tgt->nnum, 2) + Assert.Equal("", AllTrim(tgt->zzz)) + SELF:Close("tgt") + END METHOD + + [Fact, Trait("Category", "XmlToCursor")]; + METHOD AppendMatchesFieldNamesCaseInsensitively AS VOID + SELF:Close("tgt6") + CREATE CURSOR tgt6 (myfield C(5)) + DbSelectArea("tgt6") + XmlToCursor(SELF:Doc("up"), "tgt6", 8192) + DbSelectArea("tgt6") + DbGoTop() + Assert.Equal("up", AllTrim(tgt6->myfield)) + SELF:Close("tgt6") + END METHOD + + [Fact, Trait("Category", "XmlToCursor")]; + METHOD AppendWithNoMatchingColumnStillAddsBlankRows AS VOID + SELF:Close("tgt2") + CREATE CURSOR tgt2 (qqq C(5)) + DbSelectArea("tgt2") + Assert.Equal(2, (INT) XmlToCursor(SELF:Doc("12"), "tgt2", 8192)) + Assert.Equal(2, (INT) RecCount("tgt2")) + SELF:Close("tgt2") + END METHOD + + [Fact, Trait("Category", "XmlToCursor")]; + METHOD AppendCoercesToTheTargetFieldType AS VOID + SELF:Close("tgt4") + CREATE CURSOR tgt4 (ddate D, llog L, nnum N(6,2), cchar C(4)) + DbSelectArea("tgt4") + XmlToCursor(SELF:Doc("2024-01-15true" + ; + "12.3456abcdefgh"), "tgt4", 8192) + DbSelectArea("tgt4") + DbGoTop() + Assert.Equal(2024, (INT) Year(tgt4->ddate)) + Assert.Equal(1, (INT) Month(tgt4->ddate)) + Assert.True(tgt4->llog) + Assert.Equal(12.35, (REAL8) tgt4->nnum, 2) // rounded to the field scale + Assert.Equal("abcd", tgt4->cchar) // truncated to the field width + SELF:Close("tgt4") + END METHOD + + [Fact, Trait("Category", "XmlToCursor")]; + METHOD AppendWithEmptyNameUsesTheCurrentArea AS VOID + SELF:Close("cur3") + CREATE CURSOR cur3 (cchar C(20)) + DbSelectArea("cur3") + Assert.Equal(2, (INT) XmlToCursor(SELF:Doc("ab"), "", 8192)) + Assert.Equal(2, (INT) RecCount("cur3")) + SELF:Close("cur3") + END METHOD + + #endregion + + #region source flavours + + [Fact, Trait("Category", "XmlToCursor")]; + METHOD Flag512ReadsFromAFile AS VOID + VAR cFile := Path.Combine(Path.GetTempPath(), "X2CIN_" + Guid.NewGuid():ToString("N") + ".xml") + File.WriteAllText(cFile, SELF:TypesXml(TRUE)) + SELF:Close("fromfile") + Assert.Equal(2, (INT) XmlToCursor(cFile, "fromfile", 512)) + SELF:Close("fromfile") + File.Delete(cFile) + END METHOD + + [Fact, Trait("Category", "XmlToCursor")]; + METHOD AttributeFormatIsRead AS VOID + SELF:Close("attr") + Assert.Equal(1, (INT) XmlToCursor(SELF:Doc(""), "attr", 0)) + Assert.Equal("CC C(2,0) NN N(3,1)", SELF:Stru("attr")) + SELF:Close("attr") + END METHOD + + [Fact, Trait("Category", "XmlToCursor")]; + METHOD AttributesAreDroppedWhenTheRowAlsoHasElements AS VOID + SELF:Close("mix") + XmlToCursor(SELF:Doc("x"), "mix", 0) + Assert.Equal("B C(1,0)", SELF:Stru("mix")) + SELF:Close("mix") + END METHOD + + [Fact, Trait("Category", "XmlToCursor")]; + METHOD Flag65536CreatesVarChar AS VOID + SELF:Close("vc") + XmlToCursor(SELF:TypesXml(TRUE), "vc", 65536) + DbSelectArea("vc") + Assert.Equal("V", DbFieldInfo(DBS_TYPE, FieldPos("cchar"))) + SELF:Close("vc") + END METHOD + + [Fact, Trait("Category", "XmlToCursor")]; + METHOD EntitiesAndAccentsSurvive AS VOID + SELF:Close("ent") + XmlToCursor(SELF:Doc("a&bniño"), "ent", 0) + DbSelectArea("ent") + DbGoTop() + Assert.Equal("a&b", AllTrim(ent->a)) + Assert.Equal("ni" + Chr(241) + "o", AllTrim(ent->b)) + SELF:Close("ent") + END METHOD + + #endregion + + #region errors + + [Fact, Trait("Category", "XmlToCursor")]; + METHOD InvalidXmlThrows AS VOID + Assert.ThrowsAny({ => XmlToCursor("this is not xml", "bad1", 0) }) + END METHOD + + [Fact, Trait("Category", "XmlToCursor")]; + METHOD MissingFileThrows AS VOID + VAR cFile := Path.Combine(Path.GetTempPath(), "X2CMISSING_" + Guid.NewGuid():ToString("N") + ".xml") + Assert.ThrowsAny({ => XmlToCursor(cFile, "bad2", 512) }) + END METHOD + + [Fact, Trait("Category", "XmlToCursor")]; + METHOD DocumentWithoutARowLevelThrows AS VOID + Assert.ThrowsAny({ => XmlToCursor("12", "bad3", 0) }) + END METHOD + + [Fact, Trait("Category", "XmlToCursor")]; + METHOD AppendToAnUnknownAliasThrows AS VOID + Assert.ThrowsAny({ => XmlToCursor(SELF:Doc("1"), "nosuchalias", 8192) }) + END METHOD + + #endregion + + END CLASS + +END NAMESPACE diff --git a/src/Runtime/XSharp.VFP/Cursors/Xml.prg b/src/Runtime/XSharp.VFP/Cursors/Xml.prg index dd79c6006f..1518894f5a 100644 --- a/src/Runtime/XSharp.VFP/Cursors/Xml.prg +++ b/src/Runtime/XSharp.VFP/Cursors/Xml.prg @@ -8,16 +8,13 @@ using System using System.IO using System.Data using System.Text +using System.Collections.Generic using System.Xml using XSharp.RDD +using XSharp.RDD.Enums using XSharp.RDD.Support using System.Globalization -// nFlags values for CursorToXml(). Only the ones implemented are listed here: -DEFINE C2X_FLAG_CONTINUOUS := 1 // Produce unformatted XML as one continuous string -DEFINE C2X_FLAG_TOFILE := 512 // Send the output to the file name in cOutput - - /// [FoxProFunction("CURSORTOXML", FoxFunctionCategory.General, FoxEngine.RuntimeCore, FoxFunctionStatus.Partial, FoxCriticality.Medium)]; FUNCTION CursorToXML (uArea, cOutput, nOutputFormat, nFlags, nRecords, cSchemaName, cSchemaLocation, cNameSpace ) AS USUAL CLIPPER @@ -56,12 +53,12 @@ FUNCTION CursorToXML (uArea, cOutput, nOutputFormat, nFlags, nRecords, cSchemaNa var nOldArea := RuntimeState.CurrentWorkarea RuntimeState.CurrentWorkarea := nArea try - cXml := __FoxCursorToXmlString(nRecs, cSchema, cNs, nFlagsInt) + cXml := FoxXml.WriteToString(nRecs, cSchema, cNs, nFlagsInt) finally RuntimeState.CurrentWorkarea := nOldArea end try - if _AND(nFlagsInt, C2X_FLAG_TOFILE) != 0 + if _AND(nFlagsInt, FoxXml.C2X_FLAG_TOFILE) != 0 File.WriteAllText(cTarget, cXml, UTF8Encoding{FALSE}) return (long) FileInfo{cTarget}:Length endif @@ -70,153 +67,702 @@ FUNCTION CursorToXML (uArea, cOutput, nOutputFormat, nFlags, nRecords, cSchemaNa XSharp.MemVar.Put(cTarget, cXml) RETURN Encoding.UTF8:GetByteCount(cXml) -/// Builds the XML for the cursor in the current work area. -INTERNAL FUNCTION __FoxCursorToXmlString(nRecs as long, cSchema as string, cNs as string, nFlags as long) as string - local nMode as XmlWriteMode - var oData := __FoxCursorDataTable(nRecs) +/// +[FoxProFunction("XMLTOCURSOR", FoxFunctionCategory.General, FoxEngine.RuntimeCore, FoxFunctionStatus.Partial, FoxCriticality.High)]; +FUNCTION XmlToCursor( eExpression, cCursorName, nFlags ) AS USUAL CLIPPER + local cAlias as string + local nFlagsInt as long - // VFP always names the root element VFPData, whatever the output format is - var oSet := DataSet{"VFPData"} - if !String.IsNullOrEmpty(cNs) - oSet:Namespace := cNs + if !IsString(eExpression) + throw Error.VoDbError(EG_ARG, EDB_PARAM, __FUNCTION__, nameof(eExpression), 1, {eExpression}) endif - oSet:Tables:Add(oData) - - // cSchemaName: "" = no schema, "1" = inline schema, anything else = external .xsd - nMode := XmlWriteMode.IgnoreSchema - if cSchema == "1" - nMode := XmlWriteMode.WriteSchema - elseif !String.IsNullOrEmpty(cSchema) - var cSchemaFile := cSchema - if String.IsNullOrEmpty(Path.GetExtension(cSchemaFile)) - cSchemaFile += ".xsd" - endif - oSet:WriteXmlSchema(cSchemaFile) + + nFlagsInt := (long) iif(IsNumeric(nFlags), nFlags, 0) + cAlias := (string) iif(IsString(cCursorName), cCursorName, "") + + var oDoc := FoxXml.Load((string) eExpression, _AND(nFlagsInt, FoxXml.X2C_FLAG_FROMFILE) != 0) + var oSchema := FoxXml.SchemaTypes(oDoc) + var oTable := FoxXml.ReadRows(oDoc) + + if oTable != NULL + if _AND(nFlagsInt, FoxXml.X2C_FLAG_APPEND) != 0 + FoxXml.AppendRows(oTable, cAlias) + else + FoxXml.BuildCursor(oTable, oSchema, ; + iif(String.IsNullOrEmpty(cAlias), FoxXml.X2C_DEFAULTCURSOR, cAlias), nFlagsInt) + endif endif - var oSettings := XmlWriterSettings{} - oSettings:Indent := _AND(nFlags, C2X_FLAG_CONTINUOUS) == 0 - oSettings:Encoding := UTF8Encoding{FALSE} + return FoxXml.CurrentRecCount() + +/// One field of the cursor XmlToCursor() is about to build. +INTERNAL CLASS FoxXmlColumn + INTERNAL Name AS STRING + INTERNAL FldType AS STRING + INTERNAL Len AS LONG + INTERNAL Dec AS LONG + INTERNAL Flags AS LONG + /// Set for a decimal(19,4), which nFlags 2048 turns into Currency. + INTERNAL IsCurrency AS LOGIC + + INTERNAL CONSTRUCTOR(cName as string, cType as string, nLen as long, nDec as long) + SELF:Name := cName + SELF:FldType := cType + SELF:Len := nLen + SELF:Dec := nDec + SELF:Flags := 0 + SELF:IsCurrency := FALSE + END CONSTRUCTOR + + /// The schema dictionary is reused, so the flags are applied to a copy. + INTERNAL METHOD Clone() as FoxXmlColumn + var oResult := FoxXmlColumn{SELF:Name, SELF:FldType, SELF:Len, SELF:Dec} + oResult:Flags := SELF:Flags + oResult:IsCurrency := SELF:IsCurrency + return oResult + END METHOD +END CLASS + +INTERNAL STATIC CLASS FoxXml + // nFlags values for CursorToXml(). Only the ones implemented are listed here: + INTERNAL CONST C2X_FLAG_CONTINUOUS := 1 AS LONG // Produce unformatted XML as one continuous string + INTERNAL CONST C2X_FLAG_TOFILE := 512 AS LONG // Send the output to the file name in cOutput + + // nFlags values for XmlToCursor(). Only the ones implemented are listed here: + INTERNAL CONST X2C_FLAG_FROMFILE := 512 AS LONG // The first parameter is a file name, not XML text + INTERNAL CONST X2C_FLAG_NOCPTRANS := 1024 AS LONG // Character and Memo fields get the NOCPTRANS flag + INTERNAL CONST X2C_FLAG_CURRENCY := 2048 AS LONG // decimal(19,4) becomes Currency instead of Numeric + INTERNAL CONST X2C_FLAG_APPEND := 8192 AS LONG // cCursorName names an existing cursor to append to + INTERNAL CONST X2C_FLAG_VARCHAR := 65536 AS LONG // Character fields become VarChar + + // VFP names the cursor XMLRESULT when the caller does not name one + INTERNAL CONST X2C_DEFAULTCURSOR := "XMLRESULT" AS STRING + // Anything wider than this becomes a Memo instead of a Character field + INTERNAL CONST X2C_MAXCHARLEN := 254 AS LONG + INTERNAL CONST X2C_XSDNAMESPACE := "http://www.w3.org/2001/XMLSchema" AS STRING + + // Internal functions + /// Builds the XML for the cursor in the current work area. + INTERNAL STATIC METHOD WriteToString(nRecs as long, cSchema as string, cNs as string, nFlags as long) as string + local nMode as XmlWriteMode + + var oData := CursorToTable(nRecs) + + // VFP always names the root element VFPData, whatever the output format is + var oSet := DataSet{"VFPData"} + if !String.IsNullOrEmpty(cNs) + oSet:Namespace := cNs + endif + oSet:Tables:Add(oData) + + // cSchemaName: "" = no schema, "1" = inline schema, anything else = external .xsd + nMode := XmlWriteMode.IgnoreSchema + if cSchema == "1" + nMode := XmlWriteMode.WriteSchema + elseif !String.IsNullOrEmpty(cSchema) + var cSchemaFile := cSchema + if String.IsNullOrEmpty(Path.GetExtension(cSchemaFile)) + cSchemaFile += ".xsd" + endif + oSet:WriteXmlSchema(cSchemaFile) + endif - var oStream := MemoryStream{} - var oWriter := XmlWriter.Create(oStream, oSettings) - oSet:WriteXml(oWriter, nMode) - oWriter:Flush() - oWriter:Close() + var oSettings := XmlWriterSettings{} + oSettings:Indent := _AND(nFlags, FoxXml.C2X_FLAG_CONTINUOUS) == 0 + oSettings:Encoding := UTF8Encoding{FALSE} - return Encoding.UTF8:GetString(oStream:ToArray()) + var oStream := MemoryStream{} + var oWriter := XmlWriter.Create(oStream, oSettings) + oSet:WriteXml(oWriter, nMode) + oWriter:Flush() + oWriter:Close() + return Encoding.UTF8:GetString(oStream:ToArray()) -/// Reads the cursor in the current work area into a table of preformatted values. -INTERNAL FUNCTION __FoxCursorDataTable(nRecs as long) as DataTable - local oResult := NULL as object - if !CoreDb.Info(DBI_RDD_OBJECT, REF oResult) - throw Error.VoDbError(EG_NOTABLE, EDB_NOTABLE, __FUNCTION__, "uArea", 1, {}) - endif - var oRDD := (IRdd) oResult - var nFields := oRDD:FieldCount - var oTable := DataTable{oRDD:Alias:ToLower()} - - // Every column is written as text: that is the only way to reproduce the - // field width and decimal scale that VFP puts in the XML. - local aTypes as string[] - local aDecs as long[] - aTypes := string[]{nFields} - aDecs := long[]{nFields} - for var nI := 1 to nFields - var cName := ((string) oRDD:FieldInfo(nI, DBS_ALIAS, NULL)):ToLower() - aTypes[nI] := ((string) oRDD:FieldInfo(nI, DBS_TYPE, NULL)):ToUpper() - aDecs[nI] := (long) oRDD:FieldInfo(nI, DBS_DEC, NULL) - oTable:Columns:Add(cName, typeof(string)) - next - - // The record order and any active filter are honoured because we simply - // walk the work area from top to bottom. - var nWritten := 0 - oRDD:GoTop() - do while !oRDD:EoF - local oRow as object[] - oRow := object[]{nFields} + /// Reads the cursor in the current work area into a table of preformatted values. + INTERNAL STATIC METHOD CursorToTable(nRecs as long) as DataTable + local oResult := NULL as object + + if !CoreDb.Info(DBI_RDD_OBJECT, REF oResult) + throw Error.VoDbError(EG_NOTABLE, EDB_NOTABLE, __FUNCTION__, "uArea", 1, {}) + endif + var oRDD := (IRdd) oResult + var nFields := oRDD:FieldCount + var oTable := DataTable{oRDD:Alias:ToLower()} + + // Every column is written as text: that is the only way to reproduce the + // field width and decimal scale that VFP puts in the XML. + local aTypes as string[] + local aDecs as long[] + aTypes := string[]{nFields} + aDecs := long[]{nFields} for var nI := 1 to nFields - oRow[nI] := __FoxXmlValue(oRDD:GetValue(nI), aTypes[nI], aDecs[nI]) + var cName := ((string) oRDD:FieldInfo(nI, DBS_ALIAS, NULL)):ToLower() + aTypes[nI] := ((string) oRDD:FieldInfo(nI, DBS_TYPE, NULL)):ToUpper() + aDecs[nI] := (long) oRDD:FieldInfo(nI, DBS_DEC, NULL) + oTable:Columns:Add(cName, typeof(string)) next - oTable:Rows:Add(oRow) - nWritten++ - // VFP does not restore the record pointer: it ends up at EOF when every - // record was written, or on the last record written when nRecords limits it - if nRecs > 0 .AND. nWritten >= nRecs - exit - endif - oRDD:Skip(1) - enddo - oTable:AcceptChanges() - return oTable - - -/// Formats one field value the way the VFP CursorToXml() output does. -INTERNAL FUNCTION __FoxXmlValue(oValue as object, cType as string, nDec as long) as object - local r8 as real8 - - // VFP leaves the element out altogether for a NULL field - if oValue == NULL .OR. oValue == DBNull.Value - return DBNull.Value - endif - - switch cType - case "L" - return iif((logic) oValue, "true", "false") - case "D" - if oValue IS XSharp.IDate VAR dVal - // an empty date becomes an empty element, not a missing one - return iif(dVal:Month == 0, "", dVal:Value:ToString("yyyy-MM-dd", CultureInfo.InvariantCulture)) + // The record order and any active filter are honoured because we simply + // walk the work area from top to bottom. + var nWritten := 0 + oRDD:GoTop() + do while !oRDD:EoF + local oRow as object[] + oRow := object[]{nFields} + for var nI := 1 to nFields + oRow[nI] := FormatValue(oRDD:GetValue(nI), aTypes[nI], aDecs[nI]) + next + oTable:Rows:Add(oRow) + nWritten++ + // VFP does not restore the record pointer: it ends up at EOF when every + // record was written, or on the last record written when nRecords limits it + if nRecs > 0 .AND. nWritten >= nRecs + exit + endif + oRDD:Skip(1) + enddo + oTable:AcceptChanges() + return oTable + + + /// Formats one field value the way the VFP CursorToXml() output does. + INTERNAL STATIC METHOD FormatValue(oValue as object, cType as string, nDec as long) as object + local r8 as real8 + + // VFP leaves the element out altogether for a NULL field + if oValue == NULL .OR. oValue == DBNull.Value + return DBNull.Value endif - return oValue:ToString() - case "T" - local dtVal as DateTime - if oValue IS XSharp.IDate VAR dtSrc - dtVal := dtSrc:Value - else - dtVal := Convert.ToDateTime(oValue, CultureInfo.InvariantCulture) - endif - // "s" gives the ISO layout VFP uses: 2024-01-15T10:30:45 - return iif(dtVal:Year <= 1, "", dtVal:ToString("s", CultureInfo.InvariantCulture)) - - case "Y" - // VFP always writes currency with 4 decimals - r8 := __FoxXmlNumber(oValue) - return r8:ToString("F4", CultureInfo.InvariantCulture) - - case "I" - r8 := __FoxXmlNumber(oValue) - return r8:ToString("F0", CultureInfo.InvariantCulture) - - case "N" - case "F" - r8 := __FoxXmlNumber(oValue) - return r8:ToString("F" + nDec:ToString(), CultureInfo.InvariantCulture) - - case "B" - // The RDD does not report the scale of Double fields, so I cannot - // reproduce the fixed decimals VFP writes; emit the full value instead - // of truncating it. - r8 := __FoxXmlNumber(oValue) - if nDec > 0 + switch cType + case "L" + return iif((logic) oValue, "true", "false") + + case "D" + if oValue IS XSharp.IDate VAR dVal + // an empty date becomes an empty element, not a missing one + return iif(dVal:Month == 0, "", dVal:Value:ToString("yyyy-MM-dd", CultureInfo.InvariantCulture)) + endif + return oValue:ToString() + + case "T" + local dtVal as DateTime + if oValue IS XSharp.IDate VAR dtSrc + dtVal := dtSrc:Value + else + dtVal := Convert.ToDateTime(oValue, CultureInfo.InvariantCulture) + endif + // "s" gives the ISO layout VFP uses: 2024-01-15T10:30:45 + return iif(dtVal:Year <= 1, "", dtVal:ToString("s", CultureInfo.InvariantCulture)) + + case "Y" + // VFP always writes currency with 4 decimals + r8 := ToDouble(oValue) + return r8:ToString("F4", CultureInfo.InvariantCulture) + + case "I" + r8 := ToDouble(oValue) + return r8:ToString("F0", CultureInfo.InvariantCulture) + + case "N" + case "F" + r8 := ToDouble(oValue) return r8:ToString("F" + nDec:ToString(), CultureInfo.InvariantCulture) + + case "B" + // The RDD does not report the scale of Double fields, so I cannot + // reproduce the fixed decimals VFP writes; emit the full value instead + // of truncating it. + r8 := ToDouble(oValue) + if nDec > 0 + return r8:ToString("F" + nDec:ToString(), CultureInfo.InvariantCulture) + endif + return r8:ToString("R", CultureInfo.InvariantCulture) + end switch + + // C, M, V and anything else: VFP strips the padding blanks + return oValue:ToString():TrimEnd() + + + /// Unwraps the numeric types the RDD layer hands out. + INTERNAL STATIC METHOD ToDouble(oValue as object) as real8 + if oValue IS XSharp.IFloat VAR fVal + return fVal:Value + endif + return Convert.ToDouble(oValue, CultureInfo.InvariantCulture) + + /// Parses the XML once, from a string or from a file. + INTERNAL STATIC METHOD Load(cSource as string, lFromFile as logic) as XmlDocument + var oDoc := XmlDocument{} + oDoc:XmlResolver := NULL + try + if lFromFile + if !File.Exists(cSource) + // VFP reports a file it cannot open as a parse error, not a file error + throw FileNotFoundException{cSource} + endif + oDoc:Load(cSource) + else + oDoc:LoadXml(cSource) + endif + catch e as Exception + throw Exception{ __VfpStr(VFPErrors.VFP_XML_PARSE_ERROR, e:Message) } + end try + return oDoc + + /// Reads the rows as a table of strings, whatever the document declares. + INTERNAL STATIC METHOD ReadRows(oDoc as XmlDocument) as DataTable + var oSet := DataSet{} + oSet:Locale := CultureInfo.InvariantCulture + try + using var oReader := XmlNodeReader{oDoc} + oSet:ReadXml(oReader, XmlReadMode.InferSchema) + catch e as Exception + throw Exception{ __VfpStr(VFPErrors.VFP_XML_PARSE_ERROR, e:Message) } + end try + + if oSet:Tables:Count == 0 + return NULL + endif + + if oSet:DataSetName == "NewDataSet" + throw Exception{ __VfpStr(VFPErrors.VFP_XML_NOSCHEMA) } endif - return r8:ToString("R", CultureInfo.InvariantCulture) - end switch - // C, M, V and anything else: VFP strips the padding blanks - return oValue:ToString():TrimEnd() + return oSet:Tables[0] + /// The columns that carry data, in document order. + INTERNAL STATIC METHOD DataColumns(oTable as DataTable) as List + local lHasElements := FALSE as logic + var oResult := List{} -/// Unwraps the numeric types the RDD layer hands out. -INTERNAL FUNCTION __FoxXmlNumber(oValue as object) as real8 - if oValue IS XSharp.IFloat VAR fVal - return fVal:Value - endif - return Convert.ToDouble(oValue, CultureInfo.InvariantCulture) + foreach oColumn as DataColumn in oTable:Columns + if oColumn:ColumnMapping == MappingType.Element + lHasElements := TRUE + exit + endif + next + + foreach oColumn as DataColumn in oTable:Columns + switch oColumn:ColumnMapping + case MappingType.Element + oResult:Add(oColumn) + case MappingType.Attribute + if !lHasElements + oResult:Add(oColumn) + endif + end switch + next + return oResult + + /// + /// Maps element name to the field its inline xsd type calls for. The schema is + /// read out of the document text rather than through XmlSchemaSet:Compile(), + /// because the object model only exposes the facets we need through the + /// post-schema-compilation infoset. + /// + INTERNAL STATIC METHOD SchemaTypes(oDoc as XmlDocument) as Dictionary + var oResult := Dictionary{StringComparer.OrdinalIgnoreCase} + + var oNs := XmlNamespaceManager{oDoc:NameTable} + oNs:AddNamespace("xsd", FoxXml.X2C_XSDNAMESPACE) + var oNodes := oDoc:SelectNodes("//xsd:schema//xsd:element[@name]", oNs) + if oNodes == NULL + return oResult + endif + foreach oNode as XmlNode in oNodes + if oNode is XmlElement var oElement + // the dataset and the row element carry a complexType: not fields + if oElement:SelectSingleNode("xsd:complexType", oNs) == NULL + SchemaField(oElement, oNs, oResult) + endif + endif + next + return oResult + + /// Reads one field declaration out of the inline schema. + INTERNAL STATIC METHOD SchemaField(oElement as XmlElement, oNs as XmlNamespaceManager, ; + oResult as Dictionary) as void + local cBase as string + local nMaxLen := 0 as long + local nTotal := 0 as long + local nFraction := 0 as long + + var cName := oElement:GetAttribute("name") + if String.IsNullOrEmpty(cName) .or. oResult:ContainsKey(cName) + return + endif + + cBase := oElement:GetAttribute("type") + if oElement:SelectSingleNode("xsd:simpleType/xsd:restriction", oNs) is XmlElement var oRestriction + cBase := oRestriction:GetAttribute("base") + foreach oFacet as XmlNode in oRestriction:ChildNodes + if oFacet is XmlElement var oFacetElement + var nValue := FacetValue(oFacetElement:GetAttribute("value")) + switch oFacetElement:LocalName + case "maxLength" + nMaxLen := nValue + case "totalDigits" + nTotal := nValue + case "fractionDigits" + nFraction := nValue + end switch + endif + next + endif + + oResult:Add(cName, ColumnFromType(cName, LocalName(cBase), nMaxLen, nTotal, nFraction)) + return + + /// Drops the namespace prefix from an xsd type name: "xsd:decimal" gives "decimal". + INTERNAL STATIC METHOD LocalName(cType as string) as string + if String.IsNullOrEmpty(cType) + return "" + endif + var nPos := cType:IndexOf(c':') + if nPos < 0 + return cType + endif + return cType:Substring(nPos + 1) + + /// Turns one xsd type into the field VFP 9 builds from it. + INTERNAL STATIC METHOD ColumnFromType(cName as string, cBase as string, ; + nMaxLen as long, nTotal as long, nFraction as long) as FoxXmlColumn + + switch cBase + case "boolean" + return FoxXmlColumn{cName, "L", 1, 0} + case "date" + return FoxXmlColumn{cName, "D", 8, 0} + case "dateTime" + return FoxXmlColumn{cName, "T", 8, 0} + case "int" + case "integer" + case "short" + case "long" + case "unsignedInt" + case "unsignedShort" + return FoxXmlColumn{cName, "I", 4, 0} + case "double" + case "float" + return FoxXmlColumn{cName, "B", 8, 8} + case "decimal" + var oDecimal := FoxXmlColumn{cName, "N", nTotal + iif(nFraction > 0, 1, 0), nFraction} + oDecimal:IsCurrency := (nTotal == 19 .and. nFraction == 4) + return oDecimal + end switch + + if nMaxLen <= 0 .or. nMaxLen > FoxXml.X2C_MAXCHARLEN + return FoxXmlColumn{cName, "M", 4, 0} + endif + return FoxXmlColumn{cName, "C", nMaxLen, 0} + + /// Reads one xsd facet, which the schema object model hands over as a string. + INTERNAL STATIC METHOD FacetValue(cValue as string) as long + local nResult as long + if Int32.TryParse(cValue, NumberStyles.Integer, CultureInfo.InvariantCulture, out nResult) + return nResult + endif + return 0 + + /// Infers the field for one column from its values, the way VFP 9 does. + INTERNAL STATIC METHOD InferColumn(cName as string, oTable as DataTable, oColumn as DataColumn) as FoxXmlColumn + local lHasEmpty := FALSE as logic + local lAnyValue := FALSE as logic + local lAllBool := TRUE as logic + local lAllNum := TRUE as logic + local lAllDate := TRUE as logic + local lAllTime := TRUE as logic + local nMaxLen := 0 as long + local nMaxDec := 0 as long + + foreach oRow as DataRow in oTable:Rows + var cValue := CellText(oRow, oColumn) + if cValue:Length == 0 + lHasEmpty := TRUE + loop + endif + lAnyValue := TRUE + nMaxLen := Math.Max(nMaxLen, cValue:Length) + if !IsBool(cValue) + lAllBool := FALSE + endif + var nDec := Decimals(cValue) + if nDec < 0 + lAllNum := FALSE + else + nMaxDec := Math.Max(nMaxDec, nDec) + endif + if !IsDate(cValue) + lAllDate := FALSE + endif + if !IsDateTime(cValue) + lAllTime := FALSE + endif + next + + do case + case !lAnyValue + return FoxXmlColumn{cName, "C", 1, 0} + case lAllBool .and. !lHasEmpty + return FoxXmlColumn{cName, "L", 1, 0} + case lAllNum + return FoxXmlColumn{cName, "N", nMaxLen, nMaxDec} + case lAllDate .and. !lHasEmpty + return FoxXmlColumn{cName, "D", 8, 0} + case lAllTime .and. !lHasEmpty + return FoxXmlColumn{cName, "T", 8, 0} + case nMaxLen > FoxXml.X2C_MAXCHARLEN + return FoxXmlColumn{cName, "M", 4, 0} + endcase + return FoxXmlColumn{cName, "C", nMaxLen, 0} + + /// The values VFP reads back as Logical. + INTERNAL STATIC METHOD IsBool(cValue as string) as logic + switch cValue:ToLowerInvariant() + case "0" + case "1" + case "true" + case "false" + return TRUE + end switch + return FALSE + + /// + /// Number of decimals when the value is one VFP infers as Numeric, -1 otherwise. + /// A sign is deliberately rejected: VFP infers Character for "-5" and for "+5", + /// and Character for "1e3" as well. That is almost certainly a bug in the parser + /// VFP infers with, but migrated code sees the resulting structure, so it is + /// reproduced here. A leading or trailing dot is accepted, matching VFP: ".5" + /// gives N(2,1) and "5." gives N(2,0). + /// + INTERNAL STATIC METHOD Decimals(cValue as string) as long + local nDot := -1 as long + local lAnyDigit := FALSE as logic + + for var nI := 0 upto cValue:Length - 1 + var cChar := cValue[nI] + if cChar == c'.' + if nDot >= 0 + return -1 + endif + nDot := nI + elseif Char.IsDigit(cChar) + lAnyDigit := TRUE + else + return -1 + endif + next + if !lAnyDigit + return -1 + endif + if nDot < 0 + return 0 + endif + return cValue:Length - nDot - 1 + + /// True when the value is an xsd date, the only date layout VFP infers. + INTERNAL STATIC METHOD IsDate(cValue as string) as logic + local dValue as DateTime + return DateTime.TryParseExact(cValue, "yyyy-MM-dd", CultureInfo.InvariantCulture, ; + DateTimeStyles.None, out dValue) + + /// True when the value is an xsd dateTime. + INTERNAL STATIC METHOD IsDateTime(cValue as string) as logic + local dValue as DateTime + local aFormats as string[] + aFormats := {"yyyy-MM-ddTHH:mm:ss", "yyyy-MM-ddTHH:mm:ss.FFFFFFF"} + return DateTime.TryParseExact(cValue, aFormats, CultureInfo.InvariantCulture, ; + DateTimeStyles.None, out dValue) + + /// The text of one cell, trimmed the way VFP trims it. + INTERNAL STATIC METHOD CellText(oRow as DataRow, oColumn as DataColumn) as string + if oRow:IsNull(oColumn) + return "" + endif + // VFP strips the surrounding blanks unless nFlags 4 asks it not to; that flag + // is not implemented, so the values are always trimmed + var cValue := oRow[oColumn]:ToString() + if cValue == NULL + return "" + endif + return cValue:Trim() + + /// Applies the flags that change the type of a whole column. + INTERNAL STATIC METHOD ApplyFlags(oColumn as FoxXmlColumn, nFlags as long) as void + if oColumn:IsCurrency .and. _AND(nFlags, FoxXml.X2C_FLAG_CURRENCY) != 0 + oColumn:FldType := "Y" + oColumn:Len := 8 + oColumn:Dec := 4 + endif + if _AND(nFlags, FoxXml.X2C_FLAG_NOCPTRANS) != 0 + if oColumn:FldType == "C" .or. oColumn:FldType == "M" + oColumn:Flags := _OR(oColumn:Flags, (long) DBFFieldFlags.Binary) + // VFP doubles the width of a Character field read with NOCPTRANS + if oColumn:FldType == "C" + oColumn:Len := Math.Min(oColumn:Len * 2, FoxXml.X2C_MAXCHARLEN) + endif + endif + endif + if _AND(nFlags, FoxXml.X2C_FLAG_VARCHAR) != 0 .and. oColumn:FldType == "C" + oColumn:FldType := "V" + endif + return + + /// Creates the cursor, selects it and fills it. + INTERNAL STATIC METHOD BuildCursor(oTable as DataTable, oSchema as Dictionary, ; + cAlias as string, nFlags as long) as void + local oColumn as FoxXmlColumn + var aColumns := List{} + + var aSource := DataColumns(oTable) + foreach oSrc as DataColumn in aSource + if oSchema:ContainsKey(oSrc:ColumnName) + oColumn := oSchema[oSrc:ColumnName]:Clone() + else + oColumn := InferColumn(oSrc:ColumnName, oTable, oSrc) + endif + ApplyFlags(oColumn, nFlags) + aColumns:Add(oColumn) + next + + if aColumns:Count == 0 + return + endif + + var aStruct := {} + foreach oCol as FoxXmlColumn in aColumns + AAdd(aStruct, {oCol:Name, oCol:FldType, oCol:Len, oCol:Dec, oCol:Name, oCol:Flags}) + next + + if RuntimeState.Workareas:FindAlias(cAlias) != 0 + DbCloseArea(cAlias) + endif + DbCreate(Path.GetTempFileName(), aStruct, "DBFVFP", TRUE, cAlias) + DbSelectArea(cAlias) + + FillCursor(oTable, aSource, aColumns) + return + + /// Writes the rows into the cursor selected in the current work area. + INTERNAL STATIC METHOD FillCursor(oTable as DataTable, aSource as List, ; + aColumns as List) as void + local oResult := NULL as object + + if !CoreDb.Info(DBI_RDD_OBJECT, REF oResult) + throw Error.VoDbError(EG_NOTABLE, EDB_NOTABLE, __FUNCTION__, "cCursorName", 2, {}) + endif + var oRDD := (IRdd) oResult + + foreach oRow as DataRow in oTable:Rows + oRDD:Append(TRUE) + for var nI := 0 upto aColumns:Count - 1 + Put(oRDD, nI + 1, ToField(CellText(oRow, aSource[nI]), aColumns[nI]:FldType)) + next + next + oRDD:GoTop() // VFP leaves the pointer on the first row + return + + /// Appends the rows to a cursor that already exists, matching fields by name. + INTERNAL STATIC METHOD AppendRows(oTable as DataTable, cAlias as string) as void + local oResult := NULL as object + var nArea := iif(String.IsNullOrEmpty(cAlias), RuntimeState.CurrentWorkarea, ; + RuntimeState.Workareas:FindAlias(cAlias)) + if nArea == 0 + throw Error.VoDbError(EG_ARG, EDB_BADALIAS, __FUNCTION__, "cCursorName", 2, {cAlias}) + endif + + var nOldArea := RuntimeState.CurrentWorkarea + RuntimeState.CurrentWorkarea := nArea + try + if !CoreDb.Info(DBI_RDD_OBJECT, REF oResult) + throw Error.VoDbError(EG_NOTABLE, EDB_NOTABLE, __FUNCTION__, "cCursorName", 2, {cAlias}) + endif + var oRDD := (IRdd) oResult + + var aSource := DataColumns(oTable) + var aTarget := List{} + var aTypes := List{} + foreach oColumn as DataColumn in aSource + var nField := oRDD:FieldIndex(oColumn:ColumnName) + aTarget:Add(nField) + aTypes:Add(iif(nField > 0, ((string) oRDD:FieldInfo(nField, DBS_TYPE, NULL)):ToUpper(), "")) + next + + foreach oRow as DataRow in oTable:Rows + oRDD:Append(TRUE) + for var nI := 0 upto aTarget:Count - 1 + if aTarget[nI] > 0 + Put(oRDD, aTarget[nI], ToField(CellText(oRow, aSource[nI]), aTypes[nI])) + endif + next + next + oRDD:GoTop() + finally + RuntimeState.CurrentWorkarea := nOldArea + end try + return + + /// + /// Writes one value, swallowing the error when it does not fit its field. The + /// inferred width is the longest value seen and VFP never reconciles it with the + /// decimals it infers alongside, so a column holding 99999 and 0.1 becomes N(5,1) + /// and the 99999 no longer fits. VFP parks its numeric overflow marker there; our + /// RDD refuses the value outright. The structure is still the one VFP builds, so + /// the field is left blank rather than failing the whole import. + /// + INTERNAL STATIC METHOD Put(oRDD as IRdd, nField as long, oValue as object) as void + try + oRDD:PutValue(nField, oValue) + catch + // the field keeps its blank value + end try + return + + /// Converts one XML text value to the type of the field it goes into. + INTERNAL STATIC METHOD ToField(cValue as string, cType as string) as object + local dValue as DateTime + local r8Value as real8 + local nValue as long + + switch cType + case "L" + switch cValue:ToLowerInvariant() + case "1" + case "true" + return TRUE + end switch + return FALSE + case "D" + case "T" + if DateTime.TryParse(cValue, CultureInfo.InvariantCulture, DateTimeStyles.None, out dValue) + return dValue + endif + return DateTime.MinValue + case "N" + case "F" + case "Y" + case "B" + if System.Double.TryParse(cValue, NumberStyles.Float, CultureInfo.InvariantCulture, out r8Value) + return r8Value + endif + return 0.0 + case "I" + if Int32.TryParse(cValue, NumberStyles.Integer, CultureInfo.InvariantCulture, out nValue) + return nValue + endif + return 0 + end switch + return cValue + + /// RecCount() of the work area currently selected, 0 when there is none. + INTERNAL STATIC METHOD CurrentRecCount() as long + local oResult := NULL as object + if !CoreDb.Info(DBI_RDD_OBJECT, REF oResult) + return 0 + endif + return (long) ((IRdd) oResult):RecCount +END CLASS diff --git a/src/Runtime/XSharp.VFP/ToDo-TUVWX.prg b/src/Runtime/XSharp.VFP/ToDo-TUVWX.prg index 4ee80ded1c..0ff27d8921 100644 --- a/src/Runtime/XSharp.VFP/ToDo-TUVWX.prg +++ b/src/Runtime/XSharp.VFP/ToDo-TUVWX.prg @@ -26,15 +26,6 @@ FUNCTION TxtWidth( cExpression , cFontName, nFontSize , cFontStyle) AS FLOAT THROW NotImplementedException{} // RETURN 0 - - -/// -- todo -- -/// -[FoxProFunction("XMLTOCURSOR", FoxFunctionCategory.General, FoxEngine.RuntimeCore, FoxFunctionStatus.Stub, FoxCriticality.High)]; -FUNCTION XmlToCursor( eExpression , cCursorName , nFlags ) AS LONG - THROW NotImplementedException{} - // RETURN 0 - /// -- todo -- /// [FoxProFunction("XMLUPDATEGRAM", FoxFunctionCategory.General, FoxEngine.RuntimeCore, FoxFunctionStatus.Stub, FoxCriticality.Medium)];