Tk Source Code

Changes On Branch tip-560
Login

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

Changes In Branch tip-560 Excluding Merge-Ins

This is equivalent to a diff from 2145f868 to 78e1d3cc

2022-09-20
17:12
Fix [b07ecc2ebf]: Remove obsolete doc/tk4.0.ps check-in: acf63a5c user: fvogel tags: trunk, main
14:39
Merge 8.7 check-in: f90b7c8e user: jan.nijtmans tags: tip-167
14:35
Merge trunk Leaf check-in: 78e1d3cc user: jan.nijtmans tags: tip-560
14:34
Merge 8.7 Leaf check-in: 06f3c805 user: jan.nijtmans tags: tip-556
14:30
typo Tk_SetWindowMenuBar -> Tk_SetWindowMenubar. (TIP #606 and documentation was correct) check-in: 2145f868 user: jan.nijtmans tags: trunk, main
13:06
Rebase to latest trunk. Compile against Tcl's tip-558 branch check-in: c10dd93f user: jan.nijtmans tags: tip-560
05:12
Merge 8.6 check-in: f3a2b028 user: marc_culler tags: trunk, main

Changes to .github/workflows/linux-with-tcl8-build.yml.

28
29
30
31
32
33
34
35

36
37
38
39
40
41
42
28
29
30
31
32
33
34

35
36
37
38
39
40
41
42







-
+







        uses: actions/checkout@v3
        with:
          path: tk
      - name: Checkout Tcl
        uses: actions/checkout@v3
        with:
          repository: tcltk/tcl
          ref: core-8-branch
          ref: tip-558
          path: tcl
      - name: Setup Environment (compiler=${{ matrix.compiler }})
        run: |
          sudo apt-get install libxss-dev
          mkdir "$HOME/install dir"
          touch tk/doc/man.macros tk/generic/tkStubInit.c
          echo "CFGOPT=$CFGOPT" >> $GITHUB_ENV
131
132
133
134
135
136
137
138

139
140
141
142
143
144
145
131
132
133
134
135
136
137

138
139
140
141
142
143
144
145







-
+







        uses: actions/checkout@v3
        with:
          path: tk
      - name: Checkout Tcl
        uses: actions/checkout@v3
        with:
          repository: tcltk/tcl
          ref: core-8-branch
          ref: tip-558
          path: tcl
      - name: Setup Environment (compiler=${{ matrix.compiler }})
        run: |
          sudo apt-get install libxss-dev xvfb libicu-dev
          mkdir "$HOME/install dir"
          touch tk/doc/man.macros tk/generic/tkStubInit.c
          echo "CFGOPT=$CFGOPT" >> $GITHUB_ENV

Changes to .github/workflows/onefiledist.yml.

17
18
19
20
21
22
23
24

25
26
27
28
29
30
31
17
18
19
20
21
22
23

24
25
26
27
28
29
30
31







-
+







        uses: actions/checkout@v3
        with:
          path: tk
      - name: Checkout Tcl 8.7
        uses: actions/checkout@v3
        with:
          repository: tcltk/tcl
          ref: core-8-branch
          ref: tip-558
          path: tcl
      - name: Setup Environment
        run: |
          sudo apt-get install libxss-dev
          touch tcl/generic/tclStubInit.c tcl/generic/tclOOStubInit.c
          touch tk/generic/tkStubInit.c
          echo "INST_DIR=$(cd install;pwd)" >> $GITHUB_ENV
81
82
83
84
85
86
87
88

89
90
91
92
93
94
95
81
82
83
84
85
86
87

88
89
90
91
92
93
94
95







-
+







        uses: actions/checkout@v3
        with:
          path: tk
      - name: Checkout Tcl 8.7
        uses: actions/checkout@v3
        with:
          repository: tcltk/tcl
          ref: core-8-branch
          ref: tip-558
          path: tcl
      - name: Checkout create-dmg
        uses: actions/checkout@v3
        with:
          repository: create-dmg/create-dmg
          ref: v1.0.8
          path: create-dmg
169
170
171
172
173
174
175
176

177
178
179
180
181
182
183
169
170
171
172
173
174
175

176
177
178
179
180
181
182
183







-
+







        uses: actions/checkout@v3
        with:
          path: tk
      - name: Checkout Tcl 8.7
        uses: actions/checkout@v3
        with:
          repository: tcltk/tcl
          ref: core-8-branch
          ref: tip-558
          path: tcl
      - name: Setup Environment
        run: |
          mkdir -p install/combined
          touch tcl/generic/tclStubInit.c tcl/generic/tclOOStubInit.c
          touch tk/generic/tkStubInit.c
          echo "INST_DIR=$(cd install;pwd)" >> $GITHUB_ENV

Changes to .github/workflows/win-build.yml.

17
18
19
20
21
22
23
24

25
26
27
28
29
30
31
17
18
19
20
21
22
23

24
25
26
27
28
29
30
31







-
+







        uses: actions/checkout@v3
        with:
          path: tk
      - name: Checkout
        uses: actions/checkout@v3
        with:
          repository: tcltk/tcl
          ref: core-8-branch
          ref: tip-558
          path: tcl
      - name: Init MSVC
        uses: ilammy/msvc-dev-cmd@v1
      - name: Make Install Location
        working-directory: tcl
        run: |
          echo "TCLDIR=`pwd`" >> $GITHUB_ENV

Changes to doc/option.n.

11
12
13
14
15
16
17
18

19
20
21
22
23
24
25
11
12
13
14
15
16
17

18
19
20
21
22
23
24
25







-
+







'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
option \- Add/retrieve window options to/from the option database
.SH SYNOPSIS
.nf
\fBoption add \fIpattern value \fR?\fIpriority\fR?
\fBoption clear\fR
\fBoption get \fIwindow name class\fR
\fBoption get \fIwindow name class\fR ?\fIdefault\fR?
\fBoption readfile \fIfileName \fR?\fIpriority\fR?
.fi
.BE
.SH DESCRIPTION
.PP
The \fBoption\fR command allows you to add entries to the Tk option
database or to retrieve options from the database.  The \fBadd\fR
46
47
48
49
50
51
52
53





54
55
56
57
58
59
60
46
47
48
49
50
51
52

53
54
55
56
57
58
59
60
61
62
63
64







-
+
+
+
+
+







specified for \fIwindow\fR
under \fIname\fR and \fIclass\fR.  If several entries in the option
database match \fIwindow\fR, \fIname\fR, and \fIclass\fR, then
the command returns whichever was created with highest
\fIpriority\fR level.  If there are several matching
entries at the same priority level, then it returns whichever entry
was most recently entered into the option database.  If there are
no matching entries, then the empty string is returned.
no matching entries, then
.VS TIP560
either \fIdefault\fR is returned if it is specified, or otherwise
.VE TIP 560
the empty string is returned.
.PP
The \fBreadfile\fR form of the command reads \fIfileName\fR,
which should have the standard format for an
X resource database such as \fB.Xdefaults\fR, and adds all the
options specified in that file to the option database.  If \fIpriority\fR
is specified, it indicates the priority level at which to enter the
options;  \fIpriority\fR defaults to \fBinteractive\fR.

Changes to generic/tkCursor.c.

814
815
816
817
818
819
820




























































821
822
823
824
825
826
827
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
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
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887







+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+







     * Here is the real code:
     */

    Tcl_InitHashTable(&dispPtr->cursorIdTable, TCL_ONE_WORD_KEYS);

    dispPtr->cursorInit = 1;
}

/*
 *----------------------------------------------------------------------
 *
 * TkParseCursorObjCmd --
 *
 *	Implements [tk::ParseCursor]. Parses a cursor and returns either the
 *	empty string if the cursor (named in the first argument) is valid, or
 *	an error if the cursor is not actually a cursor. The cursor is not
 *	actually stored anywhere afterwards.
 *
 * Results:
 *	A Tcl result code.
 *
 * Side effects:
 *	Sets the interpreter result and error code on error.
 *
 *----------------------------------------------------------------------
 */

int
TkParseCursorObjCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Tk_Window tkwin = clientData;
    Tk_Cursor cursor;
    Tcl_Obj *cursorObj;

    if (objc != 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "cursor");
	return TCL_ERROR;
    }
    cursorObj = objv[1];

    /*
     * Type poke so that we don't need to do memory management if something
     * else has done it for us. In theory this could be a problem if the main
     * display couldn't have the cursor that this object describes... but that
     * never actually happens.
     */

    if (cursorObj->typePtr == &tkCursorObjType) {
	return TCL_OK;
    }

    /*
     * Not already a cursor. Engage the parser (and clean up destructively
     * afterwards).
     */

    cursor = Tk_AllocCursorFromObj(interp, tkwin, cursorObj);
    if (!cursor) {
	return TCL_ERROR;
    }
    Tk_FreeCursorFromObj(tkwin, cursorObj);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TkDebugCursor --
 *
 *	This function returns debugging information about a cursor.

Changes to generic/tkInt.h.

190
191
192
193
194
195
196
197

198
199
200
201
202
203
204
190
191
192
193
194
195
196

197
198
199
200
201
202
203
204







-
+







				 * Tk_AllocPreserveFromObj or Tk_Preserve). If
				 * this count is 0, then this structure is no
				 * longer valid and it isn't present in a hash
				 * table: it is being kept around only because
				 * there are objects referring to it. The
				 * structure is freed when resourceRefCount
				 * and objRefCount are both 0. */
    TkSizeT objRefCount;		/* Number of Tcl objects that reference this
    TkSizeT objRefCount;	/* Number of Tcl objects that reference this
				 * structure.. */
    Tcl_HashTable *otherTable;	/* Second table (other than idTable) used to
				 * index this entry. */
    Tcl_HashEntry *hashPtr;	/* Entry in otherTable for this structure
				 * (needed when deleting). */
    Tcl_HashEntry *idHashPtr;	/* Entry in idTable for this structure (needed
				 * when deleting). */
1494
1495
1496
1497
1498
1499
1500

1501
1502
1503
1504
1505

1506
1507
1508
1509
1510
1511
1512
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505

1506
1507
1508
1509
1510
1511
1512
1513







+




-
+







/*
 * Unsupported commands.
 */

MODULE_SCOPE int	TkUnsupported1ObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE Tcl_ObjCmdProc TkParseCursorObjCmd;

/*
 * For Tktest.
 */
MODULE_SCOPE int SquareObjCmd(ClientData clientData,
MODULE_SCOPE int	SquareObjCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj * const objv[]);
MODULE_SCOPE int	TkOldTestInit(Tcl_Interp *interp);
#if !(defined(_WIN32) || defined(MAC_OSX_TK))
#define TkplatformtestInit(x) TCL_OK
#else
MODULE_SCOPE int	TkplatformtestInit(Tcl_Interp *interp);

Changes to generic/tkOption.c.

675
676
677
678
679
680
681
682
683


684
685
686
687
688
689
690
691
692
693


694
695
696
697
698
699
700
675
676
677
678
679
680
681


682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702







-
-
+
+










+
+







	break;
    }

    case OPTION_GET: {
	Tk_Window window;
	Tk_Uid value;

	if (objc != 5) {
	    Tcl_WrongNumArgs(interp, 2, objv, "window name class");
	if (objc != 5 && objc != 6) {
	    Tcl_WrongNumArgs(interp, 2, objv, "window name class ?default?");
	    return TCL_ERROR;
	}
	window = Tk_NameToWindow(interp, Tcl_GetString(objv[2]), tkwin);
	if (window == NULL) {
	    return TCL_ERROR;
	}
	value = Tk_GetOption(window, Tcl_GetString(objv[3]),
		Tcl_GetString(objv[4]));
	if (value != NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(value, -1));
	} else if (objc == 6) {
	    Tcl_SetObjResult(interp, objv[5]);
	}
	break;
    }

    case OPTION_READFILE: {
	int priority;

Changes to generic/tkWindow.c.

190
191
192
193
194
195
196

197
198
199
200
201
202
203
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204







+







    {"tk_messageBox",	Tk_MessageBoxObjCmd,	PASSMAINWINDOW},
#endif

    /*
     * Misc.
     */

    {"::tk::ParseCursor", TkParseCursorObjCmd,	PASSMAINWINDOW|ISSAFE},
#ifdef MAC_OSX_TK
    {"::tk::unsupported::MacWindowStyle",
			TkUnsupported1ObjCmd,	PASSMAINWINDOW|ISSAFE},
#endif
    {NULL,		NULL,			0}
};

Added library/oocfg.tcl.







































































































































































































































































































































































































































































































































































































































































































































































































































































































































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
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
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
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
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
# oocfg.tcl --
#
# 	This file contains a configure system for megawidgets written in TclOO.
#
# Copyright (c) 2020 Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.

# 8.7, or any 9.*
package require Tcl 8.7-9.99

namespace eval ::tk {
    # ----------------------------------------------------------------------
    #
    # tk::OptionDefine --
    #
    #	The definition language namespace for configurable widget definitions.
    #	All actual implementations of bits and pieces are in the subordinate
    #	Support namespace, and the public API then namespace export/import-ed
    #	into the main namespace (which has its path set up to be a definition
    #	language).
    #
    # ----------------------------------------------------------------------

    namespace eval OptionDefine {
	namespace eval Support {
	    namespace ensemble create -command ::tk::OptionType
	    namespace path {::tcl ::tk ::oo::configuresupport}

	    # --------------------------------------------------------------
	    #
	    # tk::OptionDefine::Support::DefineOption --
	    #
	    #	Actually defines an option. Assumes all validation of
	    #	arguments has been done.
	    #
	    # --------------------------------------------------------------

	    proc DefineOption {name options} {
		set descriptor ::list
		lappend descriptor [dict get $options name]
		lappend descriptor [dict get $options class]
		set type [dict get $options type]
		if {[dict exists $options def]} {
		    lappend descriptor [dict get $options def]
		} else {
		    lappend descriptor [OptionType $type default]
		}
		set validator [list [namespace which OptionType] $type validate]

		uplevel 1 [list \
		    method <OptDescribe-$name> {} $descriptor]
		uplevel 1 [list \
		    forward <OptValidate-$name> {*}$validator]

		# We only make the access methods if they don't exist on this
		# class; this allows a user to override them before defining
		# the option.

		set meths [info class methods [uplevel 1 self] -scope unexported]
		if {"<OptRead-$name>" ni $meths} {
		    uplevel 1 [list \
			forward <OptRead-$name> my <StdOptRead> $name]
		}

		# Note: init-only options still have this
		if {"<OptWrite-$name>" ni $meths} {
		    uplevel 1 [list \
			forward <OptWrite-$name> my <StdOptWrite> $name]
		}

		uplevel 1 [list \
		    [namespace which readableproperties] -append -$name]
		if {![dict get $options init]} {
		    uplevel 1 [list \
			[namespace which writableproperties] -append -$name]
		}
	    }

	    # --------------------------------------------------------------
	    #
	    # tk::OptionDefine::Support::ListOptions --
	    #
	    #	Shorthand for getting the list of all options of a class of a
	    #	given type.
	    #
	    # --------------------------------------------------------------

	    proc ListOptions {class {type -readable}} {
		tailcall info class properties $class -all $type
	    }

	    # --------------------------------------------------------------
	    #
	    # tk::OptionDefine::Support::DefineAlias --
	    #
	    #	Actually defines a option alias. Does minor validation of its
	    #	target, checking that it actually exists and is not an
	    #	init-only option (because otherwise things get weird).
	    #
	    # --------------------------------------------------------------

	    proc DefineAlias {contextClass name otherName} {
		if {[string index $otherName 0] ne "-"} {
		    set otherName "-$otherName"
		}
		if {$otherName ni [ListOptions $contextClass]} {
		    throw [list TK LOOKUP OPTION $otherName] \
			"no such option \"$otherName\""
		}
		if {$otherName ni [ListOptions $contextClass -writable]} {
		    throw [list TK LOOKUP OPTION $otherName] \
			"may not alias init-only option \"$otherName\""
		}
		set descriptor [list ::list $otherName]

		uplevel 1 [list \
		    method <OptDescribe-$name> {} $descriptor]
		uplevel 1 [list \
		    forward <OptValidate-$name> my <OptValidate$otherName>]

		# Aliases always define readers and writers; overriding them
		# makes no sense at all!
		uplevel 1 [list \
		    forward <OptRead-$name> my <OptRead$otherName>]
		uplevel 1 [list \
		    forward <OptWrite-$name> my <OptWrite$otherName>]

		uplevel 1 [list \
		    [namespace which readableproperties] -append -$name]
		uplevel 1 [list \
		    [namespace which writableproperties] -append -$name]
	    }

	    # --------------------------------------------------------------
	    #
	    # tk::OptionDefine::Support::ParseOptionArgs --
	    #
	    #	Parses the various options to the [option] definition
	    #	command.
	    #
	    # --------------------------------------------------------------

	    proc ParseOptionArgs {name args} {
		dict set opt type string
		dict set opt class [string totitle $name]
		dict set opt name [string tolower $name]
		dict set opt init false
		set defFromType [OptionType string default]
		foreach {option value} $args {
		    switch [prefix match {
			-alias -class -default -initonly -name -type
		    } $option] {
			-alias {
			    if {[llength $args] != 2} {
				throw {TK OPTION_MISUSE} \
				    "-alias may only ever be used on its own"
			    }
			    dict set opt alias $value
			}
			-class {
			    if {![regexp {^[[:upper:]][[:alnum:]_]*$} $value]} {
				throw {TK OPTION_MISUSE} \
				    "-class must be alphanumeric with a leading capital letter"
			    }
			    dict set opt class $value
			}
			-name {
			    if {![regexp {^[[:lower:]][[:alnum:]_]*$} $value]} {
				throw {TK OPTION_MISUSE} \
				    "-name must be alphanumeric with a leading lower-case letter"
			    }
			    dict set opt name $value
			}
			-default {
			    # Can only validate this once we know the type
			    dict set opt def $value
			}
			-initonly {
			    # Use our existing boolean validator
			    dict set opt init \
				[OptionType boolean validate $value]
			}
			-type {
			    dict set opt type $value
			    set defFromType [OptionType $value default]
			}
		    }
		}
		if {[dict exists $opt def]} {
		    # Apply the type validation to the default
		    dict set opt def [OptionType [dict get $opt type] validate \
					  [dict get $opt def]]
		} else {
		    dict set opt def $defFromType
		}
		return $opt
	    }

	    # --------------------------------------------------------------
	    #
	    # tk::OptionDefine::Support::option --
	    #
	    #	The implementation of the [option] definition. Mostly
	    #	delegates to other procedures in this namespace.
	    #
	    # --------------------------------------------------------------

	    proc option {name args} {
		set contextClass [uplevel 1 self]
		if {[llength $args] % 2} {
		    return -code error -errorcode {TCL WRONGARGS} \
			[format {wrong # args: should be "%s"} \
			     "option name ?-option value ...?"]
		}
		if {![regexp -nocase {^[[:alpha:]][[:alnum:]_]*$} $name]} {
		    return -code error -errorcode {TK OPTION_NAME} \
			"bad option name \"$name\":\
		    	must be alphanumeric starting with a letter"
		}
		try {
		    set Opt [ParseOptionArgs $name {*}$args]
		    if {[dict exists $Opt alias]} {
			uplevel 1 [list \
			    [namespace which DefineAlias] $contextClass $name \
			    [dict get $Opt alias]]
		    } else {
			uplevel 1 [list \
			    [namespace which DefineOption] $name $Opt]
		    }
		} on error {msg opt} {
		    # Condition the errorinfo trace
		    dict unset opt -errorinfo
		    dict incr opt -level
		    return -options $opt $msg
		}
	    }

	    namespace export option
	}

	proc superclass args {
	    set support ::tk::ConfigurableStandardImplementations
	    uplevel 1 [list ::oo::define::superclass {*}$args]
	    tailcall ::oo::define::superclass -appendifnew $support
	}

	namespace import Support::option
	namespace export option
	namespace path ::oo::define
    }

    # ----------------------------------------------------------------------
    #
    # tk::Configurable --
    #
    #	The (mixin) class for configurable widgets.
    #
    #	Tricky point: namespace path of classes is uncertain; fully qualify
    #	everything.
    #
    # ----------------------------------------------------------------------

    ::oo::class create Configurable {
	private {
	    variable initialised

	    # --------------------------------------------------------------
	    #
	    # tk::Configurable Options --
	    #
	    #	Get the list of readable options of the object.
	    #
	    # --------------------------------------------------------------

	    method ReadableOptions {} {
		::info object properties [self] -all -readable
	    }

	    # --------------------------------------------------------------
	    #
	    # tk::Configurable WritableOptions --
	    #
	    #	Get the list of writable (after initialisation) options of the
	    #	object.
	    #
	    # --------------------------------------------------------------

	    method WritableOptions {} {
		::info object properties [self] -all -writable
	    }

	    # --------------------------------------------------------------
	    #
	    # tk::Configurable GetRealOptionName --
	    #
	    #	Expand unique prefixes of an option.
	    #
	    # --------------------------------------------------------------

	    method GetRealOptionName {option} {
		::try {
		    ::return [::tcl::prefix match -message "option" \
				 [my ReadableOptions] $option]
		} on error msg {
		    # Convert errorCode
		    ::throw [::list TK LOOKUP OPTION $option] $msg
		}
	    }

	    # --------------------------------------------------------------
	    #
	    # tk::Configurable DescribeOption --
	    #
	    #	Describes a single option (called from AllDescriptors and
	    #	OneDescriptor). The option name must be in its full form.
	    #
	    # --------------------------------------------------------------

	    method DescribeOption {option} {
		::set desc [my <OptDescribe$option>]
		::if {[::llength $desc] == 1} {
		    ::list $option {*}$desc
		} else {
		    ::list $option {*}$desc [my <OptRead$option>]
		}
	    }

	    # --------------------------------------------------------------
	    #
	    # tk::Configurable AllDescriptors --
	    #
	    #	Implements [$obj configure] with no extra arguments.
	    #
	    # --------------------------------------------------------------

	    method AllDescriptors {} {
		::lmap opt [my ReadableOptions] {my DescribeOption $opt}
	    }

	    # --------------------------------------------------------------
	    #
	    # tk::Configurable OneDescriptor --
	    #
	    #	Implements [$obj configure -opt] with no extra arguments.
	    #
	    # --------------------------------------------------------------

	    method OneDescriptor {option} {
		my DescribeOption [my GetRealOptionName $option]
	    }

	    # --------------------------------------------------------------
	    #
	    # tk::Configurable UpdateState --
	    #
	    #	Implements [$obj configure -opt val -opt val...].
	    #
	    # --------------------------------------------------------------

	    method UpdateState arguments {
		::set opts [my WritableOptions]
		::set stateChanged 0
		::set checkpoint [my <OptionsMakeCheckpoint>]
		::try {
		    ::foreach {option value} $arguments {
			try {
			    ::set opt [::tcl::prefix match -message "option" \
					 $opts $option]
			} on error {msg} {
			    ::try {
				::tcl::prefix match [my ReadableOptions] $option
			    } on error {} {
				# Do nothing
			    } on ok {optionName} {
				::set msg "read only option: $optionName"
			    }
			    ::throw [::list TK LOOKUP OPTION $option] $msg
			}
			set value [my <OptValidate$opt> $value]
			my <OptWrite$opt> $value
			::set stateChanged 1
		    }
		    ::if {$stateChanged} {
			my PostConfigure
		    }
		    ::unset -nocomplain checkpoint
		} finally {
		    # Rollback on error
		    ::if {[::info exists checkpoint]} {
			my <OptionsRestoreCheckpoint> $checkpoint
		    }
		}
	    }
	}

	# ------------------------------------------------------------------
	#
	# tk::Configurable configure --
	#
	#	Implements [$obj configure ...].
	#
	# ------------------------------------------------------------------

	method configure args {
	    ::try {
		::if {[::llength $args] == 0} {
		    ::return [my AllDescriptors]
		} elseif {[::llength $args] == 1} {
		    ::return [my OneDescriptor [::lindex $args 0]]
		} elseif {[::llength $args] % 2 == 0} {
		    my UpdateState $args
		    ::return
		} else {
		    # Don't like the genuine Tk errors; they're weird!
		    ::throw {TCL WRONGARGS} \
			[::format {wrong # args: should be "%s %s"} \
			     [lindex [info level 0] 0] \
			     "configure ?-option value ...?"]
		}
	    } on error {msg opt} {
		# Hide the implementation details
		::dict unset opt -errorinfo
		::dict incr opt -level
		::return -options $opt $msg
	    }
	}

	# ------------------------------------------------------------------
	#
	# tk::Configurable cget --
	#
	#	Implements [$obj cget $option].
	#
	# ------------------------------------------------------------------

	method cget {option} {
	    ::try {
		::return [my <OptRead[my GetRealOptionName $option]>]
	    } on error {msg opt} {
		# Hide the implementation details
		::dict unset opt -errorinfo
		::dict incr opt -level
		::return -options $opt $msg
	    }
	}

	# ------------------------------------------------------------------
	#
	# tk::Configurable Initialise --
	#
	#	Initialisation version of [$obj configure], which reads the
	#	option database and will set init-only options as well as
	#	ordinary ones. Intended to be called from a constructor.
	#
	#	The actual method is called something else because it does
	#	forwarding trickery to track the spelling of how it has been
	#	called.
	#
	# ------------------------------------------------------------------

	method Impl<Init> {methodName pathName args} {
	    ::if {[info exists initialised] && $initialised} {
		::return -code error -errorcode {TK DOUBLE_INIT} \
		    "this object is already initialised"
	    }
	    ::if {[::llength $args] % 2} {
		# TODO: generate a more accurate error message
		::set call "my $methodName pathName ?-option value...?"
		::return -code error -errorcode {TCL WRONGARGS} \
		    "wrong # args: should be \"$call\""
	    }
	    ::set toSet {}
	    ::set opts [my ReadableOptions]
	    ::try {
		# Tricky point: we will be writing to read-only options here.
		::foreach opt $opts {
		    ::set desc [my <OptDescribe$opt>]
		    ::if {[llength $desc] == 1} {
			# Skip aliases
			::continue
		    }
		    ::lassign $desc nm cls def
		    ::set val [::option get $pathName $nm $cls $def]
		    ::if {[catch {my <OptValidate$opt> $val}]} {
			# If the user forces a bad value via the option DB,
			# use our default anyway. It's the best we can do and
			# the DB is (by *design*) not entirely under script
			# control.
			::set val $def
		    }
		    ::dict set toSet $opt $val
		}
		::foreach {option value} $args {
		    ::try {
			# Tricky point: $opts includes init-only options
			::set opt [::tcl::prefix match -message "option" \
				     $opts $option]
		    } on error msg {
			# Rewrite the error code
			::throw [::list TK LOOKUP OPTION $option] $msg
		    }
		    ::dict set toSet $opt [my <OptValidate$opt> $value]
		}
	    } on error {msg opt} {
		# Strip the error trace
		::dict unset opt -errorinfo
		::dict incr opt -level
		::return -options $opt $msg
	    }
	    # Apply the computed state
	    dict for {opt value} $toSet {
		my <OptWrite$opt> $value
	    }
	    ::set initialised true
	}
	forward Initialise my Impl<Init> Initialise
	forward Initialize my Impl<Init> Initialize

	# Individual widgets do not support defining their own options.
	# This is different from ::oo::configurable's properties.
    }

    # ----------------------------------------------------------------------
    #
    # tk::ConfigurableStandardImplementations --
    #
    #	The superclass with user-overridable parts of the configurable system.
    #
    #	Tricky point: namespace path of classes is uncertain; fully qualify
    #	everything.
    #
    # ----------------------------------------------------------------------

    ::oo::class create ConfigurableStandardImplementations {
	# ------------------------------------------------------------------
	#
	# tk::ConfigurableStandardImplementations <StdOptRead> --
	#
	#	How to actually read an option of a given name out of the
	#	state when using the standard model of storage (the array in
	#	the instance with the empty name).
	#
	# ------------------------------------------------------------------

	method <StdOptRead> {name} {
	    ::variable ""
	    ::return $($name)
	}

	# ------------------------------------------------------------------
	#
	# tk::ConfigurableStandardImplementations <StdOptWrite> --
	#
	#	How to actually write an option of a given name to the state
	#	when using the standard model of storage (the array in the
	#	instance with the empty name).
	#
	# ------------------------------------------------------------------

	method <StdOptWrite> {name value} {
	    ::variable ""
	    ::set ($name) $value
	}

	# ------------------------------------------------------------------
	#
	# tk::ConfigurableStandardImplementations <OptionsMakeCheckpoint> --
	#
	#	How to make a checkpoint of the state that can be restored if
	#	the configuration of the object fails. If overridden, the
	#	companion method <OptionsRestoreCheckpoint> should also be
	#	overridden. The format of checkpoints is undocumented
	#	formally, but this implementation uses a dictionary.
	#
	# ------------------------------------------------------------------

	method <OptionsMakeCheckpoint> {} {
	    ::variable ""
	    ::array get ""
	}

	# ------------------------------------------------------------------
	#
	# tk::ConfigurableStandardImplementations <OptionsRestoreCheckpoint> --
	#
	#	How to restore a checkpoint of the state because the
	#	configuration of the object has failed. If overridden, the
	#	companion method <OptionsMakeCheckpoint> should also be
	#	overridden. The format of checkpoints is undocumented
	#	formally, but this implementation uses a dictionary.
	#
	# ------------------------------------------------------------------

	method <OptionsRestoreCheckpoint> {checkpoint} {
	    ::variable ""
	    ::array set "" $checkpoint
	}

	# ------------------------------------------------------------------
	#
	# tk::ConfigurableStandardImplementations PostConfigure --
	#
	#	Hook for user code to find out when a state change really
	#	occurred with [$obj configure]. Does nothing by default;
	#	subclasses may change this.
	#
	# ------------------------------------------------------------------

	method PostConfigure {} {}
    }

    # ----------------------------------------------------------------------
    #
    # tk::configurable --
    #
    #	The metaclass for making megawidgets (which are always configurable).
    #	Too bare at this point; intended to grow!
    #
    # ----------------------------------------------------------------------

    ::oo::class create configurable {
	superclass ::oo::class

    	constructor {{definitionScript ""}} {
	    next {
		superclass ::tk::ConfigurableStandardImplementations
		mixin ::tk::Configurable
	    }
	    next $definitionScript
	}
	definitionnamespace -class ::tk::OptionDefine
    }

    # ----------------------------------------------------------------------
    #
    # tk::optiontype --
    #
    #	The class of types of options. Abstract because concrete subclasses
    #	define how the validation is done.
    #
    #	Provides two variables to subclasses that they may use:
    #	  * TypeName - the name of the type, cleaned up for display to users
    #	    in error messages.
    #	  * ErrorCode - a list describing the standard error code for problems
    #	    with parsing this type
    #
    # ----------------------------------------------------------------------

    ::oo::abstract create optiontype {
	private variable def name
	variable TypeName ErrorCode

	constructor {default} {
	    set def $default
	    set name [namespace tail [self]]
	    # Ugly hack! Trims *one* leading 'z' from the type name
	    set TypeName [regsub {^z} $name ""]
	    set ErrorCode [list TK VALUE [string toupper $TypeName]]
	    set map [namespace ensemble configure ::tk::OptionType -map]
	    dict set map $name [self]
	    namespace ensemble configure ::tk::OptionType -map $map
	}

	destructor {
	    set map [namespace ensemble configure ::tk::OptionType -map]
	    dict unset map $name
	    namespace ensemble configure ::tk::OptionType -map $map
	}

	# ------------------------------------------------------------------
	#
	# tk::optiontype validate --
	#
	#	How to validate that the sole argument (conventionally called
	#	'value') is a member of the type. Throws an error if it is not
	#	of the type. Also normalizes the value if it is of the type;
	#	for most types, this is a trivial no-change operation, but for
	#	some types it may be more significant (e.g., expanding a
	#	unique prefix with a table-driven type).
	#
	# ------------------------------------------------------------------

	method validate {value} {
	    throw UNIMPLEMENTED "unimplemented method"
	}

	# ------------------------------------------------------------------
	#
	# tk::optiontype default --
	#
	#	Produces the default value of the type. The rest of the code
	#	assumes that this is a constant, so it is recommended to be a
	#	zero or an empty string (where these are meaningful).
	#
	# ------------------------------------------------------------------

	method default {} {
	    return $def
	}

	self {
	    # --------------------------------------------------------------
	    #
	    # tk::optiontype Create --
	    #
	    #	Actual factory method. Wrapper that creates classes of the
	    #	correct implementation type with the right name.
	    #
	    # --------------------------------------------------------------

	    method Create {realClass name args} {
		# Condition the class name first
		set name [namespace current]::[namespace tail $name]
		tailcall $realClass create $name {*}$args
	    }

	    # --------------------------------------------------------------
	    #
	    # tk::optiontype createbool --
	    #
	    #	Create a option type that is driven by a boolean test.
	    #
	    # --------------------------------------------------------------

	    forward createbool my Create ::tk::BoolTestType

	    # --------------------------------------------------------------
	    #
	    # tk::optiontype createthrow --
	    #
	    #	Create a option type that is driven by an erroring test.
	    #
	    # --------------------------------------------------------------

	    forward createthrow my Create ::tk::ThrowTestType

	    # --------------------------------------------------------------
	    #
	    # tk::optiontype createtable --
	    #
	    #	Create a option type that is driven by a table of valid
	    #	values (effectively an enumeration, Tcl-style).
	    #
	    # --------------------------------------------------------------

	    forward createtable my Create ::tk::TableType
	}
    }

    ::oo::class create BoolTestType {
	superclass optiontype
	private variable
	variable TypeName ErrorCode

	constructor {default test {normalizer {}}} {
	    next $default
	    ::oo::objdefine [self] forward Validate {*}$test
	    if {$normalizer ne ""} {
		::oo::objdefine [self] method Normalize {value} $normalizer
	    }
	}

	method validate {value} {
	    if {![my Validate $value]} {
		return -code error -errorcode $ErrorCode \
		    "invalid $TypeName value \"$value\""
	    }
	    try {
		return [my Normalize $value]
	    } on error {msg opt} {
		return -code error -errorcode [dict get $opt -errorcode] $msg
	    }
	}

	method Normalize {value} {
	    return $value
	}
    }

    ::oo::class create ThrowTestType {
	superclass optiontype
	variable ErrorCode

	constructor {default test {normalizer {}}} {
	    next $default
	    ::oo::objdefine [self] method Validate value $test
	    if {$normalizer ne ""} {
		::oo::objdefine [self] method Normalize {value} $normalizer
	    }
	}

	method validate {value} {
	    try {
		my Validate $value
	    } on error {msg} {
		return -code error -errorcode $ErrorCode $msg
	    }
	    try {
		return [my Normalize $value]
	    } on error {msg opt} {
		return -code error -errorcode [dict get $opt -errorcode] $msg
	    }
	}

	method Normalize {value} {
	    return $value
	}
    }

    ::oo::class create TableType {
	superclass optiontype

	private variable Table Error
	variable TypeName ErrorCode
	constructor {default table} {
	    if {$default ni $table} {
		# This requires that the default be not an abbreviation
		error "default value \"$default\" not in table of licit values"
	    }
	    next $default
	    set Table $table
	    set Error [list -level 1 -errorcode $ErrorCode]
	}

	method validate {value} {
	    ::tcl::prefix match -message $TypeName -error $Error $Table $value
	}
    }

    # ----------------------------------------------------------------------
    #
    #	Install the actual types.
    #
    # ----------------------------------------------------------------------

    # Install the types: those with a boolean test
    optiontype createbool boolean "false" {
	string is boolean -strict
    } {lindex {true false} [expr {!$value}]}
    optiontype createbool zboolean "" {
	string is boolean
    } {
	if {$value ne ""} {
	    lindex {true false} [expr {!$value}]
	}
    }
    optiontype createbool integer "0" {
	string is entier -strict
    } {expr {[string trim $value] + 0}}
    optiontype createbool zinteger "" {
	string is entier
    } {
	set value [string trim $value]
	expr {$value eq "" ? "" : $value + 0}
    }
    optiontype createbool float "0.0" {
	string is double -strict
    } {expr {[string trim $value] + 0.0}}
    optiontype createbool zfloat "" {
	string is double
    } {
	set value [string trim $value]
	expr {$value eq "" ? "" : $value + 0.0}
    }
    optiontype createbool list "" {
	string is list
    } {list {*}$value}
    optiontype createbool dict "" {
	string is dict
    } {dict merge {} $value}
    optiontype createbool window "" {
	apply {value {expr {$value eq "" || [winfo exists $value]}}}
    }

    # Install the types: those with an erroring test
    oo::objdefine [optiontype createthrow string {} {}] {
	# Special case; everything valid
	method validate value {return $value}
    }
    optiontype createthrow distance "0p" {
	winfo fpixels . $value
    }
    optiontype createthrow image "" {
	if {$value ne ""} {
	    image type $value
	}
    }
    optiontype createthrow color "#000000" {
	winfo rgb . $value
    } {
	lassign [winfo rgb . $value] r g b
	format "#%02x%02x%02x" \
	    [expr {$r >> 8}] [expr {$g >> 8}] [expr {$b >> 8}]
    }
    optiontype createthrow zcolor "" {
	if {$value ne ""} {
	    winfo rgb . $value
	}
    } {
	if {$value ne ""} {
	    lassign [winfo rgb . $value] r g b
	    format "#%02x%02x%02x" \
		[expr {$r >> 8}] [expr {$g >> 8}] [expr {$b >> 8}]
	}
    }
    optiontype createthrow font "TkDefaultFont" {
	# Cheapest property of fonts to read
	font metrics $value -fixed
    }
    optiontype createthrow cursor "" {
	if {$value ne ""} {
	    ::tk::ParseCursor $value
	}
    }

    # Install the types: those with an element table
    optiontype createtable anchor "center" {
	n ne e se s sw w nw center
    }
    optiontype createtable justify "left" {
	center left right
    }
    optiontype createtable relief "flat" {
	flat groove raised ridge solid sunken
    }
}

# Local Variables:
# mode: tcl
# c-basic-offset: 4
# fill-column: 78
# End:

Changes to library/tk.tcl.

813
814
815
816
817
818
819



820
821
822
823
824
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827







+
+
+






set ::tk::Priv(IMETextMark) [dict create]

# Run the Ttk themed widget set initialization
if {$::ttk::library ne ""} {
    uplevel \#0 [list source -encoding utf-8 $::ttk::library/ttk.tcl]
}

# Add in our classes
uplevel \#0 [list source [file join [file dirname [info script]] oocfg.tcl]]

# Local Variables:
# mode: tcl
# fill-column: 78
# End:

Changes to tests/cursor.test.

43
44
45
46
47
48
49






50












51
52
53
54
55
56
57
43
44
45
46
47
48
49
50
51
52
53
54
55

56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74







+
+
+
+
+
+
-
+
+
+
+
+
+
+
+
+
+
+
+







	foreach wincur(num) $wincur(data_octal) {
	    append wincur(data_binary) [binary format c [scan $wincur(num) %o]]
	}
	set wincur(dir) [makeDirectory {dir with spaces}]
	set wincur(file) [makeFile $wincur(data_binary) "test file.cur" $wincur(dir)]
}

# For ensuring that we don't leak memory
testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
    proc getbytes {} {
	set lines [split [memory info] \n]
	return [lindex $lines 3 3]

    }
    proc leaktest {script {iterations 3}} {
	set end [getbytes]
	for {set i 0} {$i < $iterations} {incr i} {
	    uplevel 1 $script
	    set tmp $end
	    set end [getbytes]
	}
	return [expr {$end - $tmp}]
    }
}

test cursor-1.1 {Tk_AllocCursorFromObj - converting internal reps} -constraints {
    testcursor
} -body {
    set x watch
    lindex $x 0
    button .b -cursor $x
    lindex $x 0
835
836
837
838
839
840
841











































842
843
844
845
846




852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910







+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+





+
+
+
+
	button .b -text wait
} -body {
	.b configure -cursor wait
} -cleanup {
	destroy .b
} -result {}

set badcursor {gorp gorp gorp gorp gorp}
test cursor-8.1 {basic cursor parsing} {
    tk::ParseCursor watch
} {}
test cursor-8.2 {basic cursor parsing} -returnCodes error -body {
    tk::ParseCursor $badcursor
} -result {bad cursor spec "gorp gorp gorp gorp gorp"}
test cursor-8.3 {basic cursor parsing} -returnCodes error -body {
    tk::ParseCursor {}
} -result {bad cursor spec ""}
test cursor-8.4 {cursor parsing: memory cleanliness} memory {
    leaktest {
	tk::ParseCursor watch
    }
} 0
test cursor-8.5 {cursor parsing: memory cleanliness} memory {
    leaktest {
	catch {
	    tk::ParseCursor $badcursor
	}
    }
} 0
test cursor-8.6 {evil poke-under-the-covers of cursor parsing} -setup {
    set cursor [join {w a t c h} ""]
} -body {
    tk::ParseCursor $cursor
    tcl::unsupported::representation $cursor
} -match glob -result {value is a cursor *}
test cursor-8.7 {evil poke-under-the-covers of cursor parsing} -setup {
    unset -nocomplain a b
    set cursor [join {a r r o w} ""]
    frame .cursortest -cursor $cursor
    pack .cursortest
    update
} -body {
    set a [tk::ParseCursor $cursor; tcl::unsupported::representation $cursor]
    set b [tk::ParseCursor $cursor; tcl::unsupported::representation $cursor]
    list $a [lindex {!= ==} [string equal $a $b]] $b
} -match glob -cleanup {
    unset -nocomplain cursor
    destroy .cursortest
} -result {{value is a cursor *} == {value is a cursor *}}

# -------------------------------------------------------------------------

# cleanup
cleanupTests
return

# Local Variables:
# mode: tcl
# End:

Added tests/oocfg.test.































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
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
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
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
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
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
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
# This file is a Tcl script to test entry widgets in Tk.  It is
# organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.

package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test

deleteWindows

# A simple superclass to handle calling Initialise and cleaning up
oo::class create cfgsupport {
    private variable window
    constructor {w args} {
	set window [frame $w]
	my Initialise $w {*}$args
    }
    destructor {
	destroy $window
    }

    self method clean {} {
	foreach c [info class subclasses [self]] {
	    catch {$c destroy}
	}
    }
}

# A simpler version without even initialisation; this is a plain class.  Note
# that cfgsupport doesn't inherit from this because the clean method is too
# simple-minded.
oo::class create base {
    private variable window
    constructor {w args} {
	set window [frame $w]
    }
    destructor {
	destroy $window
    }

    self method clean {} {
	foreach c [info class subclasses [self]] {
	    catch {$c destroy}
	}
    }
}

test oocfg-1.1 {tk::configurable: basic test} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option foo
    }
    set gorp [Gorp new .gorp -foo bar]
    list [$gorp configure] [$gorp configure -foo] [$gorp configure -foo grill] \
	[$gorp cget -foo]
} -cleanup {
    cfgsupport clean
} -result {{{-foo foo Foo {} bar}} {-foo foo Foo {} bar} {} grill}
test oocfg-1.2 {tk::configurable: basic test with default} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option foo -default 135
    }
    set gorp [Gorp new .gorp -foo bar]
    list [$gorp configure] [$gorp configure -foo] [$gorp configure -foo grill] \
	[$gorp cget -foo]
} -cleanup {
    cfgsupport clean
} -result {{{-foo foo Foo 135 bar}} {-foo foo Foo 135 bar} {} grill}
test oocfg-1.3 {tk::configurable: basic test with typing} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option foo -type integer
    }
    set gorp [Gorp new .gorp -foo 789]
    list [$gorp configure] [$gorp configure -foo] [$gorp configure -foo 153] \
	[$gorp cget -foo] [catch {$gorp configure -foo bar} msg] $msg
} -cleanup {
    cfgsupport clean
} -result {{{-foo foo Foo 0 789}} {-foo foo Foo 0 789} {} 153 1 {invalid integer value "bar"}}
test oocfg-1.4 {tk::configurable: basic test with alias} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option foo -type integer -default 135
	option bar -alias foo
    }
    set gorp [Gorp new .gorp -bar 789]
    list [$gorp configure] [$gorp configure -bar] [$gorp configure -bar 153] \
	[$gorp cget -foo] [$gorp cget -bar] \
	[catch {$gorp configure -bar grill} msg] $msg
} -cleanup {
    cfgsupport clean
} -result {{{-bar -foo} {-foo foo Foo 135 789}} {-bar -foo} {} 153 153 1 {invalid integer value "grill"}}
test oocfg-1.5 {tk::configurable: basic test with option DB} -setup {
    option clear
} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option foo -default bar
    }
    option add *gorp.foo ok
    set gorp [Gorp new .gorp]
    $gorp configure
} -cleanup {
    option clear
    cfgsupport clean
} -result {{-foo foo Foo bar ok}}
test oocfg-1.6 {tk::configurable: basic test with option DB} -setup {
    option clear
} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option foo -default bar
    }
    option add *gorp.Foo ok
    set gorp [Gorp new .gorp]
    $gorp configure
} -cleanup {
    option clear
    cfgsupport clean
} -result {{-foo foo Foo bar ok}}
test oocfg-1.7 {tk::configurable: basic test with option DB} -setup {
    option clear
} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option foo -default bar
    }
    option add *gorp.foo xyz
    option add *gorp.Foo zyx
    set gorp [Gorp new .gorp]
    $gorp configure
} -cleanup {
    option clear
    cfgsupport clean
} -result {{-foo foo Foo bar zyx}}
test oocfg-1.8 {tk::configurable: basic test with option DB} -setup {
    option clear
} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option foo -name foobar -class FooBar -default ok
    }
    option add *gorp.foo bad
    set gorp [Gorp new .gorp]
    $gorp configure
} -cleanup {
    option clear
    cfgsupport clean
} -result {{-foo foobar FooBar ok ok}}
test oocfg-1.9 {tk::configurable: basic test with option DB} -setup {
    option clear
} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option foo -name foobar -class FooBar -default ok
    }
    option add *gorp.foo bad
    option add *FooBar great
    set gorp [Gorp new .gorp]
    $gorp configure
} -cleanup {
    option clear
    cfgsupport clean
} -result {{-foo foobar FooBar ok great}}
test oocfg-1.10 {tk::configurable: basic test with option DB} -setup {
    option clear
} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	# Values from option DB are subject to validation, but failure just
	# triggers using the default, not an error.
	option foo -name foo -default 123 -type integer
    }
    option add *gorp.foo bad
    set gorp [Gorp new .gorp]
    $gorp configure
} -cleanup {
    option clear
    cfgsupport clean
} -result {{-foo foo Foo 123 123}}
test oocfg-1.11 {tk::configurable: basic test with inheritance} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option foo
    }
    tk::configurable create Gorp2 {
	superclass Gorp
	option bar
    }
    set gorp [Gorp2 new .gorp -foo 1 -bar 2]
    $gorp configure
} -cleanup {
    cfgsupport clean
} -result {{-bar bar Bar {} 2} {-foo foo Foo {} 1}}
test oocfg-1.12 {tk::configurable: basic test with inheritance} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option foo -default abc
    }
    tk::configurable create Gorp2 {
	superclass Gorp
	option foo -default xyz
    }
    set gorp [Gorp2 new .gorp]
    $gorp configure
} -cleanup {
    cfgsupport clean
} -result {{-foo foo Foo xyz xyz}}

test oocfg-2.1 {tk::configurable: option cfg abbreviation} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option foo -def ok
	option bar -al foo
    }
    [Gorp new .gorp] configure
} -cleanup {
    cfgsupport clean
} -result {{-bar -foo} {-foo foo Foo ok ok}}
test oocfg-2.2 {tk::configurable: option cfg abbreviation} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option foo -def ok
	option bar -al -foo
    }
    [Gorp new .gorp] configure
} -cleanup {
    cfgsupport clean
} -result {{-bar -foo} {-foo foo Foo ok ok}}
test oocfg-2.3 {tk::configurable: option cfg abbreviation} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option foo -def ok -n john -c Smith
    }
    [Gorp new .gorp] configure
} -cleanup {
    cfgsupport clean
} -result {{-foo john Smith ok ok}}
test oocfg-2.4 {tk::configurable: option cfg abbreviation and case} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option FOO -ty str
    }
    [Gorp new .gorp] configure
} -cleanup {
    cfgsupport clean
} -result {{-FOO foo Foo {} {}}}
test oocfg-2.5 {tk::configurable: option cfg abbreviation} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option foo -ty just -de r
    }
    [Gorp new .gorp] configure
} -cleanup {
    cfgsupport clean
} -result {{-foo foo Foo right right}}

test oocfg-3.1 {tk::configurable: option errors} -returnCodes error -body {
    tk::configurable create Gorp {
	option foo -gorp
    }
} -result {wrong # args: should be "option name ?-option value ...?"}
test oocfg-3.2 {tk::configurable: option errors} -returnCodes error -body {
    tk::configurable create Gorp {
	option foo -gorp blat
    }
} -result {bad option "-gorp": must be -alias, -class, -default, -initonly, -name, or -type}
test oocfg-3.3 {tk::configurable: option errors} -returnCodes error -body {
    tk::configurable create Gorp {
	option foo -type gorp
    }
} -match glob -result {unknown or ambiguous subcommand "gorp": must be *}
test oocfg-3.3a {tk::configurable: option errors} -returnCodes error -body {
    tk::configurable create Gorp {
	option foo -type gorp
    }
} -match glob -result {*: must be anchor, boolean, color, cursor, dict, distance, float, font, image, integer, justify, list, relief, string, window, zboolean, zcolor, zfloat, or zinteger}
test oocfg-3.3b {tk::configurable: option errors} -setup {
    unset -nocomplain ot
} -body {
    set ot [tk::optiontype createbool gorp gorpgorp {string length}]
    tk::configurable create Gorp {
	option foo -type gorp -default ""
    }
} -returnCodes error -cleanup {
    if {[info exists ot]} {
	$ot destroy
	unset ot
    }
} -result {invalid gorp value ""}
test oocfg-3.4 {tk::configurable: option errors} -returnCodes error -body {
    tk::configurable create Gorp {
	option foo -type integer -default abc
    }
} -result {invalid integer value "abc"}
test oocfg-3.5 {tk::configurable: option errors} -returnCodes error -body {
    tk::configurable create Gorp {
	option foo -default abc -type integer
    }
} -result {invalid integer value "abc"}
test oocfg-3.6 {tk::configurable: option errors} -returnCodes error -body {
    tk::configurable create Gorp {
	option @bad
    }
} -result {bad option name "@bad": must be alphanumeric starting with a letter}
test oocfg-3.7 {tk::configurable: option errors} -returnCodes error -body {
    tk::configurable create Gorp {
	option foo -name Abc
    }
} -result {-name must be alphanumeric with a leading lower-case letter}
test oocfg-3.8 {tk::configurable: option errors} -returnCodes error -body {
    tk::configurable create Gorp {
	option foo -class abc
    }
} -result {-class must be alphanumeric with a leading capital letter}
test oocfg-3.9 {tk::configurable: option errors} -returnCodes error -body {
    tk::configurable create Gorp {
	option foo -alias foo
    }
} -result {no such option "-foo"}
test oocfg-3.10 {tk::configurable: option errors} -returnCodes error -body {
    tk::configurable create Gorp {
	option foo
	option bar -type string -alias foo
    }
} -result {-alias may only ever be used on its own}
test oocfg-3.11 {tk::configurable: option errors} -returnCodes error -body {
    tk::configurable create Gorp {
	option foo -init gorp
    }
} -result {invalid boolean value "gorp"}
test oocfg-3.12 {tk::configurable: option errors} -returnCodes error -body {
    tk::configurable create Gorp {
	option foo -init 1
	option bar -alias foo
    }
} -result {may not alias init-only option "-foo"}
test oocfg-3.13 {tk::configurable: option errors (cross class)} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option foo -init 1
    }
    tk::configurable create Gorp2 {
	superclass Gorp
	option bar -alias foo
    }
} -returnCodes error -cleanup {
    cfgsupport clean
} -result {may not alias init-only option "-foo"}

test oocfg-4.1 {tk::configurable: configure behaviour: option sorting} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option foe -default 1 -name alpha -class Jack
	option fie -default 2 -name beta  -class Jack
	option fum -default 3 -name gamma -class Beanstalk
	option fee -default 4 -name delta -class Beanstalk
    }
    set gorp [Gorp new .gorp]
    $gorp configure
} -cleanup {
    cfgsupport clean
} -result {{-fee delta Beanstalk 4 4} {-fie beta Jack 2 2} {-foe alpha Jack 1 1} {-fum gamma Beanstalk 3 3}}
test oocfg-4.2 {tk::configurable: configure behaviour: ambiguity} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option foe
	option fie
	option fum
	option fee
    }
    set gorp [Gorp new .gorp]
    $gorp configure -f
} -returnCodes error -cleanup {
    cfgsupport clean
} -result {ambiguous option "-f": must be -fee, -fie, -foe, or -fum}
test oocfg-4.3 {tk::configurable: configure behaviour: inheritance assembly} -body {
    tk::configurable create GorpFoe {
	superclass cfgsupport
	option foe
    }
    tk::configurable create GorpFie {
	superclass cfgsupport
	option fie
    }
    tk::configurable create GorpFum {
	superclass cfgsupport
	option fum
    }
    tk::configurable create GorpFee {
	superclass cfgsupport
	option fee
    }
    tk::configurable create Gorp {
	superclass GorpFum GorpFee
	mixin GorpFoe
    }
    set gorp [Gorp new .gorp]
    oo::objdefine $gorp mixin GorpFie
    $gorp configure -f
} -returnCodes error -cleanup {
    cfgsupport clean
} -result {ambiguous option "-f": must be -fee, -fie, -foe, or -fum}
test oocfg-4.4 {tk::configurable: configure behaviour: no opts} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
    }
    [Gorp new .gorp] configure
} -cleanup {
    cfgsupport clean
} -result {}
test oocfg-4.5 {tk::configurable: configure behaviour: no opts} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
    }
    [Gorp new .gorp] configure -foo
} -returnCodes error -cleanup {
    cfgsupport clean
} -result {bad option "-foo": no valid options}
test oocfg-4.6 {tk::configurable: configure behaviour: no opts} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
    }
    [Gorp new .gorp] configure -foo bar
} -returnCodes error -cleanup {
    cfgsupport clean
} -result {bad option "-foo": no valid options}
test oocfg-4.7 {tk::configurable: configure behaviour: name prefixes} -setup {
    unset -nocomplain result msg
} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option verylongname -type int
    }
    set gorp [Gorp new .gorp -v 1]
    lappend result [$gorp configure] [$gorp configure -v]
    $gorp configure -v 2
    lappend result [$gorp cget -v]
    oo::define Gorp option variation
    lappend result :=:=: [catch {$gorp cget -v} msg] $msg
} -cleanup {
    cfgsupport clean
} -result {{{-verylongname verylongname Verylongname 0 1}} {-verylongname verylongname Verylongname 0 1} 2 :=:=: 1 {ambiguous option "-v": must be -variation or -verylongname}}
test oocfg-4.8 {tk::configurable: configure behaviour: errors} -setup {
    unset -nocomplain msg opt
} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option a
    }
    catch {
	set gorp [Gorp create gorp .gorp]
	$gorp configure -a a -a
    } msg opt
    list $msg [dict get $opt -errorcode] [dict get $opt -errorinfo]
} -cleanup {
    cfgsupport clean
} -result {{wrong # args: should be "::gorp configure ?-option value ...?"} {TCL WRONGARGS} {wrong # args: should be "::gorp configure ?-option value ...?"
    while executing
"$gorp configure -a a -a"}}
test oocfg-4.9 {tk::configurable: configure behaviour: errors} -setup {
    unset -nocomplain msg opt
} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option a
    }
    catch {
	set gorp [Gorp create gorp .gorp]
	$gorp configure -b
    } msg opt
    list $msg [dict get $opt -errorcode] [dict get $opt -errorinfo]
} -cleanup {
    cfgsupport clean
} -result {{bad option "-b": must be -a} {TK LOOKUP OPTION -b} {bad option "-b": must be -a
    while executing
"$gorp configure -b"}}
test oocfg-4.10 {tk::configurable: configure behaviour: errors} -setup {
    unset -nocomplain msg opt
} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option a
    }
    catch {
	set gorp [Gorp create gorp .gorp]
	$gorp configure -b a
    } msg opt
    list $msg [dict get $opt -errorcode] [dict get $opt -errorinfo]
} -cleanup {
    cfgsupport clean
} -result {{bad option "-b": must be -a} {TK LOOKUP OPTION -b} {bad option "-b": must be -a
    while executing
"$gorp configure -b a"}}
test oocfg-4.11 {tk::configurable: configure behaviour: errors} -setup {
    unset -nocomplain msg opt
} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option a -type integer
    }
    catch {
	set gorp [Gorp create gorp .gorp]
	$gorp configure -a gorp
    } msg opt
    list $msg [dict get $opt -errorcode] [dict get $opt -errorinfo]
} -cleanup {
    cfgsupport clean
} -result {{invalid integer value "gorp"} {TK VALUE INTEGER} {invalid integer value "gorp"
    while executing
"$gorp configure -a gorp"}}
test oocfg-4.12 {tk::configurable: configure behaviour: errors} -setup {
    unset -nocomplain msg opt
} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option a -type distance
    }
    catch {
	set gorp [Gorp create gorp .gorp]
	$gorp configure -a gorp
    } msg opt
    list $msg [dict get $opt -errorcode] [dict get $opt -errorinfo]
} -cleanup {
    cfgsupport clean
} -result {{bad screen distance "gorp"} {TK VALUE DISTANCE} {bad screen distance "gorp"
    while executing
"$gorp configure -a gorp"}}
test oocfg-4.13 {tk::configurable: configure behaviour: errors} -setup {
    unset -nocomplain msg opt
} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option a -type color
    }
    catch {
	set gorp [Gorp create gorp .gorp]
	$gorp configure -a @@@gorp@@@
    } msg opt
    list $msg [dict get $opt -errorcode] [dict get $opt -errorinfo]
} -cleanup {
    cfgsupport clean
} -result {{unknown color name "@@@gorp@@@"} {TK VALUE COLOR} {unknown color name "@@@gorp@@@"
    while executing
"$gorp configure -a @@@gorp@@@"}}
test oocfg-4.14 {tk::configurable: configure behaviour: errors} -setup {
    unset -nocomplain msg opt
} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option a -type font
    }
    catch {
	set gorp [Gorp create gorp .gorp]
	# Invalid font names are weird; font parsing is weird
	$gorp configure -a "gorp {}gorp"
    } msg opt
    list $msg [dict get $opt -errorcode] [dict get $opt -errorinfo]
} -cleanup {
    cfgsupport clean
} -result {{font "gorp {}gorp" doesn't exist} {TK VALUE FONT} {font "gorp {}gorp" doesn't exist
    while executing
"$gorp configure -a "gorp {}gorp""}}
test oocfg-4.15 {tk::configurable: configure behaviour: errors} -setup {
    unset -nocomplain msg opt
} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option a -type image
    }
    catch {
	set gorp [Gorp create gorp .gorp]
	$gorp configure -a @@@gorp@@@
    } msg opt
    list $msg [dict get $opt -errorcode] [dict get $opt -errorinfo]
} -cleanup {
    cfgsupport clean
} -result {{image "@@@gorp@@@" doesn't exist} {TK VALUE IMAGE} {image "@@@gorp@@@" doesn't exist
    while executing
"$gorp configure -a @@@gorp@@@"}}
test oocfg-4.16 {tk::configurable: configure behaviour: errors} -setup {
    unset -nocomplain msg opt
} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option a -type justify
    }
    catch {
	set gorp [Gorp create gorp .gorp]
	$gorp configure -a gorp
    } msg opt
    list $msg [dict get $opt -errorcode] [dict get $opt -errorinfo]
} -cleanup {
    cfgsupport clean
} -result {{bad justify "gorp": must be center, left, or right} {TK VALUE JUSTIFY} {bad justify "gorp": must be center, left, or right
    while executing
"$gorp configure -a gorp"}}

test oocfg-5.1 {tk::configurable: Initialise behaviour: option sorting} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option foe -default 1 -name alpha -class Jack
	option fie -default 2 -name beta  -class Jack
	option fum -default 3 -name gamma -class Beanstalk
	option fee -default 4 -name delta -class Beanstalk
    }
    Gorp new .gorp -gorp
} -returnCodes error -cleanup {
    cfgsupport clean
} -result {wrong # args: should be "my Initialise pathName ?-option value...?"}
test oocfg-5.2 {tk::configurable: Initialise behaviour: ambiguity} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option foe
	option fie
	option fum
	option fee
    }
    Gorp new .gorp -f gorp
} -returnCodes error -cleanup {
    cfgsupport clean
} -result {ambiguous option "-f": must be -fee, -fie, -foe, or -fum}
test oocfg-5.3 {tk::configurable: Initialise behaviour: inheritance assembly} -body {
    tk::configurable create GorpFoe {
	superclass cfgsupport
	option foe
    }
    tk::configurable create GorpFie {
	superclass cfgsupport
	option fie
    }
    tk::configurable create GorpFum {
	superclass cfgsupport
	option fum
    }
    tk::configurable create GorpFee {
	superclass cfgsupport
	option fee
    }
    tk::configurable create Gorp {
	superclass GorpFum GorpFee
	mixin GorpFoe GorpFie
    }
    [Gorp new .gorp -fee 1 -fie 2 -foe 3 -fum 4] configure
} -cleanup {
    cfgsupport clean
} -result {{-fee fee Fee {} 1} {-fie fie Fie {} 2} {-foe foe Foe {} 3} {-fum fum Fum {} 4}}
test oocfg-5.4 {tk::configurable: Initialise behaviour: no opts} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
    }
    Gorp create ::gorp .gorp
} -cleanup {
    cfgsupport clean
} -result ::gorp
test oocfg-5.5 {tk::configurable: Initialise behaviour: no opts} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
    }
    Gorp new .gorp -foo
} -returnCodes error -cleanup {
    cfgsupport clean
} -result {wrong # args: should be "my Initialise pathName ?-option value...?"}
test oocfg-5.6 {tk::configurable: Initialise behaviour: no opts} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
    }
    Gorp new .gorp -foo bar
} -returnCodes error -cleanup {
    cfgsupport clean
} -result {bad option "-foo": no valid options}
test oocfg-5.7 {tk::configurable: Initialise behaviour: name prefixes} -setup {
    unset -nocomplain result msg
} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option verylongname -type int
    }
    set gorp [Gorp new .gorp -v 1]
    lappend result [$gorp configure]
    oo::define Gorp option variation
    lappend result :=:=: [catch {Gorp new .gorp2 -v 2} msg] $msg
} -cleanup {
    cfgsupport clean
} -result {{{-verylongname verylongname Verylongname 0 1}} :=:=: 1 {ambiguous option "-v": must be -variation or -verylongname}}
test oocfg-5.8 {tk::configurable: Initialise behaviour: errors} -setup {
    unset -nocomplain msg opt
} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option a
    }
    catch {
	Gorp create gorp .gorp -a a -a
    } msg opt
    list $msg [dict get $opt -errorcode] [dict get $opt -errorinfo]
} -cleanup {
    cfgsupport clean
} -result {{wrong # args: should be "my Initialise pathName ?-option value...?"} {TCL WRONGARGS} {wrong # args: should be "my Initialise pathName ?-option value...?"
    while executing
"my Initialise $w {*}$args"
    (class "::cfgsupport" constructor line 3)
    invoked from within
"Gorp create gorp .gorp -a a -a"}}
test oocfg-5.9 {tk::configurable: Initialise behaviour: errors} -setup {
    unset -nocomplain msg opt
} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option a
    }
    catch {
	Gorp create gorp .gorp -b gorp
    } msg opt
    list $msg [dict get $opt -errorcode] [dict get $opt -errorinfo]
} -cleanup {
    cfgsupport clean
} -result {{bad option "-b": must be -a} {TK LOOKUP OPTION -b} {bad option "-b": must be -a
    while executing
"my Initialise $w {*}$args"
    (class "::cfgsupport" constructor line 3)
    invoked from within
"Gorp create gorp .gorp -b gorp"}}
test oocfg-5.10 {tk::configurable: Initialise behaviour: errors} -setup {
    unset -nocomplain msg opt
} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option a
    }
    catch {
	Gorp create gorp .gorp -b a
    } msg opt
    list $msg [dict get $opt -errorcode] [dict get $opt -errorinfo]
} -cleanup {
    cfgsupport clean
} -result {{bad option "-b": must be -a} {TK LOOKUP OPTION -b} {bad option "-b": must be -a
    while executing
"my Initialise $w {*}$args"
    (class "::cfgsupport" constructor line 3)
    invoked from within
"Gorp create gorp .gorp -b a"}}
test oocfg-5.11 {tk::configurable: Initialise behaviour: errors} -setup {
    unset -nocomplain msg opt
} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option a -type integer
    }
    catch {
	Gorp create gorp .gorp -a gorp
    } msg opt
    list $msg [dict get $opt -errorcode] [dict get $opt -errorinfo]
} -cleanup {
    cfgsupport clean
} -result {{invalid integer value "gorp"} {TK VALUE INTEGER} {invalid integer value "gorp"
    while executing
"my Initialise $w {*}$args"
    (class "::cfgsupport" constructor line 3)
    invoked from within
"Gorp create gorp .gorp -a gorp"}}
test oocfg-5.12 {tk::configurable: Initialise behaviour: errors} -setup {
    unset -nocomplain msg opt
} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option a -type distance
    }
    catch {
	Gorp create gorp .gorp -a gorp
    } msg opt
    list $msg [dict get $opt -errorcode] [dict get $opt -errorinfo]
} -cleanup {
    cfgsupport clean
} -result {{bad screen distance "gorp"} {TK VALUE DISTANCE} {bad screen distance "gorp"
    while executing
"my Initialise $w {*}$args"
    (class "::cfgsupport" constructor line 3)
    invoked from within
"Gorp create gorp .gorp -a gorp"}}
test oocfg-5.13 {tk::configurable: Initialise behaviour: errors} -setup {
    unset -nocomplain msg opt
} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option a -type color
    }
    catch {
	Gorp create gorp .gorp -a @@@gorp@@@
    } msg opt
    list $msg [dict get $opt -errorcode] [dict get $opt -errorinfo]
} -cleanup {
    cfgsupport clean
} -result {{unknown color name "@@@gorp@@@"} {TK VALUE COLOR} {unknown color name "@@@gorp@@@"
    while executing
"my Initialise $w {*}$args"
    (class "::cfgsupport" constructor line 3)
    invoked from within
"Gorp create gorp .gorp -a @@@gorp@@@"}}
test oocfg-5.14 {tk::configurable: Initialise behaviour: errors} -setup {
    unset -nocomplain msg opt
} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option a -type font
    }
    catch {
	# Invalid font names are weird; font parsing is weird
	Gorp create gorp .gorp -a "gorp {}gorp"
    } msg opt
    list $msg [dict get $opt -errorcode] [dict get $opt -errorinfo]
} -cleanup {
    cfgsupport clean
} -result {{font "gorp {}gorp" doesn't exist} {TK VALUE FONT} {font "gorp {}gorp" doesn't exist
    while executing
"my Initialise $w {*}$args"
    (class "::cfgsupport" constructor line 3)
    invoked from within
"Gorp create gorp .gorp -a "gorp {}gorp""}}
test oocfg-5.15 {tk::configurable: Initialise behaviour: errors} -setup {
    unset -nocomplain msg opt
} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option a -type image
    }
    catch {
	Gorp create gorp .gorp -a @@@gorp@@@
    } msg opt
    list $msg [dict get $opt -errorcode] [dict get $opt -errorinfo]
} -cleanup {
    cfgsupport clean
} -result {{image "@@@gorp@@@" doesn't exist} {TK VALUE IMAGE} {image "@@@gorp@@@" doesn't exist
    while executing
"my Initialise $w {*}$args"
    (class "::cfgsupport" constructor line 3)
    invoked from within
"Gorp create gorp .gorp -a @@@gorp@@@"}}
test oocfg-5.16 {tk::configurable: Initialise behaviour: errors} -setup {
    unset -nocomplain msg opt
} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option a -type justify
    }
    catch {
	Gorp create gorp .gorp -a gorp
    } msg opt
    list $msg [dict get $opt -errorcode] [dict get $opt -errorinfo]
} -cleanup {
    cfgsupport clean
} -result {{bad justify "gorp": must be center, left, or right} {TK VALUE JUSTIFY} {bad justify "gorp": must be center, left, or right
    while executing
"my Initialise $w {*}$args"
    (class "::cfgsupport" constructor line 3)
    invoked from within
"Gorp create gorp .gorp -a gorp"}}

test oocfg-6.1 {tk::configurable: Initialise: alt spelling} -setup {
    unset -nocomplain msg opt
} -body {
    tk::configurable create Gorp {
	superclass base
	constructor {w args} {
	    next $w
	    my Initialize $w {*}$args
	}
	option a
    }
    set gorp [Gorp create gorp .gorp -a gorp]
    list $gorp [$gorp cget -a]
} -cleanup {
    base clean
} -result {::gorp gorp}
test oocfg-6.2 {tk::configurable: Initialise: alt spelling} -setup {
    unset -nocomplain msg opt
} -body {
    tk::configurable create Gorp {
	superclass base
	constructor {w args} {
	    next $w
	    my Initialize $w {*}$args
	}
	option a
    }
    catch {
	Gorp create gorp .gorp -a gorp -a
    } msg opt
    list $msg [dict get $opt -errorcode] [dict get $opt -errorinfo]
} -cleanup {
    base clean
} -result {{wrong # args: should be "my Initialize pathName ?-option value...?"} {TCL WRONGARGS} {wrong # args: should be "my Initialize pathName ?-option value...?"
    while executing
"my Initialize $w {*}$args"
    (class "::Gorp" constructor line 3)
    invoked from within
"Gorp create gorp .gorp -a gorp -a"}}
test oocfg-6.3 {tk::configurable: Initialise: double call} -setup {
    unset -nocomplain msg opt
} -body {
    tk::configurable create Gorp {
	superclass base
	constructor {w args} {
	    next $w
	    my Initialise $w {*}$args
	    my Initialize $w {*}$args
	}
	option a
    }
    catch {
	Gorp create gorp .gorp -a gorp
    } msg opt
    list $msg [dict get $opt -errorcode] [dict get $opt -errorinfo]
} -cleanup {
    base clean
} -result {{this object is already initialised} {TK DOUBLE_INIT} {this object is already initialised
    while executing
"my Initialize $w {*}$args"
    (class "::Gorp" constructor line 4)
    invoked from within
"Gorp create gorp .gorp -a gorp"}}
test oocfg-6.4 {tk::configurable: Initialise: smartass} -setup {
    unset -nocomplain msg opt
} -body {
    tk::configurable create Gorp {
	superclass base
	constructor {w args} {
	    # NOT a recommended way of working; rude towards subclasses and
	    # uses not-well-documented result of superclass constructor.
	    tailcall my Initialise [next $w] {*}$args
	}
	option a
    }
    catch {
	Gorp create gorp .gorp -a gorp -a
    } msg opt
    list $msg [winfo exists .gorp] \
	[dict get $opt -errorcode] [dict get $opt -errorinfo]
} -cleanup {
    base clean
} -result {{wrong # args: should be "my Initialise pathName ?-option value...?"} 0 {TCL WRONGARGS} {wrong # args: should be "my Initialise pathName ?-option value...?"
    while executing
"my Initialise .gorp -a gorp -a"
    invoked from within
"Gorp create gorp .gorp -a gorp -a"}}

test oocfg-7.1 {tk::configurable: init-only params} -setup {
    unset -nocomplain msg opt
} -body {
    tk::configurable create Gorp {
	superclass base
	constructor {w args} {
	    next $w
	    my Initialise $w {*}$args
	}
	option a -initonly 1
    }
    set gorp [Gorp create foobar .gorp -a blarg]
    list $gorp [$gorp configure] [$gorp cget -a] \
	[catch {$gorp configure -a foo} msg opt] $msg \
	[dict get $opt -errorcode] [dict get $opt -errorinfo]
} -cleanup {
    base clean
} -result {::foobar {{-a a A {} blarg}} blarg 1 {read only option: -a} {TK LOOKUP OPTION -a} {read only option: -a
    while executing
"$gorp configure -a foo"}}

test oocfg-8.1 {tk::configurable: overridden getter} -setup {
    unset -nocomplain ::reads
    set ::reads {}
    proc recordcall {} "lappend ::reads \[info level [expr [info level] + 1]\]"
} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option foo
	method <OptRead-foo> {} {
	    recordcall
	    tailcall my <StdOptRead> foo
	}
    }
    Gorp create gorp .gorp -foo 1
    list $reads [gorp cget -foo] $reads [gorp configure -foo] $reads \
	[gorp configure] $reads [gorp configure -foo 2] $reads
} -cleanup {
    cfgsupport clean
    rename recordcall {}
} -result {{} 1 {{gorp cget -foo}} {-foo foo Foo {} 1} {{gorp cget -foo} {gorp configure -foo}} {{-foo foo Foo {} 1}} {{gorp cget -foo} {gorp configure -foo} {gorp configure}} {} {{gorp cget -foo} {gorp configure -foo} {gorp configure}}}
test oocfg-8.2 {tk::configurable: overridden getter} -setup {
    unset -nocomplain ::reads
    set ::reads {}
    proc recordcall {} "lappend ::reads \[info level [expr [info level] + 1]\]"
} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	method <OptRead-foo> {} {
	    recordcall
	    tailcall my <StdOptRead> foo
	}
	option foo
    }
    Gorp create gorp .gorp -foo 1
    list $reads [gorp cget -foo] $reads [gorp configure -foo] $reads \
	[gorp configure] $reads [gorp configure -foo 2] $reads
} -cleanup {
    cfgsupport clean
    rename recordcall {}
} -result {{} 1 {{gorp cget -foo}} {-foo foo Foo {} 1} {{gorp cget -foo} {gorp configure -foo}} {{-foo foo Foo {} 1}} {{gorp cget -foo} {gorp configure -foo} {gorp configure}} {} {{gorp cget -foo} {gorp configure -foo} {gorp configure}}}
test oocfg-8.3 {tk::configurable: overridden setter} -setup {
    unset -nocomplain ::writes
    set ::writes {}
    proc recordcall {} "lappend ::writes \[info level [expr [info level] + 1]\]"
} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option foo
	method <OptWrite-foo> value {
	    recordcall
	    tailcall my <StdOptWrite> foo $value
	}
    }
    Gorp create gorp .gorp -foo 1
    list $writes [gorp cget -foo] $writes [gorp configure -foo] $writes \
	[gorp configure] $writes [gorp configure -foo 2] $writes
} -cleanup {
    cfgsupport clean
    rename recordcall {}
} -result {{{Gorp create gorp .gorp -foo 1}} 1 {{Gorp create gorp .gorp -foo 1}} {-foo foo Foo {} 1} {{Gorp create gorp .gorp -foo 1}} {{-foo foo Foo {} 1}} {{Gorp create gorp .gorp -foo 1}} {} {{Gorp create gorp .gorp -foo 1} {gorp configure -foo 2}}}
test oocfg-8.4 {tk::configurable: overridden setter} -setup {
    unset -nocomplain ::writes
    set ::writes {}
    proc recordcall {} "lappend ::writes \[info level [expr [info level] + 1]\]"
} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	method <OptWrite-foo> value {
	    recordcall
	    tailcall my <StdOptWrite> foo $value
	}
	option foo
    }
    Gorp create gorp .gorp -foo 1
    list $writes [gorp cget -foo] $writes [gorp configure -foo] $writes \
	[gorp configure] $writes [gorp configure -foo 2] $writes
} -cleanup {
    cfgsupport clean
    rename recordcall {}
} -result {{{Gorp create gorp .gorp -foo 1}} 1 {{Gorp create gorp .gorp -foo 1}} {-foo foo Foo {} 1} {{Gorp create gorp .gorp -foo 1}} {{-foo foo Foo {} 1}} {{Gorp create gorp .gorp -foo 1}} {} {{Gorp create gorp .gorp -foo 1} {gorp configure -foo 2}}}

test oocfg-9.1 {tk::configurable: checkpointing} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option foo -type integer
	option bar -type integer
	method <OptionsMakeCheckpoint> {} {
	    variable ""
	    # Not actually safe in general because of aliases, but there's
	    # none of them in this test
	    join [lmap p [info object properties [self] -all] {
		set ([string trimleft $p -])
	    }] :
	}
	method <OptionsRestoreCheckpoint> state {
	    variable ""
	    foreach p [info object properties [self] -all] v [split $state :] {
		set ([string trimleft $p -]) $v
	    }
	}
	export <OptionsMakeCheckpoint> <OptionsRestoreCheckpoint>
    }
    Gorp create gorp .gorp
    # Note that this checks that we can restore an illegal state.
    # User code is strongly recommended to not do this!
    list [info object properties gorp -all] [gorp <OptionsMakeCheckpoint>] \
	[catch {gorp configure -foo 1 -bar x}] [gorp configure] \
	[gorp configure -foo 1 -bar 2] [gorp <OptionsMakeCheckpoint>] \
	[gorp <OptionsRestoreCheckpoint> pqr:xyz] [gorp configure]
} -cleanup {
    cfgsupport clean
} -result {{-bar -foo} 0:0 1 {{-bar bar Bar 0 0} {-foo foo Foo 0 0}} {} 2:1 {} {{-bar bar Bar 0 pqr} {-foo foo Foo 0 xyz}}}
test oocfg-9.2 {tk::configurable: checkpointing} -body {
    tk::configurable create Gorp {
	superclass cfgsupport
	option foo -type integer
	option bar -type integer
	export <OptionsMakeCheckpoint> <OptionsRestoreCheckpoint>
    }
    Gorp create gorp .gorp
    # Note that this checks that we can restore an illegal state.
    # User code is strongly recommended to not do this!
    list [info object properties gorp -all] [gorp <OptionsMakeCheckpoint>] \
	[catch {gorp configure -foo 1 -bar x}] [gorp configure] \
	[gorp configure -foo 1 -bar 2] [gorp <OptionsMakeCheckpoint>] \
	[gorp <OptionsRestoreCheckpoint> {bar pqr foo xyz}] [gorp configure]
} -cleanup {
    cfgsupport clean
} -result {{-bar -foo} {foo 0 bar 0} 1 {{-bar bar Bar 0 0} {-foo foo Foo 0 0}} {} {foo 1 bar 2} {} {{-bar bar Bar 0 pqr} {-foo foo Foo 0 xyz}}}

test oocfg-10.1 {standard type list} -returnCodes error -body {
    tk::OptionType ?
} -result {unknown or ambiguous subcommand "?": must be anchor, boolean, color, cursor, dict, distance, float, font, image, integer, justify, list, relief, string, window, zboolean, zcolor, zfloat, or zinteger}
test oocfg-10.2 {types: registration and deregistration} -match glob -body {
    catch {tk::OptionType ?} msg1
    set gorp [tk::optiontype createbool gorp "abc" {apply {x {
	expr {[string length $x] % 2}
    }}}]
    catch {tk::OptionType ?} msg2
    $gorp destroy
    catch {tk::OptionType ?} msg3
    list $msg1 | $msg2 | $msg3
} -result {{*font, image*} | {*font, gorp, image*} | {*font, image*}}

test oocfg-11.1 {types: anchor} {
    tk::OptionType anchor default
} center
test oocfg-11.2 {types: anchor} {
    tk::OptionType anchor validate c
} center
test oocfg-11.3 {types: anchor} -returnCodes error -body {
    tk::OptionType anchor validate gorp
} -result {bad anchor "gorp": must be n, ne, e, se, s, sw, w, nw, or center}

test oocfg-12.1 {types: boolean} {
    tk::OptionType boolean default
} false
test oocfg-12.2 {types: boolean} {
    tk::OptionType boolean validate 0
} false
test oocfg-12.3 {types: boolean} -returnCodes error -body {
    tk::OptionType boolean validate gorp
} -result {invalid boolean value "gorp"}

test oocfg-13.1 {types: color} {
    tk::OptionType color default
} "#000000"
test oocfg-13.2 {types: color} {
    tk::OptionType color validate green
} "#008000"
test oocfg-13.3 {types: color} -returnCodes error -body {
    tk::OptionType color validate gorp
} -result {unknown color name "gorp"}

test oocfg-14.1 {types: cursor} {
    tk::OptionType cursor default
} {}
test oocfg-14.2 {types: cursor} {
    tk::OptionType cursor validate watch
} watch
test oocfg-14.3 {types: cursor} {
    tk::OptionType cursor validate ""
} ""
test oocfg-14.4 {types: cursor} -returnCodes error -body {
    tk::OptionType cursor validate {gorp gorp gorp gorp gorp}
} -result {bad cursor spec "gorp gorp gorp gorp gorp"}

test oocfg-15.1 {types: dict} {
    tk::OptionType dict default
} {}
test oocfg-15.2 {types: color} {
    tk::OptionType dict validate { a b a c x y x z }
} {a c x z}
test oocfg-15.3 {types: color} -returnCodes error -body {
    tk::OptionType dict validate gorp
} -result {invalid dict value "gorp"}

test oocfg-16.1 {types: distance} {
    tk::OptionType distance default
} 0p
test oocfg-16.2 {types: distance} {
    tk::OptionType distance validate 123p
} 123p
test oocfg-16.3 {types: distance} -returnCodes error -body {
    tk::OptionType distance validate gorp
} -result {bad screen distance "gorp"}

test oocfg-17.1 {types: float} {
    tk::OptionType float default
} 0.0
test oocfg-17.2 {types: float} {
    tk::OptionType float validate 1.2e3
} 1200.0
test oocfg-17.3 {types: float} -returnCodes error -body {
    tk::OptionType float validate gorp
} -result {invalid float value "gorp"}

test oocfg-18.1 {types: font} {
    tk::OptionType font default
} TkDefaultFont
test oocfg-18.2 {types: font} {
    tk::OptionType font validate fixed
} fixed
test oocfg-18.3 {types: font} -returnCodes error -body {
    tk::OptionType font validate "gorp {}gorp"
} -result {font "gorp {}gorp" doesn't exist}

test oocfg-19.1 {types: image} {
    tk::OptionType image default
} {}
test oocfg-19.2 {types: image} -setup {
    image create photo testingImage
} -body {
    tk::OptionType image validate testingImage
} -cleanup {
    image delete testingImage
} -result testingImage
test oocfg-19.3 {types: image} {
    tk::OptionType image validate {}
} {}
test oocfg-19.4 {types: image} -returnCodes error -body {
    tk::OptionType image validate gorp
} -result {image "gorp" doesn't exist}

test oocfg-20.1 {types: integer} {
    tk::OptionType integer default
} 0
test oocfg-20.2 {types: integer} {
    tk::OptionType integer validate 0xff
} 255
test oocfg-20.3 {types: integer} -returnCodes error -body {
    tk::OptionType integer validate gorp
} -result {invalid integer value "gorp"}

test oocfg-21.1 {types: justify} {
    tk::OptionType justify default
} left
test oocfg-21.2 {types: justify} {
    tk::OptionType justify validate r
} right
test oocfg-21.3 {types: justify} -returnCodes error -body {
    tk::OptionType justify validate gorp
} -result {bad justify "gorp": must be center, left, or right}

test oocfg-22.1 {types: list} {
    tk::OptionType list default
} {}
test oocfg-22.2 {types: list} {
    tk::OptionType list validate {
	a
	b
	c
    }
} {a b c}
test oocfg-22.3 {types: list} -returnCodes error -body {
    tk::OptionType list validate "{}gorp"
} -result {invalid list value "{}gorp"}

test oocfg-23.1 {types: relief} {
    tk::OptionType relief default
} flat
test oocfg-23.2 {types: relief} {
    tk::OptionType relief validate g
} groove
test oocfg-23.3 {types: relief} -returnCodes error -body {
    tk::OptionType relief validate gorp
} -result {bad relief "gorp": must be flat, groove, raised, ridge, solid, or sunken}

test oocfg-24.1 {types: string} {
    tk::OptionType string default
} {}
test oocfg-24.2 {types: string} {
    tk::OptionType string validate "abc  de  "
} "abc  de  "
# string type never fails validation and never alters values in normalization

test oocfg-25.1 {types: window} {
    tk::OptionType window default
} {}
test oocfg-25.2 {types: window} {
    tk::OptionType window validate .
} .
test oocfg-25.3 {types: window} {
    tk::OptionType window validate ""
} ""
test oocfg-25.4 {types: window} -returnCodes error -body {
    tk::OptionType window validate gorp
} -result {invalid window value "gorp"}

test oocfg-26.1 {types: zboolean} {
    tk::OptionType zboolean default
} {}
test oocfg-26.2 {types: zboolean} {
    tk::OptionType zboolean validate 0
} false
test oocfg-26.3 {types: zboolean} {
    tk::OptionType zboolean validate ""
} ""
test oocfg-26.4 {types: zboolean} -returnCodes error -body {
    tk::OptionType zboolean validate gorp
} -result {invalid boolean value "gorp"}

test oocfg-27.1 {types: zcolor} {
    tk::OptionType zcolor default
} {}
test oocfg-27.2 {types: zcolor} {
    tk::OptionType zcolor validate green
} "#008000"
test oocfg-27.3 {types: zcolor} {
    tk::OptionType zcolor validate ""
} ""
test oocfg-27.4 {types: zcolor} -returnCodes error -body {
    tk::OptionType zcolor validate gorp
} -result {unknown color name "gorp"}

test oocfg-28.1 {types: zfloat} {
    tk::OptionType zfloat default
} {}
test oocfg-28.2 {types: zfloat} {
    tk::OptionType zfloat validate 1.2e3
} 1200.0
test oocfg-28.3 {types: zfloat} {
    tk::OptionType zfloat validate ""
} ""
test oocfg-28.4 {types: zfloat} -returnCodes error -body {
    tk::OptionType zfloat validate gorp
} -result {invalid float value "gorp"}

test oocfg-29.1 {types: zinteger} {
    tk::OptionType zinteger default
} {}
test oocfg-29.2 {types: zinteger} {
    tk::OptionType zinteger validate 0xff
} 255
test oocfg-29.3 {types: zinteger} {
    tk::OptionType zinteger validate ""
} ""
test oocfg-29.4 {types: zinteger} -returnCodes error -body {
    tk::OptionType zinteger validate gorp
} -result {invalid integer value "gorp"}

# cleanup
deleteWindows
cleanupTests
return

# Local Variables:
# mode: tcl
# End:

Changes to tests/option.test.

34
35
36
37
38
39
40
41

42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60



61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
34
35
36
37
38
39
40

41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59

60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82

83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100

101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120

121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138

139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158

159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176

177
178
179
180
181
182
183







-
+


















-
+
+
+




















-


















-




















-


















-




















-


















-







option add *Class1.x yellow
option add $appName.op1.x green
option add *Class2.Color1 orange
option add $appName.op2.op5.Color2 purple
option add $appName.Class1.Class3.y brown
option add $appName*op6*Color2 black
option add $appName*Class1.op1.Color2 grey


test option-1.1 {basic option retrieval} -body {
    option get . x Color1
} -result blue
test option-1.2 {basic option retrieval} -body {
    option get . y Color1
} -result red
test option-1.3 {basic option retrieval} -body {
    option get . z Color1
} -result red
test option-1.4 {basic option retrieval} -body {
    option get . x Color2
} -result blue
test option-1.5 {basic option retrieval} -body {
    option get . y Color2
} -result {}
test option-1.6 {basic option retrieval} -body {
    option get . z Color2
} -result {}

test option-1.7 {basic option retrieval} -body {
    option get . z Color2 gorp
} -result gorp

test option-2.1 {basic option retrieval} -body {
    option get .op1 x Color1
} -result green
test option-2.2 {basic option retrieval} -body {
    option get .op1 y Color1
} -result red
test option-2.3 {basic option retrieval} -body {
    option get .op1 z Color1
} -result red
test option-2.4 {basic option retrieval} -body {
    option get .op1 x Color2
} -result green
test option-2.5 {basic option retrieval} -body {
    option get .op1 y Color2
} -result {}
test option-2.6 {basic option retrieval} -body {
    option get .op1 z Color2
} -result {}


test option-3.1 {basic option retrieval} -body {
    option get .op1.op3 x Color1
} -result yellow
test option-3.2 {basic option retrieval} -body {
    option get .op1.op3 y Color1
} -result red
test option-3.3 {basic option retrieval} -body {
    option get .op1.op3 z Color1
} -result red
test option-3.4 {basic option retrieval} -body {
    option get .op1.op3 x Color2
} -result yellow
test option-3.5 {basic option retrieval} -body {
    option get .op1.op3 y Color2
} -result {}
test option-3.6 {basic option retrieval} -body {
    option get .op1.op3 z Color2
} -result {}


test option-4.1 {basic option retrieval} -body {
    option get .op1.op3.op6 x Color1
} -result blue
test option-4.2 {basic option retrieval} -body {
    option get .op1.op3.op6 y Color1
} -result red
test option-4.3 {basic option retrieval} -body {
    option get .op1.op3.op6 z Color1
} -result red
test option-4.4 {basic option retrieval} -body {
    option get .op1.op3.op6 x Color2
} -result black
test option-4.5 {basic option retrieval} -body {
    option get .op1.op3.op6 y Color2
} -result black
test option-4.6 {basic option retrieval} -body {
    option get .op1.op3.op6 z Color2
} -result black


test option-5.1 {basic option retrieval} -body {
    option get .op1.op4 x Color1
} -result blue
test option-5.2 {basic option retrieval} -body {
    option get .op1.op4 y Color1
} -result brown
test option-5.3 {basic option retrieval} -body {
    option get .op1.op4 z Color1
} -result red
test option-5.4 {basic option retrieval} -body {
    option get .op1.op4 x Color2
} -result blue
test option-5.5 {basic option retrieval} -body {
    option get .op1.op4 y Color2
} -result brown
test option-5.6 {basic option retrieval} -body {
    option get .op1.op4 z Color2
} -result {}


test option-6.1 {basic option retrieval} -body {
    option get .op2 x Color1
} -result orange
test option-6.2 {basic option retrieval} -body {
    option get .op2 y Color1
} -result orange
test option-6.3 {basic option retrieval} -body {
    option get .op2 z Color1
} -result orange
test option-6.4 {basic option retrieval} -body {
    option get .op2 x Color2
} -result blue
test option-6.5 {basic option retrieval} -body {
    option get .op2 y Color2
} -result {}
test option-6.6 {basic option retrieval} -body {
    option get .op2 z Color2
} -result {}


test option-7.1 {basic option retrieval} -body {
    option get .op2.op5 x Color1
} -result orange
test option-7.2 {basic option retrieval} -body {
    option get .op2.op5 y Color1
} -result orange
test option-7.3 {basic option retrieval} -body {
    option get .op2.op5 z Color1
} -result orange
test option-7.4 {basic option retrieval} -body {
    option get .op2.op5 x Color2
} -result purple
test option-7.5 {basic option retrieval} -body {
    option get .op2.op5 y Color2
} -result purple
test option-7.6 {basic option retrieval} -body {
    option get .op2.op5 z Color2
} -result purple


# Now try similar tests to above, except jump around non-hierarchically
# between windows to make sure that the option stacks are pushed and
# popped correctly.

option get . foo Foo
test option-8.1 {stack pushing/popping} -body {
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
195
196
197
198
199
200
201

202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219

220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239

240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257

258
259
260
261
262
263
264







-


















-




















-


















-







test option-8.5 {stack pushing/popping} -body {
    option get .op2.op5 y Color2
} -result purple
test option-8.6 {stack pushing/popping} -body {
    option get .op2.op5 z Color2
} -result purple


test option-9.1 {stack pushing/popping} -body {
    option get . x Color1
} -result blue
test option-9.2 {stack pushing/popping} -body {
    option get . y Color1
} -result red
test option-9.3 {stack pushing/popping} -body {
    option get . z Color1
} -result red
test option-9.4 {stack pushing/popping} -body {
    option get . x Color2
} -result blue
test option-9.5 {stack pushing/popping} -body {
    option get . y Color2
} -result {}
test option-9.6 {stack pushing/popping} -body {
    option get . z Color2
} -result {}


test option-10.1 {stack pushing/popping} -body {
    option get .op1.op3.op6 x Color1
} -result blue
test option-10.2 {stack pushing/popping} -body {
    option get .op1.op3.op6 y Color1
} -result red
test option-10.3 {stack pushing/popping} -body {
    option get .op1.op3.op6 z Color1
} -result red
test option-10.4 {stack pushing/popping} -body {
    option get .op1.op3.op6 x Color2
} -result black
test option-10.5 {stack pushing/popping} -body {
    option get .op1.op3.op6 y Color2
} -result black
test option-10.6 {stack pushing/popping} -body {
    option get .op1.op3.op6 z Color2
} -result black


test option-11.1 {stack pushing/popping} -body {
    option get .op1.op3 x Color1
} -result yellow
test option-11.2 {stack pushing/popping} -body {
    option get .op1.op3 y Color1
} -result red
test option-11.3 {stack pushing/popping} -body {
    option get .op1.op3 z Color1
} -result red
test option-11.4 {stack pushing/popping} -body {
    option get .op1.op3 x Color2
} -result yellow
test option-11.5 {stack pushing/popping} -body {
    option get .op1.op3 y Color2
} -result {}
test option-11.6 {stack pushing/popping} -body {
    option get .op1.op3 z Color2
} -result {}


test option-12.1 {stack pushing/popping} -body {
    option get .op1 x Color1
} -result green
test option-12.2 {stack pushing/popping} -body {
    option get .op1 y Color1
} -result red
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
306
307
308
309
310
311
312

313
314
315
316
317
318
319







-







    option get .op1 c B
} -result startupFile
option add $appName.op1.B file2 startupFile
test option-13.7 {priority levels} -body {
    option get .op1 c B
} -result file2


# Test various error conditions

test option-14.1 {error conditions} -body {
    option
} -returnCodes error -result {wrong # args: should be "option cmd arg ?arg ...?"}
test option-14.2 {error conditions} -body {
    option x
343
344
345
346
347
348
349
350

351
352
353

354
355
356


357
358
359
360
361
362
363
364
365
366
367
334
335
336
337
338
339
340

341
342
343

344
345


346
347
348
349
350

351
352
353
354
355
356
357







-
+


-
+

-
-
+
+



-







    option add . a 101
} -returnCodes error -result {bad priority level "101": must be widgetDefault, startupFile, userDefault, interactive, or a number between 0 and 100}
test option-14.8 {error conditions} -body {
    option add . a gorp
} -returnCodes error -result {bad priority level "gorp": must be widgetDefault, startupFile, userDefault, interactive, or a number between 0 and 100}
test option-14.9 {error conditions} -body {
    option get 3
} -returnCodes error -result {wrong # args: should be "option get window name class"}
} -returnCodes error -result {wrong # args: should be "option get window name class ?default?"}
test option-14.10 {error conditions} -body {
    option get 3 4
} -returnCodes error -result {wrong # args: should be "option get window name class"}
} -returnCodes error -result {wrong # args: should be "option get window name class ?default?"}
test option-14.11 {error conditions} -body {
    option get 3 4 5 6
} -returnCodes error -result {wrong # args: should be "option get window name class"}
    option get 3 4 5 6 7
} -returnCodes error -result {wrong # args: should be "option get window name class ?default?"}
test option-14.12 {error conditions} -body {
    option get .gorp.gorp a A
} -returnCodes error -result {bad window path name ".gorp.gorp"}


set option1 [file join [testsDirectory] option.file1]
test option-15.1 {database files} -body {
    option read non-existent
} -returnCodes error -result {couldn't open "non-existent": no such file or directory}
test option-15.2 {database files} -body {
    option read $option1
399
400
401
402
403
404
405
406

407

408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424

425

426
427
428
429
430
431


432
433


434
435
436
437
438
439
440
441



389
390
391
392
393
394
395

396
397
398
399
400
401
402
403
404
405
406
407

408
409
410
411
412


413
414
415
416
417
418
419
420
421
422
423


424
425
426
427
428
429
430
431


432
433
434







-
+

+









-





-
-
+

+






+
+
-
-
+
+






-
-
+
+
+
    set option2 [file join [testsDirectory] option.file2]
    option read $option2
} -returnCodes error -result {missing colon on line 2}
set option3 [file join [testsDirectory] option.file3]
option read $option3
test option-15.11 {database files} {option get . {x 4} color} brówn

test option-16.1 {ReadOptionFile} -body {
test option-16.1 {ReadOptionFile} -setup {
    set option4 [makeFile {} option.file3]
} -body {
    set file [open $option4 w]
    fconfigure $file -translation crlf
    puts $file "*x7: true\n*x8: false"
    close $file
    option read $option4 userDefault
    list [option get . x7 color] [option get . x8 color]
} -cleanup {
    removeFile $option4
} -result {true false}

set opt162val {label {
  foo bar
}
}
set opt162list [split $opt162val \n]

test option-16.2 {ticket 766ef52f3} {
test option-16.2 {ticket 766ef52f3} -setup {
    set option5 [makeFile {} option.file4]
} -body {
    set file [open $option5 w]
    fconfigure $file -translation crlf
    puts $file "*notok: $opt162list"
    close $file
    option read $option5 userDefault
    option get . notok notok
} -cleanup {
    removeFile $option5
} $opt162list

} -result $opt162list

deleteWindows

# cleanup
cleanupTests
return



# Local Variables:
# mode: tcl
# End: