* generic/tk.h: Added declaration of Tk_ObjCustomOption structure,

used for TK_OPTION_CUSTOM, and typedef's of the functions
Tk_CustomOptionSetProc, Tk_CustomOptionGetProc,
Tk_CustomOptionRestoreProc, and Tk_CustomOptionFreeProc, used for
TK_OPTION_CUSTOM.

* doc/SetOptions.3: Added documentation of TK_OPTION_CUSTOM, and
section "CUSTOM OPTION TYPES" explaining how to create and use
custom options.

* tests/config.test: Added tests for custom option type.

* generic/tkTest.c: Added test support for TK_OPTION_CUSTOM to
TestobjconfigObjCmd.  Added CustomOption* functions to implement a
test custom option.

* generic/tkConfig.c: Added new option type TK_OPTION_CUSTOM,
which allows the definition of custom option types by creating
parsing, printing, freeing, and restoring procedures for a custom
option.  This is needed by the text and canvas widgets if they are
to be fully objectified.

1 files changed, 49 insertions, 11 deletions

diff --git a/tests/config.test b/tests/config.test
index a12ecb5..078c3f5 100644
--- a/tests/config.test
+++ b/tests/config.test
@@ -6,7 +6,7 @@
 # Copyright (c) 1998-1999 by Scriptics Corporation.
 # All rights reserved.
 #
-# RCS: @(#) $Id: config.test,v 1.3 2000/03/02 21:52:25 hobbs Exp $
+# RCS: @(#) $Id: config.test,v 1.4 2000/09/17 21:02:40 ericm Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     source [file join [pwd] [file dirname [info script]] defs.tcl]
@@ -50,7 +50,7 @@ test config-1.1 {Tk_CreateOptionTable - reference counts} {
     lappend x [testobjconfig info alltypes]
     eval destroy [winfo children .]
     set x
-} {{1 15 -boolean} {2 15 -boolean}}
+} {{1 16 -boolean} {2 16 -boolean}}
 test config-1.2 {Tk_CreateOptionTable - synonym initialization} {
     eval destroy [winfo children .]
     testobjconfig alltypes .a -synonym green
@@ -458,9 +458,11 @@ test config-4.64 {DoObjConfig - releasing old values} {
 
     catch {rename .foo {}}
     testobjconfig alltypes .foo -string {Test string} -color yellow \
-	    -font {Courier 18} -bitmap questhead -border green -cursor cross
+	    -font {Courier 18} -bitmap questhead -border green -cursor cross \
+	    -custom foobar
     .foo configure -string {new string} -color brown \
-	    -font {Times 8} -bitmap gray75 -border pink -cursor watch
+	    -font {Times 8} -bitmap gray75 -border pink -cursor watch \
+	    -custom barbaz
     concat {}
 } {}
 test config-4.65 {DoObjConfig - releasing old values} {
@@ -470,11 +472,26 @@ test config-4.65 {DoObjConfig - releasing old values} {
 
     catch {rename .foo {}}
     testobjconfig internal .foo -string {Test string} -color yellow \
-	    -font {Courier 18} -bitmap questhead -border green -cursor cross
+	    -font {Courier 18} -bitmap questhead -border green -cursor cross \
+	    -custom foobar
     .foo configure -string {new string} -color brown \
-	    -font {Times 8} -bitmap gray75 -border pink -cursor watch
+	    -font {Times 8} -bitmap gray75 -border pink -cursor watch \
+	    -custom barbaz
     concat {}
 } {}
+test config-4.66 {DoObjConfig - custom} {
+    catch {destroy .foo}
+    list [catch {testobjconfig alltypes .foo -custom test} msg] $msg [catch {.foo cget -custom} result] $result [destroy .foo]
+} {0 .foo 0 TEST {}}
+test config-4.67 {DoObjConfig - null custom} {
+    catch {destroy .foo}
+    list [catch {testobjconfig alltypes .foo -custom {}} msg] $msg [catch {.foo cget -custom} result] $result [destroy .foo]
+} {0 .foo 0 {} {}}
+test config-4.68 {DoObjConfig - custom internal value} {
+    catch {rename .foo {}}
+    testobjconfig internal .foo -custom "this is a test"
+    .foo cget -custom
+} {THIS IS A TEST}
 
 test config-5.1 {ObjectIsEmpty - object is already string} {
     catch {destroy .foo}
@@ -550,6 +567,12 @@ test config-7.7 {Tk_SetOptions - synonym name in error message} {
 test config-7.8 {Tk_SetOptions - returning mask} {
     format %x [.a configure -color red -int 7 -relief raised -double 3.14159]
 } {226}
+test config-7.9 {Tk_SetOptions - error in DoObjConfig with custom option} {
+    list [catch {.a configure -custom bad} msg] $msg $errorInfo
+} {1 {expected good value, got "BAD"} {expected good value, got "BAD"
+    (processing "-custom" option)
+    invoked from within
+".a configure -custom bad"}}
 
 test config-8.1 {Tk_RestoreSavedOptions - restore in proper order} {
     eval destroy [winfo children .]
@@ -636,6 +659,11 @@ test config-8.16 {Tk_RestoreSavedOptions - window internal form} {
     testobjconfig internal .a -window .a
     list [catch {.a csave -window .a -color bogus}] [.a cget -window]
 } {1 .a}
+test config-8.17 {Tk_RestoreSavedOptions - custom internal form} {
+    eval destroy [winfo children .]
+    testobjconfig internal .a -custom "foobar"
+    list [catch {.a csave -custom "barbaz" -color bogus}] [.a cget -custom]
+} {1 FOOBAR}
 
 # Most of the tests below will cause memory leakage if there is a
 # problem.  This may not be evident unless the tests are run in
@@ -713,6 +741,12 @@ test config-9.12 {Tk_FreeConfigOptions/FreeResources - not special} {
     .foo configure -integer [format 27]
     destroy .foo
 } {}
+test config-9.13 {Tk_FreeConfigOptions/FreeResources - custom internal form} {
+    catch {destroy .fpp}
+    testobjconfig internal .foo
+    .foo configure -custom "foobar"
+    destroy .foo
+} {}
 
 test config-10.1 {Tk_GetOptionInfo - one item} {
     catch {destroy .foo}
@@ -730,7 +764,7 @@ test config-10.3 {Tk_GetOptionInfo - all items} {
     catch {destroy .foo}
     testobjconfig alltypes .foo -font {Helvetica 18} -integer 13563
     .foo configure
-} {{-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} {-synonym -color}}
+} {{-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}}
 test config-10.4 {Tk_GetOptionInfo - chaining through tables} {
     catch {destroy .foo}
     testobjconfig chain2 .foo -one asdf -three xyzzy
@@ -811,12 +845,16 @@ test config-12.15 {GetObjectForOption - window} {
     .a configure -window .a
     .a cget -window
 } {.a}
-test config-12.16 {GetObjectForOption - null values} {
+test config-12.16 {GetObjectForOption -custom} {
+    .a configure -custom foobar
+    .a cget -custom
+} {FOOBAR}
+test config-12.17 {GetObjectForOption - null values} {
     .a configure -string {} -color {} -font {} -bitmap {} -border {} \
-	    -cursor {} -window {}
+	    -cursor {} -window {} -custom {}
     list [.a cget -string] [.a cget -color] [.a cget -font] \
-	    [.a cget -string] [.a cget -bitmap] [.a cget -border] \
-	    [.a cget -cursor] [.a cget -window]
+	    [.a cget -bitmap] [.a cget -border] [.a cget -cursor] \
+	    [.a cget -window] [.a cget -custom]
 } {{} {} {} {} {} {} {} {}}
 
 test config-13.1 {proper cleanup of options with widget destroy} {