-
+
tdom::schema -
Create a schema validation command
-
package require tdom
+ package require tdom
tdom::schema ?create? cmdName
- This command creates validation commands with a simple API. The
+
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
@@ -167,11 +167,11 @@
READY (while preserving the defined grammer).
-
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
@@ -317,11 +317,11 @@
other definition script command and will raise error, if you
call it there.
-
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:
- !
@@ -362,11 +362,11 @@
must be integers, with n >= 0 and n < m.
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:
- isint
@@ -519,13 +519,18 @@
- This text constraint command expects the text to be a
reference to an ID within the document. The referenced ID may
be later in the document, that the reference. Several
references within the document to one ID are possible.
+
+ - base64
+ - This text constraint match if text is valid according to
+ RFC 4648RFC 4648.
+
- 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
@@ -537,10 +537,14 @@
\&\fB\fBidref\fP
\&\fRThis text constraint command expects the text to be a
reference to an ID within the document. The referenced ID may
be later in the document, that the reference. Several
references within the document to one ID are possible.
+.TP
+\&\fB\fBbase64\fP
+\&\fRThis text constraint match if text is valid according to
+RFC 4648RFC 4648.
.SH Exampels
.PP
.UR "https://www.w3.org/TR/xmlschema-0/"
.UE
Index: doc/schema.xml
==================================================================
--- doc/schema.xml
+++ doc/schema.xml
@@ -478,10 +478,15 @@
This text constraint command expects the text to be a
reference to an ID within the document. The referenced ID may
be later in the document, that the reference. Several
references within the document to one ID are possible.
+
+ base64
+ This text constraint match if text is valid according to
+ RFC 4648RFC 4648.
+
Exampels
Index: generic/schema.c
==================================================================
--- generic/schema.c
+++ generic/schema.c
@@ -4523,10 +4523,68 @@
ADD_CONSTRAINT (sdata, sc)
sc->constraint = idrefImpl;
sc->constraintData = (void *)sdata;
return TCL_OK;
}
+
+static int
+base64Impl (
+ Tcl_Interp *interp,
+ void *constraintData,
+ char *text
+ )
+{
+ int chars = 0, equals = 0;
+
+ while (*text != '\0') {
+ if (SPACE(*text)) {
+ text++;
+ continue;
+ }
+ if ( (*text >= 'A' && *text <= 'Z')
+ || (*text >= 'a' && *text <= 'z')
+ || (*text >= '0' && *text <= '9')
+ || (*text = '+')
+ || (*text = '/')) {
+ chars++;
+ text++;
+ continue;
+ }
+ if (equals < 2 && *text == '=') {
+ equals++;
+ text++;
+ continue;
+ }
+ break;
+ }
+ if (*text) {
+ return 0;
+ }
+ if ((chars + equals) % 4 != 0) {
+ return 0;
+ }
+ return 1;
+}
+
+static int
+base64TCObjCmd (
+ ClientData clientData,
+ 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 = base64Impl;
+ return TCL_OK;
+}
void
tDOM_SchemaInit (
Tcl_Interp *interp
)
@@ -4619,9 +4677,11 @@
splitTCObjCmd, NULL, NULL);
Tcl_CreateObjCommand (interp,"tdom::schema::text::id",
idTCObjCmd, NULL, NULL);
Tcl_CreateObjCommand (interp,"tdom::schema::text::idref",
idrefTCObjCmd, NULL, NULL);
+ Tcl_CreateObjCommand (interp,"tdom::schema::text::base64",
+ base64TCObjCmd, NULL, NULL);
}
#endif /* #ifndef TDOM_NO_SCHEMA */
Index: generic/schema.h
==================================================================
--- generic/schema.h
+++ generic/schema.h
@@ -103,12 +103,10 @@
int activeChild;
int hasMatched;
int *interleaveState;
} SchemaValidationStack;
-typedef keyConstraint *key;
-
typedef enum {
VALIDATION_READY,
VALIDATION_STARTED,
VALIDATION_ERROR,
VALIDATION_FINISHED
Index: generic/tcldom.c
==================================================================
--- generic/tcldom.c
+++ generic/tcldom.c
@@ -3946,57 +3946,65 @@
/*----------------------------------------------------------------------------
| selectNodesNamespaces
|
\---------------------------------------------------------------------------*/
-static int selectNodesNamespaces (
- domDocument *doc,
+int tcldom_prefixNSlist (
+ char ***prefixnsPtr,
Tcl_Interp *interp,
int objc,
- Tcl_Obj *const objv[]
+ Tcl_Obj *const objv[],
+ const char *methodName
)
{
+ char **prefixns = *prefixnsPtr;
int len, i, result;
Tcl_Obj *objPtr, *listPtr;
CheckArgs (2,3,2, "?prefixUriList?");
- if (objc == 3) {
- result = Tcl_ListObjLength (interp, objv[2], &len);
- if (result != TCL_OK || (len % 2) != 0) {
- SetResult ("The optional argument to the selectNodesNamespaces"
- " method must be a 'prefix namespace' pairs list");
- return TCL_ERROR;
- }
- i = 0;
- if (doc->prefixNSMappings) {
- while (doc->prefixNSMappings[i]) {
- FREE (doc->prefixNSMappings[i]);
- i++;
- }
- }
- if (i < len + 1) {
- if (doc->prefixNSMappings) FREE (doc->prefixNSMappings);
- doc->prefixNSMappings = MALLOC (sizeof (char*)*(len+1));
- }
- for (i = 0; i < len; i++) {
- Tcl_ListObjIndex (interp, objv[2], i, &objPtr);
- doc->prefixNSMappings[i] = tdomstrdup (Tcl_GetString (objPtr));
- }
- doc->prefixNSMappings[len] = NULL;
- Tcl_SetObjResult (interp, objv[2]);
- } else {
+ i = 0;
+ if (objc == 2) {
+ if (!prefixns) return TCL_OK;
listPtr = Tcl_NewListObj (0, NULL);
i = 0;
- if (doc->prefixNSMappings) {
- while (doc->prefixNSMappings[i]) {
- objPtr = Tcl_NewStringObj (doc->prefixNSMappings[i], -1);
- Tcl_ListObjAppendElement (interp, listPtr, objPtr);
- i++;
- }
+ while (prefixns[i]) {
+ Tcl_ListObjAppendElement (
+ interp, listPtr, Tcl_NewStringObj (prefixns[i], -1)
+ );
+ i++;
}
Tcl_SetObjResult (interp, listPtr);
+ return TCL_OK;
+ }
+ result = Tcl_ListObjLength (interp, objv[2], &len);
+ if (result != TCL_OK || (len % 2) != 0) {
+ SetResult3 ("The optional argument to the ", methodName,
+ " method must be a 'prefix namespace' pairs list");
+ return TCL_ERROR;
+ }
+ if (prefixns) {
+ while (prefixns[i]) {
+ FREE (prefixns[i]);
+ i++;
+ }
+ }
+ if (len == 0) {
+ FREE (prefixns);
+ *prefixnsPtr = NULL;
+ return TCL_OK;
+ }
+ if (i < len + 1) {
+ 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);
+ prefixns[i] = tdomstrdup (Tcl_GetString (objPtr));
}
+ prefixns[len] = NULL;
+ Tcl_SetObjResult (interp, objv[2]);
return TCL_OK;
}
/*----------------------------------------------------------------------------
| renameNodes
@@ -5925,12 +5933,13 @@
case m_cdataSectionElements:
return cdataSectionElements (doc, interp, objc, objv);
case m_selectNodesNamespaces:
- return selectNodesNamespaces (doc, interp, objc, objv);
-
+ return tcldom_prefixNSlist (&(doc->prefixNSMappings), interp, objc,
+ objv, "selectNodesNamespaces");
+
case m_renameNode:
return renameNodes (doc, interp, objc, objv);
case m_deleteXPathCache:
return deleteXPathCache (doc, interp, objc, objv);
Index: generic/tcldom.h
==================================================================
--- generic/tcldom.h
+++ generic/tcldom.h
@@ -53,10 +53,12 @@
char *objCmdName);
domNode * tcldom_getNodeFromObj(Tcl_Interp *interp, Tcl_Obj *nodeObj);
domDocument * tcldom_getDocumentFromName(Tcl_Interp *interp, char *docName,
char **errMsg);
+int tcldom_prefixNSlist (char ***prefixnsPtr, Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[], const char *methodName);
void tcldom_initialize(void);
Tcl_ObjCmdProc tcldom_DomObjCmd;
Tcl_ObjCmdProc tcldom_DocObjCmd;
Index: tests/dom.test
==================================================================
--- tests/dom.test
+++ tests/dom.test
@@ -178,10 +178,23 @@
lappend result $errMsg
$doc delete
unset doc
set result
} {1 {can't set "doc": var is read-only}}
+
+test dom-1.25 {Doc var} {
+ dom parse doc
+ dom parse doc
+ unset doc
+} {}
+
+test dom-1.26 {Doc var} {
+ dom parse doc
+ set result [catch {$doc documentElement doc}]
+ unset doc
+ set result
+} {1}
test dom-2.1 {Don't quash white space at start or end of non white space content} {
set doc [dom parse {
some content
}]
Index: tests/loadtdom.tcl
==================================================================
--- tests/loadtdom.tcl
+++ tests/loadtdom.tcl
@@ -12,10 +12,12 @@
} else {
package require Tcl 8.4-
}
package require tcltest 2.2
namespace import ::tcltest::*
+catch {tcltest::loadTestedCommands}
+
if {[catch {package require -exact tdom 0.9.2}]} {
if {[catch {load [file join [file dir [info script]] ../unix/libtdom0.9.2.so]}]} {
error "Unable to load the appropriate tDOM version!"
}
}
Index: tests/schema.test
==================================================================
--- tests/schema.test
+++ tests/schema.test
@@ -3417,10 +3417,34 @@
lappend result [s validate $xml]
}
s delete
set result
} {1 1 0 1 1 1 1 0 0 0}
+
+test schema-14.27 {base64} {
+ tdom::schema s
+ s define {
+ defelement doc {
+ text base64
+ }
+ }
+ set result [list]
+ foreach xml {
+
+ {ZVL1}
+ {zvL1}
+ {zvü1}
+ {0a BED E+9}
+ {ub1sU3==}
+ {abc}
+ {===}
+ } {
+ lappend result [s validate $xml]
+ }
+ s delete
+ set result
+} {1 1 1 0 1 1 0 0}
test schema-15.1 {constraint cmd tcl} {
tdom::schema s
s define {
defelement a {
@@ -4004,10 +4028,28 @@
tdom::schema s
s define {
defelement b {
element b1
element b2
+ }
+ defelement a {
+ element a1
+ element a2
+ }
+ }
+ set result [lsort [s info defelements]]
+ s delete
+ set result
+} {a b}
+
+test schema-17.3 {info} {
+ tdom::schema s
+ s define {
+ defelement b {
+ element b1 1 text
+ element a
+ element b2
}
defelement a {
element a1
element a2
}