tDOM manual: schema

NAME

tdom::schema -
Create a schema validation command
SYNOPSIS

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
     otherwise do.
The valid methods of the created commands are:

+      
+          
+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
+          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
+          any namespace URI arguments are used literally. This is the
+          default.
+          
+      
+
       
         
 defelement name ?namespace? <definition script>
 
         This method defines the element name (optional in
@@ -167,11 +187,11 @@
         READY (while preserving the defined grammer).
       
 
     
 
-  Schema definition scripts
Schema definition scripts are ordinary Tcl scripts that are
+  
Schema definition scripts
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 +337,11 @@
         other definition script command and will raise error, if you
         call it there.
       
     
 
-  
Quantity specifier
Serveral schema definition commands expects a quantifier as
+  
Quantity specifier
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 +382,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.
 
-  Text constraint scripts
The text constraint commands are:

+  Text constraint scripts
The text constraint commands are:

       
         isint
         
       
 
@@ -522,15 +542,15 @@
         references within the document to one ID are possible.
       
       
         base64
         This text constraint match if text is valid according to
-        RFC 4648RFC 4648.
+        RFC 4648.
       
     
   
-  Exampels
The XML Schema Part 0: Primer Second Edition
+  
Exampels
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
@@ -180,10 +180,24 @@
 the \fI-validateCmd\fR option of the \fIdom parse\fR and the
 \&\fIexpat\fR commands to enable validation additional to what they
 otherwise do.
 .PP
 The valid methods of the created commands are:
+.TP
+\&\fB\fBprefixns\fP \fI?prefixUriList?\fB
+\&\fRThis 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
+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
+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
 the namespace \fInamespace\fR) in the schema. The
 \&\fIdefinition script\fR is evaluated and defines the content
@@ -540,11 +554,11 @@
 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.
+RFC 4648.
 .SH Exampels
 .PP
 .UR "https://www.w3.org/TR/xmlschema-0/"
 
 .UE

Index: doc/schema.xml
==================================================================
--- doc/schema.xml
+++ doc/schema.xml
@@ -26,10 +26,28 @@
     otherwise do.
 
     The valid methods of the created commands are:
 
     
+      
+          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
+          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
+          any namespace URI arguments are used literally. This is the
+          default.
+          
+      
+
       
         defelement name ?namespace? <definition script>
         This method defines the element name (optional in
         the namespace namespace) in the schema. The
         definition script is evaluated and defines the content
@@ -481,11 +499,11 @@
         references within the document to one ID are possible.
       
       
         base64
         This text constraint match if text is valid according to
-        RFC 4648RFC 4648.
+        RFC 4648.
       
     
   
   
   

Index: generic/schema.c
==================================================================
--- generic/schema.c
+++ generic/schema.c
@@ -424,10 +424,11 @@
     memset (sdata, 0, sizeof(SchemaData));
     name = Tcl_GetStringFromObj (cmdNameObj, &len);
     sdata->self = Tcl_NewStringObj (name, len);
     Tcl_IncrRefCount (sdata->self);
     Tcl_InitHashTable (&sdata->element, TCL_STRING_KEYS);
+    Tcl_InitHashTable (&sdata->prefix, TCL_STRING_KEYS);
     Tcl_InitHashTable (&sdata->pattern, TCL_STRING_KEYS);
     Tcl_InitHashTable (&sdata->attrNames, TCL_STRING_KEYS);
     Tcl_InitHashTable (&sdata->namespace, TCL_STRING_KEYS);
     Tcl_InitHashTable (&sdata->textDef, TCL_STRING_KEYS);
     sdata->emptyNamespace = Tcl_CreateHashEntry (
@@ -478,13 +479,21 @@
         sdata->cleanupAfterEval = 1;
         return;
     }
     Tcl_DecrRefCount (sdata->self);
     if (sdata->start) FREE (sdata->start);
-    if (sdata->startNamespace) FREE (sdata->startNamespace);
+    if (sdata->prefixns) {
+        i = 0;
+        while (sdata->prefixns[i]) {
+            FREE (sdata->prefixns[i]);
+            i++;
+        }
+        FREE (sdata->prefixns);
+    }
     Tcl_DeleteHashTable (&sdata->namespace);
     Tcl_DeleteHashTable (&sdata->element);
+    Tcl_DeleteHashTable (&sdata->prefix);
     Tcl_DeleteHashTable (&sdata->pattern);
     Tcl_DeleteHashTable (&sdata->attrNames);
     Tcl_DeleteHashTable (&sdata->textDef);
     for (i = 0; i < sdata->numPatternList; i++) {
         freeSchemaCP (sdata->patternList[i]);
@@ -999,10 +1008,31 @@
         }
     }
     
     return -1;
 }
+
+static void *
+getNamespacePtr (
+    SchemaData *sdata,
+    char *ns
+    )
+{
+    Tcl_HashEntry *h;
+    int hnew;
+
+    if (!ns) return NULL;
+    h = Tcl_FindHashEntry (&sdata->prefix, ns);
+    if (h) {
+        return Tcl_GetHashValue (h);
+    }
+    h = Tcl_CreateHashEntry (&sdata->namespace, ns, &hnew);
+    if (h != sdata->emptyNamespace) {
+        return Tcl_GetHashKey (&sdata->namespace, h);
+    }
+    return NULL;
+}
 
 int
 probeElement (
     Tcl_Interp *interp,
     SchemaData *sdata,
@@ -1027,24 +1057,11 @@
     DBG(
         fprintf (stderr, "probeElement: look if '%s' in ns '%s' match\n",
                  name, (char *)namespace);
         );
 
-    if (namespace) {
-        entryPtr = Tcl_FindHashEntry (&sdata->namespace, (char *)namespace);
-        if (!entryPtr) {
-            SetResult ("No elements defined in this namespace");
-            return TCL_ERROR;
-        }
-        if (entryPtr == sdata->emptyNamespace) {
-            namespacePtr = NULL;
-        } else {
-            namespacePtr = Tcl_GetHashKey (&sdata->namespace, entryPtr);
-        }
-    } else {
-        namespacePtr = NULL;
-    }
+    namespacePtr = getNamespacePtr (sdata, namespace);
     entryPtr = Tcl_FindHashEntry (&sdata->element, name);
     if (entryPtr) {
         namePtr = Tcl_GetHashKey (&sdata->element, entryPtr);
     } else {
         namePtr = NULL;
@@ -1056,11 +1073,11 @@
             if (strcmp (name, sdata->start) != 0) {
                 SetResult ("Root element doesn't match");
                 return TCL_ERROR;
             }
             if (namespace) {
-                if (!sdata->startNamespace ||
+                if (!sdata->startNamespace||
                     strcmp (namespace, sdata->startNamespace) != 0) {
                     SetResult ("Root element namespace doesn't match");
                     return TCL_ERROR;
                 }
             } else {
@@ -2241,11 +2258,11 @@
     int            result = TCL_OK, forwardDef = 0, i = 0;
     int            savedDefineToplevel, type, len;
     unsigned int   savedNumPatternList;
     SchemaData    *savedsdata = NULL, *sdata = (SchemaData *) clientData;
     Tcl_HashTable *hashTable;
-    Tcl_HashEntry *h;
+    Tcl_HashEntry *h, *h1;
     SchemaCP      *pattern, *current = NULL;
     void          *namespacePtr, *savedNamespacePtr;
     char          *xmlstr, *errMsg;
     domDocument   *doc;
     domNode       *node;
@@ -2252,16 +2269,17 @@
 
     static const char *schemaInstanceMethods[] = {
         "defelement", "defpattern",  "start",   "event", "delete",
         "nrForwardDefinitions",      "state",   "reset", "define",
         "validate",   "domvalidate", "deftext", "info",  "reportcmd",
-        NULL
+        "prefixns",   NULL
     };
     enum schemaInstanceMethod {
         m_defelement,  m_defpattern,  m_start,   m_event, m_delete,
         m_nrForwardDefinitions,       m_state,   m_reset, m_define,
-        m_validate,    m_domvalidate, m_deftext, m_info,  m_reportcmd
+        m_validate,    m_domvalidate, m_deftext, m_info,  m_reportcmd,
+        m_prefixns
     };
 
     static const char *eventKeywords[] = {
         "start", "end", "text", NULL
     };
@@ -2313,15 +2331,11 @@
         savedNumPatternList = sdata->numPatternList;
         namespacePtr = NULL;
         patternIndex = 3-i;
         if (objc == 5-i) {
             patternIndex = 4-i;
-            h = Tcl_CreateHashEntry (&sdata->namespace,
-                                            Tcl_GetString (objv[3-i]), &hnew);
-            if (h != sdata->emptyNamespace) {
-                namespacePtr = Tcl_GetHashKey (&sdata->namespace, h);
-            }
+            namespacePtr = getNamespacePtr (sdata, Tcl_GetString (objv[3-i]));
         }
         h = Tcl_CreateHashEntry (hashTable, Tcl_GetString (objv[2-i]), &hnew);
         pattern = NULL;
         if (!hnew) {
             pattern = (SchemaCP *) Tcl_GetHashValue (h);
@@ -2463,23 +2477,18 @@
         }
         if (sdata->start) {
             FREE (sdata->start);
         }
         if (objc == 3-i && strcmp (Tcl_GetString (objv[2-i]), "") == 0) {
-            if (sdata->startNamespace) {
-                FREE (sdata->startNamespace);
-            }
+            sdata->startNamespace = NULL;
             sdata->start = NULL;
             break;
         }
         sdata->start = tdomstrdup (Tcl_GetString (objv[2-i]));
         if (objc == 4-i) {
-            if (sdata->startNamespace) {
-                FREE (sdata->startNamespace);
-            }
             sdata->startNamespace =
-                tdomstrdup (Tcl_GetString (objv[3-i]));
+                getNamespacePtr (sdata, Tcl_GetString (objv[3-i]));
         }
         break;
 
     case m_event:
         CHECK_EVAL
@@ -2498,20 +2507,14 @@
             if (objc < 4 && objc > 6) {
                 Tcl_WrongNumArgs (interp, 3, objv, ""
                     "?? ??");
                 return TCL_ERROR;
             }
+            namespacePtr = NULL;
             if (objc == 6) {
-                h = Tcl_FindHashEntry (&sdata->namespace,
-                                              Tcl_GetString (objv[5]));
-                if (h && h != sdata->emptyNamespace) {
-                     namespacePtr = Tcl_GetHashKey (&sdata->namespace, h);
-                } else {
-                    namespacePtr = NULL;
-                }
-            } else {
-                namespacePtr = NULL;
+                namespacePtr = getNamespacePtr (sdata,
+                                                Tcl_GetString (objv[5]));
             }
             result = probeElement (interp, sdata, Tcl_GetString (objv[3]),
                                    namespacePtr);
             break;
         case k_elementend:
@@ -2644,10 +2647,30 @@
         }
         sdata->reportCmd = objv[2];
         Tcl_IncrRefCount (sdata->reportCmd);
         break;
 
+    case m_prefixns:
+        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);
+                h1 = Tcl_CreateHashEntry (&sdata->prefix,
+                                          sdata->prefixns[i], &hnew);
+                Tcl_SetHashValue (h1, Tcl_GetHashKey (&sdata->namespace, h));
+                i += 2;
+            }
+        }
+        break;
+        
     default:
         Tcl_SetResult (interp, "unknown method", NULL);
         result = TCL_ERROR;
         break;
 
@@ -3043,21 +3066,18 @@
     int required,
     SchemaCP *type
     )
 {
     Tcl_HashEntry *h;
-    int hnew, hnew1, i, result = TCL_OK;
+    int hnew, i, result = TCL_OK;
     char *name, *namespace = NULL;
     SchemaAttr *attr;
     SchemaCP *cp;
 
     if (namespaceObj) {
-        h = Tcl_CreateHashEntry (&sdata->namespace,
-                                 Tcl_GetString (namespaceObj), &hnew1);
-        if (h != sdata->emptyNamespace) {
-            namespace = Tcl_GetHashKey (&sdata->namespace, h);
-        }
+        namespace = getNamespacePtr (sdata,
+                                     Tcl_GetString (namespaceObj));
     }
     h = Tcl_CreateHashEntry (&sdata->attrNames,
                              Tcl_GetString (nameObj), &hnew);
     name = Tcl_GetHashKey (&sdata->attrNames, h);
     if (!hnew) {
@@ -3203,26 +3223,19 @@
     Tcl_Obj *const objv[]
     )
 {
     SchemaData *sdata = GETASI;
     char *currentNamespace;
-    Tcl_HashEntry *entryPtr;
-    int hnew, result;
+    int result;
 
     CHECK_SI
     CHECK_TOPLEVEL
     checkNrArgs (3,3,"Expected: namespace pattern");
 
     currentNamespace = sdata->currentNamespace;
-    entryPtr = Tcl_CreateHashEntry (&sdata->namespace,
-                                    Tcl_GetString(objv[1]), &hnew);
-    if (entryPtr == sdata->emptyNamespace) {
-        sdata->currentNamespace = NULL;
-    } else {
-        sdata->currentNamespace = (char *)
-            Tcl_GetHashKey (&sdata->namespace, entryPtr);
-    }
+    sdata->currentNamespace =
+        getNamespacePtr (sdata, Tcl_GetString(objv[1]));
     sdata->currentEvals++;
     result = Tcl_EvalObjEx (interp, objv[2], TCL_EVAL_DIRECT);
     sdata->currentEvals--;
     sdata->currentNamespace = currentNamespace;
     return result;

Index: generic/schema.h
==================================================================
--- generic/schema.h
+++ generic/schema.h
@@ -110,10 +110,12 @@
     char *start;
     char *startNamespace;
     Tcl_HashTable element;
     Tcl_HashTable namespace;
     Tcl_HashEntry *emptyNamespace;
+    char **prefixns;
+    Tcl_HashTable prefix;
     Tcl_HashTable pattern;
     Tcl_HashTable attrNames;
     Tcl_HashTable textDef;
     SchemaCP **patternList; 
     unsigned int numPatternList;

Index: tests/schema.test
==================================================================
--- tests/schema.test
+++ tests/schema.test
@@ -230,10 +230,34 @@
         lappend result [s validate $xml]
     }
     s delete
     set result
 } {1 1 1 0}
+
+test schema-1.14a {define start w/ namespace} {
+    tdom::schema create s
+    s prefixns {ns1 http://foo.bar}
+    s start doc ns1
+    s defelement doc ns1 {
+        element a
+        element b
+    }
+    foreach elm {a b} {
+        s defelement $elm ns1 {}
+    }
+    set result [list]
+    foreach xml {
+        {}
+        {}
+        {}
+        {}
+    } {
+        lappend result [s validate $xml]
+    }
+    s delete
+    set result
+} {1 1 1 0}
 
 test schema-1.15 {call structure constraint outside define/defelement} {
     set result [catch {tdom::schema::element foo} errMsg]
     lappend result $errMsg
     tdom::schema create grammar
@@ -2202,10 +2226,26 @@
     }
     set result [s validate {} errMsg]
     s delete
     lappend result $errMsg
 } {1 {}}
+
+test schema-11.4_1 {attribute} {
+    tdom::schema create s
+    s prefixns {1 http://www.w3.org/XML/1998/namespace}
+    s define {
+        defelement doc {
+            element e 1 {
+                attribute foo
+                nsattribute lang 1 ?
+            }
+        }
+    }
+    set result [s validate {} errMsg]
+    s delete
+    lappend result $errMsg
+} {1 {}}
 
 test schema-11.4a {attribute} {
     tdom::schema create s
     s define {
         defelement doc {
@@ -2249,10 +2289,27 @@
     set result [catch {set doc [dom parse -validateCmd s {}]}]
     s delete
     $doc delete
     set result
 } 0
+
+test schema-11.5a {nsattribute} {
+    tdom::schema create s
+    s prefixns {ns1 http://www.w3.org/XML/1998/namespace}
+    s define {
+        defelement doc {
+            element e 1 {
+                attribute foo
+                nsattribute lang ns1 ?
+            }
+        }
+    }
+    set result [catch {set doc [dom parse -validateCmd s {}]}]
+    s delete
+    $doc delete
+    set result
+} 0
 
 test schema-11.6 {nsattribute} {
     tdom::schema create s
     s define {
         defelement doc {
@@ -2259,10 +2316,36 @@
             element e 1 {
                 attribute foo
                 nsattribute lang http://www.w3.org/XML/1998/namespace
             }
         }
+    }
+    set result [list]
+    foreach xml {
+        {}
+        {}
+        {}
+        {}
+    } {
+        lappend result [catch {set doc [dom parse -validateCmd s $xml]} errMsg]
+        lappend result $errMsg
+        s reset
+    }
+    s delete
+    set result
+} {1 {Missing mandatory attribute(s): http://www.w3.org/XML/1998/namespace:lang, referenced at line 1 character 19} 1 {Missing mandatory attribute(s): foo, referenced at line 1 character 23} 1 {Unknown attribute "unknown", referenced at line 1 character 24} 1 {Missing mandatory attribute(s): foo http://www.w3.org/XML/1998/namespace:lang, referenced at line 1 character 9}}
+
+test schema-11.6 {nsattribute} {
+    tdom::schema create s
+    s prefixns {ns1 http://www.w3.org/XML/1998/namespace}
+    s define {
+        defelement doc {
+            element e 1 {
+                attribute foo
+                nsattribute lang ns1
+            }
+        }
     }
     set result [list]
     foreach xml {
         {}
         {}
@@ -2415,10 +2498,63 @@
             element email
         }
         foreach e {name email} {
             defelement $e http://foo.bar {text}
         }
+    }
+    set doc [dom parse {
+
+  
+    John Smith
+    js@example.com
+  
+  
+    Fred Bloggs
+    fb@example.net
+  
+        
+    }]
+    set result [s domvalidate $doc]
+    lappend result [s domvalidate [$doc documentElement]]
+    lappend result [s domvalidate [[$doc documentElement] firstChild]]
+    lappend result [s domvalidate [[[$doc documentElement] firstChild] firstChild]]
+    $doc delete
+    set doc [dom parse {
+
+  
+    John Smith
+    js@example.com
+  
+  
+    Fred Bloggs
+    fb@example.net
+  
+        
+}]
+    lappend result [s domvalidate $doc]
+    lappend result [s domvalidate [$doc documentElement]]
+    lappend result [s domvalidate [[$doc documentElement] firstChild]]
+    lappend result [s domvalidate [[[$doc documentElement] firstChild] firstChild]]
+    $doc delete
+    s delete
+    set result
+} {1 1 1 1 1 1 1 1}
+
+test schema-12.5a {domvalidate doch w/ xml namespace} {
+    tdom::schema s 
+    s prefixns {fb http://foo.bar}
+    s define {
+        defelement addressBook fb {
+            element card *
+        }
+        defelement card fb {
+            element name
+            element email
+        }
+        foreach e {name email} {
+            defelement $e fb {text}
+        }
     }
     set doc [dom parse {
 
   
     John Smith