1# This file is a Tcl script to test the procedures in tkConfig.c,
2# which comprise the new new option configuration system.  It is
3# organized in the standard "white-box" fashion for Tcl tests.
4#
5# Copyright (c) 1997 Sun Microsystems, Inc.
6# Copyright (c) 1998-1999 by Scriptics Corporation.
7# All rights reserved.
8#
9# RCS: @(#) $Id: config.test,v 1.6 2002/07/14 05:48:46 dgp Exp $
10
11package require tcltest 2.1
12namespace import -force tcltest::configure
13namespace import -force tcltest::testsDirectory
14configure -testdir [file join [pwd] [file dirname [info script]]]
15configure -loadfile [file join [testsDirectory] constraints.tcl]
16tcltest::loadTestedCommands
17
18testConstraint testobjconfig [llength [info commands testobjconfig]]
19
20proc killTables {} {
21    # Note: it's important to delete chain2 before chain1, because
22    # chain2 depends on chain1.  If chain1 is deleted first, the
23    # delete of chain2 will crash.
24
25    foreach t {alltypes chain2 chain1 configerror internal new notenoughparams
26	    twowindows} {
27	while {[testobjconfig info $t] != ""} {
28	    testobjconfig delete $t
29	}
30    }
31}
32
33if {[testConstraint testobjconfig]} {
34    killTables
35}
36
37test config-1.1 {Tk_CreateOptionTable - reference counts} testobjconfig {
38    deleteWindows
39    killTables
40    set x {}
41    testobjconfig alltypes .a
42    lappend x [testobjconfig info alltypes]
43    testobjconfig alltypes .b
44    lappend x [testobjconfig info alltypes]
45    deleteWindows
46    set x
47} {{1 16 -boolean} {2 16 -boolean}}
48test config-1.2 {Tk_CreateOptionTable - synonym initialization} testobjconfig {
49    deleteWindows
50    testobjconfig alltypes .a -synonym green
51    .a cget -color
52} {green}
53test config-1.3 {Tk_CreateOptionTable - option database initialization} testobjconfig {
54    deleteWindows
55    option clear
56    testobjconfig alltypes .a
57    option add *b.string different
58    testobjconfig alltypes .b
59    list [.a cget -string] [.b cget -string]
60} {foo different}
61test config-1.4 {Tk_CreateOptionTable - option database initialization} testobjconfig {
62    deleteWindows
63    option clear
64    testobjconfig alltypes .a
65    option add *b.String bar
66    testobjconfig alltypes .b
67    list [.a cget -string] [.b cget -string]
68} {foo bar}
69test config-1.5 {Tk_CreateOptionTable - default initialization} testobjconfig {
70    deleteWindows
71    testobjconfig alltypes .a
72    .a cget -relief
73} {raised}
74test config-1.6 {Tk_CreateOptionTable - chained tables} testobjconfig {
75    deleteWindows
76    killTables
77    testobjconfig chain1 .a
78    testobjconfig chain2 .b
79    testobjconfig info chain2
80} {1 4 -three 2 2 -one}
81test config-1.7 {Tk_CreateOptionTable - chained tables} testobjconfig {
82    deleteWindows
83    killTables
84    testobjconfig chain2 .b
85    testobjconfig chain1 .a
86    testobjconfig info chain2
87} {1 4 -three 2 2 -one}
88test config-1.8 {Tk_CreateOptionTable - chained tables} testobjconfig {
89    deleteWindows
90    testobjconfig chain1 .a
91    testobjconfig chain2 .b
92    list [catch {.a cget -four} msg] $msg [.a cget -one] \
93	    [.b cget -four] [.b cget -one]
94} {1 {unknown option "-four"} one four one}
95
96test config-2.1 {Tk_DeleteOptionTable - reference counts} testobjconfig {
97    deleteWindows
98    killTables
99    testobjconfig chain1 .a
100    testobjconfig chain2 .b
101    testobjconfig chain2 .c
102    deleteWindows
103    set x {}
104    testobjconfig delete chain2
105    lappend x [testobjconfig info chain2] [testobjconfig info chain1]
106    testobjconfig delete chain2
107    lappend x [testobjconfig info chain2] [testobjconfig info chain1]
108} {{1 4 -three 2 2 -one} {2 2 -one} {} {1 2 -one}}
109
110# No tests for DestroyOptionHashTable; couldn't figure out how to test.
111
112test config-3.1 {Tk_InitOptions - priority of chained tables} testobjconfig {
113    deleteWindows
114    testobjconfig chain1 .a
115    testobjconfig chain2 .b
116    list [.a cget -two] [.b cget -two]
117} {two {two and a half}}
118test config-3.2 {Tk_InitOptions - initialize from database} testobjconfig {
119    deleteWindows
120    option clear
121    option add *a.color blue
122    testobjconfig alltypes .a
123    list [.a cget -color]
124} {blue}
125test config-3.3 {Tk_InitOptions - initialize from database} testobjconfig {
126    deleteWindows
127    option clear
128    option add *a.justify bogus
129    testobjconfig alltypes .a
130    list [.a cget -justify]
131} {left}
132test config-3.4 {Tk_InitOptions - initialize from widget class} testobjconfig {
133    deleteWindows
134    testobjconfig alltypes .a
135    list [.a cget -color]
136} {red}
137test config-3.5 {Tk_InitOptions - no initial value} testobjconfig {
138    deleteWindows
139    testobjconfig alltypes .a
140    .a cget -anchor
141} {}
142test config-3.6 {Tk_InitOptions - bad initial value} testobjconfig {
143    deleteWindows
144    option clear
145    option add *a.color non-existent
146    list [catch {testobjconfig alltypes .a} msg] $msg $errorInfo
147} {1 {unknown color name "non-existent"} {unknown color name "non-existent"
148    (database entry for "-color" in widget ".a")
149    invoked from within
150"testobjconfig alltypes .a"}}
151option clear
152test config-3.7 {Tk_InitOptions - bad initial value} testobjconfig {
153    deleteWindows
154    list [catch {testobjconfig configerror} msg] $msg $errorInfo
155} {1 {expected integer but got "bogus"} {expected integer but got "bogus"
156    (default value for "-int")
157    invoked from within
158"testobjconfig configerror"}}
159option clear
160
161test config-4.1 {DoObjConfig - boolean} testobjconfig {
162    catch {rename .foo {}}
163    list [catch {testobjconfig alltypes .foo -boolean 0} msg] $msg [catch {.foo cget -boolean} result] $result [catch {rename .foo {}}]
164} {0 .foo 0 0 0}
165test config-4.2 {DoObjConfig - boolean} testobjconfig {
166    catch {rename .foo {}}
167    list [catch {testobjconfig alltypes .foo -boolean 1} msg] $msg [catch {.foo cget -boolean} result] $result [catch {rename .foo {}}]
168} {0 .foo 0 1 0}
169test config-4.3 {DoObjConfig - invalid boolean} testobjconfig {
170    catch {rename .foo {}}
171    list [catch {testobjconfig alltypes .foo -boolean {}} msg] $msg
172} {1 {expected boolean value but got ""}}
173test config-4.4 {DoObjConfig - boolean internal value} testobjconfig {
174    catch {rename .foo {}}
175    testobjconfig internal .foo -boolean 0
176    .foo cget -boolean
177} {0}
178test config-4.5 {DoObjConfig - integer} testobjconfig {
179    catch {rename .foo {}}
180    list [catch {testobjconfig alltypes .foo -integer 3} msg] $msg [catch {.foo cget -integer} result] $result [catch {rename .foo {}}]
181} {0 .foo 0 3 0}
182test config-4.6 {DoObjConfig - invalid integer} testobjconfig {
183    catch {rename .foo {}}
184    list [catch {testobjconfig alltypes .foo -integer bar} msg] $msg
185} {1 {expected integer but got "bar"}}
186test config-4.7 {DoObjConfig - integer internal value} testobjconfig {
187    catch {rename .foo {}}
188    testobjconfig internal .foo -integer 421
189    .foo cget -integer
190} {421}
191test config-4.8 {DoObjConfig - double} testobjconfig {
192    catch {rename .foo {}}
193    list [catch {testobjconfig alltypes .foo -double 3.14} msg] $msg [catch {.foo cget -double} result] $result [catch {rename .foo {}}]
194} {0 .foo 0 3.14 0}
195test config-4.9 {DoObjConfig - invalid double} testobjconfig {
196    catch {rename .foo {}}
197    list [catch {testobjconfig alltypes .foo -double bar} msg] $msg
198} {1 {expected floating-point number but got "bar"}}
199test config-4.10 {DoObjConfig - double internal value} testobjconfig {
200    catch {rename .foo {}}
201    testobjconfig internal .foo -double 62.75
202    .foo cget -double
203} {62.75}
204test config-4.11 {DoObjConfig - string} testobjconfig {
205    catch {destroy .foo}
206    list [catch {testobjconfig alltypes .foo -string test} msg] $msg [catch {.foo cget -string} result] $result [destroy .foo]
207} {0 .foo 0 test {}}
208test config-4.12 {DoObjConfig - null string} testobjconfig {
209    catch {destroy .foo}
210    list [catch {testobjconfig alltypes .foo -string {}} msg] $msg [catch {.foo cget -string} result] $result [destroy .foo]
211} {0 .foo 0 {} {}}
212test config-4.13 {DoObjConfig - string internal value} testobjconfig {
213    catch {rename .foo {}}
214    testobjconfig internal .foo -string "this is a test"
215    .foo cget -string
216} {this is a test}
217test config-4.14 {DoObjConfig - string table} testobjconfig {
218    catch {destroy .foo}
219    list [catch {testobjconfig alltypes .foo -stringtable two} msg] $msg [catch {.foo cget -stringtable} result] $result [destroy .foo]
220} {0 .foo 0 two {}}
221test config-4.15 {DoObjConfig - invalid string table} testobjconfig {
222    catch {destroy .foo}
223    list [catch {testobjconfig alltypes .foo -stringtable foo} msg] $msg
224} {1 {bad stringtable "foo": must be one, two, three, or four}}
225test config-4.16 {DoObjConfig - new string table} testobjconfig {
226    catch {destroy .foo}
227    testobjconfig alltypes .foo -stringtable two
228    list [catch {.foo configure -stringtable three} msg] $msg [catch {.foo cget -stringtable} result] $result [destroy .foo]
229} {0 16 0 three {}}
230test config-4.17 {DoObjConfig - stringtable internal value} testobjconfig {
231    catch {rename .foo {}}
232    testobjconfig internal .foo -stringtable "four"
233    .foo cget -stringtable
234} {four}
235test config-4.18 {DoObjConfig - color} testobjconfig {
236    catch {rename .foo {}}
237    list [catch {testobjconfig alltypes .foo -color blue} msg] $msg [catch {.foo cget -color} result] $result [destroy .foo]
238} {0 .foo 0 blue {}}
239test config-4.19 {DoObjConfig - invalid color} testobjconfig {
240    catch {destroy .foo}
241    list [catch {testobjconfig alltypes .foo -color xxx} msg] $msg
242} {1 {unknown color name "xxx"}}
243test config-4.20 {DoObjConfig - color internal value} testobjconfig {
244    catch {rename .foo {}}
245    testobjconfig internal .foo -color purple
246    .foo cget -color
247} {purple}
248test config-4.21 {DoObjConfig - null color} testobjconfig {
249    catch {rename .foo {}}
250    list [catch {testobjconfig alltypes .foo -color {}} msg] $msg [catch {.foo cget -color} result] $result [destroy .foo]
251} {0 .foo 0 {} {}}
252test config-4.22 {DoObjConfig - getting rid of old color} testobjconfig {
253    catch {destroy .foo}
254    testobjconfig alltypes .foo -color #333333
255    list [catch {.foo configure -color #444444} msg] $msg [catch {.foo cget -color} result] $result [destroy .foo]
256} {0 32 0 #444444 {}}
257test config-4.23 {DoObjConfig - font} testobjconfig {
258    catch {rename .foo {}}
259    list [catch {testobjconfig alltypes .foo -font {Helvetica 72}} msg] $msg [catch {.foo cget -font} result] $result [destroy .foo]
260} {0 .foo 0 {Helvetica 72} {}}
261test config-4.24 {DoObjConfig - new font} testobjconfig {
262    catch {rename .foo {}}
263    testobjconfig alltypes .foo -font {Courier 12}
264    list [catch {.foo configure -font {Helvetica 72}} msg] $msg [catch {.foo cget -font} result] $result [destroy .foo]
265} {0 64 0 {Helvetica 72} {}}
266test config-4.25 {DoObjConfig - invalid font} testobjconfig {
267    catch {rename .foo {}}
268    list [catch {testobjconfig alltypes .foo -font {Helvetica 12 foo}} msg] $msg
269} {1 {unknown font style "foo"}}
270test config-4.26 {DoObjConfig - null font} testobjconfig {
271    catch {rename .foo {}}
272    list [catch {testobjconfig alltypes .foo -font {}} msg] $msg [catch {.foo cget -font} result] $result [destroy .foo]
273} {0 .foo 0 {} {}}
274test config-4.27 {DoObjConfig - font internal value} testobjconfig {
275    catch {rename .foo {}}
276    testobjconfig internal .foo -font {Times 16}
277    .foo cget -font
278} {Times 16}
279test config-4.28 {DoObjConfig - bitmap} testobjconfig {
280    catch {destroy .foo}
281    list [catch {testobjconfig alltypes .foo -bitmap gray75} msg] $msg [catch {.foo cget -bitmap} result] $result [destroy .foo]
282} {0 .foo 0 gray75 {}}
283test config-4.29 {DoObjConfig - new bitmap} testobjconfig {
284    catch {destroy .foo}
285    testobjconfig alltypes .foo -bitmap gray75
286    list [catch {.foo configure -bitmap gray50} msg] $msg [catch {.foo cget -bitmap} result] $result [destroy .foo]
287} {0 128 0 gray50 {}}
288test config-4.30 {DoObjConfig - invalid bitmap} testobjconfig {
289    catch {destroy .foo}
290    list [catch {testobjconfig alltypes .foo -bitmap foo} msg] $msg
291} {1 {bitmap "foo" not defined}}
292test config-4.31 {DoObjConfig - null bitmap} testobjconfig {
293    catch {destroy .foo}
294    list [catch {testobjconfig alltypes .foo -bitmap {}} msg] $msg [catch {.foo cget -bitmap} result] $result [destroy .foo]
295} {0 .foo 0 {} {}}
296test config-4.32 {DoObjConfig - bitmap internal value} testobjconfig {
297    catch {rename .foo {}}
298    testobjconfig internal .foo -bitmap gray25
299    .foo cget -bitmap
300} {gray25}
301test config-4.33 {DoObjConfig - border} testobjconfig {
302    catch {rename .foo {}}
303    list [catch {testobjconfig alltypes .foo -border green} msg] $msg [catch {.foo cget -border} result] $result [destroy .foo]
304} {0 .foo 0 green {}}
305test config-4.34 {DoObjConfig - invalid border} testobjconfig {
306    catch {destroy .foo}
307    list [catch {testobjconfig alltypes .foo -border xxx} msg] $msg
308} {1 {unknown color name "xxx"}}
309test config-4.35 {DoObjConfig - null border} testobjconfig {
310    catch {rename .foo {}}
311    list [catch {testobjconfig alltypes .foo -border {}} msg] $msg [catch {.foo cget -border} result] $result [destroy .foo]
312} {0 .foo 0 {} {}}
313test config-4.36 {DoObjConfig - border internal value} testobjconfig {
314    catch {rename .foo {}}
315    testobjconfig internal .foo -border #123456
316    .foo cget -border
317} {#123456}
318test config-4.37 {DoObjConfig - getting rid of old border} testobjconfig {
319    catch {destroy .foo}
320    testobjconfig alltypes .foo -border #333333
321    list [catch {.foo configure -border #444444} msg] $msg [catch {.foo cget -border} result] $result [destroy .foo]
322} {0 256 0 #444444 {}}
323test config-4.38 {DoObjConfig - relief} testobjconfig {
324    catch {destroy .foo}
325    list [catch {testobjconfig alltypes .foo -relief flat} msg] $msg [catch {.foo cget -relief} result] $result [destroy .foo]
326} {0 .foo 0 flat {}}
327test config-4.39 {DoObjConfig - invalid relief} testobjconfig {
328    catch {destroy .foo}
329    list [catch {testobjconfig alltypes .foo -relief foo} msg] $msg
330} {1 {bad relief "foo": must be flat, groove, raised, ridge, solid, or sunken}}
331test config-4.40 {DoObjConfig - new relief} testobjconfig {
332    catch {destroy .foo}
333    testobjconfig alltypes .foo -relief raised
334    list [catch {.foo configure -relief flat} msg] $msg [catch {.foo cget -relief} result] $result [destroy .foo]
335} {0 512 0 flat {}}
336test config-4.41 {DoObjConfig - relief internal value} testobjconfig {
337    catch {rename .foo {}}
338    testobjconfig internal .foo -relief ridge
339    .foo cget -relief
340} {ridge}
341test config-4.42 {DoObjConfig - cursor} testobjconfig {
342    catch {destroy .foo}
343    list [catch {testobjconfig alltypes .foo -cursor arrow} msg] $msg [catch {.foo cget -cursor} result] $result [destroy .foo]
344} {0 .foo 0 arrow {}}
345test config-4.43 {DoObjConfig - invalid cursor} testobjconfig {
346    catch {destroy .foo}
347    list [catch {testobjconfig alltypes .foo -cursor foo} msg] $msg
348} {1 {bad cursor spec "foo"}}
349test config-4.44 {DoObjConfig - null cursor} testobjconfig {
350    catch {destroy .foo}
351    list [catch {testobjconfig alltypes .foo -cursor {}} msg] $msg [catch {.foo cget -cursor} result] $result [destroy .foo]
352} {0 .foo 0 {} {}}
353test config-4.45 {DoObjConfig - new cursor} testobjconfig {
354    catch {destroy .foo}
355    testobjconfig alltypes .foo -cursor xterm
356    list [catch {.foo configure -cursor arrow} msg] $msg [catch {.foo cget -cursor} result] $result [destroy .foo]
357} {0 1024 0 arrow {}}
358test config-4.46 {DoObjConfig - cursor internal value} testobjconfig {
359    catch {rename .foo {}}
360    testobjconfig internal .foo -cursor watch
361    .foo cget -cursor
362} {watch}
363test config-4.47 {DoObjConfig - justify} testobjconfig {
364    catch {destroy .foo}
365    list [catch {testobjconfig alltypes .foo -justify center} msg] $msg [catch {.foo cget -justify} result] $result [destroy .foo]
366} {0 .foo 0 center {}}
367test config-4.48 {DoObjConfig - invalid justify} testobjconfig {
368    catch {destroy .foo}
369    list [catch {testobjconfig alltypes .foo -justify foo} msg] $msg
370} {1 {bad justification "foo": must be left, right, or center}}
371test config-4.49 {DoObjConfig - new justify} testobjconfig {
372    catch {destroy .foo}
373    testobjconfig alltypes .foo -justify left
374    list [catch {.foo configure -justify right} msg] $msg [catch {.foo cget -justify} result] $result [destroy .foo]
375} {0 2048 0 right {}}
376test config-4.50 {DoObjConfig - justify internal value} testobjconfig {
377    catch {rename .foo {}}
378    testobjconfig internal .foo -justify center
379    .foo cget -justify
380} {center}
381test config-4.51 {DoObjConfig - anchor} testobjconfig {
382    catch {destroy .foo}
383    list [catch {testobjconfig alltypes .foo -anchor center} msg] $msg [catch {.foo cget -anchor} result] $result [destroy .foo]
384} {0 .foo 0 center {}}
385test config-4.52 {DoObjConfig - invalid anchor} testobjconfig {
386    catch {destroy .foo}
387    list [catch {testobjconfig alltypes .foo -anchor foo} msg] $msg
388} {1 {bad anchor "foo": must be n, ne, e, se, s, sw, w, nw, or center}}
389test config-4.53 {DoObjConfig - new anchor} testobjconfig {
390    catch {destroy .foo}
391    testobjconfig alltypes .foo -anchor e
392    list [catch {.foo configure -anchor n} msg] $msg [catch {.foo cget -anchor} result] $result [destroy .foo]
393} {0 4096 0 n {}}
394test config-4.54 {DoObjConfig - anchor internal value} testobjconfig {
395    catch {rename .foo {}}
396    testobjconfig internal .foo -anchor sw
397    .foo cget -anchor
398} {sw}
399test config-4.55 {DoObjConfig - pixel} testobjconfig {
400    catch {destroy .foo}
401    list [catch {testobjconfig alltypes .foo -pixel 42} msg] $msg [catch {.foo cget -pixel} result] $result [destroy .foo]
402} {0 .foo 0 42 {}}
403test config-4.56 {DoObjConfig - invalid pixel} testobjconfig {
404    catch {destroy .foo}
405    list [catch {testobjconfig alltypes .foo -pixel foo} msg] $msg
406} {1 {bad screen distance "foo"}}
407test config-4.57 {DoObjConfig - new pixel} testobjconfig {
408    catch {destroy .foo}
409    testobjconfig alltypes .foo -pixel 42m
410    list [catch {.foo configure -pixel 3c} msg] $msg [catch {.foo cget -pixel} result] $result [destroy .foo]
411} {0 8192 0 3c {}}
412test config-4.58 {DoObjConfig - pixel internal value} testobjconfig {
413    catch {rename .foo {}}
414    testobjconfig internal .foo -pixel [winfo screenmmwidth .]m
415    .foo cget -pixel
416} [winfo screenwidth .]
417test config-4.59 {DoObjConfig - window} testobjconfig {
418    catch {destroy .foo}
419    catch {destroy .bar}
420    toplevel .bar
421    list [catch {testobjconfig twowindows .foo -window .bar} msg] $msg [catch {.foo cget -window} result] $result [destroy .foo] [destroy .bar]
422} {0 .foo 0 .bar {} {}}
423test config-4.60 {DoObjConfig - invalid window} testobjconfig {
424    catch {destroy .foo}
425    toplevel .bar
426    list [catch {testobjconfig twowindows .foo -window foo} msg] $msg [destroy .bar]
427} {1 {bad window path name "foo"} {}}
428test config-4.61 {DoObjConfig - null window} testobjconfig {
429    catch {destroy .foo}
430    catch {destroy .bar}
431    toplevel .bar
432    list [catch {testobjconfig twowindows .foo -window {}} msg] $msg [catch {.foo cget -window} result] $result [destroy .foo]
433} {0 .foo 0 {} {}}
434test config-4.62 {DoObjConfig - new window} testobjconfig {
435    catch {destroy .foo}
436    catch {destroy .bar}
437    catch {destroy .blamph}
438    toplevel .bar
439    toplevel .blamph
440    testobjconfig twowindows .foo -window .bar
441    list [catch {.foo configure -window .blamph} msg] $msg [catch {.foo cget -window} result] $result [destroy .foo] [destroy .bar] [destroy .blamph]
442} {0 0 0 .blamph {} {} {}}
443test config-4.63 {DoObjConfig - window internal value} testobjconfig {
444    catch {rename .foo {}}
445    testobjconfig internal .foo -window .
446    .foo cget -window
447} {.}
448test config-4.64 {DoObjConfig - releasing old values} testobjconfig {
449    # This test doesn't generate a useful value to check; if an
450    # error occurs, it will be detected only by memory checking software
451    # such as Purify or Tcl's built-in checker.
452
453    catch {rename .foo {}}
454    testobjconfig alltypes .foo -string {Test string} -color yellow \
455	    -font {Courier 18} -bitmap questhead -border green -cursor cross \
456	    -custom foobar
457    .foo configure -string {new string} -color brown \
458	    -font {Times 8} -bitmap gray75 -border pink -cursor watch \
459	    -custom barbaz
460    concat {}
461} {}
462test config-4.65 {DoObjConfig - releasing old values} testobjconfig {
463    # This test doesn't generate a useful value to check; if an
464    # error occurs, it will be detected only by memory checking software
465    # such as Purify or Tcl's built-in checker.
466
467    catch {rename .foo {}}
468    testobjconfig internal .foo -string {Test string} -color yellow \
469	    -font {Courier 18} -bitmap questhead -border green -cursor cross \
470	    -custom foobar
471    .foo configure -string {new string} -color brown \
472	    -font {Times 8} -bitmap gray75 -border pink -cursor watch \
473	    -custom barbaz
474    concat {}
475} {}
476test config-4.66 {DoObjConfig - custom} testobjconfig {
477    catch {destroy .foo}
478    list [catch {testobjconfig alltypes .foo -custom test} msg] $msg [catch {.foo cget -custom} result] $result [destroy .foo]
479} {0 .foo 0 TEST {}}
480test config-4.67 {DoObjConfig - null custom} testobjconfig {
481    catch {destroy .foo}
482    list [catch {testobjconfig alltypes .foo -custom {}} msg] $msg [catch {.foo cget -custom} result] $result [destroy .foo]
483} {0 .foo 0 {} {}}
484test config-4.68 {DoObjConfig - custom internal value} testobjconfig {
485    catch {rename .foo {}}
486    testobjconfig internal .foo -custom "this is a test"
487    .foo cget -custom
488} {THIS IS A TEST}
489
490test config-5.1 {ObjectIsEmpty - object is already string} testobjconfig {
491    catch {destroy .foo}
492    testobjconfig alltypes .foo -color [format ""]
493    .foo cget -color
494} {}
495test config-5.2 {ObjectIsEmpty - object is already string} testobjconfig {
496    catch {destroy .foo}
497    list [catch {testobjconfig alltypes .foo -color [format " "]} msg] $msg
498} {1 {unknown color name " "}}
499test config-5.3 {ObjectIsEmpty - must convert back to string} testobjconfig {
500    catch {destroy .foo}
501    testobjconfig alltypes .foo -color [list]
502    .foo cget -color
503} {}
504
505deleteWindows
506if {[testConstraint testobjconfig]} {
507    testobjconfig chain2 .a
508    testobjconfig alltypes .b
509}
510test config-6.1 {GetOptionFromObj - cached answer} testobjconfig {
511    list [.a cget -three] [.a cget -three]
512} {three three}
513test config-6.2 {GetOptionFromObj - exact match} testobjconfig {
514    .a cget -one
515} {one}
516test config-6.3 {GetOptionFromObj - abbreviation} testobjconfig {
517    .a cget -fo
518} {four}
519test config-6.4 {GetOptionFromObj - ambiguous abbreviation} testobjconfig {
520    list [catch {.a cget -on} msg] $msg
521} {1 {unknown option "-on"}}
522test config-6.5 {GetOptionFromObj - duplicate options in different tables} testobjconfig {
523    .a cget -tw
524} {two and a half}
525test config-6.6 {GetOptionFromObj - synonym} testobjconfig {
526    .b cget -synonym
527} {red}
528
529deleteWindows
530if {[testConstraint testobjconfig]} {
531    testobjconfig alltypes .a
532}
533test config-7.1 {Tk_SetOptions - basics} testobjconfig {
534    .a configure -color green -rel sunken
535     list [.a cget -color] [.a cget -relief]
536} {green sunken}
537test config-7.2 {Tk_SetOptions - bogus option name} testobjconfig {
538    list [catch {.a configure -bogus} msg] $msg
539} {1 {unknown option "-bogus"}}
540test config-7.3 {Tk_SetOptions - synonym} testobjconfig {
541    .a configure -synonym blue
542    .a cget -color
543} {blue}
544test config-7.4 {Tk_SetOptions - missing value} testobjconfig {
545    list [catch {.a configure -color green -relief} msg] $msg [.a cget -color]
546} {1 {value for "-relief" missing} green}
547test config-7.5 {Tk_SetOptions - saving old values} testobjconfig {
548    .a configure -color red -int 7 -relief raised -double 3.14159
549    list [catch {.a csave -color green -int 432 -relief sunken \
550	    -double 2.0 -color bogus} msg] $msg [.a cget -color] \
551	    [.a cget -int] [.a cget -relief] [.a cget -double]
552} {1 {unknown color name "bogus"} red 7 raised 3.14159}
553test config-7.6 {Tk_SetOptions - error in DoObjConfig call} testobjconfig {
554    list [catch {.a configure -color bogus} msg] $msg $errorInfo
555} {1 {unknown color name "bogus"} {unknown color name "bogus"
556    (processing "-color" option)
557    invoked from within
558".a configure -color bogus"}}
559test config-7.7 {Tk_SetOptions - synonym name in error message} testobjconfig {
560    list [catch {.a configure -synonym bogus} msg] $msg $errorInfo
561} {1 {unknown color name "bogus"} {unknown color name "bogus"
562    (processing "-synonym" option)
563    invoked from within
564".a configure -synonym bogus"}}
565test config-7.8 {Tk_SetOptions - returning mask} testobjconfig {
566    format %x [.a configure -color red -int 7 -relief raised -double 3.14159]
567} {226}
568test config-7.9 {Tk_SetOptions - error in DoObjConfig with custom option} testobjconfig {
569    list [catch {.a configure -custom bad} msg] $msg $errorInfo
570} {1 {expected good value, got "BAD"} {expected good value, got "BAD"
571    (processing "-custom" option)
572    invoked from within
573".a configure -custom bad"}}
574
575test config-8.1 {Tk_RestoreSavedOptions - restore in proper order} testobjconfig {
576    deleteWindows
577    testobjconfig alltypes .a
578    list [catch {.a csave -color green -color black -color blue \
579	    -color #ffff00 -color #ff00ff -color bogus} msg] $msg \
580	    [.a cget -color]
581} {1 {unknown color name "bogus"} red}
582test config-8.2 {Tk_RestoreSavedOptions - freeing object memory} testobjconfig {
583    deleteWindows
584    testobjconfig alltypes .a
585    .a csave -color green -color black -color blue -color #ffff00 \
586	    -color #ff00ff
587} {32}
588test config-8.3 {Tk_RestoreSavedOptions - boolean internal form} testobjconfig {
589    deleteWindows
590    testobjconfig internal .a
591    list [catch {.a csave -boolean 0 -color bogus}] [.a cget -boolean]
592} {1 1}
593test config-8.4 {Tk_RestoreSavedOptions - integer internal form} testobjconfig {
594    deleteWindows
595    testobjconfig internal .a
596    list [catch {.a csave -integer 24 -color bogus}] [.a cget -integer]
597} {1 148962237}
598test config-8.5 {Tk_RestoreSavedOptions - double internal form} testobjconfig {
599    deleteWindows
600    testobjconfig internal .a
601    list [catch {.a csave -double 62.4 -color bogus}] [.a cget -double]
602} {1 3.14159}
603test config-8.6 {Tk_RestoreSavedOptions - string internal form} testobjconfig {
604    deleteWindows
605    testobjconfig internal .a
606    list [catch {.a csave -string "A long string" -color bogus}] \
607	    [.a cget -string]
608} {1 foo}
609test config-8.7 {Tk_RestoreSavedOptions - string table internal form} testobjconfig {
610    deleteWindows
611    testobjconfig internal .a
612    list [catch {.a csave -stringtable three -color bogus}] \
613	    [.a cget -stringtable]
614} {1 one}
615test config-8.8 {Tk_RestoreSavedOptions - color internal form} testobjconfig {
616    deleteWindows
617    testobjconfig internal .a
618    list [catch {.a csave -color green -color bogus}] [.a cget -color]
619} {1 red}
620test config-8.9 {Tk_RestoreSavedOptions - font internal form} {testobjconfig nonPortable} {
621    deleteWindows
622    testobjconfig internal .a
623    list [catch {.a csave -font {Times 12} -color bogus}] [.a cget -font]
624} {1 {Helvetica 12}}
625test config-8.10 {Tk_RestoreSavedOptions - bitmap internal form} testobjconfig {
626    deleteWindows
627    testobjconfig internal .a
628    list [catch {.a csave -bitmap questhead -color bogus}] [.a cget -bitmap]
629} {1 gray50}
630test config-8.11 {Tk_RestoreSavedOptions - border internal form} testobjconfig {
631    deleteWindows
632    testobjconfig internal .a
633    list [catch {.a csave -border brown -color bogus}] [.a cget -border]
634} {1 blue}
635test config-8.12 {Tk_RestoreSavedOptions - relief internal form} testobjconfig {
636    deleteWindows
637    testobjconfig internal .a
638    list [catch {.a csave -relief sunken -color bogus}] [.a cget -relief]
639} {1 raised}
640test config-8.13 {Tk_RestoreSavedOptions - cursor internal form} testobjconfig {
641    deleteWindows
642    testobjconfig internal .a
643    list [catch {.a csave -cursor watch -color bogus}] [.a cget -cursor]
644} {1 xterm}
645test config-8.14 {Tk_RestoreSavedOptions - justify internal form} testobjconfig {
646    deleteWindows
647    testobjconfig internal .a
648    list [catch {.a csave -justify right -color bogus}] [.a cget -justify]
649} {1 left}
650test config-8.15 {Tk_RestoreSavedOptions - anchor internal form} testobjconfig {
651    deleteWindows
652    testobjconfig internal .a
653    list [catch {.a csave -anchor center -color bogus}] [.a cget -anchor]
654} {1 n}
655test config-8.16 {Tk_RestoreSavedOptions - window internal form} testobjconfig {
656    deleteWindows
657    testobjconfig internal .a -window .a
658    list [catch {.a csave -window .a -color bogus}] [.a cget -window]
659} {1 .a}
660test config-8.17 {Tk_RestoreSavedOptions - custom internal form} testobjconfig {
661    deleteWindows
662    testobjconfig internal .a -custom "foobar"
663    list [catch {.a csave -custom "barbaz" -color bogus}] [.a cget -custom]
664} {1 FOOBAR}
665
666# Most of the tests below will cause memory leakage if there is a
667# problem.  This may not be evident unless the tests are run in
668# conjunction with a memory usage analyzer such as Purify.
669
670test config-9.1 {Tk_FreeConfigOptions/FreeResources - string internal form} testobjconfig {
671    catch {destroy .foo}
672    testobjconfig internal .foo
673    .foo configure -string "two words"
674    destroy .foo
675} {}
676test config-9.2 {Tk_FreeConfigOptions/FreeResources - color internal form} testobjconfig {
677    catch {destroy .foo}
678    testobjconfig internal .foo
679    .foo configure -color yellow
680    destroy .foo
681} {}
682test config-9.3 {Tk_FreeConfigOptions/FreeResources - color} testobjconfig {
683    catch {destroy .foo}
684    testobjconfig alltypes .foo
685    .foo configure -color [format blue]
686    destroy .foo
687} {}
688test config-9.4 {Tk_FreeConfigOptions/FreeResources - font internal form} testobjconfig {
689    catch {destroy .foo}
690    testobjconfig internal .foo
691    .foo configure -font {Courier 20}
692    destroy .foo
693} {}
694test config-9.5 {Tk_FreeConfigOptions/FreeResources - font} testobjconfig {
695    catch {destroy .foo}
696    testobjconfig alltypes .foo
697    .foo configure -font [format {Courier 24}]
698    destroy .foo
699} {}
700test config-9.6 {Tk_FreeConfigOptions/FreeResources - bitmap internal form} testobjconfig {
701    catch {destroy .foo}
702    testobjconfig internal .foo
703    .foo configure -bitmap gray75
704    destroy .foo
705} {}
706test config-9.7 {Tk_FreeConfigOptions/FreeResources - bitmap} testobjconfig {
707    catch {destroy .foo}
708    testobjconfig alltypes .foo
709    .foo configure -bitmap [format gray75]
710    destroy .foo
711} {}
712test config-9.8 {Tk_FreeConfigOptions/FreeResources - border internal form} testobjconfig {
713    catch {destroy .foo}
714    testobjconfig internal .foo
715    .foo configure -border orange
716    destroy .foo
717} {}
718test config-9.9 {Tk_FreeConfigOptions/FreeResources - border} testobjconfig {
719    catch {destroy .foo}
720    testobjconfig alltypes .foo
721    .foo configure -border [format blue]
722    destroy .foo
723} {}
724test config-9.10 {Tk_FreeConfigOptions/FreeResources - cursor internal form} testobjconfig {
725    catch {destroy .foo}
726    testobjconfig internal .foo
727    .foo configure -cursor cross
728    destroy .foo
729} {}
730test config-9.11 {Tk_FreeConfigOptions/FreeResources - cursor} testobjconfig {
731    catch {destroy .foo}
732    testobjconfig alltypes .foo
733    .foo configure -cursor [format watch]
734    destroy .foo
735} {}
736test config-9.12 {Tk_FreeConfigOptions/FreeResources - not special} testobjconfig {
737    catch {destroy .foo}
738    testobjconfig alltypes .foo
739    .foo configure -integer [format 27]
740    destroy .foo
741} {}
742test config-9.13 {Tk_FreeConfigOptions/FreeResources - custom internal form} testobjconfig {
743    catch {destroy .fpp}
744    testobjconfig internal .foo
745    .foo configure -custom "foobar"
746    destroy .foo
747} {}
748
749test config-10.1 {Tk_GetOptionInfo - one item} testobjconfig {
750    catch {destroy .foo}
751    testobjconfig alltypes .foo
752    .foo configure -relief groove
753    .foo configure -relief
754} {-relief relief Relief raised groove}
755test config-10.2 {Tk_GetOptionInfo - one item, synonym} testobjconfig {
756    catch {destroy .foo}
757    testobjconfig alltypes .foo
758    .foo configure -color black
759    .foo configure -synonym
760} {-color color Color red black}
761test config-10.3 {Tk_GetOptionInfo - all items} testobjconfig {
762    catch {destroy .foo}
763    testobjconfig alltypes .foo -font {Helvetica 18} -integer 13563
764    .foo configure
765} {{-boolean boolean Boolean 1 1} {-integer integer Integer 7 13563} {-double double Double 3.14159 3.14159} {-string string String foo foo} {-stringtable StringTable stringTable one one} {-color color Color red red} {-font font Font {Helvetica 12} {Helvetica 18}} {-bitmap bitmap Bitmap gray50 gray50} {-border border Border blue blue} {-relief relief Relief raised raised} {-cursor cursor Cursor xterm xterm} {-justify {} {} left left} {-anchor anchor Anchor {} {}} {-pixel pixel Pixel 1 1} {-custom {} {} {} {}} {-synonym -color}}
766test config-10.4 {Tk_GetOptionInfo - chaining through tables} testobjconfig {
767    catch {destroy .foo}
768    testobjconfig chain2 .foo -one asdf -three xyzzy
769    .foo configure
770} {{-three three Three three xyzzy} {-four four Four four four} {-two two Two {two and a half} {two and a half}} {-oneAgain oneAgain OneAgain {one again} {one again}} {-one one One one asdf} {-two two Two two {two and a half}}}
771
772deleteWindows
773if {[testConstraint testobjconfig]} {
774    testobjconfig alltypes .a
775}
776test config-11.1 {GetConfigList - synonym} testobjconfig {
777    lindex [.a configure] end
778} {-synonym -color}
779test config-11.2 {GetConfigList - null database names} testobjconfig {
780    .a configure -justify
781} {-justify {} {} left left}
782test config-11.3 {GetConfigList - null default and current value} testobjconfig {
783    .a configure -anchor
784} {-anchor anchor Anchor {} {}}
785
786deleteWindows
787if {[testConstraint testobjconfig]} {
788    testobjconfig internal .a
789}
790test config-12.1 {GetObjectForOption - boolean} testobjconfig {
791    .a configure -boolean 0
792    .a cget -boolean
793} {0}
794test config-12.2 {GetObjectForOption - integer} testobjconfig {
795    .a configure -integer 1247
796    .a cget -integer
797} {1247}
798test config-12.3 {GetObjectForOption - double} testobjconfig {
799    .a configure -double -88.82
800    .a cget -double
801} {-88.82}
802test config-12.4 {GetObjectForOption - string} testobjconfig {
803    .a configure -string "test value"
804    .a cget -string
805} {test value}
806test config-12.5 {GetObjectForOption - stringTable} testobjconfig {
807    .a configure -stringtable "two"
808    .a cget -stringtable
809} {two}
810test config-12.6 {GetObjectForOption - color} testobjconfig {
811    .a configure -color "green"
812    .a cget -color
813} {green}
814test config-12.7 {GetObjectForOption - font} testobjconfig {
815    .a configure -font {Times 36}
816    .a cget -font
817} {Times 36}
818test config-12.8 {GetObjectForOption - bitmap} testobjconfig {
819    .a configure -bitmap "questhead"
820    .a cget -bitmap
821} {questhead}
822test config-12.9 {GetObjectForOption - border} testobjconfig {
823    .a configure -border #33217c
824    .a cget -border
825} {#33217c}
826test config-12.10 {GetObjectForOption - relief} testobjconfig {
827    .a configure -relief groove
828    .a cget -relief
829} {groove}
830test config-12.11 {GetObjectForOption - cursor} testobjconfig {
831    .a configure -cursor watch
832    .a cget -cursor
833} {watch}
834test config-12.12 {GetObjectForOption - justify} testobjconfig {
835    .a configure -justify right
836    .a cget -justify
837} {right}
838test config-12.13 {GetObjectForOption - anchor} testobjconfig {
839    .a configure -anchor e
840    .a cget -anchor
841} {e}
842test config-12.14 {GetObjectForOption - pixels} testobjconfig {
843    .a configure -pixel 193.2
844    .a cget -pixel
845} {193}
846test config-12.15 {GetObjectForOption - window} testobjconfig {
847    .a configure -window .a
848    .a cget -window
849} {.a}
850test config-12.16 {GetObjectForOption -custom} testobjconfig {
851    .a configure -custom foobar
852    .a cget -custom
853} {FOOBAR}
854test config-12.17 {GetObjectForOption - null values} testobjconfig {
855    .a configure -string {} -color {} -font {} -bitmap {} -border {} \
856	    -cursor {} -window {} -custom {}
857    list [.a cget -string] [.a cget -color] [.a cget -font] \
858	    [.a cget -bitmap] [.a cget -border] [.a cget -cursor] \
859	    [.a cget -window] [.a cget -custom]
860} {{} {} {} {} {} {} {} {}}
861
862test config-13.1 {proper cleanup of options with widget destroy} {
863    foreach type {
864	button canvas entry frame listbox menu menubutton message
865	scale scrollbar text radiobutton checkbutton
866    } {
867	destroy .w
868	$type .w -cursor crosshair
869	destroy .w
870    }
871} {}
872
873deleteWindows
874
875test config-14.1 {Tk_CreateOptionTable - use with namespace import} {
876    namespace export -clear *
877    foreach type {
878	button canvas entry frame listbox menu menubutton message
879	scale scrollbar spinbox text radiobutton checkbutton
880    } {
881	namespace eval ::foo [subst {
882	    namespace import -force ::$type
883	    ::foo::$type .a
884	    ::foo::$type .b
885	}
886	]
887	destroy .a .b
888    }
889} {}
890
891# cleanup
892deleteWindows
893if {[testConstraint testobjconfig]} {
894    killTables
895}
896::tcltest::cleanupTests
897return
898