diff options
| -rw-r--r-- | ChangeLog | 10 | ||||
| -rw-r--r-- | doc/image.n | 6 | ||||
| -rw-r--r-- | generic/tkImage.c | 40 | ||||
| -rw-r--r-- | tests/image.test | 50 |
4 files changed, 82 insertions, 24 deletions
@@ -1,3 +1,13 @@ +2000-05-15 Eric Melski <ericm@scriptics.com> + + * doc/image.n: Added documentation for [image inuse] command. + + * tests/image.test: Added tests for [image inuse] command. + + * generic/tkImage.c (Tk_ImageObjCmd): Added [image inuse] command, + which provides a means for programmers to determine if a given + image is in use by any widgets. [RFE: 3327]. + 2000-05-14 Eric Melski <ericm@scriptics.com> * doc/clipboard.n: Added documentation for "clipboard get". diff --git a/doc/image.n b/doc/image.n index 4c55018..4277ef4 100644 --- a/doc/image.n +++ b/doc/image.n @@ -5,7 +5,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: image.n,v 1.2 1998/09/14 18:22:57 stanton Exp $ +'\" RCS: @(#) $Id: image.n,v 1.3 2000/05/15 18:21:47 ericm Exp $ '\" .so man.macros .TH image n 4.0 Tk "Tk Built-In Commands" @@ -54,6 +54,10 @@ the existing instances will use the new image. Returns a decimal string giving the height of image \fIname\fR in pixels. .TP +\fBimage inuse \fIname\fR +Returns a boolean value indicating whether or not the image given by +\fIname\fR is in use by any widgets. +.TP \fBimage names\fR Returns a list containing the names of all existing images. .TP diff --git a/generic/tkImage.c b/generic/tkImage.c index 0c763a1..31ac3bb 100644 --- a/generic/tkImage.c +++ b/generic/tkImage.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tkImage.c,v 1.6 2000/04/25 01:03:06 hobbs Exp $ + * RCS: @(#) $Id: tkImage.c,v 1.7 2000/05/15 18:21:47 ericm Exp $ */ #include "tkInt.h" @@ -157,11 +157,11 @@ Tk_ImageObjCmd(clientData, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument strings. */ { static char *imageOptions[] = { - "create", "delete", "height", "names", "type", "types", "width", - (char *) NULL + "create", "delete", "height", "inuse", "names", "type", "types", + "width", (char *) NULL }; enum options { - IMAGE_CREATE, IMAGE_DELETE, IMAGE_HEIGHT, IMAGE_NAMES, + IMAGE_CREATE, IMAGE_DELETE, IMAGE_HEIGHT, IMAGE_INUSE, IMAGE_NAMES, IMAGE_TYPE, IMAGE_TYPES, IMAGE_WIDTH }; TkWindow *winPtr = (TkWindow *) clientData; @@ -344,18 +344,46 @@ Tk_ImageObjCmd(clientData, interp, objc, objv) Tcl_SetIntObj(Tcl_GetObjResult(interp), masterPtr->height); break; } + + case IMAGE_INUSE: { + int count = 0; + char *arg; + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "name"); + return TCL_ERROR; + } + arg = Tcl_GetString(objv[2]); + hPtr = Tcl_FindHashEntry(&winPtr->mainPtr->imageTable, arg); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "image \"", arg, + "\" doesn't exist", (char *) NULL); + return TCL_ERROR; + } + masterPtr = (ImageMaster *) Tcl_GetHashValue(hPtr); + if (masterPtr->typePtr != NULL) { + for (imagePtr = masterPtr->instancePtr; imagePtr != NULL; + imagePtr = imagePtr->nextPtr) { + count = 1; + break; + } + } + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), count); + break; + } + case IMAGE_NAMES: { if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } - for (hPtr = Tcl_FirstHashEntry(&winPtr->mainPtr->imageTable, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + hPtr = Tcl_FirstHashEntry(&winPtr->mainPtr->imageTable, &search); + for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { Tcl_AppendElement(interp, Tcl_GetHashKey( &winPtr->mainPtr->imageTable, hPtr)); } break; } + case IMAGE_TYPE: { char *arg; if (objc != 3) { diff --git a/tests/image.test b/tests/image.test index e3f7841..b2abc36 100644 --- a/tests/image.test +++ b/tests/image.test @@ -7,7 +7,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: image.test,v 1.3 1999/04/16 01:51:38 stanton Exp $ +# RCS: @(#) $Id: image.test,v 1.4 2000/05/15 18:21:47 ericm Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { source [file join [pwd] [file dirname [info script]] defs.tcl] @@ -36,7 +36,7 @@ test image-1.1 {Tk_ImageCmd procedure, "create" option} { } {1 {wrong # args: should be "image option ?args?"}} test image-1.2 {Tk_ImageCmd procedure, "create" option} { list [catch {image gorp} msg] $msg -} {1 {bad option "gorp": must be create, delete, height, names, type, types, or width}} +} {1 {bad option "gorp": must be create, delete, height, inuse, names, type, types, or width}} test image-1.3 {Tk_ImageCmd procedure, "create" option} { list [catch {image create} msg] $msg } {1 {wrong # args: should be "image create type ?name? ?options?"}} @@ -178,7 +178,21 @@ test image-7.4 {Tk_ImageCmd procedure, "width" option} { list $x [image width myimage] } {30 60} -test image-8.1 {Tk_ImageChanged procedure} { +test image-8.1 {Tk_ImageCmd procedure, "inuse" option} { + catch {image delete myimage2} + image create test myimage2 + set res {} + lappend res [image inuse myimage2] + catch {destroy .b} + button .b -image myimage2 + lappend res [image inuse myimage2] + catch {destroy .b} + image delete myimage2 + set res +} [list 0 1] + + +test image-9.1 {Tk_ImageChanged procedure} { .c delete all eval image delete [image names] image create test foo -variable x @@ -189,7 +203,7 @@ test image-8.1 {Tk_ImageChanged procedure} { update set x } {{foo display 5 6 7 8 30 30}} -test image-8.2 {Tk_ImageChanged procedure} { +test image-9.2 {Tk_ImageChanged procedure} { .c delete all eval image delete [image names] image create test foo -variable x @@ -202,10 +216,10 @@ test image-8.2 {Tk_ImageChanged procedure} { set x } {{foo display 5 6 25 9 30 30} {foo display 0 0 12 14 65 74}} -test image-9.1 {Tk_GetImage procedure} { +test image-10.1 {Tk_GetImage procedure} { list [catch {.c create image 100 10 -image bad_name} msg] $msg } {1 {image "bad_name" doesn't exist}} -test image-9.2 {Tk_GetImage procedure} { +test image-10.2 {Tk_GetImage procedure} { image create test mytest catch {destroy .l} label .l -image mytest @@ -215,7 +229,7 @@ test image-9.2 {Tk_GetImage procedure} { set result } {1 {image "mytest" doesn't exist}} -test image-10.1 {Tk_FreeImage procedure} { +test image-11.1 {Tk_FreeImage procedure} { .c delete all eval image delete [image names] image create test foo -variable x @@ -229,7 +243,7 @@ test image-10.1 {Tk_FreeImage procedure} { update list [image names] $x } {foo {{foo free} {foo display 0 0 30 15 103 121}}} -test image-10.2 {Tk_FreeImage procedure} { +test image-11.2 {Tk_FreeImage procedure} { .c delete all eval image delete [image names] image create test foo -variable x @@ -247,7 +261,7 @@ test image-10.2 {Tk_FreeImage procedure} { # Non-portable, apparently due to differences in rounding: -test image-11.1 {Tk_RedrawImage procedure, redisplay area clipping} \ +test image-12.1 {Tk_RedrawImage procedure, redisplay area clipping} \ {nonPortable} { .c delete all eval image delete [image names] @@ -259,7 +273,7 @@ test image-11.1 {Tk_RedrawImage procedure, redisplay area clipping} \ update set x } {{foo display 0 0 5 5 50 50}} -test image-11.2 {Tk_RedrawImage procedure, redisplay area clipping} \ +test image-12.2 {Tk_RedrawImage procedure, redisplay area clipping} \ {nonPortable} { .c delete all eval image delete [image names] @@ -271,7 +285,7 @@ test image-11.2 {Tk_RedrawImage procedure, redisplay area clipping} \ update set x } {{foo display 10 0 20 5 30 50}} -test image-11.3 {Tk_RedrawImage procedure, redisplay area clipping} \ +test image-12.3 {Tk_RedrawImage procedure, redisplay area clipping} \ {nonPortable} { .c delete all eval image delete [image names] @@ -283,7 +297,7 @@ test image-11.3 {Tk_RedrawImage procedure, redisplay area clipping} \ update set x } {{foo display 10 10 20 5 30 30}} -test image-11.4 {Tk_RedrawImage procedure, redisplay area clipping} \ +test image-12.4 {Tk_RedrawImage procedure, redisplay area clipping} \ {nonPortable} { .c delete all eval image delete [image names] @@ -295,7 +309,7 @@ test image-11.4 {Tk_RedrawImage procedure, redisplay area clipping} \ update set x } {{foo display 0 10 5 5 50 30}} -test image-11.5 {Tk_RedrawImage procedure, redisplay area clipping} \ +test image-12.5 {Tk_RedrawImage procedure, redisplay area clipping} \ {nonPortable} { .c delete all eval image delete [image names] @@ -307,7 +321,7 @@ test image-11.5 {Tk_RedrawImage procedure, redisplay area clipping} \ update set x } {{foo display 0 0 30 15 70 70}} -test image-11.6 {Tk_RedrawImage procedure, redisplay area clipping} \ +test image-12.6 {Tk_RedrawImage procedure, redisplay area clipping} \ {nonPortable} { .c delete all eval image delete [image names] @@ -320,7 +334,7 @@ test image-11.6 {Tk_RedrawImage procedure, redisplay area clipping} \ set x } {{foo display 5 5 20 5 30 30}} -test image-12.1 {Tk_SizeOfImage procedure} { +test image-13.1 {Tk_SizeOfImage procedure} { eval image delete [image names] image create test foo -variable x set result [list [image width foo] [image height foo]] @@ -328,7 +342,7 @@ test image-12.1 {Tk_SizeOfImage procedure} { lappend result [image width foo] [image height foo] } {30 15 85 60} -test image-12.2 {DeleteImage procedure} { +test image-13.2 {DeleteImage procedure} { .c delete all eval image delete [image names] image create test foo -variable x @@ -345,7 +359,7 @@ catch {image delete hidden} set l [image names] set h [interp hidden] -test image-13.1 {image command vs hidden commands} { +test image-14.1 {image command vs hidden commands} { catch {image delete hidden} image create photo hidden interp hide {} hidden @@ -372,3 +386,5 @@ return + + |