diff options
59 files changed, 922 insertions, 933 deletions
@@ -1,41 +0,0 @@ -README: Tk - This is the Tk 8.6.9 source distribution. - http://sourceforge.net/projects/tcl/files/Tcl/ - You can get any source release of Tk from the URL above. - -1. Introduction ---------------- - -This directory contains the sources and documentation for Tk, an X11 -toolkit implemented with the Tcl scripting language. - -For details on features, incompatibilities, and potential problems with -this release, see the Tcl/Tk 8.6 Web page at - - http://www.tcl-lang.org/software/tcltk/8.6.html - -or refer to the "changes" file in this directory, which contains a -historical record of all changes to Tk. - -Tk is maintained, enhanced, and distributed freely by the Tcl community. -Source code development and tracking of bug reports and feature requests -takes place at: - - http://core.tcl-lang.org/tk/ - -with the Tcl Developer Xchange at: - - http://www.tcl-lang.org/ - -Tk is a freely available open source package. You can do virtually -anything you like with it, such as modifying it, redistributing it, -and selling it either in whole or in part. See the file -"license.terms" for complete information. - -2. See Tcl README ------------------ - -Please see the README file that comes with the associated Tcl release -for more information. There are pointers there to extensive -documentation. In addition, there are additional README files -in the subdirectories of this distribution. diff --git a/README.md b/README.md new file mode 100644 index 0000000..26f923a --- /dev/null +++ b/README.md @@ -0,0 +1,37 @@ +# README: Tk + +This is the **Tk 8.6.9** source distribution. + +You can get any source release of Tk from [our distribution +site](https://sourceforge.net/projects/tcl/files/Tcl/). + + +## <a id="intro">1.</a> Introduction + +This directory contains the sources and documentation for Tk, a +cross-platform GUI toolkit implemented with the Tcl scripting language. + +For details on features, incompatibilities, and potential problems with +this release, see [the Tcl/Tk 8.6 Web page](https://www.tcl.tk/software/tcltk/8.6.html) +or refer to the "changes" file in this directory, which contains a +historical record of all changes to Tk. + +Tk is maintained, enhanced, and distributed freely by the Tcl community. +Source code development and tracking of bug reports and feature requests +takes place at [core.tcl-lang.org](https://core.tcl-lang.org/). +Tcl/Tk release and mailing list services are [hosted by +SourceForge](https://sourceforge.net/projects/tcl/) +with the Tcl Developer Xchange hosted at +[www.tcl-lang.org](https://www.tcl-lang.org). + +Tk is a freely available open source package. You can do virtually +anything you like with it, such as modifying it, redistributing it, +and selling it either in whole or in part. See the file +`license.terms` for complete information. + +## <a id="tcl">2.</a> See Tcl README.md + +Please see the README.md file that comes with the associated Tcl release +for more information. There are pointers there to extensive +documentation. In addition, there are additional README files +in the subdirectories of this distribution. diff --git a/doc/ttk_combobox.n b/doc/ttk_combobox.n index b8fd2bc..9d0bcc6 100644 --- a/doc/ttk_combobox.n +++ b/doc/ttk_combobox.n @@ -67,7 +67,9 @@ The following subcommands are possible for combobox widgets: .TP \fIpathName \fBcurrent\fR ?\fInewIndex\fR? If \fInewIndex\fR is supplied, sets the combobox value -to the element at position \fInewIndex\fR in the list of \fB\-values\fR. +to the element at position \fInewIndex\fR in the list of \fB\-values\fR +(in addition to integers, the \fBend\fR index is supported and indicates +the last element of the list). Otherwise, returns the index of the current value in the list of \fB\-values\fR or \fB\-1\fR if the current value does not appear in the list. .TP diff --git a/doc/ttk_treeview.n b/doc/ttk_treeview.n index 5fd5e6d..125cc78 100644 --- a/doc/ttk_treeview.n +++ b/doc/ttk_treeview.n @@ -133,25 +133,29 @@ The column name. This is a read-only option. For example, [\fI$pathname \fBcolumn #\fIn \fB\-id\fR] returns the data column associated with display column #\fIn\fR. .TP -\fB\-anchor\fR +\fB\-anchor \fIanchor\fR Specifies how the text in this column should be aligned -with respect to the cell. One of +with respect to the cell. \fIAnchor\fR is one of \fBn\fR, \fBne\fR, \fBe\fR, \fBse\fR, \fBs\fR, \fBsw\fR, \fBw\fR, \fBnw\fR, or \fBcenter\fR. .TP -\fB\-minwidth\fR +\fB\-minwidth \fIminwidth\fR The minimum width of the column in pixels. The treeview widget will not make the column any smaller than \fB\-minwidth\fR when the widget is resized or the user drags a +column separator. Default is 20 pixels. +.TP +\fB\-stretch \fIboolean\fR +Specifies whether or not the column width should be adjusted +when the widget is resized or the user drags a column separator. +\fIBoolean\fR may have any of the forms accepted by \fBTcl_GetBoolean\fR. +By default columns are stretchable. +.TP +\fB\-width \fIwidth\fR +The width of the column in pixels. Default is 200 pixels. The specified +column width may be changed by Tk in order to honor \fB\-stretch\fR +and/or \fB\-minwidth\fR, or when the widget is resized or the user drags a column separator. -.TP -\fB\-stretch\fR -Specifies whether or not the column's width should be adjusted -when the widget is resized. -.TP -\fB\-width \fIw\fR -The width of the column in pixels. Default is something reasonable, -probably 200 or so. .PP Use \fIpathname column #0\fR to configure the tree column. .RE diff --git a/generic/tkGrab.c b/generic/tkGrab.c index 5ea2906..21c06a9 100644 --- a/generic/tkGrab.c +++ b/generic/tkGrab.c @@ -881,8 +881,9 @@ TkPointerEvent( return 1; } } else { - if ((eventPtr->xbutton.state & ALL_BUTTONS) - == buttonStates[eventPtr->xbutton.button - Button1]) { + if (eventPtr->xbutton.button != AnyButton && + ((eventPtr->xbutton.state & ALL_BUTTONS) + == buttonStates[eventPtr->xbutton.button - Button1])) { ReleaseButtonGrab(dispPtr); /* Note 4. */ } } diff --git a/generic/tkTest.c b/generic/tkTest.c index 6712017..44fec0d 100644 --- a/generic/tkTest.c +++ b/generic/tkTest.c @@ -31,9 +31,9 @@ #if defined(MAC_OSX_TK) #include "tkMacOSXInt.h" #include "tkScrollbar.h" -#define APP_IS_DRAWING TkTestAppIsDrawing() +#define LOG_DISPLAY TkTestLogDisplay() #else -#define APP_IS_DRAWING 0 +#define LOG_DISPLAY 1 #endif #ifdef __UNIX__ @@ -1556,25 +1556,36 @@ ImageDisplay( /* * The purpose of the test image type is to track the calls to an image * display proc and record the parameters passed in each call. On macOS - * these tests will fail because of the asynchronous drawing. The low - * level graphics calls below which are supposed to draw a rectangle will - * not draw anything to the screen because the idle task will not be - * processed inside of the drawRect method and hence will not be able to - * obtain a valid graphics context. Instead, the window will be marked as - * needing display, and will be redrawn during a future asynchronous call - * to drawRect. This will generate an other call to this display proc, - * and the recorded data will show extra calls, causing the test to fail. - * To avoid this, we can set the [NSApp simulateDrawing] flag, which will - * cause all low level drawing routines to return immediately and not - * schedule the window for drawing later. This flag is cleared by the - * next call to XSync, which is called by the update command. + * a display proc must be run inside of the drawRect method of an NSView + * in order for the graphics operations to have any effect. To deal with + * this, whenever a display proc is called outside of any drawRect method + * it schedules a redraw of the NSView by calling [view setNeedsDisplay:YES]. + * This will trigger a later call to the view's drawRect method which will + * run the display proc a second time. + * + * This complicates testing, since it can result in more calls to the display + * proc than are expected by the test. It can also result in an inconsistent + * number of calls unless the test waits until the call to drawRect actually + * occurs before validating its results. + * + * In an attempt to work around this, this display proc only logs those + * calls which occur within a drawRect method. This means that tests must + * be written so as to ensure that the drawRect method is run before + * results are validated. In practice it usually suffices to run update + * idletasks (to run the display proc the first time) followed by update + * (to run the display proc in drawRect). + * + * This also has the consequence that the image changed command will log + * different results on Aqua than on other systems, because when the image + * is redisplayed in the drawRect method the entire image will be drawn, + * not just the changed portion. Tests must account for this. */ - sprintf(buffer, "%s display %d %d %d %d", - instPtr->masterPtr->imageName, imageX, imageY, width, height); - if (!APP_IS_DRAWING) { + if (LOG_DISPLAY) { + sprintf(buffer, "%s display %d %d %d %d", + instPtr->masterPtr->imageName, imageX, imageY, width, height); Tcl_SetVar2(instPtr->masterPtr->interp, instPtr->masterPtr->varName, - NULL, buffer, TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT); + NULL, buffer, TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT); } if (width > (instPtr->masterPtr->width - imageX)) { width = instPtr->masterPtr->width - imageX; diff --git a/generic/ttk/ttkEntry.c b/generic/ttk/ttkEntry.c index 36edf38..1579a32 100644 --- a/generic/ttk/ttkEntry.c +++ b/generic/ttk/ttkEntry.c @@ -1701,6 +1701,16 @@ static WidgetSpec EntryWidgetSpec = { }; /*------------------------------------------------------------------------ + * Named indices for the combobox "current" command + */ +static const char *const comboboxCurrentIndexNames[] = { + "end", NULL +}; +enum comboboxCurrentIndices { + INDEX_END +}; + +/*------------------------------------------------------------------------ * +++ Combobox widget record. */ @@ -1801,15 +1811,42 @@ static int ComboboxCurrentCommand( Tcl_SetObjResult(interp, Tcl_NewIntObj(currentIndex)); return TCL_OK; } else if (objc == 3) { - if (Tcl_GetIntFromObj(interp, objv[2], ¤tIndex) != TCL_OK) { - return TCL_ERROR; - } - if (currentIndex < 0 || currentIndex >= nValues) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "Index %s out of range", Tcl_GetString(objv[2]))); - Tcl_SetErrorCode(interp, "TTK", "COMBOBOX", "IDX_RANGE", NULL); - return TCL_ERROR; - } + int result, index; + + result = Tcl_GetIndexFromObj(NULL, objv[2], comboboxCurrentIndexNames, + "", 0, &index); + if (result == TCL_OK) { + + /* + * The index is one of the named indices. + */ + + switch (index) { + case INDEX_END: + /* "end" index */ + currentIndex = nValues - 1; + break; + } + } else { + + /* + * The index should be just an integer. + */ + + if (Tcl_GetIntFromObj(NULL, objv[2], ¤tIndex) != TCL_OK) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "Incorrect index %s", Tcl_GetString(objv[2]))); + Tcl_SetErrorCode(interp, "TTK", "COMBOBOX", "IDX_VALUE", NULL); + return TCL_ERROR; + } + + if (currentIndex < 0 || currentIndex >= nValues) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "Index %s out of range", Tcl_GetString(objv[2]))); + Tcl_SetErrorCode(interp, "TTK", "COMBOBOX", "IDX_RANGE", NULL); + return TCL_ERROR; + } + } cbPtr->combobox.currentIndex = currentIndex; diff --git a/generic/ttk/ttkTrace.c b/generic/ttk/ttkTrace.c index ba66db4..7c4345d 100644 --- a/generic/ttk/ttkTrace.c +++ b/generic/ttk/ttkTrace.c @@ -34,7 +34,7 @@ VarTraceProc( const char *name, *value; Tcl_Obj *valuePtr; - if (flags & TCL_INTERP_DESTROYED) { + if (Tcl_InterpDeleted(interp)) { return NULL; } diff --git a/generic/ttk/ttkTreeview.c b/generic/ttk/ttkTreeview.c index d78df5f..b1739b6 100644 --- a/generic/ttk/ttkTreeview.c +++ b/generic/ttk/ttkTreeview.c @@ -282,7 +282,7 @@ static Tk_OptionSpec ColumnOptionSpecs[] = { 0,0,0 }, {TK_OPTION_BOOLEAN, "-stretch", "stretch", "Stretch", "1", -1, Tk_Offset(TreeColumn,stretch), - 0,0,0 }, + 0,0,GEOMETRY_CHANGED }, {TK_OPTION_ANCHOR, "-anchor", "anchor", "Anchor", "w", Tk_Offset(TreeColumn,anchorObj), -1, /* <<NOTE-ANCHOR>> */ 0,0,0 }, @@ -1234,11 +1234,10 @@ static int ConfigureColumn( TtkResizeWidget(&tv->core); } RecomputeSlack(tv); + ResizeColumns(tv, TreeWidth(tv)); } TtkRedisplayWidget(&tv->core); - /* ASSERT: SLACKINVARIANT */ - Tk_FreeSavedOptions(&savedOptions); return TCL_OK; @@ -1615,13 +1614,10 @@ static void TreeviewDoLayout(void *clientData) Treeview *tv = clientData; int visibleRows; - /* ASSERT: SLACKINVARIANT */ - Ttk_PlaceLayout(tv->core.layout,tv->core.state,Ttk_WinBox(tv->core.tkwin)); tv->tree.treeArea = Ttk_ClientRegion(tv->core.layout, "treearea"); ResizeColumns(tv, tv->tree.treeArea.width); - /* ASSERT: SLACKINVARIANT */ TtkScrolled(tv->tree.xscrollHandle, tv->tree.xscroll.first, @@ -2684,7 +2680,7 @@ static int TreeviewDeleteCommand( { Treeview *tv = recordPtr; TreeItem **items, *delq; - int i; + int i, selItemDeleted = 0; if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "items"); @@ -2711,6 +2707,9 @@ static int TreeviewDeleteCommand( */ delq = 0; for (i=0; items[i]; ++i) { + if (items[i]->state & TTK_STATE_SELECTED) { + selItemDeleted = 1; + } delq = DeleteItems(items[i], delq); } @@ -2727,6 +2726,9 @@ static int TreeviewDeleteCommand( } ckfree(items); + if (selItemDeleted) { + TtkSendVirtualEvent(tv->core.tkwin, "TreeviewSelect"); + } TtkRedisplayWidget(&tv->core); return TCL_OK; } @@ -2885,9 +2887,28 @@ static int TreeviewDragCommand( TreeColumn *c = tv->tree.displayColumns[i]; int right = left + c->width; if (c == column) { - DragColumn(tv, i, newx - right); - /* ASSERT: SLACKINVARIANT */ - TtkRedisplayWidget(&tv->core); + /* The limit not to exceed at the right is given by the tree width + minus the sum of the min widths of the columns at the right of + the one being resized (and don't forget possible x scrolling!). + For stretchable columns, this min width really is the minWidth, + for non-stretchable columns, this is the column width. + */ + int newxRightLimit = tv->tree.treeArea.x - tv->tree.xscroll.first + + tv->tree.treeArea.width; + int j = i + 1; + while (j < tv->tree.nDisplayColumns) { + TreeColumn *cr = tv->tree.displayColumns[j]; + if (cr->stretch) { + newxRightLimit -= cr->minWidth; + } else { + newxRightLimit -= cr->width; + } + ++j; + } + if (newx <= newxRightLimit) { + DragColumn(tv, i, newx - right); + TtkRedisplayWidget(&tv->core); + } return TCL_OK; } left = right; @@ -2899,6 +2920,20 @@ static int TreeviewDragCommand( return TCL_ERROR; } +static int TreeviewDropCommand( + void *recordPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) +{ + Treeview *tv = recordPtr; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "drop"); + return TCL_ERROR; + } + ResizeColumns(tv, TreeWidth(tv)); + TtkRedisplayWidget(&tv->core); + return TCL_OK; +} + /*------------------------------------------------------------------------ * +++ Widget commands -- focus and selection */ @@ -3248,6 +3283,7 @@ static const Ttk_Ensemble TreeviewCommands[] = { { "delete", TreeviewDeleteCommand,0 }, { "detach", TreeviewDetachCommand,0 }, { "drag", TreeviewDragCommand,0 }, + { "drop", TreeviewDropCommand,0 }, { "exists", TreeviewExistsCommand,0 }, { "focus", TreeviewFocusCommand,0 }, { "heading", TreeviewHeadingCommand,0 }, diff --git a/library/demos/pendulum.tcl b/library/demos/pendulum.tcl index d344d8d..6422c67 100644 --- a/library/demos/pendulum.tcl +++ b/library/demos/pendulum.tcl @@ -126,16 +126,16 @@ bind $w.c <ButtonRelease-1> { } bind $w.c <Configure> { %W coords plate 0 25 %w 25 - set home [expr %w/2] - %W coords pivot [expr $home-5] 20 [expr $home+5] 30 + set home [expr {%w/2}] + %W coords pivot [expr {$home-5}] 20 [expr {$home+5}] 30 } bind $w.k <Configure> { - set psh [expr %h/2] - set psw [expr %w/2] - %W coords x_axis 2 $psh [expr %w-2] $psh - %W coords y_axis $psw [expr %h-2] $psw 2 - %W coords label_dtheta [expr $psw-4] 6 - %W coords label_theta [expr %w-6] [expr $psh+4] + set psh [expr {%h/2}] + set psw [expr {%w/2}] + %W coords x_axis 2 $psh [expr {%w-2}] $psh + %W coords y_axis $psw [expr {%h-2}] $psw 2 + %W coords label_dtheta [expr {$psw-4}] 6 + %W coords label_theta [expr {%w-6}] [expr {$psh+4}] } # This procedure is the "business" part of the simulation that does diff --git a/library/demos/square b/library/demos/square index 1d7eb20..6ce91b8 100644 --- a/library/demos/square +++ b/library/demos/square @@ -27,7 +27,7 @@ focus .s proc center {x y} { set a [.s size] - .s position [expr $x-($a/2)] [expr $y-($a/2)] + .s position [expr {$x-($a/2)}] [expr {$y-($a/2)}] } # The procedures below provide a simple form of animation where diff --git a/library/ttk/treeview.tcl b/library/ttk/treeview.tcl index 6a6f5d4..0b5d953 100644 --- a/library/ttk/treeview.tcl +++ b/library/ttk/treeview.tcl @@ -205,7 +205,7 @@ proc ttk::treeview::resize.drag {w x} { } proc ttk::treeview::resize.release {w x} { - # no-op + $w drop } ### Heading activation. diff --git a/macosx/README b/macosx/README index ee87626..bed8d22 100644 --- a/macosx/README +++ b/macosx/README @@ -163,7 +163,7 @@ which can be used to get or set the tabbingIdentifier for the NSWindow associated with a Tk Window. See section 3 for details. - The command: - tk::unsupported::MacWindowStyle appearance window ?newAappearance? + tk::unsupported::MacWindowStyle appearance window ?newAppearance? is available when Tk is built and run on macOS 10.14 (Mojave) or later. In that case the Ttk widgets all support the "Dark Mode" appearance which was introduced in 10.14. The command accepts the following values for the optional diff --git a/macosx/tkMacOSXDraw.c b/macosx/tkMacOSXDraw.c index 11dca9a..1793b64 100644 --- a/macosx/tkMacOSXDraw.c +++ b/macosx/tkMacOSXDraw.c @@ -2,7 +2,7 @@ * tkMacOSXDraw.c -- * * This file contains functions that perform drawing to Xlib windows. Most - * of the functions simple emulate Xlib functions. + * of the functions simply emulate Xlib functions. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright 2001-2009, Apple Inc. diff --git a/macosx/tkMacOSXEmbed.c b/macosx/tkMacOSXEmbed.c index 79a2094..6c4ac1f 100644 --- a/macosx/tkMacOSXEmbed.c +++ b/macosx/tkMacOSXEmbed.c @@ -848,7 +848,9 @@ ContainerEventProc( eventPtr->xmaprequest.window); } else if (eventPtr->type == DestroyNotify) { /* - * The embedded application is gone. Destroy the container window. + * It is not clear whether the container should be destroyed + * when an embedded window is destroyed. See ticket [67384bce7d]. + * Here we are following unix, by destroying the container. */ Tk_DestroyWindow((Tk_Window) winPtr); diff --git a/macosx/tkMacOSXInt.h b/macosx/tkMacOSXInt.h index 22d7d2c..9cb75d2 100644 --- a/macosx/tkMacOSXInt.h +++ b/macosx/tkMacOSXInt.h @@ -202,7 +202,7 @@ MODULE_SCOPE void TkpReleaseRegion(TkRegion r); MODULE_SCOPE void TkpShiftButton(NSButton *button, NSPoint delta); MODULE_SCOPE Bool TkpAppIsDrawing(void); MODULE_SCOPE void TkpDisplayWindow(Tk_Window tkwin); -MODULE_SCOPE Bool TkTestAppIsDrawing(void); +MODULE_SCOPE Bool TkTestLogDisplay(void); MODULE_SCOPE Bool TkMacOSXInDarkMode(Tk_Window tkwin); /* diff --git a/macosx/tkMacOSXLaunch.c b/macosx/tkMacOSXLaunch.c deleted file mode 100644 index b5dafda..0000000 --- a/macosx/tkMacOSXLaunch.c +++ /dev/null @@ -1,210 +0,0 @@ -/* - * tkMacOSXLaunch.c -- - * Launches URL's using native API's on OS X without shelling out to "/usr/bin/open". Also gets and sets default app handlers. - * Copyright (c) 2015-2019 Kevin Walzer/WordTech Communications LLC. - * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - */ - -#include <tcl.h> -#include <tk.h> -#undef panic -#include <CoreFoundation/CoreFoundation.h> -#include <CoreServices/CoreServices.h> -#include <Carbon/Carbon.h> -#include <ApplicationServices/ApplicationServices.h> -#define panic Tcl_Panic - -/*Forward declarations of functions.*/ -int TkMacOSXLaunchURL(ClientData cd, Tcl_Interp *ip, int objc, Tcl_Obj *CONST objv[]); -int TkMacOSXLaunchFile(ClientData cd, Tcl_Interp *ip, int objc, Tcl_Obj *CONST objv[]); -int TkMacOSXGetAppPath(ClientData cd, Tcl_Interp *ip, int objc, Tcl_Obj *CONST objv[]); -int TkMacOSXGetDefaultApp(ClientData cd, Tcl_Interp *ip, int objc, Tcl_Obj *CONST objv[]); -int TkMacOSXSetDefaultApp(ClientData cd, Tcl_Interp *ip, int objc, Tcl_Obj *CONST objv[]); - - -/*Tcl function to launch URL with default app.*/ -int TkMacOSXLaunchURL(ClientData cd, Tcl_Interp *ip, int objc, Tcl_Obj *CONST objv[]) { - - if(objc != 2) { - Tcl_WrongNumArgs(ip, 1, objv, "url"); - return TCL_ERROR; - } - - - /* Get url string, convert to CFURL. */ - CFStringRef url = CFStringCreateWithCString(NULL, Tcl_GetString(objv[1]), - kCFStringEncodingUTF8); - CFURLRef launchurl = CFURLCreateWithString(kCFAllocatorDefault, url, NULL); - CFRelease(url); - - /* Fire url in default app. */ - LSOpenCFURLRef(launchurl, NULL); - - CFRelease(launchurl); - - return TCL_OK; - -} - -/*Tcl function to launch file with default app.*/ -int TkMacOSXLaunchFile(ClientData cd, Tcl_Interp *ip, int objc, Tcl_Obj *CONST objv[]) { - - if(objc != 2) { - Tcl_WrongNumArgs(ip, 1, objv, "file"); - return TCL_ERROR; - } - - /* Get url string, convert to CFURL. */ - CFStringRef url = CFStringCreateWithCString(NULL, Tcl_GetString(objv[1]), - kCFStringEncodingUTF8); - CFRelease(url); - - CFURLRef launchurl = CFURLCreateWithFileSystemPath(kCFAllocatorDefault, url, kCFURLPOSIXPathStyle, false); - - /* Fire url in default app. */ - LSOpenCFURLRef(launchurl, NULL); - CFRelease(launchurl); - - return TCL_OK; - -} - - -/*Tcl function to get path to app bundle.*/ -int TkMacOSXGetAppPath(ClientData cd, Tcl_Interp *ip, int objc, Tcl_Obj *CONST objv[]) { - - CFURLRef mainBundleURL = CFBundleCopyBundleURL(CFBundleGetMainBundle()); - - - /* Convert the URL reference into a string reference. */ - CFStringRef appPath = CFURLCopyFileSystemPath(mainBundleURL, kCFURLPOSIXPathStyle); - - /* Get the system encoding method. */ - CFStringEncoding encodingMethod = CFStringGetSystemEncoding(); - - /* Convert the string reference into a C string. */ - char *path = CFStringGetCStringPtr(appPath, encodingMethod); - - Tcl_SetResult(ip, path, NULL); - - CFRelease(mainBundleURL); - CFRelease(appPath); - return TCL_OK; - -} - -/*Tcl function to get default app for URL.*/ -int TkMacOSXGetDefaultApp(ClientData cd, Tcl_Interp *ip, int objc, Tcl_Obj *CONST objv[]) { - - if(objc != 2) { - Tcl_WrongNumArgs(ip, 1, objv, "url"); - return TCL_ERROR; - } - - /* Get url string, convert to CFStringRef. */ - CFStringRef url = CFStringCreateWithCString(NULL, Tcl_GetString(objv[1]), - kCFStringEncodingUTF8); - - /*Ensure arg is well-formed.*/ - NSString *testString = (NSString*) url; - if ([testString rangeOfString:@"://"].location == NSNotFound) { - NSLog(@"Error: please provide well-formed URL in url:// format."); - return TCL_OK; - } - - /*Get default app for URL.*/ - CFURLRef defaultApp = CFURLCreateWithString(kCFAllocatorDefault, url, NULL); - CFStringRef appURL = LSCopyDefaultApplicationURLForURL(defaultApp, kLSRolesAll, nil); - - /* Convert the URL reference into a string reference. */ - CFStringRef appPath = CFURLCopyFileSystemPath(appURL, kCFURLPOSIXPathStyle); - - - /* Get the system encoding method. */ - CFStringEncoding encodingMethod = CFStringGetSystemEncoding(); - - /* Convert the string reference into a C string. */ - char *path = CFStringGetCStringPtr(appPath, encodingMethod); - - Tcl_SetResult(ip, path, NULL); - - CFRelease(defaultApp); - CFRelease(appPath); - CFRelease(appURL); - CFRelease(url); - - return TCL_OK; - -} - -/*Tcl function to set default app for URL.*/ -int TkMacOSXSetDefaultApp(ClientData cd, Tcl_Interp *ip, int objc, Tcl_Obj *CONST objv[]) { - - if(objc != 3) { - Tcl_WrongNumArgs(ip, 1, objv, "url path"); - return TCL_ERROR; - } - - /* Get url and path strings, convert to CFStringRef. */ - CFStringRef url = CFStringCreateWithCString(NULL, Tcl_GetString(objv[1]), - kCFStringEncodingUTF8); - - - /*Ensure arg is well-formed.*/ - NSString *testString = (NSString*) url; - if ([testString rangeOfString:@"://"].location == NSNotFound) { - NSLog(@"Error: please provide well-formed URL in url:// format."); - return TCL_OK; - } - - /*Strip colon and slashes because the API to set default handlers does not use them.*/ - NSString *setURL = [(NSString*)url stringByReplacingOccurrencesOfString:@"://" withString:@""]; - - CFURLRef appURL = NULL; - CFBundleRef bundle = NULL; - - CFStringRef apppath = CFStringCreateWithCString(NULL, Tcl_GetString(objv[2]), kCFStringEncodingUTF8); - - /* Convert filepath to URL, create bundle object, get bundle ID. */ - appURL = CFURLCreateWithFileSystemPath(kCFAllocatorDefault, apppath, kCFURLPOSIXPathStyle, false); - bundle = CFBundleCreate(NULL, appURL); - - CFStringRef bundleID = CFBundleGetIdentifier(bundle); - - /* Finally, set default app. */ - OSStatus err; - err= LSSetDefaultHandlerForURLScheme((CFStringRef *)setURL, bundleID); - - /* Free memory. */ - CFRelease(url); - CFRelease(apppath); - CFRelease(bundleID); - - return TCL_OK; - -} - - -/*Initalize the package in the tcl interpreter, create Tcl commands. */ -int TkMacOSXLaunch_Init (Tcl_Interp *interp) { - - - Tcl_CreateObjCommand(interp, "::tk::mac::LaunchURL", TkMacOSXLaunchURL,(ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); - Tcl_CreateObjCommand(interp, "::tk::mac::LaunchFile", TkMacOSXLaunchFile,(ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); - Tcl_CreateObjCommand(interp, "::tk::mac::GetAppPath", TkMacOSXGetAppPath,(ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); - Tcl_CreateObjCommand(interp, "::tk::mac::GetDefaultApp",TkMacOSXGetDefaultApp,(ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); - Tcl_CreateObjCommand(interp, "::tk::mac::SetDefaultApp",TkMacOSXSetDefaultApp,(ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); - - - return TCL_OK; - -} - - - - - - diff --git a/macosx/tkMacOSXLaunchServices.c b/macosx/tkMacOSXLaunchServices.c deleted file mode 100644 index 6fc6758..0000000 --- a/macosx/tkMacOSXLaunchServices.c +++ /dev/null @@ -1,193 +0,0 @@ -/*
- * tkMacOSXLaunchServices.c --
- * Launches URL's using native API's on OS X without shelling out to "/usr/bin/open". Also gets and sets default app handlers.
- * Copyright (c) 2015-2019 Kevin Walzer/WordTech Communications LLC.
- *
- * See the file "license.terms" for information on usage and redistribution of
- * this file, and for a DISCLAIMER OF ALL WARRANTIES.
- *
- */
-
-#include <tcl.h>
-#include <tk.h>
-#undef panic
-#include <CoreFoundation/CoreFoundation.h>
-#include <CoreServices/CoreServices.h>
-#include <Carbon/Carbon.h>
-#include <ApplicationServices/ApplicationServices.h>
-#define panic Tcl_Panic
-
-
-/*Tcl function to launch URL with default app.*/
-int LaunchURL(ClientData cd, Tcl_Interp *ip, int objc, Tcl_Obj *CONST objv[]) {
-
- if(objc != 2) {
- Tcl_WrongNumArgs(ip, 1, objv, "url");
- return TCL_ERROR;
- }
-
-
- /* Get url string, convert to CFURL. */
- CFStringRef url = CFStringCreateWithCString(NULL, Tcl_GetString(objv[1]),
- kCFStringEncodingUTF8);
- CFURLRef launchurl = CFURLCreateWithString(kCFAllocatorDefault, url, NULL);
- CFRelease(url);
-
- /* Fire url in default app. */
- LSOpenCFURLRef(launchurl, NULL);
-
- CFRelease(launchurl);
-
- return TCL_OK;
-
-}
-
-/*Tcl function to launch file with default app.*/
-int LaunchFile(ClientData cd, Tcl_Interp *ip, int objc, Tcl_Obj *CONST objv[]) {
-
- if(objc != 2) {
- Tcl_WrongNumArgs(ip, 1, objv, "file");
- return TCL_ERROR;
- }
-
- /* Get url string, convert to CFURL. */
- CFStringRef url = CFStringCreateWithCString(NULL, Tcl_GetString(objv[1]),
- kCFStringEncodingUTF8);
- CFRelease(url);
-
- CFURLRef launchurl = CFURLCreateWithFileSystemPath(kCFAllocatorDefault, url, kCFURLPOSIXPathStyle, false);
-
- /* Fire url in default app. */
- LSOpenCFURLRef(launchurl, NULL);
- CFRelease(launchurl);
-
- return TCL_OK;
-
-}
-
-
-/*Tcl function to get path to app bundle.*/
-int GetAppPath(ClientData cd, Tcl_Interp *ip, int objc, Tcl_Obj *CONST objv[]) {
-
- CFURLRef mainBundleURL = CFBundleCopyBundleURL(CFBundleGetMainBundle());
-
-
- /* Convert the URL reference into a string reference. */
- CFStringRef appPath = CFURLCopyFileSystemPath(mainBundleURL, kCFURLPOSIXPathStyle);
-
- /* Get the system encoding method. */
- CFStringEncoding encodingMethod = CFStringGetSystemEncoding();
-
- /* Convert the string reference into a C string. */
- char *path = CFStringGetCStringPtr(appPath, encodingMethod);
-
- Tcl_SetResult(ip, path, NULL);
-
- CFRelease(mainBundleURL);
- CFRelease(appPath);
- return TCL_OK;
-
-}
-
-/*Tcl function to launch file with default app.*/
-int GetDefaultApp(ClientData cd, Tcl_Interp *ip, int objc, Tcl_Obj *CONST objv[]) {
-
- if(objc != 2) {
- Tcl_WrongNumArgs(ip, 1, objv, "url");
- return TCL_ERROR;
- }
-
- /* Get url string, convert to CFStringRef. */
- CFStringRef url = CFStringCreateWithCString(NULL, Tcl_GetString(objv[1]),
- kCFStringEncodingUTF8);
-
- CFStringRef defaultApp;
- defaultApp = LSCopyDefaultHandlerForURLScheme(url);
-
- OSStatus result;
- CFURLRef appURL = NULL;
- result = LSFindApplicationForInfo(kLSUnknownCreator, defaultApp, NULL, NULL, &appURL);
-
- /* Convert the URL reference into a string reference. */
- CFStringRef appPath = CFURLCopyFileSystemPath(appURL, kCFURLPOSIXPathStyle);
-
- /* Get the system encoding method. */
- CFStringEncoding encodingMethod = CFStringGetSystemEncoding();
-
- /* Convert the string reference into a C string. */
- char *path = CFStringGetCStringPtr(appPath, encodingMethod);
-
- Tcl_SetResult(ip, path, NULL);
-
- CFRelease(defaultApp);
- CFRelease(appPath);
- CFRelease(url);
-
- return TCL_OK;
-
-}
-
-/*Tcl function to set default app for URL.*/
-int SetDefaultApp(ClientData cd, Tcl_Interp *ip, int objc, Tcl_Obj *CONST objv[]) {
-
- if(objc != 3) {
- Tcl_WrongNumArgs(ip, 1, objv, "url path");
- return TCL_ERROR;
- }
-
- /* Get url and path strings, convert to CFStringRef. */
- CFStringRef url = CFStringCreateWithCString(NULL, Tcl_GetString(objv[1]),
- kCFStringEncodingUTF8);
- CFURLRef appURL = NULL;
- CFBundleRef bundle = NULL;
-
- CFStringRef apppath = CFStringCreateWithCString(NULL, Tcl_GetString(objv[2]), kCFStringEncodingUTF8);
-
- /* Convert filepath to URL, create bundle object, get bundle ID. */
- appURL = CFURLCreateWithFileSystemPath(kCFAllocatorDefault, apppath, kCFURLPOSIXPathStyle, false);
- bundle = CFBundleCreate(NULL, appURL);
-
- CFStringRef bundleID = CFBundleGetIdentifier(bundle);
-
- /* Finally, set default app. */
- OSStatus err;
- err= LSSetDefaultHandlerForURLScheme(url, bundleID);
-
- /* Free memory. */
- CFRelease(url);
- CFRelease(apppath);
- CFRelease(bundleID);
-
- return TCL_OK;
-
-}
-
-
-/*Initalize the package in the tcl interpreter, create Tcl commands. */
-int TkMacOSXLauncher_Init (Tcl_Interp *interp) {
-
-
- if (Tcl_InitStubs(interp, "8.5", 0) == NULL) {
- return TCL_ERROR;
- }
- if (Tk_InitStubs(interp, "8.5", 0) == NULL) {
- return TCL_ERROR;
- }
-
-
- Tcl_CreateObjCommand(interp, "::tk::mac::LaunchURL", LaunchURL,(ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
- Tcl_CreateObjCommand(interp, "::tk::mac::LaunchFile", LaunchFile,(ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
- Tcl_CreateObjCommand(interp, "::tk::mac::GetAppPath", GetAppPath,(ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
- Tcl_CreateObjCommand(interp, "::tk::mac::GetDefaultApp", GetDefaultApp,(ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
- Tcl_CreateObjCommand(interp, "::tk::mac::SetDefaultApp",SetDefaultApp,(ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
-
-
- return TCL_OK;
-
-}
-
-
-
-
-
-
diff --git a/macosx/tkMacOSXMouseEvent.c b/macosx/tkMacOSXMouseEvent.c index adc24b1..0cf7cd6 100644 --- a/macosx/tkMacOSXMouseEvent.c +++ b/macosx/tkMacOSXMouseEvent.c @@ -53,6 +53,7 @@ enum { NSEventType eventType = [theEvent type]; TkWindow *winPtr, *grabWinPtr; Tk_Window tkwin; + NSPoint local, global; #if 0 NSTrackingArea *trackingArea = nil; NSInteger eventNumber, clickCount, buttonNumber; @@ -84,61 +85,54 @@ enum { } /* - * Remember the window in case we need it next time. - */ - - if (eventWindow && eventWindow != _windowWithMouse) { - if (_windowWithMouse) { - [_windowWithMouse release]; - } - _windowWithMouse = eventWindow; - [_windowWithMouse retain]; - } - - /* * Compute the mouse position in Tk screen coordinates (global) and in the - * Tk coordinates of its containing Tk Window. + * Tk coordinates of its containing Tk Window (local). If a grab is in effect, + * the local coordinates should be relative to the grab window. */ - NSPoint global, local = [theEvent locationInWindow]; - - /* - * If the event has no NSWindow, try using the cached NSWindow from the - * last mouse event. - */ - - if (eventWindow == NULL) { - eventWindow = _windowWithMouse; - } if (eventWindow) { - /* - * Set the local mouse position to its NSWindow flipped coordinates, - * with the origin at top left, and the global mouse position to the - * flipped screen coordinates. - */ - + local = [theEvent locationInWindow]; global = [eventWindow tkConvertPointToScreen: local]; + tkwin = TkMacOSXGetCapture(); + if (tkwin) { + winPtr = (TkWindow *) tkwin; + eventWindow = TkMacOSXDrawableWindow(winPtr->window); + if (eventWindow) { + local = [eventWindow tkConvertPointFromScreen: global]; + } else { + return theEvent; + } + } local.y = [eventWindow frame].size.height - local.y; global.y = tkMacOSXZeroScreenHeight - global.y; } else { + /* - * As a last resort, with no NSWindow to work with, set both local and - * global to the screen coordinates. + * If the event has no NSWindow, the location is in screen coordinates. */ - local.y = tkMacOSXZeroScreenHeight - local.y; - global = local; + global = [theEvent locationInWindow]; + tkwin = TkMacOSXGetCapture(); + if (tkwin) { + winPtr = (TkWindow *) tkwin; + eventWindow = TkMacOSXDrawableWindow(winPtr->window); + } else { + eventWindow = [NSApp mainWindow]; + } + if (!eventWindow) { + return theEvent; + } + local = [eventWindow tkConvertPointFromScreen: global]; + local.y = [eventWindow frame].size.height - local.y; + global.y = tkMacOSXZeroScreenHeight - global.y; } /* - * Find the toplevel which corresponds to the event NSWindow. + * Make sure tkwin is the toplevel which should receive the event. */ - winPtr = TkMacOSXGetTkWindow(eventWindow); - if (winPtr == NULL) { - tkwin = TkMacOSXGetCapture(); - winPtr = (TkWindow *) tkwin; - } else { + if (!tkwin) { + winPtr = TkMacOSXGetTkWindow(eventWindow); tkwin = (Tk_Window) winPtr; } if (!tkwin) { diff --git a/macosx/tkMacOSXPrivate.h b/macosx/tkMacOSXPrivate.h index 1ee32e2..a67f894 100644 --- a/macosx/tkMacOSXPrivate.h +++ b/macosx/tkMacOSXPrivate.h @@ -267,7 +267,6 @@ VISIBILITY_HIDDEN TKMenu *_defaultMainMenu, *_defaultApplicationMenu; NSArray *_defaultApplicationMenuItems, *_defaultWindowsMenuItems; NSArray *_defaultHelpMenuItems; - NSWindow *_windowWithMouse; NSAutoreleasePool *_mainPool; #ifdef __i386__ /* The Objective C runtime used on i386 requires this. */ diff --git a/macosx/tkMacOSXServices.c b/macosx/tkMacOSXServices.c index 3a31e6c..af40a91 100644 --- a/macosx/tkMacOSXServices.c +++ b/macosx/tkMacOSXServices.c @@ -20,14 +20,15 @@ static Tcl_Interp *ServicesInterp; * Event proc which calls the PerformService procedure */ -int ServicesEventProc( +static int +ServicesEventProc( Tcl_Event *event, int flags) { Tcl_GlobalEval(ServicesInterp, "::tk::mac::PerformService"); return 1; } - + /* * Class declarations for TkService class. */ @@ -42,7 +43,7 @@ int ServicesEventProc( - (BOOL)writeSelectionToPasteboard:(NSPasteboard *)pboard types:(NSArray *)types; @end - + /* * Class methods. */ @@ -90,6 +91,7 @@ int ServicesEventProc( { NSArray *typesDeclared = nil; NSString *pboardType = nil; + for (NSString *typeString in types) { if ([typeString isEqualToString:@"NSStringPboardType"] || [typeString isEqualToString:@"NSPasteboardTypeString"]) { @@ -101,16 +103,15 @@ int ServicesEventProc( if (!typesDeclared) { return NO; } - Tcl_Eval(ServicesInterp,"selection get"); - char *copystring; - copystring = Tcl_GetString(Tcl_GetObjResult(ServicesInterp)); + Tcl_Eval(ServicesInterp, "selection get"); + char *copystring = Tcl_GetString(Tcl_GetObjResult(ServicesInterp)); NSString *writestring = [NSString stringWithUTF8String:copystring]; + [pboard declareTypes:typesDeclared owner:nil]; return [pboard setString:writestring forType:pboardType]; } - /* * This is the method that actually calls the Tk service; this is the method * that must be defined in info.plist. @@ -148,24 +149,23 @@ int ServicesEventProc( } } @end - - + /* * Register a specific widget to access the Services menu. */ -int TkMacOSXRegisterServiceWidgetObjCmd ( - ClientData cd, - Tcl_Interp *ip, - int objc, - Tcl_Obj *CONST objv[]) +int +TkMacOSXRegisterServiceWidgetObjCmd( + ClientData cd, + Tcl_Interp *ip, + int objc, + Tcl_Obj *CONST objv[]) { - /* * Need proper number of args. */ - if(objc != 2) { + if (objc != 2) { Tcl_WrongNumArgs(ip, 1, objv, "path?"); return TCL_ERROR; } @@ -176,8 +176,8 @@ int TkMacOSXRegisterServiceWidgetObjCmd ( Rect bounds; NSRect frame; - Tk_Window path = Tk_NameToWindow(ip, Tcl_GetString(objv[1]), - Tk_MainWindow(ip)); + Tk_Window path = + Tk_NameToWindow(ip, Tcl_GetString(objv[1]), Tk_MainWindow(ip)); if (path == NULL) { return TCL_ERROR; @@ -193,6 +193,7 @@ int TkMacOSXRegisterServiceWidgetObjCmd ( TkService *serviceview = [[TkService alloc] init]; NSView *view = TkMacOSXGetRootControl(d); + if ([serviceview superview] != view) { [view addSubview:serviceview]; } @@ -215,15 +216,16 @@ int TkMacOSXRegisterServiceWidgetObjCmd ( * Initalize the package in the Tcl interpreter, create Tcl commands. */ -int TkMacOSXServices_Init( +int +TkMacOSXServices_Init( Tcl_Interp *interp) { - /* * Initialize instance of TclServices to provide service functionality. */ TkService *service = [[TkService alloc] init]; + ServicesInterp = interp; [NSApp setServicesProvider:service]; return TCL_OK; diff --git a/macosx/tkMacOSXSubwindows.c b/macosx/tkMacOSXSubwindows.c index 2579892..b660917 100644 --- a/macosx/tkMacOSXSubwindows.c +++ b/macosx/tkMacOSXSubwindows.c @@ -72,12 +72,15 @@ XDestroyWindow( } if (macWin->visRgn) { CFRelease(macWin->visRgn); + macWin->visRgn = NULL; } if (macWin->aboveVisRgn) { CFRelease(macWin->aboveVisRgn); + macWin->aboveVisRgn = NULL; } if (macWin->drawRgn) { CFRelease(macWin->drawRgn); + macWin->drawRgn = NULL; } if (macWin->toplevel->referenceCount == 0) { @@ -88,12 +91,15 @@ XDestroyWindow( } if (macWin->visRgn) { CFRelease(macWin->visRgn); + macWin->visRgn = NULL; } if (macWin->aboveVisRgn) { CFRelease(macWin->aboveVisRgn); + macWin->aboveVisRgn = NULL; } if (macWin->drawRgn) { CFRelease(macWin->drawRgn); + macWin->drawRgn = NULL; } macWin->view = nil; @@ -203,11 +209,12 @@ XMapWindow( */ TkMacOSXInvalClipRgns((Tk_Window) winPtr->parentPtr); - if ([NSApp isDrawing]) { - [[win contentView] setNeedsRedisplay:YES]; - } else { - [[win contentView] setNeedsDisplay:YES]; - } + } + + if ([NSApp isDrawing]) { + [[win contentView] setNeedsRedisplay:YES]; + } else { + [[win contentView] setNeedsDisplay:YES]; } /* @@ -280,14 +287,13 @@ XUnmapWindow( MacDrawable *macWin = (MacDrawable *) window; TkWindow *winPtr = macWin->winPtr; TkWindow *parentPtr = winPtr->parentPtr; + NSWindow *win = TkMacOSXDrawableWindow(window); XEvent event; display->request++; if (Tk_IsTopLevel(winPtr)) { if (!Tk_IsEmbedded(winPtr) && winPtr->wmInfoPtr->hints.initial_state!=IconicState) { - NSWindow *win = TkMacOSXDrawableWindow(window); - [win orderOut:nil]; } TkMacOSXInvalClipRgns((Tk_Window) winPtr); @@ -308,7 +314,8 @@ XUnmapWindow( } else { /* * Rebuild the visRgn clip region for the parent so it will be allowed - * to draw in the space from which this subwindow was removed. + * to draw in the space from which this subwindow was removed and then + * redraw the window. */ if (parentPtr && parentPtr->privatePtr->visRgn) { @@ -320,6 +327,11 @@ XUnmapWindow( TkMacOSXUpdateClipRgn(parentPtr); } winPtr->flags &= ~TK_MAPPED; + if ([NSApp isDrawing]) { + [[win contentView] setNeedsRedisplay:YES]; + } else { + [[win contentView] setNeedsDisplay:YES]; + } } /* diff --git a/macosx/tkMacOSXTest.c b/macosx/tkMacOSXTest.c index 9192fd6..eabc14e 100644 --- a/macosx/tkMacOSXTest.c +++ b/macosx/tkMacOSXTest.c @@ -90,18 +90,21 @@ DebuggerObjCmd( /* *---------------------------------------------------------------------- * - * TkTestAppIsDrawing -- - * - * A test widget display procedure which records calls can use this to - * detect whether it is being called from within [NSView drawRect]. - * If so, it probably should not be recording the call since it was - * probably generated spontaneously by the window manager rather than - * by an explicit call to update. This is just a wrapper for the NSApp - * property. + * TkTestLogDisplay -- * + * The test image display procedure calls this to determine whether it + * should write a log message recording that it has being run. On OSX + * 10.14 and later, only calls to the display procedure which occur inside + * of the drawRect method should be logged, since those are the only ones + * which actually draw anything. On earlier systems the opposite is true. + * The calls from within the drawRect method are redundant, since the + * first time the display procedure is run it will do the drawing and that + * first call will usually not occur inside of drawRect. * * Results: - * Returns true if and only if called from within [NSView drawRect]. + * On OSX 10.14 and later, returns true if and only if called from + * within [NSView drawRect]. On earlier systems returns false if + * and only if called from with [NSView drawRect]. * * Side effects: * None @@ -109,8 +112,12 @@ DebuggerObjCmd( *---------------------------------------------------------------------- */ MODULE_SCOPE Bool -TkTestAppIsDrawing(void) { - return [NSApp isDrawing]; +TkTestLogDisplay(void) { + if ([NSApp macMinorVersion] >= 14) { + return [NSApp isDrawing]; + } else { + return ![NSApp isDrawing]; + } } diff --git a/macosx/tkMacOSXWindowEvent.c b/macosx/tkMacOSXWindowEvent.c index 3eda4ec..3703340 100644 --- a/macosx/tkMacOSXWindowEvent.c +++ b/macosx/tkMacOSXWindowEvent.c @@ -198,10 +198,6 @@ extern NSString *NSWindowDidOrderOffScreenNotification; if (winPtr) { TkGenWMDestroyEvent((Tk_Window) winPtr); - if (_windowWithMouse == w) { - _windowWithMouse = nil; - [w release]; - } } /* diff --git a/macosx/tkMacOSXWm.c b/macosx/tkMacOSXWm.c index e69f9ee..e7bcbdf 100644 --- a/macosx/tkMacOSXWm.c +++ b/macosx/tkMacOSXWm.c @@ -340,18 +340,12 @@ static void RemoveTransient(TkWindow *winPtr); #else - (NSPoint) tkConvertPointToScreen: (NSPoint) point { - NSRect pointrect; - pointrect.origin = point; - pointrect.size.width = 0; - pointrect.size.height = 0; + NSRect pointrect = {point, {0,0}}; return [self convertRectToScreen:pointrect].origin; } - (NSPoint) tkConvertPointFromScreen: (NSPoint)point { - NSRect pointrect; - pointrect.origin = point; - pointrect.size.width = 0; - pointrect.size.height = 0; + NSRect pointrect = {point, {0,0}}; return [self convertRectFromScreen:pointrect].origin; } #endif @@ -2787,8 +2781,6 @@ WmManageCmd( Tk_MakeWindowExist((Tk_Window) winPtr); macWin = (MacDrawable *) winPtr->window; } - TkWmMapWindow(winPtr); - Tk_UnmapWindow(frameWin); } wmPtr = winPtr->wmInfoPtr; winPtr->flags &= ~TK_MAPPED; @@ -2799,6 +2791,7 @@ WmManageCmd( winPtr->flags |= (TK_TOP_HIERARCHY|TK_TOP_LEVEL|TK_HAS_WRAPPER|TK_WIN_MANAGED); TkMapTopFrame(frameWin); + TkWmMapWindow(winPtr); } else if (Tk_IsTopLevel(frameWin)) { /* Already managed by wm - ignore it */ } diff --git a/macosx/ttkMacOSXTheme.c b/macosx/ttkMacOSXTheme.c index a1d13de..c33e8c9 100644 --- a/macosx/ttkMacOSXTheme.c +++ b/macosx/ttkMacOSXTheme.c @@ -75,6 +75,15 @@ static CGFloat darkDisabledButtonFace[4] = { static CGFloat darkInactiveSelectedTab[4] = { 159.0 / 255, 160.0 / 255, 161.0 / 255, 1.0 }; +static CGFloat darkFocusRing[4] = { + 38.0 / 255, 113.0 / 255, 159.0 / 255, 1.0 +}; +static CGFloat darkFocusRingTop[4] = { + 50.0 / 255, 124.0 / 255, 171.0 / 255, 1.0 +}; +static CGFloat darkFocusRingBottom[4] = { + 57.0 / 255, 130.0 / 255, 176.0 / 255, 1.0 +}; static CGFloat darkTabSeparator[4] = {0.0, 0.0, 0.0, 0.25}; static CGFloat darkTrack[4] = {1.0, 1.0, 1.0, 0.25}; static CGFloat darkFrameTop[4] = {1.0, 1.0, 1.0, 0.0625}; @@ -1012,6 +1021,54 @@ static void DrawDarkSeparator( } /*---------------------------------------------------------------------- + * +++ DrawDarkFocusRing -- + * + * This is a standalone drawing procedure which draws a focus ring around + * an Entry widget in Dark Mode. + */ + +static void DrawDarkFocusRing( + CGRect bounds, + CGContextRef context) +{ + NSColorSpace *deviceRGB = [NSColorSpace deviceRGBColorSpace]; + NSColor *strokeColor; + NSColor *fillColor = [NSColor colorWithColorSpace:deviceRGB + components:darkFocusRing + count:4]; + CGFloat x = bounds.origin.x, y = bounds.origin.y; + CGFloat w = bounds.size.width, h = bounds.size.height; + CGPoint topPart[4] = { + {x, y + h}, {x, y + 1}, {x + w - 1, y + 1}, {x + w - 1, y + h} + }; + CGPoint bottom[2] = {{x, y + h}, {x + w, y + h}}; + CGRect outerRect = CGRectInset(bounds, -3, -3); + + CGContextSaveGState(context); + CGContextSetShouldAntialias(context, false); + CGContextBeginPath(context); + strokeColor = [NSColor colorWithColorSpace: deviceRGB + components: darkFocusRingTop + count: 4]; + CGContextSetStrokeColorWithColor(context, CGCOLOR(strokeColor)); + CGContextAddLines(context, topPart, 4); + CGContextStrokePath(context); + strokeColor = [NSColor colorWithColorSpace: deviceRGB + components: darkFocusRingBottom + count: 4]; + CGContextSetStrokeColorWithColor(context, CGCOLOR(strokeColor)); + CGContextAddLines(context, bottom, 2); + CGContextStrokePath(context); + CGContextSetShouldAntialias(context, true); + CGContextSetFillColorWithColor(context, CGCOLOR(fillColor)); + CGPathRef path = CGPathCreateWithRoundedRect(outerRect, 4, 4, NULL); + CGContextBeginPath(context); + CGContextAddPath(context, path); + CGContextAddRect(context, bounds); + CGContextEOFillPath(context); + CGContextRestoreGState(context); +} +/*---------------------------------------------------------------------- * +++ DrawDarkFrame -- * * This is a standalone drawing procedure which draws various @@ -1030,7 +1087,7 @@ static void DrawDarkFrame( CGFloat x = bounds.origin.x, y = bounds.origin.y; CGFloat w = bounds.size.width, h = bounds.size.height; CGPoint topPart[4] = { - {x, y + h - 1}, {x, y}, {x + w, y}, {x + w, y + h - 1} + {x, y + h - 1}, {x, y + 1}, {x + w, y + 1}, {x + w, y + h - 1} }; CGPoint bottom[2] = {{x, y + h}, {x + w, y + h}}; CGPoint accent[2] = {{x, y + 1}, {x + w, y + 1}}; @@ -1613,7 +1670,7 @@ static void EntryElementSize( int *minHeight, Ttk_Padding *paddingPtr) { - *paddingPtr = Ttk_UniformPadding(5); + *paddingPtr = Ttk_MakePadding(7, 5, 7, 6); } static void EntryElementDraw( @@ -1636,12 +1693,24 @@ static void EntryElementDraw( NSColorSpace *deviceRGB = [NSColorSpace deviceRGBColorSpace]; CGFloat fill[4]; GetBackgroundColor(dc.context, tkwin, 1, fill); + + /* + * Lighten the background to provide contrast. + */ + + for (int i = 0; i < 3; i++) { + fill[i] += 9.0 / 255.0; + } background = [NSColor colorWithColorSpace: deviceRGB components: fill count: 4]; CGContextSetFillColorWithColor(dc.context, CGCOLOR(background)); CGContextFillRect(dc.context, bounds); - DrawDarkFrame(bounds, dc.context, kHIThemeFrameTextFieldSquare); + if (state & TTK_STATE_FOCUS) { + DrawDarkFocusRing(bounds, dc.context); + } else { + DrawDarkFrame(bounds, dc.context, kHIThemeFrameTextFieldSquare); + } END_DRAWING } else { const HIThemeFrameDrawInfo info = { diff --git a/tests/arc.tcl b/tests/arc.tcl index d0a93ea..0126c7d 100644 --- a/tests/arc.tcl +++ b/tests/arc.tcl @@ -99,7 +99,7 @@ bind .t.c <Shift-1> { } bind .t.c <Shift-B1-Motion> { - .t.c move circle [expr %x-$curx] [expr %y-$cury] + .t.c move circle [expr {%x-$curx}] [expr {%y-$cury}] set curx %x set cury %y } @@ -127,7 +127,7 @@ bind .t.c a { } incr i $delta c -start $i - c -extent [expr 360-2*$i] + c -extent [expr {360-2*$i}] after 20 update } diff --git a/tests/button.test b/tests/button.test index b953197..e5cb1b9 100644 --- a/tests/button.test +++ b/tests/button.test @@ -3444,12 +3444,12 @@ test button-5.24 {ConfigureButton - computing geometry} -constraints { set expectedwidth [expr {$textwidth + 2*[.b cget -borderwidth] \ + 2*[.b cget -highlightthickness] + 2*[.b cget -padx]}] incr expectedwidth 2 ; # added (hardcoded) in tkUnixButton.c - set result [expr $expectedwidth == [winfo reqwidth .b]] + set result [expr {$expectedwidth == [winfo reqwidth .b]}] set linespace [lindex [font metrics [.b cget -font] -displayof .b] 5] set expectedheight [expr {$linespace + 2*[.b cget -borderwidth] \ + 2*[.b cget -highlightthickness] + 2*[.b cget -pady]}] incr expectedheight 2 ; # added (hardcoded) in tkUnixButton.c - lappend result [expr $expectedheight == [winfo reqheight .b]] + lappend result [expr {$expectedheight == [winfo reqheight .b]}] # 2. button with a bitmap image # there is no access to characteristics the predefined bitmaps, # so define one as an image (copied from questhead.xbm) @@ -3468,11 +3468,11 @@ test button-5.24 {ConfigureButton - computing geometry} -constraints { set expectedwidth [expr {[image width $myquesthead] + 2*[.b cget -borderwidth] \ + 2*[.b cget -highlightthickness]}] incr expectedwidth 2 ; # added (hardcoded) in tkUnixButton.c - lappend result [expr $expectedwidth == [winfo reqwidth .b]] + lappend result [expr {$expectedwidth == [winfo reqwidth .b]}] set expectedheight [expr {[image height $myquesthead] + 2*[.b cget -borderwidth] \ + 2*[.b cget -highlightthickness]}] incr expectedheight 2 ; # added (hardcoded) in tkUnixButton.c - lappend result [expr $expectedheight == [winfo reqheight .b]] + lappend result [expr {$expectedheight == [winfo reqheight .b]}] } -cleanup { destroy .b } -result {1 1 1 1} diff --git a/tests/canvImg.test b/tests/canvImg.test index ea413bb..36e937d 100644 --- a/tests/canvImg.test +++ b/tests/canvImg.test @@ -156,18 +156,25 @@ test canvImg-4.1 {ConfiugreImage procedure} -constraints testImageType -setup { .c delete all image delete foo } -result {{{foo free}} {}} -test canvImg-4.2 {ConfiugreImage procedure} -constraints testImageType -setup { +test canvImg-4.2 {ConfigureImage procedure} -constraints testImageType -setup { .c delete all } -body { - image create test foo -variable x + image create test foo -variable x image create test foo2 -variable y foo2 changed 0 0 0 0 80 60 .c create image 50 100 -image foo -tags i1 -anchor nw update set x {} set y {} + set timer [after 300 {lappend y "timeout"}] .c itemconfigure i1 -image foo2 + update idletasks update + # On MacOS we need to wait for the test image display procedure to run. + while {"timeout" ni $y && [lindex $y end 1] ne "display"} { + vwait y + } + after cancel timer list $x $y [.c bbox i1] } -cleanup { .c delete all @@ -720,6 +727,12 @@ test canvImg-9.1 {DisplayImage procedure} -constraints testImageType -setup { image delete foo } -result {75 150 105 165} +if {[tk windowingsystem] == "aqua" && $tcl_platform(osVersion) > 18} { + # Aqua >= 10.14 will redraw the entire image. + set result_10_1 {{foo display 0 0 30 15}} +} else { + set result_10_1 {{foo display 2 4 6 8}} +} test canvImg-10.1 {TranslateImage procedure} -constraints testImageType -setup { .c delete all update @@ -734,7 +747,7 @@ test canvImg-10.1 {TranslateImage procedure} -constraints testImageType -setup { } -cleanup { .c delete all image delete foo -} -result {{foo display 2 4 6 8}} +} -result $result_10_1 test canvImg-11.1 {TranslateImage procedure} -constraints testImageType -setup { .c delete all @@ -766,6 +779,12 @@ test canvImg-11.2 {ImageChangedProc procedure} -constraints { .c delete all image delete foo } -result {30 75 70 125} +if {[tk windowingsystem] == "aqua" && $tcl_platform(osVersion) > 18} { + # Aqua >= 10.14 will redraw the entire image. + set result_11_3 {{foo2 display 0 0 80 60}} +} else { + set result_11_3 {{foo2 display 0 0 20 40}} +} test canvImg-11.3 {ImageChangedProc procedure} -constraints { testImageType } -setup { @@ -773,7 +792,7 @@ test canvImg-11.3 {ImageChangedProc procedure} -constraints { update } -body { image create test foo -variable x - image create test foo2 -variable y + image create test foo2 -variable y foo changed 0 0 0 0 40 50 foo2 changed 0 0 0 0 80 60 @@ -787,7 +806,7 @@ test canvImg-11.3 {ImageChangedProc procedure} -constraints { } -cleanup { .c delete all image delete foo foo2 -} -result {{foo2 display 0 0 20 40}} +} -result $result_11_3 # cleanup imageFinish diff --git a/tests/canvText.test b/tests/canvText.test index c04cb63..b2af39b 100644 --- a/tests/canvText.test +++ b/tests/canvText.test @@ -269,7 +269,7 @@ test canvText-6.1 {ComputeTextBbox procedure} -constraints fonts -setup { .c create text 0 0 -tag test .c itemconfig test -font $font -text 0 expr {[.c itemconfig test -anchor n; .c bbox test] \ - eq "[expr -$ax/2-1] 0 [expr $ax/2+1] $ay"} + eq "[expr {-$ax/2-1}] 0 [expr {$ax/2+1}] $ay"} } -cleanup { .c delete test } -result 1 @@ -282,7 +282,7 @@ test canvText-6.2 {ComputeTextBbox procedure} -constraints fonts -setup { .c create text 0 0 -tag test .c itemconfig test -font $font -text 0 expr {[.c itemconfig test -anchor nw; .c bbox test] \ - eq "-1 0 [expr $ax+1] $ay"} + eq "-1 0 [expr {$ax+1}] $ay"} } -cleanup { .c delete test } -result 1 diff --git a/tests/canvas.test b/tests/canvas.test index 2b0da48..fe4c2b7 100644 --- a/tests/canvas.test +++ b/tests/canvas.test @@ -354,9 +354,9 @@ test canvas-9.1 {canvas id creation and deletion} -setup { for {set i 0} {$i < $size} {incr i} { set x [expr {-10 + 3*$i}] for {set j 0; set y -10} {$j < 10} {incr j; incr y 3} { - .c create rect ${x}c ${y}c [expr $x+2]c [expr $y+2]c \ + .c create rect ${x}c ${y}c [expr {$x+2}]c [expr {$y+2}]c \ -outline black -fill blue -tags rect - .c create text [expr $x+1]c [expr $y+1]c -text "$i,$j" \ + .c create text [expr {$x+1}]c [expr {$y+1}]c -text "$i,$j" \ -anchor center -tags text } } diff --git a/tests/clrpick.test b/tests/clrpick.test index 5f1b8b5..c15308b 100644 --- a/tests/clrpick.test +++ b/tests/clrpick.test @@ -78,7 +78,7 @@ test clrpick-1.7 {tk_chooseColor command} -body { # tests 3.1 and 3.2 fail when individually run # if there is no catch {tk_chooseColor -foo 1} msg # before settin isNative -catch {tk_chooseColor -foo 1} msg +catch {tk_chooseColor -foo 1} msg set isNative [expr {[info commands tk::dialog::color::] eq ""}] proc ToPressButton {parent btn} { diff --git a/tests/cmap.tcl b/tests/cmap.tcl index cca4c24..ea19131 100644 --- a/tests/cmap.tcl +++ b/tests/cmap.tcl @@ -19,7 +19,7 @@ proc colors {w redInc greenInc blueInc} { for {set x 0} {$x < 8} {incr x} { frame $w.f$x,$y -width 40 -height 40 -bd 2 -relief raised \ -bg [format #%02x%02x%02x $red $green $blue] - place $w.f$x,$y -x [expr 40*$x] -y [expr 40*$y] + place $w.f$x,$y -x [expr {40*$x}] -y [expr {40*$y}] incr red $redInc incr green $greenInc incr blue $blueInc diff --git a/tests/color.test b/tests/color.test index 6fefd90..4cdaf23 100644 --- a/tests/color.test +++ b/tests/color.test @@ -168,7 +168,7 @@ test color-1.5 {Color table} nonPortable { if {$rgb != [lrange $line 0 2] } { append result $line\n } - + } return $result } {} diff --git a/tests/font.test b/tests/font.test index f7fb325..8894d85 100644 --- a/tests/font.test +++ b/tests/font.test @@ -109,7 +109,7 @@ test font-4.1 {font command: actual: arguments} -body { font actual xyz -displayof } -returnCodes error -result {value for "-displayof" missing} test font-4.2 {font command: actual: arguments} -body { - # (objc < 3) + # (objc < 3) font actual } -returnCodes error -result {wrong # args: should be "font actual font ?-displayof window? ?option? ?--? ?char?"} test font-4.3 {font command: actual: arguments} -body { @@ -160,7 +160,7 @@ test font-4.15 {font command: actual} -body { test font-5.1 {font command: configure} -body { - # (objc < 3) + # (objc < 3) font configure } -returnCodes error -result {wrong # args: should be "font configure fontname ?-option value ...?"} test font-5.2 {font command: configure: non-existent font} -body { @@ -173,7 +173,7 @@ test font-5.3 {font command: configure: "deleted" font} -setup { pack [label .t.f] update } -body { - # (nfPtr->deletePending != 0) + # (nfPtr->deletePending != 0) font create xyz .t.f configure -font xyz font delete xyz @@ -263,13 +263,13 @@ test font-6.4 {font command: create: generate name} -setup { test font-6.5 {font command: create: bad option creating new font} -setup { catch {font delete xyz} } -body { - # name was specified so skip = 3 + # name was specified so skip = 3 font create xyz -xyz times } -returnCodes error -result {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike} test font-6.6 {font command: create: bad option creating new font} -setup { clearnondefaultfonts } -body { - # name was not specified so skip = 2 + # name was not specified so skip = 2 font create -xyz times } -returnCodes error -result {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike} test font-6.7 {font command: create: already exists} -setup { @@ -283,14 +283,14 @@ test font-6.7 {font command: create: already exists} -setup { } -returnCodes error -result {named font "xyz" already exists} test font-7.1 {font command: delete: arguments} -body { - # (objc < 3) + # (objc < 3) font delete } -returnCodes error -result {wrong # args: should be "font delete fontname ?fontname ...?"} test font-7.2 {font command: delete: loop test} -setup { clearnondefaultfonts set x {} } -body { - # for (i = 2; i < objc; i++) + # for (i = 2; i < objc; i++) font create a -underline 1 font create b -underline 1 font create c -underline 1 @@ -321,7 +321,7 @@ test font-7.3 {font command: delete: loop test} -setup { test font-7.4 {font command: delete: non-existent} -setup { catch {font delete xyz} } -body { - # (namedHashPtr == NULL) + # (namedHashPtr == NULL) font delete xyz } -returnCodes error -result {named font "xyz" doesn't exist} test font-7.5 {font command: delete: mark for later deletion} -setup { @@ -388,11 +388,11 @@ test font-9.1 {font command: measure: arguments} -body { expr {[font measure xyz -displayof] > 0} } -returnCodes ok -result 1 test font-9.2 {font command: measure: arguments} -body { - # (objc - skip != 4) + # (objc - skip != 4) font measure } -returnCodes error -result {wrong # args: should be "font measure font ?-displayof window? text"} test font-9.3 {font command: measure: arguments} -body { - # (objc - skip != 4) + # (objc - skip != 4) font measure xyz abc def } -returnCodes error -result {wrong # args: should be "font measure font ?-displayof window? text"} test font-9.4 {font command: measure: arguments} -constraints noExceed -body { @@ -422,7 +422,7 @@ test font-10.2 {font command: metrics: arguments} -body { font metrics xyz -displayof } -returnCodes error -result {value for "-displayof" missing} test font-10.3 {font command: metrics: arguments} -body { - # (objc < 3) + # (objc < 3) font metrics } -returnCodes error -result {wrong # args: should be "font metrics font ?-displayof window? ?option?"} test font-10.4 {font command: metrics: arguments} -body { @@ -585,7 +585,7 @@ test font-14.1 {Tk_GetFont procedure} -body { test font-15.1 {Tk_AllocFontFromObj - converting internal reps} -constraints { - testfont + testfont } -setup { destroy .b1 .b2 } -body { @@ -598,7 +598,7 @@ test font-15.1 {Tk_AllocFontFromObj - converting internal reps} -constraints { destroy .b1 .b2 } -result {{1 0}} test font-15.2 {Tk_AllocFontFromObj - discard stale font} -constraints { - testfont + testfont } -setup { destroy .b1 .b2 set result {} @@ -613,7 +613,7 @@ test font-15.2 {Tk_AllocFontFromObj - discard stale font} -constraints { destroy .b2 } -result {{} {{1 1}}} test font-15.3 {Tk_AllocFontFromObj - reuse existing font} -constraints { - testfont + testfont } -setup { destroy .b1 .b2 set result {} @@ -644,9 +644,9 @@ test font-15.5 {Tk_AllocFontFromObj procedure: get named font} -setup { pack [label .t.f] update } -body { - # (namedHashPtr != NULL) - font create xyz - .t.f config -font xyz + # (namedHashPtr != NULL) + font create xyz + .t.f config -font xyz } -cleanup { destroy .t.f font delete xyz @@ -662,24 +662,24 @@ test font-15.6 {Tk_AllocFontFromObj procedure: not a named font} -setup { destroy .t.f } -result {-family} -result {} test font-15.7 {Tk_AllocFontFromObj procedure: get native font} -constraints { - unix + unix } -setup { destroy .t.f pack [label .t.f] update } -body { - # not (fontPtr == NULL) + # not (fontPtr == NULL) .t.f config -font fixed } -result {} test font-15.8 {Tk_AllocFontFromObj procedure: get native font} -constraints { - win + win } -setup { destroy .t.f clearnondefaultfonts pack [label .t.f] update } -body { - # not (fontPtr == NULL) + # not (fontPtr == NULL) .t.f config -font oemfixed } -cleanup { destroy .t.f @@ -689,7 +689,7 @@ test font-15.9 {Tk_AllocFontFromObj procedure: get attribute font} -setup { pack [label .t.f] update } -body { - # (fontPtr == NULL) + # (fontPtr == NULL) .t.f config -font {xxx yyy zzz} } -cleanup { destroy .t.f @@ -724,7 +724,7 @@ test font-15.13 {Tk_AllocFontFromObj procedure: underline position} -setup { update } -cleanup { destroy .t.f -} -result {} +} -result {} test font-16.1 {Tk_NameOfFont procedure} -setup { @@ -740,7 +740,7 @@ test font-16.1 {Tk_NameOfFont procedure} -setup { test font-17.1 {Tk_FreeFontFromObj - reference counts} -constraints { - testfont + testfont } -setup { destroy .b1 .b2 .b3 set result {} @@ -785,7 +785,7 @@ test font-17.4 {Tk_FreeFont procedure: named font} -setup { pack [label .t.f] update } -body { - # (fontPtr->namedHashPtr != NULL) + # (fontPtr->namedHashPtr != NULL) font create xyz .t.f config -font xyz destroy .t.f @@ -797,7 +797,7 @@ test font-17.5 {Tk_FreeFont procedure: named font} -setup { pack [label .t.f] update } -body { - # not (fontPtr->refCount == 0) + # not (fontPtr->refCount == 0) font create xyz -underline 1 .t.f config -font xyz font delete xyz @@ -811,7 +811,7 @@ test font-17.6 {Tk_FreeFont procedure: named font not deleted yet} -setup { pack [label .t.f] update } -body { - font create xyz + font create xyz .t.f config -font xyz button .t.b -font xyz font delete xyz @@ -870,7 +870,7 @@ test font-20.1 {Tk_GetFontMetrics procedure} -setup { # Procedure used in 21.* tests proc psfontname {name} { destroy .t.c - canvas .t.c -closeenough 0 + canvas .t.c -closeenough 0 .t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12" pack .t.c update @@ -896,22 +896,22 @@ test font-21.1 {Tk_PostscriptFontName procedure: native} -constraints { } } -result {AvantGarde-Book} test font-21.2 {Tk_PostscriptFontName procedure: native} -constraints { - win + win } -body { psfontname "arial 10" } -result {Helvetica} test font-21.3 {Tk_PostscriptFontName procedure: native} -constraints { - win + win } -body { psfontname "{times new roman} 10" } -result {Times-Roman} test font-21.4 {Tk_PostscriptFontName procedure: native} -constraints { - win + win } -body { psfontname "{courier new} 10" } -result {Courier} test font-21.5 {Tk_PostscriptFontName procedure: spaces} -constraints { - unix + unix } -body { set x [font actual {{lucida bright} 10} -family] if {[string match lucida*bright $x]} { @@ -921,13 +921,13 @@ test font-21.5 {Tk_PostscriptFontName procedure: spaces} -constraints { } } -result {LucidaBright} test font-21.6 {Tk_PostscriptFontName procedure: spaces} -constraints { - x11 + x11 } -body { psfontname "{new century schoolbook} 10" } -result {NewCenturySchlbk-Roman} test font-21.7 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix + unix } -body { set name {avantgarde 12 roman normal} if {[font actual {avantgarde 12 roman normal} -family] == "avantgarde"} { @@ -937,7 +937,7 @@ test font-21.7 {Tk_PostscriptFontName procedure: exhaustive} -constraints { } } -result {AvantGarde-Book} test font-21.8 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix + unix } -body { set name {avantgarde 12 roman bold} if {[font actual {avantgarde 12 roman normal} -family] == "avantgarde"} { @@ -947,7 +947,7 @@ test font-21.8 {Tk_PostscriptFontName procedure: exhaustive} -constraints { } } -result {AvantGarde-Demi} test font-21.9 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix + unix } -body { set name {avantgarde 12 italic normal} if {[font actual {avantgarde 12 roman normal} -family] == "avantgarde"} { @@ -957,7 +957,7 @@ test font-21.9 {Tk_PostscriptFontName procedure: exhaustive} -constraints { } } -result {AvantGarde-BookOblique} test font-21.10 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix + unix } -body { set name {avantgarde 12 italic bold} if {[font actual {avantgarde 12 roman normal} -family] == "avantgarde"} { @@ -968,7 +968,7 @@ test font-21.10 {Tk_PostscriptFontName procedure: exhaustive} -constraints { } -result {AvantGarde-DemiOblique} test font-21.11 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix + unix } -body { set name {bookman 12 roman normal} if {[font actual {avantgarde 12 roman normal} -family] == "bookman"} { @@ -978,7 +978,7 @@ test font-21.11 {Tk_PostscriptFontName procedure: exhaustive} -constraints { } } -result {Bookman-Light} test font-21.12 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix + unix } -body { set name {bookman 12 roman bold} if {[font actual {avantgarde 12 roman normal} -family] == "bookman"} { @@ -988,7 +988,7 @@ test font-21.12 {Tk_PostscriptFontName procedure: exhaustive} -constraints { } } -result {Bookman-Demi} test font-21.13 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix + unix } -body { set name {bookman 12 italic normal} if {[font actual {avantgarde 12 roman normal} -family] == "bookman"} { @@ -998,7 +998,7 @@ test font-21.13 {Tk_PostscriptFontName procedure: exhaustive} -constraints { } } -result {Bookman-LightItalic} test font-21.14 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix + unix } -body { set name {bookman 12 italic bold} if {[font actual {avantgarde 12 roman normal} -family] == "bookman"} { @@ -1009,7 +1009,7 @@ test font-21.14 {Tk_PostscriptFontName procedure: exhaustive} -constraints { } -result {Bookman-DemiItalic} test font-21.15 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix + unix } -body { set name {courier 12 roman normal} if {[font actual {avantgarde 12 roman normal} -family] == "courier"} { @@ -1019,7 +1019,7 @@ test font-21.15 {Tk_PostscriptFontName procedure: exhaustive} -constraints { } } -result {Courier} test font-21.16 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix + unix } -body { set name {courier 12 roman bold} if {[font actual {avantgarde 12 roman normal} -family] == "courier"} { @@ -1029,7 +1029,7 @@ test font-21.16 {Tk_PostscriptFontName procedure: exhaustive} -constraints { } } -result {Courier-Bold} test font-21.17 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix + unix } -body { set name {courier 12 italic normal} if {[font actual {avantgarde 12 roman normal} -family] == "courier"} { @@ -1039,7 +1039,7 @@ test font-21.17 {Tk_PostscriptFontName procedure: exhaustive} -constraints { } } -result {Courier-Oblique} test font-21.18 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix + unix } -body { set name {courier 12 italic bold} if {[font actual {avantgarde 12 roman normal} -family] == "courier"} { @@ -1050,7 +1050,7 @@ test font-21.18 {Tk_PostscriptFontName procedure: exhaustive} -constraints { } -result {Courier-BoldOblique} test font-21.19 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix + unix } -body { set name {helvetica 12 roman normal} if {[font actual {avantgarde 12 roman normal} -family] == "helvetica"} { @@ -1060,7 +1060,7 @@ test font-21.19 {Tk_PostscriptFontName procedure: exhaustive} -constraints { } } -result {Helvetica} test font-21.20 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix + unix } -body { set name {helvetica 12 roman bold} if {[font actual {avantgarde 12 roman normal} -family] == "helvetica"} { @@ -1070,7 +1070,7 @@ test font-21.20 {Tk_PostscriptFontName procedure: exhaustive} -constraints { } } -result {Helvetica-Bold} test font-21.21 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix + unix } -body { set name {helvetica 12 italic normal} if {[font actual {avantgarde 12 roman normal} -family] == "helvetica"} { @@ -1080,7 +1080,7 @@ test font-21.21 {Tk_PostscriptFontName procedure: exhaustive} -constraints { } } -result {Helvetica-Oblique} test font-21.22 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix + unix } -body { set name {helvetica 12 italic bold} if {[font actual {avantgarde 12 roman normal} -family] == "helvetica"} { @@ -1091,7 +1091,7 @@ test font-21.22 {Tk_PostscriptFontName procedure: exhaustive} -constraints { } -result {Helvetica-BoldOblique} test font-21.23 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix + unix } -body { set name {{new century schoolbook} 12 roman normal} if {[font actual {avantgarde 12 roman normal} -family] == "new century schoolbook"} { @@ -1101,7 +1101,7 @@ test font-21.23 {Tk_PostscriptFontName procedure: exhaustive} -constraints { } } -result {NewCenturySchlbk-Roman} test font-21.24 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix + unix } -body { set name {{new century schoolbook} 12 roman bold} if {[font actual {avantgarde 12 roman normal} -family] == "new century schoolbook"} { @@ -1111,7 +1111,7 @@ test font-21.24 {Tk_PostscriptFontName procedure: exhaustive} -constraints { } } -result {NewCenturySchlbk-Bold} test font-21.25 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix + unix } -body { set name {{new century schoolbook} 12 italic normal} if {[font actual {avantgarde 12 roman normal} -family] == "new century schoolbook"} { @@ -1121,7 +1121,7 @@ test font-21.25 {Tk_PostscriptFontName procedure: exhaustive} -constraints { } } -result {NewCenturySchlbk-Italic} test font-21.26 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix + unix } -body { set name {{new century schoolbook} 12 italic bold} if {[font actual {avantgarde 12 roman normal} -family] == "new century schoolbook"} { @@ -1132,7 +1132,7 @@ test font-21.26 {Tk_PostscriptFontName procedure: exhaustive} -constraints { } -result {NewCenturySchlbk-BoldItalic} test font-21.27 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix + unix } -body { set name {palatino 12 roman normal} if {[font actual {avantgarde 12 roman normal} -family] == "palatino"} { @@ -1142,7 +1142,7 @@ test font-21.27 {Tk_PostscriptFontName procedure: exhaustive} -constraints { } } -result {Palatino-Roman} test font-21.28 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix + unix } -body { set name {palatino 12 roman bold} if {[font actual {avantgarde 12 roman normal} -family] == "palatino"} { @@ -1152,7 +1152,7 @@ test font-21.28 {Tk_PostscriptFontName procedure: exhaustive} -constraints { } } -result {Palatino-Bold} test font-21.29 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix + unix } -body { set name {palatino 12 italic normal} if {[font actual {avantgarde 12 roman normal} -family] == "palatino"} { @@ -1162,7 +1162,7 @@ test font-21.29 {Tk_PostscriptFontName procedure: exhaustive} -constraints { } } -result {Palatino-Italic} test font-21.30 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix + unix } -body { set name {palatino 12 italic bold} if {[font actual {avantgarde 12 roman normal} -family] == "palatino"} { @@ -1173,7 +1173,7 @@ test font-21.30 {Tk_PostscriptFontName procedure: exhaustive} -constraints { } -result {Palatino-BoldItalic} test font-21.31 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix + unix } -body { set name {symbol 12 roman normal} if {[font actual {avantgarde 12 roman normal} -family] == "symbol"} { @@ -1183,7 +1183,7 @@ test font-21.31 {Tk_PostscriptFontName procedure: exhaustive} -constraints { } } -result {Symbol} test font-21.32 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix + unix } -body { set name {symbol 12 roman bold} if {[font actual {avantgarde 12 roman normal} -family] == "symbol"} { @@ -1193,7 +1193,7 @@ test font-21.32 {Tk_PostscriptFontName procedure: exhaustive} -constraints { } } -result {Symbol} test font-21.33 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix + unix } -body { set name {symbol 12 italic normal} if {[font actual {avantgarde 12 roman normal} -family] == "symbol"} { @@ -1203,7 +1203,7 @@ test font-21.33 {Tk_PostscriptFontName procedure: exhaustive} -constraints { } } -result {Symbol} test font-21.34 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix + unix } -body { set name {symbol 12 italic bold} if {[font actual {avantgarde 12 roman normal} -family] == "symbol"} { @@ -1214,7 +1214,7 @@ test font-21.34 {Tk_PostscriptFontName procedure: exhaustive} -constraints { } -result {Symbol} test font-21.35 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix + unix } -body { set name {times 12 roman normal} if {[font actual {avantgarde 12 roman normal} -family] == "times"} { @@ -1224,7 +1224,7 @@ test font-21.35 {Tk_PostscriptFontName procedure: exhaustive} -constraints { } } -result {Times-Roman} test font-21.36 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix + unix } -body { set name {times 12 roman bold} if {[font actual {avantgarde 12 roman normal} -family] == "times"} { @@ -1234,7 +1234,7 @@ test font-21.36 {Tk_PostscriptFontName procedure: exhaustive} -constraints { } } -result {Times-Bold} test font-21.37 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix + unix } -body { set name {times 12 italic normal} if {[font actual {avantgarde 12 roman normal} -family] == "times"} { @@ -1244,7 +1244,7 @@ test font-21.37 {Tk_PostscriptFontName procedure: exhaustive} -constraints { } } -result {Times-Italic} test font-21.38 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix + unix } -body { set name {times 12 italic bold} if {[font actual {avantgarde 12 roman normal} -family] == "times"} { @@ -1255,7 +1255,7 @@ test font-21.38 {Tk_PostscriptFontName procedure: exhaustive} -constraints { } -result {Times-BoldItalic} test font-21.39 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix + unix } -body { set name {zapfchancery 12 roman normal} if {[font actual {avantgarde 12 roman normal} -family] == "zapfchancery"} { @@ -1265,7 +1265,7 @@ test font-21.39 {Tk_PostscriptFontName procedure: exhaustive} -constraints { } } -result {ZapfChancery-MediumItalic} test font-21.40 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix + unix } -body { set name {zapfchancery 12 roman bold} if {[font actual {avantgarde 12 roman normal} -family] == "zapfchancery"} { @@ -1275,7 +1275,7 @@ test font-21.40 {Tk_PostscriptFontName procedure: exhaustive} -constraints { } } -result {ZapfChancery-MediumItalic} test font-21.41 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix + unix } -body { set name {zapfchancery 12 italic normal} if {[font actual {avantgarde 12 roman normal} -family] == "zapfchancery"} { @@ -1285,7 +1285,7 @@ test font-21.41 {Tk_PostscriptFontName procedure: exhaustive} -constraints { } } -result {ZapfChancery-MediumItalic} test font-21.42 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix + unix } -body { set name {zapfchancery 12 italic bold} if {[font actual {avantgarde 12 roman normal} -family] == "zapfchancery"} { @@ -1296,7 +1296,7 @@ test font-21.42 {Tk_PostscriptFontName procedure: exhaustive} -constraints { } -result {ZapfChancery-MediumItalic} test font-21.43 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix + unix } -body { set name {zapfdingbats 12 roman normal} if {[font actual {avantgarde 12 roman normal} -family] == "zapfdingbats"} { @@ -1306,7 +1306,7 @@ test font-21.43 {Tk_PostscriptFontName procedure: exhaustive} -constraints { } } -result {ZapfDingbats} test font-21.44 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix + unix } -body { set name {zapfdingbats 12 roman bold} if {[font actual {avantgarde 12 roman normal} -family] == "zapfdingbats"} { @@ -1316,7 +1316,7 @@ test font-21.44 {Tk_PostscriptFontName procedure: exhaustive} -constraints { } } -result {ZapfDingbats} test font-21.45 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix + unix } -body { set name {zapfdingbats 12 italic normal} if {[font actual {avantgarde 12 roman normal} -family] == "zapfdingbats"} { @@ -1326,7 +1326,7 @@ test font-21.45 {Tk_PostscriptFontName procedure: exhaustive} -constraints { } } -result {ZapfDingbats} test font-21.46 {Tk_PostscriptFontName procedure: exhaustive} -constraints { - unix + unix } -body { set name {zapfdingbats 12 italic bold} if {[font actual {avantgarde 12 roman normal} -family] == "zapfdingbats"} { @@ -1443,7 +1443,7 @@ test font-21.66 {Tk_PostscriptFontName procedure: exhaustive} -constraints { test font-22.1 {Tk_TextWidth procedure} -setup { - destroy .t.l + destroy .t.l } -body { label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \ -text "0" -font "Courier -12" @@ -1469,7 +1469,7 @@ test font-23.1 {Tk_UnderlineChars procedure} -setup { # Data used in 24.* tests -destroy .t.l +destroy .t.l label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \ -text "0" -font "Courier -12" pack .t.l @@ -1594,12 +1594,12 @@ test font-24.14 {Tk_ComputeTextLayout: text ended with \n} -body { lappend x [expr {[winfo reqheight .t.l] eq [expr {$ay * 2}]}] return $x } -result {1 1 1 1} -destroy .t.l +destroy .t.l test font-24.15 {Tk_ComputeTextLayout: justification} -setup { set x {} destroy .t.c - canvas .t.c -closeenough 0 + canvas .t.c -closeenough 0 .t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12" pack .t.c update @@ -1628,11 +1628,11 @@ test font-25.1 {Tk_FreeTextLayout procedure} -setup { } -cleanup { destroy .t.f } -result {} - + # Canvas created for tests: 26.* destroy .t.c -canvas .t.c -closeenough 0 +canvas .t.c -closeenough 0 .t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12" pack .t.c update @@ -1690,7 +1690,7 @@ destroy .t.f # Canvas created for tests: 28.* destroy .t.c -canvas .t.c -closeenough 0 +canvas .t.c -closeenough 0 .t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12" pack .t.c update @@ -1782,7 +1782,7 @@ destroy .t.f # Canvas created for tests: 30.* destroy .t.c -canvas .t.c -closeenough 0 +canvas .t.c -closeenough 0 .t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12" pack .t.c update @@ -1925,7 +1925,7 @@ destroy .t.c # Canvas created for tests 31.* destroy .t.c -canvas .t.c -closeenough 0 +canvas .t.c -closeenough 0 .t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12" pack .t.c update @@ -1971,7 +1971,7 @@ destroy .t.c test font-32.1 {Tk_TextLayoutToPostscript: ensure buffer doesn't overflow} -setup { destroy .t.c - canvas .t.c -closeenough 0 + canvas .t.c -closeenough 0 .t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12" pack .t.c update @@ -1984,7 +1984,7 @@ test font-32.1 {Tk_TextLayoutToPostscript: ensure buffer doesn't overflow} -setu .t.c insert text end "\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n" .t.c insert text end "end" set x [.t.c postscript] - set i [string first "(qwerty" $x] + set i [string first "(qwerty" $x] string range $x $i [expr {$i + 278}] } -cleanup { destroy .t.c @@ -2200,7 +2200,7 @@ test font-37.6 {GetAttributeInfo procedure: underline} -setup { set x {} } -body { font create xyz -underline yes - font config xyz -underline + font config xyz -underline } -cleanup { font delete xyz } -result {1} @@ -2209,7 +2209,7 @@ test font-37.7 {GetAttributeInfo procedure: overstrike} -setup { set x {} } -body { font create xyz -overstrike no - font config xyz -overstrike + font config xyz -overstrike } -cleanup { font delete xyz } -result {0} diff --git a/tests/frame.test b/tests/frame.test index e374326..fe38128 100644 --- a/tests/frame.test +++ b/tests/frame.test @@ -60,7 +60,7 @@ test frame-1.1 {frame configuration options} -setup { .f configure -class } -cleanup { deleteWindows -} -result {-class class Class Frame NewFrame} +} -result {-class class Class Frame NewFrame} test frame-1.2 {frame configuration options} -setup { deleteWindows } -body { @@ -800,7 +800,7 @@ test frame-3.18 {TkCreateFrame procedure} -constraints { } -setup { deleteWindows } -body { - toplevel .t -visual {grayscale 8} -width 300 -height 200 -bg #434343 + toplevel .t -visual {grayscale 8} -width 300 -height 200 -bg #434343 wm geometry .t +0+0 update colorsFree .t 131 131 131 @@ -844,7 +844,7 @@ test frame-3.21 {TkCreateFrame procedure} -constraints { deleteWindows } -body { set x ok - toplevel .t -visual {grayscale 8} -width 300 -height 200 -bg #434343 + toplevel .t -visual {grayscale 8} -width 300 -height 200 -bg #434343 wm geometry .t +0+0 update colorsFree .t 131 131 131 @@ -1140,7 +1140,7 @@ test frame-12.2 {FrameWorldChanged procedure} -setup { place .f -x 0 -y 0 -width 100 -height 100 pack [frame .f.f] -fill both -expand 1 - set result {} + set result {} foreach lp {nw n ne en e es se s sw ws w wn} { .f configure -labelanchor $lp update diff --git a/tests/image.test b/tests/image.test index d4ea745..5842ce3 100644 --- a/tests/image.test +++ b/tests/image.test @@ -33,27 +33,27 @@ test image-1.4 {Tk_ImageCmd procedure, "create" option} -body { image c bad_type } -returnCodes error -result {image type "bad_type" doesn't exist} test image-1.5 {Tk_ImageCmd procedure, "create" option} -constraints { - testImageType + testImageType } -body { list [image create test myimage] [imageNames] } -cleanup { imageCleanup } -result {myimage myimage} test image-1.6 {Tk_ImageCmd procedure, "create" option} -constraints { - testImageType + testImageType } -setup { imageCleanup } -body { scan [image create test] image%d first image create test myimage scan [image create test -variable x] image%d second - expr $second-$first + expr {$second-$first} } -cleanup { imageCleanup } -result {1} test image-1.7 {Tk_ImageCmd procedure, "create" option} -constraints { - testImageType + testImageType } -setup { imageCleanup } -body { @@ -62,14 +62,24 @@ test image-1.7 {Tk_ImageCmd procedure, "create" option} -constraints { .c create image 100 150 -image myimage update set x {} + set timer [after 500 {lappend x "timeout"}] image create test myimage -variable x + update idletasks update + # On MacOS we need to wait for the test image display procedure to run. + while {"timeout" ni $x && [lindex $x end 1] ne "display"} { + vwait x + } + after cancel timer + if {[lindex $x end] eq "timeout"} { + return [lreplace $x end end] + } return $x } -cleanup { imageCleanup } -result {{myimage free} {myimage free} {myimage delete} {myimage get} {myimage get} {myimage display 0 0 30 15} {myimage display 0 0 30 15}} test image-1.8 {Tk_ImageCmd procedure, "create" option} -constraints { - testImageType + testImageType } -setup { .c delete all imageCleanup @@ -88,12 +98,12 @@ test image-1.8 {Tk_ImageCmd procedure, "create" option} -constraints { imageCleanup } -result {{myimage get} {myimage get} {myimage display 0 0 30 15} {myimage display 0 0 30 15}} test image-1.9 {Tk_ImageCmd procedure, "create" option} -constraints { - testImageType + testImageType } -body { image create test -badName foo } -returnCodes error -result {bad option name "-badName"} test image-1.10 {Tk_ImageCmd procedure, "create" option} -constraints { - testImageType + testImageType } -body { catch {image create test -badName foo} imageNames @@ -142,7 +152,7 @@ test image-2.1 {Tk_ImageCmd procedure, "delete" option} -body { image delete } -result {} test image-2.2 {Tk_ImageCmd procedure, "delete" option} -constraints { - testImageType + testImageType } -setup { imageCleanup set result {} @@ -156,7 +166,7 @@ test image-2.2 {Tk_ImageCmd procedure, "delete" option} -constraints { imageCleanup } -result {{img2 myimage} {}} test image-2.3 {Tk_ImageCmd procedure, "delete" option} -constraints { - testImageType + testImageType } -setup { imageCleanup } -body { @@ -167,7 +177,7 @@ test image-2.3 {Tk_ImageCmd procedure, "delete" option} -constraints { imageCleanup } -returnCodes error -result {image "gorp" doesn't exist} test image-2.4 {Tk_ImageCmd procedure, "delete" option} -constraints { - testImageType + testImageType } -setup { imageCleanup } -body { @@ -190,7 +200,7 @@ test image-3.3 {Tk_ImageCmd procedure, "height" option} -body { image height foo } -returnCodes error -result {image "foo" doesn't exist} test image-3.4 {Tk_ImageCmd procedure, "height" option} -constraints { - testImageType + testImageType } -setup { imageCleanup } -body { @@ -207,7 +217,7 @@ test image-4.1 {Tk_ImageCmd procedure, "names" option} -body { image names x } -returnCodes error -result {wrong # args: should be "image names"} test image-4.2 {Tk_ImageCmd procedure, "names" option} -constraints { - testImageType + testImageType } -setup { catch {interp delete testinterp} } -body { @@ -249,7 +259,7 @@ test image-5.3 {Tk_ImageCmd procedure, "type" option} -body { } -returnCodes error -result {image "foo" doesn't exist} test image-5.4 {Tk_ImageCmd procedure, "type" option} -constraints { - testImageType + testImageType } -setup { imageCleanup } -body { @@ -259,7 +269,7 @@ test image-5.4 {Tk_ImageCmd procedure, "type" option} -constraints { imageCleanup } -result {test} test image-5.5 {Tk_ImageCmd procedure, "type" option} -constraints { - testImageType + testImageType } -setup { imageCleanup } -body { @@ -271,7 +281,7 @@ test image-5.5 {Tk_ImageCmd procedure, "type" option} -constraints { imageCleanup } -returnCodes error -result {image "myimage" doesn't exist} test image-5.6 {Tk_ImageCmd procedure, "type" option} -constraints { - testOldImageType + testOldImageType } -setup { imageCleanup } -body { @@ -281,7 +291,7 @@ test image-5.6 {Tk_ImageCmd procedure, "type" option} -constraints { imageCleanup } -result {oldtest} test image-5.7 {Tk_ImageCmd procedure, "type" option} -constraints { - testOldImageType + testOldImageType } -setup { .c delete all imageCleanup @@ -300,7 +310,7 @@ test image-6.1 {Tk_ImageCmd procedure, "types" option} -body { image types x } -returnCodes error -result {wrong # args: should be "image types"} test image-6.2 {Tk_ImageCmd procedure, "types" option} -constraints { - testImageType + testImageType } -body { lsort [image types] } -result {bitmap oldtest photo test} @@ -316,7 +326,7 @@ test image-7.3 {Tk_ImageCmd procedure, "width" option} -body { image width foo } -returnCodes error -result {image "foo" doesn't exist} test image-7.4 {Tk_ImageCmd procedure, "width" option} -constraints { - testImageType + testImageType } -setup { imageCleanup } -body { @@ -330,7 +340,7 @@ test image-7.4 {Tk_ImageCmd procedure, "width" option} -constraints { test image-8.1 {Tk_ImageCmd procedure, "inuse" option} -constraints { - testImageType + testImageType } -setup { imageCleanup set res {} @@ -344,8 +354,13 @@ test image-8.1 {Tk_ImageCmd procedure, "inuse" option} -constraints { imageCleanup catch {destroy .b} } -result [list 0 1] - +if {[tk windowingsystem] == "aqua" && $tcl_platform(osVersion) > 18} { + # Aqua >= 10.14 will redraw the entire image in drawRect. + set result_9_1 {{foo display 0 0 30 15}} +} else { + set result_9_1 {{foo display 5 6 7 8}} +} test image-9.1 {Tk_ImageChanged procedure} -constraints testImageType -setup { .c delete all imageCleanup @@ -355,13 +370,26 @@ test image-9.1 {Tk_ImageChanged procedure} -constraints testImageType -setup { .c create image 50 50 -image foo update set x {} + set timer [after 500 {lappend x "timeout"}] foo changed 5 6 7 8 30 15 + update idletasks update + # On MacOS we need to wait for the test image display procedure to run. + while {"timeout" ni $x && [lindex $x end 1] ne "display"} { + vwait x + } + after cancel timer return $x } -cleanup { .c delete all imageCleanup -} -result {{foo display 5 6 7 8}} +} -result $result_9_1 +if {[tk windowingsystem] == "aqua" && $tcl_platform(osVersion) > 18} { + # Aqua >= 10.14 will redraw the entire image. + set result_9_2 {{foo display 0 0 30 15} {foo display 0 0 30 15}} +} else { + set result_9_2 {{foo display 5 6 25 9} {foo display 0 0 12 14}} +} test image-9.2 {Tk_ImageChanged procedure} -constraints testImageType -setup { .c delete all imageCleanup @@ -378,8 +406,7 @@ test image-9.2 {Tk_ImageChanged procedure} -constraints testImageType -setup { } -cleanup { .c delete all imageCleanup -} -result {{foo display 5 6 25 9} {foo display 0 0 12 14}} - +} -result $result_9_2 test image-10.1 {Tk_GetImage procedure} -setup { imageCleanup @@ -615,7 +642,7 @@ test image-15.1 {deleting image does not make widgets forget about it} -setup { .c delete all imageCleanup } -result {10 10 20 20 foo {} {10 10 30 30} foo} - + destroy .c imageFinish diff --git a/tests/listbox.test b/tests/listbox.test index 2c07633..68cb5d8 100644 --- a/tests/listbox.test +++ b/tests/listbox.test @@ -1404,7 +1404,7 @@ test listbox-4.12 {ConfigureListbox procedure, listvar -> different listvar} -se } -body { set x [list a b c d] set y [list 1 2 3 4] - listbox .l2 + listbox .l2 .l2 configure -listvar x .l2 configure -listvar y .l2 insert end 5 6 7 8 @@ -1552,7 +1552,7 @@ test listbox-5.6 {ListboxComputeGeometry procedure} -setup { } -cleanup { destroy .l } -result {} - + # Listbox used in 6.*, 7.* tests destroy .l @@ -1913,7 +1913,7 @@ test listbox-9.1 {ListboxCmdDeletedProc procedure} -setup { deleteWindows } -result {{} {}} test listbox-9.2 {ListboxCmdDeletedProc procedure, disabling -setgrid} -constraints { - fonts + fonts } -setup { destroy .top } -body { @@ -2994,7 +2994,7 @@ test listbox-25.2 {listbox item configurations and widget based inserts} -setup } -cleanup { destroy .l } -result {{} red} - + # state issues test listbox-26.1 {listbox disabled state disallows inserts} -setup { diff --git a/tests/pack.test b/tests/pack.test index e2efb4d..b1c22c7 100644 --- a/tests/pack.test +++ b/tests/pack.test @@ -1562,7 +1562,7 @@ test pack-18.1 {unmap slaves when master unmapped} -constraints { wm geometry .pack +100+100 - # On the PC, when the width/height is configured while the window is + # On the PC, when the width/height is configured while the window is # unmapped, the changes don't take effect until the window is remapped. # Who knows why? diff --git a/tests/raise.test b/tests/raise.test index 461ccbf..f8674fc 100644 --- a/tests/raise.test +++ b/tests/raise.test @@ -131,7 +131,7 @@ test raise-3.1 {raise internal windows after creation} -body { raise_getOrder } -result {a d d a c e e e} test raise-3.2 {raise internal windows after creation} -constraints { - testmakeexist + testmakeexist } -body { raise_setup testmakeexist .raise.a .raise.b @@ -140,7 +140,7 @@ test raise-3.2 {raise internal windows after creation} -constraints { raise_getOrder } -result {d d d a c e e e} test raise-3.3 {raise internal windows after creation} -constraints { - testmakeexist + testmakeexist } -body { raise_setup testmakeexist .raise.a .raise.d @@ -149,7 +149,7 @@ test raise-3.3 {raise internal windows after creation} -constraints { raise_getOrder } -result {d d d a c e e e} test raise-3.4 {raise internal windows after creation} -constraints { - testmakeexist + testmakeexist } -body { raise_setup testmakeexist .raise.a .raise.c .raise.d diff --git a/tests/scrollbar.test b/tests/scrollbar.test index 9d6a83c..8966f1f 100644 --- a/tests/scrollbar.test +++ b/tests/scrollbar.test @@ -20,34 +20,34 @@ proc getTroughSize {w} { if {[testConstraint testmetrics]} { # Only Windows has [testmetrics] if [string match v* [$w cget -orient]] { - return [expr [winfo height $w] - 2*[testmetrics cyvscroll $w]] + return [expr {[winfo height $w] - 2*[testmetrics cyvscroll $w]}] } else { - return [expr [winfo width $w] - 2*[testmetrics cxhscroll $w]] + return [expr {[winfo width $w] - 2*[testmetrics cxhscroll $w]}] } } else { if {[tk windowingsystem] eq "x11"} { # Calculations here assume that the arrow area is a square. if [string match v* [$w cget -orient]] { - return [expr [winfo height $w] \ + return [expr {[winfo height $w] \ - ([winfo width $w] \ - [$w cget -highlightthickness] \ - - [$w cget -bd] + 1)*2] + - [$w cget -bd] + 1)*2}] } else { - return [expr [winfo width $w] \ + return [expr {[winfo width $w] \ - ([winfo height $w] \ - [$w cget -highlightthickness] \ - - [$w cget -bd] + 1)*2] + - [$w cget -bd] + 1)*2}] } } else { # macOS aqua if [string match v* [$w cget -orient]] { - return [expr [winfo height $w] \ + return [expr {[winfo height $w] \ - ([$w cget -highlightthickness] \ - +[$w cget -bd])*2] + +[$w cget -bd])*2}] } else { - return [expr [winfo width $w] \ + return [expr {[winfo width $w] \ - ([$w cget -highlightthickness] \ - +[$w cget -bd])*2] + +[$w cget -bd])*2}] } } } @@ -58,8 +58,8 @@ proc getTroughSize {w} { # as you fix bugs and add features. foreach {width height} [wm minsize .] { - set height [expr ($height < 200) ? 200 : $height] - set width [expr ($width < 1) ? 1 : $width] + set height [expr {($height < 200) ? 200 : $height}] + set width [expr {($width < 1) ? 1 : $width}] } frame .f -height $height -width $width @@ -233,10 +233,10 @@ test scrollbar-3.25 {ScrollbarWidgetCmd procedure, "delta" option} { } {0} test scrollbar-3.26 {ScrollbarWidgetCmd procedure, "delta" option} { format {%.6g} [.s delta 0 20] -} [format %.6g [expr 20.0/([getTroughSize .s]-1)]] +} [format %.6g [expr {20.0/([getTroughSize .s]-1)}]] test scrollbar-3.27 {ScrollbarWidgetCmd procedure, "delta" option} { format {%.6g} [.s delta 0 -20] -} [format %.6g [expr -20.0/([getTroughSize .s]-1)]] +} [format %.6g [expr {-20.0/([getTroughSize .s]-1)}]] test scrollbar-3.28 {ScrollbarWidgetCmd procedure, "delta" option} { toplevel .t -width 250 -height 100 wm geom .t +0+0 @@ -244,7 +244,7 @@ test scrollbar-3.28 {ScrollbarWidgetCmd procedure, "delta" option} { place .t.s -width 201 update set result [list [format {%.6g} [.t.s delta 0 20]] \ - [format {%.6g} [.t.s delta [expr [getTroughSize .t.s] - 1] 0]]] + [format {%.6g} [.t.s delta [expr {[getTroughSize .t.s] - 1}] 0]]] destroy .t set result } {0 1} @@ -268,22 +268,22 @@ test scrollbar-3.34 {ScrollbarWidgetCmd procedure, "fraction" option} { } {1} test scrollbar-3.35 {ScrollbarWidgetCmd procedure, "fraction" option} { format {%.6g} [.s fraction 4 21] -} [format %.6g [expr (21.0 - ([winfo height .s] - [getTroughSize .s])/2.0) \ - /([getTroughSize .s] - 1)]] +} [format %.6g [expr {(21.0 - ([winfo height .s] - [getTroughSize .s])/2.0) \ + /([getTroughSize .s] - 1)}]] test scrollbar-3.36 {ScrollbarWidgetCmd procedure, "fraction" option} x11 { format {%.6g} [.s fraction 4 179] } {1} test scrollbar-3.37 {ScrollbarWidgetCmd procedure, "fraction" option} {testmetrics} { - format {%.6g} [.s fraction 4 [expr 200 - [testmetrics cyvscroll .s]]] + format {%.6g} [.s fraction 4 [expr {200 - [testmetrics cyvscroll .s]}]] } {1} test scrollbar-3.38 {ScrollbarWidgetCmd procedure, "fraction" option} x11 { format {%.6g} [.s fraction 4 178] } {0.993711} test scrollbar-3.39 {ScrollbarWidgetCmd procedure, "fraction" option} {testmetrics win} { - expr \ - [format {%.6g} [.s fraction 4 [expr 200 - [testmetrics cyvscroll .s] - 2]]] \ - == [format %g [expr (200.0 - [testmetrics cyvscroll .s]*2 - 2) \ - / ($height - 1 - [testmetrics cyvscroll .s]*2)]] + expr { + [format {%.6g} [.s fraction 4 [expr {200 - [testmetrics cyvscroll .s] - 2}]]] + == [format %g [expr {(200.0 - [testmetrics cyvscroll .s]*2 - 2) + / ($height - 1 - [testmetrics cyvscroll .s]*2)}]]} } 1 toplevel .t -width 250 -height 100 @@ -297,13 +297,13 @@ test scrollbar-3.41 {ScrollbarWidgetCmd procedure, "fraction" option} { } {0.5} if {[testConstraint testmetrics]} { # Only Windows has [testmetrics] - place configure .t.s -width [expr 2*[testmetrics cxhscroll .t.s]+1] + place configure .t.s -width [expr {2*[testmetrics cxhscroll .t.s]+1}] } else { if {[tk windowingsystem] eq "x11"} { - place configure .t.s -width [expr [winfo height .t.s] - 2*([.t.s cget -highlightthickness] + [.t.s cget -bd] + 1)] + place configure .t.s -width [expr {[winfo height .t.s] - 2*([.t.s cget -highlightthickness] + [.t.s cget -bd] + 1)}] } else { # macOS aqua - place configure .t.s -width [expr 2*([.t.s cget -highlightthickness] + [.t.s cget -bd])] + place configure .t.s -width [expr {2*([.t.s cget -highlightthickness] + [.t.s cget -bd])}] } } update @@ -473,16 +473,16 @@ test scrollbar-6.6 {ScrollbarPosition procedure} unix { .s identify 19 100 } {} test scrollbar-6.7 {ScrollbarPosition procedure} { - .s identify [expr [winfo width .s] / 2] -1 + .s identify [expr {[winfo width .s] / 2}] -1 } {} test scrollbar-6.8 {ScrollbarPosition procedure} { - .s identify [expr [winfo width .s] / 2] [expr [winfo height .s]] + .s identify [expr {[winfo width .s] / 2}] [winfo height .s] } {} test scrollbar-6.9 {ScrollbarPosition procedure} { - .s identify -1 [expr [winfo height .s] / 2] + .s identify -1 [expr {[winfo height .s] / 2}] } {} test scrollbar-6.10 {ScrollbarPosition procedure} { - .s identify [winfo width .s] [expr [winfo height .s] / 2] + .s identify [winfo width .s] [expr {[winfo height .s] / 2}] } {} test scrollbar-6.11.1 {ScrollbarPosition procedure} x11 { .s identify 8 4 @@ -499,10 +499,10 @@ test scrollbar-6.12.2 {ScrollbarPosition procedure} aqua { .s identify 8 19 } {trough1} test scrollbar-6.14 {ScrollbarPosition procedure} win { - .s identify [expr [winfo width .s] / 2] 0 + .s identify [expr {[winfo width .s] / 2}] 0 } {arrow1} test scrollbar-6.15 {ScrollbarPosition procedure} {testmetrics win} { - .s identify [expr [winfo width .s] / 2] [expr [testmetrics cyvscroll .s] - 1] + .s identify [expr {[winfo width .s] / 2}] [expr {[testmetrics cyvscroll .s] - 1}] } {arrow1} test scrollbar-6.16 {ScrollbarPosition procedure} unix { .s identify 8 20 @@ -513,11 +513,11 @@ test scrollbar-6.17 {ScrollbarPosition procedure} {unix nonPortable} { .s identify 8 51 } {trough1} test scrollbar-6.18 {ScrollbarPosition procedure} {testmetrics win} { - .s identify [expr [winfo width .s] / 2] [testmetrics cyvscroll .s] + .s identify [expr {[winfo width .s] / 2}] [testmetrics cyvscroll .s] } {trough1} test scrollbar-6.19 {ScrollbarPosition procedure} {testmetrics win} { - .s identify [expr [winfo width .s] / 2] [expr int(.2 / [.s delta 0 1]) \ - + [testmetrics cyvscroll .s] - 1] + .s identify [expr {[winfo width .s] / 2}] [expr {int(.2 / [.s delta 0 1]) + + [testmetrics cyvscroll .s] - 1}] } {trough1} test scrollbar-6.20 {ScrollbarPosition procedure} unix { .s identify 8 52 @@ -528,12 +528,12 @@ test scrollbar-6.21 {ScrollbarPosition procedure} {unix nonPortable} { .s identify 8 83 } {slider} test scrollbar-6.22 {ScrollbarPosition procedure} {testmetrics win} { - .s identify [expr [winfo width .s] / 2] \ - [expr int(.2 / [.s delta 0 1] + 0.5) + [testmetrics cyvscroll .s]] + .s identify [expr {[winfo width .s] / 2}] \ + [expr {int(.2 / [.s delta 0 1] + 0.5) + [testmetrics cyvscroll .s]}] } {slider} test scrollbar-6.23 {ScrollbarPosition procedure} {testmetrics win} { - .s identify [expr [winfo width .s] / 2] [expr int(.4 / [.s delta 0 1]) \ - + [testmetrics cyvscroll .s] - 1] + .s identify [expr {[winfo width .s] / 2}] [expr {int(.4 / [.s delta 0 1]) + + [testmetrics cyvscroll .s] - 1}] } {slider} test scrollbar-6.24 {ScrollbarPosition procedure} unix { .s identify 8 84 @@ -542,12 +542,12 @@ test scrollbar-6.25 {ScrollbarPosition procedure} unix { .s identify 8 179 } {trough2} test scrollbar-6.27 {ScrollbarPosition procedure} {testmetrics win} { - .s identify [expr [winfo width .s] / 2] [expr int(.4 / [.s delta 0 1]) \ - + [testmetrics cyvscroll .s]] + .s identify [expr {[winfo width .s] / 2}] [expr {int(.4 / [.s delta 0 1]) + + [testmetrics cyvscroll .s]}] } {trough2} test scrollbar-6.28 {ScrollbarPosition procedure} {testmetrics win} { - .s identify [expr [winfo width .s] / 2] [expr [winfo height .s] \ - - [testmetrics cyvscroll .s] - 1] + .s identify [expr {[winfo width .s] / 2}] [expr {[winfo height .s] + - [testmetrics cyvscroll .s] - 1}] } {trough2} test scrollbar-6.29.1 {ScrollbarPosition procedure} x11 { .s identify 8 180 @@ -564,11 +564,11 @@ test scrollbar-6.30.2 {ScrollbarPosition procedure} aqua { .s identify 8 195 } {trough2} test scrollbar-6.32 {ScrollbarPosition procedure} {testmetrics win} { - .s identify [expr [winfo width .s] / 2] [expr [winfo height .s] \ - - [testmetrics cyvscroll .s]] + .s identify [expr {[winfo width .s] / 2}] [expr {[winfo height .s] + - [testmetrics cyvscroll .s]}] } {arrow2} test scrollbar-6.33 {ScrollbarPosition procedure} win { - .s identify [expr [winfo width .s] / 2] [expr [winfo height .s] - 1] + .s identify [expr {[winfo width .s] / 2}] [expr {[winfo height .s] - 1}] } {arrow2} test scrollbar-6.34 {ScrollbarPosition procedure} unix { .s identify 4 100 @@ -580,7 +580,7 @@ test scrollbar-6.37 {ScrollbarPosition procedure} win { .s identify 0 100 } {trough2} test scrollbar-6.38 {ScrollbarPosition procedure} win { - .s identify [expr [winfo width .s] - 1] 100 + .s identify [expr {[winfo width .s] - 1}] 100 } {trough2} catch {destroy .t} @@ -599,7 +599,7 @@ test scrollbar-6.39.2 {ScrollbarPosition procedure} aqua { .t.s identify 4 8 } {trough1} test scrollbar-6.40 {ScrollbarPosition procedure} win { - .t.s identify 0 [expr [winfo height .t.s] / 2] + .t.s identify 0 [expr {[winfo height .t.s] / 2}] } {arrow1} test scrollbar-6.41.1 {ScrollbarPosition procedure} x11 { .t.s identify 82 8 @@ -609,14 +609,14 @@ test scrollbar-6.41.2 {ScrollbarPosition procedure} aqua { .t.s identify 82 8 } {trough2} test scrollbar-6.43 {ScrollbarPosition procedure} {testmetrics win} { - .t.s identify [expr int(.4 / [.t.s delta 1 0]) + [testmetrics cxhscroll .t.s] \ - - 1] [expr [winfo height .t.s] / 2] + .t.s identify [expr {int(.4 / [.t.s delta 1 0]) + [testmetrics cxhscroll .t.s] + - 1}] [expr {[winfo height .t.s] / 2}] } {slider} test scrollbar-6.44 {ScrollbarPosition procedure} unix { .t.s identify 100 18 } {trough2} test scrollbar-6.46 {ScrollbarPosition procedure} win { - .t.s identify 100 [expr [winfo height .t.s] - 1] + .t.s identify 100 [expr {[winfo height .t.s] - 1}] } {trough2} test scrollbar-7.1 {EventuallyRedraw} { @@ -645,7 +645,7 @@ test scrollbar-8.1 {TkScrollbarEventProc: recursive deletion} notAqua { .t.f.s set 0 .5 update set result [winfo exists .t.f.s] - event generate .t.f.s <ButtonPress> -button 1 -x [expr [winfo width .t.f.s] / 2] -y 5 + event generate .t.f.s <ButtonPress> -button 1 -x [expr {[winfo width .t.f.s] / 2}] -y 5 event generate .t <ButtonRelease> -button 1 update lappend result [winfo exists .t.f.s] [winfo exists .t.f] @@ -666,7 +666,7 @@ test scrollbar-8.2 {TkScrollbarEventProc: recursive deletion} notAqua { .t.f.s set 0 .5 update set result [winfo exists .t.f.s] - event generate .t.f.s <ButtonPress> -button 1 -x [expr [winfo width .t.f.s] / 2] -y 5 + event generate .t.f.s <ButtonPress> -button 1 -x [expr {[winfo width .t.f.s] / 2}] -y 5 event generate .t.f <ButtonRelease> -button 1 update lappend result [winfo exists .t.f.s] [winfo exists .t.f] diff --git a/tests/select.test b/tests/select.test index 5949b9c..f89a736 100644 --- a/tests/select.test +++ b/tests/select.test @@ -36,7 +36,7 @@ proc handler {type offset count} { if {$numBytes <= 0} { return "" } - string range $selValue $offset [expr $numBytes+$offset] + string range $selValue $offset [expr {$numBytes+$offset}] } proc errIncrHandler {type offset count} { @@ -55,7 +55,7 @@ proc errIncrHandler {type offset count} { if {$numBytes <= 0} { return "" } - string range $selValue $offset [expr $numBytes+$offset] + string range $selValue $offset [expr {$numBytes+$offset}] } proc errHandler args { @@ -70,7 +70,7 @@ proc badHandler {path type offset count} { if {$numBytes <= 0} { return "" } - string range $selValue $offset [expr $numBytes+$offset] + string range $selValue $offset [expr {$numBytes+$offset}] } proc reallyBadHandler {path type offset count} { global selValue selInfo pass @@ -86,7 +86,7 @@ proc reallyBadHandler {path type offset count} { if {$numBytes <= 0} { return "" } - string range $selValue $offset [expr $numBytes+$offset] + string range $selValue $offset [expr {$numBytes+$offset}] } # Eliminate any existing selection on the screen. This is needed in case @@ -1147,7 +1147,7 @@ test select-13.1 {SelectionSize procedure, handler deleted} -constraints { if {$numBytes <= 0} { return "" } - string range $selValue $offset [expr $numBytes+$offset] + string range $selValue $offset [expr {$numBytes+$offset}] } set selValue $longValue set selInfo "" diff --git a/tests/text.test b/tests/text.test index be25ca6..5b2d7e3 100644 --- a/tests/text.test +++ b/tests/text.test @@ -2686,7 +2686,7 @@ test text-9.2.45 {TextWidgetCmd procedure, "count" option} -setup { set res {} } -body { for {set i 1} {$i < 5} {incr i} { - .t insert end "Line $i+++Line $i---Line $i///Line $i - This is Line [format %c [expr 64+$i]]\n" + .t insert end "Line $i+++Line $i---Line $i///Line $i - This is Line [format %c [expr {64+$i}]]\n" } .t tag configure hidden -elide true .t tag add hidden 2.15 3.10 @@ -2708,7 +2708,7 @@ test text-9.2.46 {TextWidgetCmd procedure, "count" option} -setup { for {set i 1} {$i < 5} {incr i} { # 0 1 2 3 4 # 012345 678901234 567890123 456789012 34567890123456789 - .mytop.t insert end "Line $i+++Line $i---Line $i///Line $i - This is Line [format %c [expr 64+$i]]\n" + .mytop.t insert end "Line $i+++Line $i---Line $i///Line $i - This is Line [format %c [expr {64+$i}]]\n" } .mytop.t tag configure hidden -elide true .mytop.t tag add hidden 2.30 3.10 @@ -6133,9 +6133,9 @@ test text-23.4 {TkTextGetTabs procedure} -setup { .t insert end "1\t2\t3\t4\t55.5" .t configure -tabs {100 right 200 left 300 center 400 numeric} update idletasks - list [expr [lindex [.t bbox 1.2] 0] + [lindex [.t bbox 1.2] 2]] \ + list [expr {[lindex [.t bbox 1.2] 0] + [lindex [.t bbox 1.2] 2]}] \ [lindex [.t bbox 1.4] 0] \ - [expr [lindex [.t bbox 1.6] 0] + [lindex [.t bbox 1.6] 2]/2] \ + [expr {[lindex [.t bbox 1.6] 0] + [lindex [.t bbox 1.6] 2]/2}] \ [lindex [.t bbox 1.10] 0] } -cleanup { destroy .t @@ -6147,9 +6147,9 @@ test text-23.5 {TkTextGetTabs procedure} -setup { .t insert end "1\t2\t3\t4\t55.5" .t configure -tabs {105 r 205 l 305 c 405 n} update idletasks - list [expr [lindex [.t bbox 1.2] 0] + [lindex [.t bbox 1.2] 2]] \ + list [expr {[lindex [.t bbox 1.2] 0] + [lindex [.t bbox 1.2] 2]}] \ [lindex [.t bbox 1.4] 0] \ - [expr [lindex [.t bbox 1.6] 0] + [lindex [.t bbox 1.6] 2]/2] \ + [expr {[lindex [.t bbox 1.6] 0] + [lindex [.t bbox 1.6] 2]/2}] \ [lindex [.t bbox 1.10] 0] } -cleanup { destroy .t diff --git a/tests/textBTree.test b/tests/textBTree.test index ebd6c50..fd97afa 100644 --- a/tests/textBTree.test +++ b/tests/textBTree.test @@ -422,8 +422,8 @@ test btree-6.5 {very large deletes, with tags} -setup { setup .t insert 1.1 $bigText2 for {set i 0} {$i < 100} {incr i} { - set j [expr $i+2] - set k [expr 1+2*$i] + set j [expr {$i+2}] + set k [expr {1+2*$i}] .t tag add x $j.1 $j.3 .t tag add y $k.1 $k.6 } @@ -439,13 +439,13 @@ test btree-6.6 {very large deletes, with tags} -setup { setup .t insert 1.1 $bigText2 for {set i 0} {$i < 100} {incr i} { - set j [expr $i+2] - set k [expr 1+2*$i] + set j [expr {$i+2}] + set k [expr {1+2*$i}] .t tag add x $j.1 $j.3 .t tag add y $k.1 $k.6 } for {set i 199} {$i >= 2} {incr i -1} { - .t delete $i.0 [expr $i+1].0 + .t delete $i.0 [expr {$i+1}].0 } list [.t tag ranges x] [.t tag ranges y] } -result {{3.0 3.1 3.4 3.12 4.2 4.6} {1.1 1.6 3.4 3.5}} diff --git a/tests/textDisp.test b/tests/textDisp.test index 208f664..7245e91 100644 --- a/tests/textDisp.test +++ b/tests/textDisp.test @@ -230,7 +230,7 @@ test textDisp-2.1 {LayoutDLine, basics} { .t delete 1.0 end .t insert 1.0 "This is some sample text for testing." list [.t bbox 1.19] [.t bbox 1.20] -} [list [list [expr 5 + $fixedWidth * 19] 5 $fixedWidth $fixedHeight] [list 5 [expr 5 + $fixedHeight] $fixedWidth $fixedHeight]] +} [list [list [expr {5 + $fixedWidth * 19}] 5 $fixedWidth $fixedHeight] [list 5 [expr {5 + $fixedHeight}] $fixedWidth $fixedHeight]] test textDisp-2.2 {LayoutDLine, basics} {textfonts} { .t configure -wrap char .t delete 1.0 end @@ -274,7 +274,7 @@ foreach m [.t mark names] { } scan [wm geom .] %dx%d width height test textDisp-2.8 {LayoutDLine, extra chunk at end of dline} {textfonts} { - wm geom . [expr $width+1]x$height + wm geom . [expr {$width+1}]x$height update .t configure -wrap char .t delete 1.0 end @@ -414,22 +414,22 @@ test textDisp-2.22 {LayoutDLine, spacing options} {textfonts} { .t insert end "to wrap around a couple of times" .t insert end "\nLine 3\nLine 4" set i [.t dlineinfo 1.0] - set b1 [expr [lindex $i 1] + [lindex $i 4]] + set b1 [expr {[lindex $i 1] + [lindex $i 4]}] set i [.t dlineinfo 2.0] - set b2 [expr [lindex $i 1] + [lindex $i 4]] + set b2 [expr {[lindex $i 1] + [lindex $i 4]}] set i [.t dlineinfo 2.end] - set b3 [expr [lindex $i 1] + [lindex $i 4]] + set b3 [expr {[lindex $i 1] + [lindex $i 4]}] set i [.t dlineinfo 3.0] - set b4 [expr [lindex $i 1] + [lindex $i 4]] + set b4 [expr {[lindex $i 1] + [lindex $i 4]}] .t configure -spacing1 2 -spacing2 1 -spacing3 3 set i [.t dlineinfo 1.0] - set b1 [expr [lindex $i 1] + [lindex $i 4] - $b1] + set b1 [expr {[lindex $i 1] + [lindex $i 4] - $b1}] set i [.t dlineinfo 2.0] - set b2 [expr [lindex $i 1] + [lindex $i 4] - $b2] + set b2 [expr {[lindex $i 1] + [lindex $i 4] - $b2}] set i [.t dlineinfo 2.end] - set b3 [expr [lindex $i 1] + [lindex $i 4] - $b3] + set b3 [expr {[lindex $i 1] + [lindex $i 4] - $b3}] set i [.t dlineinfo 3.0] - set b4 [expr [lindex $i 1] + [lindex $i 4] - $b4] + set b4 [expr {[lindex $i 1] + [lindex $i 4] - $b4}] list $b1 $b2 $b3 $b4 } [list 2 7 10 15] .t configure -spacing1 0 -spacing2 0 -spacing3 0 @@ -441,13 +441,13 @@ test textDisp-2.23 {LayoutDLine, spacing options} {textfonts} { .t insert end "to wrap around a couple of times" .t insert end "\nLine 3\nLine 4" set i [.t dlineinfo 1.0] - set b1 [expr [lindex $i 1] + [lindex $i 4]] + set b1 [expr {[lindex $i 1] + [lindex $i 4]}] set i [.t dlineinfo 2.0] - set b2 [expr [lindex $i 1] + [lindex $i 4]] + set b2 [expr {[lindex $i 1] + [lindex $i 4]}] set i [.t dlineinfo 2.end] - set b3 [expr [lindex $i 1] + [lindex $i 4]] + set b3 [expr {[lindex $i 1] + [lindex $i 4]}] set i [.t dlineinfo 3.0] - set b4 [expr [lindex $i 1] + [lindex $i 4]] + set b4 [expr {[lindex $i 1] + [lindex $i 4]}] .t configure -spacing1 4 -spacing2 4 -spacing3 4 .t tag configure x -spacing1 1 -spacing2 2 -spacing3 3 .t tag add x 1.0 end @@ -455,13 +455,13 @@ test textDisp-2.23 {LayoutDLine, spacing options} {textfonts} { .t tag add y 2.19 end .t tag raise y set i [.t dlineinfo 1.0] - set b1 [expr [lindex $i 1] + [lindex $i 4] - $b1] + set b1 [expr {[lindex $i 1] + [lindex $i 4] - $b1}] set i [.t dlineinfo 2.0] - set b2 [expr [lindex $i 1] + [lindex $i 4] - $b2] + set b2 [expr {[lindex $i 1] + [lindex $i 4] - $b2}] set i [.t dlineinfo 2.end] - set b3 [expr [lindex $i 1] + [lindex $i 4] - $b3] + set b3 [expr {[lindex $i 1] + [lindex $i 4] - $b3}] set i [.t dlineinfo 3.0] - set b4 [expr [lindex $i 1] + [lindex $i 4] - $b4] + set b4 [expr {[lindex $i 1] + [lindex $i 4] - $b4}] list $b1 $b2 $b3 $b4 } [list 1 5 13 16] .t configure -spacing1 0 -spacing2 0 -spacing3 0 @@ -1343,7 +1343,7 @@ test textDisp-9.13 {TkTextRedrawTag} { .t configure -wrap none .t delete 1.0 end for {set i 1} {$i < 10} {incr i} { - .t insert end "Line $i - This is Line [format %c [expr 64+$i]]\n" + .t insert end "Line $i - This is Line [format %c [expr {64+$i}]]\n" } .t tag add hidden 2.8 2.17 .t tag add hidden 6.8 7.17 @@ -1514,7 +1514,7 @@ test textDisp-11.13 {TkTestSetYView, partially visible last line} { } update scan [wm geometry .top] "%dx%d" w2 h2 - wm geometry .top ${w2}x[expr $h2-2] + wm geometry .top ${w2}x[expr {$h2-2}] update .top.t yview 1.0 update @@ -1745,7 +1745,7 @@ test textDisp-13.8 {TkTextSeeCmd procedure} {textfonts} { lappend x [.t bbox 30.90] } [list [list 73 [expr {9*$fixedDiff/2 + 64}] 7 $fixedHeight] [list 136 [expr {9*$fixedDiff/2 + 64}] 7 $fixedHeight] [list 136 [expr {9*$fixedDiff/2 + 64}] 7 $fixedHeight] [list 73 [expr {9*$fixedDiff/2 + 64}] 7 $fixedHeight]] test textDisp-13.9 {TkTextSeeCmd procedure} {textfonts} { - wm geom . [expr $width-2]x$height + wm geom . [expr {$width-2}]x$height .t xview moveto 0 .t yview moveto 0 .t tag add sel 30.20 @@ -2136,7 +2136,7 @@ test textDisp-16.28 {TkTextYviewCmd procedure, "scroll" option, forward pages} { .t yview 98.0 update .t yview scroll 1 page - set res [expr int([.t index @0,0])] + set res [expr {int([.t index @0,0])}] if {$fixedDiff > 1} { incr res -1 } @@ -2292,7 +2292,7 @@ test textDisp-16.44 {TkTextYviewCmd procedure, scroll down, with elided lines} { } .t tag configure hidden -elide true ; # 5 hidden lines update - .t see [expr {5 + [winfo height .t] / $fixedHeight} + 1].0 + .t see [expr {5 + [winfo height .t] / $fixedHeight + 1}].0 update .t index @0,0 } {2.0} @@ -2743,7 +2743,7 @@ test textDisp-19.12 {GetYView procedure, partially visible last line} { # Need to wait for asychronous calculations to complete. update ; after 10 scan [wm geom .top] %dx%d twidth theight - wm geom .top ${twidth}x[expr $theight - 3] + wm geom .top ${twidth}x[expr {$theight - 3}] update .top.t yview } [list 0.0 [expr {(5.0 * $fixedHeight - 3.0)/ (5.0 * $fixedHeight)}]] @@ -2757,7 +2757,7 @@ test textDisp-19.13 {GetYView procedure, partially visible last line} {textfonts # Need to wait for asychronous calculations to complete. update ; after 10 scan [wm geom .top] %dx%d twidth theight - wm geom .top ${twidth}x[expr $theight - 3] + wm geom .top ${twidth}x[expr {$theight - 3}] update .top.t yview } [list 0.0 [expr {(5.0 * $fixedHeight - 3.0)/ (5.0 * $fixedHeight)}]] @@ -2992,21 +2992,21 @@ test textDisp-22.2 {TkTextCharBbox} {textfonts} { test textDisp-22.3 {TkTextCharBbox, cut-off lines} {textfonts} { .t config -wrap char .t yview 10.0 - wm geom . ${width}x[expr $height-1] + wm geom . ${width}x[expr {$height-1}] update list [.t bbox 19.1] [.t bbox 20.1] } [list [list 10 [expr {3+9*$fixedHeight}] 7 $fixedHeight] [list 10 [expr {3+10*$fixedHeight}] 7 3]] test textDisp-22.4 {TkTextCharBbox, cut-off lines} {textfonts} { .t config -wrap char .t yview 10.0 - wm geom . ${width}x[expr $height+1] + wm geom . ${width}x[expr {$height+1}] update list [.t bbox 19.1] [.t bbox 20.1] } [list [list 10 [expr {3+9*$fixedHeight}] 7 $fixedHeight] [list 10 [expr {3+10*$fixedHeight}] 7 5]] test textDisp-22.5 {TkTextCharBbox, cut-off char} {textfonts} { .t config -wrap none .t yview 10.0 - wm geom . [expr $width-95]x$height + wm geom . [expr {$width-95}]x$height update .t bbox 15.6 } [list 45 [expr {3+5*$fixedHeight}] 7 $fixedHeight] @@ -3014,7 +3014,7 @@ test textDisp-22.6 {TkTextCharBbox, line visible but not char} {textfonts} { .t config -wrap char .t yview 10.0 .t tag add big 20.2 20.5 - wm geom . ${width}x[expr $height+3] + wm geom . ${width}x[expr {$height+3}] update list [.t bbox 19.1] [.t bbox 20.1] [.t bbox 20.2] } [list [list 10 [expr {3+9*$fixedHeight}] 7 $fixedHeight] {} [list 17 [expr {3+10*$fixedHeight}] 14 7]] @@ -3060,7 +3060,7 @@ test textDisp-22.10 {TkTextCharBbox, handling of elided lines} {textfonts} { .t configure -wrap char .t delete 1.0 end for {set i 1} {$i < 10} {incr i} { - .t insert end "Line $i - Line [format %c [expr 64+$i]]\n" + .t insert end "Line $i - Line [format %c [expr {64+$i}]]\n" } .t tag add hidden 2.8 2.13 .t tag add hidden 6.8 7.13 @@ -3083,7 +3083,7 @@ test textDisp-22.11 {TkTextCharBbox, handling of wrapped elided lines} {textfont .t configure -wrap char .t delete 1.0 end for {set i 1} {$i < 10} {incr i} { - .t insert end "Line $i - Line _$i - Lines .$i - Line [format %c [expr 64+$i]]\n" + .t insert end "Line $i - Line _$i - Lines .$i - Line [format %c [expr {64+$i}]]\n" } .t tag add hidden 1.30 2.5 .t tag configure hidden -elide true @@ -3124,14 +3124,14 @@ test textDisp-23.3 {TkTextDLineInfo} {textfonts} { test textDisp-23.4 {TkTextDLineInfo, cut-off lines} {textfonts} { .t config -wrap char .t yview 10.0 - wm geom . ${width}x[expr $height-1] + wm geom . ${width}x[expr {$height-1}] update list [.t dlineinfo 19.0] [.t dlineinfo 20.0] } [list [list 3 [expr {9*$fixedDiff + 120}] 49 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 3 [expr {10*$fixedDiff + 133}] 49 3 [expr {$fixedDiff + 10}]]] test textDisp-23.5 {TkTextDLineInfo, cut-off lines} {textfonts} { .t config -wrap char .t yview 10.0 - wm geom . ${width}x[expr $height+1] + wm geom . ${width}x[expr {$height+1}] update list [.t dlineinfo 19.0] [.t dlineinfo 20.0] } [list [list 3 [expr {9*$fixedDiff + 120}] 49 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 3 [expr {10*$fixedDiff + 133}] 49 5 [expr {$fixedDiff + 10}]]] @@ -3172,7 +3172,7 @@ test textDisp-24.2 {TkTextCharLayoutProc} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "abcdefghijklmnopqrstuvwxyz" - wm geom . [expr $width+1]x$height + wm geom . [expr {$width+1}]x$height update list [.t bbox 1.19] [.t bbox 1.20] } [list [list 136 3 12 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]] @@ -3180,7 +3180,7 @@ test textDisp-24.3 {TkTextCharLayoutProc} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "abcdefghijklmnopqrstuvwxyz" - wm geom . [expr $width-1]x$height + wm geom . [expr {$width-1}]x$height update list [.t bbox 1.19] [.t bbox 1.20] } [list [list 136 3 10 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]] @@ -3212,7 +3212,7 @@ test textDisp-24.7 {TkTextCharLayoutProc, line ends with space} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "a b c d e f g h i j k l m n o p" - wm geom . [expr $width+1]x$height + wm geom . [expr {$width+1}]x$height update list [.t bbox 1.19] [.t bbox 1.20] } [list [list 136 3 12 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]] @@ -3220,7 +3220,7 @@ test textDisp-24.8 {TkTextCharLayoutProc, line ends with space} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "a b c d e f g h i j k l m n o p" - wm geom . [expr $width-1]x$height + wm geom . [expr {$width-1}]x$height update list [.t bbox 1.19] [.t bbox 1.20] } [list [list 136 3 10 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]] @@ -3228,7 +3228,7 @@ test textDisp-24.9 {TkTextCharLayoutProc, line ends with space} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "a b c d e f g h i j k l m n o p" - wm geom . [expr $width-6]x$height + wm geom . [expr {$width-6}]x$height update list [.t bbox 1.19] [.t bbox 1.20] } [list [list 136 3 5 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]] @@ -3236,7 +3236,7 @@ test textDisp-24.10 {TkTextCharLayoutProc, line ends with space} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "a b c d e f g h i j k l m n o p" - wm geom . [expr $width-7]x$height + wm geom . [expr {$width-7}]x$height update list [.t bbox 1.19] [.t bbox 1.20] } [list [list 136 3 4 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]] @@ -3244,7 +3244,7 @@ test textDisp-24.11 {TkTextCharLayoutProc, line ends with space that doesn't qui .t configure -wrap char .t delete 1.0 end .t insert 1.0 "01234567890123456789 \nabcdefg" - wm geom . [expr $width-2]x$height + wm geom . [expr {$width-2}]x$height update set result {} lappend result [.t bbox 1.21] [.t bbox 2.0] @@ -3271,7 +3271,7 @@ test textDisp-24.14 {TkTextCharLayoutProc, -wrap none} {textfonts} { .t configure -wrap none .t delete 1.0 end .t insert 1.0 "abcdefghijklmnopqrstuvwxyz" - wm geom . [expr $width+1]x$height + wm geom . [expr {$width+1}]x$height update list [.t bbox 1.19] [.t bbox 1.20] } [list [list 136 3 7 $fixedHeight] [list 143 3 5 $fixedHeight]] @@ -3279,7 +3279,7 @@ test textDisp-24.15 {TkTextCharLayoutProc, -wrap none} {textfonts} { .t configure -wrap none .t delete 1.0 end .t insert 1.0 "abcdefghijklmnopqrstuvwxyz" - wm geom . [expr $width-1]x$height + wm geom . [expr {$width-1}]x$height update list [.t bbox 1.19] [.t bbox 1.20] } [list [list 136 3 7 $fixedHeight] [list 143 3 3 $fixedHeight]] @@ -3428,9 +3428,9 @@ test textDisp-26.3 {AdjustForTab procedure, not enough tabs specified} { .t tag configure x -tabs {40 70 right} .t tag add x 1.0 end list [lindex [.t bbox 1.2] 0] \ - [expr [lindex [.t bbox 1.4] 0] + [lindex [.t bbox 1.4] 2]] \ - [expr [lindex [.t bbox 1.6] 0] + [lindex [.t bbox 1.6] 2]] \ - [expr [lindex [.t bbox 1.8] 0] + [lindex [.t bbox 1.8] 2]] + [expr {[lindex [.t bbox 1.4] 0] + [lindex [.t bbox 1.4] 2]}] \ + [expr {[lindex [.t bbox 1.6] 0] + [lindex [.t bbox 1.6] 2]}] \ + [expr {[lindex [.t bbox 1.8] 0] + [lindex [.t bbox 1.8] 2]}] } [list 40 70 100 130] test textDisp-26.4 {AdjustForTab procedure, different alignments} { .t delete 1.0 end diff --git a/tests/textTag.test b/tests/textTag.test index 9bab5fb..5761abc 100644 --- a/tests/textTag.test +++ b/tests/textTag.test @@ -1477,14 +1477,14 @@ test textTag-14.4 {SortTags} -constraints haveCourier12 -setup { set c [.t bbox 2.1] -set x1 [expr [lindex $c 0] + [lindex $c 2]/2] -set y1 [expr [lindex $c 1] + [lindex $c 3]/2] +set x1 [expr {[lindex $c 0] + [lindex $c 2]/2}] +set y1 [expr {[lindex $c 1] + [lindex $c 3]/2}] set c [.t bbox 3.2] -set x2 [expr [lindex $c 0] + [lindex $c 2]/2] -set y2 [expr [lindex $c 1] + [lindex $c 3]/2] +set x2 [expr {[lindex $c 0] + [lindex $c 2]/2}] +set y2 [expr {[lindex $c 1] + [lindex $c 3]/2}] set c [.t bbox 4.3] -set x3 [expr [lindex $c 0] + [lindex $c 2]/2] -set y3 [expr [lindex $c 1] + [lindex $c 3]/2] +set x3 [expr {[lindex $c 0] + [lindex $c 2]/2}] +set y3 [expr {[lindex $c 1] + [lindex $c 3]/2}] test textTag-15.1 {TkTextBindProc} -constraints haveCourier12 -setup { .t tag delete x y diff --git a/tests/ttk/combobox.test b/tests/ttk/combobox.test index 7ea0c5c..45fe0fc 100644 --- a/tests/ttk/combobox.test +++ b/tests/ttk/combobox.test @@ -43,6 +43,17 @@ test combobox-2.4 "current -- value not in list" -body { .cb current } -result -1 +test combobox-2.5 "current -- set to end index" -body { + .cb configure -values [list a b c d e thelastone] + .cb current end + .cb get +} -result thelastone + +test combobox-2.6 "current -- set to unknown index" -body { + .cb configure -values [list a b c d e] + .cb current notanindex +} -returnCodes error -result {Incorrect index notanindex} + test combobox-2.end "Cleanup" -body { destroy .cb } test combobox-3 "Read postoffset value dynamically from current style" -body { diff --git a/tests/ttk/treeview.test b/tests/ttk/treeview.test index a36e3d1..43a6527 100644 --- a/tests/ttk/treeview.test +++ b/tests/ttk/treeview.test @@ -459,6 +459,31 @@ test treeview-8.5 "Selection - bad operation" -body { .tv selection badop foo } -returnCodes 1 -match glob -result {bad selection operation "badop": must be *} +test treeview-8.6 "Selection - <<TreeviewSelect>> on selection add" -body { + .tv selection set {} + bind .tv <<TreeviewSelect>> {set res 1} + set res 0 + .tv selection add newnode.n1 + update + set res +} -result {1} + +test treeview-8.7 "<<TreeviewSelect>> on selected item deletion" -body { + .tv selection set {} + .tv insert "" end -id selectedDoomed -text DeadItem + .tv insert "" end -id doomed -text AlsoDead + .tv selection add selectedDoomed + update + bind .tv <<TreeviewSelect>> {lappend res 1} + set res 0 + .tv delete doomed + update + set res [expr {$res == 0}] + .tv delete selectedDoomed + update + set res +} -result {1 1} + ### NEED: more tests for see/yview/scrolling proc scrollcallback {args} { @@ -658,11 +683,101 @@ test treeview-368fa4561e "indicators cannot be clicked on leafs" -setup { # using $h even for x computation is intentional here in order to simulate # a mouse click on the (invisible since we're on a leaf) indicator event generate .tv <ButtonPress-1> \ - -x [expr ($x + $h / 2)] \ - -y [expr ($y + $h / 2)] + -x [expr {$x + $h / 2}] \ + -y [expr {$y + $h / 2}] lappend res [.tv item foo -open] .tv insert foo end -text "sub" lappend res [.tv item foo -open] +} -cleanup { + destroy .tv } -result {0 0 0} +test treeview-ce470f20fd-1 "dragging further than the right edge of the treeview is forbidden" -setup { + pack [ttk::treeview .tv] + .tv heading #0 -text "Drag my right edge -->" + update +} -body { + set res [.tv column #0 -width] + .tv drag #0 400 + lappend res [expr {[.tv column #0 -width] > $res}] +} -cleanup { + destroy .tv +} -result {200 0} + +proc nostretch {tv} { + foreach col [$tv cget -columns] { + $tv column $col -stretch 0 + } + $tv column #0 -stretch 0 + update idletasks ; # redisplay $tv +} + +test treeview-ce470f20fd-2 "changing -stretch resizes columns" -setup { + pack [ttk::treeview .tv -columns {bar colA colB colC foo}] + foreach col [.tv cget -columns] { + .tv heading $col -text $col + } + nostretch .tv + .tv column colA -width 50 ; .tv column colB -width 50 ; # slack created + update idletasks ; # redisplay treeview +} -body { + # when no column is stretchable and one of them becomes stretchable + # the stretchable column takes the slack and the widget is redisplayed + # automatically at idle time + set res [.tv column colA -width] + .tv column colA -stretch 1 + update idletasks ; # no slack anymore, widget redisplayed + lappend res [expr {[.tv column colA -width] > $res}] +} -cleanup { + destroy .tv +} -result {50 1} + +test treeview-ce470f20fd-3 "changing -stretch resizes columns" -setup { + pack [ttk::treeview .tv -columns {bar colA colB colC foo}] + foreach col [.tv cget -columns] { + .tv heading $col -text $col + } + .tv configure -displaycolumns {colB colA colC} + nostretch .tv + .tv column colA -width 50 ; .tv column colB -width 50 ; # slack created + update idletasks ; # redisplay treeview +} -body { + # only some columns are displayed (and in a different order than declared + # in -columns), a displayed column becomes stretchable --> the stretchable + # column expands + set res [.tv column colA -width] + .tv column colA -stretch 1 + update idletasks ; # no slack anymore, widget redisplayed + lappend res [expr {[.tv column colA -width] > $res}] +} -cleanup { + destroy .tv +} -result {50 1} + +test treeview-ce470f20fd-4 "changing -stretch resizes columns" -setup { + pack [ttk::treeview .tv -columns {bar colA colB colC foo}] + foreach col [.tv cget -columns] { + .tv heading $col -text $col + } + .tv configure -displaycolumns {colB colA colC} + nostretch .tv + .tv column colA -width 50 ; .tv column bar -width 60 ; # slack created + update idletasks ; # redisplay treeview +} -body { + # only some columns are displayed (and in a different order than declared + # in -columns), a non-displayed column becomes stretchable --> nothing + # happens + set origTreeWidth [winfo width .tv] + set res [list [.tv column bar -width] [.tv column colA -width]] + .tv column bar -stretch 1 + update idletasks ; # no change, widget redisplayed + lappend res [.tv column bar -width] [.tv column colA -width] + # this column becomes visible --> widget resizes + .tv configure -displaycolumns {bar colC colA colB} + update idletasks ; # no slack anymore because the widget resizes (shrinks) + lappend res [.tv column bar -width] [.tv column colA -width] \ + [expr {[winfo width .tv] < $origTreeWidth}] +} -cleanup { + destroy .tv +} -result {60 50 60 50 60 50 1} + tcltest::cleanupTests diff --git a/tests/ttk/ttk.test b/tests/ttk/ttk.test index e58b021..a1560b4 100644 --- a/tests/ttk/ttk.test +++ b/tests/ttk/ttk.test @@ -269,7 +269,7 @@ test ttk-3.4 "SF#2009213" -body { test ttk-4.0 "Setup" -body { catch { destroy .t } pack [ttk::label .t -text "Button 1"] - testConstraint fontOption [expr ![catch { set prevFont [.t cget -font] }]] + testConstraint fontOption [expr {![catch { set prevFont [.t cget -font] }]}] ok } diff --git a/tests/unixEmbed.test b/tests/unixEmbed.test index a29995f..c2dc073 100644 --- a/tests/unixEmbed.test +++ b/tests/unixEmbed.test @@ -983,8 +983,10 @@ test unixEmbed-7.1 {TkpRedirectKeyEvent procedure, forward keystroke} -constrain deleteWindows bind . <KeyPress> {} } -result {{{key a 1}} {}} +# TkpRedirectKeyEvent is not implemented in win or aqua. If someone +# implements it they should change the constraints for this test. test unixEmbed-7.1a {TkpRedirectKeyEvent procedure, forward keystroke} -constraints { - unix + unix notAqua } -setup { deleteWindows catch {interp delete slave} diff --git a/tests/unixFont.test b/tests/unixFont.test index a4dbaa5..177dab5 100644 --- a/tests/unixFont.test +++ b/tests/unixFont.test @@ -1,4 +1,4 @@ -# This file is a Tcl script to test out the procedures in tkUnixFont.c. +# This file is a Tcl script to test out the procedures in tkUnixFont.c. # It is organized in the standard fashion for Tcl tests. # # Many of these tests are visually oriented and cannot be checked @@ -6,7 +6,7 @@ # underlined?"); these tests attempt to exercise the code in question, # but there are no results that can be checked. Some tests depend on the # fonts having or not having certain properties, which may not be valid -# at all sites. +# at all sites. # # Copyright (c) 1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. @@ -124,7 +124,7 @@ test unixfont-2.11 {TkpGetFontFromAttributes: font cannot be loaded} x11 { font actual {-size 14} set x {} -} {} +} {} test unixfont-3.1 {TkpDeleteFont procedure} x11 { font actual {-family xyz} diff --git a/tests/unixWm.test b/tests/unixWm.test index c147bbf..28c8159 100644 --- a/tests/unixWm.test +++ b/tests/unixWm.test @@ -658,7 +658,7 @@ test unixWm-17.2 {Tk_WmCmd procedure, "focusmodel" option} unix { list [catch {wm focusmodel .t bogus} msg] $msg } {1 {bad argument "bogus": must be active or passive}} test unixWm-17.3 {Tk_WmCmd procedure, "focusmodel" option} unix { - set result {} + set result {} lappend result [wm focusmodel .t] wm focusmodel .t active lappend result [wm focusmodel .t] @@ -824,7 +824,7 @@ test unixWm-22.2 {Tk_WmCmd procedure, "iconbitmap" option} {unix testwrapper} { lappend result [wm iconbitmap .t] $bit } {{} questhead 0x4 {} 0x0} if {[tk windowingsystem] == "aqua"} { - set result_22_3 {0 {}} + set result_22_3 {0 {}} } else { set result_22_3 {1 {bitmap "bad-bitmap" not defined}} } @@ -1364,7 +1364,7 @@ test unixWm-40.1 {Tk_SetGrid procedure, set grid dimensions before turning on gr destroy .t toplevel .t wm geometry .t 30x10+0+0 - listbox .t.l -height 20 -width 20 -setgrid 1 + listbox .t.l -height 20 -width 20 -setgrid 1 pack .t.l -fill both -expand 1 update wm geometry .t @@ -1373,7 +1373,7 @@ test unixWm-40.2 {Tk_SetGrid procedure, turning on grid when dimensions already destroy .t toplevel .t wm geometry .t 200x100+0+$Y0 - listbox .t.l -height 20 -width 20 + listbox .t.l -height 20 -width 20 pack .t.l -fill both -expand 1 update .t.l configure -setgrid 1 @@ -1790,14 +1790,14 @@ test unixWm-49.2 {Tk_GetRootCoords procedure, menubars} {unix testmenubar} { testmenubar window .t .t.m update list [expr [winfo rootx .t.m.f] - $x] [expr [winfo rooty .t.m.f] - $y] \ - [expr [winfo rootx .t.f] - $x] [expr [winfo rooty .t.f] - $y] + [expr [winfo rootx .t.f] - $x] [expr [winfo rooty .t.f] - $y] } {52 7 12 62} deleteWindows wm withdraw . if {[tk windowingsystem] == "aqua"} { # Modern mac windows have no border. - set result_50_1 {{} {} .t .t .t2 {} .t2 .t .t} + set result_50_1 {{} {} .t .t .t2 {} .t2 .t .t} } else { # Windows are assumed to have a border (invisible in Gnome 3). set result_50_1 {{} {} .t {} .t2 {} .t2 {} .t} @@ -1851,7 +1851,7 @@ test unixWm-50.3 { } tempNotWin { deleteWindows catch {interp delete slave} - + toplevel .t -width 300 -height 400 -bg blue wm geom .t +100+100 frame .t.f -container 1 -bg red diff --git a/tests/visual.test b/tests/visual.test index 2f5c34a..13d6fd2 100644 --- a/tests/visual.test +++ b/tests/visual.test @@ -29,9 +29,9 @@ proc eatColors {w} { pack $w.c for {set y 0} {$y < 8} {incr y} { for {set x 0} {$x < 40} {incr x} { - set color [format #%02x%02x%02x [expr $x*6] [expr $y*30] 0] - $w.c create rectangle [expr 10*$x] [expr 20*$y] \ - [expr 10*$x + 10] [expr 20*$y + 20] -outline {} \ + set color [format #%02x%02x%02x [expr {$x*6}] [expr {$y*30}] 0] + $w.c create rectangle [expr {10*$x}] [expr {20*$y}] \ + [expr {10*$x + 10}] [expr {20*$y + 20}] -outline {} \ -fill $color } } @@ -50,8 +50,8 @@ proc eatColors {w} { proc colorsFree {w {red 31} {green 245} {blue 192}} { set vals [winfo rgb $w [format #%02x%02x%02x $red $green $blue]] - expr ([lindex $vals 0]/256 == $red) && ([lindex $vals 1]/256 == $green) \ - && ([lindex $vals 2]/256 == $blue) + expr {([lindex $vals 0]/256 == $red) && ([lindex $vals 1]/256 == $green) + && ([lindex $vals 2]/256 == $blue)} } # If more than one visual type is available for the screen, pick one diff --git a/tests/winDialog.test b/tests/winDialog.test index c8c36bf..5c14874 100755 --- a/tests/winDialog.test +++ b/tests/winDialog.test @@ -376,8 +376,8 @@ test winDialog-5.7.5 {GetFileName: extension {} } -constraints { test winDialog-5.7.6 {GetFileName: All/extension } -constraints { nt testwinevent } -body { - # In 8.6.4 this combination resulted in bar.ext.ext which is bad - start {set x [tk_getSaveFile -filetypes {{All *}} -defaultextension {ext} -title Save]} + # In 8.6.4 this combination resulted in bar.aaa.aaa which is bad + start {set x [tk_getSaveFile -filetypes {{All *}} -defaultextension {aaa} -title Save]} set msg {} then { if {[catch {SetText [vista? 0x47C 0x3e9] bar} msg]} { @@ -389,37 +389,37 @@ test winDialog-5.7.6 {GetFileName: All/extension } -constraints { set x "[file tail $x]$msg" } -cleanup { unset msg -} -result bar.ext +} -result bar.aaa test winDialog-5.7.7 {tk_getOpenFile: -defaultextension} -constraints { nt testwinevent } -body { unset -nocomplain x - tcltest::makeFile "" "5 7 7.ext" [initialdir] + tcltest::makeFile "" "5 7 7.aaa" [initialdir] start {set x [tk_getOpenFile \ - -defaultextension ext \ + -defaultextension aaa \ -initialdir [file nativename [initialdir]] \ -initialfile "5 7 7" -title Foo]} then { Click ok } return $x -} -result [file join [initialdir] "5 7 7.ext"] +} -result [file join [initialdir] "5 7 7.aaa"] test winDialog-5.7.8 {tk_getOpenFile: -defaultextension} -constraints { nt testwinevent } -body { unset -nocomplain x - tcltest::makeFile "" "5 7 8.ext" [initialdir] + tcltest::makeFile "" "5 7 8.aaa" [initialdir] start {set x [tk_getOpenFile \ - -defaultextension ext \ + -defaultextension aaa \ -initialdir [file nativename [initialdir]] \ - -initialfile "5 7 8.ext" -title Foo]} + -initialfile "5 7 8.aaa" -title Foo]} then { Click ok } return $x -} -result [file join [initialdir] "5 7 8.ext"] +} -result [file join [initialdir] "5 7 8.aaa"] test winDialog-5.8 {GetFileName: extension doesn't begin with .} -constraints { nt testwinevent diff --git a/tests/winFont.test b/tests/winFont.test index 8039426..377ef41 100644 --- a/tests/winFont.test +++ b/tests/winFont.test @@ -180,7 +180,7 @@ test winfont-5.3 {Tk_MeasureChars procedure: all chars did fit} -constraints { set ax [winfo reqwidth .t.l] set ay [winfo reqheight .t.l] - .t.l config -wrap [expr $ax*10] -text "00000000" + .t.l config -wrap [expr {$ax*10}] -text "00000000" list [expr {[winfo reqwidth .t.l] eq 8*$ax}] \ [expr {[winfo reqheight .t.l] eq $ay}] } -cleanup { @@ -199,7 +199,7 @@ test winfont-5.4 {Tk_MeasureChars procedure: not all chars fit} -constraints { set ax [winfo reqwidth .t.l] set ay [winfo reqheight .t.l] - .t.l config -wrap [expr $ax*6] -text "00000000" + .t.l config -wrap [expr {$ax*6}] -text "00000000" list [expr {[winfo reqwidth .t.l] eq 6*$ax}] \ [expr {[winfo reqheight .t.l] eq 2*$ay}] } -cleanup { @@ -218,7 +218,7 @@ test winfont-5.5 {Tk_MeasureChars procedure: include last partial char} -constra .t.c dchars $t 0 end .t.c insert $t 0 "0000" - .t.c index $t @[expr int($cx*2.5)],1 + .t.c index $t @[expr {int($cx*2.5)}],1 } -cleanup { destroy .t.c } -result {2} @@ -254,7 +254,7 @@ test winfont-5.7 {Tk_MeasureChars procedure: whole words} -constraints { set ax [winfo reqwidth .t.l] set ay [winfo reqheight .t.l] - .t.l config -wrap [expr $ax*8] -text "000000 0000" + .t.l config -wrap [expr {$ax*8}] -text "000000 0000" list [expr {[winfo reqwidth .t.l] eq 6*$ax}] \ [expr {[winfo reqheight .t.l] eq 2*$ay}] } -cleanup { @@ -273,7 +273,7 @@ test winfont-5.8 {Tk_MeasureChars procedure: already saw space in line} -constra set ax [winfo reqwidth .t.l] set ay [winfo reqheight .t.l] - .t.l config -wrap [expr $ax*12] -text "000000 0000000" + .t.l config -wrap [expr {$ax*12}] -text "000000 0000000" list [expr {[winfo reqwidth .t.l] eq 7*$ax}] \ [expr {[winfo reqheight .t.l] eq 2*$ay}] } -cleanup { @@ -292,7 +292,7 @@ test winfont-5.9 {Tk_MeasureChars procedure: internal spaces significant} -const set ax [winfo reqwidth .t.l] set ay [winfo reqheight .t.l] - .t.l config -wrap [expr $ax*12] -text "000 00 00000" + .t.l config -wrap [expr {$ax*12}] -text "000 00 00000" list [expr {[winfo reqwidth .t.l] eq 7*$ax}] \ [expr {[winfo reqheight .t.l] eq 2*$ay}] } -cleanup { @@ -311,7 +311,7 @@ test winfont-5.10 {Tk_MeasureChars procedure: make first part of word fit} -cons set ax [winfo reqwidth .t.l] set ay [winfo reqheight .t.l] - .t.l config -wrap [expr $ax*12] -text "0000000000000000" + .t.l config -wrap [expr {$ax*12}] -text "0000000000000000" list [expr {[winfo reqwidth .t.l] eq 12*$ax}] \ [expr {[winfo reqheight .t.l] eq 2*$ay}] } -cleanup { @@ -334,7 +334,7 @@ test winfont-5.11 {Tk_MeasureChars procedure: check for kerning} -constraints { .t.l config -text "XaYoYaKaWx" set x [lindex [getsize] 0] .t.l config -font $font - expr $x < ($width*10) + expr {$x < ($width*10)} } -cleanup { destroy .t.l } -result {1} diff --git a/tests/winSend.test b/tests/winSend.test index 0f3baf8..31c800e 100644 --- a/tests/winSend.test +++ b/tests/winSend.test @@ -118,8 +118,8 @@ test winSend-2.3 {Tk_SendObjCmd - sending to ourselves in a different interprete } {0 b {}} test winSend-2.4 {Tk_SendObjCmd - sending to ourselves in a different interp with errors} winSend { newApp testApp - list [catch {send testApp {expr 2 / 0}} msg] $msg $errorCode $errorInfo [interp delete testApp] -} "1 {divide by zero} {ARITH DIVZERO {divide by zero}} {divide by zero\n while executing\n\"expr 2 / 0\"\n invoked from within\n\"send testApp {expr 2 / 0}\"} {}" + list [catch {send testApp {expr {2 / 0}}} msg] $msg $errorCode $errorInfo [interp delete testApp] +} "1 {divide by zero} {ARITH DIVZERO {divide by zero}} {divide by zero\n while executing\n\"expr {2 / 0}\"\n invoked from within\n\"send testApp {expr {2 / 0}}\"} {}" test winSend-2.5 {Tk_SendObjCmd - sending to another app async} winSend { set newInterps [winfo interps] foreach interp $newInterps { @@ -145,8 +145,8 @@ test winSend-2.7 {Tk_SendObjCmd - sending to another app - error} winSend { break } } - list [catch {send $interp {expr 2 / 0}} msg] $msg $errorCode $errorInfo -} "1 {divide by zero} {ARITH DIVZERO {divide by zero}} {divide by zero\n while executing\n\"expr 2 / 0\"\n invoked from within\n\"send \$interp {expr 2 / 0}\"}" + list [catch {send $interp {expr {2 / 0}}} msg] $msg $errorCode $errorInfo +} "1 {divide by zero} {ARITH DIVZERO {divide by zero}} {divide by zero\n while executing\n\"expr {2 / 0}\"\n invoked from within\n\"send \$interp {expr {2 / 0}}\"}" test winSend-3.1 {TkGetInterpNames} winSend { set origLength [llength $currentInterps] @@ -170,7 +170,7 @@ test winSend-5.1 {ExecuteRemoteObject - no error} winSend { break } } - list [send $interp {send [tk appname] {expr 2 / 1}}] + list [send $interp {send [tk appname] {expr {2 / 1}}}] } {2} test winSend-5.2 {ExecuteRemoteObject - error} winSend { set newInterps [winfo interps] @@ -179,7 +179,7 @@ test winSend-5.2 {ExecuteRemoteObject - error} winSend { break } } - list [catch {send $interp {send [tk appname] {expr 2 / 0}}} msg] $msg + list [catch {send $interp {send [tk appname] {expr {2 / 0}}}} msg] $msg } {1 {divide by zero}} test winSend-6.1 {SendDDEServer - XTYP_CONNECT} winSend { @@ -246,7 +246,7 @@ test winSend-6.6 {SendDDEServer - XTYP_REQUEST return results} winSend { break } } - set command "send [tk appname] {expr $foo + 1}" + set command "send [tk appname] {expr {$foo + 1}}" list [catch "send \{$interp\} \{$command\}" msg] $msg } {0 4} test winSend-6.7 {SendDDEServer - XTYP_EXECUTE} winSend { @@ -256,7 +256,7 @@ test winSend-6.7 {SendDDEServer - XTYP_EXECUTE} winSend { break } } - set command "send [tk appname] {expr 4 / 2}" + set command "send [tk appname] {expr {4 / 2}}" list [catch "send \{$interp\} \{$command\}" msg] $msg } {0 2} test winSend-6.8 {SendDDEServer - XTYP_WILDCONNECT} winSend { @@ -386,7 +386,7 @@ test winSend-10.17 {Tk_DDEObjCmd - valid variable} winSend { } {0 winSend-10.17} test winSend-10.18 {Tk_DDEObjCmd - services} winSend { set currentService [list Tk [tk appname]] - list [catch {dde services Tk {}} msg] [expr [lsearch $msg $currentService] >= 0] + list [catch {dde services Tk {}} msg] [expr {[lsearch $msg $currentService] >= 0}] } {0 1} # Get rid of the other app and all of its interps diff --git a/tests/winfo.test b/tests/winfo.test index 14c2838..49a92a6 100644 --- a/tests/winfo.test +++ b/tests/winfo.test @@ -27,9 +27,9 @@ proc eatColors {w {options ""}} { pack $w.c for {set y 0} {$y < 8} {incr y} { for {set x 0} {$x < 40} {incr x} { - set color [format #%02x%02x%02x [expr $x*6] [expr $y*30] 0] - $w.c create rectangle [expr 10*$x] [expr 20*$y] \ - [expr 10*$x + 10] [expr 20*$y + 20] -outline {} \ + set color [format #%02x%02x%02x [expr {$x*6}] [expr {$y*30}] 0] + $w.c create rectangle [expr {10*$x}] [expr {20*$y}] \ + [expr {10*$x + 10}] [expr {20*$y + 20}] -outline {} \ -fill $color } } @@ -156,7 +156,7 @@ test winfo-4.6 {"winfo containing" command} -constraints { wm geom .t +0+0 update - winfo containing [expr [winfo rootx .t.f]-1] [expr [winfo rooty .t.f]-1] + winfo containing [expr {[winfo rootx .t.f]-1}] [expr {[winfo rooty .t.f]-1}] } -cleanup { destroy .t } -result .t @@ -169,8 +169,8 @@ test winfo-4.7 {"winfo containing" command} -setup { wm geom .t +0+0 update - set x [winfo containing -display .t.f [expr [winfo rootx .t]+600] \ - [expr [winfo rooty .t.f]+450]] + set x [winfo containing -display .t.f [expr {[winfo rootx .t]+600}] \ + [expr {[winfo rooty .t.f]+450}]] expr {($x == ".") || ($x == "")} } -cleanup { destroy .t @@ -364,7 +364,7 @@ test winfo-11.5 {"winfo visualid" command} -body { } -result {3} test winfo-11.6 {"winfo visualid" command} -body { set x [lindex [lindex [winfo visualsa . includeids] 0] 2] - expr $x + 2 - $x + expr {$x + 2 - $x} } -result {2} @@ -394,6 +394,13 @@ test winfo-13.1 {root coordinates of embedded toplevel} -setup { deleteWindows } -result {rootx 1 rooty 1} +# Windows does not destroy the container when an embedded window is +# destroyed. Unix and macOS do destroy it. See ticket [67384bce7d]. +if {[tk windowingsystem] == "win32"} { + set result_13_2 {embedded 0 container 1} +} else { + set result_13_2 {embedded 0 container 0} +} test winfo-13.2 {destroying embedded toplevel} -setup { deleteWindows } -body { @@ -409,7 +416,7 @@ test winfo-13.2 {destroying embedded toplevel} -setup { list embedded [winfo exists .emb.b] container [winfo exists .con] } -cleanup { deleteWindows -} -result {embedded 0 container 1} +} -result $result_13_2 test winfo-13.3 {destroying container window} -setup { deleteWindows diff --git a/unix/Makefile.in b/unix/Makefile.in index 8b86e00..48e9c3d 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -1570,7 +1570,7 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tkConfig.h.in $(UNIX_DIR)/tk.pc.in $(M cp -p $(GENERIC_DIR)/*.decls $(DISTDIR)/generic cp -p $(GENERIC_DIR)/README $(DISTDIR)/generic cp -p $(TOP_DIR)/changes $(TOP_DIR)/ChangeLog \ - $(TOP_DIR)/ChangeLog.2??? $(TOP_DIR)/README \ + $(TOP_DIR)/ChangeLog.2??? $(TOP_DIR)/README.md \ $(TOP_DIR)/license.terms $(DISTDIR) rm -f $(DISTDIR)/generic/blt*.[ch] mkdir $(DISTDIR)/generic/ttk diff --git a/win/tkWinX.c b/win/tkWinX.c index 3737345..75064b5 100644 --- a/win/tkWinX.c +++ b/win/tkWinX.c @@ -36,6 +36,15 @@ #include <zmouse.h> /* + * WM_MOUSEHWHEEL is normally defined by Winuser.h for Vista/2008 or later, + * but is also usable on 2000/XP if IntelliPoint drivers are installed. + */ + +#ifndef WM_MOUSEHWHEEL +#define WM_MOUSEHWHEEL 0x020E +#endif + +/* * imm.h is needed by HandleIMEComposition */ @@ -82,8 +91,10 @@ typedef struct ThreadSpecificData { * screen. */ int updatingClipboard; /* If 1, we are updating the clipboard. */ int surrogateBuffer; /* Buffer for first of surrogate pair. */ - DWORD wheelTickPrev; /* For high resolution wheels. */ - short wheelAcc; /* For high resolution wheels. */ + DWORD vWheelTickPrev; /* For high resolution wheels (vertical). */ + DWORD hWheelTickPrev; /* For high resolution wheels (horizontal). */ + short vWheelAcc; /* For high resolution wheels (vertical). */ + short hWheelAcc; /* For high resolution wheels (horizontal). */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; @@ -555,6 +566,7 @@ TkpOpenDisplay( Display *display; ThreadSpecificData *tsdPtr = Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); + DWORD initialWheelTick; if (tsdPtr->winDisplay != NULL) { if (!strcmp(tsdPtr->winDisplay->display->display_name, display_name)) { @@ -610,8 +622,11 @@ TkpOpenDisplay( ZeroMemory(tsdPtr->winDisplay, sizeof(TkDisplay)); tsdPtr->winDisplay->display = display; tsdPtr->updatingClipboard = FALSE; - tsdPtr->wheelTickPrev = GetTickCount(); - tsdPtr->wheelAcc = 0; + initialWheelTick = GetTickCount(); + tsdPtr->vWheelTickPrev = initialWheelTick; + tsdPtr->hWheelTickPrev = initialWheelTick; + tsdPtr->vWheelAcc = 0; + tsdPtr->hWheelAcc = 0; /* * Key map info must be available immediately, because of "send event". @@ -942,6 +957,7 @@ Tk_TranslateWinEvent( case WM_SYSKEYUP: case WM_KEYUP: case WM_MOUSEWHEEL: + case WM_MOUSEHWHEEL: GenerateXEvent(hwnd, message, wParam, lParam); return 1; case WM_MENUCHAR: @@ -986,7 +1002,7 @@ GenerateXEvent( ThreadSpecificData *tsdPtr = (ThreadSpecificData *) Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); - if (message == WM_MOUSEWHEEL) { + if ((message == WM_MOUSEWHEEL) || (message == WM_MOUSEHWHEEL)) { union {LPARAM lParam; POINTS point;} root; POINT pos; root.lParam = lParam; @@ -1101,6 +1117,7 @@ GenerateXEvent( break; case WM_MOUSEWHEEL: + case WM_MOUSEHWHEEL: case WM_CHAR: case WM_UNICHAR: case WM_SYSKEYDOWN: @@ -1142,18 +1159,50 @@ GenerateXEvent( switch (message) { case WM_MOUSEWHEEL: { /* - * Support for high resolution wheels. + * Support for high resolution wheels (vertical). + */ + + DWORD wheelTick = GetTickCount(); + + if (wheelTick - tsdPtr->vWheelTickPrev < 1500) { + tsdPtr->vWheelAcc += (short) HIWORD(wParam); + } else { + tsdPtr->vWheelAcc = (short) HIWORD(wParam); + } + tsdPtr->vWheelTickPrev = wheelTick; + if (abs(tsdPtr->vWheelAcc) < WHEEL_DELTA) { + return; + } + + /* + * We have invented a new X event type to handle this event. It + * still uses the KeyPress struct. However, the keycode field has + * been overloaded to hold the zDelta of the wheel. Set nbytes to + * 0 to prevent conversion of the keycode to a keysym in + * TkpGetString. [Bug 1118340]. + */ + + event.type = MouseWheelEvent; + event.xany.send_event = -1; + event.xkey.nbytes = 0; + event.xkey.keycode = tsdPtr->vWheelAcc / WHEEL_DELTA * WHEEL_DELTA; + tsdPtr->vWheelAcc = tsdPtr->vWheelAcc % WHEEL_DELTA; + break; + } + case WM_MOUSEHWHEEL: { + /* + * Support for high resolution wheels (horizontal). */ DWORD wheelTick = GetTickCount(); - if (wheelTick - tsdPtr->wheelTickPrev < 1500) { - tsdPtr->wheelAcc += (short) HIWORD(wParam); + if (wheelTick - tsdPtr->hWheelTickPrev < 1500) { + tsdPtr->hWheelAcc -= (short) HIWORD(wParam); } else { - tsdPtr->wheelAcc = (short) HIWORD(wParam); + tsdPtr->hWheelAcc = -((short) HIWORD(wParam)); } - tsdPtr->wheelTickPrev = wheelTick; - if (abs(tsdPtr->wheelAcc) < WHEEL_DELTA) { + tsdPtr->hWheelTickPrev = wheelTick; + if (abs(tsdPtr->hWheelAcc) < WHEEL_DELTA) { return; } @@ -1168,8 +1217,9 @@ GenerateXEvent( event.type = MouseWheelEvent; event.xany.send_event = -1; event.xkey.nbytes = 0; - event.xkey.keycode = tsdPtr->wheelAcc / WHEEL_DELTA * WHEEL_DELTA; - tsdPtr->wheelAcc = tsdPtr->wheelAcc % WHEEL_DELTA; + event.xkey.state |= ShiftMask; + event.xkey.keycode = tsdPtr->hWheelAcc / WHEEL_DELTA * WHEEL_DELTA; + tsdPtr->hWheelAcc = tsdPtr->hWheelAcc % WHEEL_DELTA; break; } case WM_SYSKEYDOWN: |