+
tdom::schema -
Create a schema validation command
package require tdom +SYNOPSIS
package require tdom tdom::schema ?create? cmdName-DESCRIPTION
This command creates validation commands with a simple API. The +
DESCRIPTION
This command creates validation commands with a simple API. The validation commands have methods to define a schema and are able to validate XML or DOM trees (and to some degree other kind of hierarchical data) against this schema.
Additionally, a validation command may be used as argument to the -validateCmd option of the dom parse and the expat commands to enable validation additional to what they @@ -24,21 +24,20 @@ otherwise do.
The valid methods of the created commands are:
Schema definition scripts are ordinary Tcl scripts that are +
Schema definition scripts are ordinary Tcl scripts that are evaluatend in the namespace tdom::schema. The below listed schema definition commands in this tcl namespace allow to define a wide variety of document structures. Every schema definition command establish a validation constraint on the content which has to match or must be optional to render the content as valid. It is a @@ -303,10 +302,21 @@ namespace uri <definition script>
Serveral schema definition commands expects a quantifier as +
Serveral schema definition commands expects a quantifier as one of their arguments, which specifies how often the content particle specified by the command is expected. The valid values for a quant argument are:
If an optional quantifier is not given then it defaults to * in case of the mixed command and to ! for all other commands.
-The text constraint commands are:
The text constraint commands are:
The XML Schema Part 0: Primer Second Edition +
The XML Schema Part 0: Primer Second Edition (https://www.w3.org/TR/xmlschema-0/) starts with this example schema:
<xsd:schema xmlns:xsd="http://www.w3.org/2001/XMLSchema"> <xsd:annotation> Index: doc/schema.n ================================================================== --- doc/schema.n +++ doc/schema.n @@ -188,14 +188,14 @@ abbreviation) to namespace URI mapping. Everywhere a namespace argument is expected in the schema command methods you may use the "prefix" pointing to the namespace URI in the current prefixUriList, set by this method. If the list map the same prefix to different namespace URIs the -last won win. If there isn't such a prefix the namespace +frist one win. If there isn't such a prefix the namespace argument is used literally as namespace URI. If the method is called without argument it returns the current -prefixUriList. If the method is called with the empty list +prefixUriList. If the method is called with the empty string any namespace URI arguments are used literally. This is the default. .TP \&\fB\fBdefelement\fP \fIname\fB \fI?namespace?\fB \fI\fB \&\fRThis method defines the element \fIname\fR (optional in @@ -369,10 +369,17 @@ \&\fB\fBnsattribute\fP \fIname\fB \fInamespace\fB \fI?quant?\fB \fI(? |\*(lqtype\*(lq typename?)\fB \&\fRThis command does the same as the command \fIattribute\fR, just for the attribute \fIname\fR in the namespace \fInamespace\fR. .TP \&\fB\fBnamespace\fP \fIuri\fB \fI \fB \&\fREvaluates the \fIdefinition script\fR with context namespace \fIuri\fR. Every element or ref command name will be looked up in the namespace \fIuri\fR and local defined element will be in that namespace. +.TP +\&\fB\fBprefixns\fP \fI?prefixUriList?\fB +\&\fRThis defines a prefix to namespace URI mapping exactly +as a \fIschemacmd prefixns\fR call. This is meant as toplevel +command of a \fIschemacmd define\fR script. This command is +not allowed nested in an other definition script command and +will raise error, if you call it there. .TP \&\fB\fBdefelement\fP \fIname\fB \fI?namespace?\fB \fI \fB \&\fRThis defines an element type exactly as a \fIschemacmd defelement\fR call. This is meant as toplevel command of a \&\fIschemacmd define\fR script. This command is not allowed Index: doc/schema.xml ================================================================== --- doc/schema.xml +++ doc/schema.xml @@ -28,21 +28,20 @@ The valid methods of the created commands are:
@@ -275,10 +274,19 @@ - prefixns ?prefixUriList? This method gives control to a prefix (or abbreviation) to namespace URI mapping. Everywhere a namespace argument is expected in the schema command methods you may use the "prefix" pointing to the namespace URI in the current prefixUriList, set by this method. If the list map the same prefix to different namespace URIs the - last won win. If there isn't such a prefix the namespace + frist one win. If there isn't such a prefix the namespace argument is used literally as namespace URI. If the method is called without argument it returns the current - prefixUriList. If the method is called with the empty list + prefixUriList. If the method is called with the empty string any namespace URI arguments are used literally. This is the default. + namespace uri <definition script> Evaluates the definition script with context namespaceuri . Every element or ref command name will be looked up in the namespaceuri and local defined element will be in that namespace.+ ++ prefixns ?prefixUriList? This defines a prefix to namespace URI mapping exactly + as a schemacmd prefixns call. This is meant as toplevel + command of a schemacmd define script. This command is + not allowed nested in an other definition script command and + will raise error, if you call it there. +defelement name ?namespace? <definition script> This defines an element type exactly as a schemacmd defelement call. This is meant as toplevel command of a schemacmd define script. This command is not allowed Index: generic/schema.c ================================================================== --- generic/schema.c +++ generic/schema.c @@ -2253,11 +2253,11 @@ int objc, Tcl_Obj *const objv[] ) { int methodIndex, keywordIndex, hnew, patternIndex; - int result = TCL_OK, forwardDef = 0, i = 0; + 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; @@ -2287,25 +2287,26 @@ enum eventKeyword { k_elementstart, k_elementend, k_text }; - if (objc < 2) { - Tcl_WrongNumArgs (interp, 1, objv, "subcommand ?arguments?"); - return TCL_ERROR; - } - if (sdata == NULL) { - /* Inline defined defelement, defpattern, deftext or start */ + /* Inline defined defelement, defpattern, deftext, start or + * prefixns */ sdata = GETASI; CHECK_SI; if (!sdata->defineToplevel && sdata->currentEvals > 1) { SetResult ("Method not allowed in nested schema define script"); return TCL_ERROR; } i = 1; } + if (objc + i < 2) { + Tcl_WrongNumArgs (interp, 1, objv, "subcommand ?arguments?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj (interp, objv[1-i], schemaInstanceMethods, "method", 0, &methodIndex) != TCL_OK) { return TCL_ERROR; @@ -2648,25 +2649,39 @@ sdata->reportCmd = objv[2]; Tcl_IncrRefCount (sdata->reportCmd); break; case m_prefixns: + CHECK_RECURSIVE_CALL + if (clientData == NULL && !sdata->defineToplevel) { + SetResult ("Command only allowed at lop level"); + return TCL_ERROR; + } + if (objc != 2-i && objc != 3-i) { + Tcl_WrongNumArgs (interp, 2-i, objv, "?prefixUriList?"); + return TCL_ERROR; + } + if (!i) {objc--; objv++;} result = tcldom_prefixNSlist (&sdata->prefixns, interp, objc, objv, "prefixns"); if (sdata->prefix.numBuckets) { Tcl_DeleteHashTable (&sdata->prefix); Tcl_InitHashTable (&sdata->prefix, TCL_STRING_KEYS); } if (result == TCL_OK && sdata->prefixns) { - i = 0; - while (sdata->prefixns[i]) { - h = Tcl_CreateHashEntry (&sdata->namespace, - sdata->prefixns[i+1], &hnew); + j = 0; + while (sdata->prefixns[j]) { h1 = Tcl_CreateHashEntry (&sdata->prefix, - sdata->prefixns[i], &hnew); - Tcl_SetHashValue (h1, Tcl_GetHashKey (&sdata->namespace, h)); - i += 2; + sdata->prefixns[j], &hnew); + /* This means: First prefix mapping wins */ + if (hnew) { + h = Tcl_CreateHashEntry (&sdata->namespace, + sdata->prefixns[j+1], &hnew); + Tcl_SetHashValue (h1, Tcl_GetHashKey (&sdata->namespace, + h)); + } + j += 2; } } break; default: @@ -4506,10 +4521,12 @@ Tcl_CreateObjCommand (interp, "tdom::schema::defpattern", schemaInstanceCmd, NULL, NULL); Tcl_CreateObjCommand (interp, "tdom::schema::deftext", schemaInstanceCmd, NULL, NULL); Tcl_CreateObjCommand (interp, "tdom::schema::start", + schemaInstanceCmd, NULL, NULL); + Tcl_CreateObjCommand (interp, "tdom::schema::prefixns", schemaInstanceCmd, NULL, NULL); /* The "any" definition command. */ Tcl_CreateObjCommand (interp, "tdom::schema::any", AnyPatternObjCmd, NULL, NULL); Index: generic/tcldom.c ================================================================== --- generic/tcldom.c +++ generic/tcldom.c @@ -3958,13 +3958,12 @@ { char **prefixns = *prefixnsPtr; int len, i, result; Tcl_Obj *objPtr, *listPtr; - CheckArgs (2,3,2, "?prefixUriList?"); i = 0; - if (objc == 2) { + if (objc == 1) { if (!prefixns) return TCL_OK; listPtr = Tcl_NewListObj (0, NULL); i = 0; while (prefixns[i]) { Tcl_ListObjAppendElement ( @@ -3973,14 +3972,14 @@ i++; } Tcl_SetObjResult (interp, listPtr); return TCL_OK; } - result = Tcl_ListObjLength (interp, objv[2], &len); + result = Tcl_ListObjLength (interp, objv[1], &len); if (result != TCL_OK || (len % 2) != 0) { - SetResult3 ("The optional argument to the ", methodName, - " method must be a 'prefix namespace' pairs list"); + SetResult3 ("The optional argument to ", methodName, + " must be a 'prefix namespace' pairs list"); return TCL_ERROR; } if (prefixns) { while (prefixns[i]) { FREE (prefixns[i]); @@ -3996,15 +3995,15 @@ if (prefixns) FREE (prefixns); prefixns = MALLOC (sizeof (char*) * (len+1)); *prefixnsPtr = prefixns; } for (i = 0; i < len; i++) { - Tcl_ListObjIndex (interp, objv[2], i, &objPtr); + Tcl_ListObjIndex (interp, objv[1], i, &objPtr); prefixns[i] = tdomstrdup (Tcl_GetString (objPtr)); } prefixns[len] = NULL; - Tcl_SetObjResult (interp, objv[2]); + Tcl_SetObjResult (interp, objv[1]); return TCL_OK; } /*---------------------------------------------------------------------------- | renameNodes @@ -5933,12 +5932,14 @@ case m_cdataSectionElements: return cdataSectionElements (doc, interp, objc, objv); case m_selectNodesNamespaces: - return tcldom_prefixNSlist (&(doc->prefixNSMappings), interp, objc, - objv, "selectNodesNamespaces"); + CheckArgs (2,3,2, "?prefixUriList?"); + return tcldom_prefixNSlist (&(doc->prefixNSMappings), interp, + --objc, ++objv, + "selectNodesNamespaces"); case m_renameNode: return renameNodes (doc, interp, objc, objv); case m_deleteXPathCache: Index: tests/domDoc.test ================================================================== --- tests/domDoc.test +++ tests/domDoc.test @@ -1393,11 +1393,11 @@ set doc [dom createDocument foo] set result [catch {$doc selectNodesNamespaces wrong} errMsg] lappend result $errMsg $doc delete set result -} {1 {The optional argument to the selectNodesNamespaces method must be a 'prefix namespace' pairs list}} +} {1 {The optional argument to selectNodesNamespaces must be a 'prefix namespace' pairs list}} test domDoc-25.5 {selectNodesNamespaces} { set doc [dom parse { Index: tests/schema.test ================================================================== --- tests/schema.test +++ tests/schema.test @@ -392,11 +392,11 @@ s2 delete s1 delete set result } {s1 s2 1 0 0 1} -test schema-1.22 {Call not toplevel cmd methods in definition script} { +test schema-1.22 {nrForwardDefinitions} { tdom::schema create s set result [list] s define { defelement e { lappend ::result [s nrForwardDefinitions] @@ -414,10 +414,190 @@ } s delete set result } {0 1 1 2 1 0} +test schema-1.23 {prefixns} { + tdom::schema create s + set result [list] + lappend result [s prefixns] + lappend result [s prefixns {a b}] + lappend result [s prefixns] + lappend result [s prefixns {a b a b c d}] + lappend result [s prefixns {}] + lappend result [s prefixns ""] + lappend result [catch {s prefixns a b c} errMsg] + lappend result $errMsg + lappend result [catch {s prefixns {a b c}} errMsg] + lappend result $errMsg + lappend result [catch {s prefixns "a \{"} errMsg] + lappend result $errMsg + s delete + set result +} {{} {a b} {a b} {a b a b c d} {} {} 1 {wrong # args: should be "s prefixns ?prefixUriList?"} 1 {The optional argument to prefixns must be a 'prefix namespace' pairs list} 1 {The optional argument to prefixns must be a 'prefix namespace' pairs list}} + +test schema-1.24 {prefixns} { + tdom::schema create s + set result [list] + lappend result [s define prefixns] + lappend result [s define {prefixns {a b}}] + lappend result [s define {prefixns}] + lappend result [s define {prefixns {a b a b c d}}] + lappend result [s define {prefixns {}}] + lappend result [s define {prefixns ""}] + lappend result [catch {s define {prefixns a b c}} errMsg] + lappend result $errMsg + lappend result [catch {s define {prefixns {a b c}}} errMsg] + lappend result $errMsg + lappend result [catch {s define {prefixns "a \{"}} errMsg] + lappend result $errMsg + s delete + set result +} {{} {a b} {a b} {a b a b c d} {} {} 1 {wrong # args: should be "prefixns ?prefixUriList?"} 1 {The optional argument to prefixns must be a 'prefix namespace' pairs list} 1 {The optional argument to prefixns must be a 'prefix namespace' pairs list}} + +test schema-1.25 {prefixns} { + set result [list] + set schema { + defelement doc ns1 { + element e + } + } + set xml { } + # 1 + tdom::schema create s + s define $schema + lappend result [s validate $xml] + s delete + # 2 + tdom::schema create s + s prefixns {ns1 http://tdom.org/test} + s define $schema + lappend result [s validate $xml] + s delete + # 3 + tdom::schema create s + s prefixns {ns1 http://foo.bar} + s define $schema + lappend result [s validate $xml] + s delete + # 4 + tdom::schema create s + s prefixns {ns1 http://tdom.org/test ns1 http://foo.bar} + s define $schema + lappend result [s validate $xml] + s delete + # 5 + tdom::schema create s + s prefixns {ns1 http://foo.bar ns1 http://tdom.org/test} + s define $schema + lappend result [s validate $xml] + s delete + # 6 + tdom::schema create s + s prefixns {ns1 http://foo.bar} + s prefixns {ns1 http://tdom.org/test ns1 http://foo.bar} + s define $schema + lappend result [s validate $xml] + s delete + # 7 + tdom::schema create s + s define { + prefixns {ns1 http://tdom.org/test} + defelement doc ns1 { + element e + } + prefixns {ns2 http://foo.bar} + defelement e ns2 {text {minLength 1}} + } + lappend result [s validate $xml] + s delete + # 8 + tdom::schema create s + s define { + prefixns {ns1 http://tdom.org/test} + defelement doc ns1 { + namespace http://foo.bar { + element e + } + } + prefixns {ns2 http://foo.bar} + defelement e ns2 {text {minLength 1}} + } + lappend result [s validate $xml] + # 9 + lappend result [s validate { }] + # 10 + lappend result [s validate { }] + s delete + # 11 + tdom::schema create s + s define { + prefixns {ns1 http://tdom.org/test ns2 http://foo.bar} + defelement doc ns1 { + namespace ns2 { + element e + } + } + prefixns {ns2 http://foo.bar} + defelement e ns2 {text {minLength 1}} + } + lappend result [s validate $xml] + # 12 + lappend result [s validate { foo }] + # 13 + lappend result [s validate { }] + s delete + set result +} {0 1 0 1 0 1 1 0 0 1 0 0 1} + +test schema-1.26 {prefixns} { + tdom::schema create s + set result [list] + lappend result [catch { + s defelement doc { + prefixns {a http://foo.bar} + namespace a { + element e + } + } + } errMsg] + lappend result $errMsg + lappend result [catch { + s defelement doc { + namespace a { + element e + } + prefixns {a http://foo.bar} + } + } errMsg] + lappend result $errMsg + lappend result [catch { + s define { + defelement doc { + prefixns {a http://foo.bar} + namespace a { + element e + } + } + } + } errMsg] + lappend result $errMsg + lappend result [catch { + s define { + defelement doc { + s prefixns {a http://foo.bar} + namespace a { + element e + } + } + } + } errMsg] + lappend result $errMsg + s delete + set result +} {1 {Command only allowed at lop level} 1 {Command only allowed at lop level} 1 {Method not allowed in nested schema define script} 1 {This recursive call is not allowed}} + test schema-2.1 {grammar definition: ref} { tdom::schema create grammar grammar defpattern thisPattern { element a element b @@ -3289,10 +3469,51 @@ minLength 2 maxLength 4 } nsattribute foo http://tdom.org/test ? type len2-4 } + } + set result [list] + foreach xml { + foo + { } + { } + { } + { } + { } + { } + { } + { } + { } + } { + lappend result [s validate $xml] + } + s delete + set result +} {0 0 1 0 1 0 1 0 0 0} + +test schema-14.20a {deftext} { + tdom::schema s + s deftext len2-4 { + minLength 2 + maxLength 4 + } + s define { + prefixns { + ns2 http://tdom.org/test + nsfoo http://foo.bar + ns2 http://baz.boo + } + defelement doc { + element e ! { + nsattribute this ns2 { + minLength 2 + maxLength 4 + } + nsattribute foo ns2 ? type len2-4 + } + } } set result [list] foreach xml { { }