diff options
| -rw-r--r-- | ChangeLog | 10 | ||||
| -rw-r--r-- | doc/ttk_treeview.n | 16 | ||||
| -rw-r--r-- | generic/ttk/ttkTagSet.c | 73 | ||||
| -rw-r--r-- | generic/ttk/ttkTheme.c | 14 | ||||
| -rw-r--r-- | generic/ttk/ttkTheme.h | 4 | ||||
| -rw-r--r-- | generic/ttk/ttkTreeview.c | 104 | ||||
| -rw-r--r-- | generic/ttk/ttkWidget.h | 9 | ||||
| -rw-r--r-- | tests/ttk/treetags.test | 190 |
8 files changed, 380 insertions, 40 deletions
@@ -1,3 +1,11 @@ +2010-03-28 Joe English <jenglish@users.sourceforge.net> + + * generic/ttk/ttkTagSet.c, generic/ttk/ttkTheme.c, + generic/ttk/ttkTheme.h, generic/ttk/ttkTreeview.c, + generic/ttk/ttkWidget.h, doc/ttk_treeview.n, + tests/ttk/treetags.test: ttk::treeview widget: add 'tag names', + 'tag add', and 'tag remove' methods. + 2010-03-23 Donal K. Fellows <dkf@users.sf.net> * unix/configure.in, unix/Makefile.in: [Bug 2965133]: Get rid of the @@ -534,7 +542,7 @@ * unix/configure: (regenerated) 2009-12-22 Joe English <jenglish@users.sourceforge.net> - + * library/ttk/sizegrip.tcl: [Bug 2912356]: Patch to avoid bizarro behavior under compiz. diff --git a/doc/ttk_treeview.n b/doc/ttk_treeview.n index f351fb3..f1a491e 100644 --- a/doc/ttk_treeview.n +++ b/doc/ttk_treeview.n @@ -4,7 +4,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: ttk_treeview.n,v 1.21 2009/11/15 21:09:22 dkf Exp $ +'\" RCS: @(#) $Id: ttk_treeview.n,v 1.22 2010/03/28 21:43:25 jenglish Exp $ '\" .so man.macros .TH ttk::treeview n 8.5 Tk "Tk Themed Widget" @@ -378,6 +378,20 @@ If \fIitem\fR is specified, returns 1 or 0 depending on whether the specified item has the named tag. Otherwise, returns a list of all items which have the specified tag. +.TP +\fIpathName \fBtag names\fR +Returns a list of all tags used by the widget. +.TP +\fIpathName \fBtag add\fR \fItag\fR \fIitems\fR +Adds the specified \fItag\fR to each of the listed \fIitems\fR. +If \fItag\fR is already present for a particular item, +then the \fB-tags\fR for that item are unchanged. +.TP +\fIpathName \fBtag remove\fR \fItag\fR ?\fIitems\fR? +Removes the specified \fItag\fR from each of the listed \fIitems\fR. +If \fIitems\fR is omitted, removes \fItag\fR from each item in the tree. +If \fItag\fR is not present for a particular item, +then the \fB-tags\fR for that item are unchanged. .RE .TP \fIpathName \fBxview \fIargs\fR diff --git a/generic/ttk/ttkTagSet.c b/generic/ttk/ttkTagSet.c index d925a78..dbf6a5c 100644 --- a/generic/ttk/ttkTagSet.c +++ b/generic/ttk/ttkTagSet.c @@ -1,4 +1,4 @@ -/* $Id: ttkTagSet.c,v 1.4 2008/05/23 20:20:05 jenglish Exp $ +/* $Id: ttkTagSet.c,v 1.5 2010/03/28 21:43:25 jenglish Exp $ * * Tag tables. 3/4-baked, work in progress. * @@ -17,7 +17,8 @@ */ struct TtkTag { int priority; /* 1=>highest */ - void *tagRecord; + const char *tagName; /* Back-pointer to hash table entry */ + void *tagRecord; /* User data */ }; struct TtkTagTable { @@ -32,13 +33,14 @@ struct TtkTagTable { /*------------------------------------------------------------------------ * +++ Tags. */ -static Ttk_Tag NewTag(Ttk_TagTable tagTable) +static Ttk_Tag NewTag(Ttk_TagTable tagTable, const char *tagName) { Ttk_Tag tag = (Ttk_Tag)ckalloc(sizeof(*tag)); tag->tagRecord = ckalloc(tagTable->recordSize); memset(tag->tagRecord, 0, tagTable->recordSize); /* Don't need Tk_InitOptions() here, all defaults should be NULL. */ tag->priority = ++tagTable->nTags; + tag->tagName = tagName; return tag; } @@ -89,7 +91,8 @@ Ttk_Tag Ttk_GetTag(Ttk_TagTable tagTable, const char *tagName) &tagTable->tags, tagName, &isNew); if (isNew) { - Tcl_SetHashValue(entryPtr, NewTag(tagTable)); + tagName = Tcl_GetHashKey(&tagTable->tags, entryPtr); + Tcl_SetHashValue(entryPtr, NewTag(tagTable,tagName)); } return Tcl_GetHashValue(entryPtr); } @@ -139,6 +142,21 @@ Ttk_TagSet Ttk_GetTagSetFromObj( return tagset; } +/* Ttk_NewTagSetObj -- + * Construct a fresh Tcl_Obj * from a tag set. + */ +Tcl_Obj *Ttk_NewTagSetObj(Ttk_TagSet tagset) +{ + Tcl_Obj *result = Tcl_NewListObj(0,0); + int i; + + for (i = 0; i < tagset->nTags; ++i) { + Tcl_ListObjAppendElement( + NULL, result, Tcl_NewStringObj(tagset->tags[i]->tagName, -1)); + } + return result; +} + void Ttk_FreeTagSet(Ttk_TagSet tagset) { ckfree((ClientData)tagset->tags); @@ -158,10 +176,55 @@ int Ttk_TagSetContains(Ttk_TagSet tagset, Ttk_Tag tag) return 0; } +/* Ttk_TagSetAdd -- add a tag to a tag set. + * + * Returns: 0 if tagset already contained tag, + * 1 if tagset was modified. + */ +int Ttk_TagSetAdd(Ttk_TagSet tagset, Ttk_Tag tag) +{ + int i; + for (i = 0; i < tagset->nTags; ++i) { + if (tagset->tags[i] == tag) { + return 0; + } + } + tagset->tags = (void*)ckrealloc((void*)tagset->tags, + (tagset->nTags+1)*sizeof(tagset->tags[0])); + tagset->tags[tagset->nTags++] = tag; + return 1; +} + +/* Ttk_TagSetRemove -- remove a tag from a tag set. + * + * Returns: 0 if tagset did not contain tag, + * 1 if tagset was modified. + */ +int Ttk_TagSetRemove(Ttk_TagSet tagset, Ttk_Tag tag) +{ + int i = 0, j = 0; + while (i < tagset->nTags) { + if ((tagset->tags[j] = tagset->tags[i]) != tag) { + ++j; + } + ++i; + } + tagset->nTags = j; + return j != i; +} + /*------------------------------------------------------------------------ * +++ Utilities for widget commands. */ +/* Ttk_EnumerateTags -- implements [$w tag names] + */ +int Ttk_EnumerateTags( + Tcl_Interp *interp, Ttk_TagTable tagTable) +{ + return TtkEnumerateHashTable(interp, &tagTable->tags); +} + /* Ttk_EnumerateTagOptions -- implements [$w tag configure $tag] */ int Ttk_EnumerateTagOptions( @@ -171,6 +234,8 @@ int Ttk_EnumerateTagOptions( tagTable->optionSpecs, tagTable->optionTable, tagTable->tkwin); } +/* Ttk_TagOptionValue -- implements [$w tag configure $tag -option] + */ Tcl_Obj *Ttk_TagOptionValue( Tcl_Interp *interp, Ttk_TagTable tagTable, diff --git a/generic/ttk/ttkTheme.c b/generic/ttk/ttkTheme.c index 5bf362d..59df20d 100644 --- a/generic/ttk/ttkTheme.c +++ b/generic/ttk/ttkTheme.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * $Id: ttkTheme.c,v 1.22 2010/02/05 21:33:14 jenglish Exp $ + * $Id: ttkTheme.c,v 1.23 2010/03/28 21:43:25 jenglish Exp $ */ #include <stdlib.h> @@ -1118,7 +1118,7 @@ Ttk_DrawElement( */ /* - * EnumerateHashTable -- + * TtkEnumerateHashTable -- * Helper routine. Sets interp's result to the list of all keys * in the hash table. * @@ -1126,7 +1126,8 @@ Ttk_DrawElement( * Side effects: Sets interp's result. */ -static int EnumerateHashTable(Tcl_Interp *interp, Tcl_HashTable *ht) +MODULE_SCOPE +int TtkEnumerateHashTable(Tcl_Interp *interp, Tcl_HashTable *ht) { Tcl_HashSearch search; Tcl_Obj *result = Tcl_NewListObj(0, NULL); @@ -1436,7 +1437,7 @@ static int StyleThemeNamesCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { StylePackageData *pkgPtr = clientData; - return EnumerateHashTable(interp, &pkgPtr->themeTable); + return TtkEnumerateHashTable(interp, &pkgPtr->themeTable); } /* + style theme settings $theme $script @@ -1516,7 +1517,7 @@ static int StyleElementNamesCmd( Tcl_WrongNumArgs(interp, 3, objv, NULL); return TCL_ERROR; } - return EnumerateHashTable(interp, &theme->elementTable); + return TtkEnumerateHashTable(interp, &theme->elementTable); } /* + style element options $element -- @@ -1661,7 +1662,8 @@ StyleObjCmd( return Ttk_InvokeEnsemble(StyleEnsemble, 1, clientData,interp,objc,objv); } -MODULE_SCOPE int Ttk_InvokeEnsemble( /* Run an ensemble command */ +MODULE_SCOPE +int Ttk_InvokeEnsemble( /* Run an ensemble command */ const Ttk_Ensemble *ensemble, int cmdIndex, void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { diff --git a/generic/ttk/ttkTheme.h b/generic/ttk/ttkTheme.h index a123db5..0b7c935 100644 --- a/generic/ttk/ttkTheme.h +++ b/generic/ttk/ttkTheme.h @@ -1,4 +1,4 @@ -/* $Id: ttkTheme.h,v 1.18 2010/01/31 22:50:56 jenglish Exp $ +/* $Id: ttkTheme.h,v 1.19 2010/03/28 21:43:25 jenglish Exp $ * Copyright (c) 2003 Joe English. Freely redistributable. * * Declarations for Tk theme engine. @@ -421,6 +421,8 @@ MODULE_SCOPE int Ttk_InvokeEnsemble( /* Run an ensemble command */ const Ttk_Ensemble *commands, int cmdIndex, void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE int TtkEnumerateHashTable(Tcl_Interp *, Tcl_HashTable *); + /*------------------------------------------------------------------------ * +++ Stub table declarations. */ diff --git a/generic/ttk/ttkTreeview.c b/generic/ttk/ttkTreeview.c index a1380ba..a023eaf 100644 --- a/generic/ttk/ttkTreeview.c +++ b/generic/ttk/ttkTreeview.c @@ -1,4 +1,4 @@ -/* $Id: ttkTreeview.c,v 1.37 2010/02/20 21:30:37 jenglish Exp $ +/* $Id: ttkTreeview.c,v 1.38 2010/03/28 21:43:25 jenglish Exp $ * Copyright (c) 2004, Joe English * * ttk::treeview widget implementation. @@ -3114,10 +3114,110 @@ static int TreeviewTagHasCommand( } } +/* + $tv tag names $tag + */ +static int TreeviewTagNamesCommand( + void *recordPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) +{ + Treeview *tv = recordPtr; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 3, objv, ""); + return TCL_ERROR; + } + + return Ttk_EnumerateTags(interp, tv->tree.tagTable); +} + +/* + $tv tag add $tag $items + */ +static void AddTag(TreeItem *item, Ttk_Tag tag) +{ + if (Ttk_TagSetAdd(item->tagset, tag)) { + Tcl_DecrRefCount(item->tagsObj); + item->tagsObj = Ttk_NewTagSetObj(item->tagset); + Tcl_IncrRefCount(item->tagsObj); + } +} + +static int TreeviewTagAddCommand( + void *recordPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) +{ + Treeview *tv = recordPtr; + Ttk_Tag tag; + TreeItem **items; + int i; + + if (objc != 5) { + Tcl_WrongNumArgs(interp, 3, objv, "tagName items"); + return TCL_ERROR; + } + + tag = Ttk_GetTagFromObj(tv->tree.tagTable, objv[3]); + items = GetItemListFromObj(interp, tv, objv[4]); + + if (!items) { + return TCL_ERROR; + } + + for (i=0; items[i]; ++i) { + AddTag(items[i], tag); + } + + return TCL_OK; +} + +/* + $tv tag remove $tag $items + */ +static void RemoveTag(TreeItem *item, Ttk_Tag tag) +{ + if (Ttk_TagSetRemove(item->tagset, tag)) { + Tcl_DecrRefCount(item->tagsObj); + item->tagsObj = Ttk_NewTagSetObj(item->tagset); + Tcl_IncrRefCount(item->tagsObj); + } +} + +static int TreeviewTagRemoveCommand( + void *recordPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) +{ + Treeview *tv = recordPtr; + Ttk_Tag tag; + + if (objc < 4) { + Tcl_WrongNumArgs(interp, 3, objv, "tagName items"); + return TCL_ERROR; + } + + tag = Ttk_GetTagFromObj(tv->tree.tagTable, objv[3]); + + if (objc == 5) { + TreeItem **items = GetItemListFromObj(interp, tv, objv[4]); + int i; + + if (!items) { + return TCL_ERROR; + } + for (i=0; items[i]; ++i) { + RemoveTag(items[i], tag); + } + } else if (objc == 4) { + TreeItem *item = tv->tree.root; + while (item) { + RemoveTag(item, tag); + item=NextPreorder(item); + } + } + return TCL_OK; +} + static const Ttk_Ensemble TreeviewTagCommands[] = { + { "add", TreeviewTagAddCommand,0 }, { "bind", TreeviewTagBindCommand,0 }, { "configure", TreeviewTagConfigureCommand,0 }, - { "has", TreeviewTagHasCommand,0 }, + { "has", TreeviewTagHasCommand,0 }, + { "names", TreeviewTagNamesCommand,0 }, + { "remove", TreeviewTagRemoveCommand,0 }, { 0,0,0 } }; diff --git a/generic/ttk/ttkWidget.h b/generic/ttk/ttkWidget.h index a5694be..99df0fb 100644 --- a/generic/ttk/ttkWidget.h +++ b/generic/ttk/ttkWidget.h @@ -1,4 +1,4 @@ -/* $Id: ttkWidget.h,v 1.14 2010/02/05 21:33:14 jenglish Exp $ +/* $Id: ttkWidget.h,v 1.15 2010/03/28 21:43:25 jenglish Exp $ * Copyright (c) 2003, Joe English * Helper routines for widget implementations. */ @@ -215,18 +215,21 @@ MODULE_SCOPE Tcl_Obj *Ttk_TagOptionValue( MODULE_SCOPE int Ttk_EnumerateTagOptions( Tcl_Interp *, Ttk_TagTable, Ttk_Tag); +MODULE_SCOPE int Ttk_EnumerateTags(Tcl_Interp *, Ttk_TagTable); + MODULE_SCOPE int Ttk_ConfigureTag( Tcl_Interp *interp, Ttk_TagTable tagTable, Ttk_Tag tag, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Ttk_TagSet Ttk_GetTagSetFromObj( Tcl_Interp *interp, Ttk_TagTable, Tcl_Obj *objPtr); +MODULE_SCOPE Tcl_Obj *Ttk_NewTagSetObj(Ttk_TagSet); MODULE_SCOPE void Ttk_FreeTagSet(Ttk_TagSet); MODULE_SCOPE int Ttk_TagSetContains(Ttk_TagSet, Ttk_Tag tag); -MODULE_SCOPE void Ttk_TagSetAdd(Ttk_TagSet, Ttk_Tag tag); -MODULE_SCOPE void Ttk_TagSetRemove(Ttk_TagSet, Ttk_Tag tag); +MODULE_SCOPE int Ttk_TagSetAdd(Ttk_TagSet, Ttk_Tag tag); +MODULE_SCOPE int Ttk_TagSetRemove(Ttk_TagSet, Ttk_Tag tag); MODULE_SCOPE void Ttk_TagSetValues(Ttk_TagTable, Ttk_TagSet, void *record); MODULE_SCOPE void Ttk_TagSetApplyStyle(Ttk_TagTable,Ttk_Style,Ttk_State,void*); diff --git a/tests/ttk/treetags.test b/tests/ttk/treetags.test index fe4dbcd..ed139a1 100644 --- a/tests/ttk/treetags.test +++ b/tests/ttk/treetags.test @@ -1,48 +1,147 @@ # -# $Id: treetags.test,v 1.2 2007/05/18 16:53:18 dgp Exp $ +# $Id: treetags.test,v 1.3 2010/03/28 21:43:25 jenglish Exp $ # -package require Tk 8.5 +package require Tk package require tcltest ; namespace import -force tcltest::* loadTestedCommands -tk useinputmethods 0 -testConstraint treeview [llength [info commands ttk::treeview]] -testConstraint nyi 0 +### treeview tag invariants: +# + +proc assert {expr {message ""}} { + if {![uplevel 1 [list expr $expr]]} { + error "PANIC: $message ($expr failed)" + } +} +proc in {e l} { expr {[lsearch -exact $l $e] >= 0} } + +proc itemConstraints {tv item} { + # $tag in [$tv item $item -tags] <==> [$tv tag has $tag $item] + foreach tag [$tv item $item -tags] { + assert {[in $item [$tv tag has $tag]]} + } + foreach child [$tv children $item] { + itemConstraints $tv $child + } +} + +proc treeConstraints {tv} { + # $item in [$tv tag has $tag] <==> [$tv tag has $tag $item] + # + foreach tag [$tv tag names] { + foreach item [$tv tag has $tag] { + assert {[in $tag [$tv item $item -tags]]} + } + } -test treetags-1.0 "Setup" -constraints treeview -body { + itemConstraints $tv {} +} +# +### + +test treetags-1.0 "Setup" -body { set tv [ttk::treeview .tv] .tv insert {} end -id item1 -text "Item 1" - pack .tv + pack .tv +} -cleanup { + treeConstraints $tv } -test treetags-1.1 "Bad tag list" -constraints treeview -body { +test treetags-1.1 "Bad tag list" -body { $tv item item1 -tags {bad {list}here bad} + $tv item item1 -tags } -returnCodes error -result "list element in braces *" -match glob -test treetags-1.2 "Good tag list" -constraints treeview -body { +test treetags-1.2 "Good tag list" -body { $tv item item1 -tags tag1 $tv item item1 -tags +} -cleanup { + assert {[$tv tag has tag1 item1]} + treeConstraints $tv } -result [list tag1] -test treetags-1.3 "Bad events" -constraints treeview -body { - $tv tag bind bad <Enter> { puts "Entered!" } -} -returnCodes 1 -result "unsupported event <Enter>*" -match glob +test treetags-1.3 "tag has - test" -body { + $tv insert {} end -id item2 -text "Item 2" -tags tag2 + set result [list] + foreach item {item1 item2} { + foreach tag {tag1 tag2 tag3} { + lappend result $item $tag [$tv tag has $tag $item] + } + } + set result +} -cleanup { + treeConstraints $tv +} -result [list \ + item1 tag1 1 item1 tag2 0 item1 tag3 0 \ + item2 tag1 0 item2 tag2 1 item2 tag3 0 ] + +test treetags-1.4 "tag has - query" -body { + list [$tv tag has tag1] [$tv tag has tag2] [$tv tag has tag3] +} -cleanup { + treeConstraints $tv +} -result [list [list item1] [list item2] [list]] + +test treetags-1.5 "tag add" -body { + $tv tag add tag3 {item1 item2} + list [$tv tag has tag1] [$tv tag has tag2] [$tv tag has tag3] +} -cleanup { + treeConstraints $tv +} -result [list [list item1] [list item2] [list item1 item2]] + +test treetags-1.6 "tag remove - list" -body { + $tv tag remove tag3 {item1 item2} + list [$tv tag has tag1] [$tv tag has tag2] [$tv tag has tag3] +} -cleanup { + treeConstraints $tv +} -result [list [list item1] [list item2] [list]] + +test treetags-1.7 "tag remove - all items" -body { + $tv tag remove tag1 + list [$tv tag has tag1] [$tv tag has tag2] [$tv tag has tag3] +} -cleanup { + treeConstraints $tv +} -result [list [list] [list item2] [list]] + +test treetags-1.8 "tag names" -body { + lsort [$tv tag names] +} -result [list tag1 tag2 tag3] + +test treetags-1.9 "tag names - tag added to item" -body { + $tv item item1 -tags tag4 + lsort [$tv tag names] +} -result [list tag1 tag2 tag3 tag4] + +test treetags-1.10 "tag names - tag configured" -body { + $tv tag configure tag5 + lsort [$tv tag names] +} -result [list tag1 tag2 tag3 tag4 tag5] + +test treetags-1.end "cleanup" -body { + $tv item item1 -tags tag1 + $tv item item2 -tags tag2 + list [$tv tag has tag1] [$tv tag has tag2] [$tv tag has tag3] +} -cleanup { + treeConstraints $tv +} -result [list [list item1] [list item2] [list]] -test treetags-2.0 "tag bind" -constraints treeview -body { +test treetags-2.0 "tag bind" -body { $tv tag bind tag1 <KeyPress> {set ::KEY %A} $tv tag bind tag1 <KeyPress> +} -cleanup { + treeConstraints $tv } -result {set ::KEY %A} -test treetags-2.1 "Events delivered to tags" -constraints treeview -body { +test treetags-2.1 "Events delivered to tags" -body { focus -force $tv ; update ;# needed so [event generate] delivers KeyPress $tv focus item1 - event generate .tv <KeyPress-a> + event generate $tv <KeyPress-a> set ::KEY +} -cleanup { + treeConstraints $tv } -result a -test treetags-2.2 "Events delivered to correct tags" -constraints treeview -body { - $tv insert {} end -id item2 -tags tag2 +test treetags-2.2 "Events delivered to correct tags" -body { $tv tag bind tag2 <KeyPress> [list set ::KEY2 %A] $tv focus item1 @@ -51,9 +150,11 @@ test treetags-2.2 "Events delivered to correct tags" -constraints treeview -body event generate $tv <KeyPress-c> list $::KEY $::KEY2 +} -cleanup { + treeConstraints $tv } -result [list b c] -test treetags-2.3 "Virtual events delivered to focus item" -constraints treeview -body { +test treetags-2.3 "Virtual events delivered to focus item" -body { set ::bong 0 $tv tag bind tag2 <<Bing>> { incr bong } $tv focus item2 @@ -61,18 +162,63 @@ test treetags-2.3 "Virtual events delivered to focus item" -constraints treeview $tv focus item1 event generate $tv <<Bing>> set bong +} -cleanup { + treeConstraints $tv } -result 1 +test treetags-2.4 "Bad events" -body { + $tv tag bind bad <Enter> { puts "Entered!" } +} -returnCodes 1 -result "unsupported event <Enter>*" -match glob -test treetags-3.0 "tag configure" -constraints treeview -body { +test treetags-3.0 "tag configure - set" -body { $tv tag configure tag1 -foreground blue -background red +} -cleanup { + treeConstraints $tv } -result {} -test treetags-3.1 "tag configure" -constraints treeview -body { +test treetags-3.1 "tag configure - get" -body { $tv tag configure tag1 -foreground -} -result [list blue] +} -cleanup { + treeConstraints $tv +} -result blue + +# @@@ fragile test +test treetags-3.2 "tag configure - enumerate" -body { + $tv tag configure tag1 +} -cleanup { + treeConstraints $tv +} -result [list \ + -text {} -image {} -anchor {} -background red -foreground blue -font {} \ +] + +# The next test exercises tag resource management. +# If options are not properly freed, the message: +# Test file error: "Font times 20 still in cache." +# will show up on stderr at program exit. +# +test treetags-3.3 "tag configure - set font" -body { + $tv tag configure tag2 -font {times 20} +} + +test treetags-3.4 "stomp tags in tag binding procedure" -body { + set result [list] + $tv tag bind rm1 <<Remove>> { lappend ::result rm1 [%W focus] <<Remove>> } + $tv tag bind rm2 <<Remove>> { + lappend ::result rm2 [%W focus] <<Remove>> + %W item [%W focus] -tags {tag1} + } + $tv tag bind rm3 <<Remove>> { lappend ::result rm3 [%W focus] <<Remove>> } + $tv item item1 -tags {rm1 rm2 rm3} + $tv focus item1 + event generate $tv <<Remove>> + set result +} -cleanup { + treeConstraints $tv +} -result [list rm1 item1 <<Remove>> rm2 item1 <<Remove>> rm3 item1 <<Remove>>] + +# -test treetags-end "Cleanup" -constraints treeview -body { destroy .tv } +test treetags-end "Cleanup" -body { destroy $tv } tcltest::cleanupTests |