tDOM: Check-in [c416325b0b]

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview

Comment:	Merged from trunk.
Downloads:	Tarball \| ZIP archive \| SQL archive
Timelines:	family \| ancestors \| descendants \| both \| wip
Files:	files \| file ages \| folders
SHA3-256:	c416325b0b873596ceae78aa81abac6ba940bb04024251932dd774668cead278
User & Date:	rolf 2019-10-24 22:05:16

Context

2019-10-25
00:30		INVALID_DOM_KEYCONSTRAINT is really not a validation error but a validation script error (as a TCL_ERROR from a called script. Though, the evalError flag isn't respected anywhere, obviously. check-in: a77a3f3b23 user: rolf tags: wip
2019-10-24
22:05		Merged from trunk. check-in: c416325b0b user: rolf tags: wip
14:12		Added xsd as new format (and default) to the text constraint command "number". check-in: c2b6dd2267 user: rolf tags: schema
2019-10-23
09:25		Merged from schema. check-in: 3c16fd1ab1 user: rolf tags: wip

Changes

Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/schema.c.

    char *name, *ns;
    SchemaCP *cp;
    Tcl_HashEntry *h;
    Tcl_Obj *attname, *attns, *attvalue;

    cp = sdata->stack->pattern;
    for (i = 0; i < len; i += 2) {




        Tcl_ListObjIndex (interp, attr, i, &attname);
        Tcl_ListObjIndex (interp, attr, i+1, &attvalue);
        if (Tcl_ListObjLength (interp, attname, &len) == TCL_OK) {
            if (len == 2) {
                Tcl_ListObjIndex (interp, attname, 1, &attns);
                Tcl_ListObjIndex (interp, attname, 1, &attname);
            }
        }
        h = Tcl_FindHashEntry (&sdata->attrNames, Tcl_GetString (attname));
        if (!h) goto unknown;
        name = Tcl_GetHashKey (&sdata->attrNames, h);
        if (attns) {
            h = Tcl_FindHashEntry (&sdata->namespace, Tcl_GetString (attns));
................................................................................
                                Tcl_GetString (attvalue), &req);
        reqAttr += req;
    unknown:
        if (!found) {
            if (!recover (interp, sdata, S("UNKNOWN_ATTRIBUTE"), 0, 0)) {
                if (ns) {
                    SetResult ("Unknown attribute \"");
                    Tcl_AppendResult (interp, ns, ":", ns,
                                      "\"");
                } else {
                    SetResult3 ("Unknown attribute \"", name, "\"");
                }
                sdata->validationState = VALIDATION_ERROR;
                return TCL_ERROR;
            }
................................................................................
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[]
    )
{
    int            methodIndex, keywordIndex, hnew, patternIndex;
    int            result = TCL_OK, forwardDef = 0, i = 0, j;
    int            savedDefineToplevel, type, len, checkAttr;
    unsigned int   savedNumPatternList;
    SchemaData    *savedsdata = NULL, *sdata = (SchemaData *) clientData;
    Tcl_HashTable *hashTable;
    Tcl_HashEntry *h, *h1;
    SchemaCP      *pattern, *current = NULL;
    void          *namespacePtr, *savedNamespacePtr;
    char          *xmlstr, *errMsg;
    domDocument   *doc;
    domNode       *node;


    static const char *schemaInstanceMethods[] = {
        "defelement",  "defpattern",  "start", "event",     "delete",
        "nrForwardDefinitions",       "reset", "define",    "validate",
        "domvalidate", "deftext",     "info",  "reportcmd", "prefixns",
        NULL
    };
................................................................................
        case k_elementstart:
            if (objc < 4 && objc > 6) {
                Tcl_WrongNumArgs (interp, 3, objv, "<elementname>"
                    "?<attInfo>? ?<namespace>?");
                return TCL_ERROR;
            }
            namespacePtr = NULL;
            checkAttr = 0;

            if (objc == 6) {
                namespacePtr = getNamespacePtr (sdata,
                                                Tcl_GetString (objv[5]));
            }
            if (objc >= 5) {
                if (Tcl_ListObjLength (interp, objv[4], &len) != TCL_OK) {




                    namespacePtr = getNamespacePtr (sdata,
                                                    Tcl_GetString (objv[4]));


                } else {
                    if (len == 1) {
                        namespacePtr = getNamespacePtr (
                            sdata, Tcl_GetString (objv[4])
                            );

                    } else if (len % 2 != 0) {
                        SetResult ("Invalid attribute information");
                        return TCL_ERROR;
                    } else {
                        checkAttr = 1;
                    }
                }
            }
            result = probeElement (interp, sdata, Tcl_GetString (objv[3]),
                                   namespacePtr);
            if (result == TCL_OK && checkAttr) {
                if (!probeEventAttribute (interp, sdata, objv[4], len)) {
                    return TCL_ERROR;
                }
            }
            break;
            
        case k_elementend:
            if (objc != 3) {
                Tcl_WrongNumArgs (interp, 3, objv, "No arguments expected.");
                return TCL_ERROR;
................................................................................
    checkNrArgs (1,1,"No arguments expected");
    ADD_CONSTRAINT (sdata, sc)
    sc->constraint = nmtokensImpl;
    return TCL_OK;
}

static int
numberImpl (





















    Tcl_Interp *interp,
    void *constraintData,
    char *text
    )
{
    double d;

................................................................................
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[]
    )
{
    SchemaData *sdata = GETASI;
    SchemaConstraint *sc;









    CHECK_TI
    CHECK_TOPLEVEL
    checkNrArgs (1,1,"No arguments expected");








    ADD_CONSTRAINT (sdata, sc)


    sc->constraint = numberImpl;





    return TCL_OK;
}

static int
booleanImplXsd (
    Tcl_Interp *interp,
    void *constraintData,








>
>
>
>





|







 







|







 







|









>







 







|
>






>
>
>
>
|
|
>
>


|
|
<
>




|





|
|
<
<







 







|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







>
>
>
>
>
>
>
>



|
>
>
>
>
>
>
>
>

>
>
|
>
>
>
>
>

    char *name, *ns;
    SchemaCP *cp;
    Tcl_HashEntry *h;
    Tcl_Obj *attname, *attns, *attvalue;

    cp = sdata->stack->pattern;
    for (i = 0; i < len; i += 2) {
        found = 0;
        ns = NULL;
        name = NULL;
        attns = NULL;
        Tcl_ListObjIndex (interp, attr, i, &attname);
        Tcl_ListObjIndex (interp, attr, i+1, &attvalue);
        if (Tcl_ListObjLength (interp, attname, &len) == TCL_OK) {
            if (len == 2) {
                Tcl_ListObjIndex (interp, attname, 1, &attns);
                Tcl_ListObjIndex (interp, attname, 0, &attname);
            }
        }
        h = Tcl_FindHashEntry (&sdata->attrNames, Tcl_GetString (attname));
        if (!h) goto unknown;
        name = Tcl_GetHashKey (&sdata->attrNames, h);
        if (attns) {
            h = Tcl_FindHashEntry (&sdata->namespace, Tcl_GetString (attns));
................................................................................
                                Tcl_GetString (attvalue), &req);
        reqAttr += req;
    unknown:
        if (!found) {
            if (!recover (interp, sdata, S("UNKNOWN_ATTRIBUTE"), 0, 0)) {
                if (ns) {
                    SetResult ("Unknown attribute \"");
                    Tcl_AppendResult (interp, ns, ":", name,
                                      "\"");
                } else {
                    SetResult3 ("Unknown attribute \"", name, "\"");
                }
                sdata->validationState = VALIDATION_ERROR;
                return TCL_ERROR;
            }
................................................................................
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[]
    )
{
    int            methodIndex, keywordIndex, hnew, patternIndex;
    int            result = TCL_OK, forwardDef = 0, i = 0, j;
    int            savedDefineToplevel, type, len;
    unsigned int   savedNumPatternList;
    SchemaData    *savedsdata = NULL, *sdata = (SchemaData *) clientData;
    Tcl_HashTable *hashTable;
    Tcl_HashEntry *h, *h1;
    SchemaCP      *pattern, *current = NULL;
    void          *namespacePtr, *savedNamespacePtr;
    char          *xmlstr, *errMsg;
    domDocument   *doc;
    domNode       *node;
    Tcl_Obj       *attData;

    static const char *schemaInstanceMethods[] = {
        "defelement",  "defpattern",  "start", "event",     "delete",
        "nrForwardDefinitions",       "reset", "define",    "validate",
        "domvalidate", "deftext",     "info",  "reportcmd", "prefixns",
        NULL
    };
................................................................................
        case k_elementstart:
            if (objc < 4 && objc > 6) {
                Tcl_WrongNumArgs (interp, 3, objv, "<elementname>"
                    "?<attInfo>? ?<namespace>?");
                return TCL_ERROR;
            }
            namespacePtr = NULL;
            len = 0;
            attData = NULL;
            if (objc == 6) {
                namespacePtr = getNamespacePtr (sdata,
                                                Tcl_GetString (objv[5]));
            }
            if (objc >= 5) {
                if (Tcl_ListObjLength (interp, objv[4], &len) != TCL_OK) {
                    if (objc == 6) {
                        SetResult ("Invalid attribute information");
                        return TCL_ERROR;
                    } else {
                        namespacePtr =
                            getNamespacePtr (sdata, Tcl_GetString (objv[4]));
                        len = 0;
                    }
                } else {
                    if (len == 1) {
                        namespacePtr =
                            getNamespacePtr (sdata, Tcl_GetString (objv[4]));

                        len = 0;
                    } else if (len % 2 != 0) {
                        SetResult ("Invalid attribute information");
                        return TCL_ERROR;
                    } else {
                        attData = objv[4];
                    }
                }
            }
            result = probeElement (interp, sdata, Tcl_GetString (objv[3]),
                                   namespacePtr);
            if (result == TCL_OK) {
                result = probeEventAttribute (interp, sdata, attData, len);


            }
            break;
            
        case k_elementend:
            if (objc != 3) {
                Tcl_WrongNumArgs (interp, 3, objv, "No arguments expected.");
                return TCL_ERROR;
................................................................................
    checkNrArgs (1,1,"No arguments expected");
    ADD_CONSTRAINT (sdata, sc)
    sc->constraint = nmtokensImpl;
    return TCL_OK;
}

static int
numberImplXsd (
    Tcl_Interp *interp,
    void *constraintData,
    char *text
    )
{
    char *c = text;
    if (!*c) return 0;
    if (*c == '-' || *c == '+') c++;
    while (isdigit(*c)) {
        c++;
    }
    if (*c == '.') c++;
    while (isdigit(*c)) {
        c++;
    }
    if (*c) return 0;
    return 1;
}

static int
numberImplTcl (
    Tcl_Interp *interp,
    void *constraintData,
    char *text
    )
{
    double d;

................................................................................
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[]
    )
{
    SchemaData *sdata = GETASI;
    SchemaConstraint *sc;
    int type;

    static const char *types[] = {
        "xsd", "tcl", NULL
    };
    enum typeSyms {
        t_xsd, t_tcl
    };

    CHECK_TI
    CHECK_TOPLEVEL
    checkNrArgs (1,2,"?xsd|tcl?");
    if (objc == 1) {
        type = t_xsd;
    } else {
        if (Tcl_GetIndexFromObj (interp, objv[1], types, "type", 0, &type)
            != TCL_OK) {
            return TCL_ERROR;
        }
    }
    ADD_CONSTRAINT (sdata, sc)
    switch ((enum typeSyms) type) {
    case t_xsd:
        sc->constraint = numberImplXsd;
        break;
    case t_tcl:
        sc->constraint = numberImplTcl;
        break;
    }
    return TCL_OK;
}

static int
booleanImplXsd (
    Tcl_Interp *interp,
    void *constraintData,

Changes to tests/schema.test.

    }
    s delete
    set result
} {0 {error "This method is not allowed in nested evaluation" at line 1 character 6} 0 {error "This method is not allowed in nested evaluation" at line 1 character 15} 0 {error "This method is not allowed in nested evaluation" at line 1 character 13}}

test schema-4.6 {event start with namespace} {
    tdom::schema s



























    s defelement doc http://tdom.org/test {
        element a 1 {
            attribute att1
        }
    }
    s event start doc http://tdom.org/test
    s event start a http://tdom.org/test
    s event end
    s event end
    s delete













} {}

test schema-5.1 {dom parse -validateCmd} {
    set result [catch {
        [dom parse -validateCmd tdom::schema <doc/>]
    }]
} 1
................................................................................
    } {
        lappend result [s validate $xml]
    }
    s delete
    set result
} {0 0 0 0 0 1 0 0 0 1 0 1 1 0 1 1 0 0 0 1 0 1 1}

test schema-14.10 {text: number} {




























    tdom::schema s
    s define {
        defelement doc {
            text number
        }
    }
    set result [list]
    foreach xml {
        <doc/>
        <doc></doc>

        <doc>foo</doc>
        <doc>1</doc>



        <doc>12</doc>
        <doc>1234-12-31</doc>
        <doc>-14.23</doc>
        <doc>.777</doc>
        <doc>-1.2e5</doc>
        {<doc> -1.2e5 </doc>}
        {<doc> -1.2e5 e</doc>}
    } {
        lappend result [s validate $xml]
    }
    s delete
    set result
} {0 0 0 1 1 0 1 1 1 1 0}

test schema-14.11 {text: maxLength} {
    tdom::schema s
    s define {
        defelement doc {
            text {
                maxLength 6








>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>






|



>
>
>
>
>
>
>
>
>
>
>
>
>







 







|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>










>


>
>
>












|

    }
    s delete
    set result
} {0 {error "This method is not allowed in nested evaluation" at line 1 character 6} 0 {error "This method is not allowed in nested evaluation" at line 1 character 15} 0 {error "This method is not allowed in nested evaluation" at line 1 character 13}}

test schema-4.6 {event start with namespace} {
    tdom::schema s
    s defelement doc http://tdom.org/test {
        element a ! text
    }
    s event start doc http://tdom.org/test
    s event start a http://tdom.org/test
    s event text "some text"
    s event end
    s event end
    s delete
} {}

test schema-4.7 {event start with namespace} {
    tdom::schema s
    s defelement doc http://tdom.org/test {
        element a 1 {
            attribute att1
        }
    }
    s event start doc http://tdom.org/test
    set result [catch {s event start a http://tdom.org/test} errMsg]
    lappend result $errMsg
    s delete
    set result
} {1 {Missing mandatory attribute(s)}}

test schema-4.8 {event start with namespace} {
    tdom::schema s
    s defelement doc http://tdom.org/test {
        element a 1 {
            attribute att1
        }
    }
    s event start doc http://tdom.org/test
    s event start a {att1 "some data"} http://tdom.org/test
    s event end
    s event end
    s delete
} {}

test schema-4.9 {event start with namespace w/ namespaced attribute} {
    tdom::schema s
    s defelement doc http://tdom.org/test {
        element a 1 {
            nsattribute att1 http://tdom.org/test
        }
    }
    s event start doc http://tdom.org/test
    s event start a {{att1 http://tdom.org/test} "some data"} http://tdom.org/test
    s event end
    s event end
} {}

test schema-5.1 {dom parse -validateCmd} {
    set result [catch {
        [dom parse -validateCmd tdom::schema <doc/>]
    }]
} 1
................................................................................
    } {
        lappend result [s validate $xml]
    }
    s delete
    set result
} {0 0 0 0 0 1 0 0 0 1 0 1 1 0 1 1 0 0 0 1 0 1 1}

test schema-14.10 {text: number tcl} {
    tdom::schema s
    s define {
        defelement doc {
            text {number tcl}
        }
    }
    set result [list]
    foreach xml {
        <doc/>
        <doc></doc>
        {<doc> </doc>}
        <doc>foo</doc>
        <doc>1</doc>
        <doc>12</doc>
        <doc>1234-12-31</doc>
        <doc>-14.23</doc>
        <doc>.777</doc>
        <doc>-1.2e5</doc>
        {<doc> -1.2e5 </doc>}
        {<doc> -1.2e5 e</doc>}
    } {
        lappend result [s validate $xml]
    }
    s delete
    set result
} {0 0 0 0 1 1 0 1 1 1 1 0}

test schema-14.10a {text: number xsd} {
    tdom::schema s
    s define {
        defelement doc {
            text number
        }
    }
    set result [list]
    foreach xml {
        <doc/>
        <doc></doc>
        {<doc> </doc>}
        <doc>foo</doc>
        <doc>1</doc>
        {<doc> 1</doc>}
        {<doc>1 </doc>}
        {<doc> 1 </doc>}
        <doc>12</doc>
        <doc>1234-12-31</doc>
        <doc>-14.23</doc>
        <doc>.777</doc>
        <doc>-1.2e5</doc>
        {<doc> -1.2e5 </doc>}
        {<doc> -1.2e5 e</doc>}
    } {
        lappend result [s validate $xml]
    }
    s delete
    set result
} {0 0 0 0 1 0 0 0 1 0 1 1 0 0 0}

test schema-14.11 {text: maxLength} {
    tdom::schema s
    s define {
        defelement doc {
            text {
                maxLength 6