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

Overview
Comment:Added text constraint command length.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | schema
Files: files | file ages | folders
SHA3-256: cc382337fc4e00fbf13e1c426e28831fe2fad29dfc9b7fb16daa1165bd4ae490
User & Date: rolf 2020-08-01 23:33:55
Context
2020-08-02
23:37
Added test. check-in: fc793568d2 user: rolf tags: schema
2020-08-01
23:33
Added text constraint command length. check-in: cc382337fc user: rolf tags: schema
2020-07-31
10:59
Minor documentation and test suite work. check-in: a14c1bb515 user: rolf tags: schema
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to doc/schema.xml.

1059
1060
1061
1062
1063
1064
1065






1066
1067
1068
1069
1070
1071
1072
            <url>https://www.tcl.tk/man/tcl8.6/TclCmd/string.htm#M35</url>.</desc>
        </commanddef>
        <commanddef>
            <command><cmd>regexp</cmd> <m>expression</m></command>
            <desc>This text constraint match if the text value match the
            regular expression given as argument. <url>https://www.tcl.tk/man/tcl8.6/TclCmd/re_syntax.htm</url> describes the regular expression syntax</desc>
        </commanddef>






        <commanddef>
            <command><cmd>maxLength</cmd> <m>length</m></command>
            <desc>This text constraint match if the length of the text
            value (in characters, not bytes) is at most <m>length</m>. The
            length argument must be an integer greater zero.</desc>
        </commanddef>
        <commanddef>







>
>
>
>
>
>







1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
            <url>https://www.tcl.tk/man/tcl8.6/TclCmd/string.htm#M35</url>.</desc>
        </commanddef>
        <commanddef>
            <command><cmd>regexp</cmd> <m>expression</m></command>
            <desc>This text constraint match if the text value match the
            regular expression given as argument. <url>https://www.tcl.tk/man/tcl8.6/TclCmd/re_syntax.htm</url> describes the regular expression syntax</desc>
        </commanddef>
        <commanddef>
            <command><cmd>length</cmd> <m>length</m></command>
            <desc>This text constraint match if the length of the text
            value (in characters, not bytes) is <m>length</m>. The
            length argument must be a positive integer or zero.</desc>
        </commanddef>
        <commanddef>
            <command><cmd>maxLength</cmd> <m>length</m></command>
            <desc>This text constraint match if the length of the text
            value (in characters, not bytes) is at most <m>length</m>. The
            length argument must be an integer greater zero.</desc>
        </commanddef>
        <commanddef>

Changes to generic/schema.c.

8411
8412
8413
8414
8415
8416
8417


















































8418
8419
8420
8421
8422
8423
8424
....
8634
8635
8636
8637
8638
8639
8640


8641
8642
8643
8644
8645
8646
8647

    CHECK_TI
    checkNrArgs (1,1,"No arguments expected");
    ADD_CONSTRAINT (sdata, sc)
    sc->constraint = durationImpl;
    return TCL_OK;
}



















































static int
dateObjCmd (
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[]
................................................................................
                          unsignedIntTypesTCObjCmd, (ClientData) 3, NULL);
    Tcl_CreateObjCommand (interp,"tdom::schema::text::setvar",
                          setvarTCObjCmd, (ClientData) 3, NULL);
    Tcl_CreateObjCommand (interp,"tdom::schema::text::whitespace",
                          whitespaceTCObjCmd, (ClientData) 3, NULL);
    Tcl_CreateObjCommand (interp,"tdom::schema::text::not",
                          notTCObjCmd, (ClientData) 3, NULL);



    /* Exposed text type commands */
    Tcl_CreateObjCommand (interp,"tdom::type::date",
                          dateObjCmd, NULL, NULL);
    Tcl_CreateObjCommand (interp,"tdom::type::dateTime",
                          dateTimeObjCmd, NULL, NULL);
    Tcl_CreateObjCommand (interp,"tdom::type::time",







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







 







>
>







8411
8412
8413
8414
8415
8416
8417
8418
8419
8420
8421
8422
8423
8424
8425
8426
8427
8428
8429
8430
8431
8432
8433
8434
8435
8436
8437
8438
8439
8440
8441
8442
8443
8444
8445
8446
8447
8448
8449
8450
8451
8452
8453
8454
8455
8456
8457
8458
8459
8460
8461
8462
8463
8464
8465
8466
8467
8468
8469
8470
8471
8472
8473
8474
....
8684
8685
8686
8687
8688
8689
8690
8691
8692
8693
8694
8695
8696
8697
8698
8699

    CHECK_TI
    checkNrArgs (1,1,"No arguments expected");
    ADD_CONSTRAINT (sdata, sc)
    sc->constraint = durationImpl;
    return TCL_OK;
}

static int
lengthImpl (
    Tcl_Interp *interp,
    void *constraintData,
    char *text
    )
{
    unsigned int length = PTR2UINT(constraintData);
    int len = 0, clen;
    while (*text != '\0') {
        clen = UTF8_CHAR_LEN (*text);
        if (!clen) {
            SetResult ("Invalid UTF-8 character");
            return 0;
        }
        len++;
        if (len > length) return 0;
        text += clen;
    }
    if (len == length) return 1;
    return 0;
}

static int
lengthTCObjCmd (
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[]
    )
{
    SchemaData *sdata = GETASI;
    SchemaConstraint *sc;
    int len;

    CHECK_TI
    checkNrArgs (2,2,"Expected: <length as integer>");
    if (Tcl_GetIntFromObj (interp, objv[1], &len) != TCL_OK) {
        SetResult ("Expected: <length as integer>");
        return TCL_ERROR;
    }
    if (len < 0) {
        SetResult ("The length must be at least 0");
    }
    ADD_CONSTRAINT (sdata, sc)
    sc->constraint = lengthImpl;
    sc->constraintData = UINT2PTR(len);
    return TCL_OK;
}

static int
dateObjCmd (
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[]
................................................................................
                          unsignedIntTypesTCObjCmd, (ClientData) 3, NULL);
    Tcl_CreateObjCommand (interp,"tdom::schema::text::setvar",
                          setvarTCObjCmd, (ClientData) 3, NULL);
    Tcl_CreateObjCommand (interp,"tdom::schema::text::whitespace",
                          whitespaceTCObjCmd, (ClientData) 3, NULL);
    Tcl_CreateObjCommand (interp,"tdom::schema::text::not",
                          notTCObjCmd, (ClientData) 3, NULL);
    Tcl_CreateObjCommand (interp,"tdom::schema::text::length",
                          lengthTCObjCmd, (ClientData) 3, NULL);

    /* Exposed text type commands */
    Tcl_CreateObjCommand (interp,"tdom::type::date",
                          dateObjCmd, NULL, NULL);
    Tcl_CreateObjCommand (interp,"tdom::type::dateTime",
                          dateTimeObjCmd, NULL, NULL);
    Tcl_CreateObjCommand (interp,"tdom::type::time",

Changes to tests/schema.test.

6024
6025
6026
6027
6028
6029
6030

















































6031
6032
6033
6034
6035
6036
6037
        "<doc>T15:20:17.0-02:00 </doc>"
    } {
        lappend result [s validate $xml]
    }
    s delete
    set result
} {0 0 0 0 1 1 1 1 1 1 1 0 0 0 0 0 0 1 0 0 0 1 1 0 1 0 0}


















































test schema-15.1 {constraint cmd tcl} {
    tdom::schema s
    s define {
        defelement a {
            tcl append ::schema-15.1 [self]
            element b







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







6024
6025
6026
6027
6028
6029
6030
6031
6032
6033
6034
6035
6036
6037
6038
6039
6040
6041
6042
6043
6044
6045
6046
6047
6048
6049
6050
6051
6052
6053
6054
6055
6056
6057
6058
6059
6060
6061
6062
6063
6064
6065
6066
6067
6068
6069
6070
6071
6072
6073
6074
6075
6076
6077
6078
6079
6080
6081
6082
6083
6084
6085
6086
        "<doc>T15:20:17.0-02:00 </doc>"
    } {
        lappend result [s validate $xml]
    }
    s delete
    set result
} {0 0 0 0 1 1 1 1 1 1 1 0 0 0 0 0 0 1 0 0 0 1 1 0 1 0 0}

test schema-14.56 {length} {
    tdom::schema s
    s defelement doc {
        element e ! {
            text {length 2}
        }
    }
    set result [list]
    foreach xml {
        <doc><e/></doc>
        <doc><e></e></doc>
        {<doc><e>1</e></doc>}
        {<doc><e>12</e></doc>}
        {<doc><e>  </e></doc>}
        {<doc><e>123</e></doc>}
        {<doc><e>1&#x1234;</e></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 0 1 1 0 1 0 0 1 1 0}

test schema-14.57 {length} {
    tdom::schema s
    s defelement doc {
        element e ! {
            text {length 0}
        }
    }
    set result [list]
    foreach xml {
        <doc><e/></doc>
        <doc><e></e></doc>
        {<doc><e>1</e></doc>}
        {<doc><e>12</e></doc>}
        {<doc><e>  </e></doc>}
    } {
        lappend result [s validate $xml]
    }
    s delete
    set result
} {1 1 0 0 0}

test schema-15.1 {constraint cmd tcl} {
    tdom::schema s
    s define {
        defelement a {
            tcl append ::schema-15.1 [self]
            element b