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