tDOM

Check-in [c24d55afe8]
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:Merged feature virtual constraints into the main schema dev branch.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | schema
Files: files | file ages | folders
SHA3-256: c24d55afe8dab5c075750544967a6de617149250c102b2e65a10e2345e43abb3
User & Date: rolf 2019-03-07 13:44:23
Context
2019-03-07
22:46
Merged from trunk. check-in: 60af362516 user: rolf tags: schema
13:44
Merged feature virtual constraints into the main schema dev branch. check-in: c24d55afe8 user: rolf tags: schema
13:42
(This and the previous commit on this branch:) Changed the calling convention of the virtual contraints: Append the schema command name to the args given and evaluate that. Whatever data the virtual contraint need has to be requested inside the called script (most probably by the new [<schemacmd> info ...] method, which has to be enhanced over time to provide the information that may needed in practice by this. Added code to ensure a Tcl error in evaluated virtual event does pop up in the result of the schema command call. Closed-Leaf check-in: 71d80fea6e user: rolf tags: virtualConstraints
2019-03-06
22:47
Further work on calling schema commands in schema definition / text constraint scripts. check-in: 2d5a4f85c8 user: rolf tags: schema
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/schema.c.

281
282
283
284
285
286
287

288
289
290
291
292
293
294
...
316
317
318
319
320
321
322

323
324
325
326
327
328
329
...
372
373
374
375
376
377
378






379
380
381
382
383
384
385
...
707
708
709
710
711
712
713



















714
715
716
717
718
719
720
...
815
816
817
818
819
820
821





822
823
824
825
826







827
828
829
830
831
832
833
...
842
843
844
845
846
847
848

849
850
851
852
853
854
855
...
890
891
892
893
894
895
896



897
898
899
900
901
902

903
904
905
906
907
908
909
....
1025
1026
1027
1028
1029
1030
1031

1032
1033
1034
1035
1036

1037
1038
1039
1040
1041
1042
1043
....
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
....
1318
1319
1320
1321
1322
1323
1324








1325
1326
1327
1328
1329
1330
1331



1332


1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352

1353
1354
1355
1356
1357
1358
1359
....
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
....
1483
1484
1485
1486
1487
1488
1489








1490
1491
1492
1493
1494
1495
1496
....
1508
1509
1510
1511
1512
1513
1514








1515
1516
1517
1518
1519
1520
1521
....
1526
1527
1528
1529
1530
1531
1532

1533
1534
1535
1536
1537
1538
1539
....
1560
1561
1562
1563
1564
1565
1566
1567
1568



1569
1570
1571
1572
1573
1574
1575
....
1885
1886
1887
1888
1889
1890
1891

1892
1893
1894
1895
1896
1897
1898
....
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
....
3051
3052
3053
3054
3055
3056
3057












































3058
3059
3060
3061
3062
3063
3064
....
3897
3898
3899
3900
3901
3902
3903




3904
3905
3906
3907
3908
3909
3910
            sizeof (SchemaQuant) * CONTENT_ARRAY_SIZE_INIT
            );
        break;
    case SCHEMA_CTYPE_TEXT:
        /* content/quant will be allocated, if the cp in fact has
         * constraints */
        break;

    case SCHEMA_CTYPE_ANY:
        /* Do nothing */
        break;
    }
    return pattern;
}

................................................................................
        /* Fall thru. */
    case SCHEMA_CTYPE_CHOICE:
    case SCHEMA_CTYPE_INTERLEAVE:
        fprintf (stderr, "\t%d childs\n", pattern->nc);
        break;
    case SCHEMA_CTYPE_ANY:
    case SCHEMA_CTYPE_TEXT:

        /* Do nothing */
        break;
    }
}

static void serializeQuant (
    SchemaQuant quant
................................................................................
    int i;
    SchemaConstraint *sc;

    switch (pattern->type) {
    case SCHEMA_CTYPE_ANY:
        /* do nothing */
        break;






    case SCHEMA_CTYPE_TEXT:
        for (i = 0; i < pattern->nc; i++) {
            sc = (SchemaConstraint *) pattern->content[i];
            if (sc->freeData) {
                (sc->freeData) (sc->constraintData);
            }
            FREE (pattern->content[i]);
................................................................................
        sc = (SchemaConstraint *) cp->content[i];
        if (!(sc->constraint) (interp, sc->constraintData, text)) {
            return 0;
        }
    }
    return 1;
}




















static int
matchElementStart (
    Tcl_Interp *interp,
    SchemaData *sdata,
    char *name,
    char *namespace
................................................................................
                        if (rc == 1) {
                            updateStack (se, cp, ac);
                            return 1;
                        }
                        popStack (sdata);
                        if (rc == -1) mayskip = 1;
                        break;





                    }
                    if (!mayskip && mayMiss (candidate->quants[i]))
                        mayskip = 1;
                }
                break;








            case SCHEMA_CTYPE_INTERLEAVE:
            case SCHEMA_CTYPE_PATTERN:
                pushToStack (sdata, candidate);
                rc = matchElementStart (interp, sdata, name, namespace);
                if (rc == 1) {
                    updateStack (se, cp, ac);
................................................................................
            }
            ac++;
            hm = 0;
        }
        if (isName) return 0;
        return -1;


    case SCHEMA_CTYPE_CHOICE:
    case SCHEMA_CTYPE_TEXT:
    case SCHEMA_CTYPE_ANY:
        /* Never pushed onto stack */
        Tcl_Panic ("Invalid CTYPE onto the validation stack!");

    case SCHEMA_CTYPE_INTERLEAVE:
................................................................................
                    se->hasMatched = 1;
                    se->interleaveState[i] = 1;
                    return 1;
                }
                popStack (sdata);
                if (!mayskip && rc == -1) mayskip = 1;
                break;



            }

        }
                
        break;
    }

    return 0;
}

int
probeElement (
    Tcl_Interp *interp,
    SchemaData *sdata,
................................................................................
        return TCL_OK;
    }
    DBG(
        fprintf (stderr, "element '%s' DOESN'T match\n", name);
        serializeStack (sdata);
        fprintf (stderr, "\n");
        );

    SetResult ("Element \"");
    if (namespacePtr) {
        Tcl_AppendResult (interp, namespacePtr, ":", NULL);
    }
    Tcl_AppendResult (interp, name, "\" doesn't match", NULL);

    return TCL_ERROR;
}

int probeAttributes (
    Tcl_Interp *interp,
    SchemaData *sdata,
    const char **attr
................................................................................
}

static int checkElementEnd (
    Tcl_Interp *interp,
    SchemaData *sdata
    )
{
    SchemaValidationStack *se;
    SchemaCP *cp, *ic;
    int hm, ac, i, mayMiss, rc;
    int isName = 0;

    DBG(fprintf (stderr, "checkElementEnd:\n");
        serializeStack(sdata););
    se = sdata->stack;
................................................................................
                    case SCHEMA_CTYPE_PATTERN:
                        pushToStack (sdata, ic);
                        if (checkElementEnd (interp, sdata)) {
                            mayMiss = 1;
                        }
                        popStack (sdata);
                        break;








                    }
                    if (mayMiss) break;
                }
                if (mayMiss) {
                    ac++; continue;
                }
                return 0;






                
            case SCHEMA_CTYPE_INTERLEAVE:
            case SCHEMA_CTYPE_PATTERN:
                pushToStack (sdata, cp->content[ac]);
                rc = checkElementEnd (interp, sdata);
                popStack (sdata);
                if (rc) {
                    ac++; continue;
                }
                return 0;
                
            case SCHEMA_CTYPE_ANY:
            case SCHEMA_CTYPE_NAME:
                return 0;
            }
            ac++;
        }
        if (isName) return 1;
        return -1;


    case SCHEMA_CTYPE_CHOICE:
    case SCHEMA_CTYPE_TEXT:
    case SCHEMA_CTYPE_ANY:
        /* Never pushed onto stack */
        Tcl_Panic ("Invalid CTYPE onto the validation stack!");
        return 0;

................................................................................
matchText (
    Tcl_Interp *interp,
    SchemaData *sdata,
    char *text
    )
{
    SchemaCP *cp, *candidate, *ic;
    SchemaValidationStack *se;
    int ac, hm, isName = 0, i;

    DBG(fprintf (stderr, "matchText called with text '%s'\n", text));
    
    while (1) {
        se = sdata->stack;
        getContext (cp, ac, hm);
................................................................................
                            if (matchText (interp, sdata, text)) {
                                updateStack (se, cp, ac);
                                return 1;
                            }
                            popStack (sdata);
                            break;









                        case SCHEMA_CTYPE_CHOICE:
                            Tcl_Panic ("MIXED or CHOICE child of MIXED or CHOICE");

                        }
                    }
                    if (mustMatch (cp->quants[ac], hm)) {
                        SetResult ("Unexpected text content");
................................................................................
                    popStack (sdata);
                    if (mustMatch (cp->quants[ac], hm)) {
                        SetResult ("Unexpected text content");
                        return 0;
                    }
                    break;









                case SCHEMA_CTYPE_NAME:
                case SCHEMA_CTYPE_ANY:
                    if (mustMatch (cp->quants[ac], hm)) {
                        SetResult ("Unexpected text content");
                        return 0;
                    }
                    break;
................................................................................
            if (isName) {
                SetResult ("Unexpected text content");
                return 0;
            }
            popStack (sdata);
            continue;


        case SCHEMA_CTYPE_CHOICE:
        case SCHEMA_CTYPE_TEXT:
        case SCHEMA_CTYPE_ANY:
            /* Never pushed onto stack */
            Tcl_Panic ("Invalid CTYPE onto the validation stack!");
            break;

................................................................................
                        updateStack (se, cp, ac);
                        return 1;
                    }
                    popStack (sdata);
                    break;

                case SCHEMA_CTYPE_CHOICE:
                    Tcl_Panic ("MIXED or CHOICE child of MIXED or CHOICE");




                }
            }
        }
        break;
    }
    return 0;
}
................................................................................
schemaReset (
    SchemaData *sdata
    )
{
    while (sdata->stack) popStack (sdata);
    sdata->validationState = VALIDATION_READY;
    sdata->skipDeep = 0;

}

static int
evalConstraints (
    Tcl_Interp *interp,
    SchemaData *sdata,
    SchemaCP *cp,
................................................................................
            serializeElementName (elmObj, cp);
            if (Tcl_ListObjAppendElement (interp, resultObj, elmObj) != TCL_OK)
                return TCL_ERROR;
        }
        break;

    case m_stack:
        if (Tcl_GetIndexFromObj (interp, objv[1],
                                 schemaInstanceInfoStackMethods,
                                 "method", 0, &methodIndex)
            != TCL_OK) {
            return TCL_ERROR;
        }
        switch ((enum schemaInstanceInfoStackMethod) methodIndex) {
        case m_top:
................................................................................
    }
    addToContent (sdata, pattern, quant, 0, 0);
    if (objc == 2) {
        return evalConstraints (interp, sdata, pattern, objv[1]);
    }
    return TCL_OK;
}













































static int
integerImpl (
    Tcl_Interp *interp,
    void *constraintData,
    char *text
    )
................................................................................
    Tcl_CreateObjCommand (interp, "tdom::schema::nsattribute",
                          AttributePatternObjCmd, (ClientData) 1, NULL);
    Tcl_CreateObjCommand (interp, "tdom::schema::namespace",
                          NamespacePatternObjCmd, NULL, NULL);
    Tcl_CreateObjCommand (interp, "tdom::schema::text",
                          TextPatternObjCmd, NULL, NULL);





    /* The text constraint commands */
    Tcl_CreateObjCommand (interp,"tdom::schema::text::integer",
                          integerTCObjCmd, NULL, NULL);
    Tcl_CreateObjCommand (interp, "tdom::schema::text::tcl",
                          tclTCObjCmd, NULL, NULL);
    Tcl_CreateObjCommand (interp, "tdom::schema::text::fixed",
                          fixedTCObjCmd, NULL, NULL);






>







 







>







 







>
>
>
>
>
>







 







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







 







>
>
>
>
>





>
>
>
>
>
>
>







 







>







 







>
>
>






>







 







>
|
|
|
|
|
>







 







|







 







>
>
>
>
>
>
>
>



|
|
|
|
>
>
>
|
>
>






|
<
<











>







 







|







 







>
>
>
>
>
>
>
>







 







>
>
>
>
>
>
>
>







 







>







 







|

>
>
>







 







>







 







|







 







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







 







>
>
>
>







281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
...
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
...
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
...
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
...
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
...
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
...
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
....
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
....
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
....
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398


1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
....
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
....
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
....
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
....
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
....
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
....
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
....
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
....
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
....
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
            sizeof (SchemaQuant) * CONTENT_ARRAY_SIZE_INIT
            );
        break;
    case SCHEMA_CTYPE_TEXT:
        /* content/quant will be allocated, if the cp in fact has
         * constraints */
        break;
    case SCHEMA_CTYPE_VIRTUAL:
    case SCHEMA_CTYPE_ANY:
        /* Do nothing */
        break;
    }
    return pattern;
}

................................................................................
        /* Fall thru. */
    case SCHEMA_CTYPE_CHOICE:
    case SCHEMA_CTYPE_INTERLEAVE:
        fprintf (stderr, "\t%d childs\n", pattern->nc);
        break;
    case SCHEMA_CTYPE_ANY:
    case SCHEMA_CTYPE_TEXT:
    case SCHEMA_CTYPE_VIRTUAL:
        /* Do nothing */
        break;
    }
}

static void serializeQuant (
    SchemaQuant quant
................................................................................
    int i;
    SchemaConstraint *sc;

    switch (pattern->type) {
    case SCHEMA_CTYPE_ANY:
        /* do nothing */
        break;
    case SCHEMA_CTYPE_VIRTUAL:
        for (i = 0; i < pattern->nc - 1; i++) {
            Tcl_DecrRefCount ((Tcl_Obj *)pattern->content[i]);
        }
        FREE (pattern->content);
        break;
    case SCHEMA_CTYPE_TEXT:
        for (i = 0; i < pattern->nc; i++) {
            sc = (SchemaConstraint *) pattern->content[i];
            if (sc->freeData) {
                (sc->freeData) (sc->constraintData);
            }
            FREE (pattern->content[i]);
................................................................................
        sc = (SchemaConstraint *) cp->content[i];
        if (!(sc->constraint) (interp, sc->constraintData, text)) {
            return 0;
        }
    }
    return 1;
}

static int
evalVirtual (
    Tcl_Interp *interp,
    SchemaData *sdata,
    SchemaCP *cp
    )
{
    int rc;

    cp->content[cp->nc-1] = (SchemaCP *) sdata->self;
    rc = Tcl_EvalObjv (interp, cp->nc, (Tcl_Obj **) cp->content,
                       TCL_EVAL_GLOBAL);
    if (rc != TCL_OK) {
        sdata->evalError = 1;
        return 0;
    }
    return 1;
}

static int
matchElementStart (
    Tcl_Interp *interp,
    SchemaData *sdata,
    char *name,
    char *namespace
................................................................................
                        if (rc == 1) {
                            updateStack (se, cp, ac);
                            return 1;
                        }
                        popStack (sdata);
                        if (rc == -1) mayskip = 1;
                        break;

                    case SCHEMA_CTYPE_VIRTUAL:
                        if (evalVirtual (interp, sdata, icp)) break;
                        else return 0;
                        
                    }
                    if (!mayskip && mayMiss (candidate->quants[i]))
                        mayskip = 1;
                }
                break;

            case SCHEMA_CTYPE_VIRTUAL:
                if (evalVirtual (interp, sdata, candidate)) {
                    mayskip = 1;
                    break;
                }
                else return 0;

            case SCHEMA_CTYPE_INTERLEAVE:
            case SCHEMA_CTYPE_PATTERN:
                pushToStack (sdata, candidate);
                rc = matchElementStart (interp, sdata, name, namespace);
                if (rc == 1) {
                    updateStack (se, cp, ac);
................................................................................
            }
            ac++;
            hm = 0;
        }
        if (isName) return 0;
        return -1;

    case SCHEMA_CTYPE_VIRTUAL:
    case SCHEMA_CTYPE_CHOICE:
    case SCHEMA_CTYPE_TEXT:
    case SCHEMA_CTYPE_ANY:
        /* Never pushed onto stack */
        Tcl_Panic ("Invalid CTYPE onto the validation stack!");

    case SCHEMA_CTYPE_INTERLEAVE:
................................................................................
                    se->hasMatched = 1;
                    se->interleaveState[i] = 1;
                    return 1;
                }
                popStack (sdata);
                if (!mayskip && rc == -1) mayskip = 1;
                break;

            case SCHEMA_CTYPE_VIRTUAL:
                break;
            }

        }
                
        break;
    }
    
    return 0;
}

int
probeElement (
    Tcl_Interp *interp,
    SchemaData *sdata,
................................................................................
        return TCL_OK;
    }
    DBG(
        fprintf (stderr, "element '%s' DOESN'T match\n", name);
        serializeStack (sdata);
        fprintf (stderr, "\n");
        );
    if (!sdata->evalError) {
        SetResult ("Element \"");
        if (namespacePtr) {
            Tcl_AppendResult (interp, namespacePtr, ":", NULL);
        }
        Tcl_AppendResult (interp, name, "\" doesn't match", NULL);
    }
    return TCL_ERROR;
}

int probeAttributes (
    Tcl_Interp *interp,
    SchemaData *sdata,
    const char **attr
................................................................................
}

static int checkElementEnd (
    Tcl_Interp *interp,
    SchemaData *sdata
    )
{
    SchemaValidationStack *se, *tse;
    SchemaCP *cp, *ic;
    int hm, ac, i, mayMiss, rc;
    int isName = 0;

    DBG(fprintf (stderr, "checkElementEnd:\n");
        serializeStack(sdata););
    se = sdata->stack;
................................................................................
                    case SCHEMA_CTYPE_PATTERN:
                        pushToStack (sdata, ic);
                        if (checkElementEnd (interp, sdata)) {
                            mayMiss = 1;
                        }
                        popStack (sdata);
                        break;
                        
                    case SCHEMA_CTYPE_VIRTUAL:
                        tse = se;
                        while (tse->pattern->type != SCHEMA_CTYPE_NAME) {
                            tse = tse->down;
                        }
                        if (evalVirtual (interp, sdata, ic)) break;
                        else return 0;
                    }
                    if (mayMiss) break;
                }
                if (mayMiss) break;
                return 0;

            case SCHEMA_CTYPE_VIRTUAL:
                tse = se;
                while (tse->pattern->type != SCHEMA_CTYPE_NAME) {
                    tse = tse->down;
                }
                if (evalVirtual (interp, sdata, cp->content[ac])) break;
                else return 0;
                
            case SCHEMA_CTYPE_INTERLEAVE:
            case SCHEMA_CTYPE_PATTERN:
                pushToStack (sdata, cp->content[ac]);
                rc = checkElementEnd (interp, sdata);
                popStack (sdata);
                if (rc) break;


                return 0;
                
            case SCHEMA_CTYPE_ANY:
            case SCHEMA_CTYPE_NAME:
                return 0;
            }
            ac++;
        }
        if (isName) return 1;
        return -1;

    case SCHEMA_CTYPE_VIRTUAL:
    case SCHEMA_CTYPE_CHOICE:
    case SCHEMA_CTYPE_TEXT:
    case SCHEMA_CTYPE_ANY:
        /* Never pushed onto stack */
        Tcl_Panic ("Invalid CTYPE onto the validation stack!");
        return 0;

................................................................................
matchText (
    Tcl_Interp *interp,
    SchemaData *sdata,
    char *text
    )
{
    SchemaCP *cp, *candidate, *ic;
    SchemaValidationStack *se, *tse;
    int ac, hm, isName = 0, i;

    DBG(fprintf (stderr, "matchText called with text '%s'\n", text));
    
    while (1) {
        se = sdata->stack;
        getContext (cp, ac, hm);
................................................................................
                            if (matchText (interp, sdata, text)) {
                                updateStack (se, cp, ac);
                                return 1;
                            }
                            popStack (sdata);
                            break;

                        case SCHEMA_CTYPE_VIRTUAL:
                            tse = se;
                            while (tse->pattern->type != SCHEMA_CTYPE_NAME) {
                                tse = tse->down;
                            }
                            if (!evalVirtual (interp, sdata, ic)) return 0;
                            break;
                            
                        case SCHEMA_CTYPE_CHOICE:
                            Tcl_Panic ("MIXED or CHOICE child of MIXED or CHOICE");

                        }
                    }
                    if (mustMatch (cp->quants[ac], hm)) {
                        SetResult ("Unexpected text content");
................................................................................
                    popStack (sdata);
                    if (mustMatch (cp->quants[ac], hm)) {
                        SetResult ("Unexpected text content");
                        return 0;
                    }
                    break;

                case SCHEMA_CTYPE_VIRTUAL:
                    tse = se;
                    while (tse->pattern->type != SCHEMA_CTYPE_NAME) {
                        tse = tse->down;
                    }
                    if (!evalVirtual (interp, sdata, ic)) return 0;
                    break;
                    
                case SCHEMA_CTYPE_NAME:
                case SCHEMA_CTYPE_ANY:
                    if (mustMatch (cp->quants[ac], hm)) {
                        SetResult ("Unexpected text content");
                        return 0;
                    }
                    break;
................................................................................
            if (isName) {
                SetResult ("Unexpected text content");
                return 0;
            }
            popStack (sdata);
            continue;

        case SCHEMA_CTYPE_VIRTUAL:
        case SCHEMA_CTYPE_CHOICE:
        case SCHEMA_CTYPE_TEXT:
        case SCHEMA_CTYPE_ANY:
            /* Never pushed onto stack */
            Tcl_Panic ("Invalid CTYPE onto the validation stack!");
            break;

................................................................................
                        updateStack (se, cp, ac);
                        return 1;
                    }
                    popStack (sdata);
                    break;

                case SCHEMA_CTYPE_CHOICE:
                    Tcl_Panic ("MIXED or CHOICE child of INTERLEAVE");

                case SCHEMA_CTYPE_VIRTUAL:
                    break;
                    
                }
            }
        }
        break;
    }
    return 0;
}
................................................................................
schemaReset (
    SchemaData *sdata
    )
{
    while (sdata->stack) popStack (sdata);
    sdata->validationState = VALIDATION_READY;
    sdata->skipDeep = 0;
    sdata->evalError = 0;
}

static int
evalConstraints (
    Tcl_Interp *interp,
    SchemaData *sdata,
    SchemaCP *cp,
................................................................................
            serializeElementName (elmObj, cp);
            if (Tcl_ListObjAppendElement (interp, resultObj, elmObj) != TCL_OK)
                return TCL_ERROR;
        }
        break;

    case m_stack:
        if (Tcl_GetIndexFromObj (interp, objv[2],
                                 schemaInstanceInfoStackMethods,
                                 "method", 0, &methodIndex)
            != TCL_OK) {
            return TCL_ERROR;
        }
        switch ((enum schemaInstanceInfoStackMethod) methodIndex) {
        case m_top:
................................................................................
    }
    addToContent (sdata, pattern, quant, 0, 0);
    if (objc == 2) {
        return evalConstraints (interp, sdata, pattern, objv[1]);
    }
    return TCL_OK;
}

static int
VirtualPatternObjCmd (
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[]
    )
{
    SchemaData *sdata = GETASI;
    SchemaCP *pattern;
    int i;

    CHECK_SI
    CHECK_TOPLEVEL
    if (objc < 2) {
        SetResult ("Expected: <tclcmd> ?arg? ?arg? ...");
        return TCL_ERROR;
    }

    switch (sdata->cp->type) {
    case SCHEMA_CTYPE_NAME:
    case SCHEMA_CTYPE_PATTERN:
        break;
    default:
        SetResult ("The \"tcl\" schema definition command is only "
                   "allowed in sequential context (defelement, "
                   "element or defpattern)");
        return TCL_ERROR;
    }

    pattern = initSchemaCP (SCHEMA_CTYPE_VIRTUAL, NULL, NULL);
    REMEMBER_PATTERN (pattern)
    /* We alloc for one arugment more: the always appended schema
     * cmd, */
    pattern->content = MALLOC (sizeof (Tcl_Obj*) * (objc));
    for (i = 1; i < objc; i++) {
        pattern->content[i-1] = (SchemaCP *) objv[i];
        Tcl_IncrRefCount (objv[i]);
    }
    pattern->nc = objc;
    addToContent (sdata, pattern, SCHEMA_CQUANT_ONE, 0, 0);
    return TCL_OK;
}

static int
integerImpl (
    Tcl_Interp *interp,
    void *constraintData,
    char *text
    )
................................................................................
    Tcl_CreateObjCommand (interp, "tdom::schema::nsattribute",
                          AttributePatternObjCmd, (ClientData) 1, NULL);
    Tcl_CreateObjCommand (interp, "tdom::schema::namespace",
                          NamespacePatternObjCmd, NULL, NULL);
    Tcl_CreateObjCommand (interp, "tdom::schema::text",
                          TextPatternObjCmd, NULL, NULL);

    /* The 'virtual' "tcl" definition command */
    Tcl_CreateObjCommand (interp, "tdom::schema::tcl",
                          VirtualPatternObjCmd, NULL, NULL);
    
    /* The text constraint commands */
    Tcl_CreateObjCommand (interp,"tdom::schema::text::integer",
                          integerTCObjCmd, NULL, NULL);
    Tcl_CreateObjCommand (interp, "tdom::schema::text::tcl",
                          tclTCObjCmd, NULL, NULL);
    Tcl_CreateObjCommand (interp, "tdom::schema::text::fixed",
                          fixedTCObjCmd, NULL, NULL);

Changes to generic/schema.h.

26
27
28
29
30
31
32
33

34
35
36
37
38
39
40
...
119
120
121
122
123
124
125

126
127
128
129
130
131
132
typedef enum {
  SCHEMA_CTYPE_ANY,
  SCHEMA_CTYPE_NAME,
  SCHEMA_CTYPE_CHOICE,
  SCHEMA_CTYPE_INTERLEAVE,
  SCHEMA_CTYPE_PATTERN,
  SCHEMA_CTYPE_TEXT

} Schema_CP_Type;

typedef enum {
  SCHEMA_CQUANT_ONE,
  SCHEMA_CQUANT_OPT,
  SCHEMA_CQUANT_REP,
  SCHEMA_CQUANT_PLUS,
................................................................................
    unsigned int patternListSize;
    unsigned int forwardPatternDefs;
    SchemaQuant *quants;
    unsigned int numQuants;
    unsigned int quantsSize;
    int       currentEvals;
    int       cleanupAfterEval;

    Tcl_Obj  *reportCmd;
    Tcl_Obj **evalStub;
    Tcl_Obj **textStub;
    char *currentNamespace;
    int   defineToplevel;
    int   isTextConstraint;
    int   isAttributeConstaint;






|
>







 







>







26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
...
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
typedef enum {
  SCHEMA_CTYPE_ANY,
  SCHEMA_CTYPE_NAME,
  SCHEMA_CTYPE_CHOICE,
  SCHEMA_CTYPE_INTERLEAVE,
  SCHEMA_CTYPE_PATTERN,
  SCHEMA_CTYPE_TEXT,
  SCHEMA_CTYPE_VIRTUAL
} Schema_CP_Type;

typedef enum {
  SCHEMA_CQUANT_ONE,
  SCHEMA_CQUANT_OPT,
  SCHEMA_CQUANT_REP,
  SCHEMA_CQUANT_PLUS,
................................................................................
    unsigned int patternListSize;
    unsigned int forwardPatternDefs;
    SchemaQuant *quants;
    unsigned int numQuants;
    unsigned int quantsSize;
    int       currentEvals;
    int       cleanupAfterEval;
    int       evalError;
    Tcl_Obj  *reportCmd;
    Tcl_Obj **evalStub;
    Tcl_Obj **textStub;
    char *currentNamespace;
    int   defineToplevel;
    int   isTextConstraint;
    int   isAttributeConstaint;

Changes to tests/schema.test.

11
12
13
14
15
16
17

18
19
20
21
22
23
24
....
3165
3166
3167
3168
3169
3170
3171




































































3172
3173
3174
3175
3176
3177
3178
#    schema-8.*: tdom::schema validate method
#    schema-9.*: Choice
#    scheam-10.*: Any
#    schema-11.*: attribute, nsattribute
#    schema-12.*: schemaCmd domvalidate
#    schema-13.*: XML namespaces
#    schema-14.*: text

#    schema-16.*: interleave
#
# Copyright (c) 2018 Rolf Ade.

source [file join [file dir [info script]] loadtdom.tcl]

if {[dom featureinfo schema]} {
................................................................................
    } {
        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
                element b






>







 







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







11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
....
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
#    schema-8.*: tdom::schema validate method
#    schema-9.*: Choice
#    scheam-10.*: Any
#    schema-11.*: attribute, nsattribute
#    schema-12.*: schemaCmd domvalidate
#    schema-13.*: XML namespaces
#    schema-14.*: text
#    schema-15.*: Constraint cmd tcl
#    schema-16.*: interleave
#
# Copyright (c) 2018 Rolf Ade.

source [file join [file dir [info script]] loadtdom.tcl]

if {[dom featureinfo schema]} {
................................................................................
    } {
        lappend result [s validate $xml]
    }
    s delete
    set result
} {0 0 1 0 1 0 1 0 0 0}

test schema-15.1 {constraint cmd tcl} {
    tdom::schema s
    s define {
        defelement a {
            tcl append ::schema-15.1
            element b
            tcl append ::schema-15.1
        }
    }
    set ::schema-15.1 ""
    set result [s validate {<a><b/></a>} msg]
    s delete
    lappend result $msg ${::schema-15.1}
    set result
} {1 {} ss}

proc schema-15.2-astart {args} {
    append ::schema-15.2 astart
}

proc schema-15.2-aend {args} {
    append ::schema-15.2 aend
}

test schema-15.2 {constraint cmd tcl} {
    tdom::schema s
    s define {
        defelement doc {
            element a *
        }
        defelement a {
            tcl schema-15.2-astart
            element b ! text
            element c ! text
            tcl schema-15.2-aend
        }
    }
    set schema-15.2 ""
    set result [s validate {<doc><a><b>foo</b><c/></a><a><b></b><c>bar</c></a></doc>} msg]
    s delete
    lappend result $msg ${schema-15.2}
    set result
} {1 {} astartaendastartaend}

proc schema-15.3 {type cmd} {
    lappend ::schema-15.3 $type [$cmd info stack inside]
}

test schema-15.3 {constraint cmd tcl} {
    tdom::schema s
    s define {
        defelement doc {
            element a *
        }
        defelement a {
            tcl schema-15.3 astart
            element b ! text
            element c ! text
            tcl schema-15.3 aend
        }
    }
    set schema-15.3 ""
    set result [s validate {<doc><a><b>foo</b><c/></a><a><b></b><c>bar</c></a></doc>} msg]
    s delete
    lappend result $msg {*}${schema-15.3}
    set result
} {1 {} astart a aend a astart a aend a}

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