tDOM

Check-in [44ebaf2b3f]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

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

Overview
Comment:Added attribute value constraining with text types.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | schema
Files: files | file ages | folders
SHA3-256: 44ebaf2b3fb2f5cd56922dc2639613c05ae2f884d780c214801ce8ba34cf694f
User & Date: rolf 2019-02-28 01:31:27
Context
2019-03-01
11:58
Added a -nocase flag to the text constraint command match (because it was easy). Small modification to the text constraint command isodate. It now accept years longer that four digits (as the xsd date types do). Added some more documentation. check-in: fa18fb363f user: rolf tags: schema
2019-02-28
01:31
Added attribute value constraining with text types. check-in: 44ebaf2b3f user: rolf tags: schema
2019-02-22
01:35
Renamed schema obj cmd method query to info and worked at bit on that. Moved all code block defines to one place while adding one. check-in: 79df08c5d7 user: rolf tags: schema
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/schema.c.

2748
2749
2750
2751
2752
2753
2754
2755

2756
2757
2758
2759
2760
2761
2762
....
2790
2791
2792
2793
2794
2795
2796


2797
2798
2799
2800
2801
2802
2803
....
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829


2830
2831
2832
2833
2834

2835
2836
2837
2838
2839
2840
2841
2842

2843
2844
2845
2846
2847
2848




2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865













2866
2867
2868





2869
2870
2871




2872

2873
2874




2875
2876
2877
2878
2879
2880
2881
....
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
static int maybeAddAttr (
    Tcl_Interp *interp,
    SchemaData *sdata,
    Tcl_Obj *nameObj,
    Tcl_Obj *namespaceObj,
    Tcl_Obj *scriptObj,
    int required

    )
{
    Tcl_HashEntry *h;
    int hnew, hnew1, i, result = TCL_OK;
    char *name, *namespace = NULL;
    SchemaAttr *attr;
    SchemaCP *cp;
................................................................................
        cp = initSchemaCP (SCHEMA_CTYPE_CHOICE, NULL, NULL);
        cp->type = SCHEMA_CTYPE_TEXT;
        REMEMBER_PATTERN (cp)
        sdata->isAttributeConstaint = 1;
        result = evalConstraints (interp, sdata, cp, scriptObj);
        sdata->isAttributeConstaint = 0;
        attr->cp = cp;


    } else {
        attr->cp = NULL;
    }
    if (!sdata->currentAttrs) {
        sdata->currentAttrs = MALLOC (sizeof(SchemaAttr*)
                                      * ATTR_ARRAY_INIT);
        sdata->attrSize = ATTR_ARRAY_INIT;
................................................................................
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[]
    )
{
    SchemaData *sdata = GETASI;
    char *quantStr;
    int len, required = 1, scriptIndex, i;
    Tcl_Obj *nsobj;



    CHECK_SI
    CHECK_TOPLEVEL

    if (clientData) {

        checkNrArgs (3,5,"Expected: name namespace"
                     " | name namespace attquant"
                     " | name namespace <constraint script>"
                     " | name namespace attquant <constraint script>");
        i = 1;
        nsobj = objv[2];
    } else {
        checkNrArgs (2,4,"Expected: name"

                     " | name attquant"
                     " | name <constraint script>"
                     " | name attquant <constraint script>");
        i = 0;
        nsobj = NULL;
    }





    if (objc == 2+i) {
        return maybeAddAttr (interp, sdata, objv[1], nsobj, NULL, 1);
    }
    quantStr = Tcl_GetStringFromObj (objv[2+i], &len);
    if (len == 1) {
        if (quantStr[0] == '?') {
            required = 0;
        } else if (quantStr[0] != '!') {
            SetResult ("Invalid attribute quant");
            return TCL_ERROR;
        }
        if (objc == 3+i) {
            return maybeAddAttr (interp, sdata, objv[1], nsobj, NULL,
                                 required);
        }
        scriptIndex = 3+i;













    } else {
        if (objc == 4+i) {
            SetResult ("Invalid attribute quant");





            return TCL_ERROR;
        }
        scriptIndex = 2+i;




    }

    return maybeAddAttr (interp, sdata, objv[1], nsobj,
                         objv[scriptIndex], required);




}

static int
NamespacePatternObjCmd (
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
................................................................................
    } else if (objc == 2) {
        quant = SCHEMA_CQUANT_ONE;
        pattern = initSchemaCP (SCHEMA_CTYPE_CHOICE, NULL, NULL);
        pattern->type = SCHEMA_CTYPE_TEXT;
    } else {
        h = Tcl_FindHashEntry (&sdata->textDef, Tcl_GetString (objv[2]));
        if (!h) {
            SetResult ("Unknown text type");
            return TCL_ERROR;
        }
        pattern = (SchemaCP *) Tcl_GetHashValue (h);
        sdata->cp->flags |= CONSTRAINT_TEXT_CHILD;
    }
    if (objc < 3) {
        REMEMBER_PATTERN (pattern)






|
>







 







>
>







 







|
|
|
>
>





>
|

|
|
<
|

|
>

|
<
|
|

>
>
>
>
|
|
|

|

|

|



|
|
|

<
>
>
>
>
>
>
>
>
>
>
>
>
>
|
<
|
>
>
>
>
>


<
>
>
>
>
|
>
|
|
>
>
>
>







 







|







2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
....
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
....
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844

2845
2846
2847
2848
2849
2850

2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873

2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887

2888
2889
2890
2891
2892
2893
2894
2895

2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
....
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
static int maybeAddAttr (
    Tcl_Interp *interp,
    SchemaData *sdata,
    Tcl_Obj *nameObj,
    Tcl_Obj *namespaceObj,
    Tcl_Obj *scriptObj,
    int required,
    SchemaCP *type
    )
{
    Tcl_HashEntry *h;
    int hnew, hnew1, i, result = TCL_OK;
    char *name, *namespace = NULL;
    SchemaAttr *attr;
    SchemaCP *cp;
................................................................................
        cp = initSchemaCP (SCHEMA_CTYPE_CHOICE, NULL, NULL);
        cp->type = SCHEMA_CTYPE_TEXT;
        REMEMBER_PATTERN (cp)
        sdata->isAttributeConstaint = 1;
        result = evalConstraints (interp, sdata, cp, scriptObj);
        sdata->isAttributeConstaint = 0;
        attr->cp = cp;
    } else if (type) {
        attr->cp = type;
    } else {
        attr->cp = NULL;
    }
    if (!sdata->currentAttrs) {
        sdata->currentAttrs = MALLOC (sizeof(SchemaAttr*)
                                      * ATTR_ARRAY_INIT);
        sdata->attrSize = ATTR_ARRAY_INIT;
................................................................................
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[]
    )
{
    SchemaData *sdata = GETASI;
    char *str;
    int len, required = 1;
    Tcl_Obj *nsObj, *nameObj;
    Tcl_HashEntry *h;
    SchemaCP *type;

    CHECK_SI
    CHECK_TOPLEVEL

    if (clientData) {
        checkNrArgs (3,6,"Expected:"
                     "  name namespace"
                     " | name namespace attquant"
                     " | name namespace ?attquant? <constraint script>"
                     " | name namespace ?attquant? \"type\" typename");

        nsObj = objv[2];
    } else {
        checkNrArgs (2,5,"Expected:"
                     "  name"
                     " | name attquant"
                     " | name ?attquant? <constraint script>"

                     " | name ?attquant? \"type\" typename");
        nsObj = NULL;
    }
    nameObj = objv[1];
    if (clientData) {
        objv++;
        objc--;
    }
    if (objc == 2) {
        return maybeAddAttr (interp, sdata, nameObj, nsObj, NULL, 1, NULL);
    }
    str = Tcl_GetStringFromObj (objv[2], &len);
    if (len == 1) {
        if (str[0] == '?') {
            required = 0;
        } else if (str[0] != '!') {
            SetResult ("Invalid attribute quant");
            return TCL_ERROR;
        }
        if (objc == 3) {
            return maybeAddAttr (interp, sdata, nameObj, nsObj, NULL,
                                 required, NULL);
        }

        objv++;
        objc--;
        str = Tcl_GetStringFromObj (objv[2], &len);
    }
    if (objc == 4) {
        if (len != 4
            || strcmp("type", str) != 0) {
            if (clientData) {
                SetResult ("Expected:"
                           "  name namespace"
                           " | name namespace attquant"
                           " | name namespace ?attquant? <constraint script>"
                           " | name namespace ?attquant? \"type\" typename");
            } else {

                SetResult ("Expected:"
                           "  name"
                           " | name attquant"
                           " | name ?attquant? <constraint script>"
                           " | name ?attquant? \"type\" typename");
            }
            return TCL_ERROR;
        }

        h = Tcl_FindHashEntry (&sdata->textDef, Tcl_GetString (objv[3]));
        if (!h) {
            SetResult3 ("Unknown text type \"", Tcl_GetString (objv[3]), "\"");
            return TCL_ERROR;
        }
        type = (SchemaCP *) Tcl_GetHashValue (h);
        return maybeAddAttr (interp, sdata, nameObj, nsObj, NULL,
                             required, type);        
    } else {
        return maybeAddAttr (interp, sdata, nameObj, nsObj, objv[2],
                             required, NULL);
    }
}

static int
NamespacePatternObjCmd (
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
................................................................................
    } else if (objc == 2) {
        quant = SCHEMA_CQUANT_ONE;
        pattern = initSchemaCP (SCHEMA_CTYPE_CHOICE, NULL, NULL);
        pattern->type = SCHEMA_CTYPE_TEXT;
    } else {
        h = Tcl_FindHashEntry (&sdata->textDef, Tcl_GetString (objv[2]));
        if (!h) {
            SetResult3 ("Unknown text type \"", Tcl_GetString (objv[2]), "\"");
            return TCL_ERROR;
        }
        pattern = (SchemaCP *) Tcl_GetHashValue (h);
        sdata->cp->flags |= CONSTRAINT_TEXT_CHILD;
    }
    if (objc < 3) {
        REMEMBER_PATTERN (pattern)

Changes to tests/schema.test.

2935
2936
2937
2938
2939
2940
2941











































































































2942
2943
2944
2945
2946
2947
2948
            $doc delete
        }
        lappend result $rc
    }
    s delete
    set result
} {0 1 0 1 0 1 0 1 0 1 1 0 1 0 1 0 1 0 0 1 0 1 1 0}












































































































test schema-16.1 {interleave} {
    tdom::schema s
    s define {
        defelement doc {
            interleave {
                element a






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







2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
            $doc delete
        }
        lappend result $rc
    }
    s delete
    set result
} {0 1 0 1 0 1 0 1 0 1 1 0 1 0 1 0 1 0 0 1 0 1 1 0}

test schema-14.19 {deftext} {
    tdom::schema s
    s deftext len2-4 {
        minLength 2
        maxLength 4
    }
    s defelement doc {
        element e
    }
    s defelement e {
        attribute this type len2-4
        attribute foo ? type len2-4
    }
    set result [list]
    foreach xml {
        <doc><e/></doc>
        {<doc><e foo="bar"/></doc>}
        {<doc><e this="bar"/></doc>}
        {<doc><e this=""/></doc>}
        {<doc><e this="12" foo="bar"/></doc>}
        {<doc><e this="12" foo="b"/></doc>}
        {<doc><e this="1234"/></doc>}
        {<doc><e this="12345"/></doc>}
        {<doc><e this="12345alkajsdlfjkals" and="this"/></doc>}
        {<doc><e and="this" this="12345alkajsdlfjkals"/></doc>}
    } {
        lappend result [s validate $xml errMsg]
        set rc [catch {dom parse -validateCmd s $xml doc}]
        if {$rc == 0} {
            $doc delete
        }
        lappend result $rc
    }
    s delete
    set result
} {0 1 0 1 1 0 0 1 1 0 0 1 1 0 0 1 0 1 0 1}

test schema-14.19a {deftext} {
    tdom::schema s
    s deftext len2-4 {
        minLength 2
        maxLength 4
    }
    s defelement doc {
        element e ! {
            attribute this type len2-4
            attribute foo ? type len2-4
        }
    }
    set result [list]
    foreach xml {
        <doc><e/></doc>
        {<doc><e foo="bar"/></doc>}
        {<doc><e this="bar"/></doc>}
        {<doc><e this=""/></doc>}
        {<doc><e this="12" foo="bar"/></doc>}
        {<doc><e this="12" foo="b"/></doc>}
        {<doc><e this="1234"/></doc>}
        {<doc><e this="12345"/></doc>}
        {<doc><e this="12345alkajsdlfjkals" and="this"/></doc>}
        {<doc><e and="this" this="12345alkajsdlfjkals"/></doc>}
    } {
        lappend result [s validate $xml]
        set rc [catch {dom parse -validateCmd s $xml doc}]
        if {$rc == 0} {
            $doc delete
        }
        lappend result $rc
    }
    s delete
    set result
} {0 1 0 1 1 0 0 1 1 0 0 1 1 0 0 1 0 1 0 1}

test schema-14.20 {deftext} {
    tdom::schema s
    s deftext len2-4 {
        minLength 2
        maxLength 4
    }
    s defelement doc {
        element e ! {
            nsattribute this http://tdom.org/test {
                minLength 2
                maxLength 4
            }
            nsattribute foo http://tdom.org/test ? type len2-4
        }
    }
    set result [list]
    foreach xml {
        <doc><e/></doc>
        {<doc xmlns:ns1="http://tdom.org/test"><e ns1:foo="bar"/></doc>}
        {<doc xmlns:ns1="http://tdom.org/test"><e ns1:this="bar"/></doc>}
        {<doc xmlns:ns1="http://tdom.org/test"><e ns1:this=""/></doc>}
        {<doc xmlns:ns1="http://tdom.org/test"><e ns1:this="12" ns1:foo="bar"/></doc>}
        {<doc xmlns:ns1="http://tdom.org/test"><e ns1:this="12" ns1:foo="b"/></doc>}
        {<doc xmlns:ns1="http://tdom.org/test"><e ns1:this="1234"/></doc>}
        {<doc xmlns:ns1="http://tdom.org/test"><e ns1:this="12345"/></doc>}
        {<doc xmlns:ns1="http://tdom.org/test"><e ns1:this="12345alkajsdlfjkals" ns1:and="this"/></doc>}
        {<doc xmlns:ns1="http://tdom.org/test"><e ns1:and="this" ns1:this="12345alkajsdlfjkals"/></doc>}
    } {
        lappend result [s validate $xml]
    }
    s delete
    set result
} {0 0 1 0 1 0 1 0 0 0}

test schema-16.1 {interleave} {
    tdom::schema s
    s define {
        defelement doc {
            interleave {
                element a