tk8.6.5/0000755003604700454610000000000012665114121010465 5ustar dgp771divtk8.6.5/README0000644003604700454610000000250612663615417011364 0ustar dgp771divREADME: Tk This is the Tk 8.6.5 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.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: http://core.tcl.tk/tk/ with the Tcl Developer Xchange at: http://www.tcl.tk/ 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. tk8.6.5/unix/0000755003604700454610000000000012665114121011450 5ustar dgp771divtk8.6.5/unix/aclocal.m40000644003604700454610000000004012665114121013302 0ustar dgp771divbuiltin(include,../unix/tcl.m4) tk8.6.5/unix/tkUnixScrlbr.c0000644003604700454610000003305712377375532014275 0ustar dgp771div/* * tkUnixScrollbar.c -- * * This file implements the Unix specific portion of the scrollbar * widget. * * Copyright (c) 1996 by Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tkInt.h" #include "tkScrollbar.h" /* * Minimum slider length, in pixels (designed to make sure that the slider is * always easy to grab with the mouse). */ #define MIN_SLIDER_LENGTH 5 /* * Declaration of Unix specific scrollbar structure. */ typedef struct UnixScrollbar { TkScrollbar info; /* Generic scrollbar info. */ GC troughGC; /* For drawing trough. */ GC copyGC; /* Used for copying from pixmap onto screen. */ } UnixScrollbar; /* * The class procedure table for the scrollbar widget. All fields except size * are left initialized to NULL, which should happen automatically since the * variable is declared at this scope. */ const Tk_ClassProcs tkpScrollbarProcs = { sizeof(Tk_ClassProcs), /* size */ NULL, /* worldChangedProc */ NULL, /* createProc */ NULL /* modalProc */ }; /* *---------------------------------------------------------------------- * * TkpCreateScrollbar -- * * Allocate a new TkScrollbar structure. * * Results: * Returns a newly allocated TkScrollbar structure. * * Side effects: * Registers an event handler for the widget. * *---------------------------------------------------------------------- */ TkScrollbar * TkpCreateScrollbar( Tk_Window tkwin) { UnixScrollbar *scrollPtr = ckalloc(sizeof(UnixScrollbar)); scrollPtr->troughGC = None; scrollPtr->copyGC = None; Tk_CreateEventHandler(tkwin, ExposureMask|StructureNotifyMask|FocusChangeMask, TkScrollbarEventProc, scrollPtr); return (TkScrollbar *) scrollPtr; } /* *-------------------------------------------------------------- * * TkpDisplayScrollbar -- * * This procedure redraws the contents of a scrollbar window. It is * invoked as a do-when-idle handler, so it only runs when there's * nothing else for the application to do. * * Results: * None. * * Side effects: * Information appears on the screen. * *-------------------------------------------------------------- */ void TkpDisplayScrollbar( ClientData clientData) /* Information about window. */ { register TkScrollbar *scrollPtr = (TkScrollbar *) clientData; register Tk_Window tkwin = scrollPtr->tkwin; XPoint points[7]; Tk_3DBorder border; int relief, width, elementBorderWidth; Pixmap pixmap; if ((scrollPtr->tkwin == NULL) || !Tk_IsMapped(tkwin)) { goto done; } if (scrollPtr->vertical) { width = Tk_Width(tkwin) - 2*scrollPtr->inset; } else { width = Tk_Height(tkwin) - 2*scrollPtr->inset; } elementBorderWidth = scrollPtr->elementBorderWidth; if (elementBorderWidth < 0) { elementBorderWidth = scrollPtr->borderWidth; } /* * In order to avoid screen flashes, this procedure redraws the scrollbar * in a pixmap, then copies the pixmap to the screen in a single * operation. This means that there's no point in time where the on-sreen * image has been cleared. */ pixmap = Tk_GetPixmap(scrollPtr->display, Tk_WindowId(tkwin), Tk_Width(tkwin), Tk_Height(tkwin), Tk_Depth(tkwin)); if (scrollPtr->highlightWidth != 0) { GC gc; if (scrollPtr->flags & GOT_FOCUS) { gc = Tk_GCForColor(scrollPtr->highlightColorPtr, pixmap); } else { gc = Tk_GCForColor(scrollPtr->highlightBgColorPtr, pixmap); } Tk_DrawFocusHighlight(tkwin, gc, scrollPtr->highlightWidth, pixmap); } Tk_Draw3DRectangle(tkwin, pixmap, scrollPtr->bgBorder, scrollPtr->highlightWidth, scrollPtr->highlightWidth, Tk_Width(tkwin) - 2*scrollPtr->highlightWidth, Tk_Height(tkwin) - 2*scrollPtr->highlightWidth, scrollPtr->borderWidth, scrollPtr->relief); XFillRectangle(scrollPtr->display, pixmap, ((UnixScrollbar*)scrollPtr)->troughGC, scrollPtr->inset, scrollPtr->inset, (unsigned) (Tk_Width(tkwin) - 2*scrollPtr->inset), (unsigned) (Tk_Height(tkwin) - 2*scrollPtr->inset)); /* * Draw the top or left arrow. The coordinates of the polygon points * probably seem odd, but they were carefully chosen with respect to X's * rules for filling polygons. These point choices cause the arrows to * just fill the narrow dimension of the scrollbar and be properly * centered. */ if (scrollPtr->activeField == TOP_ARROW) { border = scrollPtr->activeBorder; relief = scrollPtr->activeField == TOP_ARROW ? scrollPtr->activeRelief : TK_RELIEF_RAISED; } else { border = scrollPtr->bgBorder; relief = TK_RELIEF_RAISED; } if (scrollPtr->vertical) { points[0].x = scrollPtr->inset - 1; points[0].y = scrollPtr->arrowLength + scrollPtr->inset - 1; points[1].x = width + scrollPtr->inset; points[1].y = points[0].y; points[2].x = width/2 + scrollPtr->inset; points[2].y = scrollPtr->inset - 1; Tk_Fill3DPolygon(tkwin, pixmap, border, points, 3, elementBorderWidth, relief); } else { points[0].x = scrollPtr->arrowLength + scrollPtr->inset - 1; points[0].y = scrollPtr->inset - 1; points[1].x = scrollPtr->inset; points[1].y = width/2 + scrollPtr->inset; points[2].x = points[0].x; points[2].y = width + scrollPtr->inset; Tk_Fill3DPolygon(tkwin, pixmap, border, points, 3, elementBorderWidth, relief); } /* * Display the bottom or right arrow. */ if (scrollPtr->activeField == BOTTOM_ARROW) { border = scrollPtr->activeBorder; relief = scrollPtr->activeField == BOTTOM_ARROW ? scrollPtr->activeRelief : TK_RELIEF_RAISED; } else { border = scrollPtr->bgBorder; relief = TK_RELIEF_RAISED; } if (scrollPtr->vertical) { points[0].x = scrollPtr->inset; points[0].y = Tk_Height(tkwin) - scrollPtr->arrowLength - scrollPtr->inset + 1; points[1].x = width/2 + scrollPtr->inset; points[1].y = Tk_Height(tkwin) - scrollPtr->inset; points[2].x = width + scrollPtr->inset; points[2].y = points[0].y; Tk_Fill3DPolygon(tkwin, pixmap, border, points, 3, elementBorderWidth, relief); } else { points[0].x = Tk_Width(tkwin) - scrollPtr->arrowLength - scrollPtr->inset + 1; points[0].y = scrollPtr->inset - 1; points[1].x = points[0].x; points[1].y = width + scrollPtr->inset; points[2].x = Tk_Width(tkwin) - scrollPtr->inset; points[2].y = width/2 + scrollPtr->inset; Tk_Fill3DPolygon(tkwin, pixmap, border, points, 3, elementBorderWidth, relief); } /* * Display the slider. */ if (scrollPtr->activeField == SLIDER) { border = scrollPtr->activeBorder; relief = scrollPtr->activeField == SLIDER ? scrollPtr->activeRelief : TK_RELIEF_RAISED; } else { border = scrollPtr->bgBorder; relief = TK_RELIEF_RAISED; } if (scrollPtr->vertical) { Tk_Fill3DRectangle(tkwin, pixmap, border, scrollPtr->inset, scrollPtr->sliderFirst, width, scrollPtr->sliderLast - scrollPtr->sliderFirst, elementBorderWidth, relief); } else { Tk_Fill3DRectangle(tkwin, pixmap, border, scrollPtr->sliderFirst, scrollPtr->inset, scrollPtr->sliderLast - scrollPtr->sliderFirst, width, elementBorderWidth, relief); } /* * Copy the information from the off-screen pixmap onto the screen, then * delete the pixmap. */ XCopyArea(scrollPtr->display, pixmap, Tk_WindowId(tkwin), ((UnixScrollbar*)scrollPtr)->copyGC, 0, 0, (unsigned) Tk_Width(tkwin), (unsigned) Tk_Height(tkwin), 0, 0); Tk_FreePixmap(scrollPtr->display, pixmap); done: scrollPtr->flags &= ~REDRAW_PENDING; } /* *---------------------------------------------------------------------- * * TkpComputeScrollbarGeometry -- * * After changes in a scrollbar's size or configuration, this procedure * recomputes various geometry information used in displaying the * scrollbar. * * Results: * None. * * Side effects: * The scrollbar will be displayed differently. * *---------------------------------------------------------------------- */ extern void TkpComputeScrollbarGeometry( register TkScrollbar *scrollPtr) /* Scrollbar whose geometry may have * changed. */ { int width, fieldLength; if (scrollPtr->highlightWidth < 0) { scrollPtr->highlightWidth = 0; } scrollPtr->inset = scrollPtr->highlightWidth + scrollPtr->borderWidth; width = (scrollPtr->vertical) ? Tk_Width(scrollPtr->tkwin) : Tk_Height(scrollPtr->tkwin); scrollPtr->arrowLength = width - 2*scrollPtr->inset + 1; fieldLength = (scrollPtr->vertical ? Tk_Height(scrollPtr->tkwin) : Tk_Width(scrollPtr->tkwin)) - 2*(scrollPtr->arrowLength + scrollPtr->inset); if (fieldLength < 0) { fieldLength = 0; } scrollPtr->sliderFirst = fieldLength*scrollPtr->firstFraction; scrollPtr->sliderLast = fieldLength*scrollPtr->lastFraction; /* * Adjust the slider so that some piece of it is always displayed in the * scrollbar and so that it has at least a minimal width (so it can be * grabbed with the mouse). */ if (scrollPtr->sliderFirst > fieldLength - MIN_SLIDER_LENGTH) { scrollPtr->sliderFirst = fieldLength - MIN_SLIDER_LENGTH; } if (scrollPtr->sliderFirst < 0) { scrollPtr->sliderFirst = 0; } if (scrollPtr->sliderLast < scrollPtr->sliderFirst + MIN_SLIDER_LENGTH) { scrollPtr->sliderLast = scrollPtr->sliderFirst + MIN_SLIDER_LENGTH; } if (scrollPtr->sliderLast > fieldLength) { scrollPtr->sliderLast = fieldLength; } scrollPtr->sliderFirst += scrollPtr->arrowLength + scrollPtr->inset; scrollPtr->sliderLast += scrollPtr->arrowLength + scrollPtr->inset; /* * Register the desired geometry for the window (leave enough space for * the two arrows plus a minimum-size slider, plus border around the whole * window, if any). Then arrange for the window to be redisplayed. */ if (scrollPtr->vertical) { Tk_GeometryRequest(scrollPtr->tkwin, scrollPtr->width + 2*scrollPtr->inset, 2*(scrollPtr->arrowLength + scrollPtr->borderWidth + scrollPtr->inset)); } else { Tk_GeometryRequest(scrollPtr->tkwin, 2*(scrollPtr->arrowLength + scrollPtr->borderWidth + scrollPtr->inset), scrollPtr->width + 2*scrollPtr->inset); } Tk_SetInternalBorder(scrollPtr->tkwin, scrollPtr->inset); } /* *---------------------------------------------------------------------- * * TkpDestroyScrollbar -- * * Free data structures associated with the scrollbar control. * * Results: * None. * * Side effects: * Frees the GCs associated with the scrollbar. * *---------------------------------------------------------------------- */ void TkpDestroyScrollbar( TkScrollbar *scrollPtr) { UnixScrollbar *unixScrollPtr = (UnixScrollbar *)scrollPtr; if (unixScrollPtr->troughGC != None) { Tk_FreeGC(scrollPtr->display, unixScrollPtr->troughGC); } if (unixScrollPtr->copyGC != None) { Tk_FreeGC(scrollPtr->display, unixScrollPtr->copyGC); } } /* *---------------------------------------------------------------------- * * TkpConfigureScrollbar -- * * This procedure is called after the generic code has finished * processing configuration options, in order to configure platform * specific options. * * Results: * None. * * Side effects: * Configuration info may get changed. * *---------------------------------------------------------------------- */ void TkpConfigureScrollbar( register TkScrollbar *scrollPtr) /* Information about widget; may or may not * already have values for some fields. */ { XGCValues gcValues; GC new; UnixScrollbar *unixScrollPtr = (UnixScrollbar *) scrollPtr; Tk_SetBackgroundFromBorder(scrollPtr->tkwin, scrollPtr->bgBorder); gcValues.foreground = scrollPtr->troughColorPtr->pixel; new = Tk_GetGC(scrollPtr->tkwin, GCForeground, &gcValues); if (unixScrollPtr->troughGC != None) { Tk_FreeGC(scrollPtr->display, unixScrollPtr->troughGC); } unixScrollPtr->troughGC = new; if (unixScrollPtr->copyGC == None) { gcValues.graphics_exposures = False; unixScrollPtr->copyGC = Tk_GetGC(scrollPtr->tkwin, GCGraphicsExposures, &gcValues); } } /* *-------------------------------------------------------------- * * TkpScrollbarPosition -- * * Determine the scrollbar element corresponding to a given position. * * Results: * One of TOP_ARROW, TOP_GAP, etc., indicating which element of the * scrollbar covers the position given by (x, y). If (x,y) is outside the * scrollbar entirely, then OUTSIDE is returned. * * Side effects: * None. * *-------------------------------------------------------------- */ int TkpScrollbarPosition( register TkScrollbar *scrollPtr, /* Scrollbar widget record. */ int x, int y) /* Coordinates within scrollPtr's window. */ { int length, width, tmp; register const int inset = scrollPtr->inset; if (scrollPtr->vertical) { length = Tk_Height(scrollPtr->tkwin); width = Tk_Width(scrollPtr->tkwin); } else { tmp = x; x = y; y = tmp; length = Tk_Width(scrollPtr->tkwin); width = Tk_Height(scrollPtr->tkwin); } if (x=width-inset || y=length-inset) { return OUTSIDE; } /* * All of the calculations in this procedure mirror those in * TkpDisplayScrollbar. Be sure to keep the two consistent. */ if (y < inset + scrollPtr->arrowLength) { return TOP_ARROW; } if (y < scrollPtr->sliderFirst) { return TOP_GAP; } if (y < scrollPtr->sliderLast) { return SLIDER; } if (y >= length - (scrollPtr->arrowLength + inset)) { return BOTTOM_ARROW; } return BOTTOM_GAP; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ tk8.6.5/unix/installManPage0000755003604700454610000000573412665114121014306 0ustar dgp771div#!/bin/sh ######################################################################## ### Parse Options ### Gzip=: SymOrLoc="" Gz="" Suffix="" while true; do case $1 in -s | --symlinks ) SymOrLoc="-s " ;; -z | --compress ) Gzip=$2; shift ;; -e | --extension ) Gz=$2; shift ;; -x | --suffix ) Suffix=$2; shift ;; -*) cat < file dir" exit 1 fi ######################################################################## ### Parse Required Arguments ### ManPage=$1 Dir=$2 if test -f $ManPage ; then : ; else echo "source manual page file must exist" exit 1 fi if test -d $Dir ; then : ; else echo "target directory must exist" exit 1 fi test -z "$SymOrLoc" && SymOrLoc="$Dir/" ######################################################################## ### Extract Target Names from Manual Page ### # A sed script to parse the alternative names out of a man page. # # Backslashes are trippled in the sed script, because it is in # backticks which doesn't pass backslashes literally. # Names=`sed -n ' # Look for a line that starts with .SH NAME /^\.SH NAME/{ # Read next line n # Remove all commas ... s/,//g # ... and backslash-escaped spaces. s/\\\ //g # Delete from \- to the end of line s/ \\\-.*// # Convert all non-space non-alphanum sequences # to single underscores. s/[^ A-Za-z0-9][^ A-Za-z0-9]*/_/g # print the result and exit p;q }' $ManPage` if test -z "$Names" ; then echo "warning: no target names found in $ManPage" fi ######################################################################## ### Remaining Set Up ### case $ManPage in *.1) Section=1 ;; *.3) Section=3 ;; *.n) Section=n ;; *) echo "unknown section for $ManPage" exit 2 ;; esac SrcDir=`dirname $ManPage` ######################################################################## ### Process Page to Create Target Pages ### First="" for Target in $Names; do Target=$Target.$Section$Suffix rm -f $Dir/$Target $Dir/$Target.* if test -z "$First" ; then First=$Target sed -e "/man\.macros/r $SrcDir/man.macros" -e "/man\.macros/d" \ $ManPage > $Dir/$First chmod 444 $Dir/$First $Gzip $Dir/$First else ln $SymOrLoc$First$Gz $Dir/$Target$Gz fi done ######################################################################## exit 0 tk8.6.5/unix/README0000644003604700454610000002072212665114121012333 0ustar dgp771divTk UNIX README -------------- This is the directory where you configure, compile, test, and install UNIX versions of Tk. This directory also contains source files for Tk that are specific to UNIX. The information in this file is maintained at: http://www.tcl.tk/doc/howto/compile.html For information on platforms where Tcl/Tk is known to compile, along with any porting notes for getting it to work on those platforms, see: http://www.tcl.tk/software/tcltk/platforms.html The rest of this file contains instructions on how to do this. The release should compile and run either "out of the box" or with trivial changes on any UNIX-like system that approximates POSIX, BSD, or System V. We know that it runs on workstations from Sun, H-P, DEC, IBM, and SGI, as well as PCs running Linux, BSDI, and SCO UNIX. To compile for a PC running Windows, see the README file in the directory ../win. To compile for MacOSX, see the README file in the directory ../macosx. How To Compile And Install Tk: ------------------------------ (a) Make sure that the Tcl release is present in the directory ../../tcl (or else use the "--with-tcl" switch described below). This release of Tk will only work with the equivalently versioned Tcl release. Also, be sure that you have configured Tcl before you configure Tk. (b) Check for patches as described in ../README. (c) If you have already compiled Tk once in this directory and are now preparing to compile again in the same directory but for a different platform, or if you have applied patches, type "make distclean" to discard all the configuration information computed previously. (d) Type "./configure". This runs a configuration script created by GNU autoconf, which configures Tk for your system and creates a Makefile. The configure script allows you to customize the Tk configuration for your site; for details on how you can do this, type "./configure -help" or refer to the autoconf documentation (not included here). Tk's "configure" script supports the following special switches in addition to the standard ones: --with-tcl=DIR Specifies the directory containing the Tcl binaries and Tcl's platform-dependent configuration information. By default the Tcl directory is assumed to be in the location given by (a) above. --with-x=DIR Tells configure where to find an installation of the X Window System. Not normally needed. --enable-threads If this switch is set, Tk will compile itself with multithreading support. --enable-shared If this switch is specified, Tk will compile itself as a shared library if it can figure out how to do that on this platform. This is the default on platforms where we know how to build shared libraries. --disable-shared If this switch is specified, Tk will compile itself as a static library. --disable-rpath Turns off use of the rpath link option on platforms that would otherwise use it. --enable-symbols Build with debugging symbols. By default standard debugging symbols are used. You can specify the value "mem" to include TCL_MEM_DEBUG memory debugging. --disable-symbols Build without debugging symbols --enable-64bit Enable 64bit support (where applicable) --disable-64bit Disable 64bit support (where applicable) --enable-64bit-vis Enable 64bit Sparc VIS support --disable-64bit-vis Disable 64bit Sparc VIS support --disable-xft Disable support for antialiased fonts via the Freetype/xft library. By default, this is switched on whenever the configure script can detect the required libraries. --enable-man-symlinks Use symlinks for linking the manpages that should be reachable under several names. --enable-man-compression=PROG Compress the manpages using PROG. --enable-man-suffix=STRING Add STRING to the name of each of the manual pages. If specified without giving STRING, the suffix will be "tk". Mac OS X only: --enable-framework Package Tk as a framework. --disable-corefoundation Disable use of CoreFoundation API. --enable-aqua Use Aqua windowingsystem rather than X11, requires --enable-corefoundation with Tcl and Tk. Note: by default gcc will be used if it can be located on the PATH. If you want to use cc instead of gcc, set the CC environment variable to "cc" before running configure. It is not safe to change the Makefile to use gcc after configure is run. Note: be sure to use only absolute path names (those starting with "/") in the --prefix and --exec-prefix options. (e) Type "make". This will create a library archive called "libtk.a" or "libtk.so" and an interpreter application called "wish" that allows you to type Tcl/Tk commands interactively or execute script files. It will also create a stub library archive "libtkstub.a" that developers may link against other C code to produce loadable extensions that call into Tk's public interface routines. (f) If the make fails then you'll have to personalize the Makefile for your site or possibly modify the distribution in other ways. First check the porting Web page above to see if there are hints for compiling on your system. If you need to modify Makefile, there are comments at the beginning of it that describe the things you might want to change and how to change them. (g) Type "make install" to install Tk's binaries and script files in standard places. You'll need write permission on the installation directories to do this. The installation directories are determined by the "configure" script and may be specified with the --prefix and --exec-prefix options to "configure". See the Makefile for information on what directories were chosen. You should not override these choices by modifying the Makefile, or by copying files post-install. The installed binaries have embedded within them path values relative to the install directory. If you change your mind about where Tk should be installed, start this procedure over again from step (a) so that the path embedded in the binaries agrees with the install location. (h) At this point you can play with Tk by running the installed "wish" executable, or via the "make shell" target, and typing Tcl/Tk commands at the interactive prompt. If you have trouble compiling Tk, see the URL noted above about working platforms. It contains information that people have provided about changes they had to make to compile Tk in various environments. We're also interested in hearing how to change the configuration setup so that Tk compiles on additional platforms "out of the box". Note: Do not specify either of the TCL_LIBRARY and TK_LIBRARY environment variables in a production installation, as this can cause conflicts between different versions of the libraries. Instead, the libraries should have the correct locations of their associated script directories built into them. Test suite ---------- Tk has a substantial self-test suite, consisting of a set of scripts in the subdirectory "tests". To run the test suite just type "make test" in this directory. You should then see a printout of the test files processed. If any errors occur, you'll see a much more substantial printout for each error. In order to avoid false error reports, be sure to run the tests with an empty resource database (e.g., remove your .Xdefaults file or delete any entries starting with *). Also, don't try to do anything else with your display or keyboard while the tests are running, or you may get false violations. See the README file in the "tests" directory for more information on the test suite. If the test suite generates errors, most likely they are due to non-portable tests that are interacting badly with your system configuration. We are gradually eliminating the non-portable tests, but this release includes many new tests so there will probably be some portability problems. As long as the test suite doesn't core dump, it's probably safe to conclude that any errors represent portability problems in the test suite and not fundamental flaws with Tk. There are also a number of visual tests for things such as screen layout, Postscript generation, etc. These tests all have to be run by manually enabling the "userInteraction" constraint when testing, and the results have to be verified visually. This can be done with: make test TESTFLAGS="-constraints userInteraction" Some tests will present a main window with a bunch of menus, which you can use to select various tests. tk8.6.5/unix/tkUnixFocus.c0000644003604700454610000001066512077535536014124 0ustar dgp771div/* * tkUnixFocus.c -- * * This file contains platform specific functions that manage focus for * Tk. * * Copyright (c) 1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tkUnixInt.h" /* *---------------------------------------------------------------------- * * TkpChangeFocus -- * * This function is invoked to move the official X focus from one window * to another. * * Results: * The return value is the serial number of the command that changed the * focus. It may be needed by the caller to filter out focus change * events that were queued before the command. If the function doesn't * actually change the focus then it returns 0. * * Side effects: * The official X focus window changes; the application's focus window * isn't changed by this function. * *---------------------------------------------------------------------- */ int TkpChangeFocus( TkWindow *winPtr, /* Window that is to receive the X focus. */ int force) /* Non-zero means claim the focus even if it * didn't originally belong to topLevelPtr's * application. */ { TkDisplay *dispPtr = winPtr->dispPtr; Tk_ErrorHandler errHandler; Window window, root, parent, *children; unsigned int numChildren, serial; TkWindow *winPtr2; int dummy; /* * Don't set the X focus to a window that's marked override-redirect. * This is a hack to avoid problems with menus under olvwm: if we move * the focus then the focus can get lost during keyboard traversal. * Fortunately, we don't really need to move the focus for menus: events * will still find their way to the focus window, and menus aren't * decorated anyway so the window manager doesn't need to hear about the * focus change in order to redecorate the menu. */ serial = 0; if (winPtr->atts.override_redirect) { return serial; } /* * Check to make sure that the focus is still in one of the windows of * this application or one of their descendants. Furthermore, grab the * server to make sure that the focus doesn't change in the middle of this * operation. */ XGrabServer(dispPtr->display); if (!force) { /* * Find the focus window, then see if it or one of its ancestors is a * window in our application (it's possible that the focus window is * in an embedded application, which may or may not be in the same * process. */ XGetInputFocus(dispPtr->display, &window, &dummy); while (1) { winPtr2 = (TkWindow *) Tk_IdToWindow(dispPtr->display, window); if ((winPtr2 != NULL) && (winPtr2->mainPtr == winPtr->mainPtr)) { break; } if ((window == PointerRoot) || (window == None)) { goto done; } XQueryTree(dispPtr->display, window, &root, &parent, &children, &numChildren); if (children != NULL) { XFree((void *) children); } if (parent == root) { goto done; } window = parent; } } /* * Tell X to change the focus. Ignore errors that occur when changing the * focus: it is still possible that the window we're focussing to could * have gotten unmapped, which will generate an error. */ errHandler = Tk_CreateErrorHandler(dispPtr->display, -1,-1,-1, NULL,NULL); if (winPtr->window == None) { Tcl_Panic("ChangeXFocus got null X window"); } XSetInputFocus(dispPtr->display, winPtr->window, RevertToParent, CurrentTime); Tk_DeleteErrorHandler(errHandler); /* * Remember the current serial number for the X server and issue a dummy * server request. This marks the position at which we changed the focus, * so we can distinguish FocusIn and FocusOut events on either side of the * mark. */ serial = NextRequest(winPtr->display); XNoOp(winPtr->display); done: XUngrabServer(dispPtr->display); /* * After ungrabbing the server, it's important to flush the output * immediately so that the server sees the ungrab command. Otherwise we * might do something else that needs to communicate with the server (such * as invoking a subprocess that needs to do I/O to the screen); if the * ungrab command is still sitting in our output buffer, we could * deadlock. */ XFlush(dispPtr->display); return serial; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ tk8.6.5/unix/Makefile.in0000664003604700454610000016461512665114121013534 0ustar dgp771div# # This file is a Makefile for Tk. If it has the name "Makefile.in" # then it is a template for a Makefile; to generate the actual Makefile, # run "./configure", which is a configuration script generated by the # "autoconf" program (constructs like "@foo@" will get replaced in the # actual Makefile. # Current Tk version; used in various names. TCLVERSION = @TCL_VERSION@ TCLPATCHL = @TCL_PATCH_LEVEL@ VERSION = @TK_VERSION@ MAJOR_VERSION = @TK_MAJOR_VERSION@ MINOR_VERSION = @TK_MINOR_VERSION@ PATCH_LEVEL = @TK_PATCH_LEVEL@ LOCALES = @LOCALES@ #---------------------------------------------------------------- # Things you can change to personalize the Makefile for your own # site (you can make these changes in either Makefile.in or # Makefile, but changes to Makefile will get lost if you re-run # the configuration script). #---------------------------------------------------------------- # Default top-level directories in which to install architecture- # specific files (exec_prefix) and machine-independent files such # as scripts (prefix). The values specified here may be overridden # at configure-time with the --exec-prefix and --prefix options # to the "configure" script. The *dir vars are standard configure # substitutions that are based off prefix and exec_prefix. prefix = @prefix@ exec_prefix = @exec_prefix@ bindir = @bindir@ libdir = @libdir@ includedir = @includedir@ datarootdir = @datarootdir@ mandir = @mandir@ # The following definition can be set to non-null for special systems # like AFS with replication. It allows the pathnames used for installation # to be different than those used for actually reference files at # run-time. INSTALL_ROOT is prepended to $prefix and $exec_prefix # when installing files. INSTALL_ROOT = $(DESTDIR) # Directory from which applications will reference the library of Tcl # scripts (note: you can set the TK_LIBRARY environment variable at # run-time to override the compiled-in location): TK_LIBRARY = @TK_LIBRARY@ # Path to use at runtime to refer to LIB_INSTALL_DIR: LIB_RUNTIME_DIR = @LIB_RUNTIME_DIR@ # Directory in which to install the program wish: BIN_INSTALL_DIR = $(INSTALL_ROOT)$(bindir) # Directory in which to install the .a or .so binary for the Tk library: LIB_INSTALL_DIR = $(INSTALL_ROOT)$(libdir) DLL_INSTALL_DIR = @DLL_INSTALL_DIR@ # Path name to use when installing library scripts. SCRIPT_INSTALL_DIR = $(INSTALL_ROOT)$(TK_LIBRARY) # Directory in which to install the include file tk.h: INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(includedir) # Path to the private tk header dir: PRIVATE_INCLUDE_DIR = @PRIVATE_INCLUDE_DIR@ # Directory in which to (optionally) install the private tk headers: PRIVATE_INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(PRIVATE_INCLUDE_DIR) # Top-level directory in which to install manual entries: MAN_INSTALL_DIR = $(INSTALL_ROOT)$(mandir) # Directory in which to install manual entry for wish: MAN1_INSTALL_DIR = $(MAN_INSTALL_DIR)/man1 # Directory in which to install manual entries for Tk's C library # procedures: MAN3_INSTALL_DIR = $(MAN_INSTALL_DIR)/man3 # Directory in which to install manual entries for the built-in # Tcl commands implemented by Tk: MANN_INSTALL_DIR = $(MAN_INSTALL_DIR)/mann # Path to the html documentation dir: HTML_DIR = @HTML_DIR@ # Directory in which to install html documentation: HTML_INSTALL_DIR = $(INSTALL_ROOT)$(HTML_DIR) # Directory in which to install the configuration file tkConfig.sh: CONFIG_INSTALL_DIR = $(INSTALL_ROOT)$(libdir) # Directory in which to install the demo files: DEMO_INSTALL_DIR = $(INSTALL_ROOT)$(TK_LIBRARY)/demos # The directory containing the Tcl sources and headers appropriate # for this version of Tk ("srcdir" will be replaced or has already # been replaced by the configure script): TCL_GENERIC_DIR = @TCL_SRC_DIR@/generic # The directory containing the platform specific Tcl sources and headers # appropriate for this version of Tk: TCL_PLATFORM_DIR = @TCL_SRC_DIR@/unix # The directory containing the Tcl library archive file appropriate # for this version of Tk: TCL_BIN_DIR = @TCL_BIN_DIR@ # The linker flags needed to link in the Tcl library (ex: -ltcl8.2) TCL_LIB_FLAG = @TCL_LIB_FLAG@ # Flag, 1: we're building a shared lib, 0 we're not TK_SHARED_BUILD = @TK_SHARED_BUILD@ # Subdirectory of $(libdir) containing the pkgIndex.tcl file for loadable Tk TK_PKG_DIR = @TK_PKG_DIR@ # Directory in which to install the pkgIndex.tcl file for loadable Tk PKG_INSTALL_DIR = $(LIB_INSTALL_DIR)/$(TK_PKG_DIR) # Package index file for loadable Tk PKG_INDEX = $(PKG_INSTALL_DIR)/pkgIndex.tcl # warning flags CFLAGS_WARNING = @CFLAGS_WARNING@ # The default switches for optimization or debugging CFLAGS_DEBUG = @CFLAGS_DEBUG@ CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@ # To change the compiler switches, for example to change from optimization to # debugging symbols, change the following line: #CFLAGS = $(CFLAGS_DEBUG) #CFLAGS = $(CFLAGS_OPTIMIZE) #CFLAGS = $(CFLAGS_DEBUG) $(CFLAGS_OPTIMIZE) CFLAGS = @CFLAGS_DEFAULT@ @CFLAGS@ # Flags to pass to the linker LDFLAGS_DEBUG = @LDFLAGS_DEBUG@ LDFLAGS_OPTIMIZE = @LDFLAGS_OPTIMIZE@ LDFLAGS = @LDFLAGS_DEFAULT@ @LDFLAGS@ # A "-I" switch that can be used when compiling to make all of the # X11 include files accessible (the configure script will try to # set this value, and will cause it to be an empty string if the # include files are accessible via /usr/include). X11_INCLUDES = @XINCLUDES@ AQUA_INCLUDES = -I$(MAC_OSX_DIR) -I$(XLIB_DIR) # Linker switch(es) to use to link with the X11 library archive (the # configure script will try to set this value automatically, but you # can override it). X11_LIB_SWITCHES = $(XFT_LIBS) @XLIBSW@ # To turn off the security checks that disallow incoming sends when # the X server appears to be insecure, reverse the comments on the # following lines: SECURITY_FLAGS = #SECURITY_FLAGS = -DTK_NO_SECURITY # To disable ANSI-C procedure prototypes reverse the comment characters # on the following lines: PROTO_FLAGS = #PROTO_FLAGS = -DNO_PROTOTYPE # To enable memory debugging reverse the comment characters on the following # lines or call configure with --enable-symbols=mem # Warning: if you enable memory debugging, you must do it *everywhere*, # including all the code that calls Tcl, and you must use ckalloc and # ckfree everywhere instead of malloc and free. MEM_DEBUG_FLAGS = #MEM_DEBUG_FLAGS = -DTCL_MEM_DEBUG # If your X server is X11R4 or earlier, then you may wish to reverse # the comment characters on the following two lines. This will enable # extra code to speed up XStringToKeysym. In X11R5 and later releases # XStringToKeysym is plenty fast, so you needn't define REDO_KEYSYM_LOOKUP. KEYSYM_FLAGS = #KEYSYM_FLAGS = -DREDO_KEYSYM_LOOKUP # Tk does not used deprecated Tcl constructs so it should # compile fine with -DTCL_NO_DEPRECATED. To remove its own # set of deprecated code uncomment the second line. NO_DEPRECATED_FLAGS = -DTCL_NO_DEPRECATED #NO_DEPRECATED_FLAGS = -DTCL_NO_DEPRECATED -DTK_NO_DEPRECATED # Some versions of make, like SGI's, use the following variable to # determine which shell to use for executing commands: SHELL = @SHELL@ # BUILD_TCLSH is the fully qualified path name of the tclsh shell # in the Tcl build directory. Test that need to be run in the # version of tclsh that we are building against should use this # path. Targets that need an installed tclsh should not depend # on this variable. BUILD_TCLSH = @BUILD_TCLSH@ # TCL_EXE is the name of a tclsh executable that is available *BEFORE* # running make for the first time. Certain build targets (make genstubs) # need it to be available on the PATH. This executable should *NOT* be # required just to do a normal build although it can be required to run # make dist. This variable is set to "" if no tclsh is available. EXE_SUFFIX = @EXEEXT@ TCL_EXE = @TCLSH_PROG@ WISH_EXE = wish${EXE_SUFFIX} TKTEST_EXE = tktest${EXE_SUFFIX} # Tk used to let the configure script choose which program to use # for installing, but there are just too many different versions of # "install" around; better to use the install-sh script that comes # with the distribution, which is slower but guaranteed to work. INSTALL_STRIP_PROGRAM = -s INSTALL_STRIP_LIBRARY = -S -x INSTALL = $(SHELL) $(UNIX_DIR)/install-sh -c INSTALL_PROGRAM = ${INSTALL} INSTALL_LIBRARY = ${INSTALL} INSTALL_DATA = ${INSTALL} -m 644 INSTALL_DATA_DIR = ${INSTALL} -d -m 755 # The symbol below provides support for dynamic loading and shared # libraries. See configure.in for a description of what it means. # The value of the symbol is normally set by the configure script. SHLIB_CFLAGS = @SHLIB_CFLAGS@ -DBUILD_tk # To enable support for stubs in Tcl. STUB_LIB_FILE = @TK_STUB_LIB_FILE@ TK_STUB_LIB_FILE = @TK_STUB_LIB_FILE@ #TK_STUB_LIB_FILE = libtkstub.a # Generic stub lib name used in rules that apply to tcl and tk STUB_LIB_FILE = ${TK_STUB_LIB_FILE} TK_STUB_LIB_FLAG = @TK_STUB_LIB_FLAG@ #TK_STUB_LIB_FLAG = -ltkstub TK_LIB_FILE = @TK_LIB_FILE@ #TK_LIB_FILE = libtk.a # Generic lib name used in rules that apply to tcl and tk LIB_FILE = ${TK_LIB_FILE} TK_LIB_FLAG = @TK_LIB_FLAG@ #TK_LIB_FLAG = -ltk TCL_LIB_SPEC = @TCL_LIB_SPEC@ TCL_STUB_LIB_SPEC = @TCL_STUB_LIB_SPEC@ TCL_STUB_LIB_FLAG = @TCL_STUB_LIB_FLAG@ TCL_STUB_LIB_FILE = @TCL_STUB_LIB_FILE@ TCL_STUB_FLAGS = @TCL_STUB_FLAGS@ # Libraries to use when linking. This definition is determined by the # configure script. LIBS = @LIBS@ $(X11_LIB_SWITCHES) @TCL_LIBS@ WISH_LIBS = $(TCL_LIB_SPEC) @LIBS@ $(X11_LIB_SWITCHES) @TCL_LIBS@ @EXTRA_WISH_LIBS@ # The symbols below provide support for dynamic loading and shared # libraries. See configure.in for a description of what the # symbols mean. The values of the symbols are normally set by the # configure script. You shouldn't normally need to modify any of # these definitions by hand. STLIB_LD = @STLIB_LD@ SHLIB_LD = @SHLIB_LD@ SHLIB_LD_LIBS = @SHLIB_LD_LIBS@ TK_SHLIB_LD_EXTRAS = @TK_SHLIB_LD_EXTRAS@ # Additional search flags needed to find the various shared libraries # at run-time. The first symbol is for use when creating a binary # with cc, and the second is for use when running ld directly. CC_SEARCH_FLAGS = @CC_SEARCH_FLAGS@ LD_SEARCH_FLAGS = @LD_SEARCH_FLAGS@ # support for embedded libraries on Darwin / Mac OS X DYLIB_INSTALL_DIR = ${LIB_RUNTIME_DIR} # support for building the Aqua resource file TK_RSRC_FILE = @TK_RSRC_FILE@ WISH_RSRC_FILE = @WISH_RSRC_FILE@ REZ = @REZ@ REZ_SWITCHES = @REZ_FLAGS@ -i $(GENERIC_DIR) -i $(TCL_GENERIC_DIR) # support for Xft: XFT_CFLAGS = @XFT_CFLAGS@ XFT_LIBS = @XFT_LIBS@ #---------------------------------------------------------------- # The information below is modified by the configure script when # Makefile is generated from Makefile.in. You shouldn't normally # modify any of this stuff by hand. #---------------------------------------------------------------- AC_FLAGS = @DEFS@ AR = @AR@ RANLIB = @RANLIB@ SRC_DIR = @srcdir@ TOP_DIR = $(SRC_DIR)/.. GENERIC_DIR = $(TOP_DIR)/generic TTK_DIR = $(GENERIC_DIR)/ttk UNIX_DIR = $(TOP_DIR)/unix BMAP_DIR = $(TOP_DIR)/bitmaps TOOL_DIR = @TCL_SRC_DIR@/tools TEST_DIR = $(TOP_DIR)/tests MAC_OSX_DIR = $(TOP_DIR)/macosx XLIB_DIR = $(TOP_DIR)/xlib #---------------------------------------------------------------- # The information below should be usable as is. The configure # script won't modify it and you shouldn't need to modify it # either. #---------------------------------------------------------------- # Flags to be passed to installManPage to control how the manpages # should be installed (symlinks, compression, package name suffix). MAN_FLAGS = @MAN_FLAGS@ CC = @CC@ CC_SWITCHES_NO_STUBS = ${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \ -I${UNIX_DIR} -I${GENERIC_DIR} -I${BMAP_DIR} -I${TCL_GENERIC_DIR} \ -I${TCL_PLATFORM_DIR} ${@TK_WINDOWINGSYSTEM@_INCLUDES} ${AC_FLAGS} \ ${PROTO_FLAGS} ${SECURITY_FLAGS} ${MEM_DEBUG_FLAGS} ${KEYSYM_FLAGS} \ ${NO_DEPRECATED_FLAGS} @EXTRA_CC_SWITCHES@ CC_SWITCHES = $(CC_SWITCHES_NO_STUBS) @TCL_STUB_FLAGS@ APP_CC_SWITCHES = $(CC_SWITCHES_NO_STUBS) @EXTRA_APP_CC_SWITCHES@ DEPEND_SWITCHES = ${CFLAGS} -I${UNIX_DIR} -I${GENERIC_DIR} -I${BMAP_DIR} \ -I${TCL_GENERIC_DIR} -I${TCL_PLATFORM_DIR} ${@TK_WINDOWINGSYSTEM@_INCLUDES} \ ${AC_FLAGS} ${PROTO_FLAGS} ${SECURITY_FLAGS} ${MEM_DEBUG_FLAGS} \ ${KEYSYM_FLAGS} @EXTRA_CC_SWITCHES@ WISH_OBJS = tkAppInit.o TKTEST_OBJS = tkTestInit.o tkTest.o tkSquare.o tkOldTest.o \ $(@TK_WINDOWINGSYSTEM@_TKTEST_OBJS) WIDG_OBJS = tkButton.o tkEntry.o tkFrame.o tkListbox.o \ tkMenu.o tkMenubutton.o tkMenuDraw.o tkMessage.o \ tkPanedWindow.o tkScale.o tkScrollbar.o CANV_OBJS = tkCanvas.o tkCanvArc.o tkCanvBmap.o tkCanvImg.o \ tkCanvLine.o tkCanvPoly.o tkCanvPs.o tkCanvText.o \ tkCanvUtil.o tkCanvWind.o tkRectOval.o tkTrig.o IMAGE_OBJS = tkImage.o tkImgBmap.o tkImgGIF.o tkImgPNG.o tkImgPPM.o \ tkImgPhoto.o tkImgPhInstance.o TEXT_OBJS = tkText.o tkTextBTree.o tkTextDisp.o tkTextImage.o tkTextIndex.o \ tkTextMark.o tkTextTag.o tkTextWind.o # either tkUnixFont.o (default) or tkUnixRFont.o (if --enable-xft) # FONT_OBJS = @UNIX_FONT_OBJS@ GENERIC_OBJS = tk3d.o tkArgv.o tkAtom.o tkBind.o tkBitmap.o tkBusy.o \ tkClipboard.o \ tkCmds.o tkColor.o tkConfig.o tkConsole.o tkCursor.o tkError.o \ tkEvent.o tkFocus.o tkFont.o tkGet.o tkGC.o tkGeometry.o tkGrab.o \ tkGrid.o tkMain.o tkObj.o tkOldConfig.o tkOption.o tkPack.o tkPlace.o \ tkSelect.o tkStyle.o tkUndo.o tkUtil.o tkVisual.o tkWindow.o TTK_OBJS = \ ttkBlink.o ttkButton.o ttkCache.o ttkClamTheme.o ttkClassicTheme.o \ ttkDefaultTheme.o ttkElements.o ttkEntry.o ttkFrame.o ttkImage.o \ ttkInit.o ttkLabel.o ttkLayout.o ttkManager.o ttkNotebook.o \ ttkPanedwindow.o ttkProgress.o ttkScale.o ttkScrollbar.o ttkScroll.o \ ttkSeparator.o ttkSquare.o ttkState.o \ ttkTagSet.o ttkTheme.o ttkTrace.o ttkTrack.o ttkTreeview.o \ ttkWidget.o ttkStubInit.o STUB_OBJS = tkStubInit.o STUB_LIB_OBJS = tkStubLib.o ttkStubLib.o X11_OBJS = tkUnix.o tkUnix3d.o tkUnixButton.o tkUnixColor.o tkUnixConfig.o \ tkUnixCursor.o tkUnixDraw.o tkUnixEmbed.o tkUnixEvent.o \ tkUnixFocus.o $(FONT_OBJS) tkUnixInit.o tkUnixKey.o tkUnixMenu.o \ tkUnixMenubu.o tkUnixScale.o tkUnixScrlbr.o tkUnixSelect.o \ tkUnixSend.o tkUnixWm.o tkUnixXId.o AQUA_OBJS = tkMacOSXBitmap.o tkMacOSXButton.o tkMacOSXClipboard.o \ tkMacOSXColor.o tkMacOSXConfig.o tkMacOSXCursor.o tkMacOSXDebug.o \ tkMacOSXDialog.o tkMacOSXDraw.o tkMacOSXEmbed.o tkMacOSXEntry.o \ tkMacOSXEvent.o tkMacOSXFont.o tkMacOSXHLEvents.o tkMacOSXInit.o \ tkMacOSXKeyboard.o tkMacOSXKeyEvent.o tkMacOSXMenu.o \ tkMacOSXMenubutton.o tkMacOSXMenus.o tkMacOSXMouseEvent.o \ tkMacOSXNotify.o tkMacOSXRegion.o tkMacOSXScrlbr.o tkMacOSXSend.o \ tkMacOSXSubwindows.o tkMacOSXWindowEvent.o \ tkMacOSXWm.o tkMacOSXXStubs.o \ tkFileFilter.o tkMacWinMenu.o tkPointer.o tkUnix3d.o tkUnixScale.o \ xcolors.o xdraw.o xgc.o ximage.o xutil.o \ ttkMacOSXTheme.o AQUA_TKTEST_OBJS = tkMacOSXTest.o OBJS = $(GENERIC_OBJS) $(WIDG_OBJS) $(CANV_OBJS) $(IMAGE_OBJS) $(TEXT_OBJS) \ $(STUB_OBJS) $(TTK_OBJS) \ $(@TK_WINDOWINGSYSTEM@_OBJS) @PLAT_OBJS@ TK_DECLS = \ $(GENERIC_DIR)/tk.decls \ $(GENERIC_DIR)/tkInt.decls TTK_DECLS = \ $(TTK_DIR)/ttk.decls GENERIC_SRCS = \ $(GENERIC_DIR)/tk3d.c $(GENERIC_DIR)/tkArgv.c \ $(GENERIC_DIR)/tkAtom.c $(GENERIC_DIR)/tkBind.c \ $(GENERIC_DIR)/tkBitmap.c $(GENERIC_DIR)/tkBusy.c \ $(GENERIC_DIR)/tkClipboard.c \ $(GENERIC_DIR)/tkCmds.c $(GENERIC_DIR)/tkColor.c \ $(GENERIC_DIR)/tkConfig.c $(GENERIC_DIR)/tkCursor.c \ $(GENERIC_DIR)/tkError.c $(GENERIC_DIR)/tkEvent.c \ $(GENERIC_DIR)/tkFocus.c $(GENERIC_DIR)/tkFont.c \ $(GENERIC_DIR)/tkGet.c $(GENERIC_DIR)/tkGC.c \ $(GENERIC_DIR)/tkGeometry.c $(GENERIC_DIR)/tkGrab.c \ $(GENERIC_DIR)/tkGrid.c $(GENERIC_DIR)/tkConsole.c \ $(GENERIC_DIR)/tkMain.c $(GENERIC_DIR)/tkOption.c \ $(GENERIC_DIR)/tkPack.c $(GENERIC_DIR)/tkPlace.c \ $(GENERIC_DIR)/tkSelect.c $(GENERIC_DIR)/tkStyle.c \ $(GENERIC_DIR)/tkUndo.c $(GENERIC_DIR)/tkUtil.c \ $(GENERIC_DIR)/tkVisual.c $(GENERIC_DIR)/tkWindow.c \ $(GENERIC_DIR)/tkButton.c $(GENERIC_DIR)/tkObj.c \ $(GENERIC_DIR)/tkEntry.c $(GENERIC_DIR)/tkFrame.c \ $(GENERIC_DIR)/tkListbox.c $(GENERIC_DIR)/tkMenu.c \ $(GENERIC_DIR)/tkMenubutton.c $(GENERIC_DIR)/tkMenuDraw.c \ $(GENERIC_DIR)/tkMessage.c $(GENERIC_DIR)/tkPanedWindow.c \ $(GENERIC_DIR)/tkScale.c $(GENERIC_DIR)/tkScrollbar.c \ $(GENERIC_DIR)/tkCanvas.c $(GENERIC_DIR)/tkCanvArc.c \ $(GENERIC_DIR)/tkCanvBmap.c $(GENERIC_DIR)/tkCanvImg.c \ $(GENERIC_DIR)/tkCanvLine.c $(GENERIC_DIR)/tkCanvPoly.c \ $(GENERIC_DIR)/tkCanvPs.c $(GENERIC_DIR)/tkCanvText.c \ $(GENERIC_DIR)/tkCanvUtil.c \ $(GENERIC_DIR)/tkCanvWind.c $(GENERIC_DIR)/tkRectOval.c \ $(GENERIC_DIR)/tkTrig.c $(GENERIC_DIR)/tkImage.c \ $(GENERIC_DIR)/tkImgBmap.c $(GENERIC_DIR)/tkImgGIF.c \ $(GENERIC_DIR)/tkImgPNG.c $(GENERIC_DIR)/tkImgPPM.c \ $(GENERIC_DIR)/tkImgPhoto.c $(GENERIC_DIR)/tkImgPhInstance.c \ $(GENERIC_DIR)/tkText.c \ $(GENERIC_DIR)/tkTextBTree.c $(GENERIC_DIR)/tkTextDisp.c \ $(GENERIC_DIR)/tkTextImage.c \ $(GENERIC_DIR)/tkTextIndex.c $(GENERIC_DIR)/tkTextMark.c \ $(GENERIC_DIR)/tkTextTag.c $(GENERIC_DIR)/tkTextWind.c \ $(GENERIC_DIR)/tkOldConfig.c $(GENERIC_DIR)/tkOldTest.c \ $(GENERIC_DIR)/tkSquare.c $(GENERIC_DIR)/tkTest.c \ $(GENERIC_DIR)/tkStubInit.c TTK_SRCS = \ $(TTK_DIR)/ttkBlink.c \ $(TTK_DIR)/ttkButton.c \ $(TTK_DIR)/ttkCache.c \ $(TTK_DIR)/ttkClamTheme.c \ $(TTK_DIR)/ttkClassicTheme.c \ $(TTK_DIR)/ttkDefaultTheme.c \ $(TTK_DIR)/ttkElements.c \ $(TTK_DIR)/ttkEntry.c \ $(TTK_DIR)/ttkFrame.c \ $(TTK_DIR)/ttkImage.c \ $(TTK_DIR)/ttkInit.c \ $(TTK_DIR)/ttkLabel.c \ $(TTK_DIR)/ttkLayout.c \ $(TTK_DIR)/ttkManager.c \ $(TTK_DIR)/ttkNotebook.c \ $(TTK_DIR)/ttkPanedwindow.c \ $(TTK_DIR)/ttkProgress.c \ $(TTK_DIR)/ttkScale.c \ $(TTK_DIR)/ttkScrollbar.c \ $(TTK_DIR)/ttkScroll.c \ $(TTK_DIR)/ttkSeparator.c \ $(TTK_DIR)/ttkSquare.c \ $(TTK_DIR)/ttkState.c \ $(TTK_DIR)/ttkTagSet.c \ $(TTK_DIR)/ttkTheme.c \ $(TTK_DIR)/ttkTrace.c \ $(TTK_DIR)/ttkTrack.c \ $(TTK_DIR)/ttkTreeview.c \ $(TTK_DIR)/ttkWidget.c TTK_STUB_SRCS = \ $(TTK_DIR)/ttkStubInit.c $(TTK_DIR)/ttkStubLib.c X11_SRCS = \ $(UNIX_DIR)/tkAppInit.c $(UNIX_DIR)/tkUnix.c \ $(UNIX_DIR)/tkUnix3d.c \ $(UNIX_DIR)/tkUnixButton.c $(UNIX_DIR)/tkUnixColor.c \ $(UNIX_DIR)/tkUnixConfig.c \ $(UNIX_DIR)/tkUnixCursor.c \ $(UNIX_DIR)/tkUnixDraw.c \ $(UNIX_DIR)/tkUnixEmbed.c $(UNIX_DIR)/tkUnixEvent.c \ $(UNIX_DIR)/tkUnixFocus.c \ $(UNIX_DIR)/tkUnixRFont.c \ $(UNIX_DIR)/tkUnixFont.c $(UNIX_DIR)/tkUnixInit.c \ $(UNIX_DIR)/tkUnixKey.c \ $(UNIX_DIR)/tkUnixMenu.c $(UNIX_DIR)/tkUnixMenubu.c \ $(UNIX_DIR)/tkUnixScale.c $(UNIX_DIR)/tkUnixScrlbr.c \ $(UNIX_DIR)/tkUnixSelect.c \ $(UNIX_DIR)/tkUnixSend.c $(UNIX_DIR)/tkUnixWm.c \ $(UNIX_DIR)/tkUnixXId.c AQUA_SRCS = \ $(MAC_OSX_DIR)/tkMacOSXBitmap.c $(MAC_OSX_DIR)/tkMacOSXButton.c \ $(MAC_OSX_DIR)/tkMacOSXClipboard.c $(MAC_OSX_DIR)/tkMacOSXColor.c \ $(MAC_OSX_DIR)/tkMacOSXConfig.c $(MAC_OSX_DIR)/tkMacOSXCursor.c \ $(MAC_OSX_DIR)/tkMacOSXDebug.c $(MAC_OSX_DIR)/tkMacOSXDialog.c \ $(MAC_OSX_DIR)/tkMacOSXDraw.c $(MAC_OSX_DIR)/tkMacOSXEmbed.c \ $(MAC_OSX_DIR)/tkMacOSXEntry.c $(MAC_OSX_DIR)/tkMacOSXEvent.c \ $(MAC_OSX_DIR)/tkMacOSXFont.c $(MAC_OSX_DIR)/tkMacOSXHLEvents.c \ $(MAC_OSX_DIR)/tkMacOSXInit.c $(MAC_OSX_DIR)/tkMacOSXKeyboard.c \ $(MAC_OSX_DIR)/tkMacOSXKeyEvent.c $(MAC_OSX_DIR)/tkMacOSXMenu.c \ $(MAC_OSX_DIR)/tkMacOSXMenubutton.c $(MAC_OSX_DIR)/tkMacOSXMenus.c \ $(MAC_OSX_DIR)/tkMacOSXMouseEvent.c $(MAC_OSX_DIR)/tkMacOSXNotify.c \ $(MAC_OSX_DIR)/tkMacOSXRegion.c $(MAC_OSX_DIR)/tkMacOSXScrlbr.c \ $(MAC_OSX_DIR)/tkMacOSXSend.c $(MAC_OSX_DIR)/tkMacOSXSubwindows.c \ $(MAC_OSX_DIR)/tkMacOSXTest.c $(MAC_OSX_DIR)/tkMacOSXWindowEvent.c \ $(MAC_OSX_DIR)/tkMacOSXWm.c $(MAC_OSX_DIR)/tkMacOSXXStubs.c \ $(GENERIC_DIR)/tkFileFilter.c $(GENERIC_DIR)/tkMacWinMenu.c \ $(GENERIC_DIR)/tkPointer.c $(UNIX_DIR)/tkUnix3d.c \ $(UNIX_DIR)/tkUnixScale.c $(XLIB_DIR)/xcolors.c $(XLIB_DIR)/xdraw.c \ $(XLIB_DIR)/xgc.c $(XLIB_DIR)/ximage.c $(XLIB_DIR)/xutil.c \ $(TTK_DIR)/ttkMacOSXTheme.c SRCS = $(GENERIC_SRCS) $(@TK_WINDOWINGSYSTEM@_SRCS) @PLAT_SRCS@ AQUA_RESOURCES = \ $(MAC_OSX_DIR)/tkAboutDlg.r $(MAC_OSX_DIR)/tkMacOSXCursors.r \ $(MAC_OSX_DIR)/tkMacOSXXCursors.r AQUA_WISH_RESOURCES = $(MAC_OSX_DIR)/tkMacOSXAETE.r AQUA_HDRS = $(MAC_OSX_DIR)/tkMacOSX.h $(GENERIC_DIR)/tkIntXlibDecls.h AQUA_XLIB_HDRS = $(XLIB_DIR)/X11/*.h $(XLIB_DIR)/xbytes.h AQUA_PRIVATE_HDRS = $(MAC_OSX_DIR)/tkMacOSXPort.h $(MAC_OSX_DIR)/tkMacOSXInt.h X11_PRIVATE_HDRS = $(UNIX_DIR)/tkUnixPort.h $(UNIX_DIR)/tkUnixInt.h $(GENERIC_DIR)/tkIntXlibDecls.h # Currently private, eventually public TTK_HDRS = $(TTK_DIR)/ttkTheme.h $(TTK_DIR)/ttkDecls.h PUBLIC_HDRS = $(GENERIC_DIR)/tk.h $(GENERIC_DIR)/tkDecls.h \ $(GENERIC_DIR)/tkPlatDecls.h $(@TK_WINDOWINGSYSTEM@_HDRS) # The private headers we want installed for install-private-headers PRIVATE_HDRS = $(GENERIC_DIR)/tkInt.h $(GENERIC_DIR)/tkIntDecls.h \ $(GENERIC_DIR)/tkIntPlatDecls.h $(GENERIC_DIR)/tkPort.h \ $(TTK_HDRS) $(@TK_WINDOWINGSYSTEM@_PRIVATE_HDRS) DEMOPROGS = browse hello ixset rmt rolodex square tcolor timer widget SHELL_ENV = \ @LD_LIBRARY_PATH_VAR@="`pwd`:${TCL_BIN_DIR}:$${@LD_LIBRARY_PATH_VAR@}"; \ export @LD_LIBRARY_PATH_VAR@; \ TCL_LIBRARY=@TCL_SRC_DIR@/library; export TCL_LIBRARY; \ TK_LIBRARY=@TK_SRC_DIR@/library; export TK_LIBRARY; all: binaries libraries doc binaries: ${LIB_FILE} ${WISH_EXE} libraries: $(TOP_DIR)/doc/man.macros: $(INSTALL_DATA) @TCL_SRC_DIR@/doc/man.macros $(TOP_DIR)/doc/man.macros doc: $(TOP_DIR)/doc/man.macros # The following target is configured by autoconf to generate either # a shared library or non-shared library for Tk. ${LIB_FILE}: ${STUB_LIB_FILE} @LIB_RSRC_FILE@ ${OBJS} rm -f $@ @MAKE_LIB@ ${STUB_LIB_FILE}: ${STUB_LIB_OBJS} @if test "x${LIB_FILE}" = "xlibtk${MAJOR_VERSION}.${MINOR_VERSION}.dll"; then \ (cd ${TOP_DIR}/win; ${MAKE} tk${MAJOR_VERSION}${MINOR_VERSION}.dll); \ cp "${TOP_DIR}/win/tk${MAJOR_VERSION}${MINOR_VERSION}.dll" .; \ fi rm -f $@ @MAKE_STUB_LIB@ # Build Aqua resource files ${TK_RSRC_FILE}: $(AQUA_RESOURCES) rm -f $@ if test "$(REZ)" != ""; then \ $(REZ) -o $@ $(REZ_SWITCHES) $(AQUA_RESOURCES); fi ${WISH_RSRC_FILE}: $(AQUA_WISH_RESOURCES) rm -f $@ if test "$(REZ)" != ""; then \ $(REZ) -o $@ $(REZ_SWITCHES) $(AQUA_WISH_RESOURCES); fi # Make target which outputs the list of the .o contained in the Tk lib # usefull to build a single big shared library containing Tcl/Tk and other # extensions. used for the Tcl Plugin. -- dl tkLibObjs: @echo ${OBJS} # This targets actually build the objects needed for the lib in the above # case objs: ${OBJS} ${WISH_EXE}: $(TK_STUB_LIB_FILE) $(WISH_OBJS) $(TK_LIB_FILE) @APP_RSRC_FILE@ ${CC} ${CFLAGS} ${LDFLAGS} $(WISH_OBJS) @TK_BUILD_LIB_SPEC@ \ $(WISH_LIBS) $(CC_SEARCH_FLAGS) -o ${WISH_EXE} # Resetting the LIB_RUNTIME_DIR below is required so that # the generated tktest executable gets the build directory # burned into its ld search path. This keeps tktest from # picking up an already installed version of the Tcl or # Tk shared libraries. $(TKTEST_EXE): $(TKTEST_OBJS) $(TK_LIB_FILE) $(MAKE) tktest-real LIB_RUNTIME_DIR="`pwd`:$(TCL_BIN_DIR)" tktest-real: ${TK_STUB_LIB_FILE} ${CC} ${CFLAGS} ${LDFLAGS} $(TKTEST_OBJS) ${TK_STUB_LIB_FILE} ${TCL_STUB_LIB_SPEC} @TK_BUILD_LIB_SPEC@ \ $(WISH_LIBS) $(CC_SEARCH_FLAGS) -o $(TKTEST_EXE) # # FIXME: This xttest rule seems to be broken in a number of ways. It should # # use CC_SEARCH_FLAGS, it does not include the shared lib location logic from # # tktest, and it is not clear where this test.o object file comes from. # # xttest: test.o tkTest.o tkSquare.o $(TK_LIB_FILE) ${TK_STUB_LIB_FILE} # ${CC} ${CFLAGS} ${LDFLAGS} test.o tkTest.o tkSquare.o \ # @TK_BUILD_LIB_SPEC@ ${TK_STUB_LIB_FILE} ${TCL_STUB_LIB_SPEC} \ # $(WISH_LIBS) $(LD_SEARCH_FLAGS) -lXt -o xttest # Note, in the target below TCL_LIBRARY needs to be set or else # "make test" won't work in the case where the compilation directory # isn't the same as the source directory. # Specifying TESTFLAGS on the command line is the standard way to pass # args to tcltest, ie: # % make test TESTFLAGS="-verbose bps -file fileName.test" test: test-classic test-ttk test-classic: $(TKTEST_EXE) $(SHELL_ENV) ./$(TKTEST_EXE) $(TEST_DIR)/all.tcl -geometry +0+0 $(TESTFLAGS) test-ttk: $(TKTEST_EXE) $(SHELL_ENV) ./$(TKTEST_EXE) $(TEST_DIR)/ttk/all.tcl -geometry +0+0 \ $(TESTFLAGS) # Tests with different languages testlang: $(TKTEST_EXE) $(SHELL_ENV) \ for lang in $(LOCALES) ; \ do \ LANG=$(lang); export LANG; \ ./$(TKTEST_EXE) $(TEST_DIR)/all.tcl -geometry +0+0 \ $(TESTFLAGS); \ done # Useful target to launch a built tktest with the proper path,... runtest: $(TKTEST_EXE) $(SHELL_ENV) ./$(TKTEST_EXE) # This target can be used to run wish from the build directory # via `make shell` or `make shell SCRIPT=/tmp/foo.tcl` shell: ${WISH_EXE} $(SHELL_ENV) ./${WISH_EXE} $(SCRIPT) demo: $(SHELL_ENV) ./${WISH_EXE} $(TOP_DIR)/library/demos/widget # This target can be used to run wish inside either gdb or insight gdb: ${WISH_EXE} @echo "set env @LD_LIBRARY_PATH_VAR@=\"`pwd`:${TCL_BIN_DIR}:$${@LD_LIBRARY_PATH_VAR@}\"" > gdb.run @echo "set env TCL_LIBRARY=@TCL_SRC_DIR@/library" >> gdb.run @echo "set env TK_LIBRARY=@TK_SRC_DIR@/library" >> gdb.run gdb ./${WISH_EXE} --command=gdb.run rm gdb.run VALGRINDARGS=--tool=memcheck --num-callers=8 --leak-resolution=high --leak-check=yes --show-reachable=yes -v valgrind: $(TKTEST_EXE) $(SHELL_ENV) valgrind $(VALGRINDARGS) ./$(TKTEST_EXE) $(TEST_DIR)/all.tcl -geometry +0+0 -singleproc 1 $(TESTFLAGS) valgrindshell: $(TKTEST_EXE) $(SHELL_ENV) valgrind $(VALGRINDARGS) ./$(TKTEST_EXE) $(SCRIPT) INSTALL_BASE_TARGETS = install-binaries install-libraries INSTALL_DOC_TARGETS = install-doc INSTALL_DEV_TARGETS = install-headers INSTALL_DEMO_TARGETS = install-demos INSTALL_EXTRA_TARGETS = @EXTRA_INSTALL@ INSTALL_TARGETS = $(INSTALL_BASE_TARGETS) $(INSTALL_DOC_TARGETS) $(INSTALL_DEV_TARGETS) \ $(INSTALL_DEMO_TARGETS) $(INSTALL_EXTRA_TARGETS) install: $(INSTALL_TARGETS) install-strip: $(MAKE) $(INSTALL_TARGETS) \ INSTALL_PROGRAM="$(INSTALL_PROGRAM) ${INSTALL_STRIP_PROGRAM}" \ INSTALL_LIBRARY="$(INSTALL_LIBRARY) ${INSTALL_STRIP_LIBRARY}" install-binaries: $(TK_STUB_LIB_FILE) $(TK_LIB_FILE) ${WISH_EXE} @for i in "$(LIB_INSTALL_DIR)" "$(BIN_INSTALL_DIR)" \ "$(PKG_INSTALL_DIR)" "$(CONFIG_INSTALL_DIR)" ; \ do \ if [ ! -d "$$i" ] ; then \ echo "Making directory $$i"; \ $(INSTALL_DATA_DIR) "$$i"; \ else true; \ fi; \ done; @if test "x$(TK_SHARED_BUILD)" = "x1"; then \ echo "Creating package index $(PKG_INDEX)"; \ rm -f "$(PKG_INDEX)"; \ (\ echo "if {[catch {package present Tcl 8.6.0}]} return";\ relative=`echo | awk '{ORS=" "; split("$(TK_PKG_DIR)",a,"/"); for (f in a) {print ".."}}'`;\ if test "x$(DLL_INSTALL_DIR)" != "x$(BIN_INSTALL_DIR)"; then \ echo "package ifneeded Tk $(MAJOR_VERSION).$(MINOR_VERSION)$(PATCH_LEVEL) [list load [file normalize [file join \$$dir $${relative}$(TK_LIB_FILE)]] Tk]";\ else \ echo "if {(\$$::tcl_platform(platform) eq \"unix\") && ([info exists ::env(DISPLAY)]";\ echo " || ([info exists ::argv] && (\"-display\" in \$$::argv)))} {";\ echo " package ifneeded Tk $(MAJOR_VERSION).$(MINOR_VERSION)$(PATCH_LEVEL) [list load [file normalize [file join \$$dir $${relative}.. bin $(TK_LIB_FILE)]] Tk]";\ echo "} else {";\ echo " package ifneeded Tk $(MAJOR_VERSION).$(MINOR_VERSION)$(PATCH_LEVEL) [list load [file normalize [file join \$$dir $${relative}.. bin tk${MAJOR_VERSION}${MINOR_VERSION}.dll]] Tk]";\ echo "}";\ fi \ ) > "$(PKG_INDEX)"; \ fi @echo "Installing $(LIB_FILE) to $(DLL_INSTALL_DIR)/" @@INSTALL_LIB@ @chmod 555 "$(DLL_INSTALL_DIR)/$(LIB_FILE)" @if test -f "tk${MAJOR_VERSION}${MINOR_VERSION}.dll"; then \ $(INSTALL_LIBRARY) "tk${MAJOR_VERSION}${MINOR_VERSION}.dll" "$(DLL_INSTALL_DIR)";\ chmod 555 "$(DLL_INSTALL_DIR)/tk${MAJOR_VERSION}${MINOR_VERSION}.dll";\ $(INSTALL_LIBRARY) "../win/libtk${MAJOR_VERSION}${MINOR_VERSION}.a" "$(LIB_INSTALL_DIR)";\ chmod 555 "$(LIB_INSTALL_DIR)/libtk${MAJOR_VERSION}${MINOR_VERSION}.a";\ fi @echo "Installing ${WISH_EXE} as $(BIN_INSTALL_DIR)/wish$(VERSION)${EXE_SUFFIX}" @$(INSTALL_PROGRAM) ${WISH_EXE} "$(BIN_INSTALL_DIR)/wish$(VERSION)${EXE_SUFFIX}" @echo "Installing tkConfig.sh to $(CONFIG_INSTALL_DIR)/" @$(INSTALL_DATA) tkConfig.sh "$(CONFIG_INSTALL_DIR)/tkConfig.sh" @if test "$(STUB_LIB_FILE)" != "" ; then \ echo "Installing $(STUB_LIB_FILE) to $(LIB_INSTALL_DIR)/"; \ @INSTALL_STUB_LIB@ ; \ fi @EXTRA_INSTALL_BINARIES@ @echo "Installing pkg-config file to $(LIB_INSTALL_DIR)/pkgconfig/" @$(INSTALL_DATA_DIR) $(LIB_INSTALL_DIR)/pkgconfig @$(INSTALL_DATA) tk.pc $(LIB_INSTALL_DIR)/pkgconfig/tk.pc install-libraries: libraries @for i in "$(SCRIPT_INSTALL_DIR)" "$(SCRIPT_INSTALL_DIR)/images" \ "$(SCRIPT_INSTALL_DIR)/msgs" "$(SCRIPT_INSTALL_DIR)/ttk"; \ do \ if [ -n "$$i" -a ! -d "$$i" ] ; then \ echo "Making directory $$i"; \ $(INSTALL_DATA_DIR) "$$i"; \ else true; \ fi; \ done; @echo "Installing Tk library files to $(SCRIPT_INSTALL_DIR)/"; @for i in $(TOP_DIR)/library/*.tcl $(TOP_DIR)/library/tclIndex \ $(UNIX_DIR)/tkAppInit.c; \ do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"; \ done; @echo "Installing Ttk library files to $(SCRIPT_INSTALL_DIR)/ttk/"; @for i in $(TOP_DIR)/library/ttk/*.tcl; \ do \ if [ -f $$i ] ; then \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/ttk"; \ fi; \ done; @echo "Installing library image files to $(SCRIPT_INSTALL_DIR)/images/"; @for i in $(TOP_DIR)/library/images/*; \ do \ if [ -f $$i ] ; then \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/images"; \ fi; \ done; @echo "Installing message catalog files to $(SCRIPT_INSTALL_DIR)/msgs/"; @for i in $(TOP_DIR)/library/msgs/*.msg; \ do \ if [ -f $$i ] ; then \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/msgs"; \ fi; \ done; install-demos: @for i in "$(DEMO_INSTALL_DIR)" "$(DEMO_INSTALL_DIR)/images" ; \ do \ if [ ! -d "$$i" ] ; then \ echo "Making directory $$i"; \ $(INSTALL_DATA_DIR) "$$i"; \ else true; \ fi; \ done; @echo "Installing demo files to $(DEMO_INSTALL_DIR)/"; @for i in $(TOP_DIR)/library/demos/*; \ do \ if [ -f $$i ] ; then \ sed -e '3 s|exec wish|exec wish$(VERSION)|' \ $$i > "$(DEMO_INSTALL_DIR)"/`basename $$i`; \ fi; \ done; @for i in $(DEMOPROGS); \ do \ if test $$i = "square"; then \ rm -f "$(DEMO_INSTALL_DIR)/$$i"; \ else \ chmod 755 "$(DEMO_INSTALL_DIR)/$$i"; \ fi; \ done; @echo "Installing demo image files to $(DEMO_INSTALL_DIR)/images/"; @for i in $(TOP_DIR)/library/demos/images/*; \ do \ if [ -f $$i ] ; then \ $(INSTALL_DATA) $$i "$(DEMO_INSTALL_DIR)/images"; \ fi; \ done; install-doc: @for i in "$(MAN_INSTALL_DIR)" "$(MAN1_INSTALL_DIR)" "$(MAN3_INSTALL_DIR)" "$(MANN_INSTALL_DIR)" ; \ do \ if [ ! -d "$$i" ] ; then \ echo "Making directory $$i"; \ $(INSTALL_DATA_DIR) "$$i"; \ else true; \ fi; \ done; @echo "Installing and cross-linking top-level (.1) docs to $(MAN1_INSTALL_DIR)/"; @for i in $(TOP_DIR)/doc/*.1; do \ $(SHELL) $(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i "$(MAN1_INSTALL_DIR)"; \ done @echo "Installing and cross-linking C API (.3) docs to $(MAN3_INSTALL_DIR)/"; @for i in $(TOP_DIR)/doc/*.3; do \ $(SHELL) $(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i "$(MAN3_INSTALL_DIR)"; \ done @echo "Installing and cross-linking command (.n) docs to $(MANN_INSTALL_DIR)/"; @for i in $(TOP_DIR)/doc/*.n; do \ $(SHELL) $(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i "$(MANN_INSTALL_DIR)"; \ done install-headers: @if test "$(@TK_WINDOWINGSYSTEM@_XLIB_HDRS)" != ""; then \ XLIB_INCLUDE_INSTALL_DIR="$(INCLUDE_INSTALL_DIR)"/X11; fi; \ for i in "$(INCLUDE_INSTALL_DIR)" "$${XLIB_INCLUDE_INSTALL_DIR}"; \ do \ if [ -n "$$i" -a ! -d "$$i" ] ; then \ echo "Making directory $$i"; \ $(INSTALL_DATA_DIR) "$$i"; \ else true; \ fi; \ done; @echo "Installing header files to $(INCLUDE_INSTALL_DIR)/"; @for i in $(PUBLIC_HDRS); \ do \ $(INSTALL_DATA) $$i "$(INCLUDE_INSTALL_DIR)"; \ done; @list='$(@TK_WINDOWINGSYSTEM@_XLIB_HDRS)'; for i in $$list ; \ do \ $(INSTALL_DATA) $$i "$(INCLUDE_INSTALL_DIR)/X11"; \ done; # Optional target to install private headers install-private-headers: @for i in "$(PRIVATE_INCLUDE_INSTALL_DIR)"; \ do \ if [ ! -d "$$i" ] ; then \ echo "Making directory $$i"; \ $(INSTALL_DATA_DIR) "$$i"; \ else true; \ fi; \ done; @echo "Installing private header files to $(PRIVATE_INCLUDE_INSTALL_DIR)/"; @for i in $(PRIVATE_HDRS); \ do \ $(INSTALL_DATA) $$i "$(PRIVATE_INCLUDE_INSTALL_DIR)"; \ done; @if test -f tkConfig.h; then\ $(INSTALL_DATA) tkConfig.h "$(PRIVATE_INCLUDE_INSTALL_DIR)"; \ fi; Makefile: $(UNIX_DIR)/Makefile.in $(SHELL) config.status #tkConfig.h: $(UNIX_DIR)/tkConfig.h.in # $(SHELL) config.status clean: rm -f *.a *.o libtk* core errs *~ \#* TAGS *.E a.out \ errors ${WISH_EXE} $(TKTEST_EXE) lib.exp Tk *.rsrc distclean: clean rm -rf Makefile config.status config.cache config.log tkConfig.sh \ tkConfig.h *.plist Tk.framework tk.pc depend: makedepend -- $(DEPEND_SWITCHES) -- $(SRCS) # Test binaries. The rule for tkTestInit.o is complicated because # it is is compiled from tkAppInit.c. Can't use the "-o" option # because this doesn't work on some strange compilers (e.g. UnixWare). # To enable concurrent parallel make of wish and tktest, this target has to # depend on wish, this ensures that linking of wish with tkTestInit.o does not # execute concurrently with the renaming and recompiling of that same object # file in the target below. tkTestInit.o: $(UNIX_DIR)/tkAppInit.c ${WISH_EXE} @if test -f tkAppInit.o ; then \ rm -f tkAppInit.sav; \ mv tkAppInit.o tkAppInit.sav; \ fi; $(CC) -c $(APP_CC_SWITCHES) -DTK_TEST $(UNIX_DIR)/tkAppInit.c rm -f tkTestInit.o mv tkAppInit.o tkTestInit.o @if test -f tkAppInit.sav ; then \ mv tkAppInit.sav tkAppInit.o; \ fi; tkAppInit.o: $(UNIX_DIR)/tkAppInit.c $(CC) -c $(APP_CC_SWITCHES) $(UNIX_DIR)/tkAppInit.c tk3d.o: $(GENERIC_DIR)/tk3d.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tk3d.c tkArgv.o: $(GENERIC_DIR)/tkArgv.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkArgv.c tkAtom.o: $(GENERIC_DIR)/tkAtom.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkAtom.c tkBind.o: $(GENERIC_DIR)/tkBind.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkBind.c tkBitmap.o: $(GENERIC_DIR)/tkBitmap.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkBitmap.c tkBusy.o: $(GENERIC_DIR)/tkBusy.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkBusy.c tkClipboard.o: $(GENERIC_DIR)/tkClipboard.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkClipboard.c tkCmds.o: $(GENERIC_DIR)/tkCmds.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkCmds.c tkColor.o: $(GENERIC_DIR)/tkColor.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkColor.c tkConfig.o: $(GENERIC_DIR)/tkConfig.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkConfig.c tkConsole.o: $(GENERIC_DIR)/tkConsole.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkConsole.c tkCursor.o: $(GENERIC_DIR)/tkCursor.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkCursor.c tkError.o: $(GENERIC_DIR)/tkError.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkError.c tkEvent.o: $(GENERIC_DIR)/tkEvent.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkEvent.c tkFocus.o: $(GENERIC_DIR)/tkFocus.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkFocus.c tkFont.o: $(GENERIC_DIR)/tkFont.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkFont.c tkGet.o: $(GENERIC_DIR)/tkGet.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkGet.c tkGC.o: $(GENERIC_DIR)/tkGC.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkGC.c tkGeometry.o: $(GENERIC_DIR)/tkGeometry.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkGeometry.c tkGrab.o: $(GENERIC_DIR)/tkGrab.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkGrab.c tkGrid.o: $(GENERIC_DIR)/tkGrid.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkGrid.c tkMain.o: $(GENERIC_DIR)/tkMain.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkMain.c tkObj.o: $(GENERIC_DIR)/tkObj.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkObj.c tkOldConfig.o: $(GENERIC_DIR)/tkOldConfig.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkOldConfig.c tkOption.o: $(GENERIC_DIR)/tkOption.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkOption.c tkPack.o: $(GENERIC_DIR)/tkPack.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkPack.c tkPlace.o: $(GENERIC_DIR)/tkPlace.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkPlace.c tkSelect.o: $(GENERIC_DIR)/tkSelect.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkSelect.c tkStyle.o: $(GENERIC_DIR)/tkStyle.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkStyle.c tkUtil.o: $(GENERIC_DIR)/tkUtil.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkUtil.c tkVisual.o: $(GENERIC_DIR)/tkVisual.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkVisual.c tkWindow.o: $(GENERIC_DIR)/tkWindow.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkWindow.c tkButton.o: $(GENERIC_DIR)/tkButton.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkButton.c tkEntry.o: $(GENERIC_DIR)/tkEntry.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkEntry.c tkFrame.o: $(GENERIC_DIR)/tkFrame.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkFrame.c tkListbox.o: $(GENERIC_DIR)/tkListbox.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkListbox.c tkMenu.o: $(GENERIC_DIR)/tkMenu.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkMenu.c tkMenubutton.o: $(GENERIC_DIR)/tkMenubutton.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkMenubutton.c tkMenuDraw.o: $(GENERIC_DIR)/tkMenuDraw.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkMenuDraw.c tkMessage.o: $(GENERIC_DIR)/tkMessage.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkMessage.c tkPanedWindow.o: $(GENERIC_DIR)/tkPanedWindow.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkPanedWindow.c tkScale.o: $(GENERIC_DIR)/tkScale.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkScale.c tkScrollbar.o: $(GENERIC_DIR)/tkScrollbar.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkScrollbar.c tkSquare.o: $(GENERIC_DIR)/tkSquare.c $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tkSquare.c tkCanvas.o: $(GENERIC_DIR)/tkCanvas.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkCanvas.c tkCanvArc.o: $(GENERIC_DIR)/tkCanvArc.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkCanvArc.c tkCanvBmap.o: $(GENERIC_DIR)/tkCanvBmap.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkCanvBmap.c tkCanvImg.o: $(GENERIC_DIR)/tkCanvImg.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkCanvImg.c tkCanvLine.o: $(GENERIC_DIR)/tkCanvLine.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkCanvLine.c tkCanvPoly.o: $(GENERIC_DIR)/tkCanvPoly.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkCanvPoly.c tkCanvPs.o: $(GENERIC_DIR)/tkCanvPs.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkCanvPs.c tkCanvText.o: $(GENERIC_DIR)/tkCanvText.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkCanvText.c tkCanvUtil.o: $(GENERIC_DIR)/tkCanvUtil.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkCanvUtil.c tkCanvWind.o: $(GENERIC_DIR)/tkCanvWind.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkCanvWind.c tkRectOval.o: $(GENERIC_DIR)/tkRectOval.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkRectOval.c tkTrig.o: $(GENERIC_DIR)/tkTrig.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkTrig.c tkImage.o: $(GENERIC_DIR)/tkImage.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkImage.c tkImgBmap.o: $(GENERIC_DIR)/tkImgBmap.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkImgBmap.c tkImgGIF.o: $(GENERIC_DIR)/tkImgGIF.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkImgGIF.c tkImgPNG.o: $(GENERIC_DIR)/tkImgPNG.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkImgPNG.c tkImgPPM.o: $(GENERIC_DIR)/tkImgPPM.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkImgPPM.c tkImgPhoto.o: $(GENERIC_DIR)/tkImgPhoto.c $(GENERIC_DIR)/tkImgPhoto.h $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkImgPhoto.c tkImgPhInstance.o: $(GENERIC_DIR)/tkImgPhInstance.c $(GENERIC_DIR)/tkImgPhoto.h $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkImgPhInstance.c tkOldTest.o: $(GENERIC_DIR)/tkOldTest.c $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tkOldTest.c tkTest.o: $(GENERIC_DIR)/tkTest.c $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tkTest.c tkText.o: $(GENERIC_DIR)/tkText.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkText.c tkTextBTree.o: $(GENERIC_DIR)/tkTextBTree.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkTextBTree.c tkTextDisp.o: $(GENERIC_DIR)/tkTextDisp.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkTextDisp.c tkTextImage.o: $(GENERIC_DIR)/tkTextImage.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkTextImage.c tkTextIndex.o: $(GENERIC_DIR)/tkTextIndex.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkTextIndex.c tkTextMark.o: $(GENERIC_DIR)/tkTextMark.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkTextMark.c tkTextTag.o: $(GENERIC_DIR)/tkTextTag.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkTextTag.c tkTextWind.o: $(GENERIC_DIR)/tkTextWind.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkTextWind.c tkStubInit.o: $(GENERIC_DIR)/tkStubInit.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkStubInit.c # Stub library binaries, these must be compiled for use in a shared library # even though they will be placed in a static archive tkStubLib.o: $(GENERIC_DIR)/tkStubLib.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkStubLib.c tkUndo.o: $(GENERIC_DIR)/tkUndo.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkUndo.c tkUnix.o: $(UNIX_DIR)/tkUnix.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tkUnix.c tkUnix3d.o: $(UNIX_DIR)/tkUnix3d.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tkUnix3d.c tkUnixButton.o: $(UNIX_DIR)/tkUnixButton.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tkUnixButton.c tkUnixColor.o: $(UNIX_DIR)/tkUnixColor.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tkUnixColor.c tkUnixConfig.o: $(UNIX_DIR)/tkUnixConfig.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tkUnixConfig.c tkUnixCursor.o: $(UNIX_DIR)/tkUnixCursor.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tkUnixCursor.c tkUnixDraw.o: $(UNIX_DIR)/tkUnixDraw.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tkUnixDraw.c tkUnixEmbed.o: $(UNIX_DIR)/tkUnixEmbed.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tkUnixEmbed.c tkUnixEvent.o: $(UNIX_DIR)/tkUnixEvent.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tkUnixEvent.c tkUnixFocus.o: $(UNIX_DIR)/tkUnixFocus.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tkUnixFocus.c tkUnixFont.o: $(UNIX_DIR)/tkUnixFont.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tkUnixFont.c # NB: tkUnixRFont.o uses nondefault CFLAGS tkUnixRFont.o: $(UNIX_DIR)/tkUnixRFont.c $(CC) -c $(CC_SWITCHES) $(XFT_CFLAGS) $(UNIX_DIR)/tkUnixRFont.c tkUnixInit.o: $(UNIX_DIR)/tkUnixInit.c tkConfig.sh $(CC) -c $(CC_SWITCHES) -DTK_LIBRARY=\"${TK_LIBRARY}\" \ $(UNIX_DIR)/tkUnixInit.c tkUnixKey.o: $(UNIX_DIR)/tkUnixKey.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tkUnixKey.c tkUnixMenu.o: $(UNIX_DIR)/tkUnixMenu.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tkUnixMenu.c tkUnixMenubu.o: $(UNIX_DIR)/tkUnixMenubu.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tkUnixMenubu.c tkUnixScale.o: $(UNIX_DIR)/tkUnixScale.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tkUnixScale.c tkUnixScrlbr.o: $(UNIX_DIR)/tkUnixScrlbr.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tkUnixScrlbr.c tkUnixSelect.o: $(UNIX_DIR)/tkUnixSelect.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tkUnixSelect.c tkUnixSend.o: $(UNIX_DIR)/tkUnixSend.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tkUnixSend.c tkUnixWm.o: $(UNIX_DIR)/tkUnixWm.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tkUnixWm.c tkUnixXId.o: $(UNIX_DIR)/tkUnixXId.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tkUnixXId.c tkMacOSXBitmap.o: $(MAC_OSX_DIR)/tkMacOSXBitmap.c $(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tkMacOSXBitmap.c tkMacOSXButton.o: $(MAC_OSX_DIR)/tkMacOSXButton.c $(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tkMacOSXButton.c tkMacOSXClipboard.o: $(MAC_OSX_DIR)/tkMacOSXClipboard.c $(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tkMacOSXClipboard.c tkMacOSXColor.o: $(MAC_OSX_DIR)/tkMacOSXColor.c $(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tkMacOSXColor.c tkMacOSXConfig.o: $(MAC_OSX_DIR)/tkMacOSXConfig.c $(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tkMacOSXConfig.c tkMacOSXCursor.o: $(MAC_OSX_DIR)/tkMacOSXCursor.c $(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tkMacOSXCursor.c tkMacOSXDebug.o: $(MAC_OSX_DIR)/tkMacOSXDebug.c $(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tkMacOSXDebug.c tkMacOSXDialog.o: $(MAC_OSX_DIR)/tkMacOSXDialog.c $(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tkMacOSXDialog.c tkMacOSXDraw.o: $(MAC_OSX_DIR)/tkMacOSXDraw.c $(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tkMacOSXDraw.c tkMacOSXEmbed.o: $(MAC_OSX_DIR)/tkMacOSXEmbed.c $(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tkMacOSXEmbed.c tkMacOSXEntry.o: $(MAC_OSX_DIR)/tkMacOSXEntry.c $(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tkMacOSXEntry.c tkMacOSXEvent.o: $(MAC_OSX_DIR)/tkMacOSXEvent.c $(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tkMacOSXEvent.c tkMacOSXFont.o: $(MAC_OSX_DIR)/tkMacOSXFont.c $(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tkMacOSXFont.c tkMacOSXHLEvents.o: $(MAC_OSX_DIR)/tkMacOSXHLEvents.c $(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tkMacOSXHLEvents.c tkMacOSXInit.o: $(MAC_OSX_DIR)/tkMacOSXInit.c tkConfig.sh $(CC) -c $(CC_SWITCHES) -DTK_LIBRARY=\"${TK_LIBRARY}\" \ $(MAC_OSX_DIR)/tkMacOSXInit.c tkMacOSXKeyboard.o: $(MAC_OSX_DIR)/tkMacOSXKeyboard.c $(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tkMacOSXKeyboard.c tkMacOSXKeyEvent.o: $(MAC_OSX_DIR)/tkMacOSXKeyEvent.c $(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tkMacOSXKeyEvent.c tkMacOSXMenu.o: $(MAC_OSX_DIR)/tkMacOSXMenu.c $(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tkMacOSXMenu.c tkMacOSXMenubutton.o: $(MAC_OSX_DIR)/tkMacOSXMenubutton.c $(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tkMacOSXMenubutton.c tkMacOSXMenus.o: $(MAC_OSX_DIR)/tkMacOSXMenus.c $(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tkMacOSXMenus.c tkMacOSXMouseEvent.o: $(MAC_OSX_DIR)/tkMacOSXMouseEvent.c $(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tkMacOSXMouseEvent.c tkMacOSXNotify.o: $(MAC_OSX_DIR)/tkMacOSXNotify.c $(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tkMacOSXNotify.c tkMacOSXRegion.o: $(MAC_OSX_DIR)/tkMacOSXRegion.c $(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tkMacOSXRegion.c tkMacOSXScale.o: $(MAC_OSX_DIR)/tkMacOSXScale.c $(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tkMacOSXScale.c tkMacOSXScrlbr.o: $(MAC_OSX_DIR)/tkMacOSXScrlbr.c $(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tkMacOSXScrlbr.c tkMacOSXSend.o: $(MAC_OSX_DIR)/tkMacOSXSend.c $(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tkMacOSXSend.c tkMacOSXSubwindows.o: $(MAC_OSX_DIR)/tkMacOSXSubwindows.c $(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tkMacOSXSubwindows.c tkMacOSXTest.o: $(MAC_OSX_DIR)/tkMacOSXTest.c $(CC) -c $(APP_CC_SWITCHES) $(MAC_OSX_DIR)/tkMacOSXTest.c tkMacOSXWindowEvent.o: $(MAC_OSX_DIR)/tkMacOSXWindowEvent.c $(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tkMacOSXWindowEvent.c tkMacOSXWm.o: $(MAC_OSX_DIR)/tkMacOSXWm.c $(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tkMacOSXWm.c tkMacOSXXStubs.o: $(MAC_OSX_DIR)/tkMacOSXXStubs.c $(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tkMacOSXXStubs.c tkFileFilter.o: $(GENERIC_DIR)/tkFileFilter.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkFileFilter.c tkMacWinMenu.o: $(GENERIC_DIR)/tkMacWinMenu.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkMacWinMenu.c tkPointer.o: $(GENERIC_DIR)/tkPointer.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tkPointer.c xcolors.o: $(XLIB_DIR)/xcolors.c $(CC) -c $(CC_SWITCHES) $(XLIB_DIR)/xcolors.c xdraw.o: $(XLIB_DIR)/xdraw.c $(CC) -c $(CC_SWITCHES) $(XLIB_DIR)/xdraw.c xgc.o: $(XLIB_DIR)/xgc.c $(CC) -c $(CC_SWITCHES) $(XLIB_DIR)/xgc.c ximage.o: $(XLIB_DIR)/ximage.c $(CC) -c $(CC_SWITCHES) $(XLIB_DIR)/ximage.c xutil.o: $(XLIB_DIR)/xutil.c $(CC) -c $(CC_SWITCHES) $(XLIB_DIR)/xutil.c ttkBlink.o: $(TTK_DIR)/ttkBlink.c $(CC) -c $(CC_SWITCHES) $(TTK_DIR)/ttkBlink.c ttkButton.o: $(TTK_DIR)/ttkButton.c $(CC) -c $(CC_SWITCHES) $(TTK_DIR)/ttkButton.c ttkCache.o: $(TTK_DIR)/ttkCache.c $(CC) -c $(CC_SWITCHES) $(TTK_DIR)/ttkCache.c ttkClamTheme.o: $(TTK_DIR)/ttkClamTheme.c $(CC) -c $(CC_SWITCHES) $(TTK_DIR)/ttkClamTheme.c ttkClassicTheme.o: $(TTK_DIR)/ttkClassicTheme.c $(CC) -c $(CC_SWITCHES) $(TTK_DIR)/ttkClassicTheme.c ttkDefaultTheme.o: $(TTK_DIR)/ttkDefaultTheme.c $(CC) -c $(CC_SWITCHES) $(TTK_DIR)/ttkDefaultTheme.c ttkElements.o: $(TTK_DIR)/ttkElements.c $(CC) -c $(CC_SWITCHES) $(TTK_DIR)/ttkElements.c ttkEntry.o: $(TTK_DIR)/ttkEntry.c $(CC) -c $(CC_SWITCHES) $(TTK_DIR)/ttkEntry.c ttkFrame.o: $(TTK_DIR)/ttkFrame.c $(CC) -c $(CC_SWITCHES) $(TTK_DIR)/ttkFrame.c ttkImage.o: $(TTK_DIR)/ttkImage.c $(CC) -c $(CC_SWITCHES) $(TTK_DIR)/ttkImage.c ttkInit.o: $(TTK_DIR)/ttkInit.c $(CC) -c $(CC_SWITCHES) $(TTK_DIR)/ttkInit.c ttkLabel.o: $(TTK_DIR)/ttkLabel.c $(CC) -c $(CC_SWITCHES) $(TTK_DIR)/ttkLabel.c ttkLayout.o: $(TTK_DIR)/ttkLayout.c $(CC) -c $(CC_SWITCHES) $(TTK_DIR)/ttkLayout.c ttkManager.o: $(TTK_DIR)/ttkManager.c $(CC) -c $(CC_SWITCHES) $(TTK_DIR)/ttkManager.c ttkNotebook.o: $(TTK_DIR)/ttkNotebook.c $(CC) -c $(CC_SWITCHES) $(TTK_DIR)/ttkNotebook.c ttkPanedwindow.o: $(TTK_DIR)/ttkPanedwindow.c $(CC) -c $(CC_SWITCHES) $(TTK_DIR)/ttkPanedwindow.c ttkProgress.o: $(TTK_DIR)/ttkProgress.c $(CC) -c $(CC_SWITCHES) $(TTK_DIR)/ttkProgress.c ttkScale.o: $(TTK_DIR)/ttkScale.c $(CC) -c $(CC_SWITCHES) $(TTK_DIR)/ttkScale.c ttkScroll.o: $(TTK_DIR)/ttkScroll.c $(CC) -c $(CC_SWITCHES) $(TTK_DIR)/ttkScroll.c ttkScrollbar.o: $(TTK_DIR)/ttkScrollbar.c $(CC) -c $(CC_SWITCHES) $(TTK_DIR)/ttkScrollbar.c ttkSeparator.o: $(TTK_DIR)/ttkSeparator.c $(CC) -c $(CC_SWITCHES) $(TTK_DIR)/ttkSeparator.c ttkSquare.o: $(TTK_DIR)/ttkSquare.c $(CC) -c $(CC_SWITCHES) $(TTK_DIR)/ttkSquare.c ttkState.o: $(TTK_DIR)/ttkState.c $(CC) -c $(CC_SWITCHES) $(TTK_DIR)/ttkState.c ttkStubInit.o: $(TTK_DIR)/ttkStubInit.c $(CC) -c $(CC_SWITCHES) $(TTK_DIR)/ttkStubInit.c ttkStubLib.o: $(TTK_DIR)/ttkStubLib.c $(CC) -c $(CC_SWITCHES) $(TTK_DIR)/ttkStubLib.c ttkTagSet.o: $(TTK_DIR)/ttkTagSet.c $(CC) -c $(CC_SWITCHES) $(TTK_DIR)/ttkTagSet.c ttkTheme.o: $(TTK_DIR)/ttkTheme.c $(CC) -c $(CC_SWITCHES) $(TTK_DIR)/ttkTheme.c ttkTrace.o: $(TTK_DIR)/ttkTrace.c $(CC) -c $(CC_SWITCHES) $(TTK_DIR)/ttkTrace.c ttkTrack.o: $(TTK_DIR)/ttkTrack.c $(CC) -c $(CC_SWITCHES) $(TTK_DIR)/ttkTrack.c ttkTreeview.o: $(TTK_DIR)/ttkTreeview.c $(CC) -c $(CC_SWITCHES) $(TTK_DIR)/ttkTreeview.c ttkWidget.o: $(TTK_DIR)/ttkWidget.c $(CC) -c $(CC_SWITCHES) $(TTK_DIR)/ttkWidget.c ttkMacOSXTheme.o: $(MAC_OSX_DIR)/ttkMacOSXTheme.c $(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/ttkMacOSXTheme.c .c.o: $(CC) -c $(CC_SWITCHES) $< # # Target to regenerate header files and stub files from the *.decls tables. # $(GENERIC_DIR)/tkStubInit.c: $(GENERIC_DIR)/tk.decls \ $(GENERIC_DIR)/tkInt.decls @echo "Warning: tkStubInit.c may be out of date." @echo "Developers may want to run \"make genstubs\" to regenerate." @echo "This warning can be safely ignored, do not report as a bug!" $(TTK_DIR)/ttkStubInit.c: $(TTK_DIR)/ttk.decls @echo "Warning: ttkStubInit.c may be out of date." @echo "Developers may want to run \"make genstubs\" to regenerate." @echo "This warning can be safely ignored, do not report as a bug!" genstubs: $(TCL_EXE) $(TOOL_DIR)/genStubs.tcl $(GENERIC_DIR) \ $(GENERIC_DIR)/tk.decls $(GENERIC_DIR)/tkInt.decls $(TCL_EXE) $(TTK_DIR)/ttkGenStubs.tcl $(TTK_DIR) $(TTK_DIR)/ttk.decls # # Target to check that all exported functions have an entry in the stubs # tables. # checkstubs: $(TK_LIB_FILE) -@for i in `nm -p $(TK_LIB_FILE) \ | awk '$$2 ~ /^[TDBCS]$$/ { sub("^_", "", $$3); print $$3 }' \ | sort -n`; do \ match=0; \ for j in $(TK_DECLS) $(TTK_DECLS); do \ if [ `grep -c "$$i *(" $$j` -gt 0 ]; then \ match=1; \ fi; \ done; \ if [ $$match -eq 0 ]; then echo $$i; fi \ done # # Target to check for proper usage of UCHAR macro. # checkuchar: -egrep isalnum\|isalpha\|iscntrl\|isdigit\|islower\|isprint\|ispunct\|isspace\|isupper\|isxdigit\|toupper\|tolower $(SRCS) | grep -v UCHAR # # Target to make sure that only symbols with "Tk", "tk", "Ttk", "ttk" or "X" # prefixes are exported. # checkexports: $(TK_LIB_FILE) -@nm -p $(TK_LIB_FILE) \ | awk '$$2 ~ /^[TDBCS]$$/ { sub("^_", "", $$3); print $$3 }' \ | sort -n | grep -E -v '^([Tt]t?k|_?X)' || true # # Target to create a Tk RPM for Linux. Requires that you be on a Linux # system. # rpm: all rm -f THIS.TCL.SPEC echo "%define _builddir `pwd`" > THIS.TK.SPEC echo "%define _rpmdir `pwd`/RPMS" >> THIS.TK.SPEC cat tk.spec >> THIS.TK.SPEC mkdir -p RPMS/i386 rpmbuild -bb THIS.TK.SPEC mv RPMS/i386/*.rpm . rm -rf RPMS THIS.TK.SPEC # # Target to create a proper Tk distribution from information in the # master source directory. DISTDIR must be defined to indicate where # to put the distribution. DISTDIR must be an absolute path name. # DISTROOT = /tmp/dist DISTNAME = tk${VERSION}${PATCH_LEVEL} ZIPNAME = tk${MAJOR_VERSION}${MINOR_VERSION}${PATCH_LEVEL}-src.zip DISTDIR = $(DISTROOT)/$(DISTNAME) TCLDIR = @TCL_SRC_DIR@ $(UNIX_DIR)/configure: $(UNIX_DIR)/configure.in $(UNIX_DIR)/tcl.m4 \ $(UNIX_DIR)/aclocal.m4 cd $(UNIX_DIR); autoconf $(MAC_OSX_DIR)/configure: $(MAC_OSX_DIR)/configure.ac $(UNIX_DIR)/configure cd $(MAC_OSX_DIR); autoconf $(UNIX_DIR)/tkConfig.h.in: $(MAC_OSX_DIR)/configure cd $(MAC_OSX_DIR); autoheader; touch $@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tkConfig.h.in $(UNIX_DIR)/tk.pc.in $(MAC_OSX_DIR)/configure genstubs rm -rf $(DISTDIR) mkdir -p $(DISTDIR)/unix cp -p $(UNIX_DIR)/*.c $(UNIX_DIR)/*.h $(DISTDIR)/unix cp $(TOP_DIR)/license.terms $(UNIX_DIR)/Makefile.in $(DISTDIR)/unix chmod 664 $(DISTDIR)/unix/Makefile.in cp $(UNIX_DIR)/configure $(UNIX_DIR)/configure.in $(UNIX_DIR)/tk.spec \ $(UNIX_DIR)/aclocal.m4 $(UNIX_DIR)/tcl.m4 \ $(UNIX_DIR)/tkConfig.sh.in $(TCLDIR)/unix/install-sh \ $(UNIX_DIR)/README $(UNIX_DIR)/installManPage \ $(UNIX_DIR)/tkConfig.h.in $(UNIX_DIR)/tk.pc.in $(DISTDIR)/unix chmod 775 $(DISTDIR)/unix/configure $(DISTDIR)/unix/configure.in mkdir $(DISTDIR)/bitmaps @(cd $(TOP_DIR); for i in bitmaps/* ; do \ if [ -f $$i ] ; then \ sed -e 's/static char/static unsigned char/' \ $$i > $(DISTDIR)/$$i; \ fi; \ done;) mkdir $(DISTDIR)/generic cp -p $(GENERIC_DIR)/*.[ch] $(DISTDIR)/generic 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)/license.terms $(DISTDIR) rm -f $(DISTDIR)/generic/blt*.[ch] mkdir $(DISTDIR)/generic/ttk cp -p $(TTK_DIR)/*.[ch] $(TTK_DIR)/ttk.decls \ $(TTK_DIR)/ttkGenStubs.tcl $(DISTDIR)/generic/ttk mkdir $(DISTDIR)/win cp $(TOP_DIR)/win/Makefile.in $(DISTDIR)/win cp $(TOP_DIR)/win/configure.in \ $(TOP_DIR)/win/configure \ $(TOP_DIR)/win/tkConfig.sh.in \ $(TOP_DIR)/win/aclocal.m4 $(TOP_DIR)/win/tcl.m4 \ $(DISTDIR)/win cp -p $(TOP_DIR)/win/*.[ch] $(TOP_DIR)/win/*.bat $(DISTDIR)/win cp -p $(TOP_DIR)/win/makefile.* $(DISTDIR)/win cp -p $(TOP_DIR)/win/rules.vc $(DISTDIR)/win cp -p $(TOP_DIR)/win/README $(DISTDIR)/win cp -p $(TOP_DIR)/license.terms $(DISTDIR)/win mkdir $(DISTDIR)/win/rc cp -p $(TOP_DIR)/win/wish.exe.manifest.in $(DISTDIR)/win/ cp -p $(TOP_DIR)/win/rc/*.{rc,cur,ico,bmp} $(DISTDIR)/win/rc mkdir $(DISTDIR)/macosx cp -p $(MAC_OSX_DIR)/GNUmakefile $(MAC_OSX_DIR)/README \ $(MAC_OSX_DIR)/*.icns $(MAC_OSX_DIR)/*.tiff \ $(MAC_OSX_DIR)/*.[ch] $(MAC_OSX_DIR)/*.in \ $(MAC_OSX_DIR)/*.ac $(MAC_OSX_DIR)/*.xcconfig \ $(MAC_OSX_DIR)/*.sdef $(MAC_OSX_DIR)/configure \ $(DISTDIR)/macosx cp -p $(TOP_DIR)/license.terms $(DISTDIR)/macosx mkdir $(DISTDIR)/macosx/Tk.xcode cp -p $(MAC_OSX_DIR)/Tk.xcode/project.pbxproj \ $(MAC_OSX_DIR)/Tk.xcode/default.pbxuser \ $(DISTDIR)/macosx/Tk.xcode mkdir $(DISTDIR)/macosx/Tk.xcodeproj cp -p $(MAC_OSX_DIR)/Tk.xcodeproj/project.pbxproj \ $(MAC_OSX_DIR)/Tk.xcodeproj/default.pbxuser \ $(DISTDIR)/macosx/Tk.xcodeproj mkdir $(DISTDIR)/compat cp -p $(TOP_DIR)/license.terms $(TCLDIR)/compat/unistd.h \ $(TCLDIR)/compat/stdlib.h \ $(DISTDIR)/compat mkdir $(DISTDIR)/xlib cp -p $(XLIB_DIR)/*.[ch] $(DISTDIR)/xlib cp -p $(TOP_DIR)/license.terms $(DISTDIR)/xlib mkdir $(DISTDIR)/xlib/X11 cp -p $(XLIB_DIR)/X11/*.h $(DISTDIR)/xlib/X11 cp -p $(TOP_DIR)/license.terms $(DISTDIR)/xlib/X11 mkdir $(DISTDIR)/library cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/library/*.tcl \ $(TOP_DIR)/library/tclIndex \ $(DISTDIR)/library mkdir $(DISTDIR)/library/ttk cp -p $(TOP_DIR)/library/ttk/*.tcl $(DISTDIR)/library/ttk mkdir $(DISTDIR)/library/images @(cd $(TOP_DIR); for i in library/images/* ; do \ if [ -f $$i ] ; then \ cp $$i $(DISTDIR)/$$i; \ fi; \ done;) mkdir $(DISTDIR)/library/msgs @(cd $(TOP_DIR); for i in library/msgs/*.msg ; do \ if [ -f $$i ] ; then \ cp $$i $(DISTDIR)/$$i; \ fi; \ done;) mkdir $(DISTDIR)/library/demos cp -pr $(TOP_DIR)/library/demos/*.tcl \ $(TOP_DIR)/library/demos/*.msg \ $(TOP_DIR)/library/demos/tclIndex \ $(TOP_DIR)/library/demos/browse \ $(TOP_DIR)/library/demos/hello $(TOP_DIR)/library/demos/ixset \ $(TOP_DIR)/library/demos/rmt $(TOP_DIR)/library/demos/rolodex \ $(TOP_DIR)/library/demos/square \ $(TOP_DIR)/library/demos/tcolor \ $(TOP_DIR)/library/demos/timer \ $(TOP_DIR)/library/demos/widget \ $(TOP_DIR)/library/demos/README \ $(TOP_DIR)/license.terms $(DISTDIR)/library/demos mkdir $(DISTDIR)/library/demos/images @(cd $(TOP_DIR); for i in library/demos/images/* ; do \ if [ -f $$i ] ; then \ cp $$i $(DISTDIR)/$$i; \ fi; \ done;) mkdir $(DISTDIR)/doc cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/doc/*.[13n] \ $(TCLDIR)/doc/man.macros $(DISTDIR)/doc mkdir $(DISTDIR)/tests cp -p $(TOP_DIR)/license.terms $(TEST_DIR)/*.{test,tcl} \ $(TEST_DIR)/README $(TEST_DIR)/*.{gif,ppm,xbm} \ $(TEST_DIR)/option.file* $(DISTDIR)/tests mkdir $(DISTDIR)/tests/ttk cp -p $(TEST_DIR)/ttk/*.{test,tcl} $(DISTDIR)/tests/ttk alldist: dist rm -f $(DISTROOT)/$(DISTNAME)-src.tar.gz $(DISTROOT)/$(ZIPNAME) cd $(DISTROOT); tar cf $(DISTNAME)-src.tar $(DISTNAME); \ gzip -9 $(DISTNAME)-src.tar; zip -qr8 $(ZIPNAME) $(DISTNAME) # # This target creates the HTML folder for Tcl & Tk and places it # in DISTDIR/html. It uses the tcltk-man2html.tcl tool from # the Tcl group's tool workspace. It depends on the Tcl & Tk being # in directories called tcl8.3 & tk8.3 up two directories from the # TOOL_DIR. # html: $(BUILD_HTML) @EXTRA_BUILD_HTML@ html-tcl: $(BUILD_HTML) --tcl @EXTRA_BUILD_HTML@ html-tk: $(BUILD_HTML) --tk @EXTRA_BUILD_HTML@ BUILD_HTML = \ @if test -f "$(BUILD_TCLSH)"; then \ $(SHELL_ENV) TCLSH="$(BUILD_TCLSH)"; else \ TCLSH="$(TCL_EXE)"; fi ;\ "$${TCLSH}" $(TOOL_DIR)/tcltk-man2html.tcl --htmldir="$(HTML_INSTALL_DIR)" \ --srcdir=$(TOP_DIR)/.. $(BUILD_HTML_FLAGS) # # The list of all the targets that do not correspond to real files. This stops # 'make' from getting confused when someone makes an error in a rule. # .PHONY: all binaries libraries objs doc html html-tcl html-tk test runtest .PHONY: install install-strip install-binaries install-libraries .PHONY: install-headers install-private-headers install-doc .PHONY: clean distclean depend genstubs checkstubs checkexports checkuchar .PHONY: shell gdb valgrind valgrindshell dist alldist rpm .PHONY: tkLibObjs tktest-real test-classic test-ttk testlang .PHONY: demo install-demos # DO NOT DELETE THIS LINE -- make depend depends on it. tk8.6.5/unix/tkUnixPort.h0000644003604700454610000000772412600562065013765 0ustar dgp771div/* * tkUnixPort.h -- * * This file is included by all of the Tk C files. It contains * information that may be configuration-dependent, such as * #includes for system include files and a few other things. * * Copyright (c) 1991-1993 The Regents of the University of California. * Copyright (c) 1994-1996 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef _UNIXPORT #define _UNIXPORT #define __UNIX__ 1 #include #include #include #include #include #include #ifdef NO_STDLIB_H # include "../compat/stdlib.h" #else # include #endif #include #include #include #ifdef HAVE_SYS_SELECT_H # include #endif #include #ifndef _TCL # include #endif #if TIME_WITH_SYS_TIME # include # include #else # if HAVE_SYS_TIME_H # include # else # include # endif #endif #if HAVE_INTTYPES_H # include #endif #ifndef NO_UNISTD_H # include #else # include "../compat/unistd.h" #endif #include #include #include #include #include #include #include /* * The following macro defines the type of the mask arguments to * select: */ #ifndef NO_FD_SET # define SELECT_MASK fd_set #else # ifndef _AIX typedef long fd_mask; # endif # if defined(_IBMR2) # define SELECT_MASK void # else # define SELECT_MASK int # endif #endif /* * The following macro defines the number of fd_masks in an fd_set: */ #ifndef FD_SETSIZE # ifdef OPEN_MAX # define FD_SETSIZE OPEN_MAX # else # define FD_SETSIZE 256 # endif #endif #if !defined(howmany) # define howmany(x, y) (((x)+((y)-1))/(y)) #endif #ifndef NFDBITS # define NFDBITS NBBY*sizeof(fd_mask) #endif #define MASK_SIZE howmany(FD_SETSIZE, NFDBITS) /* * Define "NBBY" (number of bits per byte) if it's not already defined. */ #ifndef NBBY # define NBBY 8 #endif #ifdef __CYGWIN__ # include "tkIntXlibDecls.h" # define UINT unsigned int # define HWND void * # define HDC void * # define HINSTANCE void * # define COLORREF void * # define HMENU void * # define TkWinDCState void # define HPALETTE void * # define WNDPROC void * # define WPARAM void * # define LPARAM void * # define LRESULT void * #else /* !__CYGWIN__ */ /* * The TkPutImage macro strips off the color table information, which isn't * needed for X. */ # define TkPutImage(colors, ncolors, display, pixels, gc, image, srcx, srcy, destx, desty, width, height) \ XPutImage(display, pixels, gc, image, srcx, srcy, destx, \ desty, width, height); #endif /* !__CYGWIN__ */ /* * Supply macros for seek offsets, if they're not already provided by * an include file. */ #ifndef SEEK_SET # define SEEK_SET 0 #endif #ifndef SEEK_CUR # define SEEK_CUR 1 #endif #ifndef SEEK_END # define SEEK_END 2 #endif /* * Declarations for various library procedures that may not be declared * in any other header file. */ /* * These functions do nothing under Unix, so we just eliminate calls to them. */ #define TkpButtonSetDefaults() {} #define TkpDestroyButton(butPtr) {} #define TkSelUpdateClipboard(a,b) {} #ifndef __CYGWIN__ #define TkSetPixmapColormap(p,c) {} #endif /* * These calls implement native bitmaps which are not supported under * UNIX. The macros eliminate the calls. */ #define TkpDefineNativeBitmaps() #define TkpCreateNativeBitmap(display, source) None #define TkpGetNativeAppBitmap(display, name, w, h) None /* * This macro stores a representation of the window handle in a string. * This should perhaps use the real size of an XID. */ #ifndef __CYGWIN__ #define TkpPrintWindowId(buf,w) \ sprintf((buf), "%#08lx", (unsigned long) (w)) #endif #endif /* _UNIXPORT */ tk8.6.5/unix/tkUnixInt.h0000644003604700454610000000124212077535536013573 0ustar dgp771div/* * tkUnixInt.h -- * * This file contains declarations that are shared among the * UNIX-specific parts of Tk but aren't used by the rest of Tk. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef _TKUNIXINT #define _TKUNIXINT #ifndef _TKINT #include "tkInt.h" #endif /* * Prototypes for procedures that are referenced in files other than the ones * they're defined in. */ #include "tkIntPlatDecls.h" #endif /* _TKUNIXINT */ /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ tk8.6.5/unix/tkUnixMenu.c0000644003604700454610000014234212377375532013750 0ustar dgp771div/* * tkUnixMenu.c -- * * This module implements the UNIX platform-specific features of menus. * * Copyright (c) 1996-1998 by Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "default.h" #include "tkUnixInt.h" #include "tkMenu.h" /* * Constants used for menu drawing. */ #define MENU_MARGIN_WIDTH 2 #define MENU_DIVIDER_HEIGHT 2 /* * Platform specific flags for Unix. */ #define ENTRY_HELP_MENU ENTRY_PLATFORM_FLAG1 /* * Shared with button widget. */ MODULE_SCOPE void TkpDrawCheckIndicator(Tk_Window tkwin, Display *display, Drawable d, int x, int y, Tk_3DBorder bgBorder, XColor *indicatorColor, XColor *selectColor, XColor *disColor, int on, int disabled, int mode); /* * Indicator Draw Modes */ #define CHECK_BUTTON 0 #define CHECK_MENU 1 #define RADIO_BUTTON 2 #define RADIO_MENU 3 /* * Procedures used internally. */ static void SetHelpMenu(TkMenu *menuPtr); static void DrawMenuEntryAccelerator(TkMenu *menuPtr, TkMenuEntry *mePtr, Drawable d, GC gc, Tk_Font tkfont, const Tk_FontMetrics *fmPtr, Tk_3DBorder activeBorder, int x, int y, int width, int height, int drawArrow); static void DrawMenuEntryBackground(TkMenu *menuPtr, TkMenuEntry *mePtr, Drawable d, Tk_3DBorder activeBorder, Tk_3DBorder bgBorder, int x, int y, int width, int heigth); static void DrawMenuEntryIndicator(TkMenu *menuPtr, TkMenuEntry *mePtr, Drawable d, Tk_3DBorder border, XColor *indicatorColor, XColor *disableColor, Tk_Font tkfont, const Tk_FontMetrics *fmPtr, int x, int y, int width, int height); static void DrawMenuEntryLabel(TkMenu * menuPtr, TkMenuEntry *mePtr, Drawable d, GC gc, Tk_Font tkfont, const Tk_FontMetrics *fmPtr, int x, int y, int width, int height); static void DrawMenuSeparator(TkMenu *menuPtr, TkMenuEntry *mePtr, Drawable d, GC gc, Tk_Font tkfont, const Tk_FontMetrics *fmPtr, int x, int y, int width, int height); static void DrawTearoffEntry(TkMenu *menuPtr, TkMenuEntry *mePtr, Drawable d, GC gc, Tk_Font tkfont, const Tk_FontMetrics *fmPtr, int x, int y, int width, int height); static void DrawMenuUnderline(TkMenu *menuPtr, TkMenuEntry *mePtr, Drawable d, GC gc, Tk_Font tkfont, const Tk_FontMetrics *fmPtr, int x, int y, int width, int height); static void GetMenuAccelGeometry(TkMenu *menuPtr, TkMenuEntry *mePtr, Tk_Font tkfont, const Tk_FontMetrics *fmPtr, int *widthPtr, int *heightPtr); static void GetMenuLabelGeometry(TkMenuEntry *mePtr, Tk_Font tkfont, const Tk_FontMetrics *fmPtr, int *widthPtr, int *heightPtr); static void GetMenuIndicatorGeometry(TkMenu *menuPtr, TkMenuEntry *mePtr, Tk_Font tkfont, const Tk_FontMetrics *fmPtr, int *widthPtr, int *heightPtr); static void GetMenuSeparatorGeometry(TkMenu *menuPtr, TkMenuEntry *mePtr, Tk_Font tkfont, const Tk_FontMetrics *fmPtr, int *widthPtr, int *heightPtr); static void GetTearoffEntryGeometry(TkMenu *menuPtr, TkMenuEntry *mePtr, Tk_Font tkfont, const Tk_FontMetrics *fmPtr, int *widthPtr, int *heightPtr); /* *---------------------------------------------------------------------- * * TkpNewMenu -- * * Gets the platform-specific piece of the menu. Invoked during idle * after the generic part of the menu has been created. * * Results: * Standard TCL error. * * Side effects: * Allocates any platform specific allocations and places them in the * platformData field of the menuPtr. * *---------------------------------------------------------------------- */ int TkpNewMenu( TkMenu *menuPtr) { SetHelpMenu(menuPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * TkpDestroyMenu -- * * Destroys platform-specific menu structures. Called when the generic * menu structure is destroyed for the menu. * * Results: * None. * * Side effects: * All platform-specific allocations are freed up. * *---------------------------------------------------------------------- */ void TkpDestroyMenu( TkMenu *menuPtr) { /* * Nothing to do. */ } /* *---------------------------------------------------------------------- * * TkpDestroyMenuEntry -- * * Cleans up platform-specific menu entry items. Called when entry is * destroyed in the generic code. * * Results: * None. * * Side effects: * All platform specific allocations are freed up. * *---------------------------------------------------------------------- */ void TkpDestroyMenuEntry( TkMenuEntry *mEntryPtr) { /* * Nothing to do. */ } /* *---------------------------------------------------------------------- * * TkpConfigureMenuEntry -- * * Processes configuration options for menu entries. Called when the * generic options are processed for the menu. * * Results: * Returns standard TCL result. If TCL_ERROR is returned, then the * interp's result contains an error message. * * Side effects: * Configuration information get set for mePtr; old resources get freed, * if any need it. * *---------------------------------------------------------------------- */ int TkpConfigureMenuEntry( register TkMenuEntry *mePtr)/* Information about menu entry; may or may * not already have values for some fields. */ { /* * If this is a cascade menu, and the child menu exists, check to see if * the child menu is a help menu. */ if ((mePtr->type == CASCADE_ENTRY) && (mePtr->namePtr != NULL)) { TkMenuReferences *menuRefPtr; menuRefPtr = TkFindMenuReferencesObj(mePtr->menuPtr->interp, mePtr->namePtr); if ((menuRefPtr != NULL) && (menuRefPtr->menuPtr != NULL)) { SetHelpMenu(menuRefPtr->menuPtr); } } return TCL_OK; } /* *---------------------------------------------------------------------- * * TkpMenuNewEntry -- * * Called when a new entry is created in a menu. Fills in platform * specific data for the entry. The platformEntryData field is used to * store the indicator diameter for radio button and check box entries. * * Results: * Standard TCL error. * * Side effects: * None on Unix. * *---------------------------------------------------------------------- */ int TkpMenuNewEntry( TkMenuEntry *mePtr) { return TCL_OK; } /* *---------------------------------------------------------------------- * * TkpSetWindowMenuBar -- * * Sets up the menu as a menubar in the given window. * * Results: * None. * * Side effects: * Recomputes geometry of given window. * *---------------------------------------------------------------------- */ void TkpSetWindowMenuBar( Tk_Window tkwin, /* The window we are setting */ TkMenu *menuPtr) /* The menu we are setting */ { if (menuPtr == NULL) { TkUnixSetMenubar(tkwin, NULL); } else { TkUnixSetMenubar(tkwin, menuPtr->tkwin); } } /* *---------------------------------------------------------------------- * * TkpSetMainMenuBar -- * * Called when a toplevel widget is brought to front. On the Macintosh, * sets up the menubar that goes accross the top of the main monitor. On * other platforms, nothing is necessary. * * Results: * None. * * Side effects: * Recompute geometry of given window. * *---------------------------------------------------------------------- */ void TkpSetMainMenubar( Tcl_Interp *interp, Tk_Window tkwin, const char *menuName) { /* * Nothing to do. */ } /* *---------------------------------------------------------------------- * * GetMenuIndicatorGeometry -- * * Fills out the geometry of the indicator in a menu item. Note that the * mePtr->height field must have already been filled in by * GetMenuLabelGeometry since this height depends on the label height. * * Results: * widthPtr and heightPtr point to the new geometry values. * * Side effects: * None. * *---------------------------------------------------------------------- */ static void GetMenuIndicatorGeometry( TkMenu *menuPtr, /* The menu we are drawing. */ TkMenuEntry *mePtr, /* The entry we are interested in. */ Tk_Font tkfont, /* The precalculated font */ const Tk_FontMetrics *fmPtr,/* The precalculated metrics */ int *widthPtr, /* The resulting width */ int *heightPtr) /* The resulting height */ { int borderWidth; if ((mePtr->type == CHECK_BUTTON_ENTRY) || (mePtr->type == RADIO_BUTTON_ENTRY)) { if (!mePtr->hideMargin && mePtr->indicatorOn) { if ((mePtr->image != NULL) || (mePtr->bitmapPtr != NULL)) { *widthPtr = (14 * mePtr->height) / 10; *heightPtr = mePtr->height; if (mePtr->type == CHECK_BUTTON_ENTRY) { mePtr->platformEntryData = (TkMenuPlatformEntryData) INT2PTR((65 * mePtr->height) / 100); } else { mePtr->platformEntryData = (TkMenuPlatformEntryData) INT2PTR((75 * mePtr->height) / 100); } } else { *widthPtr = *heightPtr = mePtr->height; if (mePtr->type == CHECK_BUTTON_ENTRY) { mePtr->platformEntryData = (TkMenuPlatformEntryData) INT2PTR((80 * mePtr->height) / 100); } else { mePtr->platformEntryData = (TkMenuPlatformEntryData) INT2PTR(mePtr->height); } } } else { Tk_GetPixelsFromObj(NULL, menuPtr->tkwin, menuPtr->borderWidthPtr, &borderWidth); *heightPtr = 0; *widthPtr = borderWidth; } } else { Tk_GetPixelsFromObj(NULL, menuPtr->tkwin, menuPtr->borderWidthPtr, &borderWidth); *heightPtr = 0; *widthPtr = borderWidth; } } /* *---------------------------------------------------------------------- * * GetMenuAccelGeometry -- * * Get the geometry of the accelerator area of a menu item. * * Results: * heightPtr and widthPtr are set. * * Side effects: * None. * *---------------------------------------------------------------------- */ static void GetMenuAccelGeometry( TkMenu *menuPtr, /* The menu was are drawing */ TkMenuEntry *mePtr, /* The entry we are getting the geometry for */ Tk_Font tkfont, /* The precalculated font */ const Tk_FontMetrics *fmPtr,/* The precalculated font metrics */ int *widthPtr, /* The width of the acclerator area */ int *heightPtr) /* The height of the accelerator area */ { *heightPtr = fmPtr->linespace; if (mePtr->type == CASCADE_ENTRY) { *widthPtr = 2 * CASCADE_ARROW_WIDTH; } else if ((menuPtr->menuType != MENUBAR) && (mePtr->accelPtr != NULL)) { const char *accel = Tcl_GetString(mePtr->accelPtr); *widthPtr = Tk_TextWidth(tkfont, accel, mePtr->accelLength); } else { *widthPtr = 0; } } /* *---------------------------------------------------------------------- * * DrawMenuEntryBackground -- * * This procedure draws the background part of a menu. * * Results: * None. * * Side effects: * Commands are output to X to display the menu in its current mode. * *---------------------------------------------------------------------- */ static void DrawMenuEntryBackground( TkMenu *menuPtr, /* The menu we are drawing */ TkMenuEntry *mePtr, /* The entry we are drawing. */ Drawable d, /* The drawable we are drawing into */ Tk_3DBorder activeBorder, /* The border for an active item */ Tk_3DBorder bgBorder, /* The background border */ int x, /* Left coordinate of entry rect */ int y, /* Right coordinate of entry rect */ int width, /* Width of entry rect */ int height) /* Height of entry rect */ { if (mePtr->state == ENTRY_ACTIVE) { int relief; int activeBorderWidth; bgBorder = activeBorder; if ((menuPtr->menuType == MENUBAR) && ((menuPtr->postedCascade == NULL) || (menuPtr->postedCascade != mePtr))) { relief = TK_RELIEF_FLAT; } else { relief = TK_RELIEF_RAISED; } Tk_GetPixelsFromObj(NULL, menuPtr->tkwin, menuPtr->activeBorderWidthPtr, &activeBorderWidth); Tk_Fill3DRectangle(menuPtr->tkwin, d, bgBorder, x, y, width, height, activeBorderWidth, relief); } else { Tk_Fill3DRectangle(menuPtr->tkwin, d, bgBorder, x, y, width, height, 0, TK_RELIEF_FLAT); } } /* *---------------------------------------------------------------------- * * DrawMenuEntryAccelerator -- * * This procedure draws the background part of a menu. * * Results: * None. * * Side effects: * Commands are output to X to display the menu in its current mode. * *---------------------------------------------------------------------- */ static void DrawMenuEntryAccelerator( TkMenu *menuPtr, /* The menu we are drawing */ TkMenuEntry *mePtr, /* The entry we are drawing */ Drawable d, /* The drawable we are drawing into */ GC gc, /* The precalculated gc to draw with */ Tk_Font tkfont, /* The precalculated font */ const Tk_FontMetrics *fmPtr,/* The precalculated metrics */ Tk_3DBorder activeBorder, /* The border for an active item */ int x, /* Left coordinate of entry rect */ int y, /* Top coordinate of entry rect */ int width, /* Width of entry */ int height, /* Height of entry */ int drawArrow) /* Whether or not to draw arrow. */ { XPoint points[3]; int borderWidth, activeBorderWidth; /* * Draw accelerator or cascade arrow. */ if (menuPtr->menuType == MENUBAR) { return; } Tk_GetPixelsFromObj(NULL, menuPtr->tkwin, menuPtr->borderWidthPtr, &borderWidth); Tk_GetPixelsFromObj(NULL, menuPtr->tkwin, menuPtr->activeBorderWidthPtr, &activeBorderWidth); if ((mePtr->type == CASCADE_ENTRY) && drawArrow) { points[0].x = x + width - borderWidth - activeBorderWidth - CASCADE_ARROW_WIDTH; points[0].y = y + (height - CASCADE_ARROW_HEIGHT)/2; points[1].x = points[0].x; points[1].y = points[0].y + CASCADE_ARROW_HEIGHT; points[2].x = points[0].x + CASCADE_ARROW_WIDTH; points[2].y = points[0].y + CASCADE_ARROW_HEIGHT/2; Tk_Fill3DPolygon(menuPtr->tkwin, d, activeBorder, points, 3, DECORATION_BORDER_WIDTH, (menuPtr->postedCascade == mePtr) ? TK_RELIEF_SUNKEN : TK_RELIEF_RAISED); } else if (mePtr->accelPtr != NULL) { const char *accel = Tcl_GetString(mePtr->accelPtr); int left = x + mePtr->labelWidth + activeBorderWidth + mePtr->indicatorSpace; if (menuPtr->menuType == MENUBAR) { left += 5; } Tk_DrawChars(menuPtr->display, d, gc, tkfont, accel, mePtr->accelLength, left, (y + (height + fmPtr->ascent - fmPtr->descent) / 2)); } } /* *---------------------------------------------------------------------- * * DrawMenuEntryIndicator -- * * This procedure draws the background part of a menu. * * Results: * None. * * Side effects: * Commands are output to X to display the menu in its current mode. * *---------------------------------------------------------------------- */ static void DrawMenuEntryIndicator( TkMenu *menuPtr, /* The menu we are drawing */ TkMenuEntry *mePtr, /* The entry we are drawing */ Drawable d, /* The drawable to draw into */ Tk_3DBorder border, /* The background color */ XColor *indicatorColor, /* The color to draw indicators with */ XColor *disableColor, /* The color use use when disabled */ Tk_Font tkfont, /* The font to draw with */ const Tk_FontMetrics *fmPtr,/* The font metrics of the font */ int x, /* The left of the entry rect */ int y, /* The top of the entry rect */ int width, /* Width of menu entry */ int height) /* Height of menu entry */ { /* * Draw check-button indicator. */ if ((mePtr->type == CHECK_BUTTON_ENTRY) && mePtr->indicatorOn) { int top, left, activeBorderWidth; int disabled = (mePtr->state == ENTRY_DISABLED); XColor *bg; Tk_GetPixelsFromObj(NULL, menuPtr->tkwin, menuPtr->activeBorderWidthPtr, &activeBorderWidth); bg = Tk_3DBorderColor(border); top = y + height/2; left = x + activeBorderWidth + DECORATION_BORDER_WIDTH + mePtr->indicatorSpace/2; TkpDrawCheckIndicator(menuPtr->tkwin, menuPtr->display, d, left, top, border, indicatorColor, bg, disableColor, (mePtr->entryFlags & ENTRY_SELECTED), disabled, CHECK_MENU); } /* * Draw radio-button indicator. */ if ((mePtr->type == RADIO_BUTTON_ENTRY) && mePtr->indicatorOn) { int top, left, activeBorderWidth; int disabled = (mePtr->state == ENTRY_DISABLED); XColor *bg; Tk_GetPixelsFromObj(NULL, menuPtr->tkwin, menuPtr->activeBorderWidthPtr, &activeBorderWidth); bg = Tk_3DBorderColor(border); top = y + height/2; left = x + activeBorderWidth + DECORATION_BORDER_WIDTH + mePtr->indicatorSpace/2; TkpDrawCheckIndicator(menuPtr->tkwin, menuPtr->display, d, left, top, border, indicatorColor, bg, disableColor, (mePtr->entryFlags & ENTRY_SELECTED), disabled, RADIO_MENU); } } /* *---------------------------------------------------------------------- * * DrawMenuSeparator -- * * This procedure draws a separator menu item. * * Results: * None. * * Side effects: * Commands are output to X to display the menu in its current mode. * *---------------------------------------------------------------------- */ static void DrawMenuSeparator( TkMenu *menuPtr, /* The menu we are drawing */ TkMenuEntry *mePtr, /* The entry we are drawing */ Drawable d, /* The drawable we are using */ GC gc, /* The gc to draw into */ Tk_Font tkfont, /* The font to draw with */ const Tk_FontMetrics *fmPtr,/* The font metrics from the font */ int x, int y, int width, int height) { XPoint points[2]; Tk_3DBorder border; if (menuPtr->menuType == MENUBAR) { return; } points[0].x = x; points[0].y = y + height/2; points[1].x = width - 1; points[1].y = points[0].y; border = Tk_Get3DBorderFromObj(menuPtr->tkwin, menuPtr->borderPtr); Tk_Draw3DPolygon(menuPtr->tkwin, d, border, points, 2, 1, TK_RELIEF_RAISED); } /* *---------------------------------------------------------------------- * * DrawMenuEntryLabel -- * * This procedure draws the label part of a menu. * * Results: * None. * * Side effects: * Commands are output to X to display the menu in its current mode. * *---------------------------------------------------------------------- */ static void DrawMenuEntryLabel( TkMenu *menuPtr, /* The menu we are drawing. */ TkMenuEntry *mePtr, /* The entry we are drawing. */ Drawable d, /* What we are drawing into. */ GC gc, /* The gc we are drawing into.*/ Tk_Font tkfont, /* The precalculated font. */ const Tk_FontMetrics *fmPtr,/* The precalculated font metrics. */ int x, /* Left edge. */ int y, /* Top edge. */ int width, /* width of entry. */ int height) /* height of entry. */ { int indicatorSpace = mePtr->indicatorSpace; int activeBorderWidth, leftEdge, imageHeight, imageWidth; int textHeight = 0, textWidth = 0; /* stop GCC warning */ int haveImage = 0, haveText = 0; int imageXOffset = 0, imageYOffset = 0; int textXOffset = 0, textYOffset = 0; Tk_GetPixelsFromObj(NULL, menuPtr->tkwin, menuPtr->activeBorderWidthPtr, &activeBorderWidth); leftEdge = x + indicatorSpace + activeBorderWidth; if (menuPtr->menuType == MENUBAR) { leftEdge += 5; } /* * Work out what we will need to draw first. */ if (mePtr->image != NULL) { Tk_SizeOfImage(mePtr->image, &imageWidth, &imageHeight); haveImage = 1; } else if (mePtr->bitmapPtr != NULL) { Pixmap bitmap = Tk_GetBitmapFromObj(menuPtr->tkwin, mePtr->bitmapPtr); Tk_SizeOfBitmap(menuPtr->display, bitmap, &imageWidth, &imageHeight); haveImage = 1; } if (!haveImage || (mePtr->compound != COMPOUND_NONE)) { if (mePtr->labelLength > 0) { const char *label = Tcl_GetString(mePtr->labelPtr); textWidth = Tk_TextWidth(tkfont, label, mePtr->labelLength); textHeight = fmPtr->linespace; haveText = 1; } } /* * Now work out what the relative positions are. */ if (haveImage && haveText) { int fullWidth = (imageWidth > textWidth ? imageWidth : textWidth); switch ((enum compound) mePtr->compound) { case COMPOUND_TOP: textXOffset = (fullWidth - textWidth)/2; textYOffset = imageHeight/2 + 2; imageXOffset = (fullWidth - imageWidth)/2; imageYOffset = -textHeight/2; break; case COMPOUND_BOTTOM: textXOffset = (fullWidth - textWidth)/2; textYOffset = -imageHeight/2; imageXOffset = (fullWidth - imageWidth)/2; imageYOffset = textHeight/2 + 2; break; case COMPOUND_LEFT: /* * Position image in the indicator space to the left of the * entries, unless this entry is a radio|check button because then * the indicator space will be used. */ textXOffset = imageWidth + 2; textYOffset = 0; imageXOffset = 0; imageYOffset = 0; if ((mePtr->type != CHECK_BUTTON_ENTRY) && (mePtr->type != RADIO_BUTTON_ENTRY)) { textXOffset -= indicatorSpace; if (textXOffset < 0) { textXOffset = 0; } imageXOffset = -indicatorSpace; } break; case COMPOUND_RIGHT: textXOffset = 0; textYOffset = 0; imageXOffset = textWidth + 2; imageYOffset = 0; break; case COMPOUND_CENTER: textXOffset = (fullWidth - textWidth)/2; textYOffset = 0; imageXOffset = (fullWidth - imageWidth)/2; imageYOffset = 0; break; case COMPOUND_NONE: break; } } else { textXOffset = 0; textYOffset = 0; imageXOffset = 0; imageYOffset = 0; } /* * Draw label and/or bitmap or image for entry. */ if (mePtr->image != NULL) { if ((mePtr->selectImage != NULL) && (mePtr->entryFlags & ENTRY_SELECTED)) { Tk_RedrawImage(mePtr->selectImage, 0, 0, imageWidth, imageHeight, d, leftEdge + imageXOffset, (int) (y + (mePtr->height-imageHeight)/2 + imageYOffset)); } else { Tk_RedrawImage(mePtr->image, 0, 0, imageWidth, imageHeight, d, leftEdge + imageXOffset, (int) (y + (mePtr->height-imageHeight)/2 + imageYOffset)); } } else if (mePtr->bitmapPtr != None) { Pixmap bitmap = Tk_GetBitmapFromObj(menuPtr->tkwin, mePtr->bitmapPtr); XCopyPlane(menuPtr->display, bitmap, d, gc, 0, 0, (unsigned) imageWidth, (unsigned) imageHeight, leftEdge + imageXOffset, (int) (y + (mePtr->height - imageHeight)/2 + imageYOffset), 1); } if ((mePtr->compound != COMPOUND_NONE) || !haveImage) { int baseline = y + (height + fmPtr->ascent - fmPtr->descent) / 2; if (mePtr->labelLength > 0) { const char *label = Tcl_GetString(mePtr->labelPtr); Tk_DrawChars(menuPtr->display, d, gc, tkfont, label, mePtr->labelLength, leftEdge + textXOffset, baseline + textYOffset); DrawMenuUnderline(menuPtr, mePtr, d, gc, tkfont, fmPtr, x + textXOffset, y + textYOffset, width, height); } } if (mePtr->state == ENTRY_DISABLED) { if (menuPtr->disabledFgPtr == NULL) { XFillRectangle(menuPtr->display, d, menuPtr->disabledGC, x, y, (unsigned) width, (unsigned) height); } else if ((mePtr->image != NULL) && (menuPtr->disabledImageGC != None)) { XFillRectangle(menuPtr->display, d, menuPtr->disabledImageGC, leftEdge + imageXOffset, (int) (y + (mePtr->height - imageHeight)/2 + imageYOffset), (unsigned) imageWidth, (unsigned) imageHeight); } } } /* *---------------------------------------------------------------------- * * DrawMenuUnderline -- * * On appropriate platforms, draw the underline character for the menu. * * Results: * None. * * Side effects: * Commands are output to X to display the menu in its current mode. * *---------------------------------------------------------------------- */ static void DrawMenuUnderline( TkMenu *menuPtr, /* The menu to draw into */ TkMenuEntry *mePtr, /* The entry we are drawing */ Drawable d, /* What we are drawing into */ GC gc, /* The gc to draw into */ Tk_Font tkfont, /* The precalculated font */ const Tk_FontMetrics *fmPtr,/* The precalculated font metrics */ int x, int y, int width, int height) { if ((mePtr->underline >= 0) && (mePtr->labelPtr != NULL)) { int len; /* * Do the unicode call just to prevent overruns. */ Tcl_GetUnicodeFromObj(mePtr->labelPtr, &len); if (mePtr->underline < len) { int activeBorderWidth, leftEdge; const char *label, *start, *end; label = Tcl_GetString(mePtr->labelPtr); start = Tcl_UtfAtIndex(label, mePtr->underline); end = Tcl_UtfNext(start); Tk_GetPixelsFromObj(NULL, menuPtr->tkwin, menuPtr->activeBorderWidthPtr, &activeBorderWidth); leftEdge = x + mePtr->indicatorSpace + activeBorderWidth; if (menuPtr->menuType == MENUBAR) { leftEdge += 5; } Tk_UnderlineChars(menuPtr->display, d, gc, tkfont, label, leftEdge, y + (height + fmPtr->ascent - fmPtr->descent) / 2, start - label, end - label); } } } /* *---------------------------------------------------------------------- * * TkpPostMenu -- * * Posts a menu on the screen * * Results: * None. * * Side effects: * The menu is posted and handled. * *---------------------------------------------------------------------- */ int TkpPostMenu( Tcl_Interp *interp, TkMenu *menuPtr, int x, int y) { return TkPostTearoffMenu(interp, menuPtr, x, y); } /* *---------------------------------------------------------------------- * * GetMenuSeparatorGeometry -- * * Gets the width and height of the indicator area of a menu. * * Results: * widthPtr and heightPtr are set. * * Side effects: * None. * *---------------------------------------------------------------------- */ static void GetMenuSeparatorGeometry( TkMenu *menuPtr, /* The menu we are measuring */ TkMenuEntry *mePtr, /* The entry we are measuring */ Tk_Font tkfont, /* The precalculated font */ const Tk_FontMetrics *fmPtr,/* The precalcualted font metrics */ int *widthPtr, /* The resulting width */ int *heightPtr) /* The resulting height */ { *widthPtr = 0; *heightPtr = fmPtr->linespace; } /* *---------------------------------------------------------------------- * * GetTearoffEntryGeometry -- * * Gets the width and height of the indicator area of a menu. * * Results: * widthPtr and heightPtr are set. * * Side effects: * None. * *---------------------------------------------------------------------- */ static void GetTearoffEntryGeometry( TkMenu *menuPtr, /* The menu we are drawing */ TkMenuEntry *mePtr, /* The entry we are measuring */ Tk_Font tkfont, /* The precalculated font */ const Tk_FontMetrics *fmPtr,/* The precalculated font metrics */ int *widthPtr, /* The resulting width */ int *heightPtr) /* The resulting height */ { if (menuPtr->menuType != MASTER_MENU) { *heightPtr = 0; *widthPtr = 0; } else { *heightPtr = fmPtr->linespace; *widthPtr = Tk_TextWidth(tkfont, "W", 1); } } /* *-------------------------------------------------------------- * * TkpComputeMenubarGeometry -- * * This procedure is invoked to recompute the size and layout of a menu * that is a menubar clone. * * Results: * None. * * Side effects: * Fields of menu entries are changed to reflect their current positions, * and the size of the menu window itself may be changed. * *-------------------------------------------------------------- */ void TkpComputeMenubarGeometry( TkMenu *menuPtr) /* Structure describing menu. */ { Tk_Font tkfont, menuFont; Tk_FontMetrics menuMetrics, entryMetrics, *fmPtr; int width, height, i, j, x, y, currentRowHeight, maxWidth; int maxWindowWidth, lastRowBreak, lastEntry; int borderWidth, activeBorderWidth, helpMenuIndex = -1; TkMenuEntry *mePtr; if (menuPtr->tkwin == NULL) { return; } Tk_GetPixelsFromObj(NULL, menuPtr->tkwin, menuPtr->borderWidthPtr, &borderWidth); Tk_GetPixelsFromObj(NULL, menuPtr->tkwin, menuPtr->activeBorderWidthPtr, &activeBorderWidth); maxWidth = 0; if (menuPtr->numEntries == 0) { height = 0; } else { int borderWidth; maxWindowWidth = Tk_Width(menuPtr->tkwin); if (maxWindowWidth == 1) { maxWindowWidth = 0x7ffffff; } currentRowHeight = 0; Tk_GetPixelsFromObj(NULL, menuPtr->tkwin, menuPtr->borderWidthPtr, &borderWidth); x = y = borderWidth; lastRowBreak = 0; /* * On the Mac especially, getting font metrics can be quite slow, so * we want to do it intelligently. We are going to precalculate them * and pass them down to all of the measureing and drawing routines. * We will measure the font metrics of the menu once, and if an entry * has a font set, we will measure it as we come to it, and then we * decide which set to give the geometry routines. */ menuFont = Tk_GetFontFromObj(menuPtr->tkwin, menuPtr->fontPtr); Tk_GetFontMetrics(menuFont, &menuMetrics); for (i = 0; i < menuPtr->numEntries; i++) { mePtr = menuPtr->entries[i]; mePtr->entryFlags &= ~ENTRY_LAST_COLUMN; if (mePtr->fontPtr != NULL) { tkfont = Tk_GetFontFromObj(menuPtr->tkwin, mePtr->fontPtr); Tk_GetFontMetrics(tkfont, &entryMetrics); fmPtr = &entryMetrics; } else { tkfont = menuFont; fmPtr = &menuMetrics; } /* * For every entry, we need to check to see whether or not we * wrap. If we do wrap, then we have to adjust all of the previous * entries' height and y position, because when we see them the * first time, we don't know how big its neighbor might be. */ if ((mePtr->type == SEPARATOR_ENTRY) || (mePtr->type == TEAROFF_ENTRY)) { mePtr->height = mePtr->width = 0; } else { GetMenuLabelGeometry(mePtr, tkfont, fmPtr, &width, &height); mePtr->height = height + 2 * activeBorderWidth + 10; mePtr->width = width; GetMenuIndicatorGeometry(menuPtr, mePtr, tkfont, fmPtr, &width, &height); mePtr->indicatorSpace = width; if (width > 0) { mePtr->width += width; } mePtr->width += 2 * activeBorderWidth + 10; } if (mePtr->entryFlags & ENTRY_HELP_MENU) { helpMenuIndex = i; } else if (x + mePtr->width + borderWidth > maxWindowWidth) { if (i == lastRowBreak) { mePtr->y = y; mePtr->x = x; lastRowBreak++; y += mePtr->height; currentRowHeight = 0; } else { x = borderWidth; for (j = lastRowBreak; j < i; j++) { menuPtr->entries[j]->y = y + currentRowHeight - menuPtr->entries[j]->height; menuPtr->entries[j]->x = x; x += menuPtr->entries[j]->width; } lastRowBreak = i; y += currentRowHeight; currentRowHeight = mePtr->height; } if (x > maxWidth) { maxWidth = x; } x = borderWidth; } else { x += mePtr->width; if (mePtr->height > currentRowHeight) { currentRowHeight = mePtr->height; } } } lastEntry = menuPtr->numEntries - 1; if (helpMenuIndex == lastEntry) { lastEntry--; } if ((lastEntry >= 0) && (x + menuPtr->entries[lastEntry]->width + borderWidth > maxWidth)) { maxWidth = x + menuPtr->entries[lastEntry]->width + borderWidth; } x = borderWidth; for (j = lastRowBreak; j < menuPtr->numEntries; j++) { if (j == helpMenuIndex) { continue; } menuPtr->entries[j]->y = y + currentRowHeight - menuPtr->entries[j]->height; menuPtr->entries[j]->x = x; x += menuPtr->entries[j]->width; } if (helpMenuIndex != -1) { mePtr = menuPtr->entries[helpMenuIndex]; if (x + mePtr->width + borderWidth > maxWindowWidth) { y += currentRowHeight; currentRowHeight = mePtr->height; x = borderWidth; } else if (mePtr->height > currentRowHeight) { currentRowHeight = mePtr->height; } mePtr->x = maxWindowWidth - borderWidth - mePtr->width; mePtr->y = y + currentRowHeight - mePtr->height; } height = y + currentRowHeight + borderWidth; } width = Tk_Width(menuPtr->tkwin); /* * The X server doesn't like zero dimensions, so round up to at least 1 (a * zero-sized menu should never really occur, anyway). */ if (width <= 0) { width = 1; } if (height <= 0) { height = 1; } menuPtr->totalWidth = maxWidth; menuPtr->totalHeight = height; } /* *---------------------------------------------------------------------- * * DrawTearoffEntry -- * * This procedure draws the background part of a menu. * * Results: * None. * * Side effects: * Commands are output to X to display the menu in its current mode. * *---------------------------------------------------------------------- */ static void DrawTearoffEntry( TkMenu *menuPtr, /* The menu we are drawing */ TkMenuEntry *mePtr, /* The entry we are drawing */ Drawable d, /* The drawable we are drawing into */ GC gc, /* The gc we are drawing with */ Tk_Font tkfont, /* The font we are drawing with */ const Tk_FontMetrics *fmPtr,/* The metrics we are drawing with */ int x, int y, int width, int height) { XPoint points[2]; int segmentWidth, maxX; Tk_3DBorder border; if (menuPtr->menuType != MASTER_MENU) { return; } points[0].x = x; points[0].y = y + height/2; points[1].y = points[0].y; segmentWidth = 6; maxX = width - 1; border = Tk_Get3DBorderFromObj(menuPtr->tkwin, menuPtr->borderPtr); while (points[0].x < maxX) { points[1].x = points[0].x + segmentWidth; if (points[1].x > maxX) { points[1].x = maxX; } Tk_Draw3DPolygon(menuPtr->tkwin, d, border, points, 2, 1, TK_RELIEF_RAISED); points[0].x += 2 * segmentWidth; } } /* *-------------------------------------------------------------- * * TkpInitializeMenuBindings -- * * For every interp, initializes the bindings for Windows menus. Does * nothing on Mac or XWindows. * * Results: * None. * * Side effects: * C-level bindings are setup for the interp which will handle Alt-key * sequences for menus without beeping or interfering with user-defined * Alt-key bindings. * *-------------------------------------------------------------- */ void TkpInitializeMenuBindings( Tcl_Interp *interp, /* The interpreter to set. */ Tk_BindingTable bindingTable) /* The table to add to. */ { /* * Nothing to do. */ } /* *---------------------------------------------------------------------- * * SetHelpMenu -- * * Given a menu, check to see whether or not it is a help menu cascade in * a menubar. If it is, the entry that points to this menu will be * marked. * * RESULTS: * None. * * Side effects: * Will set the ENTRY_HELP_MENU flag appropriately. * *---------------------------------------------------------------------- */ static void SetHelpMenu( TkMenu *menuPtr) /* The menu we are checking */ { TkMenuEntry *cascadeEntryPtr; int useMotifHelp = 0; const char *option = NULL; if (menuPtr->tkwin) { option = Tk_GetOption(menuPtr->tkwin, "useMotifHelp", "UseMotifHelp"); if (option != NULL) { Tcl_GetBoolean(NULL, option, &useMotifHelp); } } if (!useMotifHelp) { return; } for (cascadeEntryPtr = menuPtr->menuRefPtr->parentEntryPtr; cascadeEntryPtr != NULL; cascadeEntryPtr = cascadeEntryPtr->nextCascadePtr) { if ((cascadeEntryPtr->menuPtr->menuType == MENUBAR) && (cascadeEntryPtr->menuPtr->masterMenuPtr->tkwin != NULL) && (menuPtr->masterMenuPtr->tkwin != NULL)) { TkMenu *masterMenuPtr = cascadeEntryPtr->menuPtr->masterMenuPtr; char *helpMenuName = ckalloc(strlen(Tk_PathName( masterMenuPtr->tkwin)) + strlen(".help") + 1); strcpy(helpMenuName, Tk_PathName(masterMenuPtr->tkwin)); strcat(helpMenuName, ".help"); if (strcmp(helpMenuName, Tk_PathName(menuPtr->masterMenuPtr->tkwin)) == 0) { cascadeEntryPtr->entryFlags |= ENTRY_HELP_MENU; } else { cascadeEntryPtr->entryFlags &= ~ENTRY_HELP_MENU; } ckfree(helpMenuName); } } } /* *---------------------------------------------------------------------- * * TkpDrawMenuEntry -- * * Draws the given menu entry at the given coordinates with the given * attributes. * * Results: * None. * * Side effects: * X Server commands are executed to display the menu entry. * *---------------------------------------------------------------------- */ void TkpDrawMenuEntry( TkMenuEntry *mePtr, /* The entry to draw */ Drawable d, /* What to draw into */ Tk_Font tkfont, /* Precalculated font for menu */ const Tk_FontMetrics *menuMetricsPtr, /* Precalculated metrics for menu */ int x, /* X-coordinate of topleft of entry */ int y, /* Y-coordinate of topleft of entry */ int width, /* Width of the entry rectangle */ int height, /* Height of the current rectangle */ int strictMotif, /* Boolean flag */ int drawArrow) /* Whether or not to draw the cascade arrow * for cascade items. Only applies to * Windows. */ { GC gc, indicatorGC; XColor *indicatorColor, *disableColor = NULL; TkMenu *menuPtr = mePtr->menuPtr; Tk_3DBorder bgBorder, activeBorder; const Tk_FontMetrics *fmPtr; Tk_FontMetrics entryMetrics; int padY = (menuPtr->menuType == MENUBAR) ? 3 : 0; int adjustedY = y + padY; int adjustedHeight = height - 2 * padY; /* * Choose the gc for drawing the foreground part of the entry. */ if ((mePtr->state == ENTRY_ACTIVE) && !strictMotif) { gc = mePtr->activeGC; if (gc == NULL) { gc = menuPtr->activeGC; } } else { TkMenuEntry *cascadeEntryPtr; int parentDisabled = 0; for (cascadeEntryPtr = menuPtr->menuRefPtr->parentEntryPtr; cascadeEntryPtr != NULL; cascadeEntryPtr = cascadeEntryPtr->nextCascadePtr) { if (cascadeEntryPtr->namePtr != NULL) { const char *name = Tcl_GetString(cascadeEntryPtr->namePtr); if (strcmp(name, Tk_PathName(menuPtr->tkwin)) == 0) { if (cascadeEntryPtr->state == ENTRY_DISABLED) { parentDisabled = 1; } break; } } } if (((parentDisabled || (mePtr->state == ENTRY_DISABLED))) && (menuPtr->disabledFgPtr != NULL)) { gc = mePtr->disabledGC; if (gc == NULL) { gc = menuPtr->disabledGC; } } else { gc = mePtr->textGC; if (gc == NULL) { gc = menuPtr->textGC; } } } indicatorGC = mePtr->indicatorGC; if (indicatorGC == NULL) { indicatorGC = menuPtr->indicatorGC; } if (mePtr->indicatorFgPtr) { indicatorColor = Tk_GetColorFromObj(menuPtr->tkwin, mePtr->indicatorFgPtr); } else { indicatorColor = Tk_GetColorFromObj(menuPtr->tkwin, menuPtr->indicatorFgPtr); } if (menuPtr->disabledFgPtr != NULL) { disableColor = Tk_GetColorFromObj(menuPtr->tkwin, menuPtr->disabledFgPtr); } bgBorder = Tk_Get3DBorderFromObj(menuPtr->tkwin, (mePtr->borderPtr == NULL) ? menuPtr->borderPtr : mePtr->borderPtr); if (strictMotif) { activeBorder = bgBorder; } else { activeBorder = Tk_Get3DBorderFromObj(menuPtr->tkwin, (mePtr->activeBorderPtr == NULL) ? menuPtr->activeBorderPtr : mePtr->activeBorderPtr); } if (mePtr->fontPtr == NULL) { fmPtr = menuMetricsPtr; } else { tkfont = Tk_GetFontFromObj(menuPtr->tkwin, mePtr->fontPtr); Tk_GetFontMetrics(tkfont, &entryMetrics); fmPtr = &entryMetrics; } /* * Need to draw the entire background, including padding. On Unix, for * menubars, we have to draw the rest of the entry taking into account the * padding. */ DrawMenuEntryBackground(menuPtr, mePtr, d, activeBorder, bgBorder, x, y, width, height); if (mePtr->type == SEPARATOR_ENTRY) { DrawMenuSeparator(menuPtr, mePtr, d, gc, tkfont, fmPtr, x, adjustedY, width, adjustedHeight); } else if (mePtr->type == TEAROFF_ENTRY) { DrawTearoffEntry(menuPtr, mePtr, d, gc, tkfont, fmPtr, x, adjustedY, width, adjustedHeight); } else { DrawMenuEntryLabel(menuPtr, mePtr, d, gc, tkfont, fmPtr, x, adjustedY, width, adjustedHeight); DrawMenuEntryAccelerator(menuPtr, mePtr, d, gc, tkfont, fmPtr, activeBorder, x, adjustedY, width, adjustedHeight, drawArrow); if (!mePtr->hideMargin) { if (mePtr->state == ENTRY_ACTIVE) { bgBorder = activeBorder; } DrawMenuEntryIndicator(menuPtr, mePtr, d, bgBorder, indicatorColor, disableColor, tkfont, fmPtr, x, adjustedY, width, adjustedHeight); } } } /* *---------------------------------------------------------------------- * * GetMenuLabelGeometry -- * * Figures out the size of the label portion of a menu item. * * Results: * widthPtr and heightPtr are filled in with the correct geometry * information. * * Side effects: * None. * *---------------------------------------------------------------------- */ static void GetMenuLabelGeometry( TkMenuEntry *mePtr, /* The entry we are computing */ Tk_Font tkfont, /* The precalculated font */ const Tk_FontMetrics *fmPtr,/* The precalculated metrics */ int *widthPtr, /* The resulting width of the label portion */ int *heightPtr) /* The resulting height of the label * portion */ { TkMenu *menuPtr = mePtr->menuPtr; int haveImage = 0; if (mePtr->image != NULL) { Tk_SizeOfImage(mePtr->image, widthPtr, heightPtr); haveImage = 1; } else if (mePtr->bitmapPtr != NULL) { Pixmap bitmap = Tk_GetBitmapFromObj(menuPtr->tkwin, mePtr->bitmapPtr); Tk_SizeOfBitmap(menuPtr->display, bitmap, widthPtr, heightPtr); haveImage = 1; } else { *heightPtr = 0; *widthPtr = 0; } if (haveImage && (mePtr->compound == COMPOUND_NONE)) { /* * We don't care about the text in this case. */ } else { /* * Either it is compound or we don't have an image. */ if (mePtr->labelPtr != NULL) { int textWidth; const char *label = Tcl_GetString(mePtr->labelPtr); textWidth = Tk_TextWidth(tkfont, label, mePtr->labelLength); if ((mePtr->compound != COMPOUND_NONE) && haveImage) { switch ((enum compound) mePtr->compound) { case COMPOUND_TOP: case COMPOUND_BOTTOM: if (textWidth > *widthPtr) { *widthPtr = textWidth; } /* * Add text and padding. */ *heightPtr += fmPtr->linespace + 2; break; case COMPOUND_LEFT: case COMPOUND_RIGHT: if (fmPtr->linespace > *heightPtr) { *heightPtr = fmPtr->linespace; } /* * Add text and padding. */ *widthPtr += textWidth + 2; break; case COMPOUND_CENTER: if (fmPtr->linespace > *heightPtr) { *heightPtr = fmPtr->linespace; } if (textWidth > *widthPtr) { *widthPtr = textWidth; } break; case COMPOUND_NONE: break; } } else { /* * We don't have an image or we're not compound. */ *heightPtr = fmPtr->linespace; *widthPtr = textWidth; } } else { /* * An empty entry still has this height. */ *heightPtr = fmPtr->linespace; } } *heightPtr += 1; } /* *-------------------------------------------------------------- * * TkpComputeStandardMenuGeometry -- * * This procedure is invoked to recompute the size and layout of a menu * that is not a menubar clone. * * Results: * None. * * Side effects: * Fields of menu entries are changed to reflect their current positions, * and the size of the menu window itself may be changed. * *-------------------------------------------------------------- */ void TkpComputeStandardMenuGeometry( TkMenu *menuPtr) /* Structure describing menu. */ { Tk_Font tkfont, menuFont; Tk_FontMetrics menuMetrics, entryMetrics, *fmPtr; int x, y, height, width, indicatorSpace, labelWidth, accelWidth; int windowWidth, windowHeight, accelSpace, i, j, lastColumnBreak = 0; TkMenuEntry *mePtr; int borderWidth, activeBorderWidth; if (menuPtr->tkwin == NULL) { return; } Tk_GetPixelsFromObj(NULL, menuPtr->tkwin, menuPtr->borderWidthPtr, &borderWidth); Tk_GetPixelsFromObj(NULL, menuPtr->tkwin, menuPtr->activeBorderWidthPtr, &activeBorderWidth); x = y = borderWidth; indicatorSpace = labelWidth = accelWidth = 0; windowHeight = windowWidth = 0; /* * On the Mac especially, getting font metrics can be quite slow, so we * want to do it intelligently. We are going to precalculate them and pass * them down to all of the measuring and drawing routines. We will measure * the font metrics of the menu once. If an entry does not have its own * font set, then we give the geometry/drawing routines the menu's font * and metrics. If an entry has its own font, we will measure that font * and give all of the geometry/drawing the entry's font and metrics. */ menuFont = Tk_GetFontFromObj(menuPtr->tkwin, menuPtr->fontPtr); Tk_GetFontMetrics(menuFont, &menuMetrics); accelSpace = Tk_TextWidth(menuFont, "M", 1); for (i = 0; i < menuPtr->numEntries; i++) { mePtr = menuPtr->entries[i]; if (mePtr->fontPtr == NULL) { tkfont = menuFont; fmPtr = &menuMetrics; } else { tkfont = Tk_GetFontFromObj(menuPtr->tkwin, mePtr->fontPtr); Tk_GetFontMetrics(tkfont, &entryMetrics); fmPtr = &entryMetrics; } if ((i > 0) && mePtr->columnBreak) { if (accelWidth != 0) { labelWidth += accelSpace; } for (j = lastColumnBreak; j < i; j++) { menuPtr->entries[j]->indicatorSpace = indicatorSpace; menuPtr->entries[j]->labelWidth = labelWidth; menuPtr->entries[j]->width = indicatorSpace + labelWidth + accelWidth + 2 * activeBorderWidth; menuPtr->entries[j]->x = x; menuPtr->entries[j]->entryFlags &= ~ENTRY_LAST_COLUMN; } x += indicatorSpace + labelWidth + accelWidth + 2 * activeBorderWidth; windowWidth = x; indicatorSpace = labelWidth = accelWidth = 0; lastColumnBreak = i; y = borderWidth; } if (mePtr->type == SEPARATOR_ENTRY) { GetMenuSeparatorGeometry(menuPtr, mePtr, tkfont, fmPtr, &width, &height); mePtr->height = height; } else if (mePtr->type == TEAROFF_ENTRY) { GetTearoffEntryGeometry(menuPtr, mePtr, tkfont, fmPtr, &width, &height); mePtr->height = height; labelWidth = width; } else { /* * For each entry, compute the height required by that particular * entry, plus three widths: the width of the label, the width to * allow for an indicator to be displayed to the left of the label * (if any), and the width of the accelerator to be displayed to * the right of the label (if any). These sizes depend, of course, * on the type of the entry. */ GetMenuLabelGeometry(mePtr, tkfont, fmPtr, &width, &height); mePtr->height = height; if (!mePtr->hideMargin) { width += MENU_MARGIN_WIDTH; } if (width > labelWidth) { labelWidth = width; } GetMenuAccelGeometry(menuPtr, mePtr, tkfont, fmPtr, &width, &height); if (height > mePtr->height) { mePtr->height = height; } if (!mePtr->hideMargin) { width += MENU_MARGIN_WIDTH; } if (width > accelWidth) { accelWidth = width; } GetMenuIndicatorGeometry(menuPtr, mePtr, tkfont, fmPtr, &width, &height); if (height > mePtr->height) { mePtr->height = height; } if (!mePtr->hideMargin) { width += MENU_MARGIN_WIDTH; } if (width > indicatorSpace) { indicatorSpace = width; } mePtr->height += 2 * activeBorderWidth + MENU_DIVIDER_HEIGHT; } mePtr->y = y; y += mePtr->height; if (y > windowHeight) { windowHeight = y; } } if (accelWidth != 0) { labelWidth += accelSpace; } for (j = lastColumnBreak; j < menuPtr->numEntries; j++) { menuPtr->entries[j]->indicatorSpace = indicatorSpace; menuPtr->entries[j]->labelWidth = labelWidth; menuPtr->entries[j]->width = indicatorSpace + labelWidth + accelWidth + 2 * activeBorderWidth; menuPtr->entries[j]->x = x; menuPtr->entries[j]->entryFlags |= ENTRY_LAST_COLUMN; } windowWidth = x + indicatorSpace + labelWidth + accelWidth + 2 * activeBorderWidth + 2 * borderWidth; windowHeight += borderWidth; /* * The X server doesn't like zero dimensions, so round up to at least 1 (a * zero-sized menu should never really occur, anyway). */ if (windowWidth <= 0) { windowWidth = 1; } if (windowHeight <= 0) { windowHeight = 1; } menuPtr->totalWidth = windowWidth; menuPtr->totalHeight = windowHeight; } /* *---------------------------------------------------------------------- * * TkpMenuNotifyToplevelCreate -- * * This routine reconfigures the menu and the clones indicated by * menuName becuase a toplevel has been created and any system menus need * to be created. Not applicable to UNIX. * * Results: * None. * * Side effects: * An idle handler is set up to do the reconfiguration. * *---------------------------------------------------------------------- */ void TkpMenuNotifyToplevelCreate( Tcl_Interp *interp, /* The interp the menu lives in. */ const char *menuName) /* The name of the menu to reconfigure. */ { /* * Nothing to do. */ } /* *---------------------------------------------------------------------- * * TkpMenuInit -- * * Does platform-specific initialization of menus. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ void TkpMenuInit(void) { /* * Nothing to do. */ } /* *---------------------------------------------------------------------- * * TkpMenuThreadInit -- * * Does platform-specific initialization of thread-specific menu state. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ void TkpMenuThreadInit(void) { /* * Nothing to do. */ } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ tk8.6.5/unix/tcl.m40000644003604700454610000030136112665114121012500 0ustar dgp771div#------------------------------------------------------------------------ # SC_PATH_TCLCONFIG -- # # Locate the tclConfig.sh file and perform a sanity check on # the Tcl compile flags # # Arguments: # none # # Results: # # Adds the following arguments to configure: # --with-tcl=... # # Defines the following vars: # TCL_BIN_DIR Full path to the directory containing # the tclConfig.sh file #------------------------------------------------------------------------ AC_DEFUN([SC_PATH_TCLCONFIG], [ # # Ok, lets find the tcl configuration # First, look for one uninstalled. # the alternative search directory is invoked by --with-tcl # if test x"${no_tcl}" = x ; then # we reset no_tcl in case something fails here no_tcl=true AC_ARG_WITH(tcl, AC_HELP_STRING([--with-tcl], [directory containing tcl configuration (tclConfig.sh)]), with_tclconfig="${withval}") AC_MSG_CHECKING([for Tcl configuration]) AC_CACHE_VAL(ac_cv_c_tclconfig,[ # First check to see if --with-tcl was specified. if test x"${with_tclconfig}" != x ; then case "${with_tclconfig}" in */tclConfig.sh ) if test -f "${with_tclconfig}"; then AC_MSG_WARN([--with-tcl argument should refer to directory containing tclConfig.sh, not to tclConfig.sh itself]) with_tclconfig="`echo "${with_tclconfig}" | sed 's!/tclConfig\.sh$!!'`" fi ;; esac if test -f "${with_tclconfig}/tclConfig.sh" ; then ac_cv_c_tclconfig="`(cd "${with_tclconfig}"; pwd)`" else AC_MSG_ERROR([${with_tclconfig} directory doesn't contain tclConfig.sh]) fi fi # then check for a private Tcl installation if test x"${ac_cv_c_tclconfig}" = x ; then for i in \ ../tcl \ `ls -dr ../tcl[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ `ls -dr ../tcl[[8-9]].[[0-9]] 2>/dev/null` \ `ls -dr ../tcl[[8-9]].[[0-9]]* 2>/dev/null` \ ../../tcl \ `ls -dr ../../tcl[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ `ls -dr ../../tcl[[8-9]].[[0-9]] 2>/dev/null` \ `ls -dr ../../tcl[[8-9]].[[0-9]]* 2>/dev/null` \ ../../../tcl \ `ls -dr ../../../tcl[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ `ls -dr ../../../tcl[[8-9]].[[0-9]] 2>/dev/null` \ `ls -dr ../../../tcl[[8-9]].[[0-9]]* 2>/dev/null` ; do if test -f "$i/unix/tclConfig.sh" ; then ac_cv_c_tclconfig="`(cd $i/unix; pwd)`" break fi done fi # on Darwin, check in Framework installation locations if test "`uname -s`" = "Darwin" -a x"${ac_cv_c_tclconfig}" = x ; then for i in `ls -d ~/Library/Frameworks 2>/dev/null` \ `ls -d /Library/Frameworks 2>/dev/null` \ `ls -d /Network/Library/Frameworks 2>/dev/null` \ `ls -d /System/Library/Frameworks 2>/dev/null` \ ; do if test -f "$i/Tcl.framework/tclConfig.sh" ; then ac_cv_c_tclconfig="`(cd $i/Tcl.framework; pwd)`" break fi done fi # check in a few common install locations if test x"${ac_cv_c_tclconfig}" = x ; then for i in `ls -d ${libdir} 2>/dev/null` \ `ls -d ${exec_prefix}/lib 2>/dev/null` \ `ls -d ${prefix}/lib 2>/dev/null` \ `ls -d /usr/local/lib 2>/dev/null` \ `ls -d /usr/contrib/lib 2>/dev/null` \ `ls -d /usr/lib 2>/dev/null` \ `ls -d /usr/lib64 2>/dev/null` \ ; do if test -f "$i/tclConfig.sh" ; then ac_cv_c_tclconfig="`(cd $i; pwd)`" break fi done fi # check in a few other private locations if test x"${ac_cv_c_tclconfig}" = x ; then for i in \ ${srcdir}/../tcl \ `ls -dr ${srcdir}/../tcl[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ `ls -dr ${srcdir}/../tcl[[8-9]].[[0-9]] 2>/dev/null` \ `ls -dr ${srcdir}/../tcl[[8-9]].[[0-9]]* 2>/dev/null` ; do if test -f "$i/unix/tclConfig.sh" ; then ac_cv_c_tclconfig="`(cd $i/unix; pwd)`" break fi done fi ]) if test x"${ac_cv_c_tclconfig}" = x ; then TCL_BIN_DIR="# no Tcl configs found" AC_MSG_ERROR([Can't find Tcl configuration definitions. Use --with-tcl to specify a directory containing tclConfig.sh]) else no_tcl= TCL_BIN_DIR="${ac_cv_c_tclconfig}" AC_MSG_RESULT([found ${TCL_BIN_DIR}/tclConfig.sh]) fi fi ]) #------------------------------------------------------------------------ # SC_PATH_TKCONFIG -- # # Locate the tkConfig.sh file # # Arguments: # none # # Results: # # Adds the following arguments to configure: # --with-tk=... # # Defines the following vars: # TK_BIN_DIR Full path to the directory containing # the tkConfig.sh file #------------------------------------------------------------------------ AC_DEFUN([SC_PATH_TKCONFIG], [ # # Ok, lets find the tk configuration # First, look for one uninstalled. # the alternative search directory is invoked by --with-tk # if test x"${no_tk}" = x ; then # we reset no_tk in case something fails here no_tk=true AC_ARG_WITH(tk, AC_HELP_STRING([--with-tk], [directory containing tk configuration (tkConfig.sh)]), with_tkconfig="${withval}") AC_MSG_CHECKING([for Tk configuration]) AC_CACHE_VAL(ac_cv_c_tkconfig,[ # First check to see if --with-tkconfig was specified. if test x"${with_tkconfig}" != x ; then case "${with_tkconfig}" in */tkConfig.sh ) if test -f "${with_tkconfig}"; then AC_MSG_WARN([--with-tk argument should refer to directory containing tkConfig.sh, not to tkConfig.sh itself]) with_tkconfig="`echo "${with_tkconfig}" | sed 's!/tkConfig\.sh$!!'`" fi ;; esac if test -f "${with_tkconfig}/tkConfig.sh" ; then ac_cv_c_tkconfig="`(cd "${with_tkconfig}"; pwd)`" else AC_MSG_ERROR([${with_tkconfig} directory doesn't contain tkConfig.sh]) fi fi # then check for a private Tk library if test x"${ac_cv_c_tkconfig}" = x ; then for i in \ ../tk \ `ls -dr ../tk[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ `ls -dr ../tk[[8-9]].[[0-9]] 2>/dev/null` \ `ls -dr ../tk[[8-9]].[[0-9]]* 2>/dev/null` \ ../../tk \ `ls -dr ../../tk[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ `ls -dr ../../tk[[8-9]].[[0-9]] 2>/dev/null` \ `ls -dr ../../tk[[8-9]].[[0-9]]* 2>/dev/null` \ ../../../tk \ `ls -dr ../../../tk[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ `ls -dr ../../../tk[[8-9]].[[0-9]] 2>/dev/null` \ `ls -dr ../../../tk[[8-9]].[[0-9]]* 2>/dev/null` ; do if test -f "$i/unix/tkConfig.sh" ; then ac_cv_c_tkconfig="`(cd $i/unix; pwd)`" break fi done fi # on Darwin, check in Framework installation locations if test "`uname -s`" = "Darwin" -a x"${ac_cv_c_tkconfig}" = x ; then for i in `ls -d ~/Library/Frameworks 2>/dev/null` \ `ls -d /Library/Frameworks 2>/dev/null` \ `ls -d /Network/Library/Frameworks 2>/dev/null` \ `ls -d /System/Library/Frameworks 2>/dev/null` \ ; do if test -f "$i/Tk.framework/tkConfig.sh" ; then ac_cv_c_tkconfig="`(cd $i/Tk.framework; pwd)`" break fi done fi # check in a few common install locations if test x"${ac_cv_c_tkconfig}" = x ; then for i in `ls -d ${libdir} 2>/dev/null` \ `ls -d ${exec_prefix}/lib 2>/dev/null` \ `ls -d ${prefix}/lib 2>/dev/null` \ `ls -d /usr/local/lib 2>/dev/null` \ `ls -d /usr/contrib/lib 2>/dev/null` \ `ls -d /usr/lib 2>/dev/null` \ `ls -d /usr/lib64 2>/dev/null` \ ; do if test -f "$i/tkConfig.sh" ; then ac_cv_c_tkconfig="`(cd $i; pwd)`" break fi done fi # check in a few other private locations if test x"${ac_cv_c_tkconfig}" = x ; then for i in \ ${srcdir}/../tk \ `ls -dr ${srcdir}/../tk[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ `ls -dr ${srcdir}/../tk[[8-9]].[[0-9]] 2>/dev/null` \ `ls -dr ${srcdir}/../tk[[8-9]].[[0-9]]* 2>/dev/null` ; do if test -f "$i/unix/tkConfig.sh" ; then ac_cv_c_tkconfig="`(cd $i/unix; pwd)`" break fi done fi ]) if test x"${ac_cv_c_tkconfig}" = x ; then TK_BIN_DIR="# no Tk configs found" AC_MSG_ERROR([Can't find Tk configuration definitions. Use --with-tk to specify a directory containing tkConfig.sh]) else no_tk= TK_BIN_DIR="${ac_cv_c_tkconfig}" AC_MSG_RESULT([found ${TK_BIN_DIR}/tkConfig.sh]) fi fi ]) #------------------------------------------------------------------------ # SC_LOAD_TCLCONFIG -- # # Load the tclConfig.sh file # # Arguments: # # Requires the following vars to be set: # TCL_BIN_DIR # # Results: # # Substitutes the following vars: # TCL_BIN_DIR # TCL_SRC_DIR # TCL_LIB_FILE #------------------------------------------------------------------------ AC_DEFUN([SC_LOAD_TCLCONFIG], [ AC_MSG_CHECKING([for existence of ${TCL_BIN_DIR}/tclConfig.sh]) if test -f "${TCL_BIN_DIR}/tclConfig.sh" ; then AC_MSG_RESULT([loading]) . "${TCL_BIN_DIR}/tclConfig.sh" else AC_MSG_RESULT([could not find ${TCL_BIN_DIR}/tclConfig.sh]) fi # eval is required to do the TCL_DBGX substitution eval "TCL_LIB_FILE=\"${TCL_LIB_FILE}\"" eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\"" # If the TCL_BIN_DIR is the build directory (not the install directory), # then set the common variable name to the value of the build variables. # For example, the variable TCL_LIB_SPEC will be set to the value # of TCL_BUILD_LIB_SPEC. An extension should make use of TCL_LIB_SPEC # instead of TCL_BUILD_LIB_SPEC since it will work with both an # installed and uninstalled version of Tcl. if test -f "${TCL_BIN_DIR}/Makefile" ; then TCL_LIB_SPEC="${TCL_BUILD_LIB_SPEC}" TCL_STUB_LIB_SPEC="${TCL_BUILD_STUB_LIB_SPEC}" TCL_STUB_LIB_PATH="${TCL_BUILD_STUB_LIB_PATH}" elif test "`uname -s`" = "Darwin"; then # If Tcl was built as a framework, attempt to use the libraries # from the framework at the given location so that linking works # against Tcl.framework installed in an arbitrary location. case ${TCL_DEFS} in *TCL_FRAMEWORK*) if test -f "${TCL_BIN_DIR}/${TCL_LIB_FILE}"; then for i in "`cd "${TCL_BIN_DIR}"; pwd`" \ "`cd "${TCL_BIN_DIR}"/../..; pwd`"; do if test "`basename "$i"`" = "${TCL_LIB_FILE}.framework"; then TCL_LIB_SPEC="-F`dirname "$i" | sed -e 's/ /\\\\ /g'` -framework ${TCL_LIB_FILE}" break fi done fi if test -f "${TCL_BIN_DIR}/${TCL_STUB_LIB_FILE}"; then TCL_STUB_LIB_SPEC="-L`echo "${TCL_BIN_DIR}" | sed -e 's/ /\\\\ /g'` ${TCL_STUB_LIB_FLAG}" TCL_STUB_LIB_PATH="${TCL_BIN_DIR}/${TCL_STUB_LIB_FILE}" fi ;; esac fi # eval is required to do the TCL_DBGX substitution eval "TCL_LIB_FLAG=\"${TCL_LIB_FLAG}\"" eval "TCL_LIB_SPEC=\"${TCL_LIB_SPEC}\"" eval "TCL_STUB_LIB_FLAG=\"${TCL_STUB_LIB_FLAG}\"" eval "TCL_STUB_LIB_SPEC=\"${TCL_STUB_LIB_SPEC}\"" AC_SUBST(TCL_VERSION) AC_SUBST(TCL_PATCH_LEVEL) AC_SUBST(TCL_BIN_DIR) AC_SUBST(TCL_SRC_DIR) AC_SUBST(TCL_LIB_FILE) AC_SUBST(TCL_LIB_FLAG) AC_SUBST(TCL_LIB_SPEC) AC_SUBST(TCL_STUB_LIB_FILE) AC_SUBST(TCL_STUB_LIB_FLAG) AC_SUBST(TCL_STUB_LIB_SPEC) ]) #------------------------------------------------------------------------ # SC_LOAD_TKCONFIG -- # # Load the tkConfig.sh file # # Arguments: # # Requires the following vars to be set: # TK_BIN_DIR # # Results: # # Sets the following vars that should be in tkConfig.sh: # TK_BIN_DIR #------------------------------------------------------------------------ AC_DEFUN([SC_LOAD_TKCONFIG], [ AC_MSG_CHECKING([for existence of ${TK_BIN_DIR}/tkConfig.sh]) if test -f "${TK_BIN_DIR}/tkConfig.sh" ; then AC_MSG_RESULT([loading]) . "${TK_BIN_DIR}/tkConfig.sh" else AC_MSG_RESULT([could not find ${TK_BIN_DIR}/tkConfig.sh]) fi # eval is required to do the TK_DBGX substitution eval "TK_LIB_FILE=\"${TK_LIB_FILE}\"" eval "TK_STUB_LIB_FILE=\"${TK_STUB_LIB_FILE}\"" # If the TK_BIN_DIR is the build directory (not the install directory), # then set the common variable name to the value of the build variables. # For example, the variable TK_LIB_SPEC will be set to the value # of TK_BUILD_LIB_SPEC. An extension should make use of TK_LIB_SPEC # instead of TK_BUILD_LIB_SPEC since it will work with both an # installed and uninstalled version of Tcl. if test -f "${TK_BIN_DIR}/Makefile" ; then TK_LIB_SPEC="${TK_BUILD_LIB_SPEC}" TK_STUB_LIB_SPEC="${TK_BUILD_STUB_LIB_SPEC}" TK_STUB_LIB_PATH="${TK_BUILD_STUB_LIB_PATH}" elif test "`uname -s`" = "Darwin"; then # If Tk was built as a framework, attempt to use the libraries # from the framework at the given location so that linking works # against Tk.framework installed in an arbitrary location. case ${TK_DEFS} in *TK_FRAMEWORK*) if test -f "${TK_BIN_DIR}/${TK_LIB_FILE}"; then for i in "`cd "${TK_BIN_DIR}"; pwd`" \ "`cd "${TK_BIN_DIR}"/../..; pwd`"; do if test "`basename "$i"`" = "${TK_LIB_FILE}.framework"; then TK_LIB_SPEC="-F`dirname "$i" | sed -e 's/ /\\\\ /g'` -framework ${TK_LIB_FILE}" break fi done fi if test -f "${TK_BIN_DIR}/${TK_STUB_LIB_FILE}"; then TK_STUB_LIB_SPEC="-L` echo "${TK_BIN_DIR}" | sed -e 's/ /\\\\ /g'` ${TK_STUB_LIB_FLAG}" TK_STUB_LIB_PATH="${TK_BIN_DIR}/${TK_STUB_LIB_FILE}" fi ;; esac fi # eval is required to do the TK_DBGX substitution eval "TK_LIB_FLAG=\"${TK_LIB_FLAG}\"" eval "TK_LIB_SPEC=\"${TK_LIB_SPEC}\"" eval "TK_STUB_LIB_FLAG=\"${TK_STUB_LIB_FLAG}\"" eval "TK_STUB_LIB_SPEC=\"${TK_STUB_LIB_SPEC}\"" AC_SUBST(TK_VERSION) AC_SUBST(TK_BIN_DIR) AC_SUBST(TK_SRC_DIR) AC_SUBST(TK_LIB_FILE) AC_SUBST(TK_LIB_FLAG) AC_SUBST(TK_LIB_SPEC) AC_SUBST(TK_STUB_LIB_FILE) AC_SUBST(TK_STUB_LIB_FLAG) AC_SUBST(TK_STUB_LIB_SPEC) ]) #------------------------------------------------------------------------ # SC_PROG_TCLSH # Locate a tclsh shell installed on the system path. This macro # will only find a Tcl shell that already exists on the system. # It will not find a Tcl shell in the Tcl build directory or # a Tcl shell that has been installed from the Tcl build directory. # If a Tcl shell can't be located on the PATH, then TCLSH_PROG will # be set to "". Extensions should take care not to create Makefile # rules that are run by default and depend on TCLSH_PROG. An # extension can't assume that an executable Tcl shell exists at # build time. # # Arguments: # none # # Results: # Substitutes the following vars: # TCLSH_PROG #------------------------------------------------------------------------ AC_DEFUN([SC_PROG_TCLSH], [ AC_MSG_CHECKING([for tclsh]) AC_CACHE_VAL(ac_cv_path_tclsh, [ search_path=`echo ${PATH} | sed -e 's/:/ /g'` for dir in $search_path ; do for j in `ls -r $dir/tclsh[[8-9]]* 2> /dev/null` \ `ls -r $dir/tclsh* 2> /dev/null` ; do if test x"$ac_cv_path_tclsh" = x ; then if test -f "$j" ; then ac_cv_path_tclsh=$j break fi fi done done ]) if test -f "$ac_cv_path_tclsh" ; then TCLSH_PROG="$ac_cv_path_tclsh" AC_MSG_RESULT([$TCLSH_PROG]) else # It is not an error if an installed version of Tcl can't be located. TCLSH_PROG="" AC_MSG_RESULT([No tclsh found on PATH]) fi AC_SUBST(TCLSH_PROG) ]) #------------------------------------------------------------------------ # SC_BUILD_TCLSH # Determine the fully qualified path name of the tclsh executable # in the Tcl build directory. This macro will correctly determine # the name of the tclsh executable even if tclsh has not yet # been built in the build directory. The build tclsh must be used # when running tests from an extension build directory. It is not # correct to use the TCLSH_PROG in cases like this. # # Arguments: # none # # Results: # Substitutes the following values: # BUILD_TCLSH #------------------------------------------------------------------------ AC_DEFUN([SC_BUILD_TCLSH], [ AC_MSG_CHECKING([for tclsh in Tcl build directory]) BUILD_TCLSH="${TCL_BIN_DIR}"/tclsh AC_MSG_RESULT([$BUILD_TCLSH]) AC_SUBST(BUILD_TCLSH) ]) #------------------------------------------------------------------------ # SC_ENABLE_SHARED -- # # Allows the building of shared libraries # # Arguments: # none # # Results: # # Adds the following arguments to configure: # --enable-shared=yes|no # # Defines the following vars: # STATIC_BUILD Used for building import/export libraries # on Windows. # # Sets the following vars: # SHARED_BUILD Value of 1 or 0 #------------------------------------------------------------------------ AC_DEFUN([SC_ENABLE_SHARED], [ AC_MSG_CHECKING([how to build libraries]) AC_ARG_ENABLE(shared, AC_HELP_STRING([--enable-shared], [build and link with shared libraries (default: on)]), [tcl_ok=$enableval], [tcl_ok=yes]) if test "${enable_shared+set}" = set; then enableval="$enable_shared" tcl_ok=$enableval else tcl_ok=yes fi if test "$tcl_ok" = "yes" ; then AC_MSG_RESULT([shared]) SHARED_BUILD=1 else AC_MSG_RESULT([static]) SHARED_BUILD=0 AC_DEFINE(STATIC_BUILD, 1, [Is this a static build?]) fi ]) #------------------------------------------------------------------------ # SC_ENABLE_FRAMEWORK -- # # Allows the building of shared libraries into frameworks # # Arguments: # none # # Results: # # Adds the following arguments to configure: # --enable-framework=yes|no # # Sets the following vars: # FRAMEWORK_BUILD Value of 1 or 0 #------------------------------------------------------------------------ AC_DEFUN([SC_ENABLE_FRAMEWORK], [ if test "`uname -s`" = "Darwin" ; then AC_MSG_CHECKING([how to package libraries]) AC_ARG_ENABLE(framework, AC_HELP_STRING([--enable-framework], [package shared libraries in MacOSX frameworks (default: off)]), [enable_framework=$enableval], [enable_framework=no]) if test $enable_framework = yes; then if test $SHARED_BUILD = 0; then AC_MSG_WARN([Frameworks can only be built if --enable-shared is yes]) enable_framework=no fi if test $tcl_corefoundation = no; then AC_MSG_WARN([Frameworks can only be used when CoreFoundation is available]) enable_framework=no fi fi if test $enable_framework = yes; then AC_MSG_RESULT([framework]) FRAMEWORK_BUILD=1 else if test $SHARED_BUILD = 1; then AC_MSG_RESULT([shared library]) else AC_MSG_RESULT([static library]) fi FRAMEWORK_BUILD=0 fi fi ]) #------------------------------------------------------------------------ # SC_ENABLE_THREADS -- # # Specify if thread support should be enabled # # Arguments: # none # # Results: # # Adds the following arguments to configure: # --enable-threads # # Sets the following vars: # THREADS_LIBS Thread library(s) # # Defines the following vars: # TCL_THREADS # _REENTRANT # _THREAD_SAFE # #------------------------------------------------------------------------ AC_DEFUN([SC_ENABLE_THREADS], [ AC_ARG_ENABLE(threads, AC_HELP_STRING([--enable-threads], [build with threads (default: on)]), [tcl_ok=$enableval], [tcl_ok=yes]) if test "${TCL_THREADS}" = 1; then tcl_threaded_core=1; fi if test "$tcl_ok" = "yes" -o "${TCL_THREADS}" = 1; then TCL_THREADS=1 # USE_THREAD_ALLOC tells us to try the special thread-based # allocator that significantly reduces lock contention AC_DEFINE(USE_THREAD_ALLOC, 1, [Do we want to use the threaded memory allocator?]) AC_DEFINE(_REENTRANT, 1, [Do we want the reentrant OS API?]) if test "`uname -s`" = "SunOS" ; then AC_DEFINE(_POSIX_PTHREAD_SEMANTICS, 1, [Do we really want to follow the standard? Yes we do!]) fi AC_DEFINE(_THREAD_SAFE, 1, [Do we want the thread-safe OS API?]) AC_CHECK_LIB(pthread,pthread_mutex_init,tcl_ok=yes,tcl_ok=no) if test "$tcl_ok" = "no"; then # Check a little harder for __pthread_mutex_init in the same # library, as some systems hide it there until pthread.h is # defined. We could alternatively do an AC_TRY_COMPILE with # pthread.h, but that will work with libpthread really doesn't # exist, like AIX 4.2. [Bug: 4359] AC_CHECK_LIB(pthread, __pthread_mutex_init, tcl_ok=yes, tcl_ok=no) fi if test "$tcl_ok" = "yes"; then # The space is needed THREADS_LIBS=" -lpthread" else AC_CHECK_LIB(pthreads, pthread_mutex_init, tcl_ok=yes, tcl_ok=no) if test "$tcl_ok" = "yes"; then # The space is needed THREADS_LIBS=" -lpthreads" else AC_CHECK_LIB(c, pthread_mutex_init, tcl_ok=yes, tcl_ok=no) if test "$tcl_ok" = "no"; then AC_CHECK_LIB(c_r, pthread_mutex_init, tcl_ok=yes, tcl_ok=no) if test "$tcl_ok" = "yes"; then # The space is needed THREADS_LIBS=" -pthread" else TCL_THREADS=0 AC_MSG_WARN([Don't know how to find pthread lib on your system - you must disable thread support or edit the LIBS in the Makefile...]) fi fi fi fi # Does the pthread-implementation provide # 'pthread_attr_setstacksize' ? ac_saved_libs=$LIBS LIBS="$LIBS $THREADS_LIBS" AC_CHECK_FUNCS(pthread_attr_setstacksize pthread_atfork) LIBS=$ac_saved_libs else TCL_THREADS=0 fi # Do checking message here to not mess up interleaved configure output AC_MSG_CHECKING([for building with threads]) if test "${TCL_THREADS}" = 1; then AC_DEFINE(TCL_THREADS, 1, [Are we building with threads enabled?]) if test "${tcl_threaded_core}" = 1; then AC_MSG_RESULT([yes (threaded core)]) else AC_MSG_RESULT([yes]) fi else AC_MSG_RESULT([no]) fi AC_SUBST(TCL_THREADS) ]) #------------------------------------------------------------------------ # SC_ENABLE_SYMBOLS -- # # Specify if debugging symbols should be used. # Memory (TCL_MEM_DEBUG) and compile (TCL_COMPILE_DEBUG) debugging # can also be enabled. # # Arguments: # none # # Requires the following vars to be set in the Makefile: # CFLAGS_DEBUG # CFLAGS_OPTIMIZE # LDFLAGS_DEBUG # LDFLAGS_OPTIMIZE # # Results: # # Adds the following arguments to configure: # --enable-symbols # # Defines the following vars: # CFLAGS_DEFAULT Sets to $(CFLAGS_DEBUG) if true # Sets to $(CFLAGS_OPTIMIZE) if false # LDFLAGS_DEFAULT Sets to $(LDFLAGS_DEBUG) if true # Sets to $(LDFLAGS_OPTIMIZE) if false # DBGX Formerly used as debug library extension; # always blank now. # #------------------------------------------------------------------------ AC_DEFUN([SC_ENABLE_SYMBOLS], [ AC_MSG_CHECKING([for build with symbols]) AC_ARG_ENABLE(symbols, AC_HELP_STRING([--enable-symbols], [build with debugging symbols (default: off)]), [tcl_ok=$enableval], [tcl_ok=no]) # FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT. DBGX="" if test "$tcl_ok" = "no"; then CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)' LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)' AC_DEFINE(NDEBUG, 1, [Is no debugging enabled?]) AC_MSG_RESULT([no]) AC_DEFINE(TCL_CFG_OPTIMIZED, 1, [Is this an optimized build?]) else CFLAGS_DEFAULT='$(CFLAGS_DEBUG)' LDFLAGS_DEFAULT='$(LDFLAGS_DEBUG)' if test "$tcl_ok" = "yes"; then AC_MSG_RESULT([yes (standard debugging)]) fi fi AC_SUBST(CFLAGS_DEFAULT) AC_SUBST(LDFLAGS_DEFAULT) if test "$tcl_ok" = "mem" -o "$tcl_ok" = "all"; then AC_DEFINE(TCL_MEM_DEBUG, 1, [Is memory debugging enabled?]) fi ifelse($1,bccdebug,dnl Only enable 'compile' for the Tcl core itself if test "$tcl_ok" = "compile" -o "$tcl_ok" = "all"; then AC_DEFINE(TCL_COMPILE_DEBUG, 1, [Is bytecode debugging enabled?]) AC_DEFINE(TCL_COMPILE_STATS, 1, [Are bytecode statistics enabled?]) fi) if test "$tcl_ok" != "yes" -a "$tcl_ok" != "no"; then if test "$tcl_ok" = "all"; then AC_MSG_RESULT([enabled symbols mem ]ifelse($1,bccdebug,[compile ])[debugging]) else AC_MSG_RESULT([enabled $tcl_ok debugging]) fi fi ]) #------------------------------------------------------------------------ # SC_ENABLE_LANGINFO -- # # Allows use of modern nl_langinfo check for better l10n. # This is only relevant for Unix. # # Arguments: # none # # Results: # # Adds the following arguments to configure: # --enable-langinfo=yes|no (default is yes) # # Defines the following vars: # HAVE_LANGINFO Triggers use of nl_langinfo if defined. #------------------------------------------------------------------------ AC_DEFUN([SC_ENABLE_LANGINFO], [ AC_ARG_ENABLE(langinfo, AC_HELP_STRING([--enable-langinfo], [use nl_langinfo if possible to determine encoding at startup, otherwise use old heuristic (default: on)]), [langinfo_ok=$enableval], [langinfo_ok=yes]) HAVE_LANGINFO=0 if test "$langinfo_ok" = "yes"; then AC_CHECK_HEADER(langinfo.h,[langinfo_ok=yes],[langinfo_ok=no]) fi AC_MSG_CHECKING([whether to use nl_langinfo]) if test "$langinfo_ok" = "yes"; then AC_CACHE_VAL(tcl_cv_langinfo_h, [ AC_TRY_COMPILE([#include ], [nl_langinfo(CODESET);], [tcl_cv_langinfo_h=yes],[tcl_cv_langinfo_h=no])]) AC_MSG_RESULT([$tcl_cv_langinfo_h]) if test $tcl_cv_langinfo_h = yes; then AC_DEFINE(HAVE_LANGINFO, 1, [Do we have nl_langinfo()?]) fi else AC_MSG_RESULT([$langinfo_ok]) fi ]) #-------------------------------------------------------------------- # SC_CONFIG_MANPAGES # # Decide whether to use symlinks for linking the manpages, # whether to compress the manpages after installation, and # whether to add a package name suffix to the installed # manpages to avoidfile name clashes. # If compression is enabled also find out what file name suffix # the given compression program is using. # # Arguments: # none # # Results: # # Adds the following arguments to configure: # --enable-man-symlinks # --enable-man-compression=PROG # --enable-man-suffix[=STRING] # # Defines the following variable: # # MAN_FLAGS - The apropriate flags for installManPage # according to the user's selection. # #-------------------------------------------------------------------- AC_DEFUN([SC_CONFIG_MANPAGES], [ AC_MSG_CHECKING([whether to use symlinks for manpages]) AC_ARG_ENABLE(man-symlinks, AC_HELP_STRING([--enable-man-symlinks], [use symlinks for the manpages (default: off)]), test "$enableval" != "no" && MAN_FLAGS="$MAN_FLAGS --symlinks", enableval="no") AC_MSG_RESULT([$enableval]) AC_MSG_CHECKING([whether to compress the manpages]) AC_ARG_ENABLE(man-compression, AC_HELP_STRING([--enable-man-compression=PROG], [compress the manpages with PROG (default: off)]), [case $enableval in yes) AC_MSG_ERROR([missing argument to --enable-man-compression]);; no) ;; *) MAN_FLAGS="$MAN_FLAGS --compress $enableval";; esac], enableval="no") AC_MSG_RESULT([$enableval]) if test "$enableval" != "no"; then AC_MSG_CHECKING([for compressed file suffix]) touch TeST $enableval TeST Z=`ls TeST* | sed 's/^....//'` rm -f TeST* MAN_FLAGS="$MAN_FLAGS --extension $Z" AC_MSG_RESULT([$Z]) fi AC_MSG_CHECKING([whether to add a package name suffix for the manpages]) AC_ARG_ENABLE(man-suffix, AC_HELP_STRING([--enable-man-suffix=STRING], [use STRING as a suffix to manpage file names (default: no, AC_PACKAGE_NAME if enabled without specifying STRING)]), [case $enableval in yes) enableval="AC_PACKAGE_NAME" MAN_FLAGS="$MAN_FLAGS --suffix $enableval";; no) ;; *) MAN_FLAGS="$MAN_FLAGS --suffix $enableval";; esac], enableval="no") AC_MSG_RESULT([$enableval]) AC_SUBST(MAN_FLAGS) ]) #-------------------------------------------------------------------- # SC_CONFIG_SYSTEM # # Determine what the system is (some things cannot be easily checked # on a feature-driven basis, alas). This can usually be done via the # "uname" command, but there are a few systems, like Next, where # this doesn't work. # # Arguments: # none # # Results: # Defines the following var: # # system - System/platform/version identification code. # #-------------------------------------------------------------------- AC_DEFUN([SC_CONFIG_SYSTEM], [ AC_CACHE_CHECK([system version], tcl_cv_sys_version, [ if test -f /usr/lib/NextStep/software_version; then tcl_cv_sys_version=NEXTSTEP-`awk '/3/,/3/' /usr/lib/NextStep/software_version` else tcl_cv_sys_version=`uname -s`-`uname -r` if test "$?" -ne 0 ; then AC_MSG_WARN([can't find uname command]) tcl_cv_sys_version=unknown else # Special check for weird MP-RAS system (uname returns weird # results, and the version is kept in special file). if test -r /etc/.relid -a "X`uname -n`" = "X`uname -s`" ; then tcl_cv_sys_version=MP-RAS-`awk '{print $[3]}' /etc/.relid` fi if test "`uname -s`" = "AIX" ; then tcl_cv_sys_version=AIX-`uname -v`.`uname -r` fi fi fi ]) system=$tcl_cv_sys_version ]) #-------------------------------------------------------------------- # SC_CONFIG_CFLAGS # # Try to determine the proper flags to pass to the compiler # for building shared libraries and other such nonsense. # # Arguments: # none # # Results: # # Defines and substitutes the following vars: # # DL_OBJS - Name of the object file that implements dynamic # loading for Tcl on this system. # DL_LIBS - Library file(s) to include in tclsh and other base # applications in order for the "load" command to work. # LDFLAGS - Flags to pass to the compiler when linking object # files into an executable application binary such # as tclsh. # LD_SEARCH_FLAGS-Flags to pass to ld, such as "-R /usr/local/tcl/lib", # that tell the run-time dynamic linker where to look # for shared libraries such as libtcl.so. Depends on # the variable LIB_RUNTIME_DIR in the Makefile. Could # be the same as CC_SEARCH_FLAGS if ${CC} is used to link. # CC_SEARCH_FLAGS-Flags to pass to ${CC}, such as "-Wl,-rpath,/usr/local/tcl/lib", # that tell the run-time dynamic linker where to look # for shared libraries such as libtcl.so. Depends on # the variable LIB_RUNTIME_DIR in the Makefile. # MAKE_LIB - Command to execute to build the a library; # differs when building shared or static. # MAKE_STUB_LIB - # Command to execute to build a stub library. # INSTALL_LIB - Command to execute to install a library; # differs when building shared or static. # INSTALL_STUB_LIB - # Command to execute to install a stub library. # STLIB_LD - Base command to use for combining object files # into a static library. # SHLIB_CFLAGS - Flags to pass to cc when compiling the components # of a shared library (may request position-independent # code, among other things). # SHLIB_LD - Base command to use for combining object files # into a shared library. # SHLIB_LD_LIBS - Dependent libraries for the linker to scan when # creating shared libraries. This symbol typically # goes at the end of the "ld" commands that build # shared libraries. The value of the symbol is # "${LIBS}" if all of the dependent libraries should # be specified when creating a shared library. If # dependent libraries should not be specified (as on # SunOS 4.x, where they cause the link to fail, or in # general if Tcl and Tk aren't themselves shared # libraries), then this symbol has an empty string # as its value. # SHLIB_SUFFIX - Suffix to use for the names of dynamically loadable # extensions. An empty string means we don't know how # to use shared libraries on this platform. # TCL_SHLIB_LD_EXTRAS - Additional element which are added to SHLIB_LD_LIBS # TK_SHLIB_LD_EXTRAS for the build of Tcl and Tk, but not recorded in the # tclConfig.sh, since they are only used for the build # of Tcl and Tk. # Examples: MacOS X records the library version and # compatibility version in the shared library. But # of course the Tcl version of this is only used for Tcl. # LIB_SUFFIX - Specifies everything that comes after the "libfoo" # in a static or shared library name, using the $VERSION variable # to put the version in the right place. This is used # by platforms that need non-standard library names. # Examples: ${VERSION}.so.1.1 on NetBSD, since it needs # to have a version after the .so, and ${VERSION}.a # on AIX, since a shared library needs to have # a .a extension whereas shared objects for loadable # extensions have a .so extension. Defaults to # ${VERSION}${SHLIB_SUFFIX}. # TCL_LIBS - # Libs to use when linking Tcl shell or some other # shell that includes Tcl libs. # CFLAGS_DEBUG - # Flags used when running the compiler in debug mode # CFLAGS_OPTIMIZE - # Flags used when running the compiler in optimize mode # CFLAGS - Additional CFLAGS added as necessary (usually 64-bit) # #-------------------------------------------------------------------- AC_DEFUN([SC_CONFIG_CFLAGS], [ # Step 0.a: Enable 64 bit support? AC_MSG_CHECKING([if 64bit support is requested]) AC_ARG_ENABLE(64bit, AC_HELP_STRING([--enable-64bit], [enable 64bit support (default: off)]), [do64bit=$enableval], [do64bit=no]) AC_MSG_RESULT([$do64bit]) # Step 0.b: Enable Solaris 64 bit VIS support? AC_MSG_CHECKING([if 64bit Sparc VIS support is requested]) AC_ARG_ENABLE(64bit-vis, AC_HELP_STRING([--enable-64bit-vis], [enable 64bit Sparc VIS support (default: off)]), [do64bitVIS=$enableval], [do64bitVIS=no]) AC_MSG_RESULT([$do64bitVIS]) # Force 64bit on with VIS AS_IF([test "$do64bitVIS" = "yes"], [do64bit=yes]) # Step 0.c: Check if visibility support is available. Do this here so # that platform specific alternatives can be used below if this fails. AC_CACHE_CHECK([if compiler supports visibility "hidden"], tcl_cv_cc_visibility_hidden, [ hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Werror" AC_TRY_LINK([ extern __attribute__((__visibility__("hidden"))) void f(void); void f(void) {}], [f();], tcl_cv_cc_visibility_hidden=yes, tcl_cv_cc_visibility_hidden=no) CFLAGS=$hold_cflags]) AS_IF([test $tcl_cv_cc_visibility_hidden = yes], [ AC_DEFINE(MODULE_SCOPE, [extern __attribute__((__visibility__("hidden")))], [Compiler support for module scope symbols]) AC_DEFINE(HAVE_HIDDEN, [1], [Compiler support for module scope symbols]) ]) # Step 0.d: Disable -rpath support? AC_MSG_CHECKING([if rpath support is requested]) AC_ARG_ENABLE(rpath, AC_HELP_STRING([--disable-rpath], [disable rpath support (default: on)]), [doRpath=$enableval], [doRpath=yes]) AC_MSG_RESULT([$doRpath]) # Step 1: set the variable "system" to hold the name and version number # for the system. SC_CONFIG_SYSTEM # Step 2: check for existence of -ldl library. This is needed because # Linux can use either -ldl or -ldld for dynamic loading. AC_CHECK_LIB(dl, dlopen, have_dl=yes, have_dl=no) # Require ranlib early so we can override it in special cases below. AC_REQUIRE([AC_PROG_RANLIB]) # Step 3: set configuration options based on system name and version. do64bit_ok=no # default to '{$LIBS}' and set to "" on per-platform necessary basis SHLIB_LD_LIBS='${LIBS}' LDFLAGS_ORIG="$LDFLAGS" # When ld needs options to work in 64-bit mode, put them in # LDFLAGS_ARCH so they eventually end up in LDFLAGS even if [load] # is disabled by the user. [Bug 1016796] LDFLAGS_ARCH="" UNSHARED_LIB_SUFFIX="" TCL_TRIM_DOTS='`echo ${VERSION} | tr -d .`' ECHO_VERSION='`echo ${VERSION}`' TCL_LIB_VERSIONS_OK=ok CFLAGS_DEBUG=-g AS_IF([test "$GCC" = yes], [ CFLAGS_OPTIMIZE=-O2 CFLAGS_WARNING="-Wall" ], [ CFLAGS_OPTIMIZE=-O CFLAGS_WARNING="" ]) AC_CHECK_TOOL(AR, ar) STLIB_LD='${AR} cr' LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH" PLAT_OBJS="" PLAT_SRCS="" LDAIX_SRC="" AS_IF([test x"${SHLIB_VERSION}" = x], [SHLIB_VERSION="1.0"]) case $system in AIX-*) AS_IF([test "${TCL_THREADS}" = "1" -a "$GCC" != "yes"], [ # AIX requires the _r compiler when gcc isn't being used case "${CC}" in *_r|*_r\ *) # ok ... ;; *) # Make sure only first arg gets _r CC=`echo "$CC" | sed -e 's/^\([[^ ]]*\)/\1_r/'` ;; esac AC_MSG_RESULT([Using $CC for compiling with threads]) ]) LIBS="$LIBS -lc" SHLIB_CFLAGS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" LD_LIBRARY_PATH_VAR="LIBPATH" # ldAix No longer needed with use of -bexpall/-brtl # but some extensions may still reference it LDAIX_SRC='$(UNIX_DIR)/ldAix' # Check to enable 64-bit flags for compiler/linker AS_IF([test "$do64bit" = yes], [ AS_IF([test "$GCC" = yes], [ AC_MSG_WARN([64bit mode not supported with GCC on $system]) ], [ do64bit_ok=yes CFLAGS="$CFLAGS -q64" LDFLAGS_ARCH="-q64" RANLIB="${RANLIB} -X64" AR="${AR} -X64" SHLIB_LD_FLAGS="-b64" ]) ]) AS_IF([test "`uname -m`" = ia64], [ # AIX-5 uses ELF style dynamic libraries on IA-64, but not PPC SHLIB_LD="/usr/ccs/bin/ld -G -z text" # AIX-5 has dl* in libc.so DL_LIBS="" AS_IF([test "$GCC" = yes], [ CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' ], [ CC_SEARCH_FLAGS='-R${LIB_RUNTIME_DIR}' ]) LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' ], [ AS_IF([test "$GCC" = yes], [ SHLIB_LD='${CC} -shared -Wl,-bexpall' ], [ SHLIB_LD="/bin/ld -bhalt:4 -bM:SRE -bexpall -H512 -T512 -bnoentry" LDFLAGS="$LDFLAGS -brtl" ]) SHLIB_LD="${SHLIB_LD} ${SHLIB_LD_FLAGS}" DL_LIBS="-ldl" CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} ]) ;; BeOS*) SHLIB_CFLAGS="-fPIC" SHLIB_LD='${CC} -nostart' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" #----------------------------------------------------------- # Check for inet_ntoa in -lbind, for BeOS (which also needs # -lsocket, even if the network functions are in -lnet which # is always linked to, for compatibility. #----------------------------------------------------------- AC_CHECK_LIB(bind, inet_ntoa, [LIBS="$LIBS -lbind -lsocket"]) ;; BSD/OS-2.1*|BSD/OS-3*) SHLIB_CFLAGS="" SHLIB_LD="shlicc -r" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; BSD/OS-4.*) SHLIB_CFLAGS="-export-dynamic -fPIC" SHLIB_LD='${CC} -shared' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" LDFLAGS="$LDFLAGS -export-dynamic" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; CYGWIN_*|MINGW32*) SHLIB_CFLAGS="" SHLIB_LD='${CC} -shared' SHLIB_SUFFIX=".dll" DL_OBJS="tclLoadDl.o" PLAT_OBJS='${CYGWIN_OBJS}' PLAT_SRCS='${CYGWIN_SRCS}' DL_LIBS="-ldl" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" TCL_NEEDS_EXP_FILE=1 TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.dll.a' SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,--out-implib,\$[@].a" AC_CACHE_CHECK(for Cygwin version of gcc, ac_cv_cygwin, AC_TRY_COMPILE([ #ifdef __CYGWIN__ #error cygwin #endif ], [], ac_cv_cygwin=no, ac_cv_cygwin=yes) ) if test "$ac_cv_cygwin" = "no"; then AC_MSG_ERROR([${CC} is not a cygwin compiler.]) fi if test "x${TCL_THREADS}" = "x0"; then AC_MSG_ERROR([CYGWIN compile is only supported with --enable-threads]) fi do64bit_ok=yes if test "x${SHARED_BUILD}" = "x1"; then echo "running cd ../win; ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args" # The eval makes quoting arguments work. if cd ../win; eval ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args; cd ../unix then : else { echo "configure: error: configure failed for ../win" 1>&2; exit 1; } fi fi ;; dgux*) SHLIB_CFLAGS="-K PIC" SHLIB_LD='${CC} -G' SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; Haiku*) LDFLAGS="$LDFLAGS -Wl,--export-dynamic" SHLIB_CFLAGS="-fPIC" SHLIB_SUFFIX=".so" SHLIB_LD='${CC} -shared ${CFLAGS} ${LDFLAGS}' DL_OBJS="tclLoadDl.o" DL_LIBS="-lroot" AC_CHECK_LIB(network, inet_ntoa, [LIBS="$LIBS -lnetwork"]) ;; HP-UX-*.11.*) # Use updated header definitions where possible AC_DEFINE(_XOPEN_SOURCE_EXTENDED, 1, [Do we want to use the XOPEN network library?]) AC_DEFINE(_XOPEN_SOURCE, 1, [Do we want to use the XOPEN network library?]) LIBS="$LIBS -lxnet" # Use the XOPEN network library AS_IF([test "`uname -m`" = ia64], [ SHLIB_SUFFIX=".so" ], [ SHLIB_SUFFIX=".sl" ]) AC_CHECK_LIB(dld, shl_load, tcl_ok=yes, tcl_ok=no) AS_IF([test "$tcl_ok" = yes], [ SHLIB_CFLAGS="+z" SHLIB_LD="ld -b" DL_OBJS="tclLoadShl.o" DL_LIBS="-ldld" LDFLAGS="$LDFLAGS -Wl,-E" CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.' LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.' LD_LIBRARY_PATH_VAR="SHLIB_PATH" ]) AS_IF([test "$GCC" = yes], [ SHLIB_LD='${CC} -shared' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} ], [ CFLAGS="$CFLAGS -z" ]) # Users may want PA-RISC 1.1/2.0 portable code - needs HP cc #CFLAGS="$CFLAGS +DAportable" # Check to enable 64-bit flags for compiler/linker AS_IF([test "$do64bit" = "yes"], [ AS_IF([test "$GCC" = yes], [ case `${CC} -dumpmachine` in hppa64*) # 64-bit gcc in use. Fix flags for GNU ld. do64bit_ok=yes SHLIB_LD='${CC} -shared' AS_IF([test $doRpath = yes], [ CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}']) LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} ;; *) AC_MSG_WARN([64bit mode not supported with GCC on $system]) ;; esac ], [ do64bit_ok=yes CFLAGS="$CFLAGS +DD64" LDFLAGS_ARCH="+DD64" ]) ]) ;; HP-UX-*.08.*|HP-UX-*.09.*|HP-UX-*.10.*) SHLIB_SUFFIX=".sl" AC_CHECK_LIB(dld, shl_load, tcl_ok=yes, tcl_ok=no) AS_IF([test "$tcl_ok" = yes], [ SHLIB_CFLAGS="+z" SHLIB_LD="ld -b" SHLIB_LD_LIBS="" DL_OBJS="tclLoadShl.o" DL_LIBS="-ldld" LDFLAGS="$LDFLAGS -Wl,-E" CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.' LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.' LD_LIBRARY_PATH_VAR="SHLIB_PATH" ]) ;; IRIX-5.*) SHLIB_CFLAGS="" SHLIB_LD="ld -shared -rdata_shared" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" AC_LIBOBJ(mkstemp) AS_IF([test $doRpath = yes], [ CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}']) ;; IRIX-6.*) SHLIB_CFLAGS="" SHLIB_LD="ld -n32 -shared -rdata_shared" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" AC_LIBOBJ(mkstemp) AS_IF([test $doRpath = yes], [ CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}']) AS_IF([test "$GCC" = yes], [ CFLAGS="$CFLAGS -mabi=n32" LDFLAGS="$LDFLAGS -mabi=n32" ], [ case $system in IRIX-6.3) # Use to build 6.2 compatible binaries on 6.3. CFLAGS="$CFLAGS -n32 -D_OLD_TERMIOS" ;; *) CFLAGS="$CFLAGS -n32" ;; esac LDFLAGS="$LDFLAGS -n32" ]) ;; IRIX64-6.*) SHLIB_CFLAGS="" SHLIB_LD="ld -n32 -shared -rdata_shared" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" AC_LIBOBJ(mkstemp) AS_IF([test $doRpath = yes], [ CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}']) # Check to enable 64-bit flags for compiler/linker AS_IF([test "$do64bit" = yes], [ AS_IF([test "$GCC" = yes], [ AC_MSG_WARN([64bit mode not supported by gcc]) ], [ do64bit_ok=yes SHLIB_LD="ld -64 -shared -rdata_shared" CFLAGS="$CFLAGS -64" LDFLAGS_ARCH="-64" ]) ]) ;; Linux*|GNU*|NetBSD-Debian) SHLIB_CFLAGS="-fPIC" SHLIB_SUFFIX=".so" CFLAGS_OPTIMIZE="-O2" # egcs-2.91.66 on Redhat Linux 6.0 generates lots of warnings # when you inline the string and math operations. Turn this off to # get rid of the warnings. #CFLAGS_OPTIMIZE="${CFLAGS_OPTIMIZE} -D__NO_STRING_INLINES -D__NO_MATH_INLINES" SHLIB_LD='${CC} -shared ${CFLAGS} ${LDFLAGS}' DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" LDFLAGS="$LDFLAGS -Wl,--export-dynamic" AS_IF([test $doRpath = yes], [ CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}']) LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} AS_IF([test "`uname -m`" = "alpha"], [CFLAGS="$CFLAGS -mieee"]) AS_IF([test $do64bit = yes], [ AC_CACHE_CHECK([if compiler accepts -m64 flag], tcl_cv_cc_m64, [ hold_cflags=$CFLAGS CFLAGS="$CFLAGS -m64" AC_TRY_LINK(,, tcl_cv_cc_m64=yes, tcl_cv_cc_m64=no) CFLAGS=$hold_cflags]) AS_IF([test $tcl_cv_cc_m64 = yes], [ CFLAGS="$CFLAGS -m64" do64bit_ok=yes ]) ]) # The combo of gcc + glibc has a bug related to inlining of # functions like strtod(). The -fno-builtin flag should address # this problem but it does not work. The -fno-inline flag is kind # of overkill but it works. Disable inlining only when one of the # files in compat/*.c is being linked in. AS_IF([test x"${USE_COMPAT}" != x],[CFLAGS="$CFLAGS -fno-inline"]) ;; Lynx*) SHLIB_CFLAGS="-fPIC" SHLIB_SUFFIX=".so" CFLAGS_OPTIMIZE=-02 SHLIB_LD='${CC} -shared' DL_OBJS="tclLoadDl.o" DL_LIBS="-mshared -ldl" LD_FLAGS="-Wl,--export-dynamic" AS_IF([test $doRpath = yes], [ CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}']) ;; MP-RAS-02*) SHLIB_CFLAGS="-K PIC" SHLIB_LD='${CC} -G' SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; MP-RAS-*) SHLIB_CFLAGS="-K PIC" SHLIB_LD='${CC} -G' SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" LDFLAGS="$LDFLAGS -Wl,-Bexport" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; OpenBSD-*) arch=`arch -s` case "$arch" in vax) # Equivalent using configure option --disable-load # Step 4 will set the necessary variables DL_OBJS="" SHLIB_LD_LIBS="" LDFLAGS="" ;; *) case "$arch" in alpha|sparc|sparc64) SHLIB_CFLAGS="-fPIC" ;; *) SHLIB_CFLAGS="-fpic" ;; esac SHLIB_LD='${CC} -shared ${SHLIB_CFLAGS}' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" AS_IF([test $doRpath = yes], [ CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}']) LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.${SHLIB_VERSION}' LDFLAGS="-Wl,-export-dynamic" ;; esac case "$arch" in vax) CFLAGS_OPTIMIZE="-O1" ;; sh) CFLAGS_OPTIMIZE="-O0" ;; *) CFLAGS_OPTIMIZE="-O2" ;; esac AS_IF([test "${TCL_THREADS}" = "1"], [ # On OpenBSD: Compile with -pthread # Don't link with -lpthread LIBS=`echo $LIBS | sed s/-lpthread//` CFLAGS="$CFLAGS -pthread" ]) # OpenBSD doesn't do version numbers with dots. UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' TCL_LIB_VERSIONS_OK=nodots ;; NetBSD-*) # NetBSD has ELF and can use 'cc -shared' to build shared libs SHLIB_CFLAGS="-fPIC" SHLIB_LD='${CC} -shared ${SHLIB_CFLAGS}' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" LDFLAGS="$LDFLAGS -export-dynamic" AS_IF([test $doRpath = yes], [ CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}']) LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} AS_IF([test "${TCL_THREADS}" = "1"], [ # The -pthread needs to go in the CFLAGS, not LIBS LIBS=`echo $LIBS | sed s/-pthread//` CFLAGS="$CFLAGS -pthread" LDFLAGS="$LDFLAGS -pthread" ]) ;; FreeBSD-*) # This configuration from FreeBSD Ports. SHLIB_CFLAGS="-fPIC" SHLIB_LD="${CC} -shared" SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,-soname,\$[@]" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" LDFLAGS="" AS_IF([test $doRpath = yes], [ CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}']) AS_IF([test "${TCL_THREADS}" = "1"], [ # The -pthread needs to go in the LDFLAGS, not LIBS LIBS=`echo $LIBS | sed s/-pthread//` CFLAGS="$CFLAGS $PTHREAD_CFLAGS" LDFLAGS="$LDFLAGS $PTHREAD_LIBS"]) case $system in FreeBSD-3.*) # Version numbers are dot-stripped by system policy. TCL_TRIM_DOTS=`echo ${VERSION} | tr -d .` UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so' TCL_LIB_VERSIONS_OK=nodots ;; esac ;; Darwin-*) CFLAGS_OPTIMIZE="-Os" SHLIB_CFLAGS="-fno-common" # To avoid discrepancies between what headers configure sees during # preprocessing tests and compiling tests, move any -isysroot and # -mmacosx-version-min flags from CFLAGS to CPPFLAGS: CPPFLAGS="${CPPFLAGS} `echo " ${CFLAGS}" | \ awk 'BEGIN {FS=" +-";ORS=" "}; {for (i=2;i<=NF;i++) \ if ([$]i~/^(isysroot|mmacosx-version-min)/) print "-"[$]i}'`" CFLAGS="`echo " ${CFLAGS}" | \ awk 'BEGIN {FS=" +-";ORS=" "}; {for (i=2;i<=NF;i++) \ if (!([$]i~/^(isysroot|mmacosx-version-min)/)) print "-"[$]i}'`" AS_IF([test $do64bit = yes], [ case `arch` in ppc) AC_CACHE_CHECK([if compiler accepts -arch ppc64 flag], tcl_cv_cc_arch_ppc64, [ hold_cflags=$CFLAGS CFLAGS="$CFLAGS -arch ppc64 -mpowerpc64 -mcpu=G5" AC_TRY_LINK(,, tcl_cv_cc_arch_ppc64=yes, tcl_cv_cc_arch_ppc64=no) CFLAGS=$hold_cflags]) AS_IF([test $tcl_cv_cc_arch_ppc64 = yes], [ CFLAGS="$CFLAGS -arch ppc64 -mpowerpc64 -mcpu=G5" do64bit_ok=yes ]);; i386) AC_CACHE_CHECK([if compiler accepts -arch x86_64 flag], tcl_cv_cc_arch_x86_64, [ hold_cflags=$CFLAGS CFLAGS="$CFLAGS -arch x86_64" AC_TRY_LINK(,, tcl_cv_cc_arch_x86_64=yes, tcl_cv_cc_arch_x86_64=no) CFLAGS=$hold_cflags]) AS_IF([test $tcl_cv_cc_arch_x86_64 = yes], [ CFLAGS="$CFLAGS -arch x86_64" do64bit_ok=yes ]);; *) AC_MSG_WARN([Don't know how enable 64-bit on architecture `arch`]);; esac ], [ # Check for combined 32-bit and 64-bit fat build AS_IF([echo "$CFLAGS " |grep -E -q -- '-arch (ppc64|x86_64) ' \ && echo "$CFLAGS " |grep -E -q -- '-arch (ppc|i386) '], [ fat_32_64=yes]) ]) SHLIB_LD='${CC} -dynamiclib ${CFLAGS} ${LDFLAGS}' AC_CACHE_CHECK([if ld accepts -single_module flag], tcl_cv_ld_single_module, [ hold_ldflags=$LDFLAGS LDFLAGS="$LDFLAGS -dynamiclib -Wl,-single_module" AC_TRY_LINK(, [int i;], tcl_cv_ld_single_module=yes, tcl_cv_ld_single_module=no) LDFLAGS=$hold_ldflags]) AS_IF([test $tcl_cv_ld_single_module = yes], [ SHLIB_LD="${SHLIB_LD} -Wl,-single_module" ]) SHLIB_SUFFIX=".dylib" DL_OBJS="tclLoadDyld.o" DL_LIBS="" # Don't use -prebind when building for Mac OS X 10.4 or later only: AS_IF([test "`echo "${MACOSX_DEPLOYMENT_TARGET}" | awk -F '10\\.' '{print int([$]2)}'`" -lt 4 -a \ "`echo "${CPPFLAGS}" | awk -F '-mmacosx-version-min=10\\.' '{print int([$]2)}'`" -lt 4], [ LDFLAGS="$LDFLAGS -prebind"]) LDFLAGS="$LDFLAGS -headerpad_max_install_names" AC_CACHE_CHECK([if ld accepts -search_paths_first flag], tcl_cv_ld_search_paths_first, [ hold_ldflags=$LDFLAGS LDFLAGS="$LDFLAGS -Wl,-search_paths_first" AC_TRY_LINK(, [int i;], tcl_cv_ld_search_paths_first=yes, tcl_cv_ld_search_paths_first=no) LDFLAGS=$hold_ldflags]) AS_IF([test $tcl_cv_ld_search_paths_first = yes], [ LDFLAGS="$LDFLAGS -Wl,-search_paths_first" ]) AS_IF([test "$tcl_cv_cc_visibility_hidden" != yes], [ AC_DEFINE(MODULE_SCOPE, [__private_extern__], [Compiler support for module scope symbols]) ]) CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" LD_LIBRARY_PATH_VAR="DYLD_LIBRARY_PATH" AC_DEFINE(MAC_OSX_TCL, 1, [Is this a Mac I see before me?]) PLAT_OBJS='${MAC_OSX_OBJS}' PLAT_SRCS='${MAC_OSX_SRCS}' AC_MSG_CHECKING([whether to use CoreFoundation]) AC_ARG_ENABLE(corefoundation, AC_HELP_STRING([--enable-corefoundation], [use CoreFoundation API on MacOSX (default: on)]), [tcl_corefoundation=$enableval], [tcl_corefoundation=yes]) AC_MSG_RESULT([$tcl_corefoundation]) AS_IF([test $tcl_corefoundation = yes], [ AC_CACHE_CHECK([for CoreFoundation.framework], tcl_cv_lib_corefoundation, [ hold_libs=$LIBS AS_IF([test "$fat_32_64" = yes], [ for v in CFLAGS CPPFLAGS LDFLAGS; do # On Tiger there is no 64-bit CF, so remove 64-bit # archs from CFLAGS et al. while testing for # presence of CF. 64-bit CF is disabled in # tclUnixPort.h if necessary. eval 'hold_'$v'="$'$v'";'$v'="`echo "$'$v' "|sed -e "s/-arch ppc64 / /g" -e "s/-arch x86_64 / /g"`"' done]) LIBS="$LIBS -framework CoreFoundation" AC_TRY_LINK([#include ], [CFBundleRef b = CFBundleGetMainBundle();], tcl_cv_lib_corefoundation=yes, tcl_cv_lib_corefoundation=no) AS_IF([test "$fat_32_64" = yes], [ for v in CFLAGS CPPFLAGS LDFLAGS; do eval $v'="$hold_'$v'"' done]) LIBS=$hold_libs]) AS_IF([test $tcl_cv_lib_corefoundation = yes], [ LIBS="$LIBS -framework CoreFoundation" AC_DEFINE(HAVE_COREFOUNDATION, 1, [Do we have access to Darwin CoreFoundation.framework?]) ], [tcl_corefoundation=no]) AS_IF([test "$fat_32_64" = yes -a $tcl_corefoundation = yes],[ AC_CACHE_CHECK([for 64-bit CoreFoundation], tcl_cv_lib_corefoundation_64, [ for v in CFLAGS CPPFLAGS LDFLAGS; do eval 'hold_'$v'="$'$v'";'$v'="`echo "$'$v' "|sed -e "s/-arch ppc / /g" -e "s/-arch i386 / /g"`"' done AC_TRY_LINK([#include ], [CFBundleRef b = CFBundleGetMainBundle();], tcl_cv_lib_corefoundation_64=yes, tcl_cv_lib_corefoundation_64=no) for v in CFLAGS CPPFLAGS LDFLAGS; do eval $v'="$hold_'$v'"' done]) AS_IF([test $tcl_cv_lib_corefoundation_64 = no], [ AC_DEFINE(NO_COREFOUNDATION_64, 1, [Is Darwin CoreFoundation unavailable for 64-bit?]) LDFLAGS="$LDFLAGS -Wl,-no_arch_warnings" ]) ]) ]) ;; NEXTSTEP-*) SHLIB_CFLAGS="" SHLIB_LD='${CC} -nostdlib -r' SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadNext.o" DL_LIBS="" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; OS/390-*) SHLIB_LD_LIBS="" CFLAGS_OPTIMIZE="" # Optimizer is buggy AC_DEFINE(_OE_SOCKETS, 1, # needed in sys/socket.h [Should OS/390 do the right thing with sockets?]) ;; OSF1-1.0|OSF1-1.1|OSF1-1.2) # OSF/1 1.[012] from OSF, and derivatives, including Paragon OSF/1 SHLIB_CFLAGS="" # Hack: make package name same as library name SHLIB_LD='ld -R -export $@:' SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadOSF.o" DL_LIBS="" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; OSF1-1.*) # OSF/1 1.3 from OSF using ELF, and derivatives, including AD2 SHLIB_CFLAGS="-fPIC" AS_IF([test "$SHARED_BUILD" = 1], [SHLIB_LD="ld -shared"], [ SHLIB_LD="ld -non_shared" ]) SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; OSF1-V*) # Digital OSF/1 SHLIB_CFLAGS="" AS_IF([test "$SHARED_BUILD" = 1], [ SHLIB_LD='ld -shared -expect_unresolved "*"' ], [ SHLIB_LD='ld -non_shared -expect_unresolved "*"' ]) SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" AS_IF([test $doRpath = yes], [ CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}']) AS_IF([test "$GCC" = yes], [CFLAGS="$CFLAGS -mieee"], [ CFLAGS="$CFLAGS -DHAVE_TZSET -std1 -ieee"]) # see pthread_intro(3) for pthread support on osf1, k.furukawa AS_IF([test "${TCL_THREADS}" = 1], [ CFLAGS="$CFLAGS -DHAVE_PTHREAD_ATTR_SETSTACKSIZE" CFLAGS="$CFLAGS -DTCL_THREAD_STACK_MIN=PTHREAD_STACK_MIN*64" LIBS=`echo $LIBS | sed s/-lpthreads//` AS_IF([test "$GCC" = yes], [ LIBS="$LIBS -lpthread -lmach -lexc" ], [ CFLAGS="$CFLAGS -pthread" LDFLAGS="$LDFLAGS -pthread" ]) ]) ;; QNX-6*) # QNX RTP # This may work for all QNX, but it was only reported for v6. SHLIB_CFLAGS="-fPIC" SHLIB_LD="ld -Bshareable -x" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" # dlopen is in -lc on QNX DL_LIBS="" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; SCO_SV-3.2*) # Note, dlopen is available only on SCO 3.2.5 and greater. However, # this test works, since "uname -s" was non-standard in 3.2.4 and # below. AS_IF([test "$GCC" = yes], [ SHLIB_CFLAGS="-fPIC -melf" LDFLAGS="$LDFLAGS -melf -Wl,-Bexport" ], [ SHLIB_CFLAGS="-Kpic -belf" LDFLAGS="$LDFLAGS -belf -Wl,-Bexport" ]) SHLIB_LD="ld -G" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; SINIX*5.4*) SHLIB_CFLAGS="-K PIC" SHLIB_LD='${CC} -G' SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; SunOS-4*) SHLIB_CFLAGS="-PIC" SHLIB_LD="ld" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} # SunOS can't handle version numbers with dots in them in library # specs, like -ltcl7.5, so use -ltcl75 instead. Also, it # requires an extra version number at the end of .so file names. # So, the library has to have a name like libtcl75.so.1.0 SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.${SHLIB_VERSION}' UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' TCL_LIB_VERSIONS_OK=nodots ;; SunOS-5.[[0-6]]) # Careful to not let 5.10+ fall into this case # Note: If _REENTRANT isn't defined, then Solaris # won't define thread-safe library routines. AC_DEFINE(_REENTRANT, 1, [Do we want the reentrant OS API?]) AC_DEFINE(_POSIX_PTHREAD_SEMANTICS, 1, [Do we really want to follow the standard? Yes we do!]) SHLIB_CFLAGS="-KPIC" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" AS_IF([test "$GCC" = yes], [ SHLIB_LD='${CC} -shared' CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} ], [ SHLIB_LD="/usr/ccs/bin/ld -G -z text" CC_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} ]) ;; SunOS-5*) # Note: If _REENTRANT isn't defined, then Solaris # won't define thread-safe library routines. AC_DEFINE(_REENTRANT, 1, [Do we want the reentrant OS API?]) AC_DEFINE(_POSIX_PTHREAD_SEMANTICS, 1, [Do we really want to follow the standard? Yes we do!]) SHLIB_CFLAGS="-KPIC" # Check to enable 64-bit flags for compiler/linker AS_IF([test "$do64bit" = yes], [ arch=`isainfo` AS_IF([test "$arch" = "sparcv9 sparc"], [ AS_IF([test "$GCC" = yes], [ AS_IF([test "`${CC} -dumpversion | awk -F. '{print [$]1}'`" -lt 3], [ AC_MSG_WARN([64bit mode not supported with GCC < 3.2 on $system]) ], [ do64bit_ok=yes CFLAGS="$CFLAGS -m64 -mcpu=v9" LDFLAGS="$LDFLAGS -m64 -mcpu=v9" SHLIB_CFLAGS="-fPIC" ]) ], [ do64bit_ok=yes AS_IF([test "$do64bitVIS" = yes], [ CFLAGS="$CFLAGS -xarch=v9a" LDFLAGS_ARCH="-xarch=v9a" ], [ CFLAGS="$CFLAGS -xarch=v9" LDFLAGS_ARCH="-xarch=v9" ]) # Solaris 64 uses this as well #LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH_64" ]) ], [AS_IF([test "$arch" = "amd64 i386"], [ AS_IF([test "$GCC" = yes], [ case $system in SunOS-5.1[[1-9]]*|SunOS-5.[[2-9]][[0-9]]*) do64bit_ok=yes CFLAGS="$CFLAGS -m64" LDFLAGS="$LDFLAGS -m64";; *) AC_MSG_WARN([64bit mode not supported with GCC on $system]);; esac ], [ do64bit_ok=yes case $system in SunOS-5.1[[1-9]]*|SunOS-5.[[2-9]][[0-9]]*) CFLAGS="$CFLAGS -m64" LDFLAGS="$LDFLAGS -m64";; *) CFLAGS="$CFLAGS -xarch=amd64" LDFLAGS="$LDFLAGS -xarch=amd64";; esac ]) ], [AC_MSG_WARN([64bit mode not supported for $arch])])]) ]) #-------------------------------------------------------------------- # On Solaris 5.x i386 with the sunpro compiler we need to link # with sunmath to get floating point rounding control #-------------------------------------------------------------------- AS_IF([test "$GCC" = yes],[use_sunmath=no],[ arch=`isainfo` AC_MSG_CHECKING([whether to use -lsunmath for fp rounding control]) AS_IF([test "$arch" = "amd64 i386" -o "$arch" = "i386"], [ AC_MSG_RESULT([yes]) MATH_LIBS="-lsunmath $MATH_LIBS" AC_CHECK_HEADER(sunmath.h) use_sunmath=yes ], [ AC_MSG_RESULT([no]) use_sunmath=no ]) ]) SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" AS_IF([test "$GCC" = yes], [ SHLIB_LD='${CC} -shared' CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} AS_IF([test "$do64bit_ok" = yes], [ AS_IF([test "$arch" = "sparcv9 sparc"], [ # We need to specify -static-libgcc or we need to # add the path to the sparv9 libgcc. SHLIB_LD="$SHLIB_LD -m64 -mcpu=v9 -static-libgcc" # for finding sparcv9 libgcc, get the regular libgcc # path, remove so name and append 'sparcv9' #v9gcclibdir="`gcc -print-file-name=libgcc_s.so` | ..." #CC_SEARCH_FLAGS="${CC_SEARCH_FLAGS},-R,$v9gcclibdir" ], [AS_IF([test "$arch" = "amd64 i386"], [ SHLIB_LD="$SHLIB_LD -m64 -static-libgcc" ])]) ]) ], [ AS_IF([test "$use_sunmath" = yes], [textmode=textoff],[textmode=text]) case $system in SunOS-5.[[1-9]][[0-9]]*|SunOS-5.[[7-9]]) SHLIB_LD="\${CC} -G -z $textmode \${LDFLAGS}";; *) SHLIB_LD="/usr/ccs/bin/ld -G -z $textmode";; esac CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' ]) ;; UNIX_SV* | UnixWare-5*) SHLIB_CFLAGS="-KPIC" SHLIB_LD='${CC} -G' SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" # Some UNIX_SV* systems (unixware 1.1.2 for example) have linkers # that don't grok the -Bexport option. Test that it does. AC_CACHE_CHECK([for ld accepts -Bexport flag], tcl_cv_ld_Bexport, [ hold_ldflags=$LDFLAGS LDFLAGS="$LDFLAGS -Wl,-Bexport" AC_TRY_LINK(, [int i;], tcl_cv_ld_Bexport=yes, tcl_cv_ld_Bexport=no) LDFLAGS=$hold_ldflags]) AS_IF([test $tcl_cv_ld_Bexport = yes], [ LDFLAGS="$LDFLAGS -Wl,-Bexport" ]) CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; esac AS_IF([test "$do64bit" = yes -a "$do64bit_ok" = no], [ AC_MSG_WARN([64bit support being disabled -- don't know magic for this platform]) ]) AS_IF([test "$do64bit" = yes -a "$do64bit_ok" = yes], [ AC_DEFINE(TCL_CFG_DO64BIT, 1, [Is this a 64-bit build?]) ]) dnl # Add any CPPFLAGS set in the environment to our CFLAGS, but delay doing so dnl # until the end of configure, as configure's compile and link tests use dnl # both CPPFLAGS and CFLAGS (unlike our compile and link) but configure's dnl # preprocessing tests use only CPPFLAGS. AC_CONFIG_COMMANDS_PRE([CFLAGS="${CFLAGS} ${CPPFLAGS}"; CPPFLAGS=""]) # Step 4: disable dynamic loading if requested via a command-line switch. AC_ARG_ENABLE(load, AC_HELP_STRING([--enable-load], [allow dynamic loading and "load" command (default: on)]), [tcl_ok=$enableval], [tcl_ok=yes]) AS_IF([test "$tcl_ok" = no], [DL_OBJS=""]) AS_IF([test "x$DL_OBJS" != x], [BUILD_DLTEST="\$(DLTEST_TARGETS)"], [ AC_MSG_WARN([Can't figure out how to do dynamic loading or shared libraries on this system.]) SHLIB_CFLAGS="" SHLIB_LD="" SHLIB_SUFFIX="" DL_OBJS="tclLoadNone.o" DL_LIBS="" LDFLAGS="$LDFLAGS_ORIG" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" BUILD_DLTEST="" ]) LDFLAGS="$LDFLAGS $LDFLAGS_ARCH" # If we're running gcc, then change the C flags for compiling shared # libraries to the right flags for gcc, instead of those for the # standard manufacturer compiler. AS_IF([test "$DL_OBJS" != "tclLoadNone.o" -a "$GCC" = yes], [ case $system in AIX-*) ;; BSD/OS*) ;; CYGWIN_*|MINGW32_*) ;; IRIX*) ;; NetBSD-*|FreeBSD-*|OpenBSD-*) ;; Darwin-*) ;; SCO_SV-3.2*) ;; *) SHLIB_CFLAGS="-fPIC" ;; esac]) AS_IF([test "$tcl_cv_cc_visibility_hidden" != yes], [ AC_DEFINE(MODULE_SCOPE, [extern], [No Compiler support for module scope symbols]) ]) AS_IF([test "$SHARED_LIB_SUFFIX" = ""], [ SHARED_LIB_SUFFIX='${VERSION}${SHLIB_SUFFIX}']) AS_IF([test "$UNSHARED_LIB_SUFFIX" = ""], [ UNSHARED_LIB_SUFFIX='${VERSION}.a']) DLL_INSTALL_DIR="\$(LIB_INSTALL_DIR)" AS_IF([test "${SHARED_BUILD}" = 1 -a "${SHLIB_SUFFIX}" != ""], [ LIB_SUFFIX=${SHARED_LIB_SUFFIX} MAKE_LIB='${SHLIB_LD} -o [$]@ ${OBJS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}' AS_IF([test "${SHLIB_SUFFIX}" = ".dll"], [ INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(BIN_INSTALL_DIR)/$(LIB_FILE)";if test -f $(LIB_FILE).a; then $(INSTALL_DATA) $(LIB_FILE).a "$(LIB_INSTALL_DIR)"; fi;' DLL_INSTALL_DIR="\$(BIN_INSTALL_DIR)" ], [ INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(LIB_INSTALL_DIR)/$(LIB_FILE)"' ]) ], [ LIB_SUFFIX=${UNSHARED_LIB_SUFFIX} AS_IF([test "$RANLIB" = ""], [ MAKE_LIB='$(STLIB_LD) [$]@ ${OBJS}' ], [ MAKE_LIB='${STLIB_LD} [$]@ ${OBJS} ; ${RANLIB} [$]@' ]) INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(LIB_INSTALL_DIR)/$(LIB_FILE)"' ]) # Stub lib does not depend on shared/static configuration AS_IF([test "$RANLIB" = ""], [ MAKE_STUB_LIB='${STLIB_LD} [$]@ ${STUB_LIB_OBJS}' ], [ MAKE_STUB_LIB='${STLIB_LD} [$]@ ${STUB_LIB_OBJS} ; ${RANLIB} [$]@' ]) INSTALL_STUB_LIB='$(INSTALL_LIBRARY) $(STUB_LIB_FILE) "$(LIB_INSTALL_DIR)/$(STUB_LIB_FILE)"' # Define TCL_LIBS now that we know what DL_LIBS is. # The trick here is that we don't want to change the value of TCL_LIBS if # it is already set when tclConfig.sh had been loaded by Tk. AS_IF([test "x${TCL_LIBS}" = x], [ TCL_LIBS="${DL_LIBS} ${LIBS} ${MATH_LIBS}"]) AC_SUBST(TCL_LIBS) # See if the compiler supports casting to a union type. # This is used to stop gcc from printing a compiler # warning when initializing a union member. AC_CACHE_CHECK(for cast to union support, tcl_cv_cast_to_union, AC_TRY_COMPILE([], [ union foo { int i; double d; }; union foo f = (union foo) (int) 0; ], tcl_cv_cast_to_union=yes, tcl_cv_cast_to_union=no) ) if test "$tcl_cv_cast_to_union" = "yes"; then AC_DEFINE(HAVE_CAST_TO_UNION, 1, [Defined when compiler supports casting to union type.]) fi # FIXME: This subst was left in only because the TCL_DL_LIBS # entry in tclConfig.sh uses it. It is not clear why someone # would use TCL_DL_LIBS instead of TCL_LIBS. AC_SUBST(DL_LIBS) AC_SUBST(DL_OBJS) AC_SUBST(PLAT_OBJS) AC_SUBST(PLAT_SRCS) AC_SUBST(LDAIX_SRC) AC_SUBST(CFLAGS) AC_SUBST(CFLAGS_DEBUG) AC_SUBST(CFLAGS_OPTIMIZE) AC_SUBST(CFLAGS_WARNING) AC_SUBST(LDFLAGS) AC_SUBST(LDFLAGS_DEBUG) AC_SUBST(LDFLAGS_OPTIMIZE) AC_SUBST(CC_SEARCH_FLAGS) AC_SUBST(LD_SEARCH_FLAGS) AC_SUBST(STLIB_LD) AC_SUBST(SHLIB_LD) AC_SUBST(TCL_SHLIB_LD_EXTRAS) AC_SUBST(TK_SHLIB_LD_EXTRAS) AC_SUBST(SHLIB_LD_LIBS) AC_SUBST(SHLIB_CFLAGS) AC_SUBST(SHLIB_SUFFIX) AC_DEFINE_UNQUOTED(TCL_SHLIB_EXT,"${SHLIB_SUFFIX}", [What is the default extension for shared libraries?]) AC_SUBST(MAKE_LIB) AC_SUBST(MAKE_STUB_LIB) AC_SUBST(INSTALL_LIB) AC_SUBST(DLL_INSTALL_DIR) AC_SUBST(INSTALL_STUB_LIB) AC_SUBST(RANLIB) ]) #-------------------------------------------------------------------- # SC_MISSING_POSIX_HEADERS # # Supply substitutes for missing POSIX header files. Special # notes: # - stdlib.h doesn't define strtol, strtoul, or # strtod insome versions of SunOS # - some versions of string.h don't declare procedures such # as strstr # # Arguments: # none # # Results: # # Defines some of the following vars: # NO_DIRENT_H # NO_VALUES_H # NO_STDLIB_H # NO_STRING_H # NO_SYS_WAIT_H # NO_DLFCN_H # HAVE_SYS_PARAM_H # # HAVE_STRING_H ? # #-------------------------------------------------------------------- AC_DEFUN([SC_MISSING_POSIX_HEADERS], [ AC_CACHE_CHECK([dirent.h], tcl_cv_dirent_h, [ AC_TRY_LINK([#include #include ], [ #ifndef _POSIX_SOURCE # ifdef __Lynx__ /* * Generate compilation error to make the test fail: Lynx headers * are only valid if really in the POSIX environment. */ missing_procedure(); # endif #endif DIR *d; struct dirent *entryPtr; char *p; d = opendir("foobar"); entryPtr = readdir(d); p = entryPtr->d_name; closedir(d); ], tcl_cv_dirent_h=yes, tcl_cv_dirent_h=no)]) if test $tcl_cv_dirent_h = no; then AC_DEFINE(NO_DIRENT_H, 1, [Do we have ?]) fi AC_CHECK_HEADER(float.h, , [AC_DEFINE(NO_FLOAT_H, 1, [Do we have ?])]) AC_CHECK_HEADER(values.h, , [AC_DEFINE(NO_VALUES_H, 1, [Do we have ?])]) AC_CHECK_HEADER(stdlib.h, tcl_ok=1, tcl_ok=0) AC_EGREP_HEADER(strtol, stdlib.h, , tcl_ok=0) AC_EGREP_HEADER(strtoul, stdlib.h, , tcl_ok=0) AC_EGREP_HEADER(strtod, stdlib.h, , tcl_ok=0) if test $tcl_ok = 0; then AC_DEFINE(NO_STDLIB_H, 1, [Do we have ?]) fi AC_CHECK_HEADER(string.h, tcl_ok=1, tcl_ok=0) AC_EGREP_HEADER(strstr, string.h, , tcl_ok=0) AC_EGREP_HEADER(strerror, string.h, , tcl_ok=0) # See also memmove check below for a place where NO_STRING_H can be # set and why. if test $tcl_ok = 0; then AC_DEFINE(NO_STRING_H, 1, [Do we have ?]) fi AC_CHECK_HEADER(sys/wait.h, , [AC_DEFINE(NO_SYS_WAIT_H, 1, [Do we have ?])]) AC_CHECK_HEADER(dlfcn.h, , [AC_DEFINE(NO_DLFCN_H, 1, [Do we have ?])]) # OS/390 lacks sys/param.h (and doesn't need it, by chance). AC_HAVE_HEADERS(sys/param.h) ]) #-------------------------------------------------------------------- # SC_PATH_X # # Locate the X11 header files and the X11 library archive. Try # the ac_path_x macro first, but if it doesn't find the X stuff # (e.g. because there's no xmkmf program) then check through # a list of possible directories. Under some conditions the # autoconf macro will return an include directory that contains # no include files, so double-check its result just to be safe. # # Arguments: # none # # Results: # # Sets the following vars: # XINCLUDES # XLIBSW # #-------------------------------------------------------------------- AC_DEFUN([SC_PATH_X], [ AC_PATH_X not_really_there="" if test "$no_x" = ""; then if test "$x_includes" = ""; then AC_TRY_CPP([#include ], , not_really_there="yes") else if test ! -r $x_includes/X11/Xlib.h; then not_really_there="yes" fi fi fi if test "$no_x" = "yes" -o "$not_really_there" = "yes"; then AC_MSG_CHECKING([for X11 header files]) found_xincludes="no" AC_TRY_CPP([#include ], found_xincludes="yes", found_xincludes="no") if test "$found_xincludes" = "no"; then dirs="/usr/unsupported/include /usr/local/include /usr/X386/include /usr/X11R6/include /usr/X11R5/include /usr/include/X11R5 /usr/include/X11R4 /usr/openwin/include /usr/X11/include /usr/sww/include" for i in $dirs ; do if test -r $i/X11/Xlib.h; then AC_MSG_RESULT([$i]) XINCLUDES=" -I$i" found_xincludes="yes" break fi done fi else if test "$x_includes" != ""; then XINCLUDES="-I$x_includes" found_xincludes="yes" fi fi if test "$found_xincludes" = "no"; then AC_MSG_RESULT([couldn't find any!]) fi if test "$no_x" = yes; then AC_MSG_CHECKING([for X11 libraries]) XLIBSW=nope dirs="/usr/unsupported/lib /usr/local/lib /usr/X386/lib /usr/X11R6/lib /usr/X11R5/lib /usr/lib/X11R5 /usr/lib/X11R4 /usr/openwin/lib /usr/X11/lib /usr/sww/X11/lib" for i in $dirs ; do if test -r $i/libX11.a -o -r $i/libX11.so -o -r $i/libX11.sl -o -r $i/libX11.dylib; then AC_MSG_RESULT([$i]) XLIBSW="-L$i -lX11" x_libraries="$i" break fi done else if test "$x_libraries" = ""; then XLIBSW=-lX11 else XLIBSW="-L$x_libraries -lX11" fi fi if test "$XLIBSW" = nope ; then AC_CHECK_LIB(Xwindow, XCreateWindow, XLIBSW=-lXwindow) fi if test "$XLIBSW" = nope ; then AC_MSG_RESULT([could not find any! Using -lX11.]) XLIBSW=-lX11 fi ]) #-------------------------------------------------------------------- # SC_BLOCKING_STYLE # # The statements below check for systems where POSIX-style # non-blocking I/O (O_NONBLOCK) doesn't work or is unimplemented. # On these systems (mostly older ones), use the old BSD-style # FIONBIO approach instead. # # Arguments: # none # # Results: # # Defines some of the following vars: # HAVE_SYS_IOCTL_H # HAVE_SYS_FILIO_H # USE_FIONBIO # O_NONBLOCK # #-------------------------------------------------------------------- AC_DEFUN([SC_BLOCKING_STYLE], [ AC_CHECK_HEADERS(sys/ioctl.h) AC_CHECK_HEADERS(sys/filio.h) SC_CONFIG_SYSTEM AC_MSG_CHECKING([FIONBIO vs. O_NONBLOCK for nonblocking I/O]) case $system in OSF*) AC_DEFINE(USE_FIONBIO, 1, [Should we use FIONBIO?]) AC_MSG_RESULT([FIONBIO]) ;; SunOS-4*) AC_DEFINE(USE_FIONBIO, 1, [Should we use FIONBIO?]) AC_MSG_RESULT([FIONBIO]) ;; *) AC_MSG_RESULT([O_NONBLOCK]) ;; esac ]) #-------------------------------------------------------------------- # SC_TIME_HANLDER # # Checks how the system deals with time.h, what time structures # are used on the system, and what fields the structures have. # # Arguments: # none # # Results: # # Defines some of the following vars: # USE_DELTA_FOR_TZ # HAVE_TM_GMTOFF # HAVE_TM_TZADJ # HAVE_TIMEZONE_VAR # #-------------------------------------------------------------------- AC_DEFUN([SC_TIME_HANDLER], [ AC_CHECK_HEADERS(sys/time.h) AC_HEADER_TIME AC_CHECK_FUNCS(gmtime_r localtime_r mktime) AC_CACHE_CHECK([tm_tzadj in struct tm], tcl_cv_member_tm_tzadj, [ AC_TRY_COMPILE([#include ], [struct tm tm; tm.tm_tzadj;], tcl_cv_member_tm_tzadj=yes, tcl_cv_member_tm_tzadj=no)]) if test $tcl_cv_member_tm_tzadj = yes ; then AC_DEFINE(HAVE_TM_TZADJ, 1, [Should we use the tm_tzadj field of struct tm?]) fi AC_CACHE_CHECK([tm_gmtoff in struct tm], tcl_cv_member_tm_gmtoff, [ AC_TRY_COMPILE([#include ], [struct tm tm; tm.tm_gmtoff;], tcl_cv_member_tm_gmtoff=yes, tcl_cv_member_tm_gmtoff=no)]) if test $tcl_cv_member_tm_gmtoff = yes ; then AC_DEFINE(HAVE_TM_GMTOFF, 1, [Should we use the tm_gmtoff field of struct tm?]) fi # # Its important to include time.h in this check, as some systems # (like convex) have timezone functions, etc. # AC_CACHE_CHECK([long timezone variable], tcl_cv_timezone_long, [ AC_TRY_COMPILE([#include ], [extern long timezone; timezone += 1; exit (0);], tcl_cv_timezone_long=yes, tcl_cv_timezone_long=no)]) if test $tcl_cv_timezone_long = yes ; then AC_DEFINE(HAVE_TIMEZONE_VAR, 1, [Should we use the global timezone variable?]) else # # On some systems (eg IRIX 6.2), timezone is a time_t and not a long. # AC_CACHE_CHECK([time_t timezone variable], tcl_cv_timezone_time, [ AC_TRY_COMPILE([#include ], [extern time_t timezone; timezone += 1; exit (0);], tcl_cv_timezone_time=yes, tcl_cv_timezone_time=no)]) if test $tcl_cv_timezone_time = yes ; then AC_DEFINE(HAVE_TIMEZONE_VAR, 1, [Should we use the global timezone variable?]) fi fi ]) #-------------------------------------------------------------------- # SC_BUGGY_STRTOD # # Under Solaris 2.4, strtod returns the wrong value for the # terminating character under some conditions. Check for this # and if the problem exists use a substitute procedure # "fixstrtod" (provided by Tcl) that corrects the error. # Also, on Compaq's Tru64 Unix 5.0, # strtod(" ") returns 0.0 instead of a failure to convert. # # Arguments: # none # # Results: # # Might defines some of the following vars: # strtod (=fixstrtod) # #-------------------------------------------------------------------- AC_DEFUN([SC_BUGGY_STRTOD], [ AC_CHECK_FUNC(strtod, tcl_strtod=1, tcl_strtod=0) if test "$tcl_strtod" = 1; then AC_CACHE_CHECK([for Solaris2.4/Tru64 strtod bugs], tcl_cv_strtod_buggy,[ AC_TRY_RUN([ extern double strtod(); int main() { char *infString="Inf", *nanString="NaN", *spaceString=" "; char *term; double value; value = strtod(infString, &term); if ((term != infString) && (term[-1] == 0)) { exit(1); } value = strtod(nanString, &term); if ((term != nanString) && (term[-1] == 0)) { exit(1); } value = strtod(spaceString, &term); if (term == (spaceString+1)) { exit(1); } exit(0); }], tcl_cv_strtod_buggy=ok, tcl_cv_strtod_buggy=buggy, tcl_cv_strtod_buggy=buggy)]) if test "$tcl_cv_strtod_buggy" = buggy; then AC_LIBOBJ([fixstrtod]) USE_COMPAT=1 AC_DEFINE(strtod, fixstrtod, [Do we want to use the strtod() in compat?]) fi fi ]) #-------------------------------------------------------------------- # SC_TCL_LINK_LIBS # # Search for the libraries needed to link the Tcl shell. # Things like the math library (-lm) and socket stuff (-lsocket vs. # -lnsl) are dealt with here. # # Arguments: # None. # # Results: # # Might append to the following vars: # LIBS # MATH_LIBS # # Might define the following vars: # HAVE_NET_ERRNO_H # #-------------------------------------------------------------------- AC_DEFUN([SC_TCL_LINK_LIBS], [ #-------------------------------------------------------------------- # On a few very rare systems, all of the libm.a stuff is # already in libc.a. Set compiler flags accordingly. # Also, Linux requires the "ieee" library for math to work # right (and it must appear before "-lm"). #-------------------------------------------------------------------- AC_CHECK_FUNC(sin, MATH_LIBS="", MATH_LIBS="-lm") AC_CHECK_LIB(ieee, main, [MATH_LIBS="-lieee $MATH_LIBS"]) #-------------------------------------------------------------------- # Interactive UNIX requires -linet instead of -lsocket, plus it # needs net/errno.h to define the socket-related error codes. #-------------------------------------------------------------------- AC_CHECK_LIB(inet, main, [LIBS="$LIBS -linet"]) AC_CHECK_HEADER(net/errno.h, [ AC_DEFINE(HAVE_NET_ERRNO_H, 1, [Do we have ?])]) #-------------------------------------------------------------------- # Check for the existence of the -lsocket and -lnsl libraries. # The order here is important, so that they end up in the right # order in the command line generated by make. Here are some # special considerations: # 1. Use "connect" and "accept" to check for -lsocket, and # "gethostbyname" to check for -lnsl. # 2. Use each function name only once: can't redo a check because # autoconf caches the results of the last check and won't redo it. # 3. Use -lnsl and -lsocket only if they supply procedures that # aren't already present in the normal libraries. This is because # IRIX 5.2 has libraries, but they aren't needed and they're # bogus: they goof up name resolution if used. # 4. On some SVR4 systems, can't use -lsocket without -lnsl too. # To get around this problem, check for both libraries together # if -lsocket doesn't work by itself. #-------------------------------------------------------------------- tcl_checkBoth=0 AC_CHECK_FUNC(connect, tcl_checkSocket=0, tcl_checkSocket=1) if test "$tcl_checkSocket" = 1; then AC_CHECK_FUNC(setsockopt, , [AC_CHECK_LIB(socket, setsockopt, LIBS="$LIBS -lsocket", tcl_checkBoth=1)]) fi if test "$tcl_checkBoth" = 1; then tk_oldLibs=$LIBS LIBS="$LIBS -lsocket -lnsl" AC_CHECK_FUNC(accept, tcl_checkNsl=0, [LIBS=$tk_oldLibs]) fi AC_CHECK_FUNC(gethostbyname, , [AC_CHECK_LIB(nsl, gethostbyname, [LIBS="$LIBS -lnsl"])]) ]) #-------------------------------------------------------------------- # SC_TCL_EARLY_FLAGS # # Check for what flags are needed to be passed so the correct OS # features are available. # # Arguments: # None # # Results: # # Might define the following vars: # _ISOC99_SOURCE # _LARGEFILE64_SOURCE # _LARGEFILE_SOURCE64 # #-------------------------------------------------------------------- AC_DEFUN([SC_TCL_EARLY_FLAG],[ AC_CACHE_VAL([tcl_cv_flag_]translit($1,[A-Z],[a-z]), AC_TRY_COMPILE([$2], $3, [tcl_cv_flag_]translit($1,[A-Z],[a-z])=no, AC_TRY_COMPILE([[#define ]$1[ 1 ]$2], $3, [tcl_cv_flag_]translit($1,[A-Z],[a-z])=yes, [tcl_cv_flag_]translit($1,[A-Z],[a-z])=no))) if test ["x${tcl_cv_flag_]translit($1,[A-Z],[a-z])[}" = "xyes"] ; then AC_DEFINE($1, 1, [Add the ]$1[ flag when building]) tcl_flags="$tcl_flags $1" fi ]) AC_DEFUN([SC_TCL_EARLY_FLAGS],[ AC_MSG_CHECKING([for required early compiler flags]) tcl_flags="" SC_TCL_EARLY_FLAG(_ISOC99_SOURCE,[#include ], [char *p = (char *)strtoll; char *q = (char *)strtoull;]) SC_TCL_EARLY_FLAG(_LARGEFILE64_SOURCE,[#include ], [struct stat64 buf; int i = stat64("/", &buf);]) SC_TCL_EARLY_FLAG(_LARGEFILE_SOURCE64,[#include ], [char *p = (char *)open64;]) if test "x${tcl_flags}" = "x" ; then AC_MSG_RESULT([none]) else AC_MSG_RESULT([${tcl_flags}]) fi ]) #-------------------------------------------------------------------- # SC_TCL_64BIT_FLAGS # # Check for what is defined in the way of 64-bit features. # # Arguments: # None # # Results: # # Might define the following vars: # TCL_WIDE_INT_IS_LONG # TCL_WIDE_INT_TYPE # HAVE_STRUCT_DIRENT64 # HAVE_STRUCT_STAT64 # HAVE_TYPE_OFF64_T # #-------------------------------------------------------------------- AC_DEFUN([SC_TCL_64BIT_FLAGS], [ AC_MSG_CHECKING([for 64-bit integer type]) AC_CACHE_VAL(tcl_cv_type_64bit,[ tcl_cv_type_64bit=none # See if the compiler knows natively about __int64 AC_TRY_COMPILE(,[__int64 value = (__int64) 0;], tcl_type_64bit=__int64, tcl_type_64bit="long long") # See if we should use long anyway Note that we substitute in the # type that is our current guess for a 64-bit type inside this check # program, so it should be modified only carefully... AC_TRY_COMPILE(,[switch (0) { case 1: case (sizeof(]${tcl_type_64bit}[)==sizeof(long)): ; }],tcl_cv_type_64bit=${tcl_type_64bit})]) if test "${tcl_cv_type_64bit}" = none ; then AC_DEFINE(TCL_WIDE_INT_IS_LONG, 1, [Are wide integers to be implemented with C 'long's?]) AC_MSG_RESULT([using long]) else AC_DEFINE_UNQUOTED(TCL_WIDE_INT_TYPE,${tcl_cv_type_64bit}, [What type should be used to define wide integers?]) AC_MSG_RESULT([${tcl_cv_type_64bit}]) # Now check for auxiliary declarations AC_CACHE_CHECK([for struct dirent64], tcl_cv_struct_dirent64,[ AC_TRY_COMPILE([#include #include ],[struct dirent64 p;], tcl_cv_struct_dirent64=yes,tcl_cv_struct_dirent64=no)]) if test "x${tcl_cv_struct_dirent64}" = "xyes" ; then AC_DEFINE(HAVE_STRUCT_DIRENT64, 1, [Is 'struct dirent64' in ?]) fi AC_CACHE_CHECK([for struct stat64], tcl_cv_struct_stat64,[ AC_TRY_COMPILE([#include ],[struct stat64 p; ], tcl_cv_struct_stat64=yes,tcl_cv_struct_stat64=no)]) if test "x${tcl_cv_struct_stat64}" = "xyes" ; then AC_DEFINE(HAVE_STRUCT_STAT64, 1, [Is 'struct stat64' in ?]) fi AC_CHECK_FUNCS(open64 lseek64) AC_MSG_CHECKING([for off64_t]) AC_CACHE_VAL(tcl_cv_type_off64_t,[ AC_TRY_COMPILE([#include ],[off64_t offset; ], tcl_cv_type_off64_t=yes,tcl_cv_type_off64_t=no)]) dnl Define HAVE_TYPE_OFF64_T only when the off64_t type and the dnl functions lseek64 and open64 are defined. if test "x${tcl_cv_type_off64_t}" = "xyes" && \ test "x${ac_cv_func_lseek64}" = "xyes" && \ test "x${ac_cv_func_open64}" = "xyes" ; then AC_DEFINE(HAVE_TYPE_OFF64_T, 1, [Is off64_t in ?]) AC_MSG_RESULT([yes]) else AC_MSG_RESULT([no]) fi fi ]) #-------------------------------------------------------------------- # SC_TCL_CFG_ENCODING TIP #59 # # Declare the encoding to use for embedded configuration information. # # Arguments: # None. # # Results: # Might append to the following vars: # DEFS (implicit) # # Will define the following vars: # TCL_CFGVAL_ENCODING # #-------------------------------------------------------------------- AC_DEFUN([SC_TCL_CFG_ENCODING], [ AC_ARG_WITH(encoding, AC_HELP_STRING([--with-encoding], [encoding for configuration values (default: iso8859-1)]), with_tcencoding=${withval}) if test x"${with_tcencoding}" != x ; then AC_DEFINE_UNQUOTED(TCL_CFGVAL_ENCODING,"${with_tcencoding}", [What encoding should be used for embedded configuration info?]) else AC_DEFINE(TCL_CFGVAL_ENCODING,"iso8859-1", [What encoding should be used for embedded configuration info?]) fi ]) #-------------------------------------------------------------------- # SC_TCL_CHECK_BROKEN_FUNC # # Check for broken function. # # Arguments: # funcName - function to test for # advancedTest - the advanced test to run if the function is present # # Results: # Might cause compatability versions of the function to be used. # Might affect the following vars: # USE_COMPAT (implicit) # #-------------------------------------------------------------------- AC_DEFUN([SC_TCL_CHECK_BROKEN_FUNC],[ AC_CHECK_FUNC($1, tcl_ok=1, tcl_ok=0) if test ["$tcl_ok"] = 1; then AC_CACHE_CHECK([proper ]$1[ implementation], [tcl_cv_]$1[_unbroken], AC_TRY_RUN([[int main() {]$2[}]],[tcl_cv_]$1[_unbroken]=ok, [tcl_cv_]$1[_unbroken]=broken,[tcl_cv_]$1[_unbroken]=unknown)) if test ["$tcl_cv_]$1[_unbroken"] = "ok"; then tcl_ok=1 else tcl_ok=0 fi fi if test ["$tcl_ok"] = 0; then AC_LIBOBJ($1) USE_COMPAT=1 fi ]) #-------------------------------------------------------------------- # SC_TCL_GETHOSTBYADDR_R # # Check if we have MT-safe variant of gethostbyaddr(). # # Arguments: # None # # Results: # # Might define the following vars: # HAVE_GETHOSTBYADDR_R # HAVE_GETHOSTBYADDR_R_7 # HAVE_GETHOSTBYADDR_R_8 # #-------------------------------------------------------------------- AC_DEFUN([SC_TCL_GETHOSTBYADDR_R], [AC_CHECK_FUNC(gethostbyaddr_r, [ AC_CACHE_CHECK([for gethostbyaddr_r with 7 args], tcl_cv_api_gethostbyaddr_r_7, [ AC_TRY_COMPILE([ #include ], [ char *addr; int length; int type; struct hostent *result; char buffer[2048]; int buflen = 2048; int h_errnop; (void) gethostbyaddr_r(addr, length, type, result, buffer, buflen, &h_errnop); ], tcl_cv_api_gethostbyaddr_r_7=yes, tcl_cv_api_gethostbyaddr_r_7=no)]) tcl_ok=$tcl_cv_api_gethostbyaddr_r_7 if test "$tcl_ok" = yes; then AC_DEFINE(HAVE_GETHOSTBYADDR_R_7, 1, [Define to 1 if gethostbyaddr_r takes 7 args.]) else AC_CACHE_CHECK([for gethostbyaddr_r with 8 args], tcl_cv_api_gethostbyaddr_r_8, [ AC_TRY_COMPILE([ #include ], [ char *addr; int length; int type; struct hostent *result, *resultp; char buffer[2048]; int buflen = 2048; int h_errnop; (void) gethostbyaddr_r(addr, length, type, result, buffer, buflen, &resultp, &h_errnop); ], tcl_cv_api_gethostbyaddr_r_8=yes, tcl_cv_api_gethostbyaddr_r_8=no)]) tcl_ok=$tcl_cv_api_gethostbyaddr_r_8 if test "$tcl_ok" = yes; then AC_DEFINE(HAVE_GETHOSTBYADDR_R_8, 1, [Define to 1 if gethostbyaddr_r takes 8 args.]) fi fi if test "$tcl_ok" = yes; then AC_DEFINE(HAVE_GETHOSTBYADDR_R, 1, [Define to 1 if gethostbyaddr_r is available.]) fi ])]) #-------------------------------------------------------------------- # SC_TCL_GETHOSTBYNAME_R # # Check to see what variant of gethostbyname_r() we have. # Based on David Arnold's example from the comp.programming.threads # FAQ Q213 # # Arguments: # None # # Results: # # Might define the following vars: # HAVE_GETHOSTBYADDR_R # HAVE_GETHOSTBYADDR_R_3 # HAVE_GETHOSTBYADDR_R_5 # HAVE_GETHOSTBYADDR_R_6 # #-------------------------------------------------------------------- AC_DEFUN([SC_TCL_GETHOSTBYNAME_R], [AC_CHECK_FUNC(gethostbyname_r, [ AC_CACHE_CHECK([for gethostbyname_r with 6 args], tcl_cv_api_gethostbyname_r_6, [ AC_TRY_COMPILE([ #include ], [ char *name; struct hostent *he, *res; char buffer[2048]; int buflen = 2048; int h_errnop; (void) gethostbyname_r(name, he, buffer, buflen, &res, &h_errnop); ], tcl_cv_api_gethostbyname_r_6=yes, tcl_cv_api_gethostbyname_r_6=no)]) tcl_ok=$tcl_cv_api_gethostbyname_r_6 if test "$tcl_ok" = yes; then AC_DEFINE(HAVE_GETHOSTBYNAME_R_6, 1, [Define to 1 if gethostbyname_r takes 6 args.]) else AC_CACHE_CHECK([for gethostbyname_r with 5 args], tcl_cv_api_gethostbyname_r_5, [ AC_TRY_COMPILE([ #include ], [ char *name; struct hostent *he; char buffer[2048]; int buflen = 2048; int h_errnop; (void) gethostbyname_r(name, he, buffer, buflen, &h_errnop); ], tcl_cv_api_gethostbyname_r_5=yes, tcl_cv_api_gethostbyname_r_5=no)]) tcl_ok=$tcl_cv_api_gethostbyname_r_5 if test "$tcl_ok" = yes; then AC_DEFINE(HAVE_GETHOSTBYNAME_R_5, 1, [Define to 1 if gethostbyname_r takes 5 args.]) else AC_CACHE_CHECK([for gethostbyname_r with 3 args], tcl_cv_api_gethostbyname_r_3, [ AC_TRY_COMPILE([ #include ], [ char *name; struct hostent *he; struct hostent_data data; (void) gethostbyname_r(name, he, &data); ], tcl_cv_api_gethostbyname_r_3=yes, tcl_cv_api_gethostbyname_r_3=no)]) tcl_ok=$tcl_cv_api_gethostbyname_r_3 if test "$tcl_ok" = yes; then AC_DEFINE(HAVE_GETHOSTBYNAME_R_3, 1, [Define to 1 if gethostbyname_r takes 3 args.]) fi fi fi if test "$tcl_ok" = yes; then AC_DEFINE(HAVE_GETHOSTBYNAME_R, 1, [Define to 1 if gethostbyname_r is available.]) fi ])]) #-------------------------------------------------------------------- # SC_TCL_GETPWUID_R # # Check if we have MT-safe variant of getpwuid() and if yes, # which one exactly. # # Arguments: # None # # Results: # # Might define the following vars: # HAVE_GETPWUID_R # HAVE_GETPWUID_R_4 # HAVE_GETPWUID_R_5 # #-------------------------------------------------------------------- AC_DEFUN([SC_TCL_GETPWUID_R], [AC_CHECK_FUNC(getpwuid_r, [ AC_CACHE_CHECK([for getpwuid_r with 5 args], tcl_cv_api_getpwuid_r_5, [ AC_TRY_COMPILE([ #include #include ], [ uid_t uid; struct passwd pw, *pwp; char buf[512]; int buflen = 512; (void) getpwuid_r(uid, &pw, buf, buflen, &pwp); ], tcl_cv_api_getpwuid_r_5=yes, tcl_cv_api_getpwuid_r_5=no)]) tcl_ok=$tcl_cv_api_getpwuid_r_5 if test "$tcl_ok" = yes; then AC_DEFINE(HAVE_GETPWUID_R_5, 1, [Define to 1 if getpwuid_r takes 5 args.]) else AC_CACHE_CHECK([for getpwuid_r with 4 args], tcl_cv_api_getpwuid_r_4, [ AC_TRY_COMPILE([ #include #include ], [ uid_t uid; struct passwd pw; char buf[512]; int buflen = 512; (void)getpwnam_r(uid, &pw, buf, buflen); ], tcl_cv_api_getpwuid_r_4=yes, tcl_cv_api_getpwuid_r_4=no)]) tcl_ok=$tcl_cv_api_getpwuid_r_4 if test "$tcl_ok" = yes; then AC_DEFINE(HAVE_GETPWUID_R_4, 1, [Define to 1 if getpwuid_r takes 4 args.]) fi fi if test "$tcl_ok" = yes; then AC_DEFINE(HAVE_GETPWUID_R, 1, [Define to 1 if getpwuid_r is available.]) fi ])]) #-------------------------------------------------------------------- # SC_TCL_GETPWNAM_R # # Check if we have MT-safe variant of getpwnam() and if yes, # which one exactly. # # Arguments: # None # # Results: # # Might define the following vars: # HAVE_GETPWNAM_R # HAVE_GETPWNAM_R_4 # HAVE_GETPWNAM_R_5 # #-------------------------------------------------------------------- AC_DEFUN([SC_TCL_GETPWNAM_R], [AC_CHECK_FUNC(getpwnam_r, [ AC_CACHE_CHECK([for getpwnam_r with 5 args], tcl_cv_api_getpwnam_r_5, [ AC_TRY_COMPILE([ #include #include ], [ char *name; struct passwd pw, *pwp; char buf[512]; int buflen = 512; (void) getpwnam_r(name, &pw, buf, buflen, &pwp); ], tcl_cv_api_getpwnam_r_5=yes, tcl_cv_api_getpwnam_r_5=no)]) tcl_ok=$tcl_cv_api_getpwnam_r_5 if test "$tcl_ok" = yes; then AC_DEFINE(HAVE_GETPWNAM_R_5, 1, [Define to 1 if getpwnam_r takes 5 args.]) else AC_CACHE_CHECK([for getpwnam_r with 4 args], tcl_cv_api_getpwnam_r_4, [ AC_TRY_COMPILE([ #include #include ], [ char *name; struct passwd pw; char buf[512]; int buflen = 512; (void)getpwnam_r(name, &pw, buf, buflen); ], tcl_cv_api_getpwnam_r_4=yes, tcl_cv_api_getpwnam_r_4=no)]) tcl_ok=$tcl_cv_api_getpwnam_r_4 if test "$tcl_ok" = yes; then AC_DEFINE(HAVE_GETPWNAM_R_4, 1, [Define to 1 if getpwnam_r takes 4 args.]) fi fi if test "$tcl_ok" = yes; then AC_DEFINE(HAVE_GETPWNAM_R, 1, [Define to 1 if getpwnam_r is available.]) fi ])]) #-------------------------------------------------------------------- # SC_TCL_GETGRGID_R # # Check if we have MT-safe variant of getgrgid() and if yes, # which one exactly. # # Arguments: # None # # Results: # # Might define the following vars: # HAVE_GETGRGID_R # HAVE_GETGRGID_R_4 # HAVE_GETGRGID_R_5 # #-------------------------------------------------------------------- AC_DEFUN([SC_TCL_GETGRGID_R], [AC_CHECK_FUNC(getgrgid_r, [ AC_CACHE_CHECK([for getgrgid_r with 5 args], tcl_cv_api_getgrgid_r_5, [ AC_TRY_COMPILE([ #include #include ], [ gid_t gid; struct group gr, *grp; char buf[512]; int buflen = 512; (void) getgrgid_r(gid, &gr, buf, buflen, &grp); ], tcl_cv_api_getgrgid_r_5=yes, tcl_cv_api_getgrgid_r_5=no)]) tcl_ok=$tcl_cv_api_getgrgid_r_5 if test "$tcl_ok" = yes; then AC_DEFINE(HAVE_GETGRGID_R_5, 1, [Define to 1 if getgrgid_r takes 5 args.]) else AC_CACHE_CHECK([for getgrgid_r with 4 args], tcl_cv_api_getgrgid_r_4, [ AC_TRY_COMPILE([ #include #include ], [ gid_t gid; struct group gr; char buf[512]; int buflen = 512; (void)getgrgid_r(gid, &gr, buf, buflen); ], tcl_cv_api_getgrgid_r_4=yes, tcl_cv_api_getgrgid_r_4=no)]) tcl_ok=$tcl_cv_api_getgrgid_r_4 if test "$tcl_ok" = yes; then AC_DEFINE(HAVE_GETGRGID_R_4, 1, [Define to 1 if getgrgid_r takes 4 args.]) fi fi if test "$tcl_ok" = yes; then AC_DEFINE(HAVE_GETGRGID_R, 1, [Define to 1 if getgrgid_r is available.]) fi ])]) #-------------------------------------------------------------------- # SC_TCL_GETGRNAM_R # # Check if we have MT-safe variant of getgrnam() and if yes, # which one exactly. # # Arguments: # None # # Results: # # Might define the following vars: # HAVE_GETGRNAM_R # HAVE_GETGRNAM_R_4 # HAVE_GETGRNAM_R_5 # #-------------------------------------------------------------------- AC_DEFUN([SC_TCL_GETGRNAM_R], [AC_CHECK_FUNC(getgrnam_r, [ AC_CACHE_CHECK([for getgrnam_r with 5 args], tcl_cv_api_getgrnam_r_5, [ AC_TRY_COMPILE([ #include #include ], [ char *name; struct group gr, *grp; char buf[512]; int buflen = 512; (void) getgrnam_r(name, &gr, buf, buflen, &grp); ], tcl_cv_api_getgrnam_r_5=yes, tcl_cv_api_getgrnam_r_5=no)]) tcl_ok=$tcl_cv_api_getgrnam_r_5 if test "$tcl_ok" = yes; then AC_DEFINE(HAVE_GETGRNAM_R_5, 1, [Define to 1 if getgrnam_r takes 5 args.]) else AC_CACHE_CHECK([for getgrnam_r with 4 args], tcl_cv_api_getgrnam_r_4, [ AC_TRY_COMPILE([ #include #include ], [ char *name; struct group gr; char buf[512]; int buflen = 512; (void)getgrnam_r(name, &gr, buf, buflen); ], tcl_cv_api_getgrnam_r_4=yes, tcl_cv_api_getgrnam_r_4=no)]) tcl_ok=$tcl_cv_api_getgrnam_r_4 if test "$tcl_ok" = yes; then AC_DEFINE(HAVE_GETGRNAM_R_4, 1, [Define to 1 if getgrnam_r takes 4 args.]) fi fi if test "$tcl_ok" = yes; then AC_DEFINE(HAVE_GETGRNAM_R, 1, [Define to 1 if getgrnam_r is available.]) fi ])]) AC_DEFUN([SC_TCL_IPV6],[ NEED_FAKE_RFC2553=0 AC_CHECK_FUNCS(getnameinfo getaddrinfo freeaddrinfo gai_strerror,,[NEED_FAKE_RFC2553=1]) AC_CHECK_TYPES([ struct addrinfo, struct in6_addr, struct sockaddr_in6, struct sockaddr_storage],,[NEED_FAKE_RFC2553=1],[[ #include #include #include #include ]]) if test "x$NEED_FAKE_RFC2553" = "x1"; then AC_DEFINE([NEED_FAKE_RFC2553], 1, [Use compat implementation of getaddrinfo() and friends]) AC_LIBOBJ([fake-rfc2553]) AC_CHECK_FUNC(strlcpy) fi ]) # Local Variables: # mode: autoconf # End: tk8.6.5/unix/tkConfig.sh.in0000644003604700454610000000634112665114121014161 0ustar dgp771div# tkConfig.sh -- # # This shell script (for sh) is generated automatically by Tk's # configure script. It will create shell variables for most of # the configuration options discovered by the configure script. # This script is intended to be included by the configure scripts # for Tk extensions so that they don't have to figure this all # out for themselves. This file does not duplicate information # already provided by tclConfig.sh, so you may need to use that # file in addition to this one. # # The information in this file is specific to a single platform. # Tk's version number. TK_VERSION='@TK_VERSION@' TK_MAJOR_VERSION='@TK_MAJOR_VERSION@' TK_MINOR_VERSION='@TK_MINOR_VERSION@' TK_PATCH_LEVEL='@TK_PATCH_LEVEL@' # -D flags for use with the C compiler. TK_DEFS='@DEFS@' # Flag, 1: we built a shared lib, 0 we didn't TK_SHARED_BUILD=@TK_SHARED_BUILD@ # TK_DBGX used to be used to distinguish debug vs. non-debug builds. # This was a righteous pain so the core doesn't do that any more. TK_DBGX= # The name of the Tk library (may be either a .a file or a shared library): TK_LIB_FILE='@TK_LIB_FILE@' # Additional libraries to use when linking Tk. TK_LIBS='@XLIBSW@ @XFT_LIBS@ @LIBS@ @TCL_LIBS@' # Top-level directory in which Tk's platform-independent files are # installed. TK_PREFIX='@prefix@' # Top-level directory in which Tk's platform-specific files (e.g. # executables) are installed. TK_EXEC_PREFIX='@exec_prefix@' # -I switch(es) to use to make all of the X11 include files accessible: TK_XINCLUDES='@XINCLUDES@' # Linker switch(es) to use to link with the X11 library archive. TK_XLIBSW='@XLIBSW@' # -l flag to pass to the linker to pick up the Tk library TK_LIB_FLAG='@TK_LIB_FLAG@' # String to pass to linker to pick up the Tk library from its # build directory. TK_BUILD_LIB_SPEC='@TK_BUILD_LIB_SPEC@' # String to pass to linker to pick up the Tk library from its # installed directory. TK_LIB_SPEC='@TK_LIB_SPEC@' # String to pass to the compiler so that an extension can # find installed Tk headers. TK_INCLUDE_SPEC='@TK_INCLUDE_SPEC@' # Location of the top-level source directory from which Tk was built. # This is the directory that contains a README file as well as # subdirectories such as generic, unix, etc. If Tk was compiled in a # different place than the directory containing the source files, this # points to the location of the sources, not the location where Tk was # compiled. TK_SRC_DIR='@TK_SRC_DIR@' # Needed if you want to make a 'fat' shared library library # containing tk objects or link a different wish. TK_CC_SEARCH_FLAGS='@CC_SEARCH_FLAGS@' TK_LD_SEARCH_FLAGS='@LD_SEARCH_FLAGS@' # The name of the Tk stub library (.a): TK_STUB_LIB_FILE='@TK_STUB_LIB_FILE@' # -l flag to pass to the linker to pick up the Tk stub library TK_STUB_LIB_FLAG='@TK_STUB_LIB_FLAG@' # String to pass to linker to pick up the Tk stub library from its # build directory. TK_BUILD_STUB_LIB_SPEC='@TK_BUILD_STUB_LIB_SPEC@' # String to pass to linker to pick up the Tk stub library from its # installed directory. TK_STUB_LIB_SPEC='@TK_STUB_LIB_SPEC@' # Path to the Tk stub library in the build directory. TK_BUILD_STUB_LIB_PATH='@TK_BUILD_STUB_LIB_PATH@' # Path to the Tk stub library in the install directory. TK_STUB_LIB_PATH='@TK_STUB_LIB_PATH@' tk8.6.5/unix/tkUnixWm.c0000644003604700454610000065565112663615423013435 0ustar dgp771div/* * tkUnixWm.c -- * * This module takes care of the interactions between a Tk-based * application and the window manager. Among other things, it implements * the "wm" command and passes geometry information to the window * manager. * * Copyright (c) 1991-1994 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tkUnixInt.h" /* * A data structure of the following type holds information for each window * manager protocol (such as WM_DELETE_WINDOW) for which a handler (i.e. a Tcl * command) has been defined for a particular top-level window. */ typedef struct ProtocolHandler { Atom protocol; /* Identifies the protocol. */ struct ProtocolHandler *nextPtr; /* Next in list of protocol handlers for the * same top-level window, or NULL for end of * list. */ Tcl_Interp *interp; /* Interpreter in which to invoke command. */ char command[1]; /* Tcl command to invoke when a client message * for this protocol arrives. The actual size * of the structure varies to accommodate the * needs of the actual command. THIS MUST BE * THE LAST FIELD OF THE STRUCTURE. */ } ProtocolHandler; #define HANDLER_SIZE(cmdLength) \ ((unsigned) ((Tk_Offset(ProtocolHandler, command) + 1) + cmdLength)) /* * Data for [wm attributes] command: */ typedef struct { double alpha; /* Transparency; 0.0=transparent, 1.0=opaque */ int topmost; /* Flag: true=>stay-on-top */ int zoomed; /* Flag: true=>maximized */ int fullscreen; /* Flag: true=>fullscreen */ } WmAttributes; typedef enum { WMATT_ALPHA, WMATT_TOPMOST, WMATT_ZOOMED, WMATT_FULLSCREEN, WMATT_TYPE, _WMATT_LAST_ATTRIBUTE } WmAttribute; static const char *const WmAttributeNames[] = { "-alpha", "-topmost", "-zoomed", "-fullscreen", "-type", NULL }; /* * A data structure of the following type holds window-manager-related * information for each top-level window in an application. */ typedef struct TkWmInfo { TkWindow *winPtr; /* Pointer to main Tk information for this * window. */ Window reparent; /* If the window has been reparented, this * gives the ID of the ancestor of the window * that is a child of the root window (may not * be window's immediate parent). If the * window isn't reparented, this has the value * None. */ char *title; /* Title to display in window caption. If * NULL, use name of widget. Malloced. */ char *iconName; /* Name to display in icon. Malloced. */ XWMHints hints; /* Various pieces of information for window * manager. */ char *leaderName; /* Path name of leader of window group * (corresponds to hints.window_group). * Malloc-ed. Note: this field doesn't get * updated if leader is destroyed. */ TkWindow *masterPtr; /* Master window for TRANSIENT_FOR property, * or NULL. */ Tk_Window icon; /* Window to use as icon for this window, or * NULL. */ Tk_Window iconFor; /* Window for which this window is icon, or * NULL if this isn't an icon for anyone. */ int withdrawn; /* Non-zero means window has been withdrawn. */ /* * In order to support menubars transparently under X, each toplevel * window is encased in an additional window, called the wrapper, that * holds the toplevel and the menubar, if any. The information below is * used to keep track of the wrapper and the menubar. */ TkWindow *wrapperPtr; /* Pointer to information about the wrapper. * This is the "real" toplevel window as seen * by the window manager. Although this is an * official Tk window, it doesn't appear in * the application's window hierarchy. NULL * means that the wrapper hasn't been created * yet. */ Tk_Window menubar; /* Pointer to information about the menubar, * or NULL if there is no menubar for this * toplevel. */ int menuHeight; /* Amount of vertical space needed for * menubar, measured in pixels. If menubar is * non-NULL, this is >= 1 (X servers don't * like dimensions of 0). */ /* * Information used to construct an XSizeHints structure for the window * manager: */ int sizeHintsFlags; /* Flags word for XSizeHints structure. If the * PBaseSize flag is set then the window is * gridded; otherwise it isn't gridded. */ int minWidth, minHeight; /* Minimum dimensions of window, in pixels or * grid units. */ int maxWidth, maxHeight; /* Maximum dimensions of window, in pixels or * grid units. 0 to default.*/ Tk_Window gridWin; /* Identifies the window that controls * gridding for this top-level, or NULL if the * top-level isn't currently gridded. */ int widthInc, heightInc; /* Increments for size changes (# pixels per * step). */ struct { int x; /* numerator */ int y; /* denominator */ } minAspect, maxAspect; /* Min/max aspect ratios for window. */ int reqGridWidth, reqGridHeight; /* The dimensions of the window (in grid * units) requested through the geometry * manager. */ int gravity; /* Desired window gravity. */ /* * Information used to manage the size and location of a window. */ int width, height; /* Desired dimensions of window, specified in * pixels or grid units. These values are set * by the "wm geometry" command and by * ConfigureNotify events (for when wm resizes * window). -1 means user hasn't requested * dimensions. */ int x, y; /* Desired X and Y coordinates for window. * These values are set by "wm geometry", plus * by ConfigureNotify events (when wm moves * window). These numbers are different than * the numbers stored in winPtr->changes * because (a) they could be measured from the * right or bottom edge of the screen (see * WM_NEGATIVE_X and WM_NEGATIVE_Y flags) and * (b) if the window has been reparented then * they refer to the parent rather than the * window itself. */ int parentWidth, parentHeight; /* Width and height of reparent, in pixels * *including border*. If window hasn't been * reparented then these will be the outer * dimensions of the window, including * border. */ int xInParent, yInParent; /* Offset of wrapperPtr within reparent, * measured in pixels from upper-left outer * corner of reparent's border to upper-left * outer corner of wrapperPtr's border. If not * reparented then these are zero. */ int configWidth, configHeight; /* Dimensions passed to last request that we * issued to change geometry of the wrapper. * Used to eliminate redundant resize * operations. */ /* * Information about the virtual root window for this top-level, if there * is one. */ Window vRoot; /* Virtual root window for this top-level, or * None if there is no virtual root window * (i.e. just use the screen's root). */ int vRootX, vRootY; /* Position of the virtual root inside the * root window. If the WM_VROOT_OFFSET_STALE * flag is set then this information may be * incorrect and needs to be refreshed from * the X server. If vRoot is None then these * values are both 0. */ int vRootWidth, vRootHeight;/* Dimensions of the virtual root window. If * vRoot is None, gives the dimensions of the * containing screen. This information is * never stale, even though vRootX and vRootY * can be. */ /* * Miscellaneous information. */ WmAttributes attributes; /* Current state of [wm attributes] */ WmAttributes reqState; /* Requested state of [wm attributes] */ ProtocolHandler *protPtr; /* First in list of protocol handlers for this * window (NULL means none). */ int cmdArgc; /* Number of elements in cmdArgv below. */ const char **cmdArgv; /* Array of strings to store in the WM_COMMAND * property. NULL means nothing available. */ char *clientMachine; /* String to store in WM_CLIENT_MACHINE * property, or NULL. */ int flags; /* Miscellaneous flags, defined below. */ int numTransients; /* number of transients on this window */ int iconDataSize; /* size of iconphoto image data */ unsigned char *iconDataPtr; /* iconphoto image data, if set */ struct TkWmInfo *nextPtr; /* Next in list of all top-level windows. */ } WmInfo; /* * Flag values for WmInfo structures: * * WM_NEVER_MAPPED - non-zero means window has never been mapped; * need to update all info when window is first * mapped. * WM_UPDATE_PENDING - non-zero means a call to UpdateGeometryInfo * has already been scheduled for this window; * no need to schedule another one. * WM_NEGATIVE_X - non-zero means x-coordinate is measured in * pixels from right edge of screen, rather than * from left edge. * WM_NEGATIVE_Y - non-zero means y-coordinate is measured in * pixels up from bottom of screen, rather than * down from top. * WM_UPDATE_SIZE_HINTS - non-zero means that new size hints need to be * propagated to window manager. * WM_SYNC_PENDING - set to non-zero while waiting for the window * manager to respond to some state change. * WM_VROOT_OFFSET_STALE - non-zero means that (x,y) offset information * about the virtual root window is stale and * needs to be fetched fresh from the X server. * WM_ABOUT_TO_MAP - non-zero means that the window is about to be * mapped by TkWmMapWindow. This is used by * UpdateGeometryInfo to modify its behavior. * WM_MOVE_PENDING - non-zero means the application has requested a * new position for the window, but it hasn't * been reflected through the window manager yet. * WM_COLORMAPS_EXPLICIT - non-zero means the colormap windows were set * explicitly via "wm colormapwindows". * WM_ADDED_TOPLEVEL_COLORMAP - non-zero means that when "wm colormapwindows" * was called the top-level itself wasn't * specified, so we added it implicitly at the * end of the list. * WM_WIDTH_NOT_RESIZABLE - non-zero means that we're not supposed to * allow the user to change the width of the * window (controlled by "wm resizable" command). * WM_HEIGHT_NOT_RESIZABLE - non-zero means that we're not supposed to * allow the user to change the height of the * window (controlled by "wm resizable" command). * WM_WITHDRAWN - non-zero means that this window has explicitly * been withdrawn. If it's a transient, it should * not mirror state changes in the master. */ #define WM_NEVER_MAPPED 1 #define WM_UPDATE_PENDING 2 #define WM_NEGATIVE_X 4 #define WM_NEGATIVE_Y 8 #define WM_UPDATE_SIZE_HINTS 0x10 #define WM_SYNC_PENDING 0x20 #define WM_VROOT_OFFSET_STALE 0x40 #define WM_ABOUT_TO_MAP 0x100 #define WM_MOVE_PENDING 0x200 #define WM_COLORMAPS_EXPLICIT 0x400 #define WM_ADDED_TOPLEVEL_COLORMAP 0x800 #define WM_WIDTH_NOT_RESIZABLE 0x1000 #define WM_HEIGHT_NOT_RESIZABLE 0x2000 #define WM_WITHDRAWN 0x4000 /* * Wrapper for XGetWindowProperty and XChangeProperty to make them a *bit* * less verbose. */ #define GetWindowProperty(wrapperPtr, atom, length, type, typePtr, formatPtr, numItemsPtr, bytesAfterPtr, itemsPtr) \ (XGetWindowProperty((wrapperPtr)->display, (wrapperPtr)->window, \ (atom), 0, (long) (length), False, (type), \ (typePtr), (formatPtr), (numItemsPtr), (bytesAfterPtr), \ (unsigned char **) (itemsPtr)) == Success) #define SetWindowProperty(wrapperPtr, atomName, type, width, data, length) \ XChangeProperty((wrapperPtr)->display, (wrapperPtr)->window, \ Tk_InternAtom((Tk_Window) wrapperPtr, (atomName)), \ (type), (width), PropModeReplace, (unsigned char *) (data), \ (int) (length)) /* * This module keeps a list of all top-level windows, primarily to simplify * the job of Tk_CoordsToWindow. The list is called firstWmPtr and is stored * in the TkDisplay structure. */ /* * The following structures are the official type records for geometry * management of top-level and menubar windows. */ static void TopLevelReqProc(ClientData dummy, Tk_Window tkwin); static void RemapWindows(TkWindow *winPtr, TkWindow *parentPtr); static void MenubarReqProc(ClientData clientData, Tk_Window tkwin); static const Tk_GeomMgr wmMgrType = { "wm", /* name */ TopLevelReqProc, /* requestProc */ NULL, /* lostSlaveProc */ }; static const Tk_GeomMgr menubarMgrType = { "menubar", /* name */ MenubarReqProc, /* requestProc */ NULL, /* lostSlaveProc */ }; /* * Structures of the following type are used for communication between * WaitForEvent, WaitRestrictProc, and WaitTimeoutProc. */ typedef struct WaitRestrictInfo { Display *display; /* Window belongs to this display. */ WmInfo *wmInfoPtr; int type; /* We only care about this type of event. */ XEvent *eventPtr; /* Where to store the event when it's found. */ int foundEvent; /* Non-zero means that an event of the desired * type has been found. */ } WaitRestrictInfo; /* * Forward declarations for functions defined in this file: */ static int ComputeReparentGeometry(WmInfo *wmPtr); static void ConfigureEvent(WmInfo *wmPtr, XConfigureEvent *eventPtr); static void CreateWrapper(WmInfo *wmPtr); static void GetMaxSize(WmInfo *wmPtr, int *maxWidthPtr, int *maxHeightPtr); static void MenubarDestroyProc(ClientData clientData, XEvent *eventPtr); static int ParseGeometry(Tcl_Interp *interp, const char *string, TkWindow *winPtr); static void ReparentEvent(WmInfo *wmPtr, XReparentEvent *eventPtr); static void PropertyEvent(WmInfo *wmPtr, XPropertyEvent *eventPtr); static void TkWmStackorderToplevelWrapperMap(TkWindow *winPtr, Display *display, Tcl_HashTable *reparentTable); static void TopLevelReqProc(ClientData dummy, Tk_Window tkwin); static void RemapWindows(TkWindow *winPtr, TkWindow *parentPtr); static void UpdateCommand(TkWindow *winPtr); static void UpdateGeometryInfo(ClientData clientData); static void UpdateHints(TkWindow *winPtr); static void UpdateSizeHints(TkWindow *winPtr, int newWidth, int newHeight); static void UpdateTitle(TkWindow *winPtr); static void UpdatePhotoIcon(TkWindow *winPtr); static void UpdateVRootGeometry(WmInfo *wmPtr); static void UpdateWmProtocols(WmInfo *wmPtr); static int SetNetWmType(TkWindow *winPtr, Tcl_Obj *typePtr); static Tcl_Obj * GetNetWmType(TkWindow *winPtr); static void SetNetWmState(TkWindow*, const char *atomName, int on); static void CheckNetWmState(WmInfo *, Atom *atoms, int numAtoms); static void UpdateNetWmState(WmInfo *); static void WaitForConfigureNotify(TkWindow *winPtr, unsigned long serial); static int WaitForEvent(Display *display, WmInfo *wmInfoPtr, int type, XEvent *eventPtr); static void WaitForMapNotify(TkWindow *winPtr, int mapped); static Tk_RestrictProc WaitRestrictProc; static void WrapperEventProc(ClientData clientData, XEvent *eventPtr); static void WmWaitMapProc(ClientData clientData, XEvent *eventPtr); static int WmAspectCmd(Tk_Window tkwin, TkWindow *winPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int WmAttributesCmd(Tk_Window tkwin, TkWindow *winPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int WmClientCmd(Tk_Window tkwin, TkWindow *winPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int WmColormapwindowsCmd(Tk_Window tkwin, TkWindow *winPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int WmCommandCmd(Tk_Window tkwin, TkWindow *winPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int WmDeiconifyCmd(Tk_Window tkwin, TkWindow *winPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int WmFocusmodelCmd(Tk_Window tkwin, TkWindow *winPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int WmForgetCmd(Tk_Window tkwin, TkWindow *winPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int WmFrameCmd(Tk_Window tkwin, TkWindow *winPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int WmGeometryCmd(Tk_Window tkwin, TkWindow *winPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int WmGridCmd(Tk_Window tkwin, TkWindow *winPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int WmGroupCmd(Tk_Window tkwin, TkWindow *winPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int WmIconbitmapCmd(Tk_Window tkwin, TkWindow *winPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int WmIconifyCmd(Tk_Window tkwin, TkWindow *winPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int WmIconmaskCmd(Tk_Window tkwin, TkWindow *winPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int WmIconnameCmd(Tk_Window tkwin, TkWindow *winPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int WmIconphotoCmd(Tk_Window tkwin, TkWindow *winPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int WmIconpositionCmd(Tk_Window tkwin, TkWindow *winPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int WmIconwindowCmd(Tk_Window tkwin, TkWindow *winPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int WmManageCmd(Tk_Window tkwin, TkWindow *winPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int WmMaxsizeCmd(Tk_Window tkwin, TkWindow *winPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int WmMinsizeCmd(Tk_Window tkwin, TkWindow *winPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int WmOverrideredirectCmd(Tk_Window tkwin, TkWindow *winPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int WmPositionfromCmd(Tk_Window tkwin, TkWindow *winPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int WmProtocolCmd(Tk_Window tkwin, TkWindow *winPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int WmResizableCmd(Tk_Window tkwin, TkWindow *winPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int WmSizefromCmd(Tk_Window tkwin, TkWindow *winPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int WmStackorderCmd(Tk_Window tkwin, TkWindow *winPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int WmStateCmd(Tk_Window tkwin, TkWindow *winPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int WmTitleCmd(Tk_Window tkwin, TkWindow *winPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int WmTransientCmd(Tk_Window tkwin, TkWindow *winPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int WmWithdrawCmd(Tk_Window tkwin, TkWindow *winPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static void WmUpdateGeom(WmInfo *wmPtr, TkWindow *winPtr); /* *-------------------------------------------------------------- * * TkWmCleanup -- * * This function is invoked to cleanup remaining wm resources associated * with a display. * * Results: * None. * * Side effects: * All WmInfo structure resources are freed and invalidated. * *-------------------------------------------------------------- */ void TkWmCleanup( TkDisplay *dispPtr) { WmInfo *wmPtr, *nextPtr; for (wmPtr = dispPtr->firstWmPtr; wmPtr != NULL; wmPtr = nextPtr) { /* * We can't assume we have access to winPtr's anymore, so some cleanup * requiring winPtr data is avoided. */ nextPtr = wmPtr->nextPtr; if (wmPtr->title != NULL) { ckfree(wmPtr->title); } if (wmPtr->iconName != NULL) { ckfree(wmPtr->iconName); } if (wmPtr->iconDataPtr != NULL) { ckfree(wmPtr->iconDataPtr); } if (wmPtr->leaderName != NULL) { ckfree(wmPtr->leaderName); } if (wmPtr->menubar != NULL) { Tk_DestroyWindow(wmPtr->menubar); } if (wmPtr->wrapperPtr != NULL) { Tk_DestroyWindow((Tk_Window) wmPtr->wrapperPtr); } while (wmPtr->protPtr != NULL) { ProtocolHandler *protPtr = wmPtr->protPtr; wmPtr->protPtr = protPtr->nextPtr; Tcl_EventuallyFree(protPtr, TCL_DYNAMIC); } if (wmPtr->cmdArgv != NULL) { ckfree(wmPtr->cmdArgv); } if (wmPtr->clientMachine != NULL) { ckfree(wmPtr->clientMachine); } ckfree(wmPtr); } if (dispPtr->iconDataPtr != NULL) { ckfree(dispPtr->iconDataPtr); dispPtr->iconDataPtr = NULL; } } /* *-------------------------------------------------------------- * * TkWmNewWindow -- * * This function is invoked whenever a new top-level window is created. * Its job is to initialize the WmInfo structure for the window. * * Results: * None. * * Side effects: * A WmInfo structure gets allocated and initialized. * *-------------------------------------------------------------- */ void TkWmNewWindow( TkWindow *winPtr) /* Newly-created top-level window. */ { register WmInfo *wmPtr; TkDisplay *dispPtr = winPtr->dispPtr; wmPtr = ckalloc(sizeof(WmInfo)); memset(wmPtr, 0, sizeof(WmInfo)); wmPtr->winPtr = winPtr; wmPtr->reparent = None; wmPtr->masterPtr = NULL; wmPtr->numTransients = 0; wmPtr->hints.flags = InputHint | StateHint; wmPtr->hints.input = True; wmPtr->hints.initial_state = NormalState; wmPtr->hints.icon_pixmap = None; wmPtr->hints.icon_window = None; wmPtr->hints.icon_x = wmPtr->hints.icon_y = 0; wmPtr->hints.icon_mask = None; wmPtr->hints.window_group = None; /* * Initialize attributes. */ wmPtr->attributes.alpha = 1.0; wmPtr->attributes.topmost = 0; wmPtr->attributes.zoomed = 0; wmPtr->attributes.fullscreen = 0; wmPtr->reqState = wmPtr->attributes; /* * Default the maximum dimensions to the size of the display, minus a * guess about how space is needed for window manager decorations. */ wmPtr->gridWin = NULL; wmPtr->minWidth = wmPtr->minHeight = 1; wmPtr->maxWidth = wmPtr->maxHeight = 0; wmPtr->widthInc = wmPtr->heightInc = 1; wmPtr->minAspect.x = wmPtr->minAspect.y = 1; wmPtr->maxAspect.x = wmPtr->maxAspect.y = 1; wmPtr->reqGridWidth = wmPtr->reqGridHeight = -1; wmPtr->gravity = NorthWestGravity; wmPtr->width = -1; wmPtr->height = -1; wmPtr->x = winPtr->changes.x; wmPtr->y = winPtr->changes.y; wmPtr->parentWidth = winPtr->changes.width + 2*winPtr->changes.border_width; wmPtr->parentHeight = winPtr->changes.height + 2*winPtr->changes.border_width; wmPtr->configWidth = -1; wmPtr->configHeight = -1; wmPtr->vRoot = None; wmPtr->flags = WM_NEVER_MAPPED; wmPtr->nextPtr = (WmInfo *) dispPtr->firstWmPtr; dispPtr->firstWmPtr = wmPtr; winPtr->wmInfoPtr = wmPtr; UpdateVRootGeometry(wmPtr); /* * Arrange for geometry requests to be reflected from the window to the * window manager. */ Tk_ManageGeometry((Tk_Window) winPtr, &wmMgrType, NULL); } /* *-------------------------------------------------------------- * * TkWmMapWindow -- * * This function is invoked to map a top-level window. This module gets a * chance to update all window-manager-related information in properties * before the window manager sees the map event and checks the * properties. It also gets to decide whether or not to even map the * window after all. * * Results: * None. * * Side effects: * Properties of winPtr may get updated to provide up-to-date information * to the window manager. The window may also get mapped, but it may not * be if this function decides that isn't appropriate (e.g. because the * window is withdrawn). * *-------------------------------------------------------------- */ void TkWmMapWindow( TkWindow *winPtr) /* Top-level window that's about to be * mapped. */ { register WmInfo *wmPtr = winPtr->wmInfoPtr; XTextProperty textProp; if (wmPtr->flags & WM_NEVER_MAPPED) { Tcl_DString ds; wmPtr->flags &= ~WM_NEVER_MAPPED; /* * This is the first time this window has ever been mapped. First * create the wrapper window that provides space for a menubar. */ if (wmPtr->wrapperPtr == NULL) { CreateWrapper(wmPtr); } /* * Store all the window-manager-related information for the window. */ TkWmSetClass(winPtr); UpdateTitle(winPtr); UpdatePhotoIcon(winPtr); if (wmPtr->masterPtr != NULL) { /* * Don't map a transient if the master is not mapped. */ if (!Tk_IsMapped(wmPtr->masterPtr)) { wmPtr->withdrawn = 1; wmPtr->hints.initial_state = WithdrawnState; } /* * Make sure that we actually set the transient-for property, even * if we are withdrawn. [Bug 1163496] */ XSetTransientForHint(winPtr->display, wmPtr->wrapperPtr->window, wmPtr->masterPtr->wmInfoPtr->wrapperPtr->window); } wmPtr->flags |= WM_UPDATE_SIZE_HINTS; UpdateHints(winPtr); UpdateWmProtocols(wmPtr); if (wmPtr->cmdArgv != NULL) { UpdateCommand(winPtr); } if (wmPtr->clientMachine != NULL) { Tcl_UtfToExternalDString(NULL, wmPtr->clientMachine, -1, &ds); if (XStringListToTextProperty(&(Tcl_DStringValue(&ds)), 1, &textProp) != 0) { unsigned long pid = (unsigned long) getpid(); XSetWMClientMachine(winPtr->display, wmPtr->wrapperPtr->window, &textProp); XFree((char *) textProp.value); /* * Inform the server (and more particularly any session * manager) what our process ID is. We only do this when the * CLIENT_MACHINE property is set since the spec for * _NET_WM_PID requires that to be set too. */ SetWindowProperty(wmPtr->wrapperPtr, "_NET_WM_PID", XA_CARDINAL, 32, &pid, 1); } Tcl_DStringFree(&ds); } } if (wmPtr->hints.initial_state == WithdrawnState) { return; } if (wmPtr->iconFor != NULL) { /* * This window is an icon for somebody else. Make sure that the * geometry is up-to-date, then return without mapping the window. */ if (wmPtr->flags & WM_UPDATE_PENDING) { Tcl_CancelIdleCall(UpdateGeometryInfo, winPtr); } UpdateGeometryInfo(winPtr); return; } wmPtr->flags |= WM_ABOUT_TO_MAP; if (wmPtr->flags & WM_UPDATE_PENDING) { Tcl_CancelIdleCall(UpdateGeometryInfo, winPtr); } UpdateGeometryInfo(winPtr); wmPtr->flags &= ~WM_ABOUT_TO_MAP; /* * Update _NET_WM_STATE hints: */ UpdateNetWmState(wmPtr); /* * Map the window, then wait to be sure that the window manager has * processed the map operation. */ XMapWindow(winPtr->display, wmPtr->wrapperPtr->window); if (wmPtr->hints.initial_state == NormalState) { WaitForMapNotify(winPtr, 1); } } /* *-------------------------------------------------------------- * * TkWmUnmapWindow -- * * This function is invoked to unmap a top-level window. The only thing * it does special is to wait for the window actually to be unmapped. * * Results: * None. * * Side effects: * Unmaps the window. * *-------------------------------------------------------------- */ void TkWmUnmapWindow( TkWindow *winPtr) /* Top-level window that's about to be * mapped. */ { /* * It seems to be important to wait after unmapping a top-level window * until the window really gets unmapped. I don't completely understand * all the interactions with the window manager, but if we go on without * waiting, and if the window is then mapped again quickly, events seem to * get lost so that we think the window isn't mapped when in fact it is * mapped. I suspect that this has something to do with the window manager * filtering Map events (and possily not filtering Unmap events?). */ XUnmapWindow(winPtr->display, winPtr->wmInfoPtr->wrapperPtr->window); WaitForMapNotify(winPtr, 0); } /* *-------------------------------------------------------------- * * TkWmDeadWindow -- * * This function is invoked when a top-level window is about to be * deleted. It cleans up the wm-related data structures for the window. * * Results: * None. * * Side effects: * The WmInfo structure for winPtr gets freed up. * *-------------------------------------------------------------- */ void TkWmDeadWindow( TkWindow *winPtr) /* Top-level window that's being deleted. */ { register WmInfo *wmPtr = winPtr->wmInfoPtr; WmInfo *wmPtr2; if (wmPtr == NULL) { return; } if ((WmInfo *) winPtr->dispPtr->firstWmPtr == wmPtr) { winPtr->dispPtr->firstWmPtr = wmPtr->nextPtr; } else { register WmInfo *prevPtr; for (prevPtr = (WmInfo *) winPtr->dispPtr->firstWmPtr; ; prevPtr = prevPtr->nextPtr) { /* ASSERT: prevPtr != NULL [Bug 1789819] */ if (prevPtr->nextPtr == wmPtr) { prevPtr->nextPtr = wmPtr->nextPtr; break; } } } if (wmPtr->title != NULL) { ckfree(wmPtr->title); } if (wmPtr->iconName != NULL) { ckfree(wmPtr->iconName); } if (wmPtr->iconDataPtr != NULL) { ckfree(wmPtr->iconDataPtr); } if (wmPtr->hints.flags & IconPixmapHint) { Tk_FreeBitmap(winPtr->display, wmPtr->hints.icon_pixmap); } if (wmPtr->hints.flags & IconMaskHint) { Tk_FreeBitmap(winPtr->display, wmPtr->hints.icon_mask); } if (wmPtr->leaderName != NULL) { ckfree(wmPtr->leaderName); } if (wmPtr->icon != NULL) { wmPtr2 = ((TkWindow *) wmPtr->icon)->wmInfoPtr; wmPtr2->iconFor = NULL; wmPtr2->withdrawn = 1; } if (wmPtr->iconFor != NULL) { wmPtr2 = ((TkWindow *) wmPtr->iconFor)->wmInfoPtr; wmPtr2->icon = NULL; wmPtr2->hints.flags &= ~IconWindowHint; UpdateHints((TkWindow *) wmPtr->iconFor); } if (wmPtr->menubar != NULL) { Tk_DestroyWindow(wmPtr->menubar); } if (wmPtr->wrapperPtr != NULL) { /* * The rest of Tk doesn't know that we reparent the toplevel inside * the wrapper, so reparent it back out again before deleting the * wrapper; otherwise the toplevel will get deleted twice (once * implicitly by the deletion of the wrapper). */ XUnmapWindow(winPtr->display, winPtr->window); XReparentWindow(winPtr->display, winPtr->window, XRootWindow(winPtr->display, winPtr->screenNum), 0, 0); Tk_DestroyWindow((Tk_Window) wmPtr->wrapperPtr); } while (wmPtr->protPtr != NULL) { ProtocolHandler *protPtr = wmPtr->protPtr; wmPtr->protPtr = protPtr->nextPtr; Tcl_EventuallyFree(protPtr, TCL_DYNAMIC); } if (wmPtr->cmdArgv != NULL) { ckfree(wmPtr->cmdArgv); } if (wmPtr->clientMachine != NULL) { ckfree(wmPtr->clientMachine); } if (wmPtr->flags & WM_UPDATE_PENDING) { Tcl_CancelIdleCall(UpdateGeometryInfo, winPtr); } /* * Reset all transient windows whose master is the dead window. */ for (wmPtr2 = winPtr->dispPtr->firstWmPtr; wmPtr2 != NULL; wmPtr2 = wmPtr2->nextPtr) { if (wmPtr2->masterPtr == winPtr) { wmPtr->numTransients--; Tk_DeleteEventHandler((Tk_Window) wmPtr2->masterPtr, StructureNotifyMask, WmWaitMapProc, wmPtr2->winPtr); wmPtr2->masterPtr = NULL; if (!(wmPtr2->flags & WM_NEVER_MAPPED)) { XDeleteProperty(winPtr->display, wmPtr2->wrapperPtr->window, Tk_InternAtom((Tk_Window) winPtr, "WM_TRANSIENT_FOR")); /* * FIXME: Need a call like Win32's UpdateWrapper() so we can * recreate the wrapper and get rid of the transient window * decorations. */ } } } /* ASSERT: numTransients == 0 [Bug 1789819] */ if (wmPtr->masterPtr != NULL) { wmPtr2 = wmPtr->masterPtr->wmInfoPtr; /* * If we had a master, tell them that we aren't tied to them anymore */ if (wmPtr2 != NULL) { wmPtr2->numTransients--; } Tk_DeleteEventHandler((Tk_Window) wmPtr->masterPtr, StructureNotifyMask, WmWaitMapProc, winPtr); wmPtr->masterPtr = NULL; } ckfree(wmPtr); winPtr->wmInfoPtr = NULL; } /* *-------------------------------------------------------------- * * TkWmSetClass -- * * This function is invoked whenever a top-level window's class is * changed. If the window has been mapped then this function updates the * window manager property for the class. If the window hasn't been * mapped, the update is deferred until just before the first mapping. * * Results: * None. * * Side effects: * A window property may get updated. * *-------------------------------------------------------------- */ void TkWmSetClass( TkWindow *winPtr) /* Newly-created top-level window. */ { if (winPtr->wmInfoPtr->flags & WM_NEVER_MAPPED) { return; } if (winPtr->classUid != NULL) { XClassHint *classPtr; Tcl_DString name, class; Tcl_UtfToExternalDString(NULL, winPtr->nameUid, -1, &name); Tcl_UtfToExternalDString(NULL, winPtr->classUid, -1, &class); classPtr = XAllocClassHint(); classPtr->res_name = Tcl_DStringValue(&name); classPtr->res_class = Tcl_DStringValue(&class); XSetClassHint(winPtr->display, winPtr->wmInfoPtr->wrapperPtr->window, classPtr); XFree((char *) classPtr); Tcl_DStringFree(&name); Tcl_DStringFree(&class); } } /* *---------------------------------------------------------------------- * * Tk_WmObjCmd -- * * This function is invoked to process the "wm" Tcl command. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tk_WmObjCmd( ClientData clientData, /* Main window associated with interpreter. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tk_Window tkwin = clientData; static const char *const optionStrings[] = { "aspect", "attributes", "client", "colormapwindows", "command", "deiconify", "focusmodel", "forget", "frame", "geometry", "grid", "group", "iconbitmap", "iconify", "iconmask", "iconname", "iconphoto", "iconposition", "iconwindow", "manage", "maxsize", "minsize", "overrideredirect", "positionfrom", "protocol", "resizable", "sizefrom", "stackorder", "state", "title", "transient", "withdraw", NULL }; enum options { WMOPT_ASPECT, WMOPT_ATTRIBUTES, WMOPT_CLIENT, WMOPT_COLORMAPWINDOWS, WMOPT_COMMAND, WMOPT_DEICONIFY, WMOPT_FOCUSMODEL, WMOPT_FORGET, WMOPT_FRAME, WMOPT_GEOMETRY, WMOPT_GRID, WMOPT_GROUP, WMOPT_ICONBITMAP, WMOPT_ICONIFY, WMOPT_ICONMASK, WMOPT_ICONNAME, WMOPT_ICONPHOTO, WMOPT_ICONPOSITION, WMOPT_ICONWINDOW, WMOPT_MANAGE, WMOPT_MAXSIZE, WMOPT_MINSIZE, WMOPT_OVERRIDEREDIRECT, WMOPT_POSITIONFROM, WMOPT_PROTOCOL, WMOPT_RESIZABLE, WMOPT_SIZEFROM, WMOPT_STACKORDER, WMOPT_STATE, WMOPT_TITLE, WMOPT_TRANSIENT, WMOPT_WITHDRAW }; int index, length; const char *argv1; TkWindow *winPtr; Tk_Window targetWin; TkDisplay *dispPtr = ((TkWindow *) tkwin)->dispPtr; if (objc < 2) { wrongNumArgs: Tcl_WrongNumArgs(interp, 1, objv, "option window ?arg ...?"); return TCL_ERROR; } argv1 = Tcl_GetStringFromObj(objv[1], &length); if ((argv1[0] == 't') && (strncmp(argv1, "tracing", (size_t) length) == 0) && (length >= 3)) { int wmTracing; if ((objc != 2) && (objc != 3)) { Tcl_WrongNumArgs(interp, 2, objv, "?boolean?"); return TCL_ERROR; } if (objc == 2) { Tcl_SetObjResult(interp, Tcl_NewBooleanObj( dispPtr->flags & TK_DISPLAY_WM_TRACING)); return TCL_OK; } if (Tcl_GetBooleanFromObj(interp, objv[2], &wmTracing) != TCL_OK) { return TCL_ERROR; } if (wmTracing) { dispPtr->flags |= TK_DISPLAY_WM_TRACING; } else { dispPtr->flags &= ~TK_DISPLAY_WM_TRACING; } return TCL_OK; } if (Tcl_GetIndexFromObjStruct(interp, objv[1], optionStrings, sizeof(char *), "option", 0, &index) != TCL_OK) { return TCL_ERROR; } if (objc < 3) { goto wrongNumArgs; } if (TkGetWindowFromObj(interp, tkwin, objv[2], &targetWin) != TCL_OK) { return TCL_ERROR; } winPtr = (TkWindow *) targetWin; if (!Tk_IsTopLevel(winPtr) && (index != WMOPT_MANAGE) && (index != WMOPT_FORGET)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "window \"%s\" isn't a top-level window", winPtr->pathName)); Tcl_SetErrorCode(interp, "TK", "LOOKUP", "TOPLEVEL", winPtr->pathName, NULL); return TCL_ERROR; } switch ((enum options) index) { case WMOPT_ASPECT: return WmAspectCmd(tkwin, winPtr, interp, objc, objv); case WMOPT_ATTRIBUTES: return WmAttributesCmd(tkwin, winPtr, interp, objc, objv); case WMOPT_CLIENT: return WmClientCmd(tkwin, winPtr, interp, objc, objv); case WMOPT_COLORMAPWINDOWS: return WmColormapwindowsCmd(tkwin, winPtr, interp, objc, objv); case WMOPT_COMMAND: return WmCommandCmd(tkwin, winPtr, interp, objc, objv); case WMOPT_DEICONIFY: return WmDeiconifyCmd(tkwin, winPtr, interp, objc, objv); case WMOPT_FOCUSMODEL: return WmFocusmodelCmd(tkwin, winPtr, interp, objc, objv); case WMOPT_FORGET: return WmForgetCmd(tkwin, winPtr, interp, objc, objv); case WMOPT_FRAME: return WmFrameCmd(tkwin, winPtr, interp, objc, objv); case WMOPT_GEOMETRY: return WmGeometryCmd(tkwin, winPtr, interp, objc, objv); case WMOPT_GRID: return WmGridCmd(tkwin, winPtr, interp, objc, objv); case WMOPT_GROUP: return WmGroupCmd(tkwin, winPtr, interp, objc, objv); case WMOPT_ICONBITMAP: return WmIconbitmapCmd(tkwin, winPtr, interp, objc, objv); case WMOPT_ICONIFY: return WmIconifyCmd(tkwin, winPtr, interp, objc, objv); case WMOPT_ICONMASK: return WmIconmaskCmd(tkwin, winPtr, interp, objc, objv); case WMOPT_ICONNAME: return WmIconnameCmd(tkwin, winPtr, interp, objc, objv); case WMOPT_ICONPHOTO: return WmIconphotoCmd(tkwin, winPtr, interp, objc, objv); case WMOPT_ICONPOSITION: return WmIconpositionCmd(tkwin, winPtr, interp, objc, objv); case WMOPT_ICONWINDOW: return WmIconwindowCmd(tkwin, winPtr, interp, objc, objv); case WMOPT_MANAGE: return WmManageCmd(tkwin, winPtr, interp, objc, objv); case WMOPT_MAXSIZE: return WmMaxsizeCmd(tkwin, winPtr, interp, objc, objv); case WMOPT_MINSIZE: return WmMinsizeCmd(tkwin, winPtr, interp, objc, objv); case WMOPT_OVERRIDEREDIRECT: return WmOverrideredirectCmd(tkwin, winPtr, interp, objc, objv); case WMOPT_POSITIONFROM: return WmPositionfromCmd(tkwin, winPtr, interp, objc, objv); case WMOPT_PROTOCOL: return WmProtocolCmd(tkwin, winPtr, interp, objc, objv); case WMOPT_RESIZABLE: return WmResizableCmd(tkwin, winPtr, interp, objc, objv); case WMOPT_SIZEFROM: return WmSizefromCmd(tkwin, winPtr, interp, objc, objv); case WMOPT_STACKORDER: return WmStackorderCmd(tkwin, winPtr, interp, objc, objv); case WMOPT_STATE: return WmStateCmd(tkwin, winPtr, interp, objc, objv); case WMOPT_TITLE: return WmTitleCmd(tkwin, winPtr, interp, objc, objv); case WMOPT_TRANSIENT: return WmTransientCmd(tkwin, winPtr, interp, objc, objv); case WMOPT_WITHDRAW: return WmWithdrawCmd(tkwin, winPtr, interp, objc, objv); } /* This should not happen */ return TCL_ERROR; } /* *---------------------------------------------------------------------- * * WmAspectCmd -- * * This function is invoked to process the "wm aspect" Tcl command. See * the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int WmAspectCmd( Tk_Window tkwin, /* Main window of the application. */ TkWindow *winPtr, /* Toplevel to work with */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { register WmInfo *wmPtr = winPtr->wmInfoPtr; int numer1, denom1, numer2, denom2; if ((objc != 3) && (objc != 7)) { Tcl_WrongNumArgs(interp, 2, objv, "window ?minNumer minDenom maxNumer maxDenom?"); return TCL_ERROR; } if (objc == 3) { if (wmPtr->sizeHintsFlags & PAspect) { Tcl_Obj *results[4]; results[0] = Tcl_NewIntObj(wmPtr->minAspect.x); results[1] = Tcl_NewIntObj(wmPtr->minAspect.y); results[2] = Tcl_NewIntObj(wmPtr->maxAspect.x); results[3] = Tcl_NewIntObj(wmPtr->maxAspect.y); Tcl_SetObjResult(interp, Tcl_NewListObj(4, results)); } return TCL_OK; } if (*Tcl_GetString(objv[3]) == '\0') { wmPtr->sizeHintsFlags &= ~PAspect; } else { if ((Tcl_GetIntFromObj(interp, objv[3], &numer1) != TCL_OK) || (Tcl_GetIntFromObj(interp, objv[4], &denom1) != TCL_OK) || (Tcl_GetIntFromObj(interp, objv[5], &numer2) != TCL_OK) || (Tcl_GetIntFromObj(interp, objv[6], &denom2) != TCL_OK)) { return TCL_ERROR; } if ((numer1 <= 0) || (denom1 <= 0) || (numer2 <= 0) || (denom2 <= 0)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "aspect number can't be <= 0", -1)); Tcl_SetErrorCode(interp, "TK", "VALUE", "ASPECT", NULL); return TCL_ERROR; } wmPtr->minAspect.x = numer1; wmPtr->minAspect.y = denom1; wmPtr->maxAspect.x = numer2; wmPtr->maxAspect.y = denom2; wmPtr->sizeHintsFlags |= PAspect; } wmPtr->flags |= WM_UPDATE_SIZE_HINTS; WmUpdateGeom(wmPtr, winPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * WmSetAttribute -- * * Helper routine for WmAttributesCmd. Sets the value of the specified * attribute. * * Returns: * * TCL_OK if successful, TCL_ERROR otherwise. In case of an error, leaves * a message in the interpreter's result. * *---------------------------------------------------------------------- */ static int WmSetAttribute( TkWindow *winPtr, /* Toplevel to work with */ Tcl_Interp *interp, /* Current interpreter */ WmAttribute attribute, /* Code of attribute to set */ Tcl_Obj *value) /* New value */ { WmInfo *wmPtr = winPtr->wmInfoPtr; switch (attribute) { case WMATT_ALPHA: { unsigned long opacity; /* 0=transparent, 0xFFFFFFFF=opaque */ if (TCL_OK != Tcl_GetDoubleFromObj(interp, value, &wmPtr->reqState.alpha)) { return TCL_ERROR; } if (wmPtr->reqState.alpha < 0.0) { wmPtr->reqState.alpha = 0.0; } if (wmPtr->reqState.alpha > 1.0) { wmPtr->reqState.alpha = 1.0; } if (!wmPtr->wrapperPtr) { break; } opacity = 0xFFFFFFFFul * wmPtr->reqState.alpha; SetWindowProperty(wmPtr->wrapperPtr, "_NET_WM_WINDOW_OPACITY", XA_CARDINAL, 32, &opacity, 1L); wmPtr->attributes.alpha = wmPtr->reqState.alpha; break; } case WMATT_TOPMOST: if (Tcl_GetBooleanFromObj(interp, value, &wmPtr->reqState.topmost) != TCL_OK) { return TCL_ERROR; } SetNetWmState(winPtr, "_NET_WM_STATE_ABOVE", wmPtr->reqState.topmost); break; case WMATT_TYPE: if (TCL_OK != SetNetWmType(winPtr, value)) return TCL_ERROR; break; case WMATT_ZOOMED: if (Tcl_GetBooleanFromObj(interp, value, &wmPtr->reqState.zoomed) != TCL_OK) { return TCL_ERROR; } SetNetWmState(winPtr, "_NET_WM_STATE_MAXIMIZED_VERT", wmPtr->reqState.zoomed); SetNetWmState(winPtr, "_NET_WM_STATE_MAXIMIZED_HORZ", wmPtr->reqState.zoomed); break; case WMATT_FULLSCREEN: if (Tcl_GetBooleanFromObj(interp, value, &wmPtr->reqState.fullscreen) != TCL_OK) { return TCL_ERROR; } SetNetWmState(winPtr, "_NET_WM_STATE_FULLSCREEN", wmPtr->reqState.fullscreen); break; case _WMATT_LAST_ATTRIBUTE: /* NOTREACHED */ return TCL_ERROR; } return TCL_OK; } /* *---------------------------------------------------------------------- * * WmGetAttribute -- * * Helper routine for WmAttributesCmd. Returns the current value of the * specified attribute. * * See also: CheckNetWmState(). * *---------------------------------------------------------------------- */ static Tcl_Obj * WmGetAttribute( TkWindow *winPtr, /* Toplevel to work with */ WmAttribute attribute) /* Code of attribute to get */ { WmInfo *wmPtr = winPtr->wmInfoPtr; switch (attribute) { case WMATT_ALPHA: return Tcl_NewDoubleObj(wmPtr->attributes.alpha); case WMATT_TOPMOST: return Tcl_NewBooleanObj(wmPtr->attributes.topmost); case WMATT_ZOOMED: return Tcl_NewBooleanObj(wmPtr->attributes.zoomed); case WMATT_FULLSCREEN: return Tcl_NewBooleanObj(wmPtr->attributes.fullscreen); case WMATT_TYPE: return GetNetWmType(winPtr); case _WMATT_LAST_ATTRIBUTE: /*NOTREACHED*/ break; } /*NOTREACHED*/ return NULL; } /* *---------------------------------------------------------------------- * * WmAttributesCmd -- * * This function is invoked to process the "wm attributes" Tcl command. * * Syntax: * * wm attributes $win ?-attribute ?value attribute value...?? * * Notes: * * Attributes of mapped windows are set by sending a _NET_WM_STATE * ClientMessage to the root window (see SetNetWmState). For withdrawn * windows, we keep track of the requested attribute state, and set the * _NET_WM_STATE property ourselves immediately prior to mapping the * window. * * See also: TIP#231, EWMH. * *---------------------------------------------------------------------- */ static int WmAttributesCmd( Tk_Window tkwin, /* Main window of the application. */ TkWindow *winPtr, /* Toplevel to work with */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int attribute = 0; if (objc == 3) { /* wm attributes $win */ Tcl_Obj *result = Tcl_NewListObj(0,0); for (attribute = 0; attribute < _WMATT_LAST_ATTRIBUTE; ++attribute) { Tcl_ListObjAppendElement(interp, result, Tcl_NewStringObj(WmAttributeNames[attribute], -1)); Tcl_ListObjAppendElement(interp, result, WmGetAttribute(winPtr, attribute)); } Tcl_SetObjResult(interp, result); return TCL_OK; } else if (objc == 4) { /* wm attributes $win -attribute */ if (Tcl_GetIndexFromObjStruct(interp, objv[3], WmAttributeNames, sizeof(char *), "attribute", 0, &attribute) != TCL_OK) { return TCL_ERROR; } Tcl_SetObjResult(interp, WmGetAttribute(winPtr, attribute)); return TCL_OK; } else if ((objc - 3) % 2 == 0) { /* wm attributes $win -att value... */ int i; for (i = 3; i < objc; i += 2) { if (Tcl_GetIndexFromObjStruct(interp, objv[i], WmAttributeNames, sizeof(char *), "attribute", 0, &attribute) != TCL_OK) { return TCL_ERROR; } if (WmSetAttribute(winPtr,interp,attribute,objv[i+1]) != TCL_OK) { return TCL_ERROR; } } return TCL_OK; } Tcl_WrongNumArgs(interp, 2, objv, "window ?-attribute ?value ...??"); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * WmClientCmd -- * * This function is invoked to process the "wm client" Tcl command. See * the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int WmClientCmd( Tk_Window tkwin, /* Main window of the application. */ TkWindow *winPtr, /* Toplevel to work with */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { register WmInfo *wmPtr = winPtr->wmInfoPtr; const char *argv3; int length; if ((objc != 3) && (objc != 4)) { Tcl_WrongNumArgs(interp, 2, objv, "window ?name?"); return TCL_ERROR; } if (objc == 3) { if (wmPtr->clientMachine != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj(wmPtr->clientMachine, -1)); } return TCL_OK; } argv3 = Tcl_GetStringFromObj(objv[3], &length); if (argv3[0] == 0) { if (wmPtr->clientMachine != NULL) { ckfree(wmPtr->clientMachine); wmPtr->clientMachine = NULL; if (!(wmPtr->flags & WM_NEVER_MAPPED)) { XDeleteProperty(winPtr->display, wmPtr->wrapperPtr->window, Tk_InternAtom((Tk_Window) winPtr, "WM_CLIENT_MACHINE")); } } return TCL_OK; } if (wmPtr->clientMachine != NULL) { ckfree(wmPtr->clientMachine); } wmPtr->clientMachine = ckalloc(length + 1); strcpy(wmPtr->clientMachine, argv3); if (!(wmPtr->flags & WM_NEVER_MAPPED)) { XTextProperty textProp; Tcl_DString ds; Tcl_UtfToExternalDString(NULL, wmPtr->clientMachine, -1, &ds); if (XStringListToTextProperty(&(Tcl_DStringValue(&ds)), 1, &textProp) != 0) { unsigned long pid = (unsigned long) getpid(); XSetWMClientMachine(winPtr->display, wmPtr->wrapperPtr->window, &textProp); XFree((char *) textProp.value); /* * Inform the server (and more particularly any session manager) * what our process ID is. We only do this when the CLIENT_MACHINE * property is set since the spec for _NET_WM_PID requires that to * be set too. */ SetWindowProperty(wmPtr->wrapperPtr, "_NET_WM_PID", XA_CARDINAL, 32, &pid, 1); } Tcl_DStringFree(&ds); } return TCL_OK; } /* *---------------------------------------------------------------------- * * WmColormapwindowsCmd -- * * This function is invoked to process the "wm colormapwindows" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int WmColormapwindowsCmd( Tk_Window tkwin, /* Main window of the application. */ TkWindow *winPtr, /* Toplevel to work with */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { register WmInfo *wmPtr = winPtr->wmInfoPtr; Window *cmapList; TkWindow *winPtr2; int count, i, windowObjc, gotToplevel; Tcl_Obj **windowObjv, *resultObj; if ((objc != 3) && (objc != 4)) { Tcl_WrongNumArgs(interp, 2, objv, "window ?windowList?"); return TCL_ERROR; } Tk_MakeWindowExist((Tk_Window) winPtr); if (wmPtr->wrapperPtr == NULL) { CreateWrapper(wmPtr); } if (objc == 3) { if (XGetWMColormapWindows(winPtr->display, wmPtr->wrapperPtr->window, &cmapList, &count) == 0) { return TCL_OK; } resultObj = Tcl_NewObj(); for (i = 0; i < count; i++) { if ((i == (count-1)) && (wmPtr->flags & WM_ADDED_TOPLEVEL_COLORMAP)) { break; } winPtr2 = (TkWindow *) Tk_IdToWindow(winPtr->display, cmapList[i]); if (winPtr2 == NULL) { Tcl_ListObjAppendElement(NULL, resultObj, Tcl_ObjPrintf("0x%lx", cmapList[i])); } else { Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(winPtr2->pathName, -1)); } } XFree((char *) cmapList); Tcl_SetObjResult(interp, resultObj); return TCL_OK; } if (Tcl_ListObjGetElements(interp, objv[3], &windowObjc, &windowObjv) != TCL_OK) { return TCL_ERROR; } cmapList = ckalloc((windowObjc+1) * sizeof(Window)); gotToplevel = 0; for (i = 0; i < windowObjc; i++) { Tk_Window mapWin; if (TkGetWindowFromObj(interp, tkwin, windowObjv[i], &mapWin) != TCL_OK) { ckfree(cmapList); return TCL_ERROR; } winPtr2 = (TkWindow *) mapWin; if (winPtr2 == winPtr) { gotToplevel = 1; } if (winPtr2->window == None) { Tk_MakeWindowExist((Tk_Window) winPtr2); } cmapList[i] = winPtr2->window; } if (!gotToplevel) { wmPtr->flags |= WM_ADDED_TOPLEVEL_COLORMAP; cmapList[windowObjc] = wmPtr->wrapperPtr->window; windowObjc++; } else { wmPtr->flags &= ~WM_ADDED_TOPLEVEL_COLORMAP; } wmPtr->flags |= WM_COLORMAPS_EXPLICIT; XSetWMColormapWindows(winPtr->display, wmPtr->wrapperPtr->window, cmapList, windowObjc); ckfree(cmapList); return TCL_OK; } /* *---------------------------------------------------------------------- * * WmCommandCmd -- * * This function is invoked to process the "wm command" Tcl command. See * the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int WmCommandCmd( Tk_Window tkwin, /* Main window of the application. */ TkWindow *winPtr, /* Toplevel to work with */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { register WmInfo *wmPtr = winPtr->wmInfoPtr; const char *argv3; int cmdArgc; const char **cmdArgv; if ((objc != 3) && (objc != 4)) { Tcl_WrongNumArgs(interp, 2, objv, "window ?value?"); return TCL_ERROR; } if (objc == 3) { if (wmPtr->cmdArgv != NULL) { char *arg = Tcl_Merge(wmPtr->cmdArgc, wmPtr->cmdArgv); Tcl_SetObjResult(interp, Tcl_NewStringObj(arg, -1)); ckfree(arg); } return TCL_OK; } argv3 = Tcl_GetString(objv[3]); if (argv3[0] == 0) { if (wmPtr->cmdArgv != NULL) { ckfree(wmPtr->cmdArgv); wmPtr->cmdArgv = NULL; if (!(wmPtr->flags & WM_NEVER_MAPPED)) { XDeleteProperty(winPtr->display, wmPtr->wrapperPtr->window, Tk_InternAtom((Tk_Window) winPtr, "WM_COMMAND")); } } return TCL_OK; } if (Tcl_SplitList(interp, argv3, &cmdArgc, &cmdArgv) != TCL_OK) { return TCL_ERROR; } if (wmPtr->cmdArgv != NULL) { ckfree(wmPtr->cmdArgv); } wmPtr->cmdArgc = cmdArgc; wmPtr->cmdArgv = cmdArgv; if (!(wmPtr->flags & WM_NEVER_MAPPED)) { UpdateCommand(winPtr); } return TCL_OK; } /* *---------------------------------------------------------------------- * * WmDeiconifyCmd -- * * This function is invoked to process the "wm deiconify" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int WmDeiconifyCmd( Tk_Window tkwin, /* Main window of the application. */ TkWindow *winPtr, /* Toplevel to work with */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { register WmInfo *wmPtr = winPtr->wmInfoPtr; if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "window"); return TCL_ERROR; } if (wmPtr->iconFor != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't deiconify %s: it is an icon for %s", Tcl_GetString(objv[2]), Tk_PathName(wmPtr->iconFor))); Tcl_SetErrorCode(interp, "TK", "WM", "DEICONIFY", "ICON", NULL); return TCL_ERROR; } if (winPtr->flags & TK_EMBEDDED) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't deiconify %s: it is an embedded window", winPtr->pathName)); Tcl_SetErrorCode(interp, "TK", "WM", "DEICONIFY", "EMBEDDED", NULL); return TCL_ERROR; } wmPtr->flags &= ~WM_WITHDRAWN; TkpWmSetState(winPtr, NormalState); return TCL_OK; } /* *---------------------------------------------------------------------- * * WmFocusmodelCmd -- * * This function is invoked to process the "wm focusmodel" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int WmFocusmodelCmd( Tk_Window tkwin, /* Main window of the application. */ TkWindow *winPtr, /* Toplevel to work with */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { register WmInfo *wmPtr = winPtr->wmInfoPtr; static const char *const optionStrings[] = { "active", "passive", NULL }; enum options { OPT_ACTIVE, OPT_PASSIVE }; int index; if ((objc != 3) && (objc != 4)) { Tcl_WrongNumArgs(interp, 2, objv, "window ?active|passive?"); return TCL_ERROR; } if (objc == 3) { Tcl_SetObjResult(interp, Tcl_NewStringObj( wmPtr->hints.input ? "passive" : "active", -1)); return TCL_OK; } if (Tcl_GetIndexFromObjStruct(interp, objv[3], optionStrings, sizeof(char *), "argument", 0, &index) != TCL_OK) { return TCL_ERROR; } if (index == OPT_ACTIVE) { wmPtr->hints.input = False; } else { /* OPT_PASSIVE */ wmPtr->hints.input = True; } UpdateHints(winPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * WmForgetCmd -- * * This procedure is invoked to process the "wm forget" Tcl command. See * the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int WmForgetCmd( Tk_Window tkwin, /* Main window of the application. */ TkWindow *winPtr, /* Toplevel or Frame to work with */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { register Tk_Window frameWin = (Tk_Window) winPtr; if (Tk_IsTopLevel(frameWin)) { TkFocusJoin(winPtr); Tk_UnmapWindow(frameWin); TkWmDeadWindow(winPtr); winPtr->flags &= ~(TK_TOP_HIERARCHY|TK_TOP_LEVEL|TK_HAS_WRAPPER|TK_WIN_MANAGED); RemapWindows(winPtr, winPtr->parentPtr); /* * Make sure wm no longer manages this window */ Tk_ManageGeometry(frameWin, NULL, NULL); /* * Flags (above) must be cleared before calling TkMapTopFrame (below). */ TkMapTopFrame(frameWin); } else { /* * Already not managed by wm - ignore it. */ } return TCL_OK; } /* *---------------------------------------------------------------------- * * WmFrameCmd -- * * This function is invoked to process the "wm frame" Tcl command. See * the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int WmFrameCmd( Tk_Window tkwin, /* Main window of the application. */ TkWindow *winPtr, /* Toplevel to work with */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { register WmInfo *wmPtr = winPtr->wmInfoPtr; Window window; if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "window"); return TCL_ERROR; } window = wmPtr->reparent; if (window == None) { window = Tk_WindowId((Tk_Window) winPtr); } Tcl_SetObjResult(interp, Tcl_ObjPrintf("0x%x", (unsigned) window)); return TCL_OK; } /* *---------------------------------------------------------------------- * * WmGeometryCmd -- * * This function is invoked to process the "wm geometry" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int WmGeometryCmd( Tk_Window tkwin, /* Main window of the application. */ TkWindow *winPtr, /* Toplevel to work with */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { register WmInfo *wmPtr = winPtr->wmInfoPtr; char xSign, ySign; int width, height; const char *argv3; if ((objc != 3) && (objc != 4)) { Tcl_WrongNumArgs(interp, 2, objv, "window ?newGeometry?"); return TCL_ERROR; } if (objc == 3) { xSign = (wmPtr->flags & WM_NEGATIVE_X) ? '-' : '+'; ySign = (wmPtr->flags & WM_NEGATIVE_Y) ? '-' : '+'; if (wmPtr->gridWin != NULL) { width = wmPtr->reqGridWidth + (winPtr->changes.width - winPtr->reqWidth)/wmPtr->widthInc; height = wmPtr->reqGridHeight + (winPtr->changes.height - winPtr->reqHeight)/wmPtr->heightInc; } else { width = winPtr->changes.width; height = winPtr->changes.height; } Tcl_SetObjResult(interp, Tcl_ObjPrintf("%dx%d%c%d%c%d", width, height, xSign, wmPtr->x, ySign, wmPtr->y)); return TCL_OK; } argv3 = Tcl_GetString(objv[3]); if (*argv3 == '\0') { wmPtr->width = -1; wmPtr->height = -1; WmUpdateGeom(wmPtr, winPtr); return TCL_OK; } return ParseGeometry(interp, argv3, winPtr); } /* *---------------------------------------------------------------------- * * WmGridCmd -- * * This function is invoked to process the "wm grid" Tcl command. See the * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int WmGridCmd( Tk_Window tkwin, /* Main window of the application. */ TkWindow *winPtr, /* Toplevel to work with */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { register WmInfo *wmPtr = winPtr->wmInfoPtr; int reqWidth, reqHeight, widthInc, heightInc; if ((objc != 3) && (objc != 7)) { Tcl_WrongNumArgs(interp, 2, objv, "window ?baseWidth baseHeight widthInc heightInc?"); return TCL_ERROR; } if (objc == 3) { if (wmPtr->sizeHintsFlags & PBaseSize) { Tcl_Obj *results[4]; results[0] = Tcl_NewIntObj(wmPtr->reqGridWidth); results[1] = Tcl_NewIntObj(wmPtr->reqGridHeight); results[2] = Tcl_NewIntObj(wmPtr->widthInc); results[3] = Tcl_NewIntObj(wmPtr->heightInc); Tcl_SetObjResult(interp, Tcl_NewListObj(4, results)); } return TCL_OK; } if (*Tcl_GetString(objv[3]) == '\0') { /* * Turn off gridding and reset the width and height to make sense as * ungridded numbers. */ wmPtr->sizeHintsFlags &= ~(PBaseSize|PResizeInc); if (wmPtr->width != -1) { wmPtr->width = winPtr->reqWidth + (wmPtr->width - wmPtr->reqGridWidth)*wmPtr->widthInc; wmPtr->height = winPtr->reqHeight + (wmPtr->height - wmPtr->reqGridHeight)*wmPtr->heightInc; } wmPtr->widthInc = 1; wmPtr->heightInc = 1; } else { if ((Tcl_GetIntFromObj(interp, objv[3], &reqWidth) != TCL_OK) || (Tcl_GetIntFromObj(interp, objv[4], &reqHeight) != TCL_OK) || (Tcl_GetIntFromObj(interp, objv[5], &widthInc) != TCL_OK) || (Tcl_GetIntFromObj(interp, objv[6], &heightInc) !=TCL_OK)) { return TCL_ERROR; } if (reqWidth < 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "baseWidth can't be < 0", -1)); Tcl_SetErrorCode(interp, "TK", "VALUE", "GRID", NULL); return TCL_ERROR; } if (reqHeight < 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "baseHeight can't be < 0", -1)); Tcl_SetErrorCode(interp, "TK", "VALUE", "GRID", NULL); return TCL_ERROR; } if (widthInc <= 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "widthInc can't be <= 0", -1)); Tcl_SetErrorCode(interp, "TK", "VALUE", "GRID", NULL); return TCL_ERROR; } if (heightInc <= 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "heightInc can't be <= 0", -1)); Tcl_SetErrorCode(interp, "TK", "VALUE", "GRID", NULL); return TCL_ERROR; } Tk_SetGrid((Tk_Window) winPtr, reqWidth, reqHeight, widthInc, heightInc); } wmPtr->flags |= WM_UPDATE_SIZE_HINTS; WmUpdateGeom(wmPtr, winPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * WmGroupCmd -- * * This function is invoked to process the "wm group" Tcl command. See * the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int WmGroupCmd( Tk_Window tkwin, /* Main window of the application. */ TkWindow *winPtr, /* Toplevel to work with */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { register WmInfo *wmPtr = winPtr->wmInfoPtr; Tk_Window tkwin2; WmInfo *wmPtr2; const char *argv3; int length; if ((objc != 3) && (objc != 4)) { Tcl_WrongNumArgs(interp, 2, objv, "window ?pathName?"); return TCL_ERROR; } if (objc == 3) { if (wmPtr->hints.flags & WindowGroupHint) { Tcl_SetObjResult(interp, Tcl_NewStringObj(wmPtr->leaderName, -1)); } return TCL_OK; } argv3 = Tcl_GetStringFromObj(objv[3], &length); if (*argv3 == '\0') { wmPtr->hints.flags &= ~WindowGroupHint; if (wmPtr->leaderName != NULL) { ckfree(wmPtr->leaderName); } wmPtr->leaderName = NULL; } else { if (TkGetWindowFromObj(interp, tkwin, objv[3], &tkwin2) != TCL_OK) { return TCL_ERROR; } while (!Tk_TopWinHierarchy(tkwin2)) { /* * Ensure that the group leader is actually a Tk toplevel. */ tkwin2 = Tk_Parent(tkwin2); } Tk_MakeWindowExist(tkwin2); wmPtr2 = ((TkWindow *) tkwin2)->wmInfoPtr; if (wmPtr2->wrapperPtr == NULL) { CreateWrapper(wmPtr2); } if (wmPtr->leaderName != NULL) { ckfree(wmPtr->leaderName); } wmPtr->hints.window_group = Tk_WindowId(wmPtr2->wrapperPtr); wmPtr->hints.flags |= WindowGroupHint; wmPtr->leaderName = ckalloc(length + 1); strcpy(wmPtr->leaderName, argv3); } UpdateHints(winPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * WmIconbitmapCmd -- * * This function is invoked to process the "wm iconbitmap" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int WmIconbitmapCmd( Tk_Window tkwin, /* Main window of the application. */ TkWindow *winPtr, /* Toplevel to work with */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { register WmInfo *wmPtr = winPtr->wmInfoPtr; Pixmap pixmap; const char *argv3; if ((objc < 3) || (objc > 4)) { Tcl_WrongNumArgs(interp, 2, objv, "window ?bitmap?"); return TCL_ERROR; } if (objc == 3) { if (wmPtr->hints.flags & IconPixmapHint) { Tcl_SetObjResult(interp, Tcl_NewStringObj( Tk_NameOfBitmap(winPtr->display, wmPtr->hints.icon_pixmap), -1)); } return TCL_OK; } argv3 = Tcl_GetString(objv[3]); if (*argv3 == '\0') { if (wmPtr->hints.icon_pixmap != None) { Tk_FreeBitmap(winPtr->display, wmPtr->hints.icon_pixmap); wmPtr->hints.icon_pixmap = None; } wmPtr->hints.flags &= ~IconPixmapHint; } else { pixmap = Tk_GetBitmap(interp, (Tk_Window) winPtr, argv3); if (pixmap == None) { return TCL_ERROR; } wmPtr->hints.icon_pixmap = pixmap; wmPtr->hints.flags |= IconPixmapHint; } UpdateHints(winPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * WmIconifyCmd -- * * This function is invoked to process the "wm iconify" Tcl command. See * the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int WmIconifyCmd( Tk_Window tkwin, /* Main window of the application. */ TkWindow *winPtr, /* Toplevel to work with */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { register WmInfo *wmPtr = winPtr->wmInfoPtr; if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "window"); return TCL_ERROR; } if (Tk_Attributes((Tk_Window) winPtr)->override_redirect) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't iconify \"%s\": override-redirect flag is set", winPtr->pathName)); Tcl_SetErrorCode(interp, "TK", "WM", "ICONIFY", "OVERRIDE_REDIRECT", NULL); return TCL_ERROR; } if (wmPtr->masterPtr != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't iconify \"%s\": it is a transient", winPtr->pathName)); Tcl_SetErrorCode(interp, "TK", "WM", "ICONIFY", "TRANSIENT", NULL); return TCL_ERROR; } if (wmPtr->iconFor != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't iconify %s: it is an icon for %s", winPtr->pathName, Tk_PathName(wmPtr->iconFor))); Tcl_SetErrorCode(interp, "TK", "WM", "ICONIFY", "ICON", NULL); return TCL_ERROR; } if (winPtr->flags & TK_EMBEDDED) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't iconify %s: it is an embedded window", winPtr->pathName)); Tcl_SetErrorCode(interp, "TK", "WM", "ICONIFY", "EMBEDDED", NULL); return TCL_ERROR; } if (TkpWmSetState(winPtr, IconicState) == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "couldn't send iconify message to window manager", -1)); Tcl_SetErrorCode(interp, "TK", "WM", "COMMUNICATION", NULL); return TCL_ERROR; } return TCL_OK; } /* *---------------------------------------------------------------------- * * WmIconmaskCmd -- * * This function is invoked to process the "wm iconmask" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int WmIconmaskCmd( Tk_Window tkwin, /* Main window of the application. */ TkWindow *winPtr, /* Toplevel to work with */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { register WmInfo *wmPtr = winPtr->wmInfoPtr; Pixmap pixmap; const char *argv3; if ((objc != 3) && (objc != 4)) { Tcl_WrongNumArgs(interp, 2, objv, "window ?bitmap?"); return TCL_ERROR; } if (objc == 3) { if (wmPtr->hints.flags & IconMaskHint) { Tcl_SetObjResult(interp, Tcl_NewStringObj( Tk_NameOfBitmap(winPtr->display, wmPtr->hints.icon_mask), -1)); } return TCL_OK; } argv3 = Tcl_GetString(objv[3]); if (*argv3 == '\0') { if (wmPtr->hints.icon_mask != None) { Tk_FreeBitmap(winPtr->display, wmPtr->hints.icon_mask); } wmPtr->hints.flags &= ~IconMaskHint; } else { pixmap = Tk_GetBitmap(interp, tkwin, argv3); if (pixmap == None) { return TCL_ERROR; } wmPtr->hints.icon_mask = pixmap; wmPtr->hints.flags |= IconMaskHint; } UpdateHints(winPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * WmIconnameCmd -- * * This function is invoked to process the "wm iconname" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int WmIconnameCmd( Tk_Window tkwin, /* Main window of the application. */ TkWindow *winPtr, /* Toplevel to work with */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { register WmInfo *wmPtr = winPtr->wmInfoPtr; const char *argv3; int length; if (objc > 4) { Tcl_WrongNumArgs(interp, 2, objv, "window ?newName?"); return TCL_ERROR; } if (objc == 3) { if (wmPtr->iconName != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj(wmPtr->iconName, -1)); } return TCL_OK; } else { if (wmPtr->iconName != NULL) { ckfree(wmPtr->iconName); } argv3 = Tcl_GetStringFromObj(objv[3], &length); wmPtr->iconName = ckalloc(length + 1); strcpy(wmPtr->iconName, argv3); if (!(wmPtr->flags & WM_NEVER_MAPPED)) { UpdateTitle(winPtr); } } return TCL_OK; } /* *---------------------------------------------------------------------- * * WmIconphotoCmd -- * * This function is invoked to process the "wm iconphoto" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int WmIconphotoCmd( Tk_Window tkwin, /* Main window of the application. */ TkWindow *winPtr, /* Toplevel to work with */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { register WmInfo *wmPtr = winPtr->wmInfoPtr; Tk_PhotoHandle photo; Tk_PhotoImageBlock block; int i, size = 0, width, height, index = 0, x, y, isDefault = 0; unsigned long *iconPropertyData; if (objc < 4) { Tcl_WrongNumArgs(interp, 2, objv, "window ?-default? image1 ?image2 ...?"); return TCL_ERROR; } if (strcmp(Tcl_GetString(objv[3]), "-default") == 0) { isDefault = 1; if (objc == 4) { Tcl_WrongNumArgs(interp, 2, objv, "window ?-default? image1 ?image2 ...?"); return TCL_ERROR; } } /* * Iterate over all images to retrieve their sizes, in order to allocate a * buffer large enough to hold all images. */ for (i = 3 + isDefault; i < objc; i++) { photo = Tk_FindPhoto(interp, Tcl_GetString(objv[i])); if (photo == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't use \"%s\" as iconphoto: not a photo image", Tcl_GetString(objv[i]))); Tcl_SetErrorCode(interp, "TK", "WM", "ICONPHOTO", "PHOTO", NULL); return TCL_ERROR; } Tk_PhotoGetSize(photo, &width, &height); /* * We need to cardinals for width & height and one cardinal for each * image pixel. */ size += 2 + width * height; } /* * We have calculated the size of the data. Try to allocate the needed * memory space. This is an unsigned long array (despite this being twice * as much as is really needed on LP64 platforms) because that's what X * defines CARD32 arrays to use. [Bug 2902814] */ iconPropertyData = attemptckalloc(sizeof(unsigned long) * size); if (iconPropertyData == NULL) { return TCL_ERROR; } memset(iconPropertyData, 0, sizeof(unsigned long) * size); for (i = 3 + isDefault; i < objc; i++) { photo = Tk_FindPhoto(interp, Tcl_GetString(objv[i])); if (photo == NULL) { Tcl_Free((char *) iconPropertyData); return TCL_ERROR; } Tk_PhotoGetSize(photo, &width, &height); Tk_PhotoGetImage(photo, &block); /* * Each image data will be placed as an array of 32bit packed * CARDINAL, in a window property named "_NET_WM_ICON": _NET_WM_ICON * * _NET_WM_ICON CARDINAL[][2+n]/32 * * This is an array of possible icons for the client. This spec. does * not stipulate what size these icons should be, but individual * desktop environments or toolkits may do so. The Window Manager MAY * scale any of these icons to an appropriate size. * * This is an array of 32bit packed CARDINAL ARGB with high byte being * A, low byte being B. The first two cardinals are width, height. * Data is in rows, left to right and top to bottom. The data will be * endian-swapped going to the server if necessary. [Bug 2830420] * * The image data will be encoded in the iconPropertyData array. */ iconPropertyData[index++] = (unsigned long) width; iconPropertyData[index++] = (unsigned long) height; for (y = 0; y < height; y++) { for (x = 0; x < width; x++) { register unsigned char *pixelPtr = block.pixelPtr + x*block.pixelSize + y*block.pitch; register unsigned long R, G, B, A; R = pixelPtr[block.offset[0]]; G = pixelPtr[block.offset[1]]; B = pixelPtr[block.offset[2]]; A = pixelPtr[block.offset[3]]; iconPropertyData[index++] = A<<24 | R<<16 | G<<8 | B<<0; } } } if (wmPtr->iconDataPtr != NULL) { ckfree(wmPtr->iconDataPtr); wmPtr->iconDataPtr = NULL; } if (isDefault) { if (winPtr->dispPtr->iconDataPtr != NULL) { ckfree(winPtr->dispPtr->iconDataPtr); } winPtr->dispPtr->iconDataPtr = (unsigned char *) iconPropertyData; winPtr->dispPtr->iconDataSize = size; } else { wmPtr->iconDataPtr = (unsigned char *) iconPropertyData; wmPtr->iconDataSize = size; } if (!(wmPtr->flags & WM_NEVER_MAPPED)) { UpdatePhotoIcon(winPtr); } return TCL_OK; } /* *---------------------------------------------------------------------- * * WmIconpositionCmd -- * * This function is invoked to process the "wm iconposition" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int WmIconpositionCmd( Tk_Window tkwin, /* Main window of the application. */ TkWindow *winPtr, /* Toplevel to work with */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { register WmInfo *wmPtr = winPtr->wmInfoPtr; int x, y; if ((objc != 3) && (objc != 5)) { Tcl_WrongNumArgs(interp, 2, objv, "window ?x y?"); return TCL_ERROR; } if (objc == 3) { if (wmPtr->hints.flags & IconPositionHint) { Tcl_Obj *results[2]; results[0] = Tcl_NewIntObj(wmPtr->hints.icon_x); results[1] = Tcl_NewIntObj(wmPtr->hints.icon_y); Tcl_SetObjResult(interp, Tcl_NewListObj(2, results)); } return TCL_OK; } if (Tcl_GetString(objv[3])[0] == '\0') { wmPtr->hints.flags &= ~IconPositionHint; } else { if ((Tcl_GetIntFromObj(interp, objv[3], &x) != TCL_OK) || (Tcl_GetIntFromObj(interp, objv[4], &y) != TCL_OK)) { return TCL_ERROR; } wmPtr->hints.icon_x = x; wmPtr->hints.icon_y = y; wmPtr->hints.flags |= IconPositionHint; } UpdateHints(winPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * WmIconwindowCmd -- * * This function is invoked to process the "wm iconwindow" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int WmIconwindowCmd( Tk_Window tkwin, /* Main window of the application. */ TkWindow *winPtr, /* Toplevel to work with */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { register WmInfo *wmPtr = winPtr->wmInfoPtr; Tk_Window tkwin2; WmInfo *wmPtr2; XSetWindowAttributes atts; if ((objc != 3) && (objc != 4)) { Tcl_WrongNumArgs(interp, 2, objv, "window ?pathName?"); return TCL_ERROR; } if (objc == 3) { if (wmPtr->icon != NULL) { Tcl_SetObjResult(interp, TkNewWindowObj(wmPtr->icon)); } return TCL_OK; } if (*Tcl_GetString(objv[3]) == '\0') { wmPtr->hints.flags &= ~IconWindowHint; if (wmPtr->icon != NULL) { /* * Remove the icon window relationship. In principle we should * also re-enable button events for the window, but this doesn't * work in general because the window manager is probably * selecting on them (we'll get an error if we try to re-enable * the events). So, just leave the icon window event-challenged; * the user will have to recreate it if they want button events. */ wmPtr2 = ((TkWindow *) wmPtr->icon)->wmInfoPtr; wmPtr2->iconFor = NULL; wmPtr2->withdrawn = 1; wmPtr2->hints.initial_state = WithdrawnState; } wmPtr->icon = NULL; } else { if (TkGetWindowFromObj(interp, tkwin, objv[3], &tkwin2) != TCL_OK) { return TCL_ERROR; } if (!Tk_IsTopLevel(tkwin2)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't use %s as icon window: not at top level", Tcl_GetString(objv[3]))); Tcl_SetErrorCode(interp, "TK", "WM", "ICONWINDOW", "INNER", NULL); return TCL_ERROR; } wmPtr2 = ((TkWindow *) tkwin2)->wmInfoPtr; if (wmPtr2->iconFor != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s is already an icon for %s", Tcl_GetString(objv[3]), Tk_PathName(wmPtr2->iconFor))); Tcl_SetErrorCode(interp, "TK", "WM", "ICONWINDOW", "ICON", NULL); return TCL_ERROR; } if (wmPtr->icon != NULL) { WmInfo *wmPtr3 = ((TkWindow *) wmPtr->icon)->wmInfoPtr; wmPtr3->iconFor = NULL; wmPtr3->withdrawn = 1; wmPtr3->hints.initial_state = WithdrawnState; } /* * Disable button events in the icon window: some window managers * (like olvwm) want to get the events themselves, but X only allows * one application at a time to receive button events for a window. */ atts.event_mask = Tk_Attributes(tkwin2)->event_mask & ~ButtonPressMask; Tk_ChangeWindowAttributes(tkwin2, CWEventMask, &atts); Tk_MakeWindowExist(tkwin2); if (wmPtr2->wrapperPtr == NULL) { CreateWrapper(wmPtr2); } wmPtr->hints.icon_window = Tk_WindowId(wmPtr2->wrapperPtr); wmPtr->hints.flags |= IconWindowHint; wmPtr->icon = tkwin2; wmPtr2->iconFor = (Tk_Window) winPtr; if (!wmPtr2->withdrawn && !(wmPtr2->flags & WM_NEVER_MAPPED)) { wmPtr2->withdrawn = 0; if (XWithdrawWindow(Tk_Display(tkwin2), Tk_WindowId(wmPtr2->wrapperPtr), Tk_ScreenNumber(tkwin2)) == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "couldn't send withdraw message to window manager", -1)); Tcl_SetErrorCode(interp, "TK", "WM", "COMMUNICATION", NULL); return TCL_ERROR; } WaitForMapNotify((TkWindow *) tkwin2, 0); } } UpdateHints(winPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * WmManageCmd -- * * This procedure is invoked to process the "wm manage" Tcl command. See * the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int WmManageCmd( Tk_Window tkwin, /* Main window of the application. */ TkWindow *winPtr, /* Toplevel or Frame to work with */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { register Tk_Window frameWin = (Tk_Window) winPtr; register WmInfo *wmPtr = winPtr->wmInfoPtr; if (!Tk_IsTopLevel(frameWin)) { if (!Tk_IsManageable(frameWin)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "window \"%s\" is not manageable: must be a frame," " labelframe or toplevel", Tk_PathName(frameWin))); Tcl_SetErrorCode(interp, "TK", "WM", "MANAGE", NULL); return TCL_ERROR; } TkFocusSplit(winPtr); Tk_UnmapWindow(frameWin); winPtr->flags |= TK_TOP_HIERARCHY|TK_TOP_LEVEL|TK_HAS_WRAPPER|TK_WIN_MANAGED; if (wmPtr == NULL) { TkWmNewWindow(winPtr); TkWmMapWindow(winPtr); Tk_UnmapWindow(frameWin); } wmPtr = winPtr->wmInfoPtr; winPtr->flags &= ~TK_MAPPED; RemapWindows(winPtr, wmPtr->wrapperPtr); /* * Flags (above) must be set before calling TkMapTopFrame (below). */ TkMapTopFrame(frameWin); } else if (Tk_IsTopLevel(frameWin)) { /* * Already managed by wm - ignore it. */ } return TCL_OK; } /* *---------------------------------------------------------------------- * * WmMaxsizeCmd -- * * This function is invoked to process the "wm maxsize" Tcl command. See * the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int WmMaxsizeCmd( Tk_Window tkwin, /* Main window of the application. */ TkWindow *winPtr, /* Toplevel to work with */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { register WmInfo *wmPtr = winPtr->wmInfoPtr; int width, height; if ((objc != 3) && (objc != 5)) { Tcl_WrongNumArgs(interp, 2, objv, "window ?width height?"); return TCL_ERROR; } if (objc == 3) { Tcl_Obj *results[2]; GetMaxSize(wmPtr, &width, &height); results[0] = Tcl_NewIntObj(width); results[1] = Tcl_NewIntObj(height); Tcl_SetObjResult(interp, Tcl_NewListObj(2, results)); return TCL_OK; } if ((Tcl_GetIntFromObj(interp, objv[3], &width) != TCL_OK) || (Tcl_GetIntFromObj(interp, objv[4], &height) != TCL_OK)) { return TCL_ERROR; } wmPtr->maxWidth = width; wmPtr->maxHeight = height; wmPtr->flags |= WM_UPDATE_SIZE_HINTS; if (width <= 0 && height <= 0) { wmPtr->sizeHintsFlags &= ~PMaxSize; } else { wmPtr->sizeHintsFlags |= PMaxSize; } WmUpdateGeom(wmPtr, winPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * WmMinsizeCmd -- * * This function is invoked to process the "wm minsize" Tcl command. See * the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int WmMinsizeCmd( Tk_Window tkwin, /* Main window of the application. */ TkWindow *winPtr, /* Toplevel to work with */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { register WmInfo *wmPtr = winPtr->wmInfoPtr; int width, height; if ((objc != 3) && (objc != 5)) { Tcl_WrongNumArgs(interp, 2, objv, "window ?width height?"); return TCL_ERROR; } if (objc == 3) { Tcl_Obj *results[2]; results[0] = Tcl_NewIntObj(wmPtr->minWidth); results[1] = Tcl_NewIntObj(wmPtr->minHeight); Tcl_SetObjResult(interp, Tcl_NewListObj(2, results)); return TCL_OK; } if ((Tcl_GetIntFromObj(interp, objv[3], &width) != TCL_OK) || (Tcl_GetIntFromObj(interp, objv[4], &height) != TCL_OK)) { return TCL_ERROR; } wmPtr->minWidth = width; wmPtr->minHeight = height; wmPtr->flags |= WM_UPDATE_SIZE_HINTS; WmUpdateGeom(wmPtr, winPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * WmOverrideredirectCmd -- * * This function is invoked to process the "wm overrideredirect" Tcl * command. See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int WmOverrideredirectCmd( Tk_Window tkwin, /* Main window of the application. */ TkWindow *winPtr, /* Toplevel to work with */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int boolean, curValue; XSetWindowAttributes atts; if ((objc != 3) && (objc != 4)) { Tcl_WrongNumArgs(interp, 2, objv, "window ?boolean?"); return TCL_ERROR; } curValue = Tk_Attributes((Tk_Window) winPtr)->override_redirect; if (objc == 3) { Tcl_SetObjResult(interp, Tcl_NewBooleanObj(curValue)); return TCL_OK; } if (Tcl_GetBooleanFromObj(interp, objv[3], &boolean) != TCL_OK) { return TCL_ERROR; } if (curValue != boolean) { /* * Only do this if we are really changing value, because it causes * some funky stuff to occur */ atts.override_redirect = (boolean) ? True : False; Tk_ChangeWindowAttributes((Tk_Window) winPtr, CWOverrideRedirect, &atts); if (winPtr->wmInfoPtr->wrapperPtr != NULL) { Tk_ChangeWindowAttributes( (Tk_Window) winPtr->wmInfoPtr->wrapperPtr, CWOverrideRedirect, &atts); } } return TCL_OK; } /* *---------------------------------------------------------------------- * * WmPositionfromCmd -- * * This function is invoked to process the "wm positionfrom" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int WmPositionfromCmd( Tk_Window tkwin, /* Main window of the application. */ TkWindow *winPtr, /* Toplevel to work with */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { register WmInfo *wmPtr = winPtr->wmInfoPtr; static const char *const optionStrings[] = { "program", "user", NULL }; enum options { OPT_PROGRAM, OPT_USER }; int index; if ((objc != 3) && (objc != 4)) { Tcl_WrongNumArgs(interp, 2, objv, "window ?user/program?"); return TCL_ERROR; } if (objc == 3) { const char *sourceStr = ""; if (wmPtr->sizeHintsFlags & USPosition) { sourceStr = "user"; } else if (wmPtr->sizeHintsFlags & PPosition) { sourceStr = "program"; } Tcl_SetObjResult(interp, Tcl_NewStringObj(sourceStr, -1)); return TCL_OK; } if (*Tcl_GetString(objv[3]) == '\0') { wmPtr->sizeHintsFlags &= ~(USPosition|PPosition); } else { if (Tcl_GetIndexFromObjStruct(interp, objv[3], optionStrings, sizeof(char *), "argument", 0, &index) != TCL_OK) { return TCL_ERROR; } if (index == OPT_USER) { wmPtr->sizeHintsFlags &= ~PPosition; wmPtr->sizeHintsFlags |= USPosition; } else { wmPtr->sizeHintsFlags &= ~USPosition; wmPtr->sizeHintsFlags |= PPosition; } } wmPtr->flags |= WM_UPDATE_SIZE_HINTS; WmUpdateGeom(wmPtr, winPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * WmProtocolCmd -- * * This function is invoked to process the "wm protocol" Tcl command. See * the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int WmProtocolCmd( Tk_Window tkwin, /* Main window of the application. */ TkWindow *winPtr, /* Toplevel to work with */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { register WmInfo *wmPtr = winPtr->wmInfoPtr; register ProtocolHandler *protPtr, *prevPtr; Atom protocol; const char *cmd; int cmdLength; if ((objc < 3) || (objc > 5)) { Tcl_WrongNumArgs(interp, 2, objv, "window ?name? ?command?"); return TCL_ERROR; } if (objc == 3) { /* * Return a list of all defined protocols for the window. */ Tcl_Obj *resultObj = Tcl_NewObj(); for (protPtr = wmPtr->protPtr; protPtr != NULL; protPtr = protPtr->nextPtr) { Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj( Tk_GetAtomName((Tk_Window)winPtr, protPtr->protocol),-1)); } Tcl_SetObjResult(interp, resultObj); return TCL_OK; } protocol = Tk_InternAtom((Tk_Window) winPtr, Tcl_GetString(objv[3])); if (objc == 4) { /* * Return the command to handle a given protocol. */ for (protPtr = wmPtr->protPtr; protPtr != NULL; protPtr = protPtr->nextPtr) { if (protPtr->protocol == protocol) { Tcl_SetObjResult(interp, Tcl_NewStringObj(protPtr->command, -1)); return TCL_OK; } } return TCL_OK; } /* * Special case for _NET_WM_PING: that's always handled directly. */ if (strcmp(Tcl_GetString(objv[3]), "_NET_WM_PING") == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "may not alter handling of that protocol", -1)); Tcl_SetErrorCode(interp, "TK", "WM", "PROTOCOL", "RESERVED", NULL); return TCL_ERROR; } /* * Delete any current protocol handler, then create a new one with the * specified command, unless the command is empty. */ for (protPtr = wmPtr->protPtr, prevPtr = NULL; protPtr != NULL; prevPtr = protPtr, protPtr = protPtr->nextPtr) { if (protPtr->protocol == protocol) { if (prevPtr == NULL) { wmPtr->protPtr = protPtr->nextPtr; } else { prevPtr->nextPtr = protPtr->nextPtr; } Tcl_EventuallyFree(protPtr, TCL_DYNAMIC); break; } } cmd = Tcl_GetStringFromObj(objv[4], &cmdLength); if (cmdLength > 0) { protPtr = ckalloc(HANDLER_SIZE(cmdLength)); protPtr->protocol = protocol; protPtr->nextPtr = wmPtr->protPtr; wmPtr->protPtr = protPtr; protPtr->interp = interp; memcpy(protPtr->command, cmd, cmdLength + 1); } if (!(wmPtr->flags & WM_NEVER_MAPPED)) { UpdateWmProtocols(wmPtr); } return TCL_OK; } /* *---------------------------------------------------------------------- * * WmResizableCmd -- * * This function is invoked to process the "wm resizable" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int WmResizableCmd( Tk_Window tkwin, /* Main window of the application. */ TkWindow *winPtr, /* Toplevel to work with */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { register WmInfo *wmPtr = winPtr->wmInfoPtr; int width, height; if ((objc != 3) && (objc != 5)) { Tcl_WrongNumArgs(interp, 2, objv, "window ?width height?"); return TCL_ERROR; } if (objc == 3) { Tcl_Obj *results[2]; results[0] = Tcl_NewBooleanObj(!(wmPtr->flags&WM_WIDTH_NOT_RESIZABLE)); results[1] = Tcl_NewBooleanObj(!(wmPtr->flags&WM_HEIGHT_NOT_RESIZABLE)); Tcl_SetObjResult(interp, Tcl_NewListObj(2, results)); return TCL_OK; } if ((Tcl_GetBooleanFromObj(interp, objv[3], &width) != TCL_OK) || (Tcl_GetBooleanFromObj(interp, objv[4], &height) != TCL_OK)) { return TCL_ERROR; } if (width) { wmPtr->flags &= ~WM_WIDTH_NOT_RESIZABLE; } else { wmPtr->flags |= WM_WIDTH_NOT_RESIZABLE; } if (height) { wmPtr->flags &= ~WM_HEIGHT_NOT_RESIZABLE; } else { wmPtr->flags |= WM_HEIGHT_NOT_RESIZABLE; } wmPtr->flags |= WM_UPDATE_SIZE_HINTS; WmUpdateGeom(wmPtr, winPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * WmSizefromCmd -- * * This function is invoked to process the "wm sizefrom" Tcl command. See * the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int WmSizefromCmd( Tk_Window tkwin, /* Main window of the application. */ TkWindow *winPtr, /* Toplevel to work with */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { register WmInfo *wmPtr = winPtr->wmInfoPtr; static const char *const optionStrings[] = { "program", "user", NULL }; enum options { OPT_PROGRAM, OPT_USER }; int index; if ((objc != 3) && (objc != 4)) { Tcl_WrongNumArgs(interp, 2, objv, "window ?user|program?"); return TCL_ERROR; } if (objc == 3) { const char *sourceStr = ""; if (wmPtr->sizeHintsFlags & USSize) { sourceStr = "user"; } else if (wmPtr->sizeHintsFlags & PSize) { sourceStr = "program"; } Tcl_SetObjResult(interp, Tcl_NewStringObj(sourceStr, -1)); return TCL_OK; } if (*Tcl_GetString(objv[3]) == '\0') { wmPtr->sizeHintsFlags &= ~(USSize|PSize); } else { if (Tcl_GetIndexFromObjStruct(interp, objv[3], optionStrings, sizeof(char *), "argument", 0, &index) != TCL_OK) { return TCL_ERROR; } if (index == OPT_USER) { wmPtr->sizeHintsFlags &= ~PSize; wmPtr->sizeHintsFlags |= USSize; } else { /* OPT_PROGRAM */ wmPtr->sizeHintsFlags &= ~USSize; wmPtr->sizeHintsFlags |= PSize; } } wmPtr->flags |= WM_UPDATE_SIZE_HINTS; WmUpdateGeom(wmPtr, winPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * WmStackorderCmd -- * * This function is invoked to process the "wm stackorder" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int WmStackorderCmd( Tk_Window tkwin, /* Main window of the application. */ TkWindow *winPtr, /* Toplevel to work with */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { TkWindow **windows, **window_ptr; static const char *const optionStrings[] = { "isabove", "isbelow", NULL }; enum options { OPT_ISABOVE, OPT_ISBELOW }; int index; if ((objc != 3) && (objc != 5)) { Tcl_WrongNumArgs(interp, 2, objv, "window ?isabove|isbelow window?"); return TCL_ERROR; } if (objc == 3) { windows = TkWmStackorderToplevel(winPtr); if (windows != NULL) { Tcl_Obj *resultObj = Tcl_NewObj(); /* ASSERT: true [Bug 1789819]*/ for (window_ptr = windows; *window_ptr ; window_ptr++) { Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj((*window_ptr)->pathName, -1)); } ckfree(windows); Tcl_SetObjResult(interp, resultObj); return TCL_OK; } } else { Tk_Window relWin; TkWindow *winPtr2; int index1=-1, index2=-1, result; if (TkGetWindowFromObj(interp, tkwin, objv[4], &relWin) != TCL_OK) { return TCL_ERROR; } winPtr2 = (TkWindow *) relWin; if (!Tk_IsTopLevel(winPtr2)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "window \"%s\" isn't a top-level window", winPtr2->pathName)); Tcl_SetErrorCode(interp, "TK", "WM", "STACK", "TOPLEVEL", NULL); return TCL_ERROR; } if (!Tk_IsMapped(winPtr)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "window \"%s\" isn't mapped", winPtr->pathName)); Tcl_SetErrorCode(interp, "TK", "WM", "STACK", "MAPPED", NULL); return TCL_ERROR; } if (!Tk_IsMapped(winPtr2)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "window \"%s\" isn't mapped", winPtr2->pathName)); Tcl_SetErrorCode(interp, "TK", "WM", "STACK", "MAPPED", NULL); return TCL_ERROR; } /* * Lookup stacking order of all toplevels that are children of "." and * find the position of winPtr and winPtr2 in the stacking order. */ windows = TkWmStackorderToplevel(winPtr->mainPtr->winPtr); if (windows == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "TkWmStackorderToplevel failed", -1)); Tcl_SetErrorCode(interp, "TK", "WM", "COMMUNICATION", NULL); return TCL_ERROR; } for (window_ptr = windows; *window_ptr ; window_ptr++) { if (*window_ptr == winPtr) { index1 = (window_ptr - windows); } if (*window_ptr == winPtr2) { index2 = (window_ptr - windows); } } /* ASSERT: index1 != -1 && index2 != -2 [Bug 1789819] */ ckfree(windows); if (Tcl_GetIndexFromObjStruct(interp, objv[3], optionStrings, sizeof(char *), "argument", 0, &index) != TCL_OK) { return TCL_ERROR; } if (index == OPT_ISABOVE) { result = index1 > index2; } else { /* OPT_ISBELOW */ result = index1 < index2; } Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); return TCL_OK; } return TCL_OK; } /* *---------------------------------------------------------------------- * * WmStateCmd -- * * This function is invoked to process the "wm state" Tcl command. See * the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int WmStateCmd( Tk_Window tkwin, /* Main window of the application. */ TkWindow *winPtr, /* Toplevel to work with */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { register WmInfo *wmPtr = winPtr->wmInfoPtr; static const char *const optionStrings[] = { "normal", "iconic", "withdrawn", NULL }; enum options { OPT_NORMAL, OPT_ICONIC, OPT_WITHDRAWN }; int index; if ((objc < 3) || (objc > 4)) { Tcl_WrongNumArgs(interp, 2, objv, "window ?state?"); return TCL_ERROR; } if (objc == 4) { if (wmPtr->iconFor != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't change state of %s: it is an icon for %s", Tcl_GetString(objv[2]), Tk_PathName(wmPtr->iconFor))); Tcl_SetErrorCode(interp, "TK", "WM", "STATE", "ICON", NULL); return TCL_ERROR; } if (Tcl_GetIndexFromObjStruct(interp, objv[3], optionStrings, sizeof(char *), "argument", 0, &index) != TCL_OK) { return TCL_ERROR; } if (index == OPT_NORMAL) { wmPtr->flags &= ~WM_WITHDRAWN; (void) TkpWmSetState(winPtr, NormalState); } else if (index == OPT_ICONIC) { if (Tk_Attributes((Tk_Window) winPtr)->override_redirect) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't iconify \"%s\": override-redirect flag is set", winPtr->pathName)); Tcl_SetErrorCode(interp, "TK", "WM", "STATE", "OVERRIDE_REDIRECT", NULL); return TCL_ERROR; } if (wmPtr->masterPtr != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't iconify \"%s\": it is a transient", winPtr->pathName)); Tcl_SetErrorCode(interp, "TK", "WM", "STATE", "TRANSIENT", NULL); return TCL_ERROR; } if (TkpWmSetState(winPtr, IconicState) == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "couldn't send iconify message to window manager", -1)); Tcl_SetErrorCode(interp, "TK", "WM", "COMMUNICATION", NULL); return TCL_ERROR; } } else { /* OPT_WITHDRAWN */ wmPtr->flags |= WM_WITHDRAWN; if (TkpWmSetState(winPtr, WithdrawnState) == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "couldn't send withdraw message to window manager", -1)); Tcl_SetErrorCode(interp, "TK", "WM", "COMMUNICATION", NULL); return TCL_ERROR; } } } else { const char *state; if (wmPtr->iconFor != NULL) { state = "icon"; } else if (wmPtr->withdrawn) { state = "withdrawn"; } else if (Tk_IsMapped((Tk_Window) winPtr) || ((wmPtr->flags & WM_NEVER_MAPPED) && (wmPtr->hints.initial_state == NormalState))) { state = "normal"; } else { state = "iconic"; } Tcl_SetObjResult(interp, Tcl_NewStringObj(state, -1)); } return TCL_OK; } /* *---------------------------------------------------------------------- * * WmTitleCmd -- * * This function is invoked to process the "wm title" Tcl command. See * the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int WmTitleCmd( Tk_Window tkwin, /* Main window of the application. */ TkWindow *winPtr, /* Toplevel to work with */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { register WmInfo *wmPtr = winPtr->wmInfoPtr; const char *argv3; int length; if (objc > 4) { Tcl_WrongNumArgs(interp, 2, objv, "window ?newTitle?"); return TCL_ERROR; } if (objc == 3) { if (wmPtr->title) { Tcl_SetObjResult(interp, Tcl_NewStringObj(wmPtr->title, -1)); } else { Tcl_SetObjResult(interp, Tcl_NewStringObj(winPtr->nameUid, -1)); } } else { if (wmPtr->title != NULL) { ckfree(wmPtr->title); } argv3 = Tcl_GetStringFromObj(objv[3], &length); wmPtr->title = ckalloc(length + 1); strcpy(wmPtr->title, argv3); if (!(wmPtr->flags & WM_NEVER_MAPPED)) { UpdateTitle(winPtr); } } return TCL_OK; } /* *---------------------------------------------------------------------- * * WmTransientCmd -- * * This function is invoked to process the "wm transient" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int WmTransientCmd( Tk_Window tkwin, /* Main window of the application. */ TkWindow *winPtr, /* Toplevel to work with */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { register WmInfo *wmPtr = winPtr->wmInfoPtr; TkWindow *masterPtr = wmPtr->masterPtr; WmInfo *wmPtr2; if ((objc != 3) && (objc != 4)) { Tcl_WrongNumArgs(interp, 2, objv, "window ?master?"); return TCL_ERROR; } if (objc == 3) { if (masterPtr != NULL) { Tcl_SetObjResult(interp, TkNewWindowObj((Tk_Window) masterPtr)); } return TCL_OK; } if (Tcl_GetString(objv[3])[0] == '\0') { if (masterPtr != NULL) { /* * If we had a master, tell them that we aren't tied to them * anymore */ masterPtr->wmInfoPtr->numTransients--; Tk_DeleteEventHandler((Tk_Window) masterPtr, StructureNotifyMask, WmWaitMapProc, winPtr); /* * FIXME: Need a call like Win32's UpdateWrapper() so we can * recreate the wrapper and get rid of the transient window * decorations. */ } wmPtr->masterPtr = NULL; } else { Tk_Window masterWin; if (TkGetWindowFromObj(interp, tkwin, objv[3], &masterWin)!=TCL_OK) { return TCL_ERROR; } masterPtr = (TkWindow *) masterWin; while (!Tk_TopWinHierarchy(masterPtr)) { /* * Ensure that the master window is actually a Tk toplevel. */ masterPtr = masterPtr->parentPtr; } Tk_MakeWindowExist((Tk_Window) masterPtr); if (wmPtr->iconFor != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't make \"%s\" a transient: it is an icon for %s", Tcl_GetString(objv[2]), Tk_PathName(wmPtr->iconFor))); Tcl_SetErrorCode(interp, "TK", "WM", "TRANSIENT", "ICON", NULL); return TCL_ERROR; } wmPtr2 = masterPtr->wmInfoPtr; if (wmPtr2->wrapperPtr == NULL) { CreateWrapper(wmPtr2); } if (wmPtr2->iconFor != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't make \"%s\" a master: it is an icon for %s", Tcl_GetString(objv[3]), Tk_PathName(wmPtr2->iconFor))); Tcl_SetErrorCode(interp, "TK", "WM", "TRANSIENT", "ICON", NULL); return TCL_ERROR; } if (masterPtr == winPtr) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't make \"%s\" its own master", Tk_PathName(winPtr))); Tcl_SetErrorCode(interp, "TK", "WM", "TRANSIENT", "SELF", NULL); return TCL_ERROR; } else if (masterPtr != wmPtr->masterPtr) { /* * Remove old master map/unmap binding before setting the new * master. The event handler will ensure that transient states * reflect the state of the master. */ if (wmPtr->masterPtr != NULL) { wmPtr->masterPtr->wmInfoPtr->numTransients--; Tk_DeleteEventHandler((Tk_Window) wmPtr->masterPtr, StructureNotifyMask, WmWaitMapProc, winPtr); } masterPtr->wmInfoPtr->numTransients++; Tk_CreateEventHandler((Tk_Window) masterPtr, StructureNotifyMask, WmWaitMapProc, winPtr); wmPtr->masterPtr = masterPtr; } } if (!(wmPtr->flags & WM_NEVER_MAPPED)) { if (wmPtr->masterPtr != NULL && !Tk_IsMapped(wmPtr->masterPtr)) { if (TkpWmSetState(winPtr, WithdrawnState) == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "couldn't send withdraw message to window manager", -1)); Tcl_SetErrorCode(interp, "TK", "WM", "COMMUNICATION", NULL); return TCL_ERROR; } } else { if (wmPtr->masterPtr != NULL) { XSetTransientForHint(winPtr->display, wmPtr->wrapperPtr->window, wmPtr->masterPtr->wmInfoPtr->wrapperPtr->window); } else { XDeleteProperty(winPtr->display, wmPtr->wrapperPtr->window, Tk_InternAtom((Tk_Window) winPtr,"WM_TRANSIENT_FOR")); } } } return TCL_OK; } /* *---------------------------------------------------------------------- * * WmWithdrawCmd -- * * This function is invoked to process the "wm withdraw" Tcl command. See * the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int WmWithdrawCmd( Tk_Window tkwin, /* Main window of the application. */ TkWindow *winPtr, /* Toplevel to work with */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { register WmInfo *wmPtr = winPtr->wmInfoPtr; if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "window"); return TCL_ERROR; } if (wmPtr->iconFor != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't withdraw %s: it is an icon for %s", Tcl_GetString(objv[2]), Tk_PathName(wmPtr->iconFor))); Tcl_SetErrorCode(interp, "TK", "WM", "WITHDRAW", "ICON", NULL); return TCL_ERROR; } wmPtr->flags |= WM_WITHDRAWN; if (TkpWmSetState(winPtr, WithdrawnState) == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "couldn't send withdraw message to window manager", -1)); Tcl_SetErrorCode(interp, "TK", "WM", "COMMUNICATION", NULL); return TCL_ERROR; } return TCL_OK; } /* * Invoked by those wm subcommands that affect geometry. Schedules a geometry * update. */ static void WmUpdateGeom( WmInfo *wmPtr, TkWindow *winPtr) { if (!(wmPtr->flags & (WM_UPDATE_PENDING|WM_NEVER_MAPPED))) { Tcl_DoWhenIdle(UpdateGeometryInfo, winPtr); wmPtr->flags |= WM_UPDATE_PENDING; } } /* * Invoked when a MapNotify or UnmapNotify event is delivered for a toplevel * that is the master of a transient toplevel. */ static void WmWaitMapProc( ClientData clientData, /* Pointer to window. */ XEvent *eventPtr) /* Information about event. */ { TkWindow *winPtr = clientData; TkWindow *masterPtr = winPtr->wmInfoPtr->masterPtr; if (masterPtr == NULL) { return; } if (eventPtr->type == MapNotify) { if (!(winPtr->wmInfoPtr->flags & WM_WITHDRAWN)) { (void) TkpWmSetState(winPtr, NormalState); } } else if (eventPtr->type == UnmapNotify) { (void) TkpWmSetState(winPtr, WithdrawnState); } } /* *---------------------------------------------------------------------- * * Tk_SetGrid -- * * This function is invoked by a widget when it wishes to set a grid * coordinate system that controls the size of a top-level window. It * provides a C interface equivalent to the "wm grid" command and is * usually associated with the -setgrid option. * * Results: * None. * * Side effects: * Grid-related information will be passed to the window manager, so that * the top-level window associated with tkwin will resize on even grid * units. If some other window already controls gridding for the * top-level window then this function call has no effect. * *---------------------------------------------------------------------- */ void Tk_SetGrid( Tk_Window tkwin, /* Token for window. New window mgr info will * be posted for the top-level window * associated with this window. */ int reqWidth, /* Width (in grid units) corresponding to the * requested geometry for tkwin. */ int reqHeight, /* Height (in grid units) corresponding to the * requested geometry for tkwin. */ int widthInc, int heightInc)/* Pixel increments corresponding to a change * of one grid unit. */ { TkWindow *winPtr = (TkWindow *) tkwin; register WmInfo *wmPtr; /* * Ensure widthInc and heightInc are greater than 0 */ if (widthInc <= 0) { widthInc = 1; } if (heightInc <= 0) { heightInc = 1; } /* * Find the top-level window for tkwin, plus the window manager * information. */ while (!(winPtr->flags & TK_TOP_HIERARCHY)) { winPtr = winPtr->parentPtr; if (winPtr == NULL) { /* * The window is being deleted... just skip this operation. */ return; } } wmPtr = winPtr->wmInfoPtr; if (wmPtr == NULL) { return; } if ((wmPtr->gridWin != NULL) && (wmPtr->gridWin != tkwin)) { return; } if ((wmPtr->reqGridWidth == reqWidth) && (wmPtr->reqGridHeight == reqHeight) && (wmPtr->widthInc == widthInc) && (wmPtr->heightInc == heightInc) && ((wmPtr->sizeHintsFlags & (PBaseSize|PResizeInc)) == (PBaseSize|PResizeInc))) { return; } /* * If gridding was previously off, then forget about any window size * requests made by the user or via "wm geometry": these are in pixel * units and there's no easy way to translate them to grid units since the * new requested size of the top-level window in pixels may not yet have * been registered yet (it may filter up the hierarchy in DoWhenIdle * handlers). However, if the window has never been mapped yet then just * leave the window size alone: assume that it is intended to be in grid * units but just happened to have been specified before this function was * called. */ if ((wmPtr->gridWin == NULL) && !(wmPtr->flags & WM_NEVER_MAPPED)) { wmPtr->width = -1; wmPtr->height = -1; } /* * Set the new gridding information, and start the process of passing all * of this information to the window manager. */ wmPtr->gridWin = tkwin; wmPtr->reqGridWidth = reqWidth; wmPtr->reqGridHeight = reqHeight; wmPtr->widthInc = widthInc; wmPtr->heightInc = heightInc; wmPtr->sizeHintsFlags |= PBaseSize|PResizeInc; wmPtr->flags |= WM_UPDATE_SIZE_HINTS; if (!(wmPtr->flags & (WM_UPDATE_PENDING|WM_NEVER_MAPPED))) { Tcl_DoWhenIdle(UpdateGeometryInfo, winPtr); wmPtr->flags |= WM_UPDATE_PENDING; } } /* *---------------------------------------------------------------------- * * Tk_UnsetGrid -- * * This function cancels the effect of a previous call to Tk_SetGrid. * * Results: * None. * * Side effects: * If tkwin currently controls gridding for its top-level window, * gridding is cancelled for that top-level window; if some other window * controls gridding then this function has no effect. * *---------------------------------------------------------------------- */ void Tk_UnsetGrid( Tk_Window tkwin) /* Token for window that is currently * controlling gridding. */ { TkWindow *winPtr = (TkWindow *) tkwin; register WmInfo *wmPtr; /* * Find the top-level window for tkwin, plus the window manager * information. */ while (!(winPtr->flags & TK_TOP_HIERARCHY)) { winPtr = winPtr->parentPtr; if (winPtr == NULL) { /* * The window is being deleted... just skip this operation. */ return; } } wmPtr = winPtr->wmInfoPtr; if (wmPtr == NULL) { return; } if (tkwin != wmPtr->gridWin) { return; } wmPtr->gridWin = NULL; wmPtr->sizeHintsFlags &= ~(PBaseSize|PResizeInc); if (wmPtr->width != -1) { wmPtr->width = winPtr->reqWidth + (wmPtr->width - wmPtr->reqGridWidth)*wmPtr->widthInc; wmPtr->height = winPtr->reqHeight + (wmPtr->height - wmPtr->reqGridHeight)*wmPtr->heightInc; } wmPtr->widthInc = 1; wmPtr->heightInc = 1; wmPtr->flags |= WM_UPDATE_SIZE_HINTS; if (!(wmPtr->flags & (WM_UPDATE_PENDING|WM_NEVER_MAPPED))) { Tcl_DoWhenIdle(UpdateGeometryInfo, winPtr); wmPtr->flags |= WM_UPDATE_PENDING; } } /* *---------------------------------------------------------------------- * * ConfigureEvent -- * * This function is called to handle ConfigureNotify events on wrapper * windows. * * Results: * None. * * Side effects: * Information gets updated in the WmInfo structure for the window and * the toplevel itself gets repositioned within the wrapper. * *---------------------------------------------------------------------- */ static void ConfigureEvent( WmInfo *wmPtr, /* Information about toplevel window. */ XConfigureEvent *configEventPtr) /* Event that just occurred for * wmPtr->wrapperPtr. */ { TkWindow *wrapperPtr = wmPtr->wrapperPtr; TkWindow *winPtr = wmPtr->winPtr; TkDisplay *dispPtr = wmPtr->winPtr->dispPtr; Tk_ErrorHandler handler; /* * Update size information from the event. There are a couple of tricky * points here: * * 1. If the user changed the size externally then set wmPtr->width and * wmPtr->height just as if a "wm geometry" command had been invoked * with the same information. * 2. However, if the size is changing in response to a request coming * from us (WM_SYNC_PENDING is set), then don't set wmPtr->width or * wmPtr->height if they were previously -1 (otherwise the window will * stop tracking geometry manager requests). */ if (((wrapperPtr->changes.width != configEventPtr->width) || (wrapperPtr->changes.height != configEventPtr->height)) && !(wmPtr->flags & WM_SYNC_PENDING)) { if (dispPtr->flags & TK_DISPLAY_WM_TRACING) { printf("TopLevelEventProc: user changed %s size to %dx%d\n", winPtr->pathName, configEventPtr->width, configEventPtr->height); } if ((wmPtr->width == -1) && (configEventPtr->width == winPtr->reqWidth)) { /* * Don't set external width, since the user didn't change it from * what the widgets asked for. */ } else { /* * Note: if this window is embedded then don't set the external * size, since it came from the containing application, not the * user. In this case we want to keep sending our size requests to * the containing application; if the user fixes the size of that * application then it will still percolate down to us in the * right way. */ if (!(winPtr->flags & TK_EMBEDDED)) { if (wmPtr->gridWin != NULL) { wmPtr->width = wmPtr->reqGridWidth + (configEventPtr->width - winPtr->reqWidth)/wmPtr->widthInc; if (wmPtr->width < 0) { wmPtr->width = 0; } } else { wmPtr->width = configEventPtr->width; } } } if ((wmPtr->height == -1) && (configEventPtr->height == (winPtr->reqHeight + wmPtr->menuHeight))) { /* * Don't set external height, since the user didn't change it from * what the widgets asked for. */ } else { /* * See note for wmPtr->width about not setting external size for * embedded windows. */ if (!(winPtr->flags & TK_EMBEDDED)) { if (wmPtr->gridWin != NULL) { wmPtr->height = wmPtr->reqGridHeight + (configEventPtr->height - wmPtr->menuHeight - winPtr->reqHeight)/wmPtr->heightInc; if (wmPtr->height < 0) { wmPtr->height = 0; } } else { wmPtr->height = configEventPtr->height - wmPtr->menuHeight; } } } wmPtr->configWidth = configEventPtr->width; wmPtr->configHeight = configEventPtr->height; } if (dispPtr->flags & TK_DISPLAY_WM_TRACING) { printf("ConfigureEvent: %s x = %d y = %d, width = %d, height = %d\n", winPtr->pathName, configEventPtr->x, configEventPtr->y, configEventPtr->width, configEventPtr->height); printf(" send_event = %d, serial = %ld (win %p, wrapper %p)\n", configEventPtr->send_event, configEventPtr->serial, winPtr, wrapperPtr); } wrapperPtr->changes.width = configEventPtr->width; wrapperPtr->changes.height = configEventPtr->height; wrapperPtr->changes.border_width = configEventPtr->border_width; wrapperPtr->changes.sibling = configEventPtr->above; wrapperPtr->changes.stack_mode = Above; /* * Reparenting window managers make life difficult. If the window manager * reparents a top-level window then the x and y information that comes in * events for the window is wrong: it gives the location of the window * inside its decorative parent, rather than the location of the window in * root coordinates, which is what we want. Window managers are supposed * to send synthetic events with the correct information, but ICCCM * doesn't require them to do this under all conditions, and the * information provided doesn't include everything we need here. So, the * code below maintains a bunch of information about the parent window. * If the window hasn't been reparented, we pretend that there is a parent * shrink-wrapped around the window. */ if (dispPtr->flags & TK_DISPLAY_WM_TRACING) { printf(" %s parent == %p, above %p\n", winPtr->pathName, (void *) wmPtr->reparent, (void *) configEventPtr->above); } if ((wmPtr->reparent == None) || !ComputeReparentGeometry(wmPtr)) { wmPtr->parentWidth = configEventPtr->width + 2*configEventPtr->border_width; wmPtr->parentHeight = configEventPtr->height + 2*configEventPtr->border_width; wrapperPtr->changes.x = wmPtr->x = configEventPtr->x; wrapperPtr->changes.y = wmPtr->y = configEventPtr->y; if (wmPtr->flags & WM_NEGATIVE_X) { wmPtr->x = wmPtr->vRootWidth - (wmPtr->x + wmPtr->parentWidth); } if (wmPtr->flags & WM_NEGATIVE_Y) { wmPtr->y = wmPtr->vRootHeight - (wmPtr->y + wmPtr->parentHeight); } } /* * Make sure that the toplevel and menubar are properly positioned within * the wrapper. If the menuHeight happens to be zero, we'll get a BadValue * X error that we want to ignore [Bug: 3377] */ handler = Tk_CreateErrorHandler(winPtr->display, -1, -1, -1, NULL, NULL); XMoveResizeWindow(winPtr->display, winPtr->window, 0, wmPtr->menuHeight, (unsigned) wrapperPtr->changes.width, (unsigned) (wrapperPtr->changes.height - wmPtr->menuHeight)); Tk_DeleteErrorHandler(handler); if ((wmPtr->menubar != NULL) && ((Tk_Width(wmPtr->menubar) != wrapperPtr->changes.width) || (Tk_Height(wmPtr->menubar) != wmPtr->menuHeight))) { Tk_MoveResizeWindow(wmPtr->menubar, 0, 0, wrapperPtr->changes.width, wmPtr->menuHeight); } /* * Update the coordinates in the toplevel (they should refer to the * position in root window coordinates, not the coordinates of the wrapper * window). Then synthesize a ConfigureNotify event to tell the * application about the change. */ winPtr->changes.x = wrapperPtr->changes.x; winPtr->changes.y = wrapperPtr->changes.y + wmPtr->menuHeight; winPtr->changes.width = wrapperPtr->changes.width; winPtr->changes.height = wrapperPtr->changes.height - wmPtr->menuHeight; TkDoConfigureNotify(winPtr); } /* *---------------------------------------------------------------------- * * ReparentEvent -- * * This function is called to handle ReparentNotify events on wrapper * windows. * * Results: * None. * * Side effects: * Information gets updated in the WmInfo structure for the window. * *---------------------------------------------------------------------- */ static void ReparentEvent( WmInfo *wmPtr, /* Information about toplevel window. */ XReparentEvent *reparentEventPtr) /* Event that just occurred for * wmPtr->wrapperPtr. */ { TkWindow *wrapperPtr = wmPtr->wrapperPtr; Window vRoot, ancestor, *children, dummy2, *virtualRootPtr, **vrPtrPtr; Atom actualType; int actualFormat; unsigned long numItems, bytesAfter; unsigned dummy; Tk_ErrorHandler handler; TkDisplay *dispPtr = wmPtr->winPtr->dispPtr; Atom WM_ROOT = Tk_InternAtom((Tk_Window) wrapperPtr, "__WM_ROOT"); Atom SWM_ROOT = Tk_InternAtom((Tk_Window) wrapperPtr, "__SWM_ROOT"); /* * Identify the root window for wrapperPtr. This is tricky because of * virtual root window managers like tvtwm. If the window has a property * named __SWM_ROOT or __WM_ROOT then this property gives the id for a * virtual root window that should be used instead of the root window of * the screen. */ vRoot = RootWindow(wrapperPtr->display, wrapperPtr->screenNum); wmPtr->vRoot = None; handler = Tk_CreateErrorHandler(wrapperPtr->display, -1,-1,-1, NULL,NULL); vrPtrPtr = &virtualRootPtr; /* Silence GCC warning */ if ((GetWindowProperty(wrapperPtr, WM_ROOT, 1, XA_WINDOW, &actualType, &actualFormat, &numItems, &bytesAfter, vrPtrPtr) && (actualType == XA_WINDOW)) || (GetWindowProperty(wrapperPtr, SWM_ROOT, 1, XA_WINDOW, &actualType, &actualFormat, &numItems, &bytesAfter, vrPtrPtr) && (actualType == XA_WINDOW))) { if ((actualFormat == 32) && (numItems == 1)) { vRoot = wmPtr->vRoot = *virtualRootPtr; } else if (dispPtr->flags & TK_DISPLAY_WM_TRACING) { printf("%s format %d numItems %ld\n", "ReparentEvent got bogus VROOT property:", actualFormat, numItems); } XFree((char *) virtualRootPtr); } Tk_DeleteErrorHandler(handler); if (dispPtr->flags & TK_DISPLAY_WM_TRACING) { printf("ReparentEvent: %s (%p) reparented to 0x%x, vRoot = 0x%x\n", wmPtr->winPtr->pathName, wmPtr->winPtr, (unsigned) reparentEventPtr->parent, (unsigned) vRoot); } /* * Fetch correct geometry information for the new virtual root. */ UpdateVRootGeometry(wmPtr); /* * If the window's new parent is the root window, then mark it as no * longer reparented. */ if (reparentEventPtr->parent == vRoot) { noReparent: wmPtr->reparent = None; wmPtr->parentWidth = wrapperPtr->changes.width; wmPtr->parentHeight = wrapperPtr->changes.height; wmPtr->xInParent = wmPtr->yInParent = 0; wrapperPtr->changes.x = reparentEventPtr->x; wrapperPtr->changes.y = reparentEventPtr->y; wmPtr->winPtr->changes.x = reparentEventPtr->x; wmPtr->winPtr->changes.y = reparentEventPtr->y + wmPtr->menuHeight; return; } /* * Search up the window hierarchy to find the ancestor of this window that * is just below the (virtual) root. This is tricky because it's possible * that things have changed since the event was generated so that the * ancestry indicated by the event no longer exists. If this happens then * an error will occur and we just discard the event (there will be a more * up-to-date ReparentNotify event coming later). */ handler = Tk_CreateErrorHandler(wrapperPtr->display, -1,-1,-1, NULL,NULL); wmPtr->reparent = reparentEventPtr->parent; while (1) { if (XQueryTree(wrapperPtr->display, wmPtr->reparent, &dummy2, &ancestor, &children, &dummy) == 0) { Tk_DeleteErrorHandler(handler); goto noReparent; } XFree((char *) children); if ((ancestor == vRoot) || (ancestor == RootWindow(wrapperPtr->display, wrapperPtr->screenNum))) { break; } wmPtr->reparent = ancestor; } Tk_DeleteErrorHandler(handler); if (!ComputeReparentGeometry(wmPtr)) { goto noReparent; } } /* *---------------------------------------------------------------------- * * ComputeReparentGeometry -- * * This function is invoked to recompute geometry information related to * a reparented top-level window, such as the position and total size of * the parent and the position within it of the top-level window. * * Results: * The return value is 1 if everything completed successfully and 0 if an * error occurred while querying information about winPtr's parents. In * this case winPtr is marked as no longer being reparented. * * Side effects: * Geometry information in wmPtr, wmPtr->winPtr, and wmPtr->wrapperPtr * gets updated. * *---------------------------------------------------------------------- */ static int ComputeReparentGeometry( WmInfo *wmPtr) /* Information about toplevel window whose * reparent info is to be recomputed. */ { TkWindow *wrapperPtr = wmPtr->wrapperPtr; int width, height, bd; unsigned dummy; int xOffset, yOffset, x, y; Window dummy2; Status status; Tk_ErrorHandler handler; TkDisplay *dispPtr = wmPtr->winPtr->dispPtr; handler = Tk_CreateErrorHandler(wrapperPtr->display, -1,-1,-1, NULL,NULL); (void) XTranslateCoordinates(wrapperPtr->display, wrapperPtr->window, wmPtr->reparent, 0, 0, &xOffset, &yOffset, &dummy2); status = XGetGeometry(wrapperPtr->display, wmPtr->reparent, &dummy2, &x, &y, (unsigned *) &width, (unsigned *) &height, (unsigned *) &bd, &dummy); Tk_DeleteErrorHandler(handler); if (status == 0) { /* * It appears that the reparented parent went away and no-one told us. * Reset the window to indicate that it's not reparented. */ wmPtr->reparent = None; wmPtr->xInParent = wmPtr->yInParent = 0; return 0; } wmPtr->xInParent = xOffset + bd; wmPtr->yInParent = yOffset + bd; wmPtr->parentWidth = width + 2*bd; wmPtr->parentHeight = height + 2*bd; /* * Some tricky issues in updating wmPtr->x and wmPtr->y: * * 1. Don't update them if the event occurred because of something we did * (i.e. WM_SYNC_PENDING and WM_MOVE_PENDING are both set). This is * because window managers treat coords differently than Tk, and no two * window managers are alike. If the window manager moved the window * because we told it to, remember the coordinates we told it, not the * ones it actually moved it to. This allows us to move the window back to * the same coordinates later and get the same result. Without this check, * windows can "walk" across the screen under some conditions. * * 2. Don't update wmPtr->x and wmPtr->y unless wrapperPtr->changes.x or * wrapperPtr->changes.y has changed (otherwise a size change can spoof us * into thinking that the position changed too and defeat the intent of * (1) above. * * (As of 9/96 the above 2 comments appear to be stale. They're being left * in place as a reminder of what was once true (and perhaps should still * be true?)). * * 3. Ignore size changes coming from the window system if we're about to * change the size ourselves but haven't seen the event for it yet: our * size change is supposed to take priority. */ if (!(wmPtr->flags & WM_MOVE_PENDING) && ((wrapperPtr->changes.x != (x + wmPtr->xInParent)) || (wrapperPtr->changes.y != (y + wmPtr->yInParent)))) { wmPtr->x = x; if (wmPtr->flags & WM_NEGATIVE_X) { wmPtr->x = wmPtr->vRootWidth - (wmPtr->x + wmPtr->parentWidth); } wmPtr->y = y; if (wmPtr->flags & WM_NEGATIVE_Y) { wmPtr->y = wmPtr->vRootHeight - (wmPtr->y + wmPtr->parentHeight); } } wrapperPtr->changes.x = x + wmPtr->xInParent; wrapperPtr->changes.y = y + wmPtr->yInParent; if (dispPtr->flags & TK_DISPLAY_WM_TRACING) { printf("wrapperPtr %p coords %d,%d\n", wrapperPtr, wrapperPtr->changes.x, wrapperPtr->changes.y); printf(" wmPtr %p coords %d,%d, offsets %d %d\n", wmPtr, wmPtr->x, wmPtr->y, wmPtr->xInParent, wmPtr->yInParent); } return 1; } /* *---------------------------------------------------------------------- * * PropertyEvent -- * * Handle PropertyNotify events on wrapper windows. The following * properties are of interest: * * _NET_WM_STATE: * Used to keep wmPtr->attributes up to date. * *---------------------------------------------------------------------- */ static void PropertyEvent( WmInfo *wmPtr, /* Information about toplevel window. */ XPropertyEvent *eventPtr) /* PropertyNotify event structure */ { TkWindow *wrapperPtr = wmPtr->wrapperPtr; Atom _NET_WM_STATE = Tk_InternAtom((Tk_Window) wmPtr->winPtr, "_NET_WM_STATE"); if (eventPtr->atom == _NET_WM_STATE) { Atom actualType; int actualFormat; unsigned long numItems, bytesAfter; unsigned char *propertyValue = 0; long maxLength = 1024; if (GetWindowProperty(wrapperPtr, _NET_WM_STATE, maxLength, XA_ATOM, &actualType, &actualFormat, &numItems, &bytesAfter, &propertyValue)) { CheckNetWmState(wmPtr, (Atom *) propertyValue, (int) numItems); XFree(propertyValue); } } } /* *---------------------------------------------------------------------- * * WrapperEventProc -- * * This function is invoked by the event loop when a wrapper window is * restructured. * * Results: * None. * * Side effects: * Tk's internal data structures for the window get modified to reflect * the structural change. * *---------------------------------------------------------------------- */ static const unsigned WrapperEventMask = (StructureNotifyMask | PropertyChangeMask); static void WrapperEventProc( ClientData clientData, /* Information about toplevel window. */ XEvent *eventPtr) /* Event that just happened. */ { WmInfo *wmPtr = clientData; XEvent mapEvent; TkDisplay *dispPtr = wmPtr->winPtr->dispPtr; wmPtr->flags |= WM_VROOT_OFFSET_STALE; if (eventPtr->type == DestroyNotify) { Tk_ErrorHandler handler; if (!(wmPtr->wrapperPtr->flags & TK_ALREADY_DEAD)) { /* * A top-level window was deleted externally (e.g., by the window * manager). This is probably not a good thing, but cleanup as * best we can. The error handler is needed because * Tk_DestroyWindow will try to destroy the window, but of course * it's already gone. */ handler = Tk_CreateErrorHandler(wmPtr->winPtr->display, -1, -1, -1, NULL, NULL); Tk_DestroyWindow((Tk_Window) wmPtr->winPtr); Tk_DeleteErrorHandler(handler); } if (dispPtr->flags & TK_DISPLAY_WM_TRACING) { printf("TopLevelEventProc: %s deleted\n", wmPtr->winPtr->pathName); } } else if (eventPtr->type == ConfigureNotify) { /* * Ignore the event if the window has never been mapped yet. Such an * event occurs only in weird cases like changing the internal border * width of a top-level window, which results in a synthetic Configure * event. These events are not relevant to us, and if we process them * confusion may result (e.g. we may conclude erroneously that the * user repositioned or resized the window). */ if (!(wmPtr->flags & WM_NEVER_MAPPED)) { ConfigureEvent(wmPtr, &eventPtr->xconfigure); } } else if (eventPtr->type == MapNotify) { wmPtr->wrapperPtr->flags |= TK_MAPPED; wmPtr->winPtr->flags |= TK_MAPPED; XMapWindow(wmPtr->winPtr->display, wmPtr->winPtr->window); goto doMapEvent; } else if (eventPtr->type == UnmapNotify) { wmPtr->wrapperPtr->flags &= ~TK_MAPPED; wmPtr->winPtr->flags &= ~TK_MAPPED; XUnmapWindow(wmPtr->winPtr->display, wmPtr->winPtr->window); goto doMapEvent; } else if (eventPtr->type == ReparentNotify) { ReparentEvent(wmPtr, &eventPtr->xreparent); } else if (eventPtr->type == PropertyNotify) { PropertyEvent(wmPtr, &eventPtr->xproperty); } return; doMapEvent: mapEvent = *eventPtr; mapEvent.xmap.event = wmPtr->winPtr->window; mapEvent.xmap.window = wmPtr->winPtr->window; Tk_HandleEvent(&mapEvent); } /* *---------------------------------------------------------------------- * * TopLevelReqProc -- * * This function is invoked by the geometry manager whenever the * requested size for a top-level window is changed. * * Results: * None. * * Side effects: * Arrange for the window to be resized to satisfy the request (this * happens as a when-idle action). * *---------------------------------------------------------------------- */ /* ARGSUSED */ static void TopLevelReqProc( ClientData dummy, /* Not used. */ Tk_Window tkwin) /* Information about window. */ { TkWindow *winPtr = (TkWindow *) tkwin; WmInfo *wmPtr = winPtr->wmInfoPtr; if (wmPtr == NULL) { return; } if ((wmPtr->width >= 0) && (wmPtr->height >= 0)) { /* * Explicit dimensions have been set for this window, so we should * ignore the geometry request. It's actually important to ignore the * geometry request because, due to quirks in window managers, * invoking UpdateGeometryInfo may cause the window to move. For * example, if "wm geometry -10-20" was invoked, the window may be * positioned incorrectly the first time it appears (because we didn't * know the proper width of the window manager borders); if we invoke * UpdateGeometryInfo again, the window will be positioned correctly, * which may cause it to jump on the screen. */ return; } wmPtr->flags |= WM_UPDATE_SIZE_HINTS; if (!(wmPtr->flags & (WM_UPDATE_PENDING|WM_NEVER_MAPPED))) { Tcl_DoWhenIdle(UpdateGeometryInfo, winPtr); wmPtr->flags |= WM_UPDATE_PENDING; } /* * If the window isn't being positioned by its upper left corner then we * have to move it as well. */ if (wmPtr->flags & (WM_NEGATIVE_X | WM_NEGATIVE_Y)) { wmPtr->flags |= WM_MOVE_PENDING; } } /* *---------------------------------------------------------------------- * * UpdateGeometryInfo -- * * This function is invoked when a top-level window is first mapped, and * also as a when-idle function, to bring the geometry and/or position of * a top-level window back into line with what has been requested by the * user and/or widgets. This function doesn't return until the window * manager has responded to the geometry change. * * Results: * None. * * Side effects: * The size and location of both the toplevel window and its wrapper may * change, unless the WM prevents that from happening. * *---------------------------------------------------------------------- */ static void UpdateGeometryInfo( ClientData clientData) /* Pointer to the window's record. */ { register TkWindow *winPtr = clientData; register WmInfo *wmPtr = winPtr->wmInfoPtr; int x, y, width, height, min, max; unsigned long serial; wmPtr->flags &= ~WM_UPDATE_PENDING; /* * Compute the new size for the top-level window. See the user * documentation for details on this, but the size requested depends on * (a) the size requested internally by the window's widgets, (b) the size * requested by the user in a "wm geometry" command or via wm-based * interactive resizing (if any), (c) whether or not the window is * gridded, and (d) the current min or max size for the toplevel. Don't * permit sizes <= 0 because this upsets the X server. */ if (wmPtr->width == -1) { width = winPtr->reqWidth; } else if (wmPtr->gridWin != NULL) { width = winPtr->reqWidth + (wmPtr->width - wmPtr->reqGridWidth)*wmPtr->widthInc; } else { width = wmPtr->width; } if (width <= 0) { width = 1; } /* * Account for window max/min width */ if (wmPtr->gridWin != NULL) { min = winPtr->reqWidth + (wmPtr->minWidth - wmPtr->reqGridWidth)*wmPtr->widthInc; if (wmPtr->maxWidth > 0) { max = winPtr->reqWidth + (wmPtr->maxWidth - wmPtr->reqGridWidth)*wmPtr->widthInc; } else { max = 0; } } else { min = wmPtr->minWidth; max = wmPtr->maxWidth; } if (width < min) { width = min; } else if ((max > 0) && (width > max)) { width = max; } if (wmPtr->height == -1) { height = winPtr->reqHeight; } else if (wmPtr->gridWin != NULL) { height = winPtr->reqHeight + (wmPtr->height - wmPtr->reqGridHeight)*wmPtr->heightInc; } else { height = wmPtr->height; } if (height <= 0) { height = 1; } /* * Account for window max/min height */ if (wmPtr->gridWin != NULL) { min = winPtr->reqHeight + (wmPtr->minHeight - wmPtr->reqGridHeight)*wmPtr->heightInc; if (wmPtr->maxHeight > 0) { max = winPtr->reqHeight + (wmPtr->maxHeight - wmPtr->reqGridHeight)*wmPtr->heightInc; } else { max = 0; } } else { min = wmPtr->minHeight; max = wmPtr->maxHeight; } if (height < min) { height = min; } else if ((max > 0) && (height > max)) { height = max; } /* * Compute the new position for the upper-left pixel of the window's * decorative frame. This is tricky, because we need to include the border * widths supplied by a reparented parent in this calculation, but can't * use the parent's current overall size since that may change as a result * of this code. */ if (wmPtr->flags & WM_NEGATIVE_X) { x = wmPtr->vRootWidth - wmPtr->x - (width + (wmPtr->parentWidth - winPtr->changes.width)); } else { x = wmPtr->x; } if (wmPtr->flags & WM_NEGATIVE_Y) { y = wmPtr->vRootHeight - wmPtr->y - (height + (wmPtr->parentHeight - winPtr->changes.height)); } else { y = wmPtr->y; } /* * If the window's size is going to change and the window is supposed to * not be resizable by the user, then we have to update the size hints. * There may also be a size-hint-update request pending from somewhere * else, too. */ if (((width != winPtr->changes.width) || (height != winPtr->changes.height)) && (wmPtr->gridWin == NULL) && !(wmPtr->sizeHintsFlags & (PMinSize|PMaxSize))) { wmPtr->flags |= WM_UPDATE_SIZE_HINTS; } if (wmPtr->flags & WM_UPDATE_SIZE_HINTS) { UpdateSizeHints(winPtr, width, height); } /* * Reconfigure the wrapper if it isn't already configured correctly. A few * tricky points: * * 1. If the window is embedded and the container is also in this process, * don't actually reconfigure the window; just pass the desired size on * to the container. Also, zero out any position information, since * embedded windows are not allowed to move. * 2. Sometimes the window manager will give us a different size than we * asked for (e.g. mwm has a minimum size for windows), so base the * size check on what we *asked for* last time, not what we got. * 3. Can't just reconfigure always, because we may not get a * ConfigureNotify event back if nothing changed, so * WaitForConfigureNotify will hang a long time. * 4. Don't move window unless a new position has been requested for it. * This is because of "features" in some window managers (e.g. twm, as * of 4/24/91) where they don't interpret coordinates according to * ICCCM. Moving a window to its current location may cause it to shift * position on the screen. */ if ((winPtr->flags & (TK_EMBEDDED|TK_BOTH_HALVES)) == (TK_EMBEDDED|TK_BOTH_HALVES)) { TkWindow *childPtr = TkpGetOtherWindow(winPtr); /* * This window is embedded and the container is also in this process, * so we don't need to do anything special about the geometry, except * to make sure that the desired size is known by the container. Also, * zero out any position information, since embedded windows are not * allowed to move. */ wmPtr->x = wmPtr->y = 0; wmPtr->flags &= ~(WM_NEGATIVE_X|WM_NEGATIVE_Y); height += wmPtr->menuHeight; if (childPtr != NULL) { Tk_GeometryRequest((Tk_Window) childPtr, width, height); } return; } serial = NextRequest(winPtr->display); height += wmPtr->menuHeight; if (wmPtr->flags & WM_MOVE_PENDING) { if ((x + wmPtr->xInParent == winPtr->changes.x) && (y+wmPtr->yInParent+wmPtr->menuHeight == winPtr->changes.y) && (width == wmPtr->wrapperPtr->changes.width) && (height == wmPtr->wrapperPtr->changes.height)) { /* * The window already has the correct geometry, so don't bother to * configure it; the X server appears to ignore these requests, so * we won't get back a ConfigureNotify and the * WaitForConfigureNotify call below will hang for a while. */ wmPtr->flags &= ~WM_MOVE_PENDING; return; } wmPtr->configWidth = width; wmPtr->configHeight = height; if (winPtr->dispPtr->flags & TK_DISPLAY_WM_TRACING) { printf("UpdateGeometryInfo moving to %d %d, resizing to %dx%d,\n", x, y, width, height); } XMoveResizeWindow(winPtr->display, wmPtr->wrapperPtr->window, x, y, (unsigned) width, (unsigned) height); } else if ((width != wmPtr->configWidth) || (height != wmPtr->configHeight)) { if ((width == wmPtr->wrapperPtr->changes.width) && (height == wmPtr->wrapperPtr->changes.height)) { /* * The window is already just the size we want, so don't bother to * configure it; the X server appears to ignore these requests, so * we won't get back a ConfigureNotify and the * WaitForConfigureNotify call below will hang for a while. */ return; } wmPtr->configWidth = width; wmPtr->configHeight = height; if (winPtr->dispPtr->flags & TK_DISPLAY_WM_TRACING) { printf("UpdateGeometryInfo resizing %p to %d x %d\n", (void *) wmPtr->wrapperPtr->window, width, height); } XResizeWindow(winPtr->display, wmPtr->wrapperPtr->window, (unsigned) width, (unsigned) height); } else if ((wmPtr->menubar != NULL) && ((Tk_Width(wmPtr->menubar) != wmPtr->wrapperPtr->changes.width) || (Tk_Height(wmPtr->menubar) != wmPtr->menuHeight))) { /* * It is possible that the window's overall size has not changed but * the menu size has. */ Tk_MoveResizeWindow(wmPtr->menubar, 0, 0, wmPtr->wrapperPtr->changes.width, wmPtr->menuHeight); XResizeWindow(winPtr->display, wmPtr->wrapperPtr->window, (unsigned) width, (unsigned) height); } else { return; } /* * Wait for the configure operation to complete. Don't need to do this, * however, if the window is about to be mapped: it will be taken care of * elsewhere. */ if (!(wmPtr->flags & WM_ABOUT_TO_MAP)) { WaitForConfigureNotify(winPtr, serial); } } /* *-------------------------------------------------------------- * * UpdateSizeHints -- * * This function is called to update the window manager's size hints * information from the information in a WmInfo structure. * * Results: * None. * * Side effects: * Properties get changed for winPtr. * *-------------------------------------------------------------- */ static void UpdateSizeHints( TkWindow *winPtr, int newWidth, int newHeight) { register WmInfo *wmPtr = winPtr->wmInfoPtr; XSizeHints *hintsPtr; int maxWidth, maxHeight; wmPtr->flags &= ~WM_UPDATE_SIZE_HINTS; hintsPtr = XAllocSizeHints(); if (hintsPtr == NULL) { return; } /* * Compute the pixel-based sizes for the various fields in the size hints * structure, based on the grid-based sizes in our structure. */ GetMaxSize(wmPtr, &maxWidth, &maxHeight); if (wmPtr->gridWin != NULL) { hintsPtr->base_width = winPtr->reqWidth - (wmPtr->reqGridWidth * wmPtr->widthInc); if (hintsPtr->base_width < 0) { hintsPtr->base_width = 0; } hintsPtr->base_height = winPtr->reqHeight + wmPtr->menuHeight - (wmPtr->reqGridHeight * wmPtr->heightInc); if (hintsPtr->base_height < 0) { hintsPtr->base_height = 0; } hintsPtr->min_width = hintsPtr->base_width + (wmPtr->minWidth * wmPtr->widthInc); hintsPtr->min_height = hintsPtr->base_height + (wmPtr->minHeight * wmPtr->heightInc); hintsPtr->max_width = hintsPtr->base_width + (maxWidth * wmPtr->widthInc); hintsPtr->max_height = hintsPtr->base_height + (maxHeight * wmPtr->heightInc); } else { hintsPtr->min_width = wmPtr->minWidth; hintsPtr->min_height = wmPtr->minHeight; hintsPtr->max_width = maxWidth; hintsPtr->max_height = maxHeight; hintsPtr->base_width = 0; hintsPtr->base_height = 0; } hintsPtr->width_inc = wmPtr->widthInc; hintsPtr->height_inc = wmPtr->heightInc; hintsPtr->min_aspect.x = wmPtr->minAspect.x; hintsPtr->min_aspect.y = wmPtr->minAspect.y; hintsPtr->max_aspect.x = wmPtr->maxAspect.x; hintsPtr->max_aspect.y = wmPtr->maxAspect.y; hintsPtr->win_gravity = wmPtr->gravity; hintsPtr->flags = wmPtr->sizeHintsFlags | PMinSize; /* * If the window isn't supposed to be resizable, then set the minimum and * maximum dimensions to be the same. */ if (wmPtr->flags & WM_WIDTH_NOT_RESIZABLE) { hintsPtr->max_width = hintsPtr->min_width = newWidth; hintsPtr->flags |= PMaxSize; } if (wmPtr->flags & WM_HEIGHT_NOT_RESIZABLE) { hintsPtr->max_height = hintsPtr->min_height = newHeight + wmPtr->menuHeight; hintsPtr->flags |= PMaxSize; } XSetWMNormalHints(winPtr->display, wmPtr->wrapperPtr->window, hintsPtr); XFree((char *) hintsPtr); } /* *-------------------------------------------------------------- * * UpdateTitle -- * * This function is called to update the window title and icon name. It * sets the ICCCM-defined properties WM_NAME and WM_ICON_NAME for older * window managers, and the freedesktop.org-defined _NET_WM_NAME and * _NET_WM_ICON_NAME properties for newer ones. The ICCCM properties are * stored in the system encoding, the newer properties are stored in * UTF-8. * * NOTE: the ICCCM specifies that WM_NAME and WM_ICON_NAME are stored in * ISO-Latin-1. Tk has historically used the default system encoding * (since 8.1). It's not clear whether this is correct or not. * * Side effects: * Properties get changed for winPtr. * *-------------------------------------------------------------- */ static void UpdateTitle( TkWindow *winPtr) { WmInfo *wmPtr = winPtr->wmInfoPtr; Atom XA_UTF8_STRING = Tk_InternAtom((Tk_Window) winPtr, "UTF8_STRING"); const char *string; Tcl_DString ds; /* * Set window title: */ string = (wmPtr->title != NULL) ? wmPtr->title : winPtr->nameUid; Tcl_UtfToExternalDString(NULL, string, -1, &ds); XStoreName(winPtr->display, wmPtr->wrapperPtr->window, Tcl_DStringValue(&ds)); Tcl_DStringFree(&ds); SetWindowProperty(wmPtr->wrapperPtr, "_NET_WM_NAME", XA_UTF8_STRING, 8, string, strlen(string)); /* * Set icon name: */ if (wmPtr->iconName != NULL) { Tcl_UtfToExternalDString(NULL, wmPtr->iconName, -1, &ds); XSetIconName(winPtr->display, wmPtr->wrapperPtr->window, Tcl_DStringValue(&ds)); Tcl_DStringFree(&ds); SetWindowProperty(wmPtr->wrapperPtr, "_NET_WM_ICON_NAME", XA_UTF8_STRING, 8, wmPtr->iconName, strlen(wmPtr->iconName)); } } /* *-------------------------------------------------------------- * * UpdatePhotoIcon -- * * This function is called to update the window photo icon. It sets the * EWMH-defined properties _NET_WM_ICON. * * Side effects: * Properties get changed for winPtr. * *-------------------------------------------------------------- */ static void UpdatePhotoIcon( TkWindow *winPtr) { WmInfo *wmPtr = winPtr->wmInfoPtr; unsigned char *data = wmPtr->iconDataPtr; int size = wmPtr->iconDataSize; if (data == NULL) { data = winPtr->dispPtr->iconDataPtr; size = winPtr->dispPtr->iconDataSize; } if (data != NULL) { SetWindowProperty(wmPtr->wrapperPtr, "_NET_WM_ICON", XA_CARDINAL, 32, data, size); } } /* *---------------------------------------------------------------------- * * SetNetWmState -- * * Sets the specified state property by sending a _NET_WM_STATE * ClientMessage to the root window. * * Preconditions: * Wrapper window must be created. * * See also: * UpdateNetWmState; EWMH spec, section _NET_WM_STATE. * *---------------------------------------------------------------------- */ #define _NET_WM_STATE_REMOVE 0l #define _NET_WM_STATE_ADD 1l #define _NET_WM_STATE_TOGGLE 2l static void SetNetWmState( TkWindow *winPtr, const char *atomName, int on) { Tk_Window tkwin = (Tk_Window) winPtr; Atom messageType = Tk_InternAtom(tkwin, "_NET_WM_STATE"); Atom action = on ? _NET_WM_STATE_ADD : _NET_WM_STATE_REMOVE; Atom property = Tk_InternAtom(tkwin, atomName); XEvent e; if (!winPtr->wmInfoPtr->wrapperPtr) { return; } e.xany.type = ClientMessage; e.xany.window = winPtr->wmInfoPtr->wrapperPtr->window; e.xclient.message_type = messageType; e.xclient.format = 32; e.xclient.data.l[0] = action; e.xclient.data.l[1] = property; e.xclient.data.l[2] = e.xclient.data.l[3] = e.xclient.data.l[4] = 0l; XSendEvent(winPtr->display, RootWindow(winPtr->display, winPtr->screenNum), 0, SubstructureNotifyMask|SubstructureRedirectMask, &e); } /* *---------------------------------------------------------------------- * * CheckNetWmState -- * * Updates the window attributes whenever the _NET_WM_STATE property * changes. * * Notes: * * Tk uses a single -zoomed state, while the EWMH spec supports separate * vertical and horizontal maximization. We consider the window to be * "zoomed" if _NET_WM_STATE_MAXIMIZED_VERT and * _NET_WM_STATE_MAXIMIZED_HORZ are both set. * *---------------------------------------------------------------------- */ static void CheckNetWmState( WmInfo *wmPtr, Atom *atoms, int numAtoms) { Tk_Window tkwin = (Tk_Window) wmPtr->wrapperPtr; int i; Atom _NET_WM_STATE_ABOVE = Tk_InternAtom(tkwin, "_NET_WM_STATE_ABOVE"), _NET_WM_STATE_MAXIMIZED_VERT = Tk_InternAtom(tkwin, "_NET_WM_STATE_MAXIMIZED_VERT"), _NET_WM_STATE_MAXIMIZED_HORZ = Tk_InternAtom(tkwin, "_NET_WM_STATE_MAXIMIZED_HORZ"), _NET_WM_STATE_FULLSCREEN = Tk_InternAtom(tkwin, "_NET_WM_STATE_FULLSCREEN"); wmPtr->attributes.topmost = 0; wmPtr->attributes.zoomed = 0; wmPtr->attributes.fullscreen = 0; for (i = 0; i < numAtoms; ++i) { if (atoms[i] == _NET_WM_STATE_ABOVE) { wmPtr->attributes.topmost = 1; } else if (atoms[i] == _NET_WM_STATE_MAXIMIZED_VERT) { wmPtr->attributes.zoomed |= 1; } else if (atoms[i] == _NET_WM_STATE_MAXIMIZED_HORZ) { wmPtr->attributes.zoomed |= 2; } else if (atoms[i] == _NET_WM_STATE_FULLSCREEN) { wmPtr->attributes.fullscreen = 1; } } wmPtr->attributes.zoomed = (wmPtr->attributes.zoomed == 3); return; } /* *---------------------------------------------------------------------- * * UpdateNetWmState -- * * Sets the _NET_WM_STATE property to match the requested attribute state * just prior to mapping a withdrawn window. * *---------------------------------------------------------------------- */ #define NET_WM_STATE_MAX_ATOMS 4 static void UpdateNetWmState( WmInfo *wmPtr) { Tk_Window tkwin = (Tk_Window) wmPtr->wrapperPtr; Atom atoms[NET_WM_STATE_MAX_ATOMS]; long numAtoms = 0; if (wmPtr->reqState.topmost) { atoms[numAtoms++] = Tk_InternAtom(tkwin,"_NET_WM_STATE_ABOVE"); } if (wmPtr->reqState.zoomed) { atoms[numAtoms++] = Tk_InternAtom(tkwin,"_NET_WM_STATE_MAXIMIZED_VERT"); atoms[numAtoms++] = Tk_InternAtom(tkwin,"_NET_WM_STATE_MAXIMIZED_HORZ"); } if (wmPtr->reqState.fullscreen) { atoms[numAtoms++] = Tk_InternAtom(tkwin, "_NET_WM_STATE_FULLSCREEN"); } SetWindowProperty(wmPtr->wrapperPtr, "_NET_WM_STATE", XA_ATOM, 32, atoms, numAtoms); } /* *---------------------------------------------------------------------- * * WaitForConfigureNotify -- * * This function is invoked in order to synchronize with the window * manager. It waits for a ConfigureNotify event to arrive, signalling * that the window manager has seen an attempt on our part to move or * resize a top-level window. * * Results: * None. * * Side effects: * Delays the execution of the process until a ConfigureNotify event * arrives with serial number at least as great as serial. This is useful * for two reasons: * * 1. It's important to distinguish ConfigureNotify events that are * coming in response to a request we've made from those generated * spontaneously by the user. The reason for this is that if the user * resizes the window we take that as an order to ignore geometry * requests coming from inside the window hierarchy. If we * accidentally interpret a response to our request as a user- * initiated action, the window will stop responding to new geometry * requests. To make this distinction, (a) this function sets a flag * for TopLevelEventProc to indicate that we're waiting to sync with * the wm, and (b) all changes to the size of a top-level window are * followed by calls to this function. * 2. Races and confusion can come about if there are multiple operations * outstanding at a time (e.g. two different resizes of the top-level * window: it's hard to tell which of the ConfigureNotify events * coming back is for which request). * While waiting, some events covered by StructureNotifyMask are * processed (ConfigureNotify, MapNotify, and UnmapNotify) and all others * are deferred. * *---------------------------------------------------------------------- */ static void WaitForConfigureNotify( TkWindow *winPtr, /* Top-level window for which we want to see a * ConfigureNotify. */ unsigned long serial) /* Serial number of resize request. Want to be * sure wm has seen this. */ { WmInfo *wmPtr = winPtr->wmInfoPtr; XEvent event; int diff, code; int gotConfig = 0; /* * One more tricky detail about this function. In some cases the window * manager will decide to ignore a configure request (e.g. because it * thinks the window is already in the right place). To avoid hanging in * this situation, only wait for a few seconds, then give up. */ while (!gotConfig) { wmPtr->flags |= WM_SYNC_PENDING; code = WaitForEvent(winPtr->display, wmPtr, ConfigureNotify, &event); wmPtr->flags &= ~WM_SYNC_PENDING; if (code != TCL_OK) { if (winPtr->dispPtr->flags & TK_DISPLAY_WM_TRACING) { printf("WaitForConfigureNotify giving up on %s\n", winPtr->pathName); } break; } diff = event.xconfigure.serial - serial; if (diff >= 0) { gotConfig = 1; } } wmPtr->flags &= ~WM_MOVE_PENDING; if (winPtr->dispPtr->flags & TK_DISPLAY_WM_TRACING) { printf("WaitForConfigureNotify finished with %s, serial %ld\n", winPtr->pathName, serial); } } /* *---------------------------------------------------------------------- * * WaitForEvent -- * * This function is used by WaitForConfigureNotify and WaitForMapNotify * to wait for an event of a certain type to arrive. * * Results: * Under normal conditions, TCL_OK is returned and an event for display * and window that matches "mask" is stored in *eventPtr. This event has * already been processed by Tk before this function returns. If a long * time goes by with no event of the right type arriving, or if an error * occurs while waiting for the event to arrive, then TCL_ERROR is * returned. * * Side effects: * While waiting for the desired event to occur, Configurenotify, * MapNotify, and UnmapNotify events for window are processed, as are all * ReparentNotify events. * *---------------------------------------------------------------------- */ static int WaitForEvent( Display *display, /* Display event is coming from. */ WmInfo *wmInfoPtr, /* Window for which event is desired. */ int type, /* Type of event that is wanted. */ XEvent *eventPtr) /* Place to store event. */ { WaitRestrictInfo info; Tk_RestrictProc *prevProc; ClientData prevArg; Tcl_Time timeout; /* * Set up an event filter to select just the events we want, and a timer * handler, then wait for events until we get the event we want or a * timeout happens. */ info.display = display; info.wmInfoPtr = wmInfoPtr; info.type = type; info.eventPtr = eventPtr; info.foundEvent = 0; prevProc = Tk_RestrictEvents(WaitRestrictProc, &info, &prevArg); Tcl_GetTime(&timeout); timeout.sec += 2; while (!info.foundEvent) { if (!TkUnixDoOneXEvent(&timeout)) { break; } } Tk_RestrictEvents(prevProc, prevArg, &prevArg); if (info.foundEvent) { return TCL_OK; } return TCL_ERROR; } /* *---------------------------------------------------------------------- * * WaitRestrictProc -- * * This function is a Tk_RestrictProc that is used to filter events while * WaitForEvent is active. * * Results: * Returns TK_PROCESS_EVENT if the right event is found. Also returns * TK_PROCESS_EVENT if any ReparentNotify event is found or if the event * is a ConfigureNotify, MapNotify, or UnmapNotify for window. Otherwise * returns TK_DEFER_EVENT. * * Side effects: * An event may get stored in the area indicated by the caller of * WaitForEvent. * *---------------------------------------------------------------------- */ static Tk_RestrictAction WaitRestrictProc( ClientData clientData, /* Pointer to WaitRestrictInfo structure. */ XEvent *eventPtr) /* Event that is about to be handled. */ { WaitRestrictInfo *infoPtr = clientData; if (eventPtr->type == ReparentNotify) { return TK_PROCESS_EVENT; } if (((eventPtr->xany.window != infoPtr->wmInfoPtr->wrapperPtr->window) && (eventPtr->xany.window != infoPtr->wmInfoPtr->reparent)) || (eventPtr->xany.display != infoPtr->display)) { return TK_DEFER_EVENT; } if (eventPtr->type == infoPtr->type) { *infoPtr->eventPtr = *eventPtr; infoPtr->foundEvent = 1; return TK_PROCESS_EVENT; } if (eventPtr->type == ConfigureNotify || eventPtr->type == MapNotify || eventPtr->type == UnmapNotify) { return TK_PROCESS_EVENT; } return TK_DEFER_EVENT; } /* *---------------------------------------------------------------------- * * WaitForMapNotify -- * * This function is invoked in order to synchronize with the window * manager. It waits for the window's mapped state to reach the value * given by mapped. * * Results: * None. * * Side effects: * Delays the execution of the process until winPtr becomes mapped or * unmapped, depending on the "mapped" argument. This allows us to * synchronize with the window manager, and allows us to identify changes * in window size that come about when the window manager first starts * managing the window (as opposed to those requested interactively by * the user later). See the comments for WaitForConfigureNotify and * WM_SYNC_PENDING. While waiting, some events covered by * StructureNotifyMask are processed and all others are deferred. * *---------------------------------------------------------------------- */ static void WaitForMapNotify( TkWindow *winPtr, /* Top-level window for which we want to see a * particular mapping state. */ int mapped) /* If non-zero, wait for window to become * mapped, otherwise wait for it to become * unmapped. */ { WmInfo *wmPtr = winPtr->wmInfoPtr; XEvent event; int code; while (1) { if (mapped) { if (winPtr->flags & TK_MAPPED) { break; } } else if (!(winPtr->flags & TK_MAPPED)) { break; } wmPtr->flags |= WM_SYNC_PENDING; code = WaitForEvent(winPtr->display, wmPtr, mapped ? MapNotify : UnmapNotify, &event); wmPtr->flags &= ~WM_SYNC_PENDING; if (code != TCL_OK) { /* * There are some bizarre situations in which the window manager * can't respond or chooses not to (e.g. if we've got a grab set * it can't respond). If this happens then just quit. */ if (winPtr->dispPtr->flags & TK_DISPLAY_WM_TRACING) { printf("WaitForMapNotify giving up on %s\n", winPtr->pathName); } break; } } wmPtr->flags &= ~WM_MOVE_PENDING; if (winPtr->dispPtr->flags & TK_DISPLAY_WM_TRACING) { printf("WaitForMapNotify finished with %s (winPtr %p, wmPtr %p)\n", winPtr->pathName, winPtr, wmPtr); } } /* *-------------------------------------------------------------- * * UpdateHints -- * * This function is called to update the window manager's hints * information from the information in a WmInfo structure. * * Results: * None. * * Side effects: * Properties get changed for winPtr. * *-------------------------------------------------------------- */ static void UpdateHints( TkWindow *winPtr) { WmInfo *wmPtr = winPtr->wmInfoPtr; if (wmPtr->flags & WM_NEVER_MAPPED) { return; } XSetWMHints(winPtr->display, wmPtr->wrapperPtr->window, &wmPtr->hints); } /* *---------------------------------------------------------------------- * * SetNetWmType -- * * Set the extended window manager hints for a toplevel window to the * types provided. The specification states that this may be a list of * window types in preferred order. To permit for future type * definitions, the set of names is unconstrained and names are converted * to upper-case and appended to "_NET_WM_WINDOW_TYPE_" before being * converted to an Atom. * *---------------------------------------------------------------------- */ static int SetNetWmType( TkWindow *winPtr, Tcl_Obj *typePtr) { Atom *atoms = NULL; WmInfo *wmPtr; Tcl_Obj **objv; int objc, n; Tk_Window tkwin = (Tk_Window) winPtr; Tcl_Interp *interp = Tk_Interp(tkwin); if (TCL_OK != Tcl_ListObjGetElements(interp, typePtr, &objc, &objv)) { return TCL_ERROR; } if (!Tk_HasWrapper(tkwin)) { return TCL_OK; /* error?? */ } if (objc > 0) { atoms = ckalloc(sizeof(Atom) * objc); } for (n = 0; n < objc; ++n) { Tcl_DString ds, dsName; int len; char *name = Tcl_GetStringFromObj(objv[n], &len); Tcl_UtfToUpper(name); Tcl_UtfToExternalDString(NULL, name, len, &dsName); Tcl_DStringInit(&ds); Tcl_DStringAppend(&ds, "_NET_WM_WINDOW_TYPE_", 20); Tcl_DStringAppend(&ds, Tcl_DStringValue(&dsName), Tcl_DStringLength(&dsName)); Tcl_DStringFree(&dsName); atoms[n] = Tk_InternAtom(tkwin, Tcl_DStringValue(&ds)); Tcl_DStringFree(&ds); } wmPtr = winPtr->wmInfoPtr; if (wmPtr->wrapperPtr == NULL) { CreateWrapper(wmPtr); } SetWindowProperty(wmPtr->wrapperPtr, "_NET_WM_WINDOW_TYPE", XA_ATOM, 32, atoms, objc); ckfree(atoms); return TCL_OK; } /* *---------------------------------------------------------------------- * * GetNetWmType -- * * Read the extended window manager type hint from a window and return as * a list of names suitable for use with SetNetWmType. * *---------------------------------------------------------------------- */ static Tcl_Obj * GetNetWmType( TkWindow *winPtr) { Atom typeAtom, actualType, *atoms; int actualFormat; unsigned long n, count, bytesAfter; unsigned char *propertyValue = NULL; long maxLength = 1024; Tk_Window tkwin = (Tk_Window) winPtr; TkWindow *wrapperPtr; Tcl_Obj *typePtr; Tcl_Interp *interp; Tcl_DString ds; interp = Tk_Interp(tkwin); typePtr = Tcl_NewListObj(0, NULL); if (winPtr->wmInfoPtr->wrapperPtr == NULL) { CreateWrapper(winPtr->wmInfoPtr); } wrapperPtr = winPtr->wmInfoPtr->wrapperPtr; typeAtom = Tk_InternAtom(tkwin, "_NET_WM_WINDOW_TYPE"); if (GetWindowProperty(wrapperPtr, typeAtom, maxLength, XA_ATOM, &actualType, &actualFormat, &count, &bytesAfter, &propertyValue)){ atoms = (Atom *) propertyValue; for (n = 0; n < count; ++n) { const char *name = Tk_GetAtomName(tkwin, atoms[n]); if (strncmp("_NET_WM_WINDOW_TYPE_", name, 20) == 0) { Tcl_ExternalToUtfDString(NULL, name+20, -1, &ds); Tcl_UtfToLower(Tcl_DStringValue(&ds)); Tcl_ListObjAppendElement(interp, typePtr, Tcl_NewStringObj(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds))); Tcl_DStringFree(&ds); } } XFree(propertyValue); } return typePtr; } /* *-------------------------------------------------------------- * * ParseGeometry -- * * This function parses a geometry string and updates information used to * control the geometry of a top-level window. * * Results: * A standard Tcl return value, plus an error message in the interp's * result if an error occurs. * * Side effects: * The size and/or location of winPtr may change. * *-------------------------------------------------------------- */ static int ParseGeometry( Tcl_Interp *interp, /* Used for error reporting. */ const char *string, /* String containing new geometry. Has the * standard form "=wxh+x+y". */ TkWindow *winPtr) /* Pointer to top-level window whose geometry * is to be changed. */ { register WmInfo *wmPtr = winPtr->wmInfoPtr; int x, y, width, height, flags; char *end; register const char *p = string; /* * The leading "=" is optional. */ if (*p == '=') { p++; } /* * Parse the width and height, if they are present. Don't actually update * any of the fields of wmPtr until we've successfully parsed the entire * geometry string. */ width = wmPtr->width; height = wmPtr->height; x = wmPtr->x; y = wmPtr->y; flags = wmPtr->flags; if (isdigit(UCHAR(*p))) { width = strtoul(p, &end, 10); p = end; if (*p != 'x') { goto error; } p++; if (!isdigit(UCHAR(*p))) { goto error; } height = strtoul(p, &end, 10); p = end; } /* * Parse the X and Y coordinates, if they are present. */ if (*p != '\0') { flags &= ~(WM_NEGATIVE_X | WM_NEGATIVE_Y); if (*p == '-') { flags |= WM_NEGATIVE_X; } else if (*p != '+') { goto error; } p++; if (!isdigit(UCHAR(*p)) && (*p != '-')) { goto error; } x = strtol(p, &end, 10); p = end; if (*p == '-') { flags |= WM_NEGATIVE_Y; } else if (*p != '+') { goto error; } p++; if (!isdigit(UCHAR(*p)) && (*p != '-')) { goto error; } y = strtol(p, &end, 10); if (*end != '\0') { goto error; } /* * Assume that the geometry information came from the user, unless an * explicit source has been specified. Otherwise most window managers * assume that the size hints were program-specified and they ignore * them. */ if (!(wmPtr->sizeHintsFlags & (USPosition|PPosition))) { wmPtr->sizeHintsFlags |= USPosition; flags |= WM_UPDATE_SIZE_HINTS; } } /* * Everything was parsed OK. Update the fields of *wmPtr and arrange for * the appropriate information to be percolated out to the window manager * at the next idle moment. */ wmPtr->width = width; wmPtr->height = height; wmPtr->x = x; wmPtr->y = y; flags |= WM_MOVE_PENDING; wmPtr->flags = flags; if (!(wmPtr->flags & (WM_UPDATE_PENDING|WM_NEVER_MAPPED))) { Tcl_DoWhenIdle(UpdateGeometryInfo, winPtr); wmPtr->flags |= WM_UPDATE_PENDING; } return TCL_OK; error: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad geometry specifier \"%s\"", string)); Tcl_SetErrorCode(interp, "TK", "VALUE", "GEOMETRY", NULL); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * Tk_GetRootCoords -- * * Given a token for a window, this function traces through the window's * lineage to find the (virtual) root-window coordinates corresponding to * point (0,0) in the window. * * Results: * The locations pointed to by xPtr and yPtr are filled in with the root * coordinates of the (0,0) point in tkwin. If a virtual root window is * in effect for the window, then the coordinates in the virtual root are * returned. * * Side effects: * None. * *---------------------------------------------------------------------- */ void Tk_GetRootCoords( Tk_Window tkwin, /* Token for window. */ int *xPtr, /* Where to store x-displacement of (0,0). */ int *yPtr) /* Where to store y-displacement of (0,0). */ { int x, y; register TkWindow *winPtr = (TkWindow *) tkwin; /* * Search back through this window's parents all the way to a top-level * window, combining the offsets of each window within its parent. */ x = y = 0; while (1) { x += winPtr->changes.x + winPtr->changes.border_width; y += winPtr->changes.y + winPtr->changes.border_width; if ((winPtr->wmInfoPtr != NULL) && (winPtr->wmInfoPtr->menubar == (Tk_Window) winPtr)) { /* * This window is a special menubar; switch over to its associated * toplevel, compensate for their differences in y coordinates, * then continue with the toplevel (in case it's embedded). */ y -= winPtr->wmInfoPtr->menuHeight; winPtr = winPtr->wmInfoPtr->winPtr; continue; } if (winPtr->flags & TK_TOP_LEVEL) { TkWindow *otherPtr; if (!(winPtr->flags & TK_EMBEDDED)) { break; } otherPtr = TkpGetOtherWindow(winPtr); if (otherPtr == NULL) { /* * The container window is not in the same application. Query * the X server. */ Window root, dummyChild; int rootX, rootY; root = winPtr->wmInfoPtr->vRoot; if (root == None) { root = RootWindowOfScreen(Tk_Screen((Tk_Window) winPtr)); } XTranslateCoordinates(winPtr->display, winPtr->window, root, 0, 0, &rootX, &rootY, &dummyChild); x += rootX; y += rootY; break; } else { /* * The container window is in the same application. Let's * query its coordinates. */ winPtr = otherPtr; continue; } } winPtr = winPtr->parentPtr; if (winPtr == NULL) { break; } } *xPtr = x; *yPtr = y; } /* *---------------------------------------------------------------------- * * Tk_CoordsToWindow -- * * Given the (virtual) root coordinates of a point, this function returns * the token for the top-most window covering that point, if there exists * such a window in this application. * * Results: * The return result is either a token for the window corresponding to * rootX and rootY, or else NULL to indicate that there is no such * window. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tk_Window Tk_CoordsToWindow( int rootX, int rootY, /* Coordinates of point in root window. If a * virtual-root window manager is in use, * these coordinates refer to the virtual * root, not the real root. */ Tk_Window tkwin) /* Token for any window in application; used * to identify the display. */ { Window window, parent, child; int x, y, childX, childY, tmpx, tmpy, bd; WmInfo *wmPtr; TkWindow *winPtr, *childPtr, *nextPtr; TkDisplay *dispPtr = ((TkWindow *) tkwin)->dispPtr; Tk_ErrorHandler handler = NULL; /* * Step 1: scan the list of toplevel windows to see if there is a virtual * root for the screen we're interested in. If so, we have to translate * the coordinates from virtual root to root coordinates. */ parent = window = RootWindowOfScreen(Tk_Screen(tkwin)); x = rootX; y = rootY; for (wmPtr = (WmInfo *) dispPtr->firstWmPtr; wmPtr != NULL; wmPtr = wmPtr->nextPtr) { if (Tk_Screen(wmPtr->winPtr) != Tk_Screen(tkwin)) { continue; } if (wmPtr->vRoot == None) { continue; } UpdateVRootGeometry(wmPtr); parent = wmPtr->vRoot; break; } /* * Step 2: work down through the window hierarchy starting at the root. * For each window, find the child that contains the given point and then * see if this child is either a wrapper for one of our toplevel windows * or a window manager decoration window for one of our toplevels. This * approach handles several tricky cases: * * 1. There may be a virtual root window between the root and one of our * toplevels. * 2. If a toplevel is embedded, we may have to search through the * windows of the container application(s) before getting to the * toplevel. */ handler = Tk_CreateErrorHandler(Tk_Display(tkwin), -1, -1, -1, NULL, NULL); while (1) { if (XTranslateCoordinates(Tk_Display(tkwin), parent, window, x, y, &childX, &childY, &child) == False) { /* * We can end up here when the window is in the middle of being * deleted */ Tk_DeleteErrorHandler(handler); return NULL; } if (child == None) { Tk_DeleteErrorHandler(handler); return NULL; } for (wmPtr = (WmInfo *) dispPtr->firstWmPtr; wmPtr != NULL; wmPtr = wmPtr->nextPtr) { if (wmPtr->reparent == child) { goto gotToplevel; } if (wmPtr->wrapperPtr != NULL) { if (child == wmPtr->wrapperPtr->window) { goto gotToplevel; } } else if (child == wmPtr->winPtr->window) { goto gotToplevel; } } x = childX; y = childY; parent = window; window = child; } gotToplevel: if (handler) { /* * Check value of handler, because we can reach this label from above * or below */ Tk_DeleteErrorHandler(handler); handler = NULL; } winPtr = wmPtr->winPtr; if (winPtr->mainPtr != ((TkWindow *) tkwin)->mainPtr) { return NULL; } /* * Step 3: at this point winPtr and wmPtr refer to the toplevel that * contains the given coordinates, and childX and childY give the * translated coordinates in the *parent* of the toplevel. Now decide * whether the coordinates are in the menubar or the actual toplevel, and * translate the coordinates into the coordinate system of that window. */ x = childX - winPtr->changes.x; y = childY - winPtr->changes.y; if ((x < 0) || (x >= winPtr->changes.width) || (y >= winPtr->changes.height)) { return NULL; } if (y < 0) { winPtr = (TkWindow *) wmPtr->menubar; if (winPtr == NULL) { return NULL; } y += wmPtr->menuHeight; if (y < 0) { return NULL; } } /* * Step 4: work down through the hierarchy underneath the current window. * At each level, scan through all the children to find the highest one in * the stacking order that contains the point. Then repeat the whole * process on that child. */ while (1) { nextPtr = NULL; for (childPtr = winPtr->childList; childPtr != NULL; childPtr = childPtr->nextPtr) { if (!Tk_IsMapped(childPtr) || (childPtr->flags & TK_TOP_HIERARCHY)) { continue; } if (childPtr->flags & TK_REPARENTED) { continue; } tmpx = x - childPtr->changes.x; tmpy = y - childPtr->changes.y; bd = childPtr->changes.border_width; if ((tmpx >= -bd) && (tmpy >= -bd) && (tmpx < (childPtr->changes.width + bd)) && (tmpy < (childPtr->changes.height + bd))) { nextPtr = childPtr; } } if (nextPtr == NULL) { break; } winPtr = nextPtr; x -= winPtr->changes.x; y -= winPtr->changes.y; if ((winPtr->flags & TK_CONTAINER) && (winPtr->flags & TK_BOTH_HALVES)) { /* * The window containing the point is a container, and the * embedded application is in this same process. Switch over to * the toplevel for the embedded application and start processing * that toplevel from scratch. */ winPtr = TkpGetOtherWindow(winPtr); if (winPtr == NULL) { return NULL; } wmPtr = winPtr->wmInfoPtr; childX = x; childY = y; goto gotToplevel; } } return (Tk_Window) winPtr; } /* *---------------------------------------------------------------------- * * UpdateVRootGeometry -- * * This function is called to update all the virtual root geometry * information in wmPtr. * * Results: * None. * * Side effects: * The vRootX, vRootY, vRootWidth, and vRootHeight fields in wmPtr are * filled with the most up-to-date information. * *---------------------------------------------------------------------- */ static void UpdateVRootGeometry( WmInfo *wmPtr) /* Window manager information to be updated. * The wmPtr->vRoot field must be valid. */ { TkWindow *winPtr = wmPtr->winPtr; int bd; unsigned dummy; Window dummy2; Status status; Tk_ErrorHandler handler; /* * If this isn't a virtual-root window manager, just return information * about the screen. */ wmPtr->flags &= ~WM_VROOT_OFFSET_STALE; if (wmPtr->vRoot == None) { noVRoot: wmPtr->vRootX = wmPtr->vRootY = 0; wmPtr->vRootWidth = DisplayWidth(winPtr->display, winPtr->screenNum); wmPtr->vRootHeight = DisplayHeight(winPtr->display, winPtr->screenNum); return; } /* * Refresh the virtual root information if it's out of date. */ handler = Tk_CreateErrorHandler(winPtr->display, -1, -1, -1, NULL, NULL); status = XGetGeometry(winPtr->display, wmPtr->vRoot, &dummy2, &wmPtr->vRootX, &wmPtr->vRootY, (unsigned *) &wmPtr->vRootWidth, (unsigned *) &wmPtr->vRootHeight, (unsigned *) &bd, &dummy); if (winPtr->dispPtr->flags & TK_DISPLAY_WM_TRACING) { printf("UpdateVRootGeometry: x = %d, y = %d, width = %d, ", wmPtr->vRootX, wmPtr->vRootY, wmPtr->vRootWidth); printf("height = %d, status = %d\n", wmPtr->vRootHeight, status); } Tk_DeleteErrorHandler(handler); if (status == 0) { /* * The virtual root is gone! Pretend that it never existed. */ wmPtr->vRoot = None; goto noVRoot; } } /* *---------------------------------------------------------------------- * * Tk_GetVRootGeometry -- * * This function returns information about the virtual root window * corresponding to a particular Tk window. * * Results: * The values at xPtr, yPtr, widthPtr, and heightPtr are set with the * offset and dimensions of the root window corresponding to tkwin. If * tkwin is being managed by a virtual root window manager these values * correspond to the virtual root window being used for tkwin; otherwise * the offsets will be 0 and the dimensions will be those of the screen. * * Side effects: * Vroot window information is refreshed if it is out of date. * *---------------------------------------------------------------------- */ void Tk_GetVRootGeometry( Tk_Window tkwin, /* Window whose virtual root is to be * queried. */ int *xPtr, int *yPtr, /* Store x and y offsets of virtual root * here. */ int *widthPtr, int *heightPtr) /* Store dimensions of virtual root here. */ { WmInfo *wmPtr; TkWindow *winPtr = (TkWindow *) tkwin; /* * Find the top-level window for tkwin, and locate the window manager * information for that window. */ while (!(winPtr->flags & TK_TOP_HIERARCHY) && (winPtr->parentPtr != NULL)) { winPtr = winPtr->parentPtr; } wmPtr = winPtr->wmInfoPtr; if (wmPtr == NULL) { /* Punt. */ *xPtr = 0; *yPtr = 0; *widthPtr = 0; *heightPtr = 0; } /* * Make sure that the geometry information is up-to-date, then copy it out * to the caller. */ if (wmPtr->flags & WM_VROOT_OFFSET_STALE) { UpdateVRootGeometry(wmPtr); } *xPtr = wmPtr->vRootX; *yPtr = wmPtr->vRootY; *widthPtr = wmPtr->vRootWidth; *heightPtr = wmPtr->vRootHeight; } /* *---------------------------------------------------------------------- * * Tk_MoveToplevelWindow -- * * This function is called instead of Tk_MoveWindow to adjust the x-y * location of a top-level window. It delays the actual move to a later * time and keeps window-manager information up-to-date with the move * * Results: * None. * * Side effects: * The window is eventually moved so that its upper-left corner * (actually, the upper-left corner of the window's decorative frame, if * there is one) is at (x,y). * *---------------------------------------------------------------------- */ void Tk_MoveToplevelWindow( Tk_Window tkwin, /* Window to move. */ int x, int y) /* New location for window (within parent). */ { TkWindow *winPtr = (TkWindow *) tkwin; register WmInfo *wmPtr = winPtr->wmInfoPtr; if (!(winPtr->flags & TK_TOP_LEVEL)) { Tcl_Panic("Tk_MoveToplevelWindow called with non-toplevel window"); } wmPtr->x = x; wmPtr->y = y; wmPtr->flags |= WM_MOVE_PENDING; wmPtr->flags &= ~(WM_NEGATIVE_X|WM_NEGATIVE_Y); if (!(wmPtr->sizeHintsFlags & (USPosition|PPosition))) { wmPtr->sizeHintsFlags |= USPosition; wmPtr->flags |= WM_UPDATE_SIZE_HINTS; } /* * If the window has already been mapped, must bring its geometry * up-to-date immediately, otherwise an event might arrive from the server * that would overwrite wmPtr->x and wmPtr->y and lose the new position. */ if (!(wmPtr->flags & WM_NEVER_MAPPED)) { if (wmPtr->flags & WM_UPDATE_PENDING) { Tcl_CancelIdleCall(UpdateGeometryInfo, winPtr); } UpdateGeometryInfo(winPtr); } } /* *---------------------------------------------------------------------- * * UpdateWmProtocols -- * * This function transfers the most up-to-date information about window * manager protocols from the WmInfo structure to the actual property on * the top-level window. * * Results: * None. * * Side effects: * The WM_PROTOCOLS property gets changed for wmPtr's window. * *---------------------------------------------------------------------- */ static void UpdateWmProtocols( register WmInfo *wmPtr) /* Information about top-level window. */ { register ProtocolHandler *protPtr; Atom deleteWindowAtom, pingAtom; int count; Atom *arrayPtr, *atomPtr; /* * There are only two tricky parts here. First, there could be any number * of atoms for the window, so count them and malloc an array to hold all * of their atoms. Second, we *always* want to respond to the * WM_DELETE_WINDOW and _NET_WM_PING protocols, even if no-one's * officially asked. */ for (protPtr = wmPtr->protPtr, count = 2; protPtr != NULL; protPtr = protPtr->nextPtr, count++) { /* Empty loop body; we're just counting the handlers. */ } arrayPtr = ckalloc(count * sizeof(Atom)); deleteWindowAtom = Tk_InternAtom((Tk_Window) wmPtr->winPtr, "WM_DELETE_WINDOW"); pingAtom = Tk_InternAtom((Tk_Window) wmPtr->winPtr, "_NET_WM_PING"); arrayPtr[0] = deleteWindowAtom; arrayPtr[1] = pingAtom; for (protPtr = wmPtr->protPtr, atomPtr = &arrayPtr[1]; protPtr != NULL; protPtr = protPtr->nextPtr) { if (protPtr->protocol != deleteWindowAtom && protPtr->protocol != pingAtom) { *(atomPtr++) = protPtr->protocol; } } SetWindowProperty(wmPtr->wrapperPtr, "WM_PROTOCOLS", XA_ATOM, 32, arrayPtr, atomPtr-arrayPtr); ckfree(arrayPtr); } /* *---------------------------------------------------------------------- * * TkWmProtocolEventProc -- * * This function is called by the Tk_HandleEvent whenever a ClientMessage * event arrives whose type is "WM_PROTOCOLS". This function handles the * message from the window manager in an appropriate fashion. * * Results: * None. * * Side effects: * Depends on what sort of handler, if any, was set up for the protocol. * *---------------------------------------------------------------------- */ void TkWmProtocolEventProc( TkWindow *winPtr, /* Window to which the event was sent. */ XEvent *eventPtr) /* X event. */ { WmInfo *wmPtr; register ProtocolHandler *protPtr; Atom protocol; int result; const char *protocolName; Tcl_Interp *interp; protocol = (Atom) eventPtr->xclient.data.l[0]; /* * If this is a _NET_WM_PING message, send it back to the root window * immediately. We do that here because scripts *cannot* respond correctly * to this protocol. */ if (protocol == Tk_InternAtom((Tk_Window) winPtr, "_NET_WM_PING")) { Window root = XRootWindow(winPtr->display, winPtr->screenNum); eventPtr->xclient.window = root; (void) XSendEvent(winPtr->display, root, False, (SubstructureNotifyMask|SubstructureRedirectMask), eventPtr); return; } wmPtr = winPtr->wmInfoPtr; if (wmPtr == NULL) { return; } /* * Note: it's very important to retrieve the protocol name now, before * invoking the command, even though the name won't be used until after * the command returns. This is because the command could delete winPtr, * making it impossible for us to use it later in the call to * Tk_GetAtomName. */ protocolName = Tk_GetAtomName((Tk_Window) winPtr, protocol); for (protPtr = wmPtr->protPtr; protPtr != NULL; protPtr = protPtr->nextPtr) { if (protocol == protPtr->protocol) { Tcl_Preserve(protPtr); interp = protPtr->interp; Tcl_Preserve(interp); result = Tcl_EvalEx(interp, protPtr->command, -1, TCL_EVAL_GLOBAL); if (result != TCL_OK) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (command for \"%s\" window manager protocol)", protocolName)); Tcl_BackgroundException(interp, result); } Tcl_Release(interp); Tcl_Release(protPtr); return; } } /* * No handler was present for this protocol. If this is a WM_DELETE_WINDOW * message then just destroy the window. */ if (protocol == Tk_InternAtom((Tk_Window) winPtr, "WM_DELETE_WINDOW")) { Tk_DestroyWindow((Tk_Window) wmPtr->winPtr); } } /* *---------------------------------------------------------------------- * * TkWmStackorderToplevelWrapperMap -- * * This function will create a table that maps the reparent wrapper X id * for a toplevel to the TkWindow structure that is wraps. Tk keeps track * of a mapping from the window X id to the TkWindow structure but that * does us no good here since we only get the X id of the wrapper window. * Only those toplevel windows that are mapped have a position in the * stacking order. * * Results: * None. * * Side effects: * Adds entries to the passed hashtable. * *---------------------------------------------------------------------- */ static void TkWmStackorderToplevelWrapperMap( TkWindow *winPtr, /* TkWindow to recurse on */ Display *display, /* X display of parent window */ Tcl_HashTable *table) /* Maps X id to TkWindow */ { TkWindow *childPtr; if (Tk_IsMapped(winPtr) && Tk_IsTopLevel(winPtr) && !Tk_IsEmbedded(winPtr) && (winPtr->display == display)) { Window wrapper = (winPtr->wmInfoPtr->reparent != None) ? winPtr->wmInfoPtr->reparent : winPtr->wmInfoPtr->wrapperPtr->window; Tcl_HashEntry *hPtr; int newEntry; hPtr = Tcl_CreateHashEntry(table, (char *) wrapper, &newEntry); Tcl_SetHashValue(hPtr, winPtr); } for (childPtr = winPtr->childList; childPtr != NULL; childPtr = childPtr->nextPtr) { TkWmStackorderToplevelWrapperMap(childPtr, display, table); } } /* *---------------------------------------------------------------------- * * TkWmStackorderToplevel -- * * This function returns the stack order of toplevel windows. * * Results: * An array of pointers to tk window objects in stacking order or else * NULL if there was an error. * * Side effects: * None. * *---------------------------------------------------------------------- */ TkWindow ** TkWmStackorderToplevel( TkWindow *parentPtr) /* Parent toplevel window. */ { Window dummy1, dummy2, vRoot; Window *children; unsigned numChildren, i; TkWindow *childWinPtr, **windows, **window_ptr; Tcl_HashTable table; Tcl_HashEntry *hPtr; Tcl_HashSearch search; /* * Map X Window ids to a TkWindow of the wrapped toplevel. */ Tcl_InitHashTable(&table, TCL_ONE_WORD_KEYS); TkWmStackorderToplevelWrapperMap(parentPtr, parentPtr->display, &table); window_ptr = windows = ckalloc((table.numEntries+1) * sizeof(TkWindow *)); /* * Special cases: If zero or one toplevels were mapped there is no need to * call XQueryTree. */ switch (table.numEntries) { case 0: windows[0] = NULL; goto done; case 1: hPtr = Tcl_FirstHashEntry(&table, &search); windows[0] = Tcl_GetHashValue(hPtr); windows[1] = NULL; goto done; } vRoot = parentPtr->wmInfoPtr->vRoot; if (vRoot == None) { vRoot = RootWindowOfScreen(Tk_Screen((Tk_Window) parentPtr)); } if (XQueryTree(parentPtr->display, vRoot, &dummy1, &dummy2, &children, &numChildren) == 0) { ckfree(windows); windows = NULL; } else { for (i = 0; i < numChildren; i++) { hPtr = Tcl_FindHashEntry(&table, (char *) children[i]); if (hPtr != NULL) { childWinPtr = Tcl_GetHashValue(hPtr); *window_ptr++ = childWinPtr; } } /* * ASSERT: window_ptr - windows == table.numEntries * (#matched toplevel windows == #children) [Bug 1789819] */ *window_ptr = NULL; if (numChildren) { XFree((char *) children); } } done: Tcl_DeleteHashTable(&table); return windows; } /* *---------------------------------------------------------------------- * * TkWmRestackToplevel -- * * This function restacks a top-level window. * * Results: * None. * * Side effects: * WinPtr gets restacked as specified by aboveBelow and otherPtr. * *---------------------------------------------------------------------- */ void TkWmRestackToplevel( TkWindow *winPtr, /* Window to restack. */ int aboveBelow, /* Gives relative position for restacking; * must be Above or Below. */ TkWindow *otherPtr) /* Window relative to which to restack; if * NULL, then winPtr gets restacked above or * below *all* siblings. */ { XWindowChanges changes; unsigned mask; TkWindow *wrapperPtr; memset(&changes, 0, sizeof(XWindowChanges)); changes.stack_mode = aboveBelow; mask = CWStackMode; /* * Make sure that winPtr and its wrapper window have been created. */ if (winPtr->wmInfoPtr->flags & WM_NEVER_MAPPED) { TkWmMapWindow(winPtr); } wrapperPtr = winPtr->wmInfoPtr->wrapperPtr; if (otherPtr != NULL) { /* * The window is to be restacked with respect to another toplevel. * Make sure it has been created as well. */ if (otherPtr->wmInfoPtr->flags & WM_NEVER_MAPPED) { TkWmMapWindow(otherPtr); } changes.sibling = otherPtr->wmInfoPtr->wrapperPtr->window; mask |= CWSibling; } /* * Reconfigure the window. Note that we use XReconfigureWMWindow instead * of XConfigureWindow, in order to handle the case where the window is to * be restacked with respect to another toplevel. See [ICCCM] 4.1.5 * "Configuring the Window" and XReconfigureWMWindow(3) for details. */ XReconfigureWMWindow(winPtr->display, wrapperPtr->window, Tk_ScreenNumber((Tk_Window) winPtr), mask, &changes); } /* *---------------------------------------------------------------------- * * TkWmAddToColormapWindows -- * * This function is called to add a given window to the * WM_COLORMAP_WINDOWS property for its top-level, if it isn't already * there. It is invoked by the Tk code that creates a new colormap, in * order to make sure that colormap information is propagated to the * window manager by default. * * Results: * None. * * Side effects: * WinPtr's window gets added to the WM_COLORMAP_WINDOWS property of its * nearest top-level ancestor, unless the colormaps have been set * explicitly with the "wm colormapwindows" command. * *---------------------------------------------------------------------- */ void TkWmAddToColormapWindows( TkWindow *winPtr) /* Window with a non-default colormap. Should * not be a top-level window. */ { TkWindow *wrapperPtr; TkWindow *topPtr; Window *oldPtr, *newPtr; int count, i; if (winPtr->window == None) { return; } for (topPtr = winPtr->parentPtr; ; topPtr = topPtr->parentPtr) { if (topPtr == NULL) { /* * Window is being deleted. Skip the whole operation. */ return; } if (topPtr->flags & TK_TOP_HIERARCHY) { break; } } if (topPtr->wmInfoPtr == NULL) { return; } if (topPtr->wmInfoPtr->flags & WM_COLORMAPS_EXPLICIT) { return; } if (topPtr->wmInfoPtr->wrapperPtr == NULL) { CreateWrapper(topPtr->wmInfoPtr); } wrapperPtr = topPtr->wmInfoPtr->wrapperPtr; /* * Fetch the old value of the property. */ if (XGetWMColormapWindows(topPtr->display, wrapperPtr->window, &oldPtr, &count) == 0) { oldPtr = NULL; count = 0; } /* * Make sure that the window isn't already in the list. */ for (i = 0; i < count; i++) { if (oldPtr[i] == winPtr->window) { return; } } /* * Make a new bigger array and use it to reset the property. Automatically * add the toplevel itself as the last element of the list. */ newPtr = ckalloc((count+2) * sizeof(Window)); for (i = 0; i < count; i++) { newPtr[i] = oldPtr[i]; } if (count == 0) { count++; } newPtr[count-1] = winPtr->window; newPtr[count] = topPtr->window; XSetWMColormapWindows(topPtr->display, wrapperPtr->window, newPtr, count+1); ckfree(newPtr); if (oldPtr != NULL) { XFree((char *) oldPtr); } } /* *---------------------------------------------------------------------- * * TkWmRemoveFromColormapWindows -- * * This function is called to remove a given window from the * WM_COLORMAP_WINDOWS property for its top-level. It is invoked when * windows are deleted. * * Results: * None. * * Side effects: * WinPtr's window gets removed from the WM_COLORMAP_WINDOWS property of * its nearest top-level ancestor, unless the top-level itself is being * deleted too. * *---------------------------------------------------------------------- */ void TkWmRemoveFromColormapWindows( TkWindow *winPtr) /* Window that may be present in * WM_COLORMAP_WINDOWS property for its * top-level. Should not be a top-level * window. */ { TkWindow *wrapperPtr; TkWindow *topPtr; Window *oldPtr; int count, i, j; if (winPtr->window == None) { return; } for (topPtr = winPtr->parentPtr; ; topPtr = topPtr->parentPtr) { if (topPtr == NULL) { /* * Ancestors have been deleted, so skip the whole operation. * Seems like this can't ever happen? */ return; } if (topPtr->flags & TK_TOP_HIERARCHY) { break; } } if (topPtr->flags & TK_ALREADY_DEAD) { /* * Top-level is being deleted, so there's no need to cleanup the * WM_COLORMAP_WINDOWS property. */ return; } if (topPtr->wmInfoPtr == NULL) { return; } if (topPtr->wmInfoPtr->wrapperPtr == NULL) { CreateWrapper(topPtr->wmInfoPtr); } wrapperPtr = topPtr->wmInfoPtr->wrapperPtr; if (wrapperPtr == NULL) { return; } /* * Fetch the old value of the property. */ if (XGetWMColormapWindows(topPtr->display, wrapperPtr->window, &oldPtr, &count) == 0) { return; } /* * Find the window and slide the following ones down to cover it up. */ for (i = 0; i < count; i++) { if (oldPtr[i] == winPtr->window) { for (j = i ; j < count-1; j++) { oldPtr[j] = oldPtr[j+1]; } XSetWMColormapWindows(topPtr->display, wrapperPtr->window, oldPtr, count-1); break; } } XFree((char *) oldPtr); } /* *---------------------------------------------------------------------- * * TkGetPointerCoords -- * * Fetch the position of the mouse pointer. * * Results: * *xPtr and *yPtr are filled in with the (virtual) root coordinates of * the mouse pointer for tkwin's display. If the pointer isn't on tkwin's * screen, then -1 values are returned for both coordinates. The argument * tkwin must be a toplevel window. * * Side effects: * None. * *---------------------------------------------------------------------- */ void TkGetPointerCoords( Tk_Window tkwin, /* Toplevel window that identifies screen on * which lookup is to be done. */ int *xPtr, int *yPtr) /* Store pointer coordinates here. */ { TkWindow *winPtr = (TkWindow *) tkwin; WmInfo *wmPtr; Window w, root, child; int rootX, rootY; unsigned mask; wmPtr = winPtr->wmInfoPtr; w = wmPtr->vRoot; if (w == None) { w = RootWindow(winPtr->display, winPtr->screenNum); } if (XQueryPointer(winPtr->display, w, &root, &child, &rootX, &rootY, xPtr, yPtr, &mask) != True) { *xPtr = -1; *yPtr = -1; } } /* *---------------------------------------------------------------------- * * GetMaxSize -- * * This function computes the current maxWidth and maxHeight values for a * window, taking into account the possibility that they may be * defaulted. * * Results: * The values at *maxWidthPtr and *maxHeightPtr are filled in with the * maximum allowable dimensions of wmPtr's window, in grid units. If no * maximum has been specified for the window, then this function computes * the largest sizes that will fit on the screen. * * Side effects: * None. * *---------------------------------------------------------------------- */ static void GetMaxSize( WmInfo *wmPtr, /* Window manager information for the * window. */ int *maxWidthPtr, /* Where to store the current maximum width of * the window. */ int *maxHeightPtr) /* Where to store the current maximum height * of the window. */ { int tmp; if (wmPtr->maxWidth > 0) { *maxWidthPtr = wmPtr->maxWidth; } else { /* * Must compute a default width. Fill up the display, leaving a bit of * extra space for the window manager's borders. */ tmp = DisplayWidth(wmPtr->winPtr->display, wmPtr->winPtr->screenNum) - 15; if (wmPtr->gridWin != NULL) { /* * Gridding is turned on; convert from pixels to grid units. */ tmp = wmPtr->reqGridWidth + (tmp - wmPtr->winPtr->reqWidth)/wmPtr->widthInc; } *maxWidthPtr = tmp; } if (wmPtr->maxHeight > 0) { *maxHeightPtr = wmPtr->maxHeight; } else { tmp = DisplayHeight(wmPtr->winPtr->display, wmPtr->winPtr->screenNum) - 30; if (wmPtr->gridWin != NULL) { tmp = wmPtr->reqGridHeight + (tmp - wmPtr->winPtr->reqHeight)/wmPtr->heightInc; } *maxHeightPtr = tmp; } } /* *---------------------------------------------------------------------- * * TkSetTransientFor -- * * Set a Tk window to be transient with reference to a specified * parent or the toplevel ancestor if None is passed as parent. * *---------------------------------------------------------------------- */ static void TkSetTransientFor(Tk_Window tkwin, Tk_Window parent) { if (parent == None) { parent = Tk_Parent(tkwin); while (!Tk_IsTopLevel(parent)) parent = Tk_Parent(parent); } /* * Prevent crash due to incomplete initialization, or other problems. * [Bugs 3554026, 3561016] */ if (((TkWindow *)parent)->wmInfoPtr->wrapperPtr == NULL) { CreateWrapper(((TkWindow *)parent)->wmInfoPtr); } XSetTransientForHint(Tk_Display(tkwin), ((TkWindow *)tkwin)->wmInfoPtr->wrapperPtr->window, ((TkWindow *)parent)->wmInfoPtr->wrapperPtr->window); } /* *---------------------------------------------------------------------- * * TkpMakeMenuWindow -- * * Configure the window to be either a pull-down menu, a pop-up menu, or * as a toplevel (torn-off) menu or palette. * * Results: * None. * * Side effects: * Changes the style bit used to create a new Mac toplevel. * *---------------------------------------------------------------------- */ void TkpMakeMenuWindow( Tk_Window tkwin, /* New window. */ int typeFlag) /* TK_MAKE_MENU_DROPDOWN means menu is only * posted briefly as a pulldown or cascade, * TK_MAKE_MENU_POPUP means it is a popup. * TK_MAKE_MENU_TEAROFF means menu is always * visible, e.g. as a torn-off menu. * Determines whether save_under and * override_redirect should be set, plus how * to flag it for the window manager. */ { WmInfo *wmPtr; XSetWindowAttributes atts; TkWindow *wrapperPtr; Tcl_Obj *typeObj; if (!Tk_HasWrapper(tkwin)) { return; } wmPtr = ((TkWindow *) tkwin)->wmInfoPtr; if (wmPtr->wrapperPtr == NULL) { CreateWrapper(wmPtr); } wrapperPtr = wmPtr->wrapperPtr; if (typeFlag == TK_MAKE_MENU_TEAROFF) { atts.override_redirect = False; atts.save_under = False; typeObj = Tcl_NewStringObj("menu", -1); TkSetTransientFor(tkwin, NULL); } else { atts.override_redirect = True; atts.save_under = True; if (typeFlag == TK_MAKE_MENU_DROPDOWN) { typeObj = Tcl_NewStringObj("dropdown_menu", -1); } else { typeObj = Tcl_NewStringObj("popup_menu", -1); } } SetNetWmType((TkWindow *)tkwin, typeObj); /* * The override-redirect and save-under bits must be set on the wrapper * window in order to have the desired effect. However, also set the * override-redirect bit on the window itself, so that the "wm * overrideredirect" command will see it. */ if ((atts.override_redirect!=Tk_Attributes(wrapperPtr)->override_redirect) || (atts.save_under != Tk_Attributes(wrapperPtr)->save_under)) { Tk_ChangeWindowAttributes((Tk_Window) wrapperPtr, CWOverrideRedirect|CWSaveUnder, &atts); } if (atts.override_redirect != Tk_Attributes(tkwin)->override_redirect) { Tk_ChangeWindowAttributes(tkwin, CWOverrideRedirect, &atts); } } /* *---------------------------------------------------------------------- * * CreateWrapper -- * * This function is invoked to create the wrapper window for a toplevel * window. It is called just before a toplevel is mapped for the first * time. * * Results: * None. * * Side effects: * The wrapper is created and the toplevel is reparented inside it. * *---------------------------------------------------------------------- */ static void CreateWrapper( WmInfo *wmPtr) /* Window manager information for the * window. */ { TkWindow *winPtr, *wrapperPtr; Window parent; Tcl_HashEntry *hPtr; int new; winPtr = wmPtr->winPtr; if (winPtr->window == None) { Tk_MakeWindowExist((Tk_Window) winPtr); } /* * The code below is copied from CreateTopLevelWindow, Tk_MakeWindowExist, * and TkpMakeWindow. The idea is to create an "official" Tk window (so * that we can get events on it), but to hide the window outside the * official Tk hierarchy so that it isn't visible to the application. See * the comments for the other functions if you have questions about this * code. */ wmPtr->wrapperPtr = wrapperPtr = TkAllocWindow(winPtr->dispPtr, Tk_ScreenNumber((Tk_Window) winPtr), winPtr); wrapperPtr->dirtyAtts |= CWBorderPixel; /* * Tk doesn't normally select for StructureNotifyMask events because the * events are synthesized internally. However, for wrapper windows we need * to know when the window manager modifies the window configuration. We * also need to select on focus change events; these are the only windows * for which we care about focus changes. */ wrapperPtr->flags |= TK_WRAPPER; wrapperPtr->atts.event_mask |= StructureNotifyMask|FocusChangeMask; wrapperPtr->atts.override_redirect = winPtr->atts.override_redirect; if (winPtr->flags & TK_EMBEDDED) { parent = TkUnixContainerId(winPtr); } else { parent = XRootWindow(wrapperPtr->display, wrapperPtr->screenNum); } wrapperPtr->window = XCreateWindow(wrapperPtr->display, parent, wrapperPtr->changes.x, wrapperPtr->changes.y, (unsigned) wrapperPtr->changes.width, (unsigned) wrapperPtr->changes.height, (unsigned) wrapperPtr->changes.border_width, wrapperPtr->depth, InputOutput, wrapperPtr->visual, wrapperPtr->dirtyAtts|CWOverrideRedirect, &wrapperPtr->atts); hPtr = Tcl_CreateHashEntry(&wrapperPtr->dispPtr->winTable, (char *) wrapperPtr->window, &new); Tcl_SetHashValue(hPtr, wrapperPtr); wrapperPtr->mainPtr = winPtr->mainPtr; wrapperPtr->mainPtr->refCount++; wrapperPtr->dirtyAtts = 0; wrapperPtr->dirtyChanges = 0; wrapperPtr->wmInfoPtr = wmPtr; /* * Reparent the toplevel window inside the wrapper. */ XReparentWindow(wrapperPtr->display, winPtr->window, wrapperPtr->window, 0, 0); /* * Tk must monitor structure events for wrapper windows in order to detect * changes made by window managers such as resizing, mapping, unmapping, * etc.. */ Tk_CreateEventHandler((Tk_Window) wmPtr->wrapperPtr, WrapperEventMask, WrapperEventProc, wmPtr); } /* *---------------------------------------------------------------------- * * TkWmFocusToplevel -- * * This is a utility function invoked by focus-management code. The focus * code responds to externally generated focus-related events on wrapper * windows but ignores those events for any other windows. This function * determines whether a given window is a wrapper window and, if so, * returns the toplevel window corresponding to the wrapper. * * Results: * If winPtr is a wrapper window, returns a pointer to the corresponding * toplevel window; otherwise returns NULL. * * Side effects: * None. * *---------------------------------------------------------------------- */ TkWindow * TkWmFocusToplevel( TkWindow *winPtr) /* Window that received a focus-related * event. */ { if (!(winPtr->flags & TK_WRAPPER)) { return NULL; } return winPtr->wmInfoPtr->winPtr; } /* *---------------------------------------------------------------------- * * TkUnixSetMenubar -- * * This function is invoked by menu management code to specify the window * to use as a menubar for a given toplevel window. * * Results: * None. * * Side effects: * The window given by menubar will be mapped and positioned inside the * wrapper for tkwin and above tkwin. Menubar will automatically be * resized to maintain the height specified by TkUnixSetMenuHeight the * same width as tkwin. Any previous menubar specified for tkwin will be * unmapped and ignored from now on. * *---------------------------------------------------------------------- */ void TkUnixSetMenubar( Tk_Window tkwin, /* Token for toplevel window. */ Tk_Window menubar) /* Token for window that is to serve as * menubar for tkwin. Must not be a toplevel * window. If NULL, any existing menubar is * canceled and the menu height is reset to * 0. */ { WmInfo *wmPtr = ((TkWindow *) tkwin)->wmInfoPtr; Tk_Window parent; TkWindow *menubarPtr = (TkWindow *) menubar; /* * Could be a Frame (i.e. not a toplevel). */ if (wmPtr == NULL) { return; } if (wmPtr->menubar != NULL) { /* * There's already a menubar for this toplevel. If it isn't the same * as the new menubar, unmap it so that it is out of the way, and * reparent it back to its original parent. */ if (wmPtr->menubar == menubar) { return; } ((TkWindow *) wmPtr->menubar)->wmInfoPtr = NULL; ((TkWindow *) wmPtr->menubar)->flags &= ~TK_REPARENTED; Tk_UnmapWindow(wmPtr->menubar); parent = Tk_Parent(wmPtr->menubar); if (parent != NULL) { Tk_MakeWindowExist(parent); XReparentWindow(Tk_Display(wmPtr->menubar), Tk_WindowId(wmPtr->menubar), Tk_WindowId(parent), 0, 0); } Tk_DeleteEventHandler(wmPtr->menubar, StructureNotifyMask, MenubarDestroyProc, wmPtr->menubar); Tk_ManageGeometry(wmPtr->menubar, NULL, NULL); } wmPtr->menubar = menubar; if (menubar == NULL) { wmPtr->menuHeight = 0; } else { if ((menubarPtr->flags & TK_TOP_LEVEL) || (Tk_Screen(menubar) != Tk_Screen(tkwin))) { Tcl_Panic("TkUnixSetMenubar got bad menubar"); } wmPtr->menuHeight = Tk_ReqHeight(menubar); if (wmPtr->menuHeight == 0) { wmPtr->menuHeight = 1; } Tk_MakeWindowExist(tkwin); Tk_MakeWindowExist(menubar); if (wmPtr->wrapperPtr == NULL) { CreateWrapper(wmPtr); } XReparentWindow(Tk_Display(menubar), Tk_WindowId(menubar), wmPtr->wrapperPtr->window, 0, 0); menubarPtr->wmInfoPtr = wmPtr; Tk_MoveResizeWindow(menubar, 0, 0, Tk_Width(tkwin), wmPtr->menuHeight); Tk_MapWindow(menubar); Tk_CreateEventHandler(menubar, StructureNotifyMask, MenubarDestroyProc, menubar); Tk_ManageGeometry(menubar, &menubarMgrType, wmPtr); menubarPtr->flags |= TK_REPARENTED; } wmPtr->flags |= WM_UPDATE_SIZE_HINTS; if (!(wmPtr->flags & (WM_UPDATE_PENDING|WM_NEVER_MAPPED))) { Tcl_DoWhenIdle(UpdateGeometryInfo, tkwin); wmPtr->flags |= WM_UPDATE_PENDING; } } /* *---------------------------------------------------------------------- * * MenubarDestroyProc -- * * This function is invoked by the event dispatcher whenever a menubar * window is destroyed (it's also invoked for a few other kinds of * events, but we ignore those). * * Results: * None. * * Side effects: * The association between the window and its toplevel is broken, so that * the window is no longer considered to be a menubar. * *---------------------------------------------------------------------- */ static void MenubarDestroyProc( ClientData clientData, /* TkWindow pointer for menubar. */ XEvent *eventPtr) /* Describes what just happened. */ { WmInfo *wmPtr; if (eventPtr->type != DestroyNotify) { return; } wmPtr = ((TkWindow *) clientData)->wmInfoPtr; wmPtr->menubar = NULL; wmPtr->menuHeight = 0; wmPtr->flags |= WM_UPDATE_SIZE_HINTS; if (!(wmPtr->flags & (WM_UPDATE_PENDING|WM_NEVER_MAPPED))) { Tcl_DoWhenIdle(UpdateGeometryInfo, wmPtr->winPtr); wmPtr->flags |= WM_UPDATE_PENDING; } } /* *---------------------------------------------------------------------- * * MenubarReqProc -- * * This function is invoked by the Tk geometry management code whenever a * menubar calls Tk_GeometryRequest to request a new size. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ static void MenubarReqProc( ClientData clientData, /* Pointer to the window manager information * for tkwin's toplevel. */ Tk_Window tkwin) /* Handle for menubar window. */ { WmInfo *wmPtr = clientData; wmPtr->menuHeight = Tk_ReqHeight(tkwin); if (wmPtr->menuHeight <= 0) { wmPtr->menuHeight = 1; } wmPtr->flags |= WM_UPDATE_SIZE_HINTS; if (!(wmPtr->flags & (WM_UPDATE_PENDING|WM_NEVER_MAPPED))) { Tcl_DoWhenIdle(UpdateGeometryInfo, wmPtr->winPtr); wmPtr->flags |= WM_UPDATE_PENDING; } } /* *---------------------------------------------------------------------- * * TkpGetWrapperWindow -- * * Given a toplevel window return the hidden wrapper window for the * toplevel window if available. * * Results: * The wrapper window. NULL is we were not passed a toplevel window or * the wrapper has yet to be created. * * Side effects: * None. * *---------------------------------------------------------------------- */ TkWindow * TkpGetWrapperWindow( TkWindow *winPtr) /* A toplevel window pointer. */ { register WmInfo *wmPtr = winPtr->wmInfoPtr; if ((winPtr == NULL) || (wmPtr == NULL)) { return NULL; } return wmPtr->wrapperPtr; } /* *---------------------------------------------------------------------- * * UpdateCommand -- * * Update the WM_COMMAND property, taking care to translate the command * strings into the external encoding. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ static void UpdateCommand( TkWindow *winPtr) { register WmInfo *wmPtr = winPtr->wmInfoPtr; Tcl_DString cmds, ds; int i, *offsets; char **cmdArgv; /* * Translate the argv strings into the external encoding. To avoid * allocating lots of memory, the strings are appended to a buffer with * nulls between each string. * * This code is tricky because we need to pass and array of pointers to * XSetCommand. However, we can't compute the pointers as we go because * the DString buffer space could get reallocated. So, store offsets for * each element as we go, then compute pointers from the offsets once the * entire DString is done. */ cmdArgv = ckalloc(sizeof(char *) * wmPtr->cmdArgc); offsets = ckalloc(sizeof(int) * wmPtr->cmdArgc); Tcl_DStringInit(&cmds); for (i = 0; i < wmPtr->cmdArgc; i++) { Tcl_UtfToExternalDString(NULL, wmPtr->cmdArgv[i], -1, &ds); offsets[i] = Tcl_DStringLength(&cmds); Tcl_DStringAppend(&cmds, Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)+1); Tcl_DStringFree(&ds); } cmdArgv[0] = Tcl_DStringValue(&cmds); for (i = 1; i < wmPtr->cmdArgc; i++) { cmdArgv[i] = cmdArgv[0] + offsets[i]; } XSetCommand(winPtr->display, wmPtr->wrapperPtr->window, cmdArgv, wmPtr->cmdArgc); Tcl_DStringFree(&cmds); ckfree(cmdArgv); ckfree(offsets); } /* *---------------------------------------------------------------------- * * TkpWmSetState -- * * Sets the window manager state for the wrapper window of a given * toplevel window. * * Results: * 0 on error, 1 otherwise * * Side effects: * May minimize, restore, or withdraw a window. * *---------------------------------------------------------------------- */ int TkpWmSetState( TkWindow *winPtr, /* Toplevel window to operate on. */ int state) /* One of IconicState, NormalState, or * WithdrawnState. */ { WmInfo *wmPtr = winPtr->wmInfoPtr; if (state == WithdrawnState) { wmPtr->hints.initial_state = WithdrawnState; wmPtr->withdrawn = 1; if (wmPtr->flags & WM_NEVER_MAPPED) { return 1; } if (XWithdrawWindow(winPtr->display, wmPtr->wrapperPtr->window, winPtr->screenNum) == 0) { return 0; } WaitForMapNotify(winPtr, 0); } else if (state == NormalState) { wmPtr->hints.initial_state = NormalState; wmPtr->withdrawn = 0; if (wmPtr->flags & WM_NEVER_MAPPED) { return 1; } UpdateHints(winPtr); Tk_MapWindow((Tk_Window) winPtr); } else if (state == IconicState) { wmPtr->hints.initial_state = IconicState; if (wmPtr->flags & WM_NEVER_MAPPED) { return 1; } if (wmPtr->withdrawn) { UpdateHints(winPtr); Tk_MapWindow((Tk_Window) winPtr); wmPtr->withdrawn = 0; } else { if (XIconifyWindow(winPtr->display, wmPtr->wrapperPtr->window, winPtr->screenNum) == 0) { return 0; } WaitForMapNotify(winPtr, 0); } } return 1; } /* *---------------------------------------------------------------------- * * RemapWindows * * Adjust parent/child relationships of the given window hierarchy. * * Results: * None * * Side effects: * Keeps windowing system (X11) happy * *---------------------------------------------------------------------- */ static void RemapWindows( TkWindow *winPtr, TkWindow *parentPtr) { XWindowAttributes win_attr; if (winPtr->window) { XGetWindowAttributes(winPtr->display, winPtr->window, &win_attr); if (parentPtr == NULL) { XReparentWindow(winPtr->display, winPtr->window, XRootWindow(winPtr->display, winPtr->screenNum), win_attr.x, win_attr.y); } else if (parentPtr->window) { XReparentWindow(parentPtr->display, winPtr->window, parentPtr->window, win_attr.x, win_attr.y); } } } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ tk8.6.5/unix/tkConfig.h.in0000644003604700454610000001445712665114121014005 0ustar dgp771div/* ../unix/tkConfig.h.in. Generated from configure.ac by autoheader. */ #ifndef _TKCONFIG #define _TKCONFIG /* Define to 1 if you have the header file. */ #undef HAVE_AVAILABILITYMACROS_H /* Defined when compiler supports casting to union type. */ #undef HAVE_CAST_TO_UNION /* Do we have access to Darwin CoreFoundation.framework? */ #undef HAVE_COREFOUNDATION /* Compiler support for module scope symbols */ #undef HAVE_HIDDEN /* Do we have the intptr_t type? */ #undef HAVE_INTPTR_T /* Define to 1 if you have the header file. */ #undef HAVE_INTTYPES_H /* Define to 1 if you have the `Xft' library (-lXft). */ #undef HAVE_LIBXFT /* Define to 1 if you have the `lseek64' function. */ #undef HAVE_LSEEK64 /* Define to 1 if you have the header file. */ #undef HAVE_MEMORY_H /* Define to 1 if you have the `open64' function. */ #undef HAVE_OPEN64 /* Define to 1 if you have the `pthread_atfork' function. */ #undef HAVE_PTHREAD_ATFORK /* Define to 1 if you have the `pthread_attr_setstacksize' function. */ #undef HAVE_PTHREAD_ATTR_SETSTACKSIZE /* Does struct password have a pw_gecos field? */ #undef HAVE_PW_GECOS /* Define to 1 if you have the header file. */ #undef HAVE_STDINT_H /* Define to 1 if you have the header file. */ #undef HAVE_STDLIB_H /* Define to 1 if you have the header file. */ #undef HAVE_STRINGS_H /* Define to 1 if you have the header file. */ #undef HAVE_STRING_H /* Is 'struct dirent64' in ? */ #undef HAVE_STRUCT_DIRENT64 /* Is 'struct stat64' in ? */ #undef HAVE_STRUCT_STAT64 /* Should we include ? */ #undef HAVE_SYS_SELECT_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_STAT_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_TIME_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_TYPES_H /* Is off64_t in ? */ #undef HAVE_TYPE_OFF64_T /* Do we have the uintptr_t type? */ #undef HAVE_UINTPTR_T /* Define to 1 if you have the header file. */ #undef HAVE_UNISTD_H /* Is weak import available? */ #undef HAVE_WEAK_IMPORT /* Have we turned on XFT (antialiased fonts)? */ #undef HAVE_XFT /* Do we have XkbKeycodeToKeysym? */ #undef HAVE_XKBKEYCODETOKEYSYM /* Is XScreenSaver available? */ #undef HAVE_XSS /* Is this a Mac I see before me? */ #undef MAC_OSX_TCL /* Are we building TkAqua? */ #undef MAC_OSX_TK /* No Compiler support for module scope symbols */ #undef MODULE_SCOPE /* Is no debugging enabled? */ #undef NDEBUG /* Is Darwin CoreFoundation unavailable for 64-bit? */ #undef NO_COREFOUNDATION_64 /* Do we have fd_set? */ #undef NO_FD_SET /* Do we have ? */ #undef NO_STDLIB_H /* Define to the address where bug reports for this package should be sent. */ #undef PACKAGE_BUGREPORT /* Define to the full name of this package. */ #undef PACKAGE_NAME /* Define to the full name and version of this package. */ #undef PACKAGE_STRING /* Define to the one symbol short name of this package. */ #undef PACKAGE_TARNAME /* Define to the version of this package. */ #undef PACKAGE_VERSION /* Is this a static build? */ #undef STATIC_BUILD /* Define to 1 if you have the ANSI C header files. */ #undef STDC_HEADERS /* Is this a 64-bit build? */ #undef TCL_CFG_DO64BIT /* Is this an optimized build? */ #undef TCL_CFG_OPTIMIZED /* Is bytecode debugging enabled? */ #undef TCL_COMPILE_DEBUG /* Are bytecode statistics enabled? */ #undef TCL_COMPILE_STATS /* Is memory debugging enabled? */ #undef TCL_MEM_DEBUG /* What is the default extension for shared libraries? */ #undef TCL_SHLIB_EXT /* Are we building with threads enabled? */ #undef TCL_THREADS /* Are wide integers to be implemented with C 'long's? */ #undef TCL_WIDE_INT_IS_LONG /* What type should be used to define wide integers? */ #undef TCL_WIDE_INT_TYPE /* Define to 1 if you can safely include both and . */ #undef TIME_WITH_SYS_TIME /* Is Tk built as a framework? */ #undef TK_FRAMEWORK /* Are TkAqua debug messages enabled? */ #undef TK_MAC_DEBUG /* Do we want to use the threaded memory allocator? */ #undef USE_THREAD_ALLOC /* Define to 1 if your processor stores words with the most significant byte first (like Motorola and SPARC, unlike Intel and VAX). */ #undef WORDS_BIGENDIAN /* Is XKeycodeToKeysym deprecated? */ #undef XKEYCODETOKEYSYM_IS_DEPRECATED /* Are Darwin SUSv3 extensions available? */ #undef _DARWIN_C_SOURCE /* Add the _ISOC99_SOURCE flag when building */ #undef _ISOC99_SOURCE /* Add the _LARGEFILE64_SOURCE flag when building */ #undef _LARGEFILE64_SOURCE /* Add the _LARGEFILE_SOURCE64 flag when building */ #undef _LARGEFILE_SOURCE64 /* # needed in sys/socket.h Should OS/390 do the right thing with sockets? */ #undef _OE_SOCKETS /* Do we really want to follow the standard? Yes we do! */ #undef _POSIX_PTHREAD_SEMANTICS /* Do we want the reentrant OS API? */ #undef _REENTRANT /* Do we want the thread-safe OS API? */ #undef _THREAD_SAFE /* Do we want to use the XOPEN network library? */ #undef _XOPEN_SOURCE /* Do we want to use the XOPEN network library? */ #undef _XOPEN_SOURCE_EXTENDED /* Define to 1 if type `char' is unsigned and you are not using gcc. */ #ifndef __CHAR_UNSIGNED__ # undef __CHAR_UNSIGNED__ #endif /* Define to `int' if doesn't define. */ #undef gid_t /* Define to `__inline__' or `__inline' if that's what the C compiler calls it, or to nothing if 'inline' is not supported under any name. */ #ifndef __cplusplus #undef inline #endif /* Signed integer type wide enough to hold a pointer. */ #undef intptr_t /* Define to `int' if does not define. */ #undef mode_t /* Define to `int' if does not define. */ #undef pid_t /* Define to `unsigned' if does not define. */ #undef size_t /* Do we want to use the strtod() in compat? */ #undef strtod /* Define to `int' if doesn't define. */ #undef uid_t /* Unsigned integer type wide enough to hold a pointer. */ #undef uintptr_t /* Undef unused package specific autoheader defines so that we can * include both tclConfig.h and tkConfig.h at the same time: */ /* override */ #undef PACKAGE_NAME /* override */ #undef PACKAGE_STRING /* override */ #undef PACKAGE_TARNAME #endif /* _TKCONFIG */ tk8.6.5/unix/tkUnixDialog.c0000644003604700454610000001174312377375532014243 0ustar dgp771div/* * tkUnixDialog.c -- * * Contains the Unix implementation of the common dialog boxes: * * Copyright (c) 1996 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tkUnixInt.h" /* * The wrapper code for Unix is actually set up in library/tk.tcl these days; * the procedure names used here are probably wrong too... */ #ifdef TK_OBSOLETE_UNIX_DIALOG_WRAPPERS /* *---------------------------------------------------------------------- * * EvalObjv -- * * Invokes the Tcl procedure with the arguments. * * Results: * Returns the result of the evaluation of the command. * * Side effects: * The command may be autoloaded. * *---------------------------------------------------------------------- */ static int EvalObjv( Tcl_Interp *interp, /* Current interpreter. */ char *cmdName, /* Name of the TCL command to call */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Arguments. */ { Tcl_Obj *cmdObj, **objs; int result; cmdObj = Tcl_NewStringObj(cmdName, -1); Tcl_IncrRefCount(cmdObj); objs = ckalloc(sizeof(Tcl_Obj *) * (objc+1)); objs[0] = cmdObj; memcpy(objs+1, objv, sizeof(Tcl_Obj *) * (unsigned)objc); result = Tcl_EvalObjv(interp, objc+1, objs, 0); Tcl_DecrRefCount(cmdObj); ckfree(objs); return result; } /* *---------------------------------------------------------------------- * * Tk_ChooseColorObjCmd -- * * This procedure implements the color dialog box for the Unix platform. * See the user documentation for details on what it does. * * Results: * See user documentation. * * Side effects: * A dialog window is created the first time this procedure is called. * This window is not destroyed and will be reused the next time the * application invokes the "tk_chooseColor" command. * *---------------------------------------------------------------------- */ int Tk_ChooseColorObjCmd( ClientData clientData, /* Main window associated with interpreter. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Arguments. */ { return EvalObjv(interp, "tk::ColorDialog", objc-1, objv+1); } /* *---------------------------------------------------------------------- * * Tk_GetOpenFileCmd -- * * This procedure implements the "open file" dialog box for the Unix * platform. See the user documentation for details on what it does. * * Results: * See user documentation. * * Side effects: * A dialog window is created the first this procedure is called. This * window is not destroyed and will be reused the next time the * application invokes the "tk_getOpenFile" or "tk_getSaveFile" command. * *---------------------------------------------------------------------- */ int Tk_GetOpenFileObjCmd( ClientData clientData, /* Main window associated with interpreter. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Arguments. */ { Tk_Window tkwin = clientData; if (Tk_StrictMotif(tkwin)) { return EvalObjv(interp, "tk::MotifOpenFDialog", objc-1, objv+1); } else { return EvalObjv(interp, "tk::OpenFDialog", objc-1, objv+1); } } /* *---------------------------------------------------------------------- * * Tk_GetSaveFileCmd -- * * Same as Tk_GetOpenFileCmd but opens a "save file" dialog box instead. * * Results: * Same as Tk_GetOpenFileCmd. * * Side effects: * Same as Tk_GetOpenFileCmd. * *---------------------------------------------------------------------- */ int Tk_GetSaveFileObjCmd( ClientData clientData, /* Main window associated with interpreter. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Arguments. */ { Tk_Window tkwin = clientData; if (Tk_StrictMotif(tkwin)) { return EvalObjv(interp, "tk::MotifSaveFDialog", objc-1, objv+1); } else { return EvalObjv(interp, "tk::SaveFDialog", objc-1, objv+1); } } /* *---------------------------------------------------------------------- * * Tk_MessageBoxCmd -- * * This procedure implements the MessageBox window for the Unix * platform. See the user documentation for details on what it does. * * Results: * See user documentation. * * Side effects: * None. The MessageBox window will be destroy before this procedure * returns. * *---------------------------------------------------------------------- */ int Tk_MessageBoxCmd( ClientData clientData, /* Main window associated with interpreter. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Arguments. */ { return EvalObjv(interp, "tk::MessageBox", objc-1, objv+1); } #endif /* TK_OBSOLETE_UNIX_DIALOG_WRAPPERS */ /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ tk8.6.5/unix/tkUnixMenubu.c0000644003604700454610000003205012377375532014271 0ustar dgp771div/* * tkUnixMenubu.c -- * * This file implements the Unix specific portion of the menubutton * widget. * * Copyright (c) 1996-1997 by Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tkInt.h" #include "tkMenubutton.h" /* *---------------------------------------------------------------------- * * TkpCreateMenuButton -- * * Allocate a new TkMenuButton structure. * * Results: * Returns a newly allocated TkMenuButton structure. * * Side effects: * Registers an event handler for the widget. * *---------------------------------------------------------------------- */ TkMenuButton * TkpCreateMenuButton( Tk_Window tkwin) { return ckalloc(sizeof(TkMenuButton)); } /* *---------------------------------------------------------------------- * * TkpDisplayMenuButton -- * * This function is invoked to display a menubutton widget. * * Results: * None. * * Side effects: * Commands are output to X to display the menubutton in its current * mode. * *---------------------------------------------------------------------- */ void TkpDisplayMenuButton( ClientData clientData) /* Information about widget. */ { register TkMenuButton *mbPtr = (TkMenuButton *) clientData; GC gc; Tk_3DBorder border; Pixmap pixmap; int x = 0; /* Initialization needed only to stop compiler * warning. */ int y = 0; register Tk_Window tkwin = mbPtr->tkwin; int fullWidth, fullHeight; int textXOffset, textYOffset; int imageWidth, imageHeight; int imageXOffset, imageYOffset; int width = 0, height = 0; /* Image information that will be used to * restrict disabled pixmap as well */ int haveImage = 0, haveText = 0; mbPtr->flags &= ~REDRAW_PENDING; if ((mbPtr->tkwin == NULL) || !Tk_IsMapped(tkwin)) { return; } if ((mbPtr->state == STATE_DISABLED) && (mbPtr->disabledFg != NULL)) { gc = mbPtr->disabledGC; border = mbPtr->normalBorder; } else if ((mbPtr->state == STATE_ACTIVE) && !Tk_StrictMotif(mbPtr->tkwin)) { gc = mbPtr->activeTextGC; border = mbPtr->activeBorder; } else { gc = mbPtr->normalTextGC; border = mbPtr->normalBorder; } if (mbPtr->image != None) { Tk_SizeOfImage(mbPtr->image, &width, &height); haveImage = 1; } else if (mbPtr->bitmap != None) { Tk_SizeOfBitmap(mbPtr->display, mbPtr->bitmap, &width, &height); haveImage = 1; } imageWidth = width; imageHeight = height; haveText = (mbPtr->textWidth != 0 && mbPtr->textHeight != 0); /* * In order to avoid screen flashes, this function redraws the menu button * in a pixmap, then copies the pixmap to the screen in a single * operation. This means that there's no point in time where the on-sreen * image has been cleared. */ pixmap = Tk_GetPixmap(mbPtr->display, Tk_WindowId(tkwin), Tk_Width(tkwin), Tk_Height(tkwin), Tk_Depth(tkwin)); Tk_Fill3DRectangle(tkwin, pixmap, border, 0, 0, Tk_Width(tkwin), Tk_Height(tkwin), 0, TK_RELIEF_FLAT); imageXOffset = 0; imageYOffset = 0; textXOffset = 0; textYOffset = 0; fullWidth = 0; fullHeight = 0; if (mbPtr->compound != COMPOUND_NONE && haveImage && haveText) { switch ((enum compound) mbPtr->compound) { case COMPOUND_TOP: case COMPOUND_BOTTOM: /* * Image is above or below text. */ if (mbPtr->compound == COMPOUND_TOP) { textYOffset = height + mbPtr->padY; } else { imageYOffset = mbPtr->textHeight + mbPtr->padY; } fullHeight = height + mbPtr->textHeight + mbPtr->padY; fullWidth = (width > mbPtr->textWidth ? width : mbPtr->textWidth); textXOffset = (fullWidth - mbPtr->textWidth)/2; imageXOffset = (fullWidth - width)/2; break; case COMPOUND_LEFT: case COMPOUND_RIGHT: /* * Image is left or right of text. */ if (mbPtr->compound == COMPOUND_LEFT) { textXOffset = width + mbPtr->padX; } else { imageXOffset = mbPtr->textWidth + mbPtr->padX; } fullWidth = mbPtr->textWidth + mbPtr->padX + width; fullHeight = (height > mbPtr->textHeight ? height : mbPtr->textHeight); textYOffset = (fullHeight - mbPtr->textHeight)/2; imageYOffset = (fullHeight - height)/2; break; case COMPOUND_CENTER: /* * Image and text are superimposed. */ fullWidth = (width > mbPtr->textWidth ? width : mbPtr->textWidth); fullHeight = (height > mbPtr->textHeight ? height : mbPtr->textHeight); textXOffset = (fullWidth - mbPtr->textWidth)/2; imageXOffset = (fullWidth - width)/2; textYOffset = (fullHeight - mbPtr->textHeight)/2; imageYOffset = (fullHeight - height)/2; break; case COMPOUND_NONE: break; } TkComputeAnchor(mbPtr->anchor, tkwin, 0, 0, mbPtr->indicatorWidth + fullWidth, fullHeight, &x, &y); imageXOffset += x; imageYOffset += y; if (mbPtr->image != NULL) { Tk_RedrawImage(mbPtr->image, 0, 0, width, height, pixmap, imageXOffset, imageYOffset); } else if (mbPtr->bitmap != None) { XSetClipOrigin(mbPtr->display, gc, imageXOffset, imageYOffset); XCopyPlane(mbPtr->display, mbPtr->bitmap, pixmap, gc, 0, 0, (unsigned) width, (unsigned) height, imageXOffset, imageYOffset, 1); XSetClipOrigin(mbPtr->display, gc, 0, 0); } Tk_DrawTextLayout(mbPtr->display, pixmap, gc, mbPtr->textLayout, x + textXOffset, y + textYOffset, 0, -1); Tk_UnderlineTextLayout(mbPtr->display, pixmap, gc, mbPtr->textLayout, x + textXOffset, y + textYOffset, mbPtr->underline); } else if (haveImage) { TkComputeAnchor(mbPtr->anchor, tkwin, 0, 0, width + mbPtr->indicatorWidth, height, &x, &y); imageXOffset += x; imageYOffset += y; if (mbPtr->image != NULL) { Tk_RedrawImage(mbPtr->image, 0, 0, width, height, pixmap, imageXOffset, imageYOffset); } else if (mbPtr->bitmap != None) { XSetClipOrigin(mbPtr->display, gc, x, y); XCopyPlane(mbPtr->display, mbPtr->bitmap, pixmap, gc, 0, 0, (unsigned) width, (unsigned) height, x, y, 1); XSetClipOrigin(mbPtr->display, gc, 0, 0); } } else { TkComputeAnchor(mbPtr->anchor, tkwin, mbPtr->padX, mbPtr->padY, mbPtr->textWidth + mbPtr->indicatorWidth, mbPtr->textHeight, &x, &y); Tk_DrawTextLayout(mbPtr->display, pixmap, gc, mbPtr->textLayout, x + textXOffset, y + textYOffset, 0, -1); Tk_UnderlineTextLayout(mbPtr->display, pixmap, gc, mbPtr->textLayout, x + textXOffset, y + textYOffset, mbPtr->underline); } /* * If the menu button is disabled with a stipple rather than a special * foreground color, generate the stippled effect. */ if ((mbPtr->state == STATE_DISABLED) && ((mbPtr->disabledFg == NULL) || (mbPtr->image != NULL))) { /* * Stipple the whole button if no disabledFg was specified, otherwise * restrict stippling only to displayed image */ if (mbPtr->disabledFg == NULL) { XFillRectangle(mbPtr->display, pixmap, mbPtr->stippleGC, mbPtr->inset, mbPtr->inset, (unsigned) (Tk_Width(tkwin) - 2*mbPtr->inset), (unsigned) (Tk_Height(tkwin) - 2*mbPtr->inset)); } else { XFillRectangle(mbPtr->display, pixmap, mbPtr->stippleGC, imageXOffset, imageYOffset, (unsigned) imageWidth, (unsigned) imageHeight); } } /* * Draw the cascade indicator for the menu button on the right side of the * window, if desired. */ if (mbPtr->indicatorOn) { int borderWidth; borderWidth = (mbPtr->indicatorHeight+1)/3; if (borderWidth < 1) { borderWidth = 1; } /*y += mbPtr->textHeight / 2;*/ Tk_Fill3DRectangle(tkwin, pixmap, border, Tk_Width(tkwin) - mbPtr->inset - mbPtr->indicatorWidth + mbPtr->indicatorHeight, ((int) (Tk_Height(tkwin) - mbPtr->indicatorHeight))/2, mbPtr->indicatorWidth - 2*mbPtr->indicatorHeight, mbPtr->indicatorHeight, borderWidth, TK_RELIEF_RAISED); } /* * Draw the border and traversal highlight last. This way, if the menu * button's contents overflow onto the border they'll be covered up by the * border. */ if (mbPtr->relief != TK_RELIEF_FLAT) { Tk_Draw3DRectangle(tkwin, pixmap, border, mbPtr->highlightWidth, mbPtr->highlightWidth, Tk_Width(tkwin) - 2*mbPtr->highlightWidth, Tk_Height(tkwin) - 2*mbPtr->highlightWidth, mbPtr->borderWidth, mbPtr->relief); } if (mbPtr->highlightWidth != 0) { GC gc; if (mbPtr->flags & GOT_FOCUS) { gc = Tk_GCForColor(mbPtr->highlightColorPtr, pixmap); } else { gc = Tk_GCForColor(mbPtr->highlightBgColorPtr, pixmap); } Tk_DrawFocusHighlight(tkwin, gc, mbPtr->highlightWidth, pixmap); } /* * Copy the information from the off-screen pixmap onto the screen, then * delete the pixmap. */ XCopyArea(mbPtr->display, pixmap, Tk_WindowId(tkwin), mbPtr->normalTextGC, 0, 0, (unsigned) Tk_Width(tkwin), (unsigned) Tk_Height(tkwin), 0, 0); Tk_FreePixmap(mbPtr->display, pixmap); } /* *---------------------------------------------------------------------- * * TkpDestroyMenuButton -- * * Free data structures associated with the menubutton control. * * Results: * None. * * Side effects: * Restores the default control state. * *---------------------------------------------------------------------- */ void TkpDestroyMenuButton( TkMenuButton *mbPtr) { } /* *---------------------------------------------------------------------- * * TkpComputeMenuButtonGeometry -- * * After changes in a menu button's text or bitmap, this function * recomputes the menu button's geometry and passes this information * along to the geometry manager for the window. * * Results: * None. * * Side effects: * The menu button's window may change size. * *---------------------------------------------------------------------- */ void TkpComputeMenuButtonGeometry( TkMenuButton *mbPtr) /* Widget record for menu button. */ { int width, height, mm, pixels; int avgWidth, txtWidth, txtHeight; int haveImage = 0, haveText = 0; Tk_FontMetrics fm; mbPtr->inset = mbPtr->highlightWidth + mbPtr->borderWidth; width = 0; height = 0; txtWidth = 0; txtHeight = 0; avgWidth = 0; if (mbPtr->image != None) { Tk_SizeOfImage(mbPtr->image, &width, &height); haveImage = 1; } else if (mbPtr->bitmap != None) { Tk_SizeOfBitmap(mbPtr->display, mbPtr->bitmap, &width, &height); haveImage = 1; } if (haveImage == 0 || mbPtr->compound != COMPOUND_NONE) { Tk_FreeTextLayout(mbPtr->textLayout); mbPtr->textLayout = Tk_ComputeTextLayout(mbPtr->tkfont, mbPtr->text, -1, mbPtr->wrapLength, mbPtr->justify, 0, &mbPtr->textWidth, &mbPtr->textHeight); txtWidth = mbPtr->textWidth; txtHeight = mbPtr->textHeight; avgWidth = Tk_TextWidth(mbPtr->tkfont, "0", 1); Tk_GetFontMetrics(mbPtr->tkfont, &fm); haveText = (txtWidth != 0 && txtHeight != 0); } /* * If the menubutton is compound (ie, it shows both an image and text), * the new geometry is a combination of the image and text geometry. We * only honor the compound bit if the menubutton has both text and an * image, because otherwise it is not really a compound menubutton. */ if (mbPtr->compound != COMPOUND_NONE && haveImage && haveText) { switch ((enum compound) mbPtr->compound) { case COMPOUND_TOP: case COMPOUND_BOTTOM: /* * Image is above or below text. */ height += txtHeight + mbPtr->padY; width = (width > txtWidth ? width : txtWidth); break; case COMPOUND_LEFT: case COMPOUND_RIGHT: /* * Image is left or right of text. */ width += txtWidth + mbPtr->padX; height = (height > txtHeight ? height : txtHeight); break; case COMPOUND_CENTER: /* * Image and text are superimposed. */ width = (width > txtWidth ? width : txtWidth); height = (height > txtHeight ? height : txtHeight); break; case COMPOUND_NONE: break; } if (mbPtr->width > 0) { width = mbPtr->width; } if (mbPtr->height > 0) { height = mbPtr->height; } width += 2*mbPtr->padX; height += 2*mbPtr->padY; } else { if (haveImage) { if (mbPtr->width > 0) { width = mbPtr->width; } if (mbPtr->height > 0) { height = mbPtr->height; } } else { width = txtWidth; height = txtHeight; if (mbPtr->width > 0) { width = mbPtr->width * avgWidth; } if (mbPtr->height > 0) { height = mbPtr->height * fm.linespace; } } } if (! haveImage) { width += 2*mbPtr->padX; height += 2*mbPtr->padY; } if (mbPtr->indicatorOn) { mm = WidthMMOfScreen(Tk_Screen(mbPtr->tkwin)); pixels = WidthOfScreen(Tk_Screen(mbPtr->tkwin)); mbPtr->indicatorHeight= (INDICATOR_HEIGHT * pixels)/(10*mm); mbPtr->indicatorWidth = (INDICATOR_WIDTH * pixels)/(10*mm) + 2*mbPtr->indicatorHeight; width += mbPtr->indicatorWidth; } else { mbPtr->indicatorHeight = 0; mbPtr->indicatorWidth = 0; } Tk_GeometryRequest(mbPtr->tkwin, (int) (width + 2*mbPtr->inset), (int) (height + 2*mbPtr->inset)); Tk_SetInternalBorder(mbPtr->tkwin, mbPtr->inset); } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ tk8.6.5/unix/tkUnixConfig.c0000644003604700454610000000220612377375532014243 0ustar dgp771div/* * tkUnixConfig.c -- * * This module implements the Unix system defaults for the configuration * package. * * Copyright (c) 1997 by Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tkInt.h" /* *---------------------------------------------------------------------- * * TkpGetSystemDefault -- * * Given a dbName and className for a configuration option, return a * string representation of the option. * * Results: * Returns a Tk_Uid that is the string identifier that identifies this * option. Returns NULL if there are no system defaults that match this * pair. * * Side effects: * None, once the package is initialized. * *---------------------------------------------------------------------- */ Tcl_Obj * TkpGetSystemDefault( Tk_Window tkwin, /* A window to use. */ const char *dbName, /* The option database name. */ const char *className) /* The name of the option class. */ { return NULL; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ tk8.6.5/unix/tkUnix3d.c0000644003604700454610000003370312377375532013352 0ustar dgp771div/* * tkUnix3d.c -- * * This file contains the platform specific routines for drawing 3d * borders in the Motif style. * * Copyright (c) 1996 by Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tkInt.h" #include "tk3d.h" #if !(defined(_WIN32) || defined(MAC_OSX_TK)) #include "tkUnixInt.h" #endif /* * This structure is used to keep track of the extra colors used by Unix 3D * borders. */ typedef struct { TkBorder info; GC solidGC; /* Used to draw solid relief. */ } UnixBorder; /* *---------------------------------------------------------------------- * * TkpGetBorder -- * * This function allocates a new TkBorder structure. * * Results: * Returns a newly allocated TkBorder. * * Side effects: * None. * *---------------------------------------------------------------------- */ TkBorder * TkpGetBorder(void) { UnixBorder *borderPtr = ckalloc(sizeof(UnixBorder)); borderPtr->solidGC = None; return (TkBorder *) borderPtr; } /* *---------------------------------------------------------------------- * * TkpFreeBorder -- * * This function frees any colors allocated by the platform specific part * of this module. * * Results: * None. * * Side effects: * May deallocate some colors. * *---------------------------------------------------------------------- */ void TkpFreeBorder( TkBorder *borderPtr) { UnixBorder *unixBorderPtr = (UnixBorder *) borderPtr; Display *display = DisplayOfScreen(borderPtr->screen); if (unixBorderPtr->solidGC != None) { Tk_FreeGC(display, unixBorderPtr->solidGC); } } /* *-------------------------------------------------------------- * * Tk_3DVerticalBevel -- * * This procedure draws a vertical bevel along one side of an object. The * bevel is always rectangular in shape: * ||| * ||| * ||| * ||| * ||| * ||| * An appropriate shadow color is chosen for the bevel based on the * leftBevel and relief arguments. Normally this procedure is called * first, then Tk_3DHorizontalBevel is called next to draw neat corners. * * Results: * None. * * Side effects: * Graphics are drawn in drawable. * *-------------------------------------------------------------- */ void Tk_3DVerticalBevel( Tk_Window tkwin, /* Window for which border was allocated. */ Drawable drawable, /* X window or pixmap in which to draw. */ Tk_3DBorder border, /* Token for border to draw. */ int x, int y, int width, int height, /* Area of vertical bevel. */ int leftBevel, /* Non-zero means this bevel forms the left * side of the object; 0 means it forms the * right side. */ int relief) /* Kind of bevel to draw. For example, * TK_RELIEF_RAISED means interior of object * should appear higher than exterior. */ { TkBorder *borderPtr = (TkBorder *) border; GC left, right; Display *display = Tk_Display(tkwin); if ((borderPtr->lightGC == None) && (relief != TK_RELIEF_FLAT)) { TkpGetShadows(borderPtr, tkwin); } if (relief == TK_RELIEF_RAISED) { XFillRectangle(display, drawable, (leftBevel) ? borderPtr->lightGC : borderPtr->darkGC, x, y, (unsigned) width, (unsigned) height); } else if (relief == TK_RELIEF_SUNKEN) { XFillRectangle(display, drawable, (leftBevel) ? borderPtr->darkGC : borderPtr->lightGC, x, y, (unsigned) width, (unsigned) height); } else if (relief == TK_RELIEF_RIDGE) { int half; left = borderPtr->lightGC; right = borderPtr->darkGC; ridgeGroove: half = width/2; if (!leftBevel && (width & 1)) { half++; } XFillRectangle(display, drawable, left, x, y, (unsigned) half, (unsigned) height); XFillRectangle(display, drawable, right, x+half, y, (unsigned) (width-half), (unsigned) height); } else if (relief == TK_RELIEF_GROOVE) { left = borderPtr->darkGC; right = borderPtr->lightGC; goto ridgeGroove; } else if (relief == TK_RELIEF_FLAT) { XFillRectangle(display, drawable, borderPtr->bgGC, x, y, (unsigned) width, (unsigned) height); } else if (relief == TK_RELIEF_SOLID) { UnixBorder *unixBorderPtr = (UnixBorder *) borderPtr; if (unixBorderPtr->solidGC == None) { XGCValues gcValues; gcValues.foreground = BlackPixelOfScreen(borderPtr->screen); unixBorderPtr->solidGC = Tk_GetGC(tkwin, GCForeground, &gcValues); } XFillRectangle(display, drawable, unixBorderPtr->solidGC, x, y, (unsigned) width, (unsigned) height); } } /* *-------------------------------------------------------------- * * Tk_3DHorizontalBevel -- * * This procedure draws a horizontal bevel along one side of an object. * The bevel has mitered corners (depending on leftIn and rightIn * arguments). * * Results: * None. * * Side effects: * None. * *-------------------------------------------------------------- */ void Tk_3DHorizontalBevel( Tk_Window tkwin, /* Window for which border was allocated. */ Drawable drawable, /* X window or pixmap in which to draw. */ Tk_3DBorder border, /* Token for border to draw. */ int x, int y, int width, int height, /* Bounding box of area of bevel. Height gives * width of border. */ int leftIn, int rightIn, /* Describes whether the left and right edges * of the bevel angle in or out as they go * down. For example, if "leftIn" is true, the * left side of the bevel looks like this: * ___________ * __________ * _________ * ________ */ int topBevel, /* Non-zero means this bevel forms the top * side of the object; 0 means it forms the * bottom side. */ int relief) /* Kind of bevel to draw. For example, * TK_RELIEF_RAISED means interior of object * should appear higher than exterior. */ { TkBorder *borderPtr = (TkBorder *) border; Display *display = Tk_Display(tkwin); int bottom, halfway, x1, x2, x1Delta, x2Delta; UnixBorder *unixBorderPtr = (UnixBorder *) borderPtr; GC topGC = None, bottomGC = None; /* Initializations needed only to prevent * compiler warnings. */ if ((borderPtr->lightGC == None) && (relief != TK_RELIEF_FLAT) && (relief != TK_RELIEF_SOLID)) { TkpGetShadows(borderPtr, tkwin); } /* * Compute a GC for the top half of the bevel and a GC for the bottom half * (they're the same in many cases). */ switch (relief) { case TK_RELIEF_FLAT: topGC = bottomGC = borderPtr->bgGC; break; case TK_RELIEF_GROOVE: topGC = borderPtr->darkGC; bottomGC = borderPtr->lightGC; break; case TK_RELIEF_RAISED: topGC = bottomGC = (topBevel? borderPtr->lightGC : borderPtr->darkGC); break; case TK_RELIEF_RIDGE: topGC = borderPtr->lightGC; bottomGC = borderPtr->darkGC; break; case TK_RELIEF_SOLID: if (unixBorderPtr->solidGC == None) { XGCValues gcValues; gcValues.foreground = BlackPixelOfScreen(borderPtr->screen); unixBorderPtr->solidGC = Tk_GetGC(tkwin, GCForeground, &gcValues); } XFillRectangle(display, drawable, unixBorderPtr->solidGC, x, y, (unsigned) width, (unsigned) height); return; case TK_RELIEF_SUNKEN: topGC = bottomGC = (topBevel? borderPtr->darkGC : borderPtr->lightGC); break; } /* * Compute various other geometry-related stuff. */ x1 = x; if (!leftIn) { x1 += height; } x2 = x+width; if (!rightIn) { x2 -= height; } x1Delta = (leftIn) ? 1 : -1; x2Delta = (rightIn) ? -1 : 1; halfway = y + height/2; if (!topBevel && (height & 1)) { halfway++; } bottom = y + height; /* * Draw one line for each y-coordinate covered by the bevel. */ for ( ; y < bottom; y++) { /* * X Dimensions are 16-bit, so avoid wraparound or display errors by * limiting these here. */ if (x1 < -32767) { x1 = -32767; } if (x2 > 32767) { x2 = 32767; } /* * In some weird cases (such as large border widths for skinny * rectangles) x1 can be >= x2. Don't draw the lines in these cases. */ if (x1 < x2) { XFillRectangle(display, drawable, (y < halfway) ? topGC : bottomGC, x1, y, (unsigned) (x2-x1), (unsigned) 1); } x1 += x1Delta; x2 += x2Delta; } } /* *---------------------------------------------------------------------- * * TkpGetShadows -- * * This procedure computes the shadow colors for a 3-D border and fills * in the corresponding fields of the Border structure. It's called * lazily, so that the colors aren't allocated until something is * actually drawn with them. That way, if a border is only used for flat * backgrounds the shadow colors will never be allocated. * * Results: * None. * * Side effects: * The lightGC and darkGC fields in borderPtr get filled in, if they * weren't already. * *---------------------------------------------------------------------- */ void TkpGetShadows( TkBorder *borderPtr, /* Information about border. */ Tk_Window tkwin) /* Window where border will be used for * drawing. */ { XColor lightColor, darkColor; int stressed, tmp1, tmp2; int r, g, b; XGCValues gcValues; if (borderPtr->lightGC != None) { return; } stressed = TkpCmapStressed(tkwin, borderPtr->colormap); /* * First, handle the case of a color display with lots of colors. The * shadow colors get computed using whichever formula results in the * greatest change in color: * 1. Lighter shadow is half-way to white, darker shadow is half way to * dark. * 2. Lighter shadow is 40% brighter than background, darker shadow is 40% * darker than background. */ if (!stressed && (Tk_Depth(tkwin) >= 6)) { /* * This is a color display with lots of colors. For the dark shadow, * cut 40% from each of the background color components. But if the * background is already very dark, make the dark color a little * lighter than the background by increasing each color component * 1/4th of the way to MAX_INTENSITY. * * For the light shadow, boost each component by 40% or half-way to * white, whichever is greater (the first approach works better for * unsaturated colors, the second for saturated ones). But if the * background is already very bright, instead choose a slightly darker * color for the light shadow by reducing each color component by 10%. * * Compute the colors using integers, not using lightColor.red etc.: * these are shorts and may have problems with integer overflow. */ /* * Compute the dark shadow color. */ r = (int) borderPtr->bgColorPtr->red; g = (int) borderPtr->bgColorPtr->green; b = (int) borderPtr->bgColorPtr->blue; if (r*0.5*r + g*1.0*g + b*0.28*b < MAX_INTENSITY*0.05*MAX_INTENSITY) { darkColor.red = (MAX_INTENSITY + 3*r)/4; darkColor.green = (MAX_INTENSITY + 3*g)/4; darkColor.blue = (MAX_INTENSITY + 3*b)/4; } else { darkColor.red = (60 * r)/100; darkColor.green = (60 * g)/100; darkColor.blue = (60 * b)/100; } /* * Allocate the dark shadow color and its GC. */ borderPtr->darkColorPtr = Tk_GetColorByValue(tkwin, &darkColor); gcValues.foreground = borderPtr->darkColorPtr->pixel; borderPtr->darkGC = Tk_GetGC(tkwin, GCForeground, &gcValues); /* * Compute the light shadow color. */ if (g > MAX_INTENSITY*0.95) { lightColor.red = (90 * r)/100; lightColor.green = (90 * g)/100; lightColor.blue = (90 * b)/100; } else { tmp1 = (14 * r)/10; if (tmp1 > MAX_INTENSITY) { tmp1 = MAX_INTENSITY; } tmp2 = (MAX_INTENSITY + r)/2; lightColor.red = (tmp1 > tmp2) ? tmp1 : tmp2; tmp1 = (14 * g)/10; if (tmp1 > MAX_INTENSITY) { tmp1 = MAX_INTENSITY; } tmp2 = (MAX_INTENSITY + g)/2; lightColor.green = (tmp1 > tmp2) ? tmp1 : tmp2; tmp1 = (14 * b)/10; if (tmp1 > MAX_INTENSITY) { tmp1 = MAX_INTENSITY; } tmp2 = (MAX_INTENSITY + b)/2; lightColor.blue = (tmp1 > tmp2) ? tmp1 : tmp2; } /* * Allocate the light shadow color and its GC. */ borderPtr->lightColorPtr = Tk_GetColorByValue(tkwin, &lightColor); gcValues.foreground = borderPtr->lightColorPtr->pixel; borderPtr->lightGC = Tk_GetGC(tkwin, GCForeground, &gcValues); return; } if (borderPtr->shadow == None) { borderPtr->shadow = Tk_GetBitmap((Tcl_Interp *) NULL, tkwin, Tk_GetUid("gray50")); if (borderPtr->shadow == None) { Tcl_Panic("TkpGetShadows couldn't allocate bitmap for border"); } } if (borderPtr->visual->map_entries > 2) { /* * This isn't a monochrome display, but the colormap either ran out of * entries or didn't have very many to begin with. Generate the light * shadows with a white stipple and the dark shadows with a black * stipple. */ gcValues.foreground = borderPtr->bgColorPtr->pixel; gcValues.background = BlackPixelOfScreen(borderPtr->screen); gcValues.stipple = borderPtr->shadow; gcValues.fill_style = FillOpaqueStippled; borderPtr->darkGC = Tk_GetGC(tkwin, GCForeground|GCBackground|GCStipple|GCFillStyle, &gcValues); gcValues.background = WhitePixelOfScreen(borderPtr->screen); borderPtr->lightGC = Tk_GetGC(tkwin, GCForeground|GCBackground|GCStipple|GCFillStyle, &gcValues); return; } /* * This is just a measly monochrome display, hardly even worth its * existence on this earth. Make one shadow a 50% stipple and the other * the opposite of the background. */ gcValues.foreground = WhitePixelOfScreen(borderPtr->screen); gcValues.background = BlackPixelOfScreen(borderPtr->screen); gcValues.stipple = borderPtr->shadow; gcValues.fill_style = FillOpaqueStippled; borderPtr->lightGC = Tk_GetGC(tkwin, GCForeground|GCBackground|GCStipple|GCFillStyle, &gcValues); if (borderPtr->bgColorPtr->pixel == WhitePixelOfScreen(borderPtr->screen)) { gcValues.foreground = BlackPixelOfScreen(borderPtr->screen); borderPtr->darkGC = Tk_GetGC(tkwin, GCForeground, &gcValues); } else { borderPtr->darkGC = borderPtr->lightGC; borderPtr->lightGC = Tk_GetGC(tkwin, GCForeground, &gcValues); } } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ tk8.6.5/unix/tk.spec0000644003604700454610000000262012665114121012742 0ustar dgp771div# This file is the basis for a binary Tk Linux RPM. %{!?directory:%define directory /usr/local} Name: tk Summary: Tk graphical toolkit for the Tcl scripting language. Version: 8.6.4 Release: 2 License: BSD Group: Development/Languages Source: http://prdownloads.sourceforge.net/tcl/tk%{version}-src.tar.gz URL: http://www.tcl.tk/ Buildroot: /var/tmp/%{name}%{version} Buildrequires: XFree86-devel tcl >= %version Requires: tcl >= %version %description The Tcl (Tool Command Language) provides a powerful platform for creating integration applications that tie together diverse applications, protocols, devices, and frameworks. When paired with the Tk toolkit, Tcl provides the fastest and most powerful way to create GUI applications that run on PCs, Unix, and Mac OS X. Tcl can also be used for a variety of web-related tasks and for creating powerful command languages for applications. %prep %setup -q -n %{name}%{version} %build cd unix CFLAGS="%optflags" ./configure \ --prefix=%{directory} \ --exec-prefix=%{directory} \ --libdir=%{directory}/%{_lib} make %install cd unix make INSTALL_ROOT=%buildroot install %clean rm -rf %buildroot %files -n tk %defattr(-,root,root) %if %{_lib} != lib %{directory}/%{_lib} %endif %{directory}/lib %{directory}/bin %{directory}/include %{directory}/man/man1 %{directory}/man/man3 %{directory}/man/mann tk8.6.5/unix/tkUnixCursor.c0000644003604700454610000004425112377375532014321 0ustar dgp771div/* * tkUnixCursor.c -- * * This file contains X specific cursor manipulation routines. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tkInt.h" /* * The following data structure is a superset of the TkCursor structure * defined in tkCursor.c. Each system specific cursor module will define a * different cursor structure. All of these structures must have the same * header consisting of the fields in TkCursor. */ typedef struct { TkCursor info; /* Generic cursor info used by tkCursor.c */ Display *display; /* Display for which cursor is valid. */ } TkUnixCursor; /* * The table below is used to map from the name of a cursor to its index in * the official cursor font: */ static const struct CursorName { const char *name; unsigned int shape; } cursorNames[] = { {"X_cursor", XC_X_cursor}, {"arrow", XC_arrow}, {"based_arrow_down", XC_based_arrow_down}, {"based_arrow_up", XC_based_arrow_up}, {"boat", XC_boat}, {"bogosity", XC_bogosity}, {"bottom_left_corner", XC_bottom_left_corner}, {"bottom_right_corner", XC_bottom_right_corner}, {"bottom_side", XC_bottom_side}, {"bottom_tee", XC_bottom_tee}, {"box_spiral", XC_box_spiral}, {"center_ptr", XC_center_ptr}, {"circle", XC_circle}, {"clock", XC_clock}, {"coffee_mug", XC_coffee_mug}, {"cross", XC_cross}, {"cross_reverse", XC_cross_reverse}, {"crosshair", XC_crosshair}, {"diamond_cross", XC_diamond_cross}, {"dot", XC_dot}, {"dotbox", XC_dotbox}, {"double_arrow", XC_double_arrow}, {"draft_large", XC_draft_large}, {"draft_small", XC_draft_small}, {"draped_box", XC_draped_box}, {"exchange", XC_exchange}, {"fleur", XC_fleur}, {"gobbler", XC_gobbler}, {"gumby", XC_gumby}, {"hand1", XC_hand1}, {"hand2", XC_hand2}, {"heart", XC_heart}, {"icon", XC_icon}, {"iron_cross", XC_iron_cross}, {"left_ptr", XC_left_ptr}, {"left_side", XC_left_side}, {"left_tee", XC_left_tee}, {"leftbutton", XC_leftbutton}, {"ll_angle", XC_ll_angle}, {"lr_angle", XC_lr_angle}, {"man", XC_man}, {"middlebutton", XC_middlebutton}, {"mouse", XC_mouse}, {"pencil", XC_pencil}, {"pirate", XC_pirate}, {"plus", XC_plus}, {"question_arrow", XC_question_arrow}, {"right_ptr", XC_right_ptr}, {"right_side", XC_right_side}, {"right_tee", XC_right_tee}, {"rightbutton", XC_rightbutton}, {"rtl_logo", XC_rtl_logo}, {"sailboat", XC_sailboat}, {"sb_down_arrow", XC_sb_down_arrow}, {"sb_h_double_arrow", XC_sb_h_double_arrow}, {"sb_left_arrow", XC_sb_left_arrow}, {"sb_right_arrow", XC_sb_right_arrow}, {"sb_up_arrow", XC_sb_up_arrow}, {"sb_v_double_arrow", XC_sb_v_double_arrow}, {"shuttle", XC_shuttle}, {"sizing", XC_sizing}, {"spider", XC_spider}, {"spraycan", XC_spraycan}, {"star", XC_star}, {"target", XC_target}, {"tcross", XC_tcross}, {"top_left_arrow", XC_top_left_arrow}, {"top_left_corner", XC_top_left_corner}, {"top_right_corner", XC_top_right_corner}, {"top_side", XC_top_side}, {"top_tee", XC_top_tee}, {"trek", XC_trek}, {"ul_angle", XC_ul_angle}, {"umbrella", XC_umbrella}, {"ur_angle", XC_ur_angle}, {"watch", XC_watch}, {"xterm", XC_xterm}, {NULL, 0} }; /* * The table below is used to map from a cursor name to the data that defines * the cursor. This table is used for cursors defined by Tk that don't exist * in the X cursor table. */ #define CURSOR_NONE_DATA \ "#define none_width 1\n" \ "#define none_height 1\n" \ "#define none_x_hot 0\n" \ "#define none_y_hot 0\n" \ "static unsigned char none_bits[] = {\n" \ " 0x00};" /* * Define test cursor to check that mask fg and bg color settings are working. * * . configure -cursor {center_ptr green red} * . configure -cursor {@myarrow.xbm myarrow-mask.xbm green red} * . configure -cursor {myarrow green red} */ /*#define DEFINE_MYARROW_CURSOR*/ #ifdef DEFINE_MYARROW_CURSOR #define CURSOR_MYARROW_DATA \ "#define myarrow_width 16\n" \ "#define myarrow_height 16\n" \ "#define myarrow_x_hot 7\n" \ "#define myarrow_y_hot 0\n" \ "static unsigned char myarrow_bits[] = {\n" \ " 0x7f, 0xff, 0xbf, 0xfe, 0xdf, 0xfd, 0xef, 0xfb, 0xf7, 0xf7, 0xfb, 0xef,\n" \ " 0xfd, 0xdf, 0xfe, 0xbf, 0x80, 0x00, 0xbf, 0xfe, 0xbf, 0xfe, 0xbf, 0xfe,\n" \ " 0xbf, 0xfe, 0xbf, 0xfe, 0xbf, 0xfe, 0x3f, 0xfe};" #define CURSOR_MYARROW_MASK \ "#define myarrow-mask_width 16\n" \ "#define myarrow-mask_height 16\n" \ "#define myarrow-mask_x_hot 7\n" \ "#define myarrow-mask_y_hot 0\n" \ "static unsigned char myarrow-mask_bits[] = {\n" \ " 0x80, 0x00, 0xc0, 0x01, 0xe0, 0x03, 0xf0, 0x07, 0xf8, 0x0f, 0xfc, 0x1f,\n" \ " 0xfe, 0x3f, 0xff, 0x7f, 0xff, 0xff, 0xc0, 0x01, 0xc0, 0x01, 0xc0, 0x01,\n" \ " 0xc0, 0x01, 0xc0, 0x01, 0xc0, 0x01, 0xc0, 0x01};" #endif /* DEFINE_MYARROW_CURSOR */ static const struct TkCursorName { const char *name; const char *data; char *mask; } tkCursorNames[] = { {"none", CURSOR_NONE_DATA, NULL}, #ifdef DEFINE_MYARROW_CURSOR {"myarrow", CURSOR_MYARROW_DATA, CURSOR_MYARROW_MASK}, #endif /* DEFINE_MYARROW_CURSOR */ {NULL, NULL, NULL} }; /* * Font to use for cursors: */ #ifndef CURSORFONT #define CURSORFONT "cursor" #endif static Cursor CreateCursorFromTableOrFile(Tcl_Interp *interp, Tk_Window tkwin, int argc, const char **argv, const struct TkCursorName *tkCursorPtr); /* *---------------------------------------------------------------------- * * TkGetCursorByName -- * * Retrieve a cursor by name. Parse the cursor name into fields and * create a cursor, either from the standard cursor font or from bitmap * files. * * Results: * Returns a new cursor, or NULL on errors. * * Side effects: * Allocates a new cursor. * *---------------------------------------------------------------------- */ TkCursor * TkGetCursorByName( Tcl_Interp *interp, /* Interpreter to use for error reporting. */ Tk_Window tkwin, /* Window in which cursor will be used. */ Tk_Uid string) /* Description of cursor. See manual entry for * details on legal syntax. */ { TkUnixCursor *cursorPtr = NULL; Cursor cursor = None; int argc; const char **argv = NULL; Display *display = Tk_Display(tkwin); int inTkTable = 0; const struct TkCursorName *tkCursorPtr = NULL; if (Tcl_SplitList(interp, string, &argc, &argv) != TCL_OK) { return NULL; } if (argc == 0) { goto badString; } /* * Check Tk specific table of cursor names. The cursor names don't overlap * with cursors defined in the X table so search order does not matter. */ if (argv[0][0] != '@') { for (tkCursorPtr = tkCursorNames; ; tkCursorPtr++) { if (tkCursorPtr->name == NULL) { tkCursorPtr = NULL; break; } if ((tkCursorPtr->name[0] == argv[0][0]) && (strcmp(tkCursorPtr->name, argv[0]) == 0)) { inTkTable = 1; break; } } } if ((argv[0][0] != '@') && !inTkTable) { XColor fg, bg; unsigned int maskIndex; register const struct CursorName *namePtr; TkDisplay *dispPtr; /* * The cursor is to come from the standard cursor font. If one arg, it * is cursor name (use black and white for fg and bg). If two args, * they are name and fg color (ignore mask). If three args, they are * name, fg, bg. Some of the code below is stolen from the * XCreateFontCursor Xlib function. */ if (argc > 3) { goto badString; } for (namePtr = cursorNames; ; namePtr++) { if (namePtr->name == NULL) { goto badString; } if ((namePtr->name[0] == argv[0][0]) && (strcmp(namePtr->name, argv[0]) == 0)) { break; } } maskIndex = namePtr->shape + 1; if (argc == 1) { fg.red = fg.green = fg.blue = 0; bg.red = bg.green = bg.blue = 65535; } else { if (TkParseColor(display, Tk_Colormap(tkwin), argv[1], &fg) == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid color name \"%s\"", argv[1])); Tcl_SetErrorCode(interp, "TK", "CURSOR", "COLOR", NULL); goto cleanup; } if (argc == 2) { bg.red = bg.green = bg.blue = 0; maskIndex = namePtr->shape; } else if (TkParseColor(display, Tk_Colormap(tkwin), argv[2], &bg) == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid color name \"%s\"", argv[2])); Tcl_SetErrorCode(interp, "TK", "CURSOR", "COLOR", NULL); goto cleanup; } } dispPtr = ((TkWindow *) tkwin)->dispPtr; if (dispPtr->cursorFont == None) { dispPtr->cursorFont = XLoadFont(display, CURSORFONT); if (dispPtr->cursorFont == None) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "couldn't load cursor font", -1)); Tcl_SetErrorCode(interp, "TK", "CURSOR", "FONT", NULL); goto cleanup; } } cursor = XCreateGlyphCursor(display, dispPtr->cursorFont, dispPtr->cursorFont, namePtr->shape, maskIndex, &fg, &bg); } else { /* * Prevent file system access in safe interpreters. */ if (!inTkTable && Tcl_IsSafe(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "can't get cursor from a file in a safe interpreter", -1)); Tcl_SetErrorCode(interp, "TK", "SAFE", "CURSOR_FILE", NULL); cursorPtr = NULL; goto cleanup; } /* * If the cursor is to be created from bitmap files, then there should * be either two elements in the list (source, color) or four (source * mask fg bg). A cursor defined in the Tk table accepts the same * arguments as an X cursor. */ if (inTkTable && (argc != 1) && (argc != 2) && (argc != 3)) { goto badString; } if (!inTkTable && (argc != 2) && (argc != 4)) { goto badString; } cursor = CreateCursorFromTableOrFile(interp, tkwin, argc, argv, tkCursorPtr); } if (cursor != None) { cursorPtr = ckalloc(sizeof(TkUnixCursor)); cursorPtr->info.cursor = (Tk_Cursor) cursor; cursorPtr->display = display; } cleanup: if (argv != NULL) { ckfree(argv); } return (TkCursor *) cursorPtr; badString: if (argv) { ckfree(argv); } Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad cursor spec \"%s\"", string)); Tcl_SetErrorCode(interp, "TK", "VALUE", "CURSOR", NULL); return NULL; } /* *---------------------------------------------------------------------- * * CreateCursorFromTableOrFile -- * * Create a cursor defined in a file or the Tk static cursor table. A * cursor defined in a file starts with the '@' character. This method * assumes that the number of arguments in argv has been validated * already. * * Results: * Returns a new cursor, or None on error. * * Side effects: * Allocates a new X cursor. * *---------------------------------------------------------------------- */ static Cursor CreateCursorFromTableOrFile( Tcl_Interp *interp, /* Interpreter to use for error reporting. */ Tk_Window tkwin, /* Window in which cursor will be used. */ int argc, const char **argv, /* Cursor spec parsed into elements. */ const struct TkCursorName *tkCursorPtr) /* Non-NULL when cursor is defined in Tk * table. */ { Cursor cursor = None; int width, height, maskWidth, maskHeight; int xHot = -1, yHot = -1; int dummy1, dummy2; XColor fg, bg; const char *fgColor; const char *bgColor; int inTkTable = (tkCursorPtr != NULL); Display *display = Tk_Display(tkwin); Drawable drawable = RootWindowOfScreen(Tk_Screen(tkwin)); Pixmap source = None; Pixmap mask = None; /* * A cursor defined in a file accepts either 2 or 4 arguments. * * {srcfile fg} * {srcfile maskfile fg bg} * * A cursor defined in the Tk table accepts 1, 2, or 3 arguments. * * {tkcursorname} * {tkcursorname fg} * {tkcursorname fg bg} */ if (inTkTable) { /* * This logic is like TkReadBitmapFile(). */ char *data; data = TkGetBitmapData(NULL, tkCursorPtr->data, NULL, &width, &height, &xHot, &yHot); if (data == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "error reading bitmap data for \"%s\"", argv[0])); Tcl_SetErrorCode(interp, "TK", "CURSOR", "BITMAP_DATA", NULL); goto cleanup; } source = XCreateBitmapFromData(display, drawable, data, width,height); ckfree(data); } else { if (TkReadBitmapFile(display, drawable, &argv[0][1], (unsigned *) &width, (unsigned *) &height, &source, &xHot, &yHot) != BitmapSuccess) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "cleanup reading bitmap file \"%s\"", &argv[0][1])); Tcl_SetErrorCode(interp, "TK", "CURSOR", "BITMAP_FILE", NULL); goto cleanup; } } if ((xHot < 0) || (yHot < 0) || (xHot >= width) || (yHot >= height)) { if (inTkTable) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad hot spot in bitmap data for \"%s\"", argv[0])); } else { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad hot spot in bitmap file \"%s\"", &argv[0][1])); } Tcl_SetErrorCode(interp, "TK", "CURSOR", "HOTSPOT", NULL); goto cleanup; } /* * Parse color names from optional fg and bg arguments */ if (argc == 1) { fg.red = fg.green = fg.blue = 0; bg.red = bg.green = bg.blue = 65535; } else if (argc == 2) { fgColor = argv[1]; if (TkParseColor(display, Tk_Colormap(tkwin), fgColor, &fg) == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid color name \"%s\"", fgColor)); Tcl_SetErrorCode(interp, "TK", "CURSOR", "COLOR", NULL); goto cleanup; } if (inTkTable) { bg.red = bg.green = bg.blue = 0; } else { bg = fg; } } else { /* 3 or 4 arguments */ if (inTkTable) { fgColor = argv[1]; bgColor = argv[2]; } else { fgColor = argv[2]; bgColor = argv[3]; } if (TkParseColor(display, Tk_Colormap(tkwin), fgColor, &fg) == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid color name \"%s\"", fgColor)); Tcl_SetErrorCode(interp, "TK", "CURSOR", "COLOR", NULL); goto cleanup; } if (TkParseColor(display, Tk_Colormap(tkwin), bgColor, &bg) == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid color name \"%s\"", bgColor)); Tcl_SetErrorCode(interp, "TK", "CURSOR", "COLOR", NULL); goto cleanup; } } /* * If there is no mask data, then create the cursor now. */ if ((!inTkTable && (argc == 2)) || (inTkTable && tkCursorPtr->mask == NULL)) { cursor = XCreatePixmapCursor(display, source, source, &fg, &fg, (unsigned) xHot, (unsigned) yHot); goto cleanup; } /* * Parse bitmap mask data and create cursor with fg and bg colors. */ if (inTkTable) { /* * This logic is like TkReadBitmapFile(). */ char *data; data = TkGetBitmapData(NULL, tkCursorPtr->mask, NULL, &maskWidth, &maskHeight, &dummy1, &dummy2); if (data == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "error reading bitmap mask data for \"%s\"", argv[0])); Tcl_SetErrorCode(interp, "TK", "CURSOR", "MASK_DATA", NULL); goto cleanup; } mask = XCreateBitmapFromData(display, drawable, data, maskWidth, maskHeight); ckfree(data); } else { if (TkReadBitmapFile(display, drawable, argv[1], (unsigned int *) &maskWidth, (unsigned int *) &maskHeight, &mask, &dummy1, &dummy2) != BitmapSuccess) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "cleanup reading bitmap file \"%s\"", argv[1])); Tcl_SetErrorCode(interp, "TK", "CURSOR", "MASK_FILE", NULL); goto cleanup; } } if ((maskWidth != width) || (maskHeight != height)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "source and mask bitmaps have different sizes", -1)); Tcl_SetErrorCode(interp, "TK", "CURSOR", "SIZE_MATCH", NULL); goto cleanup; } cursor = XCreatePixmapCursor(display, source, mask, &fg, &bg, (unsigned) xHot, (unsigned) yHot); cleanup: if (source != None) { Tk_FreePixmap(display, source); } if (mask != None) { Tk_FreePixmap(display, mask); } return cursor; } /* *---------------------------------------------------------------------- * * TkCreateCursorFromData -- * * Creates a cursor from the source and mask bits. * * Results: * Returns a new cursor, or NULL on errors. * * Side effects: * Allocates a new cursor. * *---------------------------------------------------------------------- */ TkCursor * TkCreateCursorFromData( Tk_Window tkwin, /* Window in which cursor will be used. */ const char *source, /* Bitmap data for cursor shape. */ const char *mask, /* Bitmap data for cursor mask. */ int width, int height, /* Dimensions of cursor. */ int xHot, int yHot, /* Location of hot-spot in cursor. */ XColor fgColor, /* Foreground color for cursor. */ XColor bgColor) /* Background color for cursor. */ { Cursor cursor; Pixmap sourcePixmap, maskPixmap; TkUnixCursor *cursorPtr = NULL; Display *display = Tk_Display(tkwin); sourcePixmap = XCreateBitmapFromData(display, RootWindowOfScreen(Tk_Screen(tkwin)), source, (unsigned) width, (unsigned) height); maskPixmap = XCreateBitmapFromData(display, RootWindowOfScreen(Tk_Screen(tkwin)), mask, (unsigned) width, (unsigned) height); cursor = XCreatePixmapCursor(display, sourcePixmap, maskPixmap, &fgColor, &bgColor, (unsigned) xHot, (unsigned) yHot); Tk_FreePixmap(display, sourcePixmap); Tk_FreePixmap(display, maskPixmap); if (cursor != None) { cursorPtr = ckalloc(sizeof(TkUnixCursor)); cursorPtr->info.cursor = (Tk_Cursor) cursor; cursorPtr->display = display; } return (TkCursor *) cursorPtr; } /* *---------------------------------------------------------------------- * * TkpFreeCursor -- * * This function is called to release a cursor allocated by * TkGetCursorByName. * * Results: * None. * * Side effects: * The cursor data structure is deallocated. * *---------------------------------------------------------------------- */ void TkpFreeCursor( TkCursor *cursorPtr) { TkUnixCursor *unixCursorPtr = (TkUnixCursor *) cursorPtr; XFreeCursor(unixCursorPtr->display, (Cursor) unixCursorPtr->info.cursor); Tk_FreeXId(unixCursorPtr->display, (XID) unixCursorPtr->info.cursor); } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ tk8.6.5/unix/tkUnixFont.c0000644003604700454610000027625612377375532013766 0ustar dgp771div/* * tkUnixFont.c -- * * Contains the Unix implementation of the platform-independent font * package interface. * * Copyright (c) 1996-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tkUnixInt.h" #include "tkFont.h" #include /* for htons() prototype */ #include /* inet_ntoa() */ /* * The preferred font encodings. */ static const char *const encodingList[] = { "iso8859-1", "jis0208", "jis0212", NULL }; /* * The following structure represents a font family. It is assumed that all * screen fonts constructed from the same "font family" share certain * properties; all screen fonts with the same "font family" point to a shared * instance of this structure. The most important shared property is the * character existence metrics, used to determine if a screen font can display * a given Unicode character. * * Under Unix, there are three attributes that uniquely identify a "font * family": the foundry, face name, and charset. */ #define FONTMAP_SHIFT 10 #define FONTMAP_PAGES (1 << (sizeof(Tcl_UniChar)*8 - FONTMAP_SHIFT)) #define FONTMAP_BITSPERPAGE (1 << FONTMAP_SHIFT) typedef struct FontFamily { struct FontFamily *nextPtr; /* Next in list of all known font families. */ int refCount; /* How many SubFonts are referring to this * FontFamily. When the refCount drops to * zero, this FontFamily may be freed. */ /* * Key. */ Tk_Uid foundry; /* Foundry key for this FontFamily. */ Tk_Uid faceName; /* Face name key for this FontFamily. */ Tcl_Encoding encoding; /* Encoding key for this FontFamily. */ /* * Derived properties. */ int isTwoByteFont; /* 1 if this is a double-byte font, 0 * otherwise. */ char *fontMap[FONTMAP_PAGES]; /* Two-level sparse table used to determine * quickly if the specified character exists. * As characters are encountered, more pages * in this table are dynamically alloced. The * contents of each page is a bitmask * consisting of FONTMAP_BITSPERPAGE bits, * representing whether this font can be used * to display the given character at the * corresponding bit position. The high bits * of the character are used to pick which * page of the table is used. */ } FontFamily; /* * The following structure encapsulates an individual screen font. A font * object is made up of however many SubFonts are necessary to display a * stream of multilingual characters. */ typedef struct SubFont { char **fontMap; /* Pointer to font map from the FontFamily, * cached here to save a dereference. */ XFontStruct *fontStructPtr; /* The specific screen font that will be used * when displaying/measuring chars belonging * to the FontFamily. */ FontFamily *familyPtr; /* The FontFamily for this SubFont. */ } SubFont; /* * The following structure represents Unix's implementation of a font object. */ #define SUBFONT_SPACE 3 #define BASE_CHARS 256 typedef struct UnixFont { TkFont font; /* Stuff used by generic font package. Must be * first in structure. */ SubFont staticSubFonts[SUBFONT_SPACE]; /* Builtin space for a limited number of * SubFonts. */ int numSubFonts; /* Length of following array. */ SubFont *subFontArray; /* Array of SubFonts that have been loaded in * order to draw/measure all the characters * encountered by this font so far. All fonts * start off with one SubFont initialized by * AllocFont() from the original set of font * attributes. Usually points to * staticSubFonts, but may point to malloced * space if there are lots of SubFonts. */ SubFont controlSubFont; /* Font to use to display control-character * expansions. */ Display *display; /* Display that owns font. */ int pixelSize; /* Original pixel size used when font was * constructed. */ TkXLFDAttributes xa; /* Additional attributes that specify the * preferred foundry and encoding to use when * constructing additional SubFonts. */ int widths[BASE_CHARS]; /* Widths of first 256 chars in the base font, * for handling common case. */ int underlinePos; /* Offset from baseline to origin of underline * bar (used when drawing underlined font) * (pixels). */ int barHeight; /* Height of underline or overstrike bar (used * when drawing underlined or strikeout font) * (pixels). */ } UnixFont; /* * The following structure and definition is used to keep track of the * alternative names for various encodings. Asking for an encoding that * matches one of the alias patterns will result in actually getting the * encoding by its real name. */ typedef struct EncodingAlias { const char *realName; /* The real name of the encoding to load if * the provided name matched the pattern. */ const char *aliasPattern; /* Pattern for encoding name, of the form that * is acceptable to Tcl_StringMatch. */ } EncodingAlias; /* * Just some utility structures used for passing around values in helper * functions. */ typedef struct FontAttributes { TkFontAttributes fa; TkXLFDAttributes xa; } FontAttributes; typedef struct ThreadSpecificData { FontFamily *fontFamilyList; /* The list of font families that are * currently loaded. As screen fonts are * loaded, this list grows to hold information * about what characters exist in each font * family. */ FontFamily controlFamily; /* FontFamily used to handle control character * expansions. The encoding of this FontFamily * converts UTF-8 to backslashed escape * sequences. */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; /* * The set of builtin encoding alises to convert the XLFD names for the * encodings into the names expected by the Tcl encoding package. */ static EncodingAlias encodingAliases[] = { {"gb2312-raw", "gb2312*"}, {"big5", "big5*"}, {"cns11643-1", "cns11643*-1"}, {"cns11643-1", "cns11643*.1-0"}, {"cns11643-2", "cns11643*-2"}, {"cns11643-2", "cns11643*.2-0"}, {"jis0201", "jisx0201*"}, {"jis0201", "jisx0202*"}, {"jis0208", "jisc6226*"}, {"jis0208", "jisx0208*"}, {"jis0212", "jisx0212*"}, {"tis620", "tis620*"}, {"ksc5601", "ksc5601*"}, {"dingbats", "*dingbats"}, #ifdef WORDS_BIGENDIAN {"unicode", "iso10646-1"}, #else /* * ucs-2be is needed if native order isn't BE. */ {"ucs-2be", "iso10646-1"}, #endif {NULL, NULL} }; /* * Functions used only in this file. */ static void FontPkgCleanup(ClientData clientData); static FontFamily * AllocFontFamily(Display *display, XFontStruct *fontStructPtr, int base); static SubFont * CanUseFallback(UnixFont *fontPtr, const char *fallbackName, int ch, SubFont **fixSubFontPtrPtr); static SubFont * CanUseFallbackWithAliases(UnixFont *fontPtr, const char *fallbackName, int ch, Tcl_DString *nameTriedPtr, SubFont **fixSubFontPtrPtr); static int ControlUtfProc(ClientData clientData, const char *src, int srcLen, int flags, Tcl_EncodingState*statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); static XFontStruct * CreateClosestFont(Tk_Window tkwin, const TkFontAttributes *faPtr, const TkXLFDAttributes *xaPtr); static SubFont * FindSubFontForChar(UnixFont *fontPtr, int ch, SubFont **fixSubFontPtrPtr); static void FontMapInsert(SubFont *subFontPtr, int ch); static void FontMapLoadPage(SubFont *subFontPtr, int row); static int FontMapLookup(SubFont *subFontPtr, int ch); static void FreeFontFamily(FontFamily *afPtr); static const char * GetEncodingAlias(const char *name); static int GetFontAttributes(Display *display, XFontStruct *fontStructPtr, FontAttributes *faPtr); static XFontStruct * GetScreenFont(Display *display, FontAttributes *wantPtr, char **nameList, int bestIdx[], unsigned bestScore[]); static XFontStruct * GetSystemFont(Display *display); static int IdentifySymbolEncodings(FontAttributes *faPtr); static void InitFont(Tk_Window tkwin, XFontStruct *fontStructPtr, UnixFont *fontPtr); static void InitSubFont(Display *display, XFontStruct *fontStructPtr, int base, SubFont *subFontPtr); static char ** ListFonts(Display *display, const char *faceName, int *numNamesPtr); static char ** ListFontOrAlias(Display *display, const char*faceName, int *numNamesPtr); static unsigned RankAttributes(FontAttributes *wantPtr, FontAttributes *gotPtr); static void ReleaseFont(UnixFont *fontPtr); static void ReleaseSubFont(Display *display, SubFont *subFontPtr); static int SeenName(const char *name, Tcl_DString *dsPtr); #ifndef WORDS_BIGENDIAN static int Ucs2beToUtfProc(ClientData clientData, const char*src, int srcLen, int flags, Tcl_EncodingState*statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); static int UtfToUcs2beProc(ClientData clientData, const char*src, int srcLen, int flags, Tcl_EncodingState*statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); #endif /* *------------------------------------------------------------------------- * * FontPkgCleanup -- * * This function is called when an application is created. It initializes * all the structures that are used by the platform-dependent code on a * per application basis. * * Results: * None. * * Side effects: * Releases thread-specific resources used by font pkg. * *------------------------------------------------------------------------- */ static void FontPkgCleanup( ClientData clientData) { ThreadSpecificData *tsdPtr = Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); if (tsdPtr->controlFamily.encoding != NULL) { FontFamily *familyPtr = &tsdPtr->controlFamily; int i; Tcl_FreeEncoding(familyPtr->encoding); for (i = 0; i < FONTMAP_PAGES; i++) { if (familyPtr->fontMap[i] != NULL) { ckfree(familyPtr->fontMap[i]); } } tsdPtr->controlFamily.encoding = NULL; } } /* *------------------------------------------------------------------------- * * TkpFontPkgInit -- * * This function is called when an application is created. It initializes * all the structures that are used by the platform-dependent code on a * per application basis. * * Results: * None. * * Side effects: * None. * *------------------------------------------------------------------------- */ void TkpFontPkgInit( TkMainInfo *mainPtr) /* The application being created. */ { ThreadSpecificData *tsdPtr = Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); Tcl_EncodingType type; SubFont dummy; int i; if (tsdPtr->controlFamily.encoding == NULL) { type.encodingName = "X11ControlChars"; type.toUtfProc = ControlUtfProc; type.fromUtfProc = ControlUtfProc; type.freeProc = NULL; type.clientData = NULL; type.nullSize = 0; tsdPtr->controlFamily.refCount = 2; tsdPtr->controlFamily.encoding = Tcl_CreateEncoding(&type); tsdPtr->controlFamily.isTwoByteFont = 0; dummy.familyPtr = &tsdPtr->controlFamily; dummy.fontMap = tsdPtr->controlFamily.fontMap; for (i = 0x00; i < 0x20; i++) { FontMapInsert(&dummy, i); FontMapInsert(&dummy, i + 0x80); } #ifndef WORDS_BIGENDIAN /* * UCS-2BE is unicode (UCS-2) in big-endian format. Define this if * native order isn't BE. It is used in iso10646 fonts. */ type.encodingName = "ucs-2be"; type.toUtfProc = Ucs2beToUtfProc; type.fromUtfProc = UtfToUcs2beProc; type.freeProc = NULL; type.clientData = NULL; type.nullSize = 2; Tcl_CreateEncoding(&type); #endif Tcl_CreateThreadExitHandler(FontPkgCleanup, NULL); } } /* *------------------------------------------------------------------------- * * ControlUtfProc -- * * Convert from UTF-8 into the ASCII expansion of a control character. * * Results: * Returns TCL_OK if conversion was successful. * * Side effects: * None. * *------------------------------------------------------------------------- */ static int ControlUtfProc( ClientData clientData, /* Not used. */ const char *src, /* Source string in UTF-8. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ Tcl_EncodingState *statePtr,/* Place for conversion routine to store state * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ char *dst, /* Output buffer in which converted string is * stored. */ int dstLen, /* The maximum length of output buffer in * bytes. */ int *srcReadPtr, /* Filled with the number of bytes from the * source string that were converted. This may * be less than the original source length if * there was a problem converting some source * characters. */ int *dstWrotePtr, /* Filled with the number of bytes that were * stored in the output buffer as a result of * the conversion. */ int *dstCharsPtr) /* Filled with the number of characters that * correspond to the bytes stored in the * output buffer. */ { const char *srcStart, *srcEnd; char *dstStart, *dstEnd; Tcl_UniChar ch; int result; static char hexChars[] = "0123456789abcdef"; static char mapChars[] = { 0, 0, 0, 0, 0, 0, 0, 'a', 'b', 't', 'n', 'v', 'f', 'r' }; result = TCL_OK; srcStart = src; srcEnd = src + srcLen; dstStart = dst; dstEnd = dst + dstLen - 6; for ( ; src < srcEnd; ) { if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; break; } src += Tcl_UtfToUniChar(src, &ch); dst[0] = '\\'; if ((ch < sizeof(mapChars)) && (mapChars[ch] != 0)) { dst[1] = mapChars[ch]; dst += 2; } else if (ch < 256) { dst[1] = 'x'; dst[2] = hexChars[(ch >> 4) & 0xf]; dst[3] = hexChars[ch & 0xf]; dst += 4; } else { dst[1] = 'u'; dst[2] = hexChars[(ch >> 12) & 0xf]; dst[3] = hexChars[(ch >> 8) & 0xf]; dst[4] = hexChars[(ch >> 4) & 0xf]; dst[5] = hexChars[ch & 0xf]; dst += 6; } } *srcReadPtr = src - srcStart; *dstWrotePtr = dst - dstStart; *dstCharsPtr = dst - dstStart; return result; } #ifndef WORDS_BIGENDIAN /* *------------------------------------------------------------------------- * * Ucs2beToUtfProc -- * * Convert from UCS-2BE (big-endian 16-bit Unicode) to UTF-8. * This is only defined on LE machines. * * Results: * Returns TCL_OK if conversion was successful. * * Side effects: * None. * *------------------------------------------------------------------------- */ static int Ucs2beToUtfProc( ClientData clientData, /* Not used. */ const char *src, /* Source string in Unicode. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ Tcl_EncodingState *statePtr,/* Place for conversion routine to store state * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ char *dst, /* Output buffer in which converted string is * stored. */ int dstLen, /* The maximum length of output buffer in * bytes. */ int *srcReadPtr, /* Filled with the number of bytes from the * source string that were converted. This may * be less than the original source length if * there was a problem converting some source * characters. */ int *dstWrotePtr, /* Filled with the number of bytes that were * stored in the output buffer as a result of * the conversion. */ int *dstCharsPtr) /* Filled with the number of characters that * correspond to the bytes stored in the * output buffer. */ { const char *srcStart, *srcEnd; char *dstEnd, *dstStart; int result, numChars; result = TCL_OK; /* check alignment with ucs-2 (2 == sizeof(UCS-2)) */ if ((srcLen % 2) != 0) { result = TCL_CONVERT_MULTIBYTE; srcLen--; } srcStart = src; srcEnd = src + srcLen; dstStart = dst; dstEnd = dst + dstLen - TCL_UTF_MAX; for (numChars = 0; src < srcEnd; numChars++) { if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; break; } /* * Need to swap byte-order on little-endian machines (x86) for * UCS-2BE. We know this is an LE->BE swap. */ dst += Tcl_UniCharToUtf(htons(*((short *)src)), dst); src += 2 /* sizeof(UCS-2) */; } *srcReadPtr = src - srcStart; *dstWrotePtr = dst - dstStart; *dstCharsPtr = numChars; return result; } /* *------------------------------------------------------------------------- * * UtfToUcs2beProc -- * * Convert from UTF-8 to UCS-2BE (fixed 2-byte encoding). * * Results: * Returns TCL_OK if conversion was successful. * * Side effects: * None. * *------------------------------------------------------------------------- */ static int UtfToUcs2beProc( ClientData clientData, /* TableEncodingData that specifies * encoding. */ const char *src, /* Source string in UTF-8. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ Tcl_EncodingState *statePtr,/* Place for conversion routine to store state * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ char *dst, /* Output buffer in which converted string is * stored. */ int dstLen, /* The maximum length of output buffer in * bytes. */ int *srcReadPtr, /* Filled with the number of bytes from the * source string that were converted. This may * be less than the original source length if * there was a problem converting some source * characters. */ int *dstWrotePtr, /* Filled with the number of bytes that were * stored in the output buffer as a result of * the conversion. */ int *dstCharsPtr) /* Filled with the number of characters that * correspond to the bytes stored in the * output buffer. */ { const char *srcStart, *srcEnd, *srcClose, *dstStart, *dstEnd; int result, numChars; Tcl_UniChar ch; srcStart = src; srcEnd = src + srcLen; srcClose = srcEnd; if (!(flags & TCL_ENCODING_END)) { srcClose -= TCL_UTF_MAX; } dstStart = dst; dstEnd = dst + dstLen - 2 /* sizeof(UCS-2) */; result = TCL_OK; for (numChars = 0; src < srcEnd; numChars++) { if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) { /* * If there is more string to follow, this will ensure that the * last UTF-8 character in the source buffer hasn't been cut off. */ result = TCL_CONVERT_MULTIBYTE; break; } if (dst > dstEnd) { result = TCL_CONVERT_NOSPACE; break; } src += Tcl_UtfToUniChar(src, &ch); /* * Ensure big-endianness (store big bits first). * XXX: This hard-codes the assumed size of Tcl_UniChar as 2. Make * sure to work in char* for Tcl_UtfToUniChar alignment. [Bug 1122671] */ *dst++ = (ch >> 8); *dst++ = (ch & 0xFF); } *srcReadPtr = src - srcStart; *dstWrotePtr = dst - dstStart; *dstCharsPtr = numChars; return result; } #endif /* WORDS_BIGENDIAN */ /* *--------------------------------------------------------------------------- * * TkpGetNativeFont -- * * Map a platform-specific native font name to a TkFont. * * Results: * The return value is a pointer to a TkFont that represents the native * font. If a native font by the given name could not be found, the * return value is NULL. * * Every call to this function returns a new TkFont structure, even if * the name has already been seen before. The caller should call * TkpDeleteFont() when the font is no longer needed. * * The caller is responsible for initializing the memory associated with * the generic TkFont when this function returns and releasing the * contents of the generic TkFont before calling TkpDeleteFont(). * * Side effects: * Memory allocated. * *--------------------------------------------------------------------------- */ TkFont * TkpGetNativeFont( Tk_Window tkwin, /* For display where font will be used. */ const char *name) /* Platform-specific font name. */ { UnixFont *fontPtr; XFontStruct *fontStructPtr; FontAttributes fa; const char *p; int hasSpace, dashes, hasWild; /* * The behavior of X when given a name that isn't an XLFD is unspecified. * For example, Exceed 6 returns a valid font for any random string. This * is awkward since system names have higher priority than the other Tk * font syntaxes. So, we need to perform a quick sanity check on the name * and fail if it looks suspicious. We fail if the name: * - contains a space immediately before a dash * - contains a space, but no '*' characters and fewer than 14 dashes */ hasSpace = dashes = hasWild = 0; for (p = name; *p != '\0'; p++) { if (*p == ' ') { if (p[1] == '-') { return NULL; } hasSpace = 1; } else if (*p == '-') { dashes++; } else if (*p == '*') { hasWild = 1; } } if ((dashes < 14) && !hasWild && hasSpace) { return NULL; } fontStructPtr = XLoadQueryFont(Tk_Display(tkwin), name); if (fontStructPtr == NULL) { /* * Handle all names that look like XLFDs here. Otherwise, when * TkpGetFontFromAttributes is called from generic code, any foundry * or encoding information specified in the XLFD will have been parsed * out and lost. But make sure we don't have an "-option value" string * since TkFontParseXLFD would return a false success when attempting * to parse it. */ if (name[0] == '-') { if (name[1] != '*') { char *dash; dash = strchr(name + 1, '-'); if ((dash == NULL) || (isspace(UCHAR(dash[-1])))) { return NULL; } } } else if (name[0] != '*') { return NULL; } if (TkFontParseXLFD(name, &fa.fa, &fa.xa) != TCL_OK) { return NULL; } fontStructPtr = CreateClosestFont(tkwin, &fa.fa, &fa.xa); } fontPtr = ckalloc(sizeof(UnixFont)); InitFont(tkwin, fontStructPtr, fontPtr); return (TkFont *) fontPtr; } /* *--------------------------------------------------------------------------- * * TkpGetFontFromAttributes -- * * Given a desired set of attributes for a font, find a font with the * closest matching attributes. * * Results: * The return value is a pointer to a TkFont that represents the font * with the desired attributes. If a font with the desired attributes * could not be constructed, some other font will be substituted * automatically. * * Every call to this function returns a new TkFont structure, even if * the specified attributes have already been seen before. The caller * should call TkpDeleteFont() to free the platform- specific data when * the font is no longer needed. * * The caller is responsible for initializing the memory associated with * the generic TkFont when this function returns and releasing the * contents of the generic TkFont before calling TkpDeleteFont(). * * Side effects: * Memory allocated. * *--------------------------------------------------------------------------- */ TkFont * TkpGetFontFromAttributes( TkFont *tkFontPtr, /* If non-NULL, store the information in this * existing TkFont structure, rather than * allocating a new structure to hold the * font; the existing contents of the font * will be released. If NULL, a new TkFont * structure is allocated. */ Tk_Window tkwin, /* For display where font will be used. */ const TkFontAttributes *faPtr) /* Set of attributes to match. */ { UnixFont *fontPtr; TkXLFDAttributes xa; XFontStruct *fontStructPtr; TkInitXLFDAttributes(&xa); fontStructPtr = CreateClosestFont(tkwin, faPtr, &xa); fontPtr = (UnixFont *) tkFontPtr; if (fontPtr == NULL) { fontPtr = ckalloc(sizeof(UnixFont)); } else { ReleaseFont(fontPtr); } InitFont(tkwin, fontStructPtr, fontPtr); fontPtr->font.fa.underline = faPtr->underline; fontPtr->font.fa.overstrike = faPtr->overstrike; return (TkFont *) fontPtr; } /* *--------------------------------------------------------------------------- * * TkpDeleteFont -- * * Called to release a font allocated by TkpGetNativeFont() or * TkpGetFontFromAttributes(). The caller should have already released * the fields of the TkFont that are used exclusively by the generic * TkFont code. * * Results: * None. * * Side effects: * TkFont is deallocated. * *--------------------------------------------------------------------------- */ void TkpDeleteFont( TkFont *tkFontPtr) /* Token of font to be deleted. */ { UnixFont *fontPtr = (UnixFont *) tkFontPtr; ReleaseFont(fontPtr); } /* *--------------------------------------------------------------------------- * * TkpGetFontFamilies -- * * Return information about the font families that are available on the * display of the given window. * * Results: * Modifies interp's result object to hold a list of all the available * font families. * * Side effects: * None. * *--------------------------------------------------------------------------- */ void TkpGetFontFamilies( Tcl_Interp *interp, /* Interp to hold result. */ Tk_Window tkwin) /* For display to query. */ { int i, new, numNames; char *family, **nameList; Tcl_HashTable familyTable; Tcl_HashEntry *hPtr; Tcl_HashSearch search; Tcl_Obj *resultPtr, *strPtr; Tcl_InitHashTable(&familyTable, TCL_STRING_KEYS); nameList = ListFonts(Tk_Display(tkwin), "*", &numNames); for (i = 0; i < numNames; i++) { char *familyEnd; family = strchr(nameList[i] + 1, '-'); if (family == NULL) { /* * Apparently, sometimes ListFonts() can return a font name with * zero or one '-' character in it. This is probably indicative of * a server misconfiguration, but crashing because of it is a very * bad idea anyway. [Bug 1475865] */ continue; } family++; /* Advance to char after '-'. */ familyEnd = strchr(family, '-'); if (familyEnd == NULL) { continue; /* See comment above. */ } *familyEnd = '\0'; Tcl_CreateHashEntry(&familyTable, family, &new); } XFreeFontNames(nameList); hPtr = Tcl_FirstHashEntry(&familyTable, &search); resultPtr = Tcl_NewObj(); while (hPtr != NULL) { strPtr = Tcl_NewStringObj(Tcl_GetHashKey(&familyTable, hPtr), -1); Tcl_ListObjAppendElement(NULL, resultPtr, strPtr); hPtr = Tcl_NextHashEntry(&search); } Tcl_SetObjResult(interp, resultPtr); Tcl_DeleteHashTable(&familyTable); } /* *------------------------------------------------------------------------- * * TkpGetSubFonts -- * * A function used by the testing package for querying the actual screen * fonts that make up a font object. * * Results: * Modifies interp's result object to hold a list containing the names of * the screen fonts that make up the given font object. * * Side effects: * None. * *------------------------------------------------------------------------- */ void TkpGetSubFonts( Tcl_Interp *interp, Tk_Font tkfont) { int i; Tcl_Obj *objv[3], *resultPtr, *listPtr; UnixFont *fontPtr; FontFamily *familyPtr; resultPtr = Tcl_NewObj(); fontPtr = (UnixFont *) tkfont; for (i = 0; i < fontPtr->numSubFonts; i++) { familyPtr = fontPtr->subFontArray[i].familyPtr; objv[0] = Tcl_NewStringObj(familyPtr->faceName, -1); objv[1] = Tcl_NewStringObj(familyPtr->foundry, -1); objv[2] = Tcl_NewStringObj( Tcl_GetEncodingName(familyPtr->encoding), -1); listPtr = Tcl_NewListObj(3, objv); Tcl_ListObjAppendElement(NULL, resultPtr, listPtr); } Tcl_SetObjResult(interp, resultPtr); } /* *---------------------------------------------------------------------- * * TkpGetFontAttrsForChar -- * * Retrieve the font attributes of the actual font used to render a given * character. * * Results: * None. * * Side effects: * The font attributes are stored in *faPtr. * *---------------------------------------------------------------------- */ void TkpGetFontAttrsForChar( Tk_Window tkwin, /* Window on the font's display */ Tk_Font tkfont, /* Font to query */ Tcl_UniChar c, /* Character of interest */ TkFontAttributes *faPtr) /* Output: Font attributes */ { FontAttributes atts; UnixFont *fontPtr = (UnixFont *) tkfont; /* Structure describing the logical font */ SubFont *lastSubFontPtr = &fontPtr->subFontArray[0]; /* Pointer to subfont array in case * FindSubFontForChar needs to fix up the * memory allocation */ SubFont *thisSubFontPtr = FindSubFontForChar(fontPtr, c, &lastSubFontPtr); /* Pointer to the subfont to use for the given * character */ GetFontAttributes(Tk_Display(tkwin), thisSubFontPtr->fontStructPtr, &atts); *faPtr = atts.fa; } /* *--------------------------------------------------------------------------- * * Tk_MeasureChars -- * * Determine the number of characters from the string that will fit in * the given horizontal span. The measurement is done under the * assumption that Tk_DrawChars() will be used to actually display the * characters. * * Results: * The return value is the number of bytes from source that fit into the * span that extends from 0 to maxLength. *lengthPtr is filled with the * x-coordinate of the right edge of the last character that did fit. * * Side effects: * None. * *--------------------------------------------------------------------------- */ int Tk_MeasureChars( Tk_Font tkfont, /* Font in which characters will be drawn. */ const char *source, /* UTF-8 string to be displayed. Need not be * '\0' terminated. */ int numBytes, /* Maximum number of bytes to consider from * source string. */ int maxLength, /* If >= 0, maxLength specifies the longest * permissible line length in pixels; don't * consider any character that would cross * this x-position. If < 0, then line length * is unbounded and the flags argument is * ignored. */ int flags, /* Various flag bits OR-ed together: * TK_PARTIAL_OK means include the last char * which only partially fit on this line. * TK_WHOLE_WORDS means stop on a word * boundary, if possible. TK_AT_LEAST_ONE * means return at least one character even if * no characters fit. */ int *lengthPtr) /* Filled with x-location just after the * terminating character. */ { UnixFont *fontPtr; SubFont *lastSubFontPtr; int curX, curByte; /* * Unix does not use kerning or fractional character widths when * displaying text on the screen. So that means we can safely measure * individual characters or spans of characters and add up the widths w/o * any "off-by-one-pixel" errors. */ fontPtr = (UnixFont *) tkfont; lastSubFontPtr = &fontPtr->subFontArray[0]; if (numBytes == 0) { curX = 0; curByte = 0; } else if (maxLength < 0) { const char *p, *end, *next; Tcl_UniChar ch; SubFont *thisSubFontPtr; FontFamily *familyPtr; Tcl_DString runString; /* * A three step process: * 1. Find a contiguous range of characters that can all be * represented by a single screen font. * 2. Convert those chars to the encoding of that font. * 3. Measure converted chars. */ curX = 0; end = source + numBytes; for (p = source; p < end; ) { next = p + Tcl_UtfToUniChar(p, &ch); thisSubFontPtr = FindSubFontForChar(fontPtr, ch, &lastSubFontPtr); if (thisSubFontPtr != lastSubFontPtr) { familyPtr = lastSubFontPtr->familyPtr; Tcl_UtfToExternalDString(familyPtr->encoding, source, p - source, &runString); if (familyPtr->isTwoByteFont) { curX += XTextWidth16(lastSubFontPtr->fontStructPtr, (XChar2b *) Tcl_DStringValue(&runString), Tcl_DStringLength(&runString) / 2); } else { curX += XTextWidth(lastSubFontPtr->fontStructPtr, Tcl_DStringValue(&runString), Tcl_DStringLength(&runString)); } Tcl_DStringFree(&runString); lastSubFontPtr = thisSubFontPtr; source = p; } p = next; } familyPtr = lastSubFontPtr->familyPtr; Tcl_UtfToExternalDString(familyPtr->encoding, source, p - source, &runString); if (familyPtr->isTwoByteFont) { curX += XTextWidth16(lastSubFontPtr->fontStructPtr, (XChar2b *) Tcl_DStringValue(&runString), Tcl_DStringLength(&runString) >> 1); } else { curX += XTextWidth(lastSubFontPtr->fontStructPtr, Tcl_DStringValue(&runString), Tcl_DStringLength(&runString)); } Tcl_DStringFree(&runString); curByte = numBytes; } else { const char *p, *end, *next, *term; int newX, termX, sawNonSpace, dstWrote; Tcl_UniChar ch; FontFamily *familyPtr; XChar2b buf[8]; /* * How many chars will fit in the space allotted? This first version * may be inefficient because it measures every character * individually. */ next = source + Tcl_UtfToUniChar(source, &ch); newX = curX = termX = 0; term = source; end = source + numBytes; sawNonSpace = (ch > 255) || !isspace(ch); familyPtr = lastSubFontPtr->familyPtr; for (p = source; ; ) { if ((ch < BASE_CHARS) && (fontPtr->widths[ch] != 0)) { newX += fontPtr->widths[ch]; } else { lastSubFontPtr = FindSubFontForChar(fontPtr, ch, NULL); familyPtr = lastSubFontPtr->familyPtr; Tcl_UtfToExternal(NULL, familyPtr->encoding, p, next - p, 0, NULL, (char *)&buf[0].byte1, sizeof(buf), NULL, &dstWrote, NULL); if (familyPtr->isTwoByteFont) { newX += XTextWidth16(lastSubFontPtr->fontStructPtr, buf, dstWrote >> 1); } else { newX += XTextWidth(lastSubFontPtr->fontStructPtr, (char *)&buf[0].byte1, dstWrote); } } if (newX > maxLength) { break; } curX = newX; p = next; if (p >= end) { term = end; termX = curX; break; } next += Tcl_UtfToUniChar(next, &ch); if ((ch < 256) && isspace(ch)) { if (sawNonSpace) { term = p; termX = curX; sawNonSpace = 0; } } else { sawNonSpace = 1; } } /* * P points to the first character that doesn't fit in the desired * span. Use the flags to figure out what to return. */ if ((flags & TK_PARTIAL_OK) && (p < end) && (curX < maxLength)) { /* * Include the first character that didn't quite fit in the * desired span. The width returned will include the width of that * extra character. */ curX = newX; p += Tcl_UtfToUniChar(p, &ch); } if ((flags & TK_AT_LEAST_ONE) && (term == source) && (p < end)) { term = p; termX = curX; if (term == source) { term += Tcl_UtfToUniChar(term, &ch); termX = newX; } } else if ((p >= end) || !(flags & TK_WHOLE_WORDS)) { term = p; termX = curX; } curX = termX; curByte = term - source; } *lengthPtr = curX; return curByte; } /* *--------------------------------------------------------------------------- * * TkpMeasureCharsInContext -- * * Determine the number of bytes from the string that will fit in the * given horizontal span. The measurement is done under the assumption * that TkpDrawCharsInContext() will be used to actually display the * characters. * * This one is almost the same as Tk_MeasureChars(), but with access to * all the characters on the line for context. On X11 this context isn't * consulted, so we just call Tk_MeasureChars(). * * Results: * The return value is the number of bytes from source that fit into the * span that extends from 0 to maxLength. *lengthPtr is filled with the * x-coordinate of the right edge of the last character that did fit. * * Side effects: * None. * *--------------------------------------------------------------------------- */ int TkpMeasureCharsInContext( Tk_Font tkfont, /* Font in which characters will be drawn. */ const char *source, /* UTF-8 string to be displayed. Need not be * '\0' terminated. */ int numBytes, /* Maximum number of bytes to consider from * source string in all. */ int rangeStart, /* Index of first byte to measure. */ int rangeLength, /* Length of range to measure in bytes. */ int maxLength, /* If >= 0, maxLength specifies the longest * permissible line length; don't consider any * character that would cross this x-position. * If < 0, then line length is unbounded and * the flags argument is ignored. */ int flags, /* Various flag bits OR-ed together: * TK_PARTIAL_OK means include the last char * which only partially fit on this line. * TK_WHOLE_WORDS means stop on a word * boundary, if possible. TK_AT_LEAST_ONE * means return at least one character even if * no characters fit. TK_ISOLATE_END means * that the last character should not be * considered in context with the rest of the * string (used for breaking lines). */ int *lengthPtr) /* Filled with x-location just after the * terminating character. */ { (void) numBytes; /*unused*/ return Tk_MeasureChars(tkfont, source + rangeStart, rangeLength, maxLength, flags, lengthPtr); } /* *--------------------------------------------------------------------------- * * Tk_DrawChars -- * * Draw a string of characters on the screen. Tk_DrawChars() expands * control characters that occur in the string to \xNN sequences. * * Results: * None. * * Side effects: * Information gets drawn on the screen. * *--------------------------------------------------------------------------- */ void Tk_DrawChars( Display *display, /* Display on which to draw. */ Drawable drawable, /* Window or pixmap in which to draw. */ GC gc, /* Graphics context for drawing characters. */ Tk_Font tkfont, /* Font in which characters will be drawn; * must be the same as font used in GC. */ const char *source, /* UTF-8 string to be displayed. Need not be * '\0' terminated. All Tk meta-characters * (tabs, control characters, and newlines) * should be stripped out of the string that * is passed to this function. If they are not * stripped out, they will be displayed as * regular printing characters. */ int numBytes, /* Number of bytes in string. */ int x, int y) /* Coordinates at which to place origin of * string when drawing. */ { UnixFont *fontPtr = (UnixFont *) tkfont; SubFont *thisSubFontPtr, *lastSubFontPtr; Tcl_DString runString; const char *p, *end, *next; int xStart, needWidth, window_width, do_width; Tcl_UniChar ch; FontFamily *familyPtr; #ifdef TK_DRAW_CHAR_XWINDOW_CHECK int rx, ry; unsigned width, height, border_width, depth; Drawable root; #endif lastSubFontPtr = &fontPtr->subFontArray[0]; xStart = x; #ifdef TK_DRAW_CHAR_XWINDOW_CHECK /* * Get the window width so we can abort drawing outside of the window */ if (XGetGeometry(display, drawable, &root, &rx, &ry, &width, &height, &border_width, &depth) == False) { window_width = INT_MAX; } else { window_width = width; } #else /* * This is used by default until we find a solution that doesn't do a * round-trip to the X server (needed to get Tk cached window width). */ window_width = 32768; #endif end = source + numBytes; needWidth = fontPtr->font.fa.underline + fontPtr->font.fa.overstrike; for (p = source; p <= end; ) { if (p < end) { next = p + Tcl_UtfToUniChar(p, &ch); thisSubFontPtr = FindSubFontForChar(fontPtr, ch, &lastSubFontPtr); } else { next = p + 1; thisSubFontPtr = lastSubFontPtr; } if ((thisSubFontPtr != lastSubFontPtr) || (p == end) || (p-source > 200)) { if (p > source) { do_width = (needWidth || (p != end)) ? 1 : 0; familyPtr = lastSubFontPtr->familyPtr; Tcl_UtfToExternalDString(familyPtr->encoding, source, p - source, &runString); if (familyPtr->isTwoByteFont) { XDrawString16(display, drawable, gc, x, y, (XChar2b *) Tcl_DStringValue(&runString), Tcl_DStringLength(&runString) / 2); if (do_width) { x += XTextWidth16(lastSubFontPtr->fontStructPtr, (XChar2b *) Tcl_DStringValue(&runString), Tcl_DStringLength(&runString) / 2); } } else { XDrawString(display, drawable, gc, x, y, Tcl_DStringValue(&runString), Tcl_DStringLength(&runString)); if (do_width) { x += XTextWidth(lastSubFontPtr->fontStructPtr, Tcl_DStringValue(&runString), Tcl_DStringLength(&runString)); } } Tcl_DStringFree(&runString); } lastSubFontPtr = thisSubFontPtr; source = p; XSetFont(display, gc, lastSubFontPtr->fontStructPtr->fid); if (x > window_width) { break; } } p = next; } if (lastSubFontPtr != &fontPtr->subFontArray[0]) { XSetFont(display, gc, fontPtr->subFontArray[0].fontStructPtr->fid); } if (fontPtr->font.fa.underline != 0) { XFillRectangle(display, drawable, gc, xStart, y + fontPtr->underlinePos, (unsigned) (x - xStart), (unsigned) fontPtr->barHeight); } if (fontPtr->font.fa.overstrike != 0) { y -= fontPtr->font.fm.descent + (fontPtr->font.fm.ascent) / 10; XFillRectangle(display, drawable, gc, xStart, y, (unsigned) (x - xStart), (unsigned) fontPtr->barHeight); } } /* *--------------------------------------------------------------------------- * * TkpDrawCharsInContext -- * * Draw a string of characters on the screen like Tk_DrawChars(), but * with access to all the characters on the line for context. On X11 this * context isn't consulted, so we just call Tk_DrawChars(). * * Results: * None. * * Side effects: * Information gets drawn on the screen. * *--------------------------------------------------------------------------- */ void TkpDrawCharsInContext( Display *display, /* Display on which to draw. */ Drawable drawable, /* Window or pixmap in which to draw. */ GC gc, /* Graphics context for drawing characters. */ Tk_Font tkfont, /* Font in which characters will be drawn; * must be the same as font used in GC. */ const char *source, /* UTF-8 string to be displayed. Need not be * '\0' terminated. All Tk meta-characters * (tabs, control characters, and newlines) * should be stripped out of the string that * is passed to this function. If they are not * stripped out, they will be displayed as * regular printing characters. */ int numBytes, /* Number of bytes in string. */ int rangeStart, /* Index of first byte to draw. */ int rangeLength, /* Length of range to draw in bytes. */ int x, int y) /* Coordinates at which to place origin of the * whole (not just the range) string when * drawing. */ { (void) numBytes; /*unused*/ Tk_DrawChars(display, drawable, gc, tkfont, source + rangeStart, rangeLength, x, y); } /* *------------------------------------------------------------------------- * * CreateClosestFont -- * * Helper for TkpGetNativeFont() and TkpGetFontFromAttributes(). Given a * set of font attributes, construct a close XFontStruct. If requested * face name is not available, automatically substitutes an alias for * requested face name. If encoding is not specified (or the requested * one is not available), automatically chooses another encoding from the * list of preferred encodings. If the foundry is not specified (or is * not available) automatically prefers "adobe" foundry. For all other * attributes, if the requested value was not available, the appropriate * "close" value will be used. * * Results: * Return value is the XFontStruct that best matched the requested * attributes. The return value is never NULL; some font will always be * returned. * * Side effects: * None. * *------------------------------------------------------------------------- */ static XFontStruct * CreateClosestFont( Tk_Window tkwin, /* For display where font will be used. */ const TkFontAttributes *faPtr, /* Set of generic attributes to match. */ const TkXLFDAttributes *xaPtr) /* Set of X-specific attributes to match. */ { FontAttributes want; char **nameList; int numNames, nameIdx, bestIdx[2]; Display *display; XFontStruct *fontStructPtr; unsigned bestScore[2]; want.fa = *faPtr; want.xa = *xaPtr; if (want.xa.foundry == NULL) { want.xa.foundry = Tk_GetUid("adobe"); } if (want.fa.family == NULL) { want.fa.family = Tk_GetUid("fixed"); } want.fa.size = -TkFontGetPixels(tkwin, faPtr->size); if (want.xa.charset == NULL || *want.xa.charset == '\0') { want.xa.charset = Tk_GetUid("iso8859-1"); /* locale. */ } display = Tk_Display(tkwin); /* * Algorithm to get the closest font to the name requested. * * try fontname * try all aliases for fontname * foreach fallback for fontname * try the fallback * try all aliases for the fallback */ nameList = ListFontOrAlias(display, want.fa.family, &numNames); if (numNames == 0) { const char *const *const *fontFallbacks; int i, j; const char *fallback; fontFallbacks = TkFontGetFallbacks(); for (i = 0; fontFallbacks[i] != NULL; i++) { for (j = 0; (fallback = fontFallbacks[i][j]) != NULL; j++) { if (strcasecmp(want.fa.family, fallback) == 0) { break; } } if (fallback != NULL) { for (j = 0; (fallback = fontFallbacks[i][j]) != NULL; j++) { nameList = ListFontOrAlias(display, fallback, &numNames); if (numNames != 0) { goto found; } } } } nameList = ListFonts(display, "fixed", &numNames); if (numNames == 0) { nameList = ListFonts(display, "*", &numNames); } if (numNames == 0) { return GetSystemFont(display); } } found: bestIdx[0] = -1; bestIdx[1] = -1; bestScore[0] = (unsigned) -1; bestScore[1] = (unsigned) -1; for (nameIdx = 0; nameIdx < numNames; nameIdx++) { FontAttributes got; int scalable; unsigned score; if (TkFontParseXLFD(nameList[nameIdx], &got.fa, &got.xa) != TCL_OK) { continue; } IdentifySymbolEncodings(&got); scalable = (got.fa.size == 0); score = RankAttributes(&want, &got); if (score < bestScore[scalable]) { bestIdx[scalable] = nameIdx; bestScore[scalable] = score; } if (score == 0) { break; } } fontStructPtr = GetScreenFont(display, &want, nameList, bestIdx, bestScore); XFreeFontNames(nameList); if (fontStructPtr == NULL) { return GetSystemFont(display); } return fontStructPtr; } /* *--------------------------------------------------------------------------- * * InitFont -- * * Helper for TkpGetNativeFont() and TkpGetFontFromAttributes(). * Initializes the memory for a new UnixFont that wraps the * platform-specific data. * * The caller is responsible for initializing the fields of the TkFont * that are used exclusively by the generic TkFont code, and for * releasing those fields before calling TkpDeleteFont(). * * Results: * Fills the WinFont structure. * * Side effects: * Memory allocated. * *--------------------------------------------------------------------------- */ static void InitFont( Tk_Window tkwin, /* For screen where font will be used. */ XFontStruct *fontStructPtr, /* X information about font. */ UnixFont *fontPtr) /* Filled with information constructed from * the above arguments. */ { ThreadSpecificData *tsdPtr = Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); unsigned long value; int minHi, maxHi, minLo, maxLo, fixed, width, limit, i, n; FontAttributes fa; TkFontAttributes *faPtr; TkFontMetrics *fmPtr; SubFont *controlPtr, *subFontPtr; char *pageMap; Display *display; /* * Get all font attributes and metrics. */ display = Tk_Display(tkwin); GetFontAttributes(display, fontStructPtr, &fa); minHi = fontStructPtr->min_byte1; maxHi = fontStructPtr->max_byte1; minLo = fontStructPtr->min_char_or_byte2; maxLo = fontStructPtr->max_char_or_byte2; fixed = 1; if (fontStructPtr->per_char != NULL) { width = 0; limit = (maxHi - minHi + 1) * (maxLo - minLo + 1); for (i = 0; i < limit; i++) { n = fontStructPtr->per_char[i].width; if (n != 0) { if (width == 0) { width = n; } else if (width != n) { fixed = 0; break; } } } } fontPtr->font.fid = fontStructPtr->fid; faPtr = &fontPtr->font.fa; faPtr->family = fa.fa.family; faPtr->size = TkFontGetPoints(tkwin, fa.fa.size); faPtr->weight = fa.fa.weight; faPtr->slant = fa.fa.slant; faPtr->underline = 0; faPtr->overstrike = 0; fmPtr = &fontPtr->font.fm; fmPtr->ascent = fontStructPtr->ascent; fmPtr->descent = fontStructPtr->descent; fmPtr->maxWidth = fontStructPtr->max_bounds.width; fmPtr->fixed = fixed; fontPtr->display = display; fontPtr->pixelSize = TkFontGetPixels(tkwin, fa.fa.size); fontPtr->xa = fa.xa; fontPtr->numSubFonts = 1; fontPtr->subFontArray = fontPtr->staticSubFonts; InitSubFont(display, fontStructPtr, 1, &fontPtr->subFontArray[0]); fontPtr->controlSubFont = fontPtr->subFontArray[0]; subFontPtr = FindSubFontForChar(fontPtr, '0', NULL); controlPtr = &fontPtr->controlSubFont; controlPtr->fontStructPtr = subFontPtr->fontStructPtr; controlPtr->familyPtr = &tsdPtr->controlFamily; controlPtr->fontMap = tsdPtr->controlFamily.fontMap; pageMap = fontPtr->subFontArray[0].fontMap[0]; for (i = 0; i < 256; i++) { if ((minHi > 0) || (i < minLo) || (i > maxLo) || !((pageMap[i>>3] >> (i&7)) & 1)) { n = 0; } else if (fontStructPtr->per_char == NULL) { n = fontStructPtr->max_bounds.width; } else { n = fontStructPtr->per_char[i - minLo].width; } fontPtr->widths[i] = n; } if (XGetFontProperty(fontStructPtr, XA_UNDERLINE_POSITION, &value)) { fontPtr->underlinePos = value; } else { /* * If the XA_UNDERLINE_POSITION property does not exist, the X manual * recommends using the following value: */ fontPtr->underlinePos = fontStructPtr->descent / 2; } fontPtr->barHeight = 0; if (XGetFontProperty(fontStructPtr, XA_UNDERLINE_THICKNESS, &value)) { fontPtr->barHeight = value; } if (fontPtr->barHeight == 0) { /* * If the XA_UNDERLINE_THICKNESS property does not exist, the X manual * recommends using the width of the stem on a capital letter. I don't * know of a way to get the stem width of a letter, so guess and use * 1/3 the width of a capital I. */ fontPtr->barHeight = fontPtr->widths['I'] / 3; if (fontPtr->barHeight == 0) { fontPtr->barHeight = 1; } } if (fontPtr->underlinePos + fontPtr->barHeight > fontStructPtr->descent) { /* * If this set of cobbled together values would cause the bottom of * the underline bar to stick below the descent of the font, jack the * underline up a bit higher. */ fontPtr->barHeight = fontStructPtr->descent - fontPtr->underlinePos; if (fontPtr->barHeight == 0) { fontPtr->underlinePos--; fontPtr->barHeight = 1; } } } /* *------------------------------------------------------------------------- * * ReleaseFont -- * * Called to release the unix-specific contents of a TkFont. The caller * is responsible for freeing the memory used by the font itself. * * Results: * None. * * Side effects: * Memory is freed. * *--------------------------------------------------------------------------- */ static void ReleaseFont( UnixFont *fontPtr) /* The font to delete. */ { int i; for (i = 0; i < fontPtr->numSubFonts; i++) { ReleaseSubFont(fontPtr->display, &fontPtr->subFontArray[i]); } if (fontPtr->subFontArray != fontPtr->staticSubFonts) { ckfree(fontPtr->subFontArray); } } /* *------------------------------------------------------------------------- * * InitSubFont -- * * Wrap a screen font and load the FontFamily that represents it. Used to * prepare a SubFont so that characters can be mapped from UTF-8 to the * charset of the font. * * Results: * The subFontPtr is filled with information about the font. * * Side effects: * None. * *------------------------------------------------------------------------- */ static void InitSubFont( Display *display, /* Display in which font will be used. */ XFontStruct *fontStructPtr, /* The screen font. */ int base, /* Non-zero if this SubFont is being used as * the base font for a font object. */ SubFont *subFontPtr) /* Filled with SubFont constructed from above * attributes. */ { subFontPtr->fontStructPtr = fontStructPtr; subFontPtr->familyPtr = AllocFontFamily(display, fontStructPtr, base); subFontPtr->fontMap = subFontPtr->familyPtr->fontMap; } /* *------------------------------------------------------------------------- * * ReleaseSubFont -- * * Called to release the contents of a SubFont. The caller is responsible * for freeing the memory used by the SubFont itself. * * Results: * None. * * Side effects: * Memory and resources are freed. * *--------------------------------------------------------------------------- */ static void ReleaseSubFont( Display *display, /* Display which owns screen font. */ SubFont *subFontPtr) /* The SubFont to delete. */ { XFreeFont(display, subFontPtr->fontStructPtr); FreeFontFamily(subFontPtr->familyPtr); } /* *------------------------------------------------------------------------- * * AllocFontFamily -- * * Find the FontFamily structure associated with the given font name. * The information should be stored by the caller in a SubFont and used * when determining if that SubFont supports a character. * * Cannot use the string name used to construct the font as the key, * because the capitalization may not be canonical. Therefore use the * face name actually retrieved from the font metrics as the key. * * Results: * A pointer to a FontFamily. The reference count in the FontFamily is * automatically incremented. When the SubFont is released, the reference * count is decremented. When no SubFont is using this FontFamily, it may * be deleted. * * Side effects: * A new FontFamily structure will be allocated if this font family has * not been seen. TrueType character existence metrics are loaded into * the FontFamily structure. * *------------------------------------------------------------------------- */ static FontFamily * AllocFontFamily( Display *display, /* Display in which font will be used. */ XFontStruct *fontStructPtr, /* Screen font whose FontFamily is to be * returned. */ int base) /* Non-zero if this font family is to be used * in the base font of a font object. */ { FontFamily *familyPtr; FontAttributes fa; Tcl_Encoding encoding; ThreadSpecificData *tsdPtr = Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); GetFontAttributes(display, fontStructPtr, &fa); encoding = Tcl_GetEncoding(NULL, GetEncodingAlias(fa.xa.charset)); familyPtr = tsdPtr->fontFamilyList; for (; familyPtr != NULL; familyPtr = familyPtr->nextPtr) { if ((familyPtr->faceName == fa.fa.family) && (familyPtr->foundry == fa.xa.foundry) && (familyPtr->encoding == encoding)) { Tcl_FreeEncoding(encoding); familyPtr->refCount++; return familyPtr; } } familyPtr = ckalloc(sizeof(FontFamily)); memset(familyPtr, 0, sizeof(FontFamily)); familyPtr->nextPtr = tsdPtr->fontFamilyList; tsdPtr->fontFamilyList = familyPtr; /* * Set key for this FontFamily. */ familyPtr->foundry = fa.xa.foundry; familyPtr->faceName = fa.fa.family; familyPtr->encoding = encoding; /* * An initial refCount of 2 means that FontFamily information will persist * even when the SubFont that loaded the FontFamily is released. Change it * to 1 to cause FontFamilies to be unloaded when not in use. */ familyPtr->refCount = 2; /* * One byte/character fonts have both min_byte1 and max_byte1 0, and * max_char_or_byte2 <= 255. Anything else specifies a two byte/character * font. */ familyPtr->isTwoByteFont = !( (fontStructPtr->min_byte1 == 0) && (fontStructPtr->max_byte1 == 0) && (fontStructPtr->max_char_or_byte2 < 256)); return familyPtr; } /* *------------------------------------------------------------------------- * * FreeFontFamily -- * * Called to free an FontFamily when the SubFont is finished using it. * Frees the contents of the FontFamily and the memory used by the * FontFamily itself. * * Results: * None. * * Side effects: * None. * *------------------------------------------------------------------------- */ static void FreeFontFamily( FontFamily *familyPtr) /* The FontFamily to delete. */ { FontFamily **familyPtrPtr; ThreadSpecificData *tsdPtr = Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); int i; if (familyPtr == NULL) { return; } familyPtr->refCount--; if (familyPtr->refCount > 0) { return; } Tcl_FreeEncoding(familyPtr->encoding); for (i = 0; i < FONTMAP_PAGES; i++) { if (familyPtr->fontMap[i] != NULL) { ckfree(familyPtr->fontMap[i]); } } /* * Delete from list. */ for (familyPtrPtr = &tsdPtr->fontFamilyList; ; ) { if (*familyPtrPtr == familyPtr) { *familyPtrPtr = familyPtr->nextPtr; break; } familyPtrPtr = &(*familyPtrPtr)->nextPtr; } ckfree(familyPtr); } /* *------------------------------------------------------------------------- * * FindSubFontForChar -- * * Determine which screen font is necessary to use to display the given * character. If the font object does not have a screen font that can * display the character, another screen font may be loaded into the font * object, following a set of preferred fallback rules. * * Results: * The return value is the SubFont to use to display the given character. * * Side effects: * The contents of fontPtr are modified to cache the results of the * lookup and remember any SubFonts that were dynamically loaded. The * table of SubFonts might be extended, and if a non-NULL reference to a * subfont pointer is available, it is updated if it previously pointed * into the old subfont table. * *------------------------------------------------------------------------- */ static SubFont * FindSubFontForChar( UnixFont *fontPtr, /* The font object with which the character * will be displayed. */ int ch, /* The Unicode character to be displayed. */ SubFont **fixSubFontPtrPtr) /* Subfont reference to fix up if we * reallocate our subfont table. */ { int i, j, k, numNames; Tk_Uid faceName; const char *fallback; const char *const *aliases; char **nameList; const char *const *anyFallbacks; const char *const *const *fontFallbacks; SubFont *subFontPtr; Tcl_DString ds; if (FontMapLookup(&fontPtr->subFontArray[0], ch)) { return &fontPtr->subFontArray[0]; } for (i = 1; i < fontPtr->numSubFonts; i++) { if (FontMapLookup(&fontPtr->subFontArray[i], ch)) { return &fontPtr->subFontArray[i]; } } if (FontMapLookup(&fontPtr->controlSubFont, ch)) { return &fontPtr->controlSubFont; } /* * Keep track of all face names that we check, so we don't check some name * multiple times if it can be reached by multiple paths. */ Tcl_DStringInit(&ds); /* * Are there any other fonts with the same face name as the base font that * could display this character, e.g., if the base font is * adobe:fixed:iso8859-1, we could might be able to use * misc:fixed:iso8859-8 or sony:fixed:jisx0208.1983-0 */ faceName = fontPtr->font.fa.family; if (SeenName(faceName, &ds) == 0) { subFontPtr = CanUseFallback(fontPtr, faceName, ch, fixSubFontPtrPtr); if (subFontPtr != NULL) { goto end; } } aliases = TkFontGetAliasList(faceName); subFontPtr = NULL; fontFallbacks = TkFontGetFallbacks(); for (i = 0; fontFallbacks[i] != NULL; i++) { for (j = 0; (fallback = fontFallbacks[i][j]) != NULL; j++) { if (strcasecmp(fallback, faceName) == 0) { /* * If the base font has a fallback... */ goto tryfallbacks; } else if (aliases != NULL) { /* * Or if an alias for the base font has a fallback... */ for (k = 0; aliases[k] != NULL; k++) { if (strcasecmp(fallback, aliases[k]) == 0) { goto tryfallbacks; } } } } continue; tryfallbacks: /* * ...then see if we can use one of the fallbacks, or an alias for one * of the fallbacks. */ for (j = 0; (fallback = fontFallbacks[i][j]) != NULL; j++) { subFontPtr = CanUseFallbackWithAliases(fontPtr, fallback, ch, &ds, fixSubFontPtrPtr); if (subFontPtr != NULL) { goto end; } } } /* * See if we can use something from the global fallback list. */ anyFallbacks = TkFontGetGlobalClass(); for (i = 0; (fallback = anyFallbacks[i]) != NULL; i++) { subFontPtr = CanUseFallbackWithAliases(fontPtr, fallback, ch, &ds, fixSubFontPtrPtr); if (subFontPtr != NULL) { goto end; } } /* * Try all face names available in the whole system until we find one that * can be used. */ nameList = ListFonts(fontPtr->display, "*", &numNames); for (i = 0; i < numNames; i++) { fallback = strchr(nameList[i] + 1, '-') + 1; strchr(fallback, '-')[0] = '\0'; if (SeenName(fallback, &ds) == 0) { subFontPtr = CanUseFallback(fontPtr, fallback, ch, fixSubFontPtrPtr); if (subFontPtr != NULL) { XFreeFontNames(nameList); goto end; } } } XFreeFontNames(nameList); end: Tcl_DStringFree(&ds); if (subFontPtr == NULL) { /* * No font can display this character, so it will be displayed as a * control character expansion. */ subFontPtr = &fontPtr->controlSubFont; FontMapInsert(subFontPtr, ch); } return subFontPtr; } /* *------------------------------------------------------------------------- * * FontMapLookup -- * * See if the screen font can display the given character. * * Results: * The return value is 0 if the screen font cannot display the character, * non-zero otherwise. * * Side effects: * New pages are added to the font mapping cache whenever the character * belongs to a page that hasn't been seen before. When a page is loaded, * information about all the characters on that page is stored, not just * for the single character in question. * *------------------------------------------------------------------------- */ static int FontMapLookup( SubFont *subFontPtr, /* Contains font mapping cache to be queried * and possibly updated. */ int ch) /* Character to be tested. */ { int row, bitOffset; row = ch >> FONTMAP_SHIFT; if (subFontPtr->fontMap[row] == NULL) { FontMapLoadPage(subFontPtr, row); } bitOffset = ch & (FONTMAP_BITSPERPAGE - 1); return (subFontPtr->fontMap[row][bitOffset >> 3] >> (bitOffset & 7)) & 1; } /* *------------------------------------------------------------------------- * * FontMapInsert -- * * Tell the font mapping cache that the given screen font should be used * to display the specified character. This is called when no font on the * system can be be found that can display that character; we lie to the * font and tell it that it can display the character, otherwise we would * end up re-searching the entire fallback hierarchy every time that * character was seen. * * Results: * None. * * Side effects: * New pages are added to the font mapping cache whenever the character * belongs to a page that hasn't been seen before. When a page is loaded, * information about all the characters on that page is stored, not just * for the single character in question. * *------------------------------------------------------------------------- */ static void FontMapInsert( SubFont *subFontPtr, /* Contains font mapping cache to be * updated. */ int ch) /* Character to be added to cache. */ { int row, bitOffset; row = ch >> FONTMAP_SHIFT; if (subFontPtr->fontMap[row] == NULL) { FontMapLoadPage(subFontPtr, row); } bitOffset = ch & (FONTMAP_BITSPERPAGE - 1); subFontPtr->fontMap[row][bitOffset >> 3] |= 1 << (bitOffset & 7); } /* *------------------------------------------------------------------------- * * FontMapLoadPage -- * * Load information about all the characters on a given page. This * information consists of one bit per character that indicates whether * the associated screen font can (1) or cannot (0) display the * characters on the page. * * Results: * None. * * Side effects: * Memory allocated. * *------------------------------------------------------------------------- */ static void FontMapLoadPage( SubFont *subFontPtr, /* Contains font mapping cache to be * updated. */ int row) /* Index of the page to be loaded into the * cache. */ { char buf[16], src[TCL_UTF_MAX]; int minHi, maxHi, minLo, maxLo, scale, checkLo; int i, end, bitOffset, isTwoByteFont, n; Tcl_Encoding encoding; XFontStruct *fontStructPtr; XCharStruct *widths; ThreadSpecificData *tsdPtr = Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); subFontPtr->fontMap[row] = ckalloc(FONTMAP_BITSPERPAGE / 8); memset(subFontPtr->fontMap[row], 0, FONTMAP_BITSPERPAGE / 8); if (subFontPtr->familyPtr == &tsdPtr->controlFamily) { return; } fontStructPtr = subFontPtr->fontStructPtr; encoding = subFontPtr->familyPtr->encoding; isTwoByteFont = subFontPtr->familyPtr->isTwoByteFont; widths = fontStructPtr->per_char; minHi = fontStructPtr->min_byte1; maxHi = fontStructPtr->max_byte1; minLo = fontStructPtr->min_char_or_byte2; maxLo = fontStructPtr->max_char_or_byte2; scale = maxLo - minLo + 1; checkLo = minLo; if (! isTwoByteFont) { if (minLo < 32) { checkLo = 32; } } end = (row + 1) << FONTMAP_SHIFT; for (i = row << FONTMAP_SHIFT; i < end; i++) { int hi, lo; if (Tcl_UtfToExternal(NULL, encoding, src, Tcl_UniCharToUtf(i, src), TCL_ENCODING_STOPONERROR, NULL, buf, sizeof(buf), NULL, NULL, NULL) != TCL_OK) { continue; } if (isTwoByteFont) { hi = ((unsigned char *) buf)[0]; lo = ((unsigned char *) buf)[1]; } else { hi = 0; lo = ((unsigned char *) buf)[0]; } if ((hi < minHi) || (hi > maxHi) || (lo < checkLo) || (lo > maxLo)) { continue; } n = (hi - minHi) * scale + lo - minLo; if ((widths == NULL) || (widths[n].width + widths[n].rbearing != 0)) { bitOffset = i & (FONTMAP_BITSPERPAGE - 1); subFontPtr->fontMap[row][bitOffset >> 3] |= 1 << (bitOffset & 7); } } } /* *--------------------------------------------------------------------------- * * CanUseFallbackWithAliases -- * * Helper function for FindSubFontForChar. Determine if the specified * face name (or an alias of the specified face name) can be used to * construct a screen font that can display the given character. * * Results: * See CanUseFallback(). * * Side effects: * If the name and/or one of its aliases was rejected, the rejected * string is recorded in nameTriedPtr so that it won't be tried again. * The table of SubFonts might be extended, and if a non-NULL reference * to a subfont pointer is available, it is updated if it previously * pointed into the old subfont table. * *--------------------------------------------------------------------------- */ static SubFont * CanUseFallbackWithAliases( UnixFont *fontPtr, /* The font object that will own the new * screen font. */ const char *faceName, /* Desired face name for new screen font. */ int ch, /* The Unicode character that the new screen * font must be able to display. */ Tcl_DString *nameTriedPtr, /* Records face names that have already been * tried. It is possible for the same face * name to be queried multiple times when * trying to find a suitable screen font. */ SubFont **fixSubFontPtrPtr) /* Subfont reference to fix up if we * reallocate our subfont table. */ { SubFont *subFontPtr; const char *const *aliases; int i; if (SeenName(faceName, nameTriedPtr) == 0) { subFontPtr = CanUseFallback(fontPtr, faceName, ch, fixSubFontPtrPtr); if (subFontPtr != NULL) { return subFontPtr; } } aliases = TkFontGetAliasList(faceName); if (aliases != NULL) { for (i = 0; aliases[i] != NULL; i++) { if (SeenName(aliases[i], nameTriedPtr) == 0) { subFontPtr = CanUseFallback(fontPtr, aliases[i], ch, fixSubFontPtrPtr); if (subFontPtr != NULL) { return subFontPtr; } } } } return NULL; } /* *--------------------------------------------------------------------------- * * SeenName -- * * Used to determine we have already tried and rejected the given face * name when looking for a screen font that can support some Unicode * character. * * Results: * The return value is 0 if this face name has not already been seen, * non-zero otherwise. * * Side effects: * None. * *--------------------------------------------------------------------------- */ static int SeenName( const char *name, /* The name to check. */ Tcl_DString *dsPtr) /* Contains names that have already been * seen. */ { const char *seen, *end; seen = Tcl_DStringValue(dsPtr); end = seen + Tcl_DStringLength(dsPtr); while (seen < end) { if (strcasecmp(seen, name) == 0) { return 1; } seen += strlen(seen) + 1; } Tcl_DStringAppend(dsPtr, name, (int) (strlen(name) + 1)); return 0; } /* *------------------------------------------------------------------------- * * CanUseFallback -- * * If the specified screen font has not already been loaded into the font * object, determine if the specified screen font can display the given * character. * * Results: * The return value is a pointer to a newly allocated SubFont, owned by * the font object. This SubFont can be used to display the given * character. The SubFont represents the screen font with the base set of * font attributes from the font object, but using the specified face * name. NULL is returned if the font object already holds a reference to * the specified font or if the specified font doesn't exist or cannot * display the given character. * * Side effects: * The font object's subFontArray is updated to contain a reference to * the newly allocated SubFont. The table of SubFonts might be extended, * and if a non-NULL reference to a subfont pointer is available, it is * updated if it previously pointed into the old subfont table. * *------------------------------------------------------------------------- */ static SubFont * CanUseFallback( UnixFont *fontPtr, /* The font object that will own the new * screen font. */ const char *faceName, /* Desired face name for new screen font. */ int ch, /* The Unicode character that the new screen * font must be able to display. */ SubFont **fixSubFontPtrPtr) /* Subfont reference to fix up if we * reallocate our subfont table. */ { int i, nameIdx, numNames, srcLen, numEncodings, bestIdx[2]; Tk_Uid hateFoundry; const char *charset, *hateCharset; unsigned bestScore[2]; char **nameList; char **nameListOrig; char src[TCL_UTF_MAX]; FontAttributes want, got; Display *display; SubFont subFont; XFontStruct *fontStructPtr; Tcl_DString dsEncodings; Tcl_Encoding *encodingCachePtr; /* * Assume: the face name is times. * Assume: adobe:times:iso8859-1 has already been used. * * Are there any versions of times that can display this character (e.g., * perhaps linotype:times:iso8859-2)? * a. Get list of all times fonts. * b1. Cross out all names whose encodings we've already used. * b2. Cross out all names whose foundry & encoding we've already seen. * c. Cross out all names whose encoding cannot handle the character. * d. Rank each name and pick the best match. * e. If that font cannot actually display the character, cross out all * names with the same foundry and encoding and go back to (c). */ display = fontPtr->display; nameList = ListFonts(display, faceName, &numNames); if (numNames == 0) { return NULL; } nameListOrig = nameList; srcLen = Tcl_UniCharToUtf(ch, src); want.fa = fontPtr->font.fa; want.xa = fontPtr->xa; want.fa.family = Tk_GetUid(faceName); want.fa.size = -fontPtr->pixelSize; hateFoundry = NULL; hateCharset = NULL; numEncodings = 0; Tcl_DStringInit(&dsEncodings); charset = NULL; /* lint, since numNames must be > 0 to get here. */ retry: bestIdx[0] = -1; bestIdx[1] = -1; bestScore[0] = (unsigned) -1; bestScore[1] = (unsigned) -1; for (nameIdx = 0; nameIdx < numNames; nameIdx++) { Tcl_Encoding encoding; char dst[16]; int scalable, srcRead, dstWrote; unsigned score; if (nameList[nameIdx] == NULL) { continue; } if (TkFontParseXLFD(nameList[nameIdx], &got.fa, &got.xa) != TCL_OK) { goto crossout; } IdentifySymbolEncodings(&got); charset = GetEncodingAlias(got.xa.charset); if (hateFoundry != NULL) { /* * E. If the font we picked cannot actually display the character, * cross out all names with the same foundry and encoding. */ if ((hateFoundry == got.xa.foundry) && (strcmp(hateCharset, charset) == 0)) { goto crossout; } } else { /* * B. Cross out all names whose encodings we've already used. */ for (i = 0; i < fontPtr->numSubFonts; i++) { encoding = fontPtr->subFontArray[i].familyPtr->encoding; if (strcmp(charset, Tcl_GetEncodingName(encoding)) == 0) { goto crossout; } } } /* * C. Cross out all names whose encoding cannot handle the character. */ encodingCachePtr = (Tcl_Encoding *) Tcl_DStringValue(&dsEncodings); for (i = numEncodings; --i >= 0; encodingCachePtr++) { encoding = *encodingCachePtr; if (strcmp(Tcl_GetEncodingName(encoding), charset) == 0) { break; } } if (i < 0) { encoding = Tcl_GetEncoding(NULL, charset); if (encoding == NULL) { goto crossout; } Tcl_DStringAppend(&dsEncodings, (char *) &encoding, sizeof(encoding)); numEncodings++; } Tcl_UtfToExternal(NULL, encoding, src, srcLen, TCL_ENCODING_STOPONERROR, NULL, dst, sizeof(dst), &srcRead, &dstWrote, NULL); if (dstWrote == 0) { goto crossout; } /* * D. Rank each name and pick the best match. */ scalable = (got.fa.size == 0); score = RankAttributes(&want, &got); if (score < bestScore[scalable]) { bestIdx[scalable] = nameIdx; bestScore[scalable] = score; } if (score == 0) { break; } continue; crossout: if (nameList == nameListOrig) { /* * Not allowed to change pointers to memory that X gives you, so * make a copy. */ nameList = ckalloc(numNames * sizeof(char *)); memcpy(nameList, nameListOrig, numNames * sizeof(char *)); } nameList[nameIdx] = NULL; } fontStructPtr = GetScreenFont(display, &want, nameList, bestIdx, bestScore); encodingCachePtr = (Tcl_Encoding *) Tcl_DStringValue(&dsEncodings); for (i = numEncodings; --i >= 0; encodingCachePtr++) { Tcl_FreeEncoding(*encodingCachePtr); } Tcl_DStringFree(&dsEncodings); numEncodings = 0; if (fontStructPtr == NULL) { if (nameList != nameListOrig) { ckfree(nameList); } XFreeFontNames(nameListOrig); return NULL; } InitSubFont(display, fontStructPtr, 0, &subFont); if (FontMapLookup(&subFont, ch) == 0) { /* * E. If the font we picked cannot actually display the character, * cross out all names with the same foundry and encoding and pick * another font. */ hateFoundry = got.xa.foundry; hateCharset = charset; ReleaseSubFont(display, &subFont); goto retry; } if (nameList != nameListOrig) { ckfree(nameList); } XFreeFontNames(nameListOrig); if (fontPtr->numSubFonts >= SUBFONT_SPACE) { SubFont *newPtr; newPtr = ckalloc(sizeof(SubFont) * (fontPtr->numSubFonts + 1)); memcpy(newPtr, fontPtr->subFontArray, fontPtr->numSubFonts * sizeof(SubFont)); if (fixSubFontPtrPtr != NULL) { register SubFont *fixSubFontPtr = *fixSubFontPtrPtr; if (fixSubFontPtr != &fontPtr->controlSubFont) { *fixSubFontPtrPtr = newPtr + (fixSubFontPtr - fontPtr->subFontArray); } } if (fontPtr->subFontArray != fontPtr->staticSubFonts) { ckfree(fontPtr->subFontArray); } fontPtr->subFontArray = newPtr; } fontPtr->subFontArray[fontPtr->numSubFonts] = subFont; fontPtr->numSubFonts++; return &fontPtr->subFontArray[fontPtr->numSubFonts - 1]; } /* *--------------------------------------------------------------------------- * * RankAttributes -- * * Determine how close the attributes of the font in question match the * attributes that we want. * * Results: * The return value is the score; lower numbers are better. *scalablePtr * is set to 0 if the font was not scalable, 1 otherwise. * * Side effects: * None. * *--------------------------------------------------------------------------- */ static unsigned RankAttributes( FontAttributes *wantPtr, /* The desired attributes. */ FontAttributes *gotPtr) /* The attributes we have to live with. */ { unsigned penalty; penalty = 0; if (gotPtr->xa.foundry != wantPtr->xa.foundry) { penalty += 4500; } if (gotPtr->fa.family != wantPtr->fa.family) { penalty += 9000; } if (gotPtr->fa.weight != wantPtr->fa.weight) { penalty += 90; } if (gotPtr->fa.slant != wantPtr->fa.slant) { penalty += 60; } if (gotPtr->xa.slant != wantPtr->xa.slant) { penalty += 10; } if (gotPtr->xa.setwidth != wantPtr->xa.setwidth) { penalty += 1000; } if (gotPtr->fa.size == 0) { /* * A scalable font is almost always acceptable, but the corresponding * bitmapped font would be better. */ penalty += 10; } else { int diff; /* * It's worse to be too large than to be too small. */ diff = (-gotPtr->fa.size - -wantPtr->fa.size); if (diff > 0) { penalty += 600; } else if (diff < 0) { penalty += 150; diff = -diff; } penalty += 150 * diff; } if (gotPtr->xa.charset != wantPtr->xa.charset) { int i; const char *gotAlias, *wantAlias; penalty += 65000; gotAlias = GetEncodingAlias(gotPtr->xa.charset); wantAlias = GetEncodingAlias(wantPtr->xa.charset); if (strcmp(gotAlias, wantAlias) != 0) { penalty += 30000; for (i = 0; encodingList[i] != NULL; i++) { if (strcmp(gotAlias, encodingList[i]) == 0) { penalty -= 30000; break; } penalty += 20000; } } } return penalty; } /* *--------------------------------------------------------------------------- * * GetScreenFont -- * * Given the names for the best scalable and best bitmapped font, * actually construct an XFontStruct based on the best XLFD. This is * where all the alias and fallback substitution bottoms out. * * Results: * The screen font that best corresponds to the set of attributes. * * Side effects: * None. * *--------------------------------------------------------------------------- */ static XFontStruct * GetScreenFont( Display *display, /* Display for new XFontStruct. */ FontAttributes *wantPtr, /* Contains desired actual pixel-size if the * best font was scalable. */ char **nameList, /* Array of XLFDs. */ int bestIdx[2], /* Indices into above array for XLFD of best * bitmapped and best scalable font. */ unsigned bestScore[2]) /* Scores of best bitmapped and best scalable * font. XLFD corresponding to lowest score * will be constructed. */ { XFontStruct *fontStructPtr; if ((bestIdx[0] < 0) && (bestIdx[1] < 0)) { return NULL; } /* * Now we know which is the closest matching scalable font and the closest * matching bitmapped font. If the scalable font was a better match, try * getting the scalable font; however, if the scalable font was not * actually available in the desired pointsize, fall back to the closest * bitmapped font. */ fontStructPtr = NULL; if (bestScore[1] < bestScore[0]) { char *str, *rest, buf[256]; int i; /* * Fill in the desired pixel size for this font. */ tryscale: str = nameList[bestIdx[1]]; for (i = 0; i < XLFD_PIXEL_SIZE; i++) { str = strchr(str + 1, '-'); } rest = str; for (i = XLFD_PIXEL_SIZE; i < XLFD_CHARSET; i++) { rest = strchr(rest + 1, '-'); } *str = '\0'; sprintf(buf, "%.200s-%d-*-*-*-*-*%s", nameList[bestIdx[1]], -wantPtr->fa.size, rest); *str = '-'; fontStructPtr = XLoadQueryFont(display, buf); bestScore[1] = INT_MAX; } if (fontStructPtr == NULL) { fontStructPtr = XLoadQueryFont(display, nameList[bestIdx[0]]); if (fontStructPtr == NULL) { /* * This shouldn't happen because the font name is one of the names * that X gave us to use, but it does anyhow. */ if (bestScore[1] < INT_MAX) { goto tryscale; } return GetSystemFont(display); } } return fontStructPtr; } /* *--------------------------------------------------------------------------- * * GetSystemFont -- * * Absolute fallback mechanism, called when we need a font and no other * font can be found and/or instantiated. * * Results: * A pointer to a font. Never NULL. * * Side effects: * If there are NO fonts installed on the system, this call will panic, * but how did you get X running in that case? * *--------------------------------------------------------------------------- */ static XFontStruct * GetSystemFont( Display *display) /* Display for new XFontStruct. */ { XFontStruct *fontStructPtr; fontStructPtr = XLoadQueryFont(display, "fixed"); if (fontStructPtr == NULL) { fontStructPtr = XLoadQueryFont(display, "*"); if (fontStructPtr == NULL) { Tcl_Panic("TkpGetFontFromAttributes: cannot get any font"); } } return fontStructPtr; } /* *--------------------------------------------------------------------------- * * GetFontAttributes -- * * Given a screen font, determine its actual attributes, which are not * necessarily the attributes that were used to construct it. * * Results: * *faPtr is filled with the screen font's attributes. * * Side effects: * None. * *--------------------------------------------------------------------------- */ static int GetFontAttributes( Display *display, /* Display that owns the screen font. */ XFontStruct *fontStructPtr, /* Screen font to query. */ FontAttributes *faPtr) /* For storing attributes of screen font. */ { unsigned long value; char *name; if ((XGetFontProperty(fontStructPtr, XA_FONT, &value) != False) && (value != 0)) { name = XGetAtomName(display, (Atom) value); if (TkFontParseXLFD(name, &faPtr->fa, &faPtr->xa) != TCL_OK) { faPtr->fa.family = Tk_GetUid(name); faPtr->xa.foundry = Tk_GetUid(""); faPtr->xa.charset = Tk_GetUid(""); } XFree(name); } else { TkInitFontAttributes(&faPtr->fa); TkInitXLFDAttributes(&faPtr->xa); } /* * Do last ditch check for family. It seems that some X servers can fail * on the X font calls above, slipping through earlier checks. X-Win32 5.4 * is one of these. */ if (faPtr->fa.family == NULL) { faPtr->fa.family = Tk_GetUid(""); faPtr->xa.foundry = Tk_GetUid(""); faPtr->xa.charset = Tk_GetUid(""); } return IdentifySymbolEncodings(faPtr); } /* *--------------------------------------------------------------------------- * * ListFonts -- * * Utility function to return the array of all XLFDs on the system with * the specified face name. * * Results: * The return value is an array of XLFDs, which should be freed with * XFreeFontNames(), or NULL if no XLFDs matched the requested name. * * Side effects: * None. * *--------------------------------------------------------------------------- */ static char ** ListFonts( Display *display, /* Display to query. */ const char *faceName, /* Desired face name, or "*" for all. */ int *numNamesPtr) /* Filled with length of returned array, or 0 * if no names were found. */ { char buf[256]; sprintf(buf, "-*-%.80s-*-*-*-*-*-*-*-*-*-*-*-*", faceName); return XListFonts(display, buf, 10000, numNamesPtr); } static char ** ListFontOrAlias( Display *display, /* Display to query. */ const char *faceName, /* Desired face name, or "*" for all. */ int *numNamesPtr) /* Filled with length of returned array, or 0 * if no names were found. */ { char **nameList; const char *const *aliases; int i; nameList = ListFonts(display, faceName, numNamesPtr); if (nameList != NULL) { return nameList; } aliases = TkFontGetAliasList(faceName); if (aliases != NULL) { for (i = 0; aliases[i] != NULL; i++) { nameList = ListFonts(display, aliases[i], numNamesPtr); if (nameList != NULL) { return nameList; } } } *numNamesPtr = 0; return NULL; } /* *--------------------------------------------------------------------------- * * IdentifySymbolEncodings -- * * If the font attributes refer to a symbol font, update the charset * field of the font attributes so that it reflects the encoding of that * symbol font. In general, the raw value for the charset field parsed * from an XLFD is meaningless for symbol fonts. * * Symbol fonts are all fonts whose name appears in the symbolClass. * * Results: * The return value is non-zero if the font attributes specify a symbol * font, or 0 otherwise. If a non-zero value is returned the charset * field of the font attributes will be changed to the string that * represents the actual encoding for the symbol font. * * Side effects: * None. * *--------------------------------------------------------------------------- */ static int IdentifySymbolEncodings( FontAttributes *faPtr) { int i, j; const char *const *aliases; const char *const *symbolClass; symbolClass = TkFontGetSymbolClass(); for (i = 0; symbolClass[i] != NULL; i++) { if (strcasecmp(faPtr->fa.family, symbolClass[i]) == 0) { faPtr->xa.charset = Tk_GetUid(GetEncodingAlias(symbolClass[i])); return 1; } aliases = TkFontGetAliasList(symbolClass[i]); for (j = 0; (aliases != NULL) && (aliases[j] != NULL); j++) { if (strcasecmp(faPtr->fa.family, aliases[j]) == 0) { faPtr->xa.charset = Tk_GetUid(GetEncodingAlias(aliases[j])); return 1; } } } return 0; } /* *--------------------------------------------------------------------------- * * GetEncodingAlias -- * * Map the name of an encoding to another name that should be used when * actually loading the encoding. For instance, the encodings * "jisc6226.1978", "jisx0208.1983", "jisx0208.1990", and "jisx0208.1996" * are well-known names for the same encoding and are represented by one * encoding table: "jis0208". * * Results: * As above. If the name has no alias, the original name is returned. * * Side effects: * None. * *--------------------------------------------------------------------------- */ static const char * GetEncodingAlias( const char *name) /* The name to look up. */ { EncodingAlias *aliasPtr; for (aliasPtr = encodingAliases; aliasPtr->aliasPattern != NULL; ) { if (Tcl_StringMatch(name, aliasPtr->aliasPattern)) { return aliasPtr->realName; } aliasPtr++; } return name; } /* *--------------------------------------------------------------------------- * * TkDrawAngledChars -- * * Draw some characters at an angle. This is awkward here because we have * no reliable way of drawing any characters at an angle in classic X11; * we have to draw on a Pixmap which is converted to an XImage (from * helper function GetImageOfText), rotate the image (hokey code!) onto * another XImage (from helper function InitDestImage), and then use the * rotated image as a mask when drawing. This is pretty awful; improved * versions are welcomed! * * Results: * None. * * Side effects: * Target drawable is updated. * *--------------------------------------------------------------------------- */ static inline XImage * GetImageOfText( Display *display, /* Display on which to draw. */ Drawable drawable, /* Window or pixmap in which to draw. */ Tk_Font tkfont, /* Font in which characters will be drawn. */ const char *source, /* UTF-8 string to be displayed. Need not be * '\0' terminated. All Tk meta-characters * (tabs, control characters, and newlines) * should be stripped out of the string that * is passed to this function. If they are not * stripped out, they will be displayed as * regular printing characters. */ int numBytes, /* Number of bytes in string. */ int *realWidthPtr, int *realHeightPtr) { int width, height; TkFont *fontPtr = (TkFont *) tkfont; Pixmap bitmap; GC bitmapGC; XGCValues values; XImage *image; (void) Tk_MeasureChars(tkfont, source, numBytes, -1, 0, &width); height = fontPtr->fm.ascent + fontPtr->fm.descent; bitmap = Tk_GetPixmap(display, drawable, width, height, 1); values.graphics_exposures = False; values.foreground = BlackPixel(display, DefaultScreen(display)); bitmapGC = XCreateGC(display, bitmap, GCGraphicsExposures|GCForeground, &values); XFillRectangle(display, bitmap, bitmapGC, 0, 0, width, height); values.font = Tk_FontId(tkfont); values.foreground = WhitePixel(display, DefaultScreen(display)); values.background = BlackPixel(display, DefaultScreen(display)); XChangeGC(display, bitmapGC, GCFont|GCForeground|GCBackground, &values); Tk_DrawChars(display, bitmap, bitmapGC, tkfont, source, numBytes, 0, fontPtr->fm.ascent); XFreeGC(display, bitmapGC); image = XGetImage(display, bitmap, 0, 0, width, height, AllPlanes, ZPixmap); Tk_FreePixmap(display, bitmap); *realWidthPtr = width; *realHeightPtr = height; return image; } static inline XImage * InitDestImage( Display *display, Drawable drawable, int width, int height, Pixmap *bitmapPtr) { Pixmap bitmap; XImage *image; GC bitmapGC; XGCValues values; bitmap = Tk_GetPixmap(display, drawable, width, height, 1); values.graphics_exposures = False; values.foreground = BlackPixel(display, DefaultScreen(display)); bitmapGC = XCreateGC(display, bitmap, GCGraphicsExposures|GCForeground, &values); XFillRectangle(display, bitmap, bitmapGC, 0, 0, width, height); XFreeGC(display, bitmapGC); image = XGetImage(display, bitmap, 0, 0, width, height, AllPlanes, ZPixmap); *bitmapPtr = bitmap; return image; } void TkDrawAngledChars( Display *display, /* Display on which to draw. */ Drawable drawable, /* Window or pixmap in which to draw. */ GC gc, /* Graphics context for drawing characters. */ Tk_Font tkfont, /* Font in which characters will be drawn; * must be the same as font used in GC. */ const char *source, /* UTF-8 string to be displayed. Need not be * '\0' terminated. All Tk meta-characters * (tabs, control characters, and newlines) * should be stripped out of the string that * is passed to this function. If they are not * stripped out, they will be displayed as * regular printing characters. */ int numBytes, /* Number of bytes in string. */ double x, double y, double angle) { if (angle == 0.0) { Tk_DrawChars(display, drawable, gc, tkfont, source, numBytes, x, y); } else { double sinA = sin(angle * PI/180.0), cosA = cos(angle * PI/180.0); int bufHeight, bufWidth, srcWidth, srcHeight, i, j, dx, dy; Pixmap buf; XImage *srcImage = GetImageOfText(display, drawable, tkfont, source, numBytes, &srcWidth, &srcHeight); XImage *dstImage; enum {Q0=1,R1,Q1,R2,Q2,R3,Q3} quadrant; GC bwgc, cpgc; XGCValues values; int ascent = ((TkFont *) tkfont)->fm.ascent; /* * First, work out what quadrant we are operating in. We also handle * the rectilinear rotations as special cases. Conceptually, there's * also R0 (angle == 0.0) but that has been already handled as a * special case above. * * R1 * Q1 | Q0 * | * R2 ----+---- R0 * | * Q2 | Q3 * R3 */ if (angle < 90.0) { quadrant = Q0; } else if (angle == 90.0) { quadrant = R1; } else if (angle < 180.0) { quadrant = Q1; } else if (angle == 180.0) { quadrant = R2; } else if (angle < 270.0) { quadrant = Q2; } else if (angle == 270.0) { quadrant = R3; } else { quadrant = Q3; } if (srcImage == NULL) { return; } bufWidth = srcWidth*fabs(cosA) + srcHeight*fabs(sinA); bufHeight = srcHeight*fabs(cosA) + srcWidth*fabs(sinA); dstImage = InitDestImage(display, drawable, bufWidth,bufHeight, &buf); if (dstImage == NULL) { Tk_FreePixmap(display, buf); XDestroyImage(srcImage); return; } /* * Do the rotation, setting or resetting pixels in the destination * image dependent on whether the corresponding pixel (after rotation * to source image space) is set. */ for (i=0 ; i= bufWidth || dy >= bufHeight) { continue; } XPutPixel(dstImage, dx, dy, XGetPixel(dstImage,dx,dy) | XGetPixel(srcImage,i,j)); } } XDestroyImage(srcImage); /* * Schlep the data back to the Xserver. */ values.function = GXcopy; values.foreground = WhitePixel(display, DefaultScreen(display)); values.background = BlackPixel(display, DefaultScreen(display)); bwgc = XCreateGC(display, buf, GCFunction|GCForeground|GCBackground, &values); XPutImage(display, buf, bwgc, dstImage, 0,0, 0,0, bufWidth,bufHeight); XFreeGC(display, bwgc); XDestroyImage(dstImage); /* * Calculate where we want to draw the text. */ switch (quadrant) { case Q0: dx = x; dy = y - srcWidth*sinA; break; case R1: dx = x; dy = y - srcWidth; break; case Q1: dx = x + srcWidth*cosA; dy = y + srcHeight*cosA - srcWidth*sinA; break; case R2: dx = x - srcWidth; dy = y - srcHeight; break; case Q2: dx = x + srcWidth*cosA + srcHeight*sinA; dy = y + srcHeight*cosA; break; case R3: dx = x - srcHeight; dy = y; break; default: dx = x + srcHeight*sinA; dy = y; } /* * Apply a correction to deal with the fact that we aren't told to * draw from our top-left corner but rather from the left-end of our * baseline. */ dx -= ascent*sinA; dy -= ascent*cosA; /* * Transfer the text to the screen. This is done by using it as a mask * and then drawing through that mask with the original drawing color. */ values.function = GXcopy; values.fill_style = FillSolid; values.clip_mask = buf; values.clip_x_origin = dx; values.clip_y_origin = dy; cpgc = XCreateGC(display, drawable, GCFunction|GCFillStyle|GCClipMask|GCClipXOrigin|GCClipYOrigin, &values); XCopyGC(display, gc, GCForeground, cpgc); XFillRectangle(display, drawable, cpgc, dx, dy, bufWidth, bufHeight); XFreeGC(display, cpgc); Tk_FreePixmap(display, buf); return; } } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ tk8.6.5/unix/tkUnixDefault.h0000644003604700454610000004146712652406111014423 0ustar dgp771div/* * tkUnixDefault.h -- * * This file defines the defaults for all options for all of * the Tk widgets. * * Copyright (c) 1991-1994 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef _TKUNIXDEFAULT #define _TKUNIXDEFAULT /* * The definitions below provide symbolic names for the default colors. * NORMAL_BG - Normal background color. * ACTIVE_BG - Background color when widget is active. * SELECT_BG - Background color for selected text. * TROUGH - Background color for troughs in scales and scrollbars. * INDICATOR - Color for indicator when button is selected. * DISABLED - Foreground color when widget is disabled. */ #define BLACK "#000000" #define WHITE "#ffffff" #define NORMAL_BG "#d9d9d9" #define ACTIVE_BG "#ececec" #define SELECT_BG "#c3c3c3" #define TROUGH "#b3b3b3" #define CHECK_INDICATOR WHITE #define MENU_INDICATOR BLACK #define DISABLED "#a3a3a3" /* * Defaults for labels, buttons, checkbuttons, and radiobuttons: */ #define DEF_BUTTON_ANCHOR "center" #define DEF_BUTTON_ACTIVE_BG_COLOR ACTIVE_BG #define DEF_BUTTON_ACTIVE_BG_MONO BLACK #define DEF_BUTTON_ACTIVE_FG_COLOR BLACK #define DEF_CHKRAD_ACTIVE_FG_COLOR DEF_BUTTON_ACTIVE_FG_COLOR #define DEF_BUTTON_ACTIVE_FG_MONO WHITE #define DEF_BUTTON_BG_COLOR NORMAL_BG #define DEF_BUTTON_BG_MONO WHITE #define DEF_BUTTON_BITMAP "" #define DEF_BUTTON_BORDER_WIDTH "1" #define DEF_BUTTON_CURSOR "" #define DEF_BUTTON_COMPOUND "none" #define DEF_BUTTON_COMMAND "" #define DEF_BUTTON_DEFAULT "disabled" #define DEF_BUTTON_DISABLED_FG_COLOR DISABLED #define DEF_BUTTON_DISABLED_FG_MONO "" #define DEF_BUTTON_FG BLACK #define DEF_CHKRAD_FG DEF_BUTTON_FG #define DEF_BUTTON_FONT "TkDefaultFont" #define DEF_BUTTON_HEIGHT "0" #define DEF_BUTTON_HIGHLIGHT_BG_COLOR DEF_BUTTON_BG_COLOR #define DEF_BUTTON_HIGHLIGHT_BG_MONO DEF_BUTTON_BG_MONO #define DEF_BUTTON_HIGHLIGHT BLACK #define DEF_LABEL_HIGHLIGHT_WIDTH "0" #define DEF_BUTTON_HIGHLIGHT_WIDTH "1" #define DEF_BUTTON_IMAGE ((char *) NULL) #define DEF_BUTTON_INDICATOR "1" #define DEF_BUTTON_JUSTIFY "center" #define DEF_BUTTON_OFF_VALUE "0" #define DEF_BUTTON_ON_VALUE "1" #define DEF_BUTTON_TRISTATE_VALUE "" #define DEF_BUTTON_OVER_RELIEF "" #define DEF_BUTTON_PADX "3m" #define DEF_LABCHKRAD_PADX "1" #define DEF_BUTTON_PADY "1m" #define DEF_LABCHKRAD_PADY "1" #define DEF_BUTTON_RELIEF "raised" #define DEF_LABCHKRAD_RELIEF "flat" #define DEF_BUTTON_REPEAT_DELAY "0" #define DEF_BUTTON_REPEAT_INTERVAL "0" #define DEF_BUTTON_SELECT_COLOR CHECK_INDICATOR #define DEF_BUTTON_SELECT_MONO BLACK #define DEF_BUTTON_SELECT_IMAGE ((char *) NULL) #define DEF_BUTTON_STATE "normal" #define DEF_LABEL_TAKE_FOCUS "0" #define DEF_BUTTON_TAKE_FOCUS ((char *) NULL) #define DEF_BUTTON_TEXT "" #define DEF_BUTTON_TEXT_VARIABLE "" #define DEF_BUTTON_UNDERLINE "-1" #define DEF_BUTTON_VALUE "" #define DEF_BUTTON_WIDTH "0" #define DEF_BUTTON_WRAP_LENGTH "0" #define DEF_RADIOBUTTON_VARIABLE "selectedButton" #define DEF_CHECKBUTTON_VARIABLE "" /* * Defaults for canvases: */ #define DEF_CANVAS_BG_COLOR NORMAL_BG #define DEF_CANVAS_BG_MONO WHITE #define DEF_CANVAS_BORDER_WIDTH "0" #define DEF_CANVAS_CLOSE_ENOUGH "1" #define DEF_CANVAS_CONFINE "1" #define DEF_CANVAS_CURSOR "" #define DEF_CANVAS_HEIGHT "7c" #define DEF_CANVAS_HIGHLIGHT_BG NORMAL_BG #define DEF_CANVAS_HIGHLIGHT BLACK #define DEF_CANVAS_HIGHLIGHT_WIDTH "1" #define DEF_CANVAS_INSERT_BG BLACK #define DEF_CANVAS_INSERT_BD_COLOR "0" #define DEF_CANVAS_INSERT_BD_MONO "0" #define DEF_CANVAS_INSERT_OFF_TIME "300" #define DEF_CANVAS_INSERT_ON_TIME "600" #define DEF_CANVAS_INSERT_WIDTH "2" #define DEF_CANVAS_RELIEF "flat" #define DEF_CANVAS_SCROLL_REGION "" #define DEF_CANVAS_SELECT_COLOR SELECT_BG #define DEF_CANVAS_SELECT_MONO BLACK #define DEF_CANVAS_SELECT_BD_COLOR "1" #define DEF_CANVAS_SELECT_BD_MONO "0" #define DEF_CANVAS_SELECT_FG_COLOR BLACK #define DEF_CANVAS_SELECT_FG_MONO WHITE #define DEF_CANVAS_TAKE_FOCUS ((char *) NULL) #define DEF_CANVAS_WIDTH "10c" #define DEF_CANVAS_X_SCROLL_CMD "" #define DEF_CANVAS_X_SCROLL_INCREMENT "0" #define DEF_CANVAS_Y_SCROLL_CMD "" #define DEF_CANVAS_Y_SCROLL_INCREMENT "0" /* * Defaults for entries: */ #define DEF_ENTRY_BG_COLOR WHITE #define DEF_ENTRY_BG_MONO WHITE #define DEF_ENTRY_BORDER_WIDTH "1" #define DEF_ENTRY_CURSOR "xterm" #define DEF_ENTRY_DISABLED_BG_COLOR NORMAL_BG #define DEF_ENTRY_DISABLED_BG_MONO WHITE #define DEF_ENTRY_DISABLED_FG DISABLED #define DEF_ENTRY_EXPORT_SELECTION "1" #define DEF_ENTRY_FONT "TkTextFont" #define DEF_ENTRY_FG BLACK #define DEF_ENTRY_HIGHLIGHT_BG NORMAL_BG #define DEF_ENTRY_HIGHLIGHT BLACK #define DEF_ENTRY_HIGHLIGHT_WIDTH "1" #define DEF_ENTRY_INSERT_BG BLACK #define DEF_ENTRY_INSERT_BD_COLOR "0" #define DEF_ENTRY_INSERT_BD_MONO "0" #define DEF_ENTRY_INSERT_OFF_TIME "300" #define DEF_ENTRY_INSERT_ON_TIME "600" #define DEF_ENTRY_INSERT_WIDTH "2" #define DEF_ENTRY_JUSTIFY "left" #define DEF_ENTRY_READONLY_BG_COLOR NORMAL_BG #define DEF_ENTRY_READONLY_BG_MONO WHITE #define DEF_ENTRY_RELIEF "sunken" #define DEF_ENTRY_SCROLL_COMMAND "" #define DEF_ENTRY_SELECT_COLOR SELECT_BG #define DEF_ENTRY_SELECT_MONO BLACK #define DEF_ENTRY_SELECT_BD_COLOR "0" #define DEF_ENTRY_SELECT_BD_MONO "0" #define DEF_ENTRY_SELECT_FG_COLOR BLACK #define DEF_ENTRY_SELECT_FG_MONO WHITE #define DEF_ENTRY_SHOW ((char *) NULL) #define DEF_ENTRY_STATE "normal" #define DEF_ENTRY_TAKE_FOCUS ((char *) NULL) #define DEF_ENTRY_TEXT_VARIABLE "" #define DEF_ENTRY_WIDTH "20" /* * Defaults for frames: */ #define DEF_FRAME_BG_COLOR NORMAL_BG #define DEF_FRAME_BG_MONO WHITE #define DEF_FRAME_BORDER_WIDTH "0" #define DEF_FRAME_CLASS "Frame" #define DEF_FRAME_COLORMAP "" #define DEF_FRAME_CONTAINER "0" #define DEF_FRAME_CURSOR "" #define DEF_FRAME_HEIGHT "0" #define DEF_FRAME_HIGHLIGHT_BG NORMAL_BG #define DEF_FRAME_HIGHLIGHT BLACK #define DEF_FRAME_HIGHLIGHT_WIDTH "0" #define DEF_FRAME_LABEL "" #define DEF_FRAME_PADX "0" #define DEF_FRAME_PADY "0" #define DEF_FRAME_RELIEF "flat" #define DEF_FRAME_TAKE_FOCUS "0" #define DEF_FRAME_VISUAL "" #define DEF_FRAME_WIDTH "0" /* * Defaults for labelframes: */ #define DEF_LABELFRAME_BORDER_WIDTH "2" #define DEF_LABELFRAME_CLASS "Labelframe" #define DEF_LABELFRAME_RELIEF "groove" #define DEF_LABELFRAME_FG BLACK #define DEF_LABELFRAME_FONT "TkDefaultFont" #define DEF_LABELFRAME_TEXT "" #define DEF_LABELFRAME_LABELANCHOR "nw" /* * Defaults for listboxes: */ #define DEF_LISTBOX_ACTIVE_STYLE "dotbox" #define DEF_LISTBOX_BG_COLOR WHITE #define DEF_LISTBOX_BG_MONO WHITE #define DEF_LISTBOX_BORDER_WIDTH "1" #define DEF_LISTBOX_CURSOR "" #define DEF_LISTBOX_DISABLED_FG DISABLED #define DEF_LISTBOX_EXPORT_SELECTION "1" #define DEF_LISTBOX_FONT "TkDefaultFont" #define DEF_LISTBOX_FG BLACK #define DEF_LISTBOX_HEIGHT "10" #define DEF_LISTBOX_HIGHLIGHT_BG NORMAL_BG #define DEF_LISTBOX_HIGHLIGHT BLACK #define DEF_LISTBOX_HIGHLIGHT_WIDTH "1" #define DEF_LISTBOX_JUSTIFY "left" #define DEF_LISTBOX_RELIEF "sunken" #define DEF_LISTBOX_SCROLL_COMMAND "" #define DEF_LISTBOX_LIST_VARIABLE "" #define DEF_LISTBOX_SELECT_COLOR SELECT_BG #define DEF_LISTBOX_SELECT_MONO BLACK #define DEF_LISTBOX_SELECT_BD "0" #define DEF_LISTBOX_SELECT_FG_COLOR BLACK #define DEF_LISTBOX_SELECT_FG_MONO WHITE #define DEF_LISTBOX_SELECT_MODE "browse" #define DEF_LISTBOX_SET_GRID "0" #define DEF_LISTBOX_STATE "normal" #define DEF_LISTBOX_TAKE_FOCUS ((char *) NULL) #define DEF_LISTBOX_WIDTH "20" /* * Defaults for individual entries of menus: */ #define DEF_MENU_ENTRY_ACTIVE_BG ((char *) NULL) #define DEF_MENU_ENTRY_ACTIVE_FG ((char *) NULL) #define DEF_MENU_ENTRY_ACCELERATOR ((char *) NULL) #define DEF_MENU_ENTRY_BG ((char *) NULL) #define DEF_MENU_ENTRY_BITMAP None #define DEF_MENU_ENTRY_COLUMN_BREAK "0" #define DEF_MENU_ENTRY_COMMAND ((char *) NULL) #define DEF_MENU_ENTRY_COMPOUND "none" #define DEF_MENU_ENTRY_FG ((char *) NULL) #define DEF_MENU_ENTRY_FONT ((char *) NULL) #define DEF_MENU_ENTRY_HIDE_MARGIN "0" #define DEF_MENU_ENTRY_IMAGE ((char *) NULL) #define DEF_MENU_ENTRY_INDICATOR "1" #define DEF_MENU_ENTRY_LABEL ((char *) NULL) #define DEF_MENU_ENTRY_MENU ((char *) NULL) #define DEF_MENU_ENTRY_OFF_VALUE "0" #define DEF_MENU_ENTRY_ON_VALUE "1" #define DEF_MENU_ENTRY_SELECT_IMAGE ((char *) NULL) #define DEF_MENU_ENTRY_STATE "normal" #define DEF_MENU_ENTRY_VALUE ((char *) NULL) #define DEF_MENU_ENTRY_CHECK_VARIABLE ((char *) NULL) #define DEF_MENU_ENTRY_RADIO_VARIABLE "selectedButton" #define DEF_MENU_ENTRY_SELECT ((char *) NULL) #define DEF_MENU_ENTRY_UNDERLINE "-1" /* * Defaults for menus overall: */ #define DEF_MENU_ACTIVE_BG_COLOR ACTIVE_BG #define DEF_MENU_ACTIVE_BG_MONO BLACK #define DEF_MENU_ACTIVE_BORDER_WIDTH "1" #define DEF_MENU_ACTIVE_FG_COLOR BLACK #define DEF_MENU_ACTIVE_FG_MONO WHITE #define DEF_MENU_BG_COLOR NORMAL_BG #define DEF_MENU_BG_MONO WHITE #define DEF_MENU_BORDER_WIDTH "1" #define DEF_MENU_CURSOR "arrow" #define DEF_MENU_DISABLED_FG_COLOR DISABLED #define DEF_MENU_DISABLED_FG_MONO "" #define DEF_MENU_FONT "TkMenuFont" #define DEF_MENU_FG BLACK #define DEF_MENU_POST_COMMAND "" #define DEF_MENU_RELIEF "raised" #define DEF_MENU_SELECT_COLOR MENU_INDICATOR #define DEF_MENU_SELECT_MONO BLACK #define DEF_MENU_TAKE_FOCUS "0" #define DEF_MENU_TEAROFF "1" #define DEF_MENU_TEAROFF_CMD ((char *) NULL) #define DEF_MENU_TITLE "" #define DEF_MENU_TYPE "normal" /* * Defaults for menubuttons: */ #define DEF_MENUBUTTON_ANCHOR "center" #define DEF_MENUBUTTON_ACTIVE_BG_COLOR ACTIVE_BG #define DEF_MENUBUTTON_ACTIVE_BG_MONO BLACK #define DEF_MENUBUTTON_ACTIVE_FG_COLOR BLACK #define DEF_MENUBUTTON_ACTIVE_FG_MONO WHITE #define DEF_MENUBUTTON_BG_COLOR NORMAL_BG #define DEF_MENUBUTTON_BG_MONO WHITE #define DEF_MENUBUTTON_BITMAP "" #define DEF_MENUBUTTON_BORDER_WIDTH "1" #define DEF_MENUBUTTON_CURSOR "" #define DEF_MENUBUTTON_DIRECTION "below" #define DEF_MENUBUTTON_DISABLED_FG_COLOR DISABLED #define DEF_MENUBUTTON_DISABLED_FG_MONO "" #define DEF_MENUBUTTON_FONT "TkDefaultFont" #define DEF_MENUBUTTON_FG BLACK #define DEF_MENUBUTTON_HEIGHT "0" #define DEF_MENUBUTTON_HIGHLIGHT_BG_COLOR DEF_MENUBUTTON_BG_COLOR #define DEF_MENUBUTTON_HIGHLIGHT_BG_MONO DEF_MENUBUTTON_BG_MONO #define DEF_MENUBUTTON_HIGHLIGHT BLACK #define DEF_MENUBUTTON_HIGHLIGHT_WIDTH "0" #define DEF_MENUBUTTON_IMAGE ((char *) NULL) #define DEF_MENUBUTTON_INDICATOR "0" #define DEF_MENUBUTTON_JUSTIFY "center" #define DEF_MENUBUTTON_MENU "" #define DEF_MENUBUTTON_PADX "4p" #define DEF_MENUBUTTON_PADY "3p" #define DEF_MENUBUTTON_RELIEF "flat" #define DEF_MENUBUTTON_STATE "normal" #define DEF_MENUBUTTON_TAKE_FOCUS "0" #define DEF_MENUBUTTON_TEXT "" #define DEF_MENUBUTTON_TEXT_VARIABLE "" #define DEF_MENUBUTTON_UNDERLINE "-1" #define DEF_MENUBUTTON_WIDTH "0" #define DEF_MENUBUTTON_WRAP_LENGTH "0" /* * Defaults for messages: */ #define DEF_MESSAGE_ANCHOR "center" #define DEF_MESSAGE_ASPECT "150" #define DEF_MESSAGE_BG_COLOR NORMAL_BG #define DEF_MESSAGE_BG_MONO WHITE #define DEF_MESSAGE_BORDER_WIDTH "1" #define DEF_MESSAGE_CURSOR "" #define DEF_MESSAGE_FG BLACK #define DEF_MESSAGE_FONT "TkDefaultFont" #define DEF_MESSAGE_HIGHLIGHT_BG NORMAL_BG #define DEF_MESSAGE_HIGHLIGHT BLACK #define DEF_MESSAGE_HIGHLIGHT_WIDTH "0" #define DEF_MESSAGE_JUSTIFY "left" #define DEF_MESSAGE_PADX "-1" #define DEF_MESSAGE_PADY "-1" #define DEF_MESSAGE_RELIEF "flat" #define DEF_MESSAGE_TAKE_FOCUS "0" #define DEF_MESSAGE_TEXT "" #define DEF_MESSAGE_TEXT_VARIABLE "" #define DEF_MESSAGE_WIDTH "0" /* * Defaults for panedwindows */ #define DEF_PANEDWINDOW_BG_COLOR NORMAL_BG #define DEF_PANEDWINDOW_BG_MONO WHITE #define DEF_PANEDWINDOW_BORDERWIDTH "1" #define DEF_PANEDWINDOW_CURSOR "" #define DEF_PANEDWINDOW_HANDLEPAD "8" #define DEF_PANEDWINDOW_HANDLESIZE "8" #define DEF_PANEDWINDOW_HEIGHT "" #define DEF_PANEDWINDOW_OPAQUERESIZE "1" #define DEF_PANEDWINDOW_ORIENT "horizontal" #define DEF_PANEDWINDOW_PROXYBORDER "2" #define DEF_PANEDWINDOW_RELIEF "flat" #define DEF_PANEDWINDOW_SASHCURSOR "" #define DEF_PANEDWINDOW_SASHPAD "0" #define DEF_PANEDWINDOW_SASHRELIEF "flat" #define DEF_PANEDWINDOW_SASHWIDTH "3" #define DEF_PANEDWINDOW_SHOWHANDLE "0" #define DEF_PANEDWINDOW_WIDTH "" /* * Defaults for panedwindow panes */ #define DEF_PANEDWINDOW_PANE_AFTER "" #define DEF_PANEDWINDOW_PANE_BEFORE "" #define DEF_PANEDWINDOW_PANE_HEIGHT "" #define DEF_PANEDWINDOW_PANE_MINSIZE "0" #define DEF_PANEDWINDOW_PANE_PADX "0" #define DEF_PANEDWINDOW_PANE_PADY "0" #define DEF_PANEDWINDOW_PANE_STICKY "nsew" #define DEF_PANEDWINDOW_PANE_WIDTH "" #define DEF_PANEDWINDOW_PANE_HIDE "0" #define DEF_PANEDWINDOW_PANE_STRETCH "last" /* * Defaults for scales: */ #define DEF_SCALE_ACTIVE_BG_COLOR ACTIVE_BG #define DEF_SCALE_ACTIVE_BG_MONO BLACK #define DEF_SCALE_BG_COLOR NORMAL_BG #define DEF_SCALE_BG_MONO WHITE #define DEF_SCALE_BIG_INCREMENT "0" #define DEF_SCALE_BORDER_WIDTH "1" #define DEF_SCALE_COMMAND "" #define DEF_SCALE_CURSOR "" #define DEF_SCALE_DIGITS "0" #define DEF_SCALE_FONT "TkDefaultFont" #define DEF_SCALE_FG_COLOR BLACK #define DEF_SCALE_FG_MONO BLACK #define DEF_SCALE_FROM "0" #define DEF_SCALE_HIGHLIGHT_BG_COLOR DEF_SCALE_BG_COLOR #define DEF_SCALE_HIGHLIGHT_BG_MONO DEF_SCALE_BG_MONO #define DEF_SCALE_HIGHLIGHT BLACK #define DEF_SCALE_HIGHLIGHT_WIDTH "1" #define DEF_SCALE_LABEL "" #define DEF_SCALE_LENGTH "100" #define DEF_SCALE_ORIENT "vertical" #define DEF_SCALE_RELIEF "flat" #define DEF_SCALE_REPEAT_DELAY "300" #define DEF_SCALE_REPEAT_INTERVAL "100" #define DEF_SCALE_RESOLUTION "1" #define DEF_SCALE_TROUGH_COLOR TROUGH #define DEF_SCALE_TROUGH_MONO WHITE #define DEF_SCALE_SHOW_VALUE "1" #define DEF_SCALE_SLIDER_LENGTH "30" #define DEF_SCALE_SLIDER_RELIEF "raised" #define DEF_SCALE_STATE "normal" #define DEF_SCALE_TAKE_FOCUS ((char *) NULL) #define DEF_SCALE_TICK_INTERVAL "0" #define DEF_SCALE_TO "100" #define DEF_SCALE_VARIABLE "" #define DEF_SCALE_WIDTH "15" /* * Defaults for scrollbars: */ #define DEF_SCROLLBAR_ACTIVE_BG_COLOR ACTIVE_BG #define DEF_SCROLLBAR_ACTIVE_BG_MONO BLACK #define DEF_SCROLLBAR_ACTIVE_RELIEF "raised" #define DEF_SCROLLBAR_BG_COLOR NORMAL_BG #define DEF_SCROLLBAR_BG_MONO WHITE #define DEF_SCROLLBAR_BORDER_WIDTH "1" #define DEF_SCROLLBAR_COMMAND "" #define DEF_SCROLLBAR_CURSOR "" #define DEF_SCROLLBAR_EL_BORDER_WIDTH "-1" #define DEF_SCROLLBAR_HIGHLIGHT_BG NORMAL_BG #define DEF_SCROLLBAR_HIGHLIGHT BLACK #define DEF_SCROLLBAR_HIGHLIGHT_WIDTH "0" #define DEF_SCROLLBAR_JUMP "0" #define DEF_SCROLLBAR_ORIENT "vertical" #define DEF_SCROLLBAR_RELIEF "sunken" #define DEF_SCROLLBAR_REPEAT_DELAY "300" #define DEF_SCROLLBAR_REPEAT_INTERVAL "100" #define DEF_SCROLLBAR_TAKE_FOCUS ((char *) NULL) #define DEF_SCROLLBAR_TROUGH_COLOR TROUGH #define DEF_SCROLLBAR_TROUGH_MONO WHITE #define DEF_SCROLLBAR_WIDTH "11" /* * Defaults for texts: */ #define DEF_TEXT_AUTO_SEPARATORS "1" #define DEF_TEXT_BG_COLOR WHITE #define DEF_TEXT_BG_MONO WHITE #define DEF_TEXT_BLOCK_CURSOR "0" #define DEF_TEXT_BORDER_WIDTH "1" #define DEF_TEXT_CURSOR "xterm" #define DEF_TEXT_FG BLACK #define DEF_TEXT_EXPORT_SELECTION "1" #define DEF_TEXT_FONT "TkFixedFont" #define DEF_TEXT_HEIGHT "24" #define DEF_TEXT_HIGHLIGHT_BG NORMAL_BG #define DEF_TEXT_HIGHLIGHT BLACK #define DEF_TEXT_HIGHLIGHT_WIDTH "1" #define DEF_TEXT_INSERT_BG BLACK #define DEF_TEXT_INSERT_BD_COLOR "0" #define DEF_TEXT_INSERT_BD_MONO "0" #define DEF_TEXT_INSERT_OFF_TIME "300" #define DEF_TEXT_INSERT_ON_TIME "600" #define DEF_TEXT_INSERT_UNFOCUSSED "none" #define DEF_TEXT_INSERT_WIDTH "2" #define DEF_TEXT_MAX_UNDO "0" #define DEF_TEXT_PADX "1" #define DEF_TEXT_PADY "1" #define DEF_TEXT_RELIEF "sunken" #define DEF_TEXT_INACTIVE_SELECT_COLOR SELECT_BG #define DEF_TEXT_SELECT_COLOR SELECT_BG #define DEF_TEXT_SELECT_MONO BLACK #define DEF_TEXT_SELECT_BD_COLOR "0" #define DEF_TEXT_SELECT_BD_MONO "0" #define DEF_TEXT_SELECT_FG_COLOR BLACK #define DEF_TEXT_SELECT_FG_MONO WHITE #define DEF_TEXT_SELECT_RELIEF "raised" #define DEF_TEXT_SET_GRID "0" #define DEF_TEXT_SPACING1 "0" #define DEF_TEXT_SPACING2 "0" #define DEF_TEXT_SPACING3 "0" #define DEF_TEXT_STATE "normal" #define DEF_TEXT_TABS "" #define DEF_TEXT_TABSTYLE "tabular" #define DEF_TEXT_TAKE_FOCUS ((char *) NULL) #define DEF_TEXT_UNDO "0" #define DEF_TEXT_WIDTH "80" #define DEF_TEXT_WRAP "char" #define DEF_TEXT_XSCROLL_COMMAND "" #define DEF_TEXT_YSCROLL_COMMAND "" /* * Defaults for canvas text: */ #define DEF_CANVTEXT_FONT "TkDefaultFont" /* * Defaults for toplevels (most of the defaults for frames also apply * to toplevels): */ #define DEF_TOPLEVEL_CLASS "Toplevel" #define DEF_TOPLEVEL_MENU "" #define DEF_TOPLEVEL_SCREEN "" #define DEF_TOPLEVEL_USE "" /* * Defaults for busy windows: */ #define DEF_BUSY_CURSOR "watch" #endif /* _TKUNIXDEFAULT */ tk8.6.5/unix/tkAppInit.c0000644003604700454610000001013712377375532013540 0ustar dgp771div/* * tkAppInit.c -- * * Provides a default version of the main program and Tcl_AppInit * procedure for wish and other Tk-based applications. * * Copyright (c) 1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #undef BUILD_tk #undef STATIC_BUILD #include "tk.h" #ifdef TK_TEST extern Tcl_PackageInitProc Tktest_Init; #endif /* TK_TEST */ /* * The following #if block allows you to change the AppInit function by using * a #define of TCL_LOCAL_APPINIT instead of rewriting this entire file. The * #if checks for that #define and uses Tcl_AppInit if it doesn't exist. */ #ifndef TK_LOCAL_APPINIT #define TK_LOCAL_APPINIT Tcl_AppInit #endif #ifndef MODULE_SCOPE # define MODULE_SCOPE extern #endif MODULE_SCOPE int TK_LOCAL_APPINIT(Tcl_Interp *); MODULE_SCOPE int main(int, char **); /* * The following #if block allows you to change how Tcl finds the startup * script, prime the library or encoding paths, fiddle with the argv, etc., * without needing to rewrite Tk_Main() */ #ifdef TK_LOCAL_MAIN_HOOK MODULE_SCOPE int TK_LOCAL_MAIN_HOOK(int *argc, char ***argv); #endif /* Make sure the stubbed variants of those are never used. */ #undef Tcl_ObjSetVar2 #undef Tcl_NewStringObj /* *---------------------------------------------------------------------- * * main -- * * This is the main program for the application. * * Results: * None: Tk_Main never returns here, so this procedure never returns * either. * * Side effects: * Just about anything, since from here we call arbitrary Tcl code. * *---------------------------------------------------------------------- */ int main( int argc, /* Number of command-line arguments. */ char **argv) /* Values of command-line arguments. */ { #ifdef TK_LOCAL_MAIN_HOOK TK_LOCAL_MAIN_HOOK(&argc, &argv); #endif Tk_Main(argc, argv, TK_LOCAL_APPINIT); return 0; /* Needed only to prevent compiler warning. */ } /* *---------------------------------------------------------------------- * * Tcl_AppInit -- * * This procedure performs application-specific initialization. Most * applications, especially those that incorporate additional packages, * will have their own version of this procedure. * * Results: * Returns a standard Tcl completion code, and leaves an error message in * the interp's result if an error occurs. * * Side effects: * Depends on the startup script. * *---------------------------------------------------------------------- */ int Tcl_AppInit( Tcl_Interp *interp) /* Interpreter for application. */ { if ((Tcl_Init)(interp) == TCL_ERROR) { return TCL_ERROR; } if (Tk_Init(interp) == TCL_ERROR) { return TCL_ERROR; } Tcl_StaticPackage(interp, "Tk", Tk_Init, Tk_SafeInit); #ifdef TK_TEST if (Tktest_Init(interp) == TCL_ERROR) { return TCL_ERROR; } Tcl_StaticPackage(interp, "Tktest", Tktest_Init, 0); #endif /* TK_TEST */ /* * Call the init procedures for included packages. Each call should look * like this: * * if (Mod_Init(interp) == TCL_ERROR) { * return TCL_ERROR; * } * * where "Mod" is the name of the module. (Dynamically-loadable packages * should have the same entry-point name.) */ /* * Call Tcl_CreateObjCommand for application-specific commands, if they * weren't already created by the init procedures called above. */ /* * Specify a user-specific startup file to invoke if the application is * run interactively. Typically the startup file is "~/.apprc" where "app" * is the name of the application. If this line is deleted then no user- * specific startup file will be run under any conditions. */ Tcl_ObjSetVar2(interp, Tcl_NewStringObj("tcl_rcFileName", -1), NULL, Tcl_NewStringObj("~/.wishrc", -1), TCL_GLOBAL_ONLY); return TCL_OK; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ tk8.6.5/unix/tkUnix.c0000644003604700454610000001421412526764530013113 0ustar dgp771div/* * tkUnix.c -- * * This file contains procedures that are UNIX/X-specific, and will * probably have to be written differently for Windows or Macintosh * platforms. * * Copyright (c) 1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tkInt.h" #ifdef HAVE_XSS # include # ifdef __APPLE__ /* Support for weak-linked libXss. */ # define HaveXSSLibrary() (XScreenSaverQueryInfo != NULL) # else /* Other platforms always link libXss. */ # define HaveXSSLibrary() (1) # endif #endif /* *---------------------------------------------------------------------- * * TkGetServerInfo -- * * Given a window, this procedure returns information about the window * server for that window. This procedure provides the guts of the "winfo * server" command. * * Results: * Sets the interpreter result. * * Side effects: * None. * *---------------------------------------------------------------------- */ void TkGetServerInfo( Tcl_Interp *interp, /* The server information is returned in this * interpreter's result. */ Tk_Window tkwin) /* Token for window; this selects a particular * display and server. */ { Tcl_SetObjResult(interp, Tcl_ObjPrintf("X%dR%d %s %d", ProtocolVersion(Tk_Display(tkwin)), ProtocolRevision(Tk_Display(tkwin)), ServerVendor(Tk_Display(tkwin)), VendorRelease(Tk_Display(tkwin)))); } /* *---------------------------------------------------------------------- * * TkGetDefaultScreenName -- * * Returns the name of the screen that Tk should use during * initialization. * * Results: * Returns the argument or a string that should not be freed by the * caller. * * Side effects: * None. * *---------------------------------------------------------------------- */ const char * TkGetDefaultScreenName( Tcl_Interp *interp, /* Interp used to find environment * variables. */ const char *screenName) /* Screen name from command line, or NULL. */ { if ((screenName == NULL) || (screenName[0] == '\0')) { screenName = Tcl_GetVar2(interp, "env", "DISPLAY", TCL_GLOBAL_ONLY); } return screenName; } /* *---------------------------------------------------------------------- * * Tk_UpdatePointer -- * * Unused function in UNIX * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ void Tk_UpdatePointer( Tk_Window tkwin, /* Window to which pointer event is reported. * May be NULL. */ int x, int y, /* Pointer location in root coords. */ int state) /* Modifier state mask. */ { /* * This function intentionally left blank */ } /* *---------------------------------------------------------------------- * * TkpBuildRegionFromAlphaData -- * * Set up a rectangle of the given region based on the supplied alpha * data. * * Results: * None * * Side effects: * The region is updated, with extra pixels added to it. * *---------------------------------------------------------------------- */ void TkpBuildRegionFromAlphaData( TkRegion region, /* Region to be updated. */ unsigned x, unsigned y, /* Where in region to update. */ unsigned width, unsigned height, /* Size of rectangle to update. */ unsigned char *dataPtr, /* Data to read from. */ unsigned pixelStride, /* Num bytes from one piece of alpha data to * the next in the line. */ unsigned lineStride) /* Num bytes from one line of alpha data to * the next line. */ { unsigned char *lineDataPtr; unsigned int x1, y1, end; XRectangle rect; for (y1 = 0; y1 < height; y1++) { lineDataPtr = dataPtr; for (x1 = 0; x1 < width; x1 = end) { /* * Search for first non-transparent pixel. */ while ((x1 < width) && !*lineDataPtr) { x1++; lineDataPtr += pixelStride; } end = x1; /* * Search for first transparent pixel. */ while ((end < width) && *lineDataPtr) { end++; lineDataPtr += pixelStride; } if (end > x1) { rect.x = x + x1; rect.y = y + y1; rect.width = end - x1; rect.height = 1; TkUnionRectWithRegion(&rect, region, region); } } dataPtr += lineStride; } } /* *---------------------------------------------------------------------- * * Tk_GetUserInactiveTime -- * * Return the number of milliseconds the user was inactive. * * Results: * The number of milliseconds since the user's latest interaction with * the system on the given display, or -1 if the XScreenSaver extension * is not supported by the client libraries or the X server * implementation. * * Side effects: * None. *---------------------------------------------------------------------- */ long Tk_GetUserInactiveTime( Display *dpy) /* The display for which to query the inactive * time. */ { long inactiveTime = -1; #ifdef HAVE_XSS int eventBase, errorBase, major, minor; /* * Calling XScreenSaverQueryVersion seems to be needed to prevent a crash * on some buggy versions of XFree86. */ if (HaveXSSLibrary() && XScreenSaverQueryExtension(dpy, &eventBase, &errorBase) && XScreenSaverQueryVersion(dpy, &major, &minor)) { XScreenSaverInfo *info = XScreenSaverAllocInfo(); if (info == NULL) { /* * We are out of memory. */ Tcl_Panic("Out of memory: XScreenSaverAllocInfo failed in Tk_GetUserInactiveTime"); } if (XScreenSaverQueryInfo(dpy, DefaultRootWindow(dpy), info)) { inactiveTime = info->idle; } XFree(info); } #endif /* HAVE_XSS */ return inactiveTime; } /* *---------------------------------------------------------------------- * * Tk_ResetUserInactiveTime -- * * Reset the user inactivity timer * * Results: * none * * Side effects: * The user inactivity timer of the underlaying windowing system is reset * to zero. * *---------------------------------------------------------------------- */ void Tk_ResetUserInactiveTime( Display *dpy) { XResetScreenSaver(dpy); } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ tk8.6.5/unix/tkUnixDraw.c0000644003604700454610000001434112377375532013736 0ustar dgp771div/* * tkUnixDraw.c -- * * This file contains X specific drawing routines. * * Copyright (c) 1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tkInt.h" #ifndef _WIN32 #include "tkUnixInt.h" #endif /* * The following structure is used to pass information to ScrollRestrictProc * from TkScrollWindow. */ typedef struct ScrollInfo { int done; /* Flag is 0 until filtering is done. */ Display *display; /* Display to filter. */ Window window; /* Window to filter. */ TkRegion region; /* Region into which damage is accumulated. */ int dx, dy; /* Amount by which window was shifted. */ } ScrollInfo; /* * Forward declarations for functions declared later in this file: */ static Tk_RestrictProc ScrollRestrictProc; /* *---------------------------------------------------------------------- * * TkScrollWindow -- * * Scroll a rectangle of the specified window and accumulate damage * information in the specified Region. * * Results: * Returns 0 if no damage additional damage was generated. Sets damageRgn * to contain the damaged areas and returns 1 if GraphicsExpose events * were detected. * * Side effects: * Scrolls the bits in the window and enters the event loop looking for * damage events. * *---------------------------------------------------------------------- */ int TkScrollWindow( Tk_Window tkwin, /* The window to be scrolled. */ GC gc, /* GC for window to be scrolled. */ int x, int y, int width, int height, /* Position rectangle to be scrolled. */ int dx, int dy, /* Distance rectangle should be moved. */ TkRegion damageRgn) /* Region to accumulate damage in. */ { Tk_RestrictProc *prevProc; ClientData prevArg; ScrollInfo info; XCopyArea(Tk_Display(tkwin), Tk_WindowId(tkwin), Tk_WindowId(tkwin), gc, x, y, (unsigned) width, (unsigned) height, x+dx, y+dy); info.done = 0; info.window = Tk_WindowId(tkwin); info.display = Tk_Display(tkwin); info.region = damageRgn; info.dx = dx; info.dy = dy; /* * Sync the event stream so all of the expose events will be on the Tk * event queue before we start filtering. This avoids busy waiting while * we filter events. */ TkpSync(info.display); prevProc = Tk_RestrictEvents(ScrollRestrictProc, &info, &prevArg); while (!info.done) { Tcl_ServiceEvent(TCL_WINDOW_EVENTS); } Tk_RestrictEvents(prevProc, prevArg, &prevArg); if (XEmptyRegion((Region) damageRgn)) { return 0; } else { return 1; } } /* *---------------------------------------------------------------------- * * ScrollRestrictProc -- * * A Tk_RestrictProc used by TkScrollWindow to gather up Expose * information into a single damage region. It accumulates damage events * on the specified window until a NoExpose or the last GraphicsExpose * event is detected. * * Results: * None. * * Side effects: * Discards Expose events after accumulating damage information * for a particular window. * *---------------------------------------------------------------------- */ static Tk_RestrictAction ScrollRestrictProc( ClientData arg, XEvent *eventPtr) { ScrollInfo *info = (ScrollInfo *) arg; XRectangle rect; /* * Defer events which aren't for the specified window. */ if (info->done || (eventPtr->xany.display != info->display) || (eventPtr->xany.window != info->window)) { return TK_DEFER_EVENT; } if (eventPtr->type == NoExpose) { info->done = 1; } else if (eventPtr->type == GraphicsExpose) { rect.x = eventPtr->xgraphicsexpose.x; rect.y = eventPtr->xgraphicsexpose.y; rect.width = eventPtr->xgraphicsexpose.width; rect.height = eventPtr->xgraphicsexpose.height; XUnionRectWithRegion(&rect, (Region) info->region, (Region) info->region); if (eventPtr->xgraphicsexpose.count == 0) { info->done = 1; } } else if (eventPtr->type == Expose) { /* * This case is tricky. This event was already queued before the * XCopyArea was issued. If this area overlaps the area being copied, * then some of the copied area may be invalid. The easiest way to * handle this case is to mark both the original area and the shifted * area as damaged. */ rect.x = eventPtr->xexpose.x; rect.y = eventPtr->xexpose.y; rect.width = eventPtr->xexpose.width; rect.height = eventPtr->xexpose.height; XUnionRectWithRegion(&rect, (Region) info->region, (Region) info->region); rect.x += info->dx; rect.y += info->dy; XUnionRectWithRegion(&rect, (Region) info->region, (Region) info->region); } else { return TK_DEFER_EVENT; } return TK_DISCARD_EVENT; } /* *---------------------------------------------------------------------- * * TkpDrawHighlightBorder -- * * This function draws a rectangular ring around the outside of a widget * to indicate that it has received the input focus. * * On Unix, we just draw the simple inset ring. On other sytems, e.g. the * Mac, the focus ring is a little more complicated, so we need this * abstraction. * * Results: * None. * * Side effects: * A rectangle "width" pixels wide is drawn in "drawable", corresponding * to the outer area of "tkwin". * *---------------------------------------------------------------------- */ void TkpDrawHighlightBorder( Tk_Window tkwin, GC fgGC, GC bgGC, int highlightWidth, Drawable drawable) { TkDrawInsetFocusHighlight(tkwin, fgGC, highlightWidth, drawable, 0); } /* *---------------------------------------------------------------------- * * TkpDrawFrame -- * * This function draws the rectangular frame area. * * Results: * None. * * Side effects: * Draws inside the tkwin area. * *---------------------------------------------------------------------- */ void TkpDrawFrame( Tk_Window tkwin, Tk_3DBorder border, int highlightWidth, int borderWidth, int relief) { Tk_Fill3DRectangle(tkwin, Tk_WindowId(tkwin), border, highlightWidth, highlightWidth, Tk_Width(tkwin) - 2*highlightWidth, Tk_Height(tkwin) - 2*highlightWidth, borderWidth, relief); } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ tk8.6.5/unix/configure0000775003604700454610000126250012665114121013367 0ustar dgp771div#! /bin/sh # Guess values for system-dependent variables and create Makefiles. # Generated by GNU Autoconf 2.59 for tk 8.6. # # Copyright (C) 2003 Free Software Foundation, Inc. # This configure script is free software; the Free Software Foundation # gives unlimited permission to copy, distribute and modify it. ## --------------------- ## ## M4sh Initialization. ## ## --------------------- ## # Be Bourne compatible if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then emulate sh NULLCMD=: # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' elif test -n "${BASH_VERSION+set}" && (set -o posix) >/dev/null 2>&1; then set -o posix fi DUALCASE=1; export DUALCASE # for MKS sh # Support unset when possible. if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then as_unset=unset else as_unset=false fi # Work around bugs in pre-3.0 UWIN ksh. $as_unset ENV MAIL MAILPATH PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. for as_var in \ LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \ LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \ LC_TELEPHONE LC_TIME do if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then eval $as_var=C; export $as_var else $as_unset $as_var fi done # Required to use basename. if expr a : '\(a\)' >/dev/null 2>&1; then as_expr=expr else as_expr=false fi if (basename /) >/dev/null 2>&1 && test "X`basename / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi # Name of the executable. as_me=`$as_basename "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)$' \| \ . : '\(.\)' 2>/dev/null || echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/; q; } /^X\/\(\/\/\)$/{ s//\1/; q; } /^X\/\(\/\).*/{ s//\1/; q; } s/.*/./; q'` # PATH needs CR, and LINENO needs CR and PATH. # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then echo "#! /bin/sh" >conf$$.sh echo "exit 0" >>conf$$.sh chmod +x conf$$.sh if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then PATH_SEPARATOR=';' else PATH_SEPARATOR=: fi rm -f conf$$.sh fi as_lineno_1=$LINENO as_lineno_2=$LINENO as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null` test "x$as_lineno_1" != "x$as_lineno_2" && test "x$as_lineno_3" = "x$as_lineno_2" || { # Find who we are. Look in the path if we contain no path at all # relative or not. case $0 in *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break done ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then { echo "$as_me: error: cannot find myself; rerun with an absolute path" >&2 { (exit 1); exit 1; }; } fi case $CONFIG_SHELL in '') as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for as_base in sh bash ksh sh5; do case $as_dir in /*) if ("$as_dir/$as_base" -c ' as_lineno_1=$LINENO as_lineno_2=$LINENO as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null` test "x$as_lineno_1" != "x$as_lineno_2" && test "x$as_lineno_3" = "x$as_lineno_2" ') 2>/dev/null; then $as_unset BASH_ENV || test "${BASH_ENV+set}" != set || { BASH_ENV=; export BASH_ENV; } $as_unset ENV || test "${ENV+set}" != set || { ENV=; export ENV; } CONFIG_SHELL=$as_dir/$as_base export CONFIG_SHELL exec "$CONFIG_SHELL" "$0" ${1+"$@"} fi;; esac done done ;; esac # Create $as_me.lineno as a copy of $as_myself, but with $LINENO # uniformly replaced by the line number. The first 'sed' inserts a # line-number line before each line; the second 'sed' does the real # work. The second script uses 'N' to pair each line-number line # with the numbered line, and appends trailing '-' during # substitution so that $LINENO is not a special case at line end. # (Raja R Harinath suggested sed '=', and Paul Eggert wrote the # second 'sed' script. Blame Lee E. McMahon for sed's syntax. :-) sed '=' <$as_myself | sed ' N s,$,-, : loop s,^\(['$as_cr_digits']*\)\(.*\)[$]LINENO\([^'$as_cr_alnum'_]\),\1\2\1\3, t loop s,-$,, s,^['$as_cr_digits']*\n,, ' >$as_me.lineno && chmod +x $as_me.lineno || { echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2 { (exit 1); exit 1; }; } # Don't try to exec as it changes $[0], causing all sort of problems # (the dirname of $[0] is not the place where we might find the # original and so on. Autoconf is especially sensible to this). . ./$as_me.lineno # Exit status is that of the last command. exit } case `echo "testing\c"; echo 1,2,3`,`echo -n testing; echo 1,2,3` in *c*,-n*) ECHO_N= ECHO_C=' ' ECHO_T=' ' ;; *c*,* ) ECHO_N=-n ECHO_C= ECHO_T= ;; *) ECHO_N= ECHO_C='\c' ECHO_T= ;; esac if expr a : '\(a\)' >/dev/null 2>&1; then as_expr=expr else as_expr=false fi rm -f conf$$ conf$$.exe conf$$.file echo >conf$$.file if ln -s conf$$.file conf$$ 2>/dev/null; then # We could just check for DJGPP; but this test a) works b) is more generic # and c) will remain valid once DJGPP supports symlinks (DJGPP 2.04). if test -f conf$$.exe; then # Don't use ln at all; we don't have any links as_ln_s='cp -p' else as_ln_s='ln -s' fi elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -p' fi rm -f conf$$ conf$$.exe conf$$.file if mkdir -p . 2>/dev/null; then as_mkdir_p=: else test -d ./-p && rmdir ./-p as_mkdir_p=false fi as_executable_p="test -f" # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" # IFS # We need space, tab and new line, in precisely that order. as_nl=' ' IFS=" $as_nl" # CDPATH. $as_unset CDPATH # Name of the host. # hostname on some systems (SVR3.2, Linux) returns a bogus exit status, # so uname gets run too. ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` exec 6>&1 # # Initializations. # ac_default_prefix=/usr/local ac_config_libobj_dir=. cross_compiling=no subdirs= MFLAGS= MAKEFLAGS= SHELL=${CONFIG_SHELL-/bin/sh} # Maximum number of lines to put in a shell here document. # This variable seems obsolete. It should probably be removed, and # only ac_max_sed_lines should be used. : ${ac_max_here_lines=38} # Identity of this package. PACKAGE_NAME='tk' PACKAGE_TARNAME='tk' PACKAGE_VERSION='8.6' PACKAGE_STRING='tk 8.6' PACKAGE_BUGREPORT='' # Factoring default headers for most tests. ac_includes_default="\ #include #if HAVE_SYS_TYPES_H # include #endif #if HAVE_SYS_STAT_H # include #endif #if STDC_HEADERS # include # include #else # if HAVE_STDLIB_H # include # endif #endif #if HAVE_STRING_H # if !STDC_HEADERS && HAVE_MEMORY_H # include # endif # include #endif #if HAVE_STRINGS_H # include #endif #if HAVE_INTTYPES_H # include #else # if HAVE_STDINT_H # include # endif #endif #if HAVE_UNISTD_H # include #endif" ac_subst_vars='SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS TCL_VERSION TCL_PATCH_LEVEL TCL_BIN_DIR TCL_SRC_DIR TCL_LIB_FILE TCL_LIB_FLAG TCL_LIB_SPEC TCL_STUB_LIB_FILE TCL_STUB_LIB_FLAG TCL_STUB_LIB_SPEC TCLSH_PROG BUILD_TCLSH MAN_FLAGS CC CFLAGS LDFLAGS CPPFLAGS ac_ct_CC EXEEXT OBJEXT CPP EGREP TCL_THREADS RANLIB ac_ct_RANLIB AR ac_ct_AR LIBOBJS TCL_LIBS DL_LIBS DL_OBJS PLAT_OBJS PLAT_SRCS LDAIX_SRC CFLAGS_DEBUG CFLAGS_OPTIMIZE CFLAGS_WARNING LDFLAGS_DEBUG LDFLAGS_OPTIMIZE CC_SEARCH_FLAGS LD_SEARCH_FLAGS STLIB_LD SHLIB_LD TCL_SHLIB_LD_EXTRAS TK_SHLIB_LD_EXTRAS SHLIB_LD_LIBS SHLIB_CFLAGS SHLIB_SUFFIX MAKE_LIB MAKE_STUB_LIB INSTALL_LIB DLL_INSTALL_DIR INSTALL_STUB_LIB CFLAGS_DEFAULT LDFLAGS_DEFAULT XFT_CFLAGS XFT_LIBS UNIX_FONT_OBJS TK_VERSION TK_MAJOR_VERSION TK_MINOR_VERSION TK_PATCH_LEVEL TK_YEAR TK_LIB_FILE TK_LIB_FLAG TK_LIB_SPEC TK_STUB_LIB_FILE TK_STUB_LIB_FLAG TK_STUB_LIB_SPEC TK_STUB_LIB_PATH TK_INCLUDE_SPEC TK_BUILD_STUB_LIB_SPEC TK_BUILD_STUB_LIB_PATH TK_SRC_DIR TK_SHARED_BUILD LD_LIBRARY_PATH_VAR TK_BUILD_LIB_SPEC TCL_STUB_FLAGS XINCLUDES XLIBSW LOCALES TK_WINDOWINGSYSTEM TK_PKG_DIR TK_LIBRARY LIB_RUNTIME_DIR PRIVATE_INCLUDE_DIR HTML_DIR EXTRA_CC_SWITCHES EXTRA_APP_CC_SWITCHES EXTRA_INSTALL EXTRA_INSTALL_BINARIES EXTRA_BUILD_HTML EXTRA_WISH_LIBS CFBUNDLELOCALIZATIONS TK_RSRC_FILE WISH_RSRC_FILE LIB_RSRC_FILE APP_RSRC_FILE REZ REZ_FLAGS LTLIBOBJS' ac_subst_files='' # Initialize some variables set by options. ac_init_help= ac_init_version=false # The variables have the same names as the options, with # dashes changed to underlines. cache_file=/dev/null exec_prefix=NONE no_create= no_recursion= prefix=NONE program_prefix=NONE program_suffix=NONE program_transform_name=s,x,x, silent= site= srcdir= verbose= x_includes=NONE x_libraries=NONE # Installation directory options. # These are left unexpanded so users can "make install exec_prefix=/foo" # and all the variables that are supposed to be based on exec_prefix # by default will actually change. # Use braces instead of parens because sh, perl, etc. also accept them. bindir='${exec_prefix}/bin' sbindir='${exec_prefix}/sbin' libexecdir='${exec_prefix}/libexec' datadir='${prefix}/share' sysconfdir='${prefix}/etc' sharedstatedir='${prefix}/com' localstatedir='${prefix}/var' libdir='${exec_prefix}/lib' includedir='${prefix}/include' oldincludedir='/usr/include' infodir='${prefix}/info' mandir='${prefix}/man' ac_prev= for ac_option do # If the previous option needs an argument, assign it. if test -n "$ac_prev"; then eval "$ac_prev=\$ac_option" ac_prev= continue fi ac_optarg=`expr "x$ac_option" : 'x[^=]*=\(.*\)'` # Accept the important Cygnus configure options, so we can diagnose typos. case $ac_option in -bindir | --bindir | --bindi | --bind | --bin | --bi) ac_prev=bindir ;; -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) bindir=$ac_optarg ;; -build | --build | --buil | --bui | --bu) ac_prev=build_alias ;; -build=* | --build=* | --buil=* | --bui=* | --bu=*) build_alias=$ac_optarg ;; -cache-file | --cache-file | --cache-fil | --cache-fi \ | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) ac_prev=cache_file ;; -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) cache_file=$ac_optarg ;; --config-cache | -C) cache_file=config.cache ;; -datadir | --datadir | --datadi | --datad | --data | --dat | --da) ac_prev=datadir ;; -datadir=* | --datadir=* | --datadi=* | --datad=* | --data=* | --dat=* \ | --da=*) datadir=$ac_optarg ;; -disable-* | --disable-*) ac_feature=`expr "x$ac_option" : 'x-*disable-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_feature" : ".*[^-_$as_cr_alnum]" >/dev/null && { echo "$as_me: error: invalid feature name: $ac_feature" >&2 { (exit 1); exit 1; }; } ac_feature=`echo $ac_feature | sed 's/-/_/g'` eval "enable_$ac_feature=no" ;; -enable-* | --enable-*) ac_feature=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_feature" : ".*[^-_$as_cr_alnum]" >/dev/null && { echo "$as_me: error: invalid feature name: $ac_feature" >&2 { (exit 1); exit 1; }; } ac_feature=`echo $ac_feature | sed 's/-/_/g'` case $ac_option in *=*) ac_optarg=`echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"`;; *) ac_optarg=yes ;; esac eval "enable_$ac_feature='$ac_optarg'" ;; -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ | --exec | --exe | --ex) ac_prev=exec_prefix ;; -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ | --exec=* | --exe=* | --ex=*) exec_prefix=$ac_optarg ;; -gas | --gas | --ga | --g) # Obsolete; use --with-gas. with_gas=yes ;; -help | --help | --hel | --he | -h) ac_init_help=long ;; -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) ac_init_help=recursive ;; -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) ac_init_help=short ;; -host | --host | --hos | --ho) ac_prev=host_alias ;; -host=* | --host=* | --hos=* | --ho=*) host_alias=$ac_optarg ;; -includedir | --includedir | --includedi | --included | --include \ | --includ | --inclu | --incl | --inc) ac_prev=includedir ;; -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ | --includ=* | --inclu=* | --incl=* | --inc=*) includedir=$ac_optarg ;; -infodir | --infodir | --infodi | --infod | --info | --inf) ac_prev=infodir ;; -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) infodir=$ac_optarg ;; -libdir | --libdir | --libdi | --libd) ac_prev=libdir ;; -libdir=* | --libdir=* | --libdi=* | --libd=*) libdir=$ac_optarg ;; -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ | --libexe | --libex | --libe) ac_prev=libexecdir ;; -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ | --libexe=* | --libex=* | --libe=*) libexecdir=$ac_optarg ;; -localstatedir | --localstatedir | --localstatedi | --localstated \ | --localstate | --localstat | --localsta | --localst \ | --locals | --local | --loca | --loc | --lo) ac_prev=localstatedir ;; -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ | --localstate=* | --localstat=* | --localsta=* | --localst=* \ | --locals=* | --local=* | --loca=* | --loc=* | --lo=*) localstatedir=$ac_optarg ;; -mandir | --mandir | --mandi | --mand | --man | --ma | --m) ac_prev=mandir ;; -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) mandir=$ac_optarg ;; -nfp | --nfp | --nf) # Obsolete; use --without-fp. with_fp=no ;; -no-create | --no-create | --no-creat | --no-crea | --no-cre \ | --no-cr | --no-c | -n) no_create=yes ;; -no-recursion | --no-recursion | --no-recursio | --no-recursi \ | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) no_recursion=yes ;; -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ | --oldin | --oldi | --old | --ol | --o) ac_prev=oldincludedir ;; -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) oldincludedir=$ac_optarg ;; -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) ac_prev=prefix ;; -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) prefix=$ac_optarg ;; -program-prefix | --program-prefix | --program-prefi | --program-pref \ | --program-pre | --program-pr | --program-p) ac_prev=program_prefix ;; -program-prefix=* | --program-prefix=* | --program-prefi=* \ | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) program_prefix=$ac_optarg ;; -program-suffix | --program-suffix | --program-suffi | --program-suff \ | --program-suf | --program-su | --program-s) ac_prev=program_suffix ;; -program-suffix=* | --program-suffix=* | --program-suffi=* \ | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) program_suffix=$ac_optarg ;; -program-transform-name | --program-transform-name \ | --program-transform-nam | --program-transform-na \ | --program-transform-n | --program-transform- \ | --program-transform | --program-transfor \ | --program-transfo | --program-transf \ | --program-trans | --program-tran \ | --progr-tra | --program-tr | --program-t) ac_prev=program_transform_name ;; -program-transform-name=* | --program-transform-name=* \ | --program-transform-nam=* | --program-transform-na=* \ | --program-transform-n=* | --program-transform-=* \ | --program-transform=* | --program-transfor=* \ | --program-transfo=* | --program-transf=* \ | --program-trans=* | --program-tran=* \ | --progr-tra=* | --program-tr=* | --program-t=*) program_transform_name=$ac_optarg ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) silent=yes ;; -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) ac_prev=sbindir ;; -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ | --sbi=* | --sb=*) sbindir=$ac_optarg ;; -sharedstatedir | --sharedstatedir | --sharedstatedi \ | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ | --sharedst | --shareds | --shared | --share | --shar \ | --sha | --sh) ac_prev=sharedstatedir ;; -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ | --sha=* | --sh=*) sharedstatedir=$ac_optarg ;; -site | --site | --sit) ac_prev=site ;; -site=* | --site=* | --sit=*) site=$ac_optarg ;; -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) ac_prev=srcdir ;; -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) srcdir=$ac_optarg ;; -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ | --syscon | --sysco | --sysc | --sys | --sy) ac_prev=sysconfdir ;; -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) sysconfdir=$ac_optarg ;; -target | --target | --targe | --targ | --tar | --ta | --t) ac_prev=target_alias ;; -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) target_alias=$ac_optarg ;; -v | -verbose | --verbose | --verbos | --verbo | --verb) verbose=yes ;; -version | --version | --versio | --versi | --vers | -V) ac_init_version=: ;; -with-* | --with-*) ac_package=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_package" : ".*[^-_$as_cr_alnum]" >/dev/null && { echo "$as_me: error: invalid package name: $ac_package" >&2 { (exit 1); exit 1; }; } ac_package=`echo $ac_package| sed 's/-/_/g'` case $ac_option in *=*) ac_optarg=`echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"`;; *) ac_optarg=yes ;; esac eval "with_$ac_package='$ac_optarg'" ;; -without-* | --without-*) ac_package=`expr "x$ac_option" : 'x-*without-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_package" : ".*[^-_$as_cr_alnum]" >/dev/null && { echo "$as_me: error: invalid package name: $ac_package" >&2 { (exit 1); exit 1; }; } ac_package=`echo $ac_package | sed 's/-/_/g'` eval "with_$ac_package=no" ;; --x) # Obsolete; use --with-x. with_x=yes ;; -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ | --x-incl | --x-inc | --x-in | --x-i) ac_prev=x_includes ;; -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) x_includes=$ac_optarg ;; -x-libraries | --x-libraries | --x-librarie | --x-librari \ | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) ac_prev=x_libraries ;; -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) x_libraries=$ac_optarg ;; -*) { echo "$as_me: error: unrecognized option: $ac_option Try \`$0 --help' for more information." >&2 { (exit 1); exit 1; }; } ;; *=*) ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` # Reject names that are not valid shell variable names. expr "x$ac_envvar" : ".*[^_$as_cr_alnum]" >/dev/null && { echo "$as_me: error: invalid variable name: $ac_envvar" >&2 { (exit 1); exit 1; }; } ac_optarg=`echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` eval "$ac_envvar='$ac_optarg'" export $ac_envvar ;; *) # FIXME: should be removed in autoconf 3.0. echo "$as_me: WARNING: you should use --build, --host, --target" >&2 expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && echo "$as_me: WARNING: invalid host type: $ac_option" >&2 : ${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option} ;; esac done if test -n "$ac_prev"; then ac_option=--`echo $ac_prev | sed 's/_/-/g'` { echo "$as_me: error: missing argument to $ac_option" >&2 { (exit 1); exit 1; }; } fi # Be sure to have absolute paths. for ac_var in exec_prefix prefix do eval ac_val=$`echo $ac_var` case $ac_val in [\\/$]* | ?:[\\/]* | NONE | '' ) ;; *) { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2 { (exit 1); exit 1; }; };; esac done # Be sure to have absolute paths. for ac_var in bindir sbindir libexecdir datadir sysconfdir sharedstatedir \ localstatedir libdir includedir oldincludedir infodir mandir do eval ac_val=$`echo $ac_var` case $ac_val in [\\/$]* | ?:[\\/]* ) ;; *) { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2 { (exit 1); exit 1; }; };; esac done # There might be people who depend on the old broken behavior: `$host' # used to hold the argument of --host etc. # FIXME: To remove some day. build=$build_alias host=$host_alias target=$target_alias # FIXME: To remove some day. if test "x$host_alias" != x; then if test "x$build_alias" = x; then cross_compiling=maybe echo "$as_me: WARNING: If you wanted to set the --build type, don't use --host. If a cross compiler is detected then cross compile mode will be used." >&2 elif test "x$build_alias" != "x$host_alias"; then cross_compiling=yes fi fi ac_tool_prefix= test -n "$host_alias" && ac_tool_prefix=$host_alias- test "$silent" = yes && exec 6>/dev/null # Find the source files, if location was not specified. if test -z "$srcdir"; then ac_srcdir_defaulted=yes # Try the directory containing this script, then its parent. ac_confdir=`(dirname "$0") 2>/dev/null || $as_expr X"$0" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$0" : 'X\(//\)[^/]' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| \ . : '\(.\)' 2>/dev/null || echo X"$0" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } /^X\(\/\/\)[^/].*/{ s//\1/; q; } /^X\(\/\/\)$/{ s//\1/; q; } /^X\(\/\).*/{ s//\1/; q; } s/.*/./; q'` srcdir=$ac_confdir if test ! -r $srcdir/$ac_unique_file; then srcdir=.. fi else ac_srcdir_defaulted=no fi if test ! -r $srcdir/$ac_unique_file; then if test "$ac_srcdir_defaulted" = yes; then { echo "$as_me: error: cannot find sources ($ac_unique_file) in $ac_confdir or .." >&2 { (exit 1); exit 1; }; } else { echo "$as_me: error: cannot find sources ($ac_unique_file) in $srcdir" >&2 { (exit 1); exit 1; }; } fi fi (cd $srcdir && test -r ./$ac_unique_file) 2>/dev/null || { echo "$as_me: error: sources are in $srcdir, but \`cd $srcdir' does not work" >&2 { (exit 1); exit 1; }; } srcdir=`echo "$srcdir" | sed 's%\([^\\/]\)[\\/]*$%\1%'` ac_env_build_alias_set=${build_alias+set} ac_env_build_alias_value=$build_alias ac_cv_env_build_alias_set=${build_alias+set} ac_cv_env_build_alias_value=$build_alias ac_env_host_alias_set=${host_alias+set} ac_env_host_alias_value=$host_alias ac_cv_env_host_alias_set=${host_alias+set} ac_cv_env_host_alias_value=$host_alias ac_env_target_alias_set=${target_alias+set} ac_env_target_alias_value=$target_alias ac_cv_env_target_alias_set=${target_alias+set} ac_cv_env_target_alias_value=$target_alias ac_env_CC_set=${CC+set} ac_env_CC_value=$CC ac_cv_env_CC_set=${CC+set} ac_cv_env_CC_value=$CC ac_env_CFLAGS_set=${CFLAGS+set} ac_env_CFLAGS_value=$CFLAGS ac_cv_env_CFLAGS_set=${CFLAGS+set} ac_cv_env_CFLAGS_value=$CFLAGS ac_env_LDFLAGS_set=${LDFLAGS+set} ac_env_LDFLAGS_value=$LDFLAGS ac_cv_env_LDFLAGS_set=${LDFLAGS+set} ac_cv_env_LDFLAGS_value=$LDFLAGS ac_env_CPPFLAGS_set=${CPPFLAGS+set} ac_env_CPPFLAGS_value=$CPPFLAGS ac_cv_env_CPPFLAGS_set=${CPPFLAGS+set} ac_cv_env_CPPFLAGS_value=$CPPFLAGS ac_env_CPP_set=${CPP+set} ac_env_CPP_value=$CPP ac_cv_env_CPP_set=${CPP+set} ac_cv_env_CPP_value=$CPP # # Report the --help message. # if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF \`configure' configures tk 8.6 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... To assign environment variables (e.g., CC, CFLAGS...), specify them as VAR=VALUE. See below for descriptions of some of the useful variables. Defaults for the options are specified in brackets. Configuration: -h, --help display this help and exit --help=short display options specific to this package --help=recursive display the short help of all the included packages -V, --version display version information and exit -q, --quiet, --silent do not print \`checking...' messages --cache-file=FILE cache test results in FILE [disabled] -C, --config-cache alias for \`--cache-file=config.cache' -n, --no-create do not create output files --srcdir=DIR find the sources in DIR [configure dir or \`..'] _ACEOF cat <<_ACEOF Installation directories: --prefix=PREFIX install architecture-independent files in PREFIX [$ac_default_prefix] --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX [PREFIX] By default, \`make install' will install all the files in \`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify an installation prefix other than \`$ac_default_prefix' using \`--prefix', for instance \`--prefix=\$HOME'. For better control, use the options below. Fine tuning of the installation directories: --bindir=DIR user executables [EPREFIX/bin] --sbindir=DIR system admin executables [EPREFIX/sbin] --libexecdir=DIR program executables [EPREFIX/libexec] --datadir=DIR read-only architecture-independent data [PREFIX/share] --sysconfdir=DIR read-only single-machine data [PREFIX/etc] --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] --localstatedir=DIR modifiable single-machine data [PREFIX/var] --libdir=DIR object code libraries [EPREFIX/lib] --includedir=DIR C header files [PREFIX/include] --oldincludedir=DIR C header files for non-gcc [/usr/include] --infodir=DIR info documentation [PREFIX/info] --mandir=DIR man documentation [PREFIX/man] _ACEOF cat <<\_ACEOF X features: --x-includes=DIR X include files are in DIR --x-libraries=DIR X library files are in DIR _ACEOF fi if test -n "$ac_init_help"; then case $ac_init_help in short | recursive ) echo "Configuration of tk 8.6:";; esac cat <<\_ACEOF Optional Features: --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) --enable-FEATURE[=ARG] include FEATURE [ARG=yes] --enable-man-symlinks use symlinks for the manpages (default: off) --enable-man-compression=PROG compress the manpages with PROG (default: off) --enable-man-suffix=STRING use STRING as a suffix to manpage file names (default: no, tk if enabled without specifying STRING) --enable-threads build with threads (default: on) --enable-shared build and link with shared libraries (default: on) --enable-64bit enable 64bit support (default: off) --enable-64bit-vis enable 64bit Sparc VIS support (default: off) --disable-rpath disable rpath support (default: on) --enable-corefoundation use CoreFoundation API on MacOSX (default: on) --enable-load allow dynamic loading and "load" command (default: on) --enable-symbols build with debugging symbols (default: off) --enable-aqua=yes|no use Aqua windowingsystem on Mac OS X (default: no) --enable-xft use freetype/fontconfig/xft (default: on) --enable-xss use XScreenSaver for activity timer (default: on) --enable-framework package shared libraries in MacOSX frameworks (default: off) Optional Packages: --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) --with-tcl directory containing tcl configuration (tclConfig.sh) --with-x use the X Window System Some influential environment variables: CC C compiler command CFLAGS C compiler flags LDFLAGS linker flags, e.g. -L if you have libraries in a nonstandard directory CPPFLAGS C/C++ preprocessor flags, e.g. -I if you have headers in a nonstandard directory CPP C preprocessor Use these variables to override the choices made by `configure' or to help it to find libraries and programs with nonstandard names/locations. _ACEOF fi if test "$ac_init_help" = "recursive"; then # If there are subdirs, report their specific --help. ac_popdir=`pwd` for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue test -d $ac_dir || continue ac_builddir=. if test "$ac_dir" != .; then ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'` # A "../" for each directory in $ac_dir_suffix. ac_top_builddir=`echo "$ac_dir_suffix" | sed 's,/[^\\/]*,../,g'` else ac_dir_suffix= ac_top_builddir= fi case $srcdir in .) # No --srcdir option. We are building in place. ac_srcdir=. if test -z "$ac_top_builddir"; then ac_top_srcdir=. else ac_top_srcdir=`echo $ac_top_builddir | sed 's,/$,,'` fi ;; [\\/]* | ?:[\\/]* ) # Absolute path. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ;; *) # Relative path. ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_builddir$srcdir ;; esac # Do not use `cd foo && pwd` to compute absolute paths, because # the directories may not exist. case `pwd` in .) ac_abs_builddir="$ac_dir";; *) case "$ac_dir" in .) ac_abs_builddir=`pwd`;; [\\/]* | ?:[\\/]* ) ac_abs_builddir="$ac_dir";; *) ac_abs_builddir=`pwd`/"$ac_dir";; esac;; esac case $ac_abs_builddir in .) ac_abs_top_builddir=${ac_top_builddir}.;; *) case ${ac_top_builddir}. in .) ac_abs_top_builddir=$ac_abs_builddir;; [\\/]* | ?:[\\/]* ) ac_abs_top_builddir=${ac_top_builddir}.;; *) ac_abs_top_builddir=$ac_abs_builddir/${ac_top_builddir}.;; esac;; esac case $ac_abs_builddir in .) ac_abs_srcdir=$ac_srcdir;; *) case $ac_srcdir in .) ac_abs_srcdir=$ac_abs_builddir;; [\\/]* | ?:[\\/]* ) ac_abs_srcdir=$ac_srcdir;; *) ac_abs_srcdir=$ac_abs_builddir/$ac_srcdir;; esac;; esac case $ac_abs_builddir in .) ac_abs_top_srcdir=$ac_top_srcdir;; *) case $ac_top_srcdir in .) ac_abs_top_srcdir=$ac_abs_builddir;; [\\/]* | ?:[\\/]* ) ac_abs_top_srcdir=$ac_top_srcdir;; *) ac_abs_top_srcdir=$ac_abs_builddir/$ac_top_srcdir;; esac;; esac cd $ac_dir # Check for guested configure; otherwise get Cygnus style configure. if test -f $ac_srcdir/configure.gnu; then echo $SHELL $ac_srcdir/configure.gnu --help=recursive elif test -f $ac_srcdir/configure; then echo $SHELL $ac_srcdir/configure --help=recursive elif test -f $ac_srcdir/configure.ac || test -f $ac_srcdir/configure.in; then echo $ac_configure --help else echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 fi cd $ac_popdir done fi test -n "$ac_init_help" && exit 0 if $ac_init_version; then cat <<\_ACEOF tk configure 8.6 generated by GNU Autoconf 2.59 Copyright (C) 2003 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. _ACEOF exit 0 fi exec 5>config.log cat >&5 <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. It was created by tk $as_me 8.6, which was generated by GNU Autoconf 2.59. Invocation command line was $ $0 $@ _ACEOF { cat <<_ASUNAME ## --------- ## ## Platform. ## ## --------- ## hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` uname -m = `(uname -m) 2>/dev/null || echo unknown` uname -r = `(uname -r) 2>/dev/null || echo unknown` uname -s = `(uname -s) 2>/dev/null || echo unknown` uname -v = `(uname -v) 2>/dev/null || echo unknown` /usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` /bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` /bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` /usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` /usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` hostinfo = `(hostinfo) 2>/dev/null || echo unknown` /bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` /usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` /bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` _ASUNAME as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. echo "PATH: $as_dir" done } >&5 cat >&5 <<_ACEOF ## ----------- ## ## Core tests. ## ## ----------- ## _ACEOF # Keep a trace of the command line. # Strip out --no-create and --no-recursion so they do not pile up. # Strip out --silent because we don't want to record it for future runs. # Also quote any args containing shell meta-characters. # Make two passes to allow for proper duplicate-argument suppression. ac_configure_args= ac_configure_args0= ac_configure_args1= ac_sep= ac_must_keep_next=false for ac_pass in 1 2 do for ac_arg do case $ac_arg in -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) continue ;; *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?\"\']*) ac_arg=`echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; esac case $ac_pass in 1) ac_configure_args0="$ac_configure_args0 '$ac_arg'" ;; 2) ac_configure_args1="$ac_configure_args1 '$ac_arg'" if test $ac_must_keep_next = true; then ac_must_keep_next=false # Got value, back to normal. else case $ac_arg in *=* | --config-cache | -C | -disable-* | --disable-* \ | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ | -with-* | --with-* | -without-* | --without-* | --x) case "$ac_configure_args0 " in "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; esac ;; -* ) ac_must_keep_next=true ;; esac fi ac_configure_args="$ac_configure_args$ac_sep'$ac_arg'" # Get rid of the leading space. ac_sep=" " ;; esac done done $as_unset ac_configure_args0 || test "${ac_configure_args0+set}" != set || { ac_configure_args0=; export ac_configure_args0; } $as_unset ac_configure_args1 || test "${ac_configure_args1+set}" != set || { ac_configure_args1=; export ac_configure_args1; } # When interrupted or exit'd, cleanup temporary files, and complete # config.log. We remove comments because anyway the quotes in there # would cause problems or look ugly. # WARNING: Be sure not to use single quotes in there, as some shells, # such as our DU 5.0 friend, will then `close' the trap. trap 'exit_status=$? # Save into config.log some information that might help in debugging. { echo cat <<\_ASBOX ## ---------------- ## ## Cache variables. ## ## ---------------- ## _ASBOX echo # The following way of writing the cache mishandles newlines in values, { (set) 2>&1 | case `(ac_space='"'"' '"'"'; set | grep ac_space) 2>&1` in *ac_space=\ *) sed -n \ "s/'"'"'/'"'"'\\\\'"'"''"'"'/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='"'"'\\2'"'"'/p" ;; *) sed -n \ "s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p" ;; esac; } echo cat <<\_ASBOX ## ----------------- ## ## Output variables. ## ## ----------------- ## _ASBOX echo for ac_var in $ac_subst_vars do eval ac_val=$`echo $ac_var` echo "$ac_var='"'"'$ac_val'"'"'" done | sort echo if test -n "$ac_subst_files"; then cat <<\_ASBOX ## ------------- ## ## Output files. ## ## ------------- ## _ASBOX echo for ac_var in $ac_subst_files do eval ac_val=$`echo $ac_var` echo "$ac_var='"'"'$ac_val'"'"'" done | sort echo fi if test -s confdefs.h; then cat <<\_ASBOX ## ----------- ## ## confdefs.h. ## ## ----------- ## _ASBOX echo sed "/^$/d" confdefs.h | sort echo fi test "$ac_signal" != 0 && echo "$as_me: caught signal $ac_signal" echo "$as_me: exit $exit_status" } >&5 rm -f core *.core && rm -rf conftest* confdefs* conf$$* $ac_clean_files && exit $exit_status ' 0 for ac_signal in 1 2 13 15; do trap 'ac_signal='$ac_signal'; { (exit 1); exit 1; }' $ac_signal done ac_signal=0 # confdefs.h avoids OS command line length limits that DEFS can exceed. rm -rf conftest* confdefs.h # AIX cpp loses on an empty file, so make sure it contains at least a newline. echo >confdefs.h # Predefined preprocessor variables. cat >>confdefs.h <<_ACEOF #define PACKAGE_NAME "$PACKAGE_NAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_TARNAME "$PACKAGE_TARNAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_VERSION "$PACKAGE_VERSION" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_STRING "$PACKAGE_STRING" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" _ACEOF # Let the site file select an alternate cache file if it wants to. # Prefer explicitly selected file to automatically selected ones. if test -z "$CONFIG_SITE"; then if test "x$prefix" != xNONE; then CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site" else CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site" fi fi for ac_site_file in $CONFIG_SITE; do if test -r "$ac_site_file"; then { echo "$as_me:$LINENO: loading site script $ac_site_file" >&5 echo "$as_me: loading site script $ac_site_file" >&6;} sed 's/^/| /' "$ac_site_file" >&5 . "$ac_site_file" fi done if test -r "$cache_file"; then # Some versions of bash will fail to source /dev/null (special # files actually), so we avoid doing that. if test -f "$cache_file"; then { echo "$as_me:$LINENO: loading cache $cache_file" >&5 echo "$as_me: loading cache $cache_file" >&6;} case $cache_file in [\\/]* | ?:[\\/]* ) . $cache_file;; *) . ./$cache_file;; esac fi else { echo "$as_me:$LINENO: creating cache $cache_file" >&5 echo "$as_me: creating cache $cache_file" >&6;} >$cache_file fi # Check that the precious variables saved in the cache have kept the same # value. ac_cache_corrupted=false for ac_var in `(set) 2>&1 | sed -n 's/^ac_env_\([a-zA-Z_0-9]*\)_set=.*/\1/p'`; do eval ac_old_set=\$ac_cv_env_${ac_var}_set eval ac_new_set=\$ac_env_${ac_var}_set eval ac_old_val="\$ac_cv_env_${ac_var}_value" eval ac_new_val="\$ac_env_${ac_var}_value" case $ac_old_set,$ac_new_set in set,) { echo "$as_me:$LINENO: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} ac_cache_corrupted=: ;; ,set) { echo "$as_me:$LINENO: error: \`$ac_var' was not set in the previous run" >&5 echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} ac_cache_corrupted=: ;; ,);; *) if test "x$ac_old_val" != "x$ac_new_val"; then { echo "$as_me:$LINENO: error: \`$ac_var' has changed since the previous run:" >&5 echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} { echo "$as_me:$LINENO: former value: $ac_old_val" >&5 echo "$as_me: former value: $ac_old_val" >&2;} { echo "$as_me:$LINENO: current value: $ac_new_val" >&5 echo "$as_me: current value: $ac_new_val" >&2;} ac_cache_corrupted=: fi;; esac # Pass precious variables to config.status. if test "$ac_new_set" = set; then case $ac_new_val in *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?\"\']*) ac_arg=$ac_var=`echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; *) ac_arg=$ac_var=$ac_new_val ;; esac case " $ac_configure_args " in *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. *) ac_configure_args="$ac_configure_args '$ac_arg'" ;; esac fi done if $ac_cache_corrupted; then { echo "$as_me:$LINENO: error: changes in the environment can compromise the build" >&5 echo "$as_me: error: changes in the environment can compromise the build" >&2;} { { echo "$as_me:$LINENO: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&5 echo "$as_me: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&2;} { (exit 1); exit 1; }; } fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu TK_VERSION=8.6 TK_MAJOR_VERSION=8 TK_MINOR_VERSION=6 TK_PATCH_LEVEL=".5" VERSION=${TK_VERSION} LOCALES="cs da de el en en_gb eo es fr hu it nl pl pt ru sv" #-------------------------------------------------------------------- # Find and load the tclConfig.sh file #-------------------------------------------------------------------- # # Ok, lets find the tcl configuration # First, look for one uninstalled. # the alternative search directory is invoked by --with-tcl # if test x"${no_tcl}" = x ; then # we reset no_tcl in case something fails here no_tcl=true # Check whether --with-tcl or --without-tcl was given. if test "${with_tcl+set}" = set; then withval="$with_tcl" with_tclconfig="${withval}" fi; echo "$as_me:$LINENO: checking for Tcl configuration" >&5 echo $ECHO_N "checking for Tcl configuration... $ECHO_C" >&6 if test "${ac_cv_c_tclconfig+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else # First check to see if --with-tcl was specified. if test x"${with_tclconfig}" != x ; then case "${with_tclconfig}" in */tclConfig.sh ) if test -f "${with_tclconfig}"; then { echo "$as_me:$LINENO: WARNING: --with-tcl argument should refer to directory containing tclConfig.sh, not to tclConfig.sh itself" >&5 echo "$as_me: WARNING: --with-tcl argument should refer to directory containing tclConfig.sh, not to tclConfig.sh itself" >&2;} with_tclconfig="`echo "${with_tclconfig}" | sed 's!/tclConfig\.sh$!!'`" fi ;; esac if test -f "${with_tclconfig}/tclConfig.sh" ; then ac_cv_c_tclconfig="`(cd "${with_tclconfig}"; pwd)`" else { { echo "$as_me:$LINENO: error: ${with_tclconfig} directory doesn't contain tclConfig.sh" >&5 echo "$as_me: error: ${with_tclconfig} directory doesn't contain tclConfig.sh" >&2;} { (exit 1); exit 1; }; } fi fi # then check for a private Tcl installation if test x"${ac_cv_c_tclconfig}" = x ; then for i in \ ../tcl \ `ls -dr ../tcl[8-9].[0-9].[0-9]* 2>/dev/null` \ `ls -dr ../tcl[8-9].[0-9] 2>/dev/null` \ `ls -dr ../tcl[8-9].[0-9]* 2>/dev/null` \ ../../tcl \ `ls -dr ../../tcl[8-9].[0-9].[0-9]* 2>/dev/null` \ `ls -dr ../../tcl[8-9].[0-9] 2>/dev/null` \ `ls -dr ../../tcl[8-9].[0-9]* 2>/dev/null` \ ../../../tcl \ `ls -dr ../../../tcl[8-9].[0-9].[0-9]* 2>/dev/null` \ `ls -dr ../../../tcl[8-9].[0-9] 2>/dev/null` \ `ls -dr ../../../tcl[8-9].[0-9]* 2>/dev/null` ; do if test -f "$i/unix/tclConfig.sh" ; then ac_cv_c_tclconfig="`(cd $i/unix; pwd)`" break fi done fi # on Darwin, check in Framework installation locations if test "`uname -s`" = "Darwin" -a x"${ac_cv_c_tclconfig}" = x ; then for i in `ls -d ~/Library/Frameworks 2>/dev/null` \ `ls -d /Library/Frameworks 2>/dev/null` \ `ls -d /Network/Library/Frameworks 2>/dev/null` \ `ls -d /System/Library/Frameworks 2>/dev/null` \ ; do if test -f "$i/Tcl.framework/tclConfig.sh" ; then ac_cv_c_tclconfig="`(cd $i/Tcl.framework; pwd)`" break fi done fi # check in a few common install locations if test x"${ac_cv_c_tclconfig}" = x ; then for i in `ls -d ${libdir} 2>/dev/null` \ `ls -d ${exec_prefix}/lib 2>/dev/null` \ `ls -d ${prefix}/lib 2>/dev/null` \ `ls -d /usr/local/lib 2>/dev/null` \ `ls -d /usr/contrib/lib 2>/dev/null` \ `ls -d /usr/lib 2>/dev/null` \ `ls -d /usr/lib64 2>/dev/null` \ ; do if test -f "$i/tclConfig.sh" ; then ac_cv_c_tclconfig="`(cd $i; pwd)`" break fi done fi # check in a few other private locations if test x"${ac_cv_c_tclconfig}" = x ; then for i in \ ${srcdir}/../tcl \ `ls -dr ${srcdir}/../tcl[8-9].[0-9].[0-9]* 2>/dev/null` \ `ls -dr ${srcdir}/../tcl[8-9].[0-9] 2>/dev/null` \ `ls -dr ${srcdir}/../tcl[8-9].[0-9]* 2>/dev/null` ; do if test -f "$i/unix/tclConfig.sh" ; then ac_cv_c_tclconfig="`(cd $i/unix; pwd)`" break fi done fi fi if test x"${ac_cv_c_tclconfig}" = x ; then TCL_BIN_DIR="# no Tcl configs found" { { echo "$as_me:$LINENO: error: Can't find Tcl configuration definitions. Use --with-tcl to specify a directory containing tclConfig.sh" >&5 echo "$as_me: error: Can't find Tcl configuration definitions. Use --with-tcl to specify a directory containing tclConfig.sh" >&2;} { (exit 1); exit 1; }; } else no_tcl= TCL_BIN_DIR="${ac_cv_c_tclconfig}" echo "$as_me:$LINENO: result: found ${TCL_BIN_DIR}/tclConfig.sh" >&5 echo "${ECHO_T}found ${TCL_BIN_DIR}/tclConfig.sh" >&6 fi fi echo "$as_me:$LINENO: checking for existence of ${TCL_BIN_DIR}/tclConfig.sh" >&5 echo $ECHO_N "checking for existence of ${TCL_BIN_DIR}/tclConfig.sh... $ECHO_C" >&6 if test -f "${TCL_BIN_DIR}/tclConfig.sh" ; then echo "$as_me:$LINENO: result: loading" >&5 echo "${ECHO_T}loading" >&6 . "${TCL_BIN_DIR}/tclConfig.sh" else echo "$as_me:$LINENO: result: could not find ${TCL_BIN_DIR}/tclConfig.sh" >&5 echo "${ECHO_T}could not find ${TCL_BIN_DIR}/tclConfig.sh" >&6 fi # eval is required to do the TCL_DBGX substitution eval "TCL_LIB_FILE=\"${TCL_LIB_FILE}\"" eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\"" # If the TCL_BIN_DIR is the build directory (not the install directory), # then set the common variable name to the value of the build variables. # For example, the variable TCL_LIB_SPEC will be set to the value # of TCL_BUILD_LIB_SPEC. An extension should make use of TCL_LIB_SPEC # instead of TCL_BUILD_LIB_SPEC since it will work with both an # installed and uninstalled version of Tcl. if test -f "${TCL_BIN_DIR}/Makefile" ; then TCL_LIB_SPEC="${TCL_BUILD_LIB_SPEC}" TCL_STUB_LIB_SPEC="${TCL_BUILD_STUB_LIB_SPEC}" TCL_STUB_LIB_PATH="${TCL_BUILD_STUB_LIB_PATH}" elif test "`uname -s`" = "Darwin"; then # If Tcl was built as a framework, attempt to use the libraries # from the framework at the given location so that linking works # against Tcl.framework installed in an arbitrary location. case ${TCL_DEFS} in *TCL_FRAMEWORK*) if test -f "${TCL_BIN_DIR}/${TCL_LIB_FILE}"; then for i in "`cd "${TCL_BIN_DIR}"; pwd`" \ "`cd "${TCL_BIN_DIR}"/../..; pwd`"; do if test "`basename "$i"`" = "${TCL_LIB_FILE}.framework"; then TCL_LIB_SPEC="-F`dirname "$i" | sed -e 's/ /\\\\ /g'` -framework ${TCL_LIB_FILE}" break fi done fi if test -f "${TCL_BIN_DIR}/${TCL_STUB_LIB_FILE}"; then TCL_STUB_LIB_SPEC="-L`echo "${TCL_BIN_DIR}" | sed -e 's/ /\\\\ /g'` ${TCL_STUB_LIB_FLAG}" TCL_STUB_LIB_PATH="${TCL_BIN_DIR}/${TCL_STUB_LIB_FILE}" fi ;; esac fi # eval is required to do the TCL_DBGX substitution eval "TCL_LIB_FLAG=\"${TCL_LIB_FLAG}\"" eval "TCL_LIB_SPEC=\"${TCL_LIB_SPEC}\"" eval "TCL_STUB_LIB_FLAG=\"${TCL_STUB_LIB_FLAG}\"" eval "TCL_STUB_LIB_SPEC=\"${TCL_STUB_LIB_SPEC}\"" if test "${TCL_MAJOR_VERSION}" -ne 8 ; then { { echo "$as_me:$LINENO: error: ${PACKAGE_NAME} ${PACKAGE_VERSION} requires Tcl 8.6+ Found config for Tcl ${TCL_VERSION}" >&5 echo "$as_me: error: ${PACKAGE_NAME} ${PACKAGE_VERSION} requires Tcl 8.6+ Found config for Tcl ${TCL_VERSION}" >&2;} { (exit 1); exit 1; }; } fi if test "${TCL_MINOR_VERSION}" -lt 6 ; then { { echo "$as_me:$LINENO: error: ${PACKAGE_NAME} ${PACKAGE_VERSION} requires Tcl 8.6+ Found config for Tcl ${TCL_VERSION}" >&5 echo "$as_me: error: ${PACKAGE_NAME} ${PACKAGE_VERSION} requires Tcl 8.6+ Found config for Tcl ${TCL_VERSION}" >&2;} { (exit 1); exit 1; }; } fi echo "$as_me:$LINENO: checking for tclsh" >&5 echo $ECHO_N "checking for tclsh... $ECHO_C" >&6 if test "${ac_cv_path_tclsh+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else search_path=`echo ${PATH} | sed -e 's/:/ /g'` for dir in $search_path ; do for j in `ls -r $dir/tclsh[8-9]* 2> /dev/null` \ `ls -r $dir/tclsh* 2> /dev/null` ; do if test x"$ac_cv_path_tclsh" = x ; then if test -f "$j" ; then ac_cv_path_tclsh=$j break fi fi done done fi if test -f "$ac_cv_path_tclsh" ; then TCLSH_PROG="$ac_cv_path_tclsh" echo "$as_me:$LINENO: result: $TCLSH_PROG" >&5 echo "${ECHO_T}$TCLSH_PROG" >&6 else # It is not an error if an installed version of Tcl can't be located. TCLSH_PROG="" echo "$as_me:$LINENO: result: No tclsh found on PATH" >&5 echo "${ECHO_T}No tclsh found on PATH" >&6 fi echo "$as_me:$LINENO: checking for tclsh in Tcl build directory" >&5 echo $ECHO_N "checking for tclsh in Tcl build directory... $ECHO_C" >&6 BUILD_TCLSH="${TCL_BIN_DIR}"/tclsh echo "$as_me:$LINENO: result: $BUILD_TCLSH" >&5 echo "${ECHO_T}$BUILD_TCLSH" >&6 #------------------------------------------------------------------------ # Handle the --prefix=... option #------------------------------------------------------------------------ if test "${prefix}" = "NONE"; then prefix="$TCL_PREFIX" fi if test "${exec_prefix}" = "NONE"; then exec_prefix=$prefix fi # Make sure srcdir is fully qualified! srcdir="`cd "$srcdir" ; pwd`" TK_SRC_DIR="`cd "$srcdir"/..; pwd`" #------------------------------------------------------------------------ # Compress and/or soft link the manpages? #------------------------------------------------------------------------ echo "$as_me:$LINENO: checking whether to use symlinks for manpages" >&5 echo $ECHO_N "checking whether to use symlinks for manpages... $ECHO_C" >&6 # Check whether --enable-man-symlinks or --disable-man-symlinks was given. if test "${enable_man_symlinks+set}" = set; then enableval="$enable_man_symlinks" test "$enableval" != "no" && MAN_FLAGS="$MAN_FLAGS --symlinks" else enableval="no" fi; echo "$as_me:$LINENO: result: $enableval" >&5 echo "${ECHO_T}$enableval" >&6 echo "$as_me:$LINENO: checking whether to compress the manpages" >&5 echo $ECHO_N "checking whether to compress the manpages... $ECHO_C" >&6 # Check whether --enable-man-compression or --disable-man-compression was given. if test "${enable_man_compression+set}" = set; then enableval="$enable_man_compression" case $enableval in yes) { { echo "$as_me:$LINENO: error: missing argument to --enable-man-compression" >&5 echo "$as_me: error: missing argument to --enable-man-compression" >&2;} { (exit 1); exit 1; }; };; no) ;; *) MAN_FLAGS="$MAN_FLAGS --compress $enableval";; esac else enableval="no" fi; echo "$as_me:$LINENO: result: $enableval" >&5 echo "${ECHO_T}$enableval" >&6 if test "$enableval" != "no"; then echo "$as_me:$LINENO: checking for compressed file suffix" >&5 echo $ECHO_N "checking for compressed file suffix... $ECHO_C" >&6 touch TeST $enableval TeST Z=`ls TeST* | sed 's/^....//'` rm -f TeST* MAN_FLAGS="$MAN_FLAGS --extension $Z" echo "$as_me:$LINENO: result: $Z" >&5 echo "${ECHO_T}$Z" >&6 fi echo "$as_me:$LINENO: checking whether to add a package name suffix for the manpages" >&5 echo $ECHO_N "checking whether to add a package name suffix for the manpages... $ECHO_C" >&6 # Check whether --enable-man-suffix or --disable-man-suffix was given. if test "${enable_man_suffix+set}" = set; then enableval="$enable_man_suffix" case $enableval in yes) enableval="tk" MAN_FLAGS="$MAN_FLAGS --suffix $enableval";; no) ;; *) MAN_FLAGS="$MAN_FLAGS --suffix $enableval";; esac else enableval="no" fi; echo "$as_me:$LINENO: result: $enableval" >&5 echo "${ECHO_T}$enableval" >&6 #------------------------------------------------------------------------ # Standard compiler checks #------------------------------------------------------------------------ # If the user did not set CFLAGS, set it now to keep # the AC_PROG_CC macro from adding "-g -O2". if test "${CFLAGS+set}" != "set" ; then CFLAGS="" fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args. set dummy ${ac_tool_prefix}gcc; ac_word=$2 echo "$as_me:$LINENO: checking for $ac_word" >&5 echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 if test "${ac_cv_prog_CC+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_CC="${ac_tool_prefix}gcc" echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then echo "$as_me:$LINENO: result: $CC" >&5 echo "${ECHO_T}$CC" >&6 else echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 fi fi if test -z "$ac_cv_prog_CC"; then ac_ct_CC=$CC # Extract the first word of "gcc", so it can be a program name with args. set dummy gcc; ac_word=$2 echo "$as_me:$LINENO: checking for $ac_word" >&5 echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 if test "${ac_cv_prog_ac_ct_CC+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CC="gcc" echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done fi fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then echo "$as_me:$LINENO: result: $ac_ct_CC" >&5 echo "${ECHO_T}$ac_ct_CC" >&6 else echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 fi CC=$ac_ct_CC else CC="$ac_cv_prog_CC" fi if test -z "$CC"; then if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args. set dummy ${ac_tool_prefix}cc; ac_word=$2 echo "$as_me:$LINENO: checking for $ac_word" >&5 echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 if test "${ac_cv_prog_CC+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_CC="${ac_tool_prefix}cc" echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then echo "$as_me:$LINENO: result: $CC" >&5 echo "${ECHO_T}$CC" >&6 else echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 fi fi if test -z "$ac_cv_prog_CC"; then ac_ct_CC=$CC # Extract the first word of "cc", so it can be a program name with args. set dummy cc; ac_word=$2 echo "$as_me:$LINENO: checking for $ac_word" >&5 echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 if test "${ac_cv_prog_ac_ct_CC+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CC="cc" echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done fi fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then echo "$as_me:$LINENO: result: $ac_ct_CC" >&5 echo "${ECHO_T}$ac_ct_CC" >&6 else echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 fi CC=$ac_ct_CC else CC="$ac_cv_prog_CC" fi fi if test -z "$CC"; then # Extract the first word of "cc", so it can be a program name with args. set dummy cc; ac_word=$2 echo "$as_me:$LINENO: checking for $ac_word" >&5 echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 if test "${ac_cv_prog_CC+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else ac_prog_rejected=no as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then if test "$as_dir/$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then ac_prog_rejected=yes continue fi ac_cv_prog_CC="cc" echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done if test $ac_prog_rejected = yes; then # We found a bogon in the path, so make sure we never use it. set dummy $ac_cv_prog_CC shift if test $# != 0; then # We chose a different compiler from the bogus one. # However, it has the same basename, so the bogon will be chosen # first if we set CC to just the basename; use the full file name. shift ac_cv_prog_CC="$as_dir/$ac_word${1+' '}$@" fi fi fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then echo "$as_me:$LINENO: result: $CC" >&5 echo "${ECHO_T}$CC" >&6 else echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 fi fi if test -z "$CC"; then if test -n "$ac_tool_prefix"; then for ac_prog in cl do # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. set dummy $ac_tool_prefix$ac_prog; ac_word=$2 echo "$as_me:$LINENO: checking for $ac_word" >&5 echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 if test "${ac_cv_prog_CC+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_CC="$ac_tool_prefix$ac_prog" echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then echo "$as_me:$LINENO: result: $CC" >&5 echo "${ECHO_T}$CC" >&6 else echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 fi test -n "$CC" && break done fi if test -z "$CC"; then ac_ct_CC=$CC for ac_prog in cl do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 echo "$as_me:$LINENO: checking for $ac_word" >&5 echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 if test "${ac_cv_prog_ac_ct_CC+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CC="$ac_prog" echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done fi fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then echo "$as_me:$LINENO: result: $ac_ct_CC" >&5 echo "${ECHO_T}$ac_ct_CC" >&6 else echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 fi test -n "$ac_ct_CC" && break done CC=$ac_ct_CC fi fi test -z "$CC" && { { echo "$as_me:$LINENO: error: no acceptable C compiler found in \$PATH See \`config.log' for more details." >&5 echo "$as_me: error: no acceptable C compiler found in \$PATH See \`config.log' for more details." >&2;} { (exit 1); exit 1; }; } # Provide some information about the compiler. echo "$as_me:$LINENO:" \ "checking for C compiler version" >&5 ac_compiler=`set X $ac_compile; echo $2` { (eval echo "$as_me:$LINENO: \"$ac_compiler --version &5\"") >&5 (eval $ac_compiler --version &5) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } { (eval echo "$as_me:$LINENO: \"$ac_compiler -v &5\"") >&5 (eval $ac_compiler -v &5) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } { (eval echo "$as_me:$LINENO: \"$ac_compiler -V &5\"") >&5 (eval $ac_compiler -V &5) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files a.out a.exe b.out" # Try to create an executable without -o first, disregard a.out. # It will help us diagnose broken compilers, and finding out an intuition # of exeext. echo "$as_me:$LINENO: checking for C compiler default output file name" >&5 echo $ECHO_N "checking for C compiler default output file name... $ECHO_C" >&6 ac_link_default=`echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'` if { (eval echo "$as_me:$LINENO: \"$ac_link_default\"") >&5 (eval $ac_link_default) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; then # Find the output, starting from the most likely. This scheme is # not robust to junk in `.', hence go to wildcards (a.*) only as a last # resort. # Be careful to initialize this variable, since it used to be cached. # Otherwise an old cache value of `no' led to `EXEEXT = no' in a Makefile. ac_cv_exeext= # b.out is created by i960 compilers. for ac_file in a_out.exe a.exe conftest.exe a.out conftest a.* conftest.* b.out do test -f "$ac_file" || continue case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.o | *.obj ) ;; conftest.$ac_ext ) # This is the source file. ;; [ab].out ) # We found the default executable, but exeext='' is most # certainly right. break;; *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` # FIXME: I believe we export ac_cv_exeext for Libtool, # but it would be cool to find out if it's true. Does anybody # maintain Libtool? --akim. export ac_cv_exeext break;; * ) break;; esac done else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { { echo "$as_me:$LINENO: error: C compiler cannot create executables See \`config.log' for more details." >&5 echo "$as_me: error: C compiler cannot create executables See \`config.log' for more details." >&2;} { (exit 77); exit 77; }; } fi ac_exeext=$ac_cv_exeext echo "$as_me:$LINENO: result: $ac_file" >&5 echo "${ECHO_T}$ac_file" >&6 # Check the compiler produces executables we can run. If not, either # the compiler is broken, or we cross compile. echo "$as_me:$LINENO: checking whether the C compiler works" >&5 echo $ECHO_N "checking whether the C compiler works... $ECHO_C" >&6 # FIXME: These cross compiler hacks should be removed for Autoconf 3.0 # If not cross compiling, check that we can run a simple program. if test "$cross_compiling" != yes; then if { ac_try='./$ac_file' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then cross_compiling=no else if test "$cross_compiling" = maybe; then cross_compiling=yes else { { echo "$as_me:$LINENO: error: cannot run C compiled programs. If you meant to cross compile, use \`--host'. See \`config.log' for more details." >&5 echo "$as_me: error: cannot run C compiled programs. If you meant to cross compile, use \`--host'. See \`config.log' for more details." >&2;} { (exit 1); exit 1; }; } fi fi fi echo "$as_me:$LINENO: result: yes" >&5 echo "${ECHO_T}yes" >&6 rm -f a.out a.exe conftest$ac_cv_exeext b.out ac_clean_files=$ac_clean_files_save # Check the compiler produces executables we can run. If not, either # the compiler is broken, or we cross compile. echo "$as_me:$LINENO: checking whether we are cross compiling" >&5 echo $ECHO_N "checking whether we are cross compiling... $ECHO_C" >&6 echo "$as_me:$LINENO: result: $cross_compiling" >&5 echo "${ECHO_T}$cross_compiling" >&6 echo "$as_me:$LINENO: checking for suffix of executables" >&5 echo $ECHO_N "checking for suffix of executables... $ECHO_C" >&6 if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; then # If both `conftest.exe' and `conftest' are `present' (well, observable) # catch `conftest.exe'. For instance with Cygwin, `ls conftest' will # work properly (i.e., refer to `conftest.exe'), while it won't with # `rm'. for ac_file in conftest.exe conftest conftest.*; do test -f "$ac_file" || continue case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.o | *.obj ) ;; *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` export ac_cv_exeext break;; * ) break;; esac done else { { echo "$as_me:$LINENO: error: cannot compute suffix of executables: cannot compile and link See \`config.log' for more details." >&5 echo "$as_me: error: cannot compute suffix of executables: cannot compile and link See \`config.log' for more details." >&2;} { (exit 1); exit 1; }; } fi rm -f conftest$ac_cv_exeext echo "$as_me:$LINENO: result: $ac_cv_exeext" >&5 echo "${ECHO_T}$ac_cv_exeext" >&6 rm -f conftest.$ac_ext EXEEXT=$ac_cv_exeext ac_exeext=$EXEEXT echo "$as_me:$LINENO: checking for suffix of object files" >&5 echo $ECHO_N "checking for suffix of object files... $ECHO_C" >&6 if test "${ac_cv_objext+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.o conftest.obj if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; then for ac_file in `(ls conftest.o conftest.obj; ls conftest.*) 2>/dev/null`; do case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg ) ;; *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'` break;; esac done else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { { echo "$as_me:$LINENO: error: cannot compute suffix of object files: cannot compile See \`config.log' for more details." >&5 echo "$as_me: error: cannot compute suffix of object files: cannot compile See \`config.log' for more details." >&2;} { (exit 1); exit 1; }; } fi rm -f conftest.$ac_cv_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_objext" >&5 echo "${ECHO_T}$ac_cv_objext" >&6 OBJEXT=$ac_cv_objext ac_objext=$OBJEXT echo "$as_me:$LINENO: checking whether we are using the GNU C compiler" >&5 echo $ECHO_N "checking whether we are using the GNU C compiler... $ECHO_C" >&6 if test "${ac_cv_c_compiler_gnu+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { #ifndef __GNUC__ choke me #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_compiler_gnu=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_compiler_gnu=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext ac_cv_c_compiler_gnu=$ac_compiler_gnu fi echo "$as_me:$LINENO: result: $ac_cv_c_compiler_gnu" >&5 echo "${ECHO_T}$ac_cv_c_compiler_gnu" >&6 GCC=`test $ac_compiler_gnu = yes && echo yes` ac_test_CFLAGS=${CFLAGS+set} ac_save_CFLAGS=$CFLAGS CFLAGS="-g" echo "$as_me:$LINENO: checking whether $CC accepts -g" >&5 echo $ECHO_N "checking whether $CC accepts -g... $ECHO_C" >&6 if test "${ac_cv_prog_cc_g+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_prog_cc_g=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_prog_cc_g=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_prog_cc_g" >&5 echo "${ECHO_T}$ac_cv_prog_cc_g" >&6 if test "$ac_test_CFLAGS" = set; then CFLAGS=$ac_save_CFLAGS elif test $ac_cv_prog_cc_g = yes; then if test "$GCC" = yes; then CFLAGS="-g -O2" else CFLAGS="-g" fi else if test "$GCC" = yes; then CFLAGS="-O2" else CFLAGS= fi fi echo "$as_me:$LINENO: checking for $CC option to accept ANSI C" >&5 echo $ECHO_N "checking for $CC option to accept ANSI C... $ECHO_C" >&6 if test "${ac_cv_prog_cc_stdc+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_cv_prog_cc_stdc=no ac_save_CC=$CC cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include /* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */ struct buf { int x; }; FILE * (*rcsopen) (struct buf *, struct stat *, int); static char *e (p, i) char **p; int i; { return p[i]; } static char *f (char * (*g) (char **, int), char **p, ...) { char *s; va_list v; va_start (v,p); s = g (p, va_arg (v,int)); va_end (v); return s; } /* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has function prototypes and stuff, but not '\xHH' hex character constants. These don't provoke an error unfortunately, instead are silently treated as 'x'. The following induces an error, until -std1 is added to get proper ANSI mode. Curiously '\x00'!='x' always comes out true, for an array size at least. It's necessary to write '\x00'==0 to get something that's true only with -std1. */ int osf4_cc_array ['\x00' == 0 ? 1 : -1]; int test (int i, double x); struct s1 {int (*f) (int a);}; struct s2 {int (*f) (double a);}; int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int); int argc; char **argv; int main () { return f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]; ; return 0; } _ACEOF # Don't try gcc -ansi; that turns off useful extensions and # breaks some systems' header files. # AIX -qlanglvl=ansi # Ultrix and OSF/1 -std1 # HP-UX 10.20 and later -Ae # HP-UX older versions -Aa -D_HPUX_SOURCE # SVR4 -Xc -D__EXTENSIONS__ for ac_arg in "" -qlanglvl=ansi -std1 -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" do CC="$ac_save_CC $ac_arg" rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_prog_cc_stdc=$ac_arg break else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi rm -f conftest.err conftest.$ac_objext done rm -f conftest.$ac_ext conftest.$ac_objext CC=$ac_save_CC fi case "x$ac_cv_prog_cc_stdc" in x|xno) echo "$as_me:$LINENO: result: none needed" >&5 echo "${ECHO_T}none needed" >&6 ;; *) echo "$as_me:$LINENO: result: $ac_cv_prog_cc_stdc" >&5 echo "${ECHO_T}$ac_cv_prog_cc_stdc" >&6 CC="$CC $ac_cv_prog_cc_stdc" ;; esac # Some people use a C++ compiler to compile C. Since we use `exit', # in C++ we need to declare it. In case someone uses the same compiler # for both compiling C and C++ we need to have the C++ compiler decide # the declaration of exit, since it's the most demanding environment. cat >conftest.$ac_ext <<_ACEOF #ifndef __cplusplus choke me #endif _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then for ac_declaration in \ '' \ 'extern "C" void std::exit (int) throw (); using std::exit;' \ 'extern "C" void std::exit (int); using std::exit;' \ 'extern "C" void exit (int) throw ();' \ 'extern "C" void exit (int);' \ 'void exit (int);' do cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_declaration #include int main () { exit (42); ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then : else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 continue fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_declaration int main () { exit (42); ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then break else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext done rm -f conftest* if test -n "$ac_declaration"; then echo '#ifdef __cplusplus' >>confdefs.h echo $ac_declaration >>confdefs.h echo '#endif' >>confdefs.h fi else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu echo "$as_me:$LINENO: checking for inline" >&5 echo $ECHO_N "checking for inline... $ECHO_C" >&6 if test "${ac_cv_c_inline+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_cv_c_inline=no for ac_kw in inline __inline__ __inline; do cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #ifndef __cplusplus typedef int foo_t; static $ac_kw foo_t static_foo () {return 0; } $ac_kw foo_t foo () {return 0; } #endif _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_c_inline=$ac_kw; break else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext done fi echo "$as_me:$LINENO: result: $ac_cv_c_inline" >&5 echo "${ECHO_T}$ac_cv_c_inline" >&6 case $ac_cv_c_inline in inline | yes) ;; *) case $ac_cv_c_inline in no) ac_val=;; *) ac_val=$ac_cv_c_inline;; esac cat >>confdefs.h <<_ACEOF #ifndef __cplusplus #define inline $ac_val #endif _ACEOF ;; esac #-------------------------------------------------------------------- # Supply a substitute for stdlib.h if it doesn't define strtol, # strtoul, or strtod (which it doesn't in some versions of SunOS). #-------------------------------------------------------------------- ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu echo "$as_me:$LINENO: checking how to run the C preprocessor" >&5 echo $ECHO_N "checking how to run the C preprocessor... $ECHO_C" >&6 # On Suns, sometimes $CPP names a directory. if test -n "$CPP" && test -d "$CPP"; then CPP= fi if test -z "$CPP"; then if test "${ac_cv_prog_CPP+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else # Double quotes because CPP needs to be expanded for CPP in "$CC -E" "$CC -E -traditional-cpp" "/lib/cpp" do ac_preproc_ok=false for ac_c_preproc_warn_flag in '' yes do # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # Prefer to if __STDC__ is defined, since # exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #ifdef __STDC__ # include #else # include #endif Syntax error _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then : else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 # Broken: fails on valid input. continue fi rm -f conftest.err conftest.$ac_ext # OK, works on sane cases. Now check whether non-existent headers # can be detected and how. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then # Broken: success on invalid input. continue else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 # Passes both tests. ac_preproc_ok=: break fi rm -f conftest.err conftest.$ac_ext done # Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. rm -f conftest.err conftest.$ac_ext if $ac_preproc_ok; then break fi done ac_cv_prog_CPP=$CPP fi CPP=$ac_cv_prog_CPP else ac_cv_prog_CPP=$CPP fi echo "$as_me:$LINENO: result: $CPP" >&5 echo "${ECHO_T}$CPP" >&6 ac_preproc_ok=false for ac_c_preproc_warn_flag in '' yes do # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # Prefer to if __STDC__ is defined, since # exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #ifdef __STDC__ # include #else # include #endif Syntax error _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then : else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 # Broken: fails on valid input. continue fi rm -f conftest.err conftest.$ac_ext # OK, works on sane cases. Now check whether non-existent headers # can be detected and how. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then # Broken: success on invalid input. continue else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 # Passes both tests. ac_preproc_ok=: break fi rm -f conftest.err conftest.$ac_ext done # Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. rm -f conftest.err conftest.$ac_ext if $ac_preproc_ok; then : else { { echo "$as_me:$LINENO: error: C preprocessor \"$CPP\" fails sanity check See \`config.log' for more details." >&5 echo "$as_me: error: C preprocessor \"$CPP\" fails sanity check See \`config.log' for more details." >&2;} { (exit 1); exit 1; }; } fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu echo "$as_me:$LINENO: checking for egrep" >&5 echo $ECHO_N "checking for egrep... $ECHO_C" >&6 if test "${ac_cv_prog_egrep+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if echo a | (grep -E '(a|b)') >/dev/null 2>&1 then ac_cv_prog_egrep='grep -E' else ac_cv_prog_egrep='egrep' fi fi echo "$as_me:$LINENO: result: $ac_cv_prog_egrep" >&5 echo "${ECHO_T}$ac_cv_prog_egrep" >&6 EGREP=$ac_cv_prog_egrep echo "$as_me:$LINENO: checking for ANSI C header files" >&5 echo $ECHO_N "checking for ANSI C header files... $ECHO_C" >&6 if test "${ac_cv_header_stdc+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include #include int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_header_stdc=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_header_stdc=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext if test $ac_cv_header_stdc = yes; then # SunOS 4.x string.h does not declare mem*, contrary to ANSI. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "memchr" >/dev/null 2>&1; then : else ac_cv_header_stdc=no fi rm -f conftest* fi if test $ac_cv_header_stdc = yes; then # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "free" >/dev/null 2>&1; then : else ac_cv_header_stdc=no fi rm -f conftest* fi if test $ac_cv_header_stdc = yes; then # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. if test "$cross_compiling" = yes; then : else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #if ((' ' & 0x0FF) == 0x020) # define ISLOWER(c) ('a' <= (c) && (c) <= 'z') # define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) #else # define ISLOWER(c) \ (('a' <= (c) && (c) <= 'i') \ || ('j' <= (c) && (c) <= 'r') \ || ('s' <= (c) && (c) <= 'z')) # define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c)) #endif #define XOR(e, f) (((e) && !(f)) || (!(e) && (f))) int main () { int i; for (i = 0; i < 256; i++) if (XOR (islower (i), ISLOWER (i)) || toupper (i) != TOUPPER (i)) exit(2); exit (0); } _ACEOF rm -f conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='./conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then : else echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) ac_cv_header_stdc=no fi rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi fi fi echo "$as_me:$LINENO: result: $ac_cv_header_stdc" >&5 echo "${ECHO_T}$ac_cv_header_stdc" >&6 if test $ac_cv_header_stdc = yes; then cat >>confdefs.h <<\_ACEOF #define STDC_HEADERS 1 _ACEOF fi # On IRIX 5.3, sys/types and inttypes.h are conflicting. for ac_header in sys/types.h sys/stat.h stdlib.h string.h memory.h strings.h \ inttypes.h stdint.h unistd.h do as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh` echo "$as_me:$LINENO: checking for $ac_header" >&5 echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 if eval "test \"\${$as_ac_Header+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then eval "$as_ac_Header=yes" else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_Header=no" fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 if test `eval echo '${'$as_ac_Header'}'` = yes; then cat >>confdefs.h <<_ACEOF #define `echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done if test "${ac_cv_header_stdlib_h+set}" = set; then echo "$as_me:$LINENO: checking for stdlib.h" >&5 echo $ECHO_N "checking for stdlib.h... $ECHO_C" >&6 if test "${ac_cv_header_stdlib_h+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 fi echo "$as_me:$LINENO: result: $ac_cv_header_stdlib_h" >&5 echo "${ECHO_T}$ac_cv_header_stdlib_h" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking stdlib.h usability" >&5 echo $ECHO_N "checking stdlib.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_header_compiler=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking stdlib.h presence" >&5 echo $ECHO_N "checking stdlib.h presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then ac_header_preproc=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { echo "$as_me:$LINENO: WARNING: stdlib.h: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: stdlib.h: accepted by the compiler, rejected by the preprocessor!" >&2;} { echo "$as_me:$LINENO: WARNING: stdlib.h: proceeding with the compiler's result" >&5 echo "$as_me: WARNING: stdlib.h: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { echo "$as_me:$LINENO: WARNING: stdlib.h: present but cannot be compiled" >&5 echo "$as_me: WARNING: stdlib.h: present but cannot be compiled" >&2;} { echo "$as_me:$LINENO: WARNING: stdlib.h: check for missing prerequisite headers?" >&5 echo "$as_me: WARNING: stdlib.h: check for missing prerequisite headers?" >&2;} { echo "$as_me:$LINENO: WARNING: stdlib.h: see the Autoconf documentation" >&5 echo "$as_me: WARNING: stdlib.h: see the Autoconf documentation" >&2;} { echo "$as_me:$LINENO: WARNING: stdlib.h: section \"Present But Cannot Be Compiled\"" >&5 echo "$as_me: WARNING: stdlib.h: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: stdlib.h: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: stdlib.h: proceeding with the preprocessor's result" >&2;} { echo "$as_me:$LINENO: WARNING: stdlib.h: in the future, the compiler will take precedence" >&5 echo "$as_me: WARNING: stdlib.h: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ----------------------------- ## ## Report this to the tk lists. ## ## ----------------------------- ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac echo "$as_me:$LINENO: checking for stdlib.h" >&5 echo $ECHO_N "checking for stdlib.h... $ECHO_C" >&6 if test "${ac_cv_header_stdlib_h+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_cv_header_stdlib_h=$ac_header_preproc fi echo "$as_me:$LINENO: result: $ac_cv_header_stdlib_h" >&5 echo "${ECHO_T}$ac_cv_header_stdlib_h" >&6 fi if test $ac_cv_header_stdlib_h = yes; then tk_ok=1 else tk_ok=0 fi cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "strtol" >/dev/null 2>&1; then : else tk_ok=0 fi rm -f conftest* cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "strtoul" >/dev/null 2>&1; then : else tk_ok=0 fi rm -f conftest* cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "strtod" >/dev/null 2>&1; then : else tk_ok=0 fi rm -f conftest* if test $tk_ok = 0; then cat >>confdefs.h <<\_ACEOF #define NO_STDLIB_H 1 _ACEOF fi #------------------------------------------------------------------------ # If we're using GCC, see if the compiler understands -pipe. If so, use it. # It makes compiling go faster. (This is only a performance feature.) #------------------------------------------------------------------------ if test -z "$no_pipe" && test -n "$GCC"; then echo "$as_me:$LINENO: checking if the compiler understands -pipe" >&5 echo $ECHO_N "checking if the compiler understands -pipe... $ECHO_C" >&6 if test "${tcl_cv_cc_pipe+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -pipe" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_cc_pipe=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_cc_pipe=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext CFLAGS=$hold_cflags fi echo "$as_me:$LINENO: result: $tcl_cv_cc_pipe" >&5 echo "${ECHO_T}$tcl_cv_cc_pipe" >&6 if test $tcl_cv_cc_pipe = yes; then CFLAGS="$CFLAGS -pipe" fi fi #------------------------------------------------------------------------ # Threads support - this auto-enables if Tcl was compiled threaded #------------------------------------------------------------------------ # Check whether --enable-threads or --disable-threads was given. if test "${enable_threads+set}" = set; then enableval="$enable_threads" tcl_ok=$enableval else tcl_ok=yes fi; if test "${TCL_THREADS}" = 1; then tcl_threaded_core=1; fi if test "$tcl_ok" = "yes" -o "${TCL_THREADS}" = 1; then TCL_THREADS=1 # USE_THREAD_ALLOC tells us to try the special thread-based # allocator that significantly reduces lock contention cat >>confdefs.h <<\_ACEOF #define USE_THREAD_ALLOC 1 _ACEOF cat >>confdefs.h <<\_ACEOF #define _REENTRANT 1 _ACEOF if test "`uname -s`" = "SunOS" ; then cat >>confdefs.h <<\_ACEOF #define _POSIX_PTHREAD_SEMANTICS 1 _ACEOF fi cat >>confdefs.h <<\_ACEOF #define _THREAD_SAFE 1 _ACEOF echo "$as_me:$LINENO: checking for pthread_mutex_init in -lpthread" >&5 echo $ECHO_N "checking for pthread_mutex_init in -lpthread... $ECHO_C" >&6 if test "${ac_cv_lib_pthread_pthread_mutex_init+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpthread $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char pthread_mutex_init (); int main () { pthread_mutex_init (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_pthread_pthread_mutex_init=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pthread_pthread_mutex_init=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_pthread_pthread_mutex_init" >&5 echo "${ECHO_T}$ac_cv_lib_pthread_pthread_mutex_init" >&6 if test $ac_cv_lib_pthread_pthread_mutex_init = yes; then tcl_ok=yes else tcl_ok=no fi if test "$tcl_ok" = "no"; then # Check a little harder for __pthread_mutex_init in the same # library, as some systems hide it there until pthread.h is # defined. We could alternatively do an AC_TRY_COMPILE with # pthread.h, but that will work with libpthread really doesn't # exist, like AIX 4.2. [Bug: 4359] echo "$as_me:$LINENO: checking for __pthread_mutex_init in -lpthread" >&5 echo $ECHO_N "checking for __pthread_mutex_init in -lpthread... $ECHO_C" >&6 if test "${ac_cv_lib_pthread___pthread_mutex_init+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpthread $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char __pthread_mutex_init (); int main () { __pthread_mutex_init (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_pthread___pthread_mutex_init=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pthread___pthread_mutex_init=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_pthread___pthread_mutex_init" >&5 echo "${ECHO_T}$ac_cv_lib_pthread___pthread_mutex_init" >&6 if test $ac_cv_lib_pthread___pthread_mutex_init = yes; then tcl_ok=yes else tcl_ok=no fi fi if test "$tcl_ok" = "yes"; then # The space is needed THREADS_LIBS=" -lpthread" else echo "$as_me:$LINENO: checking for pthread_mutex_init in -lpthreads" >&5 echo $ECHO_N "checking for pthread_mutex_init in -lpthreads... $ECHO_C" >&6 if test "${ac_cv_lib_pthreads_pthread_mutex_init+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lpthreads $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char pthread_mutex_init (); int main () { pthread_mutex_init (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_pthreads_pthread_mutex_init=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_pthreads_pthread_mutex_init=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_pthreads_pthread_mutex_init" >&5 echo "${ECHO_T}$ac_cv_lib_pthreads_pthread_mutex_init" >&6 if test $ac_cv_lib_pthreads_pthread_mutex_init = yes; then tcl_ok=yes else tcl_ok=no fi if test "$tcl_ok" = "yes"; then # The space is needed THREADS_LIBS=" -lpthreads" else echo "$as_me:$LINENO: checking for pthread_mutex_init in -lc" >&5 echo $ECHO_N "checking for pthread_mutex_init in -lc... $ECHO_C" >&6 if test "${ac_cv_lib_c_pthread_mutex_init+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lc $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char pthread_mutex_init (); int main () { pthread_mutex_init (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_c_pthread_mutex_init=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_c_pthread_mutex_init=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_c_pthread_mutex_init" >&5 echo "${ECHO_T}$ac_cv_lib_c_pthread_mutex_init" >&6 if test $ac_cv_lib_c_pthread_mutex_init = yes; then tcl_ok=yes else tcl_ok=no fi if test "$tcl_ok" = "no"; then echo "$as_me:$LINENO: checking for pthread_mutex_init in -lc_r" >&5 echo $ECHO_N "checking for pthread_mutex_init in -lc_r... $ECHO_C" >&6 if test "${ac_cv_lib_c_r_pthread_mutex_init+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lc_r $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char pthread_mutex_init (); int main () { pthread_mutex_init (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_c_r_pthread_mutex_init=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_c_r_pthread_mutex_init=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_c_r_pthread_mutex_init" >&5 echo "${ECHO_T}$ac_cv_lib_c_r_pthread_mutex_init" >&6 if test $ac_cv_lib_c_r_pthread_mutex_init = yes; then tcl_ok=yes else tcl_ok=no fi if test "$tcl_ok" = "yes"; then # The space is needed THREADS_LIBS=" -pthread" else TCL_THREADS=0 { echo "$as_me:$LINENO: WARNING: Don't know how to find pthread lib on your system - you must disable thread support or edit the LIBS in the Makefile..." >&5 echo "$as_me: WARNING: Don't know how to find pthread lib on your system - you must disable thread support or edit the LIBS in the Makefile..." >&2;} fi fi fi fi # Does the pthread-implementation provide # 'pthread_attr_setstacksize' ? ac_saved_libs=$LIBS LIBS="$LIBS $THREADS_LIBS" for ac_func in pthread_attr_setstacksize pthread_atfork do as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` echo "$as_me:$LINENO: checking for $ac_func" >&5 echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 if eval "test \"\${$as_ac_var+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define $ac_func to an innocuous variant, in case declares $ac_func. For example, HP-UX 11i declares gettimeofday. */ #define $ac_func innocuous_$ac_func /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef $ac_func /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char $ac_func (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_$ac_func) || defined (__stub___$ac_func) choke me #else char (*f) () = $ac_func; #endif #ifdef __cplusplus } #endif int main () { return f != $ac_func; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then eval "$as_ac_var=yes" else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 if test `eval echo '${'$as_ac_var'}'` = yes; then cat >>confdefs.h <<_ACEOF #define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done LIBS=$ac_saved_libs else TCL_THREADS=0 fi # Do checking message here to not mess up interleaved configure output echo "$as_me:$LINENO: checking for building with threads" >&5 echo $ECHO_N "checking for building with threads... $ECHO_C" >&6 if test "${TCL_THREADS}" = 1; then cat >>confdefs.h <<\_ACEOF #define TCL_THREADS 1 _ACEOF if test "${tcl_threaded_core}" = 1; then echo "$as_me:$LINENO: result: yes (threaded core)" >&5 echo "${ECHO_T}yes (threaded core)" >&6 else echo "$as_me:$LINENO: result: yes" >&5 echo "${ECHO_T}yes" >&6 fi else echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 fi # Add the threads support libraries LIBS="$LIBS$THREADS_LIBS" echo "$as_me:$LINENO: checking how to build libraries" >&5 echo $ECHO_N "checking how to build libraries... $ECHO_C" >&6 # Check whether --enable-shared or --disable-shared was given. if test "${enable_shared+set}" = set; then enableval="$enable_shared" tcl_ok=$enableval else tcl_ok=yes fi; if test "${enable_shared+set}" = set; then enableval="$enable_shared" tcl_ok=$enableval else tcl_ok=yes fi if test "$tcl_ok" = "yes" ; then echo "$as_me:$LINENO: result: shared" >&5 echo "${ECHO_T}shared" >&6 SHARED_BUILD=1 else echo "$as_me:$LINENO: result: static" >&5 echo "${ECHO_T}static" >&6 SHARED_BUILD=0 cat >>confdefs.h <<\_ACEOF #define STATIC_BUILD 1 _ACEOF fi #-------------------------------------------------------------------- # The statements below define a collection of compile flags. This # macro depends on the value of SHARED_BUILD, and should be called # after SC_ENABLE_SHARED checks the configure switches. #-------------------------------------------------------------------- if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}ranlib", so it can be a program name with args. set dummy ${ac_tool_prefix}ranlib; ac_word=$2 echo "$as_me:$LINENO: checking for $ac_word" >&5 echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 if test "${ac_cv_prog_RANLIB+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$RANLIB"; then ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_RANLIB="${ac_tool_prefix}ranlib" echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done fi fi RANLIB=$ac_cv_prog_RANLIB if test -n "$RANLIB"; then echo "$as_me:$LINENO: result: $RANLIB" >&5 echo "${ECHO_T}$RANLIB" >&6 else echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 fi fi if test -z "$ac_cv_prog_RANLIB"; then ac_ct_RANLIB=$RANLIB # Extract the first word of "ranlib", so it can be a program name with args. set dummy ranlib; ac_word=$2 echo "$as_me:$LINENO: checking for $ac_word" >&5 echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 if test "${ac_cv_prog_ac_ct_RANLIB+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$ac_ct_RANLIB"; then ac_cv_prog_ac_ct_RANLIB="$ac_ct_RANLIB" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_RANLIB="ranlib" echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done test -z "$ac_cv_prog_ac_ct_RANLIB" && ac_cv_prog_ac_ct_RANLIB=":" fi fi ac_ct_RANLIB=$ac_cv_prog_ac_ct_RANLIB if test -n "$ac_ct_RANLIB"; then echo "$as_me:$LINENO: result: $ac_ct_RANLIB" >&5 echo "${ECHO_T}$ac_ct_RANLIB" >&6 else echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 fi RANLIB=$ac_ct_RANLIB else RANLIB="$ac_cv_prog_RANLIB" fi # Step 0.a: Enable 64 bit support? echo "$as_me:$LINENO: checking if 64bit support is requested" >&5 echo $ECHO_N "checking if 64bit support is requested... $ECHO_C" >&6 # Check whether --enable-64bit or --disable-64bit was given. if test "${enable_64bit+set}" = set; then enableval="$enable_64bit" do64bit=$enableval else do64bit=no fi; echo "$as_me:$LINENO: result: $do64bit" >&5 echo "${ECHO_T}$do64bit" >&6 # Step 0.b: Enable Solaris 64 bit VIS support? echo "$as_me:$LINENO: checking if 64bit Sparc VIS support is requested" >&5 echo $ECHO_N "checking if 64bit Sparc VIS support is requested... $ECHO_C" >&6 # Check whether --enable-64bit-vis or --disable-64bit-vis was given. if test "${enable_64bit_vis+set}" = set; then enableval="$enable_64bit_vis" do64bitVIS=$enableval else do64bitVIS=no fi; echo "$as_me:$LINENO: result: $do64bitVIS" >&5 echo "${ECHO_T}$do64bitVIS" >&6 # Force 64bit on with VIS if test "$do64bitVIS" = "yes"; then do64bit=yes fi # Step 0.c: Check if visibility support is available. Do this here so # that platform specific alternatives can be used below if this fails. echo "$as_me:$LINENO: checking if compiler supports visibility \"hidden\"" >&5 echo $ECHO_N "checking if compiler supports visibility \"hidden\"... $ECHO_C" >&6 if test "${tcl_cv_cc_visibility_hidden+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Werror" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ extern __attribute__((__visibility__("hidden"))) void f(void); void f(void) {} int main () { f(); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_cc_visibility_hidden=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_cc_visibility_hidden=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext CFLAGS=$hold_cflags fi echo "$as_me:$LINENO: result: $tcl_cv_cc_visibility_hidden" >&5 echo "${ECHO_T}$tcl_cv_cc_visibility_hidden" >&6 if test $tcl_cv_cc_visibility_hidden = yes; then cat >>confdefs.h <<\_ACEOF #define MODULE_SCOPE extern __attribute__((__visibility__("hidden"))) _ACEOF cat >>confdefs.h <<\_ACEOF #define HAVE_HIDDEN 1 _ACEOF fi # Step 0.d: Disable -rpath support? echo "$as_me:$LINENO: checking if rpath support is requested" >&5 echo $ECHO_N "checking if rpath support is requested... $ECHO_C" >&6 # Check whether --enable-rpath or --disable-rpath was given. if test "${enable_rpath+set}" = set; then enableval="$enable_rpath" doRpath=$enableval else doRpath=yes fi; echo "$as_me:$LINENO: result: $doRpath" >&5 echo "${ECHO_T}$doRpath" >&6 # Step 1: set the variable "system" to hold the name and version number # for the system. echo "$as_me:$LINENO: checking system version" >&5 echo $ECHO_N "checking system version... $ECHO_C" >&6 if test "${tcl_cv_sys_version+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -f /usr/lib/NextStep/software_version; then tcl_cv_sys_version=NEXTSTEP-`awk '/3/,/3/' /usr/lib/NextStep/software_version` else tcl_cv_sys_version=`uname -s`-`uname -r` if test "$?" -ne 0 ; then { echo "$as_me:$LINENO: WARNING: can't find uname command" >&5 echo "$as_me: WARNING: can't find uname command" >&2;} tcl_cv_sys_version=unknown else # Special check for weird MP-RAS system (uname returns weird # results, and the version is kept in special file). if test -r /etc/.relid -a "X`uname -n`" = "X`uname -s`" ; then tcl_cv_sys_version=MP-RAS-`awk '{print $3}' /etc/.relid` fi if test "`uname -s`" = "AIX" ; then tcl_cv_sys_version=AIX-`uname -v`.`uname -r` fi fi fi fi echo "$as_me:$LINENO: result: $tcl_cv_sys_version" >&5 echo "${ECHO_T}$tcl_cv_sys_version" >&6 system=$tcl_cv_sys_version # Step 2: check for existence of -ldl library. This is needed because # Linux can use either -ldl or -ldld for dynamic loading. echo "$as_me:$LINENO: checking for dlopen in -ldl" >&5 echo $ECHO_N "checking for dlopen in -ldl... $ECHO_C" >&6 if test "${ac_cv_lib_dl_dlopen+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldl $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char dlopen (); int main () { dlopen (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_dl_dlopen=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_dl_dlopen=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_dl_dlopen" >&5 echo "${ECHO_T}$ac_cv_lib_dl_dlopen" >&6 if test $ac_cv_lib_dl_dlopen = yes; then have_dl=yes else have_dl=no fi # Require ranlib early so we can override it in special cases below. # Step 3: set configuration options based on system name and version. do64bit_ok=no # default to '{$LIBS}' and set to "" on per-platform necessary basis SHLIB_LD_LIBS='${LIBS}' LDFLAGS_ORIG="$LDFLAGS" # When ld needs options to work in 64-bit mode, put them in # LDFLAGS_ARCH so they eventually end up in LDFLAGS even if [load] # is disabled by the user. [Bug 1016796] LDFLAGS_ARCH="" UNSHARED_LIB_SUFFIX="" TCL_TRIM_DOTS='`echo ${VERSION} | tr -d .`' ECHO_VERSION='`echo ${VERSION}`' TCL_LIB_VERSIONS_OK=ok CFLAGS_DEBUG=-g if test "$GCC" = yes; then CFLAGS_OPTIMIZE=-O2 CFLAGS_WARNING="-Wall" else CFLAGS_OPTIMIZE=-O CFLAGS_WARNING="" fi if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}ar", so it can be a program name with args. set dummy ${ac_tool_prefix}ar; ac_word=$2 echo "$as_me:$LINENO: checking for $ac_word" >&5 echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 if test "${ac_cv_prog_AR+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$AR"; then ac_cv_prog_AR="$AR" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_AR="${ac_tool_prefix}ar" echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done fi fi AR=$ac_cv_prog_AR if test -n "$AR"; then echo "$as_me:$LINENO: result: $AR" >&5 echo "${ECHO_T}$AR" >&6 else echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 fi fi if test -z "$ac_cv_prog_AR"; then ac_ct_AR=$AR # Extract the first word of "ar", so it can be a program name with args. set dummy ar; ac_word=$2 echo "$as_me:$LINENO: checking for $ac_word" >&5 echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 if test "${ac_cv_prog_ac_ct_AR+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if test -n "$ac_ct_AR"; then ac_cv_prog_ac_ct_AR="$ac_ct_AR" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_AR="ar" echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done fi fi ac_ct_AR=$ac_cv_prog_ac_ct_AR if test -n "$ac_ct_AR"; then echo "$as_me:$LINENO: result: $ac_ct_AR" >&5 echo "${ECHO_T}$ac_ct_AR" >&6 else echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 fi AR=$ac_ct_AR else AR="$ac_cv_prog_AR" fi STLIB_LD='${AR} cr' LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH" PLAT_OBJS="" PLAT_SRCS="" LDAIX_SRC="" if test x"${SHLIB_VERSION}" = x; then SHLIB_VERSION="1.0" fi case $system in AIX-*) if test "${TCL_THREADS}" = "1" -a "$GCC" != "yes"; then # AIX requires the _r compiler when gcc isn't being used case "${CC}" in *_r|*_r\ *) # ok ... ;; *) # Make sure only first arg gets _r CC=`echo "$CC" | sed -e 's/^\([^ ]*\)/\1_r/'` ;; esac echo "$as_me:$LINENO: result: Using $CC for compiling with threads" >&5 echo "${ECHO_T}Using $CC for compiling with threads" >&6 fi LIBS="$LIBS -lc" SHLIB_CFLAGS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" LD_LIBRARY_PATH_VAR="LIBPATH" # ldAix No longer needed with use of -bexpall/-brtl # but some extensions may still reference it LDAIX_SRC='$(UNIX_DIR)/ldAix' # Check to enable 64-bit flags for compiler/linker if test "$do64bit" = yes; then if test "$GCC" = yes; then { echo "$as_me:$LINENO: WARNING: 64bit mode not supported with GCC on $system" >&5 echo "$as_me: WARNING: 64bit mode not supported with GCC on $system" >&2;} else do64bit_ok=yes CFLAGS="$CFLAGS -q64" LDFLAGS_ARCH="-q64" RANLIB="${RANLIB} -X64" AR="${AR} -X64" SHLIB_LD_FLAGS="-b64" fi fi if test "`uname -m`" = ia64; then # AIX-5 uses ELF style dynamic libraries on IA-64, but not PPC SHLIB_LD="/usr/ccs/bin/ld -G -z text" # AIX-5 has dl* in libc.so DL_LIBS="" if test "$GCC" = yes; then CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' else CC_SEARCH_FLAGS='-R${LIB_RUNTIME_DIR}' fi LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' else if test "$GCC" = yes; then SHLIB_LD='${CC} -shared -Wl,-bexpall' else SHLIB_LD="/bin/ld -bhalt:4 -bM:SRE -bexpall -H512 -T512 -bnoentry" LDFLAGS="$LDFLAGS -brtl" fi SHLIB_LD="${SHLIB_LD} ${SHLIB_LD_FLAGS}" DL_LIBS="-ldl" CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} fi ;; BeOS*) SHLIB_CFLAGS="-fPIC" SHLIB_LD='${CC} -nostart' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" #----------------------------------------------------------- # Check for inet_ntoa in -lbind, for BeOS (which also needs # -lsocket, even if the network functions are in -lnet which # is always linked to, for compatibility. #----------------------------------------------------------- echo "$as_me:$LINENO: checking for inet_ntoa in -lbind" >&5 echo $ECHO_N "checking for inet_ntoa in -lbind... $ECHO_C" >&6 if test "${ac_cv_lib_bind_inet_ntoa+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lbind $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char inet_ntoa (); int main () { inet_ntoa (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_bind_inet_ntoa=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_bind_inet_ntoa=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_bind_inet_ntoa" >&5 echo "${ECHO_T}$ac_cv_lib_bind_inet_ntoa" >&6 if test $ac_cv_lib_bind_inet_ntoa = yes; then LIBS="$LIBS -lbind -lsocket" fi ;; BSD/OS-2.1*|BSD/OS-3*) SHLIB_CFLAGS="" SHLIB_LD="shlicc -r" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; BSD/OS-4.*) SHLIB_CFLAGS="-export-dynamic -fPIC" SHLIB_LD='${CC} -shared' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" LDFLAGS="$LDFLAGS -export-dynamic" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; CYGWIN_*|MINGW32*) SHLIB_CFLAGS="" SHLIB_LD='${CC} -shared' SHLIB_SUFFIX=".dll" DL_OBJS="tclLoadDl.o" PLAT_OBJS='${CYGWIN_OBJS}' PLAT_SRCS='${CYGWIN_SRCS}' DL_LIBS="-ldl" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" TCL_NEEDS_EXP_FILE=1 TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.dll.a' SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,--out-implib,\$@.a" echo "$as_me:$LINENO: checking for Cygwin version of gcc" >&5 echo $ECHO_N "checking for Cygwin version of gcc... $ECHO_C" >&6 if test "${ac_cv_cygwin+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #ifdef __CYGWIN__ #error cygwin #endif int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_cygwin=no else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_cygwin=yes fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_cygwin" >&5 echo "${ECHO_T}$ac_cv_cygwin" >&6 if test "$ac_cv_cygwin" = "no"; then { { echo "$as_me:$LINENO: error: ${CC} is not a cygwin compiler." >&5 echo "$as_me: error: ${CC} is not a cygwin compiler." >&2;} { (exit 1); exit 1; }; } fi if test "x${TCL_THREADS}" = "x0"; then { { echo "$as_me:$LINENO: error: CYGWIN compile is only supported with --enable-threads" >&5 echo "$as_me: error: CYGWIN compile is only supported with --enable-threads" >&2;} { (exit 1); exit 1; }; } fi do64bit_ok=yes if test "x${SHARED_BUILD}" = "x1"; then echo "running cd ../win; ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args" # The eval makes quoting arguments work. if cd ../win; eval ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args; cd ../unix then : else { echo "configure: error: configure failed for ../win" 1>&2; exit 1; } fi fi ;; dgux*) SHLIB_CFLAGS="-K PIC" SHLIB_LD='${CC} -G' SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; Haiku*) LDFLAGS="$LDFLAGS -Wl,--export-dynamic" SHLIB_CFLAGS="-fPIC" SHLIB_SUFFIX=".so" SHLIB_LD='${CC} -shared ${CFLAGS} ${LDFLAGS}' DL_OBJS="tclLoadDl.o" DL_LIBS="-lroot" echo "$as_me:$LINENO: checking for inet_ntoa in -lnetwork" >&5 echo $ECHO_N "checking for inet_ntoa in -lnetwork... $ECHO_C" >&6 if test "${ac_cv_lib_network_inet_ntoa+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lnetwork $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char inet_ntoa (); int main () { inet_ntoa (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_network_inet_ntoa=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_network_inet_ntoa=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_network_inet_ntoa" >&5 echo "${ECHO_T}$ac_cv_lib_network_inet_ntoa" >&6 if test $ac_cv_lib_network_inet_ntoa = yes; then LIBS="$LIBS -lnetwork" fi ;; HP-UX-*.11.*) # Use updated header definitions where possible cat >>confdefs.h <<\_ACEOF #define _XOPEN_SOURCE_EXTENDED 1 _ACEOF cat >>confdefs.h <<\_ACEOF #define _XOPEN_SOURCE 1 _ACEOF LIBS="$LIBS -lxnet" # Use the XOPEN network library if test "`uname -m`" = ia64; then SHLIB_SUFFIX=".so" else SHLIB_SUFFIX=".sl" fi echo "$as_me:$LINENO: checking for shl_load in -ldld" >&5 echo $ECHO_N "checking for shl_load in -ldld... $ECHO_C" >&6 if test "${ac_cv_lib_dld_shl_load+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldld $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char shl_load (); int main () { shl_load (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_dld_shl_load=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_dld_shl_load=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_dld_shl_load" >&5 echo "${ECHO_T}$ac_cv_lib_dld_shl_load" >&6 if test $ac_cv_lib_dld_shl_load = yes; then tcl_ok=yes else tcl_ok=no fi if test "$tcl_ok" = yes; then SHLIB_CFLAGS="+z" SHLIB_LD="ld -b" DL_OBJS="tclLoadShl.o" DL_LIBS="-ldld" LDFLAGS="$LDFLAGS -Wl,-E" CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.' LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.' LD_LIBRARY_PATH_VAR="SHLIB_PATH" fi if test "$GCC" = yes; then SHLIB_LD='${CC} -shared' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} else CFLAGS="$CFLAGS -z" fi # Users may want PA-RISC 1.1/2.0 portable code - needs HP cc #CFLAGS="$CFLAGS +DAportable" # Check to enable 64-bit flags for compiler/linker if test "$do64bit" = "yes"; then if test "$GCC" = yes; then case `${CC} -dumpmachine` in hppa64*) # 64-bit gcc in use. Fix flags for GNU ld. do64bit_ok=yes SHLIB_LD='${CC} -shared' if test $doRpath = yes; then CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' fi LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} ;; *) { echo "$as_me:$LINENO: WARNING: 64bit mode not supported with GCC on $system" >&5 echo "$as_me: WARNING: 64bit mode not supported with GCC on $system" >&2;} ;; esac else do64bit_ok=yes CFLAGS="$CFLAGS +DD64" LDFLAGS_ARCH="+DD64" fi fi ;; HP-UX-*.08.*|HP-UX-*.09.*|HP-UX-*.10.*) SHLIB_SUFFIX=".sl" echo "$as_me:$LINENO: checking for shl_load in -ldld" >&5 echo $ECHO_N "checking for shl_load in -ldld... $ECHO_C" >&6 if test "${ac_cv_lib_dld_shl_load+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldld $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char shl_load (); int main () { shl_load (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_dld_shl_load=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_dld_shl_load=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_dld_shl_load" >&5 echo "${ECHO_T}$ac_cv_lib_dld_shl_load" >&6 if test $ac_cv_lib_dld_shl_load = yes; then tcl_ok=yes else tcl_ok=no fi if test "$tcl_ok" = yes; then SHLIB_CFLAGS="+z" SHLIB_LD="ld -b" SHLIB_LD_LIBS="" DL_OBJS="tclLoadShl.o" DL_LIBS="-ldld" LDFLAGS="$LDFLAGS -Wl,-E" CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.' LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.' LD_LIBRARY_PATH_VAR="SHLIB_PATH" fi ;; IRIX-5.*) SHLIB_CFLAGS="" SHLIB_LD="ld -shared -rdata_shared" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" case $LIBOBJS in "mkstemp.$ac_objext" | \ *" mkstemp.$ac_objext" | \ "mkstemp.$ac_objext "* | \ *" mkstemp.$ac_objext "* ) ;; *) LIBOBJS="$LIBOBJS mkstemp.$ac_objext" ;; esac if test $doRpath = yes; then CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' fi ;; IRIX-6.*) SHLIB_CFLAGS="" SHLIB_LD="ld -n32 -shared -rdata_shared" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" case $LIBOBJS in "mkstemp.$ac_objext" | \ *" mkstemp.$ac_objext" | \ "mkstemp.$ac_objext "* | \ *" mkstemp.$ac_objext "* ) ;; *) LIBOBJS="$LIBOBJS mkstemp.$ac_objext" ;; esac if test $doRpath = yes; then CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' fi if test "$GCC" = yes; then CFLAGS="$CFLAGS -mabi=n32" LDFLAGS="$LDFLAGS -mabi=n32" else case $system in IRIX-6.3) # Use to build 6.2 compatible binaries on 6.3. CFLAGS="$CFLAGS -n32 -D_OLD_TERMIOS" ;; *) CFLAGS="$CFLAGS -n32" ;; esac LDFLAGS="$LDFLAGS -n32" fi ;; IRIX64-6.*) SHLIB_CFLAGS="" SHLIB_LD="ld -n32 -shared -rdata_shared" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" case $LIBOBJS in "mkstemp.$ac_objext" | \ *" mkstemp.$ac_objext" | \ "mkstemp.$ac_objext "* | \ *" mkstemp.$ac_objext "* ) ;; *) LIBOBJS="$LIBOBJS mkstemp.$ac_objext" ;; esac if test $doRpath = yes; then CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' fi # Check to enable 64-bit flags for compiler/linker if test "$do64bit" = yes; then if test "$GCC" = yes; then { echo "$as_me:$LINENO: WARNING: 64bit mode not supported by gcc" >&5 echo "$as_me: WARNING: 64bit mode not supported by gcc" >&2;} else do64bit_ok=yes SHLIB_LD="ld -64 -shared -rdata_shared" CFLAGS="$CFLAGS -64" LDFLAGS_ARCH="-64" fi fi ;; Linux*|GNU*|NetBSD-Debian) SHLIB_CFLAGS="-fPIC" SHLIB_SUFFIX=".so" CFLAGS_OPTIMIZE="-O2" # egcs-2.91.66 on Redhat Linux 6.0 generates lots of warnings # when you inline the string and math operations. Turn this off to # get rid of the warnings. #CFLAGS_OPTIMIZE="${CFLAGS_OPTIMIZE} -D__NO_STRING_INLINES -D__NO_MATH_INLINES" SHLIB_LD='${CC} -shared ${CFLAGS} ${LDFLAGS}' DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" LDFLAGS="$LDFLAGS -Wl,--export-dynamic" if test $doRpath = yes; then CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' fi LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} if test "`uname -m`" = "alpha"; then CFLAGS="$CFLAGS -mieee" fi if test $do64bit = yes; then echo "$as_me:$LINENO: checking if compiler accepts -m64 flag" >&5 echo $ECHO_N "checking if compiler accepts -m64 flag... $ECHO_C" >&6 if test "${tcl_cv_cc_m64+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else hold_cflags=$CFLAGS CFLAGS="$CFLAGS -m64" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_cc_m64=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_cc_m64=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext CFLAGS=$hold_cflags fi echo "$as_me:$LINENO: result: $tcl_cv_cc_m64" >&5 echo "${ECHO_T}$tcl_cv_cc_m64" >&6 if test $tcl_cv_cc_m64 = yes; then CFLAGS="$CFLAGS -m64" do64bit_ok=yes fi fi # The combo of gcc + glibc has a bug related to inlining of # functions like strtod(). The -fno-builtin flag should address # this problem but it does not work. The -fno-inline flag is kind # of overkill but it works. Disable inlining only when one of the # files in compat/*.c is being linked in. if test x"${USE_COMPAT}" != x; then CFLAGS="$CFLAGS -fno-inline" fi ;; Lynx*) SHLIB_CFLAGS="-fPIC" SHLIB_SUFFIX=".so" CFLAGS_OPTIMIZE=-02 SHLIB_LD='${CC} -shared' DL_OBJS="tclLoadDl.o" DL_LIBS="-mshared -ldl" LD_FLAGS="-Wl,--export-dynamic" if test $doRpath = yes; then CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' fi ;; MP-RAS-02*) SHLIB_CFLAGS="-K PIC" SHLIB_LD='${CC} -G' SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; MP-RAS-*) SHLIB_CFLAGS="-K PIC" SHLIB_LD='${CC} -G' SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" LDFLAGS="$LDFLAGS -Wl,-Bexport" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; OpenBSD-*) arch=`arch -s` case "$arch" in vax) # Equivalent using configure option --disable-load # Step 4 will set the necessary variables DL_OBJS="" SHLIB_LD_LIBS="" LDFLAGS="" ;; *) case "$arch" in alpha|sparc|sparc64) SHLIB_CFLAGS="-fPIC" ;; *) SHLIB_CFLAGS="-fpic" ;; esac SHLIB_LD='${CC} -shared ${SHLIB_CFLAGS}' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" if test $doRpath = yes; then CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' fi LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.${SHLIB_VERSION}' LDFLAGS="-Wl,-export-dynamic" ;; esac case "$arch" in vax) CFLAGS_OPTIMIZE="-O1" ;; sh) CFLAGS_OPTIMIZE="-O0" ;; *) CFLAGS_OPTIMIZE="-O2" ;; esac if test "${TCL_THREADS}" = "1"; then # On OpenBSD: Compile with -pthread # Don't link with -lpthread LIBS=`echo $LIBS | sed s/-lpthread//` CFLAGS="$CFLAGS -pthread" fi # OpenBSD doesn't do version numbers with dots. UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' TCL_LIB_VERSIONS_OK=nodots ;; NetBSD-*) # NetBSD has ELF and can use 'cc -shared' to build shared libs SHLIB_CFLAGS="-fPIC" SHLIB_LD='${CC} -shared ${SHLIB_CFLAGS}' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" LDFLAGS="$LDFLAGS -export-dynamic" if test $doRpath = yes; then CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' fi LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} if test "${TCL_THREADS}" = "1"; then # The -pthread needs to go in the CFLAGS, not LIBS LIBS=`echo $LIBS | sed s/-pthread//` CFLAGS="$CFLAGS -pthread" LDFLAGS="$LDFLAGS -pthread" fi ;; FreeBSD-*) # This configuration from FreeBSD Ports. SHLIB_CFLAGS="-fPIC" SHLIB_LD="${CC} -shared" SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,-soname,\$@" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" LDFLAGS="" if test $doRpath = yes; then CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' fi if test "${TCL_THREADS}" = "1"; then # The -pthread needs to go in the LDFLAGS, not LIBS LIBS=`echo $LIBS | sed s/-pthread//` CFLAGS="$CFLAGS $PTHREAD_CFLAGS" LDFLAGS="$LDFLAGS $PTHREAD_LIBS" fi case $system in FreeBSD-3.*) # Version numbers are dot-stripped by system policy. TCL_TRIM_DOTS=`echo ${VERSION} | tr -d .` UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so' TCL_LIB_VERSIONS_OK=nodots ;; esac ;; Darwin-*) CFLAGS_OPTIMIZE="-Os" SHLIB_CFLAGS="-fno-common" # To avoid discrepancies between what headers configure sees during # preprocessing tests and compiling tests, move any -isysroot and # -mmacosx-version-min flags from CFLAGS to CPPFLAGS: CPPFLAGS="${CPPFLAGS} `echo " ${CFLAGS}" | \ awk 'BEGIN {FS=" +-";ORS=" "}; {for (i=2;i<=NF;i++) \ if ($i~/^(isysroot|mmacosx-version-min)/) print "-"$i}'`" CFLAGS="`echo " ${CFLAGS}" | \ awk 'BEGIN {FS=" +-";ORS=" "}; {for (i=2;i<=NF;i++) \ if (!($i~/^(isysroot|mmacosx-version-min)/)) print "-"$i}'`" if test $do64bit = yes; then case `arch` in ppc) echo "$as_me:$LINENO: checking if compiler accepts -arch ppc64 flag" >&5 echo $ECHO_N "checking if compiler accepts -arch ppc64 flag... $ECHO_C" >&6 if test "${tcl_cv_cc_arch_ppc64+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else hold_cflags=$CFLAGS CFLAGS="$CFLAGS -arch ppc64 -mpowerpc64 -mcpu=G5" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_cc_arch_ppc64=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_cc_arch_ppc64=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext CFLAGS=$hold_cflags fi echo "$as_me:$LINENO: result: $tcl_cv_cc_arch_ppc64" >&5 echo "${ECHO_T}$tcl_cv_cc_arch_ppc64" >&6 if test $tcl_cv_cc_arch_ppc64 = yes; then CFLAGS="$CFLAGS -arch ppc64 -mpowerpc64 -mcpu=G5" do64bit_ok=yes fi ;; i386) echo "$as_me:$LINENO: checking if compiler accepts -arch x86_64 flag" >&5 echo $ECHO_N "checking if compiler accepts -arch x86_64 flag... $ECHO_C" >&6 if test "${tcl_cv_cc_arch_x86_64+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else hold_cflags=$CFLAGS CFLAGS="$CFLAGS -arch x86_64" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_cc_arch_x86_64=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_cc_arch_x86_64=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext CFLAGS=$hold_cflags fi echo "$as_me:$LINENO: result: $tcl_cv_cc_arch_x86_64" >&5 echo "${ECHO_T}$tcl_cv_cc_arch_x86_64" >&6 if test $tcl_cv_cc_arch_x86_64 = yes; then CFLAGS="$CFLAGS -arch x86_64" do64bit_ok=yes fi ;; *) { echo "$as_me:$LINENO: WARNING: Don't know how enable 64-bit on architecture \`arch\`" >&5 echo "$as_me: WARNING: Don't know how enable 64-bit on architecture \`arch\`" >&2;};; esac else # Check for combined 32-bit and 64-bit fat build if echo "$CFLAGS " |grep -E -q -- '-arch (ppc64|x86_64) ' \ && echo "$CFLAGS " |grep -E -q -- '-arch (ppc|i386) '; then fat_32_64=yes fi fi SHLIB_LD='${CC} -dynamiclib ${CFLAGS} ${LDFLAGS}' echo "$as_me:$LINENO: checking if ld accepts -single_module flag" >&5 echo $ECHO_N "checking if ld accepts -single_module flag... $ECHO_C" >&6 if test "${tcl_cv_ld_single_module+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else hold_ldflags=$LDFLAGS LDFLAGS="$LDFLAGS -dynamiclib -Wl,-single_module" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { int i; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_ld_single_module=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_ld_single_module=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LDFLAGS=$hold_ldflags fi echo "$as_me:$LINENO: result: $tcl_cv_ld_single_module" >&5 echo "${ECHO_T}$tcl_cv_ld_single_module" >&6 if test $tcl_cv_ld_single_module = yes; then SHLIB_LD="${SHLIB_LD} -Wl,-single_module" fi SHLIB_SUFFIX=".dylib" DL_OBJS="tclLoadDyld.o" DL_LIBS="" # Don't use -prebind when building for Mac OS X 10.4 or later only: if test "`echo "${MACOSX_DEPLOYMENT_TARGET}" | awk -F '10\\.' '{print int($2)}'`" -lt 4 -a \ "`echo "${CPPFLAGS}" | awk -F '-mmacosx-version-min=10\\.' '{print int($2)}'`" -lt 4; then LDFLAGS="$LDFLAGS -prebind" fi LDFLAGS="$LDFLAGS -headerpad_max_install_names" echo "$as_me:$LINENO: checking if ld accepts -search_paths_first flag" >&5 echo $ECHO_N "checking if ld accepts -search_paths_first flag... $ECHO_C" >&6 if test "${tcl_cv_ld_search_paths_first+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else hold_ldflags=$LDFLAGS LDFLAGS="$LDFLAGS -Wl,-search_paths_first" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { int i; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_ld_search_paths_first=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_ld_search_paths_first=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LDFLAGS=$hold_ldflags fi echo "$as_me:$LINENO: result: $tcl_cv_ld_search_paths_first" >&5 echo "${ECHO_T}$tcl_cv_ld_search_paths_first" >&6 if test $tcl_cv_ld_search_paths_first = yes; then LDFLAGS="$LDFLAGS -Wl,-search_paths_first" fi if test "$tcl_cv_cc_visibility_hidden" != yes; then cat >>confdefs.h <<\_ACEOF #define MODULE_SCOPE __private_extern__ _ACEOF fi CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" LD_LIBRARY_PATH_VAR="DYLD_LIBRARY_PATH" cat >>confdefs.h <<\_ACEOF #define MAC_OSX_TCL 1 _ACEOF PLAT_OBJS='${MAC_OSX_OBJS}' PLAT_SRCS='${MAC_OSX_SRCS}' echo "$as_me:$LINENO: checking whether to use CoreFoundation" >&5 echo $ECHO_N "checking whether to use CoreFoundation... $ECHO_C" >&6 # Check whether --enable-corefoundation or --disable-corefoundation was given. if test "${enable_corefoundation+set}" = set; then enableval="$enable_corefoundation" tcl_corefoundation=$enableval else tcl_corefoundation=yes fi; echo "$as_me:$LINENO: result: $tcl_corefoundation" >&5 echo "${ECHO_T}$tcl_corefoundation" >&6 if test $tcl_corefoundation = yes; then echo "$as_me:$LINENO: checking for CoreFoundation.framework" >&5 echo $ECHO_N "checking for CoreFoundation.framework... $ECHO_C" >&6 if test "${tcl_cv_lib_corefoundation+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else hold_libs=$LIBS if test "$fat_32_64" = yes; then for v in CFLAGS CPPFLAGS LDFLAGS; do # On Tiger there is no 64-bit CF, so remove 64-bit # archs from CFLAGS et al. while testing for # presence of CF. 64-bit CF is disabled in # tclUnixPort.h if necessary. eval 'hold_'$v'="$'$v'";'$v'="`echo "$'$v' "|sed -e "s/-arch ppc64 / /g" -e "s/-arch x86_64 / /g"`"' done fi LIBS="$LIBS -framework CoreFoundation" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { CFBundleRef b = CFBundleGetMainBundle(); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_lib_corefoundation=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_lib_corefoundation=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext if test "$fat_32_64" = yes; then for v in CFLAGS CPPFLAGS LDFLAGS; do eval $v'="$hold_'$v'"' done fi LIBS=$hold_libs fi echo "$as_me:$LINENO: result: $tcl_cv_lib_corefoundation" >&5 echo "${ECHO_T}$tcl_cv_lib_corefoundation" >&6 if test $tcl_cv_lib_corefoundation = yes; then LIBS="$LIBS -framework CoreFoundation" cat >>confdefs.h <<\_ACEOF #define HAVE_COREFOUNDATION 1 _ACEOF else tcl_corefoundation=no fi if test "$fat_32_64" = yes -a $tcl_corefoundation = yes; then echo "$as_me:$LINENO: checking for 64-bit CoreFoundation" >&5 echo $ECHO_N "checking for 64-bit CoreFoundation... $ECHO_C" >&6 if test "${tcl_cv_lib_corefoundation_64+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else for v in CFLAGS CPPFLAGS LDFLAGS; do eval 'hold_'$v'="$'$v'";'$v'="`echo "$'$v' "|sed -e "s/-arch ppc / /g" -e "s/-arch i386 / /g"`"' done cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { CFBundleRef b = CFBundleGetMainBundle(); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_lib_corefoundation_64=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_lib_corefoundation_64=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext for v in CFLAGS CPPFLAGS LDFLAGS; do eval $v'="$hold_'$v'"' done fi echo "$as_me:$LINENO: result: $tcl_cv_lib_corefoundation_64" >&5 echo "${ECHO_T}$tcl_cv_lib_corefoundation_64" >&6 if test $tcl_cv_lib_corefoundation_64 = no; then cat >>confdefs.h <<\_ACEOF #define NO_COREFOUNDATION_64 1 _ACEOF LDFLAGS="$LDFLAGS -Wl,-no_arch_warnings" fi fi fi ;; NEXTSTEP-*) SHLIB_CFLAGS="" SHLIB_LD='${CC} -nostdlib -r' SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadNext.o" DL_LIBS="" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; OS/390-*) SHLIB_LD_LIBS="" CFLAGS_OPTIMIZE="" # Optimizer is buggy cat >>confdefs.h <<\_ACEOF #define _OE_SOCKETS 1 _ACEOF ;; OSF1-1.0|OSF1-1.1|OSF1-1.2) # OSF/1 1.[012] from OSF, and derivatives, including Paragon OSF/1 SHLIB_CFLAGS="" # Hack: make package name same as library name SHLIB_LD='ld -R -export :' SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadOSF.o" DL_LIBS="" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; OSF1-1.*) # OSF/1 1.3 from OSF using ELF, and derivatives, including AD2 SHLIB_CFLAGS="-fPIC" if test "$SHARED_BUILD" = 1; then SHLIB_LD="ld -shared" else SHLIB_LD="ld -non_shared" fi SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; OSF1-V*) # Digital OSF/1 SHLIB_CFLAGS="" if test "$SHARED_BUILD" = 1; then SHLIB_LD='ld -shared -expect_unresolved "*"' else SHLIB_LD='ld -non_shared -expect_unresolved "*"' fi SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" if test $doRpath = yes; then CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}' fi if test "$GCC" = yes; then CFLAGS="$CFLAGS -mieee" else CFLAGS="$CFLAGS -DHAVE_TZSET -std1 -ieee" fi # see pthread_intro(3) for pthread support on osf1, k.furukawa if test "${TCL_THREADS}" = 1; then CFLAGS="$CFLAGS -DHAVE_PTHREAD_ATTR_SETSTACKSIZE" CFLAGS="$CFLAGS -DTCL_THREAD_STACK_MIN=PTHREAD_STACK_MIN*64" LIBS=`echo $LIBS | sed s/-lpthreads//` if test "$GCC" = yes; then LIBS="$LIBS -lpthread -lmach -lexc" else CFLAGS="$CFLAGS -pthread" LDFLAGS="$LDFLAGS -pthread" fi fi ;; QNX-6*) # QNX RTP # This may work for all QNX, but it was only reported for v6. SHLIB_CFLAGS="-fPIC" SHLIB_LD="ld -Bshareable -x" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" # dlopen is in -lc on QNX DL_LIBS="" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; SCO_SV-3.2*) # Note, dlopen is available only on SCO 3.2.5 and greater. However, # this test works, since "uname -s" was non-standard in 3.2.4 and # below. if test "$GCC" = yes; then SHLIB_CFLAGS="-fPIC -melf" LDFLAGS="$LDFLAGS -melf -Wl,-Bexport" else SHLIB_CFLAGS="-Kpic -belf" LDFLAGS="$LDFLAGS -belf -Wl,-Bexport" fi SHLIB_LD="ld -G" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; SINIX*5.4*) SHLIB_CFLAGS="-K PIC" SHLIB_LD='${CC} -G' SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; SunOS-4*) SHLIB_CFLAGS="-PIC" SHLIB_LD="ld" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} # SunOS can't handle version numbers with dots in them in library # specs, like -ltcl7.5, so use -ltcl75 instead. Also, it # requires an extra version number at the end of .so file names. # So, the library has to have a name like libtcl75.so.1.0 SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.${SHLIB_VERSION}' UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' TCL_LIB_VERSIONS_OK=nodots ;; SunOS-5.[0-6]) # Careful to not let 5.10+ fall into this case # Note: If _REENTRANT isn't defined, then Solaris # won't define thread-safe library routines. cat >>confdefs.h <<\_ACEOF #define _REENTRANT 1 _ACEOF cat >>confdefs.h <<\_ACEOF #define _POSIX_PTHREAD_SEMANTICS 1 _ACEOF SHLIB_CFLAGS="-KPIC" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" if test "$GCC" = yes; then SHLIB_LD='${CC} -shared' CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} else SHLIB_LD="/usr/ccs/bin/ld -G -z text" CC_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} fi ;; SunOS-5*) # Note: If _REENTRANT isn't defined, then Solaris # won't define thread-safe library routines. cat >>confdefs.h <<\_ACEOF #define _REENTRANT 1 _ACEOF cat >>confdefs.h <<\_ACEOF #define _POSIX_PTHREAD_SEMANTICS 1 _ACEOF SHLIB_CFLAGS="-KPIC" # Check to enable 64-bit flags for compiler/linker if test "$do64bit" = yes; then arch=`isainfo` if test "$arch" = "sparcv9 sparc"; then if test "$GCC" = yes; then if test "`${CC} -dumpversion | awk -F. '{print $1}'`" -lt 3; then { echo "$as_me:$LINENO: WARNING: 64bit mode not supported with GCC < 3.2 on $system" >&5 echo "$as_me: WARNING: 64bit mode not supported with GCC < 3.2 on $system" >&2;} else do64bit_ok=yes CFLAGS="$CFLAGS -m64 -mcpu=v9" LDFLAGS="$LDFLAGS -m64 -mcpu=v9" SHLIB_CFLAGS="-fPIC" fi else do64bit_ok=yes if test "$do64bitVIS" = yes; then CFLAGS="$CFLAGS -xarch=v9a" LDFLAGS_ARCH="-xarch=v9a" else CFLAGS="$CFLAGS -xarch=v9" LDFLAGS_ARCH="-xarch=v9" fi # Solaris 64 uses this as well #LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH_64" fi else if test "$arch" = "amd64 i386"; then if test "$GCC" = yes; then case $system in SunOS-5.1[1-9]*|SunOS-5.[2-9][0-9]*) do64bit_ok=yes CFLAGS="$CFLAGS -m64" LDFLAGS="$LDFLAGS -m64";; *) { echo "$as_me:$LINENO: WARNING: 64bit mode not supported with GCC on $system" >&5 echo "$as_me: WARNING: 64bit mode not supported with GCC on $system" >&2;};; esac else do64bit_ok=yes case $system in SunOS-5.1[1-9]*|SunOS-5.[2-9][0-9]*) CFLAGS="$CFLAGS -m64" LDFLAGS="$LDFLAGS -m64";; *) CFLAGS="$CFLAGS -xarch=amd64" LDFLAGS="$LDFLAGS -xarch=amd64";; esac fi else { echo "$as_me:$LINENO: WARNING: 64bit mode not supported for $arch" >&5 echo "$as_me: WARNING: 64bit mode not supported for $arch" >&2;} fi fi fi #-------------------------------------------------------------------- # On Solaris 5.x i386 with the sunpro compiler we need to link # with sunmath to get floating point rounding control #-------------------------------------------------------------------- if test "$GCC" = yes; then use_sunmath=no else arch=`isainfo` echo "$as_me:$LINENO: checking whether to use -lsunmath for fp rounding control" >&5 echo $ECHO_N "checking whether to use -lsunmath for fp rounding control... $ECHO_C" >&6 if test "$arch" = "amd64 i386" -o "$arch" = "i386"; then echo "$as_me:$LINENO: result: yes" >&5 echo "${ECHO_T}yes" >&6 MATH_LIBS="-lsunmath $MATH_LIBS" if test "${ac_cv_header_sunmath_h+set}" = set; then echo "$as_me:$LINENO: checking for sunmath.h" >&5 echo $ECHO_N "checking for sunmath.h... $ECHO_C" >&6 if test "${ac_cv_header_sunmath_h+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 fi echo "$as_me:$LINENO: result: $ac_cv_header_sunmath_h" >&5 echo "${ECHO_T}$ac_cv_header_sunmath_h" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking sunmath.h usability" >&5 echo $ECHO_N "checking sunmath.h usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_header_compiler=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking sunmath.h presence" >&5 echo $ECHO_N "checking sunmath.h presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then ac_header_preproc=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { echo "$as_me:$LINENO: WARNING: sunmath.h: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: sunmath.h: accepted by the compiler, rejected by the preprocessor!" >&2;} { echo "$as_me:$LINENO: WARNING: sunmath.h: proceeding with the compiler's result" >&5 echo "$as_me: WARNING: sunmath.h: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { echo "$as_me:$LINENO: WARNING: sunmath.h: present but cannot be compiled" >&5 echo "$as_me: WARNING: sunmath.h: present but cannot be compiled" >&2;} { echo "$as_me:$LINENO: WARNING: sunmath.h: check for missing prerequisite headers?" >&5 echo "$as_me: WARNING: sunmath.h: check for missing prerequisite headers?" >&2;} { echo "$as_me:$LINENO: WARNING: sunmath.h: see the Autoconf documentation" >&5 echo "$as_me: WARNING: sunmath.h: see the Autoconf documentation" >&2;} { echo "$as_me:$LINENO: WARNING: sunmath.h: section \"Present But Cannot Be Compiled\"" >&5 echo "$as_me: WARNING: sunmath.h: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: sunmath.h: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: sunmath.h: proceeding with the preprocessor's result" >&2;} { echo "$as_me:$LINENO: WARNING: sunmath.h: in the future, the compiler will take precedence" >&5 echo "$as_me: WARNING: sunmath.h: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ----------------------------- ## ## Report this to the tk lists. ## ## ----------------------------- ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac echo "$as_me:$LINENO: checking for sunmath.h" >&5 echo $ECHO_N "checking for sunmath.h... $ECHO_C" >&6 if test "${ac_cv_header_sunmath_h+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_cv_header_sunmath_h=$ac_header_preproc fi echo "$as_me:$LINENO: result: $ac_cv_header_sunmath_h" >&5 echo "${ECHO_T}$ac_cv_header_sunmath_h" >&6 fi use_sunmath=yes else echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 use_sunmath=no fi fi SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" if test "$GCC" = yes; then SHLIB_LD='${CC} -shared' CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} if test "$do64bit_ok" = yes; then if test "$arch" = "sparcv9 sparc"; then # We need to specify -static-libgcc or we need to # add the path to the sparv9 libgcc. SHLIB_LD="$SHLIB_LD -m64 -mcpu=v9 -static-libgcc" # for finding sparcv9 libgcc, get the regular libgcc # path, remove so name and append 'sparcv9' #v9gcclibdir="`gcc -print-file-name=libgcc_s.so` | ..." #CC_SEARCH_FLAGS="${CC_SEARCH_FLAGS},-R,$v9gcclibdir" else if test "$arch" = "amd64 i386"; then SHLIB_LD="$SHLIB_LD -m64 -static-libgcc" fi fi fi else if test "$use_sunmath" = yes; then textmode=textoff else textmode=text fi case $system in SunOS-5.[1-9][0-9]*|SunOS-5.[7-9]) SHLIB_LD="\${CC} -G -z $textmode \${LDFLAGS}";; *) SHLIB_LD="/usr/ccs/bin/ld -G -z $textmode";; esac CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}' LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}' fi ;; UNIX_SV* | UnixWare-5*) SHLIB_CFLAGS="-KPIC" SHLIB_LD='${CC} -G' SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" # Some UNIX_SV* systems (unixware 1.1.2 for example) have linkers # that don't grok the -Bexport option. Test that it does. echo "$as_me:$LINENO: checking for ld accepts -Bexport flag" >&5 echo $ECHO_N "checking for ld accepts -Bexport flag... $ECHO_C" >&6 if test "${tcl_cv_ld_Bexport+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else hold_ldflags=$LDFLAGS LDFLAGS="$LDFLAGS -Wl,-Bexport" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { int i; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_ld_Bexport=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_ld_Bexport=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LDFLAGS=$hold_ldflags fi echo "$as_me:$LINENO: result: $tcl_cv_ld_Bexport" >&5 echo "${ECHO_T}$tcl_cv_ld_Bexport" >&6 if test $tcl_cv_ld_Bexport = yes; then LDFLAGS="$LDFLAGS -Wl,-Bexport" fi CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; esac if test "$do64bit" = yes -a "$do64bit_ok" = no; then { echo "$as_me:$LINENO: WARNING: 64bit support being disabled -- don't know magic for this platform" >&5 echo "$as_me: WARNING: 64bit support being disabled -- don't know magic for this platform" >&2;} fi if test "$do64bit" = yes -a "$do64bit_ok" = yes; then cat >>confdefs.h <<\_ACEOF #define TCL_CFG_DO64BIT 1 _ACEOF fi # Step 4: disable dynamic loading if requested via a command-line switch. # Check whether --enable-load or --disable-load was given. if test "${enable_load+set}" = set; then enableval="$enable_load" tcl_ok=$enableval else tcl_ok=yes fi; if test "$tcl_ok" = no; then DL_OBJS="" fi if test "x$DL_OBJS" != x; then BUILD_DLTEST="\$(DLTEST_TARGETS)" else { echo "$as_me:$LINENO: WARNING: Can't figure out how to do dynamic loading or shared libraries on this system." >&5 echo "$as_me: WARNING: Can't figure out how to do dynamic loading or shared libraries on this system." >&2;} SHLIB_CFLAGS="" SHLIB_LD="" SHLIB_SUFFIX="" DL_OBJS="tclLoadNone.o" DL_LIBS="" LDFLAGS="$LDFLAGS_ORIG" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" BUILD_DLTEST="" fi LDFLAGS="$LDFLAGS $LDFLAGS_ARCH" # If we're running gcc, then change the C flags for compiling shared # libraries to the right flags for gcc, instead of those for the # standard manufacturer compiler. if test "$DL_OBJS" != "tclLoadNone.o" -a "$GCC" = yes; then case $system in AIX-*) ;; BSD/OS*) ;; CYGWIN_*|MINGW32_*) ;; IRIX*) ;; NetBSD-*|FreeBSD-*|OpenBSD-*) ;; Darwin-*) ;; SCO_SV-3.2*) ;; *) SHLIB_CFLAGS="-fPIC" ;; esac fi if test "$tcl_cv_cc_visibility_hidden" != yes; then cat >>confdefs.h <<\_ACEOF #define MODULE_SCOPE extern _ACEOF fi if test "$SHARED_LIB_SUFFIX" = ""; then SHARED_LIB_SUFFIX='${VERSION}${SHLIB_SUFFIX}' fi if test "$UNSHARED_LIB_SUFFIX" = ""; then UNSHARED_LIB_SUFFIX='${VERSION}.a' fi DLL_INSTALL_DIR="\$(LIB_INSTALL_DIR)" if test "${SHARED_BUILD}" = 1 -a "${SHLIB_SUFFIX}" != ""; then LIB_SUFFIX=${SHARED_LIB_SUFFIX} MAKE_LIB='${SHLIB_LD} -o $@ ${OBJS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}' if test "${SHLIB_SUFFIX}" = ".dll"; then INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(BIN_INSTALL_DIR)/$(LIB_FILE)";if test -f $(LIB_FILE).a; then $(INSTALL_DATA) $(LIB_FILE).a "$(LIB_INSTALL_DIR)"; fi;' DLL_INSTALL_DIR="\$(BIN_INSTALL_DIR)" else INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(LIB_INSTALL_DIR)/$(LIB_FILE)"' fi else LIB_SUFFIX=${UNSHARED_LIB_SUFFIX} if test "$RANLIB" = ""; then MAKE_LIB='$(STLIB_LD) $@ ${OBJS}' else MAKE_LIB='${STLIB_LD} $@ ${OBJS} ; ${RANLIB} $@' fi INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(LIB_INSTALL_DIR)/$(LIB_FILE)"' fi # Stub lib does not depend on shared/static configuration if test "$RANLIB" = ""; then MAKE_STUB_LIB='${STLIB_LD} $@ ${STUB_LIB_OBJS}' else MAKE_STUB_LIB='${STLIB_LD} $@ ${STUB_LIB_OBJS} ; ${RANLIB} $@' fi INSTALL_STUB_LIB='$(INSTALL_LIBRARY) $(STUB_LIB_FILE) "$(LIB_INSTALL_DIR)/$(STUB_LIB_FILE)"' # Define TCL_LIBS now that we know what DL_LIBS is. # The trick here is that we don't want to change the value of TCL_LIBS if # it is already set when tclConfig.sh had been loaded by Tk. if test "x${TCL_LIBS}" = x; then TCL_LIBS="${DL_LIBS} ${LIBS} ${MATH_LIBS}" fi # See if the compiler supports casting to a union type. # This is used to stop gcc from printing a compiler # warning when initializing a union member. echo "$as_me:$LINENO: checking for cast to union support" >&5 echo $ECHO_N "checking for cast to union support... $ECHO_C" >&6 if test "${tcl_cv_cast_to_union+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { union foo { int i; double d; }; union foo f = (union foo) (int) 0; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_cast_to_union=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_cast_to_union=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $tcl_cv_cast_to_union" >&5 echo "${ECHO_T}$tcl_cv_cast_to_union" >&6 if test "$tcl_cv_cast_to_union" = "yes"; then cat >>confdefs.h <<\_ACEOF #define HAVE_CAST_TO_UNION 1 _ACEOF fi # FIXME: This subst was left in only because the TCL_DL_LIBS # entry in tclConfig.sh uses it. It is not clear why someone # would use TCL_DL_LIBS instead of TCL_LIBS. cat >>confdefs.h <<_ACEOF #define TCL_SHLIB_EXT "${SHLIB_SUFFIX}" _ACEOF echo "$as_me:$LINENO: checking for build with symbols" >&5 echo $ECHO_N "checking for build with symbols... $ECHO_C" >&6 # Check whether --enable-symbols or --disable-symbols was given. if test "${enable_symbols+set}" = set; then enableval="$enable_symbols" tcl_ok=$enableval else tcl_ok=no fi; # FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT. DBGX="" if test "$tcl_ok" = "no"; then CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)' LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)' cat >>confdefs.h <<\_ACEOF #define NDEBUG 1 _ACEOF echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 cat >>confdefs.h <<\_ACEOF #define TCL_CFG_OPTIMIZED 1 _ACEOF else CFLAGS_DEFAULT='$(CFLAGS_DEBUG)' LDFLAGS_DEFAULT='$(LDFLAGS_DEBUG)' if test "$tcl_ok" = "yes"; then echo "$as_me:$LINENO: result: yes (standard debugging)" >&5 echo "${ECHO_T}yes (standard debugging)" >&6 fi fi if test "$tcl_ok" = "mem" -o "$tcl_ok" = "all"; then cat >>confdefs.h <<\_ACEOF #define TCL_MEM_DEBUG 1 _ACEOF fi if test "$tcl_ok" != "yes" -a "$tcl_ok" != "no"; then if test "$tcl_ok" = "all"; then echo "$as_me:$LINENO: result: enabled symbols mem debugging" >&5 echo "${ECHO_T}enabled symbols mem debugging" >&6 else echo "$as_me:$LINENO: result: enabled $tcl_ok debugging" >&5 echo "${ECHO_T}enabled $tcl_ok debugging" >&6 fi fi #-------------------------------------------------------------------- # Detect what compiler flags to set for 64-bit support. #-------------------------------------------------------------------- echo "$as_me:$LINENO: checking for required early compiler flags" >&5 echo $ECHO_N "checking for required early compiler flags... $ECHO_C" >&6 tcl_flags="" if test "${tcl_cv_flag__isoc99_source+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { char *p = (char *)strtoll; char *q = (char *)strtoull; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_flag__isoc99_source=no else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #define _ISOC99_SOURCE 1 #include int main () { char *p = (char *)strtoll; char *q = (char *)strtoull; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_flag__isoc99_source=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_flag__isoc99_source=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi if test "x${tcl_cv_flag__isoc99_source}" = "xyes" ; then cat >>confdefs.h <<\_ACEOF #define _ISOC99_SOURCE 1 _ACEOF tcl_flags="$tcl_flags _ISOC99_SOURCE" fi if test "${tcl_cv_flag__largefile64_source+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { struct stat64 buf; int i = stat64("/", &buf); ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_flag__largefile64_source=no else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #define _LARGEFILE64_SOURCE 1 #include int main () { struct stat64 buf; int i = stat64("/", &buf); ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_flag__largefile64_source=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_flag__largefile64_source=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi if test "x${tcl_cv_flag__largefile64_source}" = "xyes" ; then cat >>confdefs.h <<\_ACEOF #define _LARGEFILE64_SOURCE 1 _ACEOF tcl_flags="$tcl_flags _LARGEFILE64_SOURCE" fi if test "${tcl_cv_flag__largefile_source64+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { char *p = (char *)open64; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_flag__largefile_source64=no else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #define _LARGEFILE_SOURCE64 1 #include int main () { char *p = (char *)open64; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_flag__largefile_source64=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_flag__largefile_source64=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi if test "x${tcl_cv_flag__largefile_source64}" = "xyes" ; then cat >>confdefs.h <<\_ACEOF #define _LARGEFILE_SOURCE64 1 _ACEOF tcl_flags="$tcl_flags _LARGEFILE_SOURCE64" fi if test "x${tcl_flags}" = "x" ; then echo "$as_me:$LINENO: result: none" >&5 echo "${ECHO_T}none" >&6 else echo "$as_me:$LINENO: result: ${tcl_flags}" >&5 echo "${ECHO_T}${tcl_flags}" >&6 fi echo "$as_me:$LINENO: checking for 64-bit integer type" >&5 echo $ECHO_N "checking for 64-bit integer type... $ECHO_C" >&6 if test "${tcl_cv_type_64bit+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else tcl_cv_type_64bit=none # See if the compiler knows natively about __int64 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { __int64 value = (__int64) 0; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_type_64bit=__int64 else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_type_64bit="long long" fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext # See if we should use long anyway Note that we substitute in the # type that is our current guess for a 64-bit type inside this check # program, so it should be modified only carefully... cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { switch (0) { case 1: case (sizeof(${tcl_type_64bit})==sizeof(long)): ; } ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_type_64bit=${tcl_type_64bit} else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi if test "${tcl_cv_type_64bit}" = none ; then cat >>confdefs.h <<\_ACEOF #define TCL_WIDE_INT_IS_LONG 1 _ACEOF echo "$as_me:$LINENO: result: using long" >&5 echo "${ECHO_T}using long" >&6 else cat >>confdefs.h <<_ACEOF #define TCL_WIDE_INT_TYPE ${tcl_cv_type_64bit} _ACEOF echo "$as_me:$LINENO: result: ${tcl_cv_type_64bit}" >&5 echo "${ECHO_T}${tcl_cv_type_64bit}" >&6 # Now check for auxiliary declarations echo "$as_me:$LINENO: checking for struct dirent64" >&5 echo $ECHO_N "checking for struct dirent64... $ECHO_C" >&6 if test "${tcl_cv_struct_dirent64+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { struct dirent64 p; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_struct_dirent64=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_struct_dirent64=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $tcl_cv_struct_dirent64" >&5 echo "${ECHO_T}$tcl_cv_struct_dirent64" >&6 if test "x${tcl_cv_struct_dirent64}" = "xyes" ; then cat >>confdefs.h <<\_ACEOF #define HAVE_STRUCT_DIRENT64 1 _ACEOF fi echo "$as_me:$LINENO: checking for struct stat64" >&5 echo $ECHO_N "checking for struct stat64... $ECHO_C" >&6 if test "${tcl_cv_struct_stat64+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { struct stat64 p; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_struct_stat64=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_struct_stat64=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $tcl_cv_struct_stat64" >&5 echo "${ECHO_T}$tcl_cv_struct_stat64" >&6 if test "x${tcl_cv_struct_stat64}" = "xyes" ; then cat >>confdefs.h <<\_ACEOF #define HAVE_STRUCT_STAT64 1 _ACEOF fi for ac_func in open64 lseek64 do as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` echo "$as_me:$LINENO: checking for $ac_func" >&5 echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 if eval "test \"\${$as_ac_var+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define $ac_func to an innocuous variant, in case declares $ac_func. For example, HP-UX 11i declares gettimeofday. */ #define $ac_func innocuous_$ac_func /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $ac_func (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef $ac_func /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char $ac_func (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_$ac_func) || defined (__stub___$ac_func) choke me #else char (*f) () = $ac_func; #endif #ifdef __cplusplus } #endif int main () { return f != $ac_func; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then eval "$as_ac_var=yes" else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 eval "$as_ac_var=no" fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 if test `eval echo '${'$as_ac_var'}'` = yes; then cat >>confdefs.h <<_ACEOF #define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done echo "$as_me:$LINENO: checking for off64_t" >&5 echo $ECHO_N "checking for off64_t... $ECHO_C" >&6 if test "${tcl_cv_type_off64_t+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { off64_t offset; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_type_off64_t=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_type_off64_t=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi if test "x${tcl_cv_type_off64_t}" = "xyes" && \ test "x${ac_cv_func_lseek64}" = "xyes" && \ test "x${ac_cv_func_open64}" = "xyes" ; then cat >>confdefs.h <<\_ACEOF #define HAVE_TYPE_OFF64_T 1 _ACEOF echo "$as_me:$LINENO: result: yes" >&5 echo "${ECHO_T}yes" >&6 else echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 fi fi #-------------------------------------------------------------------- # Check endianness because we can optimize some operations #-------------------------------------------------------------------- echo "$as_me:$LINENO: checking whether byte ordering is bigendian" >&5 echo $ECHO_N "checking whether byte ordering is bigendian... $ECHO_C" >&6 if test "${ac_cv_c_bigendian+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else # See if sys/param.h defines the BYTE_ORDER macro. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #if !BYTE_ORDER || !BIG_ENDIAN || !LITTLE_ENDIAN bogus endian macros #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then # It does; now see whether it defined to BIG_ENDIAN or not. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include int main () { #if BYTE_ORDER != BIG_ENDIAN not big endian #endif ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_c_bigendian=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_c_bigendian=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 # It does not; compile a test program. if test "$cross_compiling" = yes; then # try to guess the endianness by grepping values into an object file ac_cv_c_bigendian=unknown cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ short ascii_mm[] = { 0x4249, 0x4765, 0x6E44, 0x6961, 0x6E53, 0x7953, 0 }; short ascii_ii[] = { 0x694C, 0x5454, 0x656C, 0x6E45, 0x6944, 0x6E61, 0 }; void _ascii () { char *s = (char *) ascii_mm; s = (char *) ascii_ii; } short ebcdic_ii[] = { 0x89D3, 0xE3E3, 0x8593, 0x95C5, 0x89C4, 0x9581, 0 }; short ebcdic_mm[] = { 0xC2C9, 0xC785, 0x95C4, 0x8981, 0x95E2, 0xA8E2, 0 }; void _ebcdic () { char *s = (char *) ebcdic_mm; s = (char *) ebcdic_ii; } int main () { _ascii (); _ebcdic (); ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then if grep BIGenDianSyS conftest.$ac_objext >/dev/null ; then ac_cv_c_bigendian=yes fi if grep LiTTleEnDian conftest.$ac_objext >/dev/null ; then if test "$ac_cv_c_bigendian" = unknown; then ac_cv_c_bigendian=no else # finding both strings is unlikely to happen, but who knows? ac_cv_c_bigendian=unknown fi fi else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { /* Are we little or big endian? From Harbison&Steele. */ union { long l; char c[sizeof (long)]; } u; u.l = 1; exit (u.c[sizeof (long) - 1] == 1); } _ACEOF rm -f conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='./conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_c_bigendian=no else echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) ac_cv_c_bigendian=yes fi rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_c_bigendian" >&5 echo "${ECHO_T}$ac_cv_c_bigendian" >&6 case $ac_cv_c_bigendian in yes) cat >>confdefs.h <<\_ACEOF #define WORDS_BIGENDIAN 1 _ACEOF ;; no) ;; *) { { echo "$as_me:$LINENO: error: unknown endianness presetting ac_cv_c_bigendian=no (or yes) will help" >&5 echo "$as_me: error: unknown endianness presetting ac_cv_c_bigendian=no (or yes) will help" >&2;} { (exit 1); exit 1; }; } ;; esac #------------------------------------------------------------------------ # If Tcl and Tk are installed in different places, adjust the library # search path to reflect this. #------------------------------------------------------------------------ LIB_RUNTIME_DIR='$(libdir)' if test "$TCL_EXEC_PREFIX" != "$exec_prefix"; then LIB_RUNTIME_DIR="${LIB_RUNTIME_DIR}:${TCL_EXEC_PREFIX}/lib" fi if test "$TCL_PREFIX" != "$prefix"; then { echo "$as_me:$LINENO: WARNING: Different --prefix selected for Tk and Tcl! [package require Tk] may not work correctly in tclsh." >&5 echo "$as_me: WARNING: Different --prefix selected for Tk and Tcl! [package require Tk] may not work correctly in tclsh." >&2;} fi #-------------------------------------------------------------------- # Include sys/select.h if it exists and if it supplies things # that appear to be useful and aren't already in sys/types.h. # This appears to be true only on the RS/6000 under AIX. Some # systems like OSF/1 have a sys/select.h that's of no use, and # other systems like SCO UNIX have a sys/select.h that's # pernicious. If "fd_set" isn't defined anywhere then set a # special flag. #-------------------------------------------------------------------- echo "$as_me:$LINENO: checking for fd_set in sys/types" >&5 echo $ECHO_N "checking for fd_set in sys/types... $ECHO_C" >&6 if test "${tcl_cv_type_fd_set+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { fd_set readMask, writeMask; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_type_fd_set=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_type_fd_set=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $tcl_cv_type_fd_set" >&5 echo "${ECHO_T}$tcl_cv_type_fd_set" >&6 tk_ok=$tcl_cv_type_fd_set if test $tk_ok = no; then echo "$as_me:$LINENO: checking for fd_mask in sys/select" >&5 echo $ECHO_N "checking for fd_mask in sys/select... $ECHO_C" >&6 if test "${tcl_cv_grep_fd_mask+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "fd_mask" >/dev/null 2>&1; then tcl_cv_grep_fd_mask=present else tcl_cv_grep_fd_mask=missing fi rm -f conftest* fi echo "$as_me:$LINENO: result: $tcl_cv_grep_fd_mask" >&5 echo "${ECHO_T}$tcl_cv_grep_fd_mask" >&6 if test $tcl_cv_grep_fd_mask = present; then cat >>confdefs.h <<\_ACEOF #define HAVE_SYS_SELECT_H 1 _ACEOF tk_ok=yes fi fi if test $tk_ok = no; then cat >>confdefs.h <<\_ACEOF #define NO_FD_SET 1 _ACEOF fi #------------------------------------------------------------------------------ # Find out all about time handling differences. #------------------------------------------------------------------------------ for ac_header in sys/time.h do as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh` if eval "test \"\${$as_ac_Header+set}\" = set"; then echo "$as_me:$LINENO: checking for $ac_header" >&5 echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 if eval "test \"\${$as_ac_Header+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking $ac_header usability" >&5 echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_header_compiler=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking $ac_header presence" >&5 echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <$ac_header> _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then ac_header_preproc=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ----------------------------- ## ## Report this to the tk lists. ## ## ----------------------------- ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac echo "$as_me:$LINENO: checking for $ac_header" >&5 echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 if eval "test \"\${$as_ac_Header+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else eval "$as_ac_Header=\$ac_header_preproc" fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 fi if test `eval echo '${'$as_ac_Header'}'` = yes; then cat >>confdefs.h <<_ACEOF #define `echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done echo "$as_me:$LINENO: checking whether time.h and sys/time.h may both be included" >&5 echo $ECHO_N "checking whether time.h and sys/time.h may both be included... $ECHO_C" >&6 if test "${ac_cv_header_time+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include #include int main () { if ((struct tm *) 0) return 0; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_header_time=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_header_time=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_header_time" >&5 echo "${ECHO_T}$ac_cv_header_time" >&6 if test $ac_cv_header_time = yes; then cat >>confdefs.h <<\_ACEOF #define TIME_WITH_SYS_TIME 1 _ACEOF fi #-------------------------------------------------------------------- # Under Solaris 2.4, strtod returns the wrong value for the # terminating character under some conditions. Check for this # and if the problem exists use a substitute procedure # "fixstrtod" (provided by Tcl) that corrects the error. #-------------------------------------------------------------------- echo "$as_me:$LINENO: checking for strtod" >&5 echo $ECHO_N "checking for strtod... $ECHO_C" >&6 if test "${ac_cv_func_strtod+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define strtod to an innocuous variant, in case declares strtod. For example, HP-UX 11i declares gettimeofday. */ #define strtod innocuous_strtod /* System header to define __stub macros and hopefully few prototypes, which can conflict with char strtod (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef strtod /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char strtod (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_strtod) || defined (__stub___strtod) choke me #else char (*f) () = strtod; #endif #ifdef __cplusplus } #endif int main () { return f != strtod; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_strtod=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_strtod=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_strtod" >&5 echo "${ECHO_T}$ac_cv_func_strtod" >&6 if test $ac_cv_func_strtod = yes; then tcl_strtod=1 else tcl_strtod=0 fi if test "$tcl_strtod" = 1; then echo "$as_me:$LINENO: checking for Solaris2.4/Tru64 strtod bugs" >&5 echo $ECHO_N "checking for Solaris2.4/Tru64 strtod bugs... $ECHO_C" >&6 if test "${tcl_cv_strtod_buggy+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else if test "$cross_compiling" = yes; then tcl_cv_strtod_buggy=buggy else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ extern double strtod(); int main() { char *infString="Inf", *nanString="NaN", *spaceString=" "; char *term; double value; value = strtod(infString, &term); if ((term != infString) && (term[-1] == 0)) { exit(1); } value = strtod(nanString, &term); if ((term != nanString) && (term[-1] == 0)) { exit(1); } value = strtod(spaceString, &term); if (term == (spaceString+1)) { exit(1); } exit(0); } _ACEOF rm -f conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='./conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_strtod_buggy=ok else echo "$as_me: program exited with status $ac_status" >&5 echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ( exit $ac_status ) tcl_cv_strtod_buggy=buggy fi rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext fi fi echo "$as_me:$LINENO: result: $tcl_cv_strtod_buggy" >&5 echo "${ECHO_T}$tcl_cv_strtod_buggy" >&6 if test "$tcl_cv_strtod_buggy" = buggy; then case $LIBOBJS in "fixstrtod.$ac_objext" | \ *" fixstrtod.$ac_objext" | \ "fixstrtod.$ac_objext "* | \ *" fixstrtod.$ac_objext "* ) ;; *) LIBOBJS="$LIBOBJS fixstrtod.$ac_objext" ;; esac USE_COMPAT=1 cat >>confdefs.h <<\_ACEOF #define strtod fixstrtod _ACEOF fi fi #-------------------------------------------------------------------- # Check for various typedefs and provide substitutes if # they don't exist. #-------------------------------------------------------------------- echo "$as_me:$LINENO: checking for mode_t" >&5 echo $ECHO_N "checking for mode_t... $ECHO_C" >&6 if test "${ac_cv_type_mode_t+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default int main () { if ((mode_t *) 0) return 0; if (sizeof (mode_t)) return 0; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_type_mode_t=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_type_mode_t=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_type_mode_t" >&5 echo "${ECHO_T}$ac_cv_type_mode_t" >&6 if test $ac_cv_type_mode_t = yes; then : else cat >>confdefs.h <<_ACEOF #define mode_t int _ACEOF fi echo "$as_me:$LINENO: checking for pid_t" >&5 echo $ECHO_N "checking for pid_t... $ECHO_C" >&6 if test "${ac_cv_type_pid_t+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default int main () { if ((pid_t *) 0) return 0; if (sizeof (pid_t)) return 0; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_type_pid_t=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_type_pid_t=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_type_pid_t" >&5 echo "${ECHO_T}$ac_cv_type_pid_t" >&6 if test $ac_cv_type_pid_t = yes; then : else cat >>confdefs.h <<_ACEOF #define pid_t int _ACEOF fi echo "$as_me:$LINENO: checking for size_t" >&5 echo $ECHO_N "checking for size_t... $ECHO_C" >&6 if test "${ac_cv_type_size_t+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default int main () { if ((size_t *) 0) return 0; if (sizeof (size_t)) return 0; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_type_size_t=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_type_size_t=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_type_size_t" >&5 echo "${ECHO_T}$ac_cv_type_size_t" >&6 if test $ac_cv_type_size_t = yes; then : else cat >>confdefs.h <<_ACEOF #define size_t unsigned _ACEOF fi echo "$as_me:$LINENO: checking for uid_t in sys/types.h" >&5 echo $ECHO_N "checking for uid_t in sys/types.h... $ECHO_C" >&6 if test "${ac_cv_type_uid_t+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "uid_t" >/dev/null 2>&1; then ac_cv_type_uid_t=yes else ac_cv_type_uid_t=no fi rm -f conftest* fi echo "$as_me:$LINENO: result: $ac_cv_type_uid_t" >&5 echo "${ECHO_T}$ac_cv_type_uid_t" >&6 if test $ac_cv_type_uid_t = no; then cat >>confdefs.h <<\_ACEOF #define uid_t int _ACEOF cat >>confdefs.h <<\_ACEOF #define gid_t int _ACEOF fi echo "$as_me:$LINENO: checking for intptr_t" >&5 echo $ECHO_N "checking for intptr_t... $ECHO_C" >&6 if test "${ac_cv_type_intptr_t+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default int main () { if ((intptr_t *) 0) return 0; if (sizeof (intptr_t)) return 0; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_type_intptr_t=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_type_intptr_t=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_type_intptr_t" >&5 echo "${ECHO_T}$ac_cv_type_intptr_t" >&6 if test $ac_cv_type_intptr_t = yes; then cat >>confdefs.h <<\_ACEOF #define HAVE_INTPTR_T 1 _ACEOF else echo "$as_me:$LINENO: checking for pointer-size signed integer type" >&5 echo $ECHO_N "checking for pointer-size signed integer type... $ECHO_C" >&6 if test "${tcl_cv_intptr_t+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else for tcl_cv_intptr_t in "int" "long" "long long" none; do if test "$tcl_cv_intptr_t" != none; then cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default int main () { static int test_array [1 - 2 * !(sizeof (void *) <= sizeof ($tcl_cv_intptr_t))]; test_array [0] = 0 ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_ok=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_ok=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext test "$tcl_ok" = yes && break; fi done fi echo "$as_me:$LINENO: result: $tcl_cv_intptr_t" >&5 echo "${ECHO_T}$tcl_cv_intptr_t" >&6 if test "$tcl_cv_intptr_t" != none; then cat >>confdefs.h <<_ACEOF #define intptr_t $tcl_cv_intptr_t _ACEOF fi fi echo "$as_me:$LINENO: checking for uintptr_t" >&5 echo $ECHO_N "checking for uintptr_t... $ECHO_C" >&6 if test "${ac_cv_type_uintptr_t+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default int main () { if ((uintptr_t *) 0) return 0; if (sizeof (uintptr_t)) return 0; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_type_uintptr_t=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_type_uintptr_t=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_type_uintptr_t" >&5 echo "${ECHO_T}$ac_cv_type_uintptr_t" >&6 if test $ac_cv_type_uintptr_t = yes; then cat >>confdefs.h <<\_ACEOF #define HAVE_UINTPTR_T 1 _ACEOF else echo "$as_me:$LINENO: checking for pointer-size unsigned integer type" >&5 echo $ECHO_N "checking for pointer-size unsigned integer type... $ECHO_C" >&6 if test "${tcl_cv_uintptr_t+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else for tcl_cv_uintptr_t in "unsigned int" "unsigned long" "unsigned long long" \ none; do if test "$tcl_cv_uintptr_t" != none; then cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default int main () { static int test_array [1 - 2 * !(sizeof (void *) <= sizeof ($tcl_cv_uintptr_t))]; test_array [0] = 0 ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_ok=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_ok=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext test "$tcl_ok" = yes && break; fi done fi echo "$as_me:$LINENO: result: $tcl_cv_uintptr_t" >&5 echo "${ECHO_T}$tcl_cv_uintptr_t" >&6 if test "$tcl_cv_uintptr_t" != none; then cat >>confdefs.h <<_ACEOF #define uintptr_t $tcl_cv_uintptr_t _ACEOF fi fi #------------------------------------------- # In OS/390 struct pwd has no pw_gecos field #------------------------------------------- echo "$as_me:$LINENO: checking pw_gecos in struct pwd" >&5 echo $ECHO_N "checking pw_gecos in struct pwd... $ECHO_C" >&6 if test "${tcl_cv_pwd_pw_gecos+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { struct passwd pwd; pwd.pw_gecos; ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_pwd_pw_gecos=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_pwd_pw_gecos=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $tcl_cv_pwd_pw_gecos" >&5 echo "${ECHO_T}$tcl_cv_pwd_pw_gecos" >&6 if test $tcl_cv_pwd_pw_gecos = yes; then cat >>confdefs.h <<\_ACEOF #define HAVE_PW_GECOS 1 _ACEOF fi #-------------------------------------------------------------------- # On Mac OS X, we can build either with X11 or with Aqua #-------------------------------------------------------------------- if test "`uname -s`" = "Darwin" ; then echo "$as_me:$LINENO: checking whether to use Aqua" >&5 echo $ECHO_N "checking whether to use Aqua... $ECHO_C" >&6 # Check whether --enable-aqua or --disable-aqua was given. if test "${enable_aqua+set}" = set; then enableval="$enable_aqua" tk_aqua=$enableval else tk_aqua=no fi; if test $tk_aqua = yes -o $tk_aqua = cocoa; then tk_aqua=yes if test $tcl_corefoundation = no; then { echo "$as_me:$LINENO: WARNING: Aqua can only be used when CoreFoundation is available" >&5 echo "$as_me: WARNING: Aqua can only be used when CoreFoundation is available" >&2;} tk_aqua=no fi if test ! -d /System/Library/Frameworks/Cocoa.framework; then { echo "$as_me:$LINENO: WARNING: Aqua can only be used when Cocoa is available" >&5 echo "$as_me: WARNING: Aqua can only be used when Cocoa is available" >&2;} tk_aqua=no fi if test "`uname -r | awk -F. '{print $1}'`" -lt 9; then { echo "$as_me:$LINENO: WARNING: Aqua requires Mac OS X 10.5 or later" >&5 echo "$as_me: WARNING: Aqua requires Mac OS X 10.5 or later" >&2;} tk_aqua=no fi fi echo "$as_me:$LINENO: result: $tk_aqua" >&5 echo "${ECHO_T}$tk_aqua" >&6 if test "$fat_32_64" = yes; then if test $tk_aqua = no; then echo "$as_me:$LINENO: checking for 64-bit X11" >&5 echo $ECHO_N "checking for 64-bit X11... $ECHO_C" >&6 if test "${tcl_cv_lib_x11_64+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else for v in CFLAGS CPPFLAGS LDFLAGS; do eval 'hold_'$v'="$'$v'";'$v'="`echo "$'$v' "|sed -e "s/-arch ppc / /g" -e "s/-arch i386 / /g"`"' done CPPFLAGS="$CPPFLAGS -I/usr/X11R6/include" LDFLAGS="$LDFLAGS -L/usr/X11R6/lib -lX11" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { XrmInitialize(); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_lib_x11_64=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_lib_x11_64=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext for v in CFLAGS CPPFLAGS LDFLAGS; do eval $v'="$hold_'$v'"' done fi echo "$as_me:$LINENO: result: $tcl_cv_lib_x11_64" >&5 echo "${ECHO_T}$tcl_cv_lib_x11_64" >&6 fi # remove 64-bit arch flags from CFLAGS et al. for combined 32 & 64 bit # fat builds if configuration does not support 64-bit. if test "$tcl_cv_lib_x11_64" = no; then { echo "$as_me:$LINENO: Removing 64-bit architectures from compiler & linker flags" >&5 echo "$as_me: Removing 64-bit architectures from compiler & linker flags" >&6;} for v in CFLAGS CPPFLAGS LDFLAGS; do eval $v'="`echo "$'$v' "|sed -e "s/-arch ppc64 / /g" -e "s/-arch x86_64 / /g"`"' done fi fi if test $tk_aqua = no; then # check if weak linking whole libraries is possible. echo "$as_me:$LINENO: checking if ld accepts -weak-l flag" >&5 echo $ECHO_N "checking if ld accepts -weak-l flag... $ECHO_C" >&6 if test "${tcl_cv_ld_weak_l+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else hold_ldflags=$LDFLAGS LDFLAGS="$LDFLAGS -Wl,-weak-lm" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { double f = sin(1.0); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_ld_weak_l=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_ld_weak_l=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LDFLAGS=$hold_ldflags fi echo "$as_me:$LINENO: result: $tcl_cv_ld_weak_l" >&5 echo "${ECHO_T}$tcl_cv_ld_weak_l" >&6 fi for ac_header in AvailabilityMacros.h do as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh` if eval "test \"\${$as_ac_Header+set}\" = set"; then echo "$as_me:$LINENO: checking for $ac_header" >&5 echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 if eval "test \"\${$as_ac_Header+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 else # Is the header compilable? echo "$as_me:$LINENO: checking $ac_header usability" >&5 echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default #include <$ac_header> _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_header_compiler=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_compiler=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 echo "${ECHO_T}$ac_header_compiler" >&6 # Is the header present? echo "$as_me:$LINENO: checking $ac_header presence" >&5 echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6 cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include <$ac_header> _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then ac_header_preproc=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_header_preproc=no fi rm -f conftest.err conftest.$ac_ext echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 echo "${ECHO_T}$ac_header_preproc" >&6 # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in yes:no: ) { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} ac_header_preproc=yes ;; no:yes:* ) { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} ( cat <<\_ASBOX ## ----------------------------- ## ## Report this to the tk lists. ## ## ----------------------------- ## _ASBOX ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac echo "$as_me:$LINENO: checking for $ac_header" >&5 echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 if eval "test \"\${$as_ac_Header+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else eval "$as_ac_Header=\$ac_header_preproc" fi echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 fi if test `eval echo '${'$as_ac_Header'}'` = yes; then cat >>confdefs.h <<_ACEOF #define `echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done if test "$ac_cv_header_AvailabilityMacros_h" = yes; then echo "$as_me:$LINENO: checking if weak import is available" >&5 echo $ECHO_N "checking if weak import is available... $ECHO_C" >&6 if test "${tcl_cv_cc_weak_import+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Werror" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #ifdef __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ #if __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ < 1020 #error __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ < 1020 #endif #elif MAC_OS_X_VERSION_MIN_REQUIRED < 1020 #error MAC_OS_X_VERSION_MIN_REQUIRED < 1020 #endif int rand(void) __attribute__((weak_import)); int main () { rand(); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_cc_weak_import=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_cc_weak_import=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext CFLAGS=$hold_cflags fi echo "$as_me:$LINENO: result: $tcl_cv_cc_weak_import" >&5 echo "${ECHO_T}$tcl_cv_cc_weak_import" >&6 if test $tcl_cv_cc_weak_import = yes; then cat >>confdefs.h <<\_ACEOF #define HAVE_WEAK_IMPORT 1 _ACEOF fi echo "$as_me:$LINENO: checking if Darwin SUSv3 extensions are available" >&5 echo $ECHO_N "checking if Darwin SUSv3 extensions are available... $ECHO_C" >&6 if test "${tcl_cv_cc_darwin_c_source+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Werror" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #ifdef __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ #if __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ < 1050 #error __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ < 1050 #endif #elif MAC_OS_X_VERSION_MIN_REQUIRED < 1050 #error MAC_OS_X_VERSION_MIN_REQUIRED < 1050 #endif #define _DARWIN_C_SOURCE 1 #include int main () { ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then tcl_cv_cc_darwin_c_source=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 tcl_cv_cc_darwin_c_source=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext CFLAGS=$hold_cflags fi echo "$as_me:$LINENO: result: $tcl_cv_cc_darwin_c_source" >&5 echo "${ECHO_T}$tcl_cv_cc_darwin_c_source" >&6 if test $tcl_cv_cc_darwin_c_source = yes; then cat >>confdefs.h <<\_ACEOF #define _DARWIN_C_SOURCE 1 _ACEOF fi fi else tk_aqua=no fi if test $tk_aqua = yes; then cat >>confdefs.h <<\_ACEOF #define MAC_OSX_TK 1 _ACEOF LIBS="$LIBS -framework Cocoa -framework Carbon -framework IOKit" EXTRA_CC_SWITCHES='-std=gnu99 -x objective-c' TK_WINDOWINGSYSTEM=AQUA if test -n "${enable_symbols}" -a "${enable_symbols}" != no; then cat >>confdefs.h <<\_ACEOF #define TK_MAC_DEBUG 1 _ACEOF fi else #-------------------------------------------------------------------- # Locate the X11 header files and the X11 library archive. Try # the ac_path_x macro first, but if it doesn't find the X stuff # (e.g. because there's no xmkmf program) then check through # a list of possible directories. Under some conditions the # autoconf macro will return an include directory that contains # no include files, so double-check its result just to be safe. #-------------------------------------------------------------------- echo "$as_me:$LINENO: checking for X" >&5 echo $ECHO_N "checking for X... $ECHO_C" >&6 # Check whether --with-x or --without-x was given. if test "${with_x+set}" = set; then withval="$with_x" fi; # $have_x is `yes', `no', `disabled', or empty when we do not yet know. if test "x$with_x" = xno; then # The user explicitly disabled X. have_x=disabled else if test "x$x_includes" != xNONE && test "x$x_libraries" != xNONE; then # Both variables are already set. have_x=yes else if test "${ac_cv_have_x+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else # One or both of the vars are not set, and there is no cached value. ac_x_includes=no ac_x_libraries=no rm -fr conftest.dir if mkdir conftest.dir; then cd conftest.dir # Make sure to not put "make" in the Imakefile rules, since we grep it out. cat >Imakefile <<'_ACEOF' acfindx: @echo 'ac_im_incroot="${INCROOT}"; ac_im_usrlibdir="${USRLIBDIR}"; ac_im_libdir="${LIBDIR}"' _ACEOF if (xmkmf) >/dev/null 2>/dev/null && test -f Makefile; then # GNU make sometimes prints "make[1]: Entering...", which would confuse us. eval `${MAKE-make} acfindx 2>/dev/null | grep -v make` # Open Windows xmkmf reportedly sets LIBDIR instead of USRLIBDIR. for ac_extension in a so sl; do if test ! -f $ac_im_usrlibdir/libX11.$ac_extension && test -f $ac_im_libdir/libX11.$ac_extension; then ac_im_usrlibdir=$ac_im_libdir; break fi done # Screen out bogus values from the imake configuration. They are # bogus both because they are the default anyway, and because # using them would break gcc on systems where it needs fixed includes. case $ac_im_incroot in /usr/include) ;; *) test -f "$ac_im_incroot/X11/Xos.h" && ac_x_includes=$ac_im_incroot;; esac case $ac_im_usrlibdir in /usr/lib | /lib) ;; *) test -d "$ac_im_usrlibdir" && ac_x_libraries=$ac_im_usrlibdir ;; esac fi cd .. rm -fr conftest.dir fi # Standard set of common directories for X headers. # Check X11 before X11Rn because it is often a symlink to the current release. ac_x_header_dirs=' /usr/X11/include /usr/X11R6/include /usr/X11R5/include /usr/X11R4/include /usr/include/X11 /usr/include/X11R6 /usr/include/X11R5 /usr/include/X11R4 /usr/local/X11/include /usr/local/X11R6/include /usr/local/X11R5/include /usr/local/X11R4/include /usr/local/include/X11 /usr/local/include/X11R6 /usr/local/include/X11R5 /usr/local/include/X11R4 /usr/X386/include /usr/x386/include /usr/XFree86/include/X11 /usr/include /usr/local/include /usr/unsupported/include /usr/athena/include /usr/local/x11r5/include /usr/lpp/Xamples/include /usr/openwin/include /usr/openwin/share/include' if test "$ac_x_includes" = no; then # Guess where to find include files, by looking for Intrinsic.h. # First, try using that file with no special directory specified. cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then # We can compile using X headers with no special include directory. ac_x_includes= else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 for ac_dir in $ac_x_header_dirs; do if test -r "$ac_dir/X11/Intrinsic.h"; then ac_x_includes=$ac_dir break fi done fi rm -f conftest.err conftest.$ac_ext fi # $ac_x_includes = no if test "$ac_x_libraries" = no; then # Check for the libraries. # See if we find them without any special options. # Don't add to $LIBS permanently. ac_save_LIBS=$LIBS LIBS="-lXt $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { XtMalloc (0) ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then LIBS=$ac_save_LIBS # We can link X programs with no special library path. ac_x_libraries= else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 LIBS=$ac_save_LIBS for ac_dir in `echo "$ac_x_includes $ac_x_header_dirs" | sed s/include/lib/g` do # Don't even attempt the hair of trying to link an X program! for ac_extension in a so sl; do if test -r $ac_dir/libXt.$ac_extension; then ac_x_libraries=$ac_dir break 2 fi done done fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi # $ac_x_libraries = no if test "$ac_x_includes" = no || test "$ac_x_libraries" = no; then # Didn't find X anywhere. Cache the known absence of X. ac_cv_have_x="have_x=no" else # Record where we found X for the cache. ac_cv_have_x="have_x=yes \ ac_x_includes=$ac_x_includes ac_x_libraries=$ac_x_libraries" fi fi fi eval "$ac_cv_have_x" fi # $with_x != no if test "$have_x" != yes; then echo "$as_me:$LINENO: result: $have_x" >&5 echo "${ECHO_T}$have_x" >&6 no_x=yes else # If each of the values was on the command line, it overrides each guess. test "x$x_includes" = xNONE && x_includes=$ac_x_includes test "x$x_libraries" = xNONE && x_libraries=$ac_x_libraries # Update the cache value to reflect the command line values. ac_cv_have_x="have_x=yes \ ac_x_includes=$x_includes ac_x_libraries=$x_libraries" echo "$as_me:$LINENO: result: libraries $x_libraries, headers $x_includes" >&5 echo "${ECHO_T}libraries $x_libraries, headers $x_includes" >&6 fi not_really_there="" if test "$no_x" = ""; then if test "$x_includes" = ""; then cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then : else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 not_really_there="yes" fi rm -f conftest.err conftest.$ac_ext else if test ! -r $x_includes/X11/Xlib.h; then not_really_there="yes" fi fi fi if test "$no_x" = "yes" -o "$not_really_there" = "yes"; then echo "$as_me:$LINENO: checking for X11 header files" >&5 echo $ECHO_N "checking for X11 header files... $ECHO_C" >&6 found_xincludes="no" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include _ACEOF if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } >/dev/null; then if test -s conftest.err; then ac_cpp_err=$ac_c_preproc_warn_flag ac_cpp_err=$ac_cpp_err$ac_c_werror_flag else ac_cpp_err= fi else ac_cpp_err=yes fi if test -z "$ac_cpp_err"; then found_xincludes="yes" else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 found_xincludes="no" fi rm -f conftest.err conftest.$ac_ext if test "$found_xincludes" = "no"; then dirs="/usr/unsupported/include /usr/local/include /usr/X386/include /usr/X11R6/include /usr/X11R5/include /usr/include/X11R5 /usr/include/X11R4 /usr/openwin/include /usr/X11/include /usr/sww/include" for i in $dirs ; do if test -r $i/X11/Xlib.h; then echo "$as_me:$LINENO: result: $i" >&5 echo "${ECHO_T}$i" >&6 XINCLUDES=" -I$i" found_xincludes="yes" break fi done fi else if test "$x_includes" != ""; then XINCLUDES="-I$x_includes" found_xincludes="yes" fi fi if test "$found_xincludes" = "no"; then echo "$as_me:$LINENO: result: couldn't find any!" >&5 echo "${ECHO_T}couldn't find any!" >&6 fi if test "$no_x" = yes; then echo "$as_me:$LINENO: checking for X11 libraries" >&5 echo $ECHO_N "checking for X11 libraries... $ECHO_C" >&6 XLIBSW=nope dirs="/usr/unsupported/lib /usr/local/lib /usr/X386/lib /usr/X11R6/lib /usr/X11R5/lib /usr/lib/X11R5 /usr/lib/X11R4 /usr/openwin/lib /usr/X11/lib /usr/sww/X11/lib" for i in $dirs ; do if test -r $i/libX11.a -o -r $i/libX11.so -o -r $i/libX11.sl -o -r $i/libX11.dylib; then echo "$as_me:$LINENO: result: $i" >&5 echo "${ECHO_T}$i" >&6 XLIBSW="-L$i -lX11" x_libraries="$i" break fi done else if test "$x_libraries" = ""; then XLIBSW=-lX11 else XLIBSW="-L$x_libraries -lX11" fi fi if test "$XLIBSW" = nope ; then echo "$as_me:$LINENO: checking for XCreateWindow in -lXwindow" >&5 echo $ECHO_N "checking for XCreateWindow in -lXwindow... $ECHO_C" >&6 if test "${ac_cv_lib_Xwindow_XCreateWindow+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lXwindow $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char XCreateWindow (); int main () { XCreateWindow (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_Xwindow_XCreateWindow=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_Xwindow_XCreateWindow=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_Xwindow_XCreateWindow" >&5 echo "${ECHO_T}$ac_cv_lib_Xwindow_XCreateWindow" >&6 if test $ac_cv_lib_Xwindow_XCreateWindow = yes; then XLIBSW=-lXwindow fi fi if test "$XLIBSW" = nope ; then echo "$as_me:$LINENO: result: could not find any! Using -lX11." >&5 echo "${ECHO_T}could not find any! Using -lX11." >&6 XLIBSW=-lX11 fi TK_WINDOWINGSYSTEM=X11 fi #-------------------------------------------------------------------- # Various manipulations on the search path used at runtime to # find shared libraries: # 1. If the X library binaries are in a non-standard directory, # add the X library location into that search path. # 2. On systems such as AIX and Ultrix that use "-L" as the # search path option, colons cannot be used to separate # directories from each other. Change colons to " -L". # 3. Create two sets of search flags, one for use in cc lines # and the other for when the linker is invoked directly. In # the second case, '-Wl,' must be stripped off and commas must # be replaced by spaces. #-------------------------------------------------------------------- if test "x${x_libraries}" != "x"; then if test "x${x_libraries}" != "xNONE"; then LIB_RUNTIME_DIR="${LIB_RUNTIME_DIR}:${x_libraries}" fi fi if test "${TCL_LD_SEARCH_FLAGS}" = '-L${LIB_RUNTIME_DIR}'; then LIB_RUNTIME_DIR=`echo ${LIB_RUNTIME_DIR} |sed -e 's/:/ -L/g'` fi #-------------------------------------------------------------------- # Check for the existence of various libraries. The order here # is important, so that then end up in the right order in the # command line generated by make. The -lsocket and -lnsl libraries # require a couple of special tricks: # 1. Use "connect" and "accept" to check for -lsocket, and # "gethostbyname" to check for -lnsl. # 2. Use each function name only once: can't redo a check because # autoconf caches the results of the last check and won't redo it. # 3. Use -lnsl and -lsocket only if they supply procedures that # aren't already present in the normal libraries. This is because # IRIX 5.2 has libraries, but they aren't needed and they're # bogus: they goof up name resolution if used. # 4. On some SVR4 systems, can't use -lsocket without -lnsl too. # To get around this problem, check for both libraries together # if -lsocket doesn't work by itself. #-------------------------------------------------------------------- if test $tk_aqua = no; then echo "$as_me:$LINENO: checking for main in -lXbsd" >&5 echo $ECHO_N "checking for main in -lXbsd... $ECHO_C" >&6 if test "${ac_cv_lib_Xbsd_main+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lXbsd $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ int main () { main (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_Xbsd_main=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_Xbsd_main=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_Xbsd_main" >&5 echo "${ECHO_T}$ac_cv_lib_Xbsd_main" >&6 if test $ac_cv_lib_Xbsd_main = yes; then LIBS="$LIBS -lXbsd" fi fi #-------------------------------------------------------------------- # One more check related to the X libraries. The standard releases # of Ultrix don't support the "xauth" mechanism, so send won't work # unless TK_NO_SECURITY is defined. However, there are usually copies # of the MIT X server available as well, which do support xauth. # Check for the MIT stuff and use it if it exists. # # Note: can't use ac_check_lib macro (at least, not in Autoconf 2.1) # because it can't deal with the "-" in the library name. #-------------------------------------------------------------------- if test -d /usr/include/mit -a $tk_aqua = no; then echo "$as_me:$LINENO: checking MIT X libraries" >&5 echo $ECHO_N "checking MIT X libraries... $ECHO_C" >&6 tk_oldCFlags=$CFLAGS CFLAGS="$CFLAGS -I/usr/include/mit" tk_oldLibs=$LIBS LIBS="$LIBS -lX11-mit" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { XOpenDisplay(0); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then echo "$as_me:$LINENO: result: yes" >&5 echo "${ECHO_T}yes" >&6 XLIBSW="-lX11-mit" XINCLUDES="-I/usr/include/mit" else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext CFLAGS=$tk_oldCFlags LIBS=$tk_oldLibs fi #-------------------------------------------------------------------- # Check for freetype / fontconfig / Xft support. #-------------------------------------------------------------------- if test $tk_aqua = no; then echo "$as_me:$LINENO: checking whether to use xft" >&5 echo $ECHO_N "checking whether to use xft... $ECHO_C" >&6 # Check whether --enable-xft or --disable-xft was given. if test "${enable_xft+set}" = set; then enableval="$enable_xft" enable_xft=$enableval else enable_xft="default" fi; XFT_CFLAGS="" XFT_LIBS="" if test "$enable_xft" = "no" ; then echo "$as_me:$LINENO: result: $enable_xft" >&5 echo "${ECHO_T}$enable_xft" >&6 else found_xft="yes" XFT_CFLAGS=`xft-config --cflags 2>/dev/null` || found_xft="no" XFT_LIBS=`xft-config --libs 2>/dev/null` || found_xft="no" if test "$found_xft" = "no" ; then found_xft=yes XFT_CFLAGS=`pkg-config --cflags xft 2>/dev/null` || found_xft="no" XFT_LIBS=`pkg-config --libs xft 2>/dev/null` || found_xft="no" fi echo "$as_me:$LINENO: result: $found_xft" >&5 echo "${ECHO_T}$found_xft" >&6 if test "$found_xft" = "yes" ; then tk_oldCFlags=$CFLAGS CFLAGS="$CFLAGS $XINCLUDES $XFT_CFLAGS" tk_oldLibs=$LIBS LIBS="$tk_oldLIBS $XFT_LIBS $XLIBSW" echo "$as_me:$LINENO: checking for X11/Xft/Xft.h" >&5 echo $ECHO_N "checking for X11/Xft/Xft.h... $ECHO_C" >&6 if test "${ac_cv_header_X11_Xft_Xft_h+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_header_X11_Xft_Xft_h=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_header_X11_Xft_Xft_h=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_header_X11_Xft_Xft_h" >&5 echo "${ECHO_T}$ac_cv_header_X11_Xft_Xft_h" >&6 if test $ac_cv_header_X11_Xft_Xft_h = yes; then : else found_xft=no fi CFLAGS=$tk_oldCFlags LIBS=$tk_oldLibs fi if test "$found_xft" = "yes" ; then tk_oldCFlags=$CFLAGS CFLAGS="$CFLAGS $XINCLUDES $XFT_CFLAGS" tk_oldLibs=$LIBS LIBS="$tk_oldLIBS $XFT_LIBS $XLIBSW" echo "$as_me:$LINENO: checking for XftFontOpen in -lXft" >&5 echo $ECHO_N "checking for XftFontOpen in -lXft... $ECHO_C" >&6 if test "${ac_cv_lib_Xft_XftFontOpen+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lXft $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char XftFontOpen (); int main () { XftFontOpen (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_Xft_XftFontOpen=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_Xft_XftFontOpen=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_Xft_XftFontOpen" >&5 echo "${ECHO_T}$ac_cv_lib_Xft_XftFontOpen" >&6 if test $ac_cv_lib_Xft_XftFontOpen = yes; then cat >>confdefs.h <<_ACEOF #define HAVE_LIBXFT 1 _ACEOF LIBS="-lXft $LIBS" else found_xft=no fi CFLAGS=$tk_oldCFlags LIBS=$tk_oldLibs fi if test "$found_xft" = "yes" ; then tk_oldCFlags=$CFLAGS CFLAGS="$CFLAGS $XINCLUDES $XFT_CFLAGS" tk_oldLibs=$LIBS LIBS="$tk_oldLIBS $XFT_LIBS $XLIBSW -lfontconfig" echo "$as_me:$LINENO: checking for FcFontSort in -lfontconfig" >&5 echo $ECHO_N "checking for FcFontSort in -lfontconfig... $ECHO_C" >&6 if test "${ac_cv_lib_fontconfig_FcFontSort+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lfontconfig $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char FcFontSort (); int main () { FcFontSort (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_fontconfig_FcFontSort=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_fontconfig_FcFontSort=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_fontconfig_FcFontSort" >&5 echo "${ECHO_T}$ac_cv_lib_fontconfig_FcFontSort" >&6 if test $ac_cv_lib_fontconfig_FcFontSort = yes; then XFT_LIBS="$XFT_LIBS -lfontconfig" fi CFLAGS=$tk_oldCFlags LIBS=$tk_oldLibs fi if test "$found_xft" = "no" ; then if test "$enable_xft" = "yes" ; then { echo "$as_me:$LINENO: WARNING: Can't find xft configuration, or xft is unusable" >&5 echo "$as_me: WARNING: Can't find xft configuration, or xft is unusable" >&2;} fi enable_xft=no XFT_CFLAGS="" XFT_LIBS="" else enable_xft=yes fi fi if test $enable_xft = "yes" ; then UNIX_FONT_OBJS=tkUnixRFont.o cat >>confdefs.h <<\_ACEOF #define HAVE_XFT 1 _ACEOF else UNIX_FONT_OBJS=tkUnixFont.o fi fi #-------------------------------------------------------------------- # Check for XkbKeycodeToKeysym. #-------------------------------------------------------------------- if test $tk_aqua = no; then tk_oldCFlags=$CFLAGS tk_oldLibs=$LIBS CFLAGS="$CFLAGS $XINCLUDES" LIBS="$LIBS $XLIBSW" echo "$as_me:$LINENO: checking for X11/XKBlib.h" >&5 echo $ECHO_N "checking for X11/XKBlib.h... $ECHO_C" >&6 if test "${ac_cv_header_X11_XKBlib_h+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_header_X11_XKBlib_h=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_header_X11_XKBlib_h=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_header_X11_XKBlib_h" >&5 echo "${ECHO_T}$ac_cv_header_X11_XKBlib_h" >&6 if test $ac_cv_header_X11_XKBlib_h = yes; then xkblib_header_found=yes else xkblib_header_found=no fi if test $xkblib_header_found = "yes" ; then echo "$as_me:$LINENO: checking for XkbKeycodeToKeysym in -lX11" >&5 echo $ECHO_N "checking for XkbKeycodeToKeysym in -lX11... $ECHO_C" >&6 if test "${ac_cv_lib_X11_XkbKeycodeToKeysym+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lX11 $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char XkbKeycodeToKeysym (); int main () { XkbKeycodeToKeysym (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_X11_XkbKeycodeToKeysym=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_X11_XkbKeycodeToKeysym=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_X11_XkbKeycodeToKeysym" >&5 echo "${ECHO_T}$ac_cv_lib_X11_XkbKeycodeToKeysym" >&6 if test $ac_cv_lib_X11_XkbKeycodeToKeysym = yes; then xkbkeycodetokeysym_found=yes else xkbkeycodetokeysym_found=no fi else xkbkeycodetokeysym_found=no fi if test $xkbkeycodetokeysym_found = "yes" ; then cat >>confdefs.h <<\_ACEOF #define HAVE_XKBKEYCODETOKEYSYM 1 _ACEOF fi CFLAGS=$tk_oldCFlags LIBS=$tk_oldLibs fi #-------------------------------------------------------------------- # Check whether XKeycodeToKeysym is deprecated in X11 headers. #-------------------------------------------------------------------- if test $tk_aqua = no && test "$GCC" = yes; then echo "$as_me:$LINENO: checking whether XKeycodeToKeysym is deprecated" >&5 echo $ECHO_N "checking whether XKeycodeToKeysym is deprecated... $ECHO_C" >&6 tk_oldCFlags=$CFLAGS CFLAGS="$CFLAGS -Werror" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include int main () { XKeycodeToKeysym(0,0,0); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 echo "$as_me:$LINENO: result: yes" >&5 echo "${ECHO_T}yes" >&6 cat >>confdefs.h <<\_ACEOF #define XKEYCODETOKEYSYM_IS_DEPRECATED 1 _ACEOF fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext CFLAGS=$tk_oldCFlags fi #-------------------------------------------------------------------- # XXX Do this last. # It might modify XLIBSW which could affect other tests. # # Check whether the header and library for the XScreenSaver # extension are available, and set HAVE_XSS if so. # XScreenSaver is needed for Tk_GetUserInactiveTime(). #-------------------------------------------------------------------- if test $tk_aqua = no; then tk_oldCFlags=$CFLAGS CFLAGS="$CFLAGS $XINCLUDES" tk_oldLibs=$LIBS LIBS="$tk_oldLibs $XLIBSW" xss_header_found=no xss_lib_found=no echo "$as_me:$LINENO: checking whether to try to use XScreenSaver" >&5 echo $ECHO_N "checking whether to try to use XScreenSaver... $ECHO_C" >&6 # Check whether --enable-xss or --disable-xss was given. if test "${enable_xss+set}" = set; then enableval="$enable_xss" enable_xss=$enableval else enable_xss=yes fi; if test "$enable_xss" = "no" ; then echo "$as_me:$LINENO: result: $enable_xss" >&5 echo "${ECHO_T}$enable_xss" >&6 else echo "$as_me:$LINENO: result: $enable_xss" >&5 echo "${ECHO_T}$enable_xss" >&6 echo "$as_me:$LINENO: checking for X11/extensions/scrnsaver.h" >&5 echo $ECHO_N "checking for X11/extensions/scrnsaver.h... $ECHO_C" >&6 if test "${ac_cv_header_X11_extensions_scrnsaver_h+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include #include _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_header_X11_extensions_scrnsaver_h=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_header_X11_extensions_scrnsaver_h=no fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_header_X11_extensions_scrnsaver_h" >&5 echo "${ECHO_T}$ac_cv_header_X11_extensions_scrnsaver_h" >&6 if test $ac_cv_header_X11_extensions_scrnsaver_h = yes; then xss_header_found=yes fi echo "$as_me:$LINENO: checking for XScreenSaverQueryInfo" >&5 echo $ECHO_N "checking for XScreenSaverQueryInfo... $ECHO_C" >&6 if test "${ac_cv_func_XScreenSaverQueryInfo+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Define XScreenSaverQueryInfo to an innocuous variant, in case declares XScreenSaverQueryInfo. For example, HP-UX 11i declares gettimeofday. */ #define XScreenSaverQueryInfo innocuous_XScreenSaverQueryInfo /* System header to define __stub macros and hopefully few prototypes, which can conflict with char XScreenSaverQueryInfo (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef XScreenSaverQueryInfo /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" { #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char XScreenSaverQueryInfo (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_XScreenSaverQueryInfo) || defined (__stub___XScreenSaverQueryInfo) choke me #else char (*f) () = XScreenSaverQueryInfo; #endif #ifdef __cplusplus } #endif int main () { return f != XScreenSaverQueryInfo; ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_func_XScreenSaverQueryInfo=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_func_XScreenSaverQueryInfo=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_func_XScreenSaverQueryInfo" >&5 echo "${ECHO_T}$ac_cv_func_XScreenSaverQueryInfo" >&6 if test $ac_cv_func_XScreenSaverQueryInfo = yes; then : else echo "$as_me:$LINENO: checking for XScreenSaverQueryInfo in -lXext" >&5 echo $ECHO_N "checking for XScreenSaverQueryInfo in -lXext... $ECHO_C" >&6 if test "${ac_cv_lib_Xext_XScreenSaverQueryInfo+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lXext $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char XScreenSaverQueryInfo (); int main () { XScreenSaverQueryInfo (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_Xext_XScreenSaverQueryInfo=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_Xext_XScreenSaverQueryInfo=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_Xext_XScreenSaverQueryInfo" >&5 echo "${ECHO_T}$ac_cv_lib_Xext_XScreenSaverQueryInfo" >&6 if test $ac_cv_lib_Xext_XScreenSaverQueryInfo = yes; then XLIBSW="$XLIBSW -lXext" xss_lib_found=yes else echo "$as_me:$LINENO: checking for XScreenSaverQueryInfo in -lXss" >&5 echo $ECHO_N "checking for XScreenSaverQueryInfo in -lXss... $ECHO_C" >&6 if test "${ac_cv_lib_Xss_XScreenSaverQueryInfo+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lXss -lXext $LIBS" cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ /* Override any gcc2 internal prototype to avoid an error. */ #ifdef __cplusplus extern "C" #endif /* We use char because int might match the return type of a gcc2 builtin and then its argument prototype would still apply. */ char XScreenSaverQueryInfo (); int main () { XScreenSaverQueryInfo (); ; return 0; } _ACEOF rm -f conftest.$ac_objext conftest$ac_exeext if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 (eval $ac_link) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest$ac_exeext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_lib_Xss_XScreenSaverQueryInfo=yes else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_lib_Xss_XScreenSaverQueryInfo=no fi rm -f conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi echo "$as_me:$LINENO: result: $ac_cv_lib_Xss_XScreenSaverQueryInfo" >&5 echo "${ECHO_T}$ac_cv_lib_Xss_XScreenSaverQueryInfo" >&6 if test $ac_cv_lib_Xss_XScreenSaverQueryInfo = yes; then if test "$tcl_cv_ld_weak_l" = yes; then # On Darwin, weak link libXss if possible, # as it is only available on Tiger or later. XLIBSW="$XLIBSW -Wl,-weak-lXss -lXext" else XLIBSW="$XLIBSW -lXss -lXext" fi xss_lib_found=yes fi fi fi fi if test $enable_xss = yes -a $xss_lib_found = yes -a $xss_header_found = yes; then cat >>confdefs.h <<\_ACEOF #define HAVE_XSS 1 _ACEOF fi CFLAGS=$tk_oldCFlags LIBS=$tk_oldLibs fi #-------------------------------------------------------------------- # Figure out whether "char" is unsigned. If so, set a # #define for __CHAR_UNSIGNED__. #-------------------------------------------------------------------- echo "$as_me:$LINENO: checking whether char is unsigned" >&5 echo $ECHO_N "checking whether char is unsigned... $ECHO_C" >&6 if test "${ac_cv_c_char_unsigned+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ $ac_includes_default int main () { static int test_array [1 - 2 * !(((char) -1) < 0)]; test_array [0] = 0 ; return 0; } _ACEOF rm -f conftest.$ac_objext if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 (eval $ac_compile) 2>conftest.er1 ac_status=$? grep -v '^ *+' conftest.er1 >conftest.err rm -f conftest.er1 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; } && { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then ac_cv_c_char_unsigned=no else echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_cv_c_char_unsigned=yes fi rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_c_char_unsigned" >&5 echo "${ECHO_T}$ac_cv_c_char_unsigned" >&6 if test $ac_cv_c_char_unsigned = yes && test "$GCC" != yes; then cat >>confdefs.h <<\_ACEOF #define __CHAR_UNSIGNED__ 1 _ACEOF fi #-------------------------------------------------------------------- # The statements below define a collection of symbols related to # building libtk as a shared library instead of a static library. #-------------------------------------------------------------------- eval eval "TK_UNSHARED_LIB_SUFFIX=${UNSHARED_LIB_SUFFIX}" eval eval "TK_SHARED_LIB_SUFFIX=${SHARED_LIB_SUFFIX}" eval "TK_LIB_FILE=libtk${LIB_SUFFIX}" # tkConfig.sh needs a version of the _LIB_SUFFIX that has been eval'ed # since on some platforms TK_LIB_FILE contains shell escapes. eval "TK_LIB_FILE=${TK_LIB_FILE}" if test "${SHARED_BUILD}" = "1" -a "${SHLIB_SUFFIX}" != ""; then SHLIB_LD_LIBS="${SHLIB_LD_LIBS} \${TCL_STUB_LIB_SPEC}" TCL_STUB_FLAGS="-DUSE_TCL_STUBS" fi TK_LIBRARY='$(prefix)/lib/tk$(VERSION)' PRIVATE_INCLUDE_DIR='$(includedir)' HTML_DIR='$(DISTDIR)/html' TK_PKG_DIR='tk$(VERSION)' TK_RSRC_FILE='tk$(VERSION).rsrc' WISH_RSRC_FILE='wish$(VERSION).rsrc' # Note: in the following variable, it's important to use the absolute # path name of the Tcl directory rather than "..": this is because # AIX remembers this path and will attempt to use it at run-time to look # up the Tcl library. if test "`uname -s`" = "Darwin" ; then if test "`uname -s`" = "Darwin" ; then echo "$as_me:$LINENO: checking how to package libraries" >&5 echo $ECHO_N "checking how to package libraries... $ECHO_C" >&6 # Check whether --enable-framework or --disable-framework was given. if test "${enable_framework+set}" = set; then enableval="$enable_framework" enable_framework=$enableval else enable_framework=no fi; if test $enable_framework = yes; then if test $SHARED_BUILD = 0; then { echo "$as_me:$LINENO: WARNING: Frameworks can only be built if --enable-shared is yes" >&5 echo "$as_me: WARNING: Frameworks can only be built if --enable-shared is yes" >&2;} enable_framework=no fi if test $tcl_corefoundation = no; then { echo "$as_me:$LINENO: WARNING: Frameworks can only be used when CoreFoundation is available" >&5 echo "$as_me: WARNING: Frameworks can only be used when CoreFoundation is available" >&2;} enable_framework=no fi fi if test $enable_framework = yes; then echo "$as_me:$LINENO: result: framework" >&5 echo "${ECHO_T}framework" >&6 FRAMEWORK_BUILD=1 else if test $SHARED_BUILD = 1; then echo "$as_me:$LINENO: result: shared library" >&5 echo "${ECHO_T}shared library" >&6 else echo "$as_me:$LINENO: result: static library" >&5 echo "${ECHO_T}static library" >&6 fi FRAMEWORK_BUILD=0 fi fi TK_SHLIB_LD_EXTRAS="-compatibility_version ${TK_VERSION} -current_version ${TK_VERSION}`echo ${TK_PATCH_LEVEL} | awk '{match($0, "\\\.[0-9]+"); print substr($0,RSTART,RLENGTH)}'`" TK_SHLIB_LD_EXTRAS="${TK_SHLIB_LD_EXTRAS}"' -install_name "${DYLIB_INSTALL_DIR}/${TK_LIB_FILE}" -unexported_symbols_list $$(f=$(TK_LIB_FILE).E && nm -gp tkMacOSX*.o 2>/dev/null | awk "/^[0-9a-f]+ . \.objc/ {print \$$3}" > $$f && nm -gjp "$(TCL_BIN_DIR)"/$(TCL_STUB_LIB_FILE) | grep ^_[^_] >> $$f && echo $$f)' echo "$LDFLAGS " | grep -q -- '-prebind ' && TK_SHLIB_LD_EXTRAS="${TK_SHLIB_LD_EXTRAS}"' -seg1addr 0xb000000' TK_SHLIB_LD_EXTRAS="${TK_SHLIB_LD_EXTRAS}"' -sectcreate __TEXT __info_plist Tk-Info.plist' EXTRA_WISH_LIBS='-sectcreate __TEXT __info_plist Wish-Info.plist' EXTRA_APP_CC_SWITCHES="${EXTRA_APP_CC_SWITCHES}"' -mdynamic-no-pic' ac_config_files="$ac_config_files Tk-Info.plist:../macosx/Tk-Info.plist.in Wish-Info.plist:../macosx/Wish-Info.plist.in" for l in ${LOCALES}; do CFBUNDLELOCALIZATIONS="${CFBUNDLELOCALIZATIONS}$l"; done TK_YEAR="`date +%Y`" fi if test "$FRAMEWORK_BUILD" = "1" ; then cat >>confdefs.h <<\_ACEOF #define TK_FRAMEWORK 1 _ACEOF # Construct a fake local framework structure to make linking with # '-framework Tk' and running of tktest work ac_config_commands="$ac_config_commands Tk.framework" LD_LIBRARY_PATH_VAR="DYLD_FRAMEWORK_PATH" if test "${libdir}" = '${exec_prefix}/lib'; then # override libdir default libdir="/Library/Frameworks" fi TK_LIB_FILE="Tk" TK_LIB_FLAG="-framework Tk" TK_BUILD_LIB_SPEC="-F`pwd | sed -e 's/ /\\\\ /g'` -framework Tk" TK_LIB_SPEC="-F${libdir} -framework Tk" libdir="${libdir}/Tk.framework/Versions/\${VERSION}" TK_LIBRARY="${libdir}/Resources/Scripts" TK_PKG_DIR="Resources/Scripts" TK_RSRC_FILE="Tk.rsrc" WISH_RSRC_FILE="Wish.rsrc" includedir="${libdir}/Headers" PRIVATE_INCLUDE_DIR="${libdir}/PrivateHeaders" HTML_DIR="${libdir}/Resources/Documentation/Reference/Tk" EXTRA_INSTALL="install-private-headers html-tk" EXTRA_BUILD_HTML='@ln -fs contents.htm "$(HTML_INSTALL_DIR)"/TkTOC.html' EXTRA_INSTALL_BINARIES='@echo "Installing Info.plist to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA_DIR) "$(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) Tk-Info.plist "$(LIB_INSTALL_DIR)/Resources/Info.plist"' EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing license.terms to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA) "$(TOP_DIR)/license.terms" "$(LIB_INSTALL_DIR)/Resources"' if test $tk_aqua = yes; then EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing Images to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA_DIR) "$(LIB_INSTALL_DIR)/Resources" && for i in Tk.tiff Tk.icns; do $(INSTALL_DATA) "$(MAC_OSX_DIR)/$$i" "$(LIB_INSTALL_DIR)/Resources"; done' EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing wish$(VERSION) script to $(INSTALL_ROOT)/'"${bindir}"'/" && $(INSTALL_DATA_DIR) "$(INSTALL_ROOT)/'"${bindir}"'" && printf > "$(INSTALL_ROOT)/'"${bindir}"'/wish$(VERSION)" "#!/bin/sh\n\"\$$(dirname \$$0)'"`eval d="${bindir}"; echo "$d" | sed -e 's#/[^/][^/]*#/..#g'`"'$(bindir)/Wish\" \"\$$@\"" && chmod +x "$(INSTALL_ROOT)/'"${bindir}"'/wish$(VERSION)"' bindir="${libdir}/Resources/Wish.app/Contents/MacOS" EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing Info.plist to $(BIN_INSTALL_DIR)/.." && $(INSTALL_DATA) Wish-Info.plist "$(BIN_INSTALL_DIR)/../Info.plist" && mv -f "$(BIN_INSTALL_DIR)/wish$(VERSION)" "$(BIN_INSTALL_DIR)/Wish"' EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing Wish.icns to $(BIN_INSTALL_DIR)/../Resources" && $(INSTALL_DATA_DIR) "$(BIN_INSTALL_DIR)/../Resources"' EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && $(INSTALL_DATA) "$(MAC_OSX_DIR)/Tk.icns" "$(BIN_INSTALL_DIR)/../Resources/Wish.icns"' EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing Wish.sdef to $(BIN_INSTALL_DIR)/../Resources" && $(INSTALL_DATA) "$(MAC_OSX_DIR)/Wish.sdef" "$(BIN_INSTALL_DIR)/../Resources"' fi EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Finalizing Tk.framework" && rm -f "$(LIB_INSTALL_DIR)/../Current" && ln -s "$(VERSION)" "$(LIB_INSTALL_DIR)/../Current" && for f in "$(LIB_FILE)" tkConfig.sh Resources Headers PrivateHeaders; do rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/Current/$$f" "$(LIB_INSTALL_DIR)/../.."; done && f="$(STUB_LIB_FILE)" && rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/$(VERSION)/$$f" "$(LIB_INSTALL_DIR)/../.."' # Don't use AC_DEFINE for the following as the framework version define # needs to go into the Makefile even when using autoheader, so that we # can pick up a potential make override of VERSION. Also, don't put this # into CFLAGS as it should not go into tkConfig.sh EXTRA_CC_SWITCHES="$EXTRA_CC_SWITCHES"' -DTK_FRAMEWORK_VERSION=\"$(VERSION)\"' else if test $tk_aqua = yes; then EXTRA_INSTALL_BINARIES='@echo "Installing Images to $(LIB_INSTALL_DIR)/" && $(INSTALL_DATA_DIR) "$(LIB_INSTALL_DIR)" && for i in Tk.tiff Tk.icns; do $(INSTALL_DATA) "$(MAC_OSX_DIR)/$$i" "$(LIB_INSTALL_DIR)"; done' fi # libdir must be a fully qualified path and not ${exec_prefix}/lib eval libdir="$libdir" if test "${ac_cv_cygwin}" = "yes" -a "$SHARED_BUILD" = "1"; then TK_LIB_FLAG="-ltk`echo ${TK_VERSION} | tr -d .`" TK_BUILD_LIB_SPEC="-L\$(TOP_DIR)/win ${TK_LIB_FLAG}" else if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then TK_LIB_FLAG="-ltk${TK_VERSION}" else TK_LIB_FLAG="-ltk`echo ${TK_VERSION} | tr -d .`" fi TK_BUILD_LIB_SPEC="-L`pwd | sed -e 's/ /\\\\ /g'` ${TK_LIB_FLAG}" fi TK_LIB_SPEC="-L${libdir} ${TK_LIB_FLAG}" fi #-------------------------------------------------------------------- # The statements below define various symbols relating to Tk # stub support. #-------------------------------------------------------------------- # Replace ${VERSION} with contents of ${TK_VERSION} eval "TK_STUB_LIB_FILE=libtkstub${TK_UNSHARED_LIB_SUFFIX}" eval "TK_STUB_LIB_DIR=${libdir}" if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then TK_STUB_LIB_FLAG="-ltkstub${TK_VERSION}" else TK_STUB_LIB_FLAG="-ltkstub`echo ${TK_VERSION} | tr -d .`" fi TK_BUILD_STUB_LIB_SPEC="-L`pwd | sed -e 's/ /\\\\ /g'` ${TK_STUB_LIB_FLAG}" TK_STUB_LIB_SPEC="-L${TK_STUB_LIB_DIR} ${TK_STUB_LIB_FLAG}" TK_BUILD_STUB_LIB_PATH="`pwd`/${TK_STUB_LIB_FILE}" TK_STUB_LIB_PATH="${TK_STUB_LIB_DIR}/${TK_STUB_LIB_FILE}" # Install time header dir can be set via --includedir eval "TK_INCLUDE_SPEC=\"-I${includedir}\"" #------------------------------------------------------------------------ # tkConfig.sh refers to this by a different name #------------------------------------------------------------------------ TK_SHARED_BUILD=${SHARED_BUILD} ac_config_files="$ac_config_files Makefile:../unix/Makefile.in tkConfig.sh:../unix/tkConfig.sh.in tk.pc:../unix/tk.pc.in" cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure # tests run on this system so they can be shared between configure # scripts and configure runs, see configure's option --config-cache. # It is not useful on other systems. If it contains results you don't # want to keep, you may remove or edit it. # # config.status only pays attention to the cache file if you give it # the --recheck option to rerun configure. # # `ac_cv_env_foo' variables (set or unset) will be overridden when # loading this file, other *unset* `ac_cv_foo' will be assigned the # following values. _ACEOF # The following way of writing the cache mishandles newlines in values, # but we know of no workaround that is simple, portable, and efficient. # So, don't put newlines in cache variables' values. # Ultrix sh set writes to stderr and can't be redirected directly, # and sets the high bit in the cache file unless we assign to the vars. { (set) 2>&1 | case `(ac_space=' '; set | grep ac_space) 2>&1` in *ac_space=\ *) # `set' does not quote correctly, so add quotes (double-quote # substitution turns \\\\ into \\, and sed turns \\ into \). sed -n \ "s/'/'\\\\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" ;; *) # `set' quotes correctly as required by POSIX, so do not add quotes. sed -n \ "s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p" ;; esac; } | sed ' t clear : clear s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/ t end /^ac_cv_env/!s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ : end' >>confcache if diff $cache_file confcache >/dev/null 2>&1; then :; else if test -w $cache_file; then test "x$cache_file" != "x/dev/null" && echo "updating cache $cache_file" cat confcache >$cache_file else echo "not updating unwritable cache $cache_file" fi fi rm -f confcache test "x$prefix" = xNONE && prefix=$ac_default_prefix # Let make expand exec_prefix. test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' # VPATH may cause trouble with some makes, so we remove $(srcdir), # ${srcdir} and @srcdir@ from VPATH if srcdir is ".", strip leading and # trailing colons and then remove the whole line if VPATH becomes empty # (actually we leave an empty line to preserve line numbers). if test "x$srcdir" = x.; then ac_vpsub='/^[ ]*VPATH[ ]*=/{ s/:*\$(srcdir):*/:/; s/:*\${srcdir}:*/:/; s/:*@srcdir@:*/:/; s/^\([^=]*=[ ]*\):*/\1/; s/:*$//; s/^[^=]*=[ ]*$//; }' fi # Transform confdefs.h into DEFS. # Protect against shell expansion while executing Makefile rules. # Protect against Makefile macro expansion. # # If the first sed substitution is executed (which looks for macros that # take arguments), then we branch to the quote section. Otherwise, # look for a macro that doesn't take arguments. cat >confdef2opt.sed <<\_ACEOF t clear : clear s,^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\),-D\1=\2,g t quote s,^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\),-D\1=\2,g t quote d : quote s,[ `~#$^&*(){}\\|;'"<>?],\\&,g s,\[,\\&,g s,\],\\&,g s,\$,$$,g p _ACEOF # We use echo to avoid assuming a particular line-breaking character. # The extra dot is to prevent the shell from consuming trailing # line-breaks from the sub-command output. A line-break within # single-quotes doesn't work because, if this script is created in a # platform that uses two characters for line-breaks (e.g., DOS), tr # would break. ac_LF_and_DOT=`echo; echo .` DEFS=`sed -n -f confdef2opt.sed confdefs.h | tr "$ac_LF_and_DOT" ' .'` rm -f confdef2opt.sed ac_libobjs= ac_ltlibobjs= for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue # 1. Remove the extension, and $U if already installed. ac_i=`echo "$ac_i" | sed 's/\$U\././;s/\.o$//;s/\.obj$//'` # 2. Add them. ac_libobjs="$ac_libobjs $ac_i\$U.$ac_objext" ac_ltlibobjs="$ac_ltlibobjs $ac_i"'$U.lo' done LIBOBJS=$ac_libobjs LTLIBOBJS=$ac_ltlibobjs CFLAGS="${CFLAGS} ${CPPFLAGS}"; CPPFLAGS="" : ${CONFIG_STATUS=./config.status} ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files $CONFIG_STATUS" { echo "$as_me:$LINENO: creating $CONFIG_STATUS" >&5 echo "$as_me: creating $CONFIG_STATUS" >&6;} cat >$CONFIG_STATUS <<_ACEOF #! $SHELL # Generated by $as_me. # Run this file to recreate the current configuration. # Compiler output produced by configure, useful for debugging # configure, is in config.log if it exists. debug=false ac_cs_recheck=false ac_cs_silent=false SHELL=\${CONFIG_SHELL-$SHELL} _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF ## --------------------- ## ## M4sh Initialization. ## ## --------------------- ## # Be Bourne compatible if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then emulate sh NULLCMD=: # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' elif test -n "${BASH_VERSION+set}" && (set -o posix) >/dev/null 2>&1; then set -o posix fi DUALCASE=1; export DUALCASE # for MKS sh # Support unset when possible. if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then as_unset=unset else as_unset=false fi # Work around bugs in pre-3.0 UWIN ksh. $as_unset ENV MAIL MAILPATH PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. for as_var in \ LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \ LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \ LC_TELEPHONE LC_TIME do if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then eval $as_var=C; export $as_var else $as_unset $as_var fi done # Required to use basename. if expr a : '\(a\)' >/dev/null 2>&1; then as_expr=expr else as_expr=false fi if (basename /) >/dev/null 2>&1 && test "X`basename / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi # Name of the executable. as_me=`$as_basename "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)$' \| \ . : '\(.\)' 2>/dev/null || echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/; q; } /^X\/\(\/\/\)$/{ s//\1/; q; } /^X\/\(\/\).*/{ s//\1/; q; } s/.*/./; q'` # PATH needs CR, and LINENO needs CR and PATH. # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then echo "#! /bin/sh" >conf$$.sh echo "exit 0" >>conf$$.sh chmod +x conf$$.sh if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then PATH_SEPARATOR=';' else PATH_SEPARATOR=: fi rm -f conf$$.sh fi as_lineno_1=$LINENO as_lineno_2=$LINENO as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null` test "x$as_lineno_1" != "x$as_lineno_2" && test "x$as_lineno_3" = "x$as_lineno_2" || { # Find who we are. Look in the path if we contain no path at all # relative or not. case $0 in *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break done ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then { { echo "$as_me:$LINENO: error: cannot find myself; rerun with an absolute path" >&5 echo "$as_me: error: cannot find myself; rerun with an absolute path" >&2;} { (exit 1); exit 1; }; } fi case $CONFIG_SHELL in '') as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for as_base in sh bash ksh sh5; do case $as_dir in /*) if ("$as_dir/$as_base" -c ' as_lineno_1=$LINENO as_lineno_2=$LINENO as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null` test "x$as_lineno_1" != "x$as_lineno_2" && test "x$as_lineno_3" = "x$as_lineno_2" ') 2>/dev/null; then $as_unset BASH_ENV || test "${BASH_ENV+set}" != set || { BASH_ENV=; export BASH_ENV; } $as_unset ENV || test "${ENV+set}" != set || { ENV=; export ENV; } CONFIG_SHELL=$as_dir/$as_base export CONFIG_SHELL exec "$CONFIG_SHELL" "$0" ${1+"$@"} fi;; esac done done ;; esac # Create $as_me.lineno as a copy of $as_myself, but with $LINENO # uniformly replaced by the line number. The first 'sed' inserts a # line-number line before each line; the second 'sed' does the real # work. The second script uses 'N' to pair each line-number line # with the numbered line, and appends trailing '-' during # substitution so that $LINENO is not a special case at line end. # (Raja R Harinath suggested sed '=', and Paul Eggert wrote the # second 'sed' script. Blame Lee E. McMahon for sed's syntax. :-) sed '=' <$as_myself | sed ' N s,$,-, : loop s,^\(['$as_cr_digits']*\)\(.*\)[$]LINENO\([^'$as_cr_alnum'_]\),\1\2\1\3, t loop s,-$,, s,^['$as_cr_digits']*\n,, ' >$as_me.lineno && chmod +x $as_me.lineno || { { echo "$as_me:$LINENO: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&5 echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2;} { (exit 1); exit 1; }; } # Don't try to exec as it changes $[0], causing all sort of problems # (the dirname of $[0] is not the place where we might find the # original and so on. Autoconf is especially sensible to this). . ./$as_me.lineno # Exit status is that of the last command. exit } case `echo "testing\c"; echo 1,2,3`,`echo -n testing; echo 1,2,3` in *c*,-n*) ECHO_N= ECHO_C=' ' ECHO_T=' ' ;; *c*,* ) ECHO_N=-n ECHO_C= ECHO_T= ;; *) ECHO_N= ECHO_C='\c' ECHO_T= ;; esac if expr a : '\(a\)' >/dev/null 2>&1; then as_expr=expr else as_expr=false fi rm -f conf$$ conf$$.exe conf$$.file echo >conf$$.file if ln -s conf$$.file conf$$ 2>/dev/null; then # We could just check for DJGPP; but this test a) works b) is more generic # and c) will remain valid once DJGPP supports symlinks (DJGPP 2.04). if test -f conf$$.exe; then # Don't use ln at all; we don't have any links as_ln_s='cp -p' else as_ln_s='ln -s' fi elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -p' fi rm -f conf$$ conf$$.exe conf$$.file if mkdir -p . 2>/dev/null; then as_mkdir_p=: else test -d ./-p && rmdir ./-p as_mkdir_p=false fi as_executable_p="test -f" # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" # IFS # We need space, tab and new line, in precisely that order. as_nl=' ' IFS=" $as_nl" # CDPATH. $as_unset CDPATH exec 6>&1 # Open the log real soon, to keep \$[0] and so on meaningful, and to # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. Logging --version etc. is OK. exec 5>>config.log { echo sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX ## Running $as_me. ## _ASBOX } >&5 cat >&5 <<_CSEOF This file was extended by tk $as_me 8.6, which was generated by GNU Autoconf 2.59. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS CONFIG_LINKS = $CONFIG_LINKS CONFIG_COMMANDS = $CONFIG_COMMANDS $ $0 $@ _CSEOF echo "on `(hostname || uname -n) 2>/dev/null | sed 1q`" >&5 echo >&5 _ACEOF # Files that config.status was made for. if test -n "$ac_config_files"; then echo "config_files=\"$ac_config_files\"" >>$CONFIG_STATUS fi if test -n "$ac_config_headers"; then echo "config_headers=\"$ac_config_headers\"" >>$CONFIG_STATUS fi if test -n "$ac_config_links"; then echo "config_links=\"$ac_config_links\"" >>$CONFIG_STATUS fi if test -n "$ac_config_commands"; then echo "config_commands=\"$ac_config_commands\"" >>$CONFIG_STATUS fi cat >>$CONFIG_STATUS <<\_ACEOF ac_cs_usage="\ \`$as_me' instantiates files from templates according to the current configuration. Usage: $0 [OPTIONS] [FILE]... -h, --help print this help, then exit -V, --version print version number, then exit -q, --quiet do not print progress messages -d, --debug don't remove temporary files --recheck update $as_me by reconfiguring in the same conditions --file=FILE[:TEMPLATE] instantiate the configuration file FILE Configuration files: $config_files Configuration commands: $config_commands Report bugs to ." _ACEOF cat >>$CONFIG_STATUS <<_ACEOF ac_cs_version="\\ tk config.status 8.6 configured by $0, generated by GNU Autoconf 2.59, with options \\"`echo "$ac_configure_args" | sed 's/[\\""\`\$]/\\\\&/g'`\\" Copyright (C) 2003 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." srcdir=$srcdir _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF # If no file are specified by the user, then we need to provide default # value. By we need to know if files were specified by the user. ac_need_defaults=: while test $# != 0 do case $1 in --*=*) ac_option=`expr "x$1" : 'x\([^=]*\)='` ac_optarg=`expr "x$1" : 'x[^=]*=\(.*\)'` ac_shift=: ;; -*) ac_option=$1 ac_optarg=$2 ac_shift=shift ;; *) # This is not an option, so the user has probably given explicit # arguments. ac_option=$1 ac_need_defaults=false;; esac case $ac_option in # Handling of the options. _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) ac_cs_recheck=: ;; --version | --vers* | -V ) echo "$ac_cs_version"; exit 0 ;; --he | --h) # Conflict between --help and --header { { echo "$as_me:$LINENO: error: ambiguous option: $1 Try \`$0 --help' for more information." >&5 echo "$as_me: error: ambiguous option: $1 Try \`$0 --help' for more information." >&2;} { (exit 1); exit 1; }; };; --help | --hel | -h ) echo "$ac_cs_usage"; exit 0 ;; --debug | --d* | -d ) debug=: ;; --file | --fil | --fi | --f ) $ac_shift CONFIG_FILES="$CONFIG_FILES $ac_optarg" ac_need_defaults=false;; --header | --heade | --head | --hea ) $ac_shift CONFIG_HEADERS="$CONFIG_HEADERS $ac_optarg" ac_need_defaults=false;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil | --si | --s) ac_cs_silent=: ;; # This is an error. -*) { { echo "$as_me:$LINENO: error: unrecognized option: $1 Try \`$0 --help' for more information." >&5 echo "$as_me: error: unrecognized option: $1 Try \`$0 --help' for more information." >&2;} { (exit 1); exit 1; }; } ;; *) ac_config_targets="$ac_config_targets $1" ;; esac shift done ac_configure_extra_args= if $ac_cs_silent; then exec 6>/dev/null ac_configure_extra_args="$ac_configure_extra_args --silent" fi _ACEOF cat >>$CONFIG_STATUS <<_ACEOF if \$ac_cs_recheck; then echo "running $SHELL $0 " $ac_configure_args \$ac_configure_extra_args " --no-create --no-recursion" >&6 exec $SHELL $0 $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion fi _ACEOF cat >>$CONFIG_STATUS <<_ACEOF # # INIT-COMMANDS section. # VERSION=${TK_VERSION} && tk_aqua=${tk_aqua} _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF for ac_config_target in $ac_config_targets do case "$ac_config_target" in # Handling of arguments. "Tk-Info.plist" ) CONFIG_FILES="$CONFIG_FILES Tk-Info.plist:../macosx/Tk-Info.plist.in" ;; "Wish-Info.plist" ) CONFIG_FILES="$CONFIG_FILES Wish-Info.plist:../macosx/Wish-Info.plist.in" ;; "Makefile" ) CONFIG_FILES="$CONFIG_FILES Makefile:../unix/Makefile.in" ;; "tkConfig.sh" ) CONFIG_FILES="$CONFIG_FILES tkConfig.sh:../unix/tkConfig.sh.in" ;; "tk.pc" ) CONFIG_FILES="$CONFIG_FILES tk.pc:../unix/tk.pc.in" ;; "Tk.framework" ) CONFIG_COMMANDS="$CONFIG_COMMANDS Tk.framework" ;; *) { { echo "$as_me:$LINENO: error: invalid argument: $ac_config_target" >&5 echo "$as_me: error: invalid argument: $ac_config_target" >&2;} { (exit 1); exit 1; }; };; esac done # If the user did not use the arguments to specify the items to instantiate, # then the envvar interface is used. Set only those that are not. # We use the long form for the default assignment because of an extremely # bizarre bug on SunOS 4.1.3. if $ac_need_defaults; then test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files test "${CONFIG_COMMANDS+set}" = set || CONFIG_COMMANDS=$config_commands fi # Have a temporary directory for convenience. Make it in the build tree # simply because there is no reason to put it here, and in addition, # creating and moving files from /tmp can sometimes cause problems. # Create a temporary directory, and hook for its removal unless debugging. $debug || { trap 'exit_status=$?; rm -rf $tmp && exit $exit_status' 0 trap '{ (exit 1); exit 1; }' 1 2 13 15 } # Create a (secure) tmp directory for tmp files. { tmp=`(umask 077 && mktemp -d -q "./confstatXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" } || { tmp=./confstat$$-$RANDOM (umask 077 && mkdir $tmp) } || { echo "$me: cannot create a temporary directory in ." >&2 { (exit 1); exit 1; } } _ACEOF cat >>$CONFIG_STATUS <<_ACEOF # # CONFIG_FILES section. # # No need to generate the scripts if there are no CONFIG_FILES. # This happens for instance when ./config.status config.h if test -n "\$CONFIG_FILES"; then # Protect against being on the right side of a sed subst in config.status. sed 's/,@/@@/; s/@,/@@/; s/,;t t\$/@;t t/; /@;t t\$/s/[\\\\&,]/\\\\&/g; s/@@/,@/; s/@@/@,/; s/@;t t\$/,;t t/' >\$tmp/subs.sed <<\\CEOF s,@SHELL@,$SHELL,;t t s,@PATH_SEPARATOR@,$PATH_SEPARATOR,;t t s,@PACKAGE_NAME@,$PACKAGE_NAME,;t t s,@PACKAGE_TARNAME@,$PACKAGE_TARNAME,;t t s,@PACKAGE_VERSION@,$PACKAGE_VERSION,;t t s,@PACKAGE_STRING@,$PACKAGE_STRING,;t t s,@PACKAGE_BUGREPORT@,$PACKAGE_BUGREPORT,;t t s,@exec_prefix@,$exec_prefix,;t t s,@prefix@,$prefix,;t t s,@program_transform_name@,$program_transform_name,;t t s,@bindir@,$bindir,;t t s,@sbindir@,$sbindir,;t t s,@libexecdir@,$libexecdir,;t t s,@datadir@,$datadir,;t t s,@sysconfdir@,$sysconfdir,;t t s,@sharedstatedir@,$sharedstatedir,;t t s,@localstatedir@,$localstatedir,;t t s,@libdir@,$libdir,;t t s,@includedir@,$includedir,;t t s,@oldincludedir@,$oldincludedir,;t t s,@infodir@,$infodir,;t t s,@mandir@,$mandir,;t t s,@build_alias@,$build_alias,;t t s,@host_alias@,$host_alias,;t t s,@target_alias@,$target_alias,;t t s,@DEFS@,$DEFS,;t t s,@ECHO_C@,$ECHO_C,;t t s,@ECHO_N@,$ECHO_N,;t t s,@ECHO_T@,$ECHO_T,;t t s,@LIBS@,$LIBS,;t t s,@TCL_VERSION@,$TCL_VERSION,;t t s,@TCL_PATCH_LEVEL@,$TCL_PATCH_LEVEL,;t t s,@TCL_BIN_DIR@,$TCL_BIN_DIR,;t t s,@TCL_SRC_DIR@,$TCL_SRC_DIR,;t t s,@TCL_LIB_FILE@,$TCL_LIB_FILE,;t t s,@TCL_LIB_FLAG@,$TCL_LIB_FLAG,;t t s,@TCL_LIB_SPEC@,$TCL_LIB_SPEC,;t t s,@TCL_STUB_LIB_FILE@,$TCL_STUB_LIB_FILE,;t t s,@TCL_STUB_LIB_FLAG@,$TCL_STUB_LIB_FLAG,;t t s,@TCL_STUB_LIB_SPEC@,$TCL_STUB_LIB_SPEC,;t t s,@TCLSH_PROG@,$TCLSH_PROG,;t t s,@BUILD_TCLSH@,$BUILD_TCLSH,;t t s,@MAN_FLAGS@,$MAN_FLAGS,;t t s,@CC@,$CC,;t t s,@CFLAGS@,$CFLAGS,;t t s,@LDFLAGS@,$LDFLAGS,;t t s,@CPPFLAGS@,$CPPFLAGS,;t t s,@ac_ct_CC@,$ac_ct_CC,;t t s,@EXEEXT@,$EXEEXT,;t t s,@OBJEXT@,$OBJEXT,;t t s,@CPP@,$CPP,;t t s,@EGREP@,$EGREP,;t t s,@TCL_THREADS@,$TCL_THREADS,;t t s,@RANLIB@,$RANLIB,;t t s,@ac_ct_RANLIB@,$ac_ct_RANLIB,;t t s,@AR@,$AR,;t t s,@ac_ct_AR@,$ac_ct_AR,;t t s,@LIBOBJS@,$LIBOBJS,;t t s,@TCL_LIBS@,$TCL_LIBS,;t t s,@DL_LIBS@,$DL_LIBS,;t t s,@DL_OBJS@,$DL_OBJS,;t t s,@PLAT_OBJS@,$PLAT_OBJS,;t t s,@PLAT_SRCS@,$PLAT_SRCS,;t t s,@LDAIX_SRC@,$LDAIX_SRC,;t t s,@CFLAGS_DEBUG@,$CFLAGS_DEBUG,;t t s,@CFLAGS_OPTIMIZE@,$CFLAGS_OPTIMIZE,;t t s,@CFLAGS_WARNING@,$CFLAGS_WARNING,;t t s,@LDFLAGS_DEBUG@,$LDFLAGS_DEBUG,;t t s,@LDFLAGS_OPTIMIZE@,$LDFLAGS_OPTIMIZE,;t t s,@CC_SEARCH_FLAGS@,$CC_SEARCH_FLAGS,;t t s,@LD_SEARCH_FLAGS@,$LD_SEARCH_FLAGS,;t t s,@STLIB_LD@,$STLIB_LD,;t t s,@SHLIB_LD@,$SHLIB_LD,;t t s,@TCL_SHLIB_LD_EXTRAS@,$TCL_SHLIB_LD_EXTRAS,;t t s,@TK_SHLIB_LD_EXTRAS@,$TK_SHLIB_LD_EXTRAS,;t t s,@SHLIB_LD_LIBS@,$SHLIB_LD_LIBS,;t t s,@SHLIB_CFLAGS@,$SHLIB_CFLAGS,;t t s,@SHLIB_SUFFIX@,$SHLIB_SUFFIX,;t t s,@MAKE_LIB@,$MAKE_LIB,;t t s,@MAKE_STUB_LIB@,$MAKE_STUB_LIB,;t t s,@INSTALL_LIB@,$INSTALL_LIB,;t t s,@DLL_INSTALL_DIR@,$DLL_INSTALL_DIR,;t t s,@INSTALL_STUB_LIB@,$INSTALL_STUB_LIB,;t t s,@CFLAGS_DEFAULT@,$CFLAGS_DEFAULT,;t t s,@LDFLAGS_DEFAULT@,$LDFLAGS_DEFAULT,;t t s,@XFT_CFLAGS@,$XFT_CFLAGS,;t t s,@XFT_LIBS@,$XFT_LIBS,;t t s,@UNIX_FONT_OBJS@,$UNIX_FONT_OBJS,;t t s,@TK_VERSION@,$TK_VERSION,;t t s,@TK_MAJOR_VERSION@,$TK_MAJOR_VERSION,;t t s,@TK_MINOR_VERSION@,$TK_MINOR_VERSION,;t t s,@TK_PATCH_LEVEL@,$TK_PATCH_LEVEL,;t t s,@TK_YEAR@,$TK_YEAR,;t t s,@TK_LIB_FILE@,$TK_LIB_FILE,;t t s,@TK_LIB_FLAG@,$TK_LIB_FLAG,;t t s,@TK_LIB_SPEC@,$TK_LIB_SPEC,;t t s,@TK_STUB_LIB_FILE@,$TK_STUB_LIB_FILE,;t t s,@TK_STUB_LIB_FLAG@,$TK_STUB_LIB_FLAG,;t t s,@TK_STUB_LIB_SPEC@,$TK_STUB_LIB_SPEC,;t t s,@TK_STUB_LIB_PATH@,$TK_STUB_LIB_PATH,;t t s,@TK_INCLUDE_SPEC@,$TK_INCLUDE_SPEC,;t t s,@TK_BUILD_STUB_LIB_SPEC@,$TK_BUILD_STUB_LIB_SPEC,;t t s,@TK_BUILD_STUB_LIB_PATH@,$TK_BUILD_STUB_LIB_PATH,;t t s,@TK_SRC_DIR@,$TK_SRC_DIR,;t t s,@TK_SHARED_BUILD@,$TK_SHARED_BUILD,;t t s,@LD_LIBRARY_PATH_VAR@,$LD_LIBRARY_PATH_VAR,;t t s,@TK_BUILD_LIB_SPEC@,$TK_BUILD_LIB_SPEC,;t t s,@TCL_STUB_FLAGS@,$TCL_STUB_FLAGS,;t t s,@XINCLUDES@,$XINCLUDES,;t t s,@XLIBSW@,$XLIBSW,;t t s,@LOCALES@,$LOCALES,;t t s,@TK_WINDOWINGSYSTEM@,$TK_WINDOWINGSYSTEM,;t t s,@TK_PKG_DIR@,$TK_PKG_DIR,;t t s,@TK_LIBRARY@,$TK_LIBRARY,;t t s,@LIB_RUNTIME_DIR@,$LIB_RUNTIME_DIR,;t t s,@PRIVATE_INCLUDE_DIR@,$PRIVATE_INCLUDE_DIR,;t t s,@HTML_DIR@,$HTML_DIR,;t t s,@EXTRA_CC_SWITCHES@,$EXTRA_CC_SWITCHES,;t t s,@EXTRA_APP_CC_SWITCHES@,$EXTRA_APP_CC_SWITCHES,;t t s,@EXTRA_INSTALL@,$EXTRA_INSTALL,;t t s,@EXTRA_INSTALL_BINARIES@,$EXTRA_INSTALL_BINARIES,;t t s,@EXTRA_BUILD_HTML@,$EXTRA_BUILD_HTML,;t t s,@EXTRA_WISH_LIBS@,$EXTRA_WISH_LIBS,;t t s,@CFBUNDLELOCALIZATIONS@,$CFBUNDLELOCALIZATIONS,;t t s,@TK_RSRC_FILE@,$TK_RSRC_FILE,;t t s,@WISH_RSRC_FILE@,$WISH_RSRC_FILE,;t t s,@LIB_RSRC_FILE@,$LIB_RSRC_FILE,;t t s,@APP_RSRC_FILE@,$APP_RSRC_FILE,;t t s,@REZ@,$REZ,;t t s,@REZ_FLAGS@,$REZ_FLAGS,;t t s,@LTLIBOBJS@,$LTLIBOBJS,;t t CEOF _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF # Split the substitutions into bite-sized pieces for seds with # small command number limits, like on Digital OSF/1 and HP-UX. ac_max_sed_lines=48 ac_sed_frag=1 # Number of current file. ac_beg=1 # First line for current file. ac_end=$ac_max_sed_lines # Line after last line for current file. ac_more_lines=: ac_sed_cmds= while $ac_more_lines; do if test $ac_beg -gt 1; then sed "1,${ac_beg}d; ${ac_end}q" $tmp/subs.sed >$tmp/subs.frag else sed "${ac_end}q" $tmp/subs.sed >$tmp/subs.frag fi if test ! -s $tmp/subs.frag; then ac_more_lines=false else # The purpose of the label and of the branching condition is to # speed up the sed processing (if there are no `@' at all, there # is no need to browse any of the substitutions). # These are the two extra sed commands mentioned above. (echo ':t /@[a-zA-Z_][a-zA-Z_0-9]*@/!b' && cat $tmp/subs.frag) >$tmp/subs-$ac_sed_frag.sed if test -z "$ac_sed_cmds"; then ac_sed_cmds="sed -f $tmp/subs-$ac_sed_frag.sed" else ac_sed_cmds="$ac_sed_cmds | sed -f $tmp/subs-$ac_sed_frag.sed" fi ac_sed_frag=`expr $ac_sed_frag + 1` ac_beg=$ac_end ac_end=`expr $ac_end + $ac_max_sed_lines` fi done if test -z "$ac_sed_cmds"; then ac_sed_cmds=cat fi fi # test -n "$CONFIG_FILES" _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF for ac_file in : $CONFIG_FILES; do test "x$ac_file" = x: && continue # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in". case $ac_file in - | *:- | *:-:* ) # input from stdin cat >$tmp/stdin ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'` ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;; *:* ) ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'` ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;; * ) ac_file_in=$ac_file.in ;; esac # Compute @srcdir@, @top_srcdir@, and @INSTALL@ for subdirectories. ac_dir=`(dirname "$ac_file") 2>/dev/null || $as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$ac_file" : 'X\(//\)[^/]' \| \ X"$ac_file" : 'X\(//\)$' \| \ X"$ac_file" : 'X\(/\)' \| \ . : '\(.\)' 2>/dev/null || echo X"$ac_file" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } /^X\(\/\/\)[^/].*/{ s//\1/; q; } /^X\(\/\/\)$/{ s//\1/; q; } /^X\(\/\).*/{ s//\1/; q; } s/.*/./; q'` { if $as_mkdir_p; then mkdir -p "$ac_dir" else as_dir="$ac_dir" as_dirs= while test ! -d "$as_dir"; do as_dirs="$as_dir $as_dirs" as_dir=`(dirname "$as_dir") 2>/dev/null || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| \ . : '\(.\)' 2>/dev/null || echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } /^X\(\/\/\)[^/].*/{ s//\1/; q; } /^X\(\/\/\)$/{ s//\1/; q; } /^X\(\/\).*/{ s//\1/; q; } s/.*/./; q'` done test ! -n "$as_dirs" || mkdir $as_dirs fi || { { echo "$as_me:$LINENO: error: cannot create directory \"$ac_dir\"" >&5 echo "$as_me: error: cannot create directory \"$ac_dir\"" >&2;} { (exit 1); exit 1; }; }; } ac_builddir=. if test "$ac_dir" != .; then ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'` # A "../" for each directory in $ac_dir_suffix. ac_top_builddir=`echo "$ac_dir_suffix" | sed 's,/[^\\/]*,../,g'` else ac_dir_suffix= ac_top_builddir= fi case $srcdir in .) # No --srcdir option. We are building in place. ac_srcdir=. if test -z "$ac_top_builddir"; then ac_top_srcdir=. else ac_top_srcdir=`echo $ac_top_builddir | sed 's,/$,,'` fi ;; [\\/]* | ?:[\\/]* ) # Absolute path. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ;; *) # Relative path. ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_builddir$srcdir ;; esac # Do not use `cd foo && pwd` to compute absolute paths, because # the directories may not exist. case `pwd` in .) ac_abs_builddir="$ac_dir";; *) case "$ac_dir" in .) ac_abs_builddir=`pwd`;; [\\/]* | ?:[\\/]* ) ac_abs_builddir="$ac_dir";; *) ac_abs_builddir=`pwd`/"$ac_dir";; esac;; esac case $ac_abs_builddir in .) ac_abs_top_builddir=${ac_top_builddir}.;; *) case ${ac_top_builddir}. in .) ac_abs_top_builddir=$ac_abs_builddir;; [\\/]* | ?:[\\/]* ) ac_abs_top_builddir=${ac_top_builddir}.;; *) ac_abs_top_builddir=$ac_abs_builddir/${ac_top_builddir}.;; esac;; esac case $ac_abs_builddir in .) ac_abs_srcdir=$ac_srcdir;; *) case $ac_srcdir in .) ac_abs_srcdir=$ac_abs_builddir;; [\\/]* | ?:[\\/]* ) ac_abs_srcdir=$ac_srcdir;; *) ac_abs_srcdir=$ac_abs_builddir/$ac_srcdir;; esac;; esac case $ac_abs_builddir in .) ac_abs_top_srcdir=$ac_top_srcdir;; *) case $ac_top_srcdir in .) ac_abs_top_srcdir=$ac_abs_builddir;; [\\/]* | ?:[\\/]* ) ac_abs_top_srcdir=$ac_top_srcdir;; *) ac_abs_top_srcdir=$ac_abs_builddir/$ac_top_srcdir;; esac;; esac if test x"$ac_file" != x-; then { echo "$as_me:$LINENO: creating $ac_file" >&5 echo "$as_me: creating $ac_file" >&6;} rm -f "$ac_file" fi # Let's still pretend it is `configure' which instantiates (i.e., don't # use $as_me), people would be surprised to read: # /* config.h. Generated by config.status. */ if test x"$ac_file" = x-; then configure_input= else configure_input="$ac_file. " fi configure_input=$configure_input"Generated from `echo $ac_file_in | sed 's,.*/,,'` by configure." # First look for the input files in the build tree, otherwise in the # src tree. ac_file_inputs=`IFS=: for f in $ac_file_in; do case $f in -) echo $tmp/stdin ;; [\\/$]*) # Absolute (can't be DOS-style, as IFS=:) test -f "$f" || { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5 echo "$as_me: error: cannot find input file: $f" >&2;} { (exit 1); exit 1; }; } echo "$f";; *) # Relative if test -f "$f"; then # Build tree echo "$f" elif test -f "$srcdir/$f"; then # Source tree echo "$srcdir/$f" else # /dev/null tree { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5 echo "$as_me: error: cannot find input file: $f" >&2;} { (exit 1); exit 1; }; } fi;; esac done` || { (exit 1); exit 1; } _ACEOF cat >>$CONFIG_STATUS <<_ACEOF sed "$ac_vpsub $extrasub _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF :t /@[a-zA-Z_][a-zA-Z_0-9]*@/!b s,@configure_input@,$configure_input,;t t s,@srcdir@,$ac_srcdir,;t t s,@abs_srcdir@,$ac_abs_srcdir,;t t s,@top_srcdir@,$ac_top_srcdir,;t t s,@abs_top_srcdir@,$ac_abs_top_srcdir,;t t s,@builddir@,$ac_builddir,;t t s,@abs_builddir@,$ac_abs_builddir,;t t s,@top_builddir@,$ac_top_builddir,;t t s,@abs_top_builddir@,$ac_abs_top_builddir,;t t " $ac_file_inputs | (eval "$ac_sed_cmds") >$tmp/out rm -f $tmp/stdin if test x"$ac_file" != x-; then mv $tmp/out $ac_file else cat $tmp/out rm -f $tmp/out fi done _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF # # CONFIG_COMMANDS section. # for ac_file in : $CONFIG_COMMANDS; do test "x$ac_file" = x: && continue ac_dest=`echo "$ac_file" | sed 's,:.*,,'` ac_source=`echo "$ac_file" | sed 's,[^:]*:,,'` ac_dir=`(dirname "$ac_dest") 2>/dev/null || $as_expr X"$ac_dest" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$ac_dest" : 'X\(//\)[^/]' \| \ X"$ac_dest" : 'X\(//\)$' \| \ X"$ac_dest" : 'X\(/\)' \| \ . : '\(.\)' 2>/dev/null || echo X"$ac_dest" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } /^X\(\/\/\)[^/].*/{ s//\1/; q; } /^X\(\/\/\)$/{ s//\1/; q; } /^X\(\/\).*/{ s//\1/; q; } s/.*/./; q'` { if $as_mkdir_p; then mkdir -p "$ac_dir" else as_dir="$ac_dir" as_dirs= while test ! -d "$as_dir"; do as_dirs="$as_dir $as_dirs" as_dir=`(dirname "$as_dir") 2>/dev/null || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| \ . : '\(.\)' 2>/dev/null || echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } /^X\(\/\/\)[^/].*/{ s//\1/; q; } /^X\(\/\/\)$/{ s//\1/; q; } /^X\(\/\).*/{ s//\1/; q; } s/.*/./; q'` done test ! -n "$as_dirs" || mkdir $as_dirs fi || { { echo "$as_me:$LINENO: error: cannot create directory \"$ac_dir\"" >&5 echo "$as_me: error: cannot create directory \"$ac_dir\"" >&2;} { (exit 1); exit 1; }; }; } ac_builddir=. if test "$ac_dir" != .; then ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'` # A "../" for each directory in $ac_dir_suffix. ac_top_builddir=`echo "$ac_dir_suffix" | sed 's,/[^\\/]*,../,g'` else ac_dir_suffix= ac_top_builddir= fi case $srcdir in .) # No --srcdir option. We are building in place. ac_srcdir=. if test -z "$ac_top_builddir"; then ac_top_srcdir=. else ac_top_srcdir=`echo $ac_top_builddir | sed 's,/$,,'` fi ;; [\\/]* | ?:[\\/]* ) # Absolute path. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ;; *) # Relative path. ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_builddir$srcdir ;; esac # Do not use `cd foo && pwd` to compute absolute paths, because # the directories may not exist. case `pwd` in .) ac_abs_builddir="$ac_dir";; *) case "$ac_dir" in .) ac_abs_builddir=`pwd`;; [\\/]* | ?:[\\/]* ) ac_abs_builddir="$ac_dir";; *) ac_abs_builddir=`pwd`/"$ac_dir";; esac;; esac case $ac_abs_builddir in .) ac_abs_top_builddir=${ac_top_builddir}.;; *) case ${ac_top_builddir}. in .) ac_abs_top_builddir=$ac_abs_builddir;; [\\/]* | ?:[\\/]* ) ac_abs_top_builddir=${ac_top_builddir}.;; *) ac_abs_top_builddir=$ac_abs_builddir/${ac_top_builddir}.;; esac;; esac case $ac_abs_builddir in .) ac_abs_srcdir=$ac_srcdir;; *) case $ac_srcdir in .) ac_abs_srcdir=$ac_abs_builddir;; [\\/]* | ?:[\\/]* ) ac_abs_srcdir=$ac_srcdir;; *) ac_abs_srcdir=$ac_abs_builddir/$ac_srcdir;; esac;; esac case $ac_abs_builddir in .) ac_abs_top_srcdir=$ac_top_srcdir;; *) case $ac_top_srcdir in .) ac_abs_top_srcdir=$ac_abs_builddir;; [\\/]* | ?:[\\/]* ) ac_abs_top_srcdir=$ac_top_srcdir;; *) ac_abs_top_srcdir=$ac_abs_builddir/$ac_top_srcdir;; esac;; esac { echo "$as_me:$LINENO: executing $ac_dest commands" >&5 echo "$as_me: executing $ac_dest commands" >&6;} case $ac_dest in Tk.framework ) n=Tk && f=$n.framework && v=Versions/$VERSION && rm -rf $f && mkdir -p $f/$v/Resources && ln -s $v/$n $v/Resources $f && ln -s ../../../$n $f/$v && ln -s ../../../../$n-Info.plist $f/$v/Resources/Info.plist && if test $tk_aqua = yes; then ln -s ../../../../$n.rsrc $f/$v/Resources; fi && unset n f v ;; esac done _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF { (exit 0); exit 0; } _ACEOF chmod +x $CONFIG_STATUS ac_clean_files=$ac_clean_files_save # configure is writing to config.log, and then calls config.status. # config.status does its own redirection, appending to config.log. # Unfortunately, on DOS this fails, as config.log is still kept open # by configure, so config.status won't be able to write to it; its # output is simply discarded. So we exec the FD to /dev/null, # effectively closing config.log, so it can be properly (re)opened and # appended to by config.status. When coming back to configure, we # need to make the FD available again. if test "$no_create" != yes; then ac_cs_success=: ac_config_status_args= test "$silent" = yes && ac_config_status_args="$ac_config_status_args --quiet" exec 5>/dev/null $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false exec 5>>config.log # Use ||, not &&, to avoid exiting from the if with $? = 1, which # would make configure fail if this is the last instruction. $ac_cs_success || { (exit 1); exit 1; } fi tk8.6.5/unix/license.terms0000644003604700454610000000433312665114121014151 0ustar dgp771divThis software is copyrighted by the Regents of the University of California, Sun Microsystems, Inc., Scriptics Corporation, ActiveState Corporation, Apple Inc. and other parties. The following terms apply to all files associated with the software unless explicitly disclaimed in individual files. The authors hereby grant permission to use, copy, modify, distribute, and license this software and its documentation for any purpose, provided that existing copyright notices are retained in all copies and that this notice is included verbatim in any distributions. No written agreement, license, or royalty fee is required for any of the authorized uses. Modifications to this software may be copyrighted by their authors and need not follow the licensing terms described here, provided that the new terms are clearly indicated on the first page of each file where they apply. IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. GOVERNMENT USE: If you are acquiring this software on behalf of the U.S. government, the Government shall have only "Restricted Rights" in the software and related documentation as defined in the Federal Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you are acquiring the software on behalf of the Department of Defense, the software shall be classified as "Commercial Computer Software" and the Government shall have only "Restricted Rights" as defined in Clause 252.227-7013 (b) (3) of DFARs. Notwithstanding the foregoing, the authors grant the U.S. Government and others acting in its behalf permission to use and distribute the software in accordance with the terms specified in this license. tk8.6.5/unix/tkUnixScale.c0000644003604700454610000005075212424454072014064 0ustar dgp771div/* * tkUnixScale.c -- * * This file implements the X specific portion of the scrollbar widget. * * Copyright (c) 1996 by Sun Microsystems, Inc. * Copyright (c) 1998-2000 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tkInt.h" #include "tkScale.h" /* * Forward declarations for functions defined later in this file: */ static void DisplayHorizontalScale(TkScale *scalePtr, Drawable drawable, XRectangle *drawnAreaPtr); static void DisplayHorizontalValue(TkScale *scalePtr, Drawable drawable, double value, int top); static void DisplayVerticalScale(TkScale *scalePtr, Drawable drawable, XRectangle *drawnAreaPtr); static void DisplayVerticalValue(TkScale *scalePtr, Drawable drawable, double value, int rightEdge); /* *---------------------------------------------------------------------- * * TkpCreateScale -- * * Allocate a new TkScale structure. * * Results: * Returns a newly allocated TkScale structure. * * Side effects: * None. * *---------------------------------------------------------------------- */ TkScale * TkpCreateScale( Tk_Window tkwin) { return ckalloc(sizeof(TkScale)); } /* *---------------------------------------------------------------------- * * TkpDestroyScale -- * * Destroy a TkScale structure. It's necessary to do this with * Tcl_EventuallyFree to allow the Tcl_Preserve(scalePtr) to work as * expected in TkpDisplayScale. (hobbs) * * Results: * None * * Side effects: * Memory is freed. * *---------------------------------------------------------------------- */ void TkpDestroyScale( TkScale *scalePtr) { Tcl_EventuallyFree(scalePtr, TCL_DYNAMIC); } /* *-------------------------------------------------------------- * * DisplayVerticalScale -- * * This function redraws the contents of a vertical scale window. It is * invoked as a do-when-idle handler, so it only runs when there's * nothing else for the application to do. * * Results: * There is no return value. If only a part of the scale needs to be * redrawn, then drawnAreaPtr is modified to reflect the area that was * actually modified. * * Side effects: * Information appears on the screen. * *-------------------------------------------------------------- */ static void DisplayVerticalScale( TkScale *scalePtr, /* Widget record for scale. */ Drawable drawable, /* Where to display scale (window or * pixmap). */ XRectangle *drawnAreaPtr) /* Initally contains area of window; if only a * part of the scale is redrawn, gets modified * to reflect the part of the window that was * redrawn. */ { Tk_Window tkwin = scalePtr->tkwin; int x, y, width, height, shadowWidth; double tickValue, tickInterval = scalePtr->tickInterval; Tk_3DBorder sliderBorder; /* * Display the information from left to right across the window. */ if (!(scalePtr->flags & REDRAW_OTHER)) { drawnAreaPtr->x = scalePtr->vertTickRightX; drawnAreaPtr->y = scalePtr->inset; drawnAreaPtr->width = scalePtr->vertTroughX + scalePtr->width + 2*scalePtr->borderWidth - scalePtr->vertTickRightX; drawnAreaPtr->height -= 2*scalePtr->inset; } Tk_Fill3DRectangle(tkwin, drawable, scalePtr->bgBorder, drawnAreaPtr->x, drawnAreaPtr->y, drawnAreaPtr->width, drawnAreaPtr->height, 0, TK_RELIEF_FLAT); if (scalePtr->flags & REDRAW_OTHER) { /* * Display the tick marks. */ if (tickInterval != 0) { double ticks, maxTicks; /* * Ensure that we will only draw enough of the tick values such * that they don't overlap */ ticks = fabs((scalePtr->toValue - scalePtr->fromValue) / tickInterval); maxTicks = (double) Tk_Height(tkwin) / (double) scalePtr->fontHeight; if (ticks > maxTicks) { tickInterval *= (ticks / maxTicks); } for (tickValue = scalePtr->fromValue; ; tickValue += tickInterval) { /* * The TkRoundToResolution call gets rid of accumulated * round-off errors, if any. */ tickValue = TkRoundToResolution(scalePtr, tickValue); if (scalePtr->toValue >= scalePtr->fromValue) { if (tickValue > scalePtr->toValue) { break; } } else { if (tickValue < scalePtr->toValue) { break; } } DisplayVerticalValue(scalePtr, drawable, tickValue, scalePtr->vertTickRightX); } } } /* * Display the value, if it is desired. */ if (scalePtr->showValue) { DisplayVerticalValue(scalePtr, drawable, scalePtr->value, scalePtr->vertValueRightX); } /* * Display the trough and the slider. */ Tk_Draw3DRectangle(tkwin, drawable, scalePtr->bgBorder, scalePtr->vertTroughX, scalePtr->inset, scalePtr->width + 2*scalePtr->borderWidth, Tk_Height(tkwin) - 2*scalePtr->inset, scalePtr->borderWidth, TK_RELIEF_SUNKEN); XFillRectangle(scalePtr->display, drawable, scalePtr->troughGC, scalePtr->vertTroughX + scalePtr->borderWidth, scalePtr->inset + scalePtr->borderWidth, (unsigned) scalePtr->width, (unsigned) (Tk_Height(tkwin) - 2*scalePtr->inset - 2*scalePtr->borderWidth)); if (scalePtr->state == STATE_ACTIVE) { sliderBorder = scalePtr->activeBorder; } else { sliderBorder = scalePtr->bgBorder; } width = scalePtr->width; height = scalePtr->sliderLength/2; x = scalePtr->vertTroughX + scalePtr->borderWidth; y = TkScaleValueToPixel(scalePtr, scalePtr->value) - height; shadowWidth = scalePtr->borderWidth/2; if (shadowWidth == 0) { shadowWidth = 1; } Tk_Draw3DRectangle(tkwin, drawable, sliderBorder, x, y, width, 2*height, shadowWidth, scalePtr->sliderRelief); x += shadowWidth; y += shadowWidth; width -= 2*shadowWidth; height -= shadowWidth; Tk_Fill3DRectangle(tkwin, drawable, sliderBorder, x, y, width, height, shadowWidth, scalePtr->sliderRelief); Tk_Fill3DRectangle(tkwin, drawable, sliderBorder, x, y+height, width, height, shadowWidth, scalePtr->sliderRelief); /* * Draw the label to the right of the scale. */ if ((scalePtr->flags & REDRAW_OTHER) && (scalePtr->labelLength != 0)) { Tk_FontMetrics fm; Tk_GetFontMetrics(scalePtr->tkfont, &fm); Tk_DrawChars(scalePtr->display, drawable, scalePtr->textGC, scalePtr->tkfont, scalePtr->label, scalePtr->labelLength, scalePtr->vertLabelX, scalePtr->inset + (3*fm.ascent)/2); } } /* *---------------------------------------------------------------------- * * DisplayVerticalValue -- * * This function is called to display values (scale readings) for * vertically-oriented scales. * * Results: * None. * * Side effects: * The numerical value corresponding to value is displayed with its right * edge at "rightEdge", and at a vertical position in the scale that * corresponds to "value". * *---------------------------------------------------------------------- */ static void DisplayVerticalValue( register TkScale *scalePtr, /* Information about widget in which to * display value. */ Drawable drawable, /* Pixmap or window in which to draw the * value. */ double value, /* Y-coordinate of number to display, * specified in application coords, not in * pixels (we'll compute pixels). */ int rightEdge) /* X-coordinate of right edge of text, * specified in pixels. */ { register Tk_Window tkwin = scalePtr->tkwin; int y, width, length; char valueString[TCL_DOUBLE_SPACE]; Tk_FontMetrics fm; Tk_GetFontMetrics(scalePtr->tkfont, &fm); y = TkScaleValueToPixel(scalePtr, value) + fm.ascent/2; sprintf(valueString, scalePtr->format, value); length = (int) strlen(valueString); width = Tk_TextWidth(scalePtr->tkfont, valueString, length); /* * Adjust the y-coordinate if necessary to keep the text entirely inside * the window. */ if ((y - fm.ascent) < (scalePtr->inset + SPACING)) { y = scalePtr->inset + SPACING + fm.ascent; } if ((y + fm.descent) > (Tk_Height(tkwin) - scalePtr->inset - SPACING)) { y = Tk_Height(tkwin) - scalePtr->inset - SPACING - fm.descent; } Tk_DrawChars(scalePtr->display, drawable, scalePtr->textGC, scalePtr->tkfont, valueString, length, rightEdge - width, y); } /* *-------------------------------------------------------------- * * DisplayHorizontalScale -- * * This function redraws the contents of a horizontal scale window. It is * invoked as a do-when-idle handler, so it only runs when there's * nothing else for the application to do. * * Results: * There is no return value. If only a part of the scale needs to be * redrawn, then drawnAreaPtr is modified to reflect the area that was * actually modified. * * Side effects: * Information appears on the screen. * *-------------------------------------------------------------- */ static void DisplayHorizontalScale( TkScale *scalePtr, /* Widget record for scale. */ Drawable drawable, /* Where to display scale (window or * pixmap). */ XRectangle *drawnAreaPtr) /* Initally contains area of window; if only a * part of the scale is redrawn, gets modified * to reflect the part of the window that was * redrawn. */ { register Tk_Window tkwin = scalePtr->tkwin; int x, y, width, height, shadowWidth; double tickValue, tickInterval = scalePtr->tickInterval; Tk_3DBorder sliderBorder; /* * Display the information from bottom to top across the window. */ if (!(scalePtr->flags & REDRAW_OTHER)) { drawnAreaPtr->x = scalePtr->inset; drawnAreaPtr->y = scalePtr->horizValueY; drawnAreaPtr->width -= 2*scalePtr->inset; drawnAreaPtr->height = scalePtr->horizTroughY + scalePtr->width + 2*scalePtr->borderWidth - scalePtr->horizValueY; } Tk_Fill3DRectangle(tkwin, drawable, scalePtr->bgBorder, drawnAreaPtr->x, drawnAreaPtr->y, drawnAreaPtr->width, drawnAreaPtr->height, 0, TK_RELIEF_FLAT); if (scalePtr->flags & REDRAW_OTHER) { /* * Display the tick marks. */ if (tickInterval != 0) { char valueString[TCL_DOUBLE_SPACE]; double ticks, maxTicks; /* * Ensure that we will only draw enough of the tick values such * that they don't overlap. We base this off the width that * fromValue would take. Not exact, but better than no constraint. */ ticks = fabs((scalePtr->toValue - scalePtr->fromValue) / tickInterval); sprintf(valueString, scalePtr->format, scalePtr->fromValue); maxTicks = (double) Tk_Width(tkwin) / (double) Tk_TextWidth(scalePtr->tkfont, valueString, -1); if (ticks > maxTicks) { tickInterval *= (ticks / maxTicks); } for (tickValue = scalePtr->fromValue; ; tickValue += tickInterval) { /* * The TkRoundToResolution call gets rid of accumulated * round-off errors, if any. */ tickValue = TkRoundToResolution(scalePtr, tickValue); if (scalePtr->toValue >= scalePtr->fromValue) { if (tickValue > scalePtr->toValue) { break; } } else { if (tickValue < scalePtr->toValue) { break; } } DisplayHorizontalValue(scalePtr, drawable, tickValue, scalePtr->horizTickY); } } } /* * Display the value, if it is desired. */ if (scalePtr->showValue) { DisplayHorizontalValue(scalePtr, drawable, scalePtr->value, scalePtr->horizValueY); } /* * Display the trough and the slider. */ y = scalePtr->horizTroughY; Tk_Draw3DRectangle(tkwin, drawable, scalePtr->bgBorder, scalePtr->inset, y, Tk_Width(tkwin) - 2*scalePtr->inset, scalePtr->width + 2*scalePtr->borderWidth, scalePtr->borderWidth, TK_RELIEF_SUNKEN); XFillRectangle(scalePtr->display, drawable, scalePtr->troughGC, scalePtr->inset + scalePtr->borderWidth, y + scalePtr->borderWidth, (unsigned) (Tk_Width(tkwin) - 2*scalePtr->inset - 2*scalePtr->borderWidth), (unsigned) scalePtr->width); if (scalePtr->state == STATE_ACTIVE) { sliderBorder = scalePtr->activeBorder; } else { sliderBorder = scalePtr->bgBorder; } width = scalePtr->sliderLength/2; height = scalePtr->width; x = TkScaleValueToPixel(scalePtr, scalePtr->value) - width; y += scalePtr->borderWidth; shadowWidth = scalePtr->borderWidth/2; if (shadowWidth == 0) { shadowWidth = 1; } Tk_Draw3DRectangle(tkwin, drawable, sliderBorder, x, y, 2*width, height, shadowWidth, scalePtr->sliderRelief); x += shadowWidth; y += shadowWidth; width -= shadowWidth; height -= 2*shadowWidth; Tk_Fill3DRectangle(tkwin, drawable, sliderBorder, x, y, width, height, shadowWidth, scalePtr->sliderRelief); Tk_Fill3DRectangle(tkwin, drawable, sliderBorder, x+width, y, width, height, shadowWidth, scalePtr->sliderRelief); /* * Draw the label at the top of the scale. */ if ((scalePtr->flags & REDRAW_OTHER) && (scalePtr->labelLength != 0)) { Tk_FontMetrics fm; Tk_GetFontMetrics(scalePtr->tkfont, &fm); Tk_DrawChars(scalePtr->display, drawable, scalePtr->textGC, scalePtr->tkfont, scalePtr->label, scalePtr->labelLength, scalePtr->inset + fm.ascent/2, scalePtr->horizLabelY + fm.ascent); } } /* *---------------------------------------------------------------------- * * DisplayHorizontalValue -- * * This function is called to display values (scale readings) for * horizontally-oriented scales. * * Results: * None. * * Side effects: * The numerical value corresponding to value is displayed with its * bottom edge at "bottom", and at a horizontal position in the scale * that corresponds to "value". * *---------------------------------------------------------------------- */ static void DisplayHorizontalValue( register TkScale *scalePtr, /* Information about widget in which to * display value. */ Drawable drawable, /* Pixmap or window in which to draw the * value. */ double value, /* X-coordinate of number to display, * specified in application coords, not in * pixels (we'll compute pixels). */ int top) /* Y-coordinate of top edge of text, specified * in pixels. */ { register Tk_Window tkwin = scalePtr->tkwin; int x, y, length, width; char valueString[TCL_DOUBLE_SPACE]; Tk_FontMetrics fm; x = TkScaleValueToPixel(scalePtr, value); Tk_GetFontMetrics(scalePtr->tkfont, &fm); y = top + fm.ascent; sprintf(valueString, scalePtr->format, value); length = (int) strlen(valueString); width = Tk_TextWidth(scalePtr->tkfont, valueString, length); /* * Adjust the x-coordinate if necessary to keep the text entirely inside * the window. */ x -= (width)/2; if (x < (scalePtr->inset + SPACING)) { x = scalePtr->inset + SPACING; } /* * Check the right border so use starting point +text width for the check. */ if (x + width >= (Tk_Width(tkwin) - scalePtr->inset)) { x = Tk_Width(tkwin) - scalePtr->inset - SPACING - width; } Tk_DrawChars(scalePtr->display, drawable, scalePtr->textGC, scalePtr->tkfont, valueString, length, x, y); } /* *---------------------------------------------------------------------- * * TkpDisplayScale -- * * This function is invoked as an idle handler to redisplay the contents * of a scale widget. * * Results: * None. * * Side effects: * The scale gets redisplayed. * *---------------------------------------------------------------------- */ void TkpDisplayScale( ClientData clientData) /* Widget record for scale. */ { TkScale *scalePtr = (TkScale *) clientData; Tk_Window tkwin = scalePtr->tkwin; Tcl_Interp *interp = scalePtr->interp; Pixmap pixmap; int result; char string[TCL_DOUBLE_SPACE]; XRectangle drawnArea; Tcl_DString buf; scalePtr->flags &= ~REDRAW_PENDING; if ((scalePtr->tkwin == NULL) || !Tk_IsMapped(scalePtr->tkwin)) { goto done; } /* * Invoke the scale's command if needed. */ Tcl_Preserve(scalePtr); if ((scalePtr->flags & INVOKE_COMMAND) && (scalePtr->command != NULL)) { Tcl_Preserve(interp); sprintf(string, scalePtr->format, scalePtr->value); Tcl_DStringInit(&buf); Tcl_DStringAppend(&buf, scalePtr->command, -1); Tcl_DStringAppend(&buf, " ", -1); Tcl_DStringAppend(&buf, string, -1); result = Tcl_EvalEx(interp, Tcl_DStringValue(&buf), -1, 0); Tcl_DStringFree(&buf); if (result != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (command executed by scale)"); Tcl_BackgroundException(interp, result); } Tcl_Release(interp); } scalePtr->flags &= ~INVOKE_COMMAND; if (scalePtr->flags & SCALE_DELETED) { Tcl_Release(scalePtr); return; } Tcl_Release(scalePtr); #ifndef TK_NO_DOUBLE_BUFFERING /* * In order to avoid screen flashes, this function redraws the scale in a * pixmap, then copies the pixmap to the screen in a single operation. * This means that there's no point in time where the on-sreen image has * been cleared. */ pixmap = Tk_GetPixmap(scalePtr->display, Tk_WindowId(tkwin), Tk_Width(tkwin), Tk_Height(tkwin), Tk_Depth(tkwin)); #else pixmap = Tk_WindowId(tkwin); #endif /* TK_NO_DOUBLE_BUFFERING */ drawnArea.x = 0; drawnArea.y = 0; drawnArea.width = Tk_Width(tkwin); drawnArea.height = Tk_Height(tkwin); /* * Much of the redisplay is done totally differently for horizontal and * vertical scales. Handle the part that's different. */ if (scalePtr->orient == ORIENT_VERTICAL) { DisplayVerticalScale(scalePtr, pixmap, &drawnArea); } else { DisplayHorizontalScale(scalePtr, pixmap, &drawnArea); } /* * Now handle the part of redisplay that is the same for horizontal and * vertical scales: border and traversal highlight. */ if (scalePtr->flags & REDRAW_OTHER) { if (scalePtr->relief != TK_RELIEF_FLAT) { Tk_Draw3DRectangle(tkwin, pixmap, scalePtr->bgBorder, scalePtr->highlightWidth, scalePtr->highlightWidth, Tk_Width(tkwin) - 2*scalePtr->highlightWidth, Tk_Height(tkwin) - 2*scalePtr->highlightWidth, scalePtr->borderWidth, scalePtr->relief); } if (scalePtr->highlightWidth != 0) { GC gc; if (scalePtr->flags & GOT_FOCUS) { gc = Tk_GCForColor(scalePtr->highlightColorPtr, pixmap); } else { gc = Tk_GCForColor( Tk_3DBorderColor(scalePtr->highlightBorder), pixmap); } Tk_DrawFocusHighlight(tkwin, gc, scalePtr->highlightWidth, pixmap); } } #ifndef TK_NO_DOUBLE_BUFFERING /* * Copy the information from the off-screen pixmap onto the screen, then * delete the pixmap. */ XCopyArea(scalePtr->display, pixmap, Tk_WindowId(tkwin), scalePtr->copyGC, drawnArea.x, drawnArea.y, drawnArea.width, drawnArea.height, drawnArea.x, drawnArea.y); Tk_FreePixmap(scalePtr->display, pixmap); #endif /* TK_NO_DOUBLE_BUFFERING */ done: scalePtr->flags &= ~REDRAW_ALL; } /* *---------------------------------------------------------------------- * * TkpScaleElement -- * * Determine which part of a scale widget lies under a given point. * * Results: * The return value is either TROUGH1, SLIDER, TROUGH2, or OTHER, * depending on which of the scale's active elements (if any) is under * the point at (x,y). * * Side effects: * None. * *---------------------------------------------------------------------- */ int TkpScaleElement( TkScale *scalePtr, /* Widget record for scale. */ int x, int y) /* Coordinates within scalePtr's window. */ { int sliderFirst; if (scalePtr->orient == ORIENT_VERTICAL) { if ((x < scalePtr->vertTroughX) || (x >= (scalePtr->vertTroughX + 2*scalePtr->borderWidth + scalePtr->width))) { return OTHER; } if ((y < scalePtr->inset) || (y >= (Tk_Height(scalePtr->tkwin) - scalePtr->inset))) { return OTHER; } sliderFirst = TkScaleValueToPixel(scalePtr, scalePtr->value) - scalePtr->sliderLength/2; if (y < sliderFirst) { return TROUGH1; } if (y < (sliderFirst+scalePtr->sliderLength)) { return SLIDER; } return TROUGH2; } if ((y < scalePtr->horizTroughY) || (y >= (scalePtr->horizTroughY + 2*scalePtr->borderWidth + scalePtr->width))) { return OTHER; } if ((x < scalePtr->inset) || (x >= (Tk_Width(scalePtr->tkwin) - scalePtr->inset))) { return OTHER; } sliderFirst = TkScaleValueToPixel(scalePtr, scalePtr->value) - scalePtr->sliderLength/2; if (x < sliderFirst) { return TROUGH1; } if (x < (sliderFirst+scalePtr->sliderLength)) { return SLIDER; } return TROUGH2; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ tk8.6.5/unix/tk.pc.in0000644003604700454610000000073412665114121013023 0ustar dgp771div# tk pkg-config source file prefix=@prefix@ exec_prefix=@exec_prefix@ libdir=@libdir@ includedir=@includedir@ Name: The Tk Toolkit Description: Tk is a cross-platform graphical user interface toolkit, the standard GUI not only for Tcl, but for many other dynamic languages as well. URL: http://www.tcl.tk/ Version: @TK_VERSION@@TK_PATCH_LEVEL@ Requires: tcl >= 8.6 Libs: -L${libdir} @TK_LIB_FLAG@ @TK_STUB_LIB_FLAG@ Libs.private: @XFT_LIBS@ @XLIBSW@ Cflags: -I${includedir} tk8.6.5/unix/configure.in0000775003604700454610000010101312665114121013762 0ustar dgp771div#! /bin/bash -norc dnl This file is an input file used by the GNU "autoconf" program to dnl generate the file "configure", which is run during Tk installation dnl to configure the system for the local environment. AC_INIT([tk],[8.6]) AC_PREREQ(2.59) dnl This is only used when included from macosx/configure.ac m4_ifdef([SC_USE_CONFIG_HEADERS], [ AC_CONFIG_HEADERS([tkConfig.h:../unix/tkConfig.h.in]) AC_CONFIG_COMMANDS_PRE([DEFS="-DHAVE_TK_CONFIG_H -imacros tkConfig.h"]) AH_TOP([ #ifndef _TKCONFIG #define _TKCONFIG]) AH_BOTTOM([ /* Undef unused package specific autoheader defines so that we can * include both tclConfig.h and tkConfig.h at the same time: */ /* override */ #undef PACKAGE_NAME /* override */ #undef PACKAGE_STRING /* override */ #undef PACKAGE_TARNAME #endif /* _TKCONFIG */]) ]) TK_VERSION=8.6 TK_MAJOR_VERSION=8 TK_MINOR_VERSION=6 TK_PATCH_LEVEL=".5" VERSION=${TK_VERSION} LOCALES="cs da de el en en_gb eo es fr hu it nl pl pt ru sv" #-------------------------------------------------------------------- # Find and load the tclConfig.sh file #-------------------------------------------------------------------- SC_PATH_TCLCONFIG SC_LOAD_TCLCONFIG if test "${TCL_MAJOR_VERSION}" -ne 8 ; then AC_MSG_ERROR([${PACKAGE_NAME} ${PACKAGE_VERSION} requires Tcl 8.6+ Found config for Tcl ${TCL_VERSION}]) fi if test "${TCL_MINOR_VERSION}" -lt 6 ; then AC_MSG_ERROR([${PACKAGE_NAME} ${PACKAGE_VERSION} requires Tcl 8.6+ Found config for Tcl ${TCL_VERSION}]) fi SC_PROG_TCLSH SC_BUILD_TCLSH #------------------------------------------------------------------------ # Handle the --prefix=... option #------------------------------------------------------------------------ if test "${prefix}" = "NONE"; then prefix="$TCL_PREFIX" fi if test "${exec_prefix}" = "NONE"; then exec_prefix=$prefix fi # Make sure srcdir is fully qualified! srcdir="`cd "$srcdir" ; pwd`" TK_SRC_DIR="`cd "$srcdir"/..; pwd`" #------------------------------------------------------------------------ # Compress and/or soft link the manpages? #------------------------------------------------------------------------ SC_CONFIG_MANPAGES #------------------------------------------------------------------------ # Standard compiler checks #------------------------------------------------------------------------ # If the user did not set CFLAGS, set it now to keep # the AC_PROG_CC macro from adding "-g -O2". if test "${CFLAGS+set}" != "set" ; then CFLAGS="" fi AC_PROG_CC AC_C_INLINE #-------------------------------------------------------------------- # Supply a substitute for stdlib.h if it doesn't define strtol, # strtoul, or strtod (which it doesn't in some versions of SunOS). #-------------------------------------------------------------------- AC_CHECK_HEADER(stdlib.h, tk_ok=1, tk_ok=0) AC_EGREP_HEADER(strtol, stdlib.h, , tk_ok=0) AC_EGREP_HEADER(strtoul, stdlib.h, , tk_ok=0) AC_EGREP_HEADER(strtod, stdlib.h, , tk_ok=0) if test $tk_ok = 0; then AC_DEFINE(NO_STDLIB_H, 1, [Do we have ?]) fi #------------------------------------------------------------------------ # If we're using GCC, see if the compiler understands -pipe. If so, use it. # It makes compiling go faster. (This is only a performance feature.) #------------------------------------------------------------------------ if test -z "$no_pipe" && test -n "$GCC"; then AC_CACHE_CHECK([if the compiler understands -pipe], tcl_cv_cc_pipe, [ hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -pipe" AC_TRY_COMPILE(,, tcl_cv_cc_pipe=yes, tcl_cv_cc_pipe=no) CFLAGS=$hold_cflags]) if test $tcl_cv_cc_pipe = yes; then CFLAGS="$CFLAGS -pipe" fi fi #------------------------------------------------------------------------ # Threads support - this auto-enables if Tcl was compiled threaded #------------------------------------------------------------------------ SC_ENABLE_THREADS # Add the threads support libraries LIBS="$LIBS$THREADS_LIBS" SC_ENABLE_SHARED #-------------------------------------------------------------------- # The statements below define a collection of compile flags. This # macro depends on the value of SHARED_BUILD, and should be called # after SC_ENABLE_SHARED checks the configure switches. #-------------------------------------------------------------------- SC_CONFIG_CFLAGS SC_ENABLE_SYMBOLS #-------------------------------------------------------------------- # Detect what compiler flags to set for 64-bit support. #-------------------------------------------------------------------- SC_TCL_EARLY_FLAGS SC_TCL_64BIT_FLAGS #-------------------------------------------------------------------- # Check endianness because we can optimize some operations #-------------------------------------------------------------------- AC_C_BIGENDIAN #------------------------------------------------------------------------ # If Tcl and Tk are installed in different places, adjust the library # search path to reflect this. #------------------------------------------------------------------------ LIB_RUNTIME_DIR='$(libdir)' if test "$TCL_EXEC_PREFIX" != "$exec_prefix"; then LIB_RUNTIME_DIR="${LIB_RUNTIME_DIR}:${TCL_EXEC_PREFIX}/lib" fi if test "$TCL_PREFIX" != "$prefix"; then AC_MSG_WARN([ Different --prefix selected for Tk and Tcl! [[package require Tk]] may not work correctly in tclsh.]) fi #-------------------------------------------------------------------- # Include sys/select.h if it exists and if it supplies things # that appear to be useful and aren't already in sys/types.h. # This appears to be true only on the RS/6000 under AIX. Some # systems like OSF/1 have a sys/select.h that's of no use, and # other systems like SCO UNIX have a sys/select.h that's # pernicious. If "fd_set" isn't defined anywhere then set a # special flag. #-------------------------------------------------------------------- AC_CACHE_CHECK([for fd_set in sys/types], tcl_cv_type_fd_set, [ AC_TRY_COMPILE([#include ],[fd_set readMask, writeMask;], tcl_cv_type_fd_set=yes, tcl_cv_type_fd_set=no)]) tk_ok=$tcl_cv_type_fd_set if test $tk_ok = no; then AC_CACHE_CHECK([for fd_mask in sys/select], tcl_cv_grep_fd_mask, [ AC_EGREP_HEADER(fd_mask, sys/select.h, tcl_cv_grep_fd_mask=present, tcl_cv_grep_fd_mask=missing)]) if test $tcl_cv_grep_fd_mask = present; then AC_DEFINE(HAVE_SYS_SELECT_H, 1, [Should we include ?]) tk_ok=yes fi fi if test $tk_ok = no; then AC_DEFINE(NO_FD_SET, 1, [Do we have fd_set?]) fi #------------------------------------------------------------------------------ # Find out all about time handling differences. #------------------------------------------------------------------------------ AC_CHECK_HEADERS(sys/time.h) AC_HEADER_TIME #-------------------------------------------------------------------- # Under Solaris 2.4, strtod returns the wrong value for the # terminating character under some conditions. Check for this # and if the problem exists use a substitute procedure # "fixstrtod" (provided by Tcl) that corrects the error. #-------------------------------------------------------------------- SC_BUGGY_STRTOD #-------------------------------------------------------------------- # Check for various typedefs and provide substitutes if # they don't exist. #-------------------------------------------------------------------- AC_TYPE_MODE_T AC_TYPE_PID_T AC_TYPE_SIZE_T AC_TYPE_UID_T AC_CHECK_TYPE([intptr_t], [ AC_DEFINE([HAVE_INTPTR_T], 1, [Do we have the intptr_t type?])], [ AC_CACHE_CHECK([for pointer-size signed integer type], tcl_cv_intptr_t, [ for tcl_cv_intptr_t in "int" "long" "long long" none; do if test "$tcl_cv_intptr_t" != none; then AC_COMPILE_IFELSE([AC_LANG_BOOL_COMPILE_TRY([AC_INCLUDES_DEFAULT], [[sizeof (void *) <= sizeof ($tcl_cv_intptr_t)]])], [tcl_ok=yes], [tcl_ok=no]) test "$tcl_ok" = yes && break; fi done]) if test "$tcl_cv_intptr_t" != none; then AC_DEFINE_UNQUOTED([intptr_t], [$tcl_cv_intptr_t], [Signed integer type wide enough to hold a pointer.]) fi ]) AC_CHECK_TYPE([uintptr_t], [ AC_DEFINE([HAVE_UINTPTR_T], 1, [Do we have the uintptr_t type?])], [ AC_CACHE_CHECK([for pointer-size unsigned integer type], tcl_cv_uintptr_t, [ for tcl_cv_uintptr_t in "unsigned int" "unsigned long" "unsigned long long" \ none; do if test "$tcl_cv_uintptr_t" != none; then AC_COMPILE_IFELSE([AC_LANG_BOOL_COMPILE_TRY([AC_INCLUDES_DEFAULT], [[sizeof (void *) <= sizeof ($tcl_cv_uintptr_t)]])], [tcl_ok=yes], [tcl_ok=no]) test "$tcl_ok" = yes && break; fi done]) if test "$tcl_cv_uintptr_t" != none; then AC_DEFINE_UNQUOTED([uintptr_t], [$tcl_cv_uintptr_t], [Unsigned integer type wide enough to hold a pointer.]) fi ]) #------------------------------------------- # In OS/390 struct pwd has no pw_gecos field #------------------------------------------- AC_CACHE_CHECK([pw_gecos in struct pwd], tcl_cv_pwd_pw_gecos, [ AC_TRY_COMPILE([#include ], [struct passwd pwd; pwd.pw_gecos;], tcl_cv_pwd_pw_gecos=yes, tcl_cv_pwd_pw_gecos=no)]) if test $tcl_cv_pwd_pw_gecos = yes; then AC_DEFINE(HAVE_PW_GECOS, 1, [Does struct password have a pw_gecos field?]) fi #-------------------------------------------------------------------- # On Mac OS X, we can build either with X11 or with Aqua #-------------------------------------------------------------------- if test "`uname -s`" = "Darwin" ; then AC_MSG_CHECKING([whether to use Aqua]) AC_ARG_ENABLE(aqua, AC_HELP_STRING([--enable-aqua=yes|no], [use Aqua windowingsystem on Mac OS X (default: no)]), [tk_aqua=$enableval], [tk_aqua=no]) if test $tk_aqua = yes -o $tk_aqua = cocoa; then tk_aqua=yes if test $tcl_corefoundation = no; then AC_MSG_WARN([Aqua can only be used when CoreFoundation is available]) tk_aqua=no fi if test ! -d /System/Library/Frameworks/Cocoa.framework; then AC_MSG_WARN([Aqua can only be used when Cocoa is available]) tk_aqua=no fi if test "`uname -r | awk -F. '{print [$]1}'`" -lt 9; then AC_MSG_WARN([Aqua requires Mac OS X 10.5 or later]) tk_aqua=no fi fi AC_MSG_RESULT([$tk_aqua]) if test "$fat_32_64" = yes; then if test $tk_aqua = no; then AC_CACHE_CHECK([for 64-bit X11], tcl_cv_lib_x11_64, [ for v in CFLAGS CPPFLAGS LDFLAGS; do eval 'hold_'$v'="$'$v'";'$v'="`echo "$'$v' "|sed -e "s/-arch ppc / /g" -e "s/-arch i386 / /g"`"' done CPPFLAGS="$CPPFLAGS -I/usr/X11R6/include" LDFLAGS="$LDFLAGS -L/usr/X11R6/lib -lX11" AC_TRY_LINK([#include ], [XrmInitialize();], tcl_cv_lib_x11_64=yes, tcl_cv_lib_x11_64=no) for v in CFLAGS CPPFLAGS LDFLAGS; do eval $v'="$hold_'$v'"' done]) fi # remove 64-bit arch flags from CFLAGS et al. for combined 32 & 64 bit # fat builds if configuration does not support 64-bit. if test "$tcl_cv_lib_x11_64" = no; then AC_MSG_NOTICE([Removing 64-bit architectures from compiler & linker flags]) for v in CFLAGS CPPFLAGS LDFLAGS; do eval $v'="`echo "$'$v' "|sed -e "s/-arch ppc64 / /g" -e "s/-arch x86_64 / /g"`"' done fi fi if test $tk_aqua = no; then # check if weak linking whole libraries is possible. AC_CACHE_CHECK([if ld accepts -weak-l flag], tcl_cv_ld_weak_l, [ hold_ldflags=$LDFLAGS LDFLAGS="$LDFLAGS -Wl,-weak-lm" AC_TRY_LINK([#include ], [double f = sin(1.0);], tcl_cv_ld_weak_l=yes, tcl_cv_ld_weak_l=no) LDFLAGS=$hold_ldflags]) fi AC_CHECK_HEADERS(AvailabilityMacros.h) if test "$ac_cv_header_AvailabilityMacros_h" = yes; then AC_CACHE_CHECK([if weak import is available], tcl_cv_cc_weak_import, [ hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Werror" AC_TRY_LINK([ #ifdef __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ #if __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ < 1020 #error __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ < 1020 #endif #elif MAC_OS_X_VERSION_MIN_REQUIRED < 1020 #error MAC_OS_X_VERSION_MIN_REQUIRED < 1020 #endif int rand(void) __attribute__((weak_import)); ], [rand();], tcl_cv_cc_weak_import=yes, tcl_cv_cc_weak_import=no) CFLAGS=$hold_cflags]) if test $tcl_cv_cc_weak_import = yes; then AC_DEFINE(HAVE_WEAK_IMPORT, 1, [Is weak import available?]) fi AC_CACHE_CHECK([if Darwin SUSv3 extensions are available], tcl_cv_cc_darwin_c_source, [ hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Werror" AC_TRY_COMPILE([ #ifdef __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ #if __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ < 1050 #error __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ < 1050 #endif #elif MAC_OS_X_VERSION_MIN_REQUIRED < 1050 #error MAC_OS_X_VERSION_MIN_REQUIRED < 1050 #endif #define _DARWIN_C_SOURCE 1 #include ],,tcl_cv_cc_darwin_c_source=yes, tcl_cv_cc_darwin_c_source=no) CFLAGS=$hold_cflags]) if test $tcl_cv_cc_darwin_c_source = yes; then AC_DEFINE(_DARWIN_C_SOURCE, 1, [Are Darwin SUSv3 extensions available?]) fi fi else tk_aqua=no fi if test $tk_aqua = yes; then AC_DEFINE(MAC_OSX_TK, 1, [Are we building TkAqua?]) LIBS="$LIBS -framework Cocoa -framework Carbon -framework IOKit" EXTRA_CC_SWITCHES='-std=gnu99 -x objective-c' TK_WINDOWINGSYSTEM=AQUA if test -n "${enable_symbols}" -a "${enable_symbols}" != no; then AC_DEFINE(TK_MAC_DEBUG, 1, [Are TkAqua debug messages enabled?]) fi else #-------------------------------------------------------------------- # Locate the X11 header files and the X11 library archive. Try # the ac_path_x macro first, but if it doesn't find the X stuff # (e.g. because there's no xmkmf program) then check through # a list of possible directories. Under some conditions the # autoconf macro will return an include directory that contains # no include files, so double-check its result just to be safe. #-------------------------------------------------------------------- SC_PATH_X TK_WINDOWINGSYSTEM=X11 fi #-------------------------------------------------------------------- # Various manipulations on the search path used at runtime to # find shared libraries: # 1. If the X library binaries are in a non-standard directory, # add the X library location into that search path. # 2. On systems such as AIX and Ultrix that use "-L" as the # search path option, colons cannot be used to separate # directories from each other. Change colons to " -L". # 3. Create two sets of search flags, one for use in cc lines # and the other for when the linker is invoked directly. In # the second case, '-Wl,' must be stripped off and commas must # be replaced by spaces. #-------------------------------------------------------------------- if test "x${x_libraries}" != "x"; then if test "x${x_libraries}" != "xNONE"; then LIB_RUNTIME_DIR="${LIB_RUNTIME_DIR}:${x_libraries}" fi fi if test "${TCL_LD_SEARCH_FLAGS}" = '-L${LIB_RUNTIME_DIR}'; then LIB_RUNTIME_DIR=`echo ${LIB_RUNTIME_DIR} |sed -e 's/:/ -L/g'` fi #-------------------------------------------------------------------- # Check for the existence of various libraries. The order here # is important, so that then end up in the right order in the # command line generated by make. The -lsocket and -lnsl libraries # require a couple of special tricks: # 1. Use "connect" and "accept" to check for -lsocket, and # "gethostbyname" to check for -lnsl. # 2. Use each function name only once: can't redo a check because # autoconf caches the results of the last check and won't redo it. # 3. Use -lnsl and -lsocket only if they supply procedures that # aren't already present in the normal libraries. This is because # IRIX 5.2 has libraries, but they aren't needed and they're # bogus: they goof up name resolution if used. # 4. On some SVR4 systems, can't use -lsocket without -lnsl too. # To get around this problem, check for both libraries together # if -lsocket doesn't work by itself. #-------------------------------------------------------------------- if test $tk_aqua = no; then AC_CHECK_LIB(Xbsd, main, [LIBS="$LIBS -lXbsd"]) fi #-------------------------------------------------------------------- # One more check related to the X libraries. The standard releases # of Ultrix don't support the "xauth" mechanism, so send won't work # unless TK_NO_SECURITY is defined. However, there are usually copies # of the MIT X server available as well, which do support xauth. # Check for the MIT stuff and use it if it exists. # # Note: can't use ac_check_lib macro (at least, not in Autoconf 2.1) # because it can't deal with the "-" in the library name. #-------------------------------------------------------------------- if test -d /usr/include/mit -a $tk_aqua = no; then AC_MSG_CHECKING([MIT X libraries]) tk_oldCFlags=$CFLAGS CFLAGS="$CFLAGS -I/usr/include/mit" tk_oldLibs=$LIBS LIBS="$LIBS -lX11-mit" AC_TRY_LINK([ #include ], [ XOpenDisplay(0); ], [ AC_MSG_RESULT([yes]) XLIBSW="-lX11-mit" XINCLUDES="-I/usr/include/mit" ], AC_MSG_RESULT([no])) CFLAGS=$tk_oldCFlags LIBS=$tk_oldLibs fi #-------------------------------------------------------------------- # Check for freetype / fontconfig / Xft support. #-------------------------------------------------------------------- if test $tk_aqua = no; then AC_MSG_CHECKING([whether to use xft]) AC_ARG_ENABLE(xft, AC_HELP_STRING([--enable-xft], [use freetype/fontconfig/xft (default: on)]), [enable_xft=$enableval], [enable_xft="default"]) XFT_CFLAGS="" XFT_LIBS="" if test "$enable_xft" = "no" ; then AC_MSG_RESULT([$enable_xft]) else found_xft="yes" dnl make sure package configurator (xft-config or pkg-config dnl says that xft is present. XFT_CFLAGS=`xft-config --cflags 2>/dev/null` || found_xft="no" XFT_LIBS=`xft-config --libs 2>/dev/null` || found_xft="no" if test "$found_xft" = "no" ; then found_xft=yes XFT_CFLAGS=`pkg-config --cflags xft 2>/dev/null` || found_xft="no" XFT_LIBS=`pkg-config --libs xft 2>/dev/null` || found_xft="no" fi AC_MSG_RESULT([$found_xft]) dnl make sure that compiling against Xft header file doesn't bomb if test "$found_xft" = "yes" ; then tk_oldCFlags=$CFLAGS CFLAGS="$CFLAGS $XINCLUDES $XFT_CFLAGS" tk_oldLibs=$LIBS LIBS="$tk_oldLIBS $XFT_LIBS $XLIBSW" AC_CHECK_HEADER(X11/Xft/Xft.h, [], [ found_xft=no ],[#include ]) CFLAGS=$tk_oldCFlags LIBS=$tk_oldLibs fi dnl make sure that linking against Xft libraries finds freetype if test "$found_xft" = "yes" ; then tk_oldCFlags=$CFLAGS CFLAGS="$CFLAGS $XINCLUDES $XFT_CFLAGS" tk_oldLibs=$LIBS LIBS="$tk_oldLIBS $XFT_LIBS $XLIBSW" AC_CHECK_LIB(Xft, XftFontOpen, [], [ found_xft=no ]) CFLAGS=$tk_oldCFlags LIBS=$tk_oldLibs fi dnl make sure that linking against fontconfig libraries finds Fc* symbols if test "$found_xft" = "yes" ; then tk_oldCFlags=$CFLAGS CFLAGS="$CFLAGS $XINCLUDES $XFT_CFLAGS" tk_oldLibs=$LIBS LIBS="$tk_oldLIBS $XFT_LIBS $XLIBSW -lfontconfig" AC_CHECK_LIB(fontconfig, FcFontSort, [ XFT_LIBS="$XFT_LIBS -lfontconfig" ], []) CFLAGS=$tk_oldCFlags LIBS=$tk_oldLibs fi dnl print a warning if xft is unusable and was specifically requested if test "$found_xft" = "no" ; then if test "$enable_xft" = "yes" ; then AC_MSG_WARN([Can't find xft configuration, or xft is unusable]) fi enable_xft=no XFT_CFLAGS="" XFT_LIBS="" else enable_xft=yes fi fi if test $enable_xft = "yes" ; then UNIX_FONT_OBJS=tkUnixRFont.o AC_DEFINE(HAVE_XFT, 1, [Have we turned on XFT (antialiased fonts)?]) else UNIX_FONT_OBJS=tkUnixFont.o fi AC_SUBST(XFT_CFLAGS) AC_SUBST(XFT_LIBS) AC_SUBST(UNIX_FONT_OBJS) fi #-------------------------------------------------------------------- # Check for XkbKeycodeToKeysym. #-------------------------------------------------------------------- if test $tk_aqua = no; then tk_oldCFlags=$CFLAGS tk_oldLibs=$LIBS CFLAGS="$CFLAGS $XINCLUDES" LIBS="$LIBS $XLIBSW" AC_CHECK_HEADER(X11/XKBlib.h, [ xkblib_header_found=yes ], [ xkblib_header_found=no ], [#include ]) if test $xkblib_header_found = "yes" ; then AC_CHECK_LIB(X11, XkbKeycodeToKeysym, [ xkbkeycodetokeysym_found=yes ], [ xkbkeycodetokeysym_found=no ]) else xkbkeycodetokeysym_found=no fi if test $xkbkeycodetokeysym_found = "yes" ; then AC_DEFINE(HAVE_XKBKEYCODETOKEYSYM, 1, [Do we have XkbKeycodeToKeysym?]) fi CFLAGS=$tk_oldCFlags LIBS=$tk_oldLibs fi #-------------------------------------------------------------------- # Check whether XKeycodeToKeysym is deprecated in X11 headers. #-------------------------------------------------------------------- if test $tk_aqua = no && test "$GCC" = yes; then AC_MSG_CHECKING([whether XKeycodeToKeysym is deprecated]) tk_oldCFlags=$CFLAGS CFLAGS="$CFLAGS -Werror" AC_TRY_LINK([ #include ], [ XKeycodeToKeysym(0,0,0); ], [ AC_MSG_RESULT([no]) ], [ AC_MSG_RESULT([yes]) AC_DEFINE(XKEYCODETOKEYSYM_IS_DEPRECATED, 1, [Is XKeycodeToKeysym deprecated?]) ]) CFLAGS=$tk_oldCFlags fi #-------------------------------------------------------------------- # XXX Do this last. # It might modify XLIBSW which could affect other tests. # # Check whether the header and library for the XScreenSaver # extension are available, and set HAVE_XSS if so. # XScreenSaver is needed for Tk_GetUserInactiveTime(). #-------------------------------------------------------------------- if test $tk_aqua = no; then tk_oldCFlags=$CFLAGS CFLAGS="$CFLAGS $XINCLUDES" tk_oldLibs=$LIBS LIBS="$tk_oldLibs $XLIBSW" xss_header_found=no xss_lib_found=no AC_MSG_CHECKING([whether to try to use XScreenSaver]) AC_ARG_ENABLE(xss, AC_HELP_STRING([--enable-xss], [use XScreenSaver for activity timer (default: on)]), [enable_xss=$enableval], [enable_xss=yes]) if test "$enable_xss" = "no" ; then AC_MSG_RESULT([$enable_xss]) else AC_MSG_RESULT([$enable_xss]) AC_CHECK_HEADER(X11/extensions/scrnsaver.h, [ xss_header_found=yes ],,[#include ]) AC_CHECK_FUNC(XScreenSaverQueryInfo,,[ AC_CHECK_LIB(Xext, XScreenSaverQueryInfo, [ XLIBSW="$XLIBSW -lXext" xss_lib_found=yes ], [ AC_CHECK_LIB(Xss, XScreenSaverQueryInfo, [ if test "$tcl_cv_ld_weak_l" = yes; then # On Darwin, weak link libXss if possible, # as it is only available on Tiger or later. XLIBSW="$XLIBSW -Wl,-weak-lXss -lXext" else XLIBSW="$XLIBSW -lXss -lXext" fi xss_lib_found=yes ],, -lXext) ]) ]) fi if test $enable_xss = yes -a $xss_lib_found = yes -a $xss_header_found = yes; then AC_DEFINE(HAVE_XSS, 1, [Is XScreenSaver available?]) fi CFLAGS=$tk_oldCFlags LIBS=$tk_oldLibs fi #-------------------------------------------------------------------- # Figure out whether "char" is unsigned. If so, set a # #define for __CHAR_UNSIGNED__. #-------------------------------------------------------------------- AC_C_CHAR_UNSIGNED #-------------------------------------------------------------------- # The statements below define a collection of symbols related to # building libtk as a shared library instead of a static library. #-------------------------------------------------------------------- eval eval "TK_UNSHARED_LIB_SUFFIX=${UNSHARED_LIB_SUFFIX}" eval eval "TK_SHARED_LIB_SUFFIX=${SHARED_LIB_SUFFIX}" eval "TK_LIB_FILE=libtk${LIB_SUFFIX}" # tkConfig.sh needs a version of the _LIB_SUFFIX that has been eval'ed # since on some platforms TK_LIB_FILE contains shell escapes. eval "TK_LIB_FILE=${TK_LIB_FILE}" if test "${SHARED_BUILD}" = "1" -a "${SHLIB_SUFFIX}" != ""; then SHLIB_LD_LIBS="${SHLIB_LD_LIBS} \${TCL_STUB_LIB_SPEC}" TCL_STUB_FLAGS="-DUSE_TCL_STUBS" fi TK_LIBRARY='$(prefix)/lib/tk$(VERSION)' PRIVATE_INCLUDE_DIR='$(includedir)' HTML_DIR='$(DISTDIR)/html' TK_PKG_DIR='tk$(VERSION)' TK_RSRC_FILE='tk$(VERSION).rsrc' WISH_RSRC_FILE='wish$(VERSION).rsrc' # Note: in the following variable, it's important to use the absolute # path name of the Tcl directory rather than "..": this is because # AIX remembers this path and will attempt to use it at run-time to look # up the Tcl library. if test "`uname -s`" = "Darwin" ; then SC_ENABLE_FRAMEWORK TK_SHLIB_LD_EXTRAS="-compatibility_version ${TK_VERSION} -current_version ${TK_VERSION}`echo ${TK_PATCH_LEVEL} | awk ['{match($0, "\\\.[0-9]+"); print substr($0,RSTART,RLENGTH)}']`" TK_SHLIB_LD_EXTRAS="${TK_SHLIB_LD_EXTRAS}"' -install_name "${DYLIB_INSTALL_DIR}/${TK_LIB_FILE}" -unexported_symbols_list $$(f=$(TK_LIB_FILE).E && nm -gp tkMacOSX*.o 2>/dev/null | awk "/^[[0-9a-f]]+ . \.objc/ {print \$$3}" > $$f && nm -gjp "$(TCL_BIN_DIR)"/$(TCL_STUB_LIB_FILE) | grep ^_[[^_]] >> $$f && echo $$f)' echo "$LDFLAGS " | grep -q -- '-prebind ' && TK_SHLIB_LD_EXTRAS="${TK_SHLIB_LD_EXTRAS}"' -seg1addr 0xb000000' TK_SHLIB_LD_EXTRAS="${TK_SHLIB_LD_EXTRAS}"' -sectcreate __TEXT __info_plist Tk-Info.plist' EXTRA_WISH_LIBS='-sectcreate __TEXT __info_plist Wish-Info.plist' EXTRA_APP_CC_SWITCHES="${EXTRA_APP_CC_SWITCHES}"' -mdynamic-no-pic' AC_CONFIG_FILES([Tk-Info.plist:../macosx/Tk-Info.plist.in Wish-Info.plist:../macosx/Wish-Info.plist.in]) for l in ${LOCALES}; do CFBUNDLELOCALIZATIONS="${CFBUNDLELOCALIZATIONS}$l"; done TK_YEAR="`date +%Y`" fi if test "$FRAMEWORK_BUILD" = "1" ; then AC_DEFINE(TK_FRAMEWORK, 1, [Is Tk built as a framework?]) # Construct a fake local framework structure to make linking with # '-framework Tk' and running of tktest work AC_CONFIG_COMMANDS([Tk.framework], [n=Tk && f=$n.framework && v=Versions/$VERSION && rm -rf $f && mkdir -p $f/$v/Resources && ln -s $v/$n $v/Resources $f && ln -s ../../../$n $f/$v && ln -s ../../../../$n-Info.plist $f/$v/Resources/Info.plist && if test $tk_aqua = yes; then ln -s ../../../../$n.rsrc $f/$v/Resources; fi && unset n f v ], VERSION=${TK_VERSION} && tk_aqua=${tk_aqua}) LD_LIBRARY_PATH_VAR="DYLD_FRAMEWORK_PATH" if test "${libdir}" = '${exec_prefix}/lib'; then # override libdir default libdir="/Library/Frameworks" fi TK_LIB_FILE="Tk" TK_LIB_FLAG="-framework Tk" TK_BUILD_LIB_SPEC="-F`pwd | sed -e 's/ /\\\\ /g'` -framework Tk" TK_LIB_SPEC="-F${libdir} -framework Tk" libdir="${libdir}/Tk.framework/Versions/\${VERSION}" TK_LIBRARY="${libdir}/Resources/Scripts" TK_PKG_DIR="Resources/Scripts" TK_RSRC_FILE="Tk.rsrc" WISH_RSRC_FILE="Wish.rsrc" includedir="${libdir}/Headers" PRIVATE_INCLUDE_DIR="${libdir}/PrivateHeaders" HTML_DIR="${libdir}/Resources/Documentation/Reference/Tk" EXTRA_INSTALL="install-private-headers html-tk" EXTRA_BUILD_HTML='@ln -fs contents.htm "$(HTML_INSTALL_DIR)"/TkTOC.html' EXTRA_INSTALL_BINARIES='@echo "Installing Info.plist to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA_DIR) "$(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) Tk-Info.plist "$(LIB_INSTALL_DIR)/Resources/Info.plist"' EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing license.terms to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA) "$(TOP_DIR)/license.terms" "$(LIB_INSTALL_DIR)/Resources"' if test $tk_aqua = yes; then EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing Images to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA_DIR) "$(LIB_INSTALL_DIR)/Resources" && for i in Tk.tiff Tk.icns; do $(INSTALL_DATA) "$(MAC_OSX_DIR)/$$i" "$(LIB_INSTALL_DIR)/Resources"; done' EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing wish$(VERSION) script to $(INSTALL_ROOT)/'"${bindir}"'/" && $(INSTALL_DATA_DIR) "$(INSTALL_ROOT)/'"${bindir}"'" && printf > "$(INSTALL_ROOT)/'"${bindir}"'/wish$(VERSION)" "#!/bin/sh\n\"\$$(dirname \$$0)'"`eval d="${bindir}"; echo "$d" | sed -e 's#/[^/][^/]*#/..#g'`"'$(bindir)/Wish\" \"\$$@\"" && chmod +x "$(INSTALL_ROOT)/'"${bindir}"'/wish$(VERSION)"' bindir="${libdir}/Resources/Wish.app/Contents/MacOS" EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing Info.plist to $(BIN_INSTALL_DIR)/.." && $(INSTALL_DATA) Wish-Info.plist "$(BIN_INSTALL_DIR)/../Info.plist" && mv -f "$(BIN_INSTALL_DIR)/wish$(VERSION)" "$(BIN_INSTALL_DIR)/Wish"' EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing Wish.icns to $(BIN_INSTALL_DIR)/../Resources" && $(INSTALL_DATA_DIR) "$(BIN_INSTALL_DIR)/../Resources"' EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && $(INSTALL_DATA) "$(MAC_OSX_DIR)/Tk.icns" "$(BIN_INSTALL_DIR)/../Resources/Wish.icns"' EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing Wish.sdef to $(BIN_INSTALL_DIR)/../Resources" && $(INSTALL_DATA) "$(MAC_OSX_DIR)/Wish.sdef" "$(BIN_INSTALL_DIR)/../Resources"' fi EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Finalizing Tk.framework" && rm -f "$(LIB_INSTALL_DIR)/../Current" && ln -s "$(VERSION)" "$(LIB_INSTALL_DIR)/../Current" && for f in "$(LIB_FILE)" tkConfig.sh Resources Headers PrivateHeaders; do rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/Current/$$f" "$(LIB_INSTALL_DIR)/../.."; done && f="$(STUB_LIB_FILE)" && rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/$(VERSION)/$$f" "$(LIB_INSTALL_DIR)/../.."' # Don't use AC_DEFINE for the following as the framework version define # needs to go into the Makefile even when using autoheader, so that we # can pick up a potential make override of VERSION. Also, don't put this # into CFLAGS as it should not go into tkConfig.sh EXTRA_CC_SWITCHES="$EXTRA_CC_SWITCHES"' -DTK_FRAMEWORK_VERSION=\"$(VERSION)\"' else if test $tk_aqua = yes; then EXTRA_INSTALL_BINARIES='@echo "Installing Images to $(LIB_INSTALL_DIR)/" && $(INSTALL_DATA_DIR) "$(LIB_INSTALL_DIR)" && for i in Tk.tiff Tk.icns; do $(INSTALL_DATA) "$(MAC_OSX_DIR)/$$i" "$(LIB_INSTALL_DIR)"; done' fi # libdir must be a fully qualified path and not ${exec_prefix}/lib eval libdir="$libdir" if test "${ac_cv_cygwin}" = "yes" -a "$SHARED_BUILD" = "1"; then TK_LIB_FLAG="-ltk`echo ${TK_VERSION} | tr -d .`" TK_BUILD_LIB_SPEC="-L\$(TOP_DIR)/win ${TK_LIB_FLAG}" else if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then TK_LIB_FLAG="-ltk${TK_VERSION}" else TK_LIB_FLAG="-ltk`echo ${TK_VERSION} | tr -d .`" fi TK_BUILD_LIB_SPEC="-L`pwd | sed -e 's/ /\\\\ /g'` ${TK_LIB_FLAG}" fi TK_LIB_SPEC="-L${libdir} ${TK_LIB_FLAG}" fi #-------------------------------------------------------------------- # The statements below define various symbols relating to Tk # stub support. #-------------------------------------------------------------------- # Replace ${VERSION} with contents of ${TK_VERSION} eval "TK_STUB_LIB_FILE=libtkstub${TK_UNSHARED_LIB_SUFFIX}" eval "TK_STUB_LIB_DIR=${libdir}" if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then TK_STUB_LIB_FLAG="-ltkstub${TK_VERSION}" else TK_STUB_LIB_FLAG="-ltkstub`echo ${TK_VERSION} | tr -d .`" fi TK_BUILD_STUB_LIB_SPEC="-L`pwd | sed -e 's/ /\\\\ /g'` ${TK_STUB_LIB_FLAG}" TK_STUB_LIB_SPEC="-L${TK_STUB_LIB_DIR} ${TK_STUB_LIB_FLAG}" TK_BUILD_STUB_LIB_PATH="`pwd`/${TK_STUB_LIB_FILE}" TK_STUB_LIB_PATH="${TK_STUB_LIB_DIR}/${TK_STUB_LIB_FILE}" # Install time header dir can be set via --includedir eval "TK_INCLUDE_SPEC=\"-I${includedir}\"" #------------------------------------------------------------------------ # tkConfig.sh refers to this by a different name #------------------------------------------------------------------------ TK_SHARED_BUILD=${SHARED_BUILD} AC_SUBST(TK_VERSION) AC_SUBST(TK_MAJOR_VERSION) AC_SUBST(TK_MINOR_VERSION) AC_SUBST(TK_PATCH_LEVEL) AC_SUBST(TK_YEAR) AC_SUBST(TK_LIB_FILE) AC_SUBST(TK_LIB_FLAG) AC_SUBST(TK_LIB_SPEC) AC_SUBST(TK_STUB_LIB_FILE) AC_SUBST(TK_STUB_LIB_FLAG) AC_SUBST(TK_STUB_LIB_SPEC) AC_SUBST(TK_STUB_LIB_PATH) AC_SUBST(TK_INCLUDE_SPEC) AC_SUBST(TK_BUILD_STUB_LIB_SPEC) AC_SUBST(TK_BUILD_STUB_LIB_PATH) AC_SUBST(TK_SRC_DIR) AC_SUBST(TK_SHARED_BUILD) AC_SUBST(LD_LIBRARY_PATH_VAR) AC_SUBST(TK_BUILD_LIB_SPEC) AC_SUBST(TCL_STUB_FLAGS) AC_SUBST(XINCLUDES) AC_SUBST(XLIBSW) AC_SUBST(LOCALES) AC_SUBST(TK_WINDOWINGSYSTEM) AC_SUBST(TK_PKG_DIR) AC_SUBST(TK_LIBRARY) AC_SUBST(LIB_RUNTIME_DIR) AC_SUBST(PRIVATE_INCLUDE_DIR) AC_SUBST(HTML_DIR) AC_SUBST(EXTRA_CC_SWITCHES) AC_SUBST(EXTRA_APP_CC_SWITCHES) AC_SUBST(EXTRA_INSTALL) AC_SUBST(EXTRA_INSTALL_BINARIES) AC_SUBST(EXTRA_BUILD_HTML) AC_SUBST(EXTRA_WISH_LIBS) AC_SUBST(CFBUNDLELOCALIZATIONS) AC_SUBST(TK_RSRC_FILE) AC_SUBST(WISH_RSRC_FILE) AC_SUBST(LIB_RSRC_FILE) AC_SUBST(APP_RSRC_FILE) AC_SUBST(REZ) AC_SUBST(REZ_FLAGS) AC_CONFIG_FILES([ Makefile:../unix/Makefile.in tkConfig.sh:../unix/tkConfig.sh.in tk.pc:../unix/tk.pc.in ]) AC_OUTPUT dnl Local Variables: dnl mode: autoconf dnl End: tk8.6.5/unix/tkUnixXId.c0000644003604700454610000000707712620363651013523 0ustar dgp771div/* * tkUnixXId.c -- * * Copyright (c) 1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tkUnixInt.h" /* *---------------------------------------------------------------------- * * Tk_FreeXId -- * * This function is called to indicate that an X resource identifier is * now free. * * Results: * None. * * Side effects: * The identifier is added to the stack of free identifiers for its * display, so that it can be re-used. * *---------------------------------------------------------------------- */ void Tk_FreeXId( Display *display, /* Display for which xid was allocated. */ XID xid) /* Identifier that is no longer in use. */ { /* * This does nothing, because the XC-MISC extension takes care of * freeing XIDs for us. It has been a standard X11 extension for * about 15 years as of 2008. Keith Packard and another X.org * developer suggested that we remove the previous code that used: * #define XLIB_ILLEGAL_ACCESS. */ } /* *---------------------------------------------------------------------- * * Tk_GetPixmap -- * * Same as the XCreatePixmap function except that it manages resource * identifiers better. * * Results: * Returns a new pixmap. * * Side effects: * None. * *---------------------------------------------------------------------- */ Pixmap Tk_GetPixmap( Display *display, /* Display for new pixmap. */ Drawable d, /* Drawable where pixmap will be used. */ int width, int height, /* Dimensions of pixmap. */ int depth) /* Bits per pixel for pixmap. */ { return XCreatePixmap(display, d, (unsigned) width, (unsigned) height, (unsigned) depth); } /* *---------------------------------------------------------------------- * * Tk_FreePixmap -- * * Same as the XFreePixmap function except that it also marks the * resource identifier as free. * * Results: * None. * * Side effects: * The pixmap is freed in the X server and its resource identifier is * saved for re-use. * *---------------------------------------------------------------------- */ void Tk_FreePixmap( Display *display, /* Display for which pixmap was allocated. */ Pixmap pixmap) /* Identifier for pixmap. */ { XFreePixmap(display, pixmap); Tk_FreeXId(display, (XID) pixmap); } /* *---------------------------------------------------------------------- * * TkpScanWindowId -- * * Given a string, produce the corresponding Window Id. * * Results: * The return value is normally TCL_OK; in this case *idPtr will be set * to the Window value equivalent to string. If string is improperly * formed then TCL_ERROR is returned and an error message will be left in * the interp's result. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TkpScanWindowId( Tcl_Interp *interp, const char *string, Window *idPtr) { int code; Tcl_Obj obj; obj.refCount = 1; obj.bytes = (char *) string; /* DANGER?! */ obj.length = strlen(string); obj.typePtr = NULL; code = Tcl_GetLongFromObj(interp, &obj, (long *)idPtr); if (obj.refCount > 1) { Tcl_Panic("invalid sharing of Tcl_Obj on C stack"); } if (obj.typePtr && obj.typePtr->freeIntRepProc) { obj.typePtr->freeIntRepProc(&obj); } return code; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ tk8.6.5/unix/tkUnixSend.c0000644003604700454610000016331112377375532013734 0ustar dgp771div/* * tkUnixSend.c -- * * This file provides functions that implement the "send" command, * allowing commands to be passed from interpreter to interpreter. * * Copyright (c) 1989-1994 The Regents of the University of California. * Copyright (c) 1994-1996 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tkUnixInt.h" /* * The following structure is used to keep track of the interpreters * registered by this process. */ typedef struct RegisteredInterp { char *name; /* Interpreter's name (malloc-ed). */ Tcl_Interp *interp; /* Interpreter associated with name. NULL * means that the application was unregistered * or deleted while a send was in progress to * it. */ TkDisplay *dispPtr; /* Display for the application. Needed because * we may need to unregister the interpreter * after its main window has been deleted. */ struct RegisteredInterp *nextPtr; /* Next in list of names associated with * interps in this process. NULL means end of * list. */ } RegisteredInterp; /* * A registry of all interpreters for a display is kept in a property * "InterpRegistry" on the root window of the display. It is organized as a * series of zero or more concatenated strings (in no particular order), each * of the form * window space name '\0' * where "window" is the hex id of the comm. window to use to talk to an * interpreter named "name". * * When the registry is being manipulated by an application (e.g. to add or * remove an entry), it is loaded into memory using a structure of the * following type: */ typedef struct NameRegistry { TkDisplay *dispPtr; /* Display from which the registry was * read. */ int locked; /* Non-zero means that the display was locked * when the property was read in. */ int modified; /* Non-zero means that the property has been * modified, so it needs to be written out * when the NameRegistry is closed. */ unsigned long propLength; /* Length of the property, in bytes. */ char *property; /* The contents of the property, or NULL if * none. See format description above; this is * *not* terminated by the first null * character. Dynamically allocated. */ int allocedByX; /* Non-zero means must free property with * XFree; zero means use ckfree. */ } NameRegistry; /* * When a result is being awaited from a sent command, one of the following * structures is present on a list of all outstanding sent commands. The * information in the structure is used to process the result when it arrives. * You're probably wondering how there could ever be multiple outstanding sent * commands. This could happen if interpreters invoke each other recursively. * It's unlikely, but possible. */ typedef struct PendingCommand { int serial; /* Serial number expected in result. */ TkDisplay *dispPtr; /* Display being used for communication. */ const char *target; /* Name of interpreter command is being sent * to. */ Window commWindow; /* Target's communication window. */ Tcl_Interp *interp; /* Interpreter from which the send was * invoked. */ int code; /* Tcl return code for command will be stored * here. */ char *result; /* String result for command (malloc'ed), or * NULL. */ char *errorInfo; /* Information for "errorInfo" variable, or * NULL (malloc'ed). */ char *errorCode; /* Information for "errorCode" variable, or * NULL (malloc'ed). */ int gotResponse; /* 1 means a response has been received, 0 * means the command is still outstanding. */ struct PendingCommand *nextPtr; /* Next in list of all outstanding commands. * NULL means end of list. */ } PendingCommand; typedef struct ThreadSpecificData { PendingCommand *pendingCommands; /* List of all commands currently being waited * for. */ RegisteredInterp *interpListPtr; /* List of all interpreters registered in the * current process. */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; /* * The information below is used for communication between processes during * "send" commands. Each process keeps a private window, never even mapped, * with one property, "Comm". When a command is sent to an interpreter, the * command is appended to the comm property of the communication window * associated with the interp's process. Similarly, when a result is returned * from a sent command, it is also appended to the comm property. * * Each command and each result takes the form of ASCII text. For a command, * the text consists of a zero character followed by several null-terminated * ASCII strings. The first string consists of the single letter "c". * Subsequent strings have the form "option value" where the following options * are supported: * * -r commWindow serial * * This option means that a response should be sent to the window whose X * identifier is "commWindow" (in hex), and the response should be * identified with the serial number given by "serial" (in decimal). If * this option isn't specified then the send is asynchronous and no * response is sent. * * -n name * * "Name" gives the name of the application for which the command is * intended. This option must be present. * * -s script * * "Script" is the script to be executed. This option must be present. * * The options may appear in any order. The -n and -s options must be present, * but -r may be omitted for asynchronous RPCs. For compatibility with future * releases that may add new features, there may be additional options * present; as long as they start with a "-" character, they will be ignored. * * A result also consists of a zero character followed by several null- * terminated ASCII strings. The first string consists of the single letter * "r". Subsequent strings have the form "option value" where the following * options are supported: * * -s serial * * Identifies the command for which this is the result. It is the same as * the "serial" field from the -s option in the command. This option must * be present. * * -c code * * "Code" is the completion code for the script, in decimal. If the code * is omitted it defaults to TCL_OK. * * -r result * * "Result" is the result string for the script, which may be either a * result or an error message. If this field is omitted then it defaults * to an empty string. * * -i errorInfo * * "ErrorInfo" gives a string with which to initialize the errorInfo * variable. This option may be omitted; it is ignored unless the * completion code is TCL_ERROR. * * -e errorCode * * "ErrorCode" gives a string with with to initialize the errorCode * variable. This option may be omitted; it is ignored unless the * completion code is TCL_ERROR. * * Options may appear in any order, and only the -s option must be present. As * with commands, there may be additional options besides these; unknown * options are ignored. */ /* * Other miscellaneous per-process data: */ static struct { int sendSerial; /* The serial number that was used in the last * "send" command. */ int sendDebug; /* This can be set while debugging to do * things like skip locking the server. */ } localData = {0, 0}; /* * Maximum size property that can be read at one time by this module: */ #define MAX_PROP_WORDS 100000 /* * Forward declarations for functions defined later in this file: */ static int AppendErrorProc(ClientData clientData, XErrorEvent *errorPtr); static void AppendPropCarefully(Display *display, Window window, Atom property, char *value, int length, PendingCommand *pendingPtr); static void DeleteProc(ClientData clientData); static void RegAddName(NameRegistry *regPtr, const char *name, Window commWindow); static void RegClose(NameRegistry *regPtr); static void RegDeleteName(NameRegistry *regPtr, const char *name); static Window RegFindName(NameRegistry *regPtr, const char *name); static NameRegistry * RegOpen(Tcl_Interp *interp, TkDisplay *dispPtr, int lock); static void SendEventProc(ClientData clientData, XEvent *eventPtr); static int SendInit(Tcl_Interp *interp, TkDisplay *dispPtr); static Tk_RestrictProc SendRestrictProc; static int ServerSecure(TkDisplay *dispPtr); static void UpdateCommWindow(TkDisplay *dispPtr); static int ValidateName(TkDisplay *dispPtr, const char *name, Window commWindow, int oldOK); /* *---------------------------------------------------------------------- * * RegOpen -- * * This function loads the name registry for a display into memory so * that it can be manipulated. * * Results: * The return value is a pointer to the loaded registry. * * Side effects: * If "lock" is set then the server will be locked. It is the caller's * responsibility to call RegClose when finished with the registry, so * that we can write back the registry if needed, unlock the server if * needed, and free memory. * *---------------------------------------------------------------------- */ static NameRegistry * RegOpen( Tcl_Interp *interp, /* Interpreter to use for error reporting * (errors cause a panic so in fact no error * is ever returned, but the interpreter is * needed anyway). */ TkDisplay *dispPtr, /* Display whose name registry is to be * opened. */ int lock) /* Non-zero means lock the window server when * opening the registry, so no-one else can * use the registry until we close it. */ { NameRegistry *regPtr; int result, actualFormat; unsigned long bytesAfter; Atom actualType; char **propertyPtr; if (dispPtr->commTkwin == NULL) { SendInit(interp, dispPtr); } regPtr = ckalloc(sizeof(NameRegistry)); regPtr->dispPtr = dispPtr; regPtr->locked = 0; regPtr->modified = 0; regPtr->allocedByX = 1; propertyPtr = ®Ptr->property; if (lock && !localData.sendDebug) { XGrabServer(dispPtr->display); regPtr->locked = 1; } /* * Read the registry property. */ result = XGetWindowProperty(dispPtr->display, RootWindow(dispPtr->display, 0), dispPtr->registryProperty, 0, MAX_PROP_WORDS, False, XA_STRING, &actualType, &actualFormat, ®Ptr->propLength, &bytesAfter, (unsigned char **) propertyPtr); if (actualType == None) { regPtr->propLength = 0; regPtr->property = NULL; } else if ((result != Success) || (actualFormat != 8) || (actualType != XA_STRING)) { /* * The property is improperly formed; delete it. */ if (regPtr->property != NULL) { XFree(regPtr->property); regPtr->propLength = 0; regPtr->property = NULL; } XDeleteProperty(dispPtr->display, RootWindow(dispPtr->display, 0), dispPtr->registryProperty); } /* * Xlib placed an extra null byte after the end of the property, just to * make sure that it is always NULL-terminated. Be sure to include this * byte in our count if it's needed to ensure null termination (note: as * of 8/95 I'm no longer sure why this code is needed; seems like it * shouldn't be). */ if ((regPtr->propLength > 0) && (regPtr->property[regPtr->propLength-1] != 0)) { regPtr->propLength++; } return regPtr; } /* *---------------------------------------------------------------------- * * RegFindName -- * * Given an open name registry, this function finds an entry with a given * name, if there is one, and returns information about that entry. * * Results: * The return value is the X identifier for the comm window for the * application named "name", or None if there is no such entry in the * registry. * * Side effects: * None. * *---------------------------------------------------------------------- */ static Window RegFindName( NameRegistry *regPtr, /* Pointer to a registry opened with a * previous call to RegOpen. */ const char *name) /* Name of an application. */ { char *p; for (p=regPtr->property ; p-regPtr->property<(int)regPtr->propLength ;) { char *entry = p; while ((*p != 0) && (!isspace(UCHAR(*p)))) { p++; } if ((*p != 0) && (strcmp(name, p+1) == 0)) { unsigned id; if (sscanf(entry, "%x", &id) == 1) { /* * Must cast from an unsigned int to a Window in case we are * on a 64-bit architecture. */ return (Window) id; } } while (*p != 0) { p++; } p++; } return None; } /* *---------------------------------------------------------------------- * * RegDeleteName -- * * This function deletes the entry for a given name from an open * registry. * * Results: * None. * * Side effects: * If there used to be an entry named "name" in the registry, then it is * deleted and the registry is marked as modified so it will be written * back when closed. * *---------------------------------------------------------------------- */ static void RegDeleteName( NameRegistry *regPtr, /* Pointer to a registry opened with a * previous call to RegOpen. */ const char *name) /* Name of an application. */ { char *p; for (p=regPtr->property ; p-regPtr->property<(int)regPtr->propLength ;) { char *entry = p, *entryName; while ((*p != 0) && (!isspace(UCHAR(*p)))) { p++; } if (*p != 0) { p++; } entryName = p; while (*p != 0) { p++; } p++; if (strcmp(name, entryName) == 0) { int count; /* * Found the matching entry. Copy everything after it down on top * of it. */ count = regPtr->propLength - (p - regPtr->property); if (count > 0) { char *src, *dst; for (src=p , dst=entry ; count>0 ; src++, dst++, count--) { *dst = *src; } } regPtr->propLength -= p - entry; regPtr->modified = 1; return; } } } /* *---------------------------------------------------------------------- * * RegAddName -- * * Add a new entry to an open registry. * * Results: * None. * * Side effects: * The open registry is expanded; it is marked as modified so that it * will be written back when closed. * *---------------------------------------------------------------------- */ static void RegAddName( NameRegistry *regPtr, /* Pointer to a registry opened with a * previous call to RegOpen. */ const char *name, /* Name of an application. The caller must * ensure that this name isn't already * registered. */ Window commWindow) /* X identifier for comm. window of * application. */ { char id[30], *newProp; int idLength, newBytes; sprintf(id, "%x ", (unsigned) commWindow); idLength = strlen(id); newBytes = idLength + strlen(name) + 1; newProp = ckalloc(regPtr->propLength + newBytes); strcpy(newProp, id); strcpy(newProp+idLength, name); if (regPtr->property != NULL) { memcpy(newProp + newBytes, regPtr->property, regPtr->propLength); if (regPtr->allocedByX) { XFree(regPtr->property); } else { ckfree(regPtr->property); } } regPtr->modified = 1; regPtr->propLength += newBytes; regPtr->property = newProp; regPtr->allocedByX = 0; } /* *---------------------------------------------------------------------- * * RegClose -- * * This function is called to end a series of operations on a name * registry. * * Results: * None. * * Side effects: * The registry is written back if it has been modified, and the X server * is unlocked if it was locked. Memory for the registry is freed, so the * caller should never use regPtr again. * *---------------------------------------------------------------------- */ static void RegClose( NameRegistry *regPtr) /* Pointer to a registry opened with a * previous call to RegOpen. */ { if (regPtr->modified) { if (!regPtr->locked && !localData.sendDebug) { Tcl_Panic("The name registry was modified without being locked!"); } XChangeProperty(regPtr->dispPtr->display, RootWindow(regPtr->dispPtr->display, 0), regPtr->dispPtr->registryProperty, XA_STRING, 8, PropModeReplace, (unsigned char *) regPtr->property, (int) regPtr->propLength); } if (regPtr->locked) { XUngrabServer(regPtr->dispPtr->display); } /* * After ungrabbing the server, it's important to flush the output * immediately so that the server sees the ungrab command. Otherwise we * might do something else that needs to communicate with the server (such * as invoking a subprocess that needs to do I/O to the screen); if the * ungrab command is still sitting in our output buffer, we could * deadlock. */ XFlush(regPtr->dispPtr->display); if (regPtr->property != NULL) { if (regPtr->allocedByX) { XFree(regPtr->property); } else { ckfree(regPtr->property); } } ckfree(regPtr); } /* *---------------------------------------------------------------------- * * ValidateName -- * * This function checks to see if an entry in the registry is still * valid. * * Results: * The return value is 1 if the given commWindow exists and its name is * "name". Otherwise 0 is returned. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int ValidateName( TkDisplay *dispPtr, /* Display for which to perform the * validation. */ const char *name, /* The name of an application. */ Window commWindow, /* X identifier for the application's comm. * window. */ int oldOK) /* Non-zero means that we should consider an * application to be valid even if it looks * like an old-style (pre-4.0) one; 0 means * consider these invalid. */ { int result, actualFormat, argc, i; unsigned long length, bytesAfter; Atom actualType; char *property, **propertyPtr = &property; Tk_ErrorHandler handler; const char **argv; property = NULL; /* * Ignore X errors when reading the property (e.g., the window might not * exist). If an error occurs, result will be some value other than * Success. */ handler = Tk_CreateErrorHandler(dispPtr->display, -1, -1, -1, NULL, NULL); result = XGetWindowProperty(dispPtr->display, commWindow, dispPtr->appNameProperty, 0, MAX_PROP_WORDS, False, XA_STRING, &actualType, &actualFormat, &length, &bytesAfter, (unsigned char **) propertyPtr); if ((result == Success) && (actualType == None)) { XWindowAttributes atts; /* * The comm. window exists but the property we're looking for doesn't * exist. This probably means that the application comes from an older * version of Tk (< 4.0) that didn't set the property; if this is the * case, then assume for compatibility's sake that everything's OK. * However, it's also possible that some random application has * re-used the window id for something totally unrelated. Check a few * characteristics of the window, such as its dimensions and mapped * state, to be sure that it still "smells" like a commWindow. */ if (!oldOK || !XGetWindowAttributes(dispPtr->display, commWindow, &atts) || (atts.width != 1) || (atts.height != 1) || (atts.map_state != IsUnmapped)) { result = 0; } else { result = 1; } } else if ((result == Success) && (actualFormat == 8) && (actualType == XA_STRING)) { result = 0; if (Tcl_SplitList(NULL, property, &argc, &argv) == TCL_OK) { for (i = 0; i < argc; i++) { if (strcmp(argv[i], name) == 0) { result = 1; break; } } ckfree(argv); } } else { result = 0; } Tk_DeleteErrorHandler(handler); if (property != NULL) { XFree(property); } return result; } /* *---------------------------------------------------------------------- * * ServerSecure -- * * Check whether a server is secure enough for us to trust Tcl scripts * arriving via that server. * * Results: * The return value is 1 if the server is secure, which means that * host-style authentication is turned on but there are no hosts in the * enabled list. This means that some other form of authorization * (presumably more secure, such as xauth) is in use. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int ServerSecure( TkDisplay *dispPtr) /* Display to check. */ { #ifdef TK_NO_SECURITY return 1; #else XHostAddress *addrPtr; int numHosts, secure; Bool enabled; addrPtr = XListHosts(dispPtr->display, &numHosts, &enabled); if (!enabled) { insecure: secure = 0; } else if (numHosts == 0) { secure = 1; } else { /* * Recent versions of X11 have the extra feature of allowing more * sophisticated authorization checks to be performed than the dozy * old ones that used to plague xhost usage. However, not all deployed * versions of Xlib know how to deal with this feature, so this code * is conditional on having the right #def in place. [Bug 1909931] * * Note that at this point we know that there's at least one entry in * the list returned by XListHosts. However there may be multiple * entries; as long as each is one of either 'SI:localhost:*' or * 'SI:localgroup:*' then we will claim to be secure enough. */ #ifdef FamilyServerInterpreted XServerInterpretedAddress *siPtr; int i; for (i=0 ; itypelength == 9 /* ==strlen("localuser") */ && !memcmp(siPtr->type, "localuser", 9)) && !(siPtr->typelength == 10 /* ==strlen("localgroup") */ && !memcmp(siPtr->type, "localgroup", 10))) { /* * The other defined types of server-interpreted controls * involve particular hosts. These are still insecure for the * same reasons that classic xhost access is insecure; there's * just no way to be sure that the users on those systems are * the ones who should be allowed to connect to this display. */ goto insecure; } } secure = 1; #else /* * We don't understand what the X server is letting in, so we err on * the side of safety. */ secure = 0; #endif /* FamilyServerInterpreted */ } if (addrPtr != NULL) { XFree((char *) addrPtr); } return secure; #endif /* TK_NO_SECURITY */ } /* *---------------------------------------------------------------------- * * Tk_SetAppName -- * * This function is called to associate an ASCII name with a Tk * application. If the application has already been named, the name * replaces the old one. * * Results: * The return value is the name actually given to the application. This * will normally be the same as name, but if name was already in use for * an application then a name of the form "name #2" will be chosen, with * a high enough number to make the name unique. * * Side effects: * Registration info is saved, thereby allowing the "send" command to be * used later to invoke commands in the application. In addition, the * "send" command is created in the application's interpreter. The * registration will be removed automatically if the interpreter is * deleted or the "send" command is removed. * *---------------------------------------------------------------------- */ const char * Tk_SetAppName( Tk_Window tkwin, /* Token for any window in the application to * be named: it is just used to identify the * application and the display. */ const char *name) /* The name that will be used to refer to the * interpreter in later "send" commands. Must * be globally unique. */ { RegisteredInterp *riPtr, *riPtr2; Window w; TkWindow *winPtr = (TkWindow *) tkwin; TkDisplay *dispPtr = winPtr->dispPtr; NameRegistry *regPtr; Tcl_Interp *interp; const char *actualName; Tcl_DString dString; int offset, i; ThreadSpecificData *tsdPtr = Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); interp = winPtr->mainPtr->interp; if (dispPtr->commTkwin == NULL) { SendInit(interp, winPtr->dispPtr); } /* * See if the application is already registered; if so, remove its current * name from the registry. */ regPtr = RegOpen(interp, winPtr->dispPtr, 1); for (riPtr = tsdPtr->interpListPtr; ; riPtr = riPtr->nextPtr) { if (riPtr == NULL) { /* * This interpreter isn't currently registered; create the data * structure that will be used to register it locally, plus add * the "send" command to the interpreter. */ riPtr = ckalloc(sizeof(RegisteredInterp)); riPtr->interp = interp; riPtr->dispPtr = winPtr->dispPtr; riPtr->nextPtr = tsdPtr->interpListPtr; tsdPtr->interpListPtr = riPtr; riPtr->name = NULL; Tcl_CreateObjCommand(interp, "send", Tk_SendObjCmd, riPtr, DeleteProc); if (Tcl_IsSafe(interp)) { Tcl_HideCommand(interp, "send", "send"); } break; } if (riPtr->interp == interp) { /* * The interpreter is currently registered; remove it from the * name registry. */ if (riPtr->name) { RegDeleteName(regPtr, riPtr->name); ckfree(riPtr->name); } break; } } /* * Pick a name to use for the application. Use "name" if it's not already * in use. Otherwise add a suffix such as " #2", trying larger and larger * numbers until we eventually find one that is unique. */ actualName = name; offset = 0; /* Needed only to avoid "used before * set" compiler warnings. */ for (i = 1; ; i++) { if (i > 1) { if (i == 2) { Tcl_DStringInit(&dString); Tcl_DStringAppend(&dString, name, -1); Tcl_DStringAppend(&dString, " #", 2); offset = Tcl_DStringLength(&dString); Tcl_DStringSetLength(&dString, offset+TCL_INTEGER_SPACE); actualName = Tcl_DStringValue(&dString); } sprintf(Tcl_DStringValue(&dString) + offset, "%d", i); } w = RegFindName(regPtr, actualName); if (w == None) { break; } /* * The name appears to be in use already, but double-check to be sure * (perhaps the application died without removing its name from the * registry?). */ if (w == Tk_WindowId(dispPtr->commTkwin)) { for (riPtr2 = tsdPtr->interpListPtr; riPtr2 != NULL; riPtr2 = riPtr2->nextPtr) { if ((riPtr2->interp != interp) && (strcmp(riPtr2->name, actualName) == 0)) { goto nextSuffix; } } RegDeleteName(regPtr, actualName); break; } else if (!ValidateName(winPtr->dispPtr, actualName, w, 1)) { RegDeleteName(regPtr, actualName); break; } nextSuffix: continue; } /* * We've now got a name to use. Store it in the name registry and in the * local entry for this application, plus put it in a property on the * commWindow. */ RegAddName(regPtr, actualName, Tk_WindowId(dispPtr->commTkwin)); RegClose(regPtr); riPtr->name = ckalloc(strlen(actualName) + 1); strcpy(riPtr->name, actualName); if (actualName != name) { Tcl_DStringFree(&dString); } UpdateCommWindow(dispPtr); return riPtr->name; } /* *-------------------------------------------------------------- * * Tk_SendObjCmd -- * * This function is invoked to process the "send" Tcl command. See the * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *-------------------------------------------------------------- */ int Tk_SendObjCmd( ClientData clientData, /* Information about sender (only dispPtr * field is used). */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument strings. */ { enum { SEND_ASYNC, SEND_DISPLAYOF, SEND_LAST }; static const char *const sendOptions[] = { "-async", "-displayof", "--", NULL }; TkWindow *winPtr; Window commWindow; PendingCommand pending; register RegisteredInterp *riPtr; const char *destName; int result, index, async, i, firstArg; Tk_RestrictProc *prevProc; ClientData prevArg; TkDisplay *dispPtr; Tcl_Time timeout; NameRegistry *regPtr; Tcl_DString request; ThreadSpecificData *tsdPtr = Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); Tcl_Interp *localInterp; /* Used when the interpreter to send the * command to is within the same process. */ /* * Process options, if any. */ async = 0; winPtr = (TkWindow *) Tk_MainWindow(interp); if (winPtr == NULL) { return TCL_ERROR; } for (i = 1; i < objc; i++) { if (Tcl_GetIndexFromObjStruct(interp, objv[i], sendOptions, sizeof(char *), "option", 0, &index) != TCL_OK) { break; } if (index == SEND_ASYNC) { ++async; } else if (index == SEND_DISPLAYOF) { winPtr = (TkWindow *) Tk_NameToWindow(interp, Tcl_GetString(objv[++i]), (Tk_Window) winPtr); if (winPtr == NULL) { return TCL_ERROR; } } else if (index == SEND_LAST) { i++; break; } } if (objc < (i+2)) { Tcl_WrongNumArgs(interp, 1, objv, "?-option value ...? interpName arg ?arg ...?"); return TCL_ERROR; } destName = Tcl_GetString(objv[i]); firstArg = i+1; dispPtr = winPtr->dispPtr; if (dispPtr->commTkwin == NULL) { SendInit(interp, winPtr->dispPtr); } /* * See if the target interpreter is local. If so, execute the command * directly without going through the X server. The only tricky thing is * passing the result from the target interpreter to the invoking * interpreter. Watch out: they could be the same! */ for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; riPtr = riPtr->nextPtr) { if ((riPtr->dispPtr != dispPtr) || (strcmp(riPtr->name, destName) != 0)) { continue; } Tcl_Preserve(riPtr); localInterp = riPtr->interp; Tcl_Preserve(localInterp); if (firstArg == (objc-1)) { result = Tcl_EvalEx(localInterp, Tcl_GetString(objv[firstArg]), -1, TCL_EVAL_GLOBAL); } else { Tcl_DStringInit(&request); Tcl_DStringAppend(&request, Tcl_GetString(objv[firstArg]), -1); for (i = firstArg+1; i < objc; i++) { Tcl_DStringAppend(&request, " ", 1); Tcl_DStringAppend(&request, Tcl_GetString(objv[i]), -1); } result = Tcl_EvalEx(localInterp, Tcl_DStringValue(&request), -1, TCL_EVAL_GLOBAL); Tcl_DStringFree(&request); } if (interp != localInterp) { if (result == TCL_ERROR) { Tcl_Obj *errorObjPtr; /* * An error occurred, so transfer error information from the * destination interpreter back to our interpreter. Must clear * interp's result before calling Tcl_AddErrorInfo, since * Tcl_AddErrorInfo will store the interp's result in * errorInfo before appending riPtr's $errorInfo; we've * already got everything we need in riPtr's $errorInfo. */ Tcl_ResetResult(interp); Tcl_AddErrorInfo(interp, Tcl_GetVar2(localInterp, "errorInfo", NULL, TCL_GLOBAL_ONLY)); errorObjPtr = Tcl_GetVar2Ex(localInterp, "errorCode", NULL, TCL_GLOBAL_ONLY); Tcl_SetObjErrorCode(interp, errorObjPtr); } Tcl_SetObjResult(interp, Tcl_GetObjResult(localInterp)); Tcl_ResetResult(localInterp); } Tcl_Release(riPtr); Tcl_Release(localInterp); return result; } /* * Bind the interpreter name to a communication window. */ regPtr = RegOpen(interp, winPtr->dispPtr, 0); commWindow = RegFindName(regPtr, destName); RegClose(regPtr); if (commWindow == None) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "no application named \"%s\"", destName)); Tcl_SetErrorCode(interp, "TK", "LOOKUP", "APPLICATION", destName, NULL); return TCL_ERROR; } /* * Send the command to the target interpreter by appending it to the comm * window in the communication window. */ localData.sendSerial++; Tcl_DStringInit(&request); Tcl_DStringAppend(&request, "\0c\0-n ", 6); Tcl_DStringAppend(&request, destName, -1); if (!async) { char buffer[TCL_INTEGER_SPACE * 2]; sprintf(buffer, "%x %d", (unsigned) Tk_WindowId(dispPtr->commTkwin), localData.sendSerial); Tcl_DStringAppend(&request, "\0-r ", 4); Tcl_DStringAppend(&request, buffer, -1); } Tcl_DStringAppend(&request, "\0-s ", 4); Tcl_DStringAppend(&request, Tcl_GetString(objv[firstArg]), -1); for (i = firstArg+1; i < objc; i++) { Tcl_DStringAppend(&request, " ", 1); Tcl_DStringAppend(&request, Tcl_GetString(objv[i]), -1); } (void) AppendPropCarefully(dispPtr->display, commWindow, dispPtr->commProperty, Tcl_DStringValue(&request), Tcl_DStringLength(&request) + 1, (async ? NULL : &pending)); Tcl_DStringFree(&request); if (async) { /* * This is an asynchronous send: return immediately without waiting * for a response. */ return TCL_OK; } /* * Register the fact that we're waiting for a command to complete (this is * needed by SendEventProc and by AppendErrorProc to pass back the * command's results). Set up a timeout handler so that we can check * during long sends to make sure that the destination application is * still alive. */ pending.serial = localData.sendSerial; pending.dispPtr = dispPtr; pending.target = destName; pending.commWindow = commWindow; pending.interp = interp; pending.result = NULL; pending.errorInfo = NULL; pending.errorCode = NULL; pending.gotResponse = 0; pending.nextPtr = tsdPtr->pendingCommands; tsdPtr->pendingCommands = &pending; /* * Enter a loop processing X events until the result comes in or the * target is declared to be dead. While waiting for a result, look only at * send-related events so that the send is synchronous with respect to * other events in the application. */ prevProc = Tk_RestrictEvents(SendRestrictProc, NULL, &prevArg); Tcl_GetTime(&timeout); timeout.sec += 2; while (!pending.gotResponse) { if (!TkUnixDoOneXEvent(&timeout)) { /* * An unusually long amount of time has elapsed during the * processing of a sent command. Check to make sure that the * target application still exists. If it does, reset the timeout. */ if (!ValidateName(pending.dispPtr, pending.target, pending.commWindow, 0)) { const char *msg; if (ValidateName(pending.dispPtr, pending.target, pending.commWindow, 1)) { msg = "target application died or uses a Tk version before 4.0"; } else { msg = "target application died"; } pending.code = TCL_ERROR; pending.result = ckalloc(strlen(msg) + 1); strcpy(pending.result, msg); pending.gotResponse = 1; } else { Tcl_GetTime(&timeout); timeout.sec += 2; } } } Tk_RestrictEvents(prevProc, prevArg, &prevArg); /* * Unregister the information about the pending command and return the * result. */ if (tsdPtr->pendingCommands != &pending) { Tcl_Panic("Tk_SendCmd: corrupted send stack"); } tsdPtr->pendingCommands = pending.nextPtr; if (pending.errorInfo != NULL) { /* * Special trick: must clear the interp's result before calling * Tcl_AddErrorInfo, since Tcl_AddErrorInfo will store the interp's * result in errorInfo before appending pending.errorInfo; we've * already got everything we need in pending.errorInfo. */ Tcl_ResetResult(interp); Tcl_AddErrorInfo(interp, pending.errorInfo); ckfree(pending.errorInfo); } if (pending.errorCode != NULL) { Tcl_SetObjErrorCode(interp, Tcl_NewStringObj(pending.errorCode, -1)); ckfree(pending.errorCode); } Tcl_SetObjResult(interp, Tcl_NewStringObj(pending.result, -1)); ckfree(pending.result); return pending.code; } /* *---------------------------------------------------------------------- * * TkGetInterpNames -- * * This function is invoked to fetch a list of all the interpreter names * currently registered for the display of a particular window. * * Results: * A standard Tcl return value. The interp's result will be set to hold a * list of all the interpreter names defined for tkwin's display. If an * error occurs, then TCL_ERROR is returned and the interp's result will * hold an error message. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TkGetInterpNames( Tcl_Interp *interp, /* Interpreter for returning a result. */ Tk_Window tkwin) /* Window whose display is to be used for the * lookup. */ { TkWindow *winPtr = (TkWindow *) tkwin; NameRegistry *regPtr; Tcl_Obj *resultObj = Tcl_NewObj(); char *p; /* * Read the registry property, then scan through all of its entries. * Validate each entry to be sure that its application still exists. */ regPtr = RegOpen(interp, winPtr->dispPtr, 1); for (p=regPtr->property ; p-regPtr->property<(int)regPtr->propLength ;) { char *entry = p, *entryName; Window commWindow; unsigned id; if (sscanf(p, "%x", (unsigned *) &id) != 1) { commWindow = None; } else { commWindow = id; } while ((*p != 0) && (!isspace(UCHAR(*p)))) { p++; } if (*p != 0) { p++; } entryName = p; while (*p != 0) { p++; } p++; if (ValidateName(winPtr->dispPtr, entryName, commWindow, 1)) { /* * The application still exists; add its name to the result. */ Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(entryName, -1)); } else { int count; /* * This name is bogus (perhaps the application died without * cleaning up its entry in the registry?). Delete the name. */ count = regPtr->propLength - (p - regPtr->property); if (count > 0) { char *src, *dst; for (src = p, dst = entry; count > 0; src++, dst++, count--) { *dst = *src; } } regPtr->propLength -= p - entry; regPtr->modified = 1; p = entry; } } RegClose(regPtr); Tcl_SetObjResult(interp, resultObj); return TCL_OK; } /* *-------------------------------------------------------------- * * TkSendCleanup -- * * This function is called to free resources used by the communication * channels for sending commands and receiving results. * * Results: * None. * * Side effects: * Frees various data structures and windows. * *-------------------------------------------------------------- */ void TkSendCleanup( TkDisplay *dispPtr) { if (dispPtr->commTkwin != NULL) { Tk_DeleteEventHandler(dispPtr->commTkwin, PropertyChangeMask, SendEventProc, dispPtr); Tk_DestroyWindow(dispPtr->commTkwin); Tcl_Release(dispPtr->commTkwin); dispPtr->commTkwin = NULL; } } /* *-------------------------------------------------------------- * * SendInit -- * * This function is called to initialize the communication channels for * sending commands and receiving results. * * Results: * None. * * Side effects: * Sets up various data structures and windows. * *-------------------------------------------------------------- */ static int SendInit( Tcl_Interp *interp, /* Interpreter to use for error reporting (no * errors are ever returned, but the * interpreter is needed anyway). */ TkDisplay *dispPtr) /* Display to initialize. */ { XSetWindowAttributes atts; /* * Create the window used for communication, and set up an event handler * for it. */ dispPtr->commTkwin = (Tk_Window) TkAllocWindow(dispPtr, DefaultScreen(dispPtr->display), NULL); Tcl_Preserve(dispPtr->commTkwin); ((TkWindow *) dispPtr->commTkwin)->flags |= TK_TOP_HIERARCHY|TK_TOP_LEVEL|TK_HAS_WRAPPER|TK_WIN_MANAGED; TkWmNewWindow((TkWindow *) dispPtr->commTkwin); atts.override_redirect = True; Tk_ChangeWindowAttributes(dispPtr->commTkwin, CWOverrideRedirect, &atts); Tk_CreateEventHandler(dispPtr->commTkwin, PropertyChangeMask, SendEventProc, dispPtr); Tk_MakeWindowExist(dispPtr->commTkwin); /* * Get atoms used as property names. */ dispPtr->commProperty = Tk_InternAtom(dispPtr->commTkwin, "Comm"); dispPtr->registryProperty = Tk_InternAtom(dispPtr->commTkwin, "InterpRegistry"); dispPtr->appNameProperty = Tk_InternAtom(dispPtr->commTkwin, "TK_APPLICATION"); return TCL_OK; } /* *-------------------------------------------------------------- * * SendEventProc -- * * This function is invoked automatically by the toolkit event manager * when a property changes on the communication window. This function * reads the property and handles command requests and responses. * * Results: * None. * * Side effects: * If there are command requests in the property, they are executed. If * there are responses in the property, their information is saved for * the (ostensibly waiting) "send" commands. The property is deleted. * *-------------------------------------------------------------- */ static void SendEventProc( ClientData clientData, /* Display information. */ XEvent *eventPtr) /* Information about event. */ { TkDisplay *dispPtr = clientData; char *propInfo, **propInfoPtr = &propInfo; const char *p; int result, actualFormat; unsigned long numItems, bytesAfter; Atom actualType; Tcl_Interp *remoteInterp; /* Interp in which to execute the command. */ ThreadSpecificData *tsdPtr = Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); if ((eventPtr->xproperty.atom != dispPtr->commProperty) || (eventPtr->xproperty.state != PropertyNewValue)) { return; } /* * Read the comm property and delete it. */ propInfo = NULL; result = XGetWindowProperty(dispPtr->display, Tk_WindowId(dispPtr->commTkwin), dispPtr->commProperty, 0, MAX_PROP_WORDS, True, XA_STRING, &actualType, &actualFormat, &numItems, &bytesAfter, (unsigned char **) propInfoPtr); /* * If the property doesn't exist or is improperly formed then ignore it. */ if ((result != Success) || (actualType != XA_STRING) || (actualFormat != 8)) { if (propInfo != NULL) { XFree(propInfo); } return; } /* * Several commands and results could arrive in the property at one time; * each iteration through the outer loop handles a single command or * result. */ for (p = propInfo; (p-propInfo) < (int) numItems; ) { /* * Ignore leading NULLs; each command or result starts with a NULL so * that no matter how badly formed a preceding command is, we'll be * able to tell that a new command/result is starting. */ if (*p == 0) { p++; continue; } if ((*p == 'c') && (p[1] == 0)) { Window commWindow; const char *interpName, *script, *serial; char *end; Tcl_DString reply; RegisteredInterp *riPtr; /* *---------------------------------------------------------- * This is an incoming command from some other application. * Iterate over all of its options. Stop when we reach the end of * the property or something that doesn't look like an option. *---------------------------------------------------------- */ p += 2; interpName = NULL; commWindow = None; serial = ""; script = NULL; while (((p-propInfo) < (int) numItems) && (*p == '-')) { switch (p[1]) { case 'r': commWindow = (Window) strtoul(p+2, &end, 16); if ((end == p+2) || (*end != ' ')) { commWindow = None; } else { p = serial = end+1; } break; case 'n': if (p[2] == ' ') { interpName = p+3; } break; case 's': if (p[2] == ' ') { script = p+3; } break; } while (*p != 0) { p++; } p++; } if ((script == NULL) || (interpName == NULL)) { continue; } /* * Initialize the result property, so that we're ready at any time * if we need to return an error. */ if (commWindow != None) { Tcl_DStringInit(&reply); Tcl_DStringAppend(&reply, "\0r\0-s ", 6); Tcl_DStringAppend(&reply, serial, -1); Tcl_DStringAppend(&reply, "\0-r ", 4); } if (!ServerSecure(dispPtr)) { if (commWindow != None) { Tcl_DStringAppend(&reply, "X server insecure (must use xauth-style " "authorization); command ignored", -1); } result = TCL_ERROR; goto returnResult; } /* * Locate the application, then execute the script. */ for (riPtr = tsdPtr->interpListPtr; ; riPtr = riPtr->nextPtr) { if (riPtr == NULL) { if (commWindow != None) { Tcl_DStringAppend(&reply, "receiver never heard of interpreter \"", -1); Tcl_DStringAppend(&reply, interpName, -1); Tcl_DStringAppend(&reply, "\"", 1); } result = TCL_ERROR; goto returnResult; } if (strcmp(riPtr->name, interpName) == 0) { break; } } Tcl_Preserve(riPtr); /* * We must protect the interpreter because the script may enter * another event loop, which might call Tcl_DeleteInterp. */ remoteInterp = riPtr->interp; Tcl_Preserve(remoteInterp); result = Tcl_EvalEx(remoteInterp, script, -1, TCL_EVAL_GLOBAL); /* * The call to Tcl_Release may have released the interpreter which * will cause the "send" command for that interpreter to be * deleted. The command deletion callback will set the * riPtr->interp field to NULL, hence the check below for NULL. */ if (commWindow != None) { Tcl_DStringAppend(&reply, Tcl_GetString(Tcl_GetObjResult(remoteInterp)), -1); if (result == TCL_ERROR) { const char *varValue; varValue = Tcl_GetVar2(remoteInterp, "errorInfo", NULL, TCL_GLOBAL_ONLY); if (varValue != NULL) { Tcl_DStringAppend(&reply, "\0-i ", 4); Tcl_DStringAppend(&reply, varValue, -1); } varValue = Tcl_GetVar2(remoteInterp, "errorCode", NULL, TCL_GLOBAL_ONLY); if (varValue != NULL) { Tcl_DStringAppend(&reply, "\0-e ", 4); Tcl_DStringAppend(&reply, varValue, -1); } } } Tcl_Release(remoteInterp); Tcl_Release(riPtr); /* * Return the result to the sender if a commWindow was specified * (if none was specified then this is an asynchronous call). * Right now reply has everything but the completion code, but it * needs the NULL to terminate the current option. */ returnResult: if (commWindow != None) { if (result != TCL_OK) { char buffer[TCL_INTEGER_SPACE]; sprintf(buffer, "%d", result); Tcl_DStringAppend(&reply, "\0-c ", 4); Tcl_DStringAppend(&reply, buffer, -1); } (void) AppendPropCarefully(dispPtr->display, commWindow, dispPtr->commProperty, Tcl_DStringValue(&reply), Tcl_DStringLength(&reply) + 1, NULL); XFlush(dispPtr->display); Tcl_DStringFree(&reply); } } else if ((*p == 'r') && (p[1] == 0)) { int serial, code, gotSerial; const char *errorInfo, *errorCode, *resultString; PendingCommand *pcPtr; /* *---------------------------------------------------------- * This is a reply to some command that we sent out. Iterate over * all of its options. Stop when we reach the end of the property * or something that doesn't look like an option. *---------------------------------------------------------- */ p += 2; code = TCL_OK; gotSerial = 0; errorInfo = NULL; errorCode = NULL; resultString = ""; while (((p-propInfo) < (int) numItems) && (*p == '-')) { switch (p[1]) { case 'c': if (sscanf(p+2, " %d", &code) != 1) { code = TCL_OK; } break; case 'e': if (p[2] == ' ') { errorCode = p+3; } break; case 'i': if (p[2] == ' ') { errorInfo = p+3; } break; case 'r': if (p[2] == ' ') { resultString = p+3; } break; case 's': if (sscanf(p+2, " %d", &serial) == 1) { gotSerial = 1; } break; } while (*p != 0) { p++; } p++; } if (!gotSerial) { continue; } /* * Give the result information to anyone who's waiting for it. */ for (pcPtr = tsdPtr->pendingCommands; pcPtr != NULL; pcPtr = pcPtr->nextPtr) { if ((serial != pcPtr->serial) || (pcPtr->result != NULL)) { continue; } pcPtr->code = code; if (resultString != NULL) { pcPtr->result = ckalloc(strlen(resultString) + 1); strcpy(pcPtr->result, resultString); } if (code == TCL_ERROR) { if (errorInfo != NULL) { pcPtr->errorInfo = ckalloc(strlen(errorInfo) + 1); strcpy(pcPtr->errorInfo, errorInfo); } if (errorCode != NULL) { pcPtr->errorCode = ckalloc(strlen(errorCode) + 1); strcpy(pcPtr->errorCode, errorCode); } } pcPtr->gotResponse = 1; break; } } else { /* * Didn't recognize this thing. Just skip through the next null * character and try again. */ while (*p != 0) { p++; } p++; } } XFree(propInfo); } /* *-------------------------------------------------------------- * * AppendPropCarefully -- * * Append a given property to a given window, but set up an X error * handler so that if the append fails this function can return an error * code rather than having Xlib panic. * * Results: * None. * * Side effects: * The given property on the given window is appended to. If this * operation fails and if pendingPtr is non-NULL, then the pending * operation is marked as complete with an error. * *-------------------------------------------------------------- */ static void AppendPropCarefully( Display *display, /* Display on which to operate. */ Window window, /* Window whose property is to be modified. */ Atom property, /* Name of property. */ char *value, /* Characters to append to property. */ int length, /* Number of bytes to append. */ PendingCommand *pendingPtr) /* Pending command to mark complete if an * error occurs during the property op. NULL * means just ignore the error. */ { Tk_ErrorHandler handler; handler = Tk_CreateErrorHandler(display, -1, -1, -1, AppendErrorProc, pendingPtr); XChangeProperty(display, window, property, XA_STRING, 8, PropModeAppend, (unsigned char *) value, length); Tk_DeleteErrorHandler(handler); } /* * The function below is invoked if an error occurs during the XChangeProperty * operation above. */ /* ARGSUSED */ static int AppendErrorProc( ClientData clientData, /* Command to mark complete, or NULL. */ XErrorEvent *errorPtr) /* Information about error. */ { PendingCommand *pendingPtr = clientData; register PendingCommand *pcPtr; ThreadSpecificData *tsdPtr = Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); if (pendingPtr == NULL) { return 0; } /* * Make sure this command is still pending. */ for (pcPtr = tsdPtr->pendingCommands; pcPtr != NULL; pcPtr = pcPtr->nextPtr) { if ((pcPtr == pendingPtr) && (pcPtr->result == NULL)) { pcPtr->result = ckalloc(strlen(pcPtr->target) + 50); sprintf(pcPtr->result, "no application named \"%s\"", pcPtr->target); pcPtr->code = TCL_ERROR; pcPtr->gotResponse = 1; break; } } return 0; } /* *-------------------------------------------------------------- * * DeleteProc -- * * This function is invoked by Tcl when the "send" command is deleted in * an interpreter. It unregisters the interpreter. * * Results: * None. * * Side effects: * The interpreter given by riPtr is unregistered. * *-------------------------------------------------------------- */ static void DeleteProc( ClientData clientData) /* Info about registration, passed as * ClientData. */ { RegisteredInterp *riPtr = clientData; register RegisteredInterp *riPtr2; NameRegistry *regPtr; ThreadSpecificData *tsdPtr = Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); regPtr = RegOpen(riPtr->interp, riPtr->dispPtr, 1); RegDeleteName(regPtr, riPtr->name); RegClose(regPtr); if (tsdPtr->interpListPtr == riPtr) { tsdPtr->interpListPtr = riPtr->nextPtr; } else { for (riPtr2 = tsdPtr->interpListPtr; riPtr2 != NULL; riPtr2 = riPtr2->nextPtr) { if (riPtr2->nextPtr == riPtr) { riPtr2->nextPtr = riPtr->nextPtr; break; } } } ckfree(riPtr->name); riPtr->interp = NULL; UpdateCommWindow(riPtr->dispPtr); Tcl_EventuallyFree(riPtr, TCL_DYNAMIC); } /* *---------------------------------------------------------------------- * * SendRestrictProc -- * * This function filters incoming events when a "send" command is * outstanding. It defers all events except those containing send * commands and results. * * Results: * False is returned except for property-change events on a commWindow. * * Side effects: * None. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static Tk_RestrictAction SendRestrictProc( ClientData clientData, /* Not used. */ register XEvent *eventPtr) /* Event that just arrived. */ { TkDisplay *dispPtr; if (eventPtr->type != PropertyNotify) { return TK_DEFER_EVENT; } for (dispPtr = TkGetDisplayList(); dispPtr != NULL; dispPtr = dispPtr->nextPtr) { if ((eventPtr->xany.display == dispPtr->display) && (eventPtr->xproperty.window == Tk_WindowId(dispPtr->commTkwin))) { return TK_PROCESS_EVENT; } } return TK_DEFER_EVENT; } /* *---------------------------------------------------------------------- * * UpdateCommWindow -- * * This function updates the list of application names stored on our * commWindow. It is typically called when interpreters are registered * and unregistered. * * Results: * None. * * Side effects: * The TK_APPLICATION property on the comm window is updated. * *---------------------------------------------------------------------- */ static void UpdateCommWindow( TkDisplay *dispPtr) /* Display whose commWindow is to be * updated. */ { Tcl_DString names; RegisteredInterp *riPtr; ThreadSpecificData *tsdPtr = Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); Tcl_DStringInit(&names); for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; riPtr = riPtr->nextPtr) { Tcl_DStringAppendElement(&names, riPtr->name); } XChangeProperty(dispPtr->display, Tk_WindowId(dispPtr->commTkwin), dispPtr->appNameProperty, XA_STRING, 8, PropModeReplace, (unsigned char *) Tcl_DStringValue(&names), Tcl_DStringLength(&names)); Tcl_DStringFree(&names); } /* *---------------------------------------------------------------------- * * TkpTestsendCmd -- * * This function implements the "testsend" command. It provides a set of * functions for testing the "send" command and support function in * tkSend.c. * * Results: * A standard Tcl result. * * Side effects: * Depends on option; see below. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int TkpTestsendCmd( ClientData clientData, /* Main window for application. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument strings. */ { enum { TESTSEND_BOGUS, TESTSEND_PROP, TESTSEND_SERIAL }; static const char *const testsendOptions[] = { "bogus", "prop", "serial", NULL }; TkWindow *winPtr = clientData; int index; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); return TCL_ERROR; } if (Tcl_GetIndexFromObjStruct(interp, objv[1], testsendOptions, sizeof(char *), "option", 0, &index) != TCL_OK) { return TCL_ERROR; } if (index == TESTSEND_BOGUS) { XChangeProperty(winPtr->dispPtr->display, RootWindow(winPtr->dispPtr->display, 0), winPtr->dispPtr->registryProperty, XA_INTEGER, 32, PropModeReplace, (unsigned char *) "This is bogus information", 6); } else if (index == TESTSEND_PROP) { int result, actualFormat; unsigned long length, bytesAfter; Atom actualType, propName; char *property, **propertyPtr = &property, *p, *end; Window w; if ((objc != 4) && (objc != 5)) { Tcl_WrongNumArgs(interp, 1, objv, "prop window name ?value ?"); return TCL_ERROR; } if (strcmp(Tcl_GetString(objv[2]), "root") == 0) { w = RootWindow(winPtr->dispPtr->display, 0); } else if (strcmp(Tcl_GetString(objv[2]), "comm") == 0) { w = Tk_WindowId(winPtr->dispPtr->commTkwin); } else { w = strtoul(Tcl_GetString(objv[2]), &end, 0); } propName = Tk_InternAtom((Tk_Window) winPtr, Tcl_GetString(objv[3])); if (objc == 4) { property = NULL; result = XGetWindowProperty(winPtr->dispPtr->display, w, propName, 0, 100000, False, XA_STRING, &actualType, &actualFormat, &length, &bytesAfter, (unsigned char **) propertyPtr); if ((result == Success) && (actualType != None) && (actualFormat == 8) && (actualType == XA_STRING)) { for (p = property; (unsigned long)(p-property) < length; p++) { if (*p == 0) { *p = '\n'; } } Tcl_SetObjResult(interp, Tcl_NewStringObj(property, -1)); } if (property != NULL) { XFree(property); } } else if (Tcl_GetString(objv[4])[0] == 0) { XDeleteProperty(winPtr->dispPtr->display, w, propName); } else { Tcl_DString tmp; Tcl_DStringInit(&tmp); for (p = Tcl_DStringAppend(&tmp, Tcl_GetString(objv[4]), (int) strlen(Tcl_GetString(objv[4]))); *p != 0; p++) { if (*p == '\n') { *p = 0; } } XChangeProperty(winPtr->dispPtr->display, w, propName, XA_STRING, 8, PropModeReplace, (unsigned char*)Tcl_DStringValue(&tmp), p-Tcl_DStringValue(&tmp)); Tcl_DStringFree(&tmp); } } else if (index == TESTSEND_SERIAL) { Tcl_SetObjResult(interp, Tcl_NewIntObj(localData.sendSerial+1)); } return TCL_OK; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ tk8.6.5/unix/tkUnixColor.c0000644003604700454610000003213012377375532014113 0ustar dgp771div/* * tkUnixColor.c -- * * This file contains the platform specific color routines needed for X * support. * * Copyright (c) 1996 by Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tkUnixInt.h" #include "tkColor.h" /* * If a colormap fills up, attempts to allocate new colors from that colormap * will fail. When that happens, we'll just choose the closest color from * those that are available in the colormap. One of the following structures * will be created for each "stressed" colormap to keep track of the colors * that are available in the colormap (otherwise we would have to re-query * from the server on each allocation, which would be very slow). These * entries are flushed after a few seconds, since other clients may release or * reallocate colors over time. */ struct TkStressedCmap { Colormap colormap; /* X's token for the colormap. */ int numColors; /* Number of entries currently active at * *colorPtr. */ XColor *colorPtr; /* Pointer to malloc'ed array of all colors * that seem to be available in the colormap. * Some may not actually be available, e.g. * because they are read-write for another * client; when we find this out, we remove * them from the array. */ struct TkStressedCmap *nextPtr; /* Next in list of all stressed colormaps for * the display. */ }; /* * Forward declarations for functions defined in this file: */ static void DeleteStressedCmap(Display *display, Colormap colormap); static void FindClosestColor(Tk_Window tkwin, XColor *desiredColorPtr, XColor *actualColorPtr); /* *---------------------------------------------------------------------- * * TkpFreeColor -- * * Release the specified color back to the system. * * Results: * None * * Side effects: * Invalidates the colormap cache for the colormap associated with the * given color. * *---------------------------------------------------------------------- */ void TkpFreeColor( TkColor *tkColPtr) /* Color to be released. Must have been * allocated by TkpGetColor or * TkpGetColorByValue. */ { Visual *visual; Screen *screen = tkColPtr->screen; /* * Careful! Don't free black or white, since this will make some servers * very unhappy. Also, there is a bug in some servers (such Sun's X11/NeWS * server) where reference counting is performed incorrectly, so that if a * color is allocated twice in different places and then freed twice, the * second free generates an error (this bug existed as of 10/1/92). To get * around this problem, ignore errors that occur during the free * operation. */ visual = tkColPtr->visual; if ((visual->class != StaticGray) && (visual->class != StaticColor) && (tkColPtr->color.pixel != BlackPixelOfScreen(screen)) && (tkColPtr->color.pixel != WhitePixelOfScreen(screen))) { Tk_ErrorHandler handler; handler = Tk_CreateErrorHandler(DisplayOfScreen(screen), -1, -1, -1, NULL, NULL); XFreeColors(DisplayOfScreen(screen), tkColPtr->colormap, &tkColPtr->color.pixel, 1, 0L); Tk_DeleteErrorHandler(handler); } DeleteStressedCmap(DisplayOfScreen(screen), tkColPtr->colormap); } /* *---------------------------------------------------------------------- * * TkpGetColor -- * * Allocate a new TkColor for the color with the given name. * * Results: * Returns a newly allocated TkColor, or NULL on failure. * * Side effects: * May invalidate the colormap cache associated with tkwin upon * allocating a new colormap entry. Allocates a new TkColor structure. * *---------------------------------------------------------------------- */ TkColor * TkpGetColor( Tk_Window tkwin, /* Window in which color will be used. */ Tk_Uid name) /* Name of color to allocated (in form * suitable for passing to XParseColor). */ { Display *display = Tk_Display(tkwin); Colormap colormap = Tk_Colormap(tkwin); XColor color; TkColor *tkColPtr; /* * Map from the name to a pixel value. Call XAllocNamedColor rather than * XParseColor for non-# names: this saves a server round-trip for those * names. */ if (*name != '#') { XColor screen; if (((*name - 'A') & 0xdf) < sizeof(tkWebColors)/sizeof(tkWebColors[0])) { if (!((name[0] - 'G') & 0xdf) && !((name[1] - 'R') & 0xdf) && !((name[2] - 'A') & 0xdb) && !((name[3] - 'Y') & 0xdf) && !name[4]) { name = "#808080808080"; goto gotWebColor; } else { const char *p = tkWebColors[((*name - 'A') & 0x1f)]; if (p) { const char *q = name; while (!((*p - *(++q)) & 0xdf)) { if (!*p++) { name = p; goto gotWebColor; } } } } } if (strlen(name) > 99) { /* Don't bother to parse this. [Bug 2809525]*/ return (TkColor *) NULL; } else if (XAllocNamedColor(display, colormap, name, &screen, &color) != 0) { DeleteStressedCmap(display, colormap); } else { /* * Couldn't allocate the color. Try translating the name to a * color value, to see whether the problem is a bad color name or * a full colormap. If the colormap is full, then pick an * approximation to the desired color. */ if (XLookupColor(display, colormap, name, &color, &screen) == 0) { return NULL; } FindClosestColor(tkwin, &screen, &color); } } else { gotWebColor: if (TkParseColor(display, colormap, name, &color) == 0) { return NULL; } if (XAllocColor(display, colormap, &color) != 0) { DeleteStressedCmap(display, colormap); } else { FindClosestColor(tkwin, &color, &color); } } tkColPtr = ckalloc(sizeof(TkColor)); tkColPtr->color = color; return tkColPtr; } /* *---------------------------------------------------------------------- * * TkpGetColorByValue -- * * Given a desired set of red-green-blue intensities for a color, locate * a pixel value to use to draw that color in a given window. * * Results: * The return value is a pointer to an TkColor structure that indicates * the closest red, blue, and green intensities available to those * specified in colorPtr, and also specifies a pixel value to use to draw * in that color. * * Side effects: * May invalidate the colormap cache for the specified window. Allocates * a new TkColor structure. * *---------------------------------------------------------------------- */ TkColor * TkpGetColorByValue( Tk_Window tkwin, /* Window in which color will be used. */ XColor *colorPtr) /* Red, green, and blue fields indicate * desired color. */ { Display *display = Tk_Display(tkwin); Colormap colormap = Tk_Colormap(tkwin); TkColor *tkColPtr = ckalloc(sizeof(TkColor)); tkColPtr->color.red = colorPtr->red; tkColPtr->color.green = colorPtr->green; tkColPtr->color.blue = colorPtr->blue; if (XAllocColor(display, colormap, &tkColPtr->color) != 0) { DeleteStressedCmap(display, colormap); } else { FindClosestColor(tkwin, &tkColPtr->color, &tkColPtr->color); } return tkColPtr; } /* *---------------------------------------------------------------------- * * FindClosestColor -- * * When Tk can't allocate a color because a colormap has filled up, this * function is called to find and allocate the closest available color in * the colormap. * * Results: * There is no return value, but *actualColorPtr is filled in with * information about the closest available color in tkwin's colormap. * This color has been allocated via X, so it must be released by the * caller when the caller is done with it. * * Side effects: * A color is allocated. * *---------------------------------------------------------------------- */ static void FindClosestColor( Tk_Window tkwin, /* Window where color will be used. */ XColor *desiredColorPtr, /* RGB values of color that was wanted (but * unavailable). */ XColor *actualColorPtr) /* Structure to fill in with RGB and pixel for * closest available color. */ { TkStressedCmap *stressPtr; double tmp, distance, closestDistance; int i, closest, numFound; XColor *colorPtr; TkDisplay *dispPtr = ((TkWindow *) tkwin)->dispPtr; Colormap colormap = Tk_Colormap(tkwin); XVisualInfo template, *visInfoPtr; /* * Find the TkStressedCmap structure for this colormap, or create a new * one if needed. */ for (stressPtr = dispPtr->stressPtr; ; stressPtr = stressPtr->nextPtr) { if (stressPtr == NULL) { stressPtr = ckalloc(sizeof(TkStressedCmap)); stressPtr->colormap = colormap; template.visualid = XVisualIDFromVisual(Tk_Visual(tkwin)); visInfoPtr = XGetVisualInfo(Tk_Display(tkwin), VisualIDMask, &template, &numFound); if (numFound < 1) { Tcl_Panic("FindClosestColor couldn't lookup visual"); } stressPtr->numColors = visInfoPtr->colormap_size; XFree((char *) visInfoPtr); stressPtr->colorPtr = ckalloc(stressPtr->numColors * sizeof(XColor)); for (i = 0; i < stressPtr->numColors; i++) { stressPtr->colorPtr[i].pixel = (unsigned long) i; } XQueryColors(dispPtr->display, colormap, stressPtr->colorPtr, stressPtr->numColors); stressPtr->nextPtr = dispPtr->stressPtr; dispPtr->stressPtr = stressPtr; break; } if (stressPtr->colormap == colormap) { break; } } /* * Find the color that best approximates the desired one, then try to * allocate that color. If that fails, it must mean that the color was * read-write (so we can't use it, since it's owner might change it) or * else it was already freed. Try again, over and over again, until * something succeeds. */ while (1) { if (stressPtr->numColors == 0) { Tcl_Panic("FindClosestColor ran out of colors"); } closestDistance = 1e30; closest = 0; for (colorPtr = stressPtr->colorPtr, i = 0; i < stressPtr->numColors; colorPtr++, i++) { /* * Use Euclidean distance in RGB space, weighted by Y (of YIQ) as * the objective function; this accounts for differences in the * color sensitivity of the eye. */ tmp = .30*(((int) desiredColorPtr->red) - (int) colorPtr->red); distance = tmp*tmp; tmp = .61*(((int) desiredColorPtr->green) - (int) colorPtr->green); distance += tmp*tmp; tmp = .11*(((int) desiredColorPtr->blue) - (int) colorPtr->blue); distance += tmp*tmp; if (distance < closestDistance) { closest = i; closestDistance = distance; } } if (XAllocColor(dispPtr->display, colormap, &stressPtr->colorPtr[closest]) != 0) { *actualColorPtr = stressPtr->colorPtr[closest]; return; } /* * Couldn't allocate the color. Remove it from the table and go back * to look for the next best color. */ stressPtr->colorPtr[closest] = stressPtr->colorPtr[stressPtr->numColors-1]; stressPtr->numColors -= 1; } } /* *---------------------------------------------------------------------- * * DeleteStressedCmap -- * * This function releases the information cached for "colormap" so that * it will be refetched from the X server the next time it is needed. * * Results: * None. * * Side effects: * The TkStressedCmap structure for colormap is deleted; the colormap is * no longer considered to be "stressed". * * Note: * This function is invoked whenever a color in a colormap is freed, and * whenever a color allocation in a colormap succeeds. This guarantees * that TkStressedCmap structures are always deleted before the * corresponding Colormap is freed. * *---------------------------------------------------------------------- */ static void DeleteStressedCmap( Display *display, /* Xlib's handle for the display containing * the colormap. */ Colormap colormap) /* Colormap to flush. */ { TkStressedCmap *prevPtr, *stressPtr; TkDisplay *dispPtr = TkGetDisplay(display); for (prevPtr = NULL, stressPtr = dispPtr->stressPtr; stressPtr != NULL; prevPtr = stressPtr, stressPtr = stressPtr->nextPtr) { if (stressPtr->colormap == colormap) { if (prevPtr == NULL) { dispPtr->stressPtr = stressPtr->nextPtr; } else { prevPtr->nextPtr = stressPtr->nextPtr; } ckfree(stressPtr->colorPtr); ckfree(stressPtr); return; } } } /* *---------------------------------------------------------------------- * * TkpCmapStressed -- * * Check to see whether a given colormap is known to be out of entries. * * Results: * 1 is returned if "colormap" is stressed (i.e. it has run out of * entries recently), 0 otherwise. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TkpCmapStressed( Tk_Window tkwin, /* Window that identifies the display * containing the colormap. */ Colormap colormap) /* Colormap to check for stress. */ { TkStressedCmap *stressPtr; for (stressPtr = ((TkWindow *) tkwin)->dispPtr->stressPtr; stressPtr != NULL; stressPtr = stressPtr->nextPtr) { if (stressPtr->colormap == colormap) { return 1; } } return 0; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ tk8.6.5/unix/tkUnixEmbed.c0000644003604700454610000010461512620363651014047 0ustar dgp771div/* * tkUnixEmbed.c -- * * This file contains platform-specific functions for UNIX to provide * basic operations needed for application embedding (where one * application can use as its main window an internal window from some * other application). Also includes code to support busy windows. * * Copyright (c) 1996-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tkUnixInt.h" #include "tkBusy.h" /* * One of the following structures exists for each container in this * application. It keeps track of the container window and its associated * embedded window. */ typedef struct Container { Window parent; /* X's window id for the parent of the pair * (the container). */ Window parentRoot; /* Id for the root window of parent's * screen. */ TkWindow *parentPtr; /* Tk's information about the container, or * NULL if the container isn't in this * process. */ Window wrapper; /* X's window id for the wrapper window for * the embedded window. Starts off as None, * but gets filled in when the window is * eventually created. */ TkWindow *embeddedPtr; /* Tk's information about the embedded window, * or NULL if the embedded application isn't * in this process. Note that this is *not* * the same window as wrapper: wrapper is the * parent of embeddedPtr. */ struct Container *nextPtr; /* Next in list of all containers in this * process. */ } Container; typedef struct ThreadSpecificData { Container *firstContainerPtr; /* First in list of all containers managed by * this process. */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; /* * Prototypes for static functions defined in this file: */ static void ContainerEventProc(ClientData clientData, XEvent *eventPtr); static void EmbeddedEventProc(ClientData clientData, XEvent *eventPtr); static int EmbedErrorProc(ClientData clientData, XErrorEvent *errEventPtr); static void EmbedFocusProc(ClientData clientData, XEvent *eventPtr); static void EmbedGeometryRequest(Container *containerPtr, int width, int height); static void EmbedSendConfigure(Container *containerPtr); static void EmbedStructureProc(ClientData clientData, XEvent *eventPtr); static void EmbedWindowDeleted(TkWindow *winPtr); /* *---------------------------------------------------------------------- * * TkpUseWindow -- * * This function causes a Tk window to use a given X window as its parent * window, rather than the root window for the screen. It is invoked by * an embedded application to specify the window in which it is embedded. * * Results: * The return value is normally TCL_OK. If an error occurs (such as * string not being a valid window spec), then the return value is * TCL_ERROR and an error message is left in the interp's result if * interp is non-NULL. * * Side effects: * Changes the colormap and other visual information to match that of the * parent window given by "string". * *---------------------------------------------------------------------- */ int TkpUseWindow( Tcl_Interp *interp, /* If not NULL, used for error reporting if * string is bogus. */ Tk_Window tkwin, /* Tk window that does not yet have an * associated X window. */ const char *string) /* String identifying an X window to use for * tkwin; must be an integer value. */ { TkWindow *winPtr = (TkWindow *) tkwin; TkWindow *usePtr; int anyError; Window parent; Tk_ErrorHandler handler; Container *containerPtr; XWindowAttributes parentAtts; ThreadSpecificData *tsdPtr = Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); if (winPtr->window != None) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "can't modify container after widget is created", -1)); Tcl_SetErrorCode(interp, "TK", "EMBED", "POST_CREATE", NULL); return TCL_ERROR; } if (TkpScanWindowId(interp, string, &parent) != TCL_OK) { return TCL_ERROR; } usePtr = (TkWindow *) Tk_IdToWindow(winPtr->display, parent); if (usePtr != NULL && !(usePtr->flags & TK_CONTAINER)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "window \"%s\" doesn't have -container option set", usePtr->pathName)); Tcl_SetErrorCode(interp, "TK", "EMBED", "CONTAINER", NULL); return TCL_ERROR; } /* * Tk sets the window colormap to the screen default colormap in * tkWindow.c:AllocWindow. This doesn't work well for embedded windows. So * we override the colormap and visual settings to be the same as the * parent window (which is in the container app). */ anyError = 0; handler = Tk_CreateErrorHandler(winPtr->display, -1, -1, -1, EmbedErrorProc, &anyError); if (!XGetWindowAttributes(winPtr->display, parent, &parentAtts)) { anyError = 1; } XSync(winPtr->display, False); Tk_DeleteErrorHandler(handler); if (anyError) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't create child of window \"%s\"", string)); Tcl_SetErrorCode(interp, "TK", "EMBED", "NO_TARGET", NULL); } return TCL_ERROR; } Tk_SetWindowVisual(tkwin, parentAtts.visual, parentAtts.depth, parentAtts.colormap); /* * Create an event handler to clean up the Container structure when tkwin * is eventually deleted. */ Tk_CreateEventHandler(tkwin, StructureNotifyMask, EmbeddedEventProc, winPtr); /* * Save information about the container and the embedded window in a * Container structure. If there is already an existing Container * structure, it means that both container and embedded app. are in the * same process. */ for (containerPtr = tsdPtr->firstContainerPtr; containerPtr != NULL; containerPtr = containerPtr->nextPtr) { if (containerPtr->parent == parent) { winPtr->flags |= TK_BOTH_HALVES; containerPtr->parentPtr->flags |= TK_BOTH_HALVES; break; } } if (containerPtr == NULL) { containerPtr = ckalloc(sizeof(Container)); containerPtr->parent = parent; containerPtr->parentRoot = parentAtts.root; containerPtr->parentPtr = NULL; containerPtr->wrapper = None; containerPtr->nextPtr = tsdPtr->firstContainerPtr; tsdPtr->firstContainerPtr = containerPtr; } containerPtr->embeddedPtr = winPtr; winPtr->flags |= TK_EMBEDDED; return TCL_OK; } /* *---------------------------------------------------------------------- * * TkpMakeWindow -- * * Create an actual window system window object based on the current * attributes of the specified TkWindow. * * Results: * Returns the handle to the new window, or None on failure. * * Side effects: * Creates a new X window. * *---------------------------------------------------------------------- */ Window TkpMakeWindow( TkWindow *winPtr, /* Tk's information about the window that is * to be instantiated. */ Window parent) /* Window system token for the parent in which * the window is to be created. */ { Container *containerPtr; ThreadSpecificData *tsdPtr = Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); if (winPtr->flags & TK_EMBEDDED) { /* * This window is embedded. Don't create the new window in the given * parent; instead, create it as a child of the root window of the * container's screen. The window will get reparented into a wrapper * window later. */ for (containerPtr = tsdPtr->firstContainerPtr; ; containerPtr = containerPtr->nextPtr) { if (containerPtr == NULL) { Tcl_Panic("TkMakeWindow couldn't find container for window"); } if (containerPtr->embeddedPtr == winPtr) { break; } } parent = containerPtr->parentRoot; } return XCreateWindow(winPtr->display, parent, winPtr->changes.x, winPtr->changes.y, (unsigned) winPtr->changes.width, (unsigned) winPtr->changes.height, (unsigned) winPtr->changes.border_width, winPtr->depth, InputOutput, winPtr->visual, winPtr->dirtyAtts, &winPtr->atts); } /* *---------------------------------------------------------------------- * * TkpMakeContainer -- * * This function is called to indicate that a particular window will be a * container for an embedded application. This changes certain aspects of * the window's behavior, such as whether it will receive events anymore. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ void TkpMakeContainer( Tk_Window tkwin) /* Token for a window that is about to become * a container. */ { TkWindow *winPtr = (TkWindow *) tkwin; Container *containerPtr; ThreadSpecificData *tsdPtr = Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); /* * Register the window as a container so that, for example, we can find * out later if the embedded app. is in the same process. */ Tk_MakeWindowExist(tkwin); containerPtr = ckalloc(sizeof(Container)); containerPtr->parent = Tk_WindowId(tkwin); containerPtr->parentRoot = RootWindowOfScreen(Tk_Screen(tkwin)); containerPtr->parentPtr = winPtr; containerPtr->wrapper = None; containerPtr->embeddedPtr = NULL; containerPtr->nextPtr = tsdPtr->firstContainerPtr; tsdPtr->firstContainerPtr = containerPtr; winPtr->flags |= TK_CONTAINER; /* * Request SubstructureNotify events so that we can find out when the * embedded application creates its window or attempts to resize it. Also * watch Configure events on the container so that we can resize the child * to match. */ winPtr->atts.event_mask |= SubstructureRedirectMask|SubstructureNotifyMask; XSelectInput(winPtr->display, winPtr->window, winPtr->atts.event_mask); Tk_CreateEventHandler(tkwin, SubstructureNotifyMask|SubstructureRedirectMask, ContainerEventProc, winPtr); Tk_CreateEventHandler(tkwin, StructureNotifyMask, EmbedStructureProc, containerPtr); Tk_CreateEventHandler(tkwin, FocusChangeMask, EmbedFocusProc, containerPtr); } /* *---------------------------------------------------------------------- * * EmbedErrorProc -- * * This function is invoked if an error occurs while creating an embedded * window. * * Results: * Always returns 0 to indicate that the error has been properly handled. * * Side effects: * The integer pointed to by the clientData argument is set to 1. * *---------------------------------------------------------------------- */ static int EmbedErrorProc( ClientData clientData, /* Points to integer to set. */ XErrorEvent *errEventPtr) /* Points to information about error (not * used). */ { int *iPtr = clientData; *iPtr = 1; return 0; } /* *---------------------------------------------------------------------- * * EmbeddedEventProc -- * * This function is invoked by the Tk event dispatcher when various * useful events are received for a window that is embedded in another * application. * * Results: * None. * * Side effects: * Our internal state gets cleaned up when an embedded window is * destroyed. * *---------------------------------------------------------------------- */ static void EmbeddedEventProc( ClientData clientData, /* Token for container window. */ XEvent *eventPtr) /* ResizeRequest event. */ { TkWindow *winPtr = clientData; if (eventPtr->type == DestroyNotify) { EmbedWindowDeleted(winPtr); } } /* *---------------------------------------------------------------------- * * ContainerEventProc -- * * This function is invoked by the Tk event dispatcher when various * useful events are received for the children of a container window. It * forwards relevant information, such as geometry requests, from the * events into the container's application. * * Results: * None. * * Side effects: * Depends on the event. For example, when ConfigureRequest events occur, * geometry information gets set for the container window. * *---------------------------------------------------------------------- */ static void ContainerEventProc( ClientData clientData, /* Token for container window. */ XEvent *eventPtr) /* ResizeRequest event. */ { TkWindow *winPtr = clientData; Container *containerPtr; Tk_ErrorHandler errHandler; ThreadSpecificData *tsdPtr = Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); /* * Ignore any X protocol errors that happen in this function (almost any * operation could fail, for example, if the embedded application has * deleted its window). */ errHandler = Tk_CreateErrorHandler(eventPtr->xfocus.display, -1, -1, -1, NULL, NULL); /* * Find the Container structure associated with the parent window. */ for (containerPtr = tsdPtr->firstContainerPtr; containerPtr->parent != eventPtr->xmaprequest.parent; containerPtr = containerPtr->nextPtr) { if (containerPtr == NULL) { Tcl_Panic("ContainerEventProc couldn't find Container record"); } } if (eventPtr->type == CreateNotify) { /* * A new child window has been created in the container. Record its id * in the Container structure (if more than one child is created, just * remember the last one and ignore the earlier ones). Also set the * child's size to match the container. */ containerPtr->wrapper = eventPtr->xcreatewindow.window; XMoveResizeWindow(eventPtr->xcreatewindow.display, containerPtr->wrapper, 0, 0, (unsigned) Tk_Width((Tk_Window) containerPtr->parentPtr), (unsigned) Tk_Height((Tk_Window) containerPtr->parentPtr)); } else if (eventPtr->type == ConfigureRequest) { if ((eventPtr->xconfigurerequest.x != 0) || (eventPtr->xconfigurerequest.y != 0)) { /* * The embedded application is trying to move itself, which isn't * legal. At this point, the window hasn't actually moved, but we * need to send it a ConfigureNotify event to let it know that its * request has been denied. If the embedded application was also * trying to resize itself, a ConfigureNotify will be sent by the * geometry management code below, so we don't need to do * anything. Otherwise, generate a synthetic event. */ if ((eventPtr->xconfigurerequest.width == winPtr->changes.width) && (eventPtr->xconfigurerequest.height == winPtr->changes.height)) { EmbedSendConfigure(containerPtr); } } EmbedGeometryRequest(containerPtr, eventPtr->xconfigurerequest.width, eventPtr->xconfigurerequest.height); } else if (eventPtr->type == MapRequest) { /* * The embedded application's map request was ignored and simply * passed on to us, so we have to map the window for it to appear on * the screen. */ XMapWindow(eventPtr->xmaprequest.display, eventPtr->xmaprequest.window); } else if (eventPtr->type == DestroyNotify) { /* * The embedded application is gone. Destroy the container window. */ Tk_DestroyWindow((Tk_Window) winPtr); } Tk_DeleteErrorHandler(errHandler); } /* *---------------------------------------------------------------------- * * EmbedStructureProc -- * * This function is invoked by the Tk event dispatcher when a container * window owned by this application gets resized (and also at several * other times that we don't care about). This function reflects the size * change in the embedded window that corresponds to the container. * * Results: * None. * * Side effects: * The embedded window gets resized to match the container. * *---------------------------------------------------------------------- */ static void EmbedStructureProc( ClientData clientData, /* Token for container window. */ XEvent *eventPtr) /* ResizeRequest event. */ { Container *containerPtr = clientData; Tk_ErrorHandler errHandler; if (eventPtr->type == ConfigureNotify) { if (containerPtr->wrapper != None) { /* * Ignore errors, since the embedded application could have * deleted its window. */ errHandler = Tk_CreateErrorHandler(eventPtr->xfocus.display, -1, -1, -1, NULL, NULL); XMoveResizeWindow(eventPtr->xconfigure.display, containerPtr->wrapper, 0, 0, (unsigned) Tk_Width((Tk_Window) containerPtr->parentPtr), (unsigned) Tk_Height((Tk_Window) containerPtr->parentPtr)); Tk_DeleteErrorHandler(errHandler); } } else if (eventPtr->type == DestroyNotify) { EmbedWindowDeleted(containerPtr->parentPtr); } } /* *---------------------------------------------------------------------- * * EmbedFocusProc -- * * This function is invoked by the Tk event dispatcher when FocusIn and * FocusOut events occur for a container window owned by this * application. It is responsible for moving the focus back and forth * between a container application and an embedded application. * * Results: * None. * * Side effects: * The X focus may change. * *---------------------------------------------------------------------- */ static void EmbedFocusProc( ClientData clientData, /* Token for container window. */ XEvent *eventPtr) /* ResizeRequest event. */ { Container *containerPtr = clientData; Tk_ErrorHandler errHandler; Display *display; display = Tk_Display(containerPtr->parentPtr); if (eventPtr->type == FocusIn) { /* * The focus just arrived at the container. Change the X focus to move * it to the embedded application, if there is one. Ignore X errors * that occur during this operation (it's possible that the new focus * window isn't mapped). */ if (containerPtr->wrapper != None) { errHandler = Tk_CreateErrorHandler(eventPtr->xfocus.display, -1, -1, -1, NULL, NULL); XSetInputFocus(display, containerPtr->wrapper, RevertToParent, CurrentTime); Tk_DeleteErrorHandler(errHandler); } } } /* *---------------------------------------------------------------------- * * EmbedGeometryRequest -- * * This function is invoked when an embedded application requests a * particular size. It processes the request (which may or may not * actually honor the request) and reflects the results back to the * embedded application. * * Results: * None. * * Side effects: * If we deny the child's size change request, a Configure event is * synthesized to let the child know how big it ought to be. Events get * processed while we're waiting for the geometry managers to do their * thing. * *---------------------------------------------------------------------- */ static void EmbedGeometryRequest( Container *containerPtr, /* Information about the embedding. */ int width, int height) /* Size that the child has requested. */ { TkWindow *winPtr = containerPtr->parentPtr; /* * Forward the requested size into our geometry management hierarchy via * the container window. We need to send a Configure event back to the * embedded application if we decide not to honor its request; to make * this happen, process all idle event handlers synchronously here (so * that the geometry managers have had a chance to do whatever they want * to do), and if the window's size didn't change then generate a * configure event. */ Tk_GeometryRequest((Tk_Window) winPtr, width, height); while (Tcl_DoOneEvent(TCL_IDLE_EVENTS)) { /* Empty loop body. */ } if ((winPtr->changes.width != width) || (winPtr->changes.height != height)) { EmbedSendConfigure(containerPtr); } } /* *---------------------------------------------------------------------- * * EmbedSendConfigure -- * * This function synthesizes a ConfigureNotify event to notify an * embedded application of its current size and location. This function * is called when the embedded application made a geometry request that * we did not grant, so that the embedded application knows that its * geometry didn't change after all. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ static void EmbedSendConfigure( Container *containerPtr) /* Information about the embedding. */ { TkWindow *winPtr = containerPtr->parentPtr; XEvent event; event.xconfigure.type = ConfigureNotify; event.xconfigure.serial = LastKnownRequestProcessed(winPtr->display); event.xconfigure.send_event = True; event.xconfigure.display = winPtr->display; event.xconfigure.event = containerPtr->wrapper; event.xconfigure.window = containerPtr->wrapper; event.xconfigure.x = 0; event.xconfigure.y = 0; event.xconfigure.width = winPtr->changes.width; event.xconfigure.height = winPtr->changes.height; event.xconfigure.above = None; event.xconfigure.override_redirect = False; /* * Note: when sending the event below, the ButtonPressMask causes the * event to be sent only to applications that have selected for * ButtonPress events, which should be just the embedded application. */ XSendEvent(winPtr->display, containerPtr->wrapper, False, 0, &event); /* * The following needs to be done if the embedded window is not in the * same application as the container window. */ if (containerPtr->embeddedPtr == NULL) { XMoveResizeWindow(winPtr->display, containerPtr->wrapper, 0, 0, (unsigned) winPtr->changes.width, (unsigned) winPtr->changes.height); } } /* *---------------------------------------------------------------------- * * TkpGetOtherWindow -- * * If both the container and embedded window are in the same process, * this function will return either one, given the other. * * Results: * If winPtr is a container, the return value is the token for the * embedded window, and vice versa. If the "other" window isn't in this * process, NULL is returned. * * Side effects: * None. * *---------------------------------------------------------------------- */ TkWindow * TkpGetOtherWindow( TkWindow *winPtr) /* Tk's structure for a container or embedded * window. */ { Container *containerPtr; ThreadSpecificData *tsdPtr = Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); for (containerPtr = tsdPtr->firstContainerPtr; containerPtr != NULL; containerPtr = containerPtr->nextPtr) { if (containerPtr->embeddedPtr == winPtr) { return containerPtr->parentPtr; } else if (containerPtr->parentPtr == winPtr) { return containerPtr->embeddedPtr; } } return NULL; } /* *---------------------------------------------------------------------- * * TkpRedirectKeyEvent -- * * This function is invoked when a key press or release event arrives for * an application that does not believe it owns the input focus. This can * happen because of embedding; for example, X can send an event to an * embedded application when the real focus window is in the container * application and is an ancestor of the container. This function's job * is to forward the event back to the application where it really * belongs. * * Results: * None. * * Side effects: * The event may get sent to a different application. * *---------------------------------------------------------------------- */ void TkpRedirectKeyEvent( TkWindow *winPtr, /* Window to which the event was originally * reported. */ XEvent *eventPtr) /* X event to redirect (should be KeyPress or * KeyRelease). */ { Container *containerPtr; Window saved; ThreadSpecificData *tsdPtr = Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); /* * First, find the top-level window corresponding to winPtr. */ while (1) { if (winPtr == NULL) { /* * This window is being deleted. This is too confusing a case to * handle so discard the event. */ return; } if (winPtr->flags & TK_TOP_HIERARCHY) { break; } winPtr = winPtr->parentPtr; } if (winPtr->flags & TK_EMBEDDED) { /* * This application is embedded. If we got a key event without * officially having the focus, it means that the focus is really in * the container, but the mouse was over the embedded application. * Send the event back to the container. */ for (containerPtr = tsdPtr->firstContainerPtr; containerPtr->embeddedPtr != winPtr; containerPtr = containerPtr->nextPtr) { /* Empty loop body. */ } saved = eventPtr->xkey.window; eventPtr->xkey.window = containerPtr->parent; XSendEvent(eventPtr->xkey.display, eventPtr->xkey.window, False, KeyPressMask|KeyReleaseMask, eventPtr); eventPtr->xkey.window = saved; } } /* *---------------------------------------------------------------------- * * TkpClaimFocus -- * * This function is invoked when someone asks or the input focus to be * put on a window in an embedded application, but the application * doesn't currently have the focus. It requests the input focus from the * container application. * * Results: * None. * * Side effects: * The input focus may change. * *---------------------------------------------------------------------- */ void TkpClaimFocus( TkWindow *topLevelPtr, /* Top-level window containing desired focus * window; should be embedded. */ int force) /* One means that the container should claim * the focus if it doesn't currently have * it. */ { XEvent event; Container *containerPtr; ThreadSpecificData *tsdPtr = Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); if (!(topLevelPtr->flags & TK_EMBEDDED)) { return; } for (containerPtr = tsdPtr->firstContainerPtr; containerPtr->embeddedPtr != topLevelPtr; containerPtr = containerPtr->nextPtr) { /* Empty loop body. */ } event.xfocus.type = FocusIn; event.xfocus.serial = LastKnownRequestProcessed(topLevelPtr->display); event.xfocus.send_event = 1; event.xfocus.display = topLevelPtr->display; event.xfocus.window = containerPtr->parent; event.xfocus.mode = EMBEDDED_APP_WANTS_FOCUS; event.xfocus.detail = force; XSendEvent(event.xfocus.display, event.xfocus.window, False, 0, &event); } /* *---------------------------------------------------------------------- * * TkpTestembedCmd -- * * This function implements the "testembed" command. It returns some or * all of the information in the list pointed to by firstContainerPtr. * * Results: * A standard Tcl result. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TkpTestembedCmd( ClientData clientData, /* Main window for application. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument strings. */ { int all; Container *containerPtr; Tcl_DString dString; char buffer[50]; ThreadSpecificData *tsdPtr = Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); if ((objc > 1) && (strcmp(Tcl_GetString(objv[1]), "all") == 0)) { all = 1; } else { all = 0; } Tcl_DStringInit(&dString); for (containerPtr = tsdPtr->firstContainerPtr; containerPtr != NULL; containerPtr = containerPtr->nextPtr) { Tcl_DStringStartSublist(&dString); if (containerPtr->parent == None) { Tcl_DStringAppendElement(&dString, ""); } else if (all) { sprintf(buffer, "0x%x", (int) containerPtr->parent); Tcl_DStringAppendElement(&dString, buffer); } else { Tcl_DStringAppendElement(&dString, "XXX"); } if (containerPtr->parentPtr == NULL) { Tcl_DStringAppendElement(&dString, ""); } else { Tcl_DStringAppendElement(&dString, containerPtr->parentPtr->pathName); } if (containerPtr->wrapper == None) { Tcl_DStringAppendElement(&dString, ""); } else if (all) { sprintf(buffer, "0x%x", (int) containerPtr->wrapper); Tcl_DStringAppendElement(&dString, buffer); } else { Tcl_DStringAppendElement(&dString, "XXX"); } if (containerPtr->embeddedPtr == NULL) { Tcl_DStringAppendElement(&dString, ""); } else { Tcl_DStringAppendElement(&dString, containerPtr->embeddedPtr->pathName); } Tcl_DStringEndSublist(&dString); } Tcl_DStringResult(interp, &dString); return TCL_OK; } /* *---------------------------------------------------------------------- * * EmbedWindowDeleted -- * * This function is invoked when a window involved in embedding (as * either the container or the embedded application) is destroyed. It * cleans up the Container structure for the window. * * Results: * None. * * Side effects: * A Container structure may be freed. * *---------------------------------------------------------------------- */ static void EmbedWindowDeleted( TkWindow *winPtr) /* Tk's information about window that was * deleted. */ { Container *containerPtr, *prevPtr; ThreadSpecificData *tsdPtr = Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); /* * Find the Container structure for this window work. Delete the * information about the embedded application and free the container's * record. */ prevPtr = NULL; containerPtr = tsdPtr->firstContainerPtr; while (1) { if (containerPtr->embeddedPtr == winPtr) { containerPtr->wrapper = None; containerPtr->embeddedPtr = NULL; break; } if (containerPtr->parentPtr == winPtr) { containerPtr->parentPtr = NULL; break; } prevPtr = containerPtr; containerPtr = containerPtr->nextPtr; } if ((containerPtr->embeddedPtr == NULL) && (containerPtr->parentPtr == NULL)) { if (prevPtr == NULL) { tsdPtr->firstContainerPtr = containerPtr->nextPtr; } else { prevPtr->nextPtr = containerPtr->nextPtr; } ckfree(containerPtr); } } /* *---------------------------------------------------------------------- * * TkUnixContainerId -- * * Given an embedded window, this function returns the X window * identifier for the associated container window. * * Results: * The return value is the X window identifier for winPtr's container * window. * * Side effects: * None. * *---------------------------------------------------------------------- */ Window TkUnixContainerId( TkWindow *winPtr) /* Tk's structure for an embedded window. */ { Container *containerPtr; ThreadSpecificData *tsdPtr = Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); for (containerPtr = tsdPtr->firstContainerPtr; containerPtr != NULL; containerPtr = containerPtr->nextPtr) { if (containerPtr->embeddedPtr == winPtr) { return containerPtr->parent; } } Tcl_Panic("TkUnixContainerId couldn't find window"); return None; } /* *---------------------------------------------------------------------- * * TkpShowBusyWindow -- * * Makes a busy window "appear". * * Results: * None. * * Side effects: * Arranges for the busy window to start intercepting events and the * cursor to change to the configured "hey, I'm busy!" setting. * *---------------------------------------------------------------------- */ void TkpShowBusyWindow( TkBusy busy) { Busy *busyPtr = (Busy *) busy; if (busyPtr->tkBusy != NULL) { Tk_MapWindow(busyPtr->tkBusy); /* * Always raise the busy window just in case new sibling windows have * been created in the meantime. Can't use Tk_RestackWindow because it * doesn't work under Win32. */ XRaiseWindow(Tk_Display(busyPtr->tkBusy), Tk_WindowId(busyPtr->tkBusy)); } } /* *---------------------------------------------------------------------- * * TkpHideBusyWindow -- * * Makes a busy window "disappear". * * Results: * None. * * Side effects: * Arranges for the busy window to stop intercepting events, and the * cursor to change back to its normal setting. * *---------------------------------------------------------------------- */ void TkpHideBusyWindow( TkBusy busy) { Busy *busyPtr = (Busy *) busy; if (busyPtr->tkBusy != NULL) { Tk_UnmapWindow(busyPtr->tkBusy); } } /* *---------------------------------------------------------------------- * * TkpMakeTransparentWindowExist -- * * Construct the platform-specific resources for a transparent window. * * Results: * None. * * Side effects: * Moves the specified window in the stacking order. * *---------------------------------------------------------------------- */ void TkpMakeTransparentWindowExist( Tk_Window tkwin, /* Token for window. */ Window parent) /* Parent window. */ { TkWindow *winPtr = (TkWindow *) tkwin; long int mask = CWDontPropagate | CWEventMask; /* * Ignore the important events while the window is mapped. */ #define USER_EVENTS \ (EnterWindowMask | LeaveWindowMask | KeyPressMask | KeyReleaseMask | \ ButtonPressMask | ButtonReleaseMask | PointerMotionMask) #define PROP_EVENTS \ (KeyPressMask | KeyReleaseMask | ButtonPressMask | \ ButtonReleaseMask | PointerMotionMask) winPtr->atts.do_not_propagate_mask = PROP_EVENTS; winPtr->atts.event_mask = USER_EVENTS; winPtr->changes.border_width = 0; winPtr->depth = 0; winPtr->window = XCreateWindow(winPtr->display, parent, winPtr->changes.x, winPtr->changes.y, (unsigned) winPtr->changes.width, /* width */ (unsigned) winPtr->changes.height, /* height */ (unsigned) winPtr->changes.border_width, /* border_width */ winPtr->depth, InputOnly, winPtr->visual, mask, &winPtr->atts); } /* *---------------------------------------------------------------------- * * TkpCreateBusy -- * * Construct the platform-specific parts of a busy window. Note that this * postpones the actual creation of the window resource until later. * * Results: * None. * * Side effects: * Sets up part of the busy window structure. * *---------------------------------------------------------------------- */ void TkpCreateBusy( Tk_FakeWin *winPtr, Tk_Window tkRef, Window *parentPtr, Tk_Window tkParent, TkBusy busy) { Window root, parent, *dummy; unsigned int count; if (winPtr->flags & TK_REPARENTED) { /* * This works around a bug in the implementation of menubars for * non-MacIntosh window systems (Win32 and X11). Tk doesn't reset the * pointers to the parent window when the menu is reparented (since * winPtr->parentPtr points to the wrong window). We get around this * by determining the parent via the native API calls. */ if (XQueryTree(Tk_Display(tkRef), Tk_WindowId(tkRef), &root, &parent, &dummy, &count) > 0) { XFree(dummy); *parentPtr = parent; } else { *parentPtr = None; } } else { *parentPtr = Tk_WindowId(tkParent); } } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ tk8.6.5/unix/tkUnixKey.c0000644003604700454610000003272212377375532013574 0ustar dgp771div/* * tkUnixKey.c -- * * This file contains routines for dealing with international keyboard * input. * * Copyright (c) 1997 by Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tkInt.h" /* ** Bug [3607830]: Before using Xkb, it must be initialized. TkpOpenDisplay ** does this and sets the USE_XKB flag if xkb is supported. ** (should this be function ptr?) */ #ifdef HAVE_XKBKEYCODETOKEYSYM # include #else # define XkbKeycodeToKeysym(D,K,G,L) XKeycodeToKeysym(D,K,L) #endif #define TkKeycodeToKeysym(D,K,G,L) \ ((D)->flags & TK_DISPLAY_USE_XKB) ? \ XkbKeycodeToKeysym((D)->display,K,G,L) : \ XKeycodeToKeysym((D)->display,K,L) /* * Prototypes for local functions defined in this file: */ /* *---------------------------------------------------------------------- * * Tk_SetCaretPos -- * * This enables correct placement of the XIM caret. This is called by * widgets to indicate their cursor placement. This is currently only * used for over-the-spot XIM. * *---------------------------------------------------------------------- */ void Tk_SetCaretPos( Tk_Window tkwin, int x, int y, int height) { TkWindow *winPtr = (TkWindow *) tkwin; TkDisplay *dispPtr = winPtr->dispPtr; if ((dispPtr->caret.winPtr == winPtr) && (dispPtr->caret.x == x) && (dispPtr->caret.y == y) && (dispPtr->caret.height == height)) { return; } dispPtr->caret.winPtr = winPtr; dispPtr->caret.x = x; dispPtr->caret.y = y; dispPtr->caret.height = height; /* * Adjust the XIM caret position. */ #ifdef TK_USE_INPUT_METHODS if ((dispPtr->flags & TK_DISPLAY_USE_IM) && (dispPtr->inputStyle & XIMPreeditPosition) && (winPtr->inputContext != NULL)) { XVaNestedList preedit_attr; XPoint spot; spot.x = dispPtr->caret.x; spot.y = dispPtr->caret.y + dispPtr->caret.height; preedit_attr = XVaCreateNestedList(0, XNSpotLocation, &spot, NULL); XSetICValues(winPtr->inputContext, XNPreeditAttributes, preedit_attr, NULL); XFree(preedit_attr); } #endif } /* *---------------------------------------------------------------------- * * TkpGetString -- * * Retrieve the UTF string associated with a keyboard event. * * Results: * Returns the UTF string. * * Side effects: * Stores the input string in the specified Tcl_DString. Modifies the * internal input state. This routine can only be called once for a given * event. * *---------------------------------------------------------------------- */ const char * TkpGetString( TkWindow *winPtr, /* Window where event occurred */ XEvent *eventPtr, /* X keyboard event. */ Tcl_DString *dsPtr) /* Initialized, empty string to hold result. */ { int len; Tcl_DString buf; TkKeyEvent *kePtr = (TkKeyEvent *) eventPtr; /* * If we have the value cached already, use it now. [Bug 1373712] */ if (kePtr->charValuePtr != NULL) { Tcl_DStringSetLength(dsPtr, kePtr->charValueLen); memcpy(Tcl_DStringValue(dsPtr), kePtr->charValuePtr, (unsigned) kePtr->charValueLen+1); return Tcl_DStringValue(dsPtr); } #ifdef TK_USE_INPUT_METHODS if ((winPtr->dispPtr->flags & TK_DISPLAY_USE_IM) && (winPtr->inputContext != NULL) && (eventPtr->type == KeyPress)) { Status status; #if X_HAVE_UTF8_STRING Tcl_DStringSetLength(dsPtr, TCL_DSTRING_STATIC_SIZE-1); len = Xutf8LookupString(winPtr->inputContext, &eventPtr->xkey, Tcl_DStringValue(dsPtr), Tcl_DStringLength(dsPtr), &kePtr->keysym, &status); if (status == XBufferOverflow) { /* * Expand buffer and try again. */ Tcl_DStringSetLength(dsPtr, len); len = Xutf8LookupString(winPtr->inputContext, &eventPtr->xkey, Tcl_DStringValue(dsPtr), Tcl_DStringLength(dsPtr), &kePtr->keysym, &status); } if ((status != XLookupChars) && (status != XLookupBoth)) { len = 0; } Tcl_DStringSetLength(dsPtr, len); #else /* !X_HAVE_UTF8_STRING */ /* * Overallocate the dstring to the maximum stack amount. */ Tcl_DStringInit(&buf); Tcl_DStringSetLength(&buf, TCL_DSTRING_STATIC_SIZE-1); len = XmbLookupString(winPtr->inputContext, &eventPtr->xkey, Tcl_DStringValue(&buf), Tcl_DStringLength(&buf), &kePtr->keysym, &status); /* * If the buffer wasn't big enough, grow the buffer and try again. */ if (status == XBufferOverflow) { Tcl_DStringSetLength(&buf, len); len = XmbLookupString(winPtr->inputContext, &eventPtr->xkey, Tcl_DStringValue(&buf), len, &kePtr->keysym, &status); } if ((status != XLookupChars) && (status != XLookupBoth)) { len = 0; } Tcl_DStringSetLength(&buf, len); Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&buf), len, dsPtr); Tcl_DStringFree(&buf); #endif /* X_HAVE_UTF8_STRING */ } else #endif /* TK_USE_INPUT_METHODS */ { /* * Fall back to convert a keyboard event to a UTF-8 string using * XLookupString. This is used when input methods are turned off and * for KeyRelease events. * * Note: XLookupString() normally returns a single ISO Latin 1 or * ASCII control character. */ Tcl_DStringInit(&buf); Tcl_DStringSetLength(&buf, TCL_DSTRING_STATIC_SIZE-1); len = XLookupString(&eventPtr->xkey, Tcl_DStringValue(&buf), TCL_DSTRING_STATIC_SIZE, &kePtr->keysym, 0); Tcl_DStringValue(&buf)[len] = '\0'; if (len == 1) { len = Tcl_UniCharToUtf((unsigned char) Tcl_DStringValue(&buf)[0], Tcl_DStringValue(dsPtr)); Tcl_DStringSetLength(dsPtr, len); } else { /* * len > 1 should only happen if someone has called XRebindKeysym. * Assume UTF-8. */ Tcl_DStringSetLength(dsPtr, len); strncpy(Tcl_DStringValue(dsPtr), Tcl_DStringValue(&buf), len); } } /* * Cache the string in the event so that if/when we return to this * function, we will be able to produce it without asking X. This stops us * from having to reenter the XIM engine. [Bug 1373712] */ kePtr->charValuePtr = ckalloc(len + 1); kePtr->charValueLen = len; memcpy(kePtr->charValuePtr, Tcl_DStringValue(dsPtr), (unsigned) len + 1); return Tcl_DStringValue(dsPtr); } /* * When mapping from a keysym to a keycode, need information about the * modifier state to be used so that when they call TkKeycodeToKeysym taking * into account the xkey.state, they will get back the original keysym. */ void TkpSetKeycodeAndState( Tk_Window tkwin, KeySym keySym, XEvent *eventPtr) { TkDisplay *dispPtr = ((TkWindow *) tkwin)->dispPtr; int state; KeyCode keycode; if (keySym == NoSymbol) { keycode = 0; } else { keycode = XKeysymToKeycode(dispPtr->display, keySym); } eventPtr->xkey.keycode = keycode; if (keycode != 0) { for (state = 0; state < 4; state++) { if (XLookupKeysym(&eventPtr->xkey, state) == keySym) { if (state & 1) { eventPtr->xkey.state |= ShiftMask; } if (state & 2) { eventPtr->xkey.state |= dispPtr->modeModMask; } break; } } } eventPtr->xkey.keycode = keycode; } /* *---------------------------------------------------------------------- * * TkpGetKeySym -- * * Given an X KeyPress or KeyRelease event, map the keycode in the event * into a KeySym. * * Results: * The return value is the KeySym corresponding to eventPtr, or NoSymbol * if no matching Keysym could be found. * * Side effects: * In the first call for a given display, keycode-to-KeySym maps get * loaded. * *---------------------------------------------------------------------- */ KeySym TkpGetKeySym( TkDisplay *dispPtr, /* Display in which to map keycode. */ XEvent *eventPtr) /* Description of X event. */ { KeySym sym; int index; TkKeyEvent* kePtr = (TkKeyEvent*) eventPtr; /* * Refresh the mapping information if it's stale. This must happen before * we do any input method processing. [Bug 3599312] */ if (dispPtr->bindInfoStale) { TkpInitKeymapInfo(dispPtr); } #ifdef TK_USE_INPUT_METHODS /* * If input methods are active, we may already have determined a keysym. * Return it. */ if (eventPtr->type == KeyPress && dispPtr && (dispPtr->flags & TK_DISPLAY_USE_IM)) { if (kePtr->charValuePtr == NULL) { Tcl_DString ds; TkWindow *winPtr = (TkWindow *) Tk_IdToWindow(eventPtr->xany.display, eventPtr->xany.window); Tcl_DStringInit(&ds); (void) TkpGetString(winPtr, eventPtr, &ds); Tcl_DStringFree(&ds); } if (kePtr->charValuePtr != NULL) { return kePtr->keysym; } } #endif /* * Figure out which of the four slots in the keymap vector to use for this * key. Refer to Xlib documentation for more info on how this computation * works. */ index = 0; if (eventPtr->xkey.state & dispPtr->modeModMask) { index = 2; } if ((eventPtr->xkey.state & ShiftMask) || ((dispPtr->lockUsage != LU_IGNORE) && (eventPtr->xkey.state & LockMask))) { index += 1; } sym = TkKeycodeToKeysym(dispPtr, eventPtr->xkey.keycode, 0, index); /* * Special handling: if the key was shifted because of Lock, but lock is * only caps lock, not shift lock, and the shifted keysym isn't upper-case * alphabetic, then switch back to the unshifted keysym. */ if ((index & 1) && !(eventPtr->xkey.state & ShiftMask) && (dispPtr->lockUsage == LU_CAPS)) { if (!(((sym >= XK_A) && (sym <= XK_Z)) || ((sym >= XK_Agrave) && (sym <= XK_Odiaeresis)) || ((sym >= XK_Ooblique) && (sym <= XK_Thorn)))) { index &= ~1; sym = TkKeycodeToKeysym(dispPtr, eventPtr->xkey.keycode, 0, index); } } /* * Another bit of special handling: if this is a shifted key and there is * no keysym defined, then use the keysym for the unshifted key. */ if ((index & 1) && (sym == NoSymbol)) { sym = TkKeycodeToKeysym(dispPtr, eventPtr->xkey.keycode, 0, index & ~1); } return sym; } /* *-------------------------------------------------------------- * * TkpInitKeymapInfo -- * * This function is invoked to scan keymap information to recompute stuff * that's important for binding, such as the modifier key (if any) that * corresponds to "mode switch". * * Results: * None. * * Side effects: * Keymap-related information in dispPtr is updated. * *-------------------------------------------------------------- */ void TkpInitKeymapInfo( TkDisplay *dispPtr) /* Display for which to recompute keymap * information. */ { XModifierKeymap *modMapPtr; KeyCode *codePtr; KeySym keysym; int count, i, j, max, arraySize; #define KEYCODE_ARRAY_SIZE 20 dispPtr->bindInfoStale = 0; modMapPtr = XGetModifierMapping(dispPtr->display); /* * Check the keycodes associated with the Lock modifier. If any of them is * associated with the XK_Shift_Lock modifier, then Lock has to be * interpreted as Shift Lock, not Caps Lock. */ dispPtr->lockUsage = LU_IGNORE; codePtr = modMapPtr->modifiermap + modMapPtr->max_keypermod*LockMapIndex; for (count = modMapPtr->max_keypermod; count > 0; count--, codePtr++) { if (*codePtr == 0) { continue; } keysym = TkKeycodeToKeysym(dispPtr, *codePtr, 0, 0); if (keysym == XK_Shift_Lock) { dispPtr->lockUsage = LU_SHIFT; break; } if (keysym == XK_Caps_Lock) { dispPtr->lockUsage = LU_CAPS; break; } } /* * Look through the keycodes associated with modifiers to see if the the * "mode switch", "meta", or "alt" keysyms are associated with any * modifiers. If so, remember their modifier mask bits. */ dispPtr->modeModMask = 0; dispPtr->metaModMask = 0; dispPtr->altModMask = 0; codePtr = modMapPtr->modifiermap; max = 8 * modMapPtr->max_keypermod; for (i = 0; i < max; i++, codePtr++) { if (*codePtr == 0) { continue; } keysym = TkKeycodeToKeysym(dispPtr, *codePtr, 0, 0); if (keysym == XK_Mode_switch) { dispPtr->modeModMask |= ShiftMask << (i/modMapPtr->max_keypermod); } if ((keysym == XK_Meta_L) || (keysym == XK_Meta_R)) { dispPtr->metaModMask |= ShiftMask << (i/modMapPtr->max_keypermod); } if ((keysym == XK_Alt_L) || (keysym == XK_Alt_R)) { dispPtr->altModMask |= ShiftMask << (i/modMapPtr->max_keypermod); } } /* * Create an array of the keycodes for all modifier keys. */ if (dispPtr->modKeyCodes != NULL) { ckfree(dispPtr->modKeyCodes); } dispPtr->numModKeyCodes = 0; arraySize = KEYCODE_ARRAY_SIZE; dispPtr->modKeyCodes = ckalloc(KEYCODE_ARRAY_SIZE * sizeof(KeyCode)); for (i = 0, codePtr = modMapPtr->modifiermap; i < max; i++, codePtr++) { if (*codePtr == 0) { continue; } /* * Make sure that the keycode isn't already in the array. */ for (j = 0; j < dispPtr->numModKeyCodes; j++) { if (dispPtr->modKeyCodes[j] == *codePtr) { /* * 'continue' the outer loop. */ goto nextModCode; } } if (dispPtr->numModKeyCodes >= arraySize) { KeyCode *newCodes; /* * Ran out of space in the array; grow it. */ arraySize *= 2; newCodes = ckalloc(arraySize * sizeof(KeyCode)); memcpy(newCodes, dispPtr->modKeyCodes, dispPtr->numModKeyCodes * sizeof(KeyCode)); ckfree(dispPtr->modKeyCodes); dispPtr->modKeyCodes = newCodes; } dispPtr->modKeyCodes[dispPtr->numModKeyCodes] = *codePtr; dispPtr->numModKeyCodes++; nextModCode: continue; } XFreeModifiermap(modMapPtr); } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ tk8.6.5/unix/tkUnixRFont.c0000644003604700454610000007701112377375532014074 0ustar dgp771div/* * tkUnixRFont.c -- * * Alternate implementation of tkUnixFont.c using Xft. * * Copyright (c) 2002-2003 Keith Packard * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tkUnixInt.h" #include "tkFont.h" #include #include typedef struct { XftFont *ftFont; XftFont *ft0Font; FcPattern *source; FcCharSet *charset; double angle; } UnixFtFace; typedef struct { TkFont font; /* Stuff used by generic font package. Must be * first in structure. */ UnixFtFace *faces; int nfaces; FcFontSet *fontset; FcPattern *pattern; Display *display; int screen; XftDraw *ftDraw; XftColor color; } UnixFtFont; /* * Used to describe the current clipping box. Can't be passed normally because * the information isn't retrievable from the GC. */ typedef struct ThreadSpecificData { Region clipRegion; /* The clipping region, or None. */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; /* * Package initialization: * Nothing to do here except register the fact that we're using Xft in * the TIP 59 configuration database. */ #ifndef TCL_CFGVAL_ENCODING #define TCL_CFGVAL_ENCODING "ascii" #endif void TkpFontPkgInit( TkMainInfo *mainPtr) /* The application being created. */ { static Tcl_Config cfg[] = { { "fontsystem", "xft" }, { 0,0 } }; Tcl_RegisterConfig(mainPtr->interp, "tk", cfg, TCL_CFGVAL_ENCODING); } static XftFont * GetFont( UnixFtFont *fontPtr, FcChar32 ucs4, double angle) { int i; if (ucs4) { for (i = 0; i < fontPtr->nfaces; i++) { FcCharSet *charset = fontPtr->faces[i].charset; if (charset && FcCharSetHasChar(charset, ucs4)) { break; } } if (i == fontPtr->nfaces) { i = 0; } } else { i = 0; } if ((angle == 0.0 && !fontPtr->faces[i].ft0Font) || (angle != 0.0 && (!fontPtr->faces[i].ftFont || fontPtr->faces[i].angle != angle))){ FcPattern *pat = FcFontRenderPrepare(0, fontPtr->pattern, fontPtr->faces[i].source); double s = sin(angle*PI/180.0), c = cos(angle*PI/180.0); FcMatrix mat; XftFont *ftFont; /* * Initialize the matrix manually so this can compile with HP-UX cc * (which does not allow non-constant structure initializers). [Bug * 2978410] */ mat.xx = mat.yy = c; mat.xy = -(mat.yx = s); if (angle != 0.0) { FcPatternAddMatrix(pat, FC_MATRIX, &mat); } ftFont = XftFontOpenPattern(fontPtr->display, pat); if (!ftFont) { /* * The previous call to XftFontOpenPattern() should not fail, but * sometimes does anyway. Usual cause appears to be a * misconfigured fontconfig installation; see [Bug 1090382]. Try a * fallback: */ ftFont = XftFontOpen(fontPtr->display, fontPtr->screen, FC_FAMILY, FcTypeString, "sans", FC_SIZE, FcTypeDouble, 12.0, FC_MATRIX, FcTypeMatrix, &mat, NULL); } if (!ftFont) { /* * The previous call should definitely not fail. Impossible to * proceed at this point. */ Tcl_Panic("Cannot find a usable font"); } if (angle == 0.0) { fontPtr->faces[i].ft0Font = ftFont; } else { if (fontPtr->faces[i].ftFont) { XftFontClose(fontPtr->display, fontPtr->faces[i].ftFont); } fontPtr->faces[i].ftFont = ftFont; fontPtr->faces[i].angle = angle; } } return (angle==0.0? fontPtr->faces[i].ft0Font : fontPtr->faces[i].ftFont); } /* *--------------------------------------------------------------------------- * * GetTkFontAttributes -- * Fill in TkFontAttributes from an XftFont. */ static void GetTkFontAttributes( XftFont *ftFont, TkFontAttributes *faPtr) { const char *family = "Unknown"; const char *const *familyPtr = &family; int weight, slant, size, pxsize; double ptsize; (void) XftPatternGetString(ftFont->pattern, XFT_FAMILY, 0, familyPtr); if (XftPatternGetDouble(ftFont->pattern, XFT_SIZE, 0, &ptsize) == XftResultMatch) { size = (int) ptsize; } else if (XftPatternGetInteger(ftFont->pattern, XFT_PIXEL_SIZE, 0, &pxsize) == XftResultMatch) { size = -pxsize; } else { size = 12; } if (XftPatternGetInteger(ftFont->pattern, XFT_WEIGHT, 0, &weight) != XftResultMatch) { weight = XFT_WEIGHT_MEDIUM; } if (XftPatternGetInteger(ftFont->pattern, XFT_SLANT, 0, &slant) != XftResultMatch) { slant = XFT_SLANT_ROMAN; } #if DEBUG_FONTSEL printf("family %s size %d weight %d slant %d\n", family, size, weight, slant); #endif /* DEBUG_FONTSEL */ faPtr->family = Tk_GetUid(family); faPtr->size = size; faPtr->weight = (weight > XFT_WEIGHT_MEDIUM) ? TK_FW_BOLD : TK_FW_NORMAL; faPtr->slant = (slant > XFT_SLANT_ROMAN) ? TK_FS_ITALIC : TK_FS_ROMAN; faPtr->underline = 0; faPtr->overstrike = 0; } /* *--------------------------------------------------------------------------- * * GetTkFontMetrics -- * Fill in TkFontMetrics from an XftFont. */ static void GetTkFontMetrics( XftFont *ftFont, TkFontMetrics *fmPtr) { int spacing; if (XftPatternGetInteger(ftFont->pattern, XFT_SPACING, 0, &spacing) != XftResultMatch) { spacing = XFT_PROPORTIONAL; } fmPtr->ascent = ftFont->ascent; fmPtr->descent = ftFont->descent; fmPtr->maxWidth = ftFont->max_advance_width; fmPtr->fixed = spacing != XFT_PROPORTIONAL; } /* *--------------------------------------------------------------------------- * * InitFont -- * * Initializes the fields of a UnixFtFont structure. If fontPtr is NULL, * also allocates a new UnixFtFont. * * Results: * On error, frees fontPtr and returns NULL, otherwise returns fontPtr. * *--------------------------------------------------------------------------- */ static UnixFtFont * InitFont( Tk_Window tkwin, FcPattern *pattern, UnixFtFont *fontPtr) { FcFontSet *set; FcCharSet *charset; FcResult result; XftFont *ftFont; int i, iWidth; if (!fontPtr) { fontPtr = ckalloc(sizeof(UnixFtFont)); } FcConfigSubstitute(0, pattern, FcMatchPattern); XftDefaultSubstitute(Tk_Display(tkwin), Tk_ScreenNumber(tkwin), pattern); /* * Generate the list of fonts */ set = FcFontSort(0, pattern, FcTrue, NULL, &result); if (!set) { ckfree(fontPtr); return NULL; } fontPtr->fontset = set; fontPtr->pattern = pattern; fontPtr->faces = ckalloc(set->nfont * sizeof(UnixFtFace)); fontPtr->nfaces = set->nfont; /* * Fill in information about each returned font */ for (i = 0; i < set->nfont; i++) { fontPtr->faces[i].ftFont = 0; fontPtr->faces[i].ft0Font = 0; fontPtr->faces[i].source = set->fonts[i]; if (FcPatternGetCharSet(set->fonts[i], FC_CHARSET, 0, &charset) == FcResultMatch) { fontPtr->faces[i].charset = FcCharSetCopy(charset); } else { fontPtr->faces[i].charset = 0; } fontPtr->faces[i].angle = 0.0; } fontPtr->display = Tk_Display(tkwin); fontPtr->screen = Tk_ScreenNumber(tkwin); fontPtr->ftDraw = 0; fontPtr->color.color.red = 0; fontPtr->color.color.green = 0; fontPtr->color.color.blue = 0; fontPtr->color.color.alpha = 0xffff; fontPtr->color.pixel = 0xffffffff; /* * Fill in platform-specific fields of TkFont. */ ftFont = GetFont(fontPtr, 0, 0.0); fontPtr->font.fid = XLoadFont(Tk_Display(tkwin), "fixed"); GetTkFontAttributes(ftFont, &fontPtr->font.fa); GetTkFontMetrics(ftFont, &fontPtr->font.fm); /* * Fontconfig can't report any information about the position or thickness * of underlines or overstrikes. Thus, we use some defaults that are * hacked around from backup defaults in tkUnixFont.c, which are in turn * based on recommendations in the X manual. The comments from that file * leading to these computations were: * * If the XA_UNDERLINE_POSITION property does not exist, the X manual * recommends using half the descent. * * If the XA_UNDERLINE_THICKNESS property does not exist, the X * manual recommends using the width of the stem on a capital letter. * I don't know of a way to get the stem width of a letter, so guess * and use 1/3 the width of a capital I. * * Note that nothing corresponding to *either* property is reported by * Fontconfig at all. [Bug 1961455] */ { TkFont *fPtr = &fontPtr->font; fPtr->underlinePos = fPtr->fm.descent / 2; Tk_MeasureChars((Tk_Font) fPtr, "I", 1, -1, 0, &iWidth); fPtr->underlineHeight = iWidth / 3; if (fPtr->underlineHeight == 0) { fPtr->underlineHeight = 1; } if (fPtr->underlineHeight + fPtr->underlinePos > fPtr->fm.descent) { fPtr->underlineHeight = fPtr->fm.descent - fPtr->underlinePos; if (fPtr->underlineHeight == 0) { fPtr->underlinePos--; fPtr->underlineHeight = 1; } } } return fontPtr; } static void FinishedWithFont( UnixFtFont *fontPtr) { Display *display = fontPtr->display; int i; Tk_ErrorHandler handler = Tk_CreateErrorHandler(display, -1, -1, -1, NULL, NULL); for (i = 0; i < fontPtr->nfaces; i++) { if (fontPtr->faces[i].ftFont) { XftFontClose(fontPtr->display, fontPtr->faces[i].ftFont); } if (fontPtr->faces[i].ft0Font) { XftFontClose(fontPtr->display, fontPtr->faces[i].ft0Font); } if (fontPtr->faces[i].charset) { FcCharSetDestroy(fontPtr->faces[i].charset); } } if (fontPtr->faces) { ckfree(fontPtr->faces); } if (fontPtr->pattern) { FcPatternDestroy(fontPtr->pattern); } if (fontPtr->ftDraw) { XftDrawDestroy(fontPtr->ftDraw); } if (fontPtr->font.fid) { XUnloadFont(fontPtr->display, fontPtr->font.fid); } if (fontPtr->fontset) { FcFontSetDestroy(fontPtr->fontset); } Tk_DeleteErrorHandler(handler); } TkFont * TkpGetNativeFont( Tk_Window tkwin, /* For display where font will be used. */ const char *name) /* Platform-specific font name. */ { UnixFtFont *fontPtr; FcPattern *pattern; #if DEBUG_FONTSEL printf("TkpGetNativeFont %s\n", name); #endif /* DEBUG_FONTSEL */ pattern = XftXlfdParse(name, FcFalse, FcFalse); if (!pattern) { return NULL; } /* * Should also try: pattern = FcNameParse(name); but generic/tkFont.c * expects TkpGetNativeFont() to only work on XLFD names under Unix. */ fontPtr = InitFont(tkwin, pattern, NULL); if (!fontPtr) { FcPatternDestroy(pattern); return NULL; } return &fontPtr->font; } TkFont * TkpGetFontFromAttributes( TkFont *tkFontPtr, /* If non-NULL, store the information in this * existing TkFont structure, rather than * allocating a new structure to hold the * font; the existing contents of the font * will be released. If NULL, a new TkFont * structure is allocated. */ Tk_Window tkwin, /* For display where font will be used. */ const TkFontAttributes *faPtr) /* Set of attributes to match. */ { XftPattern *pattern; int weight, slant; UnixFtFont *fontPtr; #if DEBUG_FONTSEL printf("TkpGetFontFromAttributes %s-%d %d %d\n", faPtr->family, faPtr->size, faPtr->weight, faPtr->slant); #endif /* DEBUG_FONTSEL */ pattern = XftPatternCreate(); if (faPtr->family) { XftPatternAddString(pattern, XFT_FAMILY, faPtr->family); } if (faPtr->size > 0) { XftPatternAddDouble(pattern, XFT_SIZE, (double)faPtr->size); } else if (faPtr->size < 0) { XftPatternAddInteger(pattern, XFT_PIXEL_SIZE, -faPtr->size); } else { XftPatternAddDouble(pattern, XFT_SIZE, 12.0); } switch (faPtr->weight) { case TK_FW_NORMAL: default: weight = XFT_WEIGHT_MEDIUM; break; case TK_FW_BOLD: weight = XFT_WEIGHT_BOLD; break; } XftPatternAddInteger(pattern, XFT_WEIGHT, weight); switch (faPtr->slant) { case TK_FS_ROMAN: default: slant = XFT_SLANT_ROMAN; break; case TK_FS_ITALIC: slant = XFT_SLANT_ITALIC; break; case TK_FS_OBLIQUE: slant = XFT_SLANT_OBLIQUE; break; } XftPatternAddInteger(pattern, XFT_SLANT, slant); fontPtr = (UnixFtFont *) tkFontPtr; if (fontPtr != NULL) { FinishedWithFont(fontPtr); } fontPtr = InitFont(tkwin, pattern, fontPtr); /* * Hack to work around issues with weird issues with Xft/Xrender * connection. For details, see comp.lang.tcl thread starting from * */ if (!fontPtr) { XftPatternAddBool(pattern, XFT_RENDER, FcFalse); fontPtr = InitFont(tkwin, pattern, fontPtr); } if (!fontPtr) { FcPatternDestroy(pattern); return NULL; } fontPtr->font.fa.underline = faPtr->underline; fontPtr->font.fa.overstrike = faPtr->overstrike; return &fontPtr->font; } void TkpDeleteFont( TkFont *tkFontPtr) /* Token of font to be deleted. */ { UnixFtFont *fontPtr = (UnixFtFont *) tkFontPtr; FinishedWithFont(fontPtr); /* XXX tkUnixFont.c doesn't free tkFontPtr... */ } /* *--------------------------------------------------------------------------- * * TkpGetFontFamilies -- * * Return information about the font families that are available on the * display of the given window. * * Results: * Modifies interp's result object to hold a list of all the available * font families. * *--------------------------------------------------------------------------- */ void TkpGetFontFamilies( Tcl_Interp *interp, /* Interp to hold result. */ Tk_Window tkwin) /* For display to query. */ { Tcl_Obj *resultPtr; XftFontSet *list; int i; resultPtr = Tcl_NewListObj(0, NULL); list = XftListFonts(Tk_Display(tkwin), Tk_ScreenNumber(tkwin), (char *) 0, /* pattern elements */ XFT_FAMILY, (char*) 0); /* fields */ for (i = 0; i < list->nfont; i++) { char *family, **familyPtr = &family; if (XftPatternGetString(list->fonts[i], XFT_FAMILY, 0, familyPtr) == XftResultMatch) { Tcl_Obj *strPtr = Tcl_NewStringObj(family, -1); Tcl_ListObjAppendElement(NULL, resultPtr, strPtr); } } XftFontSetDestroy(list); Tcl_SetObjResult(interp, resultPtr); } /* *------------------------------------------------------------------------- * * TkpGetSubFonts -- * * Called by [testfont subfonts] in the Tk testing package. * * Results: * Sets interp's result to a list of the faces used by tkfont * *------------------------------------------------------------------------- */ void TkpGetSubFonts( Tcl_Interp *interp, Tk_Font tkfont) { Tcl_Obj *objv[3], *listPtr, *resultPtr; UnixFtFont *fontPtr = (UnixFtFont *) tkfont; FcPattern *pattern; const char *family = "Unknown"; const char *const *familyPtr = &family; const char *foundry = "Unknown"; const char *const *foundryPtr = &foundry; const char *encoding = "Unknown"; const char *const *encodingPtr = &encoding; int i; resultPtr = Tcl_NewListObj(0, NULL); for (i = 0; i < fontPtr->nfaces ; ++i) { pattern = FcFontRenderPrepare(0, fontPtr->pattern, fontPtr->faces[i].source); XftPatternGetString(pattern, XFT_FAMILY, 0, familyPtr); XftPatternGetString(pattern, XFT_FOUNDRY, 0, foundryPtr); XftPatternGetString(pattern, XFT_ENCODING, 0, encodingPtr); objv[0] = Tcl_NewStringObj(family, -1); objv[1] = Tcl_NewStringObj(foundry, -1); objv[2] = Tcl_NewStringObj(encoding, -1); listPtr = Tcl_NewListObj(3, objv); Tcl_ListObjAppendElement(NULL, resultPtr, listPtr); } Tcl_SetObjResult(interp, resultPtr); } /* *---------------------------------------------------------------------- * * TkpGetFontAttrsForChar -- * * Retrieve the font attributes of the actual font used to render a given * character. * *---------------------------------------------------------------------- */ void TkpGetFontAttrsForChar( Tk_Window tkwin, /* Window on the font's display */ Tk_Font tkfont, /* Font to query */ Tcl_UniChar c, /* Character of interest */ TkFontAttributes *faPtr) /* Output: Font attributes */ { UnixFtFont *fontPtr = (UnixFtFont *) tkfont; /* Structure describing the logical font */ FcChar32 ucs4 = (FcChar32) c; /* UCS-4 character to map */ XftFont *ftFont = GetFont(fontPtr, ucs4, 0.0); /* Actual font used to render the character */ GetTkFontAttributes(ftFont, faPtr); faPtr->underline = fontPtr->font.fa.underline; faPtr->overstrike = fontPtr->font.fa.overstrike; } int Tk_MeasureChars( Tk_Font tkfont, /* Font in which characters will be drawn. */ const char *source, /* UTF-8 string to be displayed. Need not be * '\0' terminated. */ int numBytes, /* Maximum number of bytes to consider from * source string. */ int maxLength, /* If >= 0, maxLength specifies the longest * permissible line length in pixels; don't * consider any character that would cross * this x-position. If < 0, then line length * is unbounded and the flags argument is * ignored. */ int flags, /* Various flag bits OR-ed together: * TK_PARTIAL_OK means include the last char * which only partially fit on this line. * TK_WHOLE_WORDS means stop on a word * boundary, if possible. TK_AT_LEAST_ONE * means return at least one character even if * no characters fit. */ int *lengthPtr) /* Filled with x-location just after the * terminating character. */ { UnixFtFont *fontPtr = (UnixFtFont *) tkfont; XftFont *ftFont; FcChar32 c; XGlyphInfo extents; int clen, curX, newX, curByte, newByte, sawNonSpace; int termByte = 0, termX = 0; #if DEBUG_FONTSEL char string[256]; int len = 0; #endif /* DEBUG_FONTSEL */ curX = 0; curByte = 0; sawNonSpace = 0; while (numBytes > 0) { Tcl_UniChar unichar; clen = Tcl_UtfToUniChar(source, &unichar); c = (FcChar32) unichar; if (clen <= 0) { /* * This can't happen (but see #1185640) */ *lengthPtr = curX; return curByte; } source += clen; numBytes -= clen; if (c < 256 && isspace(c)) { /* I18N: ??? */ if (sawNonSpace) { termByte = curByte; termX = curX; sawNonSpace = 0; } } else { sawNonSpace = 1; } #if DEBUG_FONTSEL string[len++] = (char) c; #endif /* DEBUG_FONTSEL */ ftFont = GetFont(fontPtr, c, 0.0); XftTextExtents32(fontPtr->display, ftFont, &c, 1, &extents); newX = curX + extents.xOff; newByte = curByte + clen; if (maxLength >= 0 && newX > maxLength) { if (flags & TK_PARTIAL_OK || (flags & TK_AT_LEAST_ONE && curByte == 0)) { curX = newX; curByte = newByte; } else if (flags & TK_WHOLE_WORDS && termX != 0) { curX = termX; curByte = termByte; } break; } curX = newX; curByte = newByte; } #if DEBUG_FONTSEL string[len] = '\0'; printf("MeasureChars %s length %d bytes %d\n", string, curX, curByte); #endif /* DEBUG_FONTSEL */ *lengthPtr = curX; return curByte; } int TkpMeasureCharsInContext( Tk_Font tkfont, const char *source, int numBytes, int rangeStart, int rangeLength, int maxLength, int flags, int *lengthPtr) { (void) numBytes; /*unused*/ return Tk_MeasureChars(tkfont, source + rangeStart, rangeLength, maxLength, flags, lengthPtr); } #define NUM_SPEC 1024 void Tk_DrawChars( Display *display, /* Display on which to draw. */ Drawable drawable, /* Window or pixmap in which to draw. */ GC gc, /* Graphics context for drawing characters. */ Tk_Font tkfont, /* Font in which characters will be drawn; * must be the same as font used in GC. */ const char *source, /* UTF-8 string to be displayed. Need not be * '\0' terminated. All Tk meta-characters * (tabs, control characters, and newlines) * should be stripped out of the string that * is passed to this function. If they are not * stripped out, they will be displayed as * regular printing characters. */ int numBytes, /* Number of bytes in string. */ int x, int y) /* Coordinates at which to place origin of * string when drawing. */ { const int maxCoord = 0x7FFF;/* Xft coordinates are 16 bit values */ UnixFtFont *fontPtr = (UnixFtFont *) tkfont; XGCValues values; XColor xcolor; int clen, nspec, xStart = x; XftGlyphFontSpec specs[NUM_SPEC]; XGlyphInfo metrics; ThreadSpecificData *tsdPtr = (ThreadSpecificData *) Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); if (fontPtr->ftDraw == 0) { #if DEBUG_FONTSEL printf("Switch to drawable 0x%x\n", drawable); #endif /* DEBUG_FONTSEL */ fontPtr->ftDraw = XftDrawCreate(display, drawable, DefaultVisual(display, fontPtr->screen), DefaultColormap(display, fontPtr->screen)); } else { Tk_ErrorHandler handler = Tk_CreateErrorHandler(display, -1, -1, -1, NULL, NULL); XftDrawChange(fontPtr->ftDraw, drawable); Tk_DeleteErrorHandler(handler); } XGetGCValues(display, gc, GCForeground, &values); if (values.foreground != fontPtr->color.pixel) { xcolor.pixel = values.foreground; XQueryColor(display, DefaultColormap(display, fontPtr->screen), &xcolor); fontPtr->color.color.red = xcolor.red; fontPtr->color.color.green = xcolor.green; fontPtr->color.color.blue = xcolor.blue; fontPtr->color.color.alpha = 0xffff; fontPtr->color.pixel = values.foreground; } if (tsdPtr->clipRegion != None) { XftDrawSetClip(fontPtr->ftDraw, tsdPtr->clipRegion); } nspec = 0; while (numBytes > 0 && x <= maxCoord && y <= maxCoord) { XftFont *ftFont; FcChar32 c; clen = FcUtf8ToUcs4((FcChar8 *) source, &c, numBytes); if (clen <= 0) { /* * This should not happen, but it can. */ goto doUnderlineStrikeout; } source += clen; numBytes -= clen; ftFont = GetFont(fontPtr, c, 0.0); if (ftFont) { specs[nspec].font = ftFont; specs[nspec].glyph = XftCharIndex(fontPtr->display, ftFont, c); specs[nspec].x = x; specs[nspec].y = y; XftGlyphExtents(fontPtr->display, ftFont, &specs[nspec].glyph, 1, &metrics); x += metrics.xOff; y += metrics.yOff; nspec++; if (nspec == NUM_SPEC) { XftDrawGlyphFontSpec(fontPtr->ftDraw, &fontPtr->color, specs, nspec); nspec = 0; } } } if (nspec) { XftDrawGlyphFontSpec(fontPtr->ftDraw, &fontPtr->color, specs, nspec); } doUnderlineStrikeout: if (tsdPtr->clipRegion != None) { XftDrawSetClip(fontPtr->ftDraw, None); } if (fontPtr->font.fa.underline != 0) { XFillRectangle(display, drawable, gc, xStart, y + fontPtr->font.underlinePos, (unsigned) (x - xStart), (unsigned) fontPtr->font.underlineHeight); } if (fontPtr->font.fa.overstrike != 0) { y -= fontPtr->font.fm.descent + (fontPtr->font.fm.ascent) / 10; XFillRectangle(display, drawable, gc, xStart, y, (unsigned) (x - xStart), (unsigned) fontPtr->font.underlineHeight); } } /* *--------------------------------------------------------------------------- * * TkDrawAngledChars -- * * Draw some characters at an angle. This would be simple code, except * Xft has bugs with cumulative errors in character positioning which are * caused by trying to perform all calculations internally with integers. * So we have to do the work ourselves with floating-point math. * * Results: * None. * * Side effects: * Target drawable is updated. * *--------------------------------------------------------------------------- */ void TkDrawAngledChars( Display *display, /* Display on which to draw. */ Drawable drawable, /* Window or pixmap in which to draw. */ GC gc, /* Graphics context for drawing characters. */ Tk_Font tkfont, /* Font in which characters will be drawn; * must be the same as font used in GC. */ const char *source, /* UTF-8 string to be displayed. Need not be * '\0' terminated. All Tk meta-characters * (tabs, control characters, and newlines) * should be stripped out of the string that * is passed to this function. If they are not * stripped out, they will be displayed as * regular printing characters. */ int numBytes, /* Number of bytes in string. */ double x, double y, /* Coordinates at which to place origin of * string when drawing. */ double angle) /* What angle to put text at, in degrees. */ { const int maxCoord = 0x7FFF;/* Xft coordinates are 16 bit values */ const int minCoord = -1000; /* Should be good enough... */ UnixFtFont *fontPtr = (UnixFtFont *) tkfont; XGCValues values; XColor xcolor; int xStart = x, yStart = y; ThreadSpecificData *tsdPtr = (ThreadSpecificData *) Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); #ifdef XFT_HAS_FIXED_ROTATED_PLACEMENT int clen, nglyph; FT_UInt glyphs[NUM_SPEC]; XGlyphInfo metrics; XftFont *currentFtFont; int originX, originY; if (fontPtr->ftDraw == 0) { #if DEBUG_FONTSEL printf("Switch to drawable 0x%x\n", drawable); #endif /* DEBUG_FONTSEL */ fontPtr->ftDraw = XftDrawCreate(display, drawable, DefaultVisual(display, fontPtr->screen), DefaultColormap(display, fontPtr->screen)); } else { Tk_ErrorHandler handler = Tk_CreateErrorHandler(display, -1, -1, -1, NULL, NULL); XftDrawChange(fontPtr->ftDraw, drawable); Tk_DeleteErrorHandler(handler); } XGetGCValues(display, gc, GCForeground, &values); if (values.foreground != fontPtr->color.pixel) { xcolor.pixel = values.foreground; XQueryColor(display, DefaultColormap(display, fontPtr->screen), &xcolor); fontPtr->color.color.red = xcolor.red; fontPtr->color.color.green = xcolor.green; fontPtr->color.color.blue = xcolor.blue; fontPtr->color.color.alpha = 0xffff; fontPtr->color.pixel = values.foreground; } if (tsdPtr->clipRegion != None) { XftDrawSetClip(fontPtr->ftDraw, tsdPtr->clipRegion); } nglyph = 0; currentFtFont = NULL; originX = originY = 0; /* lint */ while (numBytes > 0 && x <= maxCoord && x >= minCoord && y <= maxCoord && y >= minCoord) { XftFont *ftFont; FcChar32 c; clen = FcUtf8ToUcs4((FcChar8 *) source, &c, numBytes); if (clen <= 0) { /* * This should not happen, but it can. */ goto doUnderlineStrikeout; } source += clen; numBytes -= clen; ftFont = GetFont(fontPtr, c, angle); if (!ftFont) { continue; } if (ftFont != currentFtFont || nglyph == NUM_SPEC) { if (nglyph) { /* * We pass multiple glyphs at once to enable the code to * perform better rendering of sub-pixel inter-glyph spacing. * If only the current Xft implementation could make use of * this information... but we'll be ready when it does! */ XftDrawGlyphs(fontPtr->ftDraw, &fontPtr->color, currentFtFont, originX, originY, glyphs, nglyph); } originX = ROUND16(x); originY = ROUND16(y); if (nglyph) { XftGlyphExtents(fontPtr->display, currentFtFont, glyphs, nglyph, &metrics); nglyph = 0; x += metrics.xOff; y += metrics.yOff; } currentFtFont = ftFont; } glyphs[nglyph++] = XftCharIndex(fontPtr->display, ftFont, c); } if (nglyph) { XftDrawGlyphs(fontPtr->ftDraw, &fontPtr->color, currentFtFont, originX, originY, glyphs, nglyph); } #else /* !XFT_HAS_FIXED_ROTATED_PLACEMENT */ int clen, nspec; XftGlyphFontSpec specs[NUM_SPEC]; XGlyphInfo metrics; double sinA = sin(angle * PI/180.0), cosA = cos(angle * PI/180.0); if (fontPtr->ftDraw == 0) { #if DEBUG_FONTSEL printf("Switch to drawable 0x%x\n", drawable); #endif /* DEBUG_FONTSEL */ fontPtr->ftDraw = XftDrawCreate(display, drawable, DefaultVisual(display, fontPtr->screen), DefaultColormap(display, fontPtr->screen)); } else { Tk_ErrorHandler handler = Tk_CreateErrorHandler(display, -1, -1, -1, NULL, NULL); XftDrawChange(fontPtr->ftDraw, drawable); Tk_DeleteErrorHandler(handler); } XGetGCValues(display, gc, GCForeground, &values); if (values.foreground != fontPtr->color.pixel) { xcolor.pixel = values.foreground; XQueryColor(display, DefaultColormap(display, fontPtr->screen), &xcolor); fontPtr->color.color.red = xcolor.red; fontPtr->color.color.green = xcolor.green; fontPtr->color.color.blue = xcolor.blue; fontPtr->color.color.alpha = 0xffff; fontPtr->color.pixel = values.foreground; } if (tsdPtr->clipRegion != None) { XftDrawSetClip(fontPtr->ftDraw, tsdPtr->clipRegion); } nspec = 0; while (numBytes > 0 && x <= maxCoord && x >= minCoord && y <= maxCoord && y >= minCoord) { XftFont *ftFont, *ft0Font; FcChar32 c; clen = FcUtf8ToUcs4((FcChar8 *) source, &c, numBytes); if (clen <= 0) { /* * This should not happen, but it can. */ goto doUnderlineStrikeout; } source += clen; numBytes -= clen; ftFont = GetFont(fontPtr, c, angle); ft0Font = GetFont(fontPtr, c, 0.0); if (ftFont && ft0Font) { specs[nspec].font = ftFont; specs[nspec].glyph = XftCharIndex(fontPtr->display, ftFont, c); specs[nspec].x = ROUND16(x); specs[nspec].y = ROUND16(y); XftGlyphExtents(fontPtr->display, ft0Font, &specs[nspec].glyph, 1, &metrics); x += metrics.xOff*cosA + metrics.yOff*sinA; y += metrics.yOff*cosA - metrics.xOff*sinA; nspec++; if (nspec == NUM_SPEC) { XftDrawGlyphFontSpec(fontPtr->ftDraw, &fontPtr->color, specs, nspec); nspec = 0; } } } if (nspec) { XftDrawGlyphFontSpec(fontPtr->ftDraw, &fontPtr->color, specs, nspec); } #endif /* XFT_HAS_FIXED_ROTATED_PLACEMENT */ doUnderlineStrikeout: if (tsdPtr->clipRegion != None) { XftDrawSetClip(fontPtr->ftDraw, None); } if (fontPtr->font.fa.underline || fontPtr->font.fa.overstrike) { XPoint points[5]; double width = (x - xStart) * cosA + (yStart - y) * sinA; double barHeight = fontPtr->font.underlineHeight; double dy = fontPtr->font.underlinePos; if (fontPtr->font.fa.underline != 0) { if (fontPtr->font.underlineHeight == 1) { dy++; } points[0].x = xStart + ROUND16(dy*sinA); points[0].y = yStart + ROUND16(dy*cosA); points[1].x = xStart + ROUND16(dy*sinA + width*cosA); points[1].y = yStart + ROUND16(dy*cosA - width*sinA); if (fontPtr->font.underlineHeight == 1) { XDrawLines(display, drawable, gc, points, 2, CoordModeOrigin); } else { points[2].x = xStart + ROUND16(dy*sinA + width*cosA + barHeight*sinA); points[2].y = yStart + ROUND16(dy*cosA - width*sinA + barHeight*cosA); points[3].x = xStart + ROUND16(dy*sinA + barHeight*sinA); points[3].y = yStart + ROUND16(dy*cosA + barHeight*cosA); points[4].x = points[0].x; points[4].y = points[0].y; XFillPolygon(display, drawable, gc, points, 5, Complex, CoordModeOrigin); XDrawLines(display, drawable, gc, points, 5, CoordModeOrigin); } } if (fontPtr->font.fa.overstrike != 0) { dy = -fontPtr->font.fm.descent - (fontPtr->font.fm.ascent) / 10; points[0].x = xStart + ROUND16(dy*sinA); points[0].y = yStart + ROUND16(dy*cosA); points[1].x = xStart + ROUND16(dy*sinA + width*cosA); points[1].y = yStart + ROUND16(dy*cosA - width*sinA); if (fontPtr->font.underlineHeight == 1) { XDrawLines(display, drawable, gc, points, 2, CoordModeOrigin); } else { points[2].x = xStart + ROUND16(dy*sinA + width*cosA + barHeight*sinA); points[2].y = yStart + ROUND16(dy*cosA - width*sinA + barHeight*cosA); points[3].x = xStart + ROUND16(dy*sinA + barHeight*sinA); points[3].y = yStart + ROUND16(dy*cosA + barHeight*cosA); points[4].x = points[0].x; points[4].y = points[0].y; XFillPolygon(display, drawable, gc, points, 5, Complex, CoordModeOrigin); XDrawLines(display, drawable, gc, points, 5, CoordModeOrigin); } } } } void TkUnixSetXftClipRegion( TkRegion clipRegion) /* The clipping region to install. */ { ThreadSpecificData *tsdPtr = (ThreadSpecificData *) Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); tsdPtr->clipRegion = (Region) clipRegion; } /* * Local Variables: * c-basic-offset: 4 * fill-column: 78 * End: */ tk8.6.5/unix/tkUnixSelect.c0000644003604700454610000013006112377375532014256 0ustar dgp771div/* * tkUnixSelect.c -- * * This file contains X specific routines for manipulating selections. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tkInt.h" #include "tkSelect.h" typedef struct ConvertInfo { int offset; /* The starting byte offset into the selection * for the next chunk; -1 means all data has * been transferred for this conversion. -2 * means only the final zero-length transfer * still has to be done. Otherwise it is the * offset of the next chunk of data to * transfer. */ Tcl_EncodingState state; /* The encoding state needed across chunks. */ char buffer[TCL_UTF_MAX]; /* A buffer to hold part of a UTF character * that is split across chunks.*/ } ConvertInfo; /* * When handling INCR-style selection retrievals, the selection owner uses the * following data structure to communicate between the ConvertSelection * function and TkSelPropProc. */ typedef struct IncrInfo { TkWindow *winPtr; /* Window that owns selection. */ Atom selection; /* Selection that is being retrieved. */ Atom *multAtoms; /* Information about conversions to perform: * one or more pairs of (target, property). * This either points to a retrieved property * (for MULTIPLE retrievals) or to a static * array. */ unsigned long numConversions; /* Number of entries in converts (same as # of * pairs in multAtoms). */ ConvertInfo *converts; /* One entry for each pair in multAtoms. This * array is malloc-ed. */ char **tempBufs; /* One pointer for each pair in multAtoms; * each pointer is either NULL, or it points * to a small bit of character data that was * left over from the previous chunk. */ Tcl_EncodingState *state; /* One state info per pair in multAtoms: State * info for encoding conversions that span * multiple buffers. */ int *flags; /* One state flag per pair in multAtoms: * Encoding flags, set to TCL_ENCODING_START * at the beginning of an INCR transfer. */ int numIncrs; /* Number of entries in converts that aren't * -1 (i.e. # of INCR-mode transfers not yet * completed). */ Tcl_TimerToken timeout; /* Token for timer function. */ int idleTime; /* Number of seconds since we heard anything * from the selection requestor. */ Window reqWindow; /* Requestor's window id. */ Time time; /* Timestamp corresponding to selection at * beginning of request; used to abort * transfer if selection changes. */ struct IncrInfo *nextPtr; /* Next in list of all INCR-style retrievals * currently pending. */ } IncrInfo; typedef struct ThreadSpecificData { IncrInfo *pendingIncrs; /* List of all incr structures currently * active. */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; /* * Largest property that we'll accept when sending or receiving the selection: */ #define MAX_PROP_WORDS 100000 static TkSelRetrievalInfo *pendingRetrievals = NULL; /* List of all retrievals currently being * waited for. */ /* * Forward declarations for functions defined in this file: */ static void ConvertSelection(TkWindow *winPtr, XSelectionRequestEvent *eventPtr); static void IncrTimeoutProc(ClientData clientData); static void SelCvtFromX32(long *propPtr, int numValues, Atom type, Tk_Window tkwin, Tcl_DString *dsPtr); static void SelCvtFromX8(char *propPtr, int numValues, Atom type, Tk_Window tkwin, Tcl_DString *dsPtr); static long * SelCvtToX(char *string, Atom type, Tk_Window tkwin, int *numLongsPtr); static int SelectionSize(TkSelHandler *selPtr); static void SelRcvIncrProc(ClientData clientData, XEvent *eventPtr); static void SelTimeoutProc(ClientData clientData); /* *---------------------------------------------------------------------- * * TkSelGetSelection -- * * Retrieve the specified selection from another process. * * Results: * The return value is a standard Tcl return value. If an error occurs * (such as no selection exists) then an error message is left in the * interp's result. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TkSelGetSelection( Tcl_Interp *interp, /* Interpreter to use for reporting errors. */ Tk_Window tkwin, /* Window on whose behalf to retrieve the * selection (determines display from which to * retrieve). */ Atom selection, /* Selection to retrieve. */ Atom target, /* Desired form in which selection is to be * returned. */ Tk_GetSelProc *proc, /* Function to call to process the selection, * once it has been retrieved. */ ClientData clientData) /* Arbitrary value to pass to proc. */ { TkSelRetrievalInfo retr; TkWindow *winPtr = (TkWindow *) tkwin; TkDisplay *dispPtr = winPtr->dispPtr; /* * The selection is owned by some other process. To retrieve it, first * record information about the retrieval in progress. Use an internal * window as the requestor. */ retr.interp = interp; if (dispPtr->clipWindow == NULL) { int result; result = TkClipInit(interp, dispPtr); if (result != TCL_OK) { return result; } } retr.winPtr = (TkWindow *) dispPtr->clipWindow; retr.selection = selection; retr.property = selection; retr.target = target; retr.proc = proc; retr.clientData = clientData; retr.result = -1; retr.idleTime = 0; retr.encFlags = TCL_ENCODING_START; retr.nextPtr = pendingRetrievals; Tcl_DStringInit(&retr.buf); pendingRetrievals = &retr; /* * Initiate the request for the selection. Note: can't use TkCurrentTime * for the time. If we do, and this application hasn't received any X * events in a long time, the current time will be way in the past and * could even predate the time when the selection was made; if this * happens, the request will be rejected. */ XConvertSelection(winPtr->display, retr.selection, retr.target, retr.property, retr.winPtr->window, CurrentTime); /* * Enter a loop processing X events until the selection has been retrieved * and processed. If no response is received within a few seconds, then * timeout. */ retr.timeout = Tcl_CreateTimerHandler(1000, SelTimeoutProc, &retr); while (retr.result == -1) { Tcl_DoOneEvent(0); } Tcl_DeleteTimerHandler(retr.timeout); /* * Unregister the information about the selection retrieval in progress. */ if (pendingRetrievals == &retr) { pendingRetrievals = retr.nextPtr; } else { TkSelRetrievalInfo *retrPtr; for (retrPtr = pendingRetrievals; retrPtr != NULL; retrPtr = retrPtr->nextPtr) { if (retrPtr->nextPtr == &retr) { retrPtr->nextPtr = retr.nextPtr; break; } } } Tcl_DStringFree(&retr.buf); return retr.result; } /* *---------------------------------------------------------------------- * * TkSelPropProc -- * * This function is invoked when property-change events occur on windows * not known to the toolkit. Its function is to implement the sending * side of the INCR selection retrieval protocol when the selection * requestor deletes the property containing a part of the selection. * * Results: * None. * * Side effects: * If the property that is receiving the selection was just deleted, then * a new piece of the selection is fetched and placed in the property, * until eventually there's no more selection to fetch. * *---------------------------------------------------------------------- */ void TkSelPropProc( register XEvent *eventPtr) /* X PropertyChange event. */ { register IncrInfo *incrPtr; register TkSelHandler *selPtr; int length, numItems; unsigned long i; Atom target, formatType; long buffer[TK_SEL_WORDS_AT_ONCE]; TkDisplay *dispPtr = TkGetDisplay(eventPtr->xany.display); Tk_ErrorHandler errorHandler; ThreadSpecificData *tsdPtr = Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); /* * See if this event announces the deletion of a property being used for * an INCR transfer. If so, then add the next chunk of data to the * property. */ if (eventPtr->xproperty.state != PropertyDelete) { return; } for (incrPtr = tsdPtr->pendingIncrs; incrPtr != NULL; incrPtr = incrPtr->nextPtr) { if (incrPtr->reqWindow != eventPtr->xproperty.window) { continue; } /* * For each conversion that has been requested, handle any chunks that * haven't been transmitted yet. */ for (i = 0; i < incrPtr->numConversions; i++) { if ((eventPtr->xproperty.atom != incrPtr->multAtoms[2*i + 1]) || (incrPtr->converts[i].offset == -1)) { continue; } target = incrPtr->multAtoms[2*i]; incrPtr->idleTime = 0; /* * Look for a matching selection handler. */ for (selPtr = incrPtr->winPtr->selHandlerList; ; selPtr = selPtr->nextPtr) { if (selPtr == NULL) { /* * No handlers match, so mark the conversion as done. */ incrPtr->multAtoms[2*i + 1] = None; incrPtr->converts[i].offset = -1; incrPtr->numIncrs --; return; } if ((selPtr->target == target) && (selPtr->selection == incrPtr->selection)) { break; } } /* * We found a handler, so get the next chunk from it. */ formatType = selPtr->format; if (incrPtr->converts[i].offset == -2) { /* * We already got the last chunk, so send a null chunk to * indicate that we are finished. */ numItems = 0; length = 0; } else { TkSelInProgress ip; ip.selPtr = selPtr; ip.nextPtr = TkSelGetInProgress(); TkSelSetInProgress(&ip); /* * Copy any bytes left over from a partial character at the * end of the previous chunk into the beginning of the buffer. * Pass the rest of the buffer space into the selection * handler. */ length = strlen(incrPtr->converts[i].buffer); strcpy((char *)buffer, incrPtr->converts[i].buffer); numItems = selPtr->proc(selPtr->clientData, incrPtr->converts[i].offset, ((char *) buffer) + length, TK_SEL_BYTES_AT_ONCE - length); TkSelSetInProgress(ip.nextPtr); if (ip.selPtr == NULL) { /* * The selection handler deleted itself. */ return; } if (numItems < 0) { numItems = 0; } numItems += length; if (numItems > TK_SEL_BYTES_AT_ONCE) { Tcl_Panic("selection handler returned too many bytes"); } } ((char *) buffer)[numItems] = 0; errorHandler = Tk_CreateErrorHandler(eventPtr->xproperty.display, -1, -1, -1, (int (*)()) NULL, NULL); /* * Encode the data using the proper format for each type. */ if ((formatType == XA_STRING) || (dispPtr && formatType==dispPtr->utf8Atom) || (dispPtr && formatType==dispPtr->compoundTextAtom)) { Tcl_DString ds; int encodingCvtFlags; int srcLen, dstLen, result, srcRead, dstWrote, soFar; char *src, *dst; Tcl_Encoding encoding; /* * Set up the encoding state based on the format and whether * this is the first and/or last chunk. */ encodingCvtFlags = 0; if (incrPtr->converts[i].offset == 0) { encodingCvtFlags |= TCL_ENCODING_START; } if (numItems < TK_SEL_BYTES_AT_ONCE) { encodingCvtFlags |= TCL_ENCODING_END; } if (formatType == XA_STRING) { encoding = Tcl_GetEncoding(NULL, "iso8859-1"); } else if (dispPtr && formatType==dispPtr->utf8Atom) { encoding = Tcl_GetEncoding(NULL, "utf-8"); } else { encoding = Tcl_GetEncoding(NULL, "iso2022"); } /* * Now convert the data. */ src = (char *)buffer; srcLen = numItems; Tcl_DStringInit(&ds); dst = Tcl_DStringValue(&ds); dstLen = ds.spaceAvl - 1; /* * Now convert the data, growing the destination buffer as * needed. */ while (1) { result = Tcl_UtfToExternal(NULL, encoding, src, srcLen, encodingCvtFlags, &incrPtr->converts[i].state, dst, dstLen, &srcRead, &dstWrote, NULL); soFar = dst + dstWrote - Tcl_DStringValue(&ds); encodingCvtFlags &= ~TCL_ENCODING_START; src += srcRead; srcLen -= srcRead; if (result != TCL_CONVERT_NOSPACE) { Tcl_DStringSetLength(&ds, soFar); break; } if (Tcl_DStringLength(&ds) == 0) { Tcl_DStringSetLength(&ds, dstLen); } Tcl_DStringSetLength(&ds, 2 * Tcl_DStringLength(&ds) + 1); dst = Tcl_DStringValue(&ds) + soFar; dstLen = Tcl_DStringLength(&ds) - soFar - 1; } Tcl_DStringSetLength(&ds, soFar); if (encoding) { Tcl_FreeEncoding(encoding); } /* * Set the property to the encoded string value. */ XChangeProperty(eventPtr->xproperty.display, eventPtr->xproperty.window, eventPtr->xproperty.atom, formatType, 8, PropModeReplace, (unsigned char *) Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)); /* * Preserve any left-over bytes. */ if (srcLen > TCL_UTF_MAX) { Tcl_Panic("selection conversion left too many bytes unconverted"); } memcpy(incrPtr->converts[i].buffer, src, (size_t) srcLen+1); Tcl_DStringFree(&ds); } else { /* * Set the property to the encoded string value. */ char *propPtr = (char *) SelCvtToX((char *) buffer, formatType, (Tk_Window) incrPtr->winPtr, &numItems); if (propPtr == NULL) { numItems = 0; } XChangeProperty(eventPtr->xproperty.display, eventPtr->xproperty.window, eventPtr->xproperty.atom, formatType, 32, PropModeReplace, (unsigned char *) propPtr, numItems); if (propPtr != NULL) { ckfree(propPtr); } } Tk_DeleteErrorHandler(errorHandler); /* * Compute the next offset value. If this was the last chunk, then * set the offset to -2. If this was an empty chunk, then set the * offset to -1 to indicate we are done. */ if (numItems < TK_SEL_BYTES_AT_ONCE) { if (numItems <= 0) { incrPtr->converts[i].offset = -1; incrPtr->numIncrs--; } else { incrPtr->converts[i].offset = -2; } } else { /* * Advance over the selection data that was consumed this * time. */ incrPtr->converts[i].offset += numItems - length; } return; } } } /* *-------------------------------------------------------------- * * TkSelEventProc -- * * This function is invoked whenever a selection-related event occurs. * It does the lion's share of the work in implementing the selection * protocol. * * Results: * None. * * Side effects: * Lots: depends on the type of event. * *-------------------------------------------------------------- */ void TkSelEventProc( Tk_Window tkwin, /* Window for which event was targeted. */ register XEvent *eventPtr) /* X event: either SelectionClear, * SelectionRequest, or SelectionNotify. */ { register TkWindow *winPtr = (TkWindow *) tkwin; TkDisplay *dispPtr = winPtr->dispPtr; Tcl_Interp *interp; /* * Case #1: SelectionClear events. */ if (eventPtr->type == SelectionClear) { TkSelClearSelection(tkwin, eventPtr); } /* * Case #2: SelectionNotify events. Call the relevant function to handle * the incoming selection. */ if (eventPtr->type == SelectionNotify) { register TkSelRetrievalInfo *retrPtr; char *propInfo, **propInfoPtr = &propInfo; Atom type; int format, result; unsigned long numItems, bytesAfter; Tcl_DString ds; for (retrPtr = pendingRetrievals; ; retrPtr = retrPtr->nextPtr) { if (retrPtr == NULL) { return; } if ((retrPtr->winPtr == winPtr) && (retrPtr->selection == eventPtr->xselection.selection) && (retrPtr->target == eventPtr->xselection.target) && (retrPtr->result == -1)) { if (retrPtr->property == eventPtr->xselection.property) { break; } if (eventPtr->xselection.property == None) { Tcl_SetObjResult(retrPtr->interp, Tcl_ObjPrintf( "%s selection doesn't exist or form \"%s\" not defined", Tk_GetAtomName(tkwin, retrPtr->selection), Tk_GetAtomName(tkwin, retrPtr->target))); Tcl_SetErrorCode(retrPtr->interp, "TK", "SELECTION", "NONE", NULL); retrPtr->result = TCL_ERROR; return; } } } propInfo = NULL; result = XGetWindowProperty(eventPtr->xselection.display, eventPtr->xselection.requestor, retrPtr->property, 0, MAX_PROP_WORDS, False, (Atom) AnyPropertyType, &type, &format, &numItems, &bytesAfter, (unsigned char **) propInfoPtr); if ((result != Success) || (type == None)) { return; } if (bytesAfter != 0) { Tcl_SetObjResult(retrPtr->interp, Tcl_NewStringObj( "selection property too large", -1)); Tcl_SetErrorCode(retrPtr->interp, "TK", "SELECTION", "SIZE",NULL); retrPtr->result = TCL_ERROR; XFree(propInfo); return; } if ((type == XA_STRING) || (type == dispPtr->textAtom) || (type == dispPtr->compoundTextAtom)) { Tcl_Encoding encoding; if (format != 8) { Tcl_SetObjResult(retrPtr->interp, Tcl_ObjPrintf( "bad format for string selection: wanted \"8\", got \"%d\"", format)); Tcl_SetErrorCode(retrPtr->interp, "TK", "SELECTION", "FORMAT", NULL); retrPtr->result = TCL_ERROR; return; } interp = retrPtr->interp; Tcl_Preserve(interp); /* * Convert the X selection data into UTF before passing it to the * selection callback. Note that the COMPOUND_TEXT uses a modified * iso2022 encoding, not the current system encoding. For now * we'll just blindly apply the iso2022 encoding. This is probably * wrong, but it's a placeholder until we figure out what we're * really supposed to do. For STRING, we need to use Latin-1 * instead. Again, it's not really the full iso8859-1 space, but * this is close enough. */ if (type == dispPtr->compoundTextAtom) { encoding = Tcl_GetEncoding(NULL, "iso2022"); } else { encoding = Tcl_GetEncoding(NULL, "iso8859-1"); } Tcl_ExternalToUtfDString(encoding, propInfo, (int)numItems, &ds); if (encoding) { Tcl_FreeEncoding(encoding); } retrPtr->result = retrPtr->proc(retrPtr->clientData, interp, Tcl_DStringValue(&ds)); Tcl_DStringFree(&ds); Tcl_Release(interp); } else if (type == dispPtr->utf8Atom) { /* * The X selection data is in UTF-8 format already. We can't * guarantee that propInfo is NULL-terminated, so we might have to * copy the string. */ char *propData = propInfo; if (format != 8) { Tcl_SetObjResult(retrPtr->interp, Tcl_ObjPrintf( "bad format for string selection: wanted \"8\", got \"%d\"", format)); Tcl_SetErrorCode(retrPtr->interp, "TK", "SELECTION", "FORMAT", NULL); retrPtr->result = TCL_ERROR; return; } if (propInfo[numItems] != '\0') { propData = ckalloc(numItems + 1); strcpy(propData, propInfo); propData[numItems] = '\0'; } retrPtr->result = retrPtr->proc(retrPtr->clientData, retrPtr->interp, propData); if (propData != propInfo) { ckfree(propData); } } else if (type == dispPtr->incrAtom) { /* * It's a !?#@!?!! INCR-style reception. Arrange to receive the * selection in pieces, using the ICCCM protocol, then hang around * until either the selection is all here or a timeout occurs. */ retrPtr->idleTime = 0; Tk_CreateEventHandler(tkwin, PropertyChangeMask, SelRcvIncrProc, retrPtr); XDeleteProperty(Tk_Display(tkwin), Tk_WindowId(tkwin), retrPtr->property); while (retrPtr->result == -1) { Tcl_DoOneEvent(0); } Tk_DeleteEventHandler(tkwin, PropertyChangeMask, SelRcvIncrProc, retrPtr); } else { Tcl_DString ds; if (format != 32 && format != 8) { Tcl_SetObjResult(retrPtr->interp, Tcl_ObjPrintf( "bad format for selection: wanted \"32\" or " "\"8\", got \"%d\"", format)); Tcl_SetErrorCode(retrPtr->interp, "TK", "SELECTION", "FORMAT", NULL); retrPtr->result = TCL_ERROR; return; } Tcl_DStringInit(&ds); if (format == 32) { SelCvtFromX32((long *) propInfo, (int) numItems, type, (Tk_Window) winPtr, &ds); } else { SelCvtFromX8((char *) propInfo, (int) numItems, type, (Tk_Window) winPtr, &ds); } interp = retrPtr->interp; Tcl_Preserve(interp); retrPtr->result = retrPtr->proc(retrPtr->clientData, interp, Tcl_DStringValue(&ds)); Tcl_Release(interp); Tcl_DStringFree(&ds); } XFree(propInfo); return; } /* * Case #3: SelectionRequest events. Call ConvertSelection to do the dirty * work. */ if (eventPtr->type == SelectionRequest) { ConvertSelection(winPtr, &eventPtr->xselectionrequest); return; } } /* *---------------------------------------------------------------------- * * SelTimeoutProc -- * * This function is invoked once every second while waiting for the * selection to be returned. After a while it gives up and aborts the * selection retrieval. * * Results: * None. * * Side effects: * A new timer callback is created to call us again in another second, * unless time has expired, in which case an error is recorded for the * retrieval. * *---------------------------------------------------------------------- */ static void SelTimeoutProc( ClientData clientData) /* Information about retrieval in progress. */ { register TkSelRetrievalInfo *retrPtr = clientData; /* * Make sure that the retrieval is still in progress. Then see how long * it's been since any sort of response was received from the other side. */ if (retrPtr->result != -1) { return; } retrPtr->idleTime++; if (retrPtr->idleTime >= 5) { /* * Use a careful function to store the error message, because the * result could already be partially filled in with a partial * selection return. */ Tcl_SetObjResult(retrPtr->interp, Tcl_NewStringObj( "selection owner didn't respond", -1)); Tcl_SetErrorCode(retrPtr->interp, "TK", "SELECTION", "IGNORED", NULL); retrPtr->result = TCL_ERROR; } else { retrPtr->timeout = Tcl_CreateTimerHandler(1000, SelTimeoutProc, (ClientData) retrPtr); } } /* *---------------------------------------------------------------------- * * ConvertSelection -- * * This function is invoked to handle SelectionRequest events. It * responds to the requests, obeying the ICCCM protocols. * * Results: * None. * * Side effects: * Properties are created for the selection requestor, and a * SelectionNotify event is generated for the selection requestor. In the * event of long selections, this function implements INCR-mode * transfers, using the ICCCM protocol. * *---------------------------------------------------------------------- */ static void ConvertSelection( TkWindow *winPtr, /* Window that received the conversion * request; may not be selection's current * owner, be we set it to the current * owner. */ register XSelectionRequestEvent *eventPtr) /* Event describing request. */ { union { XSelectionEvent xsel; XEvent ev; } reply; /* Used to notify requestor that selection * info is ready. */ int multiple; /* Non-zero means a MULTIPLE request is being * handled. */ IncrInfo incr; /* State of selection conversion. */ Atom singleInfo[2]; /* incr.multAtoms points here except for * multiple conversions. */ unsigned long i; Tk_ErrorHandler errorHandler; TkSelectionInfo *infoPtr; TkSelInProgress ip; ThreadSpecificData *tsdPtr = Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); errorHandler = Tk_CreateErrorHandler(eventPtr->display, -1, -1,-1, (int (*)()) NULL, NULL); /* * Initialize the reply event. */ reply.xsel.type = SelectionNotify; reply.xsel.serial = 0; reply.xsel.send_event = True; reply.xsel.display = eventPtr->display; reply.xsel.requestor = eventPtr->requestor; reply.xsel.selection = eventPtr->selection; reply.xsel.target = eventPtr->target; reply.xsel.property = eventPtr->property; if (reply.xsel.property == None) { reply.xsel.property = reply.xsel.target; } reply.xsel.time = eventPtr->time; for (infoPtr = winPtr->dispPtr->selectionInfoPtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { if (infoPtr->selection == eventPtr->selection) { break; } } if (infoPtr == NULL) { goto refuse; } winPtr = (TkWindow *) infoPtr->owner; /* * Figure out which kind(s) of conversion to perform. If handling a * MULTIPLE conversion, then read the property describing which * conversions to perform. */ incr.winPtr = winPtr; incr.selection = eventPtr->selection; if (eventPtr->target != winPtr->dispPtr->multipleAtom) { multiple = 0; singleInfo[0] = reply.xsel.target; singleInfo[1] = reply.xsel.property; incr.multAtoms = singleInfo; incr.numConversions = 1; } else { Atom type, **multAtomsPtr = &incr.multAtoms; int format, result; unsigned long bytesAfter; multiple = 1; incr.multAtoms = NULL; if (eventPtr->property == None) { goto refuse; } result = XGetWindowProperty(eventPtr->display, eventPtr->requestor, eventPtr->property, 0, MAX_PROP_WORDS, False, XA_ATOM, &type, &format, &incr.numConversions, &bytesAfter, (unsigned char **) multAtomsPtr); if ((result != Success) || (bytesAfter != 0) || (format != 32) || (type == None)) { if (incr.multAtoms != NULL) { XFree((char *) incr.multAtoms); } goto refuse; } incr.numConversions /= 2; /* Two atoms per conversion. */ } /* * Loop through all of the requested conversions, and either return the * entire converted selection, if it can be returned in a single bunch, or * return INCR information only (the actual selection will be returned * below). */ incr.converts = ckalloc(incr.numConversions * sizeof(ConvertInfo)); incr.numIncrs = 0; for (i = 0; i < incr.numConversions; i++) { Atom target, property, type; long buffer[TK_SEL_WORDS_AT_ONCE]; register TkSelHandler *selPtr; int numItems, format; char *propPtr; target = incr.multAtoms[2*i]; property = incr.multAtoms[2*i + 1]; incr.converts[i].offset = -1; incr.converts[i].buffer[0] = '\0'; for (selPtr = winPtr->selHandlerList; selPtr != NULL; selPtr = selPtr->nextPtr) { if ((selPtr->target == target) && (selPtr->selection == eventPtr->selection)) { break; } } if (selPtr == NULL) { /* * Nobody seems to know about this kind of request. If it's of a * sort that we can handle without any help, do it. Otherwise mark * the request as an errror. */ numItems = TkSelDefaultSelection(infoPtr, target, (char *) buffer, TK_SEL_BYTES_AT_ONCE, &type); if (numItems < 0) { incr.multAtoms[2*i + 1] = None; continue; } } else { ip.selPtr = selPtr; ip.nextPtr = TkSelGetInProgress(); TkSelSetInProgress(&ip); type = selPtr->format; numItems = selPtr->proc(selPtr->clientData, 0, (char *) buffer, TK_SEL_BYTES_AT_ONCE); TkSelSetInProgress(ip.nextPtr); if ((ip.selPtr == NULL) || (numItems < 0)) { incr.multAtoms[2*i + 1] = None; continue; } if (numItems > TK_SEL_BYTES_AT_ONCE) { Tcl_Panic("selection handler returned too many bytes"); } ((char *) buffer)[numItems] = '\0'; } /* * Got the selection; store it back on the requestor's property. */ if (numItems == TK_SEL_BYTES_AT_ONCE) { /* * Selection is too big to send at once; start an INCR-mode * transfer. */ incr.numIncrs++; type = winPtr->dispPtr->incrAtom; buffer[0] = SelectionSize(selPtr); if (buffer[0] == 0) { incr.multAtoms[2*i + 1] = None; continue; } numItems = 1; propPtr = (char *) buffer; format = 32; incr.converts[i].offset = 0; XChangeProperty(reply.xsel.display, reply.xsel.requestor, property, type, format, PropModeReplace, (unsigned char *) propPtr, numItems); } else if (type == winPtr->dispPtr->utf8Atom) { /* * This matches selection requests of type UTF8_STRING, which * allows us to pass our utf-8 information untouched. */ XChangeProperty(reply.xsel.display, reply.xsel.requestor, property, type, 8, PropModeReplace, (unsigned char *) buffer, numItems); } else if ((type == XA_STRING) || (type == winPtr->dispPtr->compoundTextAtom)) { Tcl_DString ds; Tcl_Encoding encoding; /* * STRING is Latin-1, COMPOUND_TEXT is an iso2022 variant. We need * to convert the selection text into these external forms before * modifying the property. */ if (type == XA_STRING) { encoding = Tcl_GetEncoding(NULL, "iso8859-1"); } else { encoding = Tcl_GetEncoding(NULL, "iso2022"); } Tcl_UtfToExternalDString(encoding, (char *) buffer, -1, &ds); XChangeProperty(reply.xsel.display, reply.xsel.requestor, property, type, 8, PropModeReplace, (unsigned char *) Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)); if (encoding) { Tcl_FreeEncoding(encoding); } Tcl_DStringFree(&ds); } else { propPtr = (char *) SelCvtToX((char *) buffer, type, (Tk_Window) winPtr, &numItems); if (propPtr == NULL) { goto refuse; } format = 32; XChangeProperty(reply.xsel.display, reply.xsel.requestor, property, type, format, PropModeReplace, (unsigned char *) propPtr, numItems); ckfree(propPtr); } } /* * Send an event back to the requestor to indicate that the first stage of * conversion is complete (everything is done except for long conversions * that have to be done in INCR mode). */ if (incr.numIncrs > 0) { XSelectInput(reply.xsel.display, reply.xsel.requestor, PropertyChangeMask); incr.timeout = Tcl_CreateTimerHandler(1000, IncrTimeoutProc, &incr); incr.idleTime = 0; incr.reqWindow = reply.xsel.requestor; incr.time = infoPtr->time; incr.nextPtr = tsdPtr->pendingIncrs; tsdPtr->pendingIncrs = &incr; } if (multiple) { XChangeProperty(reply.xsel.display, reply.xsel.requestor, reply.xsel.property, XA_ATOM, 32, PropModeReplace, (unsigned char *) incr.multAtoms, (int) incr.numConversions*2); } else { /* * Not a MULTIPLE request. The first property in "multAtoms" got set * to None if there was an error in conversion. */ reply.xsel.property = incr.multAtoms[1]; } XSendEvent(reply.xsel.display, reply.xsel.requestor, False, 0, &reply.ev); Tk_DeleteErrorHandler(errorHandler); /* * Handle any remaining INCR-mode transfers. This all happens in callbacks * to TkSelPropProc, so just wait until the number of uncompleted INCR * transfers drops to zero. */ if (incr.numIncrs > 0) { IncrInfo *incrPtr2; while (incr.numIncrs > 0) { Tcl_DoOneEvent(0); } Tcl_DeleteTimerHandler(incr.timeout); errorHandler = Tk_CreateErrorHandler(winPtr->display, -1, -1, -1, (int (*)()) NULL, NULL); XSelectInput(reply.xsel.display, reply.xsel.requestor, 0L); Tk_DeleteErrorHandler(errorHandler); if (tsdPtr->pendingIncrs == &incr) { tsdPtr->pendingIncrs = incr.nextPtr; } else { for (incrPtr2 = tsdPtr->pendingIncrs; incrPtr2 != NULL; incrPtr2 = incrPtr2->nextPtr) { if (incrPtr2->nextPtr == &incr) { incrPtr2->nextPtr = incr.nextPtr; break; } } } } /* * All done. Cleanup and return. */ ckfree(incr.converts); if (multiple) { XFree((char *) incr.multAtoms); } return; /* * An error occurred. Send back a refusal message. */ refuse: reply.xsel.property = None; XSendEvent(reply.xsel.display, reply.xsel.requestor, False, 0, &reply.ev); Tk_DeleteErrorHandler(errorHandler); return; } /* *---------------------------------------------------------------------- * * SelRcvIncrProc -- * * This function handles the INCR protocol on the receiving side. It is * invoked in response to property changes on the requestor's window * (which hopefully are because a new chunk of the selection arrived). * * Results: * None. * * Side effects: * If a new piece of selection has arrived, a function is invoked to deal * with that piece. When the whole selection is here, a flag is left for * the higher-level function that initiated the selection retrieval. * *---------------------------------------------------------------------- */ static void SelRcvIncrProc( ClientData clientData, /* Information about retrieval. */ register XEvent *eventPtr) /* X PropertyChange event. */ { register TkSelRetrievalInfo *retrPtr = clientData; char *propInfo, **propInfoPtr = &propInfo; Atom type; int format, result; unsigned long numItems, bytesAfter; Tcl_Interp *interp; if ((eventPtr->xproperty.atom != retrPtr->property) || (eventPtr->xproperty.state != PropertyNewValue) || (retrPtr->result != -1)) { return; } propInfo = NULL; result = XGetWindowProperty(eventPtr->xproperty.display, eventPtr->xproperty.window, retrPtr->property, 0, MAX_PROP_WORDS, True, (Atom) AnyPropertyType, &type, &format, &numItems, &bytesAfter, (unsigned char **) propInfoPtr); if ((result != Success) || (type == None)) { return; } if (bytesAfter != 0) { Tcl_SetObjResult(retrPtr->interp, Tcl_NewStringObj( "selection property too large", -1)); Tcl_SetErrorCode(retrPtr->interp, "TK", "SELECTION", "SIZE", NULL); retrPtr->result = TCL_ERROR; goto done; } if ((type == XA_STRING) || (type == retrPtr->winPtr->dispPtr->textAtom) || (type == retrPtr->winPtr->dispPtr->utf8Atom) || (type == retrPtr->winPtr->dispPtr->compoundTextAtom)) { char *dst, *src; int srcLen, dstLen, srcRead, dstWrote, soFar; Tcl_Encoding encoding; Tcl_DString *dstPtr, temp; if (format != 8) { Tcl_SetObjResult(retrPtr->interp, Tcl_ObjPrintf( "bad format for string selection: wanted \"8\", got \"%d\"", format)); Tcl_SetErrorCode(retrPtr->interp, "TK", "SELECTION", "FORMAT", NULL); retrPtr->result = TCL_ERROR; goto done; } interp = retrPtr->interp; Tcl_Preserve(interp); if (type == retrPtr->winPtr->dispPtr->compoundTextAtom) { encoding = Tcl_GetEncoding(NULL, "iso2022"); } else if (type == retrPtr->winPtr->dispPtr->utf8Atom) { encoding = Tcl_GetEncoding(NULL, "utf-8"); } else { encoding = Tcl_GetEncoding(NULL, "iso8859-1"); } /* * Check to see if there is any data left over from the previous * chunk. If there is, copy the old data and the new data into a new * buffer. */ Tcl_DStringInit(&temp); if (Tcl_DStringLength(&retrPtr->buf) > 0) { Tcl_DStringAppend(&temp, Tcl_DStringValue(&retrPtr->buf), Tcl_DStringLength(&retrPtr->buf)); if (numItems > 0) { Tcl_DStringAppend(&temp, propInfo, (int)numItems); } src = Tcl_DStringValue(&temp); srcLen = Tcl_DStringLength(&temp); } else if (numItems == 0) { /* * There is no new data, so we're done. */ retrPtr->result = TCL_OK; Tcl_Release(interp); goto done; } else { src = propInfo; srcLen = numItems; } /* * Set up the destination buffer so we can use as much space as is * available. */ dstPtr = &retrPtr->buf; dst = Tcl_DStringValue(dstPtr); dstLen = dstPtr->spaceAvl - 1; /* * Now convert the data, growing the destination buffer as needed. */ while (1) { result = Tcl_ExternalToUtf(NULL, encoding, src, srcLen, retrPtr->encFlags, &retrPtr->encState, dst, dstLen, &srcRead, &dstWrote, NULL); soFar = dst + dstWrote - Tcl_DStringValue(dstPtr); retrPtr->encFlags &= ~TCL_ENCODING_START; src += srcRead; srcLen -= srcRead; if (result != TCL_CONVERT_NOSPACE) { Tcl_DStringSetLength(dstPtr, soFar); break; } if (Tcl_DStringLength(dstPtr) == 0) { Tcl_DStringSetLength(dstPtr, dstLen); } Tcl_DStringSetLength(dstPtr, 2 * Tcl_DStringLength(dstPtr) + 1); dst = Tcl_DStringValue(dstPtr) + soFar; dstLen = Tcl_DStringLength(dstPtr) - soFar - 1; } Tcl_DStringSetLength(dstPtr, soFar); result = retrPtr->proc(retrPtr->clientData, interp, Tcl_DStringValue(dstPtr)); Tcl_Release(interp); /* * Copy any unused data into the destination buffer so we can pick it * up next time around. */ Tcl_DStringSetLength(dstPtr, 0); Tcl_DStringAppend(dstPtr, src, srcLen); Tcl_DStringFree(&temp); if (encoding) { Tcl_FreeEncoding(encoding); } if (result != TCL_OK) { retrPtr->result = result; } } else if (numItems == 0) { retrPtr->result = TCL_OK; } else { Tcl_DString ds; if (format != 32 && format != 8) { Tcl_SetObjResult(retrPtr->interp, Tcl_ObjPrintf( "bad format for selection: wanted \"32\" or " "\"8\", got \"%d\"", format)); Tcl_SetErrorCode(retrPtr->interp, "TK", "SELECTION", "FORMAT", NULL); retrPtr->result = TCL_ERROR; goto done; } Tcl_DStringInit(&ds); if (format == 32) { SelCvtFromX32((long *) propInfo, (int) numItems, type, (Tk_Window) retrPtr->winPtr, &ds); } else { SelCvtFromX8((char *) propInfo, (int) numItems, type, (Tk_Window) retrPtr->winPtr, &ds); } interp = retrPtr->interp; Tcl_Preserve(interp); result = retrPtr->proc(retrPtr->clientData, interp, Tcl_DStringValue(&ds)); Tcl_Release(interp); Tcl_DStringFree(&ds); if (result != TCL_OK) { retrPtr->result = result; } } done: XFree(propInfo); retrPtr->idleTime = 0; } /* *---------------------------------------------------------------------- * * SelectionSize -- * * This function is called when the selection is too large to send in a * single buffer; it computes the total length of the selection in bytes. * * Results: * The return value is the number of bytes in the selection given by * selPtr. * * Side effects: * The selection is retrieved from its current owner (this is the only * way to compute its size). * *---------------------------------------------------------------------- */ static int SelectionSize( TkSelHandler *selPtr) /* Information about how to retrieve the * selection whose size is wanted. */ { char buffer[TK_SEL_BYTES_AT_ONCE+1]; int size, chunkSize; TkSelInProgress ip; size = TK_SEL_BYTES_AT_ONCE; ip.selPtr = selPtr; ip.nextPtr = TkSelGetInProgress(); TkSelSetInProgress(&ip); do { chunkSize = selPtr->proc(selPtr->clientData, size, (char *) buffer, TK_SEL_BYTES_AT_ONCE); if (ip.selPtr == NULL) { size = 0; break; } size += chunkSize; } while (chunkSize == TK_SEL_BYTES_AT_ONCE); TkSelSetInProgress(ip.nextPtr); return size; } /* *---------------------------------------------------------------------- * * IncrTimeoutProc -- * * This function is invoked once a second while sending the selection to * a requestor in INCR mode. After a while it gives up and aborts the * selection operation. * * Results: * None. * * Side effects: * A new timeout gets registered so that this function gets called again * in another second, unless too many seconds have elapsed, in which case * incrPtr is marked as "all done". * *---------------------------------------------------------------------- */ static void IncrTimeoutProc( ClientData clientData) /* Information about INCR-mode selection * retrieval for which we are selection * owner. */ { register IncrInfo *incrPtr = clientData; incrPtr->idleTime++; if (incrPtr->idleTime >= 5) { incrPtr->numIncrs = 0; } else { incrPtr->timeout = Tcl_CreateTimerHandler(1000, IncrTimeoutProc, incrPtr); } } /* *---------------------------------------------------------------------- * * SelCvtToX -- * * Given a selection represented as a string (the normal Tcl form), * convert it to the ICCCM-mandated format for X, depending on the type * argument. This function and SelCvtFromX are inverses. * * Results: * The return value is a malloc'ed buffer holding a value equivalent to * "string", but formatted as for "type". It is the caller's * responsibility to free the string when done with it. The word at * *numLongsPtr is filled in with the number of 32-bit words returned in * the result. If NULL is returned, the input list was not actually a * list. * * Side effects: * None. * *---------------------------------------------------------------------- */ static long * SelCvtToX( char *string, /* String representation of selection. */ Atom type, /* Atom specifying the X format that is * desired for the selection. Should not be * XA_STRING (if so, don't bother calling this * function at all). */ Tk_Window tkwin, /* Window that governs atom conversion. */ int *numLongsPtr) /* Number of 32-bit words contained in the * result. */ { const char **field; int numFields, i; long *propPtr; /* * The string is assumed to consist of fields separated by spaces. The * property gets generated by converting each field to an integer number, * in one of two ways: * 1. If type is XA_ATOM, convert each field to its corresponding atom. * 2. If type is anything else, convert each field from an ASCII number to * a 32-bit binary number. */ if (Tcl_SplitList(NULL, string, &numFields, &field) != TCL_OK) { return NULL; } propPtr = ckalloc(numFields * sizeof(long)); /* * Convert the fields one-by-one. */ for (i=0 ; i 0; propPtr++, numValues--) { if (type == XA_ATOM) { Tcl_DStringAppendElement(dsPtr, Tk_GetAtomName(tkwin, (Atom) *propPtr)); } else { char buf[12]; sprintf(buf, "0x%x", (unsigned int) *propPtr); Tcl_DStringAppendElement(dsPtr, buf); } } Tcl_DStringAppend(dsPtr, " ", 1); } static void SelCvtFromX8( register char *propPtr, /* Property value from X. */ int numValues, /* Number of 8-bit values in property. */ Atom type, /* Type of property Should not be XA_STRING * (if so, don't bother calling this function * at all). */ Tk_Window tkwin, /* Window to use for atom conversion. */ Tcl_DString *dsPtr) /* Where to store the converted string. */ { /* * Convert each long in the property to a string value, which is a * hexadecimal string. We build the list in a Tcl_DString because this is * easier than trying to get the quoting correct ourselves. */ for ( ; numValues > 0; propPtr++, numValues--) { char buf[12]; sprintf(buf, "0x%x", (unsigned char) *propPtr); Tcl_DStringAppendElement(dsPtr, buf); } Tcl_DStringAppend(dsPtr, " ", 1); } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ tk8.6.5/unix/install-sh0000755003604700454610000003305412665114121013461 0ustar dgp771div#!/bin/sh # install - install a program, script, or datafile scriptversion=2011-04-20.01; # UTC # This originates from X11R5 (mit/util/scripts/install.sh), which was # later released in X11R6 (xc/config/util/install.sh) with the # following copyright and license. # # Copyright (C) 1994 X Consortium # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # X CONSORTIUM BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN # AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNEC- # TION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. # # Except as contained in this notice, the name of the X Consortium shall not # be used in advertising or otherwise to promote the sale, use or other deal- # ings in this Software without prior written authorization from the X Consor- # tium. # # # FSF changes to this file are in the public domain. # # Calling this script install-sh is preferred over install.sh, to prevent # `make' implicit rules from creating a file called install from it # when there is no Makefile. # # This script is compatible with the BSD install script, but was written # from scratch. nl=' ' IFS=" "" $nl" # set DOITPROG to echo to test this script # Don't use :- since 4.3BSD and earlier shells don't like it. doit=${DOITPROG-} if test -z "$doit"; then doit_exec=exec else doit_exec=$doit fi # Put in absolute file names if you don't have them in your path; # or use environment vars. chgrpprog=${CHGRPPROG-chgrp} chmodprog=${CHMODPROG-chmod} chownprog=${CHOWNPROG-chown} cmpprog=${CMPPROG-cmp} cpprog=${CPPROG-cp} mkdirprog=${MKDIRPROG-mkdir} mvprog=${MVPROG-mv} rmprog=${RMPROG-rm} stripprog=${STRIPPROG-strip} posix_glob='?' initialize_posix_glob=' test "$posix_glob" != "?" || { if (set -f) 2>/dev/null; then posix_glob= else posix_glob=: fi } ' posix_mkdir= # Desired mode of installed file. mode=0755 chgrpcmd= chmodcmd=$chmodprog chowncmd= mvcmd=$mvprog rmcmd="$rmprog -f" stripcmd= src= dst= dir_arg= dst_arg= copy_on_change=false no_target_directory= usage="\ Usage: $0 [OPTION]... [-T] SRCFILE DSTFILE or: $0 [OPTION]... SRCFILES... DIRECTORY or: $0 [OPTION]... -t DIRECTORY SRCFILES... or: $0 [OPTION]... -d DIRECTORIES... In the 1st form, copy SRCFILE to DSTFILE. In the 2nd and 3rd, copy all SRCFILES to DIRECTORY. In the 4th, create DIRECTORIES. Options: --help display this help and exit. --version display version info and exit. -c (ignored) -C install only if different (preserve the last data modification time) -d create directories instead of installing files. -g GROUP $chgrpprog installed files to GROUP. -m MODE $chmodprog installed files to MODE. -o USER $chownprog installed files to USER. -s $stripprog installed files. -S $stripprog installed files. -t DIRECTORY install into DIRECTORY. -T report an error if DSTFILE is a directory. Environment variables override the default commands: CHGRPPROG CHMODPROG CHOWNPROG CMPPROG CPPROG MKDIRPROG MVPROG RMPROG STRIPPROG " while test $# -ne 0; do case $1 in -c) ;; -C) copy_on_change=true;; -d) dir_arg=true;; -g) chgrpcmd="$chgrpprog $2" shift;; --help) echo "$usage"; exit $?;; -m) mode=$2 case $mode in *' '* | *' '* | *' '* | *'*'* | *'?'* | *'['*) echo "$0: invalid mode: $mode" >&2 exit 1;; esac shift;; -o) chowncmd="$chownprog $2" shift;; -s) stripcmd=$stripprog;; -S) stripcmd="$stripprog $2" shift;; -t) dst_arg=$2 shift;; -T) no_target_directory=true;; --version) echo "$0 $scriptversion"; exit $?;; --) shift break;; -*) echo "$0: invalid option: $1" >&2 exit 1;; *) break;; esac shift done if test $# -ne 0 && test -z "$dir_arg$dst_arg"; then # When -d is used, all remaining arguments are directories to create. # When -t is used, the destination is already specified. # Otherwise, the last argument is the destination. Remove it from $@. for arg do if test -n "$dst_arg"; then # $@ is not empty: it contains at least $arg. set fnord "$@" "$dst_arg" shift # fnord fi shift # arg dst_arg=$arg done fi if test $# -eq 0; then if test -z "$dir_arg"; then echo "$0: no input file specified." >&2 exit 1 fi # It's OK to call `install-sh -d' without argument. # This can happen when creating conditional directories. exit 0 fi if test -z "$dir_arg"; then do_exit='(exit $ret); exit $ret' trap "ret=129; $do_exit" 1 trap "ret=130; $do_exit" 2 trap "ret=141; $do_exit" 13 trap "ret=143; $do_exit" 15 # Set umask so as not to create temps with too-generous modes. # However, 'strip' requires both read and write access to temps. case $mode in # Optimize common cases. *644) cp_umask=133;; *755) cp_umask=22;; *[0-7]) if test -z "$stripcmd"; then u_plus_rw= else u_plus_rw='% 200' fi cp_umask=`expr '(' 777 - $mode % 1000 ')' $u_plus_rw`;; *) if test -z "$stripcmd"; then u_plus_rw= else u_plus_rw=,u+rw fi cp_umask=$mode$u_plus_rw;; esac fi for src do # Protect names starting with `-'. case $src in -*) src=./$src;; esac if test -n "$dir_arg"; then dst=$src dstdir=$dst test -d "$dstdir" dstdir_status=$? else # Waiting for this to be detected by the "$cpprog $src $dsttmp" command # might cause directories to be created, which would be especially bad # if $src (and thus $dsttmp) contains '*'. if test ! -f "$src" && test ! -d "$src"; then echo "$0: $src does not exist." >&2 exit 1 fi if test -z "$dst_arg"; then echo "$0: no destination specified." >&2 exit 1 fi dst=$dst_arg # Protect names starting with `-'. case $dst in -*) dst=./$dst;; esac # If destination is a directory, append the input filename; won't work # if double slashes aren't ignored. if test -d "$dst"; then if test -n "$no_target_directory"; then echo "$0: $dst_arg: Is a directory" >&2 exit 1 fi dstdir=$dst dst=$dstdir/`basename "$src"` dstdir_status=0 else # Prefer dirname, but fall back on a substitute if dirname fails. dstdir=` (dirname "$dst") 2>/dev/null || expr X"$dst" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$dst" : 'X\(//\)[^/]' \| \ X"$dst" : 'X\(//\)$' \| \ X"$dst" : 'X\(/\)' \| . 2>/dev/null || echo X"$dst" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q' ` test -d "$dstdir" dstdir_status=$? fi fi obsolete_mkdir_used=false if test $dstdir_status != 0; then case $posix_mkdir in '') # Create intermediate dirs using mode 755 as modified by the umask. # This is like FreeBSD 'install' as of 1997-10-28. umask=`umask` case $stripcmd.$umask in # Optimize common cases. *[2367][2367]) mkdir_umask=$umask;; .*0[02][02] | .[02][02] | .[02]) mkdir_umask=22;; *[0-7]) mkdir_umask=`expr $umask + 22 \ - $umask % 100 % 40 + $umask % 20 \ - $umask % 10 % 4 + $umask % 2 `;; *) mkdir_umask=$umask,go-w;; esac # With -d, create the new directory with the user-specified mode. # Otherwise, rely on $mkdir_umask. if test -n "$dir_arg"; then mkdir_mode=-m$mode else mkdir_mode= fi posix_mkdir=false case $umask in *[123567][0-7][0-7]) # POSIX mkdir -p sets u+wx bits regardless of umask, which # is incompatible with FreeBSD 'install' when (umask & 300) != 0. ;; *) tmpdir=${TMPDIR-/tmp}/ins$RANDOM-$$ trap 'ret=$?; rmdir "$tmpdir/d" "$tmpdir" 2>/dev/null; exit $ret' 0 if (umask $mkdir_umask && exec $mkdirprog $mkdir_mode -p -- "$tmpdir/d") >/dev/null 2>&1 then if test -z "$dir_arg" || { # Check for POSIX incompatibilities with -m. # HP-UX 11.23 and IRIX 6.5 mkdir -m -p sets group- or # other-writeable bit of parent directory when it shouldn't. # FreeBSD 6.1 mkdir -m -p sets mode of existing directory. ls_ld_tmpdir=`ls -ld "$tmpdir"` case $ls_ld_tmpdir in d????-?r-*) different_mode=700;; d????-?--*) different_mode=755;; *) false;; esac && $mkdirprog -m$different_mode -p -- "$tmpdir" && { ls_ld_tmpdir_1=`ls -ld "$tmpdir"` test "$ls_ld_tmpdir" = "$ls_ld_tmpdir_1" } } then posix_mkdir=: fi rmdir "$tmpdir/d" "$tmpdir" else # Remove any dirs left behind by ancient mkdir implementations. rmdir ./$mkdir_mode ./-p ./-- 2>/dev/null fi trap '' 0;; esac;; esac if $posix_mkdir && ( umask $mkdir_umask && $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir" ) then : else # The umask is ridiculous, or mkdir does not conform to POSIX, # or it failed possibly due to a race condition. Create the # directory the slow way, step by step, checking for races as we go. case $dstdir in /*) prefix='/';; -*) prefix='./';; *) prefix='';; esac eval "$initialize_posix_glob" oIFS=$IFS IFS=/ $posix_glob set -f set fnord $dstdir shift $posix_glob set +f IFS=$oIFS prefixes= for d do test -z "$d" && continue prefix=$prefix$d if test -d "$prefix"; then prefixes= else if $posix_mkdir; then (umask=$mkdir_umask && $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir") && break # Don't fail if two instances are running concurrently. test -d "$prefix" || exit 1 else case $prefix in *\'*) qprefix=`echo "$prefix" | sed "s/'/'\\\\\\\\''/g"`;; *) qprefix=$prefix;; esac prefixes="$prefixes '$qprefix'" fi fi prefix=$prefix/ done if test -n "$prefixes"; then # Don't fail if two instances are running concurrently. (umask $mkdir_umask && eval "\$doit_exec \$mkdirprog $prefixes") || test -d "$dstdir" || exit 1 obsolete_mkdir_used=true fi fi fi if test -n "$dir_arg"; then { test -z "$chowncmd" || $doit $chowncmd "$dst"; } && { test -z "$chgrpcmd" || $doit $chgrpcmd "$dst"; } && { test "$obsolete_mkdir_used$chowncmd$chgrpcmd" = false || test -z "$chmodcmd" || $doit $chmodcmd $mode "$dst"; } || exit 1 else # Make a couple of temp file names in the proper directory. dsttmp=$dstdir/_inst.$$_ rmtmp=$dstdir/_rm.$$_ # Trap to clean up those temp files at exit. trap 'ret=$?; rm -f "$dsttmp" "$rmtmp" && exit $ret' 0 # Copy the file name to the temp name. (umask $cp_umask && $doit_exec $cpprog "$src" "$dsttmp") && # and set any options; do chmod last to preserve setuid bits. # # If any of these fail, we abort the whole thing. If we want to # ignore errors from any of these, just make sure not to ignore # errors from the above "$doit $cpprog $src $dsttmp" command. # { test -z "$chowncmd" || $doit $chowncmd "$dsttmp"; } && { test -z "$chgrpcmd" || $doit $chgrpcmd "$dsttmp"; } && { test -z "$stripcmd" || $doit $stripcmd "$dsttmp"; } && { test -z "$chmodcmd" || $doit $chmodcmd $mode "$dsttmp"; } && # If -C, don't bother to copy if it wouldn't change the file. if $copy_on_change && old=`LC_ALL=C ls -dlL "$dst" 2>/dev/null` && new=`LC_ALL=C ls -dlL "$dsttmp" 2>/dev/null` && eval "$initialize_posix_glob" && $posix_glob set -f && set X $old && old=:$2:$4:$5:$6 && set X $new && new=:$2:$4:$5:$6 && $posix_glob set +f && test "$old" = "$new" && $cmpprog "$dst" "$dsttmp" >/dev/null 2>&1 then rm -f "$dsttmp" else # Rename the file to the real destination. $doit $mvcmd -f "$dsttmp" "$dst" 2>/dev/null || # The rename failed, perhaps because mv can't rename something else # to itself, or perhaps because mv is so ancient that it does not # support -f. { # Now remove or move aside any old file at destination location. # We try this two ways since rm can't unlink itself on some # systems and the destination file might be busy for other # reasons. In this case, the final cleanup might fail but the new # file should still install successfully. { test ! -f "$dst" || $doit $rmcmd -f "$dst" 2>/dev/null || { $doit $mvcmd -f "$dst" "$rmtmp" 2>/dev/null && { $doit $rmcmd -f "$rmtmp" 2>/dev/null; :; } } || { echo "$0: cannot unlink or rename $dst" >&2 (exit 1); exit 1 } } && # Now rename the file to the real destination. $doit $mvcmd "$dsttmp" "$dst" } fi || exit 1 trap '' 0 fi done # Local variables: # eval: (add-hook 'write-file-hooks 'time-stamp) # time-stamp-start: "scriptversion=" # time-stamp-format: "%:y-%02m-%02d.%02H" # time-stamp-time-zone: "UTC" # time-stamp-end: "; # UTC" # End: tk8.6.5/unix/tkUnixEvent.c0000644003604700454610000004676112377375532014135 0ustar dgp771div/* * tkUnixEvent.c -- * * This file implements an event source for X displays for the UNIX * version of Tk. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tkUnixInt.h" #include #ifdef HAVE_XKBKEYCODETOKEYSYM # include #else # define XkbOpenDisplay(D,V,E,M,m,R) ((V),(E),(M),(m),(R),(NULL)) #endif /* * The following static indicates whether this module has been initialized in * the current thread. */ typedef struct ThreadSpecificData { int initialized; } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; /* * Prototypes for functions that are referenced only in this file: */ static void DisplayCheckProc(ClientData clientData, int flags); static void DisplayExitHandler(ClientData clientData); static void DisplayFileProc(ClientData clientData, int flags); static void DisplaySetupProc(ClientData clientData, int flags); static void TransferXEventsToTcl(Display *display); #ifdef TK_USE_INPUT_METHODS static void OpenIM(TkDisplay *dispPtr); #endif /* *---------------------------------------------------------------------- * * TkCreateXEventSource -- * * This function is called during Tk initialization to create the event * source for X Window events. * * Results: * None. * * Side effects: * A new event source is created. * *---------------------------------------------------------------------- */ void TkCreateXEventSource(void) { ThreadSpecificData *tsdPtr = (ThreadSpecificData *) Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); if (!tsdPtr->initialized) { tsdPtr->initialized = 1; Tcl_CreateEventSource(DisplaySetupProc, DisplayCheckProc, NULL); TkCreateExitHandler(DisplayExitHandler, NULL); } } /* *---------------------------------------------------------------------- * * DisplayExitHandler -- * * This function is called during finalization to clean up the display * module. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ static void DisplayExitHandler( ClientData clientData) /* Not used. */ { ThreadSpecificData *tsdPtr = (ThreadSpecificData *) Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); Tcl_DeleteEventSource(DisplaySetupProc, DisplayCheckProc, NULL); tsdPtr->initialized = 0; } /* *---------------------------------------------------------------------- * * TkpOpenDisplay -- * * Allocates a new TkDisplay, opens the X display, and establishes the * file handler for the connection. * * Results: * A pointer to a Tk display structure. * * Side effects: * Opens a display. * *---------------------------------------------------------------------- */ TkDisplay * TkpOpenDisplay( const char *displayNameStr) { TkDisplay *dispPtr; Display *display; int event = 0; int error = 0; int major = 1; int minor = 0; int reason = 0; unsigned int use_xkb = 0; /* Disabled, until we have a better test. See [Bug 3613668] */ #if 0 && defined(XKEYCODETOKEYSYM_IS_DEPRECATED) && defined(TCL_THREADS) static int xinited = 0; static Tcl_Mutex xinitMutex = NULL; if (!xinited) { Tcl_MutexLock(&xinitMutex); if (!xinited) { /* Necessary for threaded apps, of no consequence otherwise */ /* need only be called once, but must be called before *any* */ /* Xlib call is made. If xinitMutex is still NULL after the */ /* Tcl_MutexLock call, Tcl was compiled without threads so */ /* we cannot use XInitThreads() either. */ if (xinitMutex != NULL){ XInitThreads(); } xinited = 1; } Tcl_MutexUnlock(&xinitMutex); } #endif /* ** Bug [3607830]: Before using Xkb, it must be initialized and confirmed ** that the serve supports it. The XkbOpenDisplay call ** will perform this check and return NULL if the extension ** is not supported. ** ** Work around un-const-ified Xkb headers using (char *) cast. */ display = XkbOpenDisplay((char *)displayNameStr, &event, &error, &major, &minor, &reason); if (display == NULL) { /*fprintf(stderr,"event=%d error=%d major=%d minor=%d reason=%d\nDisabling xkb\n", event, error, major, minor, reason);*/ display = XOpenDisplay(displayNameStr); } else { use_xkb = TK_DISPLAY_USE_XKB; /*fprintf(stderr, "Using xkb %d.%d\n", major, minor);*/ } if (display == NULL) { return NULL; } dispPtr = ckalloc(sizeof(TkDisplay)); memset(dispPtr, 0, sizeof(TkDisplay)); dispPtr->display = display; dispPtr->flags |= use_xkb; #ifdef TK_USE_INPUT_METHODS OpenIM(dispPtr); #endif Tcl_CreateFileHandler(ConnectionNumber(display), TCL_READABLE, DisplayFileProc, dispPtr); return dispPtr; } /* *---------------------------------------------------------------------- * * TkpCloseDisplay -- * * Cancels notifier callbacks and closes a display. * * Results: * None. * * Side effects: * Deallocates the displayPtr and unix-specific resources. * *---------------------------------------------------------------------- */ void TkpCloseDisplay( TkDisplay *dispPtr) { TkSendCleanup(dispPtr); TkWmCleanup(dispPtr); #ifdef TK_USE_INPUT_METHODS if (dispPtr->inputXfs) { XFreeFontSet(dispPtr->display, dispPtr->inputXfs); } if (dispPtr->inputMethod) { XCloseIM(dispPtr->inputMethod); } #endif if (dispPtr->display != 0) { Tcl_DeleteFileHandler(ConnectionNumber(dispPtr->display)); (void) XSync(dispPtr->display, False); (void) XCloseDisplay(dispPtr->display); } } /* *---------------------------------------------------------------------- * * TkClipCleanup -- * * This function is called to cleanup resources associated with claiming * clipboard ownership and for receiving selection get results. This * function is called in tkWindow.c. This has to be called by the display * cleanup function because we still need the access display elements. * * Results: * None. * * Side effects: * Resources are freed - the clipboard may no longer be used. * *---------------------------------------------------------------------- */ void TkClipCleanup( TkDisplay *dispPtr) /* Display associated with clipboard */ { if (dispPtr->clipWindow != NULL) { Tk_DeleteSelHandler(dispPtr->clipWindow, dispPtr->clipboardAtom, dispPtr->applicationAtom); Tk_DeleteSelHandler(dispPtr->clipWindow, dispPtr->clipboardAtom, dispPtr->windowAtom); Tk_DestroyWindow(dispPtr->clipWindow); Tcl_Release(dispPtr->clipWindow); dispPtr->clipWindow = NULL; } } /* *---------------------------------------------------------------------- * * DisplaySetupProc -- * * This function implements the setup part of the UNIX X display event * source. It is invoked by Tcl_DoOneEvent before entering the notifier * to check for events on all displays. * * Results: * None. * * Side effects: * If data is queued on a display inside Xlib, then the maximum block * time will be set to 0 to ensure that the notifier returns control to * Tcl even if there is no more data on the X connection. * *---------------------------------------------------------------------- */ static void DisplaySetupProc( ClientData clientData, /* Not used. */ int flags) { TkDisplay *dispPtr; static Tcl_Time blockTime = { 0, 0 }; if (!(flags & TCL_WINDOW_EVENTS)) { return; } for (dispPtr = TkGetDisplayList(); dispPtr != NULL; dispPtr = dispPtr->nextPtr) { /* * Flush the display. If data is pending on the X queue, set the block * time to zero. This ensures that we won't block in the notifier if * there is data in the X queue, but not on the server socket. */ XFlush(dispPtr->display); if (QLength(dispPtr->display) > 0) { Tcl_SetMaxBlockTime(&blockTime); } } } /* *---------------------------------------------------------------------- * * TransferXEventsToTcl -- * * Transfer events from the X event queue to the Tk event queue. * * Results: * None. * * Side effects: * Moves queued X events onto the Tcl event queue. * *---------------------------------------------------------------------- */ static void TransferXEventsToTcl( Display *display) { union { int type; XEvent x; TkKeyEvent k; #ifdef GenericEvent xGenericEvent xge; #endif } event; Window w; TkDisplay *dispPtr = NULL; /* * Transfer events from the X event queue to the Tk event queue after XIM * event filtering. KeyPress and KeyRelease events need special treatment * so that they get directed according to Tk's focus rules during XIM * handling. Theoretically they can go to the wrong place still (if * there's a focus change in the queue) but if we push the handling off * until Tk_HandleEvent then many input methods actually cease to work * correctly. Most of the time, Tk processes its event queue fast enough * for this to not be an issue anyway. [Bug 1924761] */ while (QLength(display) > 0) { XNextEvent(display, &event.x); #ifdef GenericEvent if (event.type == GenericEvent) { Tcl_Panic("Wild GenericEvent; panic! (extension=%d,evtype=%d)", event.xge.extension, event.xge.evtype); } #endif w = None; if (event.type == KeyPress || event.type == KeyRelease) { for (dispPtr = TkGetDisplayList(); ; dispPtr = dispPtr->nextPtr) { if (dispPtr == NULL) { break; } else if (dispPtr->display == event.x.xany.display) { if (dispPtr->focusPtr != NULL) { w = dispPtr->focusPtr->window; } break; } } } if (XFilterEvent(&event.x, w)) { continue; } if (event.type == KeyPress || event.type == KeyRelease) { event.k.charValuePtr = NULL; event.k.charValueLen = 0; event.k.keysym = NoSymbol; /* * Force the calling of the input method engine now. The results * from it will be cached in the event so that they don't get lost * (to a race condition with other XIM-handled key events) between * entering the event queue and getting serviced. [Bug 1924761] */ #ifdef TK_USE_INPUT_METHODS if (event.type == KeyPress && dispPtr && (dispPtr->flags & TK_DISPLAY_USE_IM)) { if (dispPtr->focusPtr && dispPtr->focusPtr->inputContext) { Tcl_DString ds; Tcl_DStringInit(&ds); (void) TkpGetString(dispPtr->focusPtr, &event.x, &ds); Tcl_DStringFree(&ds); } } #endif } Tk_QueueWindowEvent(&event.x, TCL_QUEUE_TAIL); } } /* *---------------------------------------------------------------------- * * DisplayCheckProc -- * * This function checks for events sitting in the X event queue. * * Results: * None. * * Side effects: * Moves queued events onto the Tcl event queue. * *---------------------------------------------------------------------- */ static void DisplayCheckProc( ClientData clientData, /* Not used. */ int flags) { TkDisplay *dispPtr; if (!(flags & TCL_WINDOW_EVENTS)) { return; } for (dispPtr = TkGetDisplayList(); dispPtr != NULL; dispPtr = dispPtr->nextPtr) { XFlush(dispPtr->display); TransferXEventsToTcl(dispPtr->display); } } /* *---------------------------------------------------------------------- * * DisplayFileProc -- * * This function implements the file handler for the X connection. * * Results: * None. * * Side effects: * Makes entries on the Tcl event queue for all the events available from * all the displays. * *---------------------------------------------------------------------- */ static void DisplayFileProc( ClientData clientData, /* The display pointer. */ int flags) /* Should be TCL_READABLE. */ { TkDisplay *dispPtr = (TkDisplay *) clientData; Display *display = dispPtr->display; int numFound; XFlush(display); numFound = XEventsQueued(display, QueuedAfterReading); if (numFound == 0) { /* * Things are very tricky if there aren't any events readable at this * point (after all, there was supposedly data available on the * connection). A couple of things could have occurred: * * One possibility is that there were only error events in the input * from the server. If this happens, we should return (we don't want * to go to sleep in XNextEvent below, since this would block out * other sources of input to the process). * * Another possibility is that our connection to the server has been * closed. This will not necessarily be detected in XEventsQueued (!!) * so if we just return then there will be an infinite loop. To detect * such an error, generate a NoOp protocol request to exercise the * connection to the server, then return. However, must disable * SIGPIPE while sending the request, or else the process will die * from the signal and won't invoke the X error function to print a * nice (?!) message. */ void (*oldHandler)(); oldHandler = (void (*)()) signal(SIGPIPE, SIG_IGN); XNoOp(display); XFlush(display); (void) signal(SIGPIPE, oldHandler); } TransferXEventsToTcl(display); } /* *---------------------------------------------------------------------- * * TkUnixDoOneXEvent -- * * This routine waits for an X event to be processed or for a timeout to * occur. The timeout is specified as an absolute time. This routine is * called when Tk needs to wait for a particular X event without letting * arbitrary events be processed. The caller will typically call * Tk_RestrictEvents to set up an event filter before calling this * routine. This routine will service at most one event per invocation. * * Results: * Returns 0 if the timeout has expired, otherwise returns 1. * * Side effects: * Can invoke arbitrary Tcl scripts. * *---------------------------------------------------------------------- */ int TkUnixDoOneXEvent( Tcl_Time *timePtr) /* Specifies the absolute time when the call * should time out. */ { TkDisplay *dispPtr; static fd_mask readMask[MASK_SIZE]; struct timeval blockTime, *timeoutPtr; Tcl_Time now; int fd, index, numFound, numFdBits = 0; fd_mask bit, *readMaskPtr = readMask; /* * Look for queued events first. */ if (Tcl_ServiceEvent(TCL_WINDOW_EVENTS)) { return 1; } /* * Compute the next block time and check to see if we have timed out. Note * that HP-UX defines tv_sec to be unsigned so we have to be careful in * our arithmetic. */ if (timePtr) { Tcl_GetTime(&now); blockTime.tv_sec = timePtr->sec; blockTime.tv_usec = timePtr->usec - now.usec; if (blockTime.tv_usec < 0) { now.sec += 1; blockTime.tv_usec += 1000000; } if (blockTime.tv_sec < now.sec) { blockTime.tv_sec = 0; blockTime.tv_usec = 0; } else { blockTime.tv_sec -= now.sec; } timeoutPtr = &blockTime; } else { timeoutPtr = NULL; } /* * Set up the select mask for all of the displays. If a display has data * pending, then we want to poll instead of blocking. */ memset(readMask, 0, MASK_SIZE*sizeof(fd_mask)); for (dispPtr = TkGetDisplayList(); dispPtr != NULL; dispPtr = dispPtr->nextPtr) { XFlush(dispPtr->display); if (QLength(dispPtr->display) > 0) { blockTime.tv_sec = 0; blockTime.tv_usec = 0; } fd = ConnectionNumber(dispPtr->display); index = fd/(NBBY*sizeof(fd_mask)); bit = ((fd_mask)1) << (fd%(NBBY*sizeof(fd_mask))); readMask[index] |= bit; if (numFdBits <= fd) { numFdBits = fd+1; } } numFound = select(numFdBits, (SELECT_MASK *) readMaskPtr, NULL, NULL, timeoutPtr); if (numFound <= 0) { /* * Some systems don't clear the masks after an error, so we have to do * it here. */ memset(readMask, 0, MASK_SIZE*sizeof(fd_mask)); } /* * Process any new events on the display connections. */ for (dispPtr = TkGetDisplayList(); dispPtr != NULL; dispPtr = dispPtr->nextPtr) { fd = ConnectionNumber(dispPtr->display); index = fd/(NBBY*sizeof(fd_mask)); bit = ((fd_mask)1) << (fd%(NBBY*sizeof(fd_mask))); if ((readMask[index] & bit) || (QLength(dispPtr->display) > 0)) { DisplayFileProc(dispPtr, TCL_READABLE); } } if (Tcl_ServiceEvent(TCL_WINDOW_EVENTS)) { return 1; } /* * Check to see if we timed out. */ if (timePtr) { Tcl_GetTime(&now); if ((now.sec > timePtr->sec) || ((now.sec == timePtr->sec) && (now.usec > timePtr->usec))) { return 0; } } /* * We had an event but we did not generate a Tcl event from it. Behave as * though we dealt with it. (JYL&SS) */ return 1; } /* *---------------------------------------------------------------------- * * TkpSync -- * * This routine ensures that all pending X requests have been seen by the * server, and that any pending X events have been moved onto the Tk * event queue. * * Results: * None. * * Side effects: * Places new events on the Tk event queue. * *---------------------------------------------------------------------- */ void TkpSync( Display *display) /* Display to sync. */ { XSync(display, False); /* * Transfer events from the X event queue to the Tk event queue. */ TransferXEventsToTcl(display); } #ifdef TK_USE_INPUT_METHODS /* *-------------------------------------------------------------- * * OpenIM -- * * Tries to open an X input method associated with the given display. * * Results: * Stores the input method in dispPtr->inputMethod; if there isn't a * suitable input method, then NULL is stored in dispPtr->inputMethod. * * Side effects: * An input method gets opened. * *-------------------------------------------------------------- */ static void OpenIM( TkDisplay *dispPtr) /* Tk's structure for the display. */ { int i; XIMStyles *stylePtr; XIMStyle bestStyle = 0; if (XSetLocaleModifiers("") == NULL) { return; } dispPtr->inputMethod = XOpenIM(dispPtr->display, NULL, NULL, NULL); if (dispPtr->inputMethod == NULL) { return; } if ((XGetIMValues(dispPtr->inputMethod, XNQueryInputStyle, &stylePtr, NULL) != NULL) || (stylePtr == NULL)) { goto error; } /* * Select the best input style supported by both the IM and Tk. */ for (i = 0; i < stylePtr->count_styles; i++) { XIMStyle thisStyle = stylePtr->supported_styles[i]; if (thisStyle == (XIMPreeditPosition | XIMStatusNothing)) { bestStyle = thisStyle; break; } else if (thisStyle == (XIMPreeditNothing | XIMStatusNothing)) { bestStyle = thisStyle; } } XFree(stylePtr); if (bestStyle == 0) { goto error; } dispPtr->inputStyle = bestStyle; /* * Create an XFontSet for preedit area. */ if (dispPtr->inputStyle & XIMPreeditPosition) { char **missing_list; int missing_count; char *def_string; dispPtr->inputXfs = XCreateFontSet(dispPtr->display, "-*-*-*-R-Normal--14-130-75-75-*-*", &missing_list, &missing_count, &def_string); if (missing_count > 0) { XFreeStringList(missing_list); } } return; error: if (dispPtr->inputMethod) { XCloseIM(dispPtr->inputMethod); dispPtr->inputMethod = NULL; } } #endif /* TK_USE_INPUT_METHODS */ void TkpWarpPointer( TkDisplay *dispPtr) { Window w; /* Which window to warp relative to. */ if (dispPtr->warpWindow != NULL) { w = Tk_WindowId(dispPtr->warpWindow); } else { w = RootWindow(dispPtr->display, Tk_ScreenNumber(dispPtr->warpMainwin)); } XWarpPointer(dispPtr->display, None, w, 0, 0, 0, 0, (int) dispPtr->warpX, (int) dispPtr->warpY); } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ tk8.6.5/unix/tkUnixInit.c0000644003604700454610000000722712377375532013751 0ustar dgp771div/* * tkUnixInit.c -- * * This file contains Unix-specific interpreter initialization functions. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tkUnixInt.h" #ifdef HAVE_COREFOUNDATION static int GetLibraryPath(Tcl_Interp *interp); #else #define GetLibraryPath(dummy) (void)0 #endif /* HAVE_COREFOUNDATION */ /* *---------------------------------------------------------------------- * * TkpInit -- * * Performs Unix-specific interpreter initialization related to the * tk_library variable. * * Results: * Returns a standard Tcl result. Leaves an error message or result in * the interp's result. * * Side effects: * Sets "tk_library" Tcl variable, runs "tk.tcl" script. * *---------------------------------------------------------------------- */ int TkpInit( Tcl_Interp *interp) { TkCreateXEventSource(); GetLibraryPath(interp); return TCL_OK; } /* *---------------------------------------------------------------------- * * TkpGetAppName -- * * Retrieves the name of the current application from a platform specific * location. For Unix, the application name is the tail of the path * contained in the tcl variable argv0. * * Results: * Returns the application name in the given Tcl_DString. * * Side effects: * None. * *---------------------------------------------------------------------- */ void TkpGetAppName( Tcl_Interp *interp, Tcl_DString *namePtr) /* A previously initialized Tcl_DString. */ { const char *p, *name; name = Tcl_GetVar2(interp, "argv0", NULL, TCL_GLOBAL_ONLY); if ((name == NULL) || (*name == 0)) { name = "tk"; } else { p = strrchr(name, '/'); if (p != NULL) { name = p+1; } } Tcl_DStringAppend(namePtr, name, -1); } /* *---------------------------------------------------------------------- * * TkpDisplayWarning -- * * This routines is called from Tk_Main to display warning messages that * occur during startup. * * Results: * None. * * Side effects: * Generates messages on stdout. * *---------------------------------------------------------------------- */ void TkpDisplayWarning( const char *msg, /* Message to be displayed. */ const char *title) /* Title of warning. */ { Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR); if (errChannel) { Tcl_WriteChars(errChannel, title, -1); Tcl_WriteChars(errChannel, ": ", 2); Tcl_WriteChars(errChannel, msg, -1); Tcl_WriteChars(errChannel, "\n", 1); } } #ifdef HAVE_COREFOUNDATION /* *---------------------------------------------------------------------- * * GetLibraryPath -- * * If we have a bundle structure for the Tk installation, then check * there first to see if we can find the libraries there. * * Results: * TCL_OK if we have found the tk library; TCL_ERROR otherwise. * * Side effects: * Same as for Tcl_MacOSXOpenVersionedBundleResources. * *---------------------------------------------------------------------- */ static int GetLibraryPath( Tcl_Interp *interp) { #ifdef TK_FRAMEWORK int foundInFramework = TCL_ERROR; char tkLibPath[PATH_MAX + 1]; foundInFramework = Tcl_MacOSXOpenVersionedBundleResources(interp, "com.tcltk.tklibrary", TK_FRAMEWORK_VERSION, 0, PATH_MAX, tkLibPath); if (tkLibPath[0] != '\0') { Tcl_SetVar2(interp, "tk_library", NULL, tkLibPath, TCL_GLOBAL_ONLY); } return foundInFramework; #else return TCL_ERROR; #endif } #endif /* HAVE_COREFOUNDATION */ /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ tk8.6.5/unix/tkUnixButton.c0000644003604700454610000007253512467141247014317 0ustar dgp771div/* * tkUnixButton.c -- * * This file implements the Unix specific portion of the button widgets. * * Copyright (c) 1996-1997 by Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tkInt.h" #include "tkButton.h" #include "tk3d.h" /* * Shared with menu widget. */ MODULE_SCOPE void TkpDrawCheckIndicator(Tk_Window tkwin, Display *display, Drawable d, int x, int y, Tk_3DBorder bgBorder, XColor *indicatorColor, XColor *selectColor, XColor *disColor, int on, int disabled, int mode); /* * Declaration of Unix specific button structure. */ typedef struct UnixButton { TkButton info; /* Generic button info. */ } UnixButton; /* * The class function table for the button widgets. */ const Tk_ClassProcs tkpButtonProcs = { sizeof(Tk_ClassProcs), /* size */ TkButtonWorldChanged, /* worldChangedProc */ NULL, /* createProc */ NULL /* modalProc */ }; /* * The button image. * The header info here is ignored, it's the image that's important. The * colors will be applied as follows: * A = Background * B = Background * C = 3D light * D = selectColor * E = 3D dark * F = Background * G = Indicator Color * H = disabled Indicator Color */ /* XPM */ static const char *const button_images[] = { /* width height ncolors chars_per_pixel */ "52 26 7 1", /* colors */ "A c #808000000000", "B c #000080800000", "C c #808080800000", "D c #000000008080", "E c #808000008080", "F c #000080808080", "G c #000000000000", "H c #000080800000", /* pixels */ "AAAAAAAAAAAABAAAAAAAAAAAABAAAAAAAAAAAABAAAAAAAAAAAAB", "AEEEEEEEEEECBAEEEEEEEEEECBAEEEEEEEEEECBAEEEEEEEEEECB", "AEDDDDDDDDDCBAEDDDDDDDDDCBAEFFFFFFFFFCBAEFFFFFFFFFCB", "AEDDDDDDDDDCBAEDDDDDDDGDCBAEFFFFFFFFFCBAEFFFFFFFHFCB", "AEDDDDDDDDDCBAEDDDDDDGGDCBAEFFFFFFFFFCBAEFFFFFFHHFCB", "AEDDDDDDDDDCBAEDGDDDGGGDCBAEFFFFFFFFFCBAEFHFFFHHHFCB", "AEDDDDDDDDDCBAEDGGDGGGDDCBAEFFFFFFFFFCBAEFHHFHHHFFCB", "AEDDDDDDDDDCBAEDGGGGGDDDCBAEFFFFFFFFFCBAEFHHHHHFFFCB", "AEDDDDDDDDDCBAEDDGGGDDDDCBAEFFFFFFFFFCBAEFFHHHFFFFCB", "AEDDDDDDDDDCBAEDDDGDDDDDCBAEFFFFFFFFFCBAEFFFHFFFFFCB", "AEDDDDDDDDDCBAEDDDDDDDDDCBAEFFFFFFFFFCBAEFFFFFFFFFCB", "ACCCCCCCCCCCBACCCCCCCCCCCBACCCCCCCCCCCBACCCCCCCCCCCB", "BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB", "FFFFAAAAFFFFFFFFFAAAAFFFFFFFFFAAAAFFFFFFFFFAAAAFFFFF", "FFAAEEEEAAFFFFFAAEEEEAAFFFFFAAEEEEAAFFFFFAAEEEEAAFFF", "FAEEDDDDEEBFFFAEEDDDDEEBFFFAEEFFFFEEBFFFAEEFFFFEEBFF", "FAEDDDDDDCBFFFAEDDDDDDCBFFFAEFFFFFFCBFFFAEFFFFFFCBFF", "AEDDDDDDDDCBFAEDDDGGDDDCBFAEFFFFFFFFCBFAEFFFHHFFFCBF", "AEDDDDDDDDCBFAEDDGGGGDDCBFAEFFFFFFFFCBFAEFFHHHHFFCBF", "AEDDDDDDDDCBFAEDDGGGGDDCBFAEFFFFFFFFCBFAEFFHHHHFFCBF", "AEDDDDDDDDCBFAEDDDGGDDDCBFAEFFFFFFFFCBFAEFFFHHFFFCBF", "FAEDDDDDDCBFFFAEDDDDDDCBFFFAEFFFFFFCBFFFAEFFFFFFCBFF", "FACCDDDDCCBFFFACCDDDDCCBFFFACCFFFFCCBFFFACCFFFFCCBFF", "FFBBCCCCBBFFFFFBBCCCCBBFFFFFBBCCCCBBFFFFFBBCCCCBBFFF", "FFFFBBBBFFFFFFFFFBBBBFFFFFFFFFBBBBFFFFFFFFFBBBBFFFFF", "FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF", }; /* * Sizes and offsets into above XPM file. */ #define CHECK_BUTTON_DIM 13 #define CHECK_MENU_DIM 9 #define CHECK_START 9 #define CHECK_ON_OFFSET 13 #define CHECK_OFF_OFFSET 0 #define CHECK_DISON_OFFSET 39 #define CHECK_DISOFF_OFFSET 26 #define RADIO_BUTTON_DIM 12 #define RADIO_MENU_DIM 6 #define RADIO_WIDTH 13 #define RADIO_START 22 #define RADIO_ON_OFFSET 13 #define RADIO_OFF_OFFSET 0 #define RADIO_DISON_OFFSET 39 #define RADIO_DISOFF_OFFSET 26 /* * Indicator Draw Modes */ #define CHECK_BUTTON 0 #define CHECK_MENU 1 #define RADIO_BUTTON 2 #define RADIO_MENU 3 /* *---------------------------------------------------------------------- * * TkpDrawCheckIndicator - * * Draws the checkbox image in the drawable at the (x,y) location, value, * and state given. This routine is use by the button and menu widgets * * Results: * None. * * Side effects: * An image is drawn in the drawable at the location given. * *---------------------------------------------------------------------- */ void TkpDrawCheckIndicator( Tk_Window tkwin, /* handle for resource alloc */ Display *display, Drawable d, /* what to draw on */ int x, int y, /* where to draw */ Tk_3DBorder bgBorder, /* colors of the border */ XColor *indicatorColor, /* color of the indicator */ XColor *selectColor, /* color when selected */ XColor *disableColor, /* color when disabled */ int on, /* are we on? */ int disabled, /* are we disabled? */ int mode) /* kind of indicator to draw */ { int ix, iy; int dim; int imgsel, imgstart; TkBorder *bg_brdr = (TkBorder*)bgBorder; XGCValues gcValues; GC copyGC; unsigned long imgColors[8]; XImage *img; Pixmap pixmap; int depth; /* * Sanity check. */ if (tkwin == NULL || display == None || d == None || bgBorder == NULL || indicatorColor == NULL) { return; } if (disableColor == NULL) { disableColor = bg_brdr->bgColorPtr; } if (selectColor == NULL) { selectColor = bg_brdr->bgColorPtr; } depth = Tk_Depth(tkwin); /* * Compute starting point and dimensions of image inside button_images to * be used. */ switch (mode) { default: case CHECK_BUTTON: imgsel = on == 2 ? CHECK_DISON_OFFSET : on == 1 ? CHECK_ON_OFFSET : CHECK_OFF_OFFSET; imgsel += disabled && on != 2 ? CHECK_DISOFF_OFFSET : 0; imgstart = CHECK_START; dim = CHECK_BUTTON_DIM; break; case CHECK_MENU: imgsel = on == 2 ? CHECK_DISOFF_OFFSET : on == 1 ? CHECK_ON_OFFSET : CHECK_OFF_OFFSET; imgsel += disabled && on != 2 ? CHECK_DISOFF_OFFSET : 0; imgstart = CHECK_START + 2; imgsel += 2; dim = CHECK_MENU_DIM; break; case RADIO_BUTTON: imgsel = on == 2 ? RADIO_DISON_OFFSET : on==1 ? RADIO_ON_OFFSET : RADIO_OFF_OFFSET; imgsel += disabled && on != 2 ? RADIO_DISOFF_OFFSET : 0; imgstart = RADIO_START; dim = RADIO_BUTTON_DIM; break; case RADIO_MENU: imgsel = on == 2 ? RADIO_DISOFF_OFFSET : on==1 ? RADIO_ON_OFFSET : RADIO_OFF_OFFSET; imgsel += disabled && on != 2 ? RADIO_DISOFF_OFFSET : 0; imgstart = RADIO_START + 3; imgsel += 3; dim = RADIO_MENU_DIM; break; } /* * Allocate the drawing areas to use. Note that we use double-buffering * here because not all code paths leading to this function do so. */ pixmap = Tk_GetPixmap(display, d, dim, dim, depth); if (pixmap == None) { return; } x -= dim/2; y -= dim/2; img = XGetImage(display, pixmap, 0, 0, (unsigned int)dim, (unsigned int)dim, AllPlanes, ZPixmap); if (img == NULL) { return; } /* * Set up the color mapping table. */ TkpGetShadows(bg_brdr, tkwin); imgColors[0 /*A*/] = Tk_GetColorByValue(tkwin, bg_brdr->bgColorPtr)->pixel; imgColors[1 /*B*/] = Tk_GetColorByValue(tkwin, bg_brdr->bgColorPtr)->pixel; imgColors[2 /*C*/] = (bg_brdr->lightColorPtr != NULL) ? Tk_GetColorByValue(tkwin, bg_brdr->lightColorPtr)->pixel : WhitePixelOfScreen(bg_brdr->screen); imgColors[3 /*D*/] = Tk_GetColorByValue(tkwin, selectColor)->pixel; imgColors[4 /*E*/] = (bg_brdr->darkColorPtr != NULL) ? Tk_GetColorByValue(tkwin, bg_brdr->darkColorPtr)->pixel : BlackPixelOfScreen(bg_brdr->screen); imgColors[5 /*F*/] = Tk_GetColorByValue(tkwin, bg_brdr->bgColorPtr)->pixel; imgColors[6 /*G*/] = Tk_GetColorByValue(tkwin, indicatorColor)->pixel; imgColors[7 /*H*/] = Tk_GetColorByValue(tkwin, disableColor)->pixel; /* * Create the image, painting it into an XImage one pixel at a time. */ for (iy=0 ; iybgColorPtr->pixel; gcValues.graphics_exposures = False; copyGC = Tk_GetGC(tkwin, 0, &gcValues); XPutImage(display, pixmap, copyGC, img, 0, 0, 0, 0, (unsigned)dim, (unsigned)dim); XCopyArea(display, pixmap, d, copyGC, 0, 0, (unsigned)dim, (unsigned)dim, x, y); /* * Tidy up. */ Tk_FreeGC(display, copyGC); XDestroyImage(img); Tk_FreePixmap(display, pixmap); } /* *---------------------------------------------------------------------- * * TkpCreateButton -- * * Allocate a new TkButton structure. * * Results: * Returns a newly allocated TkButton structure. * * Side effects: * Registers an event handler for the widget. * *---------------------------------------------------------------------- */ TkButton * TkpCreateButton( Tk_Window tkwin) { UnixButton *butPtr = ckalloc(sizeof(UnixButton)); return (TkButton *) butPtr; } /* *---------------------------------------------------------------------- * * TkpDisplayButton -- * * This function is invoked to display a button widget. It is normally * invoked as an idle handler. * * Results: * None. * * Side effects: * Commands are output to X to display the button in its current mode. * The REDRAW_PENDING flag is cleared. * *---------------------------------------------------------------------- */ void TkpDisplayButton( ClientData clientData) /* Information about widget. */ { register TkButton *butPtr = (TkButton *) clientData; GC gc; Tk_3DBorder border; Pixmap pixmap; int x = 0; /* Initialization only needed to stop compiler * warning. */ int y, relief; Tk_Window tkwin = butPtr->tkwin; int width = 0, height = 0, fullWidth, fullHeight; int textXOffset, textYOffset; int haveImage = 0, haveText = 0; int offset; /* 1 means this is a button widget, so we * offset the text to make the button appear * to move up and down as the relief * changes. */ int imageWidth, imageHeight; int imageXOffset = 0, imageYOffset = 0; /* image information that will be used to * restrict disabled pixmap as well */ butPtr->flags &= ~REDRAW_PENDING; if ((butPtr->tkwin == NULL) || !Tk_IsMapped(tkwin)) { return; } border = butPtr->normalBorder; if ((butPtr->state == STATE_DISABLED) && (butPtr->disabledFg != NULL)) { gc = butPtr->disabledGC; } else if ((butPtr->state == STATE_ACTIVE) && !Tk_StrictMotif(butPtr->tkwin)) { gc = butPtr->activeTextGC; border = butPtr->activeBorder; } else { gc = butPtr->normalTextGC; } if ((butPtr->flags & SELECTED) && (butPtr->selectBorder != NULL) && !butPtr->indicatorOn) { border = butPtr->selectBorder; } /* * Override the relief specified for the button if this is a checkbutton * or radiobutton and there's no indicator. The new relief is as follows: * If the button is select --> "sunken" * If relief==overrelief --> relief * Otherwise --> overrelief * * The effect we are trying to achieve is as follows: * * value mouse-over? --> relief * ------- ------------ -------- * off no flat * off yes raised * on no sunken * on yes sunken * * This is accomplished by configuring the checkbutton or radiobutton like * this: * * -indicatoron 0 -overrelief raised -offrelief flat * * Bindings (see library/button.tcl) will copy the -overrelief into * -relief on mouseover. Hence, we can tell if we are in mouse-over by * comparing relief against overRelief. This is an aweful kludge, but it * gives use the desired behavior while keeping the code backwards * compatible. */ relief = butPtr->relief; if ((butPtr->type >= TYPE_CHECK_BUTTON) && !butPtr->indicatorOn) { if (butPtr->flags & SELECTED) { relief = TK_RELIEF_SUNKEN; } else if (butPtr->overRelief != relief) { relief = butPtr->offRelief; } } offset = (butPtr->type == TYPE_BUTTON) && !Tk_StrictMotif(butPtr->tkwin); /* * In order to avoid screen flashes, this function redraws the button in a * pixmap, then copies the pixmap to the screen in a single operation. * This means that there's no point in time where the on-screen image has * been cleared. */ pixmap = Tk_GetPixmap(butPtr->display, Tk_WindowId(tkwin), Tk_Width(tkwin), Tk_Height(tkwin), Tk_Depth(tkwin)); Tk_Fill3DRectangle(tkwin, pixmap, border, 0, 0, Tk_Width(tkwin), Tk_Height(tkwin), 0, TK_RELIEF_FLAT); /* * Display image or bitmap or text for button. */ if (butPtr->image != NULL) { Tk_SizeOfImage(butPtr->image, &width, &height); haveImage = 1; } else if (butPtr->bitmap != None) { Tk_SizeOfBitmap(butPtr->display, butPtr->bitmap, &width, &height); haveImage = 1; } imageWidth = width; imageHeight = height; haveText = (butPtr->textWidth != 0 && butPtr->textHeight != 0); if (butPtr->compound != COMPOUND_NONE && haveImage && haveText) { textXOffset = 0; textYOffset = 0; fullWidth = 0; fullHeight = 0; switch ((enum compound) butPtr->compound) { case COMPOUND_TOP: case COMPOUND_BOTTOM: /* * Image is above or below text. */ if (butPtr->compound == COMPOUND_TOP) { textYOffset = height + butPtr->padY; } else { imageYOffset = butPtr->textHeight + butPtr->padY; } fullHeight = height + butPtr->textHeight + butPtr->padY; fullWidth = (width > butPtr->textWidth ? width : butPtr->textWidth); textXOffset = (fullWidth - butPtr->textWidth)/2; imageXOffset = (fullWidth - width)/2; break; case COMPOUND_LEFT: case COMPOUND_RIGHT: /* * Image is left or right of text. */ if (butPtr->compound == COMPOUND_LEFT) { textXOffset = width + butPtr->padX; } else { imageXOffset = butPtr->textWidth + butPtr->padX; } fullWidth = butPtr->textWidth + butPtr->padX + width; fullHeight = (height > butPtr->textHeight ? height : butPtr->textHeight); textYOffset = (fullHeight - butPtr->textHeight)/2; imageYOffset = (fullHeight - height)/2; break; case COMPOUND_CENTER: /* * Image and text are superimposed. */ fullWidth = (width > butPtr->textWidth ? width : butPtr->textWidth); fullHeight = (height > butPtr->textHeight ? height : butPtr->textHeight); textXOffset = (fullWidth - butPtr->textWidth)/2; imageXOffset = (fullWidth - width)/2; textYOffset = (fullHeight - butPtr->textHeight)/2; imageYOffset = (fullHeight - height)/2; break; case COMPOUND_NONE: break; } TkComputeAnchor(butPtr->anchor, tkwin, butPtr->padX, butPtr->padY, butPtr->indicatorSpace + fullWidth, fullHeight, &x, &y); x += butPtr->indicatorSpace; x += offset; y += offset; if (relief == TK_RELIEF_RAISED) { x -= offset; y -= offset; } else if (relief == TK_RELIEF_SUNKEN) { x += offset; y += offset; } imageXOffset += x; imageYOffset += y; if (butPtr->image != NULL) { /* * Do boundary clipping, so that Tk_RedrawImage is passed valid * coordinates. [Bug 979239] */ if (imageXOffset < 0) { imageXOffset = 0; } if (imageYOffset < 0) { imageYOffset = 0; } if (width > Tk_Width(tkwin)) { width = Tk_Width(tkwin); } if (height > Tk_Height(tkwin)) { height = Tk_Height(tkwin); } if ((width + imageXOffset) > Tk_Width(tkwin)) { imageXOffset = Tk_Width(tkwin) - width; } if ((height + imageYOffset) > Tk_Height(tkwin)) { imageYOffset = Tk_Height(tkwin) - height; } if ((butPtr->selectImage != NULL) && (butPtr->flags & SELECTED)) { Tk_RedrawImage(butPtr->selectImage, 0, 0, width, height, pixmap, imageXOffset, imageYOffset); } else if ((butPtr->tristateImage != NULL) && (butPtr->flags & TRISTATED)) { Tk_RedrawImage(butPtr->tristateImage, 0, 0, width, height, pixmap, imageXOffset, imageYOffset); } else { Tk_RedrawImage(butPtr->image, 0, 0, width, height, pixmap, imageXOffset, imageYOffset); } } else { XSetClipOrigin(butPtr->display, gc, imageXOffset, imageYOffset); XCopyPlane(butPtr->display, butPtr->bitmap, pixmap, gc, 0, 0, (unsigned int) width, (unsigned int) height, imageXOffset, imageYOffset, 1); XSetClipOrigin(butPtr->display, gc, 0, 0); } Tk_DrawTextLayout(butPtr->display, pixmap, gc, butPtr->textLayout, x + textXOffset, y + textYOffset, 0, -1); Tk_UnderlineTextLayout(butPtr->display, pixmap, gc, butPtr->textLayout, x + textXOffset, y + textYOffset, butPtr->underline); y += fullHeight/2; } else { if (haveImage) { TkComputeAnchor(butPtr->anchor, tkwin, 0, 0, butPtr->indicatorSpace + width, height, &x, &y); x += butPtr->indicatorSpace; x += offset; y += offset; if (relief == TK_RELIEF_RAISED) { x -= offset; y -= offset; } else if (relief == TK_RELIEF_SUNKEN) { x += offset; y += offset; } imageXOffset += x; imageYOffset += y; if (butPtr->image != NULL) { /* * Do boundary clipping, so that Tk_RedrawImage is passed * valid coordinates. [Bug 979239] */ if (imageXOffset < 0) { imageXOffset = 0; } if (imageYOffset < 0) { imageYOffset = 0; } if (width > Tk_Width(tkwin)) { width = Tk_Width(tkwin); } if (height > Tk_Height(tkwin)) { height = Tk_Height(tkwin); } if ((width + imageXOffset) > Tk_Width(tkwin)) { imageXOffset = Tk_Width(tkwin) - width; } if ((height + imageYOffset) > Tk_Height(tkwin)) { imageYOffset = Tk_Height(tkwin) - height; } if ((butPtr->selectImage != NULL) && (butPtr->flags & SELECTED)) { Tk_RedrawImage(butPtr->selectImage, 0, 0, width, height, pixmap, imageXOffset, imageYOffset); } else if ((butPtr->tristateImage != NULL) && (butPtr->flags & TRISTATED)) { Tk_RedrawImage(butPtr->tristateImage, 0, 0, width, height, pixmap, imageXOffset, imageYOffset); } else { Tk_RedrawImage(butPtr->image, 0, 0, width, height, pixmap, imageXOffset, imageYOffset); } } else { XSetClipOrigin(butPtr->display, gc, x, y); XCopyPlane(butPtr->display, butPtr->bitmap, pixmap, gc, 0, 0, (unsigned int) width, (unsigned int) height, x, y, 1); XSetClipOrigin(butPtr->display, gc, 0, 0); } y += height/2; } else { TkComputeAnchor(butPtr->anchor, tkwin, butPtr->padX, butPtr->padY, butPtr->indicatorSpace + butPtr->textWidth, butPtr->textHeight, &x, &y); x += butPtr->indicatorSpace; x += offset; y += offset; if (relief == TK_RELIEF_RAISED) { x -= offset; y -= offset; } else if (relief == TK_RELIEF_SUNKEN) { x += offset; y += offset; } Tk_DrawTextLayout(butPtr->display, pixmap, gc, butPtr->textLayout, x, y, 0, -1); Tk_UnderlineTextLayout(butPtr->display, pixmap, gc, butPtr->textLayout, x, y, butPtr->underline); y += butPtr->textHeight/2; } } /* * Draw the indicator for check buttons and radio buttons. At this point, * x and y refer to the top-left corner of the text or image or bitmap. */ if ((butPtr->type == TYPE_CHECK_BUTTON) && butPtr->indicatorOn) { if (butPtr->indicatorDiameter > 2*butPtr->borderWidth) { TkBorder *selBorder = (TkBorder *) butPtr->selectBorder; XColor *selColor = NULL; if (selBorder != NULL) { selColor = selBorder->bgColorPtr; } x -= butPtr->indicatorSpace/2; y = Tk_Height(tkwin)/2; TkpDrawCheckIndicator(tkwin, butPtr->display, pixmap, x, y, border, butPtr->normalFg, selColor, butPtr->disabledFg, ((butPtr->flags & SELECTED) ? 1 : (butPtr->flags & TRISTATED) ? 2 : 0), (butPtr->state == STATE_DISABLED), CHECK_BUTTON); } } else if ((butPtr->type == TYPE_RADIO_BUTTON) && butPtr->indicatorOn) { if (butPtr->indicatorDiameter > 2*butPtr->borderWidth) { TkBorder *selBorder = (TkBorder *) butPtr->selectBorder; XColor *selColor = NULL; if (selBorder != NULL) { selColor = selBorder->bgColorPtr; } x -= butPtr->indicatorSpace/2; y = Tk_Height(tkwin)/2; TkpDrawCheckIndicator(tkwin, butPtr->display, pixmap, x, y, border, butPtr->normalFg, selColor, butPtr->disabledFg, ((butPtr->flags & SELECTED) ? 1 : (butPtr->flags & TRISTATED) ? 2 : 0), (butPtr->state == STATE_DISABLED), RADIO_BUTTON); } } /* * If the button is disabled with a stipple rather than a special * foreground color, generate the stippled effect. If the widget is * selected and we use a different background color when selected, must * temporarily modify the GC so the stippling is the right color. */ if ((butPtr->state == STATE_DISABLED) && ((butPtr->disabledFg == NULL) || (butPtr->image != NULL))) { if ((butPtr->flags & SELECTED) && !butPtr->indicatorOn && (butPtr->selectBorder != NULL)) { XSetForeground(butPtr->display, butPtr->stippleGC, Tk_3DBorderColor(butPtr->selectBorder)->pixel); } /* * Stipple the whole button if no disabledFg was specified, otherwise * restrict stippling only to displayed image */ if (butPtr->disabledFg == NULL) { XFillRectangle(butPtr->display, pixmap, butPtr->stippleGC, 0, 0, (unsigned) Tk_Width(tkwin), (unsigned) Tk_Height(tkwin)); } else { XFillRectangle(butPtr->display, pixmap, butPtr->stippleGC, imageXOffset, imageYOffset, (unsigned) imageWidth, (unsigned) imageHeight); } if ((butPtr->flags & SELECTED) && !butPtr->indicatorOn && (butPtr->selectBorder != NULL)) { XSetForeground(butPtr->display, butPtr->stippleGC, Tk_3DBorderColor(butPtr->normalBorder)->pixel); } } /* * Draw the border and traversal highlight last. This way, if the button's * contents overflow they'll be covered up by the border. This code is * complicated by the possible combinations of focus highlight and default * rings. We draw the focus and highlight rings using the highlight border * and highlight foreground color. */ if (relief != TK_RELIEF_FLAT) { int inset = butPtr->highlightWidth; if (butPtr->defaultState == DEFAULT_ACTIVE) { /* * Draw the default ring with 2 pixels of space between the * default ring and the button and the default ring and the focus * ring. Note that we need to explicitly draw the space in the * highlightBorder color to ensure that we overwrite any overflow * text and/or a different button background color. */ Tk_Draw3DRectangle(tkwin, pixmap, butPtr->highlightBorder, inset, inset, Tk_Width(tkwin) - 2*inset, Tk_Height(tkwin) - 2*inset, 2, TK_RELIEF_FLAT); inset += 2; Tk_Draw3DRectangle(tkwin, pixmap, butPtr->highlightBorder, inset, inset, Tk_Width(tkwin) - 2*inset, Tk_Height(tkwin) - 2*inset, 1, TK_RELIEF_SUNKEN); inset++; Tk_Draw3DRectangle(tkwin, pixmap, butPtr->highlightBorder, inset, inset, Tk_Width(tkwin) - 2*inset, Tk_Height(tkwin) - 2*inset, 2, TK_RELIEF_FLAT); inset += 2; } else if (butPtr->defaultState == DEFAULT_NORMAL) { /* * Leave room for the default ring and write over any text or * background color. */ Tk_Draw3DRectangle(tkwin, pixmap, butPtr->highlightBorder, 0, 0, Tk_Width(tkwin), Tk_Height(tkwin), 5, TK_RELIEF_FLAT); inset += 5; } /* * Draw the button border. */ Tk_Draw3DRectangle(tkwin, pixmap, border, inset, inset, Tk_Width(tkwin) - 2*inset, Tk_Height(tkwin) - 2*inset, butPtr->borderWidth, relief); } if (butPtr->highlightWidth > 0) { GC gc; if (butPtr->flags & GOT_FOCUS) { gc = Tk_GCForColor(butPtr->highlightColorPtr, pixmap); } else { gc = Tk_GCForColor(Tk_3DBorderColor(butPtr->highlightBorder), pixmap); } /* * Make sure the focus ring shrink-wraps the actual button, not the * padding space left for a default ring. */ if (butPtr->defaultState == DEFAULT_NORMAL) { TkDrawInsetFocusHighlight(tkwin, gc, butPtr->highlightWidth, pixmap, 5); } else { Tk_DrawFocusHighlight(tkwin, gc, butPtr->highlightWidth, pixmap); } } /* * Copy the information from the off-screen pixmap onto the screen, then * delete the pixmap. */ XCopyArea(butPtr->display, pixmap, Tk_WindowId(tkwin), butPtr->copyGC, 0, 0, (unsigned) Tk_Width(tkwin), (unsigned) Tk_Height(tkwin), 0, 0); Tk_FreePixmap(butPtr->display, pixmap); } /* *---------------------------------------------------------------------- * * TkpComputeButtonGeometry -- * * After changes in a button's text or bitmap, this function recomputes * the button's geometry and passes this information along to the * geometry manager for the window. * * Results: * None. * * Side effects: * The button's window may change size. * *---------------------------------------------------------------------- */ void TkpComputeButtonGeometry( register TkButton *butPtr) /* Button whose geometry may have changed. */ { int width, height, avgWidth, txtWidth, txtHeight; int haveImage = 0, haveText = 0; Tk_FontMetrics fm; butPtr->inset = butPtr->highlightWidth + butPtr->borderWidth; /* * Leave room for the default ring if needed. */ if (butPtr->defaultState != DEFAULT_DISABLED) { butPtr->inset += 5; } butPtr->indicatorSpace = 0; width = 0; height = 0; txtWidth = 0; txtHeight = 0; avgWidth = 0; if (butPtr->image != NULL) { Tk_SizeOfImage(butPtr->image, &width, &height); haveImage = 1; } else if (butPtr->bitmap != None) { Tk_SizeOfBitmap(butPtr->display, butPtr->bitmap, &width, &height); haveImage = 1; } if (haveImage == 0 || butPtr->compound != COMPOUND_NONE) { Tk_FreeTextLayout(butPtr->textLayout); butPtr->textLayout = Tk_ComputeTextLayout(butPtr->tkfont, Tcl_GetString(butPtr->textPtr), -1, butPtr->wrapLength, butPtr->justify, 0, &butPtr->textWidth, &butPtr->textHeight); txtWidth = butPtr->textWidth; txtHeight = butPtr->textHeight; avgWidth = Tk_TextWidth(butPtr->tkfont, "0", 1); Tk_GetFontMetrics(butPtr->tkfont, &fm); haveText = (txtWidth != 0 && txtHeight != 0); } /* * If the button is compound (i.e., it shows both an image and text), the * new geometry is a combination of the image and text geometry. We only * honor the compound bit if the button has both text and an image, * because otherwise it is not really a compound button. */ if (butPtr->compound != COMPOUND_NONE && haveImage && haveText) { switch ((enum compound) butPtr->compound) { case COMPOUND_TOP: case COMPOUND_BOTTOM: /* * Image is above or below text. */ height += txtHeight + butPtr->padY; width = (width > txtWidth ? width : txtWidth); break; case COMPOUND_LEFT: case COMPOUND_RIGHT: /* * Image is left or right of text. */ width += txtWidth + butPtr->padX; height = (height > txtHeight ? height : txtHeight); break; case COMPOUND_CENTER: /* * Image and text are superimposed. */ width = (width > txtWidth ? width : txtWidth); height = (height > txtHeight ? height : txtHeight); break; case COMPOUND_NONE: break; } if (butPtr->width > 0) { width = butPtr->width; } if (butPtr->height > 0) { height = butPtr->height; } if ((butPtr->type >= TYPE_CHECK_BUTTON) && butPtr->indicatorOn) { butPtr->indicatorSpace = height; if (butPtr->type == TYPE_CHECK_BUTTON) { butPtr->indicatorDiameter = (65*height)/100; } else { butPtr->indicatorDiameter = (75*height)/100; } } width += 2*butPtr->padX; height += 2*butPtr->padY; } else { if (haveImage) { if (butPtr->width > 0) { width = butPtr->width; } if (butPtr->height > 0) { height = butPtr->height; } if ((butPtr->type >= TYPE_CHECK_BUTTON) && butPtr->indicatorOn) { butPtr->indicatorSpace = height; if (butPtr->type == TYPE_CHECK_BUTTON) { butPtr->indicatorDiameter = (65*height)/100; } else { butPtr->indicatorDiameter = (75*height)/100; } } } else { width = txtWidth; height = txtHeight; if (butPtr->width > 0) { width = butPtr->width * avgWidth; } if (butPtr->height > 0) { height = butPtr->height * fm.linespace; } if ((butPtr->type >= TYPE_CHECK_BUTTON) && butPtr->indicatorOn) { butPtr->indicatorDiameter = fm.linespace; if (butPtr->type == TYPE_CHECK_BUTTON) { butPtr->indicatorDiameter = (80*butPtr->indicatorDiameter)/100; } butPtr->indicatorSpace = butPtr->indicatorDiameter + avgWidth; } } } /* * When issuing the geometry request, add extra space for the indicator, * if any, and for the border and padding, plus two extra pixels so the * display can be offset by 1 pixel in either direction for the raised or * lowered effect. */ if ((butPtr->image == NULL) && (butPtr->bitmap == None)) { width += 2*butPtr->padX; height += 2*butPtr->padY; } if ((butPtr->type == TYPE_BUTTON) && !Tk_StrictMotif(butPtr->tkwin)) { width += 2; height += 2; } Tk_GeometryRequest(butPtr->tkwin, (int) (width + butPtr->indicatorSpace + 2*butPtr->inset), (int) (height + 2*butPtr->inset)); Tk_SetInternalBorder(butPtr->tkwin, butPtr->inset); } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ tk8.6.5/tests/0000755003604700454610000000000012665114121011627 5ustar dgp771divtk8.6.5/tests/clrpick.test0000644003604700454610000001474612424437552014204 0ustar dgp771div# This file is a Tcl script to test out Tk's "tk_chooseColor" command. # It is organized in the standard fashion for Tcl tests. # # Copyright (c) 1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands namespace import -force tcltest::test if {[testConstraint defaultPseudocolor8]} { # let's soak up a bunch of colors...so that # machines with small color palettes still fail. # some tests will be skipped if there are no more colors set numcolors 32 testConstraint colorsLeftover 1 set i 0 canvas .c pack .c -expand 1 -fill both while {$i<$numcolors} { set color \#[format "%02x%02x%02x" $i [expr $i+1] [expr $i+3]] .c create rectangle [expr 10+$i] [expr 10+$i] [expr 50+$i] [expr 50+$i] -fill $color -outline $color incr i } set i 0 while {$i<$numcolors} { set color [.c itemcget $i -fill] if {$color != ""} { foreach {r g b} [winfo rgb . $color] {} set r [expr $r/256] set g [expr $g/256] set b [expr $b/256] if {"$color" != "#[format %02x%02x%02x $r $g $b]"} { testConstraint colorsLeftover 0 } } .c delete $i incr i } destroy .c } else { testConstraint colorsLeftover 0 } test clrpick-1.1 {tk_chooseColor command} -body { tk_chooseColor -foo } -returnCodes error -result {bad option "-foo": must be -initialcolor, -parent, or -title} test clrpick-1.2 {tk_chooseColor command } -body { tk_chooseColor -initialcolor } -returnCodes error -result {value for "-initialcolor" missing} test clrpick-1.2.1 {tk_chooseColor command } -body { tk_chooseColor -parent } -returnCodes error -result {value for "-parent" missing} test clrpick-1.2.2 {tk_chooseColor command } -body { tk_chooseColor -title } -returnCodes error -result {value for "-title" missing} test clrpick-1.3 {tk_chooseColor command} -body { tk_chooseColor -foo bar } -returnCodes error -result {bad option "-foo": must be -initialcolor, -parent, or -title} test clrpick-1.4 {tk_chooseColor command} -body { tk_chooseColor -initialcolor } -returnCodes error -result {value for "-initialcolor" missing} test clrpick-1.5 {tk_chooseColor command} -body { tk_chooseColor -parent foo.bar } -returnCodes error -result {bad window path name "foo.bar"} test clrpick-1.6 {tk_chooseColor command} -body { tk_chooseColor -initialcolor badbadbaadcolor } -returnCodes error -result {unknown color name "badbadbaadcolor"} test clrpick-1.7 {tk_chooseColor command} -body { tk_chooseColor -initialcolor ##badbadbaadcolor } -returnCodes error -result {invalid color name "##badbadbaadcolor"} # 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 set isNative [expr {[info commands tk::dialog::color::] eq ""}] proc ToPressButton {parent btn} { global isNative if {!$isNative} { after 200 "SendButtonPress . $btn mouse" } } proc ToChooseColorByKey {parent r g b} { global isNative if {!$isNative} { after 200 ChooseColorByKey . $r $g $b } } proc PressButton {btn} { event generate $btn event generate $btn <1> -x 5 -y 5 event generate $btn -x 5 -y 5 } proc ChooseColorByKey {parent r g b} { set w .__tk__color upvar ::tk::dialog::color::[winfo name $w] data update $data(red,entry) delete 0 end $data(green,entry) delete 0 end $data(blue,entry) delete 0 end $data(red,entry) insert 0 $r $data(green,entry) insert 0 $g $data(blue,entry) insert 0 $b # Manually force the refresh of the color values instead # of counting on the timing of the event stream to change # the values for us. tk::dialog::color::HandleRGBEntry $w SendButtonPress . ok mouse } proc SendButtonPress {parent btn type} { set w .__tk__color upvar ::tk::dialog::color::[winfo name $w] data set button $data($btn\Btn) if ![winfo ismapped $button] { update } if {$type == "mouse"} { PressButton $button } else { event generate $w focus $w event generate $button event generate $w -keysym Return } } test clrpick-2.1 {tk_chooseColor command} -constraints { nonUnixUserInteraction colorsLeftover } -setup { set verylongstring longstring: set verylongstring $verylongstring$verylongstring set verylongstring $verylongstring$verylongstring set verylongstring $verylongstring$verylongstring set verylongstring $verylongstring$verylongstring #set verylongstring $verylongstring$verylongstring # Interesting thing...when this is too long, the # delay caused in processing it kills the automated testing, # and makes a lot of the test cases fail. #set verylongstring $verylongstring$verylongstring #set verylongstring $verylongstring$verylongstring #set verylongstring $verylongstring$verylongstring #set verylongstring $verylongstring$verylongstring } -body { ToPressButton . ok tk_chooseColor -title "Press Ok $verylongstring" -initialcolor #404040 \ -parent . } -result {#404040} test clrpick-2.2 {tk_chooseColor command} -constraints { nonUnixUserInteraction colorsLeftover } -body { set colors "128 128 64" ToChooseColorByKey . 128 128 64 tk_chooseColor -parent . -title "choose #808040" } -result {#808040} test clrpick-2.3 {tk_chooseColor command} -constraints { nonUnixUserInteraction colorsLeftover } -body { ToPressButton . ok tk_chooseColor -parent . -title "Press OK" } -result {#808040} test clrpick-2.4 {tk_chooseColor command} -constraints { nonUnixUserInteraction colorsLeftover } -body { ToPressButton . cancel tk_chooseColor -parent . -title "Press Cancel" } -result {} test clrpick-3.1 {tk_chooseColor: background events} -constraints { nonUnixUserInteraction } -body { after 1 {set x 53} ToPressButton . ok tk_chooseColor -parent . -title "Press OK" -initialcolor #000000 } -result {#000000} test clrpick-3.2 {tk_chooseColor: background events} -constraints { nonUnixUserInteraction } -body { after 1 {set x 53} ToPressButton . cancel tk_chooseColor -parent . -title "Press Cancel" } -result {} test clrpick-4.1 {tk_chooseColor: screen is inherited from parent} -constraints { unix notAqua } -body { after 50 {set ::scr [winfo screen .__tk__color]} ToPressButton . cancel tk_chooseColor -parent . set ::scr } -result [winfo screen .] # cleanup cleanupTests return tk8.6.5/tests/canvText.test0000644003604700454610000007225412453313723014342 0ustar dgp771div# This file is a Tcl script to test out the procedures in tkCanvText.c, # which implement canvas "text" items. It is organized in the standard # fashion for Tcl tests. # # Copyright (c) 1996-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. package require tcltest 2.2 namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands # Canvas used in 1.* - 17.* tests canvas .c -width 400 -height 300 -bd 2 -relief sunken pack .c update # Item used in 1.* tests .c create text 20 20 -tag test test canvText-1.1 {configuration options: good value for "anchor"} -body { .c itemconfigure test -anchor nw list [lindex [.c itemconfigure test -anchor] 4] [.c itemcget test -anchor] } -result {nw nw} test canvasText-1.2 {configuration options: bad value for "anchor"} -body { .c itemconfigure test -anchor xyz } -returnCodes error -result {bad anchor position "xyz": must be n, ne, e, se, s, sw, w, nw, or center} test canvText-1.3 {configuration options: good value for "fill"} -body { .c itemconfigure test -fill #ff0000 list [lindex [.c itemconfigure test -fill] 4] [.c itemcget test -fill] } -result {{#ff0000} #ff0000} test canvasText-1.4 {configuration options: bad value for "fill"} -body { .c itemconfigure test -fill xyz } -returnCodes error -result {unknown color name "xyz"} test canvText-1.5 {configuration options: good value for "fill"} -body { .c itemconfigure test -fill {} list [lindex [.c itemconfigure test -fill] 4] [.c itemcget test -fill] } -result {{} {}} test canvText-1.6 {configuration options: good value for "font"} -body { .c itemconfigure test -font {Times 40} list [lindex [.c itemconfigure test -font] 4] [.c itemcget test -font] } -result {{Times 40} {Times 40}} test canvasText-1.7 {configuration options: bad value for "font"} -body { .c itemconfigure test -font {} } -returnCodes error -result {font "" doesn't exist} test canvText-1.8 {configuration options: good value for "justify"} -body { .c itemconfigure test -justify left list [lindex [.c itemconfigure test -justify] 4] [.c itemcget test -justify] } -result {left left} test canvasText-1.9 {configuration options: bad value for "justify"} -body { .c itemconfigure test -justify xyz } -returnCodes error -result {bad justification "xyz": must be left, right, or center} test canvText-1.10 {configuration options: good value for "stipple"} -body { .c itemconfigure test -stipple gray50 list [lindex [.c itemconfigure test -stipple] 4] [.c itemcget test -stipple] } -result {gray50 gray50} test canvasText-1.11 {configuration options: bad value for "stipple"} -body { .c itemconfigure test -stipple xyz } -returnCodes error -result {bitmap "xyz" not defined} test canvText-1.12 {configuration options: good value for "underline"} -body { .c itemconfigure test -underline 0 list [lindex [.c itemconfigure test -underline] 4] [.c itemcget test -underline] } -result {0 0} test canvasText-1.13 {configuration options: bad value for "underline"} -body { .c itemconfigure test -underline xyz } -returnCodes error -result {expected integer but got "xyz"} test canvText-1.14 {configuration options: good value for "width"} -body { .c itemconfigure test -width 6 list [lindex [.c itemconfigure test -width] 4] [.c itemcget test -width] } -result {6 6} test canvasText-1.15 {configuration options: bad value for "width"} -body { .c itemconfigure test -width xyz } -returnCodes error -result {bad screen distance "xyz"} test canvText-1.16 {configuration options: good value for "tags"} -body { .c itemconfigure test -tags {test a b c} list [lindex [.c itemconfigure test -tags] 4] [.c itemcget test -tags] } -result {{test a b c} {test a b c}} test canvasText-1.17 {configuration options: bad value for "angle"} -body { .c itemconfigure test -angle xyz } -returnCodes error -result {expected floating-point number but got "xyz"} test canvasText-1.18 {configuration options: good value for "angle"} -body { .c itemconfigure test -angle 32.5 list [lindex [.c itemconfigure test -angle] 4] [.c itemcget test -angle] } -result {32.5 32.5} test canvasText-1.19 {configuration options: bounding of "angle"} -body { .c itemconfigure test -angle 390 set result [.c itemcget test -angle] .c itemconfigure test -angle -30 lappend result [.c itemcget test -angle] .c itemconfigure test -angle -360 lappend result [.c itemcget test -angle] } -result {30.0 330.0 0.0} .c delete test test canvText-2.1 {CreateText procedure: args} -body { .c create text } -returnCodes {error} -result {wrong # args: should be ".c create text coords ?arg ...?"} test canvText-2.2 {CreateText procedure: args} -body { .c create text xyz 0 } -cleanup { .c delete all } -returnCodes {error} -result {bad screen distance "xyz"} test canvText-2.3 {CreateText procedure: args} -body { .c create text 0 xyz } -cleanup { .c delete all } -returnCodes {error} -result {bad screen distance "xyz"} test canvText-2.4 {CreateText procedure: args} -body { .c create text 0 0 -xyz xyz } -cleanup { .c delete all } -returnCodes {error} -result {unknown option "-xyz"} test canvText-2.5 {CreateText procedure} -body { .c create text 0 0 -tags x .c coords x } -cleanup { .c delete x } -result {0.0 0.0} test canvText-3.1 {TextCoords procedure} -body { .c create text 20 20 -tag test .c coords test 0 0 update .c coords test } -cleanup { .c delete test } -result {0.0 0.0} test canvText-3.2 {TextCoords procedure} -setup { .c create text 20 20 -tag test } -body { .c coords test xyz 0 } -cleanup { .c delete test } -returnCodes {error} -result {bad screen distance "xyz"} test canvText-3.3 {TextCoords procedure} -setup { .c create text 20 20 -tag test } -body { .c coords test 0 xyz } -cleanup { .c delete test } -returnCodes {error} -result {bad screen distance "xyz"} test canvText-3.4 {TextCoords procedure} -setup { .c create text 20 20 -tag test } -body { .c coords test 10 10 set result {} foreach element [.c coords test] { lappend result [format %.1f $element] } return $result } -cleanup { .c delete test } -result {10.0 10.0} test canvText-3.5 {TextCoords procedure} -setup { .c create text 20 20 -tag test } -body { .c coords test 10 } -cleanup { .c delete test } -returnCodes {error} -result {wrong # coordinates: expected 2, got 1} test canvText-3.6 {TextCoords procedure} -setup { .c create text 20 20 -tag test } -body { .c coords test 10 10 10 } -cleanup { .c delete test } -returnCodes {error} -result {wrong # coordinates: expected 0 or 2, got 3} test canvText-4.1 {ConfigureText procedure} -setup { .c create text 20 20 -tag test } -body { .c itemconfig test -fill xyz } -cleanup { .c delete test } -returnCodes {error} -result {unknown color name "xyz"} test canvText-4.2 {ConfigureText procedure} -setup { .c create text 20 20 -tag test } -body { .c itemconfig test -fill blue .c itemcget test -fill } -cleanup { .c delete test } -result {blue} test canvText-4.3 {ConfigureText procedure: construct font gcs} -setup { .c create text 20 20 -tag test } -body { .c itemconfig test -font "times 20" -fill black -stipple gray50 list [.c itemcget test -font] [.c itemcget test -fill] [.c itemcget test -stipple] } -cleanup { .c delete test } -result {{times 20} black gray50} test canvText-4.4 {ConfigureText procedure: construct cursor gc} -setup { .c create text 20 20 -tag test focus .c .c focus test } -body { .c itemconfig test -text "abcdefg" .c select from test 2 .c select to test 4 .c icursor test 3 # Both black -> cursor becomes white. .c config -insertbackground black .c config -selectbackground black .c itemconfig test -just left update # Both same color (and not black) -> cursor becomes black. .c config -insertbackground red .c config -selectbackground red .c itemconfig test -just left update } -cleanup { .c delete test } -result {} test canvText-4.5 {ConfigureText procedure: adjust selection} -setup { .c create text 20 20 -tag test focus .c .c focus test set x {} } -body { .c itemconfig test -text "abcdefghi" .c select from test 2 .c select to test 6 lappend x [selection get] .c dchars test 1 end lappend x [catch {selection get}] .c insert test end "bcdefghi" .c select from test 2 .c select to test 6 lappend x [selection get] .c dchars test 4 end lappend x [selection get] .c insert test end "efghi" .c select from test 6 .c select to test 2 lappend x [selection get] .c dchars test 4 end lappend x [selection get] } -cleanup { .c delete test } -result {cdefg 1 cdefg cd cdef cd} test canvText-4.6 {ConfigureText procedure: adjust cursor} -setup { .c create text 20 20 -tag test } -body { .c itemconfig test -text "abcdefghi" .c icursor test 6 .c dchars test 4 end .c index test insert } -cleanup { .c delete test } -result {4} test canvText-5.1 {ConfigureText procedure: adjust cursor} -body { .c create text 10 10 -tag x -fill blue -font "times 40" -stipple gray50 \ -text "xyz" .c delete x } -result {} test canvText-6.1 {ComputeTextBbox procedure} -constraints fonts -setup { .c delete test } -body { set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*" set ay [font metrics $font -linespace] set ax [font measure $font 0] .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"} } -cleanup { .c delete test } -result 1 test canvText-6.2 {ComputeTextBbox procedure} -constraints fonts -setup { .c delete test } -body { set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*" set ay [font metrics $font -linespace] set ax [font measure $font 0] .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"} } -cleanup { .c delete test } -result 1 test canvText-6.3 {ComputeTextBbox procedure} -constraints fonts -setup { .c delete test } -body { set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*" set ay [font metrics $font -linespace] set ax [font measure $font 0] .c create text 0 0 -tag test .c itemconfig test -font $font -text 0 expr {[.c itemconfig test -anchor w; .c bbox test] \ eq "-1 [expr -$ay/2] [expr $ax+1] [expr $ay/2]"} } -cleanup { .c delete test } -result 1 test canvText-6.4 {ComputeTextBbox procedure} -constraints fonts -setup { .c delete test } -body { set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*" set ay [font metrics $font -linespace] set ax [font measure $font 0] .c create text 0 0 -tag test .c itemconfig test -font $font -text 0 expr {[.c itemconfig test -anchor sw; .c bbox test] \ eq "-1 -$ay [expr $ax+1] 0"} } -cleanup { .c delete test } -result 1 test canvText-6.5 {ComputeTextBbox procedure} -constraints fonts -setup { .c delete test } -body { set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*" set ay [font metrics $font -linespace] set ax [font measure $font 0] .c create text 0 0 -tag test .c itemconfig test -font $font -text 0 expr {[.c itemconfig test -anchor s; .c bbox test] \ eq "[expr -$ax/2-1] -$ay [expr $ax/2+1] 0"} } -cleanup { .c delete test } -result 1 test canvText-6.6 {ComputeTextBbox procedure} -constraints fonts -setup { .c delete test } -body { set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*" set ay [font metrics $font -linespace] set ax [font measure $font 0] .c create text 0 0 -tag test .c itemconfig test -font $font -text 0 expr {[.c itemconfig test -anchor se; .c bbox test] \ eq "[expr -$ax-1] -$ay 1 0"} } -cleanup { .c delete test } -result 1 test canvText-6.7 {ComputeTextBbox procedure} -constraints fonts -setup { .c delete test } -body { set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*" set ay [font metrics $font -linespace] set ax [font measure $font 0] .c create text 0 0 -tag test .c itemconfig test -font $font -text 0 expr {[.c itemconfig test -anchor e; .c bbox test]\ eq "[expr -$ax-1] [expr -$ay/2] 1 [expr $ay/2]"} } -cleanup { .c delete test } -result 1 test canvText-6.8 {ComputeTextBbox procedure} -constraints fonts -setup { .c delete test } -body { set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*" set ay [font metrics $font -linespace] set ax [font measure $font 0] .c create text 0 0 -tag test .c itemconfig test -font $font -text 0 expr {[.c itemconfig test -anchor ne; .c bbox test] \ eq "[expr -$ax-1] 0 1 $ay"} } -cleanup { .c delete test } -result 1 test canvText-6.9 {ComputeTextBbox procedure} -constraints fonts -setup { .c delete test } -body { set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*" set ay [font metrics $font -linespace] set ax [font measure $font 0] .c create text 0 0 -tag test .c itemconfig test -font $font -text 0 expr {[.c itemconfig test -anchor center; .c bbox test] \ eq "[expr -$ax/2-1] [expr -$ay/2] [expr $ax/2+1] [expr $ay/2]"} } -cleanup { .c delete test } -result 1 #.c delete test #.c create text 20 20 -tag test #focus -force .c #.c focus test focus .c .c focus test .c itemconfig test -text "abcd\nefghi\njklmnopq" test canvText-7.1 {DisplayText procedure: stippling} -body { .c create text 20 20 -tag test .c itemconfig test -stipple gray50 update .c itemconfig test -stipple {} update } -cleanup { .c delete test } -result {} test canvText-7.2 {DisplayText procedure: draw selection} -setup { .c create text 20 20 -tag test focus .c .c focus test } -body { .c itemconfig test -text "abcd\nefghi\njklmnopq" .c select from test 0 .c select to test end update selection get } -cleanup { .c delete test } -result "abcd\nefghi\njklmnopq" test canvText-7.3 {DisplayText procedure: selection} -setup { .c create text 20 20 -tag test focus .c .c focus test } -body { .c itemconfig test -text "abcd\nefghi\njklmnopq" .c select from test 0 .c select to test end update selection get } -cleanup { .c delete test } -result "abcd\nefghi\njklmnopq" test canvText-7.4 {DisplayText procedure: one line selection} -setup { .c create text 20 20 -tag test focus .c .c focus test } -body { .c itemconfig test -text "abcd\nefghi\njklmnopq" .c select from test 2 .c select to test 3 update } -cleanup { .c delete test } -result {} test canvText-7.5 {DisplayText procedure: multi-line selection} -setup { .c create text 20 20 -tag test focus .c .c focus test } -body { .c itemconfig test -text "abcd\nefghi\njklmnopq" .c select from test 2 .c select to test 12 update } -cleanup { .c delete test } -result {} test canvText-7.6 {DisplayText procedure: draw cursor} -setup { .c create text 20 20 -tag test focus .c .c focus test } -body { .c itemconfig test -text "abcd\nefghi\njklmnopq" .c icursor test 3 update } -cleanup { .c delete test } -result {} test canvText-7.7 {DisplayText procedure: selected text different color} -setup { .c create text 20 20 -tag test .c itemconfig test -text "abcd\nefghi\njklmnopq" focus .c .c focus test } -body { .c config -selectforeground blue .c itemconfig test -anchor n update } -cleanup { .c delete test } -result {} test canvText-7.8 {DisplayText procedure: not selected} -setup { .c create text 20 20 -tag test .c itemconfig test -text "abcd\nefghi\njklmnopq" focus .c .c focus test } -body { .c select clear update } -cleanup { .c delete test } -result {} test canvText-7.9 {DisplayText procedure: select end} -setup { destroy .t } -body { toplevel .t wm geometry .t +0+0 canvas .t.c pack .t.c set id [.t.c create text 0 0 -text Dummy -anchor nw] update .t.c select from $id 0 .t.c select to $id end update #catch {destroy .t} update } -cleanup { destroy .t } -result {} test canvText-8.1 {TextInsert procedure: 0 length insert} -setup { .c create text 20 20 -tag test .c itemconfig test -text "abcd\nefghi\njklmnopq" focus .c .c focus test } -body { .c insert test end {} } -cleanup { .c delete test } -result {} test canvText-8.2 {TextInsert procedure: before beginning/after end} -body { # Can't test this because GetTextIndex filters out those numbers. } -result {} test canvText-8.3 {TextInsert procedure: inserting in a selected item} -setup { .c create text 20 20 -tag test focus .c .c focus test } -body { .c itemconfig test -text "abcdefg" .c select from test 2 .c select to test 4 .c insert test 1 "xyz" .c itemcget test -text } -result {axyzbcdefg} test canvText-8.4 {TextInsert procedure: inserting before selection} -setup { .c create text 20 20 -tag test focus .c .c focus test } -body { .c itemconfig test -text "abcdefg" .c select from test 2 .c select to test 4 .c insert test 1 "xyz" list [.c index test sel.first] [.c index test sel.last] } -result {5 7} test canvText-8.5 {TextInsert procedure: inserting in selection} -setup { .c create text 20 20 -tag test focus .c .c focus test } -body { .c itemconfig test -text "abcdefg" .c select from test 2 .c select to test 4 .c insert test 3 "xyz" list [.c index test sel.first] [.c index test sel.last] } -result {2 7} test canvText-8.6 {TextInsert procedure: inserting after selection} -setup { .c create text 20 20 -tag test focus .c .c focus test } -body { .c itemconfig test -text "abcdefg" .c select from test 2 .c select to test 4 .c insert test 5 "xyz" list [.c index test sel.first] [.c index test sel.last] } -result {2 4} test canvText-8.7 {TextInsert procedure: inserting in unselected item} -setup { .c create text 20 20 -tag test focus .c .c focus test } -body { .c itemconfig test -text "abcdefg" .c select clear .c insert test 5 "xyz" .c itemcget test -text } -result {abcdexyzfg} test canvText-8.8 {TextInsert procedure: inserting before cursor} -setup { .c create text 20 20 -tag test focus .c .c focus test } -body { .c itemconfig test -text "abcdefg" .c icursor test 3 .c insert test 2 "xyz" .c index test insert } -result {6} test canvText-8.9 {TextInsert procedure: inserting after cursor} -setup { .c create text 20 20 -tag test focus .c .c focus test } -body { .c itemconfig test -text "abcdefg" .c icursor test 3 .c insert test 4 "xyz" .c index test insert } -result {3} # Item used in 9.* tests .c create text 20 20 -tag test test canvText-9.1 {TextInsert procedure: before beginning/after end} -body { # Can't test this because GetTextIndex filters out those numbers. } -result {} test canvText-9.2 {TextInsert procedure: start > end} -body { .c itemconfig test -text "abcdefg" .c dchars test 4 2 .c itemcget test -text } -result {abcdefg} test canvText-9.3 {TextInsert procedure: deleting from a selected item} -body { .c itemconfig test -text "abcdefg" .c select from test 2 .c select to test 4 .c dchars test 3 5 .c itemcget test -text } -result {abcg} test canvText-9.4 {TextInsert procedure: deleting before start} -body { .c itemconfig test -text "abcdefghijk" .c select from test 4 .c select to test 8 .c dchars test 1 1 list [.c index test sel.first] [.c index test sel.last] } -result {3 7} test canvText-9.5 {TextInsert procedure: keep start > first char deleted} -body { .c itemconfig test -text "abcdefghijk" .c select from test 4 .c select to test 8 .c dchars test 2 6 list [.c index test sel.first] [.c index test sel.last] } -result {2 3} test canvText-9.6 {TextInsert procedure: deleting inside selection} -body { .c itemconfig test -text "abcdefghijk" .c select from test 4 .c select to test 8 .c dchars test 6 6 list [.c index test sel.first] [.c index test sel.last] } -result {4 7} test canvText-9.7 {TextInsert procedure: keep end > first char deleted} -body { .c itemconfig test -text "abcdefghijk" .c select from test 4 .c select to test 8 .c dchars test 6 10 list [.c index test sel.first] [.c index test sel.last] } -result {4 5} test canvText-9.8 {TextInsert procedure: selectFirst > selectLast: deselect} -body { .c itemconfig test -text "abcdefghijk" .c select from test 4 .c select to test 8 .c dchars test 3 10 .c index test sel.first } -returnCodes {error} -result {selection isn't in item} test canvText-9.9 {TextInsert procedure: selectFirst <= selectLast} -body { .c itemconfig test -text "abcdefghijk" .c select from test 4 .c select to test 8 .c dchars test 4 7 list [.c index test sel.first] [.c index test sel.last] } -result {4 4} test canvText-9.10 {TextInsert procedure: move anchor} -body { .c itemconfig test -text "abcdefghijk" .c select from test 6 .c select to test 8 .c dchars test 2 4 .c select to test 1 list [.c index test sel.first] [.c index test sel.last] } -result {1 2} test canvText-9.11 {TextInsert procedure: keep anchor >= first} -body { .c itemconfig test -text "abcdefghijk" .c select from test 6 .c select to test 8 .c dchars test 5 7 .c select to test 1 list [.c index test sel.first] [.c index test sel.last] } -result {1 4} test canvText-9.12 {TextInsert procedure: anchor doesn't move} -body { .c itemconfig test -text "abcdefghijk" .c select from test 2 .c select to test 5 .c dchars test 6 8 .c select to test 8 list [.c index test sel.first] [.c index test sel.last] } -result {2 8} test canvText-9.13 {TextInsert procedure: move cursor} -body { .c itemconfig test -text "abcdefghijk" .c icursor test 6 .c dchars test 2 4 .c index test insert } -result {3} test canvText-9.14 {TextInsert procedure: keep cursor >= first} -body { .c itemconfig test -text "abcdefghijk" .c icursor test 6 .c dchars test 2 10 .c index test insert } -result {2} test canvText-9.15 {TextInsert procedure: cursor doesn't move} -body { .c itemconfig test -text "abcdefghijk" .c icursor test 5 .c dchars test 7 9 .c index test insert } -result {5} .c delete test test canvText-10.1 {TextToPoint procedure} -body { .c create text 0 0 -tag test .c itemconfig test -text 0 -anchor center .c index test @0,0 } -cleanup { .c delete test } -result {0} test canvText-11.1 {TextToArea procedure} -setup { .c create text 0 0 -tag test focus .c .c focus test } -body { .c itemconfig test -text 0 -anchor center set res1 [.c find overlapping 0 0 1 1] set res2 [.c find withtag test] expr {$res1 eq $res2} } -cleanup { .c delete test } -result 1 test canvText-11.2 {TextToArea procedure} -setup { .c create text 0 0 -tag test focus .c .c focus test } -body { .c itemconfig test -text 0 -anchor center .c find overlapping 1000 1000 1001 1001 } -cleanup { .c delete test } -result {} test canvText-12.1 {ScaleText procedure} -body { .c create text 100 100 -tag test .c scale all 50 50 2 2 format {%.6g %.6g} {*}[.c coords test] } -cleanup { .c delete test } -result {150 150} test canvText-13.1 {TranslateText procedure} -body { .c create text 100 100 -tag test .c move all 10 10 format {%.6g %.6g} {*}[.c coords test] } -cleanup { .c delete test } -result {110 110} test canvText-14.1 {GetTextIndex procedure} -setup { .c create text 0 0 -tag test focus .c .c focus test } -body { .c itemconfig test -text "abcdefghijklmno" -anchor nw .c select from test 5 .c select to test 8 .c icursor test 12 .c coords test 0 0 list [.c index test end] [.c index test insert] \ [.c index test sel.first] [.c index test sel.last] \ [.c index test @0,0] \ [.c index test -1] [.c index test 10] [.c index test 100] } -cleanup { .c delete test } -result {15 12 5 8 0 0 10 15} test canvText-14.2 {GetTextIndex procedure: select error} -setup { .c create text 0 0 -tag test focus .c .c focus test } -body { .c select clear .c index test sel.first } -cleanup { .c delete test } -returnCodes {error} -result {selection isn't in item} test canvText-14.3 {GetTextIndex procedure: select error} -setup { .c create text 0 0 -tag test focus .c .c focus test } -body { .c select clear .c index test sel.last } -cleanup { .c delete test } -returnCodes {error} -result {selection isn't in item} test canvText-14.4 {GetTextIndex procedure: select error} -setup { .c create text 0 0 -tag test focus .c .c focus test } -body { .c select clear .c index test sel. } -cleanup { .c delete test } -returnCodes {error} -result {bad index "sel."} test canvText-14.5 {GetTextIndex procedure: bad int or unknown index} -setup { .c create text 0 0 -tag test focus .c .c focus test } -body { .c index test xyz } -cleanup { .c delete test } -returnCodes {error} -result {bad index "xyz"} test canvText-14.6 {select clear errors} -setup { .c create text 0 0 -tag test } -body { .c select clear test } -cleanup { .c delete test } -returnCodes error -result "wrong \# args: should be \".c select clear\"" test canvText-15.1 {SetTextCursor procedure} -setup { .c create text 0 0 -tag test focus .c .c focus test } -body { .c itemconfig test -text "abcdefghijklmno" -anchor nw .c itemconfig -text "abcdefg" .c icursor test 3 .c index test insert } -cleanup { .c delete test } -result {3} test canvText-16.1 {GetSelText procedure} -setup { .c create text 0 0 -tag test focus .c .c focus test } -body { .c itemconfig test -text "abcdefghijklmno" -anchor nw .c select from test 5 .c select to test 8 selection get } -cleanup { .c delete test } -result {fghi} test canvText-17.1 {TextToPostscript procedure} -setup { .c delete all set result {findfont [font actual $font -size] scalefont ISOEncode setfont 0.000 0.000 0.000 setrgbcolor AdjustColor 0 100 200 \[ \[(000)\] \[(000)\] \[(00)\] \] $ay -0.5 0 0 false DrawText grestore restore showpage %%Trailer end %%EOF } } -body { set font {Courier 12 italic} set ax [font measure $font 0] set ay [font metrics $font -linespace] .c config -height 300 -highlightthickness 0 -bd 0 update .c create text 100 100 -tags test .c itemconfig test -font $font -text "00000000" -width [expr 3*$ax] .c itemconfig test -anchor n -fill black set x [.c postscript] set x [string range $x [string first "findfont " $x] end] expr {$x eq [subst $result] ? "ok" : $x} } -result ok test canvText-18.1 {bug fix 2525, find enclosed on text with newlines} -setup { destroy .c } -body { pack [canvas .c] .c create text 100 100 -text Hello\n -anchor nw set bbox [.c bbox 1] set x2 [lindex $bbox 2] set y2 [lindex $bbox 3] incr y2 update .c find enclosed 99 99 [expr $x2 + 1] [expr $y2 + 1] } -cleanup { destroy .c unset -nocomplain bbox x2 y2 } -result 1 test canvText-19.1 {patch 1006286, leading space caused wrap under Win32} -setup { destroy .c set c [canvas .c -bg black -width 964] pack $c $c delete all after 100 "set done 1"; vwait done } -body { set f {Arial 28 bold} set s1 { Yeah-ah-ah-ah-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-Yow} set s2 { Yeah ah ah ah oh oh oh oh oh oh oh oh oh oh oh oh oh oh oh oh Yow} $c create text 21 18 \ -font $f \ -text $s1 \ -fill white \ -width 922 \ -anchor nw \ -tags tbox1 $c create rect {*}[$c bbox tbox1] -outline red $c create text 21 160 \ -font $f \ -text $s2 \ -fill white \ -width 922 \ -anchor nw \ -tags tbox2 $c create rect {*}[$c bbox tbox2] -outline red after 500 "set done 1" ; vwait done set results [list] $c select from tbox2 4 $c select to tbox2 8 lappend results [selection get] $c select from tbox1 4 $c select to tbox1 8 lappend results [selection get] array set metrics [font metrics $f] set x [expr {21 + [font measure $f " "] \ + ([font measure {Arial 28 bold} "Y"] / 2)}] set y1 [expr {18 + ($metrics(-linespace) / 2)}] set y2 [expr {160 + ($metrics(-linespace) / 2)}] lappend results [$c index tbox1 @$x,$y1] lappend results [$c index tbox2 @$x,$y2] } -cleanup { destroy .c } -result {{Yeah } Yeah- 4 4} test canvText-20.1 {angled text bounding box} -setup { destroy .c canvas .c proc transpose {bbox} { lassign $bbox a b c d list $b $a $d $c } } -body { .c create text 2 2 -tag t -anchor center -text 0 -font {Helvetica 24} set bb0 [.c bbox t] .c itemconf t -angle 90 set bb1 [.c bbox t] .c itemconf t -angle 180 set bb2 [.c bbox t] .c itemconf t -angle 270 set bb3 [.c bbox t] list [expr {$bb0 eq $bb2 ? "ok" : "$bb0,$bb2"}] \ [expr {$bb1 eq $bb3 ? "ok" : "$bb1,$bb3"}] \ [expr {$bb0 eq [transpose $bb1] ? "ok" : "$bb0,$bb1"}] \ } -cleanup { destroy .c rename transpose {} } -result {ok ok ok} # cleanup cleanupTests return tk8.6.5/tests/winDialog.test0000755003604700454610000007142612634004673014470 0ustar dgp771div# -*- tcl -*- # This file is a Tcl script to test the Windows specific behavior of # the common dialog boxes. It is organized in the standard # fashion for Tcl tests. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 1998-1999 ActiveState Corporation. package require tcltest 2.2 namespace import ::tcltest::* tcltest::configure {*}$argv tcltest::loadTestedCommands if {[testConstraint testwinevent]} { catch {testwinevent debug 1} } # Locale identifier LANG_ENGLISH is 0x09 testConstraint english [expr { [llength [info commands testwinlocale]] && (([testwinlocale] & 0xff) == 9) }] proc vista? {{prevista 0} {postvista 1}} { lassign [split $::tcl_platform(osVersion) .] major return [expr {$major >= 6 ? $postvista : $prevista}] } # What directory to use in initialdir tests. Old code used to use # c:/. However, on Vista/later that is a protected directory if you # are not running privileged. Moreover, not everyone has a drive c: # but not having a TEMP would break a lot Windows programs proc initialdir {} { # file join to return in Tcl canonical format (/ separator, not \) #return [file join $::env(TEMP)] return [tcltest::temporaryDirectory] } proc start {arg} { set ::tk_dialog 0 set ::iter_after 0 set ::dialogclass "#32770" after 1 $arg } proc then {cmd} { set ::command $cmd set ::dialogresult {} set ::testfont {} # Do not make the delay too short. The newer Vista dialogs take # time to come up. Even if the testforwindow returns true, the # controls are not ready to accept messages after 500 afterbody vwait ::dialogresult return $::dialogresult } proc afterbody {} { # On Vista and later, using the new file dialogs we have to find # the window using its title as tk_dialog will not be set at the C level if {[vista?]} { if {[catch {testfindwindow "" $::dialogclass} ::tk_dialog]} { if {[incr ::iter_after] > 30} { set ::dialogresult ">30 iterations waiting on tk_dialog" return } after 150 {afterbody} return } } else { if {$::tk_dialog == 0} { if {[incr ::iter_after] > 30} { set ::dialogresult ">30 iterations waiting on tk_dialog" return } after 150 {afterbody} return } } uplevel #0 {set dialogresult [eval $command]} } proc Click {button} { switch -exact -- $button { ok { set button 1 } cancel { set button 2 } } testwinevent $::tk_dialog $button WM_LBUTTONDOWN 1 0x000a000b testwinevent $::tk_dialog $button WM_LBUTTONUP 0 0x000a000b } proc GetText {id} { switch -exact -- $id { ok { set id 1 } cancel { set id 2 } } return [testwinevent $::tk_dialog $id WM_GETTEXT] } proc SetText {id text} { return [testwinevent $::tk_dialog $id WM_SETTEXT $text] } proc ApplyFont {font} { set ::testfont $font } # ---------------------------------------------------------------------- test winDialog-1.1 {Tk_ChooseColorObjCmd} -constraints { testwinevent } -body { start {tk_chooseColor} then { Click cancel } } -result {0} test winDialog-1.2 {Tk_ChooseColorObjCmd} -constraints { testwinevent } -body { start {set clr [tk_chooseColor -initialcolor "#ff9933"]} then { set x [Click cancel] } list $x $clr } -result {0 {}} test winDialog-1.3 {Tk_ChooseColorObjCmd} -constraints { testwinevent } -body { start {set clr [tk_chooseColor -initialcolor "#ff9933"]} then { set x [Click ok] } list $x $clr } -result [list 0 "#ff9933"] test winDialog-1.4 {Tk_ChooseColorObjCmd: -title} -constraints { testwinevent } -setup { catch {unset a x} } -body { set x {} start {set clr [tk_chooseColor -initialcolor "#ff9933" -title "Hello"]} then { if {[catch { array set a [testgetwindowinfo $::tk_dialog] if {[info exists a(text)]} {lappend x $a(text)} } err]} { lappend x $err } lappend x [Click ok] } lappend x $clr } -result [list Hello 0 "#ff9933"] test winDialog-1.5 {Tk_ChooseColorObjCmd: -title} -constraints { testwinevent } -setup { catch {unset a x} } -body { set x {} start { set clr [tk_chooseColor -initialcolor "#ff9933" \ -title "\u041f\u0440\u0438\u0432\u0435\u0442"] } then { if {[catch { array set a [testgetwindowinfo $::tk_dialog] if {[info exists a(text)]} {lappend x $a(text)} } err]} { lappend x $err } lappend x [Click ok] } lappend x $clr } -result [list "\u041f\u0440\u0438\u0432\u0435\u0442" 0 "#ff9933"] test winDialog-1.6 {Tk_ChooseColorObjCmd: -parent} -constraints { testwinevent } -setup { catch {unset a x} } -body { start {set clr [tk_chooseColor -initialcolor "#ff9933" -parent .]} set x {} then { if {[catch { array set a [testgetwindowinfo $::tk_dialog] if {[info exists a(parent)]} { append x [expr {$a(parent) == [wm frame .]}] } } err]} {lappend x $err} Click ok } list $x $clr } -result [list 1 "#ff9933"] test winDialog-1.7 {Tk_ChooseColorObjCmd: -parent} -constraints { testwinevent } -body { tk_chooseColor -initialcolor "#ff9933" -parent .xyzzy12 } -returnCodes error -match glob -result {bad window path name*} test winDialog-2.1 {ColorDlgHookProc} -constraints {emptyTest nt} -body {} test winDialog-3.1 {Tk_GetOpenFileObjCmd} -constraints { nt testwinevent english } -body { start {tk_getOpenFile} then { set x [GetText cancel] Click cancel } return $x } -result {Cancel} test winDialog-4.1 {Tk_GetSaveFileObjCmd} -constraints { nt testwinevent english } -body { start {tk_getSaveFile} then { set x [GetText cancel] Click cancel } return $x } -result {Cancel} test winDialog-5.1 {GetFileName: no arguments} -constraints { nt testwinevent } -body { start {tk_getOpenFile -title Open} then { Click cancel } } -result {0} test winDialog-5.2 {GetFileName: one argument} -constraints { nt } -body { tk_getOpenFile -foo } -returnCodes error -result {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -multiple, -parent, -title, or -typevariable} test winDialog-5.3 {GetFileName: many arguments} -constraints { nt testwinevent } -body { start {tk_getOpenFile -initialdir [initialdir] -parent . -title test -initialfile foo} then { Click cancel } } -result {0} test winDialog-5.4 {GetFileName: Tcl_GetIndexFromObj() != TCL_OK} -constraints { nt } -body { tk_getOpenFile -foo bar -abc } -returnCodes error -result {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -multiple, -parent, -title, or -typevariable} test winDialog-5.5 {GetFileName: Tcl_GetIndexFromObj() == TCL_OK} -constraints { nt testwinevent } -body { start {set x [tk_getOpenFile -title bar]} set y [then { Click cancel }] # Note this also tests fix for # http://core.tcl.tk/tk/tktview/4a0451f5291b3c9168cc560747dae9264e1d2ef6 # $x is expected to be empty append x $y } -result {0} test winDialog-5.6 {GetFileName: valid option, but missing value} -constraints { nt } -body { tk_getOpenFile -initialdir bar -title } -returnCodes error -result {value for "-title" missing} test winDialog-5.7 {GetFileName: extension begins with .} -constraints { nt testwinevent } -body { start {set x [tk_getSaveFile -defaultextension .foo -title Save]} set msg {} then { if {[catch {SetText [vista? 0x47C 0x3e9] bar} msg]} { Click cancel } else { Click ok } } set x "[file tail $x]$msg" } -cleanup { unset msg } -result bar.foo test winDialog-5.7.1 {GetFileName: extension {} } -constraints { nt testwinevent } -body { start {set x [tk_getSaveFile -defaultextension {} -title Save]} set msg {} then { if {[catch {SetText [vista? 0x47C 0x3e9] bar} msg]} { Click cancel } else { Click ok } } set x "[file tail $x]$msg" } -cleanup { unset msg } -result bar test winDialog-5.7.2 {GetFileName: extension {} Bug 47af31bd3ac6fbbb33cde1a5bab1e756ff2a6e00 } -constraints { nt testwinevent } -body { start {set x [tk_getSaveFile -filetypes {{All *}} -defaultextension {} -title Save]} set msg {} then { if {[catch {SetText [vista? 0x47C 0x3e9] bar} msg]} { Click cancel } else { Click ok } } set x "[file tail $x]$msg" } -cleanup { unset msg } -result bar test winDialog-5.7.3 {GetFileName: extension {} Bug 47af31bd3ac6fbbb33cde1a5bab1e756ff2a6e00 } -constraints { nt testwinevent } -body { start {set x [tk_getSaveFile -filetypes {{All *}} -defaultextension {} -title Save]} set msg {} then { if {[catch {SetText [vista? 0x47C 0x3e9] bar.c} msg]} { Click cancel } else { Click ok } } set x "[file tail $x]$msg" } -cleanup { unset msg } -result bar.c test winDialog-5.7.4 {GetFileName: extension {} } -constraints { nt testwinevent } -body { # Although the docs do not explicitly mention, -filetypes seems to # override -defaultextension start {set x [tk_getSaveFile -filetypes {{C .c} {Tcl .tcl}} -defaultextension {foo} -title Save]} set msg {} then { if {[catch {SetText [vista? 0x47C 0x3e9] bar} msg]} { Click cancel } else { Click ok } } set x "[file tail $x]$msg" } -cleanup { unset msg } -result bar.c test winDialog-5.7.5 {GetFileName: extension {} } -constraints { nt testwinevent } -body { # Although the docs do not explicitly mention, -filetypes seems to # override -defaultextension start {set x [tk_getSaveFile -filetypes {{C .c} {Tcl .tcl}} -defaultextension {} -title Save]} set msg {} then { if {[catch {SetText [vista? 0x47C 0x3e9] bar} msg]} { Click cancel } else { Click ok } } set x "[file tail $x]$msg" } -cleanup { unset msg } -result bar.c 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]} set msg {} then { if {[catch {SetText [vista? 0x47C 0x3e9] bar} msg]} { Click cancel } else { Click ok } } set x "[file tail $x]$msg" } -cleanup { unset msg } -result bar.ext test winDialog-5.7.7 {tk_getOpenFile: -defaultextension} -constraints { nt testwinevent } -body { unset -nocomplain x tcltest::makeFile "" "5 7 7.ext" [initialdir] start {set x [tk_getOpenFile \ -defaultextension ext \ -initialdir [file nativename [initialdir]] \ -initialfile "5 7 7" -title Foo]} then { Click ok } return $x } -result [file join [initialdir] "5 7 7.ext"] test winDialog-5.7.8 {tk_getOpenFile: -defaultextension} -constraints { nt testwinevent } -body { unset -nocomplain x tcltest::makeFile "" "5 7 8.ext" [initialdir] start {set x [tk_getOpenFile \ -defaultextension ext \ -initialdir [file nativename [initialdir]] \ -initialfile "5 7 8.ext" -title Foo]} then { Click ok } return $x } -result [file join [initialdir] "5 7 8.ext"] test winDialog-5.8 {GetFileName: extension doesn't begin with .} -constraints { nt testwinevent } -body { start {set x [tk_getSaveFile -defaultextension foo -title Save]} set msg {} then { if {[catch {SetText [vista? 0x47C 0x3e9] bar} msg]} { Click cancel } else { Click ok } } set x "[file tail $x]$msg" } -cleanup { unset msg } -result bar.foo test winDialog-5.9 {GetFileName: file types} -constraints { nt testwinevent } -body { # case FILE_TYPES: start {tk_getSaveFile -filetypes {{"foo files" .foo FOOF}} -title Foo} # XXX - currently disabled for vista style dialogs because the file # types control has no control ID and we don't have a mechanism to # locate it. if {[vista?]} { then { Click cancel } return 1 } else { then { set x [GetText 0x470] Click cancel } return [string equal $x {foo files (*.foo)}] } } -result 1 test winDialog-5.10 {GetFileName: file types: MakeFilter() fails} -constraints { nt } -body { # if (MakeFilter(interp, string, &utfFilterString) != TCL_OK) tk_getSaveFile -filetypes {{"foo" .foo FOO}} } -returnCodes error -result {bad Macintosh file type "FOO"} test winDialog-5.11 {GetFileName: initial directory} -constraints { nt testwinevent } -body { # case FILE_INITDIR: unset -nocomplain x start {set x [tk_getSaveFile \ -initialdir [initialdir] \ -initialfile "12x 455" -title Foo]} then { Click ok } return $x } -result [file join [initialdir] "12x 455"] test winDialog-5.12 {GetFileName: initial directory: Tcl_TranslateFilename()} -constraints { nt } -body { # if (Tcl_TranslateFileName(interp, string, &ds) == NULL) tk_getOpenFile -initialdir ~12x/455 } -returnCodes error -result {user "12x" doesn't exist} test winDialog-5.12.1 {tk_getSaveFile: initial directory: ~} -constraints { nt testwinevent } -body { unset -nocomplain x start {set x [tk_getSaveFile \ -initialdir ~ \ -initialfile "5 12 1" -title Foo]} then { Click ok } return $x } -result [file normalize [file join ~ "5 12 1"]] test winDialog-5.12.2 {tk_getSaveFile: initial directory: ~user} -constraints { nt testwinevent } -body { # Note: this test will fail on Tcl versions 8.6.4 and earlier due # to a bug in file normalize for names of the form ~xxx that # returns the wrong dir on Windows. In particular (in Win8 at # least) it returned /users/Default instead of /users/USERNAME... unset -nocomplain x start {set x [tk_getSaveFile \ -initialdir ~$::tcl_platform(user) \ -initialfile "5 12 2" -title Foo]} then { Click ok } return $x } -result [file normalize [file join ~$::tcl_platform(user) "5 12 2"]] test winDialog-5.12.3 {tk_getSaveFile: initial directory: .} -constraints { nt testwinevent } -body { # Windows remembers dirs from previous selections so use # a subdir for this test, not [initialdir] itself set newdir [tcltest::makeDirectory "5 12 3"] set cur [pwd] try { cd $newdir unset -nocomplain x start {set x [tk_getSaveFile \ -initialdir . \ -initialfile "testfile" -title Foo]} then { Click ok } } finally { cd $cur } string equal $x [file join $newdir testfile] } -result 1 test winDialog-5.12.4 {tk_getSaveFile: initial directory: unicode} -constraints { nt testwinevent } -body { set dir [tcltest::makeDirectory "\u0167\u00e9\u015d\u0167"] unset -nocomplain x start {set x [tk_getSaveFile \ -initialdir $dir \ -initialfile "testfile" -title Foo]} then { Click ok } string equal $x [file join $dir testfile] } -result 1 test winDialog-5.12.5 {tk_getSaveFile: initial directory: nativename} -constraints { nt testwinevent } -body { unset -nocomplain x start {set x [tk_getSaveFile \ -initialdir [file nativename [initialdir]] \ -initialfile "5 12 5" -title Foo]} then { Click ok } return $x } -result [file join [initialdir] "5 12 5"] test winDialog-5.12.6 {tk_getSaveFile: initial directory: relative} -constraints { nt testwinevent } -body { # Windows remembers dirs from previous selections so use # a subdir for this test, not [initialdir] itself set dir [tcltest::makeDirectory "5 12 6"] set cur [pwd] try { cd [file dirname $dir] unset -nocomplain x start {set x [tk_getSaveFile \ -initialdir "5 12 6" \ -initialfile "testfile" -title Foo]} then { Click ok } } finally { cd $cur } string equal $x [file join $dir testfile] } -result 1 test winDialog-5.12.7 {tk_getOpenFile: initial directory: ~} -constraints { nt testwinevent } -body { set fn [file tail [lindex [glob -types f ~/*] 0]] unset -nocomplain x start {set x [tk_getOpenFile \ -initialdir ~ \ -initialfile $fn -title Foo]} then { Click ok } string equal $x [file normalize [file join ~ $fn]] } -result 1 test winDialog-5.12.8 {tk_getOpenFile: initial directory: .} -constraints { nt testwinevent } -body { # Windows remembers dirs from previous selections so use # a subdir for this test, not [initialdir] itself set newdir [tcltest::makeDirectory "5 12 8"] set path [tcltest::makeFile "" "testfile" $newdir] set cur [pwd] try { cd $newdir unset -nocomplain x start {set x [tk_getOpenFile \ -initialdir . \ -initialfile "testfile" -title Foo]} then { Click ok } } finally { cd $cur } string equal $x $path } -result 1 test winDialog-5.12.9 {tk_getOpenFile: initial directory: unicode} -constraints { nt testwinevent } -body { set dir [tcltest::makeDirectory "\u0167\u00e9\u015d\u0167"] set path [tcltest::makeFile "" testfile $dir] unset -nocomplain x start {set x [tk_getOpenFile \ -initialdir $dir \ -initialfile "testfile" -title Foo]} then { Click ok } string equal $x $path } -result 1 test winDialog-5.12.10 {tk_getOpenFile: initial directory: nativename} -constraints { nt testwinevent } -body { unset -nocomplain x tcltest::makeFile "" "5 12 10" [initialdir] start {set x [tk_getOpenFile \ -initialdir [file nativename [initialdir]] \ -initialfile "5 12 10" -title Foo]} then { Click ok } return $x } -result [file join [initialdir] "5 12 10"] test winDialog-5.12.11 {tk_getOpenFile: initial directory: relative} -constraints { nt testwinevent } -body { # Windows remembers dirs from previous selections so use # a subdir for this test, not [initialdir] itself set dir [tcltest::makeDirectory "5 12 11"] set path [tcltest::makeFile "" testfile $dir] set cur [pwd] try { cd [file dirname $dir] unset -nocomplain x start {set x [tk_getOpenFile \ -initialdir [file tail $dir] \ -initialfile "testfile" -title Foo]} then { Click ok } } finally { cd $cur } string equal $x $path } -result 1 test winDialog-5.13 {GetFileName: initial file} -constraints { nt testwinevent } -body { # case FILE_INITFILE: start {set x [tk_getSaveFile -initialfile "12x 456" -title Foo]} then { Click ok } file tail $x } -result "12x 456" test winDialog-5.14 {GetFileName: initial file: Tcl_TranslateFileName()} -constraints { nt } -body { # if (Tcl_TranslateFileName(interp, string, &ds) == NULL) tk_getOpenFile -initialfile ~12x/455 } -returnCodes error -result {user "12x" doesn't exist} if {![vista?]} { # XXX - disabled for Vista because the new dialogs allow long file # names to be specified but force the user to change it. test winDialog-5.15 {GetFileName: initial file: long name} -constraints { nt testwinevent } -body { start { set dialogresult [catch { tk_getSaveFile -initialfile [string repeat a 1024] -title Long } x] } then { Click ok } list $dialogresult [string match "invalid filename *" $x] } -result {1 1} } test winDialog-5.16 {GetFileName: parent} -constraints { nt } -body { # case FILE_PARENT: toplevel .t set x 0 start {tk_getOpenFile -parent .t -title Parent; set x 1} then { destroy .t } return $x } -result {1} test winDialog-5.17 {GetFileName: title} -constraints { nt testwinevent } -body { # case FILE_TITLE: start {tk_getOpenFile -title Narf} then { Click cancel } } -result {0} if {[vista?]} { # In the newer file dialogs, the file type widget does not even exist # if no file types specified test winDialog-5.18 {GetFileName: no filter specified} -constraints { nt testwinevent } -body { # if (ofn.lpstrFilter == NULL) start {tk_getOpenFile -title Filter} then { catch {set x [GetText 0x470]} y Click cancel } return $y } -result {Could not find control with id 1136} } else { test winDialog-5.18 {GetFileName: no filter specified} -constraints { nt testwinevent } -body { # if (ofn.lpstrFilter == NULL) start {tk_getOpenFile -title Filter} then { set x [GetText 0x470] Click cancel } return $x } -result {All Files (*.*)} } test winDialog-5.19 {GetFileName: parent HWND doesn't yet exist} -constraints { nt } -setup { destroy .t } -body { # if (Tk_WindowId(parent) == None) toplevel .t start {tk_getOpenFile -parent .t -title Open} then { destroy .t } } -result {} test winDialog-5.20 {GetFileName: parent HWND already exists} -constraints { nt } -setup { destroy .t } -body { toplevel .t update start {tk_getOpenFile -parent .t -title Open} then { destroy .t } } -result {} test winDialog-5.21 {GetFileName: call GetOpenFileName} -constraints { nt testwinevent english } -body { # winCode = GetOpenFileName(&ofn); start {tk_getOpenFile -title Open} then { set x [GetText ok] Click cancel } return $x } -result {&Open} test winDialog-5.22 {GetFileName: call GetSaveFileName} -constraints { nt testwinevent english } -body { # winCode = GetSaveFileName(&ofn); start {tk_getSaveFile -title Save} then { set x [GetText ok] Click cancel } return $x } -result {&Save} test winDialog-5.23 {GetFileName: convert \ to /} -constraints { nt testwinevent } -body { set msg {} start {set x [tk_getSaveFile -title Back]} then { if {[catch {SetText [vista? 0x47C 0x3e9] [file nativename \ [file join [initialdir] "12x 457"]]} msg]} { Click cancel } else { Click ok } } return $x$msg } -cleanup { unset msg } -result [file join [initialdir] "12x 457"] test winDialog-5.24 {GetFileName: file types: MakeFilter() succeeds} -constraints { nt } -body { # MacOS type that is correct, but has embedded nulls. start {set x [catch {tk_getSaveFile -filetypes {{"foo" .foo {\0\0\0\0}}}}]} then { Click cancel } return $x } -result {0} test winDialog-5.25 {GetFileName: file types: MakeFilter() succeeds} -constraints { nt } -body { # MacOS type that is correct, but has embedded high-bit chars. start {set x [catch {tk_getSaveFile -filetypes {{"foo" .foo {\u2022\u2022\u2022\u2022}}}}]} then { Click cancel } return $x } -result {0} test winDialog-6.1 {MakeFilter} -constraints {emptyTest nt} -body {} test winDialog-7.1 {Tk_MessageBoxObjCmd} -constraints {emptyTest nt} -body {} test winDialog-8.1 {OFNHookProc} -constraints {emptyTest nt} -body {} ## The Tk_ChooseDirectoryObjCmd hang on the static build of Windows ## because somehow the GetOpenFileName ends up a noop in the static ## build. ## test winDialog-9.1 {Tk_ChooseDirectoryObjCmd: no arguments} -constraints { nt testwinevent } -body { start {set x [tk_chooseDirectory]} set y [then { Click cancel }] # $x should be "" on a Cancel append x $y } -result {0} test winDialog-9.2 {Tk_ChooseDirectoryObjCmd: one argument} -constraints { nt } -body { tk_chooseDirectory -foo } -returnCodes error -result {bad option "-foo": must be -initialdir, -mustexist, -parent, or -title} test winDialog-9.3 {Tk_ChooseDirectoryObjCmd: many arguments} -constraints { nt testwinevent } -body { start { tk_chooseDirectory -initialdir [initialdir] -mustexist 1 -parent . -title test } then { Click cancel } } -result {0} test winDialog-9.4 {Tk_ChooseDirectoryObjCmd: Tcl_GetIndexFromObj() != TCL_OK} -constraints { nt } -body { tk_chooseDirectory -foo bar -abc } -returnCodes error -result {bad option "-foo": must be -initialdir, -mustexist, -parent, or -title} test winDialog-9.5 {Tk_ChooseDirectoryObjCmd: Tcl_GetIndexFromObj() == TCL_OK} -constraints { nt testwinevent } -body { start {tk_chooseDirectory -title bar} then { Click cancel } } -result {0} test winDialog-9.6 {Tk_ChooseDirectoryObjCmd: valid option, but missing value} -constraints { nt } -body { tk_chooseDirectory -initialdir bar -title } -returnCodes error -result {value for "-title" missing} test winDialog-9.7 {Tk_ChooseDirectoryObjCmd: -initialdir} -constraints { nt testwinevent } -body { # case DIR_INITIAL: start {set x [tk_chooseDirectory -initialdir [initialdir] -title Foo]} then { Click ok } string tolower [set x] } -result [string tolower [initialdir]] test winDialog-9.8 {Tk_ChooseDirectoryObjCmd: initial directory: Tcl_TranslateFilename()} -constraints { nt } -body { # if (Tcl_TranslateFileName(interp, string, # &utfDirString) == NULL) tk_chooseDirectory -initialdir ~12x/455 } -returnCodes error -result {user "12x" doesn't exist} test winDialog-10.1 {Tk_FontchooserObjCmd: no arguments} -constraints { nt testwinevent } -body { start {tk fontchooser show} list [then { Click cancel }] $::testfont } -result {0 {}} test winDialog-10.2 {Tk_FontchooserObjCmd: -initialfont} -constraints { nt testwinevent } -body { start { tk fontchooser configure -command ApplyFont -font system tk fontchooser show } list [then { Click cancel }] $::testfont } -result {0 {}} test winDialog-10.3 {Tk_FontchooserObjCmd: -initialfont} -constraints { nt testwinevent } -body { start { tk fontchooser configure -command ApplyFont -font system tk fontchooser show } list [then { Click 1 }] [expr {[llength $::testfont] ne {}}] } -result {0 1} test winDialog-10.4 {Tk_FontchooserObjCmd: -title} -constraints { nt testwinevent } -body { start { tk fontchooser configure -command ApplyFont -title "tk test" tk fontchooser show } list [then { Click cancel }] $::testfont } -result {0 {}} test winDialog-10.5 {Tk_FontchooserObjCmd: -parent} -constraints { nt testwinevent } -setup { array set a {parent {}} } -body { start { tk fontchooser configure -command ApplyFont -parent . tk fontchooser show } then { array set a [testgetwindowinfo $::tk_dialog] Click cancel } list [expr {$a(parent) == [wm frame .]}] $::testfont } -result {1 {}} test winDialog-10.6 {Tk_FontchooserObjCmd: -apply} -constraints { nt testwinevent } -body { start { tk fontchooser configure -command FooBarBaz tk fontchooser show } then { Click cancel } } -result 0 test winDialog-10.7 {Tk_FontchooserObjCmd: -apply} -constraints { nt testwinevent } -body { start { tk fontchooser configure -command ApplyFont -parent . tk fontchooser show } list [then { Click [expr {0x0402}] ;# value from XP Click cancel }] [expr {[llength $::testfont] > 0}] } -result {0 1} test winDialog-10.8 {Tk_FontchooserObjCmd: -title} -constraints { nt testwinevent } -setup { array set a {text failed} } -body { start { tk fontchooser configure -command ApplyFont -title "Hello" tk fontchooser show } then { array set a [testgetwindowinfo $::tk_dialog] Click cancel } set a(text) } -result "Hello" test winDialog-10.9 {Tk_FontchooserObjCmd: -title} -constraints { nt testwinevent } -setup { array set a {text failed} } -body { start { tk fontchooser configure -command ApplyFont \ -title "\u041f\u0440\u0438\u0432\u0435\u0442" tk fontchooser show } then { array set a [testgetwindowinfo $::tk_dialog] Click cancel } set a(text) } -result "\u041f\u0440\u0438\u0432\u0435\u0442" if {[testConstraint testwinevent]} { catch {testwinevent debug 0} } # cleanup cleanupTests return # Local variables: # mode: tcl # End: tk8.6.5/tests/scale.test0000644003604700454610000012527612427163302013635 0ustar dgp771div# This file is a Tcl script to test out the "scale" command # of Tk. It is organized in the standard fashion for Tcl tests. # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. package require tcltest 2.2 namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands # Create entries in the option database to be sure that geometry options # like border width have predictable values. option add *Scale.borderWidth 2 option add *Scale.highlightThickness 2 option add *Scale.font {Helvetica -12 bold} # Widget used in 1.* tests scale .s -from 100 -to 300 pack .s update test scale-1.1 {configuration options} -body { .s configure -activebackground #ff0000 .s cget -activebackground } -cleanup { .s configure -activebackground [lindex [.s configure -activebackground] 3] } -result {#ff0000} test scale-1.2 {configuration options} -body { .s configure -activebackground non-existent } -returnCodes error -result {unknown color name "non-existent"} test scale-1.3 {configuration options} -body { .s configure -background #ff0000 .s cget -background } -cleanup { .s configure -background [lindex [.s configure -background] 3] } -result {#ff0000} test scale-1.4 {configuration options} -body { .s configure -background non-existent } -returnCodes error -result {unknown color name "non-existent"} test scale-1.5 {configuration options} -body { .s configure -bd 4 .s cget -bd } -cleanup { .s configure -bd [lindex [.s configure -bd] 3] } -result {4} test scale-1.6 {configuration options} -body { .s configure -bd badValue } -returnCodes error -result {bad screen distance "badValue"} test scale-1.7 {configuration options} -body { .s configure -bigincrement 12.5 .s cget -bigincrement } -cleanup { .s configure -bigincrement [lindex [.s configure -bigincrement] 3] } -result {12.5} test scale-1.8 {configuration options} -body { .s configure -bigincrement badValue } -returnCodes error -result {expected floating-point number but got "badValue"} test scale-1.9 {configuration options} -body { .s configure -bg #ff0000 .s cget -bg } -cleanup { .s configure -bg [lindex [.s configure -bg] 3] } -result {#ff0000} test scale-1.10 {configuration options} -body { .s configure -bg non-existent } -returnCodes error -result {unknown color name "non-existent"} test scale-1.11 {configuration options} -body { .s configure -borderwidth 1.3 .s cget -borderwidth } -cleanup { .s configure -borderwidth [lindex [.s configure -borderwidth] 3] } -result {1} test scale-1.12 {configuration options} -body { .s configure -borderwidth badValue } -returnCodes error -result {bad screen distance "badValue"} test scale-1.13 {configuration options} -body { .s configure -command {set x} .s cget -command } -cleanup { .s configure -command [lindex [.s configure -command] 3] } -result {set x} test scale-1.15 {configuration options} -body { .s configure -cursor arrow .s cget -cursor } -cleanup { .s configure -cursor [lindex [.s configure -cursor] 3] } -result {arrow} test scale-1.16 {configuration options} -body { .s configure -cursor badValue } -returnCodes error -result {bad cursor spec "badValue"} test scale-1.17 {configuration options} -body { .s configure -digits 5 .s cget -digits } -cleanup { .s configure -digits [lindex [.s configure -digits] 3] } -result {5} test scale-1.18 {configuration options} -body { .s configure -digits badValue } -returnCodes error -result {expected integer but got "badValue"} test scale-1.19 {configuration options} -body { .s configure -fg #00ff00 .s cget -fg } -cleanup { .s configure -fg [lindex [.s configure -fg] 3] } -result {#00ff00} test scale-1.20 {configuration options} -body { .s configure -fg badValue } -returnCodes error -result {unknown color name "badValue"} test scale-1.21 {configuration options} -body { .s configure -font fixed .s cget -font } -cleanup { .s configure -font [lindex [.s configure -font] 3] } -result {fixed} test scale-1.23 {configuration options} -body { .s configure -foreground green .s cget -foreground } -cleanup { .s configure -foreground [lindex [.s configure -foreground] 3] } -result {green} test scale-1.24 {configuration options} -body { .s configure -foreground badValue } -returnCodes error -result {unknown color name "badValue"} test scale-1.25 {configuration options} -body { .s configure -from -15.0 .s cget -from } -cleanup { .s configure -from [lindex [.s configure -from] 3] } -result {-15.0} test scale-1.26 {configuration options} -body { .s configure -from badValue } -returnCodes error -result {expected floating-point number but got "badValue"} test scale-1.27 {configuration options} -body { .s configure -highlightbackground #112233 .s cget -highlightbackground } -cleanup { .s configure -highlightbackground [lindex [.s configure -highlightbackground] 3] } -result {#112233} test scale-1.28 {configuration options} -body { .s configure -highlightbackground ugly } -returnCodes error -result {unknown color name "ugly"} test scale-1.29 {configuration options} -body { .s configure -highlightcolor #123456 .s cget -highlightcolor } -cleanup { .s configure -highlightcolor [lindex [.s configure -highlightcolor] 3] } -result {#123456} test scale-1.30 {configuration options} -body { .s configure -highlightcolor non-existent } -returnCodes error -result {unknown color name "non-existent"} test scale-1.31 {configuration options} -body { .s configure -highlightthickness 2 .s cget -highlightthickness } -cleanup { .s configure -highlightthickness [lindex [.s configure -highlightthickness] 3] } -result {2} test scale-1.32 {configuration options} -body { .s configure -highlightthickness badValue } -returnCodes error -result {bad screen distance "badValue"} test scale-1.33 {configuration options} -body { .s configure -label {Some text} .s cget -label } -cleanup { .s configure -label [lindex [.s configure -label] 3] } -result {Some text} test scale-1.35 {configuration options} -body { .s configure -length 130 .s cget -length } -cleanup { .s configure -length [lindex [.s configure -length] 3] } -result {130} test scale-1.36 {configuration options} -body { .s configure -length badValue } -returnCodes error -result {bad screen distance "badValue"} test scale-1.37 {configuration options} -body { .s configure -orient horizontal .s cget -orient } -cleanup { .s configure -orient [lindex [.s configure -orient] 3] } -result {horizontal} test scale-1.38 {configuration options} -body { .s configure -orient badValue } -returnCodes error -result {bad orient "badValue": must be horizontal or vertical} test scale-1.39 {configuration options} -body { .s configure -orient horizontal .s cget -orient } -cleanup { .s configure -orient [lindex [.s configure -orient] 3] } -result {horizontal} test scale-1.41 {configuration options} -body { .s configure -relief ridge .s cget -relief } -cleanup { .s configure -relief [lindex [.s configure -relief] 3] } -result {ridge} test scale-1.42 {configuration options} -body { .s configure -relief badValue } -returnCodes error -result {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken} test scale-1.43 {configuration options} -body { .s configure -repeatdelay 14 .s cget -repeatdelay } -cleanup { .s configure -repeatdelay [lindex [.s configure -repeatdelay] 3] } -result {14} test scale-1.44 {configuration options} -body { .s configure -repeatdelay bogus } -returnCodes error -result {expected integer but got "bogus"} test scale-1.45 {configuration options} -body { .s configure -repeatinterval 14 .s cget -repeatinterval } -cleanup { .s configure -repeatinterval [lindex [.s configure -repeatinterval] 3] } -result {14} test scale-1.46 {configuration options} -body { .s configure -repeatinterval bogus } -returnCodes error -result {expected integer but got "bogus"} test scale-1.47 {configuration options} -body { .s configure -resolution 2.0 .s cget -resolution } -cleanup { .s configure -resolution [lindex [.s configure -resolution] 3] } -result {2.0} test scale-1.48 {configuration options} -body { .s configure -resolution badValue } -returnCodes error -result {expected floating-point number but got "badValue"} test scale-1.49 {configuration options} -body { .s configure -showvalue 0 .s cget -showvalue } -cleanup { .s configure -showvalue [lindex [.s configure -showvalue] 3] } -result {0} test scale-1.50 {configuration options} -body { .s configure -showvalue badValue } -returnCodes error -result {expected boolean value but got "badValue"} test scale-1.51 {configuration options} -body { .s configure -sliderlength 86 .s cget -sliderlength } -cleanup { .s configure -sliderlength [lindex [.s configure -sliderlength] 3] } -result {86} test scale-1.52 {configuration options} -body { .s configure -sliderlength badValue } -returnCodes error -result {bad screen distance "badValue"} test scale-1.53 {configuration options} -body { .s configure -sliderrelief raised .s cget -sliderrelief } -cleanup { .s configure -sliderrelief [lindex [.s configure -sliderrelief] 3] } -result {raised} test scale-1.54 {configuration options} -body { .s configure -sliderrelief badValue } -returnCodes error -result {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken} test scale-1.55 {configuration options} -body { .s configure -state d .s cget -state } -cleanup { .s configure -state [lindex [.s configure -state] 3] } -result {disabled} test scale-1.56 {configuration options} -body { .s configure -state badValue } -returnCodes error -result {bad state "badValue": must be active, disabled, or normal} test scale-1.57 {configuration options} -body { .s configure -state n .s cget -state } -cleanup { .s configure -state [lindex [.s configure -state] 3] } -result {normal} test scale-1.59 {configuration options} -body { .s configure -takefocus {any string} .s cget -takefocus } -cleanup { .s configure -takefocus [lindex [.s configure -takefocus] 3] } -result {any string} test scale-1.61 {configuration options} -body { .s configure -tickinterval 4.3 .s cget -tickinterval } -cleanup { .s configure -tickinterval [lindex [.s configure -tickinterval] 3] } -result {4.0} test scale-1.62 {configuration options} -body { .s configure -tickinterval badValue } -returnCodes error -result {expected floating-point number but got "badValue"} test scale-1.63 {configuration options} -body { .s configure -to 14.9 .s cget -to } -cleanup { .s configure -to [lindex [.s configure -to] 3] } -result {15.0} test scale-1.64 {configuration options} -body { .s configure -to badValue } -returnCodes error -result {expected floating-point number but got "badValue"} test scale-1.65 {configuration options} -body { .s configure -troughcolor #ff0000 .s cget -troughcolor } -cleanup { .s configure -troughcolor [lindex [.s configure -troughcolor] 3] } -result {#ff0000} test scale-1.66 {configuration options} -body { .s configure -troughcolor non-existent } -returnCodes error -result {unknown color name "non-existent"} test scale-1.67 {configuration options} -body { .s configure -variable x .s cget -variable } -cleanup { .s configure -variable [lindex [.s configure -variable] 3] } -result {x} test scale-1.69 {configuration options} -body { .s configure -width 32 .s cget -width } -cleanup { .s configure -width [lindex [.s configure -width] 3] } -result {32} test scale-1.70 {configuration options} -body { .s configure -width badValue } -returnCodes error -result {bad screen distance "badValue"} destroy .s test scale-2.1 {Tk_ScaleCmd procedure} -body { scale } -returnCodes error -result {wrong # args: should be "scale pathName ?-option value ...?"} test scale-2.2 {Tk_ScaleCmd procedure} -body { scale foo } -returnCodes error -result {bad window path name "foo"} test scale-2.3 {Tk_ScaleCmd procedure} -body { catch {scale foo} winfo child . } -result {} test scale-2.4 {Tk_ScaleCmd procedure} -body { scale .s -gorp dumb } -returnCodes error -result {unknown option "-gorp"} test scale-2.5 {Tk_ScaleCmd procedure} -body { catch {scale .s -gorp dumb} winfo child . } -result {} # Widget used in 3.* tests destroy .s scale .s -from 100 -to 200 pack .s update idletasks test scale-3.1 {ScaleWidgetCmd procedure} -body { .s } -returnCodes error -result {wrong # args: should be ".s option ?arg ...?"} test scale-3.2 {ScaleWidgetCmd procedure, cget option} -body { .s cget } -returnCodes error -result {wrong # args: should be ".s cget option"} test scale-3.3 {ScaleWidgetCmd procedure, cget option} -body { .s cget a b } -returnCodes error -result {wrong # args: should be ".s cget option"} test scale-3.4 {ScaleWidgetCmd procedure, cget option} -body { .s cget -gorp } -returnCodes error -result {unknown option "-gorp"} test scale-3.5 {ScaleWidgetCmd procedure, cget option} -body { .s configure -highlightthickness 2 .s cget -highlightthickness } -result {2} test scale-3.6 {ScaleWidgetCmd procedure, configure option} -body { list [llength [.s configure]] [lindex [.s configure] 6] } -result {33 {-command command Command {} {}}} test scale-3.7 {ScaleWidgetCmd procedure, configure option} -body { .s configure -foo } -returnCodes error -result {unknown option "-foo"} test scale-3.8 {ScaleWidgetCmd procedure, configure option} -body { .s configure -borderwidth 2 -bg } -returnCodes error -result {value for "-bg" missing} test scale-3.9 {ScaleWidgetCmd procedure, coords option} -body { .s coords a b } -returnCodes error -result {wrong # args: should be ".s coords ?value?"} test scale-3.10 {ScaleWidgetCmd procedure, coords option} -body { .s coords bad } -returnCodes error -result {expected floating-point number but got "bad"} test scale-3.11 {ScaleWidgetCmd procedure} -constraints { fonts } -body { .s configure -from 100 -to 200 update idletasks .s set 120 .s coords } -result {38 34} test scale-3.12 {ScaleWidgetCmd procedure, coords option} -constraints { fonts } -body { .s configure -from 100 -to 200 -orient horizontal update idletasks .s set 120 .s coords } -result {34 31} test scale-3.13 {ScaleWidgetCmd procedure, get option} -body { .s configure -orient vertical update .s get a } -returnCodes error -result {wrong # args: should be ".s get ?x y?"} test scale-3.14 {ScaleWidgetCmd procedure, get option} -body { .s configure -orient vertical update .s get a b c } -returnCodes error -result {wrong # args: should be ".s get ?x y?"} test scale-3.15 {ScaleWidgetCmd procedure, get option} -body { .s configure -orient vertical update .s get a 11 } -returnCodes error -result {expected integer but got "a"} test scale-3.16 {ScaleWidgetCmd procedure, get option} -body { .s configure -orient vertical update .s get 12 b } -returnCodes error -result {expected integer but got "b"} test scale-3.17 {ScaleWidgetCmd procedure, get option} -body { .s configure -orient vertical update .s set 133 .s get } -result 133 test scale-3.18 {ScaleWidgetCmd procedure, get option} -body { .s configure -orient vertical -resolution 0.5 update .s set 150 .s get 37 34 } -result {119.5} .s configure -resolution 1 test scale-3.19 {ScaleWidgetCmd procedure, identify option} -body { .s identify } -returnCodes error -result {wrong # args: should be ".s identify x y"} test scale-3.20 {ScaleWidgetCmd procedure, identify option} -body { .s identify 1 2 3 } -returnCodes error -result {wrong # args: should be ".s identify x y"} test scale-3.21 {ScaleWidgetCmd procedure, identify option} -body { .s identify boo 16 } -returnCodes error -result {expected integer but got "boo"} test scale-3.22 {ScaleWidgetCmd procedure, identify option} -body { .s identify 17 bad } -returnCodes error -result {expected integer but got "bad"} test scale-3.23 {ScaleWidgetCmd procedure, identify option} -constraints { fonts } -body { .s configure -from 100 -to 200 -orient vertical -resolution 1 update .s set 120 list [.s identify 35 10] [.s identify 35 30] [.s identify 35 80] [.s identify 5 80] } -result {trough1 slider trough2 {}} test scale-3.24 {ScaleWidgetCmd procedure, set option} -body { .s set } -returnCodes error -result {wrong # args: should be ".s set value"} test scale-3.25 {ScaleWidgetCmd procedure, set option} -body { .s set a b } -returnCodes error -result {wrong # args: should be ".s set value"} test scale-3.26 {ScaleWidgetCmd procedure, set option} -body { .s set bad } -returnCodes error -result {expected floating-point number but got "bad"} test scale-3.27 {ScaleWidgetCmd procedure, set option} -body { .s configure -from 100 -to 200 -orient vertical -resolution 0.5 update .s set 142 } -result {} test scale-3.28 {ScaleWidgetCmd procedure, set option} -body { .s configure -from 100 -to 200 -orient vertical -resolution 1 update .s set 118 .s configure -state disabled .s set 181 .s configure -state normal .s get } -result {118} test scale-3.29 {ScaleWidgetCmd procedure} -body { .s dumb } -returnCodes error -result {bad option "dumb": must be cget, configure, coords, get, identify, or set} test scale-3.30 {ScaleWidgetCmd procedure} -body { .s c } -returnCodes error -result {ambiguous option "c": must be cget, configure, coords, get, identify, or set} test scale-3.31 {ScaleWidgetCmd procedure} -body { .s co } -returnCodes error -result {ambiguous option "co": must be cget, configure, coords, get, identify, or set} destroy .s test scale-3.32 {ScaleWidgetCmd procedure, Tk_Preserve} -setup { destroy .s } -body { proc kill args { destroy .s } scale .s -variable x -from 0 -to 100 -orient horizontal pack .s update .s configure -command kill .s set 55 } -cleanup { destroy .s } -result {} test scale-4.1 {DestroyScale procedure} -setup { deleteWindows } -body { set x 50 scale .s -variable x -from 0 -to 100 -orient horizontal pack .s update destroy .s list [catch {set x foo} msg] $msg $x } -result {0 foo foo} test scale-5.1 {ConfigureScale procedure} -setup { deleteWindows } -body { set x 66 set y 77 scale .s -variable x -from 0 -to 100 pack .s update .s configure -variable y list [catch {set x foo} msg] $msg $x [.s get] } -cleanup { deleteWindows } -result {0 foo foo 77} test scale-5.2 {ConfigureScale procedure} -setup { deleteWindows } -body { scale .s -from 0 -to 100 .s configure -foo bar } -cleanup { deleteWindows } -returnCodes error -result {unknown option "-foo"} test scale-5.3 {ConfigureScale procedure} -setup { deleteWindows } -body { catch {unset x} scale .s -from 0 -to 100 -variable x set result $x lappend result [.s get] set x 92 lappend result [.s get] .s set 3 lappend result $x unset x lappend result [set x] } -cleanup { deleteWindows } -result {0 0 92 3 3} test scale-5.4 {ConfigureScale procedure} -setup { deleteWindows } -body { scale .s -from 0 -to 100 .s configure -orient dumb } -cleanup { deleteWindows } -returnCodes error -result {bad orient "dumb": must be horizontal or vertical} test scale-5.5 {ConfigureScale procedure} -setup { deleteWindows } -body { scale .s -from 1.11 -to 1.89 -resolution .1 -tickinterval .76 list [format %.1f [.s cget -from]] [format %.1f [.s cget -to]] \ [format %.1f [.s cget -tickinterval]] } -cleanup { deleteWindows } -result {1.1 1.9 0.8} test scale-5.6 {ConfigureScale procedure} -setup { deleteWindows } -body { scale .s -from 1 -to 10 -tickinterval -2 pack .s set result [lindex [.s configure -tickinterval] 4] .s configure -from 10 -to 1 -tickinterval 2 lappend result [lindex [.s configure -tickinterval] 4] } -cleanup { deleteWindows } -result {2.0 -2.0} test scale-5.7 {ConfigureScale procedure} -setup { deleteWindows } -body { scale .s -from 0 -to 100 -state bogus } -cleanup { deleteWindows } -returnCodes error -result {bad state "bogus": must be active, disabled, or normal} # Widget used in 6.* tests destroy .s scale .s -orient horizontal -length 200 pack .s test scale-6.1 {ComputeFormat procedure} -body { .s configure -from 10 -to 100 -resolution 10 .s set 49.3 .s get } -result {50} test scale-6.2 {ComputeFormat procedure} -body { .s configure -from 100 -to 1000 -resolution 100 .s set 493 .s get } -result {500} test scale-6.3 {ComputeFormat procedure} -body { .s configure -from 1000 -to 10000 -resolution 1000 .s set 4930 .s get } -result {5000} test scale-6.4 {ComputeFormat procedure} -body { .s configure -from 10000 -to 100000 -resolution 10000 .s set 49000 .s get } -result {50000} test scale-6.5 {ComputeFormat procedure} -body { .s configure -from 100000 -to 1000000 -resolution 100000 .s set 493000 .s get } -result {500000} test scale-6.6 {ComputeFormat procedure} -constraints { nonPortable } -body { # This test is non-portable because some platforms format the # result as 5e+06. .s configure -from 1000000 -to 10000000 -resolution 1000000 .s set 4930000 .s get } -result {5000000} test scale-6.7 {ComputeFormat procedure} -body { .s configure -from 1000000000 -to 10000000000 -resolution 1000000000 .s set 4930000000 expr {[.s get] == 5.0e+09} } -result 1 test scale-6.8 {ComputeFormat procedure} -body { .s configure -from .1 -to 1 -resolution .1 .s set .6 .s get } -result {0.6} test scale-6.9 {ComputeFormat procedure} -body { .s configure -from .01 -to .1 -resolution .01 .s set .06 .s get } -result {0.06} test scale-6.10 {ComputeFormat procedure} -body { .s configure -from .001 -to .01 -resolution .001 .s set .006 .s get } -result {0.006} test scale-6.11 {ComputeFormat procedure} -body { .s configure -from .0001 -to .001 -resolution .0001 .s set .0006 .s get } -result {0.0006} test scale-6.12 {ComputeFormat procedure} -body { .s configure -from .00001 -to .0001 -resolution .00001 .s set .00006 .s get } -result {0.00006} test scale-6.13 {ComputeFormat procedure} -body { .s configure -from .000001 -to .00001 -resolution .000001 .s set .000006 expr {[.s get] == 6.0e-06} } -result {1} test scale-6.14 {ComputeFormat procedure} -body { .s configure -to .00001 -from .0001 -resolution .00001 .s set .00006 .s get } -result {0.00006} test scale-6.15 {ComputeFormat procedure} -body { .s configure -to .000001 -from .00001 -resolution .000001 .s set .000006 expr {[.s get] == 6.0e-06} } -result {1} test scale-6.16 {ComputeFormat procedure} -body { .s configure -from .00001 -to .0001 -resolution .00001 -digits 1 .s set .00006 expr {[.s get] == 6e-05} } -result {1} test scale-6.17 {ComputeFormat procedure} -body { .s configure -from 10000000 -to 100000000 -resolution 10000000 -digits 3 .s set 49300000 .s get } -result {50000000} test scale-6.18 {ComputeFormat procedure} -body { .s configure -length 200 -from 0 -to 10 -resolution 0 -digits 0 .s set .111111111 .s get } -result {0.11} test scale-6.19 {ComputeFormat procedure} -body { .s configure -length 200 -from 1000 -to 1002 -resolution 0 -digits 0 .s set 1001.23456789 .s get } -result {1001.23} test scale-6.20 {ComputeFormat procedure} -body { .s configure -length 200 -from 1000 -to 1001.8 -resolution 0 -digits 0 .s set 1001.23456789 .s get } -result {1001.235} test scale-6.21 {ComputeFormat procedure} -body { .s configure -length 200 -from 1000 -to 1001.8 -resolution 0 -digits 200 .s set 1001.23456789 .s get } -result {1001.235} destroy .s test scale-7.1 {ComputeScaleGeometry procedure} -constraints { nonPortable fonts } -setup { deleteWindows } -body { scale .s -from 0 -to 10 -label "Short" -orient vertical -length 5i pack .s update list [winfo reqwidth .s] [winfo reqheight .s] } -cleanup { deleteWindows } -result {88 458} test scale-7.2 {ComputeScaleGeometry procedure} -constraints { fonts } -setup { deleteWindows } -body { scale .s -from 0 -to 1000 -label "Long string" -orient vertical -tick 200 pack .s update list [winfo reqwidth .s] [winfo reqheight .s] } -cleanup { deleteWindows } -result {168 108} test scale-7.3 {ComputeScaleGeometry procedure} -constraints { fonts } -setup { deleteWindows } -body { scale .s -from 0 -to 1000 -orient vertical -showvalue 0 -width 10 \ -sliderlength 10 pack .s update list [winfo reqwidth .s] [winfo reqheight .s] } -cleanup { deleteWindows } -result {22 108} test scale-7.4 {ComputeScaleGeometry procedure} -constraints { fonts } -setup { deleteWindows } -body { scale .s -from 0 -to 1000 -orient vertical -showvalue 0 -bd 5 \ -relief sunken pack .s update list [winfo reqwidth .s] [winfo reqheight .s] } -cleanup { deleteWindows } -result {39 114} test scale-7.5 {ComputeScaleGeometry procedure} -constraints { nonPortable fonts } -setup { deleteWindows } -body { scale .s -from 0 -to 10 -label "Short" -orient horizontal -length 5i pack .s update list [winfo reqwidth .s] [winfo reqheight .s] } -cleanup { deleteWindows } -result {458 61} test scale-7.6 {ComputeScaleGeometry procedure} -constraints { fonts } -setup { deleteWindows } -body { scale .s -from 0 -to 1000 -label "Long string" -orient horizontal \ -tick 500 pack .s update list [winfo reqwidth .s] [winfo reqheight .s] } -cleanup { deleteWindows } -result {108 79} test scale-7.7 {ComputeScaleGeometry procedure} -constraints { fonts } -setup { deleteWindows } -body { scale .s -from 0 -to 1000 -orient horizontal -showvalue 0 pack .s update list [winfo reqwidth .s] [winfo reqheight .s] } -cleanup { deleteWindows } -result {108 27} test scale-7.8 {ComputeScaleGeometry procedure} -setup { deleteWindows } -body { scale .s -from 0 -to 1000 -orient horizontal -showvalue 0 -bd 5 \ -relief raised -highlightthickness 2 pack .s update list [winfo reqwidth .s] [winfo reqheight .s] } -cleanup { deleteWindows } -result {114 39} test scale-8.1 {ScaleElement procedure} -constraints { fonts } -setup { deleteWindows } -body { scale .s -from 0 -to 100 -orient vertical -bd 1 -tick 20 -length 300 pack .s .s set 30 update list [.s identify 53 52] [.s identify 54 52] [.s identify 70 52] \ [.s identify 71 52] } -cleanup { deleteWindows } -result {{} trough1 trough1 {}} test scale-8.2 {ScaleElement procedure} -constraints { fonts } -setup { deleteWindows } -body { scale .s -from 0 -to 100 -orient vertical -bd 1 -tick 20 -length 300 pack .s .s set 30 update list [.s identify 60 2] [.s identify 60 3] [.s identify 60 302] \ [.s identify 60 303] } -cleanup { deleteWindows } -result {{} trough1 trough2 {}} test scale-8.3 {ScaleElement procedure} -constraints { fonts } -setup { deleteWindows } -body { scale .s -from 0 -to 100 -orient vertical -bd 1 -tick 20 -length 300 pack .s .s set 30 update list [.s identify 60 83] [.s identify 60 84] [.s identify 60 113] \ [.s identify 60 114] \ } -cleanup { deleteWindows } -result {trough1 slider slider trough2} test scale-8.4 {ScaleElement procedure} -setup { deleteWindows } -body { scale .s -from 0 -to 100 -orient vertical -bd 4 -width 10 \ -highlightthickness 1 -length 300 -showvalue 0 pack .s .s set 30 update list [.s identify 4 40] [.s identify 5 40] [.s identify 22 40] \ [.s identify 23 40] \ } -cleanup { deleteWindows } -result {{} trough1 trough1 {}} test scale-8.5 {ScaleElement procedure} -constraints { fonts } -setup { deleteWindows } -body { scale .s -from 0 -to 100 -orient horizontal -bd 1 \ -highlightthickness 2 -tick 20 -sliderlength 20 \ -length 200 -label Test pack .s .s set 30 update list [.s identify 150 36] [.s identify 150 37] [.s identify 150 53] \ [.s identify 150 54] } -cleanup { deleteWindows } -result {{} trough2 trough2 {}} test scale-8.6 {ScaleElement procedure} -constraints { fonts } -setup { deleteWindows } -body { scale .s -from 0 -to 100 -orient horizontal -bd 2 \ -highlightthickness 1 -tick 20 -length 200 pack .s .s set 30 update list [.s identify 150 20] [.s identify 150 21] [.s identify 150 39] \ [.s identify 150 40] } -cleanup { deleteWindows } -result {{} trough2 trough2 {}} test scale-8.7 {ScaleElement procedure} -setup { deleteWindows } -body { scale .s -from 0 -to 100 -orient horizontal -bd 4 -highlightthickness 2 \ -length 200 -width 10 -showvalue 0 pack .s .s set 30 update list [.s identify 30 5] [.s identify 30 6] [.s identify 30 23] \ [.s identify 30 24] } -cleanup { deleteWindows } -result {{} trough1 trough1 {}} test scale-8.8 {ScaleElement procedure} -setup { deleteWindows } -body { scale .s -from 0 -to 100 -orient horizontal -bd 1 -highlightthickness 2 \ -tick 20 -sliderlength 20 -length 200 -label Test -showvalue 0 pack .s .s set 30 update list [.s identify 2 28] [.s identify 3 28] [.s identify 202 28] \ [.s identify 203 28] } -cleanup { deleteWindows } -result {{} trough1 trough2 {}} test scale-8.9 {ScaleElement procedure} -setup { deleteWindows } -body { scale .s -from 0 -to 100 -orient horizontal -bd 1 -highlightthickness 2 \ -tick 20 -sliderlength 20 -length 200 -label Test -showvalue 0 pack .s .s set 80 update list [.s identify 145 28] [.s identify 146 28] [.s identify 165 28] \ [.s identify 166 28] } -cleanup { deleteWindows } -result {trough1 slider slider trough2} #widget used in 9.* tests destroy .s pack [scale .s] test scale-9.1 {PixelToValue procedure} -body { .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2 update .s get 46 0 } -result 0 test scale-9.2 {PixelToValue procedure} -body { .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2 update .s get -10 9 } -result 0 test scale-9.3 {PixelToValue procedure} -body { .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2 update .s get -10 12 } -result 1 test scale-9.4 {PixelToValue procedure} -body { .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2 update .s get -10 46 } -result 35 test scale-9.5 {PixelToValue procedure} -body { .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2 update .s get -10 110 } -result 99 test scale-9.6 {PixelToValue procedure} -body { .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2 update .s get -10 111 } -result 100 test scale-9.7 {PixelToValue procedure} -body { .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2 update .s get -10 112 } -result 100 test scale-9.8 {PixelToValue procedure} -body { .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2 update .s get -10 154 } -result 100 test scale-9.9 {PixelToValue procedure} -body { .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2 \ -orient horizontal update .s get 76 152 } -result 65 destroy .s test scale-10.1 {ValueToPixel procedure} -constraints { fonts } -setup { deleteWindows } -body { scale .s -from 0 -to 100 -sliderlength 20 -length 124 -bd 2 \ -orient horizontal -label Test -tick 20 pack .s update list [.s coords -10] [.s coords 40] [.s coords 1000] } -cleanup { deleteWindows } -result {{16 47} {56 47} {116 47}} test scale-10.2 {ValueToPixel procedure} -constraints { fonts } -setup { deleteWindows } -body { scale .s -from 100 -to 0 -sliderlength 20 -length 122 -bd 1 \ -orient vertical -label Test -tick 20 pack .s update list [.s coords -10] [.s coords 40] [.s coords 1000] } -cleanup { deleteWindows } -result {{62 114} {62 74} {62 14}} test scale-11.1 {ScaleEventProc procedure} -setup { deleteWindows } -body { proc killScale value { global x if {$value > 30} { destroy .s1 lappend x [winfo exists .s1] [info commands .s1] } } set x initial scale .s1 -from 0 -to 100 -command killScale .s1 set 20 pack .s1 update idletasks lappend x [winfo exists .s1] .s1 set 40 update idletasks return $x } -cleanup { rename killScale {} deleteWindows } -result {initial 1 0 {}} test scale-11.2 {ScaleEventProc procedure} -setup { deleteWindows set x {} } -body { scale .s1 -bg #543210 rename .s1 .s2 lappend x [winfo children .] lappend x [.s2 cget -bg] destroy .s1 lappend x [info command .s*] [winfo children .] } -cleanup { deleteWindows } -result {.s1 #543210 {} {}} test scale-12.1 {ScaleCmdDeletedProc procedure} -setup { deleteWindows } -body { scale .s1 rename .s1 {} list [info command .s*] [winfo children .] } -cleanup { deleteWindows } -result {{} {}} # Widget used in 13.* tests destroy .s pack [scale .s] update test scale-13.1 {SetScaleValue procedure} -body { .s configure -from 0 -to 100 -command {set x} -variable y update set x xyzzy .s set 44 set result [list $x $y] update lappend result $x $y } -result {xyzzy 44 44 44} test scale-13.2 {SetScaleValue procedure} -body { .s set -3 .s get } -result 0 test scale-13.3 {SetScaleValue procedure} -body { .s set 105 .s get } -result 100 .s configure -from 100 -to 0 test scale-13.4 {SetScaleValue procedure} -body { .s set -3 .s get } -result 0 test scale-13.5 {SetScaleValue procedure} -body { .s set 105 .s get } -result 100 test scale-13.6 {SetScaleValue procedure} -body { proc varTrace args { global traceInfo set traceInfo $args } .s configure -from 0 -to 100 -command {set x} -variable y update .s set 50 update trace variable y w varTrace set traceInfo empty set x untouched .s set 50 update list $x $traceInfo } -result {untouched empty} # Widget used in 14.* tests destroy .s pack [scale .s] update test scale-14.1 {RoundToResolution procedure} -body { .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2 \ -orient horizontal -resolution 4.0 update .s get 84 152 } -result 72 test scale-14.2 {RoundToResolution procedure} -body { .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2 \ -orient horizontal -resolution 4.0 update .s get 86 152 } -result 76 test scale-14.3 {RoundToResolution procedure} -body { .s configure -from 100 -to 0 -sliderlength 10 -length 114 -bd 2 \ -orient horizontal -resolution 4.0 update .s get 84 152 } -result 28 test scale-14.4 {RoundToResolution procedure} -body { .s configure -from 100 -to 0 -sliderlength 10 -length 114 -bd 2 \ -orient horizontal -resolution 4.0 update .s get 86 152 } -result 24 test scale-14.5 {RoundToResolution procedure} -body { .s configure -from -100 -to 0 -sliderlength 10 -length 114 -bd 2 \ -orient horizontal -resolution 4.0 update .s get 84 152 } -result {-28} test scale-14.6 {RoundToResolution procedure} -body { .s configure -from -100 -to 0 -sliderlength 10 -length 114 -bd 2 \ -orient horizontal -resolution 4.0 update .s get 86 152 } -result {-24} test scale-14.7 {RoundToResolution procedure} -body { .s configure -from 0 -to -100 -sliderlength 10 -length 114 -bd 2 \ -orient horizontal -resolution 4.0 update .s get 84 152 } -result {-72} test scale-14.8 {RoundToResolution procedure} -body { .s configure -from 0 -to -100 -sliderlength 10 -length 114 -bd 2 \ -orient horizontal -resolution 4.0 update .s get 86 152 } -result {-76} test scale-14.9 {RoundToResolution procedure} -body { .s configure -from 0 -to 2.25 -sliderlength 10 -length 114 -bd 2 \ -orient horizontal -resolution 0 update .s get 84 152 } -result {1.64} test scale-14.10 {RoundToResolution procedure} -body { .s configure -from 0 -to 2.25 -sliderlength 10 -length 114 -bd 2 \ -orient horizontal -resolution 0 update .s get 86 152 } -result {1.69} test scale-14.11 {RoundToResolution procedure} -body { .s configure -from 0 -to 225 -sliderlength 10 -length 114 -bd 2 \ -orient horizontal -resolution 0 -digits 5 update .s get 84 152 } -result {164.25} test scale-14.12 {RoundToResolution procedure} -body { .s configure -from 0 -to 225 -sliderlength 10 -length 114 -bd 2 \ -orient horizontal -resolution 0 -digits 5 update .s get 86 152 } -result {168.75} destroy .s test scale-15.1 {ScaleVarProc procedure} -setup { deleteWindows } -body { set y -130 scale .s -from 0 -to -200 -variable y -orient horizontal -length 150 pack .s return $y } -result {-130} test scale-15.2 {ScaleVarProc procedure} -setup { deleteWindows } -body { set y -130 scale .s -from -200 -to 0 -variable y -orient horizontal -length 150 pack .s set y -87 .s get } -result {-87} test scale-15.3 {ScaleVarProc procedure} -setup { deleteWindows } -body { set y -130 scale .s -from -200 -to 0 -variable y -orient horizontal -length 150 pack .s set y 40q } -cleanup { deleteWindows } -returnCodes error -result {can't set "y": can't assign non-numeric value to scale variable} test scale-15.4 {ScaleVarProc procedure} -setup { deleteWindows } -body { set y -130 scale .s -from -200 -to 0 -variable y -orient horizontal -length 150 pack .s catch {set y 40q} .s get } -cleanup { deleteWindows } -result {-130} test scale-15.5 {ScaleVarProc procedure} -setup { deleteWindows } -body { set y 1 scale .s -from 1 -to 0 -variable y -orient horizontal -length 150 pack .s set y x } -cleanup { deleteWindows } -returnCodes error -result {can't set "y": can't assign non-numeric value to scale variable} test scale-15.6 {ScaleVarProc procedure} -setup { deleteWindows } -body { set y 1 scale .s -from 1 -to 0 -variable y -orient horizontal -length 150 pack .s catch {set y x} .s get } -cleanup { deleteWindows } -result 1 test scale-15.7 {ScaleVarProc procedure, variable deleted} -setup { deleteWindows } -body { set y 6 scale .s -from 10 -to 0 -variable y -orient horizontal -length 150 \ -command "set x" pack .s update set x untouched unset y update list [catch {set y} msg] $msg [.s get] $x } -cleanup { deleteWindows } -result {0 6 6 untouched} test scale-15.8 {ScaleVarProc procedure, don't call -command} -setup { deleteWindows } -body { set y 6 scale .s -from 0 -to 100 -variable y -orient horizontal -length 150 \ -command "set x" pack .s update set x untouched set y 60 update list $x [.s get] } -cleanup { deleteWindows } -result {untouched 60} test scale-16.1 {scale widget vs hidden commands} -body { set l [interp hidden] deleteWindows scale .s interp hide {} .s destroy .s set res1 [list [winfo children .] [interp hidden]] set res2 [list {} $l] expr {$res1 eq $res2} } -cleanup { deleteWindows } -result 1 test scale-17.1 {bug fix 1786} -setup { deleteWindows } -body { # Perhaps x is set to {}, depending on what other tests have run. # If x is unset, or set to something not convertable to a double, # then the scale try to initialize its value with the contents # of uninitialized memory. Sometimes that causes an FPE. set x {} scale .s -from 100 -to 300 pack .s update .s configure -variable x ;# CRASH! -> Floating point exception # Bug 4833 changed the result to realize that x should pick up # a value from the scale. In an FPE occurs, it is due to the # lack of errno being set to 0 by some libc's. (see bug 4942) return $x } -cleanup { deleteWindows } -result {100} test scale-18.1 {DestroyScale, -cursor option [Bug: 3897]} -setup { deleteWindows } -body { scale .s -cursor trek destroy .s } -result {} test scale-18.2 {Scale button 1 events [Bug 787065]} -setup { destroy .s set ::error {} proc bgerror {args} {set ::error $args} } -body { set y 5 scale .s -from 0 -to 10 -variable y -orient horizontal -length 150 pack .s tkwait visibility .s list [catch { event generate .s <1> -x 0 -y 0 event generate .s -x 0 -y 0 update set ::error } msg] $msg } -cleanup { unset ::error rename bgerror {} destroy .s } -result {0 {}} test scale-18.3 {Scale button 2 events [Bug 787065]} -setup { destroy .s set ::error {} proc bgerror {args} {set ::error $args} } -body { set y 5 scale .s -from 0 -to 10 -variable y -orient horizontal -length 150 pack .s tkwait visibility .s list [catch { event generate .s <2> -x 0 -y 0 event generate .s -x 0 -y 0 update set ::error } msg] $msg } -cleanup { unset ::error rename bgerror {} destroy .s } -result {0 {}} test scale-19 {Bug [3529885fff] - Click in through goes in wrong direction} \ -setup { catch {destroy .s} catch {destroy .s1 .s2 .s3 .s4} unset -nocomplain x1 x2 x3 x4 x y scale .s1 -from 0 -to 100 -resolution 1 -variable x1 -digits 4 -orient horizontal -length 100 scale .s2 -from 0 -to 100 -resolution -1 -variable x2 -digits 4 -orient horizontal -length 100 scale .s3 -from 100 -to 0 -resolution 1 -variable x3 -digits 4 -orient horizontal -length 100 scale .s4 -from 100 -to 0 -resolution -1 -variable x4 -digits 4 -orient horizontal -length 100 pack .s1 .s2 .s3 .s4 -side left update } \ -body { foreach {x y} [.s1 coord 50] {} event generate .s1 <1> -x $x -y $y event generate .s1 -x $x -y $y foreach {x y} [.s2 coord 50] {} event generate .s2 <1> -x $x -y $y event generate .s2 -x $x -y $y foreach {x y} [.s3 coord 50] {} event generate .s3 <1> -x $x -y $y event generate .s3 -x $x -y $y foreach {x y} [.s4 coord 50] {} event generate .s4 <1> -x $x -y $y event generate .s4 -x $x -y $y update list $x1 $x2 $x3 $x4 } \ -cleanup { unset x1 x2 x3 x4 x y destroy .s1 .s2 .s3 .s4 } \ -result {1.0 1.0 1.0 1.0} option clear # cleanup cleanupTests return tk8.6.5/tests/listbox.test0000644003604700454610000027350112652406111014223 0ustar dgp771div# This file is a Tcl script to test out the "listbox" command # of Tk. It is organized in the standard fashion for Tcl tests. # # Copyright (c) 1993-1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands namespace import -force tcltest::test set fixed {Courier -12} proc record {name args} { global log lappend log [format {%s %.6g %.6g} $name {*}$args] } proc getsize w { regexp {(^[^+-]*)} [wm geometry $w] foo x return $x } proc resetGridInfo {} { # Some window managers, such as mwm, don't reset gridding information # unless the window is withdrawn and re-mapped. If this procedure # isn't invoked, the window manager will stay in gridded mode, which # can cause all sorts of problems. The "wm positionfrom" command is # needed so that the window manager doesn't ask the user to # manually position the window when it is re-mapped. wm withdraw . wm positionfrom . user wm deiconify . } # Procedure that creates a second listbox for checking things related # to partially visible lines. proc mkPartial {{w .partial}} { destroy $w toplevel $w wm geometry $w +0+0 listbox $w.l -width 30 -height 5 pack $w.l -expand 1 -fill both $w.l insert end one two three four five six seven eight nine ten \ eleven twelve thirteen fourteen fifteen update scan [wm geometry $w] "%dx%d" width height wm geometry $w ${width}x[expr $height-3] update } # Create entries in the option database to be sure that geometry options # like border width have predictable values. option add *Listbox.borderWidth 2 option add *Listbox.selectBorderWidth 1 option add *Listbox.highlightThickness 2 option add *Listbox.font {Helvetica -12 bold} # Listbox used in 3.* configuration options tests listbox .l pack .l update resetGridInfo test listbox-1.1 {configuration options} -body { .l configure -activestyle under list [lindex [.l configure -activestyle] 4] [.l cget -activestyle] } -cleanup { .l configure -activestyle [lindex [.l configure -activestyle] 3] } -result {underline underline} test listbox-1.2 {configuration options} -body { .l configure -activestyle foo } -returnCodes error -result {bad activestyle "foo": must be dotbox, none, or underline} test listbox-1.3 {configuration options} -body { .l configure -background #ff0000 list [lindex [.l configure -background] 4] [.l cget -background] } -cleanup { .l configure -background [lindex [.l configure -background] 3] } -result {{#ff0000} #ff0000} test listbox-1.4 {configuration options} -body { .l configure -background non-existent } -returnCodes error -result {unknown color name "non-existent"} test listbox-1.5 {configuration options} -body { .l configure -bd 4 list [lindex [.l configure -bd] 4] [.l cget -bd] } -cleanup { .l configure -bd [lindex [.l configure -bd] 3] } -result {4 4} test listbox-1.6 {configuration options} -body { .l configure -bd badValue } -returnCodes error -result {bad screen distance "badValue"} test listbox-1.7 {configuration options} -body { .l configure -bg #ff0000 list [lindex [.l configure -bg] 4] [.l cget -bg] } -cleanup { .l configure -bg [lindex [.l configure -bg] 3] } -result {{#ff0000} #ff0000} test listbox-1.8 {configuration options} -body { .l configure -bg non-existent } -returnCodes error -result {unknown color name "non-existent"} test listbox-1.9 {configuration options} -body { .l configure -borderwidth 1.3 list [lindex [.l configure -borderwidth] 4] [.l cget -borderwidth] } -cleanup { .l configure -borderwidth [lindex [.l configure -borderwidth] 3] } -result {1 1} test listbox-1.10 {configuration options} -body { .l configure -borderwidth badValue } -returnCodes error -result {bad screen distance "badValue"} test listbox-1.11 {configuration options} -body { .l configure -cursor arrow list [lindex [.l configure -cursor] 4] [.l cget -cursor] } -cleanup { .l configure -cursor [lindex [.l configure -cursor] 3] } -result {arrow arrow} test listbox-1.12 {configuration options} -body { .l configure -cursor badValue } -returnCodes error -result {bad cursor spec "badValue"} test listbox-1.13 {configuration options} -body { .l configure -disabledforeground #110022 list [lindex [.l configure -disabledforeground] 4] [.l cget -disabledforeground] } -cleanup { .l configure -disabledforeground [lindex [.l configure -disabledforeground] 3] } -result {{#110022} #110022} test listbox-1.14 {configuration options} -body { .l configure -disabledforeground bogus } -returnCodes error -result {unknown color name "bogus"} test listbox-1.15 {configuration options} -body { .l configure -exportselection yes list [lindex [.l configure -exportselection] 4] [.l cget -exportselection] } -cleanup { .l configure -exportselection [lindex [.l configure -exportselection] 3] } -result {1 1} test listbox-1.16 {configuration options} -body { .l configure -exportselection xyzzy } -returnCodes error -result {expected boolean value but got "xyzzy"} test listbox-1.17 {configuration options} -body { .l configure -fg #110022 list [lindex [.l configure -fg] 4] [.l cget -fg] } -cleanup { .l configure -fg [lindex [.l configure -fg] 3] } -result {{#110022} #110022} test listbox-1.18 {configuration options} -body { .l configure -fg bogus } -returnCodes error -result {unknown color name "bogus"} test listbox-1.19 {configuration options} -body { .l configure -font {Helvetica 12} list [lindex [.l configure -font] 4] [.l cget -font] } -cleanup { .l configure -font [lindex [.l configure -font] 3] } -result {{Helvetica 12} {Helvetica 12}} test listbox-1.21 {configuration options} -body { .l configure -foreground #110022 list [lindex [.l configure -foreground] 4] [.l cget -foreground] } -cleanup { .l configure -foreground [lindex [.l configure -foreground] 3] } -result {{#110022} #110022} test listbox-1.22 {configuration options} -body { .l configure -foreground bogus } -returnCodes error -result {unknown color name "bogus"} test listbox-1.23 {configuration options} -body { .l configure -height 30 list [lindex [.l configure -height] 4] [.l cget -height] } -cleanup { .l configure -height [lindex [.l configure -height] 3] } -result {30 30} test listbox-1.24 {configuration options} -body { .l configure -height 20p } -returnCodes error -result {expected integer but got "20p"} test listbox-1.25 {configuration options} -body { .l configure -highlightbackground #112233 list [lindex [.l configure -highlightbackground] 4] [.l cget -highlightbackground] } -cleanup { .l configure -highlightbackground [lindex [.l configure -highlightbackground] 3] } -result {{#112233} #112233} test listbox-1.26 {configuration options} -body { .l configure -highlightbackground ugly } -returnCodes error -result {unknown color name "ugly"} test listbox-1.27 {configuration options} -body { .l configure -highlightcolor #123456 list [lindex [.l configure -highlightcolor] 4] [.l cget -highlightcolor] } -cleanup { .l configure -highlightcolor [lindex [.l configure -highlightcolor] 3] } -result {{#123456} #123456} test listbox-1.28 {configuration options} -body { .l configure -highlightcolor bogus } -returnCodes error -result {unknown color name "bogus"} test listbox-1.29 {configuration options} -body { .l configure -highlightthickness 6 list [lindex [.l configure -highlightthickness] 4] [.l cget -highlightthickness] } -cleanup { .l configure -highlightthickness [lindex [.l configure -highlightthickness] 3] } -result {6 6} test listbox-1.30 {configuration options} -body { .l configure -highlightthickness bogus } -returnCodes error -result {bad screen distance "bogus"} test listbox-1.31 {configuration options} -body { .l configure -highlightthickness -2 list [lindex [.l configure -highlightthickness] 4] [.l cget -highlightthickness] } -cleanup { .l configure -highlightthickness [lindex [.l configure -highlightthickness] 3] } -result {0 0} test listbox-1.32.1 {configuration options} -setup { set res {} } -body { .l configure -justify left set res [list [lindex [.l configure -justify] 4] [.l cget -justify]] .l configure -justify center lappend res [lindex [.l configure -justify] 4] [.l cget -justify] .l configure -justify right lappend res [lindex [.l configure -justify] 4] [.l cget -justify] } -cleanup { .l configure -justify [lindex [.l configure -justify] 3] } -result {left left center center right right} test listbox-1.32.2 {configuration options} -body { .l configure -justify bogus } -returnCodes error -result {bad justification "bogus": must be left, right, or center} test listbox-1.33 {configuration options} -body { .l configure -relief groove list [lindex [.l configure -relief] 4] [.l cget -relief] } -cleanup { .l configure -relief [lindex [.l configure -relief] 3] } -result {groove groove} test listbox-1.34 {configuration options} -body { .l configure -relief 1.5 } -returnCodes error -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken} test listbox-1.35 {configuration options} -body { .l configure -selectbackground #110022 list [lindex [.l configure -selectbackground] 4] [.l cget -selectbackground] } -cleanup { .l configure -selectbackground [lindex [.l configure -selectbackground] 3] } -result {{#110022} #110022} test listbox-1.36 {configuration options} -body { .l configure -selectbackground bogus } -returnCodes error -result {unknown color name "bogus"} test listbox-1.37 {configuration options} -body { .l configure -selectborderwidth 1.3 list [lindex [.l configure -selectborderwidth] 4] [.l cget -selectborderwidth] } -cleanup { .l configure -selectborderwidth [lindex [.l configure -selectborderwidth] 3] } -result {1 1} test listbox-1.38 {configuration options} -body { .l configure -selectborderwidth badValue } -returnCodes error -result {bad screen distance "badValue"} test listbox-1.39 {configuration options} -body { .l configure -selectforeground #654321 list [lindex [.l configure -selectforeground] 4] [.l cget -selectforeground] } -cleanup { .l configure -selectforeground [lindex [.l configure -selectforeground] 3] } -result {{#654321} #654321} test listbox-1.40 {configuration options} -body { .l configure -selectforeground bogus } -returnCodes error -result {unknown color name "bogus"} test listbox-1.41 {configuration options} -body { .l configure -selectmode string list [lindex [.l configure -selectmode] 4] [.l cget -selectmode] } -cleanup { .l configure -selectmode [lindex [.l configure -selectmode] 3] } -result {string string} test listbox-1.43 {configuration options} -body { .l configure -setgrid false list [lindex [.l configure -setgrid] 4] [.l cget -setgrid] } -cleanup { .l configure -setgrid [lindex [.l configure -setgrid] 3] } -result {0 0} test listbox-1.44 {configuration options} -body { .l configure -setgrid lousy } -returnCodes error -result {expected boolean value but got "lousy"} test listbox-1.45 {configuration options} -body { .l configure -state disabled list [lindex [.l configure -state] 4] [.l cget -state] } -cleanup { .l configure -state [lindex [.l configure -state] 3] } -result {disabled disabled} test listbox-1.46 {configuration options} -body { .l configure -state foo } -returnCodes error -result {bad state "foo": must be disabled or normal} test listbox-1.47 {configuration options} -body { .l configure -takefocus {any string} list [lindex [.l configure -takefocus] 4] [.l cget -takefocus] } -cleanup { .l configure -takefocus [lindex [.l configure -takefocus] 3] } -result {{any string} {any string}} test listbox-1.49 {configuration options} -body { .l configure -width 45 list [lindex [.l configure -width] 4] [.l cget -width] } -cleanup { .l configure -width [lindex [.l configure -width] 3] } -result {45 45} test listbox-1.50 {configuration options} -body { .l configure -width 3p } -returnCodes error -result {expected integer but got "3p"} test listbox-1.51 {configuration options} -body { .l configure -xscrollcommand {Some command} list [lindex [.l configure -xscrollcommand] 4] [.l cget -xscrollcommand] } -cleanup { .l configure -xscrollcommand [lindex [.l configure -xscrollcommand] 3] } -result {{Some command} {Some command}} test listbox-1.53 {configuration options} -body { .l configure -yscrollcommand {Another command} list [lindex [.l configure -yscrollcommand] 4] [.l cget -yscrollcommand] } -cleanup { .l configure -yscrollcommand [lindex [.l configure -yscrollcommand] 3] } -result {{Another command} {Another command}} test listbox-1.55 {configuration options} -body { .l configure -listvar testVariable list [lindex [.l configure -listvar] 4] [.l cget -listvar] } -cleanup { .l configure -listvar [lindex [.l configure -listvar] 3] } -result {testVariable testVariable} test listbox-2.1 {Tk_ListboxCmd procedure} -body { listbox } -returnCodes error -result {wrong # args: should be "listbox pathName ?-option value ...?"} test listbox-2.2 {Tk_ListboxCmd procedure} -body { listbox gorp } -returnCodes error -result {bad window path name "gorp"} test listbox-2.3 {Tk_ListboxCmd procedure} -setup { destroy .l } -body { listbox .l list [winfo exists .l] [winfo class .l] [info commands .l] } -result {1 Listbox .l} test listbox-2.4 {Tk_ListboxCmd procedure} -setup { destroy .l } -body { listbox .l -gorp foo } -cleanup { destroy .l } -returnCodes error -result {unknown option "-gorp"} test listbox-2.4.1 {Tk_ListboxCmd procedure} -setup { destroy .l } -body { catch {listbox .l -gorp foo} list [winfo exists .l] [info commands .l] } -cleanup { destroy .l } -result {0 {}} test listbox-2.5 {Tk_ListboxCmd procedure} -setup { destroy .l } -body { listbox .l } -cleanup { destroy .l } -result {.l} # Listbox used in 3.1 -3.115 tests destroy .l listbox .l -width 20 -height 5 -bd 4 -highlightthickness 1 -selectborderwidth 2 pack .l .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 el12 el13 el14 \ el15 el16 el17 update test listbox-3.1 {ListboxWidgetCmd procedure} -body { .l } -returnCodes error -result {wrong # args: should be ".l option ?arg ...?"} test listbox-3.2 {ListboxWidgetCmd procedure, "activate" option} -body { .l activate } -returnCodes error -result {wrong # args: should be ".l activate index"} test listbox-3.3 {ListboxWidgetCmd procedure, "activate" option} -body { .l activate a b } -returnCodes error -result {wrong # args: should be ".l activate index"} test listbox-3.4 {ListboxWidgetCmd procedure, "activate" option} -body { .l activate fooey } -returnCodes error -result {bad listbox index "fooey": must be active, anchor, end, @x,y, or a number} test listbox-3.5 {ListboxWidgetCmd procedure, "activate" option} -body { .l activate 3 .l index active } -result 3 test listbox-3.6 {ListboxWidgetCmd procedure, "activate" option} -body { .l activate -1 .l index active } -result {0} test listbox-3.7 {ListboxWidgetCmd procedure, "activate" option} -body { .l activate 30 .l index active } -result {17} test listbox-3.8 {ListboxWidgetCmd procedure, "activate" option} -body { .l activate end .l index active } -result {17} test listbox-3.9 {ListboxWidgetCmd procedure, "bbox" option} -body { .l bbox } -returnCodes error -result {wrong # args: should be ".l bbox index"} test listbox-3.10 {ListboxWidgetCmd procedure, "bbox" option} -body { .l bbox a b } -returnCodes error -result {wrong # args: should be ".l bbox index"} test listbox-3.11 {ListboxWidgetCmd procedure, "bbox" option} -body { .l bbox fooey } -returnCodes error -result {bad listbox index "fooey": must be active, anchor, end, @x,y, or a number} test listbox-3.12 {ListboxWidgetCmd procedure, "bbox" option} -body { .l yview 3 update list [.l bbox 2] [.l bbox 8] } -result {{} {}} test listbox-3.13 {ListboxWidgetCmd procedure, "bbox" option} -cleanup { destroy .l2 } -body { # Used to generate a core dump before a bug was fixed (the last # element would be on-screen if it existed, but it doesn't exist). listbox .l2 pack .l2 -side top tkwait visibility .l2 set x [.l2 bbox 0] destroy .l2 set x } -cleanup { destroy .l2 } -result {} test listbox-3.14 {ListboxWidgetCmd procedure, "bbox" option} -constraints { fonts } -body { .l yview 3 update list [.l bbox 3] [.l bbox 4] } -result {{7 7 17 14} {7 26 17 14}} test listbox-3.15 {ListboxWidgetCmd procedure, "bbox" option} -constraints { fonts } -body { .l yview 0 update list [.l bbox -1] [.l bbox 0] } -result {{} {7 7 17 14}} test listbox-3.16 {ListboxWidgetCmd procedure, "bbox" option} -constraints { fonts } -body { .l yview end update list [.l bbox 17] [.l bbox end] [.l bbox 18] } -result {{7 83 24 14} {7 83 24 14} {}} test listbox-3.17 {ListboxWidgetCmd procedure, "bbox" option} -constraints { fonts } -setup { destroy .t } -body { toplevel .t wm geom .t +0+0 listbox .t.l -width 10 -height 5 .t.l insert 0 "Short" "Somewhat longer" "Really, quite a whole lot longer than can possibly fit on the screen" "Short" pack .t.l update .t.l xview moveto .2 .t.l bbox 2 } -cleanup { destroy .t } -result {-72 39 393 14} test listbox-3.18 {ListboxWidgetCmd procedure, "bbox" option, partial last line} -constraints { fonts } -body { mkPartial list [.partial.l bbox 3] [.partial.l bbox 4] } -result {{5 56 24 14} {5 73 23 14}} test listbox-3.18a {ListboxWidgetCmd procedure, "bbox" option, justified} -constraints { fonts } -setup { destroy .top.l .top unset -nocomplain res } -body { toplevel .top listbox .top.l -justify left .top.l insert end Item1 LongerItem2 MuchLongerItem3 pack .top.l update lappend res [.top.l bbox 0] [.top.l bbox 1] [.top.l bbox 2] .top.l configure -justify center lappend res [.top.l bbox 0] [.top.l bbox 1] [.top.l bbox 2] .top.l configure -justify right lappend res [.top.l bbox 0] [.top.l bbox 1] [.top.l bbox 2] } -cleanup { destroy .top.l .top unset -nocomplain res } -result [list \ {5 5 34 14} {5 22 74 14} {5 39 106 14} \ {58 5 34 14} {38 22 74 14} {22 39 106 14} \ {111 5 34 14} {71 22 74 14} {39 39 106 14} \ ] test listbox-3.18b {ListboxWidgetCmd procedure, "bbox" option, justified, non-default borderwidth} -setup { destroy .top.l .top unset -nocomplain lres res } -body { # This test checks whether all "x" values from bbox for different size # items with different justification settings are all positive or zero # This checks a bit the calculation of this x value with non-default # borders widths of the listbox toplevel .top listbox .top.l -justify left -borderwidth 17 -highlightthickness 19 -selectborderwidth 22 .top.l insert end Item1 LongerItem2 MuchLongerItem3 .top.l selection set 1 pack .top.l update lappend lres [.top.l bbox 0] [.top.l bbox 1] [.top.l bbox 2] .top.l configure -justify center lappend lres [.top.l bbox 0] [.top.l bbox 1] [.top.l bbox 2] .top.l configure -justify right lappend lres [.top.l bbox 0] [.top.l bbox 1] [.top.l bbox 2] set res 1 for {set i 0} {$i < [llength $lres]} {incr i 4} { set res [expr {$res * [expr {[lindex $lres $i] >= 0}] }] } set res } -cleanup { destroy .top.l .top unset -nocomplain lres res } -result {1} test listbox-3.19 {ListboxWidgetCmd procedure, "cget" option} -body { .l cget } -returnCodes error -result {wrong # args: should be ".l cget option"} test listbox-3.20 {ListboxWidgetCmd procedure, "cget" option} -body { .l cget a b } -returnCodes error -result {wrong # args: should be ".l cget option"} test listbox-3.21 {ListboxWidgetCmd procedure, "cget" option} -body { .l cget -gorp } -returnCodes error -result {unknown option "-gorp"} test listbox-3.22 {ListboxWidgetCmd procedure, "cget" option} -body { .l cget -setgrid } -result {0} test listbox-3.23 {ListboxWidgetCmd procedure, "configure" option} -body { llength [.l configure] } -result {28} test listbox-3.24 {ListboxWidgetCmd procedure, "configure" option} -body { .l configure -gorp } -returnCodes error -result {unknown option "-gorp"} test listbox-3.25 {ListboxWidgetCmd procedure, "configure" option} -body { .l configure -setgrid } -result {-setgrid setGrid SetGrid 0 0} test listbox-3.26 {ListboxWidgetCmd procedure, "configure" option} -body { .l configure -gorp is_messy } -returnCodes error -result {unknown option "-gorp"} test listbox-3.27 {ListboxWidgetCmd procedure, "configure" option} -body { set oldbd [.l cget -bd] set oldht [.l cget -highlightthickness] .l configure -bd 3 -highlightthickness 0 set x "[.l cget -bd] [.l cget -highlightthickness]" .l configure -bd $oldbd -highlightthickness $oldht set x } -result {3 0} test listbox-3.28 {ListboxWidgetCmd procedure, "curselection" option} -body { .l curselection a } -returnCodes error -result {wrong # args: should be ".l curselection"} test listbox-3.29 {ListboxWidgetCmd procedure, "curselection" option} -body { .l selection clear 0 end .l selection set 3 6 .l selection set 9 .l curselection } -result {3 4 5 6 9} test listbox-3.30 {ListboxWidgetCmd procedure, "delete" option} -body { .l delete } -returnCodes error -result {wrong # args: should be ".l delete firstIndex ?lastIndex?"} test listbox-3.31 {ListboxWidgetCmd procedure, "delete" option} -body { .l delete a b c } -returnCodes error -result {wrong # args: should be ".l delete firstIndex ?lastIndex?"} test listbox-3.32 {ListboxWidgetCmd procedure, "delete" option} -body { .l delete badIndex } -returnCodes error -result {bad listbox index "badIndex": must be active, anchor, end, @x,y, or a number} test listbox-3.33 {ListboxWidgetCmd procedure, "delete" option} -body { .l delete 2 123ab } -returnCodes error -result {bad listbox index "123ab": must be active, anchor, end, @x,y, or a number} test listbox-3.34 {ListboxWidgetCmd procedure, "delete" option} -setup { destroy .l2 } -body { listbox .l2 .l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7 .l2 delete 3 list [.l2 get 2] [.l2 get 3] [.l2 index end] } -cleanup { destroy .l2 } -result {el2 el4 7} test listbox-3.35 {ListboxWidgetCmd procedure, "delete" option} -setup { destroy .l2 } -body { listbox .l2 .l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7 .l2 delete 2 4 list [.l2 get 1] [.l2 get 2] [.l2 index end] } -cleanup { destroy .l2 } -result {el1 el5 5} test listbox-3.36 {ListboxWidgetCmd procedure, "delete" option} -setup { destroy .l2 } -body { listbox .l2 .l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7 .l2 delete -3 2 .l2 get 0 end } -cleanup { destroy .l2 } -result {el3 el4 el5 el6 el7} test listbox-3.37 {ListboxWidgetCmd procedure, "delete" option} -setup { destroy .l2 } -body { listbox .l2 .l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7 .l2 delete -3 -1 .l2 get 0 end } -cleanup { destroy .l2 } -result {el0 el1 el2 el3 el4 el5 el6 el7} test listbox-3.38 {ListboxWidgetCmd procedure, "delete" option} -setup { destroy .l2 } -body { listbox .l2 .l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7 .l2 delete 2 end .l2 get 0 end } -cleanup { destroy .l2 } -result {el0 el1} test listbox-3.39 {ListboxWidgetCmd procedure, "delete" option} -setup { destroy .l2 } -body { listbox .l2 .l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7 .l2 delete 5 20 .l2 get 0 end } -cleanup { destroy .l2 } -result {el0 el1 el2 el3 el4} test listbox-3.40 {ListboxWidgetCmd procedure, "delete" option} -setup { destroy .l2 } -body { listbox .l2 .l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7 .l2 delete end 20 .l2 get 0 end } -cleanup { destroy .l2 } -result {el0 el1 el2 el3 el4 el5 el6} test listbox-3.41 {ListboxWidgetCmd procedure, "delete" option} -setup { destroy .l2 } -body { listbox .l2 .l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7 .l2 delete 8 20 .l2 get 0 end } -cleanup { destroy .l2 } -result {el0 el1 el2 el3 el4 el5 el6 el7} test listbox-3.42 {ListboxWidgetCmd procedure, "get" option} -body { .l get } -returnCodes error -result {wrong # args: should be ".l get firstIndex ?lastIndex?"} test listbox-3.43 {ListboxWidgetCmd procedure, "get" option} -body { .l get a b c } -returnCodes error -result {wrong # args: should be ".l get firstIndex ?lastIndex?"} test listbox-3.44 {ListboxWidgetCmd procedure, "get" option} -body { .l get 2.4 } -returnCodes error -result {bad listbox index "2.4": must be active, anchor, end, @x,y, or a number} test listbox-3.45 {ListboxWidgetCmd procedure, "get" option} -body { .l get end bogus } -returnCodes error -result {bad listbox index "bogus": must be active, anchor, end, @x,y, or a number} test listbox-3.46 {ListboxWidgetCmd procedure, "get" option} -setup { destroy .l2 } -body { listbox .l2 .l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7 list [.l2 get 0] [.l2 get 3] [.l2 get end] } -cleanup { destroy .l2 } -result {el0 el3 el7} test listbox-3.47 {ListboxWidgetCmd procedure, "get" option} -setup { destroy .l2 } -body { listbox .l2 list [.l2 get 0] [.l2 get end] } -cleanup { destroy .l2 } -result {{} {}} test listbox-3.48 {ListboxWidgetCmd procedure, "get" option} -setup { destroy .l2 } -body { listbox .l2 .l2 insert 0 el0 el1 el2 "two words" el4 el5 el6 el7 .l2 get 3 end } -cleanup { destroy .l2 } -result {{two words} el4 el5 el6 el7} test listbox-3.49 {ListboxWidgetCmd procedure, "get" option} -body { .l get -1 } -result {} test listbox-3.50 {ListboxWidgetCmd procedure, "get" option} -body { .l get -2 -1 } -result {} test listbox-3.51 {ListboxWidgetCmd procedure, "get" option} -body { .l get -2 3 } -result {el0 el1 el2 el3} test listbox-3.52 {ListboxWidgetCmd procedure, "get" option} -body { .l get 12 end } -result {el12 el13 el14 el15 el16 el17} test listbox-3.53 {ListboxWidgetCmd procedure, "get" option} -body { .l get 12 20 } -result {el12 el13 el14 el15 el16 el17} test listbox-3.54 {ListboxWidgetCmd procedure, "get" option} -body { .l get end } -result {el17} test listbox-3.55 {ListboxWidgetCmd procedure, "get" option} -body { .l get 30 } -result {} test listbox-3.56 {ListboxWidgetCmd procedure, "get" option} -body { .l get 30 35 } -result {} test listbox-3.57 {ListboxWidgetCmd procedure, "index" option} -body { .l index } -returnCodes error -result {wrong # args: should be ".l index index"} test listbox-3.58 {ListboxWidgetCmd procedure, "index" option} -body { .l index a b } -returnCodes error -result {wrong # args: should be ".l index index"} test listbox-3.59 {ListboxWidgetCmd procedure, "index" option} -body { .l index @ } -returnCodes error -result {bad listbox index "@": must be active, anchor, end, @x,y, or a number} test listbox-3.60 {ListboxWidgetCmd procedure, "index" option} -body { .l index 2 } -result 2 test listbox-3.61 {ListboxWidgetCmd procedure, "index" option} -body { .l index -1 } -result {-1} test listbox-3.62 {ListboxWidgetCmd procedure, "index" option} -body { .l index end } -result 18 test listbox-3.63 {ListboxWidgetCmd procedure, "index" option} -body { .l index 34 } -result 34 test listbox-3.64 {ListboxWidgetCmd procedure, "insert" option} -body { .l insert } -returnCodes error -result {wrong # args: should be ".l insert index ?element ...?"} test listbox-3.65 {ListboxWidgetCmd procedure, "insert" option} -body { .l insert badIndex } -returnCodes error -result {bad listbox index "badIndex": must be active, anchor, end, @x,y, or a number} test listbox-3.66 {ListboxWidgetCmd procedure, "insert" option} -setup { destroy .l2 } -body { listbox .l2 .l2 insert end a b c d e .l2 insert 3 x y z .l2 get 0 end } -cleanup { destroy .l2 } -result {a b c x y z d e} test listbox-3.67 {ListboxWidgetCmd procedure, "insert" option} -setup { destroy .l2 } -body { listbox .l2 .l2 insert end a b c .l2 insert -1 x .l2 get 0 end } -cleanup { destroy .l2 } -result {x a b c} test listbox-3.68 {ListboxWidgetCmd procedure, "insert" option} -setup { destroy .l2 } -body { listbox .l2 .l2 insert end a b c .l2 insert end x .l2 get 0 end } -cleanup { destroy .l2 } -result {a b c x} test listbox-3.69 {ListboxWidgetCmd procedure, "insert" option} -setup { destroy .l2 } -body { listbox .l2 .l2 insert end a b c .l2 insert 43 x .l2 get 0 end } -cleanup { destroy .l2 } -result {a b c x} test listbox-3.70 {ListboxWidgetCmd procedure, "nearest" option} -body { .l nearest } -returnCodes error -result {wrong # args: should be ".l nearest y"} test listbox-3.71 {ListboxWidgetCmd procedure, "nearest" option} -body { .l nearest a b } -returnCodes error -result {wrong # args: should be ".l nearest y"} test listbox-3.72 {ListboxWidgetCmd procedure, "nearest" option} -body { .l nearest 20p } -returnCodes error -result {expected integer but got "20p"} test listbox-3.73 {ListboxWidgetCmd procedure, "nearest" option} -body { .l yview 3 .l nearest 1000 } -result {7} test listbox-3.74 {ListboxWidgetCmd procedure, "scan" option} -body { .l scan a b } -returnCodes error -result {wrong # args: should be ".l scan mark|dragto x y"} test listbox-3.75 {ListboxWidgetCmd procedure, "scan" option} -body { .l scan a b c d } -returnCodes error -result {wrong # args: should be ".l scan mark|dragto x y"} test listbox-3.76 {ListboxWidgetCmd procedure, "scan" option} -body { .l scan foo bogus 2 } -returnCodes error -result {expected integer but got "bogus"} test listbox-3.77 {ListboxWidgetCmd procedure, "scan" option} -body { .l scan foo 2 2.3 } -returnCodes error -result {expected integer but got "2.3"} test listbox-3.78 {ListboxWidgetCmd procedure, "scan" option} -constraints { fonts } -setup { destroy .t } -body { toplevel .t wm geom .t +0+0 listbox .t.l -width 10 -height 5 .t.l insert 0 "Short" "Somewhat longer" "Really, quite a whole lot longer than can possibly fit on the screen" "Short" a b c d e f g h i j pack .t.l update .t.l scan mark 100 140 .t.l scan dragto 90 137 update list [format {%.6g %.6g} {*}[.t.l xview]] [format {%.6g %.6g} {*}[.t.l yview]] } -cleanup { destroy .t } -result {{0.249364 0.427481} {0.0714286 0.428571}} test listbox-3.79 {ListboxWidgetCmd procedure, "scan" option} -body { .l scan foo 2 4 } -returnCodes error -result {bad option "foo": must be mark or dragto} test listbox-3.80 {ListboxWidgetCmd procedure, "see" option} -body { .l see } -returnCodes error -result {wrong # args: should be ".l see index"} test listbox-3.81 {ListboxWidgetCmd procedure, "see" option} -body { .l see a b } -returnCodes error -result {wrong # args: should be ".l see index"} test listbox-3.82 {ListboxWidgetCmd procedure, "see" option} -body { .l see gorp } -returnCodes error -result {bad listbox index "gorp": must be active, anchor, end, @x,y, or a number} test listbox-3.83 {ListboxWidgetCmd procedure, "see" option} -body { .l yview 7 .l see 7 .l index @0,0 } -result {7} test listbox-3.84 {ListboxWidgetCmd procedure, "see" option} -body { .l yview 7 .l see 11 .l index @0,0 } -result {7} test listbox-3.85 {ListboxWidgetCmd procedure, "see" option} -body { .l yview 7 .l see 6 .l index @0,0 } -result {6} test listbox-3.86 {ListboxWidgetCmd procedure, "see" option} -body { .l yview 7 .l see 5 .l index @0,0 } -result {3} test listbox-3.87 {ListboxWidgetCmd procedure, "see" option} -body { .l yview 7 .l see 12 .l index @0,0 } -result {8} test listbox-3.88 {ListboxWidgetCmd procedure, "see" option} -body { .l yview 7 .l see 13 .l index @0,0 } -result {11} test listbox-3.89 {ListboxWidgetCmd procedure, "see" option} -body { .l yview 7 .l see -1 .l index @0,0 } -result {0} test listbox-3.90 {ListboxWidgetCmd procedure, "see" option} -body { .l yview 7 .l see end .l index @0,0 } -result {13} test listbox-3.91 {ListboxWidgetCmd procedure, "see" option} -body { .l yview 7 .l see 322 .l index @0,0 } -result {13} test listbox-3.92 {ListboxWidgetCmd procedure, "see" option, partial last line} -body { mkPartial .partial.l see 4 .partial.l index @0,0 } -result {1} test listbox-3.93 {ListboxWidgetCmd procedure, "selection" option} -body { .l select a } -returnCodes error -result {wrong # args: should be ".l selection option index ?index?"} test listbox-3.94 {ListboxWidgetCmd procedure, "selection" option} -body { .l select a b c d } -returnCodes error -result {wrong # args: should be ".l selection option index ?index?"} test listbox-3.95 {ListboxWidgetCmd procedure, "selection" option} -body { .l selection a bogus } -returnCodes error -result {bad listbox index "bogus": must be active, anchor, end, @x,y, or a number} test listbox-3.96 {ListboxWidgetCmd procedure, "selection" option} -body { .l selection a 0 lousy } -returnCodes error -result {bad listbox index "lousy": must be active, anchor, end, @x,y, or a number} test listbox-3.97 {ListboxWidgetCmd procedure, "selection" option} -body { .l selection anchor 0 0 } -returnCodes error -result {wrong # args: should be ".l selection anchor index"} test listbox-3.98 {ListboxWidgetCmd procedure, "selection" option} -body { list [.l selection anchor 5; .l index anchor] \ [.l selection anchor 0; .l index anchor] } -result {5 0} test listbox-3.99 {ListboxWidgetCmd procedure, "selection" option} -body { .l selection anchor -1 .l index anchor } -result {0} test listbox-3.100 {ListboxWidgetCmd procedure, "selection" option} -body { .l selection anchor end .l index anchor } -result {17} test listbox-3.101 {ListboxWidgetCmd procedure, "selection" option} -body { .l selection anchor 44 .l index anchor } -result {17} test listbox-3.102 {ListboxWidgetCmd procedure, "selection" option} -body { .l selection clear 0 end .l selection set 2 8 .l selection clear 3 4 .l curselection } -result {2 5 6 7 8} test listbox-3.103 {ListboxWidgetCmd procedure, "selection" option} -body { .l selection includes 0 0 } -returnCodes error -result {wrong # args: should be ".l selection includes index"} test listbox-3.104 {ListboxWidgetCmd procedure, "selection" option} -body { .l selection clear 0 end .l selection set 2 8 .l selection clear 4 list [.l selection includes 3] [.l selection includes 4] \ [.l selection includes 5] } -result {1 0 1} test listbox-3.105 {ListboxWidgetCmd procedure, "selection" option} -body { .l selection set 0 end .l selection includes -1 } -result {0} test listbox-3.106 {ListboxWidgetCmd procedure, "selection" option} -body { .l selection clear 0 end .l selection set end .l selection includes end } -result {1} test listbox-3.107 {ListboxWidgetCmd procedure, "selection" option} -body { .l selection set 0 end .l selection includes 44 } -result {0} test listbox-3.108 {ListboxWidgetCmd procedure, "selection" option} -setup { destroy .l2 } -body { listbox .l2 .l2 selection includes 0 } -cleanup { destroy .l2 } -result {0} test listbox-3.109 {ListboxWidgetCmd procedure, "selection" option} -body { .l selection clear 0 end .l selection set 2 .l selection set 5 7 .l curselection } -result {2 5 6 7} test listbox-3.110 {ListboxWidgetCmd procedure, "selection" option} -body { .l selection clear 0 end .l selection set 2 .l selection set 5 7 .l selection set 5 7 .l curselection } -result {2 5 6 7} test listbox-3.111 {ListboxWidgetCmd procedure, "selection" option} -body { .l selection badOption 0 0 } -returnCodes error -result {bad option "badOption": must be anchor, clear, includes, or set} test listbox-3.112 {ListboxWidgetCmd procedure, "size" option} -body { .l size a } -returnCodes error -result {wrong # args: should be ".l size"} test listbox-3.113 {ListboxWidgetCmd procedure, "size" option} -body { .l size } -result {18} test listbox-3.114 {ListboxWidgetCmd procedure, "xview" option} -setup { destroy .l2 } -body { listbox .l2 update format {%.6g %.6g} {*}[.l2 xview] } -cleanup { destroy .l2 } -result {0 1} test listbox-3.115 {ListboxWidgetCmd procedure, "xview" option} -setup { destroy .l2 } -body { listbox .l2 -width 10 -height 5 -font $fixed .l2 insert 0 a b c d e f g h i j k l m n o p q r s t pack .l2 update format {%.6g %.6g} {*}[.l2 xview] } -cleanup { destroy .l2 } -result {0 1} test listbox-3.116 {ListboxWidgetCmd procedure, "xview" option} -constraints { fonts } -setup { destroy .l2 listbox .l2 -width 10 -height 5 -font $fixed pack .l2 update } -body { .l2 insert 0 a b c d e f g h i j k l m n o p q r s t .l2 insert 1 "0123456789a123456789b123456789c123456789d123456789" .l2 xview 4 format {%.6g %.6g} {*}[.l2 xview] } -cleanup { destroy .l2 } -result {0.08 0.28} test listbox-3.117 {ListboxWidgetCmd procedure, "xview" option} -body { .l xview foo } -returnCodes error -result {expected integer but got "foo"} test listbox-3.118 {ListboxWidgetCmd procedure, "xview" option} -body { .l xview zoom a b } -returnCodes error -result {unknown option "zoom": must be moveto or scroll} test listbox-3.119 {ListboxWidgetCmd procedure, "xview" option} -constraints { fonts } -setup { destroy .l2 listbox .l2 -width 10 -height 5 -font $fixed pack .l2 update } -body { .l2 insert 0 a b c d e f g h i j k l m n o p q r s t .l2 insert 1 "0123456789a123456789b123456789c123456789d123456789" .l xview 0 .l2 xview moveto .4 update format {%.6g %.6g} {*}[.l2 xview] } -cleanup { destroy .l2 } -result {0.4 0.6} test listbox-3.120 {ListboxWidgetCmd procedure, "xview" option} -constraints { fonts } -setup { destroy .l2 listbox .l2 -width 10 -height 5 -font $fixed pack .l2 update } -body { .l2 insert 0 a b c d e f g h i j k l m n o p q r s t .l2 insert 1 "0123456789a123456789b123456789c123456789d123456789" .l2 xview 0 .l2 xview scroll 2 units update format {%.6g %.6g} {*}[.l2 xview] } -cleanup { destroy .l2 } -result {0.04 0.24} test listbox-3.121 {ListboxWidgetCmd procedure, "xview" option} -constraints { fonts } -setup { destroy .l2 listbox .l2 -width 10 -height 5 -font $fixed pack .l2 update } -body { .l2 insert 0 a b c d e f g h i j k l m n o p q r s t .l2 insert 1 "0123456789a123456789b123456789c123456789d123456789" .l2 xview 30 .l2 xview scroll -1 pages update format {%.6g %.6g} {*}[.l2 xview] } -cleanup { destroy .l2 } -result {0.44 0.64} test listbox-3.122 {ListboxWidgetCmd procedure, "xview" option} -constraints { fonts } -setup { destroy .l2 listbox .l2 -width 10 -height 5 -font $fixed pack .l2 update } -body { .l2 insert 0 a b c d e f g h i j k l m n o p q r s t .l2 insert 1 "0123456789a123456789b123456789c123456789d123456789" .l2 configure -width 1 update .l2 xview 30 .l2 xview scroll -4 pages update format {%.6g %.6g} {*}[.l2 xview] } -cleanup { destroy .l2 } -result {0.52 0.54} test listbox-3.123 {ListboxWidgetCmd procedure, "yview" option} -setup { destroy .l2 } -body { listbox .l2 pack .l2 update format {%.6g %.6g} {*}[.l2 yview] } -cleanup { destroy .l2 } -result {0 1} test listbox-3.124 {ListboxWidgetCmd procedure, "yview" option} -setup { destroy .l2 } -body { listbox .l2 .l2 insert 0 el1 pack .l2 update format {%.6g %.6g} {*}[.l2 yview] } -cleanup { destroy .l2 } -result {0 1} test listbox-3.125 {ListboxWidgetCmd procedure, "yview" option} -setup { destroy .l2 listbox .l2 -width 10 -height 5 -font $fixed pack .l2 update } -body { .l2 insert 0 a b c d e f g h i j k l m n o p q r s t .l2 yview 4 update format {%.6g %.6g} {*}[.l2 yview] } -cleanup { destroy .l2 } -result {0.2 0.45} test listbox-3.126 {ListboxWidgetCmd procedure, "yview" option, partial last line} -setup { destroy .l listbox .l -width 10 -height 5 -font $fixed pack .l update } -body { .l insert 0 a b c d e f g h i j k l m n o p q r s t mkPartial format {%.6g %.6g} {*}[.partial.l yview] } -cleanup { destroy .l } -result {0 0.266667} # Listbox used in 3.127 -3.137 tests destroy .l listbox .l -width 20 -height 5 -bd 4 -highlightthickness 1 -selectborderwidth 2 pack .l .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 el12 el13 el14 \ el15 el16 el17 update test listbox-3.127 {ListboxWidgetCmd procedure, "xview" option} -body { .l yview foo } -returnCodes error -result {bad listbox index "foo": must be active, anchor, end, @x,y, or a number} test listbox-3.128 {ListboxWidgetCmd procedure, "xview" option} -body { .l yview foo a b } -returnCodes error -result {unknown option "foo": must be moveto or scroll} test listbox-3.129 {ListboxWidgetCmd procedure, "xview" option} -setup { destroy .l2 listbox .l2 -width 10 -height 5 -font $fixed pack .l2 update } -body { .l2 insert 0 a b c d e f g h i j k l m n o p q r s t .l2 yview 0 .l2 yview moveto .31 format {%.6g %.6g} {*}[.l2 yview] } -cleanup { destroy .l2 } -result {0.3 0.55} test listbox-3.130 {ListboxWidgetCmd procedure, "xview" option} -setup { destroy .l2 listbox .l2 -width 10 -height 5 -font $fixed pack .l2 update } -body { .l2 insert 0 a b c d e f g h i j k l m n o p q r s t .l2 yview 2 .l2 yview scroll 2 pages format {%.6g %.6g} {*}[.l2 yview] } -cleanup { destroy .l2 } -result {0.4 0.65} test listbox-3.131 {ListboxWidgetCmd procedure, "xview" option} -setup { destroy .l2 listbox .l2 -width 10 -height 5 -font $fixed pack .l2 update } -body { .l2 insert 0 a b c d e f g h i j k l m n o p q r s t .l2 yview 10 .l2 yview scroll -3 units format {%.6g %.6g} {*}[.l2 yview] } -cleanup { destroy .l2 } -result {0.35 0.6} test listbox-3.132 {ListboxWidgetCmd procedure, "xview" option} -setup { destroy .l2 listbox .l2 -width 10 -height 5 -font $fixed pack .l2 update } -body { .l2 insert 0 a b c d e f g h i j k l m n o p q r s t .l2 configure -height 2 update .l2 yview 15 .l2 yview scroll -4 pages format {%.6g %.6g} {*}[.l2 yview] } -cleanup { destroy .l2 } -result {0.55 0.65} test listbox-3.133 {ListboxWidgetCmd procedure, "xview" option} -body { .l whoknows } -returnCodes error -result {bad option "whoknows": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, itemcget, itemconfigure, nearest, scan, see, selection, size, xview, or yview} test listbox-3.134 {ListboxWidgetCmd procedure, "xview" option} -body { .l c } -returnCodes error -result {ambiguous option "c": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, itemcget, itemconfigure, nearest, scan, see, selection, size, xview, or yview} test listbox-3.135 {ListboxWidgetCmd procedure, "xview" option} -body { .l in } -returnCodes error -result {ambiguous option "in": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, itemcget, itemconfigure, nearest, scan, see, selection, size, xview, or yview} test listbox-3.136 {ListboxWidgetCmd procedure, "xview" option} -body { .l s } -returnCodes error -result {ambiguous option "s": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, itemcget, itemconfigure, nearest, scan, see, selection, size, xview, or yview} test listbox-3.137 {ListboxWidgetCmd procedure, "xview" option} -body { .l se } -returnCodes error -result {ambiguous option "se": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, itemcget, itemconfigure, nearest, scan, see, selection, size, xview, or yview} # No tests for DestroyListbox: I can't come up with anything to test # in this procedure. test listbox-4.1 {ConfigureListbox procedure} -constraints { fonts } -setup { deleteWindows destroy .l listbox .l -setgrid 1 -width 25 -height 15 pack .l update } -body { set x [getsize .] .l configure -setgrid 0 update list $x [getsize .] } -cleanup { deleteWindows } -result {25x15 185x263} resetGridInfo test listbox-4.2 {ConfigureListbox procedure} -setup { deleteWindows destroy .l listbox .l -setgrid 1 -width 25 -height 15 pack .l update } -body { .l configure -highlightthickness -3 .l cget -highlightthickness } -cleanup { deleteWindows } -result {0} test listbox-4.3 {ConfigureListbox procedure} -setup { deleteWindows destroy .l listbox .l -setgrid 1 -width 25 -height 15 pack .l update } -body { .l configure -exportselection 0 .l delete 0 end .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 .l selection set 3 5 .l configure -exportselection 1 selection get } -cleanup { deleteWindows } -result {el3 el4 el5} test listbox-4.4 {ConfigureListbox procedure} -setup { deleteWindows listbox .l -setgrid 1 -width 25 -height 15 pack .l update } -body { entry .e .e insert 0 abc .e select from 0 .e select to 2 .l configure -exportselection 0 .l delete 0 end .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 .l selection set 3 5 .l selection clear 3 5 .l configure -exportselection 1 list [selection own] [selection get] } -cleanup { deleteWindows } -result {.e ab} test listbox-4.5 {-exportselection option} -setup { deleteWindows listbox .l -setgrid 1 -width 25 -height 15 pack .l update } -body { selection clear . .l configure -exportselection 1 .l delete 0 end .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 .l selection set 1 1 set x {} lappend x [catch {selection get} msg] $msg [.l curselection] .l config -exportselection 0 lappend x [catch {selection get} msg] $msg [.l curselection] .l selection clear 0 end lappend x [catch {selection get} msg] $msg [.l curselection] .l selection set 1 3 lappend x [catch {selection get} msg] $msg [.l curselection] .l config -exportselection 1 lappend x [catch {selection get} msg] $msg [.l curselection] } -cleanup { deleteWindows } -result {0 el1 1 1 {PRIMARY selection doesn't exist or form "STRING" not defined} 1 1 {PRIMARY selection doesn't exist or form "STRING" not defined} {} 1 {PRIMARY selection doesn't exist or form "STRING" not defined} {1 2 3} 0 {el1 el2 el3} {1 2 3}} test listbox-4.6 {ConfigureListbox procedure} -constraints { fonts } -setup { deleteWindows } -body { # The following code (reset geometry, withdraw, etc.) is necessary # to reset the state of some window managers like olvwm under # SunOS 4.1.3. wm geom . 300x300 update wm geom . {} wm withdraw . listbox .l2 -font $fixed -width 15 -height 20 pack .l2 update wm deiconify . set x [getsize .] .l2 configure -setgrid 1 update list $x [getsize .] } -cleanup { deleteWindows } -result {115x328 15x20} test listbox-4.7 {ConfigureListbox procedure} -setup { deleteWindows } -body { wm withdraw . listbox .l2 -font $fixed -width 30 -height 20 -setgrid 1 wm geom . +25+25 pack .l2 update wm deiconify . set result [getsize .] wm geom . 26x15 update lappend result [getsize .] .l2 configure -setgrid 1 update lappend result [getsize .] } -cleanup { deleteWindows wm geom . {} } -result {30x20 26x15 26x15} resetGridInfo test listbox-4.8 {ConfigureListbox procedure} -setup { destroy .l2 } -body { listbox .l2 -width 15 -height 20 -xscrollcommand "record x" \ -yscrollcommand "record y" pack .l2 update .l2 configure -fg black set log {} update set log } -cleanup { destroy .l2 } -result {{y 0 1} {x 0 1}} test listbox-4.9 {ConfigureListbox procedure, -listvar} -setup { destroy .l2 } -body { set x [list a b c d] listbox .l2 -listvar x .l2 get 0 end } -cleanup { destroy .l2 } -result [list a b c d] test listbox-4.10 {ConfigureListbox, no listvar -> existing listvar} -setup { destroy .l2 } -body { set x [list a b c d] listbox .l2 .l2 insert end 1 2 3 4 .l2 configure -listvar x .l2 get 0 end } -cleanup { destroy .l2 } -result [list a b c d] test listbox-4.11 {ConfigureListbox procedure, listvar -> no listvar} -setup { destroy .l2 } -body { set x [list a b c d] listbox .l2 -listvar x .l2 configure -listvar {} .l2 insert end 1 2 3 4 list $x [.l2 get 0 end] } -cleanup { destroy .l2 } -result [list [list a b c d] [list a b c d 1 2 3 4]] test listbox-4.12 {ConfigureListbox procedure, listvar -> different listvar} -setup { destroy .l2 } -body { set x [list a b c d] set y [list 1 2 3 4] listbox .l2 .l2 configure -listvar x .l2 configure -listvar y .l2 insert end 5 6 7 8 list $x $y } -cleanup { destroy .l2 } -result [list [list a b c d] [list 1 2 3 4 5 6 7 8]] test listbox-4.13 {ConfigureListbox, no listvar -> non-existant listvar} -setup { destroy .l2 } -body { catch {unset x} listbox .l2 .l2 insert end a b c d .l2 configure -listvar x set x } -cleanup { destroy .l2 } -result [list a b c d] test listbox-4.14 {ConfigureListbox, non-existant listvar} -setup { destroy .l2 } -body { catch {unset x} listbox .l2 -listvar x list [info exists x] $x } -cleanup { destroy .l2 } -result [list 1 {}] test listbox-4.15 {ConfigureListbox, listvar -> non-existant listvar} -setup { destroy .l2 } -body { catch {unset y} set x [list a b c d] listbox .l2 -listvar x .l2 configure -listvar y list [info exists y] $y } -cleanup { destroy .l2 } -result [list 1 [list a b c d]] test listbox-4.16 {ConfigureListbox, listvar -> same listvar} -setup { destroy .l2 } -body { set x [list a b c d] listbox .l2 -listvar x .l2 configure -listvar x set x } -cleanup { destroy .l2 } -result [list a b c d] test listbox-4.17 {ConfigureListbox, no listvar -> no listvar} -setup { destroy .l2 } -body { listbox .l2 .l2 insert end a b c d .l2 configure -listvar {} .l2 get 0 end } -cleanup { destroy .l2 } -result [list a b c d] test listbox-4.18 {ConfigureListbox, no listvar -> bad listvar} -setup { destroy .l2 } -body { listbox .l2 .l2 insert end a b c d set x "this is a \" bad list" catch {.l2 configure -listvar x} result list [.l2 get 0 end] [.l2 cget -listvar] $result } -cleanup { destroy .l2 } -result [list [list a b c d] {} \ "unmatched open quote in list: invalid -listvariable value"] test listbox-4.19 {ConfigureListbox, no listvar -> bad non-existent listvar} -setup { destroy .l2 } -body { unset -nocomplain ::foo listbox .l2 -listvar foo .l2 insert end a b c d catch {.l2 configure -listvar ::zoo::bar::foo} result list [.l2 get 0 end] [.l2 cget -listvar] $foo $result } -cleanup { destroy .l2 } -result [list [list a b c d] foo [list a b c d] \ {can't set "::zoo::bar::foo": parent namespace doesn't exist}] # No tests for DisplayListbox: I don't know how to test this procedure. test listbox-5.1 {ListboxComputeGeometry procedure} -constraints { fonts } -setup { destroy .l } -body { listbox .l -font $fixed -width 15 -height 20 pack .l list [winfo reqwidth .l] [winfo reqheight .l] } -result {115 328} test listbox-5.2 {ListboxComputeGeometry procedure} -constraints { fonts } -setup { destroy .l } -body { listbox .l -font $fixed -width 0 -height 10 pack .l update list [winfo reqwidth .l] [winfo reqheight .l] } -result {17 168} test listbox-5.3 {ListboxComputeGeometry procedure} -constraints { fonts } -setup { destroy .l } -body { listbox .l -font $fixed -width 0 -height 10 -bd 3 .l insert 0 Short "Really much longer" Longer pack .l update list [winfo reqwidth .l] [winfo reqheight .l] } -result {138 170} test listbox-5.4 {ListboxComputeGeometry procedure} -constraints { fonts } -setup { destroy .l } -body { listbox .l -font $fixed -width 10 -height 0 pack .l update list [winfo reqwidth .l] [winfo reqheight .l] } -result {80 24} test listbox-5.5 {ListboxComputeGeometry procedure} -constraints { fonts } -setup { destroy .l } -body { listbox .l -font $fixed -width 10 -height 0 -highlightthickness 0 .l insert 0 Short "Really much longer" Longer pack .l update list [winfo reqwidth .l] [winfo reqheight .l] } -result {76 52} test listbox-5.6 {ListboxComputeGeometry procedure} -setup { destroy .l } -body { # If "0" in selected font had 0 width, caused divide-by-zero error. pack [listbox .l -font {{open look glyph}}] update } -cleanup { destroy .l } -result {} # Listbox used in 6.*, 7.* tests destroy .l listbox .l -height 2 -xscrollcommand "record x" -yscrollcommand "record y" pack .l update test listbox-6.1 {InsertEls procedure} -body { .l delete 0 end .l insert end a b c d .l insert 5 x y z .l insert 2 A .l insert 0 q r s .l get 0 end } -result {q r s a b A c d x y z} test listbox-6.2 {InsertEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l selection anchor 2 .l insert 2 A B .l index anchor } -result {4} test listbox-6.3 {InsertEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l selection anchor 2 .l insert 3 A B .l index anchor } -result {2} test listbox-6.4 {InsertEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l yview 3 update .l insert 2 A B .l index @0,0 } -result {5} test listbox-6.5 {InsertEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l yview 3 update .l insert 3 A B .l index @0,0 } -result {3} test listbox-6.6 {InsertEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l activate 5 .l insert 5 A B .l index active } -result {7} test listbox-6.7 {InsertEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l activate 5 .l insert 6 A B .l index active } -result {5} test listbox-6.8 {InsertEls procedure} -body { .l delete 0 end .l insert 0 a b c .l index active } -result {2} test listbox-6.9 {InsertEls procedure} -body { .l delete 0 end .l insert 0 .l index active } -result {0} test listbox-6.10 {InsertEls procedure} -body { .l delete 0 end .l insert 0 a b "two words" c d e f g h i j update set log {} .l insert 0 word update set log } -result {{y 0 0.166667}} test listbox-6.11 {InsertEls procedure} -body { .l delete 0 end .l insert 0 a b "two words" c d e f g h i j update set log {} .l insert 0 "much longer entry" update set log } -result {{y 0 0.166667} {x 0 1}} test listbox-6.12 {InsertEls procedure} -constraints { fonts } -setup { destroy .l2 } -body { listbox .l2 -width 0 -height 0 pack .l2 -side top .l2 insert 0 a b "two words" c d set x {} lappend x [winfo reqwidth .l2] [winfo reqheight .l2] .l2 insert 0 "much longer entry" lappend x [winfo reqwidth .l2] [winfo reqheight .l2] } -cleanup { destroy .l2 } -result {80 93 122 110} test listbox-6.13 {InsertEls procedure, check -listvar update} -setup { destroy .l2 } -body { set x [list a b c d] listbox .l2 -listvar x .l2 insert 0 1 2 3 4 set x } -cleanup { destroy .l2 } -result [list 1 2 3 4 a b c d] test listbox-6.14 {InsertEls procedure, check selection update} -setup { destroy .l2 } -body { listbox .l2 .l2 insert 0 0 1 2 3 4 .l2 selection set 2 4 .l2 insert 0 a .l2 curselection } -cleanup { destroy .l2 } -result [list 3 4 5] test listbox-6.15 {InsertEls procedure, lost namespaced listvar} -body { destroy .l2 namespace eval test { variable foo {a b} } listbox .l2 -listvar ::test::foo namespace delete test .l2 insert end c d .l2 delete end .l2 insert end e f catch {set ::test::foo} result list [.l2 get 0 end] [.l2 cget -listvar] $result } -cleanup { destroy .l2 } -result [list [list a b c e f] ::test::foo \ {can't read "::test::foo": no such variable}] test listbox-7.1 {DeleteEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l selection set 1 6 .l delete 4 3 list [.l size] [selection get] } -result {10 {b c d e f g}} test listbox-7.2 {DeleteEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l selection set 3 6 .l delete 4 4 list [.l size] [.l get 4] [.l curselection] } -result {9 f {3 4 5}} test listbox-7.3 {DeleteEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l delete 0 3 list [.l size] [.l get 0] [.l get 1] } -result {6 e f} test listbox-7.4 {DeleteEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l delete 8 1000 list [.l size] [.l get 7] } -result {8 h} test listbox-7.5 {DeleteEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l selection anchor 2 .l delete 0 1 .l index anchor } -result {0} test listbox-7.6 {DeleteEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l selection anchor 2 .l delete 2 .l index anchor } -result {2} test listbox-7.7 {DeleteEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l selection anchor 4 .l delete 2 5 .l index anchor } -result {2} test listbox-7.8 {DeleteEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l selection anchor 3 .l delete 4 5 .l index anchor } -result {3} test listbox-7.9 {DeleteEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l yview 3 update .l delete 1 2 .l index @0,0 } -result {1} test listbox-7.10 {DeleteEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l yview 3 update .l delete 3 4 .l index @0,0 } -result {3} test listbox-7.11 {DeleteEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l yview 3 update .l delete 4 6 .l index @0,0 } -result {3} test listbox-7.12 {DeleteEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l yview 3 update .l delete 3 end .l index @0,0 } -result {1} test listbox-7.13 {DeleteEls procedure, updating view with partial last line} -body { mkPartial .partial.l yview 8 update .partial.l delete 10 13 .partial.l index @0,0 } -result {7} test listbox-7.14 {DeleteEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l activate 6 .l delete 3 4 .l index active } -result {4} test listbox-7.15 {DeleteEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l activate 6 .l delete 5 7 .l index active } -result {5} test listbox-7.16 {DeleteEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l activate 6 .l delete 5 end .l index active } -result {4} test listbox-7.17 {DeleteEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l activate 6 .l delete 0 end .l index active } -result {0} test listbox-7.18 {DeleteEls procedure} -body { .l delete 0 end .l insert 0 a b c "two words" d e f g h i j update set log {} .l delete 4 6 update set log } -result {{y 0 0.25}} test listbox-7.19 {DeleteEls procedure} -body { .l delete 0 end .l insert 0 a b c "two words" d e f g h i j update set log {} .l delete 3 update set log } -result {{y 0 0.2} {x 0 1}} test listbox-7.20 {DeleteEls procedure} -constraints { fonts } -setup { destroy .l2 } -body { listbox .l2 -width 0 -height 0 pack .l2 -side top .l2 insert 0 a b "two words" c d e f g set x {} lappend x [winfo reqwidth .l2] [winfo reqheight .l2] .l2 delete 2 4 lappend x [winfo reqwidth .l2] [winfo reqheight .l2] } -result {80 144 17 93} test listbox-7.21 {DeleteEls procedure, check -listvar update} -setup { destroy .l2 } -body { set x [list a b c d] listbox .l2 -listvar x .l2 delete 0 1 set x } -result [list c d] test listbox-8.1 {ListboxEventProc procedure} -constraints { fonts } -setup { destroy .l } -body { listbox .l -setgrid 1 pack .l update set x [getsize .] destroy .l list $x [getsize .] [winfo exists .l] [info command .l] } -cleanup { destroy .l } -result {20x10 150x178 0 {}} resetGridInfo test listbox-8.2 {ListboxEventProc procedure} -constraints { fonts } -setup { destroy .l } -body { listbox .l -height 5 -width 10 .l insert 0 a b c "A string that is very very long" d e f g h i j k pack .l update place .l -width 50 -height 80 update list [format {%.6g %.6g} {*}[.l xview]] [format {%.6g %.6g} {*}[.l yview]] } -cleanup { destroy .l } -result {{0 0.222222} {0 0.333333}} test listbox-8.3 {ListboxEventProc procedure} -setup { deleteWindows } -body { listbox .l1 -bg #543210 rename .l1 .l2 set x {} lappend x [winfo children .] lappend x [.l2 cget -bg] destroy .l1 lappend x [info command .l*] [winfo children .] } -cleanup { deleteWindows } -result {.l1 #543210 {} {}} test listbox-9.1 {ListboxCmdDeletedProc procedure} -setup { deleteWindows } -body { listbox .l1 rename .l1 {} list [info command .l*] [winfo children .] } -cleanup { deleteWindows } -result {{} {}} test listbox-9.2 {ListboxCmdDeletedProc procedure, disabling -setgrid} -constraints { fonts } -setup { destroy .top } -body { toplevel .top wm geom .top +0+0 listbox .top.l -setgrid 1 -width 20 -height 10 pack .top.l update set x [getsize .top] rename .top.l {} update lappend x [getsize .top] } -cleanup { destroy .top } -result {20x10 150x178} # Listbox used in 10.* tests destroy .l test listbox-10.1 {GetListboxIndex procedure} -setup { destroy .l } -body { pack [listbox .l] .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 .l activate 3 update list [.l activate 3; .l index active] [.l activate 6; .l index active] } -cleanup { destroy .l } -result {3 6} test listbox-10.2 {GetListboxIndex procedure} -setup { destroy .l } -body { pack [listbox .l] .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 .l selection anchor 2 update .l index anchor } -cleanup { destroy .l } -result 2 test listbox-10.3 {GetListboxIndex procedure} -setup { destroy .l } -body { pack [listbox .l] .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 .l insert end A B C D E .l selection anchor end update .l delete 12 end list [.l index anchor] [.l index end] } -cleanup { destroy .l } -result {12 12} test listbox-10.4 {GetListboxIndex procedure} -setup { destroy .l } -body { pack [listbox .l] .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 update .l index a } -cleanup { destroy .l } -returnCodes error -result {bad listbox index "a": must be active, anchor, end, @x,y, or a number} test listbox-10.5 {GetListboxIndex procedure} -setup { destroy .l } -body { pack [listbox .l] .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 update .l index end } -cleanup { destroy .l } -result {12} test listbox-10.6 {GetListboxIndex procedure} -setup { destroy .l } -body { pack [listbox .l] .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 update .l get end } -cleanup { destroy .l } -result {el11} test listbox-10.7 {GetListboxIndex procedure} -setup { destroy .l } -body { pack [listbox .l] .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 .l delete 0 end update .l index end } -cleanup { destroy .l } -result 0 test listbox-10.8 {GetListboxIndex procedure} -setup { destroy .l } -body { pack [listbox .l] .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 update .l index @ } -cleanup { destroy .l } -returnCodes error -result {bad listbox index "@": must be active, anchor, end, @x,y, or a number} test listbox-10.9 {GetListboxIndex procedure} -setup { destroy .l } -body { pack [listbox .l] .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 update .l index @foo } -cleanup { destroy .l } -returnCodes error -result {bad listbox index "@foo": must be active, anchor, end, @x,y, or a number} test listbox-10.10 {GetListboxIndex procedure} -setup { destroy .l } -body { pack [listbox .l] .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 update .l index @1x3 } -cleanup { destroy .l } -returnCodes error -result {bad listbox index "@1x3": must be active, anchor, end, @x,y, or a number} test listbox-10.11 {GetListboxIndex procedure} -setup { destroy .l } -body { pack [listbox .l] .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 update .l index @1, } -cleanup { destroy .l } -returnCodes error -result {bad listbox index "@1,": must be active, anchor, end, @x,y, or a number} test listbox-10.12 {GetListboxIndex procedure} -setup { destroy .l } -body { pack [listbox .l] .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 update .l index @1,foo } -cleanup { destroy .l } -returnCodes error -result {bad listbox index "@1,foo": must be active, anchor, end, @x,y, or a number} test listbox-10.13 {GetListboxIndex procedure} -setup { destroy .l } -body { pack [listbox .l] .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 update .l index @1,2x } -cleanup { destroy .l } -returnCodes error -result {bad listbox index "@1,2x": must be active, anchor, end, @x,y, or a number} test listbox-10.14 {GetListboxIndex procedure} -constraints { fonts } -setup { destroy .l } -body { pack [listbox .l] .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 update list [.l index @5,57] [.l index @5,58] } -cleanup { .l delete 0 end } -cleanup { destroy .l } -result {3 3} test listbox-10.15 {GetListboxIndex procedure} -setup { destroy .l } -body { pack [listbox .l] .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 update .l index 1xy } -cleanup { destroy .l } -returnCodes error -result {bad listbox index "1xy": must be active, anchor, end, @x,y, or a number} test listbox-10.16 {GetListboxIndex procedure} -setup { destroy .l } -body { pack [listbox .l] .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 update .l index 3 } -cleanup { destroy .l } -result {3} test listbox-10.17 {GetListboxIndex procedure} -setup { destroy .l } -body { pack [listbox .l] .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 update .l index 20 } -cleanup { destroy .l } -result {20} test listbox-10.18 {GetListboxIndex procedure} -setup { destroy .l } -body { pack [listbox .l] .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 update .l get 20 } -cleanup { destroy .l } -result {} test listbox-10.19 {GetListboxIndex procedure} -setup { destroy .l } -body { pack [listbox .l] .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 update .l index -2 } -cleanup { destroy .l } -result -2 test listbox-10.20 {GetListboxIndex procedure} -setup { destroy .l } -body { pack [listbox .l] .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 .l delete 0 end update .l index 1 } -cleanup { destroy .l } -result 1 test listbox-11.1 {ChangeListboxView procedure, boundary conditions for index} -setup { destroy .l } -body { listbox .l -height 5 pack .l .l insert 0 a b c d e f g h i j .l yview 3 update set x [.l index @0,0] .l yview -1 update lappend x [.l index @0,0] } -cleanup { destroy .l } -result {3 0} test listbox-11.2 {ChangeListboxView procedure, boundary conditions for index} -setup { destroy .l } -body { listbox .l -height 5 pack .l .l insert 0 a b c d e f g h i j .l yview 3 update set x [.l index @0,0] .l yview 20 update lappend x [.l index @0,0] } -cleanup { destroy .l } -result {3 5} test listbox-11.3 {ChangeListboxView procedure} -setup { destroy .l } -body { listbox .l -height 5 -yscrollcommand "record y" pack .l .l insert 0 a b c d e f g h i j update set log {} .l yview 2 update list [format {%.6g %.6g} {*}[.l yview]] $log } -cleanup { destroy .l } -result {{0.2 0.7} {{y 0.2 0.7}}} test listbox-11.4 {ChangeListboxView procedure} -setup { destroy .l } -body { listbox .l -height 5 -yscrollcommand "record y" pack .l .l insert 0 a b c d e f g h i j update set log {} .l yview 8 update list [format {%.6g %.6g} {*}[.l yview]] $log } -cleanup { destroy .l } -result {{0.5 1} {{y 0.5 1}}} test listbox-11.5 {ChangeListboxView procedure} -setup { destroy .l } -body { listbox .l -height 5 -yscrollcommand "record y" pack .l .l insert 0 a b c d e f g h i j .l yview 3 update set log {} .l yview 3 update list [format {%.6g %.6g} {*}[.l yview]] $log } -cleanup { destroy .l } -result {{0.3 0.8} {}} test listbox-11.6 {ChangeListboxView procedure, partial last line} -body { mkPartial .partial.l yview 13 .partial.l index @0,0 } -cleanup { destroy .l } -result {11} # Listbox used in 12.* tests destroy .l listbox .l -font $fixed -xscrollcommand "record x" -width 10 .l insert 0 0123456789a123456789b123456789c123456789d123456789e123456789f123456789g123456789h123456789i123456789 pack .l update test listbox-12.1 {ChangeListboxOffset procedure} -constraints { fonts } -body { set log {} .l xview 99 update list [format {%.6g %.6g} {*}[.l xview]] $log } -result {{0.9 1} {{x 0.9 1}}} test listbox-12.2 {ChangeListboxOffset procedure} -constraints { fonts } -body { set log {} .l xview 99 .l xview moveto -.25 update list [format {%.6g %.6g} {*}[.l xview]] $log } -result {{0 0.1} {{x 0 0.1}}} test listbox-12.3 {ChangeListboxOffset procedure} -constraints { fonts } -body { .l xview 10 update set log {} .l xview 10 update list [format {%.6g %.6g} {*}[.l xview]] $log } -result {{0.1 0.2} {}} # Listbox used in 13.* tests destroy .l listbox .l -font $fixed -width 10 -height 5 pack .l .l insert 0 a bb c d e f g h i j k l m n o p q r s .l insert 0 0123456789a123456789b123456789c123456789d123456789 update set width [expr [lindex [.l bbox 2] 2] - [lindex [.l bbox 1] 2]] set height [expr [lindex [.l bbox 2] 1] - [lindex [.l bbox 1] 1]] test listbox-13.1 {ListboxScanTo procedure} -constraints { fonts } -body { .l yview 0 .l xview 0 .l scan mark 10 20 .l scan dragto [expr 10-$width] [expr 20-$height] update list [format {%.6g %.6g} {*}[.l xview]] [format {%.6g %.6g} {*}[.l yview]] } -result {{0.2 0.4} {0.5 0.75}} test listbox-13.2 {ListboxScanTo procedure} -constraints { fonts } -body { .l yview 5 .l xview 10 .l scan mark 10 20 .l scan dragto 20 40 update set x [list [format {%.6g %.6g} {*}[.l xview]] [format {%.6g %.6g} {*}[.l yview]]] .l scan dragto [expr 20-$width] [expr 40-$height] update lappend x [format {%.6g %.6g} {*}[.l xview]] [format {%.6g %.6g} {*}[.l yview]] } -result {{0 0.2} {0 0.25} {0.2 0.4} {0.5 0.75}} test listbox-13.3 {ListboxScanTo procedure} -constraints { fonts } -body { .l yview moveto 1.0 .l xview moveto 1.0 .l scan mark 10 20 .l scan dragto 5 10 update set x [list [format {%.6g %.6g} {*}[.l xview]] [format {%.6g %.6g} {*}[.l yview]]] .l scan dragto [expr 5+$width] [expr 10+$height] update lappend x [format {%.6g %.6g} {*}[.l xview]] [format {%.6g %.6g} {*}[.l yview]] } -result {{0.8 1} {0.75 1} {0.64 0.84} {0.25 0.5}} test listbox-14.1 {NearestListboxElement procedure, partial last line} -body { mkPartial .partial.l nearest [winfo height .partial.l] } -result {4} # Listbox used in 14.* tests destroy .l listbox .l -font $fixed -width 20 -height 10 .l insert 0 a b c d e f g h i j k l m n o p q r s t .l yview 4 pack .l update test listbox-14.2 {NearestListboxElement procedure} -constraints { fonts } -body { .l index @50,0 } -result {4} test listbox-14.3 {NearestListboxElement procedure} -constraints { fonts } -body { list [.l index @50,35] [.l index @50,36] } -result {5 6} test listbox-14.4 {NearestListboxElement procedure} -constraints { fonts } -body { .l index @50,200 } -result {13} # Listbox used in 15.* 16.* and 17.* tests destroy .l listbox .l -font $fixed -width 20 -height 10 pack .l update test listbox-15.1 {ListboxSelect procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j k l m n o p .l select set 2 4 .l select set 7 12 .l select clear 4 7 .l curselection } -result {2 3 8 9 10 11 12} test listbox-15.2 {ListboxSelect procedure} -setup { destroy .e } -body { .l delete 0 end .l insert 0 a b c d e f g h i j k l m n o p entry .e .e insert 0 "This is some text" .e select from 0 .e select to 7 .l selection clear 2 4 set x [selection own] .l selection set 3 list $x [selection own] [selection get] } -cleanup { destroy .e } -result {.e .l d} test listbox-15.3 {ListboxSelect procedure} -body { .l delete 0 end .l selection clear 0 end .l select set 0 end .l curselection } -result {} test listbox-15.4 {ListboxSelect procedure, boundary conditions for indices} -body { .l delete 0 end .l insert 0 a b c d e f .l select clear 0 end .l select set -2 -1 .l curselection } -result {} test listbox-15.5 {ListboxSelect procedure, boundary conditions for indices} -body { .l delete 0 end .l insert 0 a b c d e f .l select clear 0 end .l select set -1 3 .l curselection } -result {0 1 2 3} test listbox-15.6 {ListboxSelect procedure, boundary conditions for indices} -body { .l delete 0 end .l insert 0 a b c d e f .l select clear 0 end .l select set 2 4 .l curselection } -result {2 3 4} test listbox-15.7 {ListboxSelect procedure, boundary conditions for indices} -body { .l delete 0 end .l insert 0 a b c d e f .l select clear 0 end .l select set 4 end .l curselection } -result {4 5} test listbox-15.8 {ListboxSelect procedure, boundary conditions for indices} -body { .l delete 0 end .l insert 0 a b c d e f .l select clear 0 end .l select set 4 30 .l curselection } -result {4 5} test listbox-15.9 {ListboxSelect procedure, boundary conditions for indices} -body { .l delete 0 end .l insert 0 a b c d e f .l select clear 0 end .l select set end 30 .l curselection } -result {5} test listbox-15.10 {ListboxSelect procedure, boundary conditions for indices} -body { .l delete 0 end .l insert 0 a b c d e f .l select clear 0 end .l select set 20 25 .l curselection } -result {} test listbox-16.1 {ListboxFetchSelection procedure} -body { .l delete 0 end .l insert 0 a b c "two words" e f g h i \\ k l m n o p .l selection set 2 4 .l selection set 9 .l selection set 11 12 selection get } -result "c\ntwo words\ne\n\\\nl\nm" test listbox-16.2 {ListboxFetchSelection procedure} -body { .l delete 0 end .l insert 0 a b c "two words" e f g h i \\ k l m n o p .l selection set 3 selection get } -result "two words" test listbox-16.3 {ListboxFetchSelection procedure, retrieve in several parts} -body { set long "This is quite a long string\n" append long $long $long $long $long append long $long $long $long $long append long $long $long .l delete 0 end .l insert 0 1$long 2$long 3$long 4$long 5$long .l selection set 0 end set sel [selection get] string compare 1$long\n2$long\n3$long\n4$long\n5$long $sel } -cleanup { catch {unset long sel} } -result {0} test listbox-17.1 {ListboxLostSelection procedure} -setup { destroy .e } -body { .l delete 0 end .l insert 0 a b c d e .l select set 0 end entry .e .e insert 0 "This is some text" .e select from 0 .e select to 5 .l curselection } -cleanup { destroy .e } -result {} test listbox-17.2 {ListboxLostSelection procedure} -setup { destroy .e } -body { .l delete 0 end .l insert 0 a b c d e .l select set 0 end .l configure -exportselection 0 entry .e .e insert 0 "This is some text" .e select from 0 .e select to 5 .l curselection } -cleanup { destroy .e } -result {0 1 2 3 4} # Listbox used in 18.* tests destroy .l listbox .l -font $fixed -width 10 -height 5 pack .l update test listbox-18.1 {ListboxUpdateVScrollbar procedure} -body { .l configure -yscrollcommand "record y" set log {} .l insert 0 a b c update .l insert end d e f g h update .l delete 0 end update set log } -result {{y 0 1} {y 0 0.625} {y 0 1}} test listbox-18.2 {ListboxUpdateVScrollbar procedure, partial last line} -body { mkPartial .partial.l configure -yscrollcommand "record y" set log {} .partial.l yview 3 update set log } -result {{y 0.2 0.466667}} test listbox-18.3 {ListboxUpdateVScrollbar procedure} -body { proc bgerror args { global x errorInfo set x [list $args $errorInfo] } .l configure -yscrollcommand gorp .l insert 0 foo update set x } -cleanup { rename bgerror {} } -result {{{invalid command name "gorp"}} {invalid command name "gorp" while executing "gorp 0.0 1.0" (vertical scrolling command executed by listbox)}} # Listbox used in 19.* tests destroy .l listbox .l -font $fixed -width 10 -height 5 pack .l update test listbox-19.1 {ListboxUpdateVScrollbar procedure} -constraints { fonts } -body { .l configure -xscrollcommand "record x" set log {} .l insert 0 abc update .l insert 0 "This is a much longer string..." update .l delete 0 end update set log } -result {{x 0 1} {x 0 0.322581} {x 0 1}} test listbox-19.2 {ListboxUpdateVScrollbar procedure} -body { proc bgerror args { global x errorInfo set x [list $args $errorInfo] } .l configure -xscrollcommand bogus .l insert 0 foo update set x } -result {{{invalid command name "bogus"}} {invalid command name "bogus" while executing "bogus 0.0 1.0" (horizontal scrolling command executed by listbox)}} test listbox-20.1 {listbox vs hidden commands} -setup { deleteWindows } -body { set l [interp hidden] listbox .l interp hide {} .l destroy .l set res1 [list [winfo children .] [interp hidden]] set res2 [list {} $l] expr {$res1 eq $res2} } -result 1 # tests for ListboxListVarProc test listbox-21.1 {ListboxListVarProc} -setup { destroy .l } -body { catch {unset x} listbox .l -listvar x set x [list a b c d] .l get 0 end } -cleanup { destroy .l } -result [list a b c d] test listbox-21.2 {ListboxListVarProc} -setup { destroy .l } -body { set x [list a b c d] listbox .l -listvar x unset x set x } -cleanup { destroy .l } -result [list a b c d] test listbox-21.3 {ListboxListVarProc} -setup { destroy .l } -body { set x [list a b c d] listbox .l -listvar x .l configure -listvar {} unset x info exists x } -cleanup { destroy .l } -result 0 test listbox-21.4 {ListboxListVarProc} -setup { destroy .l } -body { set x [list a b c d] listbox .l -listvar x lappend x e f g .l size } -cleanup { destroy .l } -result 7 test listbox-21.5 {ListboxListVarProc, test selection after listvar mod} -setup { destroy .l } -body { set x [list a b c d e f g] listbox .l -listvar x .l selection set end set x [list a b c d] set x [list 0 1 2 3 4 5 6] .l curselection } -cleanup { destroy .l } -result {} test listbox-21.6 {ListboxListVarProc, test selection after listvar mod} -setup { destroy .l } -body { set x [list a b c d] listbox .l -listvar x .l selection set 3 lappend x e f g .l curselection } -cleanup { destroy .l } -result 3 test listbox-21.7 {ListboxListVarProc, test selection after listvar mod} -setup { destroy .l } -body { set x [list a b c d] listbox .l -listvar x .l selection set 0 set x [linsert $x 0 1 2 3 4] .l curselection } -cleanup { destroy .l } -result 0 test listbox-21.8 {ListboxListVarProc, test selection after listvar mod} -setup { destroy .l } -body { set x [list a b c d] listbox .l -listvar x .l selection set 2 set x [list a b c] .l curselection } -cleanup { destroy .l } -result 2 test listbox-21.9 {ListboxListVarProc, test hscrollbar after listvar mod} -setup { destroy .l } -body { catch {unset x} set log {} listbox .l -font $fixed -width 10 -xscrollcommand "record x" -listvar x pack .l update lappend x "0000000000" update lappend x "00000000000000000000" update set log } -cleanup { destroy .l } -result [list {x 0 1} {x 0 1} {x 0 0.5}] test listbox-21.10 {ListboxListVarProc, test hscrollbar after listvar mod} -setup { destroy .l } -body { catch {unset x} set log {} listbox .l -font $fixed -width 10 -xscrollcommand "record x" -listvar x pack .l update lappend x "0000000000" update lappend x "00000000000000000000" update set x [list "0000000000"] update set log } -cleanup { destroy .l } -result [list {x 0 1} {x 0 1} {x 0 0.5} {x 0 1}] test listbox-21.11 {ListboxListVarProc, bad list} -setup { destroy .l } -body { catch {unset x} listbox .l -listvar x set x [list a b c d] catch {set x "this is a \" bad list"} result set result } -cleanup { destroy .l } -result {can't set "x": invalid listvar value} test listbox-21.12 {ListboxListVarProc, cleanup item attributes} -setup { destroy .l } -body { set x [list a b c d e f g] listbox .l -listvar x .l itemconfigure end -fg red set x [list a b c d] set x [list 0 1 2 3 4 5 6] .l itemcget end -fg } -cleanup { destroy .l } -result {} test listbox-21.12a {ListboxListVarProc, cleanup item attributes} -setup { destroy .l } -body { set x [list a b c d e f g] listbox .l -listvar x .l itemconfigure end -fg red set x [list a b c d] set x [list 0 1 2 3 4 5 6] .l itemcget end -fg } -cleanup { destroy .l } -result {} test listbox-21.13 {listbox item configurations and listvar based deletions} -setup { destroy .l } -body { catch {unset x} listbox .l -listvar x .l insert end a b c .l itemconfigure 1 -fg red set x [list b c] .l itemcget 1 -fg } -cleanup { destroy .l } -result red test listbox-21.14 {listbox item configurations and listvar based inserts} -setup { destroy .l } -body { catch {unset x} listbox .l -listvar x .l insert end a b c .l itemconfigure 0 -fg red set x [list 1 2 3 4 a b c] .l itemcget 0 -fg } -cleanup { destroy .l } -result red test listbox-21.15 {ListboxListVarProc, update vertical scrollbar} -setup { destroy .l } -body { catch {unset x} set log {} listbox .l -listvar x -yscrollcommand "record y" -font fixed -height 3 pack .l update lappend x a b c d e f update set log } -cleanup { destroy .l } -result [list {y 0 1} {y 0 0.5}] test listbox-21.16 {ListboxListVarProc, update vertical scrollbar} -setup { destroy .l } -body { catch {unset x} listbox .l -listvar x -height 3 pack .l update set x [list 0 1 2 3 4 5] .l yview scroll 3 units update set result {} lappend result [format {%.6g %.6g} {*}[.l yview]] set x [lreplace $x 3 3] set x [lreplace $x 3 3] set x [lreplace $x 3 3] update lappend result [format {%.6g %.6g} {*}[.l yview]] set result } -cleanup { destroy .l } -result [list {0.5 1} {0 1}] # UpdateHScrollbar test listbox-22.1 {UpdateHScrollbar} -setup { destroy .l } -body { set log {} listbox .l -font $fixed -width 10 -xscrollcommand "record x" pack .l update .l insert end "0000000000" update .l insert end "00000000000000000000" update set log } -cleanup { destroy .l } -result [list {x 0 1} {x 0 1} {x 0 0.5}] # ConfigureListboxItem test listbox-23.1 {ConfigureListboxItem} -setup { destroy .l } -body { listbox .l catch {.l itemconfigure 0} result set result } -cleanup { destroy .l } -result {item number "0" out of range} test listbox-23.2 {ConfigureListboxItem} -setup { destroy .l } -body { listbox .l .l insert end a b c d .l itemconfigure 0 } -cleanup { destroy .l } -result [list {-background background Background {} {}} \ {-bg -background} \ {-fg -foreground} \ {-foreground foreground Foreground {} {}} \ {-selectbackground selectBackground Foreground {} {}} \ {-selectforeground selectForeground Background {} {}}] test listbox-23.3 {ConfigureListboxItem, itemco shortcut} -setup { destroy .l } -body { listbox .l .l insert end a b c d .l itemco 0 -background } -cleanup { destroy .l } -result {-background background Background {} {}} test listbox-23.4 {ConfigureListboxItem, wrong num args} -setup { destroy .l } -body { listbox .l .l insert end a catch {.l itemco} result set result } -cleanup { destroy .l } -result {wrong # args: should be ".l itemconfigure index ?-option? ?value? ?-option value ...?"} test listbox-23.5 {ConfigureListboxItem, multiple calls} -setup { destroy .l } -body { listbox .l set i 0 foreach color {red orange yellow green blue white violet} { .l insert end $color .l itemconfigure $i -bg $color incr i } pack .l update list [.l itemcget 0 -bg] [.l itemcget 1 -bg] [.l itemcget 2 -bg] \ [.l itemcget 3 -bg] [.l itemcget 4 -bg] [.l itemcget 5 -bg] \ [.l itemcget 6 -bg] } -cleanup { destroy .l } -result {red orange yellow green blue white violet} # Listbox used in 23.6 -23.17 tests destroy .l listbox .l .l insert end a b c d test listbox-23.6 {configuration options} -body { .l itemconfigure 0 -background #ff0000 list [lindex [.l itemconfigure 0 -background] 4] [.l itemcget 0 -background] } -cleanup { .l configure -background #ffffff } -result {{#ff0000} #ff0000} test listbox-23.7 {configuration options} -body { .l configure -background non-existent } -returnCodes error -result {unknown color name "non-existent"} test listbox-23.8 {configuration options} -body { .l itemconfigure 0 -bg #ff0000 list [lindex [.l itemconfigure 0 -bg] 4] [.l itemcget 0 -bg] } -cleanup { .l configure -bg #ffffff } -result {{#ff0000} #ff0000} test listbox-23.9 {configuration options} -body { .l configure -bg non-existent } -returnCodes error -result {unknown color name "non-existent"} test listbox-23.10 {configuration options} -body { .l itemconfigure 0 -fg #110022 list [lindex [.l itemconfigure 0 -fg] 4] [.l itemcget 0 -fg] } -cleanup { .l configure -fg #000000 } -result {{#110022} #110022} test listbox-23.11 {configuration options} -body { .l configure -fg bogus } -returnCodes error -result {unknown color name "bogus"} test listbox-23.12 {configuration options} -body { .l itemconfigure 0 -foreground #110022 list [lindex [.l itemconfigure 0 -foreground] 4] [.l itemcget 0 -foreground] } -cleanup { .l configure -foreground #000000 } -result {{#110022} #110022} test listbox-23.13 {configuration options} -body { .l configure -foreground bogus } -returnCodes error -result {unknown color name "bogus"} test listbox-23.14 {configuration options} -body { .l itemconfigure 0 -selectbackground #110022 list [lindex [.l itemconfigure 0 -selectbackground] 4] [.l itemcget 0 -selectbackground] } -cleanup { .l configure -selectbackground #c3c3c3 } -result {{#110022} #110022} test listbox-23.15 {configuration options} -body { .l configure -selectbackground bogus } -returnCodes error -result {unknown color name "bogus"} test listbox-23.16 {configuration options} -body { .l itemconfigure 0 -selectforeground #654321 list [lindex [.l itemconfigure 0 -selectforeground] 4] [.l itemcget 0 -selectforeground] } -cleanup { .l configure -selectforeground #000000 } -result {{#654321} #654321} test listbox-23.17 {configuration options} -body { .l configure -selectforeground bogus } -returnCodes error -result {unknown color name "bogus"} # ListboxWidgetObjCmd, itemcget test listbox-24.1 {itemcget} -setup { destroy .l } -body { listbox .l .l insert end a b c d .l itemcget 0 -fg } -cleanup { destroy .l } -result {} test listbox-24.2 {itemcget} -setup { destroy .l } -body { listbox .l .l insert end a b c d .l itemconfigure 0 -fg red .l itemcget 0 -fg } -cleanup { destroy .l } -result red test listbox-24.3 {itemcget} -setup { destroy .l } -body { listbox .l .l insert end a b c d catch {.l itemcget 0} result set result } -cleanup { destroy .l } -result {wrong # args: should be ".l itemcget index option"} test listbox-24.4 {itemcget, itemcg shortcut} -setup { destroy .l } -body { listbox .l .l insert end a b c d catch {.l itemcg 0} result set result } -cleanup { destroy .l } -result {wrong # args: should be ".l itemcget index option"} # General item configuration issues test listbox-25.1 {listbox item configurations and widget based deletions} -setup { destroy .l } -body { listbox .l .l insert end a .l itemconfigure 0 -fg red .l delete 0 end .l insert end a .l itemcget 0 -fg } -cleanup { destroy .l } -result {} test listbox-25.2 {listbox item configurations and widget based inserts} -setup { destroy .l } -body { listbox .l .l insert end a b c .l itemconfigure 0 -fg red .l insert 0 1 2 3 4 list [.l itemcget 0 -fg] [.l itemcget 4 -fg] } -cleanup { destroy .l } -result {{} red} # state issues test listbox-26.1 {listbox disabled state disallows inserts} -setup { destroy .l } -body { listbox .l .l insert end a b c .l configure -state disabled .l insert end d e f .l get 0 end } -cleanup { destroy .l } -result [list a b c] test listbox-26.2 {listbox disabled state disallows deletions} -setup { destroy .l } -body { listbox .l .l insert end a b c .l configure -state disabled .l delete 0 end .l get 0 end } -cleanup { destroy .l } -result [list a b c] test listbox-26.3 {listbox disabled state disallows selection modification} -setup { destroy .l } -body { listbox .l .l insert end a b c .l selection set 0 .l selection set 2 .l configure -state disabled .l selection clear 0 end .l selection set 1 .l curselection } -cleanup { destroy .l } -result [list 0 2] test listbox-26.4 {listbox disabled state disallows anchor modification} -setup { destroy .l } -body { listbox .l .l insert end a b c .l selection anchor 0 .l configure -state disabled .l selection anchor 2 .l index anchor } -cleanup { destroy .l } -result 0 test listbox-26.5 {listbox disabled state disallows active modification} -setup { destroy .l } -body { listbox .l .l insert end a b c .l activate 0 .l configure -state disabled .l activate 2 .l index active } -cleanup { destroy .l } -result 0 test listbox-27.1 {widget deletion while active} -setup { destroy .l } -body { pack [listbox .l] update .l configure -cursor xterm -xscrollcommand { destroy .l } update idle winfo exists .l } -cleanup { destroy .l } -result 0 test listbox-28.1 {listbox -activestyle} -setup { destroy .l } -body { listbox .l -activ non .l cget -activestyle } -cleanup { destroy .l } -result none test listbox-28.2 {listbox -activestyle} -constraints { nonwin } -setup { destroy .l } -body { listbox .l .l cget -activestyle } -cleanup { destroy .l } -result dotbox test listbox-28.3 {listbox -activestyle} -constraints { win } -setup { destroy .l } -body { listbox .l .l cget -activestyle } -cleanup { destroy .l } -result underline test listbox-28.4 {listbox -activestyle} -setup { destroy .l } -body { listbox .l -activestyle und .l cget -activestyle } -cleanup { destroy .l } -result underline test listbox-29.1 {listbox selection behavior, -state disabled} -setup { destroy .l } -body { listbox .l .l insert end 1 2 3 .l selection set 2 set out [.l selection includes 2] .l configure -state disabled # still return 1 when disabled, because 'selection get' will work, # but selection cannot be changed (new behavior since 8.4) .l selection set 3 lappend out [.l selection includes 2] [.l curselection] } -cleanup { destroy .l } -result {1 1 2} test listbox-30.1 {Bug 3607326} -setup { destroy .l unset -nocomplain a } -body { array set a {} listbox .l -listvariable a } -cleanup { destroy .l unset -nocomplain a } -result * -match glob -returnCodes error test listbox-31.1 {<> event} -setup { destroy .l unset -nocomplain res } -body { pack [listbox .l -state normal] update bind .l <> {lappend res [%W curselection]} .l insert end a b c focus -force .l event generate .l <1> -x 5 -y 5 ; # <> fires .l configure -state disabled focus -force .l event generate .l ; # <> does NOT fire .l configure -state normal focus -force .l event generate .l ; # <> fires .l selection clear 0 end ; # <> does NOT fire .l selection set 1 1 ; # <> does NOT fire lappend res [.l curselection] } -cleanup { destroy .l unset -nocomplain res } -result {0 2 1} test listbox-31.2 {<> event on lost selection} -setup { destroy .l } -body { pack [listbox .l -exportselection true] update bind .l <> {lappend res [list [selection own] [%W curselection]]} .l insert end a b c focus -force .l event generate .l <1> -x 5 -y 5 ; # <> fires selection clear ; # <> fires again set res } -cleanup { destroy .l } -result {{.l 0} {{} {}}} resetGridInfo deleteWindows option clear # cleanup cleanupTests return tk8.6.5/tests/winSend.test0000644003604700454610000003326512377375532014167 0ustar dgp771div# This file is a Tcl script to test out the "send" command and the # other procedures in the file tkSend.c. It is organized in the # standard fashion for Tcl tests. # # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. package require tcltest 2.1 eval tcltest::configure $argv tcltest::loadTestedCommands # Compute a script that will load Tk into a child interpreter. foreach pkg [info loaded] { if {[lindex $pkg 1] == "Tk"} { set loadTk "load $pkg" break } } # Procedure to create a new application with a given name and class. proc newApp {name {safe {}}} { global loadTk if {[string compare $safe "-safe"] == 0} { interp create -safe $name } else { interp create $name } $name eval [list set argv [list -name $name]] catch {eval $loadTk $name} } set currentInterps [winfo interps] if { [testConstraint win] && [llength [info commands send]] && [catch {exec [interpreter] &}] == 0 } then { # Wait until the child application has launched. while {[llength [winfo interps]] == [llength $currentInterps]} {} # Now find an interp to send to set newInterps [winfo interps] foreach interp $newInterps { if {[lsearch -exact $currentInterps $interp] < 0} { break } } # Now we have found our interpreter we are going to send to. # Make sure that it works first. testConstraint winSend [expr {![catch { send $interp { console hide update } }]}] } else { testConstraint winSend 0 } # setting up dde server is done when the first interp is created and # cannot be tested very easily. test winSend-1.1 {Tk_SetAppName - changing name of interp} winSend { newApp testApp list [testApp eval tk appname testApp2] [interp delete testApp] } {testApp2 {}} test winSend-1.2 {Tk_SetAppName - changing name - not front of linked list} winSend { newApp testApp newApp testApp2 list [testApp eval tk appname testApp3] [interp delete testApp] [interp delete testApp2] } {testApp3 {} {}} test winSend-1.3 {Tk_SetAppName - unique name - no conflicts} winSend { newApp testApp list [testApp eval tk appname testApp] [interp delete testApp] } {testApp {}} test winSend-1.4 {Tk_SetAppName - unique name - one conflict} winSend { newApp testApp newApp foobar list [foobar eval tk appname testApp] [interp delete foobar] [interp delete testApp] } {{testApp #2} {} {}} test winSend-1.5 {Tk_SetAppName - unique name - one conflict} winSend { newApp testApp newApp foobar newApp blaz foobar eval tk appname testApp list [blaz eval tk appname testApp] [interp delete foobar] [interp delete testApp] [interp delete blaz] } {{testApp #3} {} {} {}} test winSend-1.6 {Tk_SetAppName - safe interps} winSend { newApp testApp -safe list [catch {testApp eval send testApp {set foo a}} msg] $msg [interp delete testApp] } {1 {invalid command name "send"} {}} test winSend-2.1 {Tk_SendObjCmd - # of args} winSend { list [catch {send tktest} msg] $msg } {1 {wrong # args: should be "send ?-option value ...? interpName arg ?arg ...?"}} test winSend-2.1a {Tk_SendObjCmd: arguments} winSend { list [catch {send -bogus tktest} msg] $msg } {1 {bad option "-bogus": must be -async, -displayof, or --}} test winSend-2.1b {Tk_SendObjCmd: arguments} winSend { list [catch {send -async bogus foo} msg] $msg } {1 {no registered server named "bogus"}} test winSend-2.1c {Tk_SendObjCmd: arguments} winSend { list [catch {send -displayof . bogus foo} msg] $msg } {1 {no registered server named "bogus"}} test winSend-2.1d {Tk_SendObjCmd: arguments} winSend { list [catch {send -- -bogus foo} msg] $msg } {1 {no registered server named "-bogus"}} test winSend-2.2 {Tk_SendObjCmd - sending to ourselves} winSend { list [send [tk appname] {set foo a}] } {a} test winSend-2.3 {Tk_SendObjCmd - sending to ourselves in a different interpreter} winSend { newApp testApp list [catch {send testApp {set foo b}} msg] $msg [interp delete testApp] } {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}\"} {}" test winSend-2.5 {Tk_SendObjCmd - sending to another app async} winSend { set newInterps [winfo interps] foreach interp $newInterps { if {[lsearch $currentInterps $interp] < 0} { break } } list [catch {send -async $interp {set foo a}} msg] $msg } {0 {}} test winSend-2.6 {Tk_SendObjCmd - sending to another app sync - no error} winSend { set newInterps [winfo interps] foreach interp $newInterps { if {[lsearch $currentInterps $interp] < 0} { break } } list [catch {send $interp {set foo a}} msg] $msg } {0 a} test winSend-2.7 {Tk_SendObjCmd - sending to another app - error} winSend { set newInterps [winfo interps] foreach interp $newInterps { if {[lsearch $currentInterps $interp] < 0} { 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}\"}" test winSend-3.1 {TkGetInterpNames} winSend { set origLength [llength $currentInterps] set newLength [llength [winfo interps]] expr {($newLength - 2) == $origLength} } {1} test winSend-4.1 {DeleteProc - changing name of app} winSend { newApp a list [a eval tk appname foo] [interp delete a] } {foo {}} test winSend-4.2 {DeleteProc - normal} winSend { newApp a list [interp delete a] } {{}} test winSend-5.1 {ExecuteRemoteObject - no error} winSend { set newInterps [winfo interps] foreach interp $newInterps { if {[lsearch $currentInterps $interp] < 0} { break } } list [send $interp {send [tk appname] {expr 2 / 1}}] } {2} test winSend-5.2 {ExecuteRemoteObject - error} winSend { set newInterps [winfo interps] foreach interp $newInterps { if {[lsearch $currentInterps $interp] < 0} { break } } list [catch {send $interp {send [tk appname] {expr 2 / 0}}} msg] $msg } {1 {divide by zero}} test winSend-6.1 {SendDDEServer - XTYP_CONNECT} winSend { set foo "Hello, World" set newInterps [winfo interps] foreach interp $newInterps { if {[lsearch $currentInterps $interp] < 0} { break } } set command "dde request Tk [tk appname] foo" list [catch "send \{$interp\} \{$command\}" msg] $msg } {0 {Hello, World}} test winSend-6.2 {SendDDEServer - XTYP_CONNECT_CONFIRM} winSend { set foo "Hello, World" set newInterps [winfo interps] foreach interp $newInterps { if {[lsearch $currentInterps $interp] < 0} { break } } set command "dde request Tk [tk appname] foo" list [catch "send \{$interp\} \{$command\}" msg] $msg } {0 {Hello, World}} test winSend-6.3 {SendDDEServer - XTYP_DISCONNECT} winSend { set foo "Hello, World" set newInterps [winfo interps] foreach interp $newInterps { if {[lsearch $currentInterps $interp] < 0} { break } } set command "dde request Tk [tk appname] foo" list [catch "send \{$interp\} \{$command\}" msg] $msg } {0 {Hello, World}} test winSend-6.4 {SendDDEServer - XTYP_REQUEST variable} winSend { set foo "Hello, World" set newInterps [winfo interps] foreach interp $newInterps { if {[lsearch $currentInterps $interp] < 0} { break } } set command "dde request Tk [tk appname] foo" list [catch "send \{$interp\} \{$command\}" msg] $msg } {0 {Hello, World}} test winSend-6.5 {SendDDEServer - XTYP_REQUEST array} winSend { catch {unset foo} set foo(test) "Hello, World" set newInterps [winfo interps] foreach interp $newInterps { if {[lsearch $currentInterps $interp] < 0} { break } } set command "dde request Tk [tk appname] foo(test)" list [catch "send \{$interp\} \{$command\}" msg] $msg [catch {unset foo}] } {0 {Hello, World} 0} test winSend-6.6 {SendDDEServer - XTYP_REQUEST return results} winSend { set foo 3 set newInterps [winfo interps] foreach interp $newInterps { if {[lsearch $currentInterps $interp] < 0} { break } } 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 { set newInterps [winfo interps] foreach interp $newInterps { if {[lsearch $currentInterps $interp] < 0} { break } } 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 { set newInterps [winfo interps] foreach interp $newInterps { if {[lsearch $currentInterps $interp] < 0} { break } } set command "dde services Tk {}" list [catch "send \{$interp\} \{$command\}"] } {0} test winSend-7.1 {DDEExitProc} winSend { newApp testApp list [interp delete testApp] } {{}} test winSend-8.1 {SendDdeConnect} winSend { set newInterps [winfo interps] foreach interp $newInterps { if {[lsearch $currentInterps $interp] < 0} { break } } list [send $interp {set tk foo}] } {foo} test winSend-9.1 {SetDDEError} winSend { list [catch {dde execute Tk foo {set foo hello}} msg] $msg } {1 {dde command failed}} test winSend-10.1 {Tk_DDEObjCmd - wrong num args} winSend { list [catch {dde} msg] $msg } {1 {wrong # args: should be "dde ?-async? serviceName topicName value"}} test winSend-10.2 {Tk_DDEObjCmd - unknown subcommand} winSend { list [catch {dde foo} msg] $msg } {1 {bad command "foo": must be execute, request, or services}} test winSend-10.3 {Tk_DDEObjCmd - execute - wrong num args} winSend { list [catch {dde execute} msg] $msg } {1 {wrong # args: should be "dde execute ?-async? serviceName topicName value"}} test winSend-10.4 {Tk_DDEObjCmd - execute - wrong num args} winSend { list [catch {dde execute 3 4 5 6 7} msg] $msg } {1 {wrong # args: should be "dde execute ?-async? serviceName topicName value"}} test winSend-10.5 {Tk_DDEObjCmd - execute async - wrong num args} winSend { list [catch {dde execute -async} msg] $msg } {1 {wrong # args: should be "dde execute ?-async? serviceName topicName value"}} test winSend-10.6 {Tk_DDEObjCmd - request - wrong num args} winSend { list [catch {dde request} msg] $msg } {1 {wrong # args: should be "dde request serviceName topicName value"}} test winSend-10.7 {Tk_DDEObjCmd - services wrong num args} winSend { list [catch {dde services} msg] $msg } {1 {wrong # args: should be "dde services serviceName topicName"}} test winSend-10.8 {Tk_DDEObjCmd - null service name} winSend { list [catch {dde services {} {tktest #2}}] } {0} test winSend-10.9 {Tk_DDEObjCmd - null topic name} winSend { list [catch {dde services {Tk} {}}] } {0} test winSend-10.10 {Tk_DDEObjCmd - execute - nothing to execute} winSend { set newInterps [winfo interps] foreach interp $newInterps { if {[lsearch $currentInterps $interp] < 0} { break } } list [catch {dde execute Tk $interp {}} msg] $msg } {1 {cannot execute null data}} test winSend-10.11 {Tk_DDEObjCmd - execute - no such conversation} winSend { list [catch {dde execute Tk foo {set foo hello}} msg] $msg } {1 {dde command failed}} test winSend-10.12 {Tk_DDEObjCmd - execute - async} winSend { set newInterps [winfo interps] foreach interp $newInterps { if {[lsearch $currentInterps $interp] < 0} { break } } list [catch {dde execute -async Tk $interp {set foo hello}} msg] $msg } {0 {}} test winSend-10.13 {Tk_DDEObjCmd - execute} winSend { set newInterps [winfo interps] foreach interp $newInterps { if {[lsearch $currentInterps $interp] < 0} { break } } list [catch {dde execute Tk $interp {set foo goodbye}} msg] $msg } {0 {}} test winSend-10.14 {Tk_DDEObjCmd - request - nothing to request} winSend { set newInterps [winfo interps] foreach interp $newInterps { if {[lsearch $currentInterps $interp] < 0} { break } } list [catch {dde request Tk $interp {}} msg] $msg } {1 {cannot request value of null data}} test winSend-10.15 {Tk_DDEObjCmd - request - invalid interp} winSend { set newInterps [winfo interps] foreach interp $newInterps { if {[lsearch $currentInterps $interp] < 0} { break } } list [catch {dde request Tk foo foo} msg] $msg } {1 {dde command failed}} test winSend-10.16 {Tk_DDEObjCmd - invalid variable} winSend { set newInterps [winfo interps] foreach interp $newInterps { if {[lsearch $currentInterps $interp] < 0} { break } } send $interp {unset foo} list [catch {dde request Tk $interp foo} msg] $msg } {1 {remote server cannot handle this command}} test winSend-10.17 {Tk_DDEObjCmd - valid variable} winSend { set newInterps [winfo interps] foreach interp $newInterps { if {[lsearch $currentInterps $interp] < 0} { break } } send $interp {set foo winSend-10.17} list [catch {dde request Tk $interp foo} msg] $msg } {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] } {0 1} # Get rid of the other app and all of its interps set newInterps [winfo interps] while {[llength $newInterps] != [llength $currentInterps]} { foreach interp $newInterps { if {[lsearch -exact $currentInterps $interp] < 0} { catch {send $interp exit} set newInterps [winfo interps] break } } } # cleanup cleanupTests return tk8.6.5/tests/image.test0000644003604700454610000004310112377375532013630 0ustar dgp771div# This file is a Tcl script to test out the "image" command and the # other procedures in the file tkImage.c. It is organized in the # standard fashion for Tcl tests. # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. package require tcltest 2.2 namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands imageInit # Canvas used in some tests in the whole file canvas .c -highlightthickness 2 pack .c update test image-1.1 {Tk_ImageCmd procedure, "create" option} -body { image } -returnCodes error -result {wrong # args: should be "image option ?args?"} test image-1.2 {Tk_ImageCmd procedure, "create" option} -body { image gorp } -returnCodes error -result {bad option "gorp": must be create, delete, height, inuse, names, type, types, or width} test image-1.3 {Tk_ImageCmd procedure, "create" option} -body { image create } -returnCodes error -result {wrong # args: should be "image create type ?name? ?-option value ...?"} 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 } -body { list [image create test myimage] [imageNames] } -cleanup { imageCleanup } -result {myimage myimage} test image-1.6 {Tk_ImageCmd procedure, "create" option} -constraints { 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 } -cleanup { imageCleanup } -result {1} test image-1.7 {Tk_ImageCmd procedure, "create" option} -constraints { testImageType } -setup { imageCleanup } -body { image create test myimage -variable x .c create image 100 50 -image myimage .c create image 100 150 -image myimage update set x {} image create test myimage -variable x update return $x } -cleanup { imageCleanup } -result {{myimage free} {myimage free} {myimage delete} {myimage get} {myimage get} {myimage display 0 0 30 15 30 30} {myimage display 0 0 30 15 30 130}} test image-1.8 {Tk_ImageCmd procedure, "create" option} -constraints { testImageType } -setup { .c delete all imageCleanup } -body { image create test myimage -variable x .c create image 100 50 -image myimage .c create image 100 150 -image myimage image delete myimage update set x {} image create test myimage -variable x update return $x } -cleanup { .c delete all imageCleanup } -result {{myimage get} {myimage get} {myimage display 0 0 30 15 30 30} {myimage display 0 0 30 15 30 130}} test image-1.9 {Tk_ImageCmd procedure, "create" option} -constraints { 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 } -body { catch {image create test -badName foo} imageNames } -result {} test image-1.11 {Tk_ImageCmd procedure, "create" option with same name as main window} -body { set code [loadTkCommand] append code { update puts [list [catch {image create photo .} msg] $msg] exit } set script [makeFile $code script] exec [interpreter] <$script } -cleanup { removeFile script } -result {1 {images may not be named the same as the main window}} test image-1.12 {Tk_ImageCmd procedure, "create" option with same name as main window after renaming} -body { set code [loadTkCommand] append code { update puts [list [catch {rename . foo;image create photo foo} msg] $msg] exit } set script [makeFile $code script] exec [interpreter] <$script } -cleanup { removeFile script } -result {1 {images may not be named the same as the main window}} test image-1.13 {Tk_ImageCmd, "create" option: do not generated command name in use} -setup { .c delete all imageCleanup } -body { set i [image create bitmap] regexp {^image(\d+)$} $i -> serial incr serial proc image$serial {} {return works} set j [image create bitmap] image$serial } -cleanup { rename image$serial {} image delete $i $j } -result works test image-2.1 {Tk_ImageCmd procedure, "delete" option} -body { image delete } -result {} test image-2.2 {Tk_ImageCmd procedure, "delete" option} -constraints { testImageType } -setup { imageCleanup set result {} } -body { image create test myimage image create test img2 lappend result [lsort [imageNames]] image d myimage img2 lappend result [imageNames] } -cleanup { imageCleanup } -result {{img2 myimage} {}} test image-2.3 {Tk_ImageCmd procedure, "delete" option} -constraints { testImageType } -setup { imageCleanup } -body { image create test myimage image create test img2 image delete myimage gorp img2 } -cleanup { imageCleanup } -returnCodes error -result {image "gorp" doesn't exist} test image-2.4 {Tk_ImageCmd procedure, "delete" option} -constraints { testImageType } -setup { imageCleanup } -body { image create test myimage image create test img2 catch {image delete myimage gorp img2} imageNames } -cleanup { imageCleanup } -result {img2} test image-3.1 {Tk_ImageCmd procedure, "height" option} -body { image height } -returnCodes error -result {wrong # args: should be "image height name"} test image-3.2 {Tk_ImageCmd procedure, "height" option} -body { image height a b } -returnCodes error -result {wrong # args: should be "image height name"} 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 } -setup { imageCleanup } -body { image create test myimage set x [image h myimage] myimage changed 0 0 0 0 60 50 list $x [image height myimage] } -cleanup { imageCleanup } -result {15 50} 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 } -setup { catch {interp delete testinterp} } -body { interp create testinterp load {} Tk testinterp interp eval testinterp { image delete {*}[image names] image create test myimage image create test img2 image create test 24613 lsort [image names] } } -cleanup { interp delete testinterp } -result {24613 img2 myimage} test image-4.3 {Tk_ImageCmd procedure, "names" option} -setup { catch {interp delete testinterp} } -body { interp create testinterp load {} Tk testinterp interp eval testinterp { image delete {*}[image names] eval image delete [image names] [image names] lsort [image names] } } -cleanup { interp delete testinterp } -result {} test image-5.1 {Tk_ImageCmd procedure, "type" option} -body { image type } -returnCodes error -result {wrong # args: should be "image type name"} test image-5.2 {Tk_ImageCmd procedure, "type" option} -body { image type a b } -returnCodes error -result {wrong # args: should be "image type name"} test image-5.3 {Tk_ImageCmd procedure, "type" option} -body { image type foo } -returnCodes error -result {image "foo" doesn't exist} test image-5.4 {Tk_ImageCmd procedure, "type" option} -constraints { testImageType } -setup { imageCleanup } -body { image create test myimage image type myimage } -cleanup { imageCleanup } -result {test} test image-5.5 {Tk_ImageCmd procedure, "type" option} -constraints { testImageType } -setup { imageCleanup } -body { image create test myimage .c create image 50 50 -image myimage image delete myimage image type myimage } -cleanup { imageCleanup } -returnCodes error -result {image "myimage" doesn't exist} test image-5.6 {Tk_ImageCmd procedure, "type" option} -constraints { testOldImageType } -setup { imageCleanup } -body { image create oldtest myimage image type myimage } -cleanup { imageCleanup } -result {oldtest} test image-5.7 {Tk_ImageCmd procedure, "type" option} -constraints { testOldImageType } -setup { .c delete all imageCleanup } -body { image create oldtest myimage .c create image 50 50 -image myimage image delete myimage image type myimage } -cleanup { .c delete all imageCleanup } -returnCodes error -result {image "myimage" doesn't exist} 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 } -body { lsort [image types] } -result {bitmap oldtest photo test} test image-7.1 {Tk_ImageCmd procedure, "width" option} -body { image width } -returnCodes error -result {wrong # args: should be "image width name"} test image-7.2 {Tk_ImageCmd procedure, "width" option} -body { image width a b } -returnCodes error -result {wrong # args: should be "image width name"} 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 } -setup { imageCleanup } -body { image create test myimage set x [image w myimage] myimage changed 0 0 0 0 60 50 list $x [image width myimage] } -cleanup { imageCleanup } -result {30 60} test image-8.1 {Tk_ImageCmd procedure, "inuse" option} -constraints { testImageType } -setup { imageCleanup set res {} destroy .b } -body { image create test myimage2 lappend res [image inuse myimage2] button .b -image myimage2 lappend res [image inuse myimage2] } -cleanup { imageCleanup catch {destroy .b} } -result [list 0 1] test image-9.1 {Tk_ImageChanged procedure} -constraints testImageType -setup { .c delete all imageCleanup } -body { image create test foo -variable x .c create image 50 50 -image foo update set x {} foo changed 5 6 7 8 30 15 update return $x } -cleanup { .c delete all imageCleanup } -result {{foo display 5 6 7 8 30 30}} test image-9.2 {Tk_ImageChanged procedure} -constraints testImageType -setup { .c delete all imageCleanup } -body { image create test foo -variable x .c create image 50 50 -image foo .c create image 90 100 -image foo update set x {} foo changed 5 6 7 8 30 15 update return $x } -cleanup { .c delete all imageCleanup } -result {{foo display 5 6 25 9 30 30} {foo display 0 0 12 14 65 74}} test image-10.1 {Tk_GetImage procedure} -setup { imageCleanup } -body { .c create image 100 10 -image bad_name } -cleanup { imageCleanup } -returnCodes error -result {image "bad_name" doesn't exist} test image-10.2 {Tk_GetImage procedure} -constraints testImageType -setup { destroy .l imageCleanup } -body { image create test mytest label .l -image mytest image delete mytest label .l2 -image mytest } -cleanup { destroy .l imageCleanup } -returnCodes error -result {image "mytest" doesn't exist} test image-11.1 {Tk_FreeImage procedure} -constraints testImageType -setup { .c delete all imageCleanup } -body { image create test foo -variable x .c create image 50 50 -image foo -tags i1 .c create image 90 100 -image foo -tags i2 pack forget .c update set x {} .c delete i1 pack .c update list [imageNames] $x } -cleanup { .c delete all imageCleanup } -result {foo {{foo free} {foo display 0 0 30 15 103 121}}} test image-11.2 {Tk_FreeImage procedure} -constraints testImageType -setup { .c delete all imageCleanup } -body { image create test foo -variable x .c create image 50 50 -image foo -tags i1 set names [imageNames] image delete foo update set names2 [imageNames] set x {} .c delete i1 pack forget .c pack .c update list $names $names2 [imageNames] $x } -cleanup { .c delete all imageCleanup } -result {foo {} {} {}} # Non-portable, apparently due to differences in rounding: test image-12.1 {Tk_RedrawImage procedure, redisplay area clipping} -constraints { testImageType nonPortable } -setup { imageCleanup } -body { image create test foo -variable x .c create image 50 60 -image foo -tags i1 -anchor nw update .c create rectangle 30 40 55 65 -width 0 -fill black -outline {} set x {} update return $x } -cleanup { imageCleanup } -result {{foo display 0 0 5 5 50 50}} test image-12.2 {Tk_RedrawImage procedure, redisplay area clipping} -constraints { testImageType nonPortable } -setup { imageCleanup } -body { image create test foo -variable x .c create image 50 60 -image foo -tags i1 -anchor nw update .c create rectangle 60 40 100 65 -width 0 -fill black -outline {} set x {} update return $x } -cleanup { imageCleanup } -result {{foo display 10 0 20 5 30 50}} test image-12.3 {Tk_RedrawImage procedure, redisplay area clipping} -constraints { testImageType nonPortable } -setup { imageCleanup } -body { image create test foo -variable x .c create image 50 60 -image foo -tags i1 -anchor nw update .c create rectangle 60 70 100 200 -width 0 -fill black -outline {} set x {} update return $x } -cleanup { imageCleanup } -result {{foo display 10 10 20 5 30 30}} test image-12.4 {Tk_RedrawImage procedure, redisplay area clipping} -constraints { testImageType nonPortable } -setup { imageCleanup } -body { image create test foo -variable x .c create image 50 60 -image foo -tags i1 -anchor nw update .c create rectangle 30 70 55 200 -width 0 -fill black -outline {} set x {} update return $x } -cleanup { imageCleanup } -result {{foo display 0 10 5 5 50 30}} test image-12.5 {Tk_RedrawImage procedure, redisplay area clipping} -constraints { testImageType nonPortable } -setup { imageCleanup } -body { image create test foo -variable x .c create image 50 60 -image foo -tags i1 -anchor nw update .c create rectangle 10 20 120 130 -width 0 -fill black -outline {} set x {} update return $x } -cleanup { imageCleanup } -result {{foo display 0 0 30 15 70 70}} test image-12.6 {Tk_RedrawImage procedure, redisplay area clipping} -constraints { testImageType nonPortable } -setup { imageCleanup } -body { image create test foo -variable x .c create image 50 60 -image foo -tags i1 -anchor nw update .c create rectangle 55 65 75 70 -width 0 -fill black -outline {} set x {} update return $x } -cleanup { imageCleanup } -result {{foo display 5 5 20 5 30 30}} test image-13.1 {Tk_SizeOfImage procedure} -constraints testImageType -setup { imageCleanup } -body { image create test foo -variable x set result [list [image width foo] [image height foo]] foo changed 0 0 0 0 85 60 lappend result [image width foo] [image height foo] } -cleanup { imageCleanup } -result {30 15 85 60} test image-13.2 {DeleteImage procedure} -constraints testImageType -setup { .c delete all imageCleanup } -body { image create test foo -variable x .c create image 50 50 -image foo -tags i1 .c create image 90 100 -image foo -tags i2 set x {} image delete foo lappend x | [imageNames] | [catch {image delete foo} msg] | $msg | [imageNames] | } -cleanup { imageCleanup } -result {{foo free} {foo free} {foo delete} | {} | 1 | {image "foo" doesn't exist} | {} |} test image-13.3 {Tk_SizeOfImage procedure} -constraints testOldImageType -setup { imageCleanup } -body { image create oldtest foo -variable x set result [list [image width foo] [image height foo]] foo changed 0 0 0 0 85 60 lappend result [image width foo] [image height foo] } -cleanup { imageCleanup } -result {30 15 85 60} test image-13.4 {DeleteImage procedure} -constraints testOldImageType -setup { .c delete all imageCleanup } -body { image create oldtest foo -variable x .c create image 50 50 -image foo -tags i1 .c create image 90 100 -image foo -tags i2 set x {} image delete foo lappend x | [imageNames] | [catch {image delete foo} msg] | $msg | [imageNames] | } -cleanup { .c delete all imageCleanup } -result {{foo free} {foo free} {foo delete} | {} | 1 | {image "foo" doesn't exist} | {} |} test image-14.1 {image command vs hidden commands} -body { catch {image delete hidden} set l [imageNames] set h [interp hidden] image create photo hidden interp hide {} hidden image delete hidden set res1 [list [imageNames] [interp hidden]] set res2 [list $l $h] expr {$res1 eq $res2} } -result 1 test image-15.1 {deleting image does not make widgets forget about it} -setup { .c delete all imageCleanup } -body { image create photo foo -width 10 -height 10 .c create image 10 10 -image foo -tags i1 -anchor nw update set x [.c bbox i1] lappend x [imageNames] image delete foo lappend x [imageNames] image create photo foo -width 20 -height 20 lappend x [.c bbox i1] [imageNames] } -cleanup { .c delete all imageCleanup } -result {10 10 20 20 foo {} {10 10 30 30} foo} destroy .c imageFinish # cleanup cleanupTests return # Local variables: # mode: tcl # End: tk8.6.5/tests/README0000644003604700454610000000032712077535536012527 0ustar dgp771divREADME -- Tk test suite design document. This directory contains a set of validation tests for the Tk commands. Please see the tests/README file in the Tcl source distribution for information about the test suite. tk8.6.5/tests/window.test0000644003604700454610000002152412377375532014062 0ustar dgp771div# This file is a Tcl script to test the procedures in the file # tkWindow.c. It is organized in the standard fashion for Tcl tests. # # Copyright (c) 1995 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. package require tcltest 2.2 namespace import ::tcltest::* tcltest::configure {*}$argv tcltest::loadTestedCommands namespace import ::tk::test::loadTkCommand update # XXX This file is woefully incomplete. Right now it only tests # a few parts of a few procedures in tkWindow.c # ---------------------------------------------------------------------- test window-1.1 {Tk_CreateWindowFromPath procedure, parent dead} -setup { destroy .t } -body { proc bgerror msg { global x errorInfo set x [list $msg $errorInfo] } set x unchanged frame .t -width 100 -height 50 place .t -x 10 -y 10 bind .t {button .t.b -text hello; pack .t.b} update destroy .t update set x } -cleanup { rename bgerror {} } -result {{can't create window: parent has been destroyed} {can't create window: parent has been destroyed while executing "button .t.b -text hello" (command bound to event)}} # Most of the tests below don't produce meaningful results; they # will simply dump core if there are bugs. test window-2.1 {Tk_DestroyWindow procedure, destroy handler deletes parent} -setup { destroy .t } -body { toplevel .t -width 300 -height 200 wm geometry .t +0+0 frame .t.f -width 200 -height 200 -relief raised -bd 2 place .t.f -x 0 -y 0 frame .t.f.f -width 100 -height 100 -relief raised -bd 2 place .t.f.f -relx 1 -rely 1 -anchor se bind .t.f {destroy .t} update destroy .t.f } -result {} test window-2.2 {Tk_DestroyWindow procedure, destroy handler deletes parent} -setup { destroy .t } -body { toplevel .t -width 300 -height 200 wm geometry .t +0+0 frame .t.f -width 200 -height 200 -relief raised -bd 2 place .t.f -x 0 -y 0 frame .t.f.f -width 100 -height 100 -relief raised -bd 2 place .t.f.f -relx 1 -rely 1 -anchor se bind .t.f.f {destroy .t} update destroy .t.f } -result {} test window-2.3 {Tk_DestroyWindow procedure, destroy handler deletes parent} -setup { destroy .f } -body { frame .f -width 80 -height 120 -relief raised -bd 2 place .f -relx 0.5 -rely 0.5 -anchor center toplevel .f.t -width 300 -height 200 wm geometry .f.t +0+0 frame .f.t.f -width 200 -height 200 -relief raised -bd 2 place .f.t.f -x 0 -y 0 frame .f.t.f.f -width 100 -height 100 -relief raised -bd 2 place .f.t.f.f -relx 1 -rely 1 -anchor se update destroy .f } -result {} test window-2.4 {Tk_DestroyWindow, cleanup half dead window at exit} -constraints { unixOrWin } -body { set code [loadTkCommand] append code { update bind . exit destroy . } set script [makeFile $code script] if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { set error 1 } else { set error 0 } removeFile script list $error $msg } -result {0 {}} test window-2.5 {Tk_DestroyWindow, cleanup half dead windows at exit} -constraints { unixOrWin } -body { set code [loadTkCommand] append code { toplevel .t update bind .t exit destroy .t } set script [makeFile $code script] if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { set error 1 } else { set error 0 } removeFile script list $error $msg } -result {0 {}} test window-2.6 {Tk_DestroyWindow, cleanup half dead windows at exit} -constraints { unixOrWin } -body { set code [loadTkCommand] append code { toplevel .t update bind .t exit destroy . } set script [makeFile $code script] if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { set error 1 } else { set error 0 } removeFile script list $error $msg } -result {0 {}} test window-2.7 {Tk_DestroyWindow, cleanup half dead windows at exit} -constraints { unixOrWin } -body { set code [loadTkCommand] append code { toplevel .t toplevel .t.f update bind .t.f exit destroy . } set script [makeFile $code script] if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { set error 1 } else { set error 0 } removeFile script list $error $msg } -result {0 {}} test window-2.8 {Tk_DestroyWindow, cleanup half dead windows at exit} -constraints { unixOrWin } -body { set code [loadTkCommand] append code { toplevel .t1 toplevel .t2 toplevel .t3 update bind .t3 {destroy .t2} bind .t2 {destroy .t1} bind .t1 {exit 0} destroy .t3 } set script [makeFile $code script] if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { set error 1 } else { set error 0 } removeFile script list $error $msg } -result {0 {}} test window-2.9 {Tk_DestroyWindow, Destroy bindings evaluated after exit} -constraints { unixOrWin } -body { set code [loadTkCommand] append code { toplevel .t1 toplevel .t2 update bind .t2 {puts "Destroy .t2" ; exit 1} bind .t1 {puts "Destroy .t1" ; exit 0} destroy .t2 } set script [makeFile $code script] if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { set error 1 } else { set error 0 } removeFile script list $error $msg } -result {0 {Destroy .t2 Destroy .t1}} test window-2.10 {Tk_DestroyWindow, Destroy binding evaluated once} -constraints { unixOrWin } -body { set code [loadTkCommand] append code { update bind . { puts "Destroy ." bind . {puts "Re-Destroy ."} exit 0 } destroy . } set script [makeFile $code script] if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { set error 1 } else { set error 0 } removeFile script list $error $msg } -result {0 {Destroy .}} test window-2.11 {Tk_DestroyWindow, don't reanimate a half-dead window} -constraints { unixOrWin } -body { set code [loadTkCommand] append code { toplevel .t1 toplevel .t2 update bind .t1 { if {[catch {entry .t2.newchild}]} { puts YES } else { puts NO } } bind .t2 {exit} destroy .t2 } set script [makeFile $code script] if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { set error 1 } else { set error 0 } removeFile script list $error $msg } -result {0 YES} test window-3.1 {Tk_MakeWindowExist procedure, stacking order and menubars} -constraints { unix testmenubar } -setup { destroy .t } -body { toplevel .t -width 300 -height 200 wm geometry .t +0+0 pack [entry .t.e] frame .t.f -bd 2 -relief raised testmenubar window .t .t.f update # If stacking order isn't handle properly, generates an X error. } -cleanup { destroy .t } -result {} test window-3.2 {Tk_MakeWindowExist procedure, stacking order and menubars} -constraints { unix testmenubar } -setup { destroy .t } -body { toplevel .t -width 300 -height 200 wm geometry .t +0+0 pack [entry .t.e] pack [entry .t.e2] update frame .t.f -bd 2 -relief raised raise .t.f .t.e testmenubar window .t .t.f update # If stacking order isn't handled properly, generates an X error. } -cleanup { destroy .t } -result {} test window-4.1 {Tk_NameToWindow procedure} -constraints { testmenubar } -setup { destroy .t } -body { winfo geometry .t } -cleanup { destroy .t } -returnCodes error -result {bad window path name ".t"} test window-4.2 {Tk_NameToWindow procedure} -constraints { testmenubar } -setup { destroy .t } -body { frame .t -width 100 -height 50 place .t -x 10 -y 10 update winfo geometry .t } -cleanup { destroy .t } -returnCodes ok -result {100x50+10+10} test window-5.1 {Tk_MakeWindowExist procedure, stacking order and menubars} -constraints { unix testmenubar } -setup { destroy .t } -body { toplevel .t -width 300 -height 200 wm geometry .t +0+0 pack [entry .t.e] pack [entry .t.e2] frame .t.f -bd 2 -relief raised testmenubar window .t .t.f update lower .t.e2 .t.f update # If stacking order isn't handled properly, generates an X error. } -cleanup { destroy .t } -result {} # cleanup cleanupTests return # Local variables: # mode: tcl # End: tk8.6.5/tests/canvPsArc.tcl0000644003604700454610000000340412077535536014232 0ustar dgp771div# This file creates a screen to exercise Postscript generation # for bitmaps in canvases. It is part of the Tk visual test suite, # which is invoked via the "visual" script. catch {destroy .t} toplevel .t wm title .t "Postscript Tests for Canvases" wm iconname .t "Postscript" wm geom .t +0+0 wm minsize .t 1 1 set c .t.c message .t.m -text {This screen exercises the Postscript-generation abilities of Tk canvas widgets for arcs. Click on "Print" to print the canvas to your default printer. You can click on items in the canvas to delete them.} -width 6i pack .t.m -side top -fill both frame .t.bot pack .t.bot -side bottom -fill both button .t.bot.quit -text Quit -command {destroy .t} button .t.bot.print -text Print -command "lpr $c" pack .t.bot.print .t.bot.quit -side left -pady 1m -expand 1 canvas $c -width 6i -height 6i -bd 2 -relief sunken pack $c -expand yes -fill both -padx 2m -pady 2m $c create arc .5i .5i 2i 2i -style pieslice -start 20 -extent 90 \ -fill black -outline {} $c create arc 2.5i 0 4.5i 1i -style pieslice -start -45 -extent -135 \ -fill {} -outline black -outlinestipple gray50 -width 3m $c create arc 5.0i .5i 6.5i 2i -style pieslice -start 45 -extent 315 \ -fill black -stipple gray25 -outline black -width 1m $c create arc -.5i 2.5i 2.0i 3.5i -style chord -start 90 -extent 270 \ -fill black -outline {} $c create arc 2.5i 2i 4i 6i -style chord -start 20 -extent 140 \ -fill black -stipple gray50 -outline black -width 2m $c create arc 4i 2.5i 8i 4.5i -style chord -start 60 -extent 60 \ -fill {} -outline black $c create arc .5i 4.5i 2i 6i -style arc -start 135 -extent 315 -width 3m \ -outline black -outlinestipple gray25 $c create arc 3.5i 4.5i 5.5i 5.5i -style arc -start 45 -extent -90 -width 1m \ -outline black tk8.6.5/tests/packgrid.test0000644003604700454610000001354012377375532014336 0ustar dgp771div# This file is a Tcl script to test out interaction between Tk's "pack" and # "grid" commands. # It is organized in the standard fashion for Tcl tests. # # Copyright (c) 2008 Peter Spjuth # All rights reserved. package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands namespace import -force tcltest::* test packgrid-1.1 {pack and grid in same master} -setup { grid propagate . true pack propagate . true label .p -text PACK label .g -text GRID } -body { # Basic conflict grid .g pack .p } -returnCodes error -cleanup { destroy .p destroy .g } -result {cannot use geometry manager pack inside . which already has slaves managed by grid} test packgrid-1.2 {pack and grid in same master} -setup { grid propagate . true pack propagate . true label .p -text PACK label .g -text GRID } -body { # Basic conflict pack .p grid .g } -returnCodes error -cleanup { destroy .p destroy .g } -result {cannot use geometry manager grid inside . which already has slaves managed by pack} test packgrid-1.3 {pack and grid in same master} -setup { grid propagate . false pack propagate . true label .p -text PACK label .g -text GRID } -body { # Ok if one is non-propagating grid .g pack .p } -cleanup { destroy .p destroy .g } -result {} test packgrid-1.4 {pack and grid in same master} -setup { grid propagate . false pack propagate . true label .p -text PACK label .g -text GRID } -body { # Ok if one is non-propagating pack .p grid .g } -cleanup { destroy .p destroy .g } -result {} test packgrid-1.5 {pack and grid in same master} -setup { grid propagate . true pack propagate . false label .p -text PACK label .g -text GRID } -body { # Ok if one is non-propagating grid .g pack .p } -cleanup { destroy .p destroy .g } -result {} test packgrid-1.6 {pack and grid in same master} -setup { grid propagate . true pack propagate . false label .p -text PACK label .g -text GRID } -body { # Ok if one is non-propagating pack .p grid .g } -cleanup { destroy .p destroy .g } -result {} test packgrid-1.7 {pack and grid in same master} -setup { grid propagate . true pack propagate . true label .p -text PACK label .g -text GRID } -body { # Basic conflict should stop widget from being handled grid .g catch { pack .p } pack slaves . } -cleanup { destroy .p destroy .g } -result {} test packgrid-1.8 {pack and grid in same master} -setup { grid propagate . true pack propagate . true label .p -text PACK label .g -text GRID } -body { # Basic conflict should stop widget from being handled pack .p catch { grid .g } grid slaves . } -cleanup { destroy .p destroy .g } -result {} test packgrid-2.1 {pack and grid in same master, change propagation} -setup { grid propagate . false pack propagate . true label .p -text PACK label .g -text GRID pack .p grid .g update } -body { grid propagate . true } -returnCodes error -cleanup { destroy .p destroy .g } -result {cannot use geometry manager grid inside . which already has slaves managed by pack} test packgrid-2.2 {pack and grid in same master, change propagation} -setup { grid propagate . true pack propagate . false label .p -text PACK label .g -text GRID pack .p grid .g update } -body { pack propagate . true } -returnCodes error -cleanup { destroy .p update destroy .g } -result {cannot use geometry manager pack inside . which already has slaves managed by grid} test packgrid-2.3 {pack and grid in same master, change propagation} -setup { grid propagate . false pack propagate . false label .p -text PACK label .g -text GRID pack .p grid .g update } -body { grid propagate . true update pack propagate . true } -returnCodes error -cleanup { destroy .p destroy .g } -result {cannot use geometry manager pack inside . which already has slaves managed by grid} test packgrid-2.4 {pack and grid in same master, change propagation} -setup { grid propagate . false pack propagate . false label .p -text PACK label .g -text GRID pack .p grid .g update } -body { pack propagate . true grid propagate . true } -returnCodes error -cleanup { destroy .p destroy .g } -result {cannot use geometry manager grid inside . which already has slaves managed by pack} test packgrid-3.1 {stealing slave} -setup { grid propagate . true pack propagate . true label .p -text PACK label .g -text GRID } -body { # Ok to steal if the other one is emptied grid .g pack .g } -cleanup { destroy .p destroy .g } -result {} test packgrid-3.2 {stealing slave} -setup { grid propagate . true pack propagate . true label .p -text PACK label .g -text GRID } -body { # Ok to steal if the other one is emptied pack .g grid .g } -cleanup { destroy .p destroy .g } -result {} test packgrid-3.3 {stealing slave} -setup { grid propagate . true pack propagate . true label .p -text PACK label .g -text GRID } -body { # Not ok to steal if the other one is not emptied grid .g grid .p pack .g } -returnCodes error -cleanup { destroy .p destroy .g } -result {cannot use geometry manager pack inside . which already has slaves managed by grid} test packgrid-3.4 {stealing slave} -setup { grid propagate . true pack propagate . true label .p -text PACK label .g -text GRID } -body { # Not ok to steal if the other one is not emptied pack .g pack .p grid .g } -returnCodes error -cleanup { destroy .p destroy .g } -result {cannot use geometry manager grid inside . which already has slaves managed by pack} cleanupTests return tk8.6.5/tests/textImage.test0000644003604700454610000003244612471106105014466 0ustar dgp771div# textImage.test -- test images embedded in text widgets # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. package require tcltest 2.2 namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands imageInit # One time setup. Create a font to insure the tests are font metric invariant. destroy .t font create test_font -family courier -size 14 text .t -font test_font destroy .t test textImage-1.1 {basic argument checking} -setup { destroy .t } -body { text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 pack .t .t image } -cleanup { destroy .t } -returnCodes error -result {wrong # args: should be ".t image option ?arg ...?"} test textImage-1.2 {basic argument checking} -setup { destroy .t } -body { text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 pack .t .t image c } -cleanup { destroy .t } -returnCodes error -result {ambiguous option "c": must be cget, configure, create, or names} test textImage-1.3 {cget argument checking} -setup { destroy .t } -body { text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 pack .t .t image cget } -cleanup { destroy .t } -returnCodes error -result {wrong # args: should be ".t image cget index option"} test textImage-1.4 {cget argument checking} -setup { destroy .t } -body { text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 pack .t .t image cget blurf -flurp } -cleanup { destroy .t } -returnCodes error -result {bad text index "blurf"} test textImage-1.5 {cget argument checking} -setup { destroy .t } -body { text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 pack .t .t image cget 1.1 -flurp } -cleanup { destroy .t } -returnCodes error -result {no embedded image at index "1.1"} test textImage-1.6 {configure argument checking} -setup { destroy .t } -body { text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 pack .t .t image configure } -cleanup { destroy .t } -returnCodes error -result {wrong # args: should be ".t image configure index ?-option value ...?"} test textImage-1.7 {configure argument checking} -setup { destroy .t } -body { text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 pack .t .t image configure blurf } -cleanup { destroy .t } -returnCodes error -result {bad text index "blurf"} test textImage-1.8 {configure argument checking} -setup { destroy .t } -body { text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 pack .t .t image configure 1.1 } -cleanup { destroy .t } -returnCodes error -result {no embedded image at index "1.1"} test textImage-1.9 {create argument checking} -setup { destroy .t } -body { text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 pack .t .t image create } -cleanup { destroy .t } -returnCodes error -result {wrong # args: should be ".t image create index ?-option value ...?"} test textImage-1.10 {create argument checking} -setup { destroy .t } -body { text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 pack .t .t image create blurf } -cleanup { destroy .t } -returnCodes error -result {bad text index "blurf"} test textImage-1.11 {basic argument checking} -setup { destroy .t } -body { catch { image create photo small -width 5 -height 5 small put red -to 0 0 4 4 } text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 pack .t .t image create 1000.1000 -image small } -cleanup { destroy .t image delete small } -returnCodes ok -result {small} test textImage-1.12 {names argument checking} -setup { destroy .t } -body { text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 pack .t .t image names dates places } -cleanup { destroy .t } -returnCodes error -result {wrong # args: should be ".t image names"} test textImage-1.13 {names argument checking} -setup { destroy .t set result "" } -body { catch { image create photo small -width 5 -height 5 small put red -to 0 0 4 4 } text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 pack .t lappend result [.t image names] .t image create insert -image small lappend result [.t image names] .t image create insert -image small lappend result [lsort [.t image names]] .t image create insert -image small -name little lappend result [lsort [.t image names]] } -cleanup { destroy .t image delete small } -result {{} small {small small#1} {little small small#1}} test textImage-1.14 {basic argument checking} -setup { destroy .t } -body { text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 pack .t .t image huh } -cleanup { destroy .t } -returnCodes error -result {bad option "huh": must be cget, configure, create, or names} test textImage-1.15 {align argument checking} -setup { destroy .t } -body { catch { image create photo small -width 5 -height 5 small put red -to 0 0 4 4 } text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 pack .t .t image create end -image small -align wrong } -cleanup { destroy .t image delete small } -returnCodes error -result {bad align "wrong": must be baseline, bottom, center, or top} test textImage-1.16 {configure} -setup { destroy .t } -body { catch { image create photo small -width 5 -height 5 small put red -to 0 0 4 4 } text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 pack .t .t image create end -image small .t image configure small } -cleanup { destroy .t image delete small } -result {{-align {} {} center center} {-padx {} {} 0 0} {-pady {} {} 0 0} {-image {} {} {} small} {-name {} {} {} {}}} test textImage-1.17 {basic cget options} -setup { destroy .t set result "" } -body { catch { image create photo small -width 5 -height 5 small put red -to 0 0 4 4 } text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 pack .t .t image create end -image small foreach i {align padx pady image name} { lappend result $i:[.t image cget small -$i] } return $result } -cleanup { destroy .t image delete small } -result {align:center padx:0 pady:0 image:small name:} test textImage-1.18 {basic configure options} -setup { destroy .t set result "" } -body { catch { image create photo small -width 5 -height 5 small put red -to 0 0 4 4 image create photo large -width 50 -height 50 large put green -to 0 0 50 50 } text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 pack .t .t image create end -image small foreach {option value} {align top padx 5 pady 7 image large name none} { .t image configure small -$option $value } update .t image configure small } -cleanup { destroy .t image delete small large } -result {{-align {} {} center top} {-padx {} {} 0 5} {-pady {} {} 0 7} {-image {} {} {} large} {-name {} {} {} none}} test textImage-1.19 {basic image naming} -setup { destroy .t } -body { catch { image create photo small -width 5 -height 5 small put red -to 0 0 4 4 } text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 pack .t .t image create end -image small .t image create end -image small -name small .t image create end -image small -name small#6342 .t image create end -image small -name small lsort [.t image names] } -cleanup { destroy .t image delete small } -result {small small#1 small#6342 small#6343} test textImage-2.1 {debug} -setup { destroy .t } -body { catch { image create photo small -width 5 -height 5 small put red -to 0 0 4 4 } text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 pack .t .t debug 1 .t insert end front .t image create end -image small .t insert end back .t delete small .t image names .t debug 0 } -cleanup { destroy .t image delete small } -result {} test textImage-3.1 {image change propagation} -setup { destroy .t set result "" } -body { catch { image create photo vary -width 5 -height 5 vary put red -to 0 0 4 4 } text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 pack .t .t image create end -image vary -align top update lappend result base:[.t bbox vary] foreach i {10 20 40} { vary configure -width $i -height $i update lappend result $i:[.t bbox vary] } return $result } -cleanup { destroy .t image delete vary } -result {{base:0 0 5 5} {10:0 0 10 10} {20:0 0 20 20} {40:0 0 40 40}} test textImage-3.2 {delayed image management, see also bug 1591493} -setup { destroy .t set result "" } -body { catch { image create photo small -width 5 -height 5 small put red -to 0 0 4 4 } text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 pack .t .t image create end -name test update foreach {x1 y1 w1 h1} [.t bbox test] {} lappend result [list $x1 $w1 $h1] .t image configure test -image small -align top update foreach {x2 y2 w2 h2} [.t bbox test] {} lappend result [list [expr {$x1==$x2}] [expr {$w2>0}] [expr {$h2>0}]] } -cleanup { destroy .t image delete small } -result {{0 0 0} {1 1 1}} # some temporary random tests test textImage-4.1 {alignment checking - except baseline} -setup { destroy .t set result "" } -body { catch { image create photo small -width 5 -height 5 small put red -to 0 0 4 4 image create photo large -width 50 -height 50 large put green -to 0 0 50 50 } text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 pack .t .t image create end -image large .t image create end -image small .t insert end test update lappend result default:[.t bbox small] foreach i {top bottom center} { .t image configure small -align $i update lappend result [.t image cget small -align]:[.t bbox small] } return $result } -cleanup { destroy .t image delete small large } -result {{default:50 22 5 5} {top:50 0 5 5} {bottom:50 45 5 5} {center:50 22 5 5}} test textImage-4.2 {alignment checking - baseline} -setup { destroy .t set result "" } -body { catch { image create photo small -width 5 -height 5 small put red -to 0 0 4 4 image create photo large -width 50 -height 50 large put green -to 0 0 50 50 } font create test_font2 -size 5 text .t -font test_font2 -bd 0 -highlightthickness 0 -padx 0 -pady 0 pack .t .t image create end -image large .t image create end -image small -align baseline .t insert end test # Sizes larger than 25 can be too big and lead to a negative 'norm', # at least on Windows XP with certain settings. foreach size {10 15 20 25} { font configure test_font2 -size $size array set Metrics [font metrics test_font2] update foreach {x y w h} [.t bbox small] {} set norm [expr { (([image height large] - $Metrics(-linespace))/2 + $Metrics(-ascent) - [image height small] - $y) }] lappend result "$size $norm" } return $result } -cleanup { destroy .t image delete small large font delete test_font2 unset Metrics } -result {{10 0} {15 0} {20 0} {25 0}} test textImage-4.3 {alignment and padding checking} -constraints { fonts } -setup { destroy .t set result "" } -body { catch { image create photo small -width 5 -height 5 small put red -to 0 0 4 4 image create photo large -width 50 -height 50 large put green -to 0 0 50 50 } text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 pack .t .t image create end -image large .t image create end -image small -padx 5 -pady 10 .t insert end test update lappend result default:[.t bbox small] foreach i {top bottom center baseline} { .t image configure small -align $i update lappend result $i:[.t bbox small] } return $result } -cleanup { destroy .t image delete small large } -result {{default:55 22 5 5} {top:55 10 5 5} {bottom:55 35 5 5} {center:55 22 5 5} {baseline:55 22 5 5}} test textImage-5.1 {peer widget images} -setup { destroy .t .tt } -body { catch { image create photo small -width 5 -height 5 small put red -to 0 0 4 4 image create photo large -width 50 -height 50 large put green -to 0 0 50 50 } pack [text .t] toplevel .tt pack [.t peer create .tt.t] .t image create end -image large .t image create end -image small -padx 5 -pady 10 .t insert end test update destroy .t .tt } -cleanup { image delete small large } -result {} # cleanup destroy .t font delete test_font imageFinish # cleanup cleanupTests return # Local variables: # mode: tcl # End: tk8.6.5/tests/geometry.test0000644003604700454610000002027412424437553014402 0ustar dgp771div# This file is a Tcl script to test the procedures in the file # tkGeometry.c (generic support for geometry managers). It is # organized in the standard fashion for Tcl tests. # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. proc getsize w { regexp {(^[^+-]*)} [wm geometry $w] foo x return $x } package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands namespace import -force tcltest::test wm geometry . 300x300 raise . update frame .f -bd 2 -relief raised frame .f.f -bd 2 -relief sunken frame .f.f.f -bd 2 -relief raised button .b1 -text .b1 button .b2 -text .b2 button .b3 -text .b3 button .f.f.b4 -text .b4 test geometry-1.1 {Tk_ManageGeometry procedure} -setup { foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { place forget $w } } -body { place .b1 -x 120 -y 80 update list [winfo x .b1] [winfo y .b1] } -result {120 80} test geometry-1.2 {Tk_ManageGeometry procedure} -setup { foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { place forget $w } } -body { place .f -x 20 -y 30 -width 200 -height 200 place .b1 -in .f -x 40 -y 30 update pack .b1 -side top -anchor w place .f -x 30 -y 40 update list [winfo x .b1] [winfo y .b1] } -result {0 0} test geometry-2.1 {Tk_GeometryRequest procedure} -setup { foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { place forget $w } destroy .f2 } -body { frame .f2 set result [list [winfo reqwidth .f2] [winfo reqheight .f2]] .f2 configure -width 150 -height 300 update lappend result [winfo reqwidth .f2] [winfo reqheight .f2] \ [winfo geom .f2] place .f2 -x 10 -y 20 update lappend result [winfo geom .f2] .f2 configure -width 100 -height 80 update lappend result [winfo geom .f2] } -cleanup { destroy .f2 } -result {1 1 150 300 1x1+0+0 150x300+10+20 100x80+10+20} test geometry-3.1 {Tk_SetInternalBorder procedure} -setup { foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { place forget $w } } -body { place .f -x 20 -y 30 -width 200 -height 200 place .b1 -in .f -x 50 -y 5 update set x [list [winfo x .b1] [winfo y .b1]] .f configure -bd 5 update lappend x [winfo x .b1] [winfo y .b1] } -cleanup { .f configure -bd 2 } -result {72 37 75 40} test geometry-4.1 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup { foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { place forget $w } } -body { place .f -x 20 -y 30 -width 200 -height 200 place .f.f -x 15 -y 5 -width 150 -height 120 place .f.f.f -width 100 -height 80 place .b1 -in .f.f.f -x 50 -y 5 update list [winfo x .b1] [winfo y .b1] } -result {91 46} test geometry-4.2 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup { foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { place forget $w } } -body { place .f -x 20 -y 30 -width 200 -height 200 place .f.f -x 15 -y 5 -width 150 -height 120 place .f.f.f -width 100 -height 80 place .b1 -in .f.f.f -x 50 -y 5 place .b2 -in .f.f.f -x 10 -y 25 place .b3 -in .f.f.f -x 50 -y 25 update place .f -x 30 -y 25 update list [winfo x .b1] [winfo y .b1] [winfo x .b2] [winfo y .b2] \ [winfo x .b3] [winfo y .b3] } -result {101 41 61 61 101 61} test geometry-4.3 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup { foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { place forget $w } } -body { place .f -x 20 -y 30 -width 200 -height 200 place .f.f -x 15 -y 5 -width 150 -height 120 place .f.f.f -width 100 -height 80 place .b1 -in .f.f.f -x 50 -y 5 place .b2 -in .f.f.f -x 10 -y 25 place .b3 -in .f.f.f -x 50 -y 25 update destroy .b1 button .b1 -text .b1 place .f.f -x 10 -y 25 update list [winfo x .b1] [winfo y .b1] [winfo x .b2] [winfo y .b2] \ [winfo x .b3] [winfo y .b3] } -result {0 0 46 86 86 86} test geometry-4.4 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup { foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { place forget $w } } -body { place .f -x 20 -y 30 -width 200 -height 200 place .f.f -x 15 -y 5 -width 150 -height 120 place .f.f.f -width 100 -height 80 place .b1 -in .f.f.f -x 50 -y 5 place .b2 -in .f.f.f -x 10 -y 25 place .b3 -in .f.f.f -x 50 -y 25 update destroy .b2 button .b2 -text .b2 place .f.f.f -x 2 -y 3 update list [winfo x .b1] [winfo y .b1] [winfo x .b2] [winfo y .b2] \ [winfo x .b3] [winfo y .b3] } -result {93 49 0 0 93 69} test geometry-4.5 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup { foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { place forget $w } } -body { place .f -x 20 -y 30 -width 200 -height 200 place .f.f -x 15 -y 5 -width 150 -height 120 place .f.f.f -width 100 -height 80 place .b1 -in .f.f.f -x 50 -y 5 place .b2 -in .f.f.f -x 10 -y 25 place .b3 -in .f.f.f -x 50 -y 25 update destroy .b3 button .b3 -text .b3 place .f.f.f -x 2 -y 3 update list [winfo x .b1] [winfo y .b1] [winfo x .b2] [winfo y .b2] \ [winfo x .b3] [winfo y .b3] } -result {93 49 53 69 0 0} test geometry-4.6 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup { foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { place forget $w } } -body { foreach w {.f .f.f .f.f.f .b1 .b2 .b3 .f.f.b4} { place forget $w } place .f -x 20 -y 30 -width 200 -height 200 place .f.f -x 15 -y 5 -width 150 -height 120 place .f.f.f -width 100 -height 80 place .f.f.b4 -in .f.f.f -x 50 -y 5 place .b2 -in .f.f.f -x 10 -y 25 update place .f -x 25 -y 35 update list [winfo x .f.f.b4] [winfo y .f.f.b4] [winfo x .b2] [winfo y .b2] } -result {54 9 56 71} test geometry-4.7 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup { foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { place forget $w } } -body { bind .b1 {lappend x configure} place .f -x 20 -y 30 -width 200 -height 200 place .f.f -x 15 -y 5 -width 150 -height 120 place .f.f.f -width 100 -height 80 place .f.f.b4 -in .f.f.f -x 50 -y 5 place .b1 -in .f.f.f -x 10 -y 25 update set x init place .f -x 25 -y 35 update lappend x | place .f -x 30 -y 40 place .f.f -x 10 -y 0 update return $x } -cleanup { bind .b1 {} } -result {init configure |} test geometry-4.8 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup { foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { place forget $w } } -body { place .f -x 20 -y 30 -width 200 -height 200 place .f.f -x 15 -y 5 -width 150 -height 120 place .f.f.f -width 100 -height 80 place .b1 -in .f.f.f -x 50 -y 5 place .b2 -in .f.f.f -x 10 -y 25 place .b3 -in .f.f.f -x 50 -y 25 update destroy .f.f frame .f.f -bd 2 -relief raised frame .f.f.f -bd 2 -relief raised place .f -x 30 -y 25 update list [winfo x .b1] [winfo y .b1] [winfo ismapped .b1] \ [winfo x .b2] [winfo y .b2] [winfo ismapped .b2] \ [winfo x .b3] [winfo y .b3] [winfo ismapped .b3] } -result {91 46 0 51 66 0 91 66 0} test geometry-4.9 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup { foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { place forget $w } } -body { place .f -x 20 -y 30 -width 200 -height 200 place .f.f -x 15 -y 5 -width 150 -height 120 place .f.f.f -width 100 -height 80 place .b1 -in .f.f.f -x 50 -y 5 update set result [winfo ismapped .b1] place forget .f.f update lappend result [winfo ismapped .b1] place .f.f -x 15 -y 5 -width 150 -height 120 update lappend result [winfo ismapped .b1] } -result {1 0 1} test geometry-4.10 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup { foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { place forget $w } destroy .t } -body { toplevel .t wm geometry .t +0+0 tkwait visibility .t update pack [frame .t.f] button .t.quit -text Quit -command exit pack .t.quit -in .t.f wm iconify .t set x 0 after 500 {set x 1} tkwait variable x wm deiconify .t update winfo ismapped .t.quit } -cleanup { destroy .t } -result {1} # cleanup cleanupTests return tk8.6.5/tests/unixMenu.test0000644003604700454610000010660212377375532014364 0ustar dgp771div# This file is a Tcl script to test menus in Tk. It is # organized in the standard fashion for Tcl tests. This # file tests the Macintosh-specific features of the menu # system. # # Copyright (c) 1995-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. package require tcltest 2.2 namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands test unixMenu-1.1 {TkpNewMenu - normal menu} -constraints unix -setup { destroy .m1 } -body { list [menu .m1] [destroy .m1] } -returnCodes ok -result {.m1 {}} test unixMenu-1.2 {TkpNewMenu - help menu} -constraints unix -setup { destroy .m1 } -body { menu .m1 -tearoff 0 . configure -menu .m1 .m1 add cascade -label Help -menu .m1.help list [menu .m1.help] [. configure -menu ""] [destroy .m1] } -returnCodes ok -result {.m1.help {} {}} test unixMenu-2.1 {TkpDestroyMenu - nothing to do} -constraints unix -body {} test unixMenu-3.1 {TkpDestroymenuEntry - nothing to do} -constraints unix -body {} test unixMenu-4.1 {TkpConfigureMenuEntry - non-cascade entry} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 -tearoff 0 .m1 add command -label test list [.m1 entryconfigure test -label foo] [destroy .m1] } -returnCodes ok -result {{} {}} test unixMenu-4.2 {TkpConfigureMenuEntry - cascade entry} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 -tearoff 0 .m1 add cascade -menu .m2 -label test menu .m1.foo -tearoff 0 list [.m1 entryconfigure test -menu .m1.foo] [destroy .m1] } -returnCodes ok -result {{} {}} test unixMenu-5.1 {TkpMenuNewEntry - nothing to do} -constraints unix -body {} test unixMenu-6.1 {TkpSetWindowMenuBar - null menu} -constraints unix -setup { destroy .m1 } -body { menu .m1 .m1 add cascade -label foo . configure -menu .m1 list [. configure -menu ""] [destroy .m1] } -returnCodes ok -result {{} {}} test unixMenu-6.2 {TkpSetWindowMenuBar - menu} -constraints unix -setup { destroy .m1 } -body { menu .m1 .m1 add cascade -label foo list [. configure -menu .m1] [. configure -menu ""] [destroy .m1] } -returnCodes ok -result {{} {} {}} test unixMenu-7.1 {TkpSetMainMenubar - nothing to do} -constraints unix -body {} test unixMenu-8.1 {GetMenuIndicatorGeometry - indicator off} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add checkbutton -label foo -indicatoron 0 tk::TearOffMenu .m1 40 40 destroy .m1 } -returnCodes ok test unixMenu-8.2 {GetMenuIndicatorGeometry - not checkbutton or radio} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add command -label foo tk::TearOffMenu .m1 40 40 destroy .m1 } -returnCodes ok test unixMenu-8.3 {GetMenuIndicatorGeometry - checkbutton image} -constraints { unix testImageType } -setup { destroy .m1 catch {image delete image1} } -body { menu .m1 image create test image1 .m1 add checkbutton -image image1 -label foo .m1 invoke foo tk::TearOffMenu .m1 40 40 destroy .m1 } -cleanup { image delete image1 } -returnCodes ok test unixMenu-8.4 {GetMenuIndicatorGeometry - checkbutton bitmap} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add checkbutton -bitmap questhead -label foo .m1 invoke foo tk::TearOffMenu .m1 40 40 destroy .m1 } -returnCodes ok test unixMenu-8.5 {GetMenuIndicatorGeometry - checkbutton} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add checkbutton -label foo .m1 invoke foo tk::TearOffMenu .m1 40 40 destroy .m1 } -returnCodes ok test unixMenu-8.6 {GetMenuIndicatorGeometry - radiobutton image} -constraints { unix testImageType } -setup { destroy .m1 catch {image delete image1} } -body { menu .m1 image create test image1 .m1 add radiobutton -image image1 -label foo .m1 invoke foo tk::TearOffMenu .m1 40 40 destroy .m1 image delete image1 } -returnCodes ok test unixMenu-8.7 {GetMenuIndicatorGeometry - radiobutton bitmap} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add radiobutton -bitmap questhead -label foo .m1 invoke foo tk::TearOffMenu .m1 40 40 destroy .m1 } -returnCodes ok test unixMenu-8.8 {GetMenuIndicatorGeometry - radiobutton} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add radiobutton -label foo .m1 invoke foo tk::TearOffMenu .m1 40 40 destroy .m1 } -returnCodes ok test unixMenu-8.9 {GetMenuIndicatorGeometry - hideMargin} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add radiobutton -label foo -hidemargin 1 .m1 invoke foo tk::TearOffMenu .m1 40 40 destroy .m1 } -returnCodes ok test unixMenu-9.1 {GetMenuAccelGeometry - cascade entry} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add cascade -label foo tk::TearOffMenu .m1 40 40 destroy .m1 } -returnCodes ok test unixMenu-9.2 {GetMenuAccelGeometry - non-null label} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add command -label foo -accel "Ctrl+S" tk::TearOffMenu .m1 40 40 destroy .m1 } -returnCodes ok test unixMenu-9.3 {GetMenuAccelGeometry - null label} -constraints unix -setup { destroy .m1 } -body { menu .m1 .m1 add command -label foo tk::TearOffMenu .m1 40 40 destroy .m1 } -returnCodes ok test unixMenu-10.1 {DrawMenuEntryBackground - active menubar} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add cascade -label foo . configure -menu .m1 .m1 activate 1 list [update] [. configure -menu ""] [destroy .m1] } -returnCodes ok -result {{} {} {}} test unixMenu-10.2 {DrawMenuEntryBackground - active} -constraints unix -setup { destroy .m1 } -body { menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] $tearoff activate 0 list [update] [destroy .m1] } -returnCodes ok -result {{} {}} test unixMenu-10.3 {DrawMenuEntryBackground - non-active} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } -returnCodes ok -result {{} {}} test unixMenu-11.1 {DrawMenuEntryAccelerator - menubar} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add command -label foo -accel "Ctrl+U" . configure -menu .m1 list [update] [. configure -menu ""] [destroy .m1] } -result {{} {} {}} # drawArrow parameter is never false under Unix test unixMenu-11.2 {DrawMenuEntryAccelerator - cascade entry} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add cascade -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } -result {{} {}} test unixMenu-11.3 {DrawMenuEntryAccelerator - normal entry} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add command -label foo -accel "Ctrl+U" set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } -result {{} {}} test unixMenu-11.4 {DrawMenuEntryAccelerator - null entry} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } -result {{} {}} test unixMenu-12.1 {DrawMenuEntryIndicator - non-check or radio} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } -result {{} {}} test unixMenu-12.2 {DrawMenuEntryIndicator - checkbutton - indicator off} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add checkbutton -label foo -indicatoron 0 set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } -result {{} {}} test unixMenu-12.3 {DrawMenuEntryIndicator - checkbutton - not selected} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add checkbutton -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } -result {{} {}} test unixMenu-12.4 {DrawMenuEntryIndicator - checkbutton - selected} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add checkbutton -label foo .m1 invoke 1 set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } -result {{} {}} test unixMenu-12.5 {DrawMenuEntryIndicator - radiobutton - indicator off} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add radiobutton -label foo -indicatoron 0 set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } -result {{} {}} test unixMenu-12.6 {DrawMenuEntryIndicator - radiobutton - not selected} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add radiobutton -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } -result {{} {}} test unixMenu-12.7 {DrawMenuEntryIndicator - radiobutton - selected} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add radiobutton -label foo .m1 invoke 1 set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } -result {{} {}} test unixMenu-13.1 {DrawMenuSeparator - menubar case} -constraints unix -setup { destroy .m1 } -body { menu .m1 .m1 add separator . configure -menu .m1 list [update] [. configure -menu ""] [destroy .m1] } -result {{} {} {}} test unixMenu-13.2 {DrawMenuSepartor - normal menu} -constraints unix -setup { destroy .m1 } -body { menu .m1 .m1 add separator set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } -result {{} {}} test unixMenu-14.1 {DrawMenuEntryLabel} -constraints unix -setup { destroy .m1 } -body { menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } -result {{} {}} test unixMenu-15.1 {DrawMenuUnderline - menubar} -constraints unix -setup { destroy .m1 } -body { menu .m1 .m1 add command -label foo -underline 0 . configure -menu .m1 list [update] [. configure -menu ""] [destroy .m1] } -result {{} {} {}} test unixMenu-15.2 {DrawMenuUnderline - no menubar} -constraints unix -setup { destroy .m1 } -body { menu .m1 .m1 add command -label foo -underline 0 set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } -result {{} {}} test unixMenu-16.1 {TkpPostMenu} -constraints unix -setup { destroy .m1 } -body { menu .m1 .m1 add command -label foo tk::TearOffMenu .m1 40 40 destroy .m1 } -returnCodes ok test unixMenu-17.1 {GetMenuSeparatorGeometry} -constraints unix -setup { destroy .m1 } -body { menu .m1 .m1 add separator tk::TearOffMenu .m1 40 40 destroy .m1 } -returnCodes ok test unixMenu-18.1 {GetTearoffEntryGeometry} -constraints { unix nonUnixUserInteraction } -setup { destroy .mb } -body { menubutton .mb -text "test" -menu .mb.m menu .mb.m .mb.m add command -label test pack .mb raise . list [tk::MbPost .mb] [tk::MenuUnpost .mb.m] [destroy .mb] } -result {{} {} {}} # Don't know how to reproduce the case where the tkwin has been deleted. test unixMenu-19.1 {TkpComputeMenubarGeometry - zero entries} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 . configure -menu .m1 list [update] [. configure -menu ""] [destroy .m1] } -result {{} {} {}} # Don't know how to generate one width windows test unixMenu-19.2 {TkpComputeMenubarGeometry - one entry} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add cascade -label File . configure -menu .m1 list [update] [. configure -menu ""] [destroy .m1] } -result {{} {} {}} test unixMenu-19.3 {TkpComputeMenubarGeometry - entry with different font} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 -font "Courier 24" .m1 add cascade -label File -font "Helvetica 18" . configure -menu .m1 list [update] [. configure -menu ""] [destroy .m1] } -result {{} {} {}} test unixMenu-19.4 {TkpComputeMenubarGeometry - separator} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add separator . configure -menu .m1 list [update] [. configure -menu ""] [destroy .m1] } -result {{} {} {}} test unixMenu-19.5 {TkpComputeMenubarGeometry - First entry} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 -tearoff 0 .m1 add cascade -label File . configure -menu .m1 list [update] [. configure -menu ""] [destroy .m1] } -result {{} {} {}} test unixMenu-19.6 {TkpComputeMenubarGeometry - First entry too wide} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 -tearoff 0 .m1 add cascade -label File -font "Times 72" . configure -menu .m1 wm geometry . 10x10 list [update] [. configure -menu ""] [destroy .m1] } -result {{} {} {}} test unixMenu-19.7 {TkpComputeMenubarGeometry - two entries fit} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 -tearoff 0 .m1 add cascade -label File .m1 add cascade -label Edit . configure -menu .m1 wm geometry . 200x200 list [update] [. configure -menu ""] [destroy .m1] } -result {{} {} {}} test unixMenu-19.8 {TkpComputeMenubarGeometry - two entries; 2nd don't fit} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 -tearoff 0 .m1 add cascade -label File .m1 add cascade -label Edit -font "Times 72" . configure -menu .m1 wm geometry . 100x100 list [update] [. configure -menu ""] [destroy .m1] } -result {{} {} {}} test unixMenu-19.9 {TkpComputeMenubarGeometry - two entries; 1st dont fit} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 -tearoff 0 .m1 add cascade -label File -font "Times 72" .m1 add cascade -label Edit . configure -menu .m1 wm geometry . 100x100 list [update] [. configure -menu ""] [destroy .m1] } -result {{} {} {}} test unixMenu-19.10 {TkpComputeMenubarGeometry - two entries; neither fit} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 -tearoff 0 -font "Times 72" .m1 add cascade -label File .m1 add cascade -label Edit . configure -menu .m1 wm geometry . 10x10 list [update] [. configure -menu ""] [destroy .m1] } -result {{} {} {}} # ABC notation; capital A means first window fits, small a means it # does not. capital B menu means second window fist, etc. test unixMenu-19.11 {TkpComputeMenubarGeometry - abc} -constraints unix -setup { destroy .m1 } -body { menu .m1 -tearoff 0 -font "Times 72" .m1 add cascade -label "aaaaa" .m1 add cascade -label "bbbbb" .m1 add cascade -label "ccccc" . configure -menu .m1 wm geometry . 10x10 list [update] [. configure -menu ""] [destroy .m1] } -result {{} {} {}} test unixMenu-19.12 {TkpComputeMenubarGeometry - abC} -constraints unix -setup { destroy .m1 } -body { menu .m1 -tearoff 0 .m1 add cascade -label "aaaaa" -font "Times 72" .m1 add cascade -label "bbbbb" -font "Times 72" .m1 add cascade -label "C" . configure -menu .m1 wm geometry . 10x10 list [update] [. configure -menu ""] [destroy .m1] } -result {{} {} {}} test unixMenu-19.13 {TkpComputeMenubarGeometry - aBc} -constraints unix -setup { destroy .m1 } -body { menu .m1 -tearoff 0 .m1 add cascade -label "aaaaa" -font "Times 72" .m1 add cascade -label "B" .m1 add cascade -label "ccccc" -font "Times 72" . configure -menu .m1 wm geometry . 10x10 list [update] [. configure -menu ""] [destroy .m1] } -result {{} {} {}} test unixMenu-19.14 {TkpComputeMenubarGeometry - aBC} -constraints unix -setup { destroy .m1 } -body { menu .m1 -tearoff 0 .m1 add cascade -label "aaaaa" -font "Times 72" .m1 add cascade -label "B" .m1 add cascade -label "C" . configure -menu .m1 wm geometry . 60x10 list [update] [. configure -menu ""] [destroy .m1] } -result {{} {} {}} test unixMenu-19.15 {TkpComputeMenubarGeometry - Abc} -constraints unix -setup { destroy .m1 } -body { menu .m1 -tearoff 0 .m1 add cascade -label "A" .m1 add cascade -label "bbbbb" -font "Times 72" .m1 add cascade -label "ccccc" -font "Times 72" . configure -menu .m1 wm geometry . 60x10 list [update] [. configure -menu ""] [destroy .m1] } -result {{} {} {}} test unixMenu-19.16 {TkpComputeMenubarGeometry - AbC} -constraints unix -setup { destroy .m1 } -body { menu .m1 -tearoff 0 .m1 add cascade -label "A" .m1 add cascade -label "bbbbb" -font "Times 72" .m1 add cascade -label "C" . configure -menu .m1 wm geometry . 60x10 list [update] [. configure -menu ""] [destroy .m1] } -result {{} {} {}} test unixMenu-19.17 {TkpComputeMenubarGeometry - ABc} -constraints unix -setup { destroy .m1 } -body { menu .m1 -tearoff 0 .m1 add cascade -label "A" .m1 add cascade -label "B" .m1 add cascade -label "ccccc" -font "Times 72" . configure -menu .m1 wm geometry . 60x10 list [update] [. configure -menu ""] [destroy .m1] } -result {{} {} {}} test unixMenu-19.18 {TkpComputeMenubarGeometry - ABC} -constraints unix -setup { destroy .m1 } -body { menu .m1 -tearoff 0 .m1 add cascade -label "A" .m1 add cascade -label "B" .m1 add cascade -label "C" . configure -menu .m1 wm geometry . 100x10 list [update] [. configure -menu ""] [destroy .m1] } -result {{} {} {}} test unixMenu-19.19 {TkpComputeMenubarGeometry - help menu in first position} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 -tearoff 0 .m1 add cascade -label Help -menu .m1.help menu .m1.help -tearoff 0 .m1 add cascade -label File -menu .m1.file menu .m1.file -tearoff 0 .m1 add cascade -label Edit -menu .m1.edit menu .m1.edit -tearoff 0 . configure -menu .m1 wm geometry . 100x10 list [update] [. configure -menu ""] [destroy .m1] } -result {{} {} {}} test unixMenu-19.20 {TkpComputeMenubarGeometry - help menu in middle} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 -tearoff 0 .m1 add cascade -label Edit -menu .m1.edit menu .m1.edit -tearoff 0 .m1 add cascade -label Help -menu .m1.help menu .m1.help -tearoff 0 .m1 add cascade -label File -menu .m1.file menu .m1.file -tearoff 0 . configure -menu .m1 wm geometry . 100x10 list [update] [. configure -menu ""] [destroy .m1] } -result {{} {} {}} test unixMenu-19.21 {TkpComputeMenubarGeometry - help menu in first position} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 -tearoff 0 .m1 add cascade -label File -menu .m1.file menu .m1.file -tearoff 0 .m1 add cascade -label Edit -menu .m1.edit menu .m1.edit -tearoff 0 .m1 add cascade -label Help -menu .m1.help menu .m1.help -tearoff 0 . configure -menu .m1 wm geometry . 100x10 list [update] [. configure -menu ""] [destroy .m1] } -result {{} {} {}} test unixMenu-19.22 {TkpComputeMenubarGeometry - help item fits} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 -tearoff 0 .m1 add cascade -label File -menu .m1.file menu .m1.file -tearoff 0 .m1 add cascade -label Help -menu .m1.help menu .m1.help -tearoff 0 . configure -menu .m1 wm geometry . 100x10 list [update] [. configure -menu ""] [destroy .m1] } -result {{} {} {}} test unixMenu-19.23 {TkpComputeMenubarGeometry - help item does not fit} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 -tearoff 0 .m1 add cascade -label File -menu .m1.file menu .m1.file -tearoff 0 .m1 add cascade -label Help -menu .m1.help -font "Helvetica 72" menu .m1.help -tearoff 0 . configure -menu .m1 wm geometry . 100x10 list [update] [. configure -menu ""] [destroy .m1] } -result {{} {} {}} test unixMenu-19.24 {TkpComputeMenubarGeometry - help item only one} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 -tearoff 0 .m1 add cascade -label Help -menu .m1.help menu .m1.help -tearoff 0 . configure -menu .m1 wm geometry . 100x10 list [update] [. configure -menu ""] [destroy .m1] } -result {{} {} {}} test unixMenu-20.1 {DrawTearoffEntry - menubar} -constraints unix -setup { destroy .m1 } -body { menu .m1 .m1 add cascade -label File . configure -menu .m1 list [update] [. configure -menu ""] [destroy .m1] } -result {{} {} {}} test unixMenu-20.2 {DrawTearoffEntry - non-menubar} -constraints { unix nonUnixUserInteraction } -setup { destroy .m1 } -body { menu .m1 .m1 add command -label foo .m1 post 40 40 list [update] [destroy .m1] } -result {{} {}} test unixMenu-21.1 {TkpInitializeMenuBindings - nothing to do} -constraints unix -body {} test unixMenu-22.1 {SetHelpMenu - no menubars} -constraints unix -setup { destroy .m1 } -body { menu .m1 -tearoff 0 .m1 add cascade -label test -menu .m1.test list [menu .m1.test] [destroy .m1] } -result {.m1.test {}} # Don't know how to automate missing tkwins test unixMenu-22.2 {SetHelpMenu - menubar but no help menu} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 -tearoff 0 . configure -menu .m1 .m1 add cascade -label .m1.file list [menu .m1.file] [. configure -menu ""] [destroy .m1] } -result {.m1.file {} {}} test unixMenu-22.3 {SetHelpMenu - menubar with help menu} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 -tearoff 0 . configure -menu .m1 .m1 add cascade -label .m1.help list [menu .m1.help] [. configure -menu ""] [destroy .m1] } -result {.m1.help {} {}} test unixMenu-22.4 {SetHelpMenu - multiple menubars with same help menu} -constraints { unix } -setup { destroy .m1 .t2 } -body { toplevel .t2 wm geometry .t2 +40+40 menu .m1 -tearoff 0 . configure -menu .m1 .t2 configure -menu .m1 .m1 add cascade -label .m1.help list [menu .m1.help] [. configure -menu ""] [destroy .m1] [destroy .t2] } -result {.m1.help {} {} {}} test unixMenu-23.1 {TkpDrawMenuEntry - gc for active and not strict motif} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] .m1 entryconfigure 1 -state active list [update] [destroy .m1] } -result {{} {}} test unixMenu-23.2 {TkpDrawMenuEntry - gc for active menu item with its own gc} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add command -label foo -activeforeground red set tearoff [tk::TearOffMenu .m1 40 40] .m1 entryconfigure 1 -state active list [update] [destroy .m1] } -result {{} {}} test unixMenu-23.3 {TkpDrawMenuEntry - gc for active and strict motif} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 set tk_strictMotif 1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] .m1 entryconfigure 1 -state active list [update] [destroy .m1] [set tk_strictMotif 0] } -result {{} {} 0} test unixMenu-23.4 {TkpDrawMenuEntry - gc for disabled with disabledfg and custom entry} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 -disabledforeground blue .m1 add command -label foo -state disabled -background red set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } -result {{} {}} test unixMenu-23.5 {TkpDrawMenuEntry - gc for disabled with disabledFg} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 -disabledforeground blue .m1 add command -label foo -state disabled set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } -result {{} {}} test unixMenu-23.6 {TkpDrawMenuEntry - gc for disabled - no disabledFg} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 -disabledforeground "" .m1 add command -label foo -state disabled set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } -result {{} {}} test unixMenu-23.7 {TkpDrawMenuEntry - gc for normal - custom entry} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add command -label foo -foreground red set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } -result {{} {}} test unixMenu-23.8 {TkpDrawMenuEntry - gc for normal} -constraints unix -setup { destroy .m1 } -body { menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } -result {{} {}} test unixMenu-23.9 {TkpDrawMenuEntry - gc for indicator - custom entry} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add checkbutton -label foo -selectcolor orange .m1 invoke 1 set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } -result {{} {}} test unixMenu-23.10 {TkpDrawMenuEntry - gc for indicator} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add checkbutton -label foo .m1 invoke 1 set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } -result {{} {}} test unixMenu-23.11 {TkpDrawMenuEntry - border - custom entry} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add command -label foo -activebackground green set tearoff [tk::TearOffMenu .m1 40 40] .m1 entryconfigure 1 -state active list [update] [destroy .m1] } -result {{} {}} test unixMenu-23.12 {TkpDrawMenuEntry - border} -constraints unix -setup { destroy .m1 } -body { menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] .m1 entryconfigure 1 -state active list [update] [destroy .m1] } -result {{} {}} test unixMenu-23.13 {TkpDrawMenuEntry - active border - strict motif} -constraints { unix } -setup { destroy .m1 } -body { set tk_strictMotif 1 menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] .m1 entryconfigure 1 -state active list [update] [destroy .m1] [set tk_strictMotif 0] } -result {{} {} 0} test unixMenu-23.14 {TkpDrawMenuEntry - active border - custom entry} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add command -label foo -activeforeground yellow set tearoff [tk::TearOffMenu .m1 40 40] .m1 entryconfigure 1 -state active list [update] [destroy .m1] } -result {{} {}} test unixMenu-23.15 {TkpDrawMenuEntry - active border} -constraints unix -setup { destroy .m1 } -body { menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] .m1 entryconfigure 1 -state active list [update] [destroy .m1] } -result {{} {}} test unixMenu-23.16 {TkpDrawMenuEntry - font - custom entry} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add command -label foo -font "Helvectica 72" set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } -result {{} {}} test unixMenu-23.17 {TkpDrawMenuEntry - font} -constraints unix -setup { destroy .m1 } -body { menu .m1 -font "Courier 72" .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } -result {{} {}} test unixMenu-23.18 {TkpDrawMenuEntry - separator} -constraints unix -setup { destroy .m1 } -body { menu .m1 .m1 add separator set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } -result {{} {}} test unixMenu-23.19 {TkpDrawMenuEntry - standard} -constraints unix -setup { destroy .m1 } -body { menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } -result {{} {}} test unixMenu-23.20 {TkpDrawMenuEntry - disabled cascade item} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add cascade -label File -menu .m1.file menu .m1.file .m1.file add command -label foo .m1 entryconfigure File -state disabled set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } -result {{} {}} test unixMenu-23.21 {TkpDrawMenuEntry - indicator} -constraints unix -setup { destroy .m1 } -body { menu .m1 .m1 add checkbutton -label Foo .m1 invoke Foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } -result {{} {}} test unixMenu-23.22 {TkpDrawMenuEntry - hide margin} -constraints unix -setup { destroy .m1 } -body { menu .m1 .m1 add checkbutton -label Foo -hidemargin 1 .m1 invoke Foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] } -result {{} {}} test unixMenu-24.1 {GetMenuLabelGeometry - image} -constraints { testImageType unix } -setup { destroy .m1 catch {image delete image1} } -body { menu .m1 image create test image1 .m1 add command -image image1 list [update idletasks] [destroy .m1] [image delete image1] } -result {{} {} {}} test unixMenu-24.2 {GetMenuLabelGeometry - bitmap} -constraints unix -setup { destroy .m1 } -body { menu .m1 .m1 add command -bitmap questhead list [update idletasks] [destroy .m1] } -result {{} {}} test unixMenu-24.3 {GetMenuLabelGeometry - no text} -constraints unix -setup { destroy .m1 } -body { menu .m1 .m1 add command list [update idletasks] [destroy .m1] } -result {{} {}} test unixMenu-24.4 {GetMenuLabelGeometry - text} -constraints unix -setup { destroy .m1 } -body { menu .m1 .m1 add command -label "This is a test." list [update idletasks] [destroy .m1] } -result {{} {}} test unixMenu-25.1 {TkpComputeStandardMenuGeometry - no entries} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 list [update idletasks] [destroy .m1] } -result {{} {}} test unixMenu-25.2 {TkpComputeStandardMenuGeometry - one entry} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add command -label "one" list [update idletasks] [destroy .m1] } -result {{} {}} test unixMenu-25.3 {TkpComputeStandardMenuGeometry - more than one entry} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add command -label "one" .m1 add command -label "two" list [update idletasks] [destroy .m1] } -result {{} {}} test unixMenu-25.4 {TkpComputeStandardMenuGeometry - separator} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add separator list [update idletasks] [destroy .m1] } -result {{} {}} test unixMenu-25.5 {TkpComputeStandardMenuGeometry - tearoff entry} -constraints { unix nonUnixUserInteraction } -setup { destroy .mb } -body { menubutton .mb -text "test" -menu .mb.m menu .mb.m .mb.m add command -label test pack .mb catch {tk::MbPost .mb} list [update] [tk::MenuUnpost .mb.m] [destroy .mb] } -result {{} {} {}} test unixMenu-25.6 {TkpComputeStandardMenuGeometry - standard label geometry} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add command -label "test" list [update idletasks] [destroy .m1] } -result {{} {}} test unixMenu-25.7 {TkpComputeStandardMenuGeometry - different font for entry} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 -font "Helvetica 12" .m1 add command -label "test" -font "Courier 12" list [update idletasks] [destroy .m1] } -result {{} {}} test unixMenu-25.8 {TkpComputeStandardMenuGeometry - second entry larger} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add command -label "test" .m1 add command -label "test test" list [update idletasks] [destroy .m1] } -result {{} {}} test unixMenu-25.9 {TkpComputeStandardMenuGeometry - first entry larger} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add command -label "test test" .m1 add command -label "test" list [update idletasks] [destroy .m1] } -result {{} {}} test unixMenu-25.10 {TkpComputeStandardMenuGeometry - accelerator} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add command -label "test" -accel "Ctrl+S" list [update idletasks] [destroy .m1] } -result {{} {}} test unixMenu-25.11 {TkpComputeStandardMenuGeometry - second accel larger} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add command -label "test" -accel "1" .m1 add command -label "test" -accel "1 1" list [update idletasks] [destroy .m1] } -result {{} {}} test unixMenu-25.12 {TkpComputeStandardMenuGeometry - second accel smaller} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add command -label "test" -accel "1 1" .m1 add command -label "test" -accel "1" list [update idletasks] [destroy .m1] } -result {{} {}} test unixMenu-25.13 {TkpComputeStandardMenuGeometry - indicator} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add checkbutton -label test .m1 invoke 1 list [update idletasks] [destroy .m1] } -result {{} {}} test unixMenu-25.14 {TkpComputeStandardMenuGeometry - second indicator less or equal } -constraints { unix testImageType } -setup { destroy .m1 catch {image delete image1} } -body { image create test image1 menu .m1 .m1 add checkbutton -image image1 .m1 invoke 1 .m1 add checkbutton -label test .m1 invoke 2 list [update idletasks] [destroy .m1] [image delete image1] } -result {{} {} {}} test unixMenu-25.15 {TkpComputeStandardMenuGeometry - second indicator larger } -constraints { unix testImageType } -setup { destroy .m1 catch {image delete image1} } -body { image create test image1 menu .m1 .m1 add checkbutton -image image1 .m1 invoke 1 .m1 add checkbutton -label test .m1 invoke 2 list [update idletasks] [destroy .m1] [image delete image1] } -result {{} {} {}} test unixMenu-25.16 {TkpComputeStandardMenuGeometry - zero sized menus} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 -tearoff 0 list [update idletasks] [destroy .m1] } -result {{} {}} test unixMenu-25.17 {TkpComputeStandardMenuGeometry - first column bigger} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 .m1 add command -label one .m1 add command -label two .m1 add command -label three -columnbreak 1 list [update idletasks] [destroy .m1] } -result {{} {}} test unixMenu-25.18 {TkpComputeStandardMenuGeometry - second column bigger} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 -tearoff 0 .m1 add command -label one .m1 add command -label two -columnbreak 1 .m1 add command -label three list [update idletasks] [destroy .m1] } -result {{} {}} test unixMenu-25.19 {TkpComputeStandardMenuGeometry - three columns} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 -tearoff 0 .m1 add command -label one .m1 add command -label two -columnbreak 1 .m1 add command -label three .m1 add command -label four .m1 add command -label five -columnbreak 1 .m1 add command -label six list [update idletasks] [destroy .m1] } -result {{} {}} test unixMenu-25.20 {TkpComputeStandardMenuGeometry - hide margin} -constraints { unix } -setup { destroy .m1 } -body { menu .m1 -tearoff 0 .m1 add checkbutton -label one -hidemargin 1 list [update idletasks] [destroy .m1] } -result {{} {}} test unixMenu-26.1 {TkpMenuInit - nothing to do} -constraints unix -body {} # cleanup deleteWindows cleanupTests return tk8.6.5/tests/flagup.xbm0000644003604700454610000000353011555562545013634 0ustar dgp771div#define flagup_width 48 #define flagup_height 48 static char flagup_bits[] = { 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x7f, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x7f, 0x00, 0x00, 0x00, 0x00, 0xef, 0x6a, 0x00, 0x00, 0x00, 0xc0, 0x7b, 0x75, 0x00, 0x00, 0x00, 0xe0, 0xe0, 0x6a, 0x00, 0x00, 0x00, 0x30, 0x60, 0x75, 0x00, 0x00, 0x00, 0x18, 0xe0, 0x7f, 0x00, 0x00, 0x00, 0x0c, 0xe0, 0x7f, 0x00, 0x00, 0x00, 0x06, 0xe0, 0x04, 0x00, 0x00, 0x00, 0x03, 0xe0, 0x04, 0x00, 0x00, 0x80, 0x01, 0xe0, 0x06, 0x00, 0x00, 0xc0, 0x1f, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x7f, 0xe0, 0x07, 0x00, 0x00, 0x70, 0xe0, 0xe0, 0x05, 0x00, 0x00, 0x38, 0x80, 0xe1, 0x04, 0x00, 0x00, 0x18, 0x80, 0xf1, 0x04, 0x00, 0x00, 0x0c, 0x00, 0xfb, 0x04, 0x00, 0x00, 0x0c, 0x00, 0xff, 0x04, 0x00, 0x00, 0x86, 0x1f, 0xee, 0x04, 0x00, 0x00, 0x06, 0x06, 0xe6, 0x04, 0x00, 0x00, 0x06, 0x00, 0xe6, 0x04, 0x00, 0x00, 0x06, 0x00, 0xe6, 0x04, 0x00, 0x00, 0x06, 0x00, 0x66, 0x04, 0x00, 0x7f, 0x56, 0x52, 0x06, 0xe4, 0xff, 0x00, 0x76, 0x55, 0x06, 0x04, 0x00, 0x00, 0x56, 0x57, 0x06, 0x04, 0x00, 0x00, 0x56, 0x55, 0x06, 0x06, 0x00, 0x00, 0x56, 0xd5, 0x06, 0x03, 0x00, 0x00, 0x06, 0x00, 0x86, 0x01, 0x00, 0x54, 0x06, 0x00, 0xc6, 0x54, 0x55, 0xaa, 0x06, 0x00, 0x66, 0xaa, 0x2a, 0x54, 0x06, 0x00, 0x36, 0x55, 0x55, 0xaa, 0x06, 0x00, 0xbe, 0xaa, 0x2a, 0x54, 0xfe, 0xff, 0x6f, 0x55, 0x55, 0xaa, 0xfc, 0xff, 0xa7, 0xaa, 0x2a, 0x54, 0x01, 0x88, 0x60, 0x55, 0x55, 0xaa, 0xaa, 0x8a, 0xa0, 0xaa, 0x2a, 0x54, 0x55, 0x8d, 0x60, 0x55, 0x55, 0xaa, 0xaa, 0x8a, 0xa0, 0xaa, 0x2a, 0x54, 0x55, 0x8d, 0x60, 0x55, 0x55, 0xaa, 0xaa, 0x8a, 0xa0, 0xaa, 0x2a, 0x54, 0x55, 0x8d, 0x50, 0x55, 0x55, 0xaa, 0xaa, 0x8a, 0xa8, 0xaa, 0x2a, 0x54, 0x55, 0x95, 0x54, 0x55, 0x55, 0xaa, 0xaa, 0xaa, 0xaa, 0xaa, 0x2a, 0x54, 0x55, 0x55, 0x55, 0x55, 0x15, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}; tk8.6.5/tests/canvPsText.tcl0000644003604700454610000001001712077535536014447 0ustar dgp771div# This file creates a screen to exercise Postscript generation # for text in canvases. It is part of the Tk visual test suite, # which is invoked via the "visual" script. catch {destroy .t} toplevel .t wm title .t "Postscript Tests for Canvases" wm iconname .t "Postscript" wm geom .t +0+0 wm minsize .t 1 1 set c .t.c message .t.m -text {This screen exercises the Postscript-generation abilities of Tk canvas widgets for text. Click on "Print" to print the canvas to your default printer. The "Stipple" button can be used to turn stippling on and off for the text, but beware: many Postscript printers cannot handle stippled text. You can click on items in the canvas to delete them.} -width 6i pack .t.m -side top -fill both set stipple {} checkbutton .t.stipple -text Stippling -variable stipple -onvalue gray50 \ -offvalue {} -command "setStipple $c" -relief flat pack .t.stipple -side top -pady 2m -expand 1 -anchor w frame .t.bot pack .t.bot -side bottom -fill both button .t.bot.quit -text Quit -command {destroy .t} button .t.bot.print -text Print -command "lpr $c" pack .t.bot.print .t.bot.quit -side left -pady 1m -expand 1 canvas $c -width 6i -height 7i -bd 2 -relief sunken pack $c -expand yes -fill both -padx 2m -pady 2m $c create rect 2.95i 0.45i 3.05i 0.55i -fill {} -outline black $c create text 3.0i 0.5i -text "Center Courier Oblique 24" \ -anchor center -tags text -font {Courier 24 italic} -stipple $stipple $c create rect 2.95i 0.95i 3.05i 1.05i -fill {} -outline black $c create text 3.0i 1.0i -text "Northwest Helvetica 24" \ -anchor nw -tags text -font {Helvetica 24} -stipple $stipple $c create rect 2.95i 1.45i 3.05i 1.55i -fill {} -outline black $c create text 3.0i 1.5i -text "North Helvetica Oblique 12 " \ -anchor n -tags text -font {Helvetica 12 italic} -stipple $stipple $c create rect 2.95i 1.95i 3.05i 2.05i -fill {} -outline blue $c create text 3.0i 2.0i -text "Northeast Helvetica Bold 24" \ -anchor ne -tags text -font {Helvetica 24 bold} -stipple $stipple $c create rect 2.95i 2.45i 3.05i 2.55i -fill {} -outline black $c create text 3.0i 2.5i -text "East Helvetica Bold Oblique 18" \ -anchor e -tags text -font {Helvetica 18 {bold italic}} -stipple $stipple $c create rect 2.95i 2.95i 3.05i 3.05i -fill {} -outline black $c create text 3.0i 3.0i -text "Southeast Times 10" \ -anchor se -tags text -font {Times 10} -stipple $stipple $c create rect 2.95i 3.45i 3.05i 3.55i -fill {} -outline black $c create text 3.0i 3.5i -text "South Times Italic 24" \ -anchor s -tags text -font {Times 24 italic} -stipple $stipple $c create rect 2.95i 3.95i 3.05i 4.05i -fill {} -outline black $c create text 3.0i 4.0i -text "Southwest Times Bold 18" \ -anchor sw -tags text -font {Times 18 bold} -stipple $stipple $c create rect 2.95i 4.45i 3.05i 4.55i -fill {} -outline black $c create text 3.0i 4.5i -text "West Times Bold Italic 24"\ -anchor w -tags text -font {Times 24 {bold italic}} -stipple $stipple $c create rect 0.95i 5.20i 1.05i 5.30i -fill {} -outline black $c create text 1.0i 5.25i -width 1.9i -anchor c -justify left -tags text \ -font {Times 18 bold} -stipple $stipple \ -text "This is a sample text item to see how left justification works" $c create rect 2.95i 5.20i 3.05i 5.30i -fill {} -outline black $c create text 3.0i 5.25i -width 1.8i -anchor c -justify center -tags text \ -font {Times 18 bold} -stipple $stipple \ -text "This is a sample text item to see how center justification works" $c create rect 4.95i 5.20i 5.05i 5.30i -fill {} -outline black $c create text 5.0i 5.25i -width 1.8i -anchor c -justify right -tags text \ -font {Times 18 bold} -stipple $stipple \ -text "This is a sample text item to see how right justification works" $c create text 3.0i 6.0i -width 5.0i -anchor n -justify right -tags text \ -text "This text is\nright justified\nwith a line length equal to\n\ the size of the enclosing rectangle.\nMake sure it prints right\ justified as well." $c create rect 0.5i 6.0i 5.5i 6.9i -fill {} -outline black proc setStipple c { global stipple $c itemconfigure text -stipple $stipple } tk8.6.5/tests/textDisp.test0000644003604700454610000045663212656426177014375 0ustar dgp771div# This file is a Tcl script to test the code in the file tkTextDisp.c. # This file is organized in the standard fashion for Tcl tests. # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. package require tcltest 2.1 eval tcltest::configure $argv tcltest::loadTestedCommands namespace import -force tcltest::test # The procedure below is used as the scrolling command for the text; # it just saves the scrolling information in a variable "scrollInfo". proc scroll args { global scrollInfo set scrollInfo $args } # The procedure below is used to generate errors during scrolling commands. proc scrollError args { error "scrolling error" } # Create entries in the option database to be sure that geometry options # like border width have predictable values. set twbw 2 set twht 2 option add *Text.borderWidth $twbw option add *Text.highlightThickness $twht # The frame .f is needed to make sure that the overall window is always # fairly wide, even if the text window is very narrow. This is needed # because some window managers don't allow the overall width of a window # to get very narrow. catch {destroy .f .t} frame .f -width 100 -height 20 pack append . .f left set fixedFont {Courier -12} # 15 on XP, 13 on Solaris 8 set fixedHeight [font metrics $fixedFont -linespace] # 7 on all platforms set fixedWidth [font measure $fixedFont m] # 12 on XP set fixedAscent [font metrics $fixedFont -ascent] set fixedDiff [expr {$fixedHeight - 13}] ;# 2 on XP set varFont {Times -14} # 16 on XP, 15 on Solaris 8 set varHeight [font metrics $varFont -linespace] # 13 on XP set varAscent [font metrics $varFont -ascent] set varDiff [expr {$varHeight - 15}] ;# 1 on XP set bigFont {Helvetica -24} # 27 on XP, 27 on Solaris 8 set bigHeight [font metrics $bigFont -linespace] # 21 on XP set bigAscent [font metrics $bigFont -ascent] set ascentDiff [expr {$bigAscent - $fixedAscent}] text .t -font $fixedFont -width 20 -height 10 -yscrollcommand scroll pack append . .t {top expand fill} .t tag configure big -font $bigFont .t debug on wm geometry . {} # The statements below reset the main window; it's needed if the window # manager is mwm to make mwm forget about a previous minimum size setting. wm withdraw . wm minsize . 1 1 wm positionfrom . user wm deiconify . update # Some window managers (like olwm under SunOS 4.1.3) misbehave in a way # that tends to march windows off the top and left of the screen. If # this happens, some tests will fail because parts of the window will # not need to be displayed (because they're off-screen). To keep this # from happening, move the window if it's getting near the left or top # edges of the screen. if {([winfo rooty .] < 50) || ([winfo rootx .] < 50)} { wm geom . +50+50 } test textDisp-0.1 {double tag elide transition} { # Example from tkchat crash. For some reason can only # get this test case to crash when first. catch {destroy .top} pack [text .top] foreach val {0 1 2 3} { .top insert 1.0 "hello\n" .top tag configure tag$val .top tag add tag$val 1.0 2.0 set ::Options(tag$val) 0 } proc DoVis {tag} { .top tag config $tag -elide $::Options($tag) } proc NickVis {val} { foreach t [array names ::Options ] { if {$::Options($t) != $val} { set ::Options($t) $val DoVis $t } } } NickVis 1 unset ::Options destroy .top } {} test textDisp-0.2 {double tag elide transition} { # Example from tkchat crash. For some reason can only # get this test case to crash when first. catch {destroy .top} pack [text .top] foreach val {0 1 2 3} { .top insert 1.0 "hello" .top tag configure tag$val .top tag add tag$val 1.0 1.5 set ::Options(tag$val) 0 } proc DoVis {tag} { .top tag config $tag -elide $::Options($tag) } proc NickVis {val} { foreach t [array names ::Options ] { if {$::Options($t) != $val} { set ::Options($t) $val DoVis $t } } } NickVis 1 unset ::Options destroy .top } {} test textDisp-0.3 {double tag elide transition} { catch {destroy .txt} pack [text .txt] # Note that TRAFFIC should have a higher priority than SYSTEM # in terms of the tag effects. .txt tag configure SYSTEM -elide 0 .txt tag configure TRAFFIC -elide 1 .txt insert end "\n" {TRAFFIC SYSTEM} update destroy .txt } {} test textDisp-0.4 {double tag elide transition} { catch {destroy .txt} pack [text .txt] # Note that TRAFFIC should have a higher priority than SYSTEM # in terms of the tag effects. .txt tag configure SYSTEM -elide 0 .txt tag configure TRAFFIC -elide 1 .txt insert end "\n" {SYSTEM TRAFFIC} # Crash was here. update destroy .txt } {} test textDisp-0.5 {double tag elide transition} { catch {destroy .txt} pack [text .txt] .txt tag configure WELCOME -elide 1 .txt tag configure SYSTEM -elide 0 .txt tag configure TRAFFIC -elide 1 .txt insert end "\n" {SYSTEM TRAFFIC} .txt insert end "\n" WELCOME # Crash was here. update destroy .txt } {} test textDisp-1.1 {GetStyle procedure, priorities and tab stops} { .t delete 1.0 end .t insert 1.0 "x\ty" .t tag delete x y z .t tag configure x -tabs {50} .t tag configure y -foreground black .t tag configure z -tabs {70} .t tag add x 1.0 1.end .t tag add y 1.0 1.end .t tag add z 1.0 1.end update idletasks set x [lindex [.t bbox 1.2] 0] .t tag configure z -tabs {} lappend x [lindex [.t bbox 1.2] 0] .t tag configure z -tabs {30} .t tag raise x update idletasks lappend x [lindex [.t bbox 1.2] 0] } [list 75 55 55] .t tag delete x y z test textDisp-1.2 {GetStyle procedure, wrapmode} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "abcd\nefg hijkl mnop qrstuv wxyz" .t tag configure x -wrap word .t tag configure y -wrap none .t tag raise y update set result [list [.t bbox 2.20]] .t tag add x 2.0 2.1 lappend result [.t bbox 2.20] .t tag add y 1.end 2.2 lappend result [.t bbox 2.20] } [list [list 5 [expr {5+2*$fixedHeight}] 7 $fixedHeight] [list 40 [expr {5+2*$fixedHeight}] 7 $fixedHeight] {}] .t tag delete x y test textDisp-2.1 {LayoutDLine, basics} { .t configure -wrap char .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]] test textDisp-2.2 {LayoutDLine, basics} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "This isx some sample text for testing." list [.t bbox 1.19] [.t bbox 1.20] } [list [list 138 5 7 $fixedHeight] [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight]] test textDisp-2.3 {LayoutDLine, basics} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "This isxxx some sample text for testing." list [.t bbox 1.19] [.t bbox 1.20] } [list [list 138 5 7 $fixedHeight] [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight]] test textDisp-2.4 {LayoutDLine, word wrap} {textfonts} { .t configure -wrap word .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 138 5 7 $fixedHeight] [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight]] test textDisp-2.5 {LayoutDLine, word wrap} {textfonts} { .t configure -wrap word .t delete 1.0 end .t insert 1.0 "This isx some sample text for testing." list [.t bbox 1.13] [.t bbox 1.14] [.t bbox 1.19] } [list [list 96 5 49 $fixedHeight] [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 40 [expr {$fixedDiff + 18}] 7 $fixedHeight]] test textDisp-2.6 {LayoutDLine, word wrap} { .t configure -wrap word .t delete 1.0 end .t insert 1.0 "This isxxx some sample text for testing." list [.t bbox 1.15] [.t bbox 1.16] } [list [list 110 5 35 $fixedHeight] [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight]] test textDisp-2.7 {LayoutDLine, marks and tags} {textfonts} { .t configure -wrap word .t delete 1.0 end .t insert 1.0 "This isxxx some sample text for testing." .t tag add foo 1.4 1.6 .t mark set insert 1.8 list [.t bbox 1.2] [.t bbox 1.5] [.t bbox 1.11] } [list [list 19 5 7 $fixedHeight] [list 40 5 7 $fixedHeight] [list 82 5 7 $fixedHeight]] foreach m [.t mark names] { catch {.t mark unset $m} } 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 update .t configure -wrap char .t delete 1.0 end .t insert 1.0 "This isxx some sample text for testing." .t mark set foo 1.20 list [.t bbox 1.19] [.t bbox 1.20] } [list [list 138 5 8 $fixedHeight] [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight]] wm geom . {} update test textDisp-2.9 {LayoutDLine, marks and tags} {textfonts} { .t configure -wrap word .t delete 1.0 end .t insert 1.0 "This is a very_very_long_word_that_wraps." list [.t bbox 1.9] [.t bbox 1.10] [.t bbox 1.25] } [list [list 68 5 77 $fixedHeight] [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 110 [expr {$fixedDiff + 18}] 7 $fixedHeight]] test textDisp-2.10 {LayoutDLine, marks and tags} {textfonts} { .t configure -wrap word .t delete 1.0 end .t insert 1.0 "This is a very_very_long_word_that_wraps." .t tag add foo 1.13 .t tag add foo 1.15 .t tag add foo 1.17 .t tag add foo 1.19 list [.t bbox 1.9] [.t bbox 1.10] [.t bbox 1.25] } [list [list 68 5 77 $fixedHeight] [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 110 [expr {$fixedDiff + 18}] 7 $fixedHeight]] test textDisp-2.11 {LayoutDLine, newline width} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "a\nbb\nccc\ndddd" list [.t bbox 2.2] [.t bbox 3.3] } [list [list 19 [expr {$fixedDiff + 18}] 126 $fixedHeight] [list 26 [expr {2*$fixedDiff + 31}] 119 $fixedHeight]] test textDisp-2.12 {LayoutDLine, justification} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "\na\nbb\nccc\ndddd" .t tag configure x -justify center .t tag add x 1.0 end .t tag add y 3.0 3.2 list [.t bbox 1.0] [.t bbox 2.0] [.t bbox 4.0] [.t bbox 4.2] } [list [list 75 5 70 $fixedHeight] [list 71 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 64 [expr {3*$fixedDiff + 44}] 7 $fixedHeight] [list 78 [expr {3*$fixedDiff + 44}] 7 $fixedHeight]] test textDisp-2.13 {LayoutDLine, justification} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "\na\nbb\nccc\ndddd" .t tag configure x -justify right .t tag add x 1.0 end .t tag add y 3.0 3.2 list [.t bbox 1.0] [.t bbox 2.0] [.t bbox 4.0] [.t bbox 4.2] } [list [list 145 5 0 $fixedHeight] [list 138 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 124 [expr {3*$fixedDiff + 44}] 7 $fixedHeight] [list 138 [expr {3*$fixedDiff + 44}] 7 $fixedHeight]] test textDisp-2.14 {LayoutDLine, justification} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "\na\nbb\nccc\ndddd" .t tag configure x -justify center .t tag add x 2.0 3.1 .t tag configure y -justify right .t tag add y 3.0 4.0 .t tag raise y list [.t bbox 2.0] [.t bbox 3.0] [.t bbox 3.end] [.t bbox 4.0] } [list [list 71 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 131 [expr {2*$fixedDiff + 31}] 7 $fixedHeight] [list 145 [expr {2*$fixedDiff + 31}] 0 $fixedHeight] [list 5 [expr {3*$fixedDiff + 44}] 7 $fixedHeight]] test textDisp-2.15 {LayoutDLine, justification} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "\na\nbb\nccc\ndddd" .t tag configure x -justify center .t tag add x 2.0 3.1 .t tag configure y -justify right .t tag add y 3.0 4.0 .t tag lower y list [.t bbox 2.0] [.t bbox 3.0] [.t bbox 3.end] [.t bbox 4.0] } [list [list 71 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 68 [expr {2*$fixedDiff + 31}] 7 $fixedHeight] [list 82 [expr {2*$fixedDiff + 31}] 63 $fixedHeight] [list 5 [expr {3*$fixedDiff + 44}] 7 $fixedHeight]] test textDisp-2.16 {LayoutDLine, justification} {textfonts} { .t configure -wrap word .t delete 1.0 end .t insert 1.0 "Lots of long words, enough to force word wrap\nThen\nmore lines" .t tag configure x -justify center .t tag add x 1.1 1.20 .t tag add x 1.21 1.end list [.t bbox 1.0] [.t bbox 1.20] [.t bbox 1.36] [.t bbox 2.0] } [list [list 5 5 7 $fixedHeight] [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 43 [expr {2*$fixedDiff + 31}] 7 $fixedHeight] [list 5 [expr {3*$fixedDiff + 44}] 7 $fixedHeight]] test textDisp-2.17 {LayoutDLine, justification} {textfonts} { .t configure -wrap word .t delete 1.0 end .t insert 1.0 "Lots of long words, enough to force word wrap\nThen\nmore lines" .t tag configure x -justify center .t tag add x 1.20 list [.t bbox 1.0] [.t bbox 1.20] [.t bbox 1.36] [.t bbox 2.0] } [list [list 5 5 7 $fixedHeight] [list 19 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 5 [expr {2*$fixedDiff + 31}] 7 $fixedHeight] [list 5 [expr {3*$fixedDiff + 44}] 7 $fixedHeight]] test textDisp-2.18 {LayoutDLine, justification} {textfonts} { .t configure -wrap none .t delete 1.0 end .t insert 1.0 "Lots of long words, enough to extend out of the window\n" .t insert end "Then\nmore lines\nThat are shorter" .t tag configure x -justify center .t tag configure y -justify right .t tag add x 2.0 .t tag add y 3.0 .t xview scroll 5 units list [.t bbox 2.0] [.t bbox 3.0] } [list [list 26 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 40 [expr {2*$fixedDiff + 31}] 7 $fixedHeight]] .t tag delete x .t tag delete y test textDisp-2.19 {LayoutDLine, margins} {textfonts} { .t configure -wrap word .t delete 1.0 end .t insert 1.0 "Lots of long words, enough to force word wrap\nThen\nmore lines" .t tag configure x -lmargin1 20 -lmargin2 40 -rmargin 15 .t tag add x 1.0 end list [.t bbox 1.0] [.t bbox 1.12] [.t bbox 1.13] [.t bbox 2.0] } [list [list 25 5 7 $fixedHeight] [list 109 5 36 $fixedHeight] [list 45 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 25 [expr {5*$fixedDiff + 70}] 7 $fixedHeight]] test textDisp-2.20 {LayoutDLine, margins} {textfonts} { .t configure -wrap word .t delete 1.0 end .t insert 1.0 "Lots of long words, enough to force word wrap\nThen\nmore lines" .t tag configure x -lmargin1 20 -lmargin2 10 -rmargin 3 .t tag configure y -lmargin1 15 -lmargin2 5 -rmargin 0 .t tag raise y .t tag add x 1.0 end .t tag add y 1.13 list [.t bbox 1.0] [.t bbox 1.13] [.t bbox 1.30] [.t bbox 2.0] } [list [list 25 5 7 $fixedHeight] [list 10 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 15 [expr {2*$fixedDiff + 31}] 7 $fixedHeight] [list 25 [expr {3*$fixedDiff + 44}] 7 $fixedHeight]] test textDisp-2.21 {LayoutDLine, margins} {textfonts} { .t configure -wrap word .t delete 1.0 end .t insert 1.0 "Sample text" .t tag configure x -lmargin1 80 -lmargin2 80 -rmargin 100 .t tag add x 1.0 end list [.t bbox 1.0] [.t bbox 1.1] [.t bbox 1.2] } [list [list 85 5 60 $fixedHeight] [list 85 [expr {$fixedDiff + 18}] 60 $fixedHeight] [list 85 [expr {2*$fixedDiff + 31}] 60 $fixedHeight]] .t tag delete x .t tag delete y test textDisp-2.22 {LayoutDLine, spacing options} {textfonts} { .t configure -wrap word .t delete 1.0 end .t tag delete x y .t insert end "Short line\nLine 2 is long enough " .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 i [.t dlineinfo 2.0] 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 i [.t dlineinfo 3.0] 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 i [.t dlineinfo 2.0] 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 i [.t dlineinfo 3.0] 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 test textDisp-2.23 {LayoutDLine, spacing options} {textfonts} { .t configure -wrap word .t delete 1.0 end .t tag delete x y .t insert end "Short line\nLine 2 is long enough " .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 i [.t dlineinfo 2.0] 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 i [.t dlineinfo 3.0] 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 .t tag configure y -spacing1 0 -spacing2 3 .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 i [.t dlineinfo 2.0] 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 i [.t dlineinfo 3.0] 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 test textDisp-2.24 {LayoutDLine, tabs, saving from first chunk} {textfonts} { .t delete 1.0 end .t tag delete x y .t tag configure x -tabs 70 .t tag configure y -tabs 80 .t insert 1.0 "ab\tcde" .t tag add x 1.0 end .t tag add y 1.1 end lindex [.t bbox 1.3] 0 } {75} test textDisp-2.25 {LayoutDLine, tabs, breaking chunks at tabs} {textfonts} { .t delete 1.0 end .t tag delete x .t tag configure x -tabs [list 30 60 90 120] .t insert 1.0 "a\tb\tc\td\te" .t mark set dummy1 1.1 .t mark set dummy2 1.2 .t tag add x 1.0 end list [lindex [.t bbox 1.2] 0] [lindex [.t bbox 1.4] 0] \ [lindex [.t bbox 1.6] 0] [lindex [.t bbox 1.8] 0] } [list 35 65 95 125] test textDisp-2.26 {LayoutDLine, tabs, breaking chunks at tabs} {textfonts} { .t delete 1.0 end .t tag delete x .t tag configure x -tabs [list 30 60 90 120] -justify right .t insert 1.0 "a\tb\tc\td\te" .t mark set dummy1 1.1 .t mark set dummy2 1.2 .t tag add x 1.0 end list [lindex [.t bbox 1.2] 0] [lindex [.t bbox 1.4] 0] \ [lindex [.t bbox 1.6] 0] [lindex [.t bbox 1.8] 0] } [list 117 124 131 138] test textDisp-2.27 {LayoutDLine, tabs, calling AdjustForTab} {textfonts} { .t delete 1.0 end .t tag delete x .t tag configure x -tabs [list 30 60] .t insert 1.0 "a\tb\tcd" .t tag add x 1.0 end list [lindex [.t bbox 1.2] 0] [lindex [.t bbox 1.4] 0] } [list 35 65] test textDisp-2.28 {LayoutDLine, tabs, running out of space in dline} {textfonts} { .t delete 1.0 end .t insert 1.0 "a\tb\tc\td" .t bbox 1.6 } [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight] test textDisp-2.29 {LayoutDLine, tabs, running out of space in dline} {textfonts} { .t delete 1.0 end .t insert 1.0 "a\tx\tabcd" .t bbox 1.4 } [list 117 5 7 $fixedHeight] test textDisp-2.30 {LayoutDLine, tabs, running out of space in dline} {textfonts} { .t delete 1.0 end .t insert 1.0 "a\tx\tabc" .t bbox 1.4 } [list 117 5 7 $fixedHeight] test textDisp-3.1 {different character sizes} {textfonts} { .t configure -wrap word .t delete 1.0 end .t insert end "Some sample text, including both large\n" .t insert end "characters and\nsmall\n" .t insert end "abc\nd\ne\nfghij" .t tag add big 1.5 1.10 .t tag add big 2.11 2.14 list [.t bbox 1.1] [.t bbox 1.6] [.t dlineinfo 1.0] [.t dlineinfo 3.0] } [list [list 12 [expr {5+$ascentDiff}] 7 $fixedHeight] [list 52 5 13 27] [list 5 5 114 27 [font metrics $bigFont -ascent]] [list 5 [expr {2* $fixedDiff + 85}] 35 $fixedHeight [expr {$fixedDiff + 10}]]] .t configure -wrap char test textDisp-4.1 {UpdateDisplayInfo, basic} {textfonts} { .t delete 1.0 end .t insert end "Line 1\nLine 2\nLine 3\n" update .t delete 2.0 2.end update set res $tk_textRelayout .t insert 2.0 "New Line 2" update lappend res [.t bbox 1.0] [.t bbox 2.0] [.t bbox 3.0] $tk_textRelayout } [list 2.0 [list 5 5 7 $fixedHeight] [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 5 [expr {2*$fixedDiff + 31}] 7 $fixedHeight] 2.0] test textDisp-4.2 {UpdateDisplayInfo, re-use tail of text line} {textfonts} { .t delete 1.0 end .t insert end "Line 1\nLine 2 is so long that it wraps around\nLine 3" update .t mark set x 2.21 .t delete 2.2 update set res $tk_textRelayout .t insert 2.0 X update lappend res [.t bbox 2.0] [.t bbox x] [.t bbox 3.0] $tk_textRelayout } [list 2.0 2.20 [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 12 [expr {2*$fixedDiff + 31}] 7 $fixedHeight] [list 5 [expr {3*$fixedDiff + 44}] 7 $fixedHeight] {2.0 2.20}] test textDisp-4.3 {UpdateDisplayInfo, tail of text line shifts} {textfonts} { .t delete 1.0 end .t insert end "Line 1\nLine 2 is so long that it wraps around\nLine 3" update .t mark set x 2.21 .t delete 2.2 update list [.t bbox 2.0] [.t bbox x] [.t bbox 3.0] $tk_textRelayout } [list [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 5 [expr {2*$fixedDiff + 31}] 7 $fixedHeight] [list 5 [expr {3*$fixedDiff + 44}] 7 $fixedHeight] {2.0 2.20}] .t mark unset x test textDisp-4.4 {UpdateDisplayInfo, wrap-mode "none"} {textfonts} { .t configure -wrap none .t delete 1.0 end .t insert end "Line 1\nLine 2 is so long that it wraps around\nLine 3" update list [.t bbox 2.0] [.t bbox 2.25] [.t bbox 3.0] $tk_textRelayout } [list [list 5 [expr {$fixedDiff + 18}] 7 $fixedHeight] {} [list 5 [expr {2*$fixedDiff + 31}] 7 $fixedHeight] {1.0 2.0 3.0}] test textDisp-4.5 {UpdateDisplayInfo, tiny window} {textfonts} { if {$tcl_platform(platform) == "windows"} { wm overrideredirect . 1 } wm geom . 103x$height update .t configure -wrap none .t delete 1.0 end .t insert end "Line 1\nLine 2 is so long that it wraps around\nLine 3" update list [.t bbox 2.0] [.t bbox 2.1] [.t bbox 3.0] $tk_textRelayout } [list [list 5 [expr {$fixedDiff + 18}] 1 $fixedHeight] {} [list 5 [expr {2*$fixedDiff + 31}] 1 $fixedHeight] {1.0 2.0 3.0}] if {$tcl_platform(platform) == "windows"} { wm overrideredirect . 0 } test textDisp-4.6 {UpdateDisplayInfo, tiny window} { # This test was failing on Windows because the title bar on . # was a certain minimum size and it was interfering with the size # requested. The "overrideredirect" gets rid of the titlebar so # the toplevel can shrink to the appropriate size. On Unix, setting # the overrideredirect on "." confuses the window manager and # causes subsequent tests to fail. if {$tcl_platform(platform) == "windows"} { wm overrideredirect . 1 } frame .f2 -width 20 -height 100 pack before .f .f2 top wm geom . 103x103 update .t configure -wrap none -borderwidth 2 .t delete 1.0 end .t insert end "Line 1\nLine 2 is so long that it wraps around\nLine 3" update set x [list [.t bbox 1.0] [.t bbox 2.0] $tk_textRelayout] wm overrideredirect . 0 update set x } [list [list 5 5 1 1] {} 1.0] catch {destroy .f2} .t configure -borderwidth 0 -wrap char wm geom . {} update set bw [.t cget -borderwidth] set px [.t cget -padx] set py [.t cget -pady] set hlth [.t cget -highlightthickness] test textDisp-4.7 {UpdateDisplayInfo, filling in extra vertical space} { # This test was failing on Windows because the title bar on . # was a certain minimum size and it was interfering with the size # requested. The "overrideredirect" gets rid of the titlebar so # the toplevel can shrink to the appropriate size. On Unix, setting # the overrideredirect on "." confuses the window manager and # causes subsequent tests to fail. if {$tcl_platform(platform) == "windows"} { wm overrideredirect . 1 } .t delete 1.0 end .t insert end "1\n2\n3\n4\n5\n6\n7\n8\n9\n10\n11\n12\n13\n14\n15\n16\n17" .t yview 1.0 update .t yview 16.0 update set x [list [.t index @0,0] $tk_textRelayout $tk_textRedraw] wm overrideredirect . 0 update set x } {8.0 {16.0 17.0 15.0 14.0 13.0 12.0 11.0 10.0 9.0 8.0} {8.0 9.0 10.0 11.0 12.0 13.0 14.0 15.0 16.0 17.0}} test textDisp-4.8 {UpdateDisplayInfo, filling in extra vertical space} { .t delete 1.0 end .t insert end "1\n2\n3\n4\n5\n6\n7\n8\n9\n10\n11\n12\n13\n14\n15\n16\n17" .t yview 16.0 update .t delete 5.0 14.0 update set x [list [.t index @0,0] $tk_textRelayout $tk_textRedraw] } {1.0 {5.0 4.0 3.0 2.0 1.0} {1.0 2.0 3.0 4.0 5.0 eof}} test textDisp-4.9 {UpdateDisplayInfo, filling in extra vertical space} {textfonts} { .t delete 1.0 end .t insert end "1\n2\n3\n4\n5\n6\n7\n8\n9\n10\n11\n12\n13\n14\n15\n16\n17" .t yview 16.0 update .t delete 15.0 end list [.t bbox 7.0] [.t bbox 12.0] } [list [list [expr {$hlth + $px + $bw}] [expr {$hlth + $py + $bw + $fixedHeight}] $fixedWidth $fixedHeight] [list [expr {$hlth + $px + $bw}] [expr {$hlth + $py + $bw + 6 * $fixedHeight}] $fixedWidth $fixedHeight]] test textDisp-4.10 {UpdateDisplayInfo, filling in extra vertical space} { .t delete 1.0 end .t insert end "1\n2\n3\n4\n5\nLine 6 is such a long line that it wraps around.\n7\n8\n9\n10\n11\n12\n13\n14\n15\n16\n17" .t yview end update .t delete 13.0 end update list [.t index @0,0] $tk_textRelayout $tk_textRedraw } {6.0 {13.0 7.0 6.40 6.20 6.0} {6.0 6.20 6.40 7.0 13.0}} test textDisp-4.11 {UpdateDisplayInfo, filling in extra vertical space} { .t delete 1.0 end .t insert end "1\n2\n3\n4\n5\nLine 6 is such a long line that it wraps around, not once but really quite a few times.\n7\n8\n9\n10\n11\n12\n13\n14\n15\n16\n17" .t yview end update .t delete 14.0 end update list [.t index @0,0] $tk_textRelayout $tk_textRedraw } {6.60 {14.0 7.0 6.80 6.60} {6.60 6.80 7.0 14.0}} test textDisp-4.12 {UpdateDisplayInfo, filling in extra vertical space} { .t delete 1.0 end .t insert end "1\n2\n3\n4\n5\n7\n8\n9\n10\n11\n12\n13\n14\n15\n16" button .b -text "Test" -bd 2 -highlightthickness 2 .t window create 3.end -window .b .t yview moveto 1 update .t yview moveto 0 update .t yview moveto 1 update winfo ismapped .b } {0} .t configure -wrap word .t delete 1.0 end .t insert end "Line 1\nLine 2\nLine 3\nLine 4\nLine 5\nLine 6\nLine 7\n" .t insert end "Line 8\nLine 9\nLine 10\nLine 11\nLine 12\nLine 13\n" .t insert end "Line 14\nLine 15\nLine 16" .t tag delete x .t tag configure x -relief raised -borderwidth 2 -background white test textDisp-4.13 {UpdateDisplayInfo, special handling for top/bottom lines} { .t tag add x 1.0 end .t yview 1.0 update .t yview scroll 3 units update list $tk_textRelayout $tk_textRedraw } {{11.0 12.0 13.0} {4.0 10.0 11.0 12.0 13.0}} test textDisp-4.14 {UpdateDisplayInfo, special handling for top/bottom lines} { .t tag remove x 1.0 end .t yview 1.0 update .t yview scroll 3 units update list $tk_textRelayout $tk_textRedraw } {{11.0 12.0 13.0} {11.0 12.0 13.0}} test textDisp-4.15 {UpdateDisplayInfo, special handling for top/bottom lines} { .t tag add x 1.0 end .t yview 4.0 update .t yview scroll -2 units update list $tk_textRelayout $tk_textRedraw } {{2.0 3.0} {2.0 3.0 4.0 11.0}} test textDisp-4.16 {UpdateDisplayInfo, special handling for top/bottom lines} { .t tag remove x 1.0 end .t yview 4.0 update .t yview scroll -2 units update list $tk_textRelayout $tk_textRedraw } {{2.0 3.0} {2.0 3.0}} test textDisp-4.17 {UpdateDisplayInfo, horizontal scrolling} {textfonts} { .t configure -wrap none .t delete 1.0 end .t insert end "Short line 1\nLine 2 is long enough to scroll horizontally" .t insert end "\nLine 3\nLine 4" update .t xview scroll 3 units update list $tk_textRelayout $tk_textRedraw [.t bbox 2.0] [.t bbox 2.5] \ [.t bbox 2.23] } [list {} {1.0 2.0 3.0 4.0} {} [list 17 [expr {$fixedDiff + 16}] 7 $fixedHeight] {}] test textDisp-4.18 {UpdateDisplayInfo, horizontal scrolling} {textfonts} { .t configure -wrap none .t delete 1.0 end .t insert end "Short line 1\nLine 2 is long enough to scroll horizontally" .t insert end "\nLine 3\nLine 4" update .t xview scroll 100 units update list $tk_textRelayout $tk_textRedraw [.t bbox 2.25] } [list {} {1.0 2.0 3.0 4.0} [list 10 [expr {$fixedDiff + 16}] 7 $fixedHeight]] test textDisp-4.19 {UpdateDisplayInfo, horizontal scrolling} {textfonts} { .t configure -wrap none .t delete 1.0 end .t insert end "Short line 1\nLine 2 is long enough to scroll horizontally" .t insert end "\nLine 3\nLine 4" update .t xview moveto 0 .t xview scroll -10 units update list $tk_textRelayout $tk_textRedraw [.t bbox 2.5] } [list {} {1.0 2.0 3.0 4.0} [list 38 [expr {$fixedDiff + 16}] 7 $fixedHeight]] test textDisp-4.20 {UpdateDisplayInfo, horizontal scrolling} {textfonts} { .t configure -wrap none .t delete 1.0 end .t insert end "Short line 1\nLine 2 is long enough to scroll horizontally" .t insert end "\nLine 3\nLine 4" .t xview moveto 0.0 .t xview scroll 100 units update .t delete 2.30 2.44 update list $tk_textRelayout $tk_textRedraw [.t bbox 2.25] } [list 2.0 {1.0 2.0 3.0 4.0} [list 108 [expr {$fixedDiff + 16}] 7 $fixedHeight]] test textDisp-4.21 {UpdateDisplayInfo, horizontal scrolling} {textfonts} { .t configure -wrap none .t delete 1.0 end .t insert end "Short line 1\nLine 2 is long enough to scroll horizontally" .t insert end "\nLine 3\nLine 4" .t xview moveto .9 update .t xview moveto .6 update list $tk_textRelayout $tk_textRedraw } {{} {}} test textDisp-4.22 {UpdateDisplayInfo, no horizontal scrolling except for -wrap none} {textfonts} { .t configure -wrap none .t delete 1.0 end .t insert end "Short line 1\nLine 2 is long enough to scroll horizontally" .t insert end "\nLine 3\nLine 4" .t xview scroll 25 units update .t configure -wrap word list [.t bbox 2.0] [.t bbox 2.16] } [list [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight] [list 10 [expr {2*$fixedDiff + 29}] 7 $fixedHeight]] test textDisp-4.23 {UpdateDisplayInfo, no horizontal scrolling except for -wrap none} {textfonts} { .t configure -wrap none .t delete 1.0 end .t insert end "Short line 1\nLine 2 is long enough to scroll horizontally" .t insert end "\nLine 3\nLine 4" .t xview scroll 25 units update .t configure -wrap char list [.t bbox 2.0] [.t bbox 2.16] } [list [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight] [list 115 [expr {$fixedDiff + 16}] 7 $fixedHeight]] test textDisp-5.1 {DisplayDLine, handling of spacing} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "abcdefghijkl\nmnopqrstuvwzyz" .t tag configure spacing -spacing1 8 -spacing3 2 .t tag add spacing 1.0 end frame .t.f1 -width 10 -height 4 -bg black frame .t.f2 -width 10 -height 4 -bg black frame .t.f3 -width 10 -height 4 -bg black frame .t.f4 -width 10 -height 4 -bg black .t window create 1.3 -window .t.f1 -align top .t window create 1.7 -window .t.f2 -align center .t window create 2.1 -window .t.f3 -align bottom .t window create 2.10 -window .t.f4 -align baseline update list [winfo geometry .t.f1] [winfo geometry .t.f2] \ [winfo geometry .t.f3] [winfo geometry .t.f4] } [list 10x4+24+11 10x4+55+[expr {$fixedDiff/2 + 15}] 10x4+10+[expr {2*$fixedDiff + 43}] 10x4+76+[expr {2*$fixedDiff + 40}]] .t tag delete spacing # Although the following test produces a useful result, its main # effect is to produce a core dump if Tk doesn't handle display # relayout that occurs during redisplay. test textDisp-5.2 {DisplayDLine, line resizes during display} { .t delete 1.0 end frame .t.f -width 20 -height 20 -bd 2 -relief raised bind .t.f {.t.f configure -width 30 -height 30} .t window create insert -window .t.f update list [winfo width .t.f] [winfo height .t.f] } [list 30 30] .t configure -wrap char test textDisp-6.1 {scrolling in DisplayText, scroll up} { .t delete 1.0 end .t insert 1.0 "Line 1" foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { .t insert end "\nLine $i" } update .t delete 2.0 3.0 update list $tk_textRelayout $tk_textRedraw } {{2.0 10.0} {2.0 10.0}} test textDisp-6.2 {scrolling in DisplayText, scroll down} { .t delete 1.0 end .t insert 1.0 "Line 1" foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { .t insert end "\nLine $i" } update .t insert 2.0 "New Line 2\n" update list $tk_textRelayout $tk_textRedraw } {{2.0 3.0} {2.0 3.0}} test textDisp-6.3 {scrolling in DisplayText, multiple scrolls} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "Line 1" foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { .t insert end "\nLine $i" } update .t insert 2.end "is so long that it wraps" .t insert 4.end "is so long that it wraps" update list $tk_textRelayout $tk_textRedraw } {{2.0 2.20 4.0 4.20} {2.0 2.20 4.0 4.20}} test textDisp-6.4 {scrolling in DisplayText, scrolls interfere} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "Line 1" foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { .t insert end "\nLine $i" } update .t insert 2.end "is so long that it wraps around, not once but three times" .t insert 4.end "is so long that it wraps" update list $tk_textRelayout $tk_textRedraw } {{2.0 2.20 2.40 2.60 4.0 4.20} {2.0 2.20 2.40 2.60 4.0 4.20 6.0}} test textDisp-6.5 {scrolling in DisplayText, scroll source obscured} {nonPortable} { .t configure -wrap char frame .f2 -bg red place .f2 -in .t -relx 0.5 -rely 0.5 -relwidth 0.5 -relheight 0.5 .t delete 1.0 end .t insert 1.0 "Line 1 is so long that it wraps around, a couple of times" foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { .t insert end "\nLine $i" } update .t delete 1.6 1.end update destroy .f2 list $tk_textRelayout $tk_textRedraw } {{1.0 9.0 10.0} {1.0 4.0 5.0 9.0 10.0}} test textDisp-6.6 {scrolling in DisplayText, Expose events after scroll} {unix nonPortable} { # this test depends on all of the expose events being handled at once .t configure -wrap char frame .f2 -bg #ff0000 place .f2 -in .t -relx 0.2 -rely 0.5 -relwidth 0.5 -relheight 0.5 .t configure -bd 2 -relief raised .t delete 1.0 end .t insert 1.0 "Line 1 is so long that it wraps around, a couple of times" foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { .t insert end "\nLine $i" } update .t delete 1.6 1.end destroy .f2 update list $tk_textRelayout $tk_textRedraw } {{1.0 9.0 10.0} {borders 1.0 4.0 5.0 6.0 7.0 8.0 9.0 10.0}} .t configure -bd 0 test textDisp-6.7 {DisplayText, vertical scrollbar updates} { .t configure -wrap char .t delete 1.0 end update ; .t count -update -ypixels 1.0 end ; update set scrollInfo } {0.0 1.0} test textDisp-6.8 {DisplayText, vertical scrollbar updates} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "Line 1" update set scrollInfo "unchanged" foreach i {2 3 4 5 6 7 8 9 10 11 12 13} { .t insert end "\nLine $i" } update ; .t count -update -ypixels 1.0 end ; update set scrollInfo } [list 0.0 [expr {10.0/13}]] .t configure -yscrollcommand {} -xscrollcommand scroll test textDisp-6.9 {DisplayText, horizontal scrollbar updates} { .t configure -wrap none .t delete 1.0 end update set scrollInfo unchanged .t insert end xxxxxxxxx\n .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxx update set scrollInfo } [list 0.0 [expr {4.0/11}]] # The following group of tests is marked non-portable because # they result in a lot of extra redisplay under Ultrix. I don't # know why this is so. .t configure -bd 2 -relief raised -wrap char .t delete 1.0 end .t insert 1.0 "Line 1 is so long that it wraps around, a couple of times" foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { .t insert end "\nLine $i" } test textDisp-7.1 {TkTextRedrawRegion} {nonPortable} { frame .f2 -bg #ff0000 place .f2 -in .t -relx 0.2 -relwidth 0.6 -rely 0.22 -relheight 0.55 update destroy .f2 update list $tk_textRelayout $tk_textRedraw } {{} {1.40 2.0 3.0 4.0 5.0 6.0}} test textDisp-7.2 {TkTextRedrawRegion} {nonPortable} { frame .f2 -bg #ff0000 place .f2 -in .t -relx 0 -relwidth 0.5 -rely 0 -relheight 0.5 update destroy .f2 update list $tk_textRelayout $tk_textRedraw } {{} {borders 1.0 1.20 1.40 2.0 3.0}} test textDisp-7.3 {TkTextRedrawRegion} {nonPortable} { frame .f2 -bg #ff0000 place .f2 -in .t -relx 0.5 -relwidth 0.5 -rely 0.5 -relheight 0.5 update destroy .f2 update list $tk_textRelayout $tk_textRedraw } {{} {borders 4.0 5.0 6.0 7.0 8.0}} test textDisp-7.4 {TkTextRedrawRegion} {nonPortable} { frame .f2 -bg #ff0000 place .f2 -in .t -relx 0.4 -relwidth 0.2 -rely 0 -relheight 0.2 \ -bordermode ignore update destroy .f2 update list $tk_textRelayout $tk_textRedraw } {{} {borders 1.0 1.20}} test textDisp-7.5 {TkTextRedrawRegion} {nonPortable} { frame .f2 -bg #ff0000 place .f2 -in .t -relx 0.4 -relwidth 0.2 -rely 1.0 -relheight 0.2 \ -anchor s -bordermode ignore update destroy .f2 update list $tk_textRelayout $tk_textRedraw } {{} {borders 7.0 8.0}} test textDisp-7.6 {TkTextRedrawRegion} {nonPortable} { frame .f2 -bg #ff0000 place .f2 -in .t -relx 0 -relwidth 0.2 -rely 0.55 -relheight 0.2 \ -anchor w -bordermode ignore update destroy .f2 update list $tk_textRelayout $tk_textRedraw } {{} {borders 3.0 4.0 5.0}} test textDisp-7.7 {TkTextRedrawRegion} {nonPortable} { frame .f2 -bg #ff0000 place .f2 -in .t -relx 1.0 -relwidth 0.2 -rely 0.55 -relheight 0.2 \ -anchor e -bordermode ignore update destroy .f2 update list $tk_textRelayout $tk_textRedraw } {{} {borders 3.0 4.0 5.0}} test textDisp-7.8 {TkTextRedrawRegion} {nonPortable} { .t delete 1.0 end .t insert 1.0 "Line 1\nLine 2\nLine 3\nLine 4\nLine 5\nLine 6\n" frame .f2 -bg #ff0000 place .f2 -in .t -relx 0.0 -relwidth 0.4 -rely 0.35 -relheight 0.4 \ -anchor nw -bordermode ignore update destroy .f2 update list $tk_textRelayout $tk_textRedraw } {{} {borders 4.0 5.0 6.0 7.0 eof}} .t configure -bd 0 test textDisp-8.1 {TkTextChanged: redisplay whole lines} {textfonts} { .t configure -wrap word .t delete 1.0 end .t insert 1.0 "Line 1\nLine 2 is so long that it wraps around, two times" foreach i {3 4 5 6 7 8 9 10 11 12 13 14 15} { .t insert end "\nLine $i" } update .t delete 2.36 2.38 update list $tk_textRelayout $tk_textRedraw [.t bbox 2.32] } [list {2.0 2.18 2.38} {2.0 2.18 2.38} [list 101 [expr {2*$fixedDiff + 29}] 7 $fixedHeight]] .t configure -wrap char test textDisp-8.2 {TkTextChanged, redisplay whole lines} { .t delete 1.0 end .t insert 1.0 "Line 1 is so long that it wraps around, two times" foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { .t insert end "\nLine $i" } update .t insert 1.2 xx update list $tk_textRelayout $tk_textRedraw } {{1.0 1.20 1.40} {1.0 1.20 1.40}} test textDisp-8.3 {TkTextChanged} { .t delete 1.0 end .t insert 1.0 "Line 1 is so long that it wraps around, two times" foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { .t insert end "\nLine $i" } update .t insert 2.0 xx update list $tk_textRelayout $tk_textRedraw } {2.0 2.0} test textDisp-8.4 {TkTextChanged} { .t delete 1.0 end .t insert 1.0 "Line 1 is so long that it wraps around, two times" foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { .t insert end "\nLine $i" } update .t delete 1.5 update list $tk_textRelayout $tk_textRedraw } {{1.0 1.20 1.40} {1.0 1.20 1.40}} test textDisp-8.5 {TkTextChanged} { .t delete 1.0 end .t insert 1.0 "Line 1 is so long that it wraps around, two times" foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { .t insert end "\nLine $i" } update .t delete 1.40 1.44 update list $tk_textRelayout $tk_textRedraw } {{1.0 1.20 1.40} {1.0 1.20 1.40}} test textDisp-8.6 {TkTextChanged} { .t delete 1.0 end .t insert 1.0 "Line 1 is so long that it wraps around, two times" foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { .t insert end "\nLine $i" } update .t delete 1.41 1.44 update list $tk_textRelayout $tk_textRedraw } {{1.0 1.20 1.40} {1.0 1.20 1.40}} test textDisp-8.7 {TkTextChanged} { .t delete 1.0 end .t insert 1.0 "Line 1 is so long that it wraps around, two times" foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { .t insert end "\nLine $i" } update .t delete 1.2 1.end update list $tk_textRelayout $tk_textRedraw } {{1.0 9.0 10.0} {1.0 9.0 10.0}} test textDisp-8.8 {TkTextChanged} { .t delete 1.0 end .t insert 1.0 "Line 1 is so long that it wraps around, two times" foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { .t insert end "\nLine $i" } update .t delete 2.2 update list $tk_textRelayout $tk_textRedraw } {2.0 2.0} test textDisp-8.9 {TkTextChanged} { .t delete 1.0 end .t insert 1.0 "Line 1 is so long that it wraps around, two times" foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { .t insert end "\nLine $i" } update .t delete 2.0 3.0 update list $tk_textRelayout $tk_textRedraw } {{2.0 8.0} {2.0 8.0}} test textDisp-8.10 {TkTextChanged} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "Line 1\nLine 2 is long enough to wrap\nLine 3 is also long enough to wrap\nLine 4" .t tag add big 2.19 update .t delete 2.19 update set tk_textRedraw } {2.0 2.20 eof} test textDisp-8.11 {TkTextChanged, scrollbar notification when changes are off-screen} { .t delete 1.0 end .t insert end "1\n2\n3\n4\n5\n6\n7\n8\n9\n10\n11\n12\n" .t configure -yscrollcommand scroll update set scrollInfo "" .t insert end "a\nb\nc\n" # We need to wait for our asychronous callbacks to update the # scrollbar update ; .t count -update -ypixels 1.0 end ; update .t configure -yscrollcommand "" set scrollInfo } {0.0 0.625} test textDisp-8.12 {TkTextChanged, moving the insert cursor redraws only past and new lines} { .t delete 1.0 end .t configure -wrap none for {set i 1} {$i < 25} {incr i} { .t insert end "Line $i Line $i\n" } .t tag add hidden 5.0 8.0 .t tag configure hidden -elide true .t mark set insert 9.0 update .t mark set insert 8.0 ; # up one line update set res [list $tk_textRedraw] .t mark set insert 12.2 ; # in the visible text update lappend res $tk_textRedraw .t mark set insert 6.5 ; # in the hidden text update lappend res $tk_textRedraw .t mark set insert 3.5 ; # in the visible text again update lappend res $tk_textRedraw .t mark set insert 3.8 ; # within the same line update lappend res $tk_textRedraw } {{8.0 9.0} {8.0 12.0} {8.0 12.0} {3.0 8.0} {3.0 4.0}} test textDisp-8.13 {TkTextChanged, used to crash, see [06c1433906]} { .t delete 1.0 end .t insert 1.0 \nLine2\nLine3\n update .t insert 3.0 "" .t delete 1.0 2.0 update idletasks } {} test textDisp-9.1 {TkTextRedrawTag} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "Line 1\nLine 2 is long enough to wrap around\nLine 3\nLine 4" update .t tag add big 2.2 2.4 update list $tk_textRelayout $tk_textRedraw } {{2.0 2.18} {2.0 2.18}} test textDisp-9.2 {TkTextRedrawTag} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "Line 1\nLine 2 is long enough to wrap around\nLine 3\nLine 4" update .t tag add big 1.2 2.4 update list $tk_textRelayout $tk_textRedraw } {{1.0 2.0 2.17} {1.0 2.0 2.17}} test textDisp-9.3 {TkTextRedrawTag} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "Line 1\nLine 2 is long enough to wrap around\nLine 3\nLine 4" update .t tag add big 2.2 2.4 update .t tag remove big 1.0 end update list $tk_textRelayout $tk_textRedraw } {{2.0 2.20} {2.0 2.20 eof}} test textDisp-9.4 {TkTextRedrawTag} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "Line 1\nLine 2 is long enough to wrap around\nLine 3\nLine 4" update .t tag add big 2.2 2.20 update .t tag remove big 1.0 end update list $tk_textRelayout $tk_textRedraw } {{2.0 2.20} {2.0 2.20 eof}} test textDisp-9.5 {TkTextRedrawTag} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "Line 1\nLine 2 is long enough to wrap around\nLine 3\nLine 4" update .t tag add big 2.2 2.end update .t tag remove big 1.0 end update list $tk_textRelayout $tk_textRedraw } {{2.0 2.20} {2.0 2.20 eof}} test textDisp-9.6 {TkTextRedrawTag} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "Line 1\nLine 2 is long enough to wrap\nLine 3 is also long enough to wrap" update .t tag add big 2.2 3.5 update .t tag remove big 1.0 end update list $tk_textRelayout $tk_textRedraw } {{2.0 2.20 3.0 3.20} {2.0 2.20 3.0 3.20 eof}} test textDisp-9.7 {TkTextRedrawTag} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "Line 1\nLine 2 is long enough to wrap\nLine 3 is also long enough to wrap\nLine 4" .t tag add big 2.19 update .t tag remove big 2.19 update set tk_textRedraw } {2.0 2.20 eof} test textDisp-9.8 {TkTextRedrawTag} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "Line 1\nLine 2 is long enough to wrap\nLine 3 is also long enough to wrap\nLine 4" .t tag add big 1.0 2.0 update .t tag add big 2.0 2.5 update set tk_textRedraw } {2.0 2.17} test textDisp-9.9 {TkTextRedrawTag} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "Line 1\nLine 2 is long enough to wrap\nLine 3 is also long enough to wrap\nLine 4" .t tag add big 1.0 2.0 update .t tag add big 1.5 2.5 update set tk_textRedraw } {2.0 2.17} test textDisp-9.10 {TkTextRedrawTag} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "Line 1\nLine 2 is long enough to wrap\nLine 3 is also long enough to wrap\nLine 4" .t tag add big 1.0 2.0 update set tk_textRedraw {none} .t tag add big 1.3 1.5 update set tk_textRedraw } {none} test textDisp-9.11 {TkTextRedrawTag} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "Line 1\nLine 2 is long enough to wrap\nLine 3 is also long enough to wrap\nLine 4" .t tag add big 1.0 2.0 update .t tag add big 1.0 2.0 update set tk_textRedraw } {} test textDisp-9.12 {TkTextRedrawTag} { .t configure -wrap char .t delete 1.0 end for {set i 1} {$i < 5} {incr i} { .t insert end "Line $i+++Line $i\n" } .t tag configure hidden -elide true .t tag add hidden 2.6 3.6 update .t tag add hidden 3.11 4.6 update list $tk_textRelayout $tk_textRedraw } {2.0 {2.0 eof}} 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 tag add hidden 2.8 2.17 .t tag add hidden 6.8 7.17 .t tag configure hidden -background red .t tag configure hidden -elide true update .t tag configure hidden -elide false update list $tk_textRelayout $tk_textRedraw } {{2.0 6.0 7.0} {2.0 6.0 7.0}} test textDisp-9.14 {TkTextRedrawTag} { pack [text .tnocrash] for {set i 1} {$i < 6} {incr i} { .tnocrash insert end \nfoo$i } .tnocrash tag configure mytag1 -relief raised .tnocrash tag configure mytag2 -relief solid update proc doit {} { .tnocrash tag add mytag1 4.0 5.0 .tnocrash tag add mytag2 4.0 5.0 after idle { .tnocrash tag remove mytag1 1.0 end .tnocrash tag remove mytag2 1.0 end } .tnocrash delete 1.0 2.0 } doit ; # must not crash after 500 { destroy .tnocrash set done 1 } vwait done } {} test textDisp-10.1 {TkTextRelayoutWindow} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "Line 1\nLine 2 is long enough to wrap\nLine 3 is also long enough to wrap\nLine 4" update .t configure -bg black update list $tk_textRelayout $tk_textRedraw } {{1.0 2.0 2.20 3.0 3.20 4.0} {borders 1.0 2.0 2.20 3.0 3.20 4.0 eof}} .t configure -bg [lindex [.t configure -bg] 3] catch {destroy .top} test textDisp-10.2 {TkTextRelayoutWindow} { toplevel .top -width 300 -height 200 wm geometry .top +0+0 text .top.t -font $fixedFont -width 20 -height 10 -relief raised -bd 2 place .top.t -x 0 -y 0 -width 20 -height 20 .top.t insert end "First line" .top.t see insert tkwait visibility .top.t place .top.t -width 150 -height 100 update .top.t index @0,0 } {1.0} catch {destroy .top} .t delete 1.0 end .t insert end "Line 1" for {set i 2} {$i <= 200} {incr i} { .t insert end "\nLine $i" } update test textDisp-11.1 {TkTextSetYView} { .t yview 30.0 update .t index @0,0 } {30.0} test textDisp-11.2 {TkTextSetYView} { .t yview 30.0 update .t yview 32.0 update list [.t index @0,0] $tk_textRedraw } {32.0 {40.0 41.0}} test textDisp-11.3 {TkTextSetYView} { .t yview 30.0 update .t yview 28.0 update list [.t index @0,0] $tk_textRedraw } {28.0 {28.0 29.0}} test textDisp-11.4 {TkTextSetYView} { .t yview 30.0 update .t yview 31.4 update list [.t index @0,0] $tk_textRedraw } {31.0 40.0} test textDisp-11.5 {TkTextSetYView} { .t yview 30.0 update set tk_textRedraw {} .t yview -pickplace 31.0 update list [.t index @0,0] $tk_textRedraw } {30.0 {}} test textDisp-11.6 {TkTextSetYView} { .t yview 30.0 update set tk_textRedraw {} .t yview -pickplace 28.0 update list [.t index @0,0] $tk_textRedraw } {28.0 {28.0 29.0}} test textDisp-11.7 {TkTextSetYView} { .t yview 30.0 update ; update set tk_textRedraw {} .t yview -pickplace 26.0 update list [.t index @0,0] $tk_textRedraw } {21.0 {21.0 22.0 23.0 24.0 25.0 26.0 27.0 28.0 29.0}} test textDisp-11.8 {TkTextSetYView} { .t yview 30.0 update set tk_textRedraw {} .t yview -pickplace 41.0 update list [.t index @0,0] $tk_textRedraw } {32.0 {40.0 41.0}} test textDisp-11.9 {TkTextSetYView} { .t yview 30.0 update set tk_textRedraw {} .t yview -pickplace 43.0 update list [.t index @0,0] $tk_textRedraw } {38.0 {40.0 41.0 42.0 43.0 44.0 45.0 46.0 47.0 48.0}} test textDisp-11.10 {TkTextSetYView} { .t yview 30.0 update set tk_textRedraw {} .t yview 10000.0 update list [.t index @0,0] $tk_textRedraw } {191.0 {191.0 192.0 193.0 194.0 195.0 196.0 197.0 198.0 199.0 200.0}} test textDisp-11.11 {TkTextSetYView} { .t yview 195.0 update set tk_textRedraw {} .t yview 197.0 update list [.t index @0,0] $tk_textRedraw } {191.0 {191.0 192.0 193.0 194.0 195.0 196.0}} test textDisp-11.12 {TkTextSetYView, wrapped line is off-screen} { .t insert 10.0 "Long line with enough text to wrap\n" .t yview 1.0 update set tk_textRedraw {} .t see 10.30 update list [.t index @0,0] $tk_textRedraw } {2.0 10.20} .t delete 10.0 11.0 test textDisp-11.13 {TkTestSetYView, partially visible last line} { catch {destroy .top} toplevel .top wm geometry .top +0+0 text .top.t -width 20 -height 5 pack .top.t .top.t insert end "Line 1" for {set i 2} {$i <= 100} {incr i} { .top.t insert end "\nLine $i" } update scan [wm geometry .top] "%dx%d" w2 h2 wm geometry .top ${w2}x[expr $h2-2] update .top.t yview 1.0 update set tk_textRedraw {} .top.t see 5.0 update # Note, with smooth scrolling, the results of this test # have changed, and the old '2.0 {5.0 6.0}' is quite wrong. list [.top.t index @0,0] $tk_textRedraw } {1.0 5.0} catch {destroy .top} toplevel .top wm geometry .top +0+0 text .top.t -width 30 -height 3 pack .top.t .top.t insert end "Line 1" for {set i 2} {$i <= 20} {incr i} { .top.t insert end "\nLine $i" } update test textDisp-11.14 {TkTextSetYView, only a few lines visible} { .top.t yview 5.0 update .top.t see 10.0 .top.t index @0,0 } {8.0} test textDisp-11.15 {TkTextSetYView, only a few lines visible} { .top.t yview 5.0 update .top.t see 11.0 .top.t index @0,0 # The index 9.0 should be just visible by a couple of pixels } {9.0} test textDisp-11.16 {TkTextSetYView, only a few lines visible} { .top.t yview 8.0 update .top.t see 5.0 .top.t index @0,0 } {5.0} test textDisp-11.17 {TkTextSetYView, only a few lines visible} { .top.t yview 8.0 update .top.t see 4.0 .top.t index @0,0 # The index 2.0 should be just visible by a couple of pixels } {2.0} test textDisp-11.18 {TkTextSetYView, see in elided lines} { .top.t delete 1.0 end for {set i 1} {$i < 20} {incr i} { .top.t insert end [string repeat "Line $i" 10] .top.t insert end "\n" } .top.t yview 4.0 .top.t tag add hidden 4.10 "4.10 lineend" .top.t tag add hidden 5.15 10.3 .top.t tag configure hidden -elide true update .top.t see "8.0 lineend" # The index "8.0 lineend" is on screen despite elided -> no scroll .top.t index @0,0 } {4.0} test textDisp-11.19 {TkTextSetYView, see in elided lines} { .top.t delete 1.0 end for {set i 1} {$i < 50} {incr i} { .top.t insert end "Line $i\n" } # button just for having a line with a larger height button .top.t.b -text "Test" -bd 2 -highlightthickness 2 .top.t window create 21.0 -window .top.t.b .top.t tag add hidden 15.36 21.0 .top.t tag configure hidden -elide true .top.t configure -height 15 wm geometry .top 300x200+0+0 # Indices 21.0, 17.0 and 15.0 are all on the same display line # therefore index @0,0 shall be the same for all of them .top.t see end update .top.t see 21.0 update set ind1 [.top.t index @0,0] .top.t see end update .top.t see 17.0 update set ind2 [.top.t index @0,0] .top.t see end update .top.t see 15.0 update set ind3 [.top.t index @0,0] list [expr {$ind1 == $ind2}] [expr {$ind1 == $ind3}] } {1 1} test textDisp-11.20 {TkTextSetYView, see in elided lines} { .top.t delete 1.0 end .top.t configure -wrap none for {set i 1} {$i < 5} {incr i} { .top.t insert end [string repeat "Line $i " 50] .top.t insert end "\n" } .top.t delete 3.11 3.14 .top.t tag add hidden 3.0 4.0 # this shall not crash (null chunkPtr in TkTextSeeCmd is tested) .top.t see 3.0 } {} test textDisp-11.21 {TkTextSetYView, window height smaller than the line height} { .top.t delete 1.0 end for {set i 1} {$i <= 10} {incr i} { .top.t insert end "Line $i\n" } set lineheight [font metrics [.top.t cget -font] -linespace] wm geometry .top 200x[expr {$lineheight / 2}] update .top.t see 1.0 .top.t index @0,[expr {$lineheight - 2}] } {1.0} .t configure -wrap word .t delete 50.0 51.0 .t insert 50.0 "This is a long line, one that will wrap around twice.\n" test textDisp-12.1 {MeasureUp} { .t yview 100.0 update .t yview -pickplace 52.0 update .t index @0,0 } {49.0} test textDisp-12.2 {MeasureUp} { .t yview 100.0 update .t yview -pickplace 53.0 update .t index @0,0 } {50.0} test textDisp-12.3 {MeasureUp} { .t yview 100.0 update .t yview -pickplace 50.10 update .t index @0,0 } {45.0} .t configure -wrap none test textDisp-12.4 {MeasureUp} { .t yview 100.0 update .t yview -pickplace 53.0 update .t index @0,0 } {48.0} test textDisp-12.5 {MeasureUp} { .t yview 100.0 update .t yview -pickplace 50.10 update .t index @0,0 } {45.0} .t configure -wrap none .t delete 1.0 end for {set i 1} {$i < 99} {incr i} { .t insert end "Line $i\n" } .t insert end "Line 100" .t insert 30.end { is quite long, so that it flows way off the end of the window and we can use it to test out the horizontal positioning features of the "see" command.} test textDisp-13.1 {TkTextSeeCmd procedure} { list [catch {.t see} msg] $msg } {1 {wrong # args: should be ".t see index"}} test textDisp-13.2 {TkTextSeeCmd procedure} { list [catch {.t see a b} msg] $msg } {1 {wrong # args: should be ".t see index"}} test textDisp-13.3 {TkTextSeeCmd procedure} { list [catch {.t see badIndex} msg] $msg } {1 {bad text index "badIndex"}} test textDisp-13.4 {TkTextSeeCmd procedure} { .t xview moveto 0 .t yview moveto 0 update .t see 4.2 .t index @0,0 } {1.0} test textDisp-13.5 {TkTextSeeCmd procedure} { .t configure -wrap char .t xview moveto 0 .t yview moveto 0 update .t see 12.1 .t index @0,0 } {3.0} test textDisp-13.6 {TkTextSeeCmd procedure} { .t configure -wrap char .t xview moveto 0 .t yview moveto 0 update .t see 30.50 set x [.t index @0,0] .t configure -wrap none set x } {27.0} test textDisp-13.7 {TkTextSeeCmd procedure} {textfonts} { .t xview moveto 0 .t yview moveto 0 .t tag add sel 30.20 .t tag add sel 30.40 update .t see 30.50 .t yview 25.0 .t see 30.50 set x [list [.t bbox 30.50]] .t see 30.39 lappend x [.t bbox 30.39] .t see 30.38 lappend x [.t bbox 30.38] .t see 30.20 lappend x [.t bbox 30.20] } [list [list 73 [expr {5*$fixedDiff + 68}] 7 $fixedHeight] [list 3 [expr {5*$fixedDiff + 68}] 7 $fixedHeight] [list 3 [expr {5*$fixedDiff + 68}] 7 $fixedHeight] [list 73 [expr {5*$fixedDiff + 68}] 7 $fixedHeight]] test textDisp-13.8 {TkTextSeeCmd procedure} {textfonts} { .t xview moveto 0 .t yview moveto 0 .t tag add sel 30.20 .t tag add sel 30.50 update .t see 30.50 set x [list [.t bbox 30.50]] .t see 30.60 lappend x [.t bbox 30.60] .t see 30.65 lappend x [.t bbox 30.65] .t see 30.90 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 .t xview moveto 0 .t yview moveto 0 .t tag add sel 30.20 .t tag add sel 30.50 update .t see 30.50 set x [list [.t bbox 30.50]] .t see 30.60 lappend x [.t bbox 30.60] .t see 30.65 lappend x [.t bbox 30.65] .t see 30.90 lappend x [.t bbox 30.90] } [list [list 74 [expr {9*$fixedDiff/2 + 66}] 7 $fixedHeight] [list 138 [expr {9*$fixedDiff/2 + 66}] 7 $fixedHeight] [list 138 [expr {9*$fixedDiff/2 + 66}] 7 $fixedHeight] [list 74 [expr {9*$fixedDiff/2 + 66}] 7 $fixedHeight]] test textDisp-13.10 {TkTextSeeCmd procedure} {} { # SF Bug 641778 set w .tsee destroy $w text $w -font {Helvetica 8 normal} -bd 16 $w insert end Hello $w see end set res [$w bbox end] destroy $w set res } {} test textDisp-13.11 {TkTextSeeCmd procedure} {} { # insertion of a character at end of a line containing multi-byte # characters and calling see at the line end shall actually show # this character toplevel .top2 pack [text .top2.t2 -wrap none] for {set i 1} {$i < 5} {incr i} { .top2.t2 insert end [string repeat "Line $i: éèàçù" 5]\n } wm geometry .top2 300x200+0+0 update .top2.t2 see "1.0 lineend" update set ref [.top2.t2 index @0,0] .top2.t2 insert "1.0 lineend" ç .top2.t2 see "1.0 lineend" update set new [.top2.t2 index @0,0] set res [.top2.t2 compare $ref == $new] destroy .top2 set res } {0} wm geom . {} .t configure -wrap none test textDisp-14.1 {TkTextXviewCmd procedure} { .t delete 1.0 end update .t insert end xxxxxxxxx\n .t insert end "xxxxx xxxxxxxxxxx xxxx xxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxx\n" .t insert end "xxxx xxxxxxxxx xxxxxxxxxxxxx" .t xview moveto .5 .t xview } [list 0.5 [expr {6./7.}]] .t configure -wrap char test textDisp-14.2 {TkTextXviewCmd procedure} { .t delete 1.0 end update .t insert end xxxxxxxxx\n .t insert end "xxxxx\n" .t insert end "xxxx" .t xview } {0.0 1.0} .t configure -wrap none test textDisp-14.3 {TkTextXviewCmd procedure} { .t delete 1.0 end update .t insert end xxxxxxxxx\n .t insert end "xxxxx\n" .t insert end "xxxx" .t xview } {0.0 1.0} test textDisp-14.4 {TkTextXviewCmd procedure} { list [catch {.t xview moveto} msg] $msg } {1 {wrong # args: should be ".t xview moveto fraction"}} test textDisp-14.5 {TkTextXviewCmd procedure} { list [catch {.t xview moveto a b} msg] $msg } {1 {wrong # args: should be ".t xview moveto fraction"}} test textDisp-14.6 {TkTextXviewCmd procedure} { list [catch {.t xview moveto a} msg] $msg } {1 {expected floating-point number but got "a"}} test textDisp-14.7 {TkTextXviewCmd procedure} { .t delete 1.0 end .t insert end xxxxxxxxx\n .t insert end "xxxxx xxxxxxxxxxx xxxx xxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxx\n" .t insert end "xxxx xxxxxxxxx xxxxxxxxxxxxx" .t xview moveto .3 .t xview } [list [expr {118.0/392}] [expr {258.0/392}]] test textDisp-14.8 {TkTextXviewCmd procedure} { .t delete 1.0 end .t insert end xxxxxxxxx\n .t insert end "xxxxx xxxxxxxxxxx xxxx xxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxx\n" .t insert end "xxxx xxxxxxxxx xxxxxxxxxxxxx" .t xview moveto -.4 .t xview } [list 0.0 [expr {5.0/14}]] test textDisp-14.9 {TkTextXviewCmd procedure} { .t delete 1.0 end .t insert end xxxxxxxxx\n .t insert end "xxxxx xxxxxxxxxxx xxxx xxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxx\n" .t insert end "xxxx xxxxxxxxx xxxxxxxxxxxxx" .t xview m 1.4 .t xview } [list [expr {9.0/14}] 1.0] test textDisp-14.10 {TkTextXviewCmd procedure} { list [catch {.t xview scroll a} msg] $msg } {1 {wrong # args: should be ".t xview scroll number units|pages|pixels"}} test textDisp-14.11 {TkTextXviewCmd procedure} { list [catch {.t xview scroll a b c} msg] $msg } {1 {wrong # args: should be ".t xview scroll number units|pages|pixels"}} test textDisp-14.12 {TkTextXviewCmd procedure} { list [catch {.t xview scroll gorp units} msg] $msg } {1 {expected integer but got "gorp"}} test textDisp-14.13 {TkTextXviewCmd procedure} { .t delete 1.0 end .t insert end xxxxxxxxx\n .t insert end "a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 c0 c1 c2 c3 c4 c5 c6 c7 c8 c9 c0 c1 c2 c3 c4 c5 c6 c7 c8 c9\n" .t insert end "xxxx xxxxxxxxx xxxxxxxxxxxxx" .t xview moveto 0 .t xview scroll 2 pa set x [.t index @0,22] .t xview scroll -1 pa lappend x [.t index @0,22] .t xview scroll -2 pages lappend x [.t index @0,22] } {2.36 2.18 2.0} test textDisp-14.14 {TkTextXviewCmd procedure} { .t delete 1.0 end .t insert end xxxxxxxxx\n .t insert end "a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 c0 c1 c2 c3 c4 c5 c6 c7 c8 c9 c0 c1 c2 c3 c4 c5 c6 c7 c8 c9\n" .t insert end "xxxx xxxxxxxxx xxxxxxxxxxxxx" .t xview moveto 0 .t xview scroll 21 u set x [.t index @0,22] .t xview scroll -1 u lappend x [.t index @0,22] .t xview scroll 100 units lappend x [.t index @0,22] .t xview scroll -15 units lappend x [.t index @0,22] } {2.21 2.20 2.99 2.84} test textDisp-14.15 {TkTextXviewCmd procedure} { list [catch {.t xview scroll 14 globs} msg] $msg } {1 {bad argument "globs": must be units, pages, or pixels}} test textDisp-14.16 {TkTextXviewCmd procedure} { list [catch {.t xview flounder} msg] $msg } {1 {bad option "flounder": must be moveto or scroll}} .t configure -wrap char .t delete 1.0 end for {set i 1} {$i < 99} {incr i} { .t insert end "Line $i\n" } .t insert end "Line 100" .t delete 50.0 51.0 .t insert 50.0 "This is a long line, one that will wrap around twice.\n" test textDisp-15.1 {ScrollByLines procedure, scrolling backwards} { .t yview 45.0 update .t yview scroll -3 units .t index @0,0 } {42.0} test textDisp-15.2 {ScrollByLines procedure, scrolling backwards} { .t yview 51.0 update .t yview scroll -2 units .t index @0,0 } {50.20} test textDisp-15.3 {ScrollByLines procedure, scrolling backwards} { .t yview 51.0 update .t yview scroll -4 units .t index @0,0 } {49.0} test textDisp-15.4 {ScrollByLines procedure, scrolling backwards} { .t yview 50.20 update .t yview scroll -2 units .t index @0,0 } {49.0} test textDisp-15.5 {ScrollByLines procedure, scrolling backwards} { .t yview 50.40 update .t yview scroll -2 units .t index @0,0 } {50.0} test textDisp-15.6 {ScrollByLines procedure, scrolling backwards} { .t yview 3.2 update .t yview scroll -5 units .t index @0,0 } {1.0} test textDisp-15.7 {ScrollByLines procedure, scrolling forwards} { .t yview 48.0 update .t yview scroll 4 units .t index @0,0 } {50.40} test textDisp-15.8 {Scrolling near end of window} { set textheight 12 set textwidth 30 toplevel .tf frame .tf.f -relief sunken -borderwidth 2 pack .tf.f -padx 10 -pady 10 text .tf.f.t -font {Courier 9} -height $textheight \ -width $textwidth -yscrollcommand ".tf.f.sb set" scrollbar .tf.f.sb -command ".tf.f.t yview" pack .tf.f.t -side left -expand 1 -fill both pack .tf.f.sb -side right -fill y .tf.f.t tag configure Header -font {Helvetica 14 bold italic} \ -wrap word -spacing1 12 -spacing3 4 .tf.f.t insert end "Foo" Header for {set i 1} {$i < $textheight} {incr i} { .tf.f.t insert end "\nLine $i" } update ; after 1000 ; update # Should scroll and should not crash! .tf.f.t yview scroll 1 unit # Check that it has scrolled set res [.tf.f.t index @0,[expr [winfo height .tf.f.t] - 15]] destroy .tf set res } {12.0} .t configure -wrap char .t delete 1.0 end .t insert insert "Line 1" for {set i 2} {$i <= 200} {incr i} { .t insert end "\nLine $i" } .t tag add big 100.0 105.0 .t insert 151.end { has a lot of extra text, so that it wraps around on the screen several times over.} .t insert 153.end { also has enoug extra text to wrap.} update ; .t count -update -ypixels 1.0 end test textDisp-16.1 {TkTextYviewCmd procedure} { .t yview 21.0 set x [.t yview] .t yview 1.0 list [expr {int([lindex $x 0]*100)}] [expr {int ([lindex $x 1] * 100)}] } {9 14} test textDisp-16.2 {TkTextYviewCmd procedure} { list [catch {.t yview 2 3} msg] $msg } {1 {bad option "2": must be moveto or scroll}} test textDisp-16.3 {TkTextYviewCmd procedure} { list [catch {.t yview -pickplace} msg] $msg } {1 {wrong # args: should be ".t yview -pickplace lineNum|index"}} test textDisp-16.4 {TkTextYviewCmd procedure} { list [catch {.t yview -pickplace 2 3} msg] $msg } {1 {wrong # args: should be ".t yview -pickplace lineNum|index"}} test textDisp-16.5 {TkTextYviewCmd procedure} { list [catch {.t yview -bogus 2} msg] $msg } {1 {bad option "-bogus": must be moveto or scroll}} test textDisp-16.6 {TkTextYviewCmd procedure, integer position} { .t yview 100.0 update .t yview 98 .t index @0,0 } {99.0} test textDisp-16.7 {TkTextYviewCmd procedure} { .t yview 2.0 .t yv -pickplace 13.0 .t index @0,0 } {4.0} test textDisp-16.8 {TkTextYviewCmd procedure} { list [catch {.t yview bad_mark_name} msg] $msg } {1 {bad text index "bad_mark_name"}} test textDisp-16.9 {TkTextYviewCmd procedure, "moveto" option} { list [catch {.t yview moveto a b} msg] $msg } {1 {wrong # args: should be ".t yview moveto fraction"}} test textDisp-16.10 {TkTextYviewCmd procedure, "moveto" option} { list [catch {.t yview moveto gorp} msg] $msg } {1 {expected floating-point number but got "gorp"}} test textDisp-16.11 {TkTextYviewCmd procedure, "moveto" option} { .t yview moveto 0.5 .t index @0,0 } {103.0} test textDisp-16.12 {TkTextYviewCmd procedure, "moveto" option} { .t yview moveto -1 .t index @0,0 } {1.0} test textDisp-16.13 {TkTextYviewCmd procedure, "moveto" option} { .t yview moveto 1.1 .t index @0,0 } {191.0} test textDisp-16.14 {TkTextYviewCmd procedure, "moveto" option} { .t yview moveto .75 .t index @0,0 } {151.60} test textDisp-16.15 {TkTextYviewCmd procedure, "moveto" option} { .t yview moveto .752 .t index @0,0 } {151.60} test textDisp-16.16 {TkTextYviewCmd procedure, "moveto" option} {textfonts} { set count [expr {5 * $bigHeight + 150 * $fixedHeight}] set extra [expr {0.04 * double($fixedDiff * 150) / double($count)}] .t yview moveto [expr {.753 - $extra}] .t index @0,0 } {151.60} test textDisp-16.17 {TkTextYviewCmd procedure, "moveto" option} { .t yview moveto .755 .t index @0,0 } {151.80} test textDisp-16.18 {TkTextYviewCmd procedure, "moveto" roundoff} {textfonts} { catch {destroy .top1} toplevel .top1 wm geometry .top1 +0+0 text .top1.t -height 3 -width 4 -wrap none -setgrid 1 -padx 6 \ -spacing3 6 pack .top1.t update .top1.t insert end "1\n2\n3\n4\n5\n6" .top1.t yview moveto 0.3333 set result [.top1.t yview] destroy .top1 set result } [list [expr {1.0/3}] [expr {5.0/6}]] test textDisp-16.19 {TkTextYviewCmd procedure, "scroll" option} { list [catch {.t yview scroll a} msg] $msg } {1 {wrong # args: should be ".t yview scroll number units|pages|pixels"}} test textDisp-16.20 {TkTextYviewCmd procedure, "scroll" option} { list [catch {.t yview scroll a b c} msg] $msg } {1 {wrong # args: should be ".t yview scroll number units|pages|pixels"}} test textDisp-16.21 {TkTextYviewCmd procedure, "scroll" option} { list [catch {.t yview scroll badInt bogus} msg] $msg } {1 {bad argument "bogus": must be units, pages, or pixels}} test textDisp-16.21.2 {TkTextYviewCmd procedure, "scroll" option} { list [catch {.t yview scroll badInt units} msg] $msg } {1 {expected integer but got "badInt"}} test textDisp-16.22 {TkTextYviewCmd procedure, "scroll" option, back pages} { .t yview 50.0 update .t yview scroll -1 pages .t index @0,0 } {42.0} test textDisp-16.22.1 {TkTextYviewCmd procedure, "scroll" option, back pages} { list [catch {.t yview scroll -3 p} res] $res } {1 {ambiguous argument "p": must be units, pages, or pixels}} test textDisp-16.23 {TkTextYviewCmd procedure, "scroll" option, back pages} { .t yview 50.0 update .t yview scroll -3 pa .t index @0,0 } {26.0} test textDisp-16.24 {TkTextYviewCmd procedure, "scroll" option, back pages} { .t yview 5.0 update .t yview scroll -3 pa .t index @0,0 } {1.0} test textDisp-16.25 {TkTextYviewCmd procedure, "scroll" option, back pages} { .t configure -height 1 update .t yview 50.0 update .t yview scroll -1 pages set x [.t index @0,0] .t configure -height 10 update set x } {49.0} test textDisp-16.26 {TkTextYviewCmd procedure, "scroll" option, forward pages} { .t yview 50.0 update .t yview scroll 1 pages .t index @0,0 } {58.0} test textDisp-16.27 {TkTextYviewCmd procedure, "scroll" option, forward pages} { .t yview 50.0 update .t yview scroll 2 pages .t index @0,0 } {66.0} test textDisp-16.28 {TkTextYviewCmd procedure, "scroll" option, forward pages} {textfonts} { .t yview 98.0 update .t yview scroll 1 page set res [expr int([.t index @0,0])] if {$fixedDiff > 1} { incr res -1 } set res } {102} test textDisp-16.29 {TkTextYviewCmd procedure, "scroll" option, forward pages} { .t configure -height 1 update .t yview 50.0 update .t yview scroll 1 pages set x [.t index @0,0] .t configure -height 10 update set x } {51.0} test textDisp-16.30 {TkTextYviewCmd procedure, "scroll units" option} { .t yview 45.0 update .t yview scroll -3 units .t index @0,0 } {42.0} test textDisp-16.31 {TkTextYviewCmd procedure, "scroll units" option} { .t yview 149.0 update .t yview scroll 4 units .t index @0,0 } {151.40} test textDisp-16.32 {TkTextYviewCmd procedure} { list [catch {.t yview scroll 12 bogoids} msg] $msg } {1 {bad argument "bogoids": must be units, pages, or pixels}} test textDisp-16.33 {TkTextYviewCmd procedure} { list [catch {.t yview bad_arg 1 2} msg] $msg } {1 {bad option "bad_arg": must be moveto or scroll}} test textDisp-16.34 {TkTextYviewCmd procedure} { set res {} .t yview 1.0 lappend res [format %.12g [expr {[lindex [.t yview] 0] * [.t count -ypixels 1.0 end]}]] .t yview scroll 1 pixels lappend res [format %.12g [expr {[lindex [.t yview] 0] * [.t count -ypixels 1.0 end]}]] .t yview scroll 1 pixels lappend res [format %.12g [expr {[lindex [.t yview] 0] * [.t count -ypixels 1.0 end]}]] .t yview scroll 1 pixels lappend res [format %.12g [expr {[lindex [.t yview] 0] * [.t count -ypixels 1.0 end]}]] .t yview scroll 1 pixels lappend res [format %.12g [expr {[lindex [.t yview] 0] * [.t count -ypixels 1.0 end]}]] .t yview scroll 1 pixels lappend res [format %.12g [expr {[lindex [.t yview] 0] * [.t count -ypixels 1.0 end]}]] } {0 1 2 3 4 5} test textDisp-16.35 {TkTextYviewCmd procedure} { set res {} .t yview 1.0 lappend res [expr {round([lindex [.t yview] 0] * [.t count -ypixels 1.0 end])}] .t yview scroll 13 pixels lappend res [expr {round([lindex [.t yview] 0] * [.t count -ypixels 1.0 end])}] .t yview scroll -4 pixels lappend res [expr {round([lindex [.t yview] 0] * [.t count -ypixels 1.0 end])}] .t yview scroll -9 pixels lappend res [expr {round([lindex [.t yview] 0] * [.t count -ypixels 1.0 end])}] } {0 13 9 0} test textDisp-16.36 {TkTextYviewCmd procedure} { set res {} .t yview 1.0 .t yview scroll 5 pixels .t yview scroll -1 pages lappend res [expr {[lindex [.t yview] 0] * [.t count -ypixels 1.0 end]}] .t yview scroll 5 pixels .t yview scroll -1 units lappend res [expr {[lindex [.t yview] 0] * [.t count -ypixels 1.0 end]}] } {0.0 0.0} test textDisp-16.37 {TkTextYviewCmd procedure} { list [catch {.t yview scroll 1.3 pixels} msg] $msg } {0 {}} test textDisp-16.38 {TkTextYviewCmd procedure} { list [catch {.t yview scroll 1.3blah pixels} msg] $msg } {1 {bad screen distance "1.3blah"}} test textDisp-16.39 {TkTextYviewCmd procedure} { list [catch {.t yview scroll 1.3i pixels} msg] $msg } {0 {}} test textDisp-16.40 {text count -xpixels} { set res {} lappend res [.t count -xpixels 1.0 1.5] \ [.t count -xpixels 1.5 1.0] \ [.t count -xpixels 1.0 13.0] \ [.t count -xpixels 1.0 "1.0 displaylineend"] \ [.t count -xpixels 1.0 "1.0 lineend"] \ [.t count -xpixels 1.0 "1.0 displaylineend"] \ [.t count -xpixels 1.0 end] } {35 -35 0 42 42 42 0} test textDisp-16.41 {text count -xpixels with indices in elided lines} { set res {} .t delete 1.0 end for {set i 1} {$i < 40} {incr i} { .t insert end [string repeat "Line $i" 20] .t insert end "\n" } .t configure -wrap none .t tag add hidden 5.15 20.15 .t tag configure hidden -elide true lappend res [.t count -xpixels 5.15 6.0] \ [.t count -xpixels 5.15 6.1] \ [.t count -xpixels 6.0 6.1] \ [.t count -xpixels 6.1 6.2] \ [.t count -xpixels 6.1 6.0] \ [.t count -xpixels 6.0 7.0] \ [.t count -xpixels 6.1 7.1] \ [.t count -xpixels 15.0 20.15] \ [.t count -xpixels 20.15 20.16] \ [.t count -xpixels 20.16 20.15] .t tag remove hidden 20.0 20.15 lappend res [expr {[.t count -xpixels 5.0 20.0] != 0}] } [list 0 0 0 0 0 0 0 0 $fixedWidth -$fixedWidth 1] test textDisp-16.42 {TkTextYviewCmd procedure with indices in elided lines} { .t configure -wrap none .t delete 1.0 end for {set i 1} {$i < 100} {incr i} { .t insert end [string repeat "Line $i" 20] .t insert end "\n" } .t tag add hidden 5.15 20.15 .t tag configure hidden -elide true .t yview 35.0 .t yview scroll [expr {- 15 * $fixedHeight}] pixels update .t index @0,0 } {5.0} test textDisp-16.43 {TkTextYviewCmd procedure with indices in elided lines} { .t configure -wrap none .t delete 1.0 end for {set i 1} {$i < 100} {incr i} { .t insert end [string repeat "Line $i" 20] .t insert end "\n" } .t tag add hidden 5.15 20.15 .t tag configure hidden -elide true .t yview 35.0 .t yview scroll -15 units update .t index @0,0 } {5.0} test textDisp-16.44 {TkTextYviewCmd procedure, scroll down, with elided lines} { .t configure -wrap none .t delete 1.0 end foreach x [list 0 1 2 3 4 5 6 7 8 9 0] { .t insert end "$x aaa1\n$x bbb2\n$x ccc3\n$x ddd4\n$x eee5\n$x fff6" .t insert end "$x 1111\n$x 2222\n$x 3333\n$x 4444\n$x 5555\n$x 6666" hidden } .t tag configure hidden -elide true ; # 5 hidden lines update .t see [expr {5 + [winfo height .t] / $fixedHeight} + 1].0 update .t index @0,0 } {2.0} .t delete 1.0 end foreach i {a b c d e f g h i j k l m n o p q r s t u v w x y z} { .t insert end "\nLine $i 11111 $i 22222 $i 33333 $i 44444 $i 55555" .t insert end " $i 66666 $i 77777 $i 88888 $i" } .t configure -wrap none test textDisp-17.1 {TkTextScanCmd procedure} { list [catch {.t scan a b} msg] $msg } {1 {wrong # args: should be ".t scan mark x y" or ".t scan dragto x y ?gain?"}} test textDisp-17.2 {TkTextScanCmd procedure} { list [catch {.t scan a b c d} msg] $msg } {1 {expected integer but got "b"}} test textDisp-17.3 {TkTextScanCmd procedure} { list [catch {.t scan stupid b 20} msg] $msg } {1 {expected integer but got "b"}} test textDisp-17.4 {TkTextScanCmd procedure} { list [catch {.t scan stupid -2 bogus} msg] $msg } {1 {expected integer but got "bogus"}} test textDisp-17.5 {TkTextScanCmd procedure} { list [catch {.t scan stupid 123 456} msg] $msg } {1 {bad scan option "stupid": must be mark or dragto}} test textDisp-17.6 {TkTextScanCmd procedure} {textfonts} { .t yview 1.0 .t xview moveto 0 .t scan mark 40 60 .t scan dragto 35 55 .t index @0,0 } {4.7} test textDisp-17.7 {TkTextScanCmd procedure} {textfonts} { .t yview 10.0 .t xview moveto 0 .t xview scroll 20 units .t scan mark -10 60 .t scan dragto -5 65 .t index @0,0 set x [.t index @0,0] .t scan dragto 0 [expr {70 + $fixedDiff}] list $x [.t index @0,0] } {6.12 2.5} test textDisp-17.8 {TkTextScanCmd procedure} {textfonts} { .t yview 1.0 .t xview moveto 0 .t scan mark 0 60 .t scan dragto 30 100 .t scan dragto 25 95 .t index @0,0 } {4.7} test textDisp-17.9 {TkTextScanCmd procedure} {textfonts} { .t yview end .t xview moveto 0 .t xview scroll 100 units .t scan mark 90 60 .t scan dragto 10 0 .t scan dragto 14 5 .t index @0,0 } {18.44} .t configure -wrap word test textDisp-17.10 {TkTextScanCmd procedure, word wrapping} {textfonts} { .t yview 10.0 .t scan mark -10 60 .t scan dragto -5 65 set x [.t index @0,0] .t scan dragto 0 [expr {70 + $fixedDiff}] list $x [.t index @0,0] } {9.15 8.31} .t configure -xscrollcommand scroll -yscrollcommand {} test textDisp-18.1 {GetXView procedure} { .t configure -wrap none .t delete 1.0 end .t insert end xxxxxxxxx\n .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxx update set scrollInfo } [list 0.0 [expr {4.0/11}]] test textDisp-18.2 {GetXView procedure} { .t configure -wrap char .t delete 1.0 end .t insert end xxxxxxxxx\n .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxx update set scrollInfo } {0.0 1.0} test textDisp-18.3 {GetXView procedure} { .t configure -wrap none .t delete 1.0 end update set scrollInfo } {0.0 1.0} test textDisp-18.4 {GetXView procedure} { .t configure -wrap none .t delete 1.0 end .t insert end xxxxxxxxx\n .t insert end xxxxxx\n .t insert end xxxxxxxxxxxxxxxxx update set scrollInfo } {0.0 1.0} test textDisp-18.5 {GetXView procedure} { .t configure -wrap none .t delete 1.0 end .t insert end xxxxxxxxx\n .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxx .t xview scroll 31 units update set scrollInfo } [list [expr {31.0/55}] [expr {51.0/55}]] test textDisp-18.6 {GetXView procedure} { .t configure -wrap none .t delete 1.0 end .t insert end xxxxxxxxx\n .t insert end "xxxxx xxxxxxxxxxx xxxx xxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxx\n" .t insert end "xxxx xxxxxxxxx xxxxxxxxxxxxx" .t xview moveto 0 .t xview scroll 31 units update set x {} lappend x $scrollInfo .t configure -wrap char update lappend x $scrollInfo .t configure -wrap word update lappend x $scrollInfo .t configure -wrap none update lappend x $scrollInfo } [list [list [expr {31.0/56}] [expr {51.0/56}]] {0.0 1.0} {0.0 1.0} [list 0.0 [expr {5.0/14}]]] test textDisp-18.7 {GetXView procedure} { .t configure -wrap none .t delete 1.0 end update set scrollInfo unchanged .t insert end xxxxxx\n .t insert end xxx update set scrollInfo } {unchanged} test textDisp-18.8 {GetXView procedure} { proc bgerror msg { global x errorInfo set x [list $msg $errorInfo] } proc bogus args { error "bogus scroll proc" } .t configure -wrap none .t delete 1.0 end .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n update .t delete 1.0 end .t configure -xscrollcommand scrollError update set x } {{scrolling error} {scrolling error while executing "error "scrolling error"" (procedure "scrollError" line 2) invoked from within "scrollError 0.0 1.0" (horizontal scrolling command executed by text)}} catch {rename bgerror {}} catch {rename bogus {}} .t configure -xscrollcommand {} -yscrollcommand scroll .t configure -xscrollcommand {} -yscrollcommand scroll test textDisp-19.1 {GetYView procedure} { .t configure -wrap char .t delete 1.0 end update set scrollInfo } {0.0 1.0} test textDisp-19.2 {GetYView procedure} { .t configure -wrap char .t delete 1.0 end update set scrollInfo "unchanged" .t insert 1.0 "Line1\nLine2" update set scrollInfo } {unchanged} test textDisp-19.3 {GetYView procedure} { .t configure -wrap char .t delete 1.0 end update; after 10 ; update set scrollInfo "unchanged" .t insert 1.0 "Line 1\nLine 2 is so long that it wraps around\nLine 3" update set scrollInfo } {unchanged} test textDisp-19.4 {GetYView procedure} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "Line 1" update set scrollInfo "unchanged" foreach i {2 3 4 5 6 7 8 9 10 11 12 13} { .t insert end "\nLine $i" } update set scrollInfo } [list 0.0 [expr {70.0/91}]] test textDisp-19.5 {GetYView procedure} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "Line 1" foreach i {2 3 4 5 6 7 8 9 10 11 12 13} { .t insert end "\nLine $i" } .t insert 2.end " is really quite long; in fact it's so long that it wraps three times" update ; after 100 set x $scrollInfo } {0.0 0.625} test textDisp-19.6 {GetYView procedure} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "Line 1" foreach i {2 3 4 5 6 7 8 9 10 11 12 13} { .t insert end "\nLine $i" } .t insert 2.end " is really quite long; in fact it's so long that it wraps three times" .t yview 4.0 update set x $scrollInfo } {0.375 1.0} test textDisp-19.7 {GetYView procedure} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "Line 1" foreach i {2 3 4 5 6 7 8 9 10 11 12 13} { .t insert end "\nLine $i" } .t insert 2.end " is really quite long; in fact it's so long that it wraps three times" .t yview 2.26 update; after 1; update set x $scrollInfo } {0.125 0.75} test textDisp-19.8 {GetYView procedure} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "Line 1" foreach i {2 3 4 5 6 7 8 9 10 11 12 13} { .t insert end "\nLine $i" } .t insert 10.end " is really quite long; in fact it's so long that it wraps three times" .t yview 2.0 update .t count -update -ypixels 1.0 end set x $scrollInfo } {0.0625 0.6875} test textDisp-19.9 {GetYView procedure} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "Line 1" foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { .t insert end "\nLine $i" } .t yview 3.0 update set scrollInfo } [list [expr {4.0/30}] 0.8] test textDisp-19.10 {GetYView procedure} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "Line 1" foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { .t insert end "\nLine $i" } .t yview 11.0 update set scrollInfo } [list [expr {1.0/3}] 1.0] test textDisp-19.10.1 {Widget manipulation causes height miscount} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "Line 1" foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { .t insert end "\nLine $i" } .t yview 11.0 update .t configure -wrap word .t delete 1.0 end .t insert 1.0 "Line 1" foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { .t insert end "\nLine $i" } .t insert end "\nThis last line wraps around four " .t insert end "times with a bit left on the last line." .t yview insert update .t count -update -ypixels 1.0 end set scrollInfo } {0.5 1.0} test textDisp-19.11 {GetYView procedure} { .t configure -wrap word .t delete 1.0 end .t insert 1.0 "Line 1" foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { .t insert end "\nLine $i" } .t insert end "\nThis last line wraps around four " .t insert end "times with a bit left on the last line." .t yview insert update .t count -update -ypixels 1.0 end set scrollInfo } {0.5 1.0} test textDisp-19.11.2 {TextWidgetCmd procedure, "count -displaylines"} { .t count -displaylines 1.0 end } {20} test textDisp-19.11.3 {TextWidgetCmd procedure, "count -displaylines"} { .t count -displaylines end 1.0 } {-20} test textDisp-19.11.4 {TextWidgetCmd procedure, "count -displaylines"} { .t count -displaylines 1.1 1.3 } {0} test textDisp-19.11.5 {TextWidgetCmd procedure, "count -displaylines"} { .t count -displaylines 16.0 16.1 } {0} test textDisp-19.11.5.1 {TextWidgetCmd procedure, "count -displaylines"} { .t count -displaylines 16.0 16.5 } {0} test textDisp-19.11.6 {TextWidgetCmd procedure, "count -displaylines"} { .t count -displaylines 16.0 16.20 } {1} test textDisp-19.11.7 {TextWidgetCmd procedure, "count -displaylines"} { .t count -displaylines 16.0 16.40 } {2} test textDisp-19.11.8 {TextWidgetCmd procedure, "count -displaylines"} { .t count -displaylines "16.0 displaylineend +1c" "16.0 lineend" } {3} test textDisp-19.11.9 {TextWidgetCmd procedure, "count -displaylines"} { .t count -displaylines 16.0 "16.0 lineend" } {4} test textDisp-19.11.10 {TextWidgetCmd procedure, "count -displaylines"} { .t count -displaylines 16.0 "16.0 +4displaylines" } {4} test textDisp-19.11.11 {TextWidgetCmd procedure, "count -displaylines"} { .t count -displaylines 16.0 "16.0 +2displaylines" } {2} test textDisp-19.11.12 {TextWidgetCmd procedure, "count -displaylines"} { .t count -displaylines "16.0 +1displayline" "16.0 +2displaylines -1c" } {0} .t tag configure elide -elide 1 test textDisp-19.11.13 {TextWidgetCmd procedure, "count -displaylines"} { .t tag remove elide 1.0 end .t tag add elide "16.0 +1displaylines" "16.0 +1displaylines +6c" .t count -displaylines 16.0 "16.0 +4displaylines" } {4} test textDisp-19.11.14 {TextWidgetCmd procedure, "count -displaylines"} { .t tag remove elide 1.0 end .t tag add elide "16.0 +1displaylines" "16.0 +1displaylines displaylineend" .t count -displaylines 16.0 "16.0 +4displaylines" } {4} test textDisp-19.11.15 {TextWidgetCmd procedure, "count -displaylines"} { .t tag remove elide 1.0 end .t tag add elide "16.0 +1displaylines" "16.0 +2displaylines" .t count -displaylines 16.0 "16.0 +4displaylines -1c" } {3} test textDisp-19.11.15a {TextWidgetCmd procedure, "count -displaylines"} { .t tag remove elide 1.0 end .t tag add elide "16.0 +1displaylines" "16.0 +2displaylines" .t count -displaylines 16.0 "16.0 +4displaylines" } {4} test textDisp-19.11.16 {TextWidgetCmd procedure, "count -displaylines"} { .t tag remove elide 1.0 end .t tag add elide "12.0" "14.0" .t count -displaylines 12.0 16.0 } {2} test textDisp-19.11.17 {TextWidgetCmd procedure, "index +displaylines"} { .t tag remove elide 1.0 end .t tag add elide "12.0" "14.0" list [.t index "11.5 +2d lines"] \ [.t index "12.0 +2d lines"] [.t index "11.0 +2d lines"] \ [.t index "13.0 +2d lines"] [.t index "13.1 +3d lines"] \ [.t index "13.0 +4d lines"] } {15.5 16.0 15.0 16.0 16.15 16.33} test textDisp-19.11.18 {TextWidgetCmd procedure, "index +displaylines"} { .t tag remove elide 1.0 end .t tag add elide "12.0" "14.0" list [.t index "15.5 -2d lines"] \ [.t index "16.0 -2d lines"] [.t index "15.0 -2d lines"] \ [.t index "16.0 -3d lines"] [.t index "16.17 -4d lines"] \ [.t index "16.36 -5d lines"] } {11.5 14.0 11.0 11.0 11.2 11.3} test textDisp-19.11.19 {TextWidgetCmd procedure, "count -displaylines"} { .t tag remove elide 1.0 end .t tag add elide "12.0" "16.0 +1displaylines" .t count -displaylines 12.0 17.0 } {4} test textDisp-19.11.20 {TextWidgetCmd procedure, "index +displaylines"} { .t tag remove elide 1.0 end .t tag add elide "12.0" "16.0 +1displaylines" list [.t index "11.5 +2d lines"] \ [.t index "12.0 +2d lines"] [.t index "11.0 +2d lines"] \ [.t index "13.0 +2d lines"] [.t index "13.0 +3d lines"] \ [.t index "13.0 +4d lines"] } {16.38 16.50 16.33 16.50 16.67 17.0} test textDisp-19.11.21 {TextWidgetCmd procedure, "index +displaylines"} { .t tag remove elide 1.0 end .t tag add elide "12.0" "16.0 +1displaylines" list [.t index "16.38 -2d lines"] \ [.t index "16.50 -3d lines"] [.t index "16.33 -2d lines"] \ [.t index "16.53 -4d lines"] [.t index "16.69 -4d lines"] \ [.t index "17.1 -5d lines"] } {11.5 11.0 11.0 10.3 11.2 11.0} test textDisp-19.11.22 {TextWidgetCmd procedure, "index +displaylines"} { .t tag remove elide 1.0 end list [.t index "end +5d lines"] \ [.t index "end -3d lines"] [.t index "1.0 -2d lines"] \ [.t index "1.0 +4d lines"] [.t index "1.0 +50d lines"] \ [.t index "end -50d lines"] } {17.0 16.33 1.0 5.0 17.0 1.0} test textDisp-19.11.23 {TextWidgetCmd procedure, "index +displaylines"} { .t tag remove elide 1.0 end .t tag add elide "12.3" "16.0 +1displaylines" list [.t index "11.5 +1d lines"] [.t index "11.5 +2d lines"] \ [.t index "12.0 +1d lines"] \ [.t index "12.0 +2d lines"] [.t index "11.0 +2d lines"] \ [.t index "13.0 +2d lines"] [.t index "13.0 +3d lines"] \ [.t index "13.0 +4d lines"] } {16.17 16.33 16.28 16.46 16.28 16.49 16.65 16.72} .t tag remove elide 1.0 end test textDisp-19.11.24 {TextWidgetCmd procedure, "index +/-displaylines"} { list [.t index "11.5 + -1 display lines"] \ [.t index "11.5 + +1 disp lines"] \ [.t index "11.5 - -1 disp lines"] \ [.t index "11.5 - +1 disp lines"] \ [.t index "11.5 -1 disp lines"] \ [.t index "11.5 +1 disp lines"] \ [.t index "11.5 +0 disp lines"] } {10.5 12.5 12.5 10.5 10.5 12.5 11.5} .t tag remove elide 1.0 end test textDisp-19.12 {GetYView procedure, partially visible last line} { catch {destroy .top} toplevel .top wm geometry .top +0+0 text .top.t -width 40 -height 5 -font $fixedFont pack .top.t -expand yes -fill both .top.t insert end "Line 1\nLine 2\nLine 3\nLine 4\nLine 5" # 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] update .top.t yview } [list 0.0 [expr {(5.0 * $fixedHeight - 3.0)/ (5.0 * $fixedHeight)}]] test textDisp-19.13 {GetYView procedure, partially visible last line} {textfonts} { catch {destroy .top} toplevel .top wm geometry .top +0+0 text .top.t -width 40 -height 5 -font $fixedFont pack .top.t -expand yes -fill both .top.t insert end "Line 1\nLine 2\nLine 3\nLine 4 has enough text to wrap around at least once" # 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] update .top.t yview } [list 0.0 [expr {(5.0 * $fixedHeight - 3.0)/ (5.0 * $fixedHeight)}]] catch {destroy .top} test textDisp-19.14 {GetYView procedure} { .t configure -wrap word .t delete 1.0 end .t insert 1.0 "Line 1" foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { .t insert end "\nLine $i" } .t insert end "\nThis last line wraps around four " .t insert end "times with a bit left on the last line." # Need to update so everything is calculated. update ; .t count -update -ypixels 1.0 end update ; after 10 ; update set scrollInfo "unchanged" .t mark set insert 3.0 .t tag configure x -background red .t tag add x 1.0 5.0 update .t tag delete x set scrollInfo } {unchanged} test textDisp-19.15 {GetYView procedure} { .t configure -wrap word .t delete 1.0 end .t insert 1.0 "Line 1" foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { .t insert end "\nLine $i" } .t insert end "\nThis last line wraps around four " .t insert end "times with a bit left on the last line." update .t configure -yscrollcommand scrollError proc bgerror args { global x errorInfo errorCode set x [list $args $errorInfo $errorCode] } .t delete 1.0 end update rename bgerror {} .t configure -yscrollcommand scroll set x } {{{scrolling error}} {scrolling error while executing "error "scrolling error"" (procedure "scrollError" line 2) invoked from within "scrollError 0.0 1.0" (vertical scrolling command executed by text)} NONE} test textDisp-19.16 {count -ypixels} { .t configure -wrap word .t delete 1.0 end .t insert 1.0 "Line 1" foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} { .t insert end "\nLine $i" } .t insert end "\nThis last line wraps around four " .t insert end "times with a bit left on the last line." # Need to update so everything is calculated. update ; .t count -update -ypixels 1.0 end ; update set res {} lappend res \ [.t count -ypixels 1.0 end] \ [.t count -update -ypixels 1.0 end] \ [.t count -ypixels 15.0 16.0] \ [.t count -ypixels 15.0 "16.0 displaylineend +1c"] \ [.t count -ypixels 16.0 "16.0 displaylineend +1c"] \ [.t count -ypixels "16.0 +1 displaylines" "16.0 +4 displaylines +3c"] } [list [expr {260 + 20 * $fixedDiff}] [expr {260 + 20 * $fixedDiff}] $fixedHeight [expr {2*$fixedHeight}] $fixedHeight [expr {3*$fixedHeight}]] test textDisp-19.17 {count -ypixels with indices in elided lines} { .t configure -wrap none .t delete 1.0 end for {set i 1} {$i < 100} {incr i} { .t insert end [string repeat "Line $i" 20] .t insert end "\n" } .t tag add hidden 5.15 20.15 .t tag configure hidden -elide true set res {} update lappend res \ [.t count -ypixels 1.0 6.0] \ [.t count -ypixels 2.0 7.5] \ [.t count -ypixels 5.0 8.5] \ [.t count -ypixels 6.1 6.2] \ [.t count -ypixels 6.1 18.8] \ [.t count -ypixels 18.0 20.50] \ [.t count -ypixels 5.2 20.60] \ [.t count -ypixels 20.60 20.70] \ [.t count -ypixels 5.0 25.0] \ [.t count -ypixels 25.0 5.0] \ [.t count -ypixels 25.4 27.50] \ [.t count -ypixels 35.0 38.0] .t yview 35.0 lappend res [.t count -ypixels 5.0 25.0] } [list [expr {4 * $fixedHeight}] [expr {3 * $fixedHeight}] 0 0 0 0 0 0 [expr {5 * $fixedHeight}] [expr {- 5 * $fixedHeight}] [expr {2 * $fixedHeight}] [expr {3 * $fixedHeight}] [expr {5 * $fixedHeight}]] test textDisp-19.18 {count -ypixels with indices in elided lines} { .t configure -wrap none .t delete 1.0 end for {set i 1} {$i < 100} {incr i} { .t insert end [string repeat "Line $i" 20] .t insert end "\n" } .t tag add hidden 5.15 20.15 .t tag configure hidden -elide true .t yview 35.0 set res {} update lappend res [.t count -ypixels 5.0 25.0] .t yview scroll [expr {- 15 * $fixedHeight}] pixels update lappend res [.t count -ypixels 5.0 25.0] } [list [expr {5 * $fixedHeight}] [expr {5 * $fixedHeight}]] test textDisp-19.19 {count -ypixels with indices in elided lines} { .t configure -wrap char .t delete 1.0 end for {set i 1} {$i < 25} {incr i} { .t insert end [string repeat "Line $i -" 6] .t insert end "\n" } .t tag add hidden 5.27 11.0 .t tag configure hidden -elide true .t yview 5.0 update set res [list [.t count -ypixels 5.0 11.0] [.t count -ypixels 5.0 11.20]] } [list [expr {1 * $fixedHeight}] [expr {2 * $fixedHeight}]] .t delete 1.0 end .t insert end "Line 1" for {set i 2} {$i <= 200} {incr i} { .t insert end "\nLine $i" } .t configure -wrap word .t delete 50.0 51.0 .t insert 50.0 "This is a long line, one that will wrap around twice.\n" test textDisp-20.1 {FindDLine} {textfonts} { .t yview 48.0 list [.t dlineinfo 46.0] [.t dlineinfo 47.0] [.t dlineinfo 49.0] \ [.t dlineinfo 58.0] } [list {} {} [list 3 [expr {$fixedDiff + 16}] 49 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] {}] test textDisp-20.2 {FindDLine} {textfonts} { .t yview 100.0 .t yview -pickplace 53.0 list [.t dlineinfo 50.0] [.t dlineinfo 50.14] [.t dlineinfo 50.15] } [list [list 3 [expr {-1 - $fixedDiff/2}] 105 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 3 [expr {-1 - $fixedDiff/2}] 105 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 3 [expr {12 + $fixedDiff/2}] 140 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]]] test textDisp-20.3 {FindDLine} {textfonts} { .t yview 100.0 .t yview 49.0 list [.t dlineinfo 50.0] [.t dlineinfo 50.20] [.t dlineinfo 57.0] } [list [list 3 [expr {$fixedDiff + 16}] 105 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 3 [expr {2*$fixedDiff + 29}] 140 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] {}] test textDisp-20.4 {FindDLine} {textfonts} { .t yview 100.0 .t yview 42.0 list [.t dlineinfo 50.0] [.t dlineinfo 50.20] [.t dlineinfo 50.40] } [list [list 3 [expr {8*$fixedDiff + 107}] 105 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 3 [expr {9*$fixedDiff + 120}] 140 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] {}] .t config -wrap none test textDisp-20.5 {FindDLine} {textfonts} { .t yview 100.0 .t yview 48.0 list [.t dlineinfo 50.0] [.t dlineinfo 50.20] [.t dlineinfo 50.40] } [list [list 3 [expr {3+2*$fixedHeight}] 371 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 3 [expr {3+2*$fixedHeight}] 371 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 3 [expr {3+2*$fixedHeight}] 371 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]]] .t config -wrap word test textDisp-21.1 {TkTextPixelIndex} {textfonts} { .t yview 48.0 list [.t index @-10,-10] [.t index @6,6] [.t index @22,6] \ [.t index @102,6] [.t index @38,[expr {$fixedHeight * 4 + 3}]] [.t index @44,67] } {48.0 48.0 48.2 48.7 50.40 50.40} .t insert end \n test textDisp-21.2 {TkTextPixelIndex} {textfonts} { .t yview 195.0 list [.t index @11,[expr {$fixedHeight * 5 + 5}]] [.t index @11,[expr {$fixedHeight * 6 + 5}]] [.t index @11,[expr {$fixedHeight * 7 + 5}]] \ [.t index @11,1002] } {197.1 198.1 199.1 201.0} test textDisp-21.3 {TkTextPixelIndex, horizontal scrolling} {textfonts} { .t configure -wrap none .t delete 1.0 end .t insert end "12345\n" .t insert end "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" .t xview scroll 2 units list [.t index @-5,7] [.t index @5,7] [.t index @33,20] } {1.2 1.2 2.6} test textDisp-21.4 {count -displaylines regression} { set message { QOTW: "C/C++, which is used by 16% of users, is the most popular programming language, but Tcl, used by 0%, seems to be the language of choice for the highest scoring users." (new line) Use the Up (cursor) key to scroll up one line at a time. At the second press, the cursor either gets locked or jumps several lines. Connect with Tkcon. The command .u count -displaylines \ 3.10 2.173 should give answer -1; it gives me 5. Using 8.5a4 (ActiveState beta 4) under Linux. No problem with ActiveState beta 3. } toplevel .tt pack [text .tt.u] -side right .tt.u configure -width 30 -height 27 -wrap word -bg #FFFFFF .tt.u insert end $message .tt.u mark set insert 3.10 tkwait visibility .tt.u set res [.tt.u count -displaylines 3.10 2.173] destroy .tt unset message set res } {-1} .t delete 1.0 end .t insert end "Line 1" for {set i 2} {$i <= 200} {incr i} { .t insert end "\nLine $i" } .t configure -wrap word .t delete 50.0 51.0 .t insert 50.0 "This is a long line, one that will wrap around twice.\n" update .t tag add x 50.1 test textDisp-22.1 {TkTextCharBbox} {textfonts} { .t config -wrap word .t yview 48.0 list [.t bbox 47.2] [.t bbox 48.0] [.t bbox 50.5] [.t bbox 50.40] \ [.t bbox 58.0] } [list {} [list 3 3 7 $fixedHeight] [list 38 [expr {3+2*$fixedHeight}] 7 $fixedHeight] [list 38 [expr {3+4*$fixedHeight}] 7 $fixedHeight] {}] test textDisp-22.2 {TkTextCharBbox} {textfonts} { .t config -wrap none .t yview 48.0 list [.t bbox 50.5] [.t bbox 50.40] [.t bbox 57.0] } [list [list 38 [expr {3+2*$fixedHeight}] 7 $fixedHeight] {} [list 3 [expr {3+9*$fixedHeight}] 7 $fixedHeight]] test textDisp-22.3 {TkTextCharBbox, cut-off lines} {textfonts} { .t config -wrap char .t yview 10.0 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] 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 update .t bbox 15.6 } [list 45 [expr {3+5*$fixedHeight}] 7 $fixedHeight] 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] 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]] wm geom . {} update test textDisp-22.7 {TkTextCharBbox, different character sizes} {textfonts} { .t config -wrap char .t yview 10.0 .t tag add big 12.2 12.5 update list [.t bbox 12.1] [.t bbox 12.2] } [list [list 10 [expr {3 + 2*$fixedHeight + $ascentDiff}] 7 $fixedHeight] [list 17 [expr {3+ 2*$fixedHeight}] 14 27]] .t tag remove big 1.0 end test textDisp-22.8 {TkTextCharBbox, horizontal scrolling} {textfonts} { .t configure -wrap none .t delete 1.0 end .t insert end "12345\n" .t insert end "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" .t xview scroll 4 units list [.t bbox 1.3] [.t bbox 1.4] [.t bbox 2.3] [.t bbox 2.4] \ [.t bbox 2.23] [.t bbox 2.24] } [list {} [list 3 3 7 $fixedHeight] {} [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight] [list 136 [expr {$fixedDiff + 16}] 7 $fixedHeight] {}] test textDisp-22.9 {TkTextCharBbox, handling of spacing} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "abcdefghijkl\nmnopqrstuvwzyz" .t tag configure spacing -spacing1 8 -spacing3 2 .t tag add spacing 1.0 end frame .t.f1 -width 10 -height 4 -bg black frame .t.f2 -width 10 -height 4 -bg black frame .t.f3 -width 10 -height 4 -bg black frame .t.f4 -width 10 -height 4 -bg black .t window create 1.3 -window .t.f1 -align top .t window create 1.7 -window .t.f2 -align center .t window create 2.1 -window .t.f3 -align bottom .t window create 2.10 -window .t.f4 -align baseline update list [.t bbox .t.f1] [.t bbox .t.f2] [.t bbox .t.f3] [.t bbox .t.f4] \ [.t bbox 1.1] [.t bbox 2.9] } [list [list 24 11 10 4] [list 55 [expr {$fixedDiff/2 + 15}] 10 4] [list 10 [expr {2*$fixedDiff + 43}] 10 4] [list 76 [expr {2*$fixedDiff + 40}] 10 4] [list 10 11 7 $fixedHeight] [list 69 [expr {$fixedDiff + 34}] 7 $fixedHeight]] .t tag delete spacing 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 tag add hidden 2.8 2.13 .t tag add hidden 6.8 7.13 .t tag configure hidden -elide true update list \ [expr {[lindex [.t bbox 2.9] 0] - [lindex [.t bbox 2.8] 0]}] \ [expr {[lindex [.t bbox 2.10] 0] - [lindex [.t bbox 2.8] 0]}] \ [expr {[lindex [.t bbox 2.13] 0] - [lindex [.t bbox 2.8] 0]}] \ [expr {[lindex [.t bbox 6.9] 0] - [lindex [.t bbox 6.8] 0]}] \ [expr {[lindex [.t bbox 6.10] 0] - [lindex [.t bbox 6.8] 0]}] \ [expr {[lindex [.t bbox 6.13] 0] - [lindex [.t bbox 6.8] 0]}] \ [expr {[lindex [.t bbox 6.14] 0] - [lindex [.t bbox 6.8] 0]}] \ [expr {[lindex [.t bbox 6.15] 0] - [lindex [.t bbox 6.8] 0]}] \ [expr {[lindex [.t bbox 7.0] 0] - [lindex [.t bbox 6.8] 0]}] \ [expr {[lindex [.t bbox 7.1] 0] - [lindex [.t bbox 6.8] 0]}] \ [expr {[lindex [.t bbox 7.12] 0] - [lindex [.t bbox 6.8] 0]}] } [list 0 0 0 0 0 0 0 0 0 0 0] test textDisp-22.11 {TkTextCharBbox, handling of wrapped 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 _$i - Lines .$i - Line [format %c [expr 64+$i]]\n" } .t tag add hidden 1.30 2.5 .t tag configure hidden -elide true update list \ [expr {[lindex [.t bbox 1.30] 0] - [lindex [.t bbox 2.4] 0]}] \ [expr {[lindex [.t bbox 1.30] 0] - [lindex [.t bbox 2.5] 0]}] } [list 0 0] .t delete 1.0 end .t insert end "Line 1" for {set i 2} {$i <= 200} {incr i} { .t insert end "\nLine $i" } .t configure -wrap word .t delete 50.0 51.0 .t insert 50.0 "This is a long line, one that will wrap around twice.\n" update test textDisp-23.1 {TkTextDLineInfo} {textfonts} { .t config -wrap word .t yview 48.0 list [.t dlineinfo 47.3] [.t dlineinfo 48.0] [.t dlineinfo 50.40] \ [.t dlineinfo 56.0] } [list {} [list 3 3 49 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 3 [expr {4*$fixedDiff + 55}] 126 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] {}] test textDisp-23.2 {TkTextDLineInfo} {textfonts} { .t config -bd 4 -wrap word update .t yview 48.0 .t dlineinfo 50.40 } [list 7 [expr {4*$fixedDiff + 59}] 126 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] .t config -bd 0 test textDisp-23.3 {TkTextDLineInfo} {textfonts} { .t config -wrap none update .t yview 48.0 list [.t dlineinfo 50.40] [.t dlineinfo 57.3] } [list [list 3 [expr {2*$fixedDiff + 29}] 371 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 3 [expr {9*$fixedDiff + 120}] 49 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]]] test textDisp-23.4 {TkTextDLineInfo, cut-off lines} {textfonts} { .t config -wrap char .t yview 10.0 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] 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}]]] wm geom . {} update test textDisp-23.6 {TkTextDLineInfo, horizontal scrolling} {textfonts} { .t config -wrap none .t delete 1.0 end .t insert end "First line\n" .t insert end "Second line is a very long one that doesn't all fit.\n" .t insert end "Third" .t xview scroll 6 units update list [.t dlineinfo 1.0] [.t dlineinfo 2.0] [.t dlineinfo 3.0] } [list [list -39 3 70 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list -39 [expr {$fixedDiff + 16}] 364 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list -39 [expr {2*$fixedDiff + 29}] 35 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]]] .t xview moveto 0 test textDisp-23.7 {TkTextDLineInfo, centering} {textfonts} { .t config -wrap word .t delete 1.0 end .t insert end "First line\n" .t insert end "Second line is a very long one that doesn't all fit.\n" .t insert end "Third" .t tag configure x -justify center .t tag configure y -justify right .t tag add x 1.0 .t tag add y 3.0 list [.t dlineinfo 1.0] [.t dlineinfo 2.0] [.t dlineinfo 3.0] } [list [list 38 3 70 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 3 [expr {$fixedDiff + 16}] 119 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 108 [expr {4*$fixedDiff + 55}] 35 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]]] .t tag delete x y test textDisp-24.1 {TkTextCharLayoutProc} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "abcdefghijklmnopqrstuvwxyz" list [.t bbox 1.19] [.t bbox 1.20] } [list [list 136 3 7 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]] 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 update list [.t bbox 1.19] [.t bbox 1.20] } [list [list 136 3 12 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]] 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 update list [.t bbox 1.19] [.t bbox 1.20] } [list [list 136 3 10 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]] test textDisp-24.4 {TkTextCharLayoutProc, newline not visible} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 01234567890123456789\n012345678901234567890 wm geom . {} update list [.t bbox 1.19] [.t bbox 1.20] [.t bbox 2.20] } [list [list 136 3 7 $fixedHeight] [list 143 3 0 $fixedHeight] [list 3 [expr {2*$fixedDiff + 29}] 7 $fixedHeight]] test textDisp-24.5 {TkTextCharLayoutProc, char doesn't fit, newline not visible} {unix textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 0\n1\n wm geom . 110x$height update list [.t bbox 1.0] [.t bbox 1.1] [.t bbox 2.0] } [list [list 3 3 4 $fixedHeight] [list 7 3 0 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 4 $fixedHeight]] test textDisp-24.6 {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 . {} update list [.t bbox 1.19] [.t bbox 1.20] } [list [list 136 3 7 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]] 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 update list [.t bbox 1.19] [.t bbox 1.20] } [list [list 136 3 12 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]] 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 update list [.t bbox 1.19] [.t bbox 1.20] } [list [list 136 3 10 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]] 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 update list [.t bbox 1.19] [.t bbox 1.20] } [list [list 136 3 5 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]] 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 update list [.t bbox 1.19] [.t bbox 1.20] } [list [list 136 3 4 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]] test textDisp-24.11 {TkTextCharLayoutProc, line ends with space that doesn't quite fit} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "01234567890123456789 \nabcdefg" wm geom . [expr $width-2]x$height update set result {} lappend result [.t bbox 1.21] [.t bbox 2.0] .t mark set insert 1.21 lappend result [.t bbox 1.21] [.t bbox 2.0] } [list [list 145 3 0 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight] [list 145 3 0 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]] test textDisp-24.12 {TkTextCharLayoutProc, tab causes wrap} {textfonts} { .t configure -wrap char .t delete 1.0 end .t insert 1.0 "abcdefghi" .t mark set insert 1.4 .t insert insert \t\t\t list [.t bbox {insert -1c}] [.t bbox insert] } [list [list 115 3 30 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]] test textDisp-24.13 {TkTextCharLayoutProc, -wrap none} {textfonts} { .t configure -wrap none .t delete 1.0 end .t insert 1.0 "abcdefghijklmnopqrstuvwxyz" wm geom . {} update list [.t bbox 1.19] [.t bbox 1.20] } [list [list 136 3 7 $fixedHeight] {}] 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 update list [.t bbox 1.19] [.t bbox 1.20] } [list [list 136 3 7 $fixedHeight] [list 143 3 5 $fixedHeight]] 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 update list [.t bbox 1.19] [.t bbox 1.20] } [list [list 136 3 7 $fixedHeight] [list 143 3 3 $fixedHeight]] test textDisp-24.16 {TkTextCharLayoutProc, no chars fit} {textfonts} { if {$tcl_platform(platform) == "windows"} { wm overrideredirect . 1 } .t configure -wrap char .t delete 1.0 end .t insert 1.0 "abcdefghijklmnopqrstuvwxyz" wm geom . 103x$height update list [.t bbox 1.0] [.t bbox 1.1] [.t bbox 1.2] } [list [list 3 3 1 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 1 $fixedHeight] [list 3 [expr {2*$fixedDiff + 29}] 1 $fixedHeight]] if {$tcl_platform(platform) == "windows"} { wm overrideredirect . 0 } test textDisp-24.17 {TkTextCharLayoutProc, -wrap word} {textfonts} { .t configure -wrap word .t delete 1.0 end .t insert 1.0 "This is a line that wraps around" wm geom . {} update list [.t bbox 1.19] [.t bbox 1.20] } [list [list 136 3 7 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]] test textDisp-24.18 {TkTextCharLayoutProc, -wrap word} {textfonts} { .t configure -wrap word .t delete 1.0 end .t insert 1.0 "xThis is a line that wraps around" wm geom . {} update list [.t bbox 1.14] [.t bbox 1.15] [.t bbox 1.16] } [list [list 101 3 7 $fixedHeight] [list 108 3 35 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 7 $fixedHeight]] test textDisp-24.19 {TkTextCharLayoutProc, -wrap word} {textfonts} { .t configure -wrap word .t delete 1.0 end .t insert 1.0 "xxThis is a line that wraps around" wm geom . {} update list [.t bbox 1.14] [.t bbox 1.15] [.t bbox 1.16] } [list [list 101 3 7 $fixedHeight] [list 108 3 7 $fixedHeight] [list 115 3 28 $fixedHeight]] test textDisp-24.20 {TkTextCharLayoutProc, vertical offset} {textfonts} { .t configure -wrap none .t delete 1.0 end .t insert 1.0 "Line 1\nLine 2\nLine 3" set result {} lappend result [.t bbox 2.1] [.t dlineinfo 2.1] .t tag configure up -offset 6 .t tag add up 2.1 lappend result [.t bbox 2.1] [.t dlineinfo 2.1] .t tag configure up -offset -2 lappend result [.t bbox 2.1] [.t dlineinfo 2.1] .t tag delete up set result } [list [list 10 [expr {$fixedDiff + 16}] 7 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 42 [expr {$fixedDiff + 13}] [expr {$fixedDiff + 10}]] [list 10 [expr {$fixedDiff + 16}] 7 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 42 [expr {$fixedDiff + 19}] [expr {$fixedDiff + 16}]] [list 10 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 3 [expr {$fixedDiff + 16}] 42 [expr {$fixedDiff + 15}] [expr {$fixedDiff + 10}]]] .t configure -width 30 update test textDisp-24.21 {TkTextCharLayoutProc, word breaks} {textfonts} { .t configure -wrap word .t delete 1.0 end .t insert 1.0 "Sample text xxxxxxx yyyyy zzzzzzz qqqqq rrrr ssss tt u vvvvv" frame .t.f -width 30 -height 20 -bg black .t window create 1.36 -window .t.f .t bbox 1.26 } [list 3 [expr {$fixedDiff/2 + 19}] 7 $fixedHeight] test textDisp-24.22 {TkTextCharLayoutProc, word breaks} {textfonts} { .t configure -wrap word .t delete 1.0 end frame .t.f -width 30 -height 20 -bg black .t insert 1.0 "Sample text xxxxxxx yyyyyyy" .t window create end -window .t.f .t insert end "zzzzzzz qqqqq rrrr ssss tt u vvvvv" .t bbox 1.28 } [list 33 [expr {$fixedDiff/2 + 19}] 7 $fixedHeight] test textDisp-24.23 {TkTextCharLayoutProc, word breaks} {textfonts} { .t configure -wrap word .t delete 1.0 end frame .t.f -width 30 -height 20 -bg black .t insert 1.0 "Sample text xxxxxxx yyyyyyy " .t insert end "zzzzzzz qqqqq rrrr ssss tt" .t window create end -window .t.f .t insert end "u vvvvv" .t bbox .t.f } [list 3 [expr {2*$fixedDiff + 29}] 30 20] catch {destroy .t.f} .t configure -width 20 update test textDisp-24.24 {TkTextCharLayoutProc, justification and tabs} {textfonts} { .t delete 1.0 end .t tag configure x -justify center .t insert 1.0 aa\tbb\tcc\tdd\t .t tag add x 1.0 end list [.t bbox 1.0] [.t bbox 1.10] } [list [list 45 3 7 $fixedHeight] [list 94 3 7 $fixedHeight]] .t configure -width 40 -bd 0 -relief flat -highlightthickness 0 -padx 0 \ -tabs 100 update test textDisp-25.1 {CharBboxProc procedure, check tab width} {textfonts} { .t delete 1.0 end .t insert 1.0 abc\td\tfgh list [.t bbox 1.3] [.t bbox 1.5] [.t bbox 1.6] } [list [list 21 1 79 $fixedHeight] [list 107 1 93 $fixedHeight] [list 200 1 7 $fixedHeight]] .t configure -width 40 -bd 0 -relief flat -highlightthickness 0 -padx 0 \ -tabs {} update test textDisp-26.1 {AdjustForTab procedure, no tabs} {textfonts} { .t delete 1.0 end .t insert 1.0 a\tbcdefghij\tc\td list [lindex [.t bbox 1.2] 0] [lindex [.t bbox 1.12] 0] \ [lindex [.t bbox 1.14] 0] } [list 56 126 168] test textDisp-26.1.2 {AdjustForTab procedure, no tabs} {textfonts} { .t delete 1.0 end .t insert 1.0 a\tbcdefghij\tc\td .t configure -tabstyle wordprocessor set res [list [lindex [.t bbox 1.2] 0] [lindex [.t bbox 1.12] 0] \ [lindex [.t bbox 1.14] 0]] .t configure -tabstyle tabular set res } [list 56 168 224] test textDisp-26.2 {AdjustForTab procedure, not enough tabs specified} { .t delete 1.0 end .t insert 1.0 a\tb\tc\td .t tag delete x .t tag configure x -tabs 40 .t tag add x 1.0 end list [lindex [.t bbox 1.2] 0] [lindex [.t bbox 1.4] 0] \ [lindex [.t bbox 1.6] 0] } [list 40 80 120] test textDisp-26.3 {AdjustForTab procedure, not enough tabs specified} { .t delete 1.0 end .t insert 1.0 a\tb\tc\td\te .t tag delete x .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]] } [list 40 70 100 130] test textDisp-26.4 {AdjustForTab procedure, different alignments} { .t delete 1.0 end .t insert 1.0 a\tbc\tde\tfg\thi .t tag delete x .t tag configure x -tabs {40 center 80 left 130 right} .t tag add x 1.0 end .t tag add y 1.2 .t tag add y 1.5 .t tag add y 1.8 list [lindex [.t bbox 1.3] 0] [lindex [.t bbox 1.5] 0] \ [lindex [.t bbox 1.10] 0] } [list 40 80 130] test textDisp-26.5 {AdjustForTab procedure, numeric alignment} { .t delete 1.0 end .t insert 1.0 a\t1.234 .t tag delete x .t tag configure x -tabs {120 numeric} .t tag add x 1.0 end .t tag add y 1.2 .t tag add y 1.5 lindex [.t bbox 1.3] 0 } {120} test textDisp-26.6 {AdjustForTab procedure, numeric alignment} { .t delete 1.0 end .t insert 1.0 a\t1,456.234 .t tag delete x .t tag configure x -tabs {120 numeric} .t tag add x 1.0 end .t tag add y 1.2 lindex [.t bbox 1.7] 0 } {120} test textDisp-26.7 {AdjustForTab procedure, numeric alignment} { .t delete 1.0 end .t insert 1.0 a\t1.456.234,7 .t tag delete x .t tag configure x -tabs {120 numeric} .t tag add x 1.0 end .t tag add y 1.2 lindex [.t bbox 1.11] 0 } {120} test textDisp-26.8 {AdjustForTab procedure, numeric alignment} { .t delete 1.0 end .t insert 1.0 a\ttest .t tag delete x .t tag configure x -tabs {120 numeric} .t tag add x 1.0 end .t tag add y 1.2 lindex [.t bbox 1.6] 0 } {120} test textDisp-26.9 {AdjustForTab procedure, numeric alignment} { .t delete 1.0 end .t insert 1.0 a\t1234 .t tag delete x .t tag configure x -tabs {120 numeric} .t tag add x 1.0 end .t tag add y 1.2 lindex [.t bbox 1.6] 0 } {120} test textDisp-26.10 {AdjustForTab procedure, numeric alignment} { .t delete 1.0 end .t insert 1.0 a\t1.234567 .t tag delete x .t tag configure x -tabs {120 numeric} .t tag add x 1.0 end .t tag add y 1.5 lindex [.t bbox 1.3] 0 } {120} test textDisp-26.11 {AdjustForTab procedure, numeric alignment} { .t delete 1.0 end .t insert 1.0 a\tx=1.234567 .t tag delete x .t tag configure x -tabs {120 numeric} .t tag add x 1.0 end .t tag add y 1.7 .t tag add y 1.9 lindex [.t bbox 1.5] 0 } {120} test textDisp-26.12 {AdjustForTab procedure, adjusting chunks} { .t delete 1.0 end .t insert 1.0 a\tx1.234567 .t tag delete x .t tag configure x -tabs {120 numeric} .t tag add x 1.0 end .t tag add y 1.7 .t tag add y 1.9 button .b -text "=" .t window create 1.3 -window .b update lindex [.t bbox 1.5] 0 } {120} test textDisp-26.13 {AdjustForTab procedure, not enough space} {textfonts} { .t delete 1.0 end .t insert 1.0 "abc\txyz\tqrs\txyz\t0" .t tag delete x .t tag configure x -tabs {10 30 center 50 right 120} .t tag add x 1.0 end list [lindex [.t bbox 1.4] 0] [lindex [.t bbox 1.8] 0] \ [lindex [.t bbox 1.12] 0] [lindex [.t bbox 1.16] 0] } [list 28 56 84 120] test textDisp-26.13.2 {AdjustForTab procedure, not enough space} {textfonts} { .t delete 1.0 end .t insert 1.0 "abc\txyz\tqrs\txyz\t0" .t tag delete x .t tag configure x -tabs {10 30 center 50 right 120} -tabstyle wordprocessor .t tag add x 1.0 end set res [list [lindex [.t bbox 1.4] 0] [lindex [.t bbox 1.8] 0] \ [lindex [.t bbox 1.12] 0] [lindex [.t bbox 1.16] 0]] .t tag configure x -tabstyle tabular set res } [list 28 56 120 190] test textDisp-26.14 {AdjustForTab procedure, not enough space} {textfonts} { .t delete 1.0 end .t insert end "a \tb \tc \td \te \tf \tg\n" .t insert end "Watch the \tX and the \t\t\tY\n" .t tag configure moop -tabs [expr {8*$fixedWidth}] .t insert end "Watch the \tX and the \t\t\tY\n" moop list [lindex [.t bbox 2.11] 0] [lindex [.t bbox 2.24] 0] \ [lindex [.t bbox 3.11] 0] [lindex [.t bbox 3.24] 0] } [list 77 224 77 224] test textDisp-26.14.2 {AdjustForTab procedure, not enough space} {textfonts} { .t delete 1.0 end .t configure -tabstyle wordprocessor .t insert end "a \tb \tc \td \te \tf \tg\n" .t insert end "Watch the \tX and the \t\t\tY\n" .t tag configure moop -tabs [expr {8*$fixedWidth}] .t insert end "Watch the \tX and the \t\t\tY\n" moop set res [list [lindex [.t bbox 2.11] 0] [lindex [.t bbox 2.24] 0] \ [lindex [.t bbox 3.11] 0] [lindex [.t bbox 3.24] 0]] .t configure -tabstyle tabular set res } [list 112 56 112 56] .t configure -width 20 -bd 2 -highlightthickness 2 -relief sunken -tabs {} \ -wrap char update test textDisp-27.1 {SizeOfTab procedure, old-style tabs} {textfonts} { .t delete 1.0 end .t insert 1.0 a\tbcdefghij\tc\td list [.t bbox 1.2] [.t bbox 1.10] [.t bbox 1.12] } [list [list 60 5 7 $fixedHeight] [list 116 5 7 $fixedHeight] [list 130 5 7 $fixedHeight]] test textDisp-27.1.1 {SizeOfTab procedure, old-style tabs} {textfonts} { .t delete 1.0 end .t insert 1.0 a\tbcdefghij\tc\td .t configure -tabstyle wordprocessor set res [list [.t bbox 1.2] [.t bbox 1.10] [.t bbox 1.12]] .t configure -tabstyle tabular set res } [list [list 60 5 7 $fixedHeight] [list 116 5 7 $fixedHeight] [list 4 [expr {$fixedDiff + 18}] 7 $fixedHeight]] test textDisp-27.2 {SizeOfTab procedure, choosing tabX and alignment} {textfonts} { .t delete 1.0 end .t insert 1.0 a\tbcd .t tag delete x .t tag configure x -tabs 120 .t tag add x 1.0 end list [.t bbox 1.3] [.t bbox 1.4] } [list [list 131 5 13 $fixedHeight] [list 4 [expr {$fixedDiff + 18}] 7 $fixedHeight]] test textDisp-27.3 {SizeOfTab procedure, choosing tabX and alignment} {textfonts} { .t delete 1.0 end .t insert 1.0 a\t\t\tbcd .t tag delete x .t tag configure x -tabs 40 .t tag add x 1.0 end list [.t bbox 1.5] [.t bbox 1.6] } [list [list 131 5 13 $fixedHeight] [list 4 [expr {$fixedDiff + 18}] 7 $fixedHeight]] test textDisp-27.4 {SizeOfTab procedure, choosing tabX and alignment} {textfonts} { .t delete 1.0 end .t insert 1.0 a\t\t\tbcd .t tag delete x .t tag configure x -tabs {20 center 70 left} .t tag add x 1.0 end list [.t bbox 1.5] [.t bbox 1.6] } [list [list 131 5 13 $fixedHeight] [list 4 [expr {$fixedDiff + 18}] 7 $fixedHeight]] test textDisp-27.5 {SizeOfTab procedure, center alignment} {textfonts} { .t delete 1.0 end .t insert 1.0 a\txyzzyabc .t tag delete x .t tag configure x -tabs {120 center} .t tag add x 1.0 end list [.t bbox 1.6] [.t bbox 1.7] } [list [list 135 5 9 $fixedHeight] [list 4 [expr {$fixedDiff + 18}] 7 $fixedHeight]] test textDisp-27.6 {SizeOfTab procedure, center alignment} {textfonts} { .t delete 1.0 end .t insert 1.0 a\txyzzyabc .t tag delete x .t tag configure x -tabs {150 center} .t tag add x 1.0 end list [.t bbox 1.6] [.t bbox 1.7] } [list [list 32 [expr {$fixedDiff + 18}] 7 $fixedHeight] [list 39 [expr {$fixedDiff + 18}] 7 $fixedHeight]] test textDisp-27.7 {SizeOfTab procedure, center alignment, wrap -none (potential numerical problems)} {textfonts} { .t delete 1.0 end set cm [winfo fpixels .t 1c] .t configure -tabs {1c 2c center 3c 4c 5c 6c 7c 8c} -wrap none -width 40 .t insert 1.0 a\tb\tc\td\te\n012345678934567890a\tbb\tcc\tdd set width [expr {$fixedWidth * 19}] set tab $cm while {$tab < $width} { set tab [expr {$tab + $cm}] } # Now we've calculated to the end of the tab after 'a', add one # more for 'bb\t' and we're there, with 4 for the border. Since # Tk_GetPixelsFromObj uses the standard 'int(0.5 + float)' rounding, # so must we. set tab [expr {4 + int(0.5 + $tab + $cm)}] update set res [.t bbox 2.23] lset res 0 [expr {[lindex $res 0] - $tab}] set res } [list -28 [expr {$fixedDiff + 18}] 7 $fixedHeight] test textDisp-27.7.1 {SizeOfTab procedure, center alignment, wrap -none (potential numerical problems)} {textfonts} { .t delete 1.0 end .t configure -tabstyle wordprocessor set cm [winfo fpixels .t 1c] .t configure -tabs {1c 2c center 3c 4c 5c 6c 7c 8c} -wrap none -width 40 .t insert 1.0 a\tb\tc\td\te\n012345678934567890a\tbb\tcc\tdd set width [expr {$fixedWidth * 19}] set tab $cm while {$tab < $width} { set tab [expr {$tab + $cm}] } # Now we've calculated to the end of the tab after 'a', add one # more for 'bb\t' and we're there, with 4 for the border. Since # Tk_GetPixelsFromObj uses the standard 'int(0.5 + float)' rounding, # so must we. set tab [expr {4 + int(0.5 + $tab + $cm)}] update set res [.t bbox 2.23] .t configure -tabstyle tabular lset res 0 [expr {[lindex $res 0] - $tab}] set res } [list 0 [expr {$fixedDiff + 18}] 7 $fixedHeight] test textDisp-27.7.2 {SizeOfTab procedure, fractional tab interpolation problem} { .t delete 1.0 end set interpolatetab {1c 2c} set precisetab {} for {set i 1} {$i < 20} {incr i} { lappend precisetab "${i}c" } .t configure -tabs $interpolatetab -wrap none -width 150 .t insert 1.0 [string repeat "a\t" 20] update set res [.t bbox 1.20] # Now, Tk's interpolated tabs should be the same as # non-interpolated. .t configure -tabs $precisetab update expr {[lindex $res 0] - [lindex [.t bbox 1.20] 0]} } {0} .t configure -wrap char -tabs {} -width 20 update test textDisp-27.8 {SizeOfTab procedure, right alignment} {textfonts} { .t delete 1.0 end .t insert 1.0 a\t\txyzzyabc .t tag delete x .t tag configure x -tabs {100 left 140 right} .t tag add x 1.0 end list [.t bbox 1.6] [.t bbox 1.7] } [list [list 137 5 7 $fixedHeight] [list 4 [expr {$fixedDiff + 18}] 7 $fixedHeight]] test textDisp-27.9 {SizeOfTab procedure, left alignment} {textfonts} { .t delete 1.0 end .t insert 1.0 a\txyzzyabc .t tag delete x .t tag configure x -tabs {120} .t tag add x 1.0 end list [.t bbox 1.3] [.t bbox 1.4] } [list [list 131 5 13 $fixedHeight] [list 4 [expr {$fixedDiff + 18}] 7 $fixedHeight]] test textDisp-27.10 {SizeOfTab procedure, numeric alignment} {textfonts} { .t delete 1.0 end .t insert 1.0 a\t123.4 .t tag delete x .t tag configure x -tabs {120 numeric} .t tag add x 1.0 end list [.t bbox 1.3] [.t bbox 1.4] } [list [list 117 5 27 $fixedHeight] [list 4 [expr {$fixedDiff + 18}] 7 $fixedHeight]] test textDisp-27.11 {SizeOfTab procedure, making tabs at least as wide as a space} {textfonts} { .t delete 1.0 end .t insert 1.0 abc\tdefghijklmnopqrst .t tag delete x .t tag configure x -tabs {120} .t tag add x 1.0 end list [.t bbox 1.5] [.t bbox 1.6] } [list [list 131 5 13 $fixedHeight] [list 4 [expr {$fixedDiff + 18}] 7 $fixedHeight]] proc bizarre_scroll args { .t2.t delete 5.0 end } test textDisp-28.1 {"yview" option with bizarre scroll command} { catch {destroy .t2} toplevel .t2 text .t2.t -width 40 -height 4 .t2.t insert end "1\n2\n3\n4\n5\n6\n7\n8\n" pack .t2.t wm geometry .t2 +0+0 update .t2.t configure -yscrollcommand bizarre_scroll .t2.t yview 100.0 set result [.t2.t index @0,0] update lappend result [.t2.t index @0,0] } {6.0 2.0} test textDisp-29.1 {miscellaneous: lines wrap but are still too long} {textfonts} { catch {destroy .t2} toplevel .t2 wm geometry .t2 +0+0 text .t2.t -width 20 -height 10 -font $fixedFont \ -wrap char -xscrollcommand ".t2.s set" pack .t2.t -side top scrollbar .t2.s -orient horizontal -command ".t2.t xview" pack .t2.s -side bottom -fill x .t2.t insert end 123 frame .t2.t.f -width 300 -height 50 -bd 2 -relief raised .t2.t window create 1.1 -window .t2.t.f update list [.t2.t xview] [winfo geom .t2.t.f] [.t2.t bbox 1.3] } [list [list 0.0 [expr {20.0*$fixedWidth/300}]] 300x50+[expr {$twbw + $twht + 1}]+[expr {$twbw + $twht + $fixedHeight + 1}] [list [expr {$twbw + $twht + $fixedWidth + 1}] [expr {$twbw + $twht + $fixedHeight + 50 + 1}] $fixedWidth $fixedHeight]] test textDisp-29.2 {miscellaneous: lines wrap but are still too long} {textfonts} { catch {destroy .t2} toplevel .t2 wm geometry .t2 +0+0 text .t2.t -width 20 -height 10 -font $fixedFont \ -wrap char -xscrollcommand ".t2.s set" pack .t2.t -side top scrollbar .t2.s -orient horizontal -command ".t2.t xview" pack .t2.s -side bottom -fill x .t2.t insert end 123 frame .t2.t.f -width 300 -height 50 -bd 2 -relief raised .t2.t window create 1.1 -window .t2.t.f update .t2.t xview scroll 1 unit update list [.t2.t xview] [winfo geom .t2.t.f] [.t2.t bbox 1.3] } [list [list [expr {1.0*$fixedWidth/300}] [expr {21.0*$fixedWidth/300}]] 300x50+[expr {$twbw + $twht + 1 - $fixedWidth}]+[expr {$twbw + $twht + $fixedHeight + 1}] [list [expr {$twbw + $twht + $fixedWidth + 1 - $fixedWidth}] [expr {$twbw + $twht + $fixedHeight + 50 + 1}] $fixedWidth $fixedHeight]] test textDisp-29.2.1 {miscellaneous: lines wrap but are still too long} {textfonts} { catch {destroy .t2} toplevel .t2 wm geometry .t2 +0+0 text .t2.t -width 20 -height 10 -font $fixedFont \ -wrap none -xscrollcommand ".t2.s set" pack .t2.t -side top scrollbar .t2.s -orient horizontal -command ".t2.t xview" pack .t2.s -side bottom -fill x .t2.t insert end 1\n .t2.t insert end [string repeat "abc" 30] update .t2.t xview scroll 5 unit update .t2.t xview } [list [expr {5.0/90}] [expr {25.0/90}]] test textDisp-29.2.2 {miscellaneous: lines wrap but are still too long} {textfonts} { catch {destroy .t2} toplevel .t2 wm geometry .t2 +0+0 text .t2.t -width 20 -height 10 -font $fixedFont \ -wrap char -xscrollcommand ".t2.s set" pack .t2.t -side top scrollbar .t2.s -orient horizontal -command ".t2.t xview" pack .t2.s -side bottom -fill x .t2.t insert end 123 frame .t2.t.f -width 300 -height 50 -bd 2 -relief raised .t2.t window create 1.1 -window .t2.t.f update .t2.t xview scroll 2 unit update list [.t2.t xview] [winfo geom .t2.t.f] [.t2.t bbox 1.3] } [list [list [expr {2.0*$fixedWidth/300}] [expr {22.0*$fixedWidth/300}]] 300x50+[expr {$twbw + $twht + 1 - 2*$fixedWidth}]+[expr {$twbw + $twht + $fixedHeight + 1}] {}] test textDisp-29.2.3 {miscellaneous: lines wrap but are still too long} {textfonts} { catch {destroy .t2} toplevel .t2 wm geometry .t2 +0+0 text .t2.t -width 20 -height 10 -font $fixedFont \ -wrap char -xscrollcommand ".t2.s set" pack .t2.t -side top scrollbar .t2.s -orient horizontal -command ".t2.t xview" pack .t2.s -side bottom -fill x .t2.t insert end 123 frame .t2.t.f -width 300 -height 50 -bd 2 -relief raised .t2.t window create 1.1 -window .t2.t.f update .t2.t xview scroll 7 pixels update list [.t2.t xview] [winfo geom .t2.t.f] [.t2.t bbox 1.3] } [list [list [expr {7.0/300}] [expr {(20.0*$fixedWidth + 7)/300}]] 300x50+[expr {$twbw + $twht + 1 - 7}]+[expr {$twbw + $twht + $fixedHeight + 1}] [list [expr {$twbw + $twht + $fixedWidth + 1 - 7}] [expr {$twbw + $twht + $fixedHeight + 50 + 1}] $fixedWidth $fixedHeight]] test textDisp-29.2.4 {miscellaneous: lines wrap but are still too long} {textfonts} { catch {destroy .t2} toplevel .t2 wm geometry .t2 +0+0 text .t2.t -width 20 -height 10 -font $fixedFont \ -wrap char -xscrollcommand ".t2.s set" pack .t2.t -side top scrollbar .t2.s -orient horizontal -command ".t2.t xview" pack .t2.s -side bottom -fill x .t2.t insert end 123 frame .t2.t.f -width 300 -height 50 -bd 2 -relief raised .t2.t window create 1.1 -window .t2.t.f update .t2.t xview scroll 17 pixels update list [.t2.t xview] [winfo geom .t2.t.f] [.t2.t bbox 1.3] } [list [list [expr {17.0/300}] [expr {(20.0*$fixedWidth + 17)/300}]] 300x50+[expr {$twbw + $twht + 1 - 17}]+[expr {$twbw + $twht + $fixedHeight + 1}] {}] test textDisp-29.2.5 {miscellaneous: can show last character} { catch {destroy .t2} toplevel .t2 wm geometry .t2 121x141+200+200 text .t2.t -width 5 -height 5 -font {Arial 10} \ -wrap none -xscrollcommand ".t2.s set" \ -bd 2 -highlightthickness 0 -padx 1 .t2.t insert end "WWWWWWWWWWWWi" scrollbar .t2.s -orient horizontal -command ".t2.t xview" grid .t2.t -row 0 -column 0 -sticky nsew grid .t2.s -row 1 -column 0 -sticky ew grid columnconfigure .t2 0 -weight 1 grid rowconfigure .t2 0 -weight 1 grid rowconfigure .t2 1 -weight 0 update ; update set xv [.t2.t xview] set xd [expr {[lindex $xv 1] - [lindex $xv 0]}] .t2.t xview moveto [expr {1.0-$xd}] set iWidth [lindex [.t2.t bbox end-2c] 2] .t2.t xview scroll 2 units set iWidth2 [lindex [.t2.t bbox end-2c] 2] if {($iWidth == $iWidth2) && $iWidth >= 2} { set result "correct" } else { set result "last character is not completely visible when it should be" } } {correct} test textDisp-29.3 {miscellaneous: lines wrap but are still too long} {textfonts} { catch {destroy .t2} toplevel .t2 wm geometry .t2 +0+0 text .t2.t -width 20 -height 10 -font $fixedFont \ -wrap char -xscrollcommand ".t2.s set" pack .t2.t -side top scrollbar .t2.s -orient horizontal -command ".t2.t xview" pack .t2.s -side bottom -fill x .t2.t insert end 123 frame .t2.t.f -width 300 -height 50 -bd 2 -relief raised .t2.t window create 1.1 -window .t2.t.f update .t2.t xview scroll 200 units update list [.t2.t xview] [winfo geom .t2.t.f] [.t2.t bbox 1.3] } [list [list [expr {16.0/30}] 1.0] 300x50+-155+[expr {$fixedDiff + 18}] {}] test textDisp-30.1 {elidden text joining multiple logical lines} { .t2.t delete 1.0 end .t2.t insert 1.0 "1111\n2222\n3333" .t2.t tag configure elidden -elide 1 -background red .t2.t tag add elidden 1.2 3.2 .t2.t count -displaylines 1.0 end } {1} test textDisp-30.2 {elidden text joining multiple logical lines} { .t2.t delete 1.0 end .t2.t insert 1.0 "1111\n2222\n3333" .t2.t tag configure elidden -elide 1 -background red .t2.t tag add elidden 1.2 2.2 .t2.t count -displaylines 1.0 end } {2} catch {destroy .t2} .t configure -height 1 update test textDisp-31.1 {line embedded window height update} { set res {} .t delete 1.0 end .t insert end "abcd\nefgh\nijkl\nmnop\nqrst\nuvwx\nyx" frame .t.f -background red -width 100 -height 100 .t window create 3.0 -window .t.f lappend res [.t count -update -ypixels 1.0 end] .t.f configure -height 10 lappend res [.t count -ypixels 1.0 end] lappend res [.t count -update -ypixels 1.0 end] set res } [list [expr {100 + $fixedHeight * 6}] [expr {100 + $fixedHeight * 6}] [expr {$fixedHeight * 7}]] test textDisp-31.2 {line update index shifting} { set res {} .t.f configure -height 100 update lappend res [.t count -update -ypixels 1.0 end] .t.f configure -height 10 .t insert 1.0 "abc\n" .t insert 1.0 "abc\n" lappend res [.t count -ypixels 1.0 end] lappend res [.t count -update -ypixels 1.0 end] .t.f configure -height 100 .t delete 1.0 3.0 lappend res [.t count -ypixels 1.0 end] lappend res [.t count -update -ypixels 1.0 end] set res } [list [expr {100 + $fixedHeight * 6}] [expr {100 + $fixedHeight * 8}] [expr {$fixedHeight * 9}] [expr {$fixedHeight * 7}] [expr {100 + $fixedHeight * 6}]] test textDisp-31.3 {line update index shifting} { # Should do exactly the same as the above, as long # as we are correctly tagging the correct lines for # recalculation. The 'update' and 'delay' must be # long enough to ensure all asynchronous updates # have been performed. set res {} .t.f configure -height 100 update lappend res [.t count -update -ypixels 1.0 end] .t.f configure -height 10 .t insert 1.0 "abc\n" .t insert 1.0 "abc\n" lappend res [.t count -ypixels 1.0 end] update ; after 1000 ; update lappend res [.t count -ypixels 1.0 end] .t.f configure -height 100 .t delete 1.0 3.0 lappend res [.t count -ypixels 1.0 end] update ; after 1000 ; update lappend res [.t count -ypixels 1.0 end] set res } [list [expr {100 + $fixedHeight * 6}] [expr {100 + $fixedHeight * 8}] [expr {$fixedHeight * 9}] [expr {$fixedHeight * 7}] [expr {100 + $fixedHeight * 6}]] test textDisp-31.4 {line embedded image height update} { set res {} image create photo textest -height 100 -width 10 .t delete 3.0 .t image create 3.0 -image textest update lappend res [.t count -update -ypixels 1.0 end] textest configure -height 10 lappend res [.t count -ypixels 1.0 end] lappend res [.t count -update -ypixels 1.0 end] set res } [list [expr {100 + $fixedHeight * 6}] [expr {100 + $fixedHeight * 6}] [expr {$fixedHeight * 7}]] test textDisp-31.5 {line update index shifting} { set res {} textest configure -height 100 update ; after 1000 ; update lappend res [.t count -update -ypixels 1.0 end] textest configure -height 10 .t insert 1.0 "abc\n" .t insert 1.0 "abc\n" lappend res [.t count -ypixels 1.0 end] lappend res [.t count -update -ypixels 1.0 end] textest configure -height 100 .t delete 1.0 3.0 lappend res [.t count -ypixels 1.0 end] lappend res [.t count -update -ypixels 1.0 end] set res } [list [expr {100 + $fixedHeight * 6}] [expr {100 + $fixedHeight * 8}] [expr {$fixedHeight * 9}] [expr {$fixedHeight * 7}] [expr {100 + $fixedHeight * 6}]] test textDisp-31.6 {line update index shifting} { # Should do exactly the same as the above, as long # as we are correctly tagging the correct lines for # recalculation. The 'update' and 'delay' must be # long enough to ensure all asynchronous updates # have been performed. set res {} textest configure -height 100 update ; after 1000 ; update lappend res [.t count -update -ypixels 1.0 end] textest configure -height 10 .t insert 1.0 "abc\n" .t insert 1.0 "abc\n" lappend res [.t count -ypixels 1.0 end] update ; after 1000 ; update lappend res [.t count -ypixels 1.0 end] textest configure -height 100 .t delete 1.0 3.0 lappend res [.t count -ypixels 1.0 end] update ; after 1000 ; update lappend res [.t count -ypixels 1.0 end] set res } [list [expr {100 + $fixedHeight * 6}] [expr {100 + $fixedHeight * 8}] [expr {$fixedHeight * 9}] [expr {$fixedHeight * 7}] [expr {100 + $fixedHeight * 6}]] test textDisp-31.7 {line update index shifting, elided} { # The 'update' and 'delay' must be long enough to ensure all # asynchronous updates have been performed. set res {} .t delete 1.0 end lappend res [.t count -update -ypixels 1.0 end] .t insert 1.0 "abc\nabc" .t insert 1.0 "abc\n" lappend res [.t count -update -ypixels 1.0 end] .t tag configure elide -elide 1 .t tag add elide 1.3 2.1 lappend res [.t count -ypixels 1.0 end] update ; after 1000 ; update lappend res [.t count -ypixels 1.0 end] .t delete 1.0 3.0 lappend res [.t count -ypixels 1.0 end] update ; after 1000 ; update lappend res [.t count -ypixels 1.0 end] set res } [list [expr {$fixedHeight * 1}] [expr {$fixedHeight * 3}] [expr {$fixedHeight * 3}] [expr {$fixedHeight * 2}] [expr {$fixedHeight * 1}] [expr {$fixedHeight * 1}]] test textDisp-32.0 {everything elided} { # Must not crash pack [text .tt] .tt insert 0.0 HELLO .tt tag configure HIDE -elide 1 .tt tag add HIDE 0.0 end update ; update ; update ; update destroy .tt } {} test textDisp-32.1 {everything elided} { # Must not crash pack [text .tt] update .tt insert 0.0 HELLO update .tt tag configure HIDE -elide 1 update .tt tag add HIDE 0.0 end update ; update ; update ; update destroy .tt } {} test textDisp-32.2 {elide and tags} { pack [text .tt -height 30 -width 100 -bd 0 \ -highlightthickness 0 -padx 0] .tt insert end \ {test text using tags 1 and 3 } \ {testtag1 testtag3} \ {[this bit here uses tags 2 and 3]} \ {testtag2 testtag3} update # indent left margin of tag 1 by 20 pixels # text should be indented .tt tag configure testtag1 -lmargin1 20 ; update #1 set res {} lappend res [list [.tt index "1.0 + 0 displaychars"] \ [lindex [.tt bbox 1.0] 0] \ [lindex [.tt bbox "1.0 + 0 displaychars"] 0]] # hide tag 1, remaining text should not be indented, since # the indented tag and character is hidden. .tt tag configure testtag1 -elide 1 ; update #2 lappend res [list [.tt index "1.0 + 0 displaychars"] \ [lindex [.tt bbox 1.0] 0] \ [lindex [.tt bbox "1.0 + 0 displaychars"] 0]] # reset .tt tag configure testtag1 -lmargin1 0 .tt tag configure testtag1 -elide 0 # indent left margin of tag 2 by 20 pixels # text should not be indented, since tag1 has lmargin1 of 0. .tt tag configure testtag2 -lmargin1 20 ; update #3 lappend res [list [.tt index "1.0 + 0 displaychars"] \ [lindex [.tt bbox 1.0] 0] \ [lindex [.tt bbox "1.0 + 0 displaychars"] 0]] # hide tag 1, remaining text should now be indented, but # the bbox of 1.0 should have zero width and zero indent, # since it is elided at that position. .tt tag configure testtag1 -elide 1 ; update #4 lappend res [list [.tt index "1.0 + 0 displaychars"] \ [lindex [.tt bbox 1.0] 0] \ [lindex [.tt bbox "1.0 + 0 displaychars"] 0]] # reset .tt tag configure testtag2 -lmargin1 {} .tt tag configure testtag1 -elide 0 # indent left margin of tag 3 by 20 pixels # text should be indented, since this tag takes # precedence over testtag1, and is applied to the # start of the text. .tt tag configure testtag3 -lmargin1 20 ; update #5 lappend res [list [.tt index "1.0 + 0 displaychars"] \ [lindex [.tt bbox 1.0] 0] \ [lindex [.tt bbox "1.0 + 0 displaychars"] 0]] # hide tag 1, remaining text should still be indented, # since it still has testtag3 on it. Again the # bbox of 1.0 should have 0. .tt tag configure testtag1 -elide 1 ; update #6 lappend res [list [.tt index "1.0 + 0 displaychars"] \ [lindex [.tt bbox 1.0] 0] \ [lindex [.tt bbox "1.0 + 0 displaychars"] 0]] .tt tag configure testtag3 -lmargin1 {} -elide 0 .tt tag configure testtag1 -elide 1 -lmargin1 20 #7 lappend res [list [.tt index "1.0 + 0 displaychars"] \ [lindex [.tt bbox 1.0] 0] \ [lindex [.tt bbox "1.0 + 0 displaychars"] 0]] destroy .tt set res } {{1.0 20 20} {1.29 0 0} {1.0 0 0} {1.29 0 20}\ {1.0 20 20} {1.29 0 20} {1.0 20 20}} test textDisp-32.3 "NULL undisplayProc problems: #1791052" -setup { set img [image create photo -data { R0lGODlhEgASANUAAAAAAP/////iHP/mIPrWDPraEP/eGPfOAPbKAPbOBPrS CP/aFPbGAPLCAPLGAN62ANauAMylAPbCAPW/APK+AN6uALKNAPK2APK5ANal AOyzArGHBZp3B+6uAHFVBFVACO6qAOqqAOalAMGMAbF+Am1QBG5QBeuiAOad AM6NAJ9vBW1MBFlACFQ9CVlBCuaZAOKVANyVAZlpBMyFAKZtBJVhBEAUEP// /wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAADcALAAAAAASABIAAAa+ wJtw+Ckah0iiZwNhODKk0icp/HAShEKBoEBgVFOkK0Iw2GyCs+BAGbGIlrIt EJjXBYgL6X3zJMx1Z2d3EyEmNx9xaYGCdwgaNEUPBYt0do4XKUUOlAOCnmcD CwcXMZsEAgOqq6oLBY+mHxUKBqysCwQSIDNFJAidtgKjFyeRfRQHB2ipAmZs IDArVSTIyoI2bB0oxkIsIxcNyeIXICh7SR8yIhoXFxogJzE1YegrNCkoLzM0 K/RUiEY+tKASBAA7 }] destroy .tt } -body { text .tt .tt tag configure emoticon -elide 1 .tt insert end X .tt mark set MSGLEFT "end - 1 char" .tt mark gravity MSGLEFT left .tt insert end ":)" emoticon .tt image create end -image $img pack .tt update; update; update } -cleanup { image delete $img destroy .tt } test textDisp-33.0 {one line longer than fits in the widget} { pack [text .tt -wrap char] .tt insert 1.0 [string repeat "more wrap + " 300] update ; update ; update .tt see 1.0 lindex [.tt yview] 0 } {0.0} test textDisp-33.1 {one line longer than fits in the widget} { destroy .tt pack [text .tt -wrap char] .tt insert 1.0 [string repeat "more wrap + " 300] update ; update ; update .tt yview "1.0 +1 displaylines" if {[lindex [.tt yview] 0] > 0.1} { set result "window should be scrolled to the top" } else { set result "ok" } } {ok} test textDisp-33.2 {one line longer than fits in the widget} { destroy .tt pack [text .tt -wrap char] .tt debug 1 set tk_textHeightCalc "" .tt insert 1.0 [string repeat "more wrap + " 1] after 100 ; update idletasks # Nothing should have been recalculated. set tk_textHeightCalc } {} test textDisp-33.3 {one line longer than fits in the widget} { destroy .tt pack [text .tt -wrap char] .tt debug 1 set tk_textHeightCalc "" .tt insert 1.0 [string repeat "more wrap + " 300] update ; .tt count -update -ypixels 1.0 end ; update # Each line should have been recalculated just once .tt debug 0 expr {[llength $tk_textHeightCalc] == [.tt count -displaylines 1.0 end]} } {1} test textDisp-33.4 {one line longer than fits in the widget} { destroy .tt pack [text .tt -wrap char] .tt debug 1 set tk_textHeightCalc "" .tt insert 1.0 [string repeat "more wrap + " 300] update ; update ; update set idx [.tt index "1.0 + 1 displaylines"] .tt yview $idx if {[lindex [.tt yview] 0] > 0.1} { set result "window should be scrolled to the top" } else { set result "ok" } set idx [.tt index "1.0 + 1 displaylines"] .tt debug 0 set result } {ok} destroy .tt test textDisp-33.5 {bold or italic fonts} win { destroy .tt pack [text .tt -wrap char -font {{MS Sans Serif} 15}] font create no -family [lindex [.tt cget -font] 0] -size 24 font create bi -family [lindex [.tt cget -font] 0] -size 24 font configure bi -weight bold -slant italic .tt tag configure bi -font bi .tt tag configure no -font no .tt insert end abcd no efgh bi ijkl\n no update set bb {} for {set i 0} {$i < 12} {incr i 4} { lappend bb [lindex [.tt bbox 1.$i] 0] } foreach {a b c} $bb {} unset bb if {($b - $a) * 1.5 < ($c - $b)} { set result "italic font has much too much space" } else { set result "italic font measurement ok" } } {italic font measurement ok} destroy .tt test textDisp-34.1 {Line heights recalculation problem: bug 2677890} -setup { pack [text .t1] -expand 1 -fill both set txt "" for {set i 1} {$i < 100} {incr i} { append txt "Line $i\n" } set result {} } -body { .t1 insert end $txt .t1 debug 1 set ge [winfo geometry .] scan $ge "%dx%d+%d+%d" width height left top update .t1 sync set negative 0 bind .t1 <> { if {%d < 0} {set negative 1} } # Without the fix for bug 2677890, changing the width of the toplevel # will launch recomputation of the line heights, but will produce negative # number of still remaining outdated lines, which is obviously wrong. # Thus we use this way to check for regression regarding bug 2677890, # i.e. to check that the fix for this bug really is still in. wm geometry . "[expr {$width * 2}]x$height+$left+$top" update .t1 sync set negative } -cleanup { destroy .t1 } -result {0} test textDisp-35.1 {Init value of charHeight - Dancing scrollbar bug 1499165} -setup { pack [text .t1] -fill both -expand y -side left .t insert end "[string repeat a\nb\nc\n 500000]THE END\n" set res {} } -body { .t see 10000.0 after 300 {set fr1 [.t yview] ; set done 1} vwait done after 300 {set fr2 [.t yview] ; set done 1} vwait done lappend res [expr {[lindex $fr1 0] == [lindex $fr2 0]}] lappend res [expr {[lindex $fr1 1] == [lindex $fr2 1]}] } -cleanup { destroy .t1 } -result {1 1} deleteWindows option clear # cleanup cleanupTests return tk8.6.5/tests/panedwindow.test0000644003604700454610000052622112607165315015066 0ustar dgp771div# This file is a Tcl script to test entry widgets in Tk. It is # organized in the standard fashion for Tcl tests. # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands namespace import -force tcltest::test deleteWindows # Panedwindow for tests 1.* panedwindow .p # Buttons for tests 1.33 - 1.52 .p add [button .b] .p add [button .c] test panedwindow-1.1 {configuration options: -background (good)} -body { .p configure -background #ff0000 list [lindex [.p configure -background] 4] [.p cget -background] } -cleanup { .p configure -background [lindex [.p configure -background] 3] } -result {{#ff0000} #ff0000} test panedwindow-1.2 {configuration options: -background (bad)} -body { .p configure -background non-existent } -returnCodes error -result {unknown color name "non-existent"} test panedwindow-1.3 {configuration options: -bd (good)} -body { .p configure -bd 4 list [lindex [.p configure -bd] 4] [.p cget -bd] } -cleanup { .p configure -bd [lindex [.p configure -bd] 3] } -result {4 4} test panedwindow-1.4 {configuration options: -bd (bad)} -body { .p configure -bd badValue } -returnCodes error -result {bad screen distance "badValue"} test panedwindow-1.5 {configuration options: -bg (good)} -body { .p configure -bg #ff0000 list [lindex [.p configure -bg] 4] [.p cget -bg] } -cleanup { .p configure -bg [lindex [.p configure -bg] 3] } -result {{#ff0000} #ff0000} test panedwindow-1.6 {configuration options: -bg (bad)} -body { .p configure -bg non-existent } -returnCodes error -result {unknown color name "non-existent"} test panedwindow-1.7 {configuration options: -borderwidth (good)} -body { .p configure -borderwidth 1.3 list [lindex [.p configure -borderwidth] 4] [.p cget -borderwidth] } -cleanup { .p configure -borderwidth [lindex [.p configure -borderwidth] 3] } -result {1 1} test panedwindow-1.8 {configuration options: -borderwidth (bad)} -body { .p configure -borderwidth badValue } -returnCodes error -result {bad screen distance "badValue"} test panedwindow-1.9 {configuration options: -cursor (good)} -body { .p configure -cursor arrow list [lindex [.p configure -cursor] 4] [.p cget -cursor] } -cleanup { .p configure -cursor [lindex [.p configure -cursor] 3] } -result {arrow arrow} test panedwindow-1.10 {configuration options: -cursor (bad)} -body { .p configure -cursor badValue } -returnCodes error -result {bad cursor spec "badValue"} test panedwindow-1.11 {configuration options: -handlesize (good)} -body { .p configure -handlesize 20 list [lindex [.p configure -handlesize] 4] [.p cget -handlesize] } -cleanup { .p configure -handlesize [lindex [.p configure -handlesize] 3] } -result {20 20} test panedwindow-1.12 {configuration options: -handlesize (bad)} -body { .p configure -handlesize badValue } -returnCodes error -result {bad screen distance "badValue"} test panedwindow-1.13 {configuration options: -height (good)} -body { .p configure -height 20 list [lindex [.p configure -height] 4] [.p cget -height] } -cleanup { .p configure -height [lindex [.p configure -height] 3] } -result {20 20} test panedwindow-1.14 {configuration options: -height (bad)} -body { .p configure -height badValue } -returnCodes error -result {bad screen distance "badValue"} test panedwindow-1.15 {configuration options: -opaqueresize (good)} -body { .p configure -opaqueresize true list [lindex [.p configure -opaqueresize] 4] [.p cget -opaqueresize] } -cleanup { .p configure -opaqueresize [lindex [.p configure -opaqueresize] 3] } -result {1 1} test panedwindow-1.16 {configuration options: -opaqueresize (bad)} -body { .p configure -opaqueresize foo } -returnCodes error -result {expected boolean value but got "foo"} test panedwindow-1.17 {configuration options: -orient (good)} -body { .p configure -orient horizontal list [lindex [.p configure -orient] 4] [.p cget -orient] } -cleanup { .p configure -orient [lindex [.p configure -orient] 3] } -result {horizontal horizontal} test panedwindow-1.18 {configuration options: -orient (bad)} -body { .p configure -orient badValue } -returnCodes error -result {bad orient "badValue": must be horizontal or vertical} test panedwindow-1.19 {configuration options: -proxybackground (good)} -body { .p configure -proxybackground "#f0a0a0" list [lindex [.p configure -proxybackground] 4] [.p cget -proxybackground] } -cleanup { .p configure -proxybackground [lindex [.p configure -proxybackground] 3] } -result {{#f0a0a0} #f0a0a0} test panedwindow-1.20 {configuration options: -proxybackground (bad)} -body { .p configure -proxybackground badValue } -returnCodes error -result {unknown color name "badValue"} test panedwindow-1.21 {configuration options: -proxyborderwidth (good)} -body { .p configure -proxyborderwidth 1.3 list [lindex [.p configure -proxyborderwidth] 4] [.p cget -proxyborderwidth] } -cleanup { .p configure -proxyborderwidth [lindex [.p configure -proxyborderwidth] 3] } -result {1.3 1.3} test panedwindow-1.22 {configuration options: -proxyborderwidth (bad)} -body { .p configure -proxyborderwidth badValue } -returnCodes error -result {bad screen distance "badValue"} test panedwindow-1.23 {configuration options: -proxyrelief (good)} -body { .p configure -proxyrelief groove list [lindex [.p configure -proxyrelief] 4] [.p cget -proxyrelief] } -cleanup { .p configure -proxyrelief [lindex [.p configure -proxyrelief] 3] } -result {groove groove} test panedwindow-1.24 {configuration options: -proxyrelief (bad)} -body { .p configure -proxyrelief 1.5 } -returnCodes error -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken} test panedwindow-1.25 {configuration options: -relief (good)} -body { .p configure -relief groove list [lindex [.p configure -relief] 4] [.p cget -relief] } -cleanup { .p configure -relief [lindex [.p configure -relief] 3] } -result {groove groove} test panedwindow-1.26 {configuration options: -relief (bad)} -body { .p configure -relief 1.5 } -returnCodes error -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken} test panedwindow-1.27 {configuration options: -sashcursor (good)} -body { .p configure -sashcursor arrow list [lindex [.p configure -sashcursor] 4] [.p cget -sashcursor] } -cleanup { .p configure -sashcursor [lindex [.p configure -sashcursor] 3] } -result {arrow arrow} test panedwindow-1.28 {configuration options: -sashcursor (bad)} -body { .p configure -sashcursor badValue } -returnCodes error -result {bad cursor spec "badValue"} test panedwindow-1.29 {configuration options: -sashpad (good)} -body { .p configure -sashpad 1.3 list [lindex [.p configure -sashpad] 4] [.p cget -sashpad] } -cleanup { .p configure -sashpad [lindex [.p configure -sashpad] 3] } -result {1 1} test panedwindow-1.30 {configuration options: -sashpad (bad)} -body { .p configure -sashpad badValue } -returnCodes error -result {bad screen distance "badValue"} test panedwindow-1.31 {configuration options: -sashrelief (good)} -body { .p configure -sashrelief groove list [lindex [.p configure -sashrelief] 4] [.p cget -sashrelief] } -cleanup { .p configure -sashrelief [lindex [.p configure -sashrelief] 3] } -result {groove groove} test panedwindow-1.32 {configuration options: -sashrelief (bad)} -body { .p configure -sashrelief 1.5 } -returnCodes error -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken} test panedwindow-1.33 {configuration options: -sashwidth (good)} -body { .p configure -sashwidth 10 list [lindex [.p configure -sashwidth] 4] [.p cget -sashwidth] } -cleanup { .p configure -sashwidth [lindex [.p configure -sashwidth] 3] } -result {10 10} test panedwindow-1.34 {configuration options: -sashwidth (bad)} -body { .p configure -sashwidth badValue } -returnCodes error -result {bad screen distance "badValue"} test panedwindow-1.35 {configuration options: -showhandle (good)} -body { .p configure -showhandle true list [lindex [.p configure -showhandle] 4] [.p cget -showhandle] } -cleanup { .p configure -showhandle [lindex [.p configure -showhandle] 3] } -result {1 1} test panedwindow-1.36 {configuration options: -showhandle (bad)} -body { .p configure -showhandle foo } -returnCodes error -result {expected boolean value but got "foo"} test panedwindow-1.37 {configuration options: -width (good)} -body { .p configure -width 402 list [lindex [.p configure -width] 4] [.p cget -width] } -cleanup { .p configure -width [lindex [.p configure -width] 3] } -result {402 402} test panedwindow-1.38 {configuration options: -width (bad)} -body { .p configure -width badValue } -returnCodes error -result {bad screen distance "badValue"} test panedwindow-1.39 {configuration options: -after (good)} -body { .p paneconfigure .b -after .c list [lindex [.p paneconfigure .b -after] 4] \ [.p panecget .b -after] } -cleanup { .p paneconfig .b -after [lindex [.p paneconfig .b -after] 3] } -result {.c .c} test panedwindow-1.40 {configuration options: -after (bad)} -body { .p paneconfigure .b -after badValue } -returnCodes error -result {bad window path name "badValue"} test panedwindow-1.41 {configuration options: -before (good)} -body { .p paneconfigure .b -before .c list [lindex [.p paneconfigure .b -before] 4] \ [.p panecget .b -before] } -cleanup { .p paneconfig .b -before [lindex [.p paneconfig .b -before] 3] } -result {.c .c} test panedwindow-1.42 {configuration options: -before (bad)} -body { .p paneconfigure .b -before badValue } -returnCodes error -result {bad window path name "badValue"} test panedwindow-1.43 {configuration options: -height (good)} -body { .p paneconfigure .b -height 10 list [lindex [.p paneconfigure .b -height] 4] \ [.p panecget .b -height] } -cleanup { .p paneconfig .b -height [lindex [.p paneconfig .b -height] 3] } -result {10 10} test panedwindow-1.44 {configuration options: -height (bad)} -body { .p paneconfigure .b -height badValue } -returnCodes error -result {bad screen distance "badValue"} test panedwindow-1.45 {configuration options: -hide (good)} -body { .p paneconfigure .b -hide false list [lindex [.p paneconfigure .b -hide] 4] \ [.p panecget .b -hide] } -cleanup { .p paneconfig .b -hide [lindex [.p paneconfig .b -hide] 3] } -result {0 0} test panedwindow-1.46 {configuration options: -hide (bad)} -body { .p paneconfigure .b -hide foo } -returnCodes error -result {expected boolean value but got "foo"} test panedwindow-1.47 {configuration options: -minsize (good)} -body { .p paneconfigure .b -minsize 10 list [lindex [.p paneconfigure .b -minsize] 4] \ [.p panecget .b -minsize] } -cleanup { .p paneconfig .b -minsize [lindex [.p paneconfig .b -minsize] 3] } -result {10 10} test panedwindow-1.48 {configuration options: -minsize (bad)} -body { .p paneconfigure .b -minsize badValue } -returnCodes error -result {bad screen distance "badValue"} test panedwindow-1.49 {configuration options: -padx (good)} -body { .p paneconfigure .b -padx 1.3 list [lindex [.p paneconfigure .b -padx] 4] \ [.p panecget .b -padx] } -cleanup { .p paneconfig .b -padx [lindex [.p paneconfig .b -padx] 3] } -result {1 1} test panedwindow-1.50 {configuration options: -padx (bad)} -body { .p paneconfigure .b -padx badValue } -returnCodes error -result {bad screen distance "badValue"} test panedwindow-1.51 {configuration options: -pady (good)} -body { .p paneconfigure .b -pady 1.3 list [lindex [.p paneconfigure .b -pady] 4] \ [.p panecget .b -pady] } -cleanup { .p paneconfig .b -pady [lindex [.p paneconfig .b -pady] 3] } -result {1 1} test panedwindow-1.52 {configuration options: -pady (bad)} -body { .p paneconfigure .b -pady badValue } -returnCodes error -result {bad screen distance "badValue"} test panedwindow-1.53 {configuration options: -sticky (good)} -body { .p paneconfigure .b -sticky nsew list [lindex [.p paneconfigure .b -sticky] 4] \ [.p panecget .b -sticky] } -cleanup { .p paneconfig .b -sticky [lindex [.p paneconfig .b -sticky] 3] } -result {nesw nesw} test panedwindow-1.54 {configuration options: -sticky (bad)} -body { .p paneconfigure .b -sticky abcd } -returnCodes error -result {bad stickyness value "abcd": must be a string containing zero or more of n, e, s, and w} test panedwindow-1.55 {configuration options: -stretch (good)} -body { .p paneconfigure .b -stretch alw list [lindex [.p paneconfigure .b -stretch] 4] \ [.p panecget .b -stretch] } -cleanup { .p paneconfig .b -stretch [lindex [.p paneconfig .b -stretch] 3] } -result {always always} test panedwindow-1.56 {configuration options: -stretch (bad)} -body { .p paneconfigure .b -stretch foo } -returnCodes error -result {bad stretch "foo": must be always, first, last, middle, or never} test panedwindow-1.57 {configuration options: -width (good)} -body { .p paneconfigure .b -width 10 list [lindex [.p paneconfigure .b -width] 4] \ [.p panecget .b -width] } -cleanup { .p paneconfig .b -width [lindex [.p paneconfig .b -width] 3] } -result {10 10} test panedwindow-1.58 {configuration options: -width (bad)} -body { .p paneconfigure .b -width badValue } -returnCodes error -result {bad screen distance "badValue"} deleteWindows test panedwindow-2.1 {panedwindow widget command} -setup { deleteWindows } -body { panedwindow .p .p foo } -cleanup { deleteWindows } -returnCodes error -result {bad command "foo": must be add, cget, configure, forget, identify, panecget, paneconfigure, panes, proxy, or sash} test panedwindow-3.1 {panedwindow panes subcommand} -setup { deleteWindows } -body { panedwindow .p .p add [button .b] .p add [button .c] set result [list [.p panes]] .p forget .b lappend result [.p panes] } -cleanup { deleteWindows } -result [list [list .b .c] [list .c]] test panedwindow-4.1 {forget subcommand} -setup { deleteWindows } -body { panedwindow .p .p forget } -cleanup { deleteWindows } -returnCodes error -result {wrong # args: should be ".p forget widget ?widget ...?"} test panedwindow-4.2 {forget subcommand, forget one from start} -setup { deleteWindows } -body { panedwindow .p .p add [button .b] .p add [button .c] set result [list [.p panes]] .p forget .b lappend result [.p panes] } -cleanup { deleteWindows } -result [list {.b .c} .c] test panedwindow-4.3 {forget subcommand, forget one from end} -setup { deleteWindows } -body { panedwindow .p .p add [button .b] .p add [button .c] .p add [button .d] set result [list [.p panes]] .p forget .d update lappend result [.p panes] } -cleanup { deleteWindows } -result [list {.b .c .d} {.b .c}] test panedwindow-4.4 {forget subcommand, forget multiple} -setup { deleteWindows } -body { panedwindow .p .p add [button .b] .p add [button .c] .p add [button .d] set result [list [.p panes]] .p forget .b .c update lappend result [.p panes] } -cleanup { deleteWindows } -result [list {.b .c .d} .d] test panedwindow-4.5 {forget subcommand, panes are unmapped} -setup { deleteWindows } -body { panedwindow .p .p add [button .b] .p add [button .c] pack .p update set result [list [winfo ismapped .b] [winfo ismapped .c]] .p forget .b update lappend result [winfo ismapped .b] [winfo ismapped .c] } -cleanup { deleteWindows } -result [list 1 1 0 1] test panedwindow-4.6 {forget subcommand, changes reqsize of panedwindow} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 4 -showhandle false .p add [frame .f -width 20 -height 20] [frame .g -width 20 -height 20] set result [list [winfo reqwidth .p]] .p forget .f lappend result [winfo reqwidth .p] } -cleanup { deleteWindows } -result [list 44 20] test panedwindow-5.1 {sash subcommand} -setup { deleteWindows } -body { panedwindow .p .p sash } -cleanup { deleteWindows } -returnCodes error -result {wrong # args: should be ".p sash option ?arg ...?"} test panedwindow-5.2 {sash subcommand} -setup { deleteWindows } -body { panedwindow .p .p sash foo } -cleanup { deleteWindows } -returnCodes error -result {bad option "foo": must be coord, dragto, mark, or place} test panedwindow-6.1 {sash coord subcommand, errors} -setup { deleteWindows } -body { panedwindow .p .p sash coord } -cleanup { deleteWindows } -returnCodes error -result {wrong # args: should be ".p sash coord index"} test panedwindow-6.2 {sash coord subcommand, errors} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 4 .p sash coord 0 } -cleanup { deleteWindows } -returnCodes error -result {invalid sash index} test panedwindow-6.3 {sash coord subcommand, errors} -setup { deleteWindows } -body { panedwindow .p .p sash coord foo } -cleanup { deleteWindows } -returnCodes error -result {expected integer but got "foo"} test panedwindow-6.4 {sash coord subcommand sashes correctly placed} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 2 -sashwidth 4 -showhandle false .p add [frame .p.f -width 20 -height 20] \ [frame .p.f2 -width 20 -height 20] \ [frame .p.f3 -width 20 -height 20] .p sash coord 0 } -cleanup { deleteWindows } -result [list 22 0] test panedwindow-6.5 {sash coord subcommand sashes correctly placed} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 2 -sashwidth 4 -showhandle false .p add [frame .p.f -width 20 -height 20] \ [frame .p.f2 -width 20 -height 20] \ [frame .p.f3 -width 20 -height 20] .p sash coord 1 } -cleanup { deleteWindows } -result [list 50 0] test panedwindow-6.6 {sash coord subcommand, sashes correctly placed} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 2 -sashwidth 4 -orient vertical \ -showhandle false .p add [frame .p.f -width 20 -height 20] \ [frame .p.f2 -width 20 -height 20] \ [frame .p.f3 -width 20 -height 20] .p sash coord 0 } -cleanup { deleteWindows } -result [list 0 22] test panedwindow-6.7 {sash coord subcommand, sashes correctly placed} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 2 -sashwidth 4 -orient vertical \ -showhandle false .p add [frame .p.f -width 20 -height 20] \ [frame .p.f2 -width 20 -height 20] \ [frame .p.f3 -width 20 -height 20] .p sash coord 1 } -cleanup { deleteWindows } -result [list 0 50] test panedwindow-6.8 {sash coord subcommand, errors} -setup { deleteWindows } -body { panedwindow .p list [catch {.p sash coord -1} msg] $msg \ [catch {.p sash coord 0} msg] $msg \ [catch {.p sash coord 1} msg] $msg } -cleanup { deleteWindows } -result [list 1 "invalid sash index" 1 "invalid sash index" 1 "invalid sash index"] test panedwindow-6.9 {sash coord subcommand, errors} -setup { deleteWindows } -body { # There are no sashes until you have 2 panes panedwindow .p .p add [frame .p.f] list [catch {.p sash coord -1} msg] $msg \ [catch {.p sash coord 0} msg] $msg \ [catch {.p sash coord 1} msg] $msg } -cleanup { deleteWindows } -result [list 1 "invalid sash index" 1 "invalid sash index" 1 "invalid sash index"] test panedwindow-6.10 {sash coord subcommand, errors} -setup { deleteWindows } -body { # There are no sashes until you have 2 panes panedwindow .p .p add [frame .p.f] [frame .p.f2] list [catch {.p sash coord -1} msg] $msg \ [catch {.p sash coord 0} msg] \ [catch {.p sash coord 1} msg] $msg \ [catch {.p sash coord 2} msg] $msg } -cleanup { deleteWindows } -result [list 1 "invalid sash index" 0 1 "invalid sash index" 1 "invalid sash index"] test panedwindow-7.1 {sash mark subcommand, errors} -setup { deleteWindows } -body { panedwindow .p .p sash mark } -cleanup { deleteWindows } -returnCodes error -result {wrong # args: should be ".p sash mark index ?x y?"} test panedwindow-7.2 {sash mark subcommand, errors} -setup { deleteWindows } -body { panedwindow .p .p sash mark foo } -cleanup { deleteWindows } -returnCodes error -result {expected integer but got "foo"} test panedwindow-7.3 {sash mark subcommand, errors} -setup { deleteWindows } -body { panedwindow .p .p sash mark 0 foo bar } -cleanup { deleteWindows } -returnCodes error -result {invalid sash index} test panedwindow-7.4 {sash mark subcommand, errors} -setup { deleteWindows } -body { panedwindow .p .p add [button .b] [button .c] .p sash mark 0 foo bar } -cleanup { deleteWindows } -returnCodes error -result {expected integer but got "foo"} test panedwindow-7.5 {sash mark subcommand, errors} -setup { deleteWindows } -body { panedwindow .p .p add [button .b] [button .c] .p sash mark 0 0 bar } -cleanup { deleteWindows } -returnCodes error -result {expected integer but got "bar"} test panedwindow-7.6 {sash mark subcommand, mark defaults to 0 0} -setup { deleteWindows } -body { panedwindow .p .p add [button .b] [button .c] .p sash mark 0 } -cleanup { deleteWindows } -result [list 0 0] test panedwindow-7.7 {sash mark subcommand, set mark} -setup { deleteWindows } -body { panedwindow .p .p add [button .b] [button .c] .p sash mark 0 10 10 .p sash mark 0 } -cleanup { deleteWindows } -result [list 10 10] test panedwindow-8.1 {sash dragto subcommand, errors} -setup { deleteWindows } -body { panedwindow .p .p sash dragto } -cleanup { deleteWindows } -returnCodes error -result {wrong # args: should be ".p sash dragto index x y"} test panedwindow-8.2 {sash dragto subcommand, errors} -setup { deleteWindows } -body { panedwindow .p .p sash dragto foo bar baz } -cleanup { deleteWindows } -returnCodes error -result {expected integer but got "foo"} test panedwindow-8.3 {sash dragto subcommand, errors} -setup { deleteWindows } -body { panedwindow .p .p sash dragto 0 foo bar } -cleanup { deleteWindows } -returnCodes error -result {invalid sash index} test panedwindow-8.4 {sash dragto subcommand, errors} -setup { deleteWindows } -body { panedwindow .p .p add [button .b] [button .c] .p sash dragto 0 foo bar } -cleanup { deleteWindows } -returnCodes error -result {expected integer but got "foo"} test panedwindow-8.5 {sash dragto subcommand, errors} -setup { deleteWindows } -body { panedwindow .p .p add [button .b] [button .c] .p sash dragto 0 0 bar } -cleanup { deleteWindows } -returnCodes error -result {expected integer but got "bar"} test panedwindow-9.1 {sash mark/sash dragto interaction} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 4 -showhandle false .p add [frame .f -width 20 -height 20] [button .c -text foobar] .p sash mark 0 10 10 .p sash dragto 0 20 10 .p sash coord 0 } -cleanup { deleteWindows } -result [list 30 0] test panedwindow-9.2 {sash mark/sash dragto interaction} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 4 -orient vertical \ -showhandle false .p add [frame .p.f -width 20 -height 20] [button .p.c -text foobar] .p sash mark 0 10 10 .p sash dragto 0 10 20 .p sash coord 0 } -cleanup { deleteWindows } -result [list 0 30] test panedwindow-9.3 {sash mark/sash dragto, respects minsize} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 4 -showhandle false .p add [frame .f -width 20 -height 20] [button .c] -minsize 15 .p sash mark 0 20 10 .p sash dragto 0 10 10 .p sash coord 0 } -cleanup { deleteWindows } -result [list 15 0] test panedwindow-10.1 {sash place subcommand, errors} -setup { deleteWindows } -body { panedwindow .p .p sash place } -cleanup { deleteWindows } -returnCodes error -result {wrong # args: should be ".p sash place index x y"} test panedwindow-10.2 {sash place subcommand, errors} -setup { deleteWindows } -body { panedwindow .p .p sash place foo bar baz } -cleanup { deleteWindows } -returnCodes error -result {expected integer but got "foo"} test panedwindow-10.3 {sash place subcommand, errors} -setup { deleteWindows } -body { panedwindow .p .p sash place 0 foo bar } -cleanup { deleteWindows } -returnCodes error -result {invalid sash index} test panedwindow-10.4 {sash place subcommand, errors} -setup { deleteWindows } -body { panedwindow .p .p add [button .b] [button .c] .p sash place 0 foo bar } -cleanup { deleteWindows } -returnCodes error -result {expected integer but got "foo"} test panedwindow-10.5 {sash place subcommand, errors} -setup { deleteWindows } -body { panedwindow .p .p add [button .b] [button .c] .p sash place 0 0 bar } -cleanup { deleteWindows } -returnCodes error -result {expected integer but got "bar"} test panedwindow-10.6 {sash place subcommand, moves sash} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 4 .p add [frame .f -width 20 -height 20] [button .c] .p sash place 0 10 0 .p sash coord 0 } -cleanup { deleteWindows } -result [list 10 0] test panedwindow-10.7 {sash place subcommand, moves sash} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 4 -orient vertical .p add [frame .f -width 20 -height 20] [button .c] .p sash place 0 0 10 .p sash coord 0 } -cleanup { deleteWindows } -result [list 0 10] test panedwindow-10.8 {sash place subcommand, respects minsize} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 4 -showhandle false .p add [frame .f -width 20 -height 20] [button .c] -minsize 15 .p sash place 0 10 0 .p sash coord 0 } -cleanup { deleteWindows } -result [list 15 0] test panedwindow-10.9 {sash place subcommand, respects minsize} -setup { deleteWindows } -body { panedwindow .p .p add [frame .f -width 20 -height 20 -bg pink] .p sash place 0 2 0 } -cleanup { deleteWindows } -returnCodes error -result {invalid sash index} test panedwindow-11.1 {moving sash changes size of pane to left} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 4 -showhandle false .p add [frame .f -width 20 -height 20] [button .c -text foobar] -sticky nsew .p sash place 0 30 0 pack .p update winfo width .f } -result 30 test panedwindow-11.2 {moving sash changes size of pane to right} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 .p add [frame .f -width 20 -height 20] [frame .f2 -width 20 -height 20] pack .p update set result [winfo width .f2] .p sash place 0 30 0 update lappend result [winfo width .f2] } -cleanup { deleteWindows } -result {20 10} test panedwindow-11.3 {moving sash does not change reqsize of panedwindow} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 .p add [frame .f -width 20 -height 20] [frame .f2 -width 20 -height 20] .p sash place 0 30 0 winfo reqwidth .p } -result 44 test panedwindow-11.4 {moving sash changes size of pane above} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 \ -orient vertical .p add [frame .f -width 20 -height 10] [button .c -text foobar] -sticky nsew .p sash place 0 0 20 pack .p update set result [winfo height .f] set result } -result 20 test panedwindow-11.5 {moving sash changes size of pane below} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 \ -orient vertical .p add [frame .f -width 20 -height 10] [frame .f2 -width 20 -height 10] pack .p update set result [winfo height .f2] .p sash place 0 0 15 update lappend result [winfo height .f2] set result } -cleanup { deleteWindows } -result {10 5} test panedwindow-11.6 {moving sash does not change reqsize of panedwindow} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 \ -orient vertical .p add [frame .f -width 20 -height 10] [frame .f2 -width 20 -height 10] set result [winfo reqheight .p] .p sash place 0 0 20 lappend result [winfo reqheight .p] set result } -cleanup { deleteWindows } -result [list 24 24] test panedwindow-11.7 {moving sash does not alter reqsize of widget} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 \ -orient vertical .p add [frame .f -width 20 -height 10] [frame .f2 -width 20 -height 10] set result [winfo reqheight .f] .p sash place 0 0 20 lappend result [winfo reqheight .f] } -cleanup { deleteWindows } -result [list 10 10] test panedwindow-11.8 {moving sash restricted to minsize} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 .p add [frame .f -width 20 -height 20] [button .c] -minsize 15 .p sash place 0 10 0 pack .p update winfo width .f } -result 15 test panedwindow-11.9 {moving sash restricted to minsize} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 \ -orient vertical .p add [frame .f -width 20 -height 30] [button .c] -minsize 10 .p sash place 0 0 5 pack .p update winfo height .f } -result 10 test panedwindow-11.10 {moving sash in unmapped window restricted to reqsize} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 .p add [frame .f -width 20 -height 30] [frame .f2 -width 20 -height 20] set result [list [.p sash coord 0]] .p sash place 0 100 0 lappend result [.p sash coord 0] } -cleanup { deleteWindows } -result [list {20 0} {40 0}] test panedwindow-11.11 {moving sash right pushes other sashes} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 .p add [frame .f -width 20 -height 30] [frame .f2 -width 20 -height 20] \ [frame .f3 -width 20 -height 30] .p sash place 0 80 0 list [.p sash coord 0] [.p sash coord 1] } -cleanup { deleteWindows } -result {{60 0} {64 0}} test panedwindow-11.12 {moving sash left pushes other sashes} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 .p add [frame .f -width 20 -height 30] [frame .f2 -width 20 -height 20] \ [frame .f3 -width 20 -height 30] .p sash place 1 0 0 list [.p sash coord 0] [.p sash coord 1] } -cleanup { deleteWindows } -result {{0 0} {4 0}} test panedwindow-11.13 {move sash in mapped window restricted to visible win} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 .p add [frame .f -width 20 -height 30] [frame .f2 -width 20 -height 20] \ [frame .f3 -width 20 -height 30] place .p -width 50 update .p sash place 1 100 0 update .p sash coord 1 } -cleanup { deleteWindows } -result {46 0} test panedwindow-11.14 {move sash in mapped window restricted to visible win} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 .p add [frame .f -width 20 -height 30] [frame .f2 -width 20 -height 20] \ [frame .f3 -width 20 -height 30] place .p -width 100 update .p sash place 1 200 0 update .p sash coord 1 } -cleanup { deleteWindows } -result {96 0} test panedwindow-11.15 {moving sash into "virtual" space on last pane increases reqsize} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 .p add [frame .f -width 20 -height 30] [frame .f2 -width 20 -height 20] \ [frame .f3 -width 20 -height 30] place .p -width 100 set result [winfo reqwidth .p] update .p sash place 1 200 0 update lappend result [winfo reqwidth .p] } -cleanup { deleteWindows } -result {68 100} test panedwindow-12.1 {horizontal panedwindow lays out widgets properly} -setup { deleteWindows set result {} } -body { panedwindow .p -showhandle false -borderwidth 2 -sashpad 2 -sashwidth 2 foreach win {.p.f .p.f2 .p.f3} {.p add [frame $win -width 20 -height 10]} pack .p update foreach w [.p panes] {lappend result [winfo x $w] [winfo y $w]} return $result } -cleanup { deleteWindows } -result [list 2 2 28 2 54 2] test panedwindow-12.2 {vertical panedwindow lays out widgets properly} -setup { deleteWindows set result {} } -body { panedwindow .p -showhandle false -borderwidth 2 -sashpad 2 -sashwidth 2 \ -orient vertical foreach win {.p.f .p.f2 .p.f3} {.p add [frame $win -width 20 -height 10]} pack .p update foreach w [.p panes] {lappend result [winfo x $w] [winfo y $w]} return $result } -cleanup { deleteWindows } -result [list 2 2 2 18 2 34] test panedwindow-12.3 {horizontal panedwindow lays out widgets properly} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 foreach {win color} {.p.f blue .p.f2 green} { .p add [frame $win -width 20 -height 20 -bg $color] -padx 10 -pady 5 \ -sticky "" } pack .p update set result [list [winfo reqwidth .p] [winfo reqheight .p]] foreach win {.p.f .p.f2} {lappend result [winfo x $win] [winfo y $win]} .p paneconfigure .p.f -padx 0 -pady 0 update lappend result [winfo reqwidth .p] [winfo reqheight .p] foreach win {.p.f .p.f2} {lappend result [winfo x $win] [winfo y $win]} return $result } -cleanup { deleteWindows } -result [list 80 30 10 5 50 5 60 30 0 5 30 5] test panedwindow-12.4 {vertical panedwindow lays out widgets properly} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 \ -orient vertical foreach win {.p.f .p.f2} { .p add [frame $win -width 20 -height 20] -padx 10 -pady 5 -sticky "" } pack .p update set result [list [winfo reqwidth .p] [winfo reqheight .p]] foreach win {.p.f .p.f2} {lappend result [winfo x $win] [winfo y $win]} .p paneconfigure .p.f -padx 0 -pady 0 update lappend result [winfo reqwidth .p] [winfo reqheight .p] foreach win {.p.f .p.f2} {lappend result [winfo x $win] [winfo y $win]} return $result } -cleanup { deleteWindows } -result [list 40 60 10 5 10 35 40 50 10 0 10 25] test panedwindow-12.5 {panedwindow respects reqsize of panes when possible} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 .p add [frame .p.f -width 20 -height 20] -sticky "" place .p -width 40 update set result [list [winfo width .p.f]] .p.f configure -width 30 update lappend result [winfo width .p.f] } -cleanup { deleteWindows } -result [list 20 30] test panedwindow-12.6 {panedwindow takes explicit widget width over reqwidth} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 .p add [frame .p.f -width 20 -height 20] -width 20 -sticky "" place .p -width 40 update set result [list [winfo width .p.f]] .p.f configure -width 30 update lappend result [winfo width .p.f] } -cleanup { deleteWindows } -result [list 20 20] test panedwindow-12.7 {horizontal panedwindow reqheight is max slave height} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 .p add [frame .p.f -width 20 -height 20] [frame .p.f2 -width 20 -height 20] set result [winfo reqheight .p] .p.f config -height 40 lappend result [winfo reqheight .p] } -cleanup { deleteWindows } -result {20 40} test panedwindow-12.8 {horizontal panedwindow reqheight is max slave height} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 foreach win {.p.f .p.f2} {.p add [frame $win -width 20 -height 20]} .p paneconfigure .p.f -height 15 set result [winfo reqheight .p] .p.f config -height 40 lappend result [winfo reqheight .p] } -cleanup { deleteWindows } -result {20 20} test panedwindow-12.9 {panedwindow pane width overrides widget width} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 foreach win {.p.f .p.f2} {.p add [frame $win -width 20 -height 20]} .p sash place 0 10 0 pack .p update set result [winfo width .p.f] .p paneconfigure .p.f -width 30 lappend result [winfo width .p.f] } -cleanup { deleteWindows } -result [list 10 10] test panedwindow-12.10 {panedwindow respects reqsize of panes when possible} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 .p add [frame .p.f -width 20 -height 20] -sticky "" place .p -height 40 update set result [list [winfo height .p.f]] .p.f configure -height 30 update lappend result [winfo height .p.f] } -cleanup { deleteWindows } -result [list 20 30] test panedwindow-12.11 {panedwindow takes explicit height over reqheight} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 .p add [frame .p.f -width 20 -height 20] -height 20 -sticky "" place .p -height 40 update set result [list [winfo height .p.f]] .p.f configure -height 30 update lappend result [winfo height .p.f] } -cleanup { deleteWindows } -result [list 20 20] test panedwindow-12.12 {vertical panedwindow reqwidth is max slave width} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 \ -orient vertical .p add [frame .p.f -width 20 -height 20] [frame .p.f2 -width 20 -height 20] set result [winfo reqwidth .p] .p.f config -width 40 lappend result [winfo reqwidth .p] } -cleanup { deleteWindows } -result {20 40} test panedwindow-12.13 {vertical panedwindow reqwidth is max slave width} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 \ -orient vertical foreach win {.p.f .p.f2} {.p add [frame $win -width 20 -height 20]} .p paneconfigure .p.f -width 15 set result [winfo reqwidth .p] .p.f config -width 40 lappend result [winfo reqwidth .p] } -cleanup { deleteWindows } -result {20 20} test panedwindow-12.14 {panedwindow pane height overrides widget width} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 \ -orient vertical foreach win {.p.f .p.f2} {.p add [frame $win -width 20 -height 20]} .p sash place 0 0 10 pack .p update set result [winfo height .p.f] .p paneconfigure .p.f -height 30 lappend result [winfo height .p.f] } -cleanup { deleteWindows } -result [list 10 10] test panedwindow-13.1 {PanestructureProc, widget yields managements} -setup { deleteWindows } -body { # Check that the panedwindow correctly yields geometry management of # a slave when the slave is destroyed. # This test should not cause a core dump, and it should not cause # a memory leak. panedwindow .p .p add [button .b] destroy .p pack .b destroy .b set result "" } -result {} test panedwindow-13.2 {PanedWindowLostSlaveProc, widget yields management} -setup { deleteWindows } -body { # Check that the paned window correctly yields geometry management of # a slave when some other geometry manager steals the slave from us. # This test should not cause a core dump, and it should not cause a # memory leak. panedwindow .p .p add [button .b] pack .p update pack .b update set result [.p panes] destroy .p .b set result } -result {} test panedwindow-14.1 {panedwindow sticky settings} -setup { deleteWindows } -body { panedwindow .p -showhandle false .p add [button .b] .p paneconfigure .b -sticky n .p panecget .b -sticky } -cleanup { deleteWindows } -result {n} test panedwindow-14.2 {panedwindow sticky settings} -setup { deleteWindows } -body { panedwindow .p -showhandle false .p add [button .b] .p paneconfigure .b -sticky s .p panecget .b -sticky } -cleanup { deleteWindows } -result {s} test panedwindow-14.3 {panedwindow sticky settings} -setup { deleteWindows } -body { panedwindow .p -showhandle false .p add [button .b] .p paneconfigure .b -sticky e .p panecget .b -sticky } -cleanup { deleteWindows } -result {e} test panedwindow-14.4 {panedwindow sticky settings} -setup { deleteWindows } -body { panedwindow .p -showhandle false .p add [button .b] .p paneconfigure .b -sticky w .p panecget .b -sticky } -cleanup { deleteWindows } -result {w} test panedwindow-14.5 {panedwindow sticky settings} -setup { deleteWindows } -body { panedwindow .p -showhandle false .p add [button .b] .p paneconfigure .b -sticky sn .p panecget .b -sticky } -cleanup { deleteWindows } -result {ns} test panedwindow-14.6 {panedwindow sticky settings} -setup { deleteWindows } -body { panedwindow .p -showhandle false .p add [button .b] .p paneconfigure .b -sticky ns .p panecget .b -sticky } -cleanup { deleteWindows } -result {ns} test panedwindow-14.7 {panedwindow sticky settings} -setup { deleteWindows } -body { panedwindow .p -showhandle false .p add [button .b] .p paneconfigure .b -sticky en .p panecget .b -sticky } -cleanup { deleteWindows } -result {ne} test panedwindow-14.8 {panedwindow sticky settings} -setup { deleteWindows } -body { panedwindow .p -showhandle false .p add [button .b] .p paneconfigure .b -sticky ne .p panecget .b -sticky } -cleanup { deleteWindows } -result {ne} test panedwindow-14.9 {panedwindow sticky settings} -setup { deleteWindows } -body { panedwindow .p -showhandle false .p add [button .b] .p paneconfigure .b -sticky wn .p panecget .b -sticky } -cleanup { deleteWindows } -result {nw} test panedwindow-14.10 {panedwindow sticky settings} -setup { deleteWindows } -body { panedwindow .p -showhandle false .p add [button .b] .p paneconfigure .b -sticky nw .p panecget .b -sticky } -cleanup { deleteWindows } -result {nw} test panedwindow-14.11 {panedwindow sticky settings} -setup { deleteWindows } -body { panedwindow .p -showhandle false .p add [button .b] .p paneconfigure .b -sticky esn .p panecget .b -sticky } -cleanup { deleteWindows } -result {nes} test panedwindow-14.12 {panedwindow sticky settings} -setup { deleteWindows } -body { panedwindow .p -showhandle false .p add [button .b] .p paneconfigure .b -sticky nse .p panecget .b -sticky } -cleanup { deleteWindows } -result {nes} test panedwindow-14.13 {panedwindow sticky settings} -setup { deleteWindows } -body { panedwindow .p -showhandle false .p add [button .b] .p paneconfigure .b -sticky nsw .p panecget .b -sticky } -cleanup { deleteWindows } -result {nsw} test panedwindow-14.14 {panedwindow sticky settings} -setup { deleteWindows } -body { panedwindow .p -showhandle false .p add [button .b] .p paneconfigure .b -sticky nsew .p panecget .b -sticky } -cleanup { deleteWindows } -result {nesw} test panedwindow-14.15 {panedwindow sticky settings} -setup { deleteWindows } -body { panedwindow .p -showhandle false .p add [button .b] .p paneconfigure .b -sticky "" .p panecget .b -sticky } -cleanup { deleteWindows } -result {} test panedwindow-15.1 {panedwindow sticky works} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 .p add [frame .p.f -height 20 -width 20 -bg red] -sticky {} place .p -width 40 -height 40 update list {} [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f] } -cleanup { deleteWindows } -result {{} 10 10 20 20} test panedwindow-15.2 {panedwindow sticky works} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 .p add [frame .p.f -height 20 -width 20 -bg red] -sticky n place .p -width 40 -height 40 update list n [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f] } -cleanup { deleteWindows } -result {n 10 0 20 20} test panedwindow-15.3 {panedwindow sticky works} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 .p add [frame .p.f -height 20 -width 20 -bg red] -sticky s place .p -width 40 -height 40 update list s [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f] } -cleanup { deleteWindows } -result {s 10 20 20 20} test panedwindow-15.4 {panedwindow sticky works} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 .p add [frame .p.f -height 20 -width 20 -bg red] -sticky e place .p -width 40 -height 40 update list e [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f] } -cleanup { deleteWindows } -result {e 20 10 20 20} test panedwindow-15.5 {panedwindow sticky works} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 .p add [frame .p.f -height 20 -width 20 -bg red] -sticky w place .p -width 40 -height 40 update list w [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f] } -cleanup { deleteWindows } -result {w 0 10 20 20} test panedwindow-15.6 {panedwindow sticky works} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 .p add [frame .p.f -height 20 -width 20 -bg red] -sticky ns place .p -width 40 -height 40 update list ns [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f] } -cleanup { deleteWindows } -result {ns 10 0 20 40} test panedwindow-15.7 {panedwindow sticky works} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 .p add [frame .p.f -height 20 -width 20 -bg red] -sticky ew place .p -width 40 -height 40 update list ew [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f] } -cleanup { deleteWindows } -result {ew 0 10 40 20} test panedwindow-15.8 {panedwindow sticky works} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 .p add [frame .p.f -height 20 -width 20 -bg red] -sticky nw place .p -width 40 -height 40 update list nw [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f] } -cleanup { deleteWindows } -result {nw 0 0 20 20} test panedwindow-15.9 {panedwindow sticky works} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 .p add [frame .p.f -height 20 -width 20 -bg red] -sticky ne place .p -width 40 -height 40 update list ne [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f] } -cleanup { deleteWindows } -result {ne 20 0 20 20} test panedwindow-15.10 {panedwindow sticky works} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 .p add [frame .p.f -height 20 -width 20 -bg red] -sticky se place .p -width 40 -height 40 update list se [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f] } -cleanup { deleteWindows } -result {se 20 20 20 20} test panedwindow-15.11 {panedwindow sticky works} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 .p add [frame .p.f -height 20 -width 20 -bg red] -sticky sw place .p -width 40 -height 40 update list sw [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f] } -cleanup { deleteWindows } -result {sw 0 20 20 20} test panedwindow-15.12 {panedwindow sticky works} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 .p add [frame .p.f -height 20 -width 20 -bg red] -sticky nse place .p -width 40 -height 40 update list nse [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f] } -cleanup { deleteWindows } -result {nse 20 0 20 40} test panedwindow-15.13 {panedwindow sticky works} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 .p add [frame .p.f -height 20 -width 20 -bg red] -sticky nsw place .p -width 40 -height 40 update list nsw [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f] } -cleanup { deleteWindows } -result {nsw 0 0 20 40} test panedwindow-15.14 {panedwindow sticky works} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 .p add [frame .p.f -height 20 -width 20 -bg red] -sticky sew place .p -width 40 -height 40 update list sew [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f] } -cleanup { deleteWindows } -result {sew 0 20 40 20} test panedwindow-15.15 {panedwindow sticky works} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 .p add [frame .p.f -height 20 -width 20 -bg red] -sticky new place .p -width 40 -height 40 update list new [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f] } -cleanup { deleteWindows } -result {new 0 0 40 20} test panedwindow-15.16 {panedwindow sticky works} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 .p add [frame .p.f -height 20 -width 20 -bg red] -sticky news place .p -width 40 -height 40 update list news [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f] } -cleanup { deleteWindows } -result {news 0 0 40 40} test panedwindow-16.1 {setting minsize when pane is too small snaps width} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 .p add [frame .p.f -height 20 -width 20 -bg red] set result [winfo reqwidth .p] .p paneconfigure .p.f -minsize 40 lappend result [winfo reqwidth .p] } -cleanup { deleteWindows } -result [list 20 40] test panedwindow-17.1 {MoveSash, move right} -setup { deleteWindows set result {} } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 foreach w {.f1 .f2} c {red blue} { .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew } # Get the requested width of the paned window lappend result [winfo reqwidth .p] .p sash place 0 30 0 # Get the reqwidth again, to make sure it hasn't changed lappend result [winfo reqwidth .p] # Check that the sash moved lappend result [.p sash coord 0] } -cleanup { deleteWindows } -result [list 42 42 {30 0}] test panedwindow-17.2 {MoveSash, move right (unmapped) clipped by reqwidth} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 foreach w {.f1 .f2} c {red blue} { .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew } .p sash place 0 100 0 # Get the new sash coord; it should be clipped by the reqwidth of # the panedwindow. .p sash coord 0 } -cleanup { deleteWindows } -result [list 40 0] test panedwindow-17.3 {MoveSash, move right (mapped, width < reqwidth) clipped by width} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 foreach w {.f1 .f2} c {red blue} { .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew } # Put the panedwindow up on the display and give it a width < reqwidth place .p -x 0 -y 0 -width 32 update .p sash place 0 100 0 # Get the new sash coord; it should be clipped by the visible width of # the panedwindow. .p sash coord 0 } -cleanup { deleteWindows } -result [list 30 0] test panedwindow-17.4 {MoveSash, move right (mapped, width > reqwidth) clipped by width} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 foreach w {.f1 .f2} c {red blue} { .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew } # Put the panedwindow up on the display and give it a width > reqwidth place .p -x 0 -y 0 -width 102 update .p sash place 0 200 0 # Get the new sash coord; it should be clipped by the visible width of # the panedwindow. .p sash coord 0 } -cleanup { deleteWindows } -result [list 100 0] test panedwindow-17.5 {MoveSash, move right respects minsize} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 foreach w {.f1 .f2} c {red blue} { .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10 } .p sash place 0 100 0 # Get the new sash coord; it should have moved as far as possible while # respecting minsizes. .p sash coord 0 } -cleanup { deleteWindows } -result [list 30 0] test panedwindow-17.6 {MoveSash, move right respects minsize} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 foreach w {.f1 .f2 .f3} c {red blue} { .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10 } .p sash place 0 100 0 # Get the new sash coord; it should have moved as far as possible. .p sash coord 0 } -cleanup { deleteWindows } -result [list 40 0] test panedwindow-17.7 {MoveSash, move right pushes other sashes} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 foreach w {.f1 .f2 .f3} c {red blue} { .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew } .p sash place 0 100 0 # Get the new sash coord; it should have moved as far as possible while # respecting minsizes. .p sash coord 1 } -cleanup { deleteWindows } -result [list 62 0] test panedwindow-17.8 {MoveSash, move right pushes other sashes, respects minsize} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 foreach w {.f1 .f2 .f3} c {red blue} { .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10 } .p sash place 0 100 0 # Get the new sash coord; it should have moved as far as possible while # respecting minsizes. .p sash coord 1 } -cleanup { deleteWindows } -result [list 52 0] test panedwindow-17.9 {MoveSash, move right respects minsize, exludes pad} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 foreach w {.f1 .f2 .f3} c {red blue} { .p add [frame $w -height 20 -width 20 -bg $c] \ -sticky nsew -minsize 10 -padx 5 } .p sash place 0 100 0 # Get the new sash coord; it should have moved as far as possible, # respecting minsizes. .p sash coord 0 } -cleanup { deleteWindows } -result [list 50 0] test panedwindow-17.10 {MoveSash, move right, negative minsize becomes 0} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 foreach w {.f1 .f2 .f3} c {red blue} { .p add [frame $w -height 20 -width 20 -bg $c] \ -sticky nsew -minsize -50 } .p sash place 0 50 0 # Get the new sash coord; it should have moved as far as possible, # respecting minsizes. list [.p sash coord 0] [.p sash coord 1] } -cleanup { deleteWindows } -result [list [list 50 0] [list 52 0]] test panedwindow-17.11 {MoveSash, move left} -setup { deleteWindows } -body { set result {} panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 foreach w {.f1 .f2} c {red blue} { .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew } # Get the requested width of the paned window lappend result [winfo reqwidth .p] .p sash place 0 10 0 # Get the reqwidth again, to make sure it hasn't changed lappend result [winfo reqwidth .p] # Check that the sash moved lappend result [.p sash coord 0] } -cleanup { deleteWindows } -result [list 42 42 {10 0}] test panedwindow-17.12 {MoveSash, move left, can't move outside of window} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 foreach w {.f1 .f2} c {red blue} { .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew } .p sash place 0 -100 0 # Get the new sash coord; it should be clipped by the reqwidth of # the panedwindow. .p sash coord 0 } -cleanup { deleteWindows } -result [list 0 0] test panedwindow-17.13 {MoveSash, move left respects minsize} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 foreach w {.f1 .f2} c {red blue} { .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10 } .p sash place 0 0 0 # Get the new sash coord; it should have moved as far as possible while # respecting minsizes. .p sash coord 0 } -cleanup { deleteWindows } -result [list 10 0] test panedwindow-17.14 {MoveSash, move left respects minsize} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 foreach w {.f1 .f2 .f3} c {red blue} { .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10 } .p sash place 1 0 0 # Get the new sash coord; it should have moved as far as possible. .p sash coord 1 } -cleanup { deleteWindows } -result [list 22 0] test panedwindow-17.15 {MoveSash, move left pushes other sashes} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 foreach w {.f1 .f2 .f3} c {red blue} { .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew } .p sash place 1 0 0 # Get the new sash coord; it should have moved as far as possible while # respecting minsizes. .p sash coord 0 } -cleanup { deleteWindows } -result [list 0 0] test panedwindow-17.16 {MoveSash, move left pushes other sashes, respects minsize} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 foreach w {.f1 .f2 .f3} c {red blue} { .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10 } .p sash place 1 0 0 # Get the new sash coord; it should have moved as far as possible while # respecting minsizes. .p sash coord 0 } -cleanup { deleteWindows } -result [list 10 0] test panedwindow-17.17 {MoveSash, move left respects minsize, exludes pad} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 foreach w {.f1 .f2 .f3} c {red blue} { .p add [frame $w -height 20 -width 20 -bg $c] \ -sticky nsew -minsize 10 -padx 5 } .p sash place 1 0 0 # Get the new sash coord; it should have moved as far as possible, # respecting minsizes. .p sash coord 1 } -cleanup { deleteWindows } -result [list 42 0] test panedwindow-17.18 {MoveSash, move left, negative minsize becomes 0} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 foreach w {.f1 .f2 .f3} c {red blue green} { .p add [frame $w -height 20 -width 20 -bg $c] \ -sticky nsew -minsize -50 } .p sash place 1 10 0 # Get the new sash coord; it should have moved as far as possible, # respecting minsizes. list [.p sash coord 0] [.p sash coord 1] } -cleanup { deleteWindows } -result [list [list 8 0] [list 10 0]] test panedwindow-18.1 {MoveSash, move down} -setup { deleteWindows } -body { set result {} panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical foreach w {.f1 .f2} c {red blue} { .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew } # Get the requested width of the paned window lappend result [winfo reqheight .p] .p sash place 0 0 30 # Get the reqwidth again, to make sure it hasn't changed lappend result [winfo reqheight .p] # Check that the sash moved lappend result [.p sash coord 0] } -cleanup { deleteWindows } -result [list 42 42 {0 30}] test panedwindow-18.2 {MoveSash, move down (unmapped) clipped by reqheight} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical foreach w {.f1 .f2} c {red blue} { .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew } .p sash place 0 0 100 # Get the new sash coord; it should be clipped by the reqheight of # the panedwindow. .p sash coord 0 } -cleanup { deleteWindows } -result [list 0 40] test panedwindow-18.3 {MoveSash, move down (mapped, height < reqheight) clipped by height} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical foreach w {.f1 .f2} c {red blue} { .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew } # Put the panedwindow up on the display and give it a height < reqheight place .p -x 0 -y 0 -height 32 update .p sash place 0 0 100 # Get the new sash coord; it should be clipped by the visible height of # the panedwindow. .p sash coord 0 } -cleanup { deleteWindows } -result [list 0 30] test panedwindow-18.4 {MoveSash, move down (mapped, height > reqheight) clipped by height} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical foreach w {.f1 .f2} c {red blue} { .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew } # Put the panedwindow up on the display and give it a width > reqwidth place .p -x 0 -y 0 -height 102 update .p sash place 0 0 200 # Get the new sash coord; it should be clipped by the visible width of # the panedwindow. .p sash coord 0 } -cleanup { deleteWindows } -result [list 0 100] test panedwindow-18.5 {MoveSash, move down respects minsize} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical foreach w {.f1 .f2} c {red blue} { .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10 } .p sash place 0 0 100 # Get the new sash coord; it should have moved as far as possible while # respecting minsizes. .p sash coord 0 } -cleanup { deleteWindows } -result [list 0 30] test panedwindow-18.6 {MoveSash, move down respects minsize} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical foreach w {.f1 .f2 .f3} c {red blue} { .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10 } .p sash place 0 0 100 # Get the new sash coord; it should have moved as far as possible while # respecting minsizes. .p sash coord 0 } -cleanup { deleteWindows } -result [list 0 40] test panedwindow-18.7 {MoveSash, move down pushes other sashes} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical foreach w {.f1 .f2 .f3} c {red blue} { .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew } .p sash place 0 0 100 # Get the new sash coord; it should have moved as far as possible while # respecting minsizes. .p sash coord 1 } -cleanup { deleteWindows } -result [list 0 62] test panedwindow-18.8 {MoveSash, move down pushes other sashes, respects minsize} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical foreach w {.f1 .f2 .f3} c {red blue} { .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10 } .p sash place 0 0 100 # Get the new sash coord; it should have moved as far as possible while # respecting minsizes. .p sash coord 1 } -cleanup { deleteWindows } -result [list 0 52] test panedwindow-18.9 {MoveSash, move down respects minsize, exludes pad} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical foreach w {.f1 .f2 .f3} c {red blue} { .p add [frame $w -height 20 -width 20 -bg $c] \ -sticky nsew -minsize 10 -pady 5 } .p sash place 0 0 100 # Get the new sash coord; it should have moved as far as possible, # respecting minsizes. .p sash coord 0 } -cleanup { deleteWindows } -result [list 0 50] test panedwindow-18.10 {MoveSash, move right, negative minsize becomes 0} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical foreach w {.f1 .f2 .f3} c {red blue} { .p add [frame $w -height 20 -width 20 -bg $c] \ -sticky nsew -minsize -50 } .p sash place 0 0 50 # Get the new sash coord; it should have moved as far as possible, # respecting minsizes. list [.p sash coord 0] [.p sash coord 1] } -cleanup { deleteWindows } -result [list [list 0 50] [list 0 52]] test panedwindow-18.11 {MoveSash, move up} -setup { deleteWindows } -body { set result {} panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical foreach w {.f1 .f2} c {red blue} { .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew } # Get the requested width of the paned window lappend result [winfo reqheight .p] .p sash place 0 0 10 # Get the reqwidth again, to make sure it hasn't changed lappend result [winfo reqheight .p] # Check that the sash moved lappend result [.p sash coord 0] } -cleanup { deleteWindows } -result [list 42 42 {0 10}] test panedwindow-18.12 {MoveSash, move up, can't move outside of window} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical foreach w {.f1 .f2} c {red blue} { .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew } .p sash place 0 0 -100 # Get the new sash coord; it should be clipped by the reqwidth of # the panedwindow. .p sash coord 0 } -cleanup { deleteWindows } -result [list 0 0] test panedwindow-18.13 {MoveSash, move up respects minsize} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical foreach w {.f1 .f2} c {red blue} { .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10 } .p sash place 0 0 0 # Get the new sash coord; it should have moved as far as possible while # respecting minsizes. .p sash coord 0 } -cleanup { deleteWindows } -result [list 0 10] test panedwindow-18.14 {MoveSash, move up respects minsize} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical foreach w {.f1 .f2 .f3} c {red blue} { .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10 } .p sash place 1 0 0 # Get the new sash coord; it should have moved as far as possible. .p sash coord 1 } -cleanup { deleteWindows } -result [list 0 22] test panedwindow-18.15 {MoveSash, move up pushes other sashes} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical foreach w {.f1 .f2 .f3} c {red blue} { .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew } .p sash place 1 0 0 # Get the new sash coord; it should have moved as far as possible while # respecting minsizes. .p sash coord 0 } -cleanup { deleteWindows } -result [list 0 0] test panedwindow-18.16 {MoveSash, move up pushes other sashes, respects minsize} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical foreach w {.f1 .f2 .f3} c {red blue} { .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10 } .p sash place 1 0 0 # Get the new sash coord; it should have moved as far as possible while # respecting minsizes. .p sash coord 0 } -cleanup { deleteWindows } -result [list 0 10] test panedwindow-18.17 {MoveSash, move up respects minsize, exludes pad} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical foreach w {.f1 .f2 .f3} c {red blue} { .p add [frame $w -height 20 -width 20 -bg $c] \ -sticky nsew -minsize 10 -pady 5 } .p sash place 1 0 0 # Get the new sash coord; it should have moved as far as possible, # respecting minsizes. .p sash coord 1 } -cleanup { deleteWindows } -result [list 0 42] test panedwindow-18.18 {MoveSash, move up, negative minsize becomes 0} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical foreach w {.f1 .f2 .f3} c {red blue green} { .p add [frame $w -height 20 -width 20 -bg $c] \ -sticky nsew -minsize -50 } .p sash place 1 0 10 # Get the new sash coord; it should have moved as far as possible, # respecting minsizes. list [.p sash coord 0] [.p sash coord 1] } -cleanup { deleteWindows } -result [list [list 0 8] [list 0 10]] # The following tests check that the panedwindow is correctly computing its # geometry based on the various configuration options that can affect the # geometry. test panedwindow-19.1 {ComputeGeometry, reqheight taken from widgets} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] } set result [list [list [winfo reqwidth .p] [winfo reqheight .p]]] .f3 configure -height 40 lappend result [list [winfo reqwidth .p] [winfo reqheight .p]] } -cleanup { deleteWindows } -result [list [list 60 20] [list 60 40]] test panedwindow-19.2 {ComputeGeometry, reqheight taken from widgets} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] } set result [list [list [winfo reqwidth .p] [winfo reqheight .p]]] .p paneconfigure .f3 -height 40 lappend result [list [winfo reqwidth .p] [winfo reqheight .p]] } -cleanup { deleteWindows } -result [list [list 60 20] [list 60 40]] test panedwindow-19.3 {ComputeGeometry, reqheight taken from widgets} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] -pady 20 } set result [list [list [winfo reqwidth .p] [winfo reqheight .p]]] .p paneconfigure .f3 -height 40 lappend result [list [winfo reqwidth .p] [winfo reqheight .p]] } -cleanup { deleteWindows } -result [list [list 60 60] [list 60 80]] test panedwindow-19.4 {ComputeGeometry, reqwidth taken from widgets} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 \ -orient vertical foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] } set result [list [list [winfo reqwidth .p] [winfo reqheight .p]]] .f3 configure -width 40 lappend result [list [winfo reqwidth .p] [winfo reqheight .p]] } -cleanup { deleteWindows } -result [list [list 20 60] [list 40 60]] test panedwindow-19.5 {ComputeGeometry, reqwidth taken from widgets} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 \ -orient vertical foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] } set result [list [list [winfo reqwidth .p] [winfo reqheight .p]]] .p paneconfigure .f3 -width 40 lappend result [list [winfo reqwidth .p] [winfo reqheight .p]] } -cleanup { deleteWindows } -result [list [list 20 60] [list 40 60]] test panedwindow-19.6 {ComputeGeometry, reqwidth taken from widgets} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 \ -orient vertical foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] -padx 20 } set result [list [list [winfo reqwidth .p] [winfo reqheight .p]]] .p paneconfigure .f3 -width 40 lappend result [list [winfo reqwidth .p] [winfo reqheight .p]] } -cleanup { deleteWindows } -result [list [list 60 60] [list 80 60]] test panedwindow-19.7 {ComputeGeometry, one slave, reqsize set properly} -setup { deleteWindows } -body { # With just one slave, sashpad and sashwidth should not # affect the panedwindow's geometry, since no sash should # ever be drawn. panedwindow .p -borderwidth 0 -sashpad 0 \ -sashwidth 0 -handlesize 6 -showhandle 0 .p add [frame .p.f -width 20 -height 20 -bg red] -padx 0 -sticky "" list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {20 20} test panedwindow-19.8 {ComputeGeometry, three panes, reqsize set properly} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 0 \ -sashwidth 0 -handlesize 6 -showhandle 0 foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] -sticky "" } list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {60 20} test panedwindow-19.9 {ComputeGeometry, sash coords} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 0 \ -sashwidth 0 -handlesize 6 -showhandle 0 foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [.p sash coord 0] [.p sash coord 1] } -cleanup { deleteWindows } -result {{20 0} {40 0}} test panedwindow-19.10 {ComputeGeometry/ArrangePanes, slave coords} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 0 \ -sashwidth 0 -handlesize 6 -showhandle 0 foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky nsew -pady 3 -padx 11 } pack .p update set result {} foreach w {.p.f1 .p.f2 .p.f3} { lappend result [list [winfo x $w] [winfo y $w] \ [winfo width $w] [winfo height $w]] } return $result } -cleanup { deleteWindows } -result {{11 3 20 20} {53 3 20 20} {95 3 20 20}} test panedwindow-19.11 {ComputeGeometry, one slave, vertical} -setup { deleteWindows } -body { # With just one slave, sashpad and sashwidth should not # affect the panedwindow's geometry, since no sash should # ever be drawn. panedwindow .p -borderwidth 0 -sashpad 0 \ -orient vertical -sashwidth 0 -handlesize 6 \ -showhandle 0 .p add [frame .f -width 20 -height 20 -bg red] -pady 0 \ -sticky "" list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {20 20} test panedwindow-19.12 {ComputeGeometry, three panes, vertical} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 0 \ -sashwidth 0 -handlesize 6 -showhandle 0 \ -orient vertical foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {20 60} test panedwindow-19.13 {ComputeGeometry, sash coords, vertical} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 0 \ -sashwidth 0 -handlesize 6 -showhandle 0 \ -orient vertical foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [.p sash coord 0] [.p sash coord 1] } -cleanup { deleteWindows } -result {{0 20} {0 40}} test panedwindow-19.14 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 0 \ -sashwidth 0 -handlesize 6 -showhandle 0 \ -orient vertical foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky nsew -pady 11 -padx 3 } pack .p update set result {} foreach w {.p.f1 .p.f2 .p.f3} { lappend result [list [winfo x $w] [winfo y $w] \ [winfo width $w] [winfo height $w]] } return $result } -cleanup { deleteWindows } -result {{3 11 20 20} {3 53 20 20} {3 95 20 20}} test panedwindow-19.15 {ComputeGeometry, one slave, reqsize set properly} -setup { deleteWindows } -body { # With just one slave, sashpad and sashwidth should not # affect the panedwindow's geometry, since no sash should # ever be drawn. panedwindow .p -borderwidth 0 -sashpad 0 \ -sashwidth 0 -handlesize 6 -showhandle 1 .p add [frame .p.f -width 20 -height 20 -bg red] -padx 1 -sticky "" list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {22 20} test panedwindow-19.16 {ComputeGeometry, three panes, reqsize set properly} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 0 \ -sashwidth 0 -handlesize 6 -showhandle 1 foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] -sticky "" } list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {72 20} test panedwindow-19.17 {ComputeGeometry, sash coords} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 0 \ -sashwidth 0 -handlesize 6 -showhandle 1 foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [.p sash coord 0] [.p sash coord 1] } -cleanup { deleteWindows } -result {{23 0} {49 0}} test panedwindow-19.18 {ComputeGeometry/ArrangePanes, slave coords} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 0 \ -sashwidth 0 -handlesize 6 -showhandle 1 foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky nsew -pady 3 -padx 11 } pack .p update set result {} foreach w {.p.f1 .p.f2 .p.f3} { lappend result [list [winfo x $w] [winfo y $w] \ [winfo width $w] [winfo height $w]] } return $result } -cleanup { deleteWindows } -result {{11 3 20 20} {59 3 20 20} {107 3 20 20}} test panedwindow-19.19 {ComputeGeometry, one slave, vertical} -setup { deleteWindows } -body { # With just one slave, sashpad and sashwidth should not # affect the panedwindow's geometry, since no sash should # ever be drawn. panedwindow .p -borderwidth 0 -sashpad 0 \ -orient vertical -sashwidth 0 -handlesize 6 \ -showhandle 1 .p add [frame .f -width 20 -height 20 -bg red] -pady 1 \ -sticky "" list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {20 22} test panedwindow-19.20 {ComputeGeometry, three panes, vertical} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 0 \ -sashwidth 0 -handlesize 6 -showhandle 1 \ -orient vertical foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {20 72} test panedwindow-19.21 {ComputeGeometry, sash coords, vertical} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 0 \ -sashwidth 0 -handlesize 6 -showhandle 1 \ -orient vertical foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [.p sash coord 0] [.p sash coord 1] } -cleanup { deleteWindows } -result {{0 23} {0 49}} test panedwindow-19.22 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 0 \ -sashwidth 0 -handlesize 6 -showhandle 1 \ -orient vertical foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky nsew -pady 11 -padx 3 } pack .p update set result {} foreach w {.p.f1 .p.f2 .p.f3} { lappend result [list [winfo x $w] [winfo y $w] \ [winfo width $w] [winfo height $w]] } return $result } -cleanup { deleteWindows } -result {{3 11 20 20} {3 59 20 20} {3 107 20 20}} test panedwindow-19.23 {ComputeGeometry, one slave, reqsize set properly} -setup { deleteWindows } -body { # With just one slave, sashpad and sashwidth should not # affect the panedwindow's geometry, since no sash should # ever be drawn. panedwindow .p -borderwidth 0 -sashpad 0 \ -sashwidth 3 -handlesize 6 -showhandle 0 .p add [frame .p.f -width 20 -height 20 -bg red] -padx 0 -sticky "" list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {20 20} test panedwindow-19.24 {ComputeGeometry, three panes, reqsize set properly} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 0 \ -sashwidth 3 -handlesize 6 -showhandle 0 foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] -sticky "" } list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {66 20} test panedwindow-19.25 {ComputeGeometry, sash coords} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 0 \ -sashwidth 3 -handlesize 6 -showhandle 0 foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [.p sash coord 0] [.p sash coord 1] } -cleanup { deleteWindows } -result {{20 0} {43 0}} test panedwindow-19.26 {ComputeGeometry/ArrangePanes, slave coords} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 0 \ -sashwidth 3 -handlesize 6 -showhandle 0 foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky nsew -pady 3 -padx 11 } pack .p update set result {} foreach w {.p.f1 .p.f2 .p.f3} { lappend result [list [winfo x $w] [winfo y $w] \ [winfo width $w] [winfo height $w]] } return $result } -cleanup { deleteWindows } -result {{11 3 20 20} {56 3 20 20} {101 3 20 20}} test panedwindow-19.27 {ComputeGeometry, one slave, vertical} -setup { deleteWindows } -body { # With just one slave, sashpad and sashwidth should not # affect the panedwindow's geometry, since no sash should # ever be drawn. panedwindow .p -borderwidth 0 -sashpad 0 \ -orient vertical -sashwidth 3 -handlesize 6 \ -showhandle 0 .p add [frame .f -width 20 -height 20 -bg red] -pady 0 \ -sticky "" list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {20 20} test panedwindow-19.28 {ComputeGeometry, three panes, vertical} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 0 \ -sashwidth 3 -handlesize 6 -showhandle 0 \ -orient vertical foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {20 66} test panedwindow-19.29 {ComputeGeometry, sash coords, vertical} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 0 \ -sashwidth 3 -handlesize 6 -showhandle 0 \ -orient vertical foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [.p sash coord 0] [.p sash coord 1] } -cleanup { deleteWindows } -result {{0 20} {0 43}} test panedwindow-19.30 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 0 \ -sashwidth 3 -handlesize 6 -showhandle 0 \ -orient vertical foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky nsew -pady 11 -padx 3 } pack .p update set result {} foreach w {.p.f1 .p.f2 .p.f3} { lappend result [list [winfo x $w] [winfo y $w] \ [winfo width $w] [winfo height $w]] } return $result } -cleanup { deleteWindows } -result {{3 11 20 20} {3 56 20 20} {3 101 20 20}} test panedwindow-19.31 {ComputeGeometry, one slave, reqsize set properly} -setup { deleteWindows } -body { # With just one slave, sashpad and sashwidth should not # affect the panedwindow's geometry, since no sash should # ever be drawn. panedwindow .p -borderwidth 0 -sashpad 0 \ -sashwidth 3 -handlesize 6 -showhandle 1 .p add [frame .p.f -width 20 -height 20 -bg red] -padx 1 -sticky "" list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {22 20} test panedwindow-19.32 {ComputeGeometry, three panes, reqsize set properly} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 0 \ -sashwidth 3 -handlesize 6 -showhandle 1 foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] -sticky "" } list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {72 20} test panedwindow-19.33 {ComputeGeometry, sash coords} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 0 \ -sashwidth 3 -handlesize 6 -showhandle 1 foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [.p sash coord 0] [.p sash coord 1] } -cleanup { deleteWindows } -result {{21 0} {47 0}} test panedwindow-19.34 {ComputeGeometry/ArrangePanes, slave coords} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 0 \ -sashwidth 3 -handlesize 6 -showhandle 1 foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky nsew -pady 3 -padx 11 } pack .p update set result {} foreach w {.p.f1 .p.f2 .p.f3} { lappend result [list [winfo x $w] [winfo y $w] \ [winfo width $w] [winfo height $w]] } return $result } -cleanup { deleteWindows } -result {{11 3 20 20} {59 3 20 20} {107 3 20 20}} test panedwindow-19.35 {ComputeGeometry, one slave, vertical} -setup { deleteWindows } -body { # With just one slave, sashpad and sashwidth should not # affect the panedwindow's geometry, since no sash should # ever be drawn. panedwindow .p -borderwidth 0 -sashpad 0 \ -orient vertical -sashwidth 3 -handlesize 6 \ -showhandle 1 .p add [frame .f -width 20 -height 20 -bg red] -pady 1 \ -sticky "" list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {20 22} test panedwindow-19.36 {ComputeGeometry, three panes, vertical} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 0 \ -sashwidth 3 -handlesize 6 -showhandle 1 \ -orient vertical foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {20 72} test panedwindow-19.37 {ComputeGeometry, sash coords, vertical} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 0 \ -sashwidth 3 -handlesize 6 -showhandle 1 \ -orient vertical foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [.p sash coord 0] [.p sash coord 1] } -cleanup { deleteWindows } -result {{0 21} {0 47}} test panedwindow-19.38 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 0 \ -sashwidth 3 -handlesize 6 -showhandle 1 \ -orient vertical foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky nsew -pady 11 -padx 3 } pack .p update set result {} foreach w {.p.f1 .p.f2 .p.f3} { lappend result [list [winfo x $w] [winfo y $w] \ [winfo width $w] [winfo height $w]] } return $result } -cleanup { deleteWindows } -result {{3 11 20 20} {3 59 20 20} {3 107 20 20}} test panedwindow-19.39 {ComputeGeometry, one slave, reqsize set properly} -setup { deleteWindows } -body { # With just one slave, sashpad and sashwidth should not # affect the panedwindow's geometry, since no sash should # ever be drawn. panedwindow .p -borderwidth 0 -sashpad 5 \ -sashwidth 0 -handlesize 6 -showhandle 0 .p add [frame .p.f -width 20 -height 20 -bg red] -padx 0 -sticky "" list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {20 20} test panedwindow-19.40 {ComputeGeometry, three panes, reqsize set properly} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 5 \ -sashwidth 0 -handlesize 6 -showhandle 0 foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] -sticky "" } list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {80 20} test panedwindow-19.41 {ComputeGeometry, sash coords} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 5 \ -sashwidth 0 -handlesize 6 -showhandle 0 foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [.p sash coord 0] [.p sash coord 1] } -cleanup { deleteWindows } -result {{25 0} {55 0}} test panedwindow-19.42 {ComputeGeometry/ArrangePanes, slave coords} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 5 \ -sashwidth 0 -handlesize 6 -showhandle 0 foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky nsew -pady 3 -padx 11 } pack .p update set result {} foreach w {.p.f1 .p.f2 .p.f3} { lappend result [list [winfo x $w] [winfo y $w] \ [winfo width $w] [winfo height $w]] } return $result } -cleanup { deleteWindows } -result {{11 3 20 20} {63 3 20 20} {115 3 20 20}} test panedwindow-19.43 {ComputeGeometry, one slave, vertical} -setup { deleteWindows } -body { # With just one slave, sashpad and sashwidth should not # affect the panedwindow's geometry, since no sash should # ever be drawn. panedwindow .p -borderwidth 0 -sashpad 5 \ -orient vertical -sashwidth 0 -handlesize 6 \ -showhandle 0 .p add [frame .f -width 20 -height 20 -bg red] -pady 0 \ -sticky "" list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {20 20} test panedwindow-19.44 {ComputeGeometry, three panes, vertical} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 5 \ -sashwidth 0 -handlesize 6 -showhandle 0 \ -orient vertical foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {20 80} test panedwindow-19.45 {ComputeGeometry, sash coords, vertical} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 5 \ -sashwidth 0 -handlesize 6 -showhandle 0 \ -orient vertical foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [.p sash coord 0] [.p sash coord 1] } -cleanup { deleteWindows } -result {{0 25} {0 55}} test panedwindow-19.46 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 5 \ -sashwidth 0 -handlesize 6 -showhandle 0 \ -orient vertical foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky nsew -pady 11 -padx 3 } pack .p update set result {} foreach w {.p.f1 .p.f2 .p.f3} { lappend result [list [winfo x $w] [winfo y $w] \ [winfo width $w] [winfo height $w]] } return $result } -cleanup { deleteWindows } -result {{3 11 20 20} {3 63 20 20} {3 115 20 20}} test panedwindow-19.47 {ComputeGeometry, one slave, reqsize set properly} -setup { deleteWindows } -body { # With just one slave, sashpad and sashwidth should not # affect the panedwindow's geometry, since no sash should # ever be drawn. panedwindow .p -borderwidth 0 -sashpad 5 \ -sashwidth 0 -handlesize 6 -showhandle 1 .p add [frame .p.f -width 20 -height 20 -bg red] -padx 1 -sticky "" list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {22 20} test panedwindow-19.48 {ComputeGeometry, three panes, reqsize set properly} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 5 \ -sashwidth 0 -handlesize 6 -showhandle 1 foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] -sticky "" } list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {92 20} test panedwindow-19.49 {ComputeGeometry, sash coords} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 5 \ -sashwidth 0 -handlesize 6 -showhandle 1 foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [.p sash coord 0] [.p sash coord 1] } -cleanup { deleteWindows } -result {{28 0} {64 0}} test panedwindow-19.50 {ComputeGeometry/ArrangePanes, slave coords} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 5 \ -sashwidth 0 -handlesize 6 -showhandle 1 foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky nsew -pady 3 -padx 11 } pack .p update set result {} foreach w {.p.f1 .p.f2 .p.f3} { lappend result [list [winfo x $w] [winfo y $w] \ [winfo width $w] [winfo height $w]] } return $result } -cleanup { deleteWindows } -result {{11 3 20 20} {69 3 20 20} {127 3 20 20}} test panedwindow-19.51 {ComputeGeometry, one slave, vertical} -setup { deleteWindows } -body { # With just one slave, sashpad and sashwidth should not # affect the panedwindow's geometry, since no sash should # ever be drawn. panedwindow .p -borderwidth 0 -sashpad 5 \ -orient vertical -sashwidth 0 -handlesize 6 \ -showhandle 1 .p add [frame .f -width 20 -height 20 -bg red] -pady 1 \ -sticky "" list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {20 22} test panedwindow-19.52 {ComputeGeometry, three panes, vertical} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 5 \ -sashwidth 0 -handlesize 6 -showhandle 1 \ -orient vertical foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {20 92} test panedwindow-19.53 {ComputeGeometry, sash coords, vertical} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 5 \ -sashwidth 0 -handlesize 6 -showhandle 1 \ -orient vertical foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [.p sash coord 0] [.p sash coord 1] } -cleanup { deleteWindows } -result {{0 28} {0 64}} test panedwindow-19.54 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 5 \ -sashwidth 0 -handlesize 6 -showhandle 1 \ -orient vertical foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky nsew -pady 11 -padx 3 } pack .p update set result {} foreach w {.p.f1 .p.f2 .p.f3} { lappend result [list [winfo x $w] [winfo y $w] \ [winfo width $w] [winfo height $w]] } return $result } -cleanup { deleteWindows } -result {{3 11 20 20} {3 69 20 20} {3 127 20 20}} test panedwindow-19.55 {ComputeGeometry, one slave, reqsize set properly} -setup { deleteWindows } -body { # With just one slave, sashpad and sashwidth should not # affect the panedwindow's geometry, since no sash should # ever be drawn. panedwindow .p -borderwidth 0 -sashpad 5 \ -sashwidth 3 -handlesize 6 -showhandle 0 .p add [frame .p.f -width 20 -height 20 -bg red] -padx 0 -sticky "" list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {20 20} test panedwindow-19.56 {ComputeGeometry, three panes, reqsize set properly} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 5 \ -sashwidth 3 -handlesize 6 -showhandle 0 foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] -sticky "" } list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {86 20} test panedwindow-19.57 {ComputeGeometry, sash coords} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 5 \ -sashwidth 3 -handlesize 6 -showhandle 0 foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [.p sash coord 0] [.p sash coord 1] } -cleanup { deleteWindows } -result {{25 0} {58 0}} test panedwindow-19.58 {ComputeGeometry/ArrangePanes, slave coords} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 5 \ -sashwidth 3 -handlesize 6 -showhandle 0 foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky nsew -pady 3 -padx 11 } pack .p update set result {} foreach w {.p.f1 .p.f2 .p.f3} { lappend result [list [winfo x $w] [winfo y $w] \ [winfo width $w] [winfo height $w]] } return $result } -cleanup { deleteWindows } -result {{11 3 20 20} {66 3 20 20} {121 3 20 20}} test panedwindow-19.59 {ComputeGeometry, one slave, vertical} -setup { deleteWindows } -body { # With just one slave, sashpad and sashwidth should not # affect the panedwindow's geometry, since no sash should # ever be drawn. panedwindow .p -borderwidth 0 -sashpad 5 \ -orient vertical -sashwidth 3 -handlesize 6 \ -showhandle 0 .p add [frame .f -width 20 -height 20 -bg red] -pady 0 \ -sticky "" list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {20 20} test panedwindow-19.60 {ComputeGeometry, three panes, vertical} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 5 \ -sashwidth 3 -handlesize 6 -showhandle 0 \ -orient vertical foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {20 86} test panedwindow-19.61 {ComputeGeometry, sash coords, vertical} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 5 \ -sashwidth 3 -handlesize 6 -showhandle 0 \ -orient vertical foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [.p sash coord 0] [.p sash coord 1] } -cleanup { deleteWindows } -result {{0 25} {0 58}} test panedwindow-19.62 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 5 \ -sashwidth 3 -handlesize 6 -showhandle 0 \ -orient vertical foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky nsew -pady 11 -padx 3 } pack .p update set result {} foreach w {.p.f1 .p.f2 .p.f3} { lappend result [list [winfo x $w] [winfo y $w] \ [winfo width $w] [winfo height $w]] } return $result } -cleanup { deleteWindows } -result {{3 11 20 20} {3 66 20 20} {3 121 20 20}} test panedwindow-19.63 {ComputeGeometry, one slave, reqsize set properly} -setup { deleteWindows } -body { # With just one slave, sashpad and sashwidth should not # affect the panedwindow's geometry, since no sash should # ever be drawn. panedwindow .p -borderwidth 0 -sashpad 5 \ -sashwidth 3 -handlesize 6 -showhandle 1 .p add [frame .p.f -width 20 -height 20 -bg red] -padx 1 -sticky "" list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {22 20} test panedwindow-19.64 {ComputeGeometry, three panes, reqsize set properly} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 5 \ -sashwidth 3 -handlesize 6 -showhandle 1 foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] -sticky "" } list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {92 20} test panedwindow-19.65 {ComputeGeometry, sash coords} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 5 \ -sashwidth 3 -handlesize 6 -showhandle 1 foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [.p sash coord 0] [.p sash coord 1] } -cleanup { deleteWindows } -result {{26 0} {62 0}} test panedwindow-19.66 {ComputeGeometry/ArrangePanes, slave coords} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 5 \ -sashwidth 3 -handlesize 6 -showhandle 1 foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky nsew -pady 3 -padx 11 } pack .p update set result {} foreach w {.p.f1 .p.f2 .p.f3} { lappend result [list [winfo x $w] [winfo y $w] \ [winfo width $w] [winfo height $w]] } return $result } -cleanup { deleteWindows } -result {{11 3 20 20} {69 3 20 20} {127 3 20 20}} test panedwindow-19.67 {ComputeGeometry, one slave, vertical} -setup { deleteWindows } -body { # With just one slave, sashpad and sashwidth should not # affect the panedwindow's geometry, since no sash should # ever be drawn. panedwindow .p -borderwidth 0 -sashpad 5 \ -orient vertical -sashwidth 3 -handlesize 6 \ -showhandle 1 .p add [frame .f -width 20 -height 20 -bg red] -pady 1 \ -sticky "" list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {20 22} test panedwindow-19.68 {ComputeGeometry, three panes, vertical} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 5 \ -sashwidth 3 -handlesize 6 -showhandle 1 \ -orient vertical foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {20 92} test panedwindow-19.69 {ComputeGeometry, sash coords, vertical} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 5 \ -sashwidth 3 -handlesize 6 -showhandle 1 \ -orient vertical foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [.p sash coord 0] [.p sash coord 1] } -cleanup { deleteWindows } -result {{0 26} {0 62}} test panedwindow-19.70 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 5 \ -sashwidth 3 -handlesize 6 -showhandle 1 \ -orient vertical foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky nsew -pady 11 -padx 3 } pack .p update set result {} foreach w {.p.f1 .p.f2 .p.f3} { lappend result [list [winfo x $w] [winfo y $w] \ [winfo width $w] [winfo height $w]] } return $result } -cleanup { deleteWindows } -result {{3 11 20 20} {3 69 20 20} {3 127 20 20}} test panedwindow-19.71 {ComputeGeometry, one slave, reqsize set properly} -setup { deleteWindows } -body { # With just one slave, sashpad and sashwidth should not # affect the panedwindow's geometry, since no sash should # ever be drawn. panedwindow .p -borderwidth 2 -sashpad 0 \ -sashwidth 0 -handlesize 6 -showhandle 0 .p add [frame .p.f -width 20 -height 20 -bg red] -padx 0 -sticky "" list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {24 24} test panedwindow-19.72 {ComputeGeometry, three panes, reqsize set properly} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 0 \ -sashwidth 0 -handlesize 6 -showhandle 0 foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] -sticky "" } list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {64 24} test panedwindow-19.73 {ComputeGeometry, sash coords} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 0 \ -sashwidth 0 -handlesize 6 -showhandle 0 foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [.p sash coord 0] [.p sash coord 1] } -cleanup { deleteWindows } -result {{22 2} {42 2}} test panedwindow-19.74 {ComputeGeometry/ArrangePanes, slave coords} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 0 \ -sashwidth 0 -handlesize 6 -showhandle 0 foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky nsew -pady 3 -padx 11 } pack .p update set result {} foreach w {.p.f1 .p.f2 .p.f3} { lappend result [list [winfo x $w] [winfo y $w] \ [winfo width $w] [winfo height $w]] } return $result } -cleanup { deleteWindows } -result {{13 5 20 20} {55 5 20 20} {97 5 20 20}} test panedwindow-19.75 {ComputeGeometry, one slave, vertical} -setup { deleteWindows } -body { # With just one slave, sashpad and sashwidth should not # affect the panedwindow's geometry, since no sash should # ever be drawn. panedwindow .p -borderwidth 2 -sashpad 0 \ -orient vertical -sashwidth 0 -handlesize 6 \ -showhandle 0 .p add [frame .f -width 20 -height 20 -bg red] -pady 0 \ -sticky "" list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {24 24} test panedwindow-19.76 {ComputeGeometry, three panes, vertical} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 0 \ -sashwidth 0 -handlesize 6 -showhandle 0 \ -orient vertical foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {24 64} test panedwindow-19.77 {ComputeGeometry, sash coords, vertical} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 0 \ -sashwidth 0 -handlesize 6 -showhandle 0 \ -orient vertical foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [.p sash coord 0] [.p sash coord 1] } -cleanup { deleteWindows } -result {{2 22} {2 42}} test panedwindow-19.78 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 0 \ -sashwidth 0 -handlesize 6 -showhandle 0 \ -orient vertical foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky nsew -pady 11 -padx 3 } pack .p update set result {} foreach w {.p.f1 .p.f2 .p.f3} { lappend result [list [winfo x $w] [winfo y $w] \ [winfo width $w] [winfo height $w]] } return $result } -cleanup { deleteWindows } -result {{5 13 20 20} {5 55 20 20} {5 97 20 20}} test panedwindow-19.79 {ComputeGeometry, one slave, reqsize set properly} -setup { deleteWindows } -body { # With just one slave, sashpad and sashwidth should not # affect the panedwindow's geometry, since no sash should # ever be drawn. panedwindow .p -borderwidth 2 -sashpad 0 \ -sashwidth 0 -handlesize 6 -showhandle 1 .p add [frame .p.f -width 20 -height 20 -bg red] -padx 1 -sticky "" list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {26 24} test panedwindow-19.80 {ComputeGeometry, three panes, reqsize set properly} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 0 \ -sashwidth 0 -handlesize 6 -showhandle 1 foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] -sticky "" } list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {76 24} test panedwindow-19.81 {ComputeGeometry, sash coords} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 0 \ -sashwidth 0 -handlesize 6 -showhandle 1 foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [.p sash coord 0] [.p sash coord 1] } -cleanup { deleteWindows } -result {{25 2} {51 2}} test panedwindow-19.82 {ComputeGeometry/ArrangePanes, slave coords} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 0 \ -sashwidth 0 -handlesize 6 -showhandle 1 foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky nsew -pady 3 -padx 11 } pack .p update set result {} foreach w {.p.f1 .p.f2 .p.f3} { lappend result [list [winfo x $w] [winfo y $w] \ [winfo width $w] [winfo height $w]] } return $result } -cleanup { deleteWindows } -result {{13 5 20 20} {61 5 20 20} {109 5 20 20}} test panedwindow-19.83 {ComputeGeometry, one slave, vertical} -setup { deleteWindows } -body { # With just one slave, sashpad and sashwidth should not # affect the panedwindow's geometry, since no sash should # ever be drawn. panedwindow .p -borderwidth 2 -sashpad 0 \ -orient vertical -sashwidth 0 -handlesize 6 \ -showhandle 1 .p add [frame .f -width 20 -height 20 -bg red] -pady 1 \ -sticky "" list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {24 26} test panedwindow-19.84 {ComputeGeometry, three panes, vertical} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 0 \ -sashwidth 0 -handlesize 6 -showhandle 1 \ -orient vertical foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {24 76} test panedwindow-19.85 {ComputeGeometry, sash coords, vertical} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 0 \ -sashwidth 0 -handlesize 6 -showhandle 1 \ -orient vertical foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [.p sash coord 0] [.p sash coord 1] } -cleanup { deleteWindows } -result {{2 25} {2 51}} test panedwindow-19.86 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 0 \ -sashwidth 0 -handlesize 6 -showhandle 1 \ -orient vertical foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky nsew -pady 11 -padx 3 } pack .p update set result {} foreach w {.p.f1 .p.f2 .p.f3} { lappend result [list [winfo x $w] [winfo y $w] \ [winfo width $w] [winfo height $w]] } return $result } -cleanup { deleteWindows } -result {{5 13 20 20} {5 61 20 20} {5 109 20 20}} test panedwindow-19.87 {ComputeGeometry, one slave, reqsize set properly} -setup { deleteWindows } -body { # With just one slave, sashpad and sashwidth should not # affect the panedwindow's geometry, since no sash should # ever be drawn. panedwindow .p -borderwidth 2 -sashpad 0 \ -sashwidth 3 -handlesize 6 -showhandle 0 .p add [frame .p.f -width 20 -height 20 -bg red] -padx 0 -sticky "" list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {24 24} test panedwindow-19.88 {ComputeGeometry, three panes, reqsize set properly} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 0 \ -sashwidth 3 -handlesize 6 -showhandle 0 foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] -sticky "" } list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {70 24} test panedwindow-19.89 {ComputeGeometry, sash coords} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 0 \ -sashwidth 3 -handlesize 6 -showhandle 0 foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [.p sash coord 0] [.p sash coord 1] } -cleanup { deleteWindows } -result {{22 2} {45 2}} test panedwindow-19.90 {ComputeGeometry/ArrangePanes, slave coords} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 0 \ -sashwidth 3 -handlesize 6 -showhandle 0 foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky nsew -pady 3 -padx 11 } pack .p update set result {} foreach w {.p.f1 .p.f2 .p.f3} { lappend result [list [winfo x $w] [winfo y $w] \ [winfo width $w] [winfo height $w]] } return $result } -cleanup { deleteWindows } -result {{13 5 20 20} {58 5 20 20} {103 5 20 20}} test panedwindow-19.91 {ComputeGeometry, one slave, vertical} -setup { deleteWindows } -body { # With just one slave, sashpad and sashwidth should not # affect the panedwindow's geometry, since no sash should # ever be drawn. panedwindow .p -borderwidth 2 -sashpad 0 \ -orient vertical -sashwidth 3 -handlesize 6 \ -showhandle 0 .p add [frame .f -width 20 -height 20 -bg red] -pady 0 \ -sticky "" list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {24 24} test panedwindow-19.92 {ComputeGeometry, three panes, vertical} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 0 \ -sashwidth 3 -handlesize 6 -showhandle 0 \ -orient vertical foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {24 70} test panedwindow-19.93 {ComputeGeometry, sash coords, vertical} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 0 \ -sashwidth 3 -handlesize 6 -showhandle 0 \ -orient vertical foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [.p sash coord 0] [.p sash coord 1] } -cleanup { deleteWindows } -result {{2 22} {2 45}} test panedwindow-19.94 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 0 \ -sashwidth 3 -handlesize 6 -showhandle 0 \ -orient vertical foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky nsew -pady 11 -padx 3 } pack .p update set result {} foreach w {.p.f1 .p.f2 .p.f3} { lappend result [list [winfo x $w] [winfo y $w] \ [winfo width $w] [winfo height $w]] } return $result } -cleanup { deleteWindows } -result {{5 13 20 20} {5 58 20 20} {5 103 20 20}} test panedwindow-19.95 {ComputeGeometry, one slave, reqsize set properly} -setup { deleteWindows } -body { # With just one slave, sashpad and sashwidth should not # affect the panedwindow's geometry, since no sash should # ever be drawn. panedwindow .p -borderwidth 2 -sashpad 0 \ -sashwidth 3 -handlesize 6 -showhandle 1 .p add [frame .p.f -width 20 -height 20 -bg red] -padx 1 -sticky "" list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {26 24} test panedwindow-19.96 {ComputeGeometry, three panes, reqsize set properly} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 0 \ -sashwidth 3 -handlesize 6 -showhandle 1 foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] -sticky "" } list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {76 24} test panedwindow-19.97 {ComputeGeometry, sash coords} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 0 \ -sashwidth 3 -handlesize 6 -showhandle 1 foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [.p sash coord 0] [.p sash coord 1] } -cleanup { deleteWindows } -result {{23 2} {49 2}} test panedwindow-19.98 {ComputeGeometry/ArrangePanes, slave coords} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 0 \ -sashwidth 3 -handlesize 6 -showhandle 1 foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky nsew -pady 3 -padx 11 } pack .p update set result {} foreach w {.p.f1 .p.f2 .p.f3} { lappend result [list [winfo x $w] [winfo y $w] \ [winfo width $w] [winfo height $w]] } return $result } -cleanup { deleteWindows } -result {{13 5 20 20} {61 5 20 20} {109 5 20 20}} test panedwindow-19.99 {ComputeGeometry, one slave, vertical} -setup { deleteWindows } -body { # With just one slave, sashpad and sashwidth should not # affect the panedwindow's geometry, since no sash should # ever be drawn. panedwindow .p -borderwidth 2 -sashpad 0 \ -orient vertical -sashwidth 3 -handlesize 6 \ -showhandle 1 .p add [frame .f -width 20 -height 20 -bg red] -pady 1 \ -sticky "" list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {24 26} test panedwindow-19.100 {ComputeGeometry, three panes, vertical} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 0 \ -sashwidth 3 -handlesize 6 -showhandle 1 \ -orient vertical foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {24 76} test panedwindow-19.101 {ComputeGeometry, sash coords, vertical} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 0 \ -sashwidth 3 -handlesize 6 -showhandle 1 \ -orient vertical foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [.p sash coord 0] [.p sash coord 1] } -cleanup { deleteWindows } -result {{2 23} {2 49}} test panedwindow-19.102 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 0 \ -sashwidth 3 -handlesize 6 -showhandle 1 \ -orient vertical foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky nsew -pady 11 -padx 3 } pack .p update set result {} foreach w {.p.f1 .p.f2 .p.f3} { lappend result [list [winfo x $w] [winfo y $w] \ [winfo width $w] [winfo height $w]] } return $result } -cleanup { deleteWindows } -result {{5 13 20 20} {5 61 20 20} {5 109 20 20}} test panedwindow-19.103 {ComputeGeometry, one slave, reqsize set properly} -setup { deleteWindows } -body { # With just one slave, sashpad and sashwidth should not # affect the panedwindow's geometry, since no sash should # ever be drawn. panedwindow .p -borderwidth 2 -sashpad 5 \ -sashwidth 0 -handlesize 6 -showhandle 0 .p add [frame .p.f -width 20 -height 20 -bg red] -padx 0 -sticky "" list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {24 24} test panedwindow-19.104 {ComputeGeometry, three panes, reqsize set properly} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 5 \ -sashwidth 0 -handlesize 6 -showhandle 0 foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] -sticky "" } list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {84 24} test panedwindow-19.105 {ComputeGeometry, sash coords} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 5 \ -sashwidth 0 -handlesize 6 -showhandle 0 foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [.p sash coord 0] [.p sash coord 1] } -cleanup { deleteWindows } -result {{27 2} {57 2}} test panedwindow-19.106 {ComputeGeometry/ArrangePanes, slave coords} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 5 \ -sashwidth 0 -handlesize 6 -showhandle 0 foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky nsew -pady 3 -padx 11 } pack .p update set result {} foreach w {.p.f1 .p.f2 .p.f3} { lappend result [list [winfo x $w] [winfo y $w] \ [winfo width $w] [winfo height $w]] } return $result } -cleanup { deleteWindows } -result {{13 5 20 20} {65 5 20 20} {117 5 20 20}} test panedwindow-19.107 {ComputeGeometry, one slave, vertical} -setup { deleteWindows } -body { # With just one slave, sashpad and sashwidth should not # affect the panedwindow's geometry, since no sash should # ever be drawn. panedwindow .p -borderwidth 2 -sashpad 5 \ -orient vertical -sashwidth 0 -handlesize 6 \ -showhandle 0 .p add [frame .f -width 20 -height 20 -bg red] -pady 0 \ -sticky "" list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {24 24} test panedwindow-19.108 {ComputeGeometry, three panes, vertical} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 5 \ -sashwidth 0 -handlesize 6 -showhandle 0 \ -orient vertical foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {24 84} test panedwindow-19.109 {ComputeGeometry, sash coords, vertical} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 5 \ -sashwidth 0 -handlesize 6 -showhandle 0 \ -orient vertical foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [.p sash coord 0] [.p sash coord 1] } -cleanup { deleteWindows } -result {{2 27} {2 57}} test panedwindow-19.110 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 5 \ -sashwidth 0 -handlesize 6 -showhandle 0 \ -orient vertical foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky nsew -pady 11 -padx 3 } pack .p update set result {} foreach w {.p.f1 .p.f2 .p.f3} { lappend result [list [winfo x $w] [winfo y $w] \ [winfo width $w] [winfo height $w]] } return $result } -cleanup { deleteWindows } -result {{5 13 20 20} {5 65 20 20} {5 117 20 20}} test panedwindow-19.111 {ComputeGeometry, one slave, reqsize set properly} -setup { deleteWindows } -body { # With just one slave, sashpad and sashwidth should not # affect the panedwindow's geometry, since no sash should # ever be drawn. panedwindow .p -borderwidth 2 -sashpad 5 \ -sashwidth 0 -handlesize 6 -showhandle 1 .p add [frame .p.f -width 20 -height 20 -bg red] -padx 1 -sticky "" list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {26 24} test panedwindow-19.112 {ComputeGeometry, three panes, reqsize set properly} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 5 \ -sashwidth 0 -handlesize 6 -showhandle 1 foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] -sticky "" } list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {96 24} test panedwindow-19.113 {ComputeGeometry, sash coords} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 5 \ -sashwidth 0 -handlesize 6 -showhandle 1 foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [.p sash coord 0] [.p sash coord 1] } -cleanup { deleteWindows } -result {{30 2} {66 2}} test panedwindow-19.114 {ComputeGeometry/ArrangePanes, slave coords} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 5 \ -sashwidth 0 -handlesize 6 -showhandle 1 foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky nsew -pady 3 -padx 11 } pack .p update set result {} foreach w {.p.f1 .p.f2 .p.f3} { lappend result [list [winfo x $w] [winfo y $w] \ [winfo width $w] [winfo height $w]] } return $result } -cleanup { deleteWindows } -result {{13 5 20 20} {71 5 20 20} {129 5 20 20}} test panedwindow-19.115 {ComputeGeometry, one slave, vertical} -setup { deleteWindows } -body { # With just one slave, sashpad and sashwidth should not # affect the panedwindow's geometry, since no sash should # ever be drawn. panedwindow .p -borderwidth 2 -sashpad 5 \ -orient vertical -sashwidth 0 -handlesize 6 \ -showhandle 1 .p add [frame .f -width 20 -height 20 -bg red] -pady 1 \ -sticky "" list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {24 26} test panedwindow-19.116 {ComputeGeometry, three panes, vertical} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 5 \ -sashwidth 0 -handlesize 6 -showhandle 1 \ -orient vertical foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {24 96} test panedwindow-19.117 {ComputeGeometry, sash coords, vertical} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 5 \ -sashwidth 0 -handlesize 6 -showhandle 1 \ -orient vertical foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [.p sash coord 0] [.p sash coord 1] } -cleanup { deleteWindows } -result {{2 30} {2 66}} test panedwindow-19.118 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 5 \ -sashwidth 0 -handlesize 6 -showhandle 1 \ -orient vertical foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky nsew -pady 11 -padx 3 } pack .p update set result {} foreach w {.p.f1 .p.f2 .p.f3} { lappend result [list [winfo x $w] [winfo y $w] \ [winfo width $w] [winfo height $w]] } return $result } -cleanup { deleteWindows } -result {{5 13 20 20} {5 71 20 20} {5 129 20 20}} test panedwindow-19.119 {ComputeGeometry, one slave, reqsize set properly} -setup { deleteWindows } -body { # With just one slave, sashpad and sashwidth should not # affect the panedwindow's geometry, since no sash should # ever be drawn. panedwindow .p -borderwidth 2 -sashpad 5 \ -sashwidth 3 -handlesize 6 -showhandle 0 .p add [frame .p.f -width 20 -height 20 -bg red] -padx 0 -sticky "" list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {24 24} test panedwindow-19.120 {ComputeGeometry, three panes, reqsize set properly} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 5 \ -sashwidth 3 -handlesize 6 -showhandle 0 foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] -sticky "" } list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {90 24} test panedwindow-19.121 {ComputeGeometry, sash coords} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 5 \ -sashwidth 3 -handlesize 6 -showhandle 0 foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [.p sash coord 0] [.p sash coord 1] } -cleanup { deleteWindows } -result {{27 2} {60 2}} test panedwindow-19.122 {ComputeGeometry/ArrangePanes, slave coords} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 5 \ -sashwidth 3 -handlesize 6 -showhandle 0 foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky nsew -pady 3 -padx 11 } pack .p update set result {} foreach w {.p.f1 .p.f2 .p.f3} { lappend result [list [winfo x $w] [winfo y $w] \ [winfo width $w] [winfo height $w]] } return $result } -cleanup { deleteWindows } -result {{13 5 20 20} {68 5 20 20} {123 5 20 20}} test panedwindow-19.123 {ComputeGeometry, one slave, vertical} -setup { deleteWindows } -body { # With just one slave, sashpad and sashwidth should not # affect the panedwindow's geometry, since no sash should # ever be drawn. panedwindow .p -borderwidth 2 -sashpad 5 \ -orient vertical -sashwidth 3 -handlesize 6 \ -showhandle 0 .p add [frame .f -width 20 -height 20 -bg red] -pady 0 \ -sticky "" list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {24 24} test panedwindow-19.124 {ComputeGeometry, three panes, vertical} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 5 \ -sashwidth 3 -handlesize 6 -showhandle 0 \ -orient vertical foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {24 90} test panedwindow-19.125 {ComputeGeometry, sash coords, vertical} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 5 \ -sashwidth 3 -handlesize 6 -showhandle 0 \ -orient vertical foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [.p sash coord 0] [.p sash coord 1] } -cleanup { deleteWindows } -result {{2 27} {2 60}} test panedwindow-19.126 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 5 \ -sashwidth 3 -handlesize 6 -showhandle 0 \ -orient vertical foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky nsew -pady 11 -padx 3 } pack .p update set result {} foreach w {.p.f1 .p.f2 .p.f3} { lappend result [list [winfo x $w] [winfo y $w] \ [winfo width $w] [winfo height $w]] } return $result } -cleanup { deleteWindows } -result {{5 13 20 20} {5 68 20 20} {5 123 20 20}} test panedwindow-19.127 {ComputeGeometry, one slave, reqsize set properly} -setup { deleteWindows } -body { # With just one slave, sashpad and sashwidth should not # affect the panedwindow's geometry, since no sash should # ever be drawn. panedwindow .p -borderwidth 2 -sashpad 5 \ -sashwidth 3 -handlesize 6 -showhandle 1 .p add [frame .p.f -width 20 -height 20 -bg red] -padx 1 -sticky "" list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {26 24} test panedwindow-19.128 {ComputeGeometry, three panes, reqsize set properly} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 5 \ -sashwidth 3 -handlesize 6 -showhandle 1 foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] -sticky "" } list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {96 24} test panedwindow-19.129 {ComputeGeometry, sash coords} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 5 \ -sashwidth 3 -handlesize 6 -showhandle 1 foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [.p sash coord 0] [.p sash coord 1] } -cleanup { deleteWindows } -result {{28 2} {64 2}} test panedwindow-19.130 {ComputeGeometry/ArrangePanes, slave coords} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 5 \ -sashwidth 3 -handlesize 6 -showhandle 1 foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky nsew -pady 3 -padx 11 } pack .p update set result {} foreach w {.p.f1 .p.f2 .p.f3} { lappend result [list [winfo x $w] [winfo y $w] \ [winfo width $w] [winfo height $w]] } return $result } -cleanup { deleteWindows } -result {{13 5 20 20} {71 5 20 20} {129 5 20 20}} test panedwindow-19.131 {ComputeGeometry, one slave, vertical} -setup { deleteWindows } -body { # With just one slave, sashpad and sashwidth should not # affect the panedwindow's geometry, since no sash should # ever be drawn. panedwindow .p -borderwidth 2 -sashpad 5 \ -orient vertical -sashwidth 3 -handlesize 6 \ -showhandle 1 .p add [frame .f -width 20 -height 20 -bg red] -pady 1 \ -sticky "" list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {24 26} test panedwindow-19.132 {ComputeGeometry, three panes, vertical} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 5 \ -sashwidth 3 -handlesize 6 -showhandle 1 \ -orient vertical foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {24 96} test panedwindow-19.133 {ComputeGeometry, sash coords, vertical} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 5 \ -sashwidth 3 -handlesize 6 -showhandle 1 \ -orient vertical foreach w {.f1 .f2 .f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" } list [.p sash coord 0] [.p sash coord 1] } -cleanup { deleteWindows } -result {{2 28} {2 64}} test panedwindow-19.134 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup { deleteWindows } -body { panedwindow .p -borderwidth 2 -sashpad 5 \ -sashwidth 3 -handlesize 6 -showhandle 1 \ -orient vertical foreach w {.p.f1 .p.f2 .p.f3} { .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky nsew -pady 11 -padx 3 } pack .p update set result {} foreach w {.p.f1 .p.f2 .p.f3} { lappend result [list [winfo x $w] [winfo y $w] \ [winfo width $w] [winfo height $w]] } return $result } -cleanup { deleteWindows } -result {{5 13 20 20} {5 71 20 20} {5 129 20 20}} test panedwindow-20.1 {destroyed widgets are removed from panedwindow} -setup { deleteWindows } -body { panedwindow .p .p add [frame .f -width 20 -height 20 -bg blue] destroy .f .p panes } -cleanup { deleteWindows } -result {} test panedwindow-20.2 {destroyed slave causes geometry recomputation} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 2 .p add [frame .f -width 20 -height 20 -bg blue] \ [frame .f2 -width 20 -height 20 -bg red] destroy .f winfo reqwidth .p } -cleanup { deleteWindows } -result 20 test panedwindow-21.1 {ArrangePanes, extra space is given to the last pane} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 .p add [frame .f1 -width 20 -height 20 -bg blue] \ [frame .f2 -width 20 -height 20 -bg red] -sticky nsew place .p -width 100 -x 0 -y 0 update winfo width .f2 } -cleanup { deleteWindows } -result 78 test panedwindow-21.2 {ArrangePanes, extra space is given to the last pane} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical .p add [frame .f1 -width 20 -height 20 -bg blue] \ [frame .f2 -width 20 -height 20 -bg red] -sticky nsew place .p -height 100 -x 0 -y 0 update winfo height .f2 } -cleanup { deleteWindows } -result 78 test panedwindow-21.3 {ArrangePanes, explicit height/width are preferred} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 .p add [frame .f1 -width 20 -height 20 -bg blue] \ [frame .f2 -width 20 -height 20 -bg red] -sticky "" .p paneconfigure .f1 -width 10 -height 15 pack .p update list [winfo width .f1] [winfo height .f1] } -cleanup { deleteWindows } -result {10 15} test panedwindow-21.4 {ArrangePanes, panes clipped by size of pane} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 .p add [frame .f1 -width 20 -height 20 -bg blue] \ [frame .f2 -width 20 -height 20 -bg red] .p sash place 0 10 0 pack .p update list [winfo width .f1] [winfo height .f1] } -cleanup { deleteWindows } -result {10 20} test panedwindow-21.5 {ArrangePanes, panes clipped by size of pane} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical .p add [frame .f1 -width 20 -height 20 -bg blue] \ [frame .f2 -width 20 -height 20 -bg red] .p sash place 0 0 10 pack .p update list [winfo width .f1] [winfo height .f1] } -cleanup { deleteWindows } -result {20 10} test panedwindow-21.6 {ArrangePanes, height of pane taken from total height} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 .p add [frame .p.f1 -width 20 -height 20 -bg blue] \ [frame .p.f2 -width 20 -height 40 -bg red] -sticky "" pack .p update winfo y .p.f1 } -cleanup { deleteWindows } -result 10 test panedwindow-21.7 {ArrangePanes, width of pane taken from total width} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical .p add [frame .p.f1 -width 20 -height 20 -bg blue] \ [frame .p.f2 -width 40 -height 40 -bg red] -sticky "" pack .p update winfo x .p.f1 } -cleanup { deleteWindows } -result 10 test panedwindow-21.8 {ArrangePanes, panes with width <= 0 are unmapped} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 .p add [frame .f1 -width 20 -height 20 -bg blue] \ [frame .f2 -width 20 -height 40 -bg red] pack .p update set result [winfo ismapped .f1] .p sash place 0 0 0 update lappend result [winfo ismapped .f1] } -cleanup { deleteWindows } -result {1 0} test panedwindow-21.9 {ArrangePanes, panes with width <= 0 are unmapped} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 .p add [frame .p.f1 -width 20 -height 20 -bg blue] \ [frame .p.f2 -width 20 -height 40 -bg red] pack .p update set result [winfo ismapped .p.f1] .p sash place 0 0 0 update lappend result [winfo ismapped .p.f1] } -cleanup { deleteWindows } -result {1 0} test panedwindow-21.10 {ArrangePanes, panes with width <= 0 are unmapped} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 -orient vertical .p add [frame .p.f1 -width 20 -height 20 -bg blue] \ [frame .p.f2 -width 20 -height 40 -bg red] pack .p update set result [winfo ismapped .p.f1] .p sash place 0 0 0 update lappend result [winfo ismapped .p.f1] } -cleanup { deleteWindows } -result {1 0} test panedwindow-21.11 {ArrangePanes, last pane shrinks} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 .p add [frame .f1 -width 20 -height 20 -bg blue] \ [frame .f2 -width 20 -height 20 -bg red] -sticky nsew place .p -width 40 -x 0 -y 0 update winfo width .f2 } -cleanup { deleteWindows } -result 18 test panedwindow-21.12 {ArrangePanes, last pane shrinks} -setup { deleteWindows } -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical .p add [frame .f1 -width 20 -height 20 -bg blue] \ [frame .f2 -width 20 -height 20 -bg red] -sticky nsew place .p -height 40 -x 0 -y 0 update winfo height .f2 } -cleanup { deleteWindows } -result 18 test panedwindow-21.13 {ArrangePanes, panedwindow resizes} -setup { deleteWindows } -body { panedwindow .p -width 200 -borderwidth 0 frame .f1 -height 50 -bg blue set result [list] lappend result [winfo reqwidth .p] [winfo reqheight .p] .p add .f1 pack .p lappend result [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {200 1 200 50} test panedwindow-21.14 {ArrangePanes, panedwindow resizes} -setup { deleteWindows } -body { panedwindow .p -height 200 -borderwidth 0 -orient vertical frame .f1 -width 50 -bg blue set result [list] lappend result [winfo reqwidth .p] [winfo reqheight .p] .p add .f1 pack .p lappend result [winfo reqwidth .p] [winfo reqheight .p] } -cleanup { deleteWindows } -result {1 200 50 200} test panedwindow-21.15 {ArrangePanes, last pane grows} -setup { deleteWindows } -body { panedwindow .p -showhandle false -height 50 .p add [frame .f1 -width 50 -bg red] [frame .f2 -width 50 -bg white] \ [frame .f3 -width 50 -bg blue] [frame .f4 -width 50 -bg green] .p sash place 1 250 0 pack .p update set result [list] lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \ [winfo width .f4] [winfo width .p] .p configure -width 300 update lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \ [winfo width .f4] [winfo width .p] } -cleanup { deleteWindows } -result {50 150 1 1 211 50 150 1 89 300} test panedwindow-22.1 {PanedWindowReqProc, react to slave geometry changes} -setup { deleteWindows } -body { # Basically just want to make sure that the PanedWindowReqProc is called panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 2 .p add [frame .f1 -width 20 -height 20 -bg blue] \ [frame .f2 -width 20 -height 40 -bg red] set result [winfo reqheight .p] .f1 configure -height 80 lappend result [winfo reqheight .p] } -cleanup { deleteWindows } -result {40 80} test panedwindow-22.2 {PanedWindowReqProc, react to slave geometry changes} -setup { deleteWindows } -body { panedwindow .p -orient horizontal -sashpad 0 -sashwidth 2 .p add [frame .f1 -width 10] [frame .f2 -width 10] set result [winfo reqwidth .p] .f1 configure -width 20 lappend result [winfo reqwidth .p] destroy .p .f1 .f2 expr {[lindex $result 1] - [lindex $result 0]} } -cleanup { deleteWindows } -result {10} test panedwindow-23.1 {ConfigurePanes, can't add panedwindow to itself} -setup { deleteWindows } -body { panedwindow .p .p add .p } -cleanup { deleteWindows } -returnCodes error -result {can't add .p to itself} test panedwindow-23.2 {ConfigurePanes, bad window throws error} -setup { deleteWindows } -body { panedwindow .p .p add .b } -cleanup { deleteWindows } -returnCodes error -result {bad window path name ".b"} test panedwindow-23.3 {ConfigurePanes, bad window aborts processing} -setup { deleteWindows } -body { panedwindow .p button .b catch {.p add .b .a} .p panes } -cleanup { deleteWindows } -result {} test panedwindow-23.4 {ConfigurePanes, bad option aborts processing} -setup { deleteWindows } -body { panedwindow .p button .b catch {.p add .b -sticky foobar} .p panes } -cleanup { deleteWindows } -result {} test panedwindow-23.5 {ConfigurePanes, after win isn't managed by panedwin} -setup { deleteWindows } -body { panedwindow .p button .b button .c .p add .b -after .c } -cleanup { deleteWindows } -returnCodes error -result {window ".c" is not managed by .p} test panedwindow-23.6 {ConfigurePanes, before win isn't managed by panedwin} -setup { deleteWindows } -body { panedwindow .p button .b button .c .p add .b -before .c } -cleanup { deleteWindows } -returnCodes error -result {window ".c" is not managed by .p} test panedwindow-23.7 {ConfigurePanes, -after {} is a no-op} -setup { deleteWindows } -body { panedwindow .p .p add [button .b] [button .c] .p paneconfigure .b -after {} .p panes } -cleanup { deleteWindows } -result {.b .c} test panedwindow-23.8 {ConfigurePanes, -before {} is a no-op} -setup { deleteWindows } -body { panedwindow .p .p add [button .b] [button .c] .p paneconfigure .b -before {} .p panes } -cleanup { deleteWindows } -result {.b .c} test panedwindow-23.9 {ConfigurePanes, new panes are added} -setup { deleteWindows } -body { panedwindow .p .p add [button .b] [button .c] .p panes } -cleanup { deleteWindows } -result {.b .c} test panedwindow-23.10 {ConfigurePanes, options applied to all panes} -setup { deleteWindows } -body { panedwindow .p .p add [button .b] [button .c] -sticky ne -height 5 -width 5 -minsize 10 set result {} foreach w {.b .c} { set val {} foreach option {-sticky -height -width -minsize} { lappend val $option [.p panecget $w $option] } lappend result $w $val } return $result } -cleanup { deleteWindows } -result {.b {-sticky ne -height 5 -width 5 -minsize 10} .c {-sticky ne -height 5 -width 5 -minsize 10}} test panedwindow-23.11 {ConfigurePanes, existing panes are reconfigured} -setup { deleteWindows } -body { panedwindow .p .p add [button .b] -sticky nw -height 10 .p add .b [button .c] -sticky se -height 2 list [.p panes] [.p panecget .b -sticky] [.p panecget .b -height] \ [.p panecget .c -sticky] [.p panecget .c -height] } -cleanup { deleteWindows } -result [list {.b .c} es 2 es 2] test panedwindow-23.12 {ConfigurePanes, widgets added to end by default} -setup { deleteWindows } -body { panedwindow .p .p add [button .b] .p add [button .c] .p add [button .d] .p panes } -cleanup { deleteWindows } -result {.b .c .d} test panedwindow-23.13 {ConfigurePanes, -after, single addition} -setup { deleteWindows } -body { panedwindow .p button .a button .b button .c .p add .a .b .p add .c -after .a .p panes } -cleanup { deleteWindows } -result {.a .c .b} test panedwindow-23.14 {ConfigurePanes, -after, multiple additions} -setup { deleteWindows } -body { panedwindow .p button .a button .b button .c button .d .p add .a .b .p add .c .d -after .a .p panes } -cleanup { deleteWindows } -result {.a .c .d .b} test panedwindow-23.15 {ConfigurePanes, -after, relocates existing widget} -setup { deleteWindows } -body { panedwindow .p button .a button .b button .c button .d .p add .a .b .c .d .p add .d -after .a .p panes } -cleanup { deleteWindows } -result {.a .d .b .c} test panedwindow-23.16 {ConfigurePanes, -after, relocates existing widgets} -setup { deleteWindows } -body { panedwindow .p button .a button .b button .c button .d .p add .a .b .c .d .p add .b .d -after .a .p panes } -cleanup { deleteWindows } -result {.a .b .d .c} test panedwindow-23.17 {ConfigurePanes, -after, relocates existing widgets} -setup { deleteWindows } -body { panedwindow .p button .a button .b button .c button .d .p add .a .b .c .d .p add .d .a -after .b .p panes } -cleanup { deleteWindows } -result {.b .d .a .c} test panedwindow-23.18 {ConfigurePanes, -after, relocates existing widgets} -setup { deleteWindows } -body { panedwindow .p button .a button .b button .c button .d .p add .a .b .c .d .p add .d .a -after .a .p panes } -cleanup { deleteWindows } -result {.d .a .b .c} test panedwindow-23.19 {ConfigurePanes, -after, after last window} -setup { deleteWindows } -body { panedwindow .p button .a button .b button .c button .d .p add .a .b .c .p add .d -after .c .p panes } -cleanup { deleteWindows } -result {.a .b .c .d} test panedwindow-23.20 {ConfigurePanes, -before, before first window} -setup { deleteWindows } -body { panedwindow .p button .a button .b button .c button .d .p add .a .b .c .p add .d -before .a .p panes } -cleanup { deleteWindows } -result {.d .a .b .c} test panedwindow-23.21 {ConfigurePanes, -before, relocate existing windows} -setup { deleteWindows } -body { panedwindow .p button .a button .b button .c button .d .p add .a .b .c .p add .d .b -before .a .p panes } -cleanup { deleteWindows } -result {.d .b .a .c} test panedwindow-23.22 {ConfigurePanes, slave specified multiple times} -setup { deleteWindows } -body { # This test should not cause a core dump panedwindow .p button .a button .b button .c .p add .a .a .b .c .p panes } -cleanup { deleteWindows } -result {.a .b .c} test panedwindow-23.23 {ConfigurePanes, slave specified multiple times} -setup { deleteWindows } -body { # This test should not cause a core dump panedwindow .p button .a button .b button .c .p add .a .a .b .c .p add .a .b .a -after .c .p panes } -cleanup { deleteWindows } -result {.c .a .b} test panedwindow-23.24 {ConfigurePanes, panedwindow cannot manage toplevels} -setup { deleteWindows } -body { panedwindow .p toplevel .t .p add .t } -cleanup { deleteWindows } -returnCodes error -result {can't add toplevel .t to .p} test panedwindow-23.25 {ConfigurePanes, restrict possible panes} -setup { deleteWindows } -body { panedwindow .p frame .f button .f.b .p add .f.b } -cleanup { deleteWindows } -returnCodes error -result {can't add .f.b to .p} test panedwindow-23.26 {ConfigurePanes, restrict possible panes} -setup { deleteWindows } -body { frame .f panedwindow .f.p button .b .f.p add .b } -cleanup { deleteWindows } -result {} test panedwindow-23.27 {ConfigurePanes, restrict possible panes} -setup { deleteWindows } -body { panedwindow .p button .p.b .p add .p.b } -cleanup { deleteWindows } -result {} test panedwindow-23.28 {ConfigurePanes, restrict possible panes} -setup { deleteWindows } -body { frame .f frame .f.f frame .f.f.f panedwindow .f.f.f.p button .b .f.f.f.p add .b } -cleanup { deleteWindows } -result {} test panedwindow-23.29 {ConfigurePanes, -hide works} -setup { deleteWindows } -body { panedwindow .p -showhandle false frame .f1 -width 40 -height 100 -bg red frame .f2 -width 40 -height 100 -bg white frame .f3 -width 40 -height 100 -bg blue frame .f4 -width 40 -height 100 -bg green .p add .f1 .f2 .f3 .f4 pack .p update set result [list] lappend result [winfo ismapped .f1] [winfo ismapped .f2] \ [winfo ismapped .f3] [winfo ismapped .f4] lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \ [winfo width .f4] [winfo width .p] .p paneconfigure .f2 -hide 1 update lappend result [winfo ismapped .f1] [winfo ismapped .f2] \ [winfo ismapped .f3] [winfo ismapped .f4] lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \ [winfo width .f4] [winfo width .p] } -cleanup { deleteWindows } -result {1 1 1 1 40 40 40 40 171 1 0 1 1 40 40 40 40 128} test panedwindow-23.30 {ConfigurePanes, -hide works} -setup { deleteWindows } -body { panedwindow .p -showhandle false -width 130 -height 100 frame .f1 -width 40 -bg red frame .f2 -width 40 -bg white frame .f3 -width 40 -bg blue frame .f4 -width 40 -bg green .p add .f1 .f2 .f3 .f4 pack .p update set result [list] lappend result [winfo ismapped .f1] [winfo ismapped .f2] \ [winfo ismapped .f3] [winfo ismapped .f4] lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \ [winfo width .f4] [winfo width .p] .p paneconfigure .f2 -hide 1 update lappend result [winfo ismapped .f1] [winfo ismapped .f2] \ [winfo ismapped .f3] [winfo ismapped .f4] lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \ [winfo width .f4] [winfo width .p] } -cleanup { deleteWindows } -result {1 1 1 0 39 40 40 1 130 1 0 1 1 40 40 40 42 130} test panedwindow-23.31 {ConfigurePanes, -hide works, last pane stretches} -setup { deleteWindows } -body { panedwindow .p -showhandle false -width 200 -height 200 -borderwidth 0 frame .f1 -width 50 -bg red frame .f2 -width 50 -bg green frame .f3 -width 50 -bg blue .p add .f1 .f2 .f3 pack .p update set result [list] lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] .p paneconfigure .f2 -hide 1 update lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] } -cleanup { deleteWindows } -result {50 50 94 50 50 147} test panedwindow-23.32 {ConfigurePanes, -hide works, last pane stretches} -setup { deleteWindows } -body { panedwindow .p -showhandle false -width 200 -height 200 \ -borderwidth 0 -orient vertical frame .f1 -height 50 -bg red frame .f2 -height 50 -bg green frame .f3 -height 50 -bg blue .p add .f1 .f2 .f3 pack .p update set result [list] lappend result [winfo height .f1] [winfo height .f2] [winfo height .f3] .p paneconfigure .f2 -hide 1 update lappend result [winfo height .f1] [winfo height .f2] [winfo height .f3] } -cleanup { deleteWindows } -result {50 50 94 50 50 147} test panedwindow-23.33 {ConfigurePanes, -stretch first} -setup { deleteWindows } -body { panedwindow .p -showhandle false -height 100 -width 182 frame .f1 -width 40 -bg red frame .f2 -width 40 -bg white frame .f3 -width 40 -bg blue frame .f4 -width 40 -bg green .p add .f1 .f2 .f3 .f4 -stretch first pack .p update set result [list] lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \ [winfo width .f4] .p paneconfigure .f2 -hide 1 update lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \ [winfo width .f4] } -cleanup { deleteWindows } -result {51 40 40 40 94 40 40 40} test panedwindow-23.34 {ConfigurePanes, -stretch middle} -setup { deleteWindows } -body { panedwindow .p -showhandle false -height 100 -width 182 frame .f1 -width 40 -bg red frame .f2 -width 40 -bg white frame .f3 -width 40 -bg blue frame .f4 -width 40 -bg green .p add .f1 .f2 .f3 .f4 -stretch middle pack .p update set result [list] lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \ [winfo width .f4] .p paneconfigure .f2 -hide 1 update lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \ [winfo width .f4] } -cleanup { deleteWindows } -result {40 45 46 40 40 45 94 40} test panedwindow-23.35 {ConfigurePanes, -stretch always} -setup { deleteWindows } -body { panedwindow .p -showhandle false -height 100 -width 182 frame .f1 -width 40 -bg red frame .f2 -width 40 -bg white frame .f3 -width 40 -bg blue frame .f4 -width 40 -bg green .p add .f1 .f2 .f3 .f4 -stretch always pack .p update set result [list] lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \ [winfo width .f4] .p paneconfigure .f2 -hide 1 update lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \ [winfo width .f4] } -cleanup { deleteWindows } -result {42 43 43 43 58 43 58 58} test panedwindow-23.36 {ConfigurePanes, -stretch never} -setup { deleteWindows } -body { panedwindow .p -showhandle false -height 100 -width 182 frame .f1 -width 40 -bg red frame .f2 -width 40 -bg white frame .f3 -width 40 -bg blue frame .f4 -width 40 -bg green .p add .f1 .f2 .f3 .f4 -stretch never pack .p update set result [list] lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \ [winfo width .f4] .p paneconfigure .f2 -hide 1 update lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \ [winfo width .f4] } -cleanup { deleteWindows } -result {40 40 40 40 40 40 40 40} test panedwindow-24.1 {Unlink, remove a paned with -before/-after refs} -setup { deleteWindows } -body { # Bug 928413 set result {} panedwindow .pw label .pw.l1 -text Label1 label .pw.l2 -text Label2 label .pw.l3 -text Label3 .pw add .pw.l1 .pw add .pw.l3 .pw add .pw.l2 -before .pw.l3 lappend result [.pw panecget .pw.l2 -before] destroy .pw.l3 lappend result [.pw panecget .pw.l2 -before] .pw paneconfigure .pw.l2 -before .pw.l1 lappend result [.pw panecget .pw.l2 -before] } -cleanup { deleteWindows } -result {.pw.l3 {} .pw.l1} test panedwindow-25.1 {DestroyPanedWindow} -setup { deleteWindows } -body { # This test should not result in any memory leaks. panedwindow .p foreach w {.a .b .c .d .e .f .g .h .i .j .k .l .m .n .o .q .r .s .t} { .p add [button $w] } foreach w {.a .b .c .d .e .f .g .h .i .j .k .l .m .n .o .p .q .r .s .t} { destroy $w } set result {} } -result {} test panedwindow-25.2 {UnmapNotify and MapNotify events are propagated to slaves} -setup { deleteWindows } -body { panedwindow .pw .pw add [button .pw.b] pack .pw update set result [winfo ismapped .pw.b] pack forget .pw update lappend result [winfo ismapped .pw.b] lappend result [winfo ismapped .pw] pack .pw update lappend result [winfo ismapped .pw] lappend result [winfo ismapped .pw.b] destroy .pw .pw.b set result } -cleanup { deleteWindows } -result {1 0 0 1 1} test panedwindow-26.1 {PanedWindowIdentifyCoords} -setup { deleteWindows } -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] .p identify 0 0 } -cleanup { deleteWindows } -result {} test panedwindow-26.2 {PanedWindowIdentifyCoords, padding is included} -setup { deleteWindows } -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] .p identify 20 0 } -cleanup { deleteWindows } -result {0 sash} test panedwindow-26.3 {PanedWindowIdentifyCoords} -setup { deleteWindows } -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] .p identify 22 0 } -cleanup { deleteWindows } -result {0 sash} test panedwindow-26.4 {PanedWindowIdentifyCoords} -setup { deleteWindows } -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] .p identify 24 0 } -cleanup { deleteWindows } -result {0 sash} test panedwindow-26.5 {PanedWindowIdentifyCoords} -setup { deleteWindows } -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] .p identify 26 0 } -cleanup { deleteWindows } -result {0 sash} test panedwindow-26.6 {PanedWindowIdentifyCoords} -setup { deleteWindows } -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] .p identify 26 -1 } -cleanup { deleteWindows } -result {} test panedwindow-26.7 {PanedWindowIdentifyCoords} -setup { deleteWindows } -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] .p identify 26 100 } -cleanup { deleteWindows } -result {} test panedwindow-26.8 {PanedWindowIdentifyCoords} -setup { deleteWindows } -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -showhandle 1 -handlepad 5 \ -handlesize 6 .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] .p identify 22 4 } -cleanup { deleteWindows } -result {0 sash} test panedwindow-26.9 {PanedWindowIdentifyCoords} -setup { deleteWindows } -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -showhandle 1 -handlepad 5 \ -handlesize 6 .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] .p identify 22 5 } -cleanup { deleteWindows } -result {0 handle} test panedwindow-26.10 {PanedWindowIdentifyCoords} -setup { deleteWindows } -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -showhandle 1 -handlepad 5 \ -handlesize 8 .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] .p identify 20 5 } -cleanup { deleteWindows } -result {0 handle} test panedwindow-26.11 {PanedWindowIdentifyCoords} -setup { deleteWindows } -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -showhandle 1 -handlepad 5 \ -handlesize 8 .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] .p identify 20 0 } -cleanup { deleteWindows } -result {0 sash} test panedwindow-26.12 {PanedWindowIdentifyCoords} -setup { deleteWindows } -body { panedwindow .p -showhandle false -bd 0 -sashwidth 2 -sashpad 2 .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] \ [frame .f3 -bg green -width 20 -height 20] .p identify 48 0 } -cleanup { deleteWindows } -result {1 sash} test panedwindow-26.13 {identify subcommand errors} -setup { deleteWindows } -body { panedwindow .p -borderwidth 0 -sashpad 2 -sashwidth 4 .p identify } -cleanup { deleteWindows } -returnCodes error -result {wrong # args: should be ".p identify x y"} test panedwindow-26.14 {identify subcommand errors} -setup { deleteWindows } -body { panedwindow .p .p identify foo bar } -cleanup { deleteWindows } -returnCodes error -result {expected integer but got "foo"} test panedwindow-26.15 {identify subcommand errors} -setup { deleteWindows } -body { panedwindow .p .p identify 0 bar } -cleanup { deleteWindows } -returnCodes error -result {expected integer but got "bar"} test panedwindow-26.16 {PanedWindowIdentifyCoords} -setup { deleteWindows } -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -orient vertical .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] .p identify 0 0 } -cleanup { deleteWindows } -result {} test panedwindow-26.17 {PanedWindowIdentifyCoords, padding is included} -setup { deleteWindows } -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -orient vertical .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] .p identify 0 20 } -cleanup { deleteWindows } -result {0 sash} test panedwindow-26.18 {PanedWindowIdentifyCoords} -setup { deleteWindows } -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -orient vertical .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] .p identify 0 22 } -cleanup { deleteWindows } -result {0 sash} test panedwindow-26.19 {PanedWindowIdentifyCoords} -setup { deleteWindows } -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -orient vertical .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] .p identify 0 24 } -cleanup { deleteWindows } -result {0 sash} test panedwindow-26.20 {PanedWindowIdentifyCoords} -setup { deleteWindows } -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -orient vertical .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] .p identify 0 26 } -cleanup { deleteWindows } -result {0 sash} test panedwindow-26.21 {PanedWindowIdentifyCoords} -setup { deleteWindows } -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -orient vertical .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] .p identify -1 26 } -cleanup { deleteWindows } -result {} test panedwindow-26.22 {PanedWindowIdentifyCoords} -setup { deleteWindows } -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -orient vertical .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] .p identify 100 26 } -cleanup { deleteWindows } -result {} test panedwindow-26.23 {PanedWindowIdentifyCoords} -setup { deleteWindows } -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -showhandle 1 -handlepad 5 \ -handlesize 6 -orient vertical .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] .p identify 4 22 } -cleanup { deleteWindows } -result {0 sash} test panedwindow-26.24 {PanedWindowIdentifyCoords} -setup { deleteWindows } -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -showhandle 1 -handlepad 5 \ -handlesize 6 -orient vertical .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] .p identify 5 22 } -cleanup { deleteWindows } -result {0 handle} test panedwindow-26.25 {PanedWindowIdentifyCoords} -setup { deleteWindows } -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -showhandle 1 -handlepad 5 \ -handlesize 8 -orient vertical .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] .p identify 5 20 } -cleanup { deleteWindows } -result {0 handle} test panedwindow-26.26 {PanedWindowIdentifyCoords} -setup { deleteWindows } -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -showhandle 1 -handlepad 5 \ -handlesize 8 -orient vertical .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] .p identify 0 20 } -cleanup { deleteWindows } -result {0 sash} test panedwindow-26.27 {PanedWindowIdentifyCoords} -setup { deleteWindows } -body { panedwindow .p -showhandle false -bd 0 -sashwidth 2 -sashpad 2 -orient vertical .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] \ [frame .f3 -bg green -width 20 -height 20] .p identify 0 48 } -cleanup { deleteWindows } -result {1 sash} test panedwindow-27.1 {destroy the window cleanly on error [Bug #616589]} -setup { deleteWindows } -body { panedwindow .p -bogusopt bogus } -cleanup { deleteWindows } -returnCodes error -result {unknown option "-bogusopt"} test panedwindow-27.2 {destroy the window cleanly on rename [Bug #616589]} -setup { deleteWindows } -body { destroy .p panedwindow .p rename .p {} winfo exists .p } -cleanup { deleteWindows } -result {0} test panedwindow-28.1 {resizing width} -setup { deleteWindows } -body { panedwindow .p -bd 5 frame .f1 -width 100 -height 50 -bg blue frame .f2 -width 100 -height 50 -bg red .p add .f1 -sticky news .p add .f2 -sticky news pack .p -side top -fill both -expand 1 wm geometry . "" update # Note the width set a [winfo width .f2] # Increase the size by 10 regexp {^(\d+)x(\d+)} [wm geometry .] -> w h wm geometry . [expr {$w + 10}]x$h update set b "$a [winfo width .f2]" } -cleanup { deleteWindows } -result {100 110} test panedwindow-28.2 {resizing height} -setup { deleteWindows } -body { panedwindow .p -orient vertical -bd 5 frame .f1 -width 50 -height 100 -bg blue frame .f2 -width 50 -height 100 -bg red .p add .f1 -sticky news .p add .f2 -sticky news pack .p -side top -fill both -expand 1 wm geometry . "" update # Note the height set a [winfo height .f2] # Increase the size by 10 regexp {^(\d+)x(\d+)} [wm geometry .] -> w h wm geometry . ${w}x[expr {$h + 10}] update set b "$a [winfo height .f2]" } -cleanup { deleteWindows } -result {100 110} test panedwindow-29.1 {display on depths other than the default one} -constraints { pseudocolor8 haveTruecolor24 } -setup { deleteWindows } -body { toplevel .t -visual {truecolor 24} pack [panedwindow .t.p] .t.p add [frame .t.p.f1] [frame .t.p.f2] update # If we got here, we didn't crash and that's good } -cleanup { deleteWindows } -result {} test panedwindow-29.2 {display on depths other than the default one} -constraints { pseudocolor8 haveTruecolor24 } -setup { deleteWindows } -body { toplevel .t -visual {pseudocolor 8} pack [frame .t.f -visual {truecolor 24}] pack [panedwindow .t.f.p] .t.f.p add [frame .t.f.p.f1 -width 5] [frame .t.f.p.f2 -width 5] update .t.f.p proxy place 1 1 update .t.f.p proxy forget update # If we got here, we didn't crash and that's good } -cleanup { deleteWindows } -result {} # cleanup cleanupTests return tk8.6.5/tests/textMark.test0000644003604700454610000002346012377375532014353 0ustar dgp771div# This file is a Tcl script to test the code in the file tkTextMark.c. # This file is organized in the standard fashion for Tcl tests. # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. package require tcltest 2.2 namespace import ::tcltest::* tcltest::configure {*}$argv tcltest::loadTestedCommands destroy .t text .t -width 20 -height 10 pack append . .t {top expand fill} update .t debug on wm geometry . {} entry .t.e .t peer create .pt .t insert 1.0 "Line 1 abcdefghijklm 12345 Line 4 bOy GIrl .#@? x_yz !@#$% Line 7" # The statements below reset the main window; it's needed if the window # manager is mwm to make mwm forget about a previous minimum size setting. wm withdraw . wm minsize . 1 1 wm positionfrom . user wm deiconify . test textMark-1.1 {TkTextMarkCmd - missing option} -returnCodes error -body { .t mark } -result {wrong # args: should be ".t mark option ?arg ...?"} test textMark-1.2 {TkTextMarkCmd - bogus option} -returnCodes error -body { .t mark gorp } -match glob -result {bad mark option "gorp": must be *} test textMark-1.3 {TkTextMarkCmd - "gravity" option} -returnCodes error -body { .t mark gravity foo } -result {there is no mark named "foo"} test textMark-1.4 {TkTextMarkCmd - "gravity" option} -body { .t mark set x 1.3 .t insert 1.3 x list [.t mark gravity x] [.t index x] } -result {right 1.4} test textMark-1.5 {TkTextMarkCmd - "gravity" option} -body { .t mark set x 1.3 .t mark g x left .t insert 1.3 x list [.t mark gravity x] [.t index x] } -result {left 1.3} test textMark-1.6 {TkTextMarkCmd - "gravity" option} -body { .t mark set x 1.3 .t mark gravity x right .t insert 1.3 x list [.t mark gravity x] [.t index x] } -result {right 1.4} test textMark-1.7 {TkTextMarkCmd - "gravity" option} -returnCodes error -body { .t mark set x 1.3 .t mark gravity x gorp } -result {bad mark gravity "gorp": must be left or right} test textMark-1.8 {TkTextMarkCmd - "gravity" option} -returnCodes error -body { .t mark gravity } -result {wrong # args: should be ".t mark gravity markName ?gravity?"} test textMark-2.1 {TkTextMarkCmd - "names" option} -body { .t mark names 2 } -returnCodes error -result {wrong # args: should be ".t mark names"} test textMark-2.2 {TkTextMarkCmd - "names" option} -setup { .t mark unset {*}[.t mark names] } -body { lsort [.t mark na] } -result {current insert} test textMark-2.3 {TkTextMarkCmd - "names" option} -setup { .t mark unset {*}[.t mark names] } -body { .t mark set a 1.1 .t mark set "b c" 2.3 lsort [.t mark names] } -result {a {b c} current insert} test textMark-3.1 {TkTextMarkCmd - "set" option} -returnCodes error -body { .t mark set a } -result {wrong # args: should be ".t mark set markName index"} test textMark-3.2 {TkTextMarkCmd - "set" option} -returnCodes error -body { .t mark s a b c } -result {wrong # args: should be ".t mark set markName index"} test textMark-3.3 {TkTextMarkCmd - "set" option} -body { .t mark set a @x } -returnCodes error -result {bad text index "@x"} test textMark-3.4 {TkTextMarkCmd - "set" option} -body { .t mark set a 1.2 .t index a } -result 1.2 test textMark-3.5 {TkTextMarkCmd - "set" option} -body { .t mark set a end .t index a } -result {8.0} test textMark-4.1 {TkTextMarkCmd - "unset" option} -body { .t mark unset } -result {} test textMark-4.2 {TkTextMarkCmd - "unset" option} -body { .t mark set a 1.2 .t mark set b 2.3 .t mark unset a b .t index a } -returnCodes error -result {bad text index "a"} test textMark-4.2.1 {TkTextMarkCmd - "unset" option} -body { .t mark set a 1.2 .t mark set b 2.3 .t mark unset a b .t index b } -returnCodes error -result {bad text index "b"} test textMark-4.3 {TkTextMarkCmd - "unset" option} -body { .t mark set a 1.2 .t mark set b 2.3 .t mark set 49ers 3.1 .t mark unset {*}[.t mark names] lsort [.t mark names] } -result {current insert} test textMark-5.1 {TkTextMarkCmd - miscellaneous} -returnCodes error -body { .t mark } -result {wrong # args: should be ".t mark option ?arg ...?"} test textMark-5.2 {TkTextMarkCmd - miscellaneous} -returnCodes error -body { .t mark foo } -result {bad mark option "foo": must be gravity, names, next, previous, set, or unset} test textMark-6.1 {TkTextMarkSegToIndex} -body { .t mark set a 1.2 .t mark set b 1.2 .t mark set c 1.2 .t mark set d 1.4 list [.t index a] [.t index b] [.t index c ] [.t index d] } -result {1.2 1.2 1.2 1.4} test textMark-6.2 {TkTextMarkNameToIndex, with mark outside -startline/-endline range - bug 1630271} -body { .t mark set insert 1.0 .t configure -startline 2 set res [list [.t index insert] [.t index insert-1c] [.t get insert]] .t mark set insert end .t configure -endline 4 lappend res [.t index insert] } -cleanup { .t configure -startline {} -endline {} } -result {1.0 1.0 a 2.5} test textMark-6.3 {TkTextMarkNameToIndex, with mark outside -startline/-endline range - bug 1630271} -body { .t mark set mymark 1.0 .t configure -startline 2 list [catch {.t index mymark} msg] $msg } -cleanup { .t configure -startline {} -endline {} .t mark unset mymark } -result {1 {bad text index "mymark"}} test textMark-6.4 {TkTextMarkNameToIndex, with mark outside -startline/-endline range - bug 1630271} -body { .t mark set mymark 1.0 .t configure -startline 2 set res [list [catch {.t index mymark} msg] $msg] lappend res [.pt index mymark] .t configure -startline {} .pt configure -startline 4 lappend res [.t index mymark] lappend res [catch {.pt index mymark} msg] $msg lappend res [.t get mymark] lappend res [catch {.pt get mymark} msg] $msg } -cleanup { .t configure -startline {} -endline {} .pt configure -startline {} -endline {} .t mark unset mymark } -result {1 {bad text index "mymark"} 1.0 1.0 1 {bad text index "mymark"} L 1 {bad text index "mymark"}} test textMark-6.5 {insert and current marks in an empty peer - bug 3487407} -body { .t mark set insert 1.0 .t configure -start 5 -end 5 set res [.t index insert] } -cleanup { .t configure -startline {} -endline {} } -result {1.0} test textMark-7.1 {MarkFindNext - invalid mark name} -body { .t mark next bogus } -returnCodes error -result {bad text index "bogus"} test textMark-7.2 {MarkFindNext - marks at same location} -body { .t mark set insert 2.0 .t mark set current 2.0 .t mark next current } -result {insert} test textMark-7.3 {MarkFindNext - numerical starting mark} -body { .t mark set current 1.0 .t mark set insert 1.0 .t mark next 1.0 } -result {insert} test textMark-7.4 {MarkFindNext - mark on the same line} -setup { .t mark unset {*}[.t mark names] } -body { .t mark set current 1.0 .t mark set insert 1.1 .t mark next current } -result {insert} test textMark-7.5 {MarkFindNext - mark on the next line} -setup { .t mark unset {*}[.t mark names] } -body { .t mark set current 1.end .t mark set insert 2.0 .t mark next current } -result {insert} test textMark-7.6 {MarkFindNext - mark far away} -setup { .t mark unset {*}[.t mark names] } -body { .t mark set current 1.2 .t mark set insert 7.0 .t mark next current } -result {insert} test textMark-7.7 {MarkFindNext - mark on top of end} -setup { .t mark unset {*}[.t mark names] } -body { .t mark set current end .t mark next end } -result {current} test textMark-7.8 {MarkFindNext - no next mark} -setup { .t mark unset {*}[.t mark names] } -body { .t mark set current 1.0 .t mark set insert 3.0 .t mark next insert } -result {} test textMark-7.9 {MarkFindNext - mark set in a text widget and retrieved from a peer} -setup { .t mark unset {*}[.t mark names] } -body { .t mark set mymark 1.0 lsort [list [.pt mark next 1.0] [.pt mark next mymark] [.pt mark next insert]] } -result {current insert mymark} test textMark-8.1 {MarkFindPrev - invalid mark name} -body { .t mark prev bogus } -returnCodes error -result {bad text index "bogus"} test textMark-8.2 {MarkFindPrev - marks at same location} -body { .t mark set insert 2.0 .t mark set current 2.0 .t mark prev insert } -result {current} test textMark-8.3 {MarkFindPrev - numerical starting mark} -setup { .t mark unset {*}[.t mark names] } -body { .t mark set current 1.0 .t mark set insert 1.0 .t mark prev 1.1 } -result {current} test textMark-8.4 {MarkFindPrev - mark on the same line} -setup { .t mark unset {*}[.t mark names] } -body { .t mark set current 1.0 .t mark set insert 1.1 .t mark prev insert } -result {current} test textMark-8.5 {MarkFindPrev - mark on the previous line} -setup { .t mark unset {*}[.t mark names] } -body { .t mark set current 1.end .t mark set insert 2.0 .t mark prev insert } -result {current} test textMark-8.6 {MarkFindPrev - mark far away} -setup { .t mark unset {*}[.t mark names] } -body { .t mark set current 1.2 .t mark set insert 7.0 .t mark prev insert } -result {current} test textMark-8.7 {MarkFindPrev - mark on top of end} -setup { .t mark unset {*}[.t mark names] } -body { .t mark set insert 3.0 .t mark set current end .t mark prev end } -result {insert} test textMark-8.8 {MarkFindPrev - no previous mark} -setup { .t mark unset {*}[.t mark names] } -body { .t mark set current 1.0 .t mark set insert 3.0 .t mark prev current } -result {} test textMark-8.9 {MarkFindPrev - mark set in a text widget and retrieved from a peer} -setup { .t mark unset {*}[.t mark names] } -body { .t mark set mymark 1.0 lsort [list [.pt mark prev end] [.pt mark prev current] [.pt mark prev insert]] } -result {current insert mymark} destroy .pt destroy .t # cleanup cleanupTests return # Local Variables: # mode: tcl # End: tk8.6.5/tests/visual_bb.test0000644003604700454610000001001612377375532014513 0ustar dgp771div#!/usr/local/bin/wish -f # # This script displays provides visual tests for many of Tk's features. # Each test displays a window with various information in it, along # with instructions about how the window should appear. You can look # at the window to make sure it appears as expected. Individual tests # are kept in separate ".tcl" files in this directory. package require tcltest 2.2 namespace import ::tcltest::* tcltest::configure {*}$argv tcltest::loadTestedCommands set auto_path ". $auto_path" wm title . "Visual Tests for Tk" set testNum 1 # Each menu entry invokes a visual test file proc runTest {file} { global testNum test "2.$testNum" "testing $file" {userInteraction} { uplevel \#0 source [file join [testsDirectory] $file] concat "" } {} incr testNum } # The following procedure is invoked to print the contents of a canvas: proc lpr {c args} { exec lpr <<[eval [list $c postscript] $args] } proc end {} { cleanupTests set ::EndOfVisualTests 1 } # ---------------------------------------------------------------------- test 1.1 {running visual tests} -constraints userInteraction -body { #------------------------------------------------------- # The code below create the main window, consisting of a # menu bar and a message explaining the basic operation # of the program. #------------------------------------------------------- frame .menu -relief raised -borderwidth 1 message .msg -font {Times 18} -relief raised -width 4i \ -borderwidth 1 -text "This application provides a collection of visual tests for the Tk toolkit. Each menu entry invokes a test, which displays information on the screen. You can then verify visually that the information is being displayed in the correct way. The tests under the \"Postscript\" menu exercise the Postscript-generation capabilities of canvas widgets." pack .menu -side top -fill x pack .msg -side bottom -expand yes -fill both #------------------------------------------------------- # The code below creates all the menus, which invoke procedures # to create particular demonstrations of various widgets. #------------------------------------------------------- menubutton .menu.file -text "File" -menu .menu.file.m menu .menu.file.m .menu.file.m add command -label "Quit" -command end menubutton .menu.group1 -text "Group 1" -menu .menu.group1.m menu .menu.group1.m .menu.group1.m add command -label "Canvas arcs" -command {runTest arc.tcl} .menu.group1.m add command -label "Beveled borders in text widgets" \ -command {runTest bevel.tcl} .menu.group1.m add command -label "Colormap management" \ -command {runTest cmap.tcl} .menu.group1.m add command -label "Label/button geometry" \ -command {runTest butGeom.tcl} .menu.group1.m add command -label "Label/button colors" \ -command {runTest butGeom2.tcl} menubutton .menu.ps -text "Canvas Postscript" -menu .menu.ps.m menu .menu.ps.m .menu.ps.m add command -label "Rectangles and other graphics" \ -command {runTest canvPsGrph.tcl} .menu.ps.m add command -label "Text" \ -command {runTest canvPsText.tcl} .menu.ps.m add command -label "Bitmaps" \ -command {runTest canvPsBmap.tcl} .menu.ps.m add command -label "Images" \ -command {runTest canvPsImg.tcl} .menu.ps.m add command -label "Arcs" \ -command {runTest canvPsArc.tcl} pack .menu.file .menu.group1 .menu.ps -side left -padx 1m # Set up for keyboard-based menu traversal bind . { if {("%d" == "NotifyVirtual") && ("%m" == "NotifyNormal")} { focus .menu } } tk_menuBar .menu .menu.file .menu.group1 .menu.ps # Set up a class binding to allow objects to be deleted from a canvas # by clicking with mouse button 1: bind Canvas <1> {%W delete [%W find closest %x %y]} concat "" } -result {} if {![testConstraint userInteraction]} { cleanupTests } else { vwait EndOfVisualTests } tk8.6.5/tests/canvPsGrph.tcl0000644003604700454610000000626112456213337014422 0ustar dgp771div# This file creates a screen to exercise Postscript generation # for some of the graphical objects in canvases. It is part of the Tk # visual test suite, which is invoked via the "visual" script. catch {destroy .t} toplevel .t wm title .t "Postscript Tests for Canvases" wm iconname .t "Postscript" wm geom .t +0+0 wm minsize .t 1 1 set c .t.mid.c message .t.m -text {This screen exercises the Postscript-generation abilities of Tk canvas widgets. Select what you want to display with the buttons below, then click on "Print" to print it to your default printer. You can click on items in the canvas to delete them.} -width 4i pack .t.m -side top -fill both frame .t.top pack .t.top -side top -fill both set what rect radiobutton .t.top.rect -text Rectangles -variable what -value rect \ -command "mkObjs $c" -relief flat radiobutton .t.top.oval -text Ovals -variable what -value oval \ -command "mkObjs $c" -relief flat radiobutton .t.top.poly -text Polygons -variable what -value poly \ -command "mkObjs $c" -relief flat radiobutton .t.top.line -text Lines -variable what -value line \ -command "mkObjs $c" -relief flat pack .t.top.rect .t.top.oval .t.top.poly .t.top.line \ -side left -pady 2m -ipadx 2m -ipady 1m -expand 1 frame .t.bot pack .t.bot -side bottom -fill both button .t.bot.quit -text Quit -command {destroy .t} button .t.bot.print -text Print -command "lpr $c" pack .t.bot.print .t.bot.quit -side left -pady 1m -expand 1 frame .t.mid -relief sunken -bd 2 pack .t.mid -side top -expand yes -fill both -padx 2m -pady 2m canvas $c -width 400 -height 350 -bd 0 -relief sunken pack $c -expand yes -fill both -padx 1 -pady 1 proc mkObjs c { global what $c delete all if {$what == "rect"} { $c create rect 0 0 400 350 -outline black $c create rect 2 2 100 50 -fill black -stipple gray25 $c create rect -20 180 80 320 -fill black -stipple gray50 -width .5c $c create rect 200 -20 240 20 -fill black $c create rect 380 200 420 240 -fill black $c create rect 200 330 240 370 -fill black } if {$what == "oval"} { $c create oval 50 10 150 80 -fill black -stipple gray25 -outline {} $c create oval 100 100 200 150 -outline {} -fill black -stipple gray50 $c create oval 250 100 400 300 -width .5c } if {$what == "poly"} { $c create poly 100 200 200 50 300 200 -smooth yes -stipple gray25 \ -outline black -width 4 $c create poly 100 300 100 250 350 250 350 300 350 300 100 300 100 300 \ -fill red -smooth yes $c create poly 20 10 40 10 40 60 80 60 80 25 30 25 30 \ 35 50 35 50 45 20 45 $c create poly 300 20 300 120 380 80 320 100 -fill blue -outline black $c create poly 20 200 100 220 90 100 40 250 \ -fill {} -outline brown -width 3 } if {$what == "line"} { $c create line 20 20 120 20 -arrow both -width 5 $c create line 20 80 150 80 20 200 150 200 -smooth yes $c create line 150 20 150 150 250 150 -width .5c -smooth yes \ -arrow both -arrowshape {.75c 1.0c .5c} -stipple gray25 $c create line 50 340 100 250 150 340 -join round -cap round -width 10 $c create line 200 340 250 250 300 340 -join bevel -cap project \ -width 10 $c create line 300 20 380 20 300 150 380 150 -join miter -cap butt \ -width 10 -stipple gray25 } } mkObjs $c tk8.6.5/tests/raise.test0000644003604700454610000002143512377375532013657 0ustar dgp771div# This file is a Tcl script to test out Tk's "raise" and # "lower" commands, plus associated code to manage window # stacking order. It is organized in the standard fashion # for Tcl tests. # # Copyright (c) 1993-1994 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands namespace import -force tcltest::test # Procedure to create a bunch of overlapping windows, which should # make it easy to detect differences in order. proc raise_setup {} { foreach i [winfo child .raise] { destroy $i } foreach i {a b c d e} { label .raise.$i -text $i -relief raised -bd 2 } place .raise.a -x 20 -y 60 -width 60 -height 80 place .raise.b -x 60 -y 60 -width 60 -height 80 place .raise.c -x 100 -y 60 -width 60 -height 80 place .raise.d -x 40 -y 20 -width 100 -height 60 place .raise.e -x 40 -y 120 -width 100 -height 60 } # Procedure to return information about which windows are on top # of which other windows. proc raise_getOrder {} { set x [winfo rootx .raise] set y [winfo rooty .raise] list [winfo name [winfo containing [expr $x+50] [expr $y+70]]] \ [winfo name [winfo containing [expr $x+90] [expr $y+70]]] \ [winfo name [winfo containing [expr $x+130] [expr $y+70]]] \ [winfo name [winfo containing [expr $x+70] [expr $y+100]]] \ [winfo name [winfo containing [expr $x+110] [expr $y+100]]] \ [winfo name [winfo containing [expr $x+50] [expr $y+130]]] \ [winfo name [winfo containing [expr $x+90] [expr $y+130]]] \ [winfo name [winfo containing [expr $x+130] [expr $y+130]]] } # Procedure to set up a collection of top-level windows proc raise_makeToplevels {} { deleteWindows foreach i {.raise1 .raise2 .raise3} { toplevel $i wm geom $i 150x100+0+0 update } } toplevel .raise wm geom .raise 250x200+0+0 test raise-1.1 {preserve creation order} -body { raise_setup tkwait visibility .raise.e raise_getOrder } -result {d d d b c e e e} test raise-1.2 {preserve creation order} -constraints testmakeexist -body { raise_setup testmakeexist .raise.a update raise_getOrder } -result {d d d b c e e e} test raise-1.3 {preserve creation order} -constraints testmakeexist -body { raise_setup testmakeexist .raise.c update raise_getOrder } -result {d d d b c e e e} test raise-1.4 {preserve creation order} -constraints testmakeexist -body { raise_setup testmakeexist .raise.e update raise_getOrder } -result {d d d b c e e e} test raise-1.5 {preserve creation order} -constraints testmakeexist -body { raise_setup testmakeexist .raise.d .raise.c .raise.b update raise_getOrder } -result {d d d b c e e e} test raise-2.1 {raise internal windows before creation} -body { raise_setup raise .raise.a update raise_getOrder } -result {a d d a c a e e} test raise-2.2 {raise internal windows before creation} -body { raise_setup raise .raise.c update raise_getOrder } -result {d d c b c e e c} test raise-2.3 {raise internal windows before creation} -body { raise_setup raise .raise.e update raise_getOrder } -result {d d d b c e e e} test raise-2.4 {raise internal windows before creation} -body { raise_setup raise .raise.e .raise.a update raise_getOrder } -result {d d d b c e b c} test raise-2.5 {raise internal windows before creation} -body { raise_setup raise .raise.a .raise.d update raise_getOrder } -result {a d d a c e e e} test raise-3.1 {raise internal windows after creation} -body { raise_setup update raise .raise.a .raise.d raise_getOrder } -result {a d d a c e e e} test raise-3.2 {raise internal windows after creation} -constraints { testmakeexist } -body { raise_setup testmakeexist .raise.a .raise.b raise .raise.a .raise.b update raise_getOrder } -result {d d d a c e e e} test raise-3.3 {raise internal windows after creation} -constraints { testmakeexist } -body { raise_setup testmakeexist .raise.a .raise.d raise .raise.a .raise.b update raise_getOrder } -result {d d d a c e e e} test raise-3.4 {raise internal windows after creation} -constraints { testmakeexist } -body { raise_setup testmakeexist .raise.a .raise.c .raise.d raise .raise.a .raise.b update raise_getOrder } -result {d d d a c e e e} test raise-4.1 {raise relative to nephews} -body { raise_setup update frame .raise.d.child raise .raise.a .raise.d.child raise_getOrder } -result {a d d a c e e e} test raise-4.2 {raise relative to nephews} -setup { destroy .raise2 } -body { raise_setup update frame .raise2 raise .raise.a .raise2 } -cleanup { destroy .raise2 } -returnCodes error -result {can't raise ".raise.a" above ".raise2"} test raise-5.1 {lower internal windows} -body { raise_setup update lower .raise.d raise_getOrder } -result {a b c b c e e e} test raise-5.2 {lower internal windows} -body { raise_setup update lower .raise.d .raise.b raise_getOrder } -result {d b c b c e e e} test raise-5.3 {lower internal windows} -body { raise_setup update lower .raise.a .raise.e raise_getOrder } -result {a d d a c e e e} test raise-5.4 {lower internal windows} -setup { destroy .raise2 } -body { raise_setup update frame .raise2 lower .raise.a .raise2 } -cleanup { destroy .raise2 } -returnCodes error -result {can't lower ".raise.a" below ".raise2"} test raise-6.1 {raise/lower toplevel windows} -constraints { nonPortable } -body { raise_makeToplevels update raise .raise1 winfo containing [winfo rootx .raise1] [winfo rooty .raise1] } -result {.raise1} test raise-6.2 {raise/lower toplevel windows} -constraints { nonPortable } -body { raise_makeToplevels update raise .raise2 winfo containing [winfo rootx .raise1] [winfo rooty .raise1] } -result {.raise2} test raise-6.3 {raise/lower toplevel windows} -constraints { nonPortable } -body { raise_makeToplevels update raise .raise3 raise .raise2 raise .raise1 .raise3 set result [winfo containing [winfo rootx .raise1] \ [winfo rooty .raise1]] destroy .raise2 update after 500 list $result [winfo containing [winfo rootx .raise1] \ [winfo rooty .raise1]] } -result {.raise2 .raise1} test raise-6.4 {raise/lower toplevel windows} -constraints { nonPortable } -body { raise_makeToplevels update raise .raise2 raise .raise1 lower .raise3 .raise1 set result [winfo containing [winfo rootx .raise1] \ [winfo rooty .raise1]] wm geometry .raise2 +30+30 wm geometry .raise1 +60+60 destroy .raise1 update after 500 list $result [winfo containing [winfo rootx .raise2] \ [winfo rooty .raise2]] } -result {.raise1 .raise3} test raise-6.5 {raise/lower toplevel windows} -constraints { nonPortable } -body { raise_makeToplevels raise .raise1 set time [lindex [time {raise .raise1}] 0] expr {$time < 2000000} } -result 1 test raise-6.6 {raise/lower toplevel windows} -constraints { nonPortable } -body { raise_makeToplevels update raise .raise2 raise .raise1 raise .raise3 frame .raise1.f1 frame .raise1.f1.f2 lower .raise3 .raise1.f1.f2 set result [winfo containing [winfo rootx .raise1] \ [winfo rooty .raise1]] destroy .raise1 update after 500 list $result [winfo containing [winfo rootx .raise2] \ [winfo rooty .raise2]] } -result {.raise1 .raise3} test raise-7.1 {errors in raise/lower commands} -body { raise } -returnCodes error -result {wrong # args: should be "raise window ?aboveThis?"} test raise-7.2 {errors in raise/lower commands} -body { raise a b c } -returnCodes error -result {wrong # args: should be "raise window ?aboveThis?"} test raise-7.3 {errors in raise/lower commands} -body { raise badName } -returnCodes error -result {bad window path name "badName"} test raise-7.4 {errors in raise/lower commands} -body { raise . badName2 } -returnCodes error -result {bad window path name "badName2"} test raise-7.5 {errors in raise/lower commands} -body { lower } -returnCodes error -result {wrong # args: should be "lower window ?belowThis?"} test raise-7.6 {errors in raise/lower commands} -body { lower a b c } -returnCodes error -result {wrong # args: should be "lower window ?belowThis?"} test raise-7.7 {errors in raise/lower commands} -body { lower badName3 } -returnCodes error -result {bad window path name "badName3"} test raise-7.8 {errors in raise/lower commands} -body { lower . badName4 } -returnCodes error -result {bad window path name "badName4"} deleteWindows # cleanup cleanupTests return tk8.6.5/tests/winWm.test0000644003604700454610000003554312377375532013662 0ustar dgp771div# This file tests is a Tcl script to test the procedures in the file # tkWinWm.c. It is organized in the standard fashion for Tcl tests. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1996 by Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. package require tcltest 2.2 namespace import ::tcltest::* tcltest::configure {*}$argv tcltest::loadTestedCommands test winWm-1.1 {TkWmMapWindow} -constraints win -setup { destroy .t } -body { toplevel .t wm override .t 1 wm geometry .t +0+0 update list [winfo rootx .t] [winfo rooty .t] } -cleanup { destroy .t } -result {0 0} test winWm-1.2 {TkWmMapWindow} -constraints win -setup { destroy .t } -body { toplevel .t wm transient .t . update wm iconify . update wm deiconify . update wm iconify .t } -cleanup { destroy .t } -returnCodes error -result {can't iconify ".t": it is a transient} test winWm-1.3 {TkWmMapWindow} -constraints win -setup { destroy .t } -body { toplevel .t update toplevel .t2 update expr {[winfo x .t] != [winfo x .t2]} } -cleanup { destroy .t .t2 } -result 1 test winWm-1.4 {TkWmMapWindow} -constraints win -setup { destroy .t } -body { toplevel .t wm geometry .t +10+10 update toplevel .t2 wm geometry .t2 +40+10 update list [winfo x .t] [winfo x .t2] } -cleanup { destroy .t .t2 } -result {10 40} test winWm-1.5 {TkWmMapWindow} -constraints win -setup { destroy .t } -body { toplevel .t wm iconify .t update wm state .t } -result {iconic} test winWm-2.1 {TkpWmSetState} -constraints win -setup { destroy .t } -body { toplevel .t wm geometry .t 150x50+10+10 update set result [wm state .t] wm iconify .t update lappend result [wm state .t] wm deiconify .t update lappend result [wm state .t] } -cleanup { destroy .t } -result {normal iconic normal} test winWm-2.2 {TkpWmSetState} -constraints win -setup { destroy .t } -body { toplevel .t wm geometry .t 150x50+10+10 update set result [wm state .t] wm withdraw .t update lappend result [wm state .t] wm iconify .t update lappend result [wm state .t] wm deiconify .t update lappend result [wm state .t] } -cleanup { destroy .t } -result {normal withdrawn iconic normal} test winWm-2.3 {TkpWmSetState} -constraints win -setup { destroy .t } -body { toplevel .t wm geometry .t 150x50+10+10 update set result [wm state .t] wm state .t withdrawn update lappend result [wm state .t] wm state .t iconic update lappend result [wm state .t] wm state .t normal update lappend result [wm state .t] } -cleanup { destroy .t } -result {normal withdrawn iconic normal} test winWm-2.4 {TkpWmSetState} -constraints win -setup { destroy .t set result {} } -body { toplevel .t wm geometry .t 150x50+10+10 update lappend result [list [wm state .t] [wm geometry .t]] wm iconify .t update lappend result [list [wm state .t] [wm geometry .t]] wm geometry .t 200x50+10+10 update lappend result [list [wm state .t] [wm geometry .t]] wm deiconify .t update lappend result [list [wm state .t] [wm geometry .t]] } -cleanup { destroy .t } -result {{normal 150x50+10+10} {iconic 150x50+10+10} {iconic 150x50+10+10} {normal 200x50+10+10}} test winWm-3.1 {ConfigureTopLevel: window geometry propagation} -constraints { win } -setup { destroy .t } -body { toplevel .t wm geometry .t +0+0 button .t.b pack .t.b update set x [winfo x .t.b] destroy .t toplevel .t wm geometry .t +0+0 button .t.b update pack .t.b update expr {$x == [winfo x .t.b]} } -cleanup { destroy .t } -result 1 test winWm-4.1 {ConfigureTopLevel: menu resizing} -constraints win -setup { destroy .t } -body { toplevel .t frame .t.f -width 100 -height 50 pack .t.f menu .t.m .t.m add command -label "thisisreallylong" .t configure -menu .t.m wm geometry .t -0-0 update set menuheight [winfo y .t] .t.m add command -label "thisisreallylong" wm geometry .t -0-0 update set menuheight [expr {$menuheight - [winfo y .t]}] destroy .t toplevel .t frame .t.f -width 150 -height 50 -background red pack .t.f wm geometry .t -0-0 update set y [winfo y .t] menu .t.m .t.m add command -label foo .t configure -menu .t.m update expr {$y - [winfo y .t] eq $menuheight + 1} } -cleanup { destroy .t } -result 1 # This test works on 8.0p2 but has not worked on anything since 8.2. # It would be very strange to have a windows application increase the size # of the clientarea when a menu wraps so I believe this test to be wrong. # Original result was {50 50 50} new result may depend on the default menu # font test winWm-5.1 {UpdateGeometryInfo: menu resizing} -constraints win -setup { destroy .t set result {} } -body { toplevel .t frame .t.f -width 150 -height 50 -background red pack .t.f update set result [winfo height .t] menu .t.m .t.m add command -label foo .t configure -menu .t.m update lappend result [winfo height .t] .t.m add command -label "thisisreallylong" .t.m add command -label "thisisreallylong" update lappend result [winfo height .t] } -cleanup { destroy .t } -result {50 50 31} test winWm-5.2 {UpdateGeometryInfo: menu resizing} -constraints win -setup { destroy .t } -body { set result {} toplevel .t frame .t.f -width 150 -height 50 -background red pack .t.f wm geometry .t -0-0 update set y [winfo rooty .t] lappend result [winfo height .t] menu .t.m .t configure -menu .t.m .t.m add command -label foo .t.m add command -label "thisisreallylong" .t.m add command -label "thisisreallylong" update lappend result [winfo height .t] lappend result [expr {$y - [winfo rooty .t]}] destroy .t return $result } -cleanup { destroy .t } -result {50 50 0} test winWm-6.1 {wm attributes} -constraints win -setup { destroy .t } -body { toplevel .t wm attributes .t } -cleanup { destroy .t } -result {-alpha 1.0 -transparentcolor {} -disabled 0 -fullscreen 0 -toolwindow 0 -topmost 0} test winWm-6.2 {wm attributes} -constraints win -setup { destroy .t } -body { toplevel .t wm attributes .t -disabled } -cleanup { destroy .t } -result {0} test winWm-6.3 {wm attributes} -constraints win -setup { destroy .t } -body { # This isn't quite the correct error message yet, but it works. toplevel .t wm attributes .t -foo } -cleanup { destroy .t } -returnCodes error -result {wrong # args: should be "wm attributes window ?-alpha ?double?? ?-transparentcolor ?color?? ?-disabled ?bool?? ?-fullscreen ?bool?? ?-toolwindow ?bool?? ?-topmost ?bool??"} test winWm-6.4 {wm attributes -alpha} -constraints win -setup { destroy .t } -body { # Expect this to return all 1.0 {} on pre-2K/XP toplevel .t set res [wm attributes .t -alpha] # we don't return on set yet lappend res [wm attributes .t -alpha 0.5] lappend res [wm attributes .t -alpha] lappend res [wm attributes .t -alpha -100] lappend res [wm attributes .t -alpha] lappend res [wm attributes .t -alpha 100] lappend res [wm attributes .t -alpha] return $res } -cleanup { destroy .t } -result {1.0 {} 0.5 {} 0.0 {} 1.0} test winWm-6.5 {wm attributes -alpha} -constraints win -setup { destroy .t } -body { toplevel .t wm attributes .t -alpha foo } -cleanup { destroy .t } -returnCodes error -result {expected floating-point number but got "foo"} test winWm-6.6 {wm attributes -alpha} -constraints win -setup { destroy .t } -body { # This test is just to show off -alpha toplevel .t wm attributes .t -alpha 0.2 pack [label .t.l -text "Alpha Toplevel" -font "Helvetica 18 bold"] tk::PlaceWindow .t center update if {$::tcl_platform(osVersion) >= 5.0} { for {set i 0.2} {$i < 0.99} {set i [expr {$i+0.02}]} { wm attributes .t -alpha $i update idle after 20 } for {set i 0.99} {$i > 0.2} {set i [expr {$i-0.02}]} { wm attributes .t -alpha $i update idle after 20 } } } -cleanup { destroy .t } -result {} test winWm-6.7 {wm attributes -transparentcolor} -constraints win -setup { destroy .t set res {} } -body { # Expect this to return all "" on pre-2K/XP toplevel .t lappend res [wm attributes .t -transparentcolor] # we don't return on set yet lappend res [wm attributes .t -trans black] lappend res [wm attributes .t -trans] lappend res [wm attributes .t -trans "#FFFFFF"] lappend res [wm attributes .t -trans] } -cleanup { destroy .t } -result [list {} {} black {} "#FFFFFF"] test winWm-6.8 {wm attributes -transparentcolor} -constraints win -setup { destroy .t } -body { destroy .t toplevel .t wm attributes .t -tr foo } -cleanup { destroy .t } -returnCodes error -result {unknown color name "foo"} test winWm-7.1 {deiconify on an unmapped toplevel will raise \ the window and set the focus} -constraints { win } -setup { destroy .t } -body { toplevel .t lower .t focus -force . wm deiconify .t update list [wm stackorder .t isabove .] [focus] } -cleanup { destroy .t } -result {1 .t} test winWm-7.2 {deiconify on an already mapped toplevel\ will raise the window and set the focus} -constraints { win } -setup { destroy .t } -body { toplevel .t lower .t update focus -force . wm deiconify .t update list [wm stackorder .t isabove .] [focus] } -cleanup { destroy .t } -result {1 .t} test winWm-7.3 {UpdateWrapper must maintain Z order} -constraints win -setup { destroy .t } -body { destroy .t toplevel .t lower .t update set res [wm stackorder .t isbelow .] wm resizable .t 0 0 update list $res [wm stackorder .t isbelow .] } -cleanup { destroy .t } -result {1 1} test winWm-7.4 {UpdateWrapper must maintain focus} -constraints win -setup { destroy .t } -body { toplevel .t focus -force .t update set res [focus] wm resizable .t 0 0 update list $res [focus] } -cleanup { destroy .t } -result {.t .t} test winWm-8.1 {Tk_WmCmd procedure, "iconphoto" option} -constraints win -body { wm iconph . } -returnCodes error -result {wrong # args: should be "wm iconphoto window ?-default? image1 ?image2 ...?"} test winWm-8.2 {Tk_WmCmd procedure, "iconphoto" option} -constraints win -setup { destroy .t } -body { toplevel .t image create photo blank16 -width 16 -height 16 image create photo blank32 -width 32 -height 32 # This should just make blank icons for the window wm iconphoto .t blank16 blank32 image delete blank16 blank32 } -cleanup { destroy .t } -result {} test winWm-9.0 "Bug #2799589 - delayed activation of destroyed window" -constraints win -setup { proc winwm90click {w} { if {![winfo ismapped $w]} { update } event generate $w focus -force $w event generate $w -x 5 -y 5 event generate $w -x 5 -y 5 } proc winwm90proc3 {} { global winwm90done winwm90check set w .sd toplevel $w pack [button $w.b -text "OK" -command {set winwm90check 1}] bind $w.b {after idle {winwm90click %W}} update idletasks tkwait visibility $w grab $w tkwait variable winwm90check grab release $w destroy $w after idle {set winwm90done ok} } proc winwm90proc2 {w} { winwm90proc3; destroy $w } proc winwm90proc1 {w} { toplevel $w pack [button $w.b -text "Do dialog" -command [list winwm90proc2 $w]] bind $w.b {bind %W {}; after idle {winwm90click %W}} } global winwm90done set winwm90done wait toplevel .t } -body { pack [button .t.b -text "Show" -command {winwm90proc1 .tx}] bind .t.b {bind %W {}; after idle {winwm90click %W}} after 5000 {set winwm90done timeout} vwait winwm90done set winwm90done } -cleanup { foreach cmd {proc1 proc2 proc3 click} { rename winwm90$cmd {} } destroy .tx .t .sd } -result {ok} test winWm-9.1 "delayed activation of grabbed destroyed window" -constraints win -setup { proc winwm91click {w} { if {![winfo ismapped $w]} { update } event generate $w focus -force $w event generate $w -x 5 -y 5 event generate $w -x 5 -y 5 } proc winwm91proc3 {} { global winwm91done winwm91check set w .sd toplevel $w pack [button $w.b -text "OK" -command {set winwm91check 1}] bind $w.b {after idle {winwm91click %W}} update idletasks tkwait visibility $w grab $w tkwait variable winwm91check #skip the release: #grab release $w destroy $w after idle {set winwm91done ok} } proc winwm91proc2 {w} { winwm91proc3; destroy $w } proc winwm91proc1 {w} { toplevel $w pack [button $w.b -text "Do dialog" -command [list winwm91proc2 $w]] bind $w.b {bind %W {}; after idle {winwm91click %W}} } destroy .t global winwm91done set winwm91done wait toplevel .t } -body { pack [button .t.b -text "Show" -command {winwm91proc1 .tx}] bind .t.b {bind %W {}; after idle {winwm91click %W}} after 5000 {set winwm91done timeout} vwait winwm91done set winwm91done } -cleanup { foreach cmd {proc1 proc2 proc3 click} { rename winwm91$cmd {} } destroy .tx .t .sd } -result {ok} test winWm-9.2 "check wm forget for unmapped parent (#3205464,#2967911)" -setup { destroy .t toplevel .t set winwm92 {} frame .t.f -background blue -height 200 -width 200 frame .t.f.x -background red -height 100 -width 100 } -body { pack .t.f.x pack .t.f lappend aid [after 2000 {set ::winwm92 timeout}] [after 100 { wm manage .t.f wm iconify .t lappend aid [after 100 { wm forget .t.f wm deiconify .t lappend aid [after 100 { pack .t.f lappend aid [after 100 { set ::winwm92 [expr { [winfo rooty .t.f.x] == 0 ? "failed" : "ok"}]}] }] }] }] vwait ::winwm92 foreach id $aid { after cancel $id } set winwm92 } -cleanup { destroy .t.f.x .t.f .t unset -nocomplain winwm92 aid id } -result ok destroy .t # cleanup cleanupTests return # Local variables: # mode: tcl # End: tk8.6.5/tests/color.test0000644003604700454610000002054312077535536013670 0ustar dgp771div# This file is a Tcl script to test out the procedures in the file # tkColor.c. It is organized in the standard fashion for Tcl tests. # # Copyright (c) 1995-1998 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. package require tcltest 2.1 eval tcltest::configure $argv tcltest::loadTestedCommands # cname -- # Returns a proper name for a color, given its intensities. # # Arguments: # r, g, b - Intensities on a 0-255 scale. proc cname {r g b} { format #%02x%02x%02x $r $g $b } proc cname4 {r g b} { format #%04x%04x%04x $r $g $b } # mkColors -- # Creates a canvas and fills it with a 2-D array of squares, each of a # different color. # # Arguments: # c - Name of canvas window to create. # width - Number of squares in each row. # height - Number of squares in each column. # r, g, b - Initial value for red, green, and blue intensities. # rx, gx, bx - Change in intensities between adjacent elements in row. # ry, gy, by - Change in intensities between adjacent elements in column. proc mkColors {c width height r g b rx gx bx ry gy by} { catch {destroy $c} canvas $c -width 400 -height 200 -bd 0 for {set y 0} {$y < $height} {incr y} { for {set x 0} {$x < $width} {incr x} { set color [format #%02x%02x%02x [expr $r + $y*$ry + $x*$rx] \ [expr $g + $y*$gy + $x*$gx] [expr $b + $y*$by + $x*$bx]] $c create rectangle [expr 10*$x] [expr 20*$y] \ [expr 10*$x + 10] [expr 20*$y + 20] -outline {} \ -fill $color } } } # closest - # Given intensities between 0 and 255, return the closest intensities # that the server can provide. # # Arguments: # w - Window in which to lookup color # r, g, b - Desired intensities, between 0 and 255. proc closest {w r g b} { set vals [winfo rgb $w [cname $r $g $b]] list [expr [lindex $vals 0]/256] [expr [lindex $vals 1]/256] \ [expr [lindex $vals 2]/256] } # c255 - # Given a list of red, green, and blue intensities, scale them # down to a 0-255 range. # # Arguments: # vals - List of intensities. proc c255 {vals} { list [expr {[lindex $vals 0]/256}] [expr {[lindex $vals 1]/256}] \ [expr {[lindex $vals 2]/256}] } # colorsFree -- # # Returns 1 if there appear to be free colormap entries in a window, # 0 otherwise. # # Arguments: # w - Name of window in which to check. # red, green, blue - Intensities to use in a trial color allocation # to see if there are colormap entries free. 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) } if {[testConstraint psuedocolor8]} { toplevel .t -visual {pseudocolor 8} -colormap new wm geom .t +0+0 mkColors .t.c 40 6 0 0 0 0 6 0 0 0 40 pack .t.c update testConstraint colorsFree [colorsFree .t.c 101 233 17] if {[testConstraint colorsFree]} { mkColors .t.c2 20 1 250 0 0 -10 0 0 0 0 0 pack .t.c2 testConstraint colorsFree [expr {![colorsFree .t.c]}] } destroy .t.c .t.c2 } test color-1.1 {Tk_AllocColorFromObj - converting internal reps} colorsFree { set x green lindex $x 0 destroy .b1 button .b1 -foreground $x -text .b1 lindex $x 0 testcolor green } {{1 0}} test color-1.2 {Tk_AllocColorFromObj - discard stale color} colorsFree { set x green destroy .b1 .b2 button .b1 -foreground $x -text First destroy .b1 set result {} lappend result [testcolor green] button .b2 -foreground $x -text Second lappend result [testcolor green] } {{} {{1 1}}} test color-1.3 {Tk_AllocColorFromObj - reuse existing color} colorsFree { set x green destroy .b1 .b2 button .b1 -foreground $x -text First set result {} lappend result [testcolor green] button .b2 -foreground $x -text Second pack .b1 .b2 -side top lappend result [testcolor green] } {{{1 1}} {{2 1}}} test color-1.4 {Tk_AllocColorFromObj - try other colors in list} colorsFree { set x purple destroy .b1 .b2 .t.b button .b1 -foreground $x -text First pack .b1 -side top set result {} lappend result [testcolor purple] button .t.b -foreground $x -text Second pack .t.b -side top lappend result [testcolor purple] button .b2 -foreground $x -text Third pack .b2 -side top lappend result [testcolor purple] } {{{1 1}} {{1 1} {1 0}} {{1 0} {2 1}}} test color-1.5 {Color table} nonPortable { set fd [open ../xlib/rgb.txt] set result {} while {[gets $fd line] != -1} { if {[string index $line 0] == "!"} continue set rgb [c255 [winfo rgb . [lrange $line 3 end]]] if {$rgb != [lrange $line 0 2] } { append result $line\n } } return $result } {} test color-2.1 {Tk_GetColor procedure} colorsFree { c255 [winfo rgb .t #FF0000] } {255 0 0} test color-2.2 {Tk_GetColor procedure} colorsFree { list [catch {winfo rgb .t noname} msg] $msg } {1 {unknown color name "noname"}} test color-2.3 {Tk_GetColor procedure} colorsFree { c255 [winfo rgb .t #123456] } {18 52 86} test color-2.4 {Tk_GetColor procedure} colorsFree { list [catch {winfo rgb .t #xyz} msg] $msg } {1 {invalid color name "#xyz"}} test color-2.5 {Tk_GetColor procedure} colorsFree { winfo rgb .t #00FF00 } {0 65535 0} test color-2.6 {Tk_GetColor procedure} {colorsFree nonPortable} { # Red doesn't always map to *pure* red winfo rgb .t red } {65535 0 0} test color-2.7 {Tk_GetColor procedure} colorsFree { winfo rgb .t #ff0000 } {65535 0 0} test color-3.1 {Tk_FreeColor procedure, reference counting} colorsFree { eval destroy [winfo child .t] mkColors .t.c 40 6 0 240 240 0 -6 0 0 0 -40 pack .t.c mkColors .t.c2 20 1 250 0 0 -10 0 0 0 0 0 pack .t.c2 update set last [.t.c2 create rectangle 50 50 70 60 -outline {} \ -fill [cname 0 240 240]] .t.c delete 1 set result [colorsFree .t] .t.c2 delete $last lappend result [colorsFree .t] } {0 1} test color-3.2 {Tk_FreeColor procedure, flushing stressed cmap information} colorsFree { eval destroy [winfo child .t] mkColors .t.c 40 6 0 240 240 0 -6 0 0 0 -40 pack .t.c mkColors .t.c2 20 1 250 0 0 -10 0 0 0 0 0 mkColors .t.c2 20 1 250 250 0 -10 -10 0 0 0 0 pack .t.c2 update closest .t 241 241 1 } {240 240 0} test color-3.3 {Tk_FreeColorFromObj - reference counts} colorsFree { set x purple destroy .b1 .b2 .t.b button .b1 -foreground $x -text First pack .b1 -side top button .t.b -foreground $x -text Second pack .t.b -side top button .b2 -foreground $x -text Third pack .b2 -side top set result {} lappend result [testcolor purple] destroy .b1 lappend result [testcolor purple] destroy .b2 lappend result [testcolor purple] destroy .t.b lappend result [testcolor purple] } {{{1 0} {2 1}} {{1 0} {1 1}} {{1 0}} {}} test color-3.4 {Tk_FreeColorFromObj - unlinking from list} colorsFree { destroy .b .t.b .t2 .t3 toplevel .t2 -visual {pseudocolor 8} -colormap new toplevel .t3 -visual {pseudocolor 8} -colormap new set x purple button .b -foreground $x -text .b1 button .t.b1 -foreground $x -text .t.b1 button .t.b2 -foreground $x -text .t.b2 button .t2.b1 -foreground $x -text .t2.b1 button .t2.b2 -foreground $x -text .t2.b2 button .t2.b3 -foreground $x -text .t2.b3 button .t3.b1 -foreground $x -text .t3.b1 button .t3.b2 -foreground $x -text .t3.b2 button .t3.b3 -foreground $x -text .t3.b3 button .t3.b4 -foreground $x -text .t3.b4 set result {} lappend result [testcolor purple] destroy .t2 lappend result [testcolor purple] destroy .b lappend result [testcolor purple] destroy .t3 lappend result [testcolor purple] destroy .t lappend result [testcolor purple] } {{{4 1} {3 0} {2 0} {1 0}} {{4 1} {2 0} {1 0}} {{4 1} {2 0}} {{2 0}} {}} test color-4.1 {FreeColorObjProc} colorsFree { destroy .b set x [format purple] button .b -foreground $x -text .b1 set y [format purple] .b configure -foreground $y set z [format purple] .b configure -foreground $z set result {} lappend result [testcolor purple] set x red lappend result [testcolor purple] set z 32 lappend result [testcolor purple] destroy .b lappend result [testcolor purple] set y bogus set result } {{{1 3}} {{1 2}} {{1 1}} {}} destroy .t # cleanup cleanupTests return tk8.6.5/tests/safe.test0000644003604700454610000001574212377375532013476 0ustar dgp771div# This file is a Tcl script to test the Safe Tk facility. It is organized in # the standard fashion for Tk tests. # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994-1995 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands namespace import -force tcltest::test ## NOTE: Any time tests fail here with an error like: # Can't find a usable tk.tcl in the following directories: # {$p(:26:)} # # $p(:26:)/tk.tcl: script error # script error # invoked from within # "source {$p(:26:)/tk.tcl}" # ("uplevel" body line 1) # invoked from within # "uplevel #0 [list source $file]" # # # This probably means that tk wasn't installed properly. ## it indicates that something went wrong sourcing tk.tcl. ## Ensure that any changes that occured to tk.tcl will work or are properly ## prevented in a safe interpreter. -- hobbs # The set of hidden commands is platform dependent: set hidden_cmds {bell cd clipboard encoding exec exit fconfigure glob grab load menu open pwd selection socket source toplevel unload wm} lappend hidden_cmds {*}[apply {{} { foreach cmd { atime attributes copy delete dirname executable exists extension isdirectory isfile link lstat mkdir mtime nativename normalize owned readable readlink rename rootname size stat tail tempfile type volumes writable } {lappend result tcl:file:$cmd}; return $result }}] if {[tk windowingsystem] ne "x11"} { lappend hidden_cmds tk_chooseColor tk_chooseDirectory tk_getOpenFile \ tk_getSaveFile tk_messageBox } if {[llength [info commands send]]} { lappend hidden_cmds send } set saveAutoPath $::auto_path set auto_path [list [info library] $::tk_library] set hidden_cmds [lsort $hidden_cmds] test safe-1.1 {Safe Tk loading into an interpreter} -setup { catch {safe::interpDelete a} } -body { safe::loadTk [safe::interpCreate a] safe::interpDelete a set x {} return $x } -result {} test safe-1.2 {Safe Tk loading into an interpreter} -setup { catch {safe::interpDelete a} } -body { safe::interpCreate a safe::loadTk a lsort [interp hidden a] } -cleanup { safe::interpDelete a } -result $hidden_cmds test safe-1.3 {Safe Tk loading into an interpreter} -setup { catch {safe::interpDelete a} } -body { safe::interpCreate a safe::loadTk a lsort [interp aliases a] } -cleanup { safe::interpDelete a } -match glob -result {*encoding*exit*glob*load*source*} test safe-2.1 {Unsafe commands not available} -setup { catch {safe::interpDelete a} } -body { safe::interpCreate a safe::loadTk a set status broken if {[catch {interp eval a {toplevel .t}} msg]} { set status ok } return $status } -cleanup { safe::interpDelete a } -result ok test safe-2.2 {Unsafe commands not available} -setup { catch {safe::interpDelete a} } -body { safe::interpCreate a safe::loadTk a set status broken if {[catch {interp eval a {menu .m}} msg]} { set status ok } return $status } -cleanup { safe::interpDelete a } -result ok test safe-2.3 {Unsafe subcommands not available} -setup { catch {safe::interpDelete a} } -body { safe::interpCreate a safe::loadTk a set status broken if {[catch {interp eval a {tk appname}} msg]} { set status ok } list $status $msg } -cleanup { safe::interpDelete a } -result {ok {appname not accessible in a safe interpreter}} test safe-2.4 {Unsafe subcommands not available} -setup { catch {safe::interpDelete a} } -body { safe::interpCreate a safe::loadTk a set status broken if {[catch {interp eval a {tk scaling}} msg]} { set status ok } list $status $msg } -cleanup { safe::interpDelete a } -result {ok {scaling not accessible in a safe interpreter}} test safe-3.1 {Unsafe commands are available hidden} -setup { catch {safe::interpDelete a} } -body { safe::interpCreate a safe::loadTk a set status ok if {[catch {interp invokehidden a toplevel .t} msg]} { set status broken } return $status } -cleanup { safe::interpDelete a } -result ok test safe-3.2 {Unsafe commands are available hidden} -setup { catch {safe::interpDelete a} } -body { safe::interpCreate a safe::loadTk a set status ok if {[catch {interp invokehidden a menu .m} msg]} { set status broken } return $status } -cleanup { safe::interpDelete a } -result ok test safe-4.1 {testing loadTk} -body { # no error shall occur, the user will eventually see a new toplevel set i [safe::loadTk [safe::interpCreate]] interp eval $i {button .b -text "hello world!"; pack .b} # lets don't update because it might imply that the user has to position # the window (if the wm does not do it automatically) and thus make the # test suite not runable non interactively safe::interpDelete $i } -result {} test safe-4.2 {testing loadTk -use} -setup { destroy .safeTkFrame } -body { set w .safeTkFrame frame $w -container 1; pack $w set i [safe::loadTk [safe::interpCreate] -use [winfo id $w]] interp eval $i {button .b -text "hello world!"; pack .b} safe::interpDelete $i destroy $w } -result {} test safe-5.1 {loading Tk in safe interps without master's clearance} -body { set i [safe::interpCreate] interp eval $i {load {} Tk} } -cleanup { safe::interpDelete $i } -returnCodes error -result {not allowed to start Tk by master's safe::TkInit} test safe-5.2 {multi-level Tk loading with clearance} -setup { set safeParent [safe::interpCreate] } -body { # No error shall occur in that test and no window shall remain at the end. set i [safe::interpCreate [list $safeParent x]] safe::loadTk $i interp eval $i { button .b -text Ok -command {destroy .} pack .b # tkwait window . ; # for interactive testing/debugging } } -cleanup { catch {safe::interpDelete $i} safe::interpDelete $safeParent } -result {} test safe-6.1 {loadTk -use windowPath} -setup { destroy .safeTkFrame } -body { set w .safeTkFrame frame $w -container 1; pack $w set i [safe::loadTk [safe::interpCreate] -use $w] interp eval $i {button .b -text "hello world!"; pack .b} safe::interpDelete $i destroy $w } -result {} test safe-6.2 {loadTk -use windowPath, conflicting -display} -setup { destroy .safeTkFrame } -body { set w .safeTkFrame frame $w -container 1; pack $w set i [safe::interpCreate] catch {safe::loadTk $i -use $w -display :23.56} msg string range $msg 0 36 } -cleanup { safe::interpDelete $i destroy $w } -result {conflicting -display :23.56 and -use } test safe-7.1 {canvas printing} -body { set i [safe::loadTk [safe::interpCreate]] interp eval $i {canvas .c; .c postscript} } -cleanup { safe::interpDelete $i } -returnCodes ok -match glob -result * # cleanup set ::auto_path $saveAutoPath unset hidden_cmds cleanupTests return # Local Variables: # mode: tcl # fill-column: 78 # End: tk8.6.5/tests/winButton.test0000644003604700454610000001547612643727754014560 0ustar dgp771div# This file is a Tcl script to test the Windows specific behavior of # labels, buttons, checkbuttons, and radiobuttons in Tk (i.e., all the # widgets defined in tkWinButton.c). It is organized in the standard # fashion for Tcl tests. # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. package require tcltest 2.2 namespace import ::tcltest::* tcltest::configure {*}$argv tcltest::loadTestedCommands imageInit proc bogusTrace args { error "trace aborted" } option clear # ---------------------------------------------------------------------- test winbutton-1.1 {TkpComputeButtonGeometry procedure} -constraints { testImageType win nonPortable } -setup { # nonPortable because of [3e3e25f483]: on Win7 first started with a high DPI screen # the smallest size (i.e. 8) is not available for "MS Sans Serif" font deleteWindows } -body { image create test image1 image1 changed 0 0 0 0 60 40 label .b1 -image image1 -bd 4 -padx 0 -pady 2 button .b2 -image image1 -bd 4 -padx 0 -pady 2 checkbutton .b3 -image image1 -bd 4 -padx 1 -pady 1 \ -font {{MS Sans Serif} 8} radiobutton .b4 -image image1 -bd 4 -padx 2 -pady 0 \ -font {{MS Sans Serif} 8} pack .b1 .b2 .b3 .b4 update # with patch 463234 with native L&F enabled, this returns: # {68 48 70 50 88 50 88 50} list [winfo reqwidth .b1] [winfo reqheight .b1] \ [winfo reqwidth .b2] [winfo reqheight .b2] \ [winfo reqwidth .b3] [winfo reqheight .b3] \ [winfo reqwidth .b4] [winfo reqheight .b4] } -cleanup { deleteWindows image delete image1 } -result {68 48 70 50 90 52 90 52} test winbutton-1.2 {TkpComputeButtonGeometry procedure} -constraints { win nonPortable } -setup { # nonPortable because of [3e3e25f483]: on Win7 first started with a high DPI screen # the smallest size (i.e. 8) is not available for "MS Sans Serif" font deleteWindows } -body { label .b1 -bitmap question -bd 3 -padx 0 -pady 2 button .b2 -bitmap question -bd 3 -padx 0 -pady 2 checkbutton .b3 -bitmap question -bd 3 -padx 1 -pady 1 \ -font {{MS Sans Serif} 8} radiobutton .b4 -bitmap question -bd 3 -padx 2 -pady 0 \ -font {{MS Sans Serif} 8} pack .b1 .b2 .b3 .b4 update # with patch 463234 with native L&F enabled, this returns: # {23 33 25 35 43 35 43 35} list [winfo reqwidth .b1] [winfo reqheight .b1] \ [winfo reqwidth .b2] [winfo reqheight .b2] \ [winfo reqwidth .b3] [winfo reqheight .b3] \ [winfo reqwidth .b4] [winfo reqheight .b4] } -cleanup { deleteWindows } -result {23 33 25 35 45 37 45 37} test winbutton-1.3 {TkpComputeButtonGeometry procedure} -constraints win -setup { deleteWindows } -body { label .b1 -bitmap question -bd 3 -highlightthickness 4 button .b2 -bitmap question -bd 3 -highlightthickness 0 checkbutton .b3 -bitmap question -bd 3 -highlightthickness 1 \ -indicatoron 0 radiobutton .b4 -bitmap question -bd 3 -indicatoron false pack .b1 .b2 .b3 .b4 update # with patch 463234 with native L&F enabled, this returns: # {31 41 23 33 25 35 25 35} list [winfo reqwidth .b1] [winfo reqheight .b1] \ [winfo reqwidth .b2] [winfo reqheight .b2] \ [winfo reqwidth .b3] [winfo reqheight .b3] \ [winfo reqwidth .b4] [winfo reqheight .b4] } -cleanup { deleteWindows } -result {31 41 23 33 27 37 27 37} test winbutton-1.4 {TkpComputeButtonGeometry procedure} -constraints { win nonPortable } -setup { deleteWindows } -body { label .b1 -text Xagqpim -bd 2 -padx 0 -pady 2 -font {{MS Sans Serif} 8} button .b2 -text Xagqpim -bd 2 -padx 0 -pady 2 -font {{MS Sans Serif} 8} checkbutton .b3 -text Xagqpim -bd 2 -padx 1 -pady 1 -font {{MS Sans Serif} 8} radiobutton .b4 -text Xagqpim -bd 2 -padx 2 -pady 0 -font {{MS Sans Serif} 8} pack .b1 .b2 .b3 .b4 update list [winfo reqwidth .b1] [winfo reqheight .b1] \ [winfo reqwidth .b2] [winfo reqheight .b2] \ [winfo reqwidth .b3] [winfo reqheight .b3] \ [winfo reqwidth .b4] [winfo reqheight .b4] } -cleanup { deleteWindows } -result {58 24 67 33 88 30 90 28} test winbutton-1.5 {TkpComputeButtonGeometry procedure} -constraints { win nonPortable } -setup { deleteWindows } -body { label .l1 -wraplength 1.5i -padx 0 -pady 0 \ -text "This is a long string that will wrap around on several lines.\n\nIt also has a blank line (above)." pack .l1 update list [winfo reqwidth .l1] [winfo reqheight .l1] } -cleanup { deleteWindows } -result {178 84} test winbutton-1.6 {TkpComputeButtonGeometry procedure} -constraints { win nonPortable } -setup { deleteWindows } -body { label .l1 -padx 0 -pady 0 \ -text "This is a long string without wrapping.\n\nIt also has a blank line (above)." pack .l1 update list [winfo reqwidth .l1] [winfo reqheight .l1] } -cleanup { deleteWindows } -result {222 52} test winbutton-1.7 {TkpComputeButtonGeometry procedure} -constraints { win nonPortable } -setup { deleteWindows } -body { label .b1 -text Xagqpim -bd 2 -padx 0 -pady 2 -width 10 button .b2 -text Xagqpim -bd 2 -padx 0 -pady 2 -height 5 checkbutton .b3 -text Xagqpim -bd 2 -padx 1 -pady 1 -width 20 -height 2 radiobutton .b4 -text Xagqpim -bd 2 -padx 2 -pady 0 -width 4 pack .b1 .b2 .b3 .b4 update list [winfo reqwidth .b1] [winfo reqheight .b1] \ [winfo reqwidth .b2] [winfo reqheight .b2] \ [winfo reqwidth .b3] [winfo reqheight .b3] \ [winfo reqwidth .b4] [winfo reqheight .b4] } -cleanup { deleteWindows } -result {74 24 67 97 174 46 64 28} test winbutton-1.8 {TkpComputeButtonGeometry procedure} -constraints { win nonPortable } -setup { deleteWindows } -body { label .b1 -text Xagqpim -bd 2 -padx 0 -pady 2 \ -highlightthickness 4 button .b2 -text Xagqpim -bd 2 -padx 0 -pady 2 \ -highlightthickness 0 checkbutton .b3 -text Xagqpim -bd 2 -padx 1 -pady 1 \ -highlightthickness 1 -indicatoron no radiobutton .b4 -text Xagqpim -bd 2 -padx 2 -pady 0 -indicatoron 0 pack .b1 .b2 .b3 .b4 update list [winfo reqwidth .b1] [winfo reqheight .b1] \ [winfo reqwidth .b2] [winfo reqheight .b2] \ [winfo reqwidth .b3] [winfo reqheight .b3] \ [winfo reqwidth .b4] [winfo reqheight .b4] } -cleanup { deleteWindows } -result {66 32 65 31 69 31 71 29} test winbutton-1.9 {TkpComputeButtonGeometry procedure} -constraints win -setup { deleteWindows } -body { button .b2 -bitmap question -default normal list [winfo reqwidth .b2] [winfo reqheight .b2] } -cleanup { deleteWindows } -result {23 33} # cleanup imageFinish deleteWindows cleanupTests return # Local variables: # mode: tcl # End: tk8.6.5/tests/textBTree.test0000644003604700454610000010751712467141247014462 0ustar dgp771div# This file is a Tcl script to test out the B-tree facilities of # Tk's text widget (the contents of the file "tkTextBTree.c". There are # several file with additional tests for other features of text widgets. # This file is organized in the standard fashion for Tcl tests. # # Copyright (c) 1992-1994 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. package require tcltest 2.2 namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands proc setup {} { .t delete 1.0 100000.0 .t tag delete x y .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" .t tag add x 1.1 .t tag add x 1.5 1.13 .t tag add x 2.2 2.6 .t tag add y 1.5 } # setup procedure for tests 10.*, 11.*, 12.* proc msetup {} { .t delete 1.0 100000.0 .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" .t mark set m1 1.2 .t mark set l1 1.2 .t mark gravity l1 left .t mark set next 1.6 .t mark set x 1.6 .t mark set m2 2.0 .t mark set m3 2.100 .t tag add x 1.3 1.8 } # setup procedure for tests 16.*, 17.*, 18.9 proc setupBig {} { .t delete 1.0 end .t tag delete x y .t tag configure x -foreground blue .t tag configure y -underline true # Create a Btree with 2002 lines (2000 + already existing + phantom at end) # This generates a level 3 node with 9 children # Most level 2 nodes cover 216 lines and have 6 children, except the last # level 2 node covers 274 lines and has 7 children. # Most level 1 nodes cover 36 lines and have 6 children, except the # rightmost node has 58 lines and 9 children. # Level 2: 2002 = 8*216 + 274 # Level 1: 2002 = 54*36 + 58 # Level 0: 2002 = 332*6 + 10 for {set i 0} {$i < 2000} {incr i} { append x "Line $i abcd efgh ijkl\n" } .t insert insert $x .t debug 1 } # Widget used in tests 1.* - 13.* destroy .t text .t .t debug on test btree-1.1 {basic insertions} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t get 1.0 1000000.0 } -result "Line 1\nLine 2\nLine 3\n" test btree-1.2 {basic insertions} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t insert 1.3 XXX .t get 1.0 1000000.0 } -result "LinXXXe 1\nLine 2\nLine 3\n" test btree-1.3 {basic insertions} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t insert 3.0 YYY .t get 1.0 1000000.0 } -result "Line 1\nLine 2\nYYYLine 3\n" test btree-1.4 {basic insertions} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t insert 2.1 X\nYY .t get 1.0 1000000.0 } -result "Line 1\nLX\nYYine 2\nLine 3\n" test btree-1.5 {basic insertions} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t insert 2.0 X\n\n\n .t get 1.0 1000000.0 } -result "Line 1\nX\n\n\nLine 2\nLine 3\n" test btree-1.6 {basic insertions} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t insert 2.6 X\n .t get 1.0 1000000.0 } -result "Line 1\nLine 2X\n\nLine 3\n" test btree-1.7 {insertion before start of text} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t insert 0.4 XXX .t get 1.0 1000000.0 } -result "XXXLine 1\nLine 2\nLine 3\n" test btree-1.8 {insertion past end of text} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t insert 100.0 ZZ .t get 1.0 1000000.0 } -result "Line 1\nLine 2\nLine 3ZZ\n" test btree-1.9 {insertion before start of line} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t insert 2.-3 Q .t get 1.0 1000000.0 } -result "Line 1\nQLine 2\nLine 3\n" test btree-1.10 {insertion past end of line} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t insert 2.40 XYZZY .t get 1.0 1000000.0 } -result "Line 1\nLine 2XYZZY\nLine 3\n" test btree-1.11 {insertion past end of last line} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t insert 3.40 ABC .t get 1.0 1000000.0 } -result "Line 1\nLine 2\nLine 3ABC\n" test btree-2.1 {basic deletions} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t delete 1.0 1.3 .t get 1.0 1000000.0 } -result "e 1\nLine 2\nLine 3\n" test btree-2.2 {basic deletions} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t delete 2.2 .t get 1.0 1000000.0 } -result "Line 1\nLie 2\nLine 3\n" test btree-2.3 {basic deletions} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t delete 2.0 2.3 .t get 1.0 1000000.0 } -result "Line 1\ne 2\nLine 3\n" test btree-2.4 {deleting whole lines} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t delete 1.2 3.0 .t get 1.0 1000000.0 } -result "LiLine 3\n" test btree-2.5 {deleting whole lines} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\n\n\nLine 5" .t delete 1.0 5.2 .t get 1.0 1000000.0 } -result "ne 5\n" test btree-2.6 {deleting before start of file} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t delete 0.3 1.2 .t get 1.0 1000000.0 } -result "ne 1\nLine 2\nLine 3\n" test btree-2.7 {deleting after end of file} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t delete 10.3 .t get 1.0 1000000.0 } -result "Line 1\nLine 2\nLine 3\n" test btree-2.8 {deleting before start of line} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t delete 3.-1 3.3 .t get 1.0 1000000.0 } -result "Line 1\nLine 2\ne 3\n" test btree-2.9 {deleting before start of line} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t delete 1.-1 1.0 .t get 1.0 1000000.0 } -result "Line 1\nLine 2\nLine 3\n" test btree-2.10 {deleting after end of line} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t delete 1.8 2.1 .t get 1.0 1000000.0 } -result "Line 1ine 2\nLine 3\n" test btree-2.11 {deleting after end of last line} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t delete 3.8 4.1 .t get 1.0 1000000.0 } -result "Line 1\nLine 2\nLine 3\n" test btree-2.12 {deleting before start of file} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t delete 1.8 0.0 .t get 1.0 1000000.0 } -result "Line 1\nLine 2\nLine 3\n" test btree-2.13 {deleting past end of file} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t delete 1.8 4.0 .t get 1.0 1000000.0 } -result "Line 1\n" test btree-2.14 {deleting with end before start of line} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t delete 1.3 2.-3 .t get 1.0 1000000.0 } -result "LinLine 2\nLine 3\n" test btree-2.15 {deleting past end of line} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t delete 1.3 1.9 .t get 1.0 1000000.0 } -result "Lin\nLine 2\nLine 3\n" test btree-2.16 {deleting past end of line} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t delete 3.2 3.15 .t get 1.0 1000000.0 } -result "Line 1\nLine 2\nLi\n" test btree-2.17 {deleting past end of line} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t delete 3.0 3.15 .t get 1.0 1000000.0 } -result "Line 1\nLine 2\n\n" test btree-2.18 {deleting past end of line} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t delete 1.0 3.15 .t get 1.0 1000000.0 } -result "\n" test btree-2.19 {deleting with negative range} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t delete 3.2 2.4 .t get 1.0 1000000.0 } -result "Line 1\nLine 2\nLine 3\n" test btree-2.20 {deleting with negative range} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t delete 3.2 3.1 .t get 1.0 1000000.0 } -result "Line 1\nLine 2\nLine 3\n" test btree-2.21 {deleting with negative range} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t delete 3.2 3.2 .t get 1.0 1000000.0 } -result "Line 1\nLine 2\nLine 3\n" test btree-3.1 {inserting with tags} -body { setup .t insert 1.0 XXX list [.t tag ranges x] [.t tag ranges y] } -result {{1.4 1.5 1.8 1.16 2.2 2.6} {1.8 1.9}} test btree-3.2 {inserting with tags} -body { setup .t insert 1.15 YYY list [.t tag ranges x] [.t tag ranges y] } -result {{1.1 1.2 1.5 1.13 2.2 2.6} {1.5 1.6}} test btree-3.3 {inserting with tags} -body { setup .t insert 1.7 ZZZZ list [.t tag ranges x] [.t tag ranges y] } -result {{1.1 1.2 1.5 1.17 2.2 2.6} {1.5 1.6}} test btree-3.4 {inserting with tags} -body { setup .t insert 1.7 \n\n list [.t tag ranges x] [.t tag ranges y] } -result {{1.1 1.2 1.5 3.6 4.2 4.6} {1.5 1.6}} test btree-3.5 {inserting with tags} -body { setup .t insert 1.5 A\n list [.t tag ranges x] [.t tag ranges y] } -result {{1.1 1.2 2.0 2.8 3.2 3.6} {2.0 2.1}} test btree-3.6 {inserting with tags} -body { setup .t insert 1.13 A\n list [.t tag ranges x] [.t tag ranges y] } -result {{1.1 1.2 1.5 1.13 3.2 3.6} {1.5 1.6}} test btree-4.1 {deleting with tags} -body { setup .t delete 1.6 1.9 list [.t tag ranges x] [.t tag ranges y] } -result {{1.1 1.2 1.5 1.10 2.2 2.6} {1.5 1.6}} test btree-4.2 {deleting with tags} -body { setup .t delete 1.1 2.3 list [.t tag ranges x] [.t tag ranges y] } -result {{1.1 1.4} {}} test btree-4.3 {deleting with tags} -body { setup .t delete 1.4 2.1 list [.t tag ranges x] [.t tag ranges y] } -result {{1.1 1.2 1.5 1.9} {}} test btree-4.4 {deleting with tags} -body { setup .t delete 1.14 2.1 list [.t tag ranges x] [.t tag ranges y] } -result {{1.1 1.2 1.5 1.13 1.15 1.19} {1.5 1.6}} test btree-4.5 {deleting with tags} -body { setup .t delete 1.0 2.10 list [.t tag ranges x] [.t tag ranges y] } -result {{} {}} test btree-4.6 {deleting with tags} -body { setup .t delete 1.0 1.5 list [.t tag ranges x] [.t tag ranges y] } -result {{1.0 1.8 2.2 2.6} {1.0 1.1}} test btree-4.7 {deleting with tags} -body { setup .t delete 1.6 1.9 list [.t tag ranges x] [.t tag ranges y] } -result {{1.1 1.2 1.5 1.10 2.2 2.6} {1.5 1.6}} test btree-4.8 {deleting with tags} -body { setup .t delete 1.5 1.13 list [.t tag ranges x] [.t tag ranges y] } -result {{1.1 1.2 2.2 2.6} {}} test btree-5.1 {very large inserts, with tags} -setup { set bigText1 {} for {set i 0} {$i < 10} {incr i} { append bigText1 "Line $i\n" } } -body { setup .t insert 1.0 $bigText1 list [.t tag ranges x] [.t tag ranges y] } -result {{11.1 11.2 11.5 11.13 12.2 12.6} {11.5 11.6}} test btree-5.2 {very large inserts, with tags} -setup { set bigText2 {} for {set i 0} {$i < 200} {incr i} { append bigText2 "Line $i\n" } } -body { setup .t insert 1.2 $bigText2 list [.t tag ranges x] [.t tag ranges y] } -result {{1.1 1.2 201.3 201.11 202.2 202.6} {201.3 201.4}} test btree-5.3 {very large inserts, with tags} -body { setup for {set i 0} {$i < 200} {incr i} { .t insert 1.8 "longer line $i\n" } list [.t tag ranges x] [.t tag ranges y] [.t get 1.0 1.100] \ [.t get 198.0 198.100] } -result {{1.1 1.2 1.5 201.5 202.2 202.6} {1.5 1.6} {Text forlonger line 199} {longer line 2}} test btree-6.1 {very large deletes, with tags} -setup { set bigText2 {} for {set i 0} {$i < 200} {incr i} { append bigText2 "Line $i\n" } } -body { setup .t insert 1.1 $bigText2 .t delete 1.2 201.2 list [.t tag ranges x] [.t tag ranges y] } -result {{1.4 1.12 2.2 2.6} {1.4 1.5}} test btree-6.2 {very large deletes, with tags} -setup { set bigText2 {} for {set i 0} {$i < 200} {incr i} { append bigText2 "Line $i\n" } } -body { setup .t insert 1.1 $bigText2 for {set i 0} {$i < 200} {incr i} { .t delete 1.2 2.2 } list [.t tag ranges x] [.t tag ranges y] } -result {{1.4 1.12 2.2 2.6} {1.4 1.5}} test btree-6.3 {very large deletes, with tags} -setup { set bigText2 {} for {set i 0} {$i < 200} {incr i} { append bigText2 "Line $i\n" } } -body { setup .t insert 1.1 $bigText2 .t delete 2.3 10000.0 .t get 1.0 1000.0 } -result {TLine 0 Lin } test btree-6.4 {very large deletes, with tags} -setup { set bigText2 {} for {set i 0} {$i < 200} {incr i} { append bigText2 "Line $i\n" } } -body { setup .t insert 1.1 $bigText2 for {set i 0} {$i < 100} {incr i} { .t delete 30.0 31.0 } list [.t tag ranges x] [.t tag ranges y] } -result {{101.0 101.1 101.4 101.12 102.2 102.6} {101.4 101.5}} test btree-6.5 {very large deletes, with tags} -setup { set bigText2 {} for {set i 0} {$i < 200} {incr i} { append bigText2 "Line $i\n" } } -body { 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] .t tag add x $j.1 $j.3 .t tag add y $k.1 $k.6 } .t delete 2.0 200.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}} test btree-6.6 {very large deletes, with tags} -setup { set bigText2 {} for {set i 0} {$i < 200} {incr i} { append bigText2 "Line $i\n" } } -body { 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] .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 } 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}} test btree-7.1 {tag addition and removal} -setup { .t delete 1.0 end .t tag remove x 1.0 end } -body { .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" set check {1.3 1.6 1.7 2.0} while {[llength $check]} { .t tag add x [lindex $check 0] [lindex $check 1] set check [lrange $check 2 end] } .t tag ranges x } -result {1.3 1.6 1.7 2.0} test btree-7.2 {tag addition and removal} -setup { .t delete 1.0 end .t tag remove x 1.0 end } -body { .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" set check {1.3 1.6 1.6 2.0} while {[llength $check]} { .t tag add x [lindex $check 0] [lindex $check 1] set check [lrange $check 2 end] } .t tag ranges x } -result {1.3 2.0} test btree-7.3 {tag addition and removal} -setup { .t delete 1.0 end .t tag remove x 1.0 end } -body { .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" set check {1.3 1.6 1.4 2.0} while {[llength $check]} { .t tag add x [lindex $check 0] [lindex $check 1] set check [lrange $check 2 end] } .t tag ranges x } -result {1.3 2.0} test btree-7.4 {tag addition and removal} -setup { .t delete 1.0 end .t tag remove x 1.0 end } -body { .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" set check {2.0 4.3 1.4 1.10} while {[llength $check]} { .t tag add x [lindex $check 0] [lindex $check 1] set check [lrange $check 2 end] } .t tag ranges x } -result {1.4 1.10 2.0 4.3} test btree-7.5 {tag addition and removal} -setup { .t delete 1.0 end .t tag remove x 1.0 end } -body { .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" set check {2.0 4.3 1.4 1.end} while {[llength $check]} { .t tag add x [lindex $check 0] [lindex $check 1] set check [lrange $check 2 end] } .t tag ranges x } -result {1.4 1.19 2.0 4.3} test btree-7.6 {tag addition and removal} -setup { .t delete 1.0 end .t tag remove x 1.0 end } -body { .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" set check {2.0 4.3 1.4 2.0} while {[llength $check]} { .t tag add x [lindex $check 0] [lindex $check 1] set check [lrange $check 2 end] } .t tag ranges x } -result {1.4 4.3} test btree-7.7 {tag addition and removal} -setup { .t delete 1.0 end .t tag remove x 1.0 end } -body { .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" set check {2.0 4.3 1.4 3.0} while {[llength $check]} { .t tag add x [lindex $check 0] [lindex $check 1] set check [lrange $check 2 end] } .t tag ranges x } -result {1.4 4.3} test btree-7.8 {tag addition and removal} -setup { .t delete 1.0 end .t tag remove x 1.0 end } -body { .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" set check {1.2 1.3 1.6 1.7 1.end 2.0 2.4 2.7 3.0 4.0 1.1 4.2} while {[llength $check]} { .t tag add x [lindex $check 0] [lindex $check 1] set check [lrange $check 2 end] } .t tag ranges x } -result {1.1 4.2} test btree-7.9 {tag addition and removal} -setup { .t delete 1.0 end .t tag remove x 1.0 end } -body { .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" set check {1.2 1.3 1.6 1.7 1.end 2.0 2.4 2.7 3.0 4.0 1.3 4.2} while {[llength $check]} { .t tag add x [lindex $check 0] [lindex $check 1] set check [lrange $check 2 end] } .t tag ranges x } -result {1.2 4.2} test btree-7.10 {tag addition and removal} -setup { .t delete 1.0 end .t tag remove x 1.0 end } -body { .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" set check {1.2 1.3 1.6 1.7 1.end 2.0 2.4 2.7 3.0 4.0 1.1 3.0} while {[llength $check]} { .t tag add x [lindex $check 0] [lindex $check 1] set check [lrange $check 2 end] } .t tag ranges x } -result {1.1 4.0} test btree-7.11 {tag addition and removal} -setup { .t delete 1.0 end .t tag remove x 1.0 end } -body { .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" set check {1.2 1.3 1.6 1.7 1.end 2.0 2.4 2.7 3.0 4.0 1.2 3.0} while {[llength $check]} { .t tag add x [lindex $check 0] [lindex $check 1] set check [lrange $check 2 end] } .t tag ranges x } -result {1.2 4.0} test btree-8.1 {tag addition and removal, weird ranges} -body { .t delete 1.0 100000.0 .t tag delete x .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" .t tag add x 0.0 1.3 .t tag ranges x } -result {1.0 1.3} test btree-8.2 {tag addition and removal, weird ranges} -body { .t delete 1.0 100000.0 .t tag delete x .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" .t tag add x 1.40 2.4 .t tag ranges x } -result {1.19 2.4} test btree-8.3 {tag addition and removal, weird ranges} -body { .t delete 1.0 100000.0 .t tag delete x .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" .t tag add x 4.40 4.41 .t tag ranges x } -result {} test btree-8.4 {tag addition and removal, weird ranges} -body { .t delete 1.0 100000.0 .t tag delete x .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" .t tag add x 5.1 5.2 .t tag ranges x } -result {} test btree-8.5 {tag addition and removal, weird ranges} -body { .t delete 1.0 100000.0 .t tag delete x .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" .t tag add x 1.1 9.0 .t tag ranges x } -result {1.1 5.0} test btree-8.6 {tag addition and removal, weird ranges} -body { .t delete 1.0 100000.0 .t tag delete x .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" .t tag add x 1.1 1.90 .t tag ranges x } -result {1.1 1.19} test btree-8.7 {tag addition and removal, weird ranges} -body { .t delete 1.0 100000.0 .t tag delete x .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" .t tag add x 1.1 4.90 .t tag ranges x } -result {1.1 4.17} test btree-8.8 {tag addition and removal, weird ranges} -body { .t delete 1.0 100000.0 .t tag delete x .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" .t tag add x 3.0 3.0 .t tag ranges x } -result {} test btree-9.1 {tag names} -body { setup .t tag names } -result {sel x y} test btree-9.2 {tag names} -body { setup .t tag add tag1 1.8 .t tag add tag2 1.8 .t tag add tag3 1.7 1.9 .t tag names 1.8 } -result {x tag1 tag2 tag3} test btree-9.3 {lots of tag names} -setup { set bigText2 {} for {set i 0} {$i < 200} {incr i} { append bigText2 "Line $i\n" } } -body { setup .t insert 1.2 $bigText2 foreach i {tag1 foo ThisOne {x space} q r s t} { .t tag add $i 150.2 } foreach i {u tagA tagB tagC and more {$} \{} { .t tag add $i 150.1 150.3 } .t tag names 150.2 } -result {tag1 foo ThisOne {x space} q r s t u tagA tagB tagC and more {$} \{} test btree-9.4 {lots of tag names} -setup { set bigText2 {} for {set i 0} {$i < 200} {incr i} { append bigText2 "Line $i\n" } } -body { setup .t insert 1.2 $bigText2 .t tag delete tag1 foo ThisOne more {x space} q r s t u .t tag delete tagA tagB tagC and {$} \{ more foreach i {tag1 foo ThisOne more {x space} q r s t} { .t tag add $i 150.2 } foreach i {foo ThisOne u tagA tagB tagC and more {$} \{} { .t tag add $i 150.4 } .t tag delete tag1 more q r tagA .t tag names 150.2 } -result {foo ThisOne {x space} s t} test btree-10.1 {basic mark facilities} -body { msetup list [lsort [.t mark names]] [.t index m1] [.t index m2] [.t index m3] } -result {{current insert l1 m1 m2 m3 next x} 1.2 2.0 2.11} test btree-10.2 {basic mark facilities} -body { msetup .t mark unset m2 lsort [.t mark names] } -result {current insert l1 m1 m3 next x} test btree-10.3 {basic mark facilities} -body { msetup .t mark set m2 1.8 list [lsort [.t mark names]] [.t index m1] [.t index m2] [.t index m3] } -result {{current insert l1 m1 m2 m3 next x} 1.2 1.8 2.11} test btree-11.1 {marks and inserts} -body { msetup .t insert 1.1 abcde list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] } -result {1.7 1.7 1.11 1.11 2.0 2.11} test btree-11.2 {marks and inserts} -body { msetup .t insert 1.2 abcde list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] } -result {1.2 1.7 1.11 1.11 2.0 2.11} test btree-11.3 {marks and inserts} -body { msetup .t insert 1.3 abcde list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] } -result {1.2 1.2 1.11 1.11 2.0 2.11} test btree-11.4 {marks and inserts} -body { msetup .t insert 1.1 ab\n\ncde list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] } -result {3.4 3.4 3.8 3.8 4.0 4.11} test btree-11.5 {marks and inserts} -body { msetup .t insert 1.4 ab\n\ncde list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] } -result {1.2 1.2 3.5 3.5 4.0 4.11} test btree-11.6 {marks and inserts} -body { msetup .t insert 1.7 ab\n\ncde list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] } -result {1.2 1.2 1.6 1.6 4.0 4.11} test btree-12.1 {marks and deletes} -body { msetup .t delete 1.3 1.5 list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] } -result {1.2 1.2 1.4 1.4 2.0 2.11} test btree-12.2 {marks and deletes} -body { msetup .t delete 1.3 1.8 list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] } -result {1.2 1.2 1.3 1.3 2.0 2.11} test btree-12.3 {marks and deletes} -body { msetup .t delete 1.2 1.8 list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] } -result {1.2 1.2 1.2 1.2 2.0 2.11} test btree-12.4 {marks and deletes} -body { msetup .t delete 1.1 1.8 list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] } -result {1.1 1.1 1.1 1.1 2.0 2.11} test btree-12.5 {marks and deletes} -body { msetup .t delete 1.5 3.1 list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] } -result {1.2 1.2 1.5 1.5 1.5 1.5} test btree-12.6 {marks and deletes} -body { msetup .t mark set m2 4.5 .t delete 1.5 4.1 list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] } -result {1.2 1.2 1.5 1.5 1.9 1.5} test btree-12.7 {marks and deletes} -body { msetup .t mark set m2 4.5 .t mark set m3 4.5 .t mark set m1 4.7 .t delete 1.5 4.1 list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] } -result {1.2 1.11 1.5 1.5 1.9 1.9} test btree-13.1 {tag searching} -setup { .t delete 1.0 100000.0 } -body { .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" .t tag next x 2.2 2.1 } -result {} test btree-13.2 {tag searching} -setup { .t delete 1.0 100000.0 } -body { .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" .t tag add x 2.2 2.4 .t tag next x 2.2 2.3 } -result {2.2 2.4} test btree-13.3 {tag searching} -setup { .t delete 1.0 100000.0 } -body { .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" .t tag add x 2.2 2.4 .t tag next x 2.3 2.6 } -result {} test btree-13.4 {tag searching} -setup { .t delete 1.0 100000.0 } -body { .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" .t tag add x 2.5 2.8 .t tag next x 2.1 2.6 } -result {2.5 2.8} test btree-13.5 {tag searching} -setup { .t delete 1.0 100000.0 } -body { .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" .t tag add x 2.5 2.8 .t tag next x 2.1 2.5 } -result {} test btree-13.6 {tag searching} -setup { .t delete 1.0 100000.0 } -body { .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" .t tag add x 2.1 2.4 .t tag next x 2.5 2.8 } -result {} test btree-13.7 {tag searching} -setup { .t delete 1.0 100000.0 } -body { .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" .t tag add x 2.5 2.8 .t tag next x 2.1 2.4 } -result {} test btree-13.8 {tag searching} -setup { set bigText2 {} for {set i 0} {$i < 200} {incr i} { append bigText2 "Line $i\n" } } -body { setup .t insert 1.2 $bigText2 .t tag add x 190.3 191.2 .t tag next x 3.5 } -result {190.3 191.2} destroy .t test btree-14.1 {check tag presence} -setup { destroy .t text .t set bigText2 {} for {set i 0} {$i < 200} {incr i} { append bigText2 "Line $i\n" } } -body { setup .t insert 1.2 $bigText2 .t tag add x 3.5 3.7 .t tag add y 133.9 141.5 .t tag add z 1.5 180.2 .t tag add q 141.4 142.3 .t tag add x 130.2 145.1 .t tag add a 141.0 .t tag add b 4.3 .t tag add b 7.5 .t tag add b 140.3 for {set i 120} {$i < 160} {incr i} { .t tag add c $i.4 } foreach i {a1 a2 a3 a4 a5 a6 a7 a8 a9 10 a11 a12 a13} { .t tag add $i 122.2 } .t tag add x 141.3 .t tag names 141.1 } -cleanup { destroy .t } -result {x y z} test btree-14.2 {TkTextIsElided} -setup { destroy .t text .t } -body { .t delete 1.0 end .t tag config hidden -elide 1 .t insert end "Line1\nLine2\nLine3\n" .t tag add hidden 2.0 3.0 .t tag add sel 1.2 3.2 # next line used to panic because of "Bad tag priority being toggled on" # (see bug [382da038c9]) .t index "2.0 - 1 display line linestart" } -cleanup { destroy .t } -result {1.0} test btree-15.1 {rebalance with empty node} -setup { destroy .t } -body { text .t .t debug 1 .t insert end "1\n2\n3\n4\n5\n6\n7\n8\n9\n10\n11\n12\n13\n14\n15\n16\n17\n18\n19\n20\n21\n22\n23" .t delete 6.0 12.0 .t get 1.0 end } -cleanup { destroy .t } -result "1\n2\n3\n4\n5\n12\n13\n14\n15\n16\n17\n18\n19\n20\n21\n22\n23\n" test btree-16.1 {add tag does not push root above level 0} -setup { destroy .t text .t } -body { setupBig .t debug 0 .t tag add x 1.1 1.10 .t tag add x 5.1 5.10 .t tag ranges x } -cleanup { destroy .t } -result {1.1 1.10 5.1 5.10} test btree-16.2 {add tag pushes root up to level 1 node} -setup { destroy .t text .t } -body { setupBig .t tag add x 1.1 1.10 .t tag add x 8.1 8.10 .t tag ranges x } -cleanup { destroy .t } -result {1.1 1.10 8.1 8.10} test btree-16.3 {add tag pushes root up to level 2 node} -setup { destroy .t text .t } -body { setupBig .t tag add x 8.1 9.10 .t tag add x 180.1 180.end .t tag ranges x } -cleanup { destroy .t } -result {8.1 9.10 180.1 180.23} test btree-16.4 {add tag pushes root up to level 3 node} -setup { destroy .t text .t } -body { setupBig .t tag add y 1.1 2000.0 .t tag add x 1.1 8.10 .t tag add x 180.end 217.0 list [.t tag ranges x] [.t tag ranges y] } -cleanup { destroy .t } -result {{1.1 8.10 180.23 217.0} {1.1 2000.0}} test btree-16.5 {add tag doesn't push root up} -setup { destroy .t text .t } -body { setupBig .t tag add x 1.1 8.10 .t tag add x 2000.0 2000.3 .t tag add x 180.end 217.0 .t tag ranges x } -cleanup { destroy .t } -result {1.1 8.10 180.23 217.0 2000.0 2000.3} test btree-16.6 {two node splits at once pushes root up} -setup { destroy .t text .t } -body { for {set i 1} {$i < 10} {incr i} { .t insert end "Line $i\n" } .t tag add x 8.0 8.end .t tag add y 9.0 end set x {} for {} {$i < 50} {incr i} { append x "Line $i\n" } .t insert end $x y list [.t tag ranges x] [.t tag ranges y] } -cleanup { destroy .t } -result {{8.0 8.6} {9.0 51.0}} # The following find bugs in the SearchStart procedures test btree-16.7 {Partial tag remove from before first range} -setup { destroy .t text .t for {set i 1} {$i < 10} {incr i} { .t insert end "Line $i\n" } } -body { .t tag add x 2.0 2.6 .t tag remove x 1.0 2.0 .t tag ranges x } -cleanup { destroy .t } -result {2.0 2.6} test btree-16.8 {Partial tag remove from before first range} -setup { destroy .t text .t for {set i 1} {$i < 10} {incr i} { .t insert end "Line $i\n" } } -body { .t tag add x 2.0 2.6 .t tag remove x 1.0 2.1 .t tag ranges x } -cleanup { destroy .t } -result {2.1 2.6} test btree-16.9 {Partial tag remove from before first range} -setup { destroy .t text .t for {set i 1} {$i < 10} {incr i} { .t insert end "Line $i\n" } } -body { .t tag add x 2.0 2.6 .t tag remove x 1.0 2.3 .t tag ranges x } -cleanup { destroy .t } -result {2.3 2.6} test btree-16.10 {Partial tag remove from before first range} -setup { destroy .t text .t for {set i 1} {$i < 10} {incr i} { .t insert end "Line $i\n" } } -body { .t tag add x 1.0 2.6 .t tag remove x 1.0 2.5 .t tag ranges x } -cleanup { destroy .t } -result {2.5 2.6} test btree-16.11 {StartSearchBack boundary case} -setup { destroy .t text .t for {set i 1} {$i < 10} {incr i} { .t insert end "Line $i\n" } } -body { .t tag add x 1.3 1.4 .t tag prevr x 2.0 1.4 } -cleanup { destroy .t } -result {} test btree-16.12 {StartSearchBack boundary case} -setup { destroy .t text .t for {set i 1} {$i < 10} {incr i} { .t insert end "Line $i\n" } } -body { .t tag add x 1.3 1.4 .t tag prevr x 2.0 1.3 } -cleanup { destroy .t } -result {1.3 1.4} test btree-16.13 {StartSearchBack boundary case} -setup { destroy .t text .t for {set i 1} {$i < 10} {incr i} { .t insert end "Line $i\n" } } -body { .t tag add x 1.0 1.4 .t tag prevr x 1.3 } -cleanup { destroy .t } -result {1.0 1.4} test btree-17.1 {remove tag does not push root down} -setup { destroy .t text .t } -body { .t debug 0 setupBig .t tag add x 1.1 5.10 .t tag remove x 3.1 5.end .t tag ranges x } -cleanup { destroy .t } -result {1.1 3.1} test btree-17.2 {remove tag pushes root from level 1 to level 0} -setup { destroy .t text .t } -body { setupBig .t tag add x 1.1 8.10 .t tag remove x 3.1 end .t tag ranges x } -cleanup { destroy .t } -result {1.1 3.1} test btree-17.3 {remove tag pushes root from level 2 to level 1} -setup { destroy .t text .t } -body { setupBig .t tag add x 1.1 180.10 .t tag remove x 35.1 end .t tag ranges x } -cleanup { destroy .t } -result {1.1 35.1} test btree-17.4 {remove tag doesn't change level 2} -setup { destroy .t text .t } -body { setupBig .t tag add x 1.1 180.10 .t tag remove x 35.1 180.0 .t tag ranges x } -cleanup { destroy .t } -result {1.1 35.1 180.0 180.10} test btree-17.5 {remove tag pushes root from level 3 to level 0} -setup { destroy .t text .t } -body { setupBig .t tag add x 1.1 1.10 .t tag add x 2000.1 2000.10 .t tag remove x 1.0 2000.0 .t tag ranges x } -cleanup { destroy .t } -result {2000.1 2000.10} test btree-17.6 {text deletion pushes root from level 3 to level 0} -setup { destroy .t text .t } -body { setupBig .t tag add x 1.1 1.10 .t tag add x 2000.1 2000.10 .t delete 1.0 "1000.0 lineend +1 char" .t tag ranges x } -cleanup { destroy .t } -result {1000.1 1000.10} test btree-18.1 {tag search back, no tag} -setup { destroy .t text .t } -body { .t insert 1.0 "Line 1 abcd efgh ijkl\n" .t tag prev x 1.1 1.1 } -cleanup { destroy .t } -result {} test btree-18.2 {tag search back, start at existing range} -setup { destroy .t text .t } -body { .t insert 1.0 "Line 1 abcd efgh ijkl\n" .t tag add x 1.1 1.4 .t tag add x 1.8 1.11 .t tag add x 1.16 .t tag prev x 1.1 } -cleanup { destroy .t } -result {} test btree-18.3 {tag search back, end at existing range} -setup { destroy .t text .t } -body { .t insert 1.0 "Line 1 abcd efgh ijkl\n" .t tag add x 1.1 1.4 .t tag add x 1.8 1.11 .t tag add x 1.16 .t tag prev x 1.3 1.1 } -cleanup { destroy .t } -result {1.1 1.4} test btree-18.4 {tag search back, start within range} -setup { destroy .t text .t } -body { .t insert 1.0 "Line 1 abcd efgh ijkl\n" .t tag add x 1.1 1.4 .t tag add x 1.8 1.11 .t tag add x 1.16 .t tag prev x 1.10 1.0 } -cleanup { destroy .t } -result {1.8 1.11} test btree-18.5 {tag search back, start at end of range} -setup { destroy .t text .t } -body { .t insert 1.0 "Line 1 abcd efgh ijkl\n" .t tag add x 1.1 1.4 .t tag add x 1.8 1.11 .t tag add x 1.16 list [.t tag prev x 1.4 1.0] [.t tag prev x 1.11 1.0] } -cleanup { destroy .t } -result {{1.1 1.4} {1.8 1.11}} test btree-18.6 {tag search back, start beyond range, same level 0 node} -setup { destroy .t text .t } -body { .t insert 1.0 "Line 1 abcd efgh ijkl\n" .t tag add x 1.1 1.4 .t tag add x 1.8 1.11 .t tag add x 1.16 .t tag prev x 3.0 } -cleanup { destroy .t } -result {1.16 1.17} test btree-18.7 {tag search back, outside any range} -setup { destroy .t text .t } -body { .t insert 1.0 "Line 1 abcd efgh ijkl\n" .t tag add x 1.1 1.4 .t tag add x 1.16 .t tag prev x 1.8 1.5 } -cleanup { destroy .t } -result {} test btree-18.8 {tag search back, start at start of node boundary} -setup { destroy .t text .t } -body { setupBig .t tag add x 2.5 2.8 .t tag prev x 19.0 } -cleanup { destroy .t } -result {2.5 2.8} test btree-18.9 {tag search back, large complex btree spans} -setup { destroy .t text .t } -body { setupBig .t tag add x 1.3 1.end .t tag add x 200.0 220.0 .t tag add x 500.0 520.0 list [.t tag prev x end] [.t tag prev x 433.0] } -cleanup { destroy .t } -result {{500.0 520.0} {200.0 220.0}} # cleanup cleanupTests return tk8.6.5/tests/menuDraw.test0000644003604700454610000004370512377375532014342 0ustar dgp771div# This file is a Tcl script to test drawing of menus in Tk. It is # organized in the standard fashion for Tcl tests. # # Copyright (c) 1996-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands namespace import -force tcltest::test imageInit test menuDraw-1.1 {TkMenuInitializeDrawingFields} -setup { deleteWindows } -body { menu .m1 } -cleanup { deleteWindows } -result {.m1} test menuDraw-2.1 {TkIntializeMenuEntryDrawingFields} -setup { deleteWindows } -body { menu .m1 .m1 add command } -cleanup { deleteWindows } -result {} test menuDraw-3.1 {TkMenuFreeDrawOptions} -setup { deleteWindows } -body { menu .m1 destroy .m1 } -result {} test menuDraw-4.1 {TkMenuEntryFreeDrawOptions} -setup { deleteWindows } -body { menu .m1 .m1 add command -label "This is a test" destroy .m1 } -result {} test menuDraw-4.2 {TkMenuEntryFreeDrawOptions} -setup { deleteWindows } -body { menu .m1 .m1 add checkbutton -label "This is a test." -font "Courier 12" \ -activeforeground red -background green -selectcolor purple destroy .m1 } -result {} test menuDraw-5.1 {TkMenuConfigureDrawOptions - new menu} -setup { deleteWindows } -body { menu .m1 } -cleanup { deleteWindows } -result {.m1} test menuDraw-5.2 {TkMenuConfigureDrawOptions - old menu} -setup { deleteWindows } -body { menu .m1 .m1 configure -fg red } -cleanup { deleteWindows } -result {} test menuDraw-5.3 {TkMenuConfigureDrawOptions - no disabledFg} -setup { deleteWindows } -body { menu .m1 -disabledforeground "" } -cleanup { deleteWindows } -result {.m1} test menuDraw-6.1 {TkMenuConfigureEntryDrawOptions - no tkfont specified} -setup { deleteWindows } -body { menu .m1 .m1 add command -label "foo" } -cleanup { deleteWindows } -result {} test menuDraw-6.2 {TkMenuConfigureEntryDrawOptions - tkfont specified} -setup { deleteWindows } -body { menu .m1 .m1 add command -label "foo" -font "Courier 12" } -cleanup { deleteWindows } -result {} test menuDraw-6.3 {TkMenuConfigureEntryDrawOptions - active state - wrong entry} -setup { deleteWindows } -body { menu .m1 .m1 add command -label "foo" .m1 entryconfigure 1 -state active } -cleanup { deleteWindows } -result {} test menuDraw-6.4 {TkMenuConfigureEntryDrawOptions - active state - correct entry} -setup { deleteWindows } -body { menu .m1 .m1 add command -label "foo" .m1 activate 1 .m1 entryconfigure 1 -state active } -cleanup { deleteWindows } -result {} test menuDraw-6.5 {TkMenuConfigureEntryDrawOptions - deactivate entry} -setup { deleteWindows } -body { menu .m1 .m1 add command -label "foo" .m1 activate 1 .m1 entryconfigure 1 -state normal } -cleanup { deleteWindows } -result {} test menuDraw-6.6 {TkMenuConfigureEntryDrawOptions - bad state} -setup { deleteWindows } -body { menu .m1 .m1 add command -label "foo" .m1 entryconfigure 1 -state foo } -cleanup { deleteWindows } -returnCodes error -result {bad state "foo": must be active, normal, or disabled} test menuDraw-6.7 {TkMenuConfigureEntryDrawOptions - tkfont specified} -setup { deleteWindows } -body { menu .m1 .m1 add command -label "foo" -font "Courier 12" } -cleanup { deleteWindows } -result {} test menuDraw-6.8 {TkMenuConfigureEntryDrawOptions - border specified} -setup { deleteWindows } -body { menu .m1 .m1 add command -label "foo" -background "red" } -cleanup { deleteWindows } -result {} test menuDraw-6.9 {TkMenuConfigureEntryDrawOptions - foreground specified} -setup { deleteWindows } -body { menu .m1 .m1 add command -label "foo" -foreground "red" } -cleanup { deleteWindows } -result {} test menuDraw-6.10 {TkMenuConfigureEntryDrawOptions - activeBorder specified} -setup { deleteWindows } -body { menu .m1 .m1 add command -label "foo" -activebackground "red" } -cleanup { deleteWindows } -result {} test menuDraw-6.11 {TkMenuConfigureEntryDrawOptions - activeforeground specified} -setup { deleteWindows } -body { menu .m1 .m1 add command -label "foo" -activeforeground "red" } -cleanup { deleteWindows } -result {} test menuDraw-6.12 {TkMenuConfigureEntryDrawOptions - selectcolor specified} -setup { deleteWindows } -body { menu .m1 .m1 add radiobutton -label "foo" -selectcolor "red" } -cleanup { deleteWindows } -result {} test menuDraw-6.13 {TkMenuConfigureEntryDrawOptions - textGC disposal} -setup { deleteWindows } -body { menu .m1 .m1 add command -label "foo" -font "Helvetica 12" .m1 entryconfigure 1 -font "Courier 12" } -cleanup { deleteWindows } -result {} test menuDraw-6.14 {TkMenuConfigureEntryDrawOptions - activeGC disposal} -setup { deleteWindows } -body { menu .m1 .m1 add command -label "foo" -activeforeground "red" .m1 entryconfigure 1 -activeforeground "green" } -cleanup { deleteWindows } -result {} test menuDraw-6.15 {TkMenuConfigureEntryDrawOptions - disabledGC disposal} -setup { deleteWindows } -body { menu .m1 -disabledforeground "red" .m1 add command -label "foo" .m1 configure -disabledforeground "green" } -cleanup { deleteWindows } -result {} test menuDraw-6.16 {TkMenuConfigureEntryDrawOptions - indicatorGC disposal} -setup { deleteWindows } -body { menu .m1 .m1 add radiobutton -label "foo" -selectcolor "red" .m1 entryconfigure 1 -selectcolor "green" } -cleanup { deleteWindows } -result {} test menuDraw-7.1 {TkEventuallyRecomputeMenu} -setup { deleteWindows } -body { menu .m1 .m1 add command -label "This is a long label" set tearoff [tk::TearOffMenu .m1] update idletasks .m1 entryconfigure 1 -label "foo" } -cleanup { deleteWindows } -result {} test menuDraw-7.2 {TkEventuallyRecomputeMenu - update pending} -setup { deleteWindows } -body { menu .m1 .m1 add command -label "This is a long label" set tearoff [tk::TearOffMenu .m1] .m1 entryconfigure 1 -label "foo" } -cleanup { deleteWindows } -result {} test menuDraw-8.1 {TkRecomputeMenu} -constraints { win userInteraction } -setup { deleteWindows } -body { menu .m1 .m1 configure -postcommand [.m1 add command -label foo] .m1 add command -label "Hit ESCAPE to make this menu go away." .m1 post 0 0 } -cleanup { deleteWindows } -result {} test menuDraw-9.1 {TkEventuallyRedrawMenu - entry test} -setup { deleteWindows } -body { catch {unset foo} menu .m1 set foo 0 .m1 add radiobutton -variable foo -label test tk::TearOffMenu .m1 update idletasks list [set foo test] [destroy .m1] [unset foo] } -result {test {} {}} test menuDraw-9.2 {TkEventuallyRedrawMenu - whole menu} -setup { deleteWindows } -body { menu .m1 tk::TearOffMenu .m1 } -cleanup { deleteWindows } -returnCodes ok -match glob -result * # Don't know how to test when window has been deleted and ComputeMenuGeometry # gets called. test menuDraw-10.1 {ComputeMenuGeometry - menubar} -setup { deleteWindows } -body { menu .m1 .m1 add command -label test . configure -menu .m1 list [update idletasks] [. configure -menu ""] } -cleanup { deleteWindows } -result {{} {}} test menuDraw-10.2 {ComputeMenuGeometry - non-menubar} -setup { deleteWindows } -body { menu .m1 .m1 add command -label test update idletasks } -cleanup { deleteWindows } -result {} test menuDraw-10.3 {ComputeMenuGeometry - Resize necessary} -setup { deleteWindows } -body { menu .m1 .m1 add command -label test update idletasks } -cleanup { deleteWindows } -result {} test menuDraw-10.4 {ComputeMenuGeometry - resize not necessary} -setup { deleteWindows } -body { menu .m1 .m1 add command -label test update idletasks .m1 entryconfigure 1 -label test update idletasks } -cleanup { deleteWindows } -result {} test menuDraw-11.1 {TkMenuSelectImageProc - entry selected; redraw not pending} -constraints { testImageType } -setup { deleteWindows imageCleanup } -body { image create test image1 image create test image2 menu .m1 .m1 add checkbutton -image image1 -selectimage image2 .m1 invoke 1 set tearoff [tk::TearOffMenu .m1 40 40] update idletasks list [image delete image2] [destroy .m1] } -cleanup { imageCleanup } -result {{} {}} test menuDraw-11.2 {TkMenuSelectImageProc - entry selected; redraw pending} -constraints { testImageType } -setup { deleteWindows imageCleanup } -body { image create test image1 image create test image2 menu .m1 .m1 add checkbutton -image image1 -selectimage image2 .m1 invoke 1 set tearoff [tk::TearOffMenu .m1 40 40] list [image delete image2] [destroy .m1] } -cleanup { imageCleanup } -result {{} {}} test menuDraw-11.3 {TkMenuSelectImageProc - entry not selected} -constraints { testImageType } -setup { deleteWindows imageCleanup } -body { image create test image1 image create test image2 menu .m1 .m1 add checkbutton -image image1 -selectimage image2 set tearoff [tk::TearOffMenu .m1 40 40] update idletasks list [image delete image2] [destroy .m1] } -cleanup { imageCleanup } -result {{} {}} #Don't know how to test missing tkwin in DisplayMenu test menuDraw-12.1 {DisplayMenu - menubar background} -constraints unix -setup { deleteWindows } -body { menu .m1 .m1 add cascade -label foo -menu .m2 . configure -menu .m1 list [update] [. configure -menu ""] } -cleanup { deleteWindows } -result {{} {}} test menuDraw-12.2 {Display menu - no entries} -setup { deleteWindows } -body { menu .m1 set tearoff [tk::TearOffMenu .m1 40 40] update } -cleanup { deleteWindows } -result {} test menuDraw-12.3 {DisplayMenu - one entry} -setup { deleteWindows } -body { menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] update } -cleanup { deleteWindows } -result {} test menuDraw-12.4 {DisplayMenu - two entries} -setup { deleteWindows } -body { menu .m1 .m1 add command -label "one" .m1 add command -label "two" set tearoff [tk::TearOffMenu .m1 40 40] update } -cleanup { deleteWindows } -result {} test menuDraw.12.5 {DisplayMenu - two columns - first bigger} -setup { deleteWindows } -body { menu .m1 .m1 add command -label "one" .m1 add command -label "two" .m1 add command -label "three" -columnbreak 1 set tearoff [tk::TearOffMenu .m1 40 40] update } -cleanup { deleteWindows } -result {} test menuDraw-12.5 {DisplayMenu - two column - second bigger} -setup { deleteWindows } -body { menu .m1 .m1 add command -label "one" .m1 add command -label "two" -columnbreak 1 .m1 add command -label "three" set tearoff [tk::TearOffMenu .m1 40 40] update } -cleanup { deleteWindows } -result {} test menuDraw.12.7 {DisplayMenu - three columns} -setup { deleteWindows } -body { menu .m1 .m1 add command -label "one" .m1 add command -label "two" -columnbreak 1 .m1 add command -label "three" .m1 add command -label "four" .m1 add command -label "five" .m1 add command -label "six" set tearoff [tk::TearOffMenu .m1 40 40] update } -cleanup { deleteWindows } -result {} test menuDraw-12.6 {Display menu - testing for extra space and menubars} -constraints { unix } -setup { deleteWindows } -body { menu .m1 .m1 add cascade -label foo . configure -menu .m1 update . configure -menu "" } -cleanup { deleteWindows } -result {} test menuDraw-12.7 {Display menu - extra space at end of menu} -setup { deleteWindows } -body { menu .m1 .m1 add cascade -label foo set tearoff [tk::TearOffMenu .m1 40 40] wm geometry $tearoff 200x100 update } -cleanup { deleteWindows } -result {} test menuDraw-13.1 {TkMenuEventProc - Expose} -setup { deleteWindows } -body { menu .m1 .m1 add command -label "one" menu .m2 .m2 add command -label "two" set tearoff1 [tk::TearOffMenu .m1 40 40] set tearoff2 [tk::TearOffMenu .m2 40 40] list [raise $tearoff2] [update] } -cleanup { deleteWindows } -result {{} {}} test menuDraw-13.2 {TkMenuEventProc - ConfigureNotify} -setup { deleteWindows } -body { menu .m1 .m1 add command -label "foo" set tearoff [tk::TearOffMenu .m1 40 40] list [wm geometry $tearoff 200x100] [update] } -cleanup { deleteWindows } -result {{} {}} # Testing deletes is hard, and I am going to do my best. Don't know how # to test the case where we have already cleared the tkwin field in the # menuPtr. test menuDraw-13.4 {TkMenuEventProc - simple delete} -setup { deleteWindows } -body { menu .m1 destroy .m1 } -result {} test menuDraw-13.5 {TkMenuEventProc - nothing pending} -setup { deleteWindows } -body { menu .m1 .m1 add command -label foo update idletasks destroy .m1 } -result {} test menuDraw-14.1 {TkMenuImageProc} -constraints testImageType -setup { deleteWindows } -body { catch {image delete image1} menu .m1 image create test image1 .m1 add command -image image1 update idletasks image delete image1 } -cleanup { deleteWindows } -result {} test menuDraw-14.2 {TkMenuImageProc} -constraints testImageType -setup { deleteWindows } -body { catch {image delete image1} menu .m1 image create test image1 .m1 add command -image image1 image delete image1 } -cleanup { deleteWindows } -result {} test menuDraw-15.1 {TkPostTearoffMenu - Basic posting} -setup { deleteWindows } -body { menu .m1 .m1 add command -label "foo" tk::TearOffMenu .m1 40 40 } -cleanup { deleteWindows } -returnCodes ok -match glob -result * test menuDraw-15.2 {TkPostTearoffMenu - Deactivation} -setup { deleteWindows } -body { menu .m1 .m1 add command -label "foo" -state active set tearoff [tk::TearOffMenu .m1 40 40] $tearoff index active } -cleanup { deleteWindows } -result {none} test menuDraw-15.3 {TkPostTearoffMenu - post command} -setup { deleteWindows } -body { catch {unset foo} menu .m1 -postcommand "set foo .m1" .m1 add command -label "foo" list [catch {tk::TearOffMenu .m1 40 40}] [set foo] [unset foo] [destroy .m1] } -result {0 .m1 {} {}} test menuDraw-15.4 {TkPostTearoffMenu - post command deleting the menu} -setup { deleteWindows } -body { menu .m1 -postcommand "destroy .m1" .m1 add command -label "foo" list [catch {tk::TearOffMenu .m1 40 40} msg] $msg [winfo exists .m1] } -result {0 {} 0} test menuDraw-15.5 {TkPostTearoffMenu - tearoff at edge of screen} -setup { deleteWindows } -body { menu .m1 .m1 add command -label "foo" set height [winfo screenheight .m1] tk::TearOffMenu .m1 40 $height } -cleanup { deleteWindows } -returnCodes ok -match glob -result * test menuDraw-15.6 {TkPostTearoffMenu - tearoff off right} -setup { deleteWindows } -body { menu .m1 .m1 add command -label "foo" set width [winfo screenwidth .m1] tk::TearOffMenu .m1 $width 40 } -cleanup { deleteWindows } -returnCodes ok -match glob -result * test menuDraw-16.1 {TkPostSubmenu} -constraints nonUnixUserInteraction -setup { deleteWindows } -body { menu .m1 .m1 add cascade -label test -menu .m2 menu .m2 .m2 add command -label "Hit ESCAPE to make this menu go away." set tearoff [tk::TearOffMenu .m1 40 40] $tearoff postcascade 0 $tearoff postcascade 0 } -cleanup { deleteWindows } -result {} test menuDraw-16.2 {TkPostSubMenu} -constraints nonUnixUserInteraction -setup { deleteWindows } -body { menu .m1 .m1 add cascade -label "two" -menu .m2 .m1 add cascade -label "three" -menu .m3 menu .m2 .m2 add command -label "two" menu .m3 .m3 add command -label "three" set tearoff [tk::TearOffMenu .m1 40 40] $tearoff postcascade 0 $tearoff postcascade 1 } -cleanup { deleteWindows } -result {} test menuDraw-16.3 {TkPostSubMenu} -setup { deleteWindows } -body { menu .m1 .m1 add cascade -label test -menu .m2 .m1 postcascade 1 } -cleanup { deleteWindows } -result {} test menuDraw-16.4 {TkPostSubMenu} -setup { deleteWindows } -body { menu .m1 .m1 add cascade -label test set tearoff [tk::TearOffMenu .m1 40 40] $tearoff postcascade 0 } -cleanup { deleteWindows } -result {} test menuDraw-16.5 {TkPostSubMenu} -constraints unix -setup { deleteWindows } -body { menu .m1 .m1 add cascade -label test -menu .m2 menu .m2 -postcommand "glorp" set tearoff [tk::TearOffMenu .m1 40 40] $tearoff postcascade test } -cleanup { deleteWindows } -returnCodes error -result {invalid command name "glorp"} test menuDraw-16.6 {TkPostSubMenu} -constraints { win userInteraction } -setup { deleteWindows } -body { menu .m1 .m1 add cascade -label test -menu .m2 menu .m2 .m2 add command -label "Hit ESCAPE to get rid of this menu" set tearoff [tk::TearOffMenu .m1 40 40] $tearoff postcascade 0 } -cleanup { deleteWindows } -result {} test menuDraw-17.1 {AdjustMenuCoords - menubar} -constraints unix -setup { deleteWindows } -body { menu .m1 -tearoff 0 .m1 add cascade -label test -menu .m2 menu .m2 -tearoff 0 .m2 add command -label foo . configure -menu .m1 foreach w [winfo children .] { if {[$w cget -type] == "menubar"} { break } } list [$w postcascade 0] [. configure -menu ""] } -cleanup { deleteWindows } -result {{} {}} test menuDraw-17.2 {AdjustMenuCoords - menu} -constraints { win userInteraction } -setup { deleteWindows } -body { menu .m1 .m1 add cascade -label test -menu .m2 menu .m2 .m2 add command -label "Hit ESCAPE to make this menu go away" set tearoff [tk::TearOffMenu .m1 40 40] $tearoff postcascade 0 } -cleanup { deleteWindows } -result {} # cleanup imageFinish deleteWindows cleanupTests return # Local variables: # mode: tcl # End: tk8.6.5/tests/option.test0000644003604700454610000003206112614413601014041 0ustar dgp771div# This file is a Tcl script to test out the option-handling facilities # of Tk. It is organized in the standard fashion for Tcl tests. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. package require tcltest 2.2 namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands testConstraint appNameIsTktest [expr {[winfo name .] eq "tktest"}] deleteWindows set appName [winfo name .] # First, test basic retrievals, being sure to trigger all the various # types of NodeElements (EXACT_LEAF_NAME, WILDCARD_NODE_CLASS, and # everything in-between). frame .op1 -class Class1 frame .op2 -class Class2 frame .op1.op3 -class Class1 frame .op1.op4 -class Class3 frame .op2.op5 -class Class2 frame .op1.op3.op6 -class Class4 # Configurations for tests 1.* - 12.* option clear option add *Color1 red option add *x blue option add *Class1.x yellow option add $appName.op1.x green option add *Class2.Color1 orange option add $appName.op2.op5.Color2 purple option add $appName.Class1.Class3.y brown option add $appName*op6*Color2 black option add $appName*Class1.op1.Color2 grey test option-1.1 {basic option retrieval} -body { option get . x Color1 } -result blue test option-1.2 {basic option retrieval} -body { option get . y Color1 } -result red test option-1.3 {basic option retrieval} -body { option get . z Color1 } -result red test option-1.4 {basic option retrieval} -body { option get . x Color2 } -result blue test option-1.5 {basic option retrieval} -body { option get . y Color2 } -result {} test option-1.6 {basic option retrieval} -body { option get . z Color2 } -result {} test option-2.1 {basic option retrieval} -body { option get .op1 x Color1 } -result green test option-2.2 {basic option retrieval} -body { option get .op1 y Color1 } -result red test option-2.3 {basic option retrieval} -body { option get .op1 z Color1 } -result red test option-2.4 {basic option retrieval} -body { option get .op1 x Color2 } -result green test option-2.5 {basic option retrieval} -body { option get .op1 y Color2 } -result {} test option-2.6 {basic option retrieval} -body { option get .op1 z Color2 } -result {} test option-3.1 {basic option retrieval} -body { option get .op1.op3 x Color1 } -result yellow test option-3.2 {basic option retrieval} -body { option get .op1.op3 y Color1 } -result red test option-3.3 {basic option retrieval} -body { option get .op1.op3 z Color1 } -result red test option-3.4 {basic option retrieval} -body { option get .op1.op3 x Color2 } -result yellow test option-3.5 {basic option retrieval} -body { option get .op1.op3 y Color2 } -result {} test option-3.6 {basic option retrieval} -body { option get .op1.op3 z Color2 } -result {} test option-4.1 {basic option retrieval} -body { option get .op1.op3.op6 x Color1 } -result blue test option-4.2 {basic option retrieval} -body { option get .op1.op3.op6 y Color1 } -result red test option-4.3 {basic option retrieval} -body { option get .op1.op3.op6 z Color1 } -result red test option-4.4 {basic option retrieval} -body { option get .op1.op3.op6 x Color2 } -result black test option-4.5 {basic option retrieval} -body { option get .op1.op3.op6 y Color2 } -result black test option-4.6 {basic option retrieval} -body { option get .op1.op3.op6 z Color2 } -result black test option-5.1 {basic option retrieval} -body { option get .op1.op4 x Color1 } -result blue test option-5.2 {basic option retrieval} -body { option get .op1.op4 y Color1 } -result brown test option-5.3 {basic option retrieval} -body { option get .op1.op4 z Color1 } -result red test option-5.4 {basic option retrieval} -body { option get .op1.op4 x Color2 } -result blue test option-5.5 {basic option retrieval} -body { option get .op1.op4 y Color2 } -result brown test option-5.6 {basic option retrieval} -body { option get .op1.op4 z Color2 } -result {} test option-6.1 {basic option retrieval} -body { option get .op2 x Color1 } -result orange test option-6.2 {basic option retrieval} -body { option get .op2 y Color1 } -result orange test option-6.3 {basic option retrieval} -body { option get .op2 z Color1 } -result orange test option-6.4 {basic option retrieval} -body { option get .op2 x Color2 } -result blue test option-6.5 {basic option retrieval} -body { option get .op2 y Color2 } -result {} test option-6.6 {basic option retrieval} -body { option get .op2 z Color2 } -result {} test option-7.1 {basic option retrieval} -body { option get .op2.op5 x Color1 } -result orange test option-7.2 {basic option retrieval} -body { option get .op2.op5 y Color1 } -result orange test option-7.3 {basic option retrieval} -body { option get .op2.op5 z Color1 } -result orange test option-7.4 {basic option retrieval} -body { option get .op2.op5 x Color2 } -result purple test option-7.5 {basic option retrieval} -body { option get .op2.op5 y Color2 } -result purple test option-7.6 {basic option retrieval} -body { option get .op2.op5 z Color2 } -result purple # Now try similar tests to above, except jump around non-hierarchically # between windows to make sure that the option stacks are pushed and # popped correctly. option get . foo Foo test option-8.1 {stack pushing/popping} -body { option get .op2.op5 x Color1 } -result orange test option-8.2 {stack pushing/popping} -body { option get .op2.op5 y Color1 } -result orange test option-8.3 {stack pushing/popping} -body { option get .op2.op5 z Color1 } -result orange test option-8.4 {stack pushing/popping} -body { option get .op2.op5 x Color2 } -result purple test option-8.5 {stack pushing/popping} -body { option get .op2.op5 y Color2 } -result purple test option-8.6 {stack pushing/popping} -body { option get .op2.op5 z Color2 } -result purple test option-9.1 {stack pushing/popping} -body { option get . x Color1 } -result blue test option-9.2 {stack pushing/popping} -body { option get . y Color1 } -result red test option-9.3 {stack pushing/popping} -body { option get . z Color1 } -result red test option-9.4 {stack pushing/popping} -body { option get . x Color2 } -result blue test option-9.5 {stack pushing/popping} -body { option get . y Color2 } -result {} test option-9.6 {stack pushing/popping} -body { option get . z Color2 } -result {} test option-10.1 {stack pushing/popping} -body { option get .op1.op3.op6 x Color1 } -result blue test option-10.2 {stack pushing/popping} -body { option get .op1.op3.op6 y Color1 } -result red test option-10.3 {stack pushing/popping} -body { option get .op1.op3.op6 z Color1 } -result red test option-10.4 {stack pushing/popping} -body { option get .op1.op3.op6 x Color2 } -result black test option-10.5 {stack pushing/popping} -body { option get .op1.op3.op6 y Color2 } -result black test option-10.6 {stack pushing/popping} -body { option get .op1.op3.op6 z Color2 } -result black test option-11.1 {stack pushing/popping} -body { option get .op1.op3 x Color1 } -result yellow test option-11.2 {stack pushing/popping} -body { option get .op1.op3 y Color1 } -result red test option-11.3 {stack pushing/popping} -body { option get .op1.op3 z Color1 } -result red test option-11.4 {stack pushing/popping} -body { option get .op1.op3 x Color2 } -result yellow test option-11.5 {stack pushing/popping} -body { option get .op1.op3 y Color2 } -result {} test option-11.6 {stack pushing/popping} -body { option get .op1.op3 z Color2 } -result {} test option-12.1 {stack pushing/popping} -body { option get .op1 x Color1 } -result green test option-12.2 {stack pushing/popping} -body { option get .op1 y Color1 } -result red test option-12.3 {stack pushing/popping} -body { option get .op1 z Color1 } -result red test option-12.4 {stack pushing/popping} -body { option get .op1 x Color2 } -result green test option-12.5 {stack pushing/popping} -body { option get .op1 y Color2 } -result {} test option-12.6 {stack pushing/popping} -body { option get .op1 z Color2 } -result {} # Test the major priority levels (widgetDefault, etc.) # Configurations for tests 13.* option clear option add $appName.op1.a 100 100 option add $appName.op1.A interactive interactive option add $appName.op1.b userDefault userDefault option add $appName.op1.B startupFile startupFile option add $appName.op1.c widgetDefault widgetDefault option add $appName.op1.C 0 0 test option-13.1 {priority levels} -body { option get .op1 a A } -result 100 test option-13.2 {priority levels} -body { option get .op1 b A } -result interactive test option-13.3 {priority levels} -body { option get .op1 b B } -result userDefault test option-13.4 {priority levels} -body { option get .op1 c B } -result startupFile test option-13.5 {priority levels} -body { option get .op1 c C } -result widgetDefault option add $appName.op1.B file2 widget test option-13.6 {priority levels} -body { option get .op1 c B } -result startupFile option add $appName.op1.B file2 startupFile test option-13.7 {priority levels} -body { option get .op1 c B } -result file2 # Test various error conditions test option-14.1 {error conditions} -body { option } -returnCodes error -result {wrong # args: should be "option cmd arg ?arg ...?"} test option-14.2 {error conditions} -body { option x } -returnCodes error -result {bad option "x": must be add, clear, get, or readfile} test option-14.3 {error conditions} -body { option foo 3 } -returnCodes error -result {bad option "foo": must be add, clear, get, or readfile} test option-14.4 {error conditions} -body { option add 3 } -returnCodes error -result {wrong # args: should be "option add pattern value ?priority?"} test option-14.5 {error conditions} -body { option add . a b c } -returnCodes error -result {wrong # args: should be "option add pattern value ?priority?"} test option-14.6 {error conditions} -body { option add . a -1 } -returnCodes error -result {bad priority level "-1": must be widgetDefault, startupFile, userDefault, interactive, or a number between 0 and 100} test option-14.7 {error conditions} -body { option add . a 101 } -returnCodes error -result {bad priority level "101": must be widgetDefault, startupFile, userDefault, interactive, or a number between 0 and 100} test option-14.8 {error conditions} -body { option add . a gorp } -returnCodes error -result {bad priority level "gorp": must be widgetDefault, startupFile, userDefault, interactive, or a number between 0 and 100} test option-14.9 {error conditions} -body { option get 3 } -returnCodes error -result {wrong # args: should be "option get window name class"} test option-14.10 {error conditions} -body { option get 3 4 } -returnCodes error -result {wrong # args: should be "option get window name class"} test option-14.11 {error conditions} -body { option get 3 4 5 6 } -returnCodes error -result {wrong # args: should be "option get window name class"} test option-14.12 {error conditions} -body { option get .gorp.gorp a A } -returnCodes error -result {bad window path name ".gorp.gorp"} set option1 [file join [testsDirectory] option.file1] test option-15.1 {database files} -body { option read non-existent } -returnCodes error -result {couldn't open "non-existent": no such file or directory} test option-15.2 {database files} -body { option read $option1 option get . x1 color } -result blue test option-15.3 {database files} -constraints appNameIsTktest -body { option read $option1 option get . x2 color } -result green test option-15.4 {database files} -body { option read $option1 option get . x3 color } -result purple test option-15.5 {database files} -body { option read $option1 option get . {x 4} color } -result brown test option-15.6 {database files} -body { option read $option1 option get . x6 color } -result {} test option-15.7 {database files} -body { option read $option1 option get . x9 color } -result " \t\\A\n" test option-15.8 {database files} -body { option read $option1 widget foo } -returnCodes error -result {wrong # args: should be "option readfile fileName ?priority?"} test option-15.9 {database files} -body { option add *x3 burgundy catch {option read $option1 userDefault} option get . x3 color } -result burgundy test option-15.10 {database files} -body { set option2 [file join [testsDirectory] option.file2] option read $option2 } -returnCodes error -result {missing colon on line 2} set option3 [file join [testsDirectory] option.file3] option read $option3 test option-15.11 {database files} {option get . {x 4} color} br\xf3wn test option-16.1 {ReadOptionFile} -body { set option4 [makeFile {} option.file3] set file [open $option4 w] fconfigure $file -translation crlf puts $file "*x7: true\n*x8: false" close $file option read $option4 userDefault list [option get . x7 color] [option get . x8 color] } -cleanup { removeFile $option4 } -result {true false} deleteWindows # cleanup cleanupTests return tk8.6.5/tests/butGeom.tcl0000644003604700454610000001076112077535536013760 0ustar dgp771div# This file creates a visual test for button layout. It is part of # the Tk visual test suite, which is invoked via the "visual" script. catch {destroy .t} toplevel .t wm title .t "Visual Tests for Button Geometry" wm iconname .t "Button Geometry" wm geom .t +0+0 wm minsize .t 1 1 label .t.l -text {This screen exercises the layout mechanisms for various flavors of buttons. Select display options below, and they will be applied to all of the button widgets. In order to see the effects of different anchor positions, expand the window so that there is extra space in the buttons. The letter "o" in "automatically" should be underlined in the right column of widgets.} -wraplength 5i pack .t.l -side top -fill both button .t.quit -text Quit -command {destroy .t} pack .t.quit -side bottom -pady 2m set sepId 1 proc sep {} { global sepId frame .t.sep$sepId -height 2 -bd 1 -relief sunken pack .t.sep$sepId -side top -padx 2m -pady 2m -fill x incr sepId } # Create buttons that control configuration options. frame .t.control pack .t.control -side top -fill x -pady 3m frame .t.control.left frame .t.control.right pack .t.control.left .t.control.right -side left -expand 1 -fill x label .t.anchorLabel -text "Anchor:" frame .t.control.left.f -width 6c -height 3c pack .t.anchorLabel .t.control.left.f -in .t.control.left -side top foreach anchor {nw n ne w center e sw s se} { button .t.anchor-$anchor -text $anchor -command "config -anchor $anchor" } place .t.anchor-nw -in .t.control.left.f -relx 0 -relwidth 0.333 \ -rely 0 -relheight 0.333 place .t.anchor-n -in .t.control.left.f -relx 0.333 -relwidth 0.333 \ -rely 0 -relheight 0.333 place .t.anchor-ne -in .t.control.left.f -relx 0.666 -relwidth 0.333 \ -rely 0 -relheight 0.333 place .t.anchor-w -in .t.control.left.f -relx 0 -relwidth 0.333 \ -rely 0.333 -relheight 0.333 place .t.anchor-center -in .t.control.left.f -relx 0.333 -relwidth 0.333 \ -rely 0.333 -relheight 0.333 place .t.anchor-e -in .t.control.left.f -relx 0.666 -relwidth 0.333 \ -rely 0.333 -relheight 0.333 place .t.anchor-sw -in .t.control.left.f -relx 0 -relwidth 0.333 \ -rely 0.666 -relheight 0.333 place .t.anchor-s -in .t.control.left.f -relx 0.333 -relwidth 0.333 \ -rely 0.666 -relheight 0.333 place .t.anchor-se -in .t.control.left.f -relx 0.666 -relwidth 0.333 \ -rely 0.666 -relheight 0.333 set justify center radiobutton .t.justify-left -text "Justify Left" -relief flat \ -command "config -justify left" -variable justify \ -value left radiobutton .t.justify-center -text "Justify Center" -relief flat \ -command "config -justify center" -variable justify \ -value center radiobutton .t.justify-right -text "Justify Right" -relief flat \ -command "config -justify right" -variable justify \ -value right pack .t.justify-left .t.justify-center .t.justify-right \ -in .t.control.right -anchor w sep frame .t.f1 pack .t.f1 -side top -expand 1 -fill both sep frame .t.f2 pack .t.f2 -side top -expand 1 -fill both sep frame .t.f3 pack .t.f3 -side top -expand 1 -fill both sep frame .t.f4 pack .t.f4 -side top -expand 1 -fill both sep label .t.l1 -text Label -bd 2 -relief sunken label .t.l2 -text "Explicit\nnewlines\n\nin the text" -bd 2 -relief sunken label .t.l3 -text "This text is quite long, so it must be wrapped automatically by Tk" -wraplength 2i -bd 2 -relief sunken -underline 50 pack .t.l1 .t.l2 .t.l3 -in .t.f1 -side left -padx 5m -pady 3m \ -expand y -fill both button .t.b1 -text Button button .t.b2 -text "Explicit\nnewlines\n\nin the text" button .t.b3 -text "This text is quite long, so it must be wrapped automatically by Tk" -wraplength 2i -underline 50 pack .t.b1 .t.b2 .t.b3 -in .t.f2 -side left -padx 5m -pady 3m \ -expand y -fill both checkbutton .t.c1 -text Checkbutton -variable a checkbutton .t.c2 -text "Explicit\nnewlines\n\nin the text" -variable b checkbutton .t.c3 -text "This text is quite long, so it must be wrapped automatically by Tk" -wraplength 2i -variable c -underline 50 pack .t.c1 .t.c2 .t.c3 -in .t.f3 -side left -padx 5m -pady 3m \ -expand y -fill both radiobutton .t.r1 -text Radiobutton -value a radiobutton .t.r2 -text "Explicit\nnewlines\n\nin the text" -value b radiobutton .t.r3 -text "This text is quite long, so it must be wrapped automatically by Tk" -wraplength 2i -value c -underline 50 pack .t.r1 .t.r2 .t.r3 -in .t.f4 -side left -padx 5m -pady 3m \ -expand y -fill both proc config {option value} { foreach w {.t.l1 .t.l2 .t.l3 .t.b1 .t.b2 .t.b3 .t.c1 .t.c2 .t.c3 .t.r1 .t.r2 .t.r3} { $w configure $option $value } } tk8.6.5/tests/winClipboard.test0000644003604700454610000000717112377375532015172 0ustar dgp771div# This file is a Tcl script to test out Tk's Windows specific # clipboard code. It is organized in the standard fashion for Tcl # tests. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 by Sun Microsystems, Inc. # Copyright (c) 1998-2000 by Scriptics Corporation. # All rights reserved. package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands namespace import -force tcltest::test # Note that these tests may fail if another application is grabbing the # clipboard (e.g. an X server) test winClipboard-1.1 {TkSelGetSelection} -constraints win -setup { clipboard clear } -body { selection get -selection CLIPBOARD } -cleanup { clipboard clear } -returnCodes error -result {CLIPBOARD selection doesn't exist or form "STRING" not defined} test winClipboard-1.2 {TkSelGetSelection} -constraints { win testclipboard } -setup { clipboard clear } -body { clipboard append {} list [selection get -selection CLIPBOARD] [testclipboard] } -cleanup { clipboard clear } -result {{} {}} test winClipboard-1.3 {TkSelGetSelection & TkWinClipboardRender} -constraints { win testclipboard } -setup { clipboard clear } -body { clipboard append abcd update list [selection get -selection CLIPBOARD] [testclipboard] } -cleanup { clipboard clear } -result {abcd abcd} test winClipboard-1.4 {TkSelGetSelection & TkWinClipboardRender} -constraints { win testclipboard } -setup { clipboard clear } -body { set map [list "\r" "\\r" "\n" "\\n"] clipboard append "line 1\nline 2" list [string map $map [selection get -selection CLIPBOARD]]\ [string map $map [testclipboard]] } -cleanup { clipboard clear } -result [list "line 1\\nline 2" "line 1\\nline 2"] test winClipboard-1.5 {TkSelGetSelection & TkWinClipboardRender} -constraints { win testclipboard } -setup { clipboard clear } -body { set map [list "\r" "\\r" "\n" "\\n"] clipboard append "line 1\u00c7\nline 2" list [string map $map [selection get -selection CLIPBOARD]]\ [string map $map [testclipboard]] } -cleanup { clipboard clear } -result [list "line 1\u00c7\\nline 2" "line 1\u00c7\\nline 2"] test winClipboard-1.6 {TkSelGetSelection & TkWinClipboardRender} -constraints { win testclipboard } -setup { clipboard clear } -body { clipboard append "\u043f\u0440\u0438\u0432\u0435\u0442 \u043c\u0438\u0444" list [selection get -selection CLIPBOARD] [testclipboard] } -cleanup { clipboard clear } -result [list "\u043f\u0440\u0438\u0432\u0435\u0442 \u043c\u0438\u0444"\ "\u043f\u0440\u0438\u0432\u0435\u0442 \u043c\u0438\u0444"] test winClipboard-2.1 {TkSelUpdateClipboard reentrancy problem} -constraints { win testclipboard } -setup { clipboard clear } -body { clipboard append -type OUR_ACTION "action data" clipboard append "string data" update list [selection get -selection CLIPBOARD -type OUR_ACTION] [testclipboard] } -cleanup { clipboard clear } -result {{action data} {string data}} test winClipboard-2.2 {TkSelUpdateClipboard reentrancy problem} -constraints { win testclipboard } -setup { clipboard clear } -body { clipboard append -type OUR_ACTION "new data" clipboard append "more data in string" update list [testclipboard] [selection get -selection CLIPBOARD -type OUR_ACTION] } -cleanup { clipboard clear } -result {{more data in string} {new data}} # cleanup cleanupTests return # Local variables: # mode: tcl # End: tk8.6.5/tests/cmds.test0000644003604700454610000000340112424437552013465 0ustar dgp771div# This file is a Tcl script to test the procedures in the file # tkCmds.c. It is organized in the standard fashion for Tcl tests. # # Copyright (c) 1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands namespace import -force tcltest::test update test cmds-1.1 {tkwait visibility, argument errors} -body { tkwait visibility } -returnCodes {error} -result {wrong # args: should be "tkwait variable|visibility|window name"} test cmds-1.2 {tkwait visibility, argument errors} -body { tkwait visibility foo bar } -returnCodes {error} -result {wrong # args: should be "tkwait variable|visibility|window name"} test cmds-1.3 {tkwait visibility, argument errors} -body { tkwait visibility bad_window } -returnCodes {error} -result {bad window path name "bad_window"} test cmds-1.4 {tkwait visibility, waiting for window to be mapped} -setup { button .b -text "Test" set x init } -body { after 100 {set x delay; place .b -x 0 -y 0} tkwait visibility .b return $x } -cleanup { destroy .b } -result {delay} test cmds-1.5 {tkwait visibility, window gets deleted} -setup { frame .f button .f.b -text "Test" pack .f.b set x init } -body { after 100 {set x deleted; destroy .f} tkwait visibility .f.b } -returnCodes {error} -result {window ".f.b" was deleted before its visibility changed} test cmds-1.6 {tkwait visibility, window gets deleted} -setup { frame .f button .f.b -text "Test" pack .f.b set x init } -body { after 100 {set x deleted; destroy .f} catch {tkwait visibility .f.b} return $x } -cleanup { destroy .f } -result {deleted} # cleanup cleanupTests return tk8.6.5/tests/focus.test0000644003604700454610000004744312424437552013674 0ustar dgp771div# This file is a Tcl script to test out the "focus" command and the # other procedures in the file tkFocus.c. It is organized in the # standard fashion for Tcl tests. # # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands namespace import -force tcltest::test proc focusSetup {} { destroy .t toplevel .t wm geom .t +0+0 foreach i {b1 b2 b3 b4} { button .t.$i -text .t.$i -relief raised -bd 2 pack .t.$i } tkwait visibility .t.b4 } proc focusSetupAlt {} { global env destroy .alt toplevel .alt -screen $env(TK_ALT_DISPLAY) foreach i {a b c d} { button .alt.$i -text .alt.$i -relief raised -bd 2 pack .alt.$i } tkwait visibility .alt.d } # The following procedure ensures that there is no input focus # in this application. It does it by arranging for another # application to grab the focus. The "after" and "update" stuff # is needed to wait long enough for pending actions to get through # the X server and possibly also the window manager. proc focusClear {} { global x; after 200 {set x 1} tkwait variable x dobg {focus -force .; update} update } # Button used in some tests in the whole test file button .b -text .b -relief raised -bd 2 pack .b # Make sure the window manager knows who has focus catch {fixfocus} # cleanupbg will be after 4.3 test setupbg update bind all { append focusInfo "in %W %d\n" } bind all { append focusInfo "out %W %d\n" } bind all { append focusInfo "press %W %K" } focusSetup if {[testConstraint altDisplay]} { focusSetupAlt } test focus-1.1 {Tk_FocusCmd procedure} -constraints unix -body { focusClear focus } -result {} test focus-1.2 {Tk_FocusCmd procedure} -constraints { unix altDisplay } -body { focus .alt.b focus } -result {} test focus-1.3 {Tk_FocusCmd procedure} -constraints unix -body { focusClear focus .t.b3 focus } -result {} test focus-1.4 {Tk_FocusCmd procedure} -constraints unix -body { focus "" } -returnCodes ok -result {} test focus-1.5 {Tk_FocusCmd procedure} -constraints unix -body { focusClear focus -force .t focus .t.b3 focus } -result {.t.b3} test focus-1.6 {Tk_FocusCmd procedure} -constraints unix -body { focus .gorp } -returnCodes error -result {bad window path name ".gorp"} test focus-1.7 {Tk_FocusCmd procedure} -constraints unix -body { focus .gorp a } -returnCodes error -result {bad option ".gorp": must be -displayof, -force, or -lastfor} test focus-1.8 {Tk_FocusCmd procedure, focussing on dead window} -constraints { unix } -setup { destroy .t2 } -body { focusClear toplevel .t2 wm geom .t2 +10+10 frame .t2.f -width 200 -height 100 -bd 2 -relief raised frame .t2.f2 -width 200 -height 100 -bd 2 -relief raised pack .t2.f .t2.f2 bind .t2.f {focus .t2.f} bind .t2.f2 {focus .t2} focus -force .t2.f2 tkwait visibility .t2.f2 update set x [focus] destroy .t2.f2 lappend x [focus] destroy .t2.f lappend x [focus] destroy .t2 return $x } -cleanup { destroy .t2 } -result {.t2.f2 .t2 .t2} test focus-1.9 {Tk_FocusCmd procedure, -displayof option} -constraints { unix } -body { focus -displayof } -returnCodes error -result {wrong # args: should be "focus -displayof window"} test focus-1.10 {Tk_FocusCmd procedure, -displayof option} -constraints { unix } -body { focus -displayof a b } -returnCodes error -result {wrong # args: should be "focus -displayof window"} test focus-1.11 {Tk_FocusCmd procedure, -displayof option} -constraints { unix } -body { focus -displayof .lousy } -returnCodes error -result {bad window path name ".lousy"} test focus-1.12 {Tk_FocusCmd procedure, -displayof option} -constraints { unix } -body { focusClear focus .t focus -displayof .t.b3 } -result {} test focus-1.13 {Tk_FocusCmd procedure, -displayof option} -constraints { unix } -body { focusClear focus -force .t focus -displayof .t.b3 } -result {.t} test focus-1.14 {Tk_FocusCmd procedure, -displayof option} -constraints { unix altDisplay } -body { focusClear focus -force .alt.c focus -displayof .alt } -result {.alt.c} test focus-1.15 {Tk_FocusCmd procedure, -force option} -constraints unix -body { focus -force } -returnCodes error -result {wrong # args: should be "focus -force window"} test focus-1.16 {Tk_FocusCmd procedure, -force option} -constraints unix -body { focus -force a b } -returnCodes error -result {wrong # args: should be "focus -force window"} test focus-1.17 {Tk_FocusCmd procedure, -force option} -constraints unix -body { focus -force foo } -returnCodes error -result {bad window path name "foo"} test focus-1.18 {Tk_FocusCmd procedure, -force option} -constraints unix -body { focus -force "" } -returnCodes ok -result {} test focus-1.19 {Tk_FocusCmd procedure, -force option} -constraints unix -body { focusClear focus .t.b1 set x [list [focus]] focus -force .t.b1 lappend x [focus] } -result {{} .t.b1} test focus-1.20 {Tk_FocusCmd procedure, -lastfor option} -constraints { unix } -body { focus -lastfor } -returnCodes error -result {wrong # args: should be "focus -lastfor window"} test focus-1.21 {Tk_FocusCmd procedure, -lastfor option} -constraints { unix } -body { focus -lastfor 1 2 } -returnCodes error -result {wrong # args: should be "focus -lastfor window"} test focus-1.22 {Tk_FocusCmd procedure, -lastfor option} -constraints { unix } -body { focus -lastfor who_knows? } -returnCodes error -result {bad window path name "who_knows?"} test focus-1.23 {Tk_FocusCmd procedure, -lastfor option} -constraints { unix } -body { focusClear focusSetup focus .b focus .t.b1 list [focus -lastfor .] [focus -lastfor .t.b3] } -result {.b .t.b1} test focus-1.24 {Tk_FocusCmd procedure, -lastfor option} -constraints { unix } -body { focusClear focusSetup update focus -lastfor .t.b2 } -result {.t} test focus-1.25 {Tk_FocusCmd procedure} -constraints unix -body { focus -unknown } -returnCodes error -result {bad option "-unknown": must be -displayof, -force, or -lastfor} focusSetup test focus-2.1 {TkFocusFilterEvent procedure} -constraints { unix nonPortable testwrapper } -body { focusClear focus -force .b focusSetup update set focusInfo {} event gen [testwrapper .t] -detail NotifyAncestor \ -sendevent 0x54217567 return $focusInfo } -result {} test focus-2.2 {TkFocusFilterEvent procedure} -constraints { unix nonPortable testwrapper } -body { focusClear focus -force .b focusSetup update set focusInfo {} event gen .t -detail NotifyAncestor -sendevent 0x547321ac list $focusInfo [focus] } -result {{in .t NotifyAncestor } .b} test focus-2.3 {TkFocusFilterEvent procedure} -constraints { unix nonPortable testwrapper } -body { focusClear focus -force .b focusSetup update set focusInfo {} event gen [testwrapper .t] -detail NotifyAncestor update list $focusInfo [focus -lastfor .t] } -result {{out .b NotifyNonlinear out . NotifyNonlinearVirtual in .t NotifyNonlinear } .t} test focus-2.4 {TkFocusFilterEvent procedure, FocusIn events} -constraints { unix nonPortable testwrapper } -body { focusClear set result {} focus .t.b1 # Important to end with NotifyAncestor, which is an # event that is processed normally. This has a side # effect on text 2.5 foreach detail {NotifyAncestor NotifyNonlinear NotifyNonlinearVirtual NotifyPointer NotifyPointerRoot NotifyVirtual NotifyAncestor} { focus -force . update event gen [testwrapper .t] -detail $detail set focusInfo {} update lappend result $focusInfo } return $result } -result {{out . NotifyNonlinear in .t NotifyNonlinearVirtual in .t.b1 NotifyNonlinear } {out . NotifyNonlinear in .t NotifyNonlinearVirtual in .t.b1 NotifyNonlinear } {} {out . NotifyNonlinear in .t NotifyNonlinearVirtual in .t.b1 NotifyNonlinear } {} {} {out . NotifyNonlinear in .t NotifyNonlinearVirtual in .t.b1 NotifyNonlinear }} test focus-2.5 {TkFocusFilterEvent procedure, creating FocusInfo struct} -constraints { unix nonPortable testwrapper } -body { focusSetup focus .t.b1 update event gen [testwrapper .t] -detail NotifyAncestor list $focusInfo [focus] } -result {{out . NotifyNonlinear in .t NotifyNonlinearVirtual in .t.b1 NotifyNonlinear } .t.b1} test focus-2.6 {TkFocusFilterEvent procedure, FocusIn events} -constraints { unix testwrapper } -body { focus .t.b1 focus . update event gen [testwrapper .t] -detail NotifyAncestor set focusInfo {} set x [focus] event gen . list $x $focusInfo } -result {.t.b1 {press .t.b1 x}} test focus-2.7 {TkFocusFilterEvent procedure, FocusOut events} -constraints { unix testwrapper } -body { set result {} foreach detail {NotifyAncestor NotifyInferior NotifyNonlinear NotifyNonlinearVirtual NotifyPointer NotifyPointerRoot NotifyVirtual} { focus -force .t.b1 event gen [testwrapper .t] -detail $detail update lappend result [focus] } return $result } -result {{} .t.b1 {} {} .t.b1 .t.b1 {}} test focus-2.8 {TkFocusFilterEvent procedure, FocusOut events} -constraints { unix testwrapper } -body { focus -force .t.b1 event gen .t.b1 -detail NotifyAncestor focus } -result {.t.b1} test focus-2.9 {TkFocusFilterEvent procedure, FocusOut events} -constraints { unix testwrapper } -body { focus .t.b1 event gen [testwrapper .] -detail NotifyAncestor focus } -result {} test focus-2.10 {TkFocusFilterEvent procedure, Enter events} -constraints { unix testwrapper } -body { set result {} focus .t.b1 focusClear foreach detail {NotifyAncestor NotifyInferior NotifyNonlinear NotifyNonlinearVirtual NotifyVirtual} { event gen [testwrapper .t] -detail $detail -focus 1 update lappend result [focus] event gen [testwrapper .t] -detail NotifyAncestor update } return $result } -result {.t.b1 {} .t.b1 .t.b1 .t.b1} test focus-2.11 {TkFocusFilterEvent procedure, Enter events} -constraints { unix testwrapper } -body { focusClear set focusInfo {} event gen [testwrapper .t] -detail NotifyAncestor update return $focusInfo } -result {} test focus-2.12 {TkFocusFilterEvent procedure, Enter events} -constraints { unix testwrapper } -body { focus -force .b update set focusInfo {} event gen [testwrapper .t] -detail NotifyAncestor -focus 1 update return $focusInfo } -result {} test focus-2.13 {TkFocusFilterEvent procedure, Enter events} -constraints { unix testwrapper } -body { focus .t.b1 focusClear event gen [testwrapper .t] -detail NotifyAncestor -focus 1 set focusInfo {} update return $focusInfo } -result {in .t NotifyVirtual in .t.b1 NotifyAncestor } test focus-2.14 {TkFocusFilterEvent procedure, Enter events, ignore errors when setting focus due to implicit focus} -constraints { unix testwrapper } -setup { destroy .t2 set focusInfo {} } -body { focusClear toplevel .t2 wm withdraw .t2 update event gen [testwrapper .t2] -detail NotifyAncestor -focus 1 update } -cleanup { destroy .t2 } -result {} test focus-2.15 {TkFocusFilterEvent procedure, Leave events} -constraints { unix testwrapper } -body { set result {} focus .t.b1 foreach detail {NotifyAncestor NotifyInferior NotifyNonlinear NotifyNonlinearVirtual NotifyVirtual} { focusClear event gen [testwrapper .t] -detail NotifyAncestor -focus 1 update event gen [testwrapper .t] -detail $detail update lappend result [focus] } return $result } -result {{} .t.b1 {} {} {}} test focus-2.16 {TkFocusFilterEvent procedure, Leave events} -constraints { unix testwrapper } -body { focusClear focus .t.b1 event gen [testwrapper .t] -detail NotifyAncestor -focus 1 update set focusInfo {} event gen [testwrapper .t] -detail NotifyAncestor update return $focusInfo } -result {out .t.b1 NotifyAncestor out .t NotifyVirtual } test focus-2.17 {TkFocusFilterEvent procedure, Leave events} -constraints { unix testwrapper } -body { focusClear focus .t.b1 event gen [testwrapper .t] -detail NotifyAncestor -focus 1 update set focusInfo {} event gen .t.b1 -detail NotifyAncestor event gen [testwrapper .] -detail NotifyAncestor update list $focusInfo [focus] } -result {{out .t.b1 NotifyAncestor out .t NotifyVirtual } {}} test focus-3.1 {SetFocus procedure, create record on focus} -constraints { unix testwrapper } -body { toplevel .t2 -width 250 -height 100 wm geometry .t2 +0+0 update focus -force .t2 update focus } -cleanup { destroy .t2 } -result {.t2} # This test produces no result, but it will generate a protocol # error if Tk forgets to make the window exist before focussing # on it. test focus-3.2 {SetFocus procedure, making window exist} -constraints { unix testwrapper } -body { update button .b2 -text "Another button" focus .b2 update } -cleanup { destroy .b2 update } -result {} # The following test doesn't produce a check-able result, but if # there are bugs it may generate an X protocol error. test focus-3.3 {SetFocus procedure, delaying claim of X focus} -constraints { unix testwrapper } -body { focusSetup focus -force .t.b2 update } -result {} test focus-3.4 {SetFocus procedure, delaying claim of X focus} -constraints { unix testwrapper } -body { focusSetup wm withdraw .t focus -force .t.b2 toplevel .t2 -width 250 -height 100 wm geometry .t2 +10+10 focus -force .t2 wm withdraw .t2 update wm deiconify .t2 wm deiconify .t } -cleanup { destroy .t2 } -result {} test focus-3.5 {SetFocus procedure, generating events} -constraints { unix testwrapper } -body { focusSetup focusClear set focusInfo {} focus -force .t.b2 update return $focusInfo } -result {in .t NotifyVirtual in .t.b2 NotifyAncestor } test focus-3.6 {SetFocus procedure, generating events} -constraints { unix testwrapper } -body { focusSetup focus -force .b update set focusInfo {} focus .t.b2 update return $focusInfo } -result {out .b NotifyNonlinear out . NotifyNonlinearVirtual in .t NotifyNonlinearVirtual in .t.b2 NotifyNonlinear } test focus-3.7 {SetFocus procedure, generating events} -constraints { unix nonPortable testwrapper } -body { # Non-portable because some platforms generate extra events. focusSetup focusClear set focusInfo {} focus .t.b2 update return $focusInfo } -result {} test focus-4.1 {TkFocusDeadWindow procedure} -constraints { unix testwrapper } -body { focusSetup update focus -force .b update destroy .t focus } -result {.b} test focus-4.2 {TkFocusDeadWindow procedure} -constraints { unix testwrapper } -body { focusSetup update focus -force .t.b2 focus .b update destroy .t.b2 update focus } -result {.b} # Non-portable due to wm-specific redirection of input focus when # windows are deleted: test focus-4.3 {TkFocusDeadWindow procedure} -constraints { unix nonPortable testwrapper } -body { focusSetup update focus .t update destroy .t update focus } -result {} test focus-4.4 {TkFocusDeadWindow procedure} -constraints { unix testwrapper } -body { focusSetup focus -force .t.b2 update destroy .t.b2 focus } -result {.t} cleanupbg # I don't know how to test most of the remaining procedures of this file # explicitly; they've already been exercised by the preceding tests. # Test 5.1 fails (before and after update) test focus-5.1 {ChangeXFocus procedure, don't take focus unless have it} -constraints { unix testwrapper secureserver } -body { setupbg focusSetup focus -force .t update set result [focus] send [dobg {tk appname}] {focus -force .; update} lappend result [focus] focus .t.b2 update lappend result [focus] } -cleanup { cleanupbg } -result {.t {} {}} destroy .t bind all {} bind all {} bind all {} fixfocus test focus-6.1 {miscellaneous - embedded application in same process} -constraints { unix testwrapper } -setup { eval interp delete [interp slaves] } -body { toplevel .t wm geometry .t +0+0 frame .t.f1 -container 1 frame .t.f2 pack .t.f1 .t.f2 entry .t.f2.e1 -bg red pack .t.f2.e1 bind all {lappend x "focus in %W %d"} bind all {lappend x "focus out %W %d"} interp create child child eval "set argv {-use [winfo id .t.f1]}" load {} Tk child child eval { entry .e1 -bg lightBlue pack .e1 bind all {lappend x "focus in %W %d"} bind all {lappend x "focus out %W %d"} set x {} } # Claim the focus and wait long enough for it to really arrive. focus -force .t.f2.e1 after 300 {set timer 1} vwait timer set x {} lappend x [focus] [child eval focus] # See if a "focus" command will move the focus to the embedded # application. child eval {focus .e1} after 300 {set timer 1} vwait timer lappend x | child eval {lappend x |} # Bring the focus back to the main application. focus .t.f2.e1 after 300 {set timer 1} vwait timer set result [list $x [child eval {set x}]] return $result } -cleanup { interp delete child destroy .t bind all {} bind all {} } -result {{.t.f2.e1 {} {focus out .t.f2.e1 NotifyNonlinear} {focus out .t.f2 NotifyNonlinearVirtual} {focus in .t.f1 NotifyNonlinear} | {focus out .t.f1 NotifyNonlinear} {focus in .t.f2 NotifyNonlinearVirtual} {focus in .t.f2.e1 NotifyNonlinear}} {{focus in . NotifyVirtual} {focus in .e1 NotifyAncestor} | {focus out .e1 NotifyAncestor} {focus out . NotifyVirtual}}} test focus-6.2 {miscellaneous - embedded application in different process} -constraints { unix testwrapper } -body { setupbg toplevel .t wm geometry .t +0+0 frame .t.f1 -container 1 frame .t.f2 pack .t.f1 .t.f2 entry .t.f2.e1 -bg red pack .t.f2.e1 bind all {lappend x "focus in %W %d"} bind all {lappend x "focus out %W %d"} setupbg -use [winfo id .t.f1] dobg { entry .e1 -bg lightBlue pack .e1 bind all {lappend x "focus in %W %d"} bind all {lappend x "focus out %W %d"} set x {} } # Claim the focus and wait long enough for it to really arrive. focus -force .t.f2.e1 after 300 {set timer 1} vwait timer set x {} lappend x [focus] [dobg focus] # See if a "focus" command will move the focus to the embedded # application. dobg {focus .e1} after 300 {set timer 1} vwait timer lappend x | dobg {lappend x |} # Bring the focus back to the main application. focus .t.f2.e1 after 300 {set timer 1} vwait timer set result [list $x [dobg {set x}]] return $result } -cleanup { destroy .t cleanupbg bind all {} bind all {} } -result {{.t.f2.e1 {} {focus out .t.f2.e1 NotifyNonlinear} {focus out .t.f2 NotifyNonlinearVirtual} {focus in .t.f1 NotifyNonlinear} | {focus out .t.f1 NotifyNonlinear} {focus in .t.f2 NotifyNonlinearVirtual} {focus in .t.f2.e1 NotifyNonlinear}} {{focus in . NotifyVirtual} {focus in .e1 NotifyAncestor} | {focus out .e1 NotifyAncestor} {focus out . NotifyVirtual}}} deleteWindows # cleanup cleanupTests return tk8.6.5/tests/oldpack.test0000644003604700454610000005020012377375532014161 0ustar dgp771div# This file is a Tcl script to test out the old syntax of Tk's # "pack" command (before release 3.3). It is organized in the # standard fashion for Tcl tests. # # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands namespace import -force tcltest::test # First, test a single window packed in various ways in a parent destroy .pack frame .pack place .pack -width 100 -height 100 frame .pack.red -width 10 -height 20 label .pack.red.l -text R -bd 2 -relief raised place .pack.red.l -relwidth 1.0 -relheight 1.0 frame .pack.green -width 30 -height 40 label .pack.green.l -text G -bd 2 -relief raised place .pack.green.l -relwidth 1.0 -relheight 1.0 frame .pack.blue -width 40 -height 40 label .pack.blue.l -text B -bd 2 -relief raised place .pack.blue.l -relwidth 1.0 -relheight 1.0 frame .pack.violet -width 80 -height 20 label .pack.violet.l -text P -bd 2 -relief raised place .pack.violet.l -relwidth 1.0 -relheight 1.0 test oldpack-1.1 {basic positioning} -body { pack ap .pack .pack.red top update winfo geometry .pack.red } -result 10x20+45+0 test oldpack-1.2 {basic positioning} -body { pack append .pack .pack.red bottom update winfo geometry .pack.red } -result 10x20+45+80 test oldpack-1.3 {basic positioning} -body { pack append .pack .pack.red left update winfo geometry .pack.red } -result 10x20+0+40 test oldpack-1.4 {basic positioning} -body { pack append .pack .pack.red right update winfo geometry .pack.red } -result 10x20+90+40 # Try adding padding around the window and make sure that the # window gets a larger frame. test oldpack-2.1 {padding} -body { pack append .pack .pack.red {t padx 20} update winfo geometry .pack.red } -result 10x20+45+0 test oldpack-2.2 {padding} -body { pack append .pack .pack.red {top pady 20} update winfo geometry .pack.red } -result 10x20+45+10 test oldpack-2.3 {padding} -body { pack append .pack .pack.red {l padx 20} update winfo geometry .pack.red } -result 10x20+10+40 test oldpack-2.4 {padding} -body { pack append .pack .pack.red {left pady 20} update winfo geometry .pack.red } -result 10x20+0+40 # Position the window at different positions in its frame to # make sure they all work. Try two differenet frame locations, # to make sure that frame offsets are being added in correctly. test oldpack-3.1 {framing} -body { pack append .pack .pack.red {b padx 20 pady 30} update winfo geometry .pack.red } -result 10x20+45+65 test oldpack-3.2 {framing} -body { pack append .pack .pack.red {bottom padx 20 pady 30 fr n} update winfo geometry .pack.red } -result 10x20+45+50 test oldpack-3.3 {framing} -body { pack append .pack .pack.red {bottom padx 20 pady 30 frame ne} update winfo geometry .pack.red } -result 10x20+90+50 test oldpack-3.4 {framing} -body { pack append .pack .pack.red {bottom padx 20 pady 30 frame e} update winfo geometry .pack.red } -result 10x20+90+65 test oldpack-3.5 {framing} -body { pack append .pack .pack.red {bottom padx 20 pady 30 frame se} update winfo geometry .pack.red } -result 10x20+90+80 test oldpack-3.6 {framing} -body { pack append .pack .pack.red {bottom padx 20 pady 30 frame s} update winfo geometry .pack.red } -result 10x20+45+80 test oldpack-3.7 {framing} -body { pack append .pack .pack.red {bottom padx 20 pady 30 frame sw} update winfo geometry .pack.red } -result 10x20+0+80 test oldpack-3.8 {framing} -body { pack append .pack .pack.red {bottom padx 20 pady 30 frame w} update winfo geometry .pack.red } -result 10x20+0+65 test oldpack-3.9 {framing} -body { pack append .pack .pack.red {bottom padx 20 pady 30 frame nw} update winfo geometry .pack.red } -result 10x20+0+50 test oldpack-3.10 {framing} -body { pack append .pack .pack.red {bottom padx 20 pady 30 frame c} update winfo geometry .pack.red } -result 10x20+45+65 test oldpack-3.11 {framing} -body { pack append .pack .pack.red {r padx 20 pady 30} update winfo geometry .pack.red } -result 10x20+80+40 test oldpack-3.12 {framing} -body { pack append .pack .pack.red {right padx 20 pady 30 frame n} update winfo geometry .pack.red } -result 10x20+80+0 test oldpack-3.13 {framing} -body { pack append .pack .pack.red {right padx 20 pady 30 frame ne} update winfo geometry .pack.red } -result 10x20+90+0 test oldpack-3.14 {framing} -body { pack append .pack .pack.red {right padx 20 pady 30 frame e} update winfo geometry .pack.red } -result 10x20+90+40 test oldpack-3.15 {framing} -body { pack append .pack .pack.red {right padx 20 pady 30 frame se} update winfo geometry .pack.red } -result 10x20+90+80 test oldpack-3.16 {framing} -body { pack append .pack .pack.red {right padx 20 pady 30 frame s} update winfo geometry .pack.red } -result 10x20+80+80 test oldpack-3.17 {framing} -body { pack append .pack .pack.red {right padx 20 pady 30 frame sw} update winfo geometry .pack.red } -result 10x20+70+80 test oldpack-3.18 {framing} -body { pack append .pack .pack.red {right padx 20 pady 30 frame w} update winfo geometry .pack.red } -result 10x20+70+40 test oldpack-3.19 {framing} -body { pack append .pack .pack.red {right padx 20 pady 30 frame nw} update winfo geometry .pack.red } -result 10x20+70+0 test oldpack-3.20 {framing} -body { pack append .pack .pack.red {right padx 20 pady 30 frame center} update winfo geometry .pack.red } -result 10x20+80+40 # Try out various filling combinations in a couple of different # frame locations. test oldpack-4.1 {filling} -body { pack append .pack .pack.red {bottom padx 20 pady 30 fillx} update winfo geometry .pack.red } -result 100x20+0+65 test oldpack-4.2 {filling} -body { pack append .pack .pack.red {bottom padx 20 pady 30 filly} update winfo geometry .pack.red } -result 10x50+45+50 test oldpack-4.3 {filling} -body { pack append .pack .pack.red {bottom padx 20 pady 30 fill} update winfo geometry .pack.red } -result 100x50+0+50 test oldpack-4.4 {filling} -body { pack append .pack .pack.red {right padx 20 pady 30 fillx} update winfo geometry .pack.red } -result 30x20+70+40 test oldpack-4.5 {filling} -body { pack append .pack .pack.red {right padx 20 pady 30 filly} update winfo geometry .pack.red } -result 10x100+80+0 test oldpack-4.6 {filling} -body { pack append .pack .pack.red {right padx 20 pady 30 fill} update winfo geometry .pack.red } -result 30x100+70+0 # Multiple windows: make sure that space is properly subtracted # from the cavity as windows are positioned inwards from all # different sides. Also make sure that windows get unmapped if # there isn't enough space for them. pack append .pack .pack.red top .pack.green top .pack.blue top \ .pack.violet top update test oldpack-5.1 {multiple windows} -body { winfo geometry .pack.red } -result 10x20+45+0 test oldpack-5.2 {multiple windows} -body { winfo geometry .pack.green } -result 30x40+35+20 test oldpack-5.3 {multiple windows} -body { winfo geometry .pack.blue } -result 40x40+30+60 test oldpack-5.4 {multiple windows} -body { winfo ismapped .pack.violet } -result 0 pack b .pack.blue .pack.violet top update test oldpack-5.5 {multiple windows} -body { winfo ismapped .pack.violet } -result 1 test oldpack-5.6 {multiple windows} -body { winfo geometry .pack.violet } -result 80x20+10+60 test oldpack-5.7 {multiple windows} -body { winfo geometry .pack.blue } -result 40x20+30+80 pack after .pack.blue .pack.red top update test oldpack-5.8 {multiple windows} -body { winfo geometry .pack.green } -result 30x40+35+0 test oldpack-5.9 {multiple windows} -body { winfo geometry .pack.violet } -result 80x20+10+40 test oldpack-5.10 {multiple windows} -body { winfo geometry .pack.blue } -result 40x40+30+60 test oldpack-5.11 {multiple windows} -body { winfo ismapped .pack.red } -result 0 pack before .pack.green .pack.red right .pack.blue left update test oldpack-5.12 {multiple windows} -body { winfo ismapped .pack.red } -result 1 test oldpack-5.13 {multiple windows} -body { winfo geometry .pack.red } -result 10x20+90+40 test oldpack-5.14 {multiple windows} -body { winfo geometry .pack.blue } -result 40x40+0+30 test oldpack-5.15 {multiple windows} -body { winfo geometry .pack.green } -result 30x40+50+0 test oldpack-5.16 {multiple windows} -body { winfo geometry .pack.violet } -result 50x20+40+40 pack append .pack .pack.violet left .pack.green bottom .pack.red bottom \ .pack.blue bottom update test oldpack-5.17 {multiple windows} -body { winfo geometry .pack.violet } -result 80x20+0+40 test oldpack-5.18 {multiple windows} -body { winfo geometry .pack.green } -result 20x40+80+60 test oldpack-5.19 {multiple windows} -body { winfo geometry .pack.red } -result 10x20+85+40 test oldpack-5.20 {multiple windows} -body { winfo geometry .pack.blue } -result 20x40+80+0 pack after .pack.blue .pack.blue top .pack.red right .pack.green right \ .pack.violet right update test oldpack-5.21 {multiple windows} -body { winfo geometry .pack.blue } -result 40x40+30+0 test oldpack-5.22 {multiple windows} -body { winfo geometry .pack.red } -result 10x20+90+60 test oldpack-5.23 {multiple windows} -body { winfo geometry .pack.green } -result 30x40+60+50 test oldpack-5.24 {multiple windows} -body { winfo geometry .pack.violet } -result 60x20+0+60 pack after .pack.blue .pack.red left .pack.green left .pack.violet left update test oldpack-5.25 {multiple windows} -body { winfo geometry .pack.blue } -result 40x40+30+0 test oldpack-5.26 {multiple windows} -body { winfo geometry .pack.red } -result 10x20+0+60 test oldpack-5.27 {multiple windows} -body { winfo geometry .pack.green } -result 30x40+10+50 test oldpack-5.28 {multiple windows} -body { winfo geometry .pack.violet } -result 60x20+40+60 pack append .pack .pack.violet left .pack.green left .pack.blue left \ .pack.red left update test oldpack-5.29 {multiple windows} -body { winfo geometry .pack.violet } -result 80x20+0+40 test oldpack-5.30 {multiple windows} -body { winfo geometry .pack.green } -result 20x40+80+30 test oldpack-5.31 {multiple windows} -body { winfo ismapped .pack.blue } -result 0 test oldpack-5.32 {multiple windows} -body { winfo ismapped .pack.red } -result 0 # Test the ability of the packer to propagate geometry information # to its parent. Make sure it computes the parent's needs both in # the direction of packing (width for "left" and "right" windows, # for example), and perpendicular to the pack direction (height for # "left" and "right" windows). pack append .pack .pack.red top .pack.green top .pack.blue top \ .pack.violet top update test oldpack-6.1 {geometry propagation} -body { winfo reqwidth .pack} -result 80 test oldpack-6.2 {geometry propagation} -body { winfo reqheight .pack} -result 120 destroy .pack.violet update test oldpack-6.3 {geometry propagation} -body { winfo reqwidth .pack} -result 40 test oldpack-6.4 {geometry propagation} -body { winfo reqheight .pack} -result 100 frame .pack.violet -width 80 -height 20 -bg violet label .pack.violet.l -text P -bd 2 -relief raised place .pack.violet.l -relwidth 1.0 -relheight 1.0 pack append .pack .pack.red left .pack.green right .pack.blue bottom \ .pack.violet top update test oldpack-6.5 {geometry propagation} -body { winfo reqwidth .pack} -result 120 test oldpack-6.6 {geometry propagation} -body { winfo reqheight .pack} -result 60 pack append .pack .pack.violet top .pack.green top .pack.blue left \ .pack.red left update test oldpack-6.7 {geometry propagation} -body { winfo reqwidth .pack} -result 80 test oldpack-6.8 {geometry propagation} -body { winfo reqheight .pack} -result 100 # Test the "expand" option, and make sure space is evenly divided # when several windows request expansion. pack append .pack .pack.violet top .pack.green {left e} \ .pack.blue {left expand} .pack.red {left expand} update test oldpack-7.1 {multiple expanded windows} -body { pack append .pack .pack.violet top .pack.green {left e} \ .pack.blue {left expand} .pack.red {left expand} update list [winfo geometry .pack.green] [winfo geometry .pack.blue] \ [winfo geometry .pack.red] } -result {30x40+3+40 40x40+39+40 10x20+86+50} test oldpack-7.2 {multiple expanded windows} -body { pack append .pack .pack.green left .pack.violet {bottom expand} \ .pack.blue {bottom expand} .pack.red {bottom expand} update list [winfo geometry .pack.violet] [winfo geometry .pack.blue] \ [winfo geometry .pack.red] } -result {70x20+30+77 40x40+45+30 10x20+60+3} test oldpack-7.3 {multiple expanded windows} -body { foreach i [winfo child .pack] { pack unpack $i } pack append .pack .pack.green {left e fill} .pack.red {left expand fill} \ .pack.blue {top fill} update list [winfo geometry .pack.green] [winfo geometry .pack.red] \ [winfo geometry .pack.blue] } -result {40x100+0+0 20x100+40+0 40x40+60+0} test oldpack-7.4 {multiple expanded windows} -body { foreach i [winfo child .pack] { pack unpack $i } pack append .pack .pack.red {top expand} .pack.violet {top expand} \ .pack.blue {right fill} update list [winfo geometry .pack.red] [winfo geometry .pack.violet] \ [winfo geometry .pack.blue] } -result {10x20+45+5 80x20+10+35 40x40+60+60} test oldpack-7.5 {multiple expanded windows} -body { foreach i [winfo child .pack] { pack unpack $i } pack append .pack .pack.green {right frame s} .pack.red {top expand} update list [winfo geometry .pack.green] [winfo geometry .pack.red] } -result {30x40+70+60 10x20+30+40} test oldpack-7.6 {multiple expanded windows} -body { foreach i [winfo child .pack] { pack unpack $i } pack append .pack .pack.violet {bottom frame e} .pack.red {right expand} update list [winfo geometry .pack.violet] [winfo geometry .pack.red] } -result {80x20+20+80 10x20+45+30} # Need more bizarre tests with combinations of expanded windows and # windows in opposing directions! Also, include padding in expanded # (and unexpanded) windows. # Syntax errors on pack commands test oldpack-8.1 {syntax errors} -body { pack } -returnCodes error -result {wrong # args: should be "pack option arg ?arg ...?"} test oldpack-8.2 {syntax errors} -body { pack append } -returnCodes error -result {wrong # args: should be "pack option arg ?arg ...?"} test oldpack-8.3 {syntax errors} -body { pack gorp foo } -returnCodes error -result {bad option "gorp": must be configure, forget, info, propagate, or slaves} test oldpack-8.4 {syntax errors} -body { pack a .pack } -returnCodes error -result {bad option "a": must be configure, forget, info, propagate, or slaves} test oldpack-8.5 {syntax errors} -body { pack after foobar } -returnCodes error -result {bad window path name "foobar"} test oldpack-8.6 {syntax errors} -setup { destroy .pack.yellow } -body { frame .pack.yellow -bg yellow pack after .pack.yellow } -cleanup { destroy .pack.yellow } -returnCodes error -result {window ".pack.yellow" isn't packed} test oldpack-8.7 {syntax errors} -body { pack append foobar } -returnCodes error -result {bad window path name "foobar"} test oldpack-8.8 {syntax errors} -body { pack before foobar } -returnCodes error -result {bad window path name "foobar"} test oldpack-8.9 {syntax errors} -setup { destroy .pack.yellow } -body { frame .pack.yellow -bg yellow pack before .pack.yellow } -cleanup { destroy .pack.yellow } -returnCodes error -result {window ".pack.yellow" isn't packed} test oldpack-8.10 {syntax errors} -body { pack info .pack help } -returnCodes error -result {wrong # args: should be "pack info window"} test oldpack-8.11 {syntax errors} -body { pack info foobar } -returnCodes error -result {bad window path name "foobar"} test oldpack-8.12 {syntax errors} -body { pack append .pack .pack.blue } -returnCodes error -result {wrong # args: window ".pack.blue" should be followed by options} test oldpack-8.13 {syntax errors} -body { pack append . .pack.blue top } -returnCodes error -result {can't pack .pack.blue inside .} test oldpack-8.14 {syntax errors} -body { pack append .pack .pack.blue f } -returnCodes error -result {bad option "f": should be top, bottom, left, right, expand, fill, fillx, filly, padx, pady, or frame} test oldpack-8.15 {syntax errors} -body { pack append .pack .pack.blue pad } -returnCodes error -result {bad option "pad": should be top, bottom, left, right, expand, fill, fillx, filly, padx, pady, or frame} test oldpack-8.16 {syntax errors} -body { pack append .pack .pack.blue {frame south} } -returnCodes error -result {bad anchor "south": must be n, ne, e, se, s, sw, w, nw, or center} test oldpack-8.17 {syntax errors} -body { pack append .pack .pack.blue {padx -2} } -returnCodes error -result {bad pad value "-2": must be positive screen distance} test oldpack-8.18 {syntax errors} -body { pack append .pack .pack.blue {padx} } -returnCodes error -result {wrong # args: "padx" option must be followed by screen distance} test oldpack-8.19 {syntax errors} -body { pack append .pack .pack.blue {pady -2} } -returnCodes error -result {bad pad value "-2": must be positive screen distance} test oldpack-8.20 {syntax errors} -body { pack append .pack .pack.blue {pady} } -returnCodes error -result {wrong # args: "pady" option must be followed by screen distance} test oldpack-8.21 {syntax errors} -body { pack append .pack .pack.blue "\{abc" } -returnCodes error -result {unmatched open brace in list} test oldpack-8.22 {syntax errors} -body { pack append .pack .pack.blue frame } -returnCodes error -result {wrong # args: "frame" option must be followed by anchor point} # Test "pack info" command output. test oldpack-9.1 {information output} -body { pack append .pack .pack.blue {top fillx frame n} \ .pack.red {bottom filly frame s} .pack.green {left fill frame w} \ .pack.violet {right expand frame e} list [pack slaves .pack] [pack info .pack.blue] [pack info .pack.red] \ [pack info .pack.green] [pack info .pack.violet] } -result {{.pack.blue .pack.red .pack.green .pack.violet} {-in .pack -anchor n -expand 0 -fill x -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} {-in .pack -anchor s -expand 0 -fill y -ipadx 0 -ipady 0 -padx 0 -pady 0 -side bottom} {-in .pack -anchor w -expand 0 -fill both -ipadx 0 -ipady 0 -padx 0 -pady 0 -side left} {-in .pack -anchor e -expand 1 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side right}} test oldpack-9.2 {information output} -body { pack append .pack .pack.blue {padx 10 frame nw} \ .pack.red {pady 20 frame ne} .pack.green {frame se} \ .pack.violet {frame sw} list [pack slaves .pack] [pack info .pack.blue] [pack info .pack.red] \ [pack info .pack.green] [pack info .pack.violet] } -result {{.pack.blue .pack.red .pack.green .pack.violet} {-in .pack -anchor nw -expand 0 -fill none -ipadx 0 -ipady 0 -padx 5 -pady 0 -side top} {-in .pack -anchor ne -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 10 -side top} {-in .pack -anchor se -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} {-in .pack -anchor sw -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top}} test oldpack-9.3 {information output} -body { pack append .pack .pack.blue {frame center} .pack.red {frame center} \ .pack.green {frame c} .pack.violet {frame c} list [pack slaves .pack] [pack info .pack.blue] [pack info .pack.red] \ [pack info .pack.green] [pack info .pack.violet] } -result {{.pack.blue .pack.red .pack.green .pack.violet} {-in .pack -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} {-in .pack -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} {-in .pack -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} {-in .pack -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top}} destroy .pack # cleanup cleanupTests return tk8.6.5/tests/cursor.test0000644003604700454610000005246012424437552014065 0ustar dgp771div# This file is a Tcl script to test out the procedures in the file # tkCursor.c. It is organized in the standard white-box fashion for # Tcl tests. # # Copyright (c) 1998 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. package require tcltest 2.2 namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands # Tests 2.3 and 2.4 need a helper file with a very specific name and # controlled format. proc setWincur {wincurName} { upvar $wincurName wincur set wincur(data_octal) { 000 000 002 000 001 000 040 040 000 000 007 000 007 000 060 001 000 000 026 000 000 000 050 000 000 000 040 000 000 000 100 000 000 000 001 000 001 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 377 377 377 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 160 016 000 000 170 036 000 000 174 076 000 000 076 174 000 000 037 370 000 000 017 360 000 000 007 340 000 000 007 340 000 000 017 360 000 000 037 370 000 000 076 174 000 000 174 076 000 000 170 036 000 000 160 016 000 000 000 000 000 000 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 017 360 377 377 007 340 377 377 003 300 377 377 001 200 377 377 200 001 377 377 300 003 377 377 340 007 377 377 360 017 377 377 360 017 377 377 340 007 377 377 300 003 377 377 200 001 377 377 001 200 377 377 003 300 377 377 007 340 377 377 017 360 377 377 } set wincur(data_binary) {} foreach wincur(num) $wincur(data_octal) { append wincur(data_binary) [binary format c [scan $wincur(num) %o]] } set wincur(dir) [makeDirectory {dir with spaces}] set wincur(file) [makeFile $wincur(data_binary) "test file.cur" $wincur(dir)] } test cursor-1.1 {Tk_AllocCursorFromObj - converting internal reps} -constraints { testcursor } -body { set x watch lindex $x 0 button .b -cursor $x lindex $x 0 testcursor watch } -cleanup { destroy .b } -result {{1 0}} test cursor-1.2 {Tk_AllocCursorFromObj - discard stale cursor} -constraints { testcursor } -body { set x watch set result {} button .b1 -cursor $x destroy .b1 lappend result [testcursor watch] button .b2 -cursor $x lappend result [testcursor watch] } -cleanup { destroy .b2 } -result {{} {{1 1}}} test cursor-1.3 {Tk_AllocCursorFromObj - reuse existing cursor} -constraints { testcursor } -body { set x watch set result {} button .b1 -cursor $x lappend result [testcursor watch] button .b2 -cursor $x pack .b1 .b2 -side top lappend result [testcursor watch] } -cleanup { destroy .b1 .b2 } -result {{{1 1}} {{2 1}}} test cursor-2.1 {Tk_GetCursor procedure} -body { button .b -cursor bad_name } -cleanup { destroy .b } -returnCodes error -result {bad cursor spec "bad_name"} test cursor-2.2 {Tk_GetCursor procedure} -body { button .b -cursor @xyzzy } -cleanup { destroy .b } -returnCodes error -result {bad cursor spec "@xyzzy"} test cursor-2.3 {Tk_GetCursor procedure: cursor specs are lists} -constraints { win } -setup { unset -nocomplain wincur set wincur(file) "" } -body { setWincur wincur button .b -cursor [list @$wincur(file)] } -cleanup { destroy .b removeDirectory $wincur(dir) unset wincur } -result {.b} test cursor-2.4 {Tk_GetCursor procedure: cursor specs are lists} -constraints { win } -setup { unset -nocomplain wincur set wincur(file) "" } -body { setWincur wincur button .b -cursor @[regsub -all {[][ \\{}""$#]} $wincur(file) {\\&}] } -cleanup { destroy .b removeDirectory $wincur(dir) unset wincur } -result {.b} test cursor-3.1 {Tk_FreeCursorFromObj - reference counts} -constraints { testcursor } -setup { set x heart set result {} } -body { button .b1 -cursor $x button .b3 -cursor $x button .b2 -cursor $x lappend result [testcursor heart] destroy .b1 lappend result [testcursor heart] destroy .b2 lappend result [testcursor heart] destroy .b3 lappend result [testcursor heart] } -result {{{3 1}} {{2 1}} {{1 1}} {}} test cursor-4.1 {FreeCursorObjProc} -constraints { testcursor } -body { set x [join heart] button .b -cursor $x set y [join heart] .b configure -cursor $y set z [join heart] .b configure -cursor $z set result {} lappend result [testcursor heart] set x red lappend result [testcursor heart] set z 32 lappend result [testcursor heart] destroy .b lappend result [testcursor heart] set y bogus set result } -cleanup { destroy .b } -result {{{1 3}} {{1 2}} {{1 1}} {}} # ------------------------------------------------------------------------- test cursor-5.1 {assert consistent cursor configuration command} -setup { button .b } -body { .b configure -cursor {watch red black} } -cleanup { destroy .b } -result {} # ------------------------------------------------------------------------- # Check for the standard set of cursors. test cursor-6.1 {check cursor-font cursor X_cursor} -setup { button .b -text X_cursor } -body { .b configure -cursor X_cursor } -cleanup { destroy .b } -result {} test cursor-6.2 {check cursor-font cursor arrow} -setup { button .b -text arrow } -body { .b configure -cursor arrow } -cleanup { destroy .b } -result {} test cursor-6.3 {check cursor-font cursor based_arrow_down} -setup { button .b -text based_arrow_down } -body { .b configure -cursor based_arrow_down } -cleanup { destroy .b } -result {} test cursor-6.4 {check cursor-font cursor based_arrow_up} -setup { button .b -text based_arrow_up } -body { .b configure -cursor based_arrow_up } -cleanup { destroy .b } -result {} test cursor-6.5 {check cursor-font cursor boat} -setup { button .b -text boat } -body { .b configure -cursor boat } -cleanup { destroy .b } -result {} test cursor-6.6 {check cursor-font cursor bogosity} -setup { button .b -text bogosity } -body { .b configure -cursor bogosity } -cleanup { destroy .b } -result {} test cursor-6.7 {check cursor-font cursor bottom_left_corner} -setup { button .b -text bottom_left_corner } -body { .b configure -cursor bottom_left_corner } -cleanup { destroy .b } -result {} test cursor-6.8 {check cursor-font cursor bottom_right_corner} -setup { button .b -text bottom_right_corner } -body { .b configure -cursor bottom_right_corner } -cleanup { destroy .b } -result {} test cursor-6.9 {check cursor-font cursor bottom_side} -setup { button .b -text bottom_side } -body { .b configure -cursor bottom_side } -cleanup { destroy .b } -result {} test cursor-6.10 {check cursor-font cursor bottom_tee} -setup { button .b -text bottom_tee } -body { .b configure -cursor bottom_tee } -cleanup { destroy .b } -result {} test cursor-6.11 {check cursor-font cursor box_spiral} -setup { button .b -text box_spiral } -body { .b configure -cursor box_spiral } -cleanup { destroy .b } -result {} test cursor-6.12 {check cursor-font cursor center_ptr} -setup { button .b -text center_ptr } -body { .b configure -cursor center_ptr } -cleanup { destroy .b } -result {} test cursor-6.13 {check cursor-font cursor circle} -setup { button .b -text circle } -body { .b configure -cursor circle } -cleanup { destroy .b } -result {} test cursor-6.14 {check cursor-font cursor clock} -setup { button .b -text clock } -body { .b configure -cursor clock } -cleanup { destroy .b } -result {} test cursor-6.15 {check cursor-font cursor coffee_mug} -setup { button .b -text coffee_mug } -body { .b configure -cursor coffee_mug } -cleanup { destroy .b } -result {} test cursor-6.16 {check cursor-font cursor cross} -setup { button .b -text cross } -body { .b configure -cursor cross } -cleanup { destroy .b } -result {} test cursor-6.17 {check cursor-font cursor cross_reverse} -setup { button .b -text cross_reverse } -body { .b configure -cursor cross_reverse } -cleanup { destroy .b } -result {} test cursor-6.18 {check cursor-font cursor crosshair} -setup { button .b -text crosshair } -body { .b configure -cursor crosshair } -cleanup { destroy .b } -result {} test cursor-6.19 {check cursor-font cursor diamond_cross} -setup { button .b -text diamond_cross } -body { .b configure -cursor diamond_cross } -cleanup { destroy .b } -result {} test cursor-6.20 {check cursor-font cursor dot} -setup { button .b -text dot } -body { .b configure -cursor dot } -cleanup { destroy .b } -result {} test cursor-6.21 {check cursor-font cursor dotbox} -setup { button .b -text dotbox } -body { .b configure -cursor dotbox } -cleanup { destroy .b } -result {} test cursor-6.22 {check cursor-font cursor double_arrow} -setup { button .b -text double_arrow } -body { .b configure -cursor double_arrow } -cleanup { destroy .b } -result {} test cursor-6.23 {check cursor-font cursor draft_large} -setup { button .b -text draft_large } -body { .b configure -cursor draft_large } -cleanup { destroy .b } -result {} test cursor-6.24 {check cursor-font cursor draft_small} -setup { button .b -text draft_small } -body { .b configure -cursor draft_small } -cleanup { destroy .b } -result {} test cursor-6.25 {check cursor-font cursor draped_box} -setup { button .b -text draped_box } -body { .b configure -cursor draped_box } -cleanup { destroy .b } -result {} test cursor-6.26 {check cursor-font cursor exchange} -setup { button .b -text exchange } -body { .b configure -cursor exchange } -cleanup { destroy .b } -result {} test cursor-6.27 {check cursor-font cursor fleur} -setup { button .b -text fleur } -body { .b configure -cursor fleur } -cleanup { destroy .b } -result {} test cursor-6.28 {check cursor-font cursor gobbler} -setup { button .b -text gobbler } -body { .b configure -cursor gobbler } -cleanup { destroy .b } -result {} test cursor-6.29 {check cursor-font cursor gumby} -setup { button .b -text gumby } -body { .b configure -cursor gumby } -cleanup { destroy .b } -result {} test cursor-6.30 {check cursor-font cursor hand1} -setup { button .b -text hand1 } -body { .b configure -cursor hand1 } -cleanup { destroy .b } -result {} test cursor-6.31 {check cursor-font cursor hand2} -setup { button .b -text hand2 } -body { .b configure -cursor hand2 } -cleanup { destroy .b } -result {} test cursor-6.32 {check cursor-font cursor heart} -setup { button .b -text heart } -body { .b configure -cursor heart } -cleanup { destroy .b } -result {} test cursor-6.33 {check cursor-font cursor icon} -setup { button .b -text icon } -body { .b configure -cursor icon } -cleanup { destroy .b } -result {} test cursor-6.34 {check cursor-font cursor iron_cross} -setup { button .b -text iron_cross } -body { .b configure -cursor iron_cross } -cleanup { destroy .b } -result {} test cursor-6.35 {check cursor-font cursor left_ptr} -setup { button .b -text left_ptr } -body { .b configure -cursor left_ptr } -cleanup { destroy .b } -result {} test cursor-6.36 {check cursor-font cursor left_side} -setup { button .b -text left_side } -body { .b configure -cursor left_side } -cleanup { destroy .b } -result {} test cursor-6.37 {check cursor-font cursor left_tee} -setup { button .b -text left_tee } -body { .b configure -cursor left_tee } -cleanup { destroy .b } -result {} test cursor-6.38 {check cursor-font cursor leftbutton} -setup { button .b -text leftbutton } -body { .b configure -cursor leftbutton } -cleanup { destroy .b } -result {} test cursor-6.39 {check cursor-font cursor ll_angle} -setup { button .b -text ll_angle } -body { .b configure -cursor ll_angle } -cleanup { destroy .b } -result {} test cursor-6.40 {check cursor-font cursor lr_angle} -setup { button .b -text lr_angle } -body { .b configure -cursor lr_angle } -cleanup { destroy .b } -result {} test cursor-6.41 {check cursor-font cursor man} -setup { button .b -text man } -body { .b configure -cursor man } -cleanup { destroy .b } -result {} test cursor-6.42 {check cursor-font cursor middlebutton} -setup { button .b -text middlebutton } -body { .b configure -cursor middlebutton } -cleanup { destroy .b } -result {} test cursor-6.43 {check cursor-font cursor mouse} -setup { button .b -text mouse } -body { .b configure -cursor mouse } -cleanup { destroy .b } -result {} test cursor-6.44 {check cursor-font cursor pencil} -setup { button .b -text pencil } -body { .b configure -cursor pencil } -cleanup { destroy .b } -result {} test cursor-6.45 {check cursor-font cursor pirate} -setup { button .b -text pirate } -body { .b configure -cursor pirate } -cleanup { destroy .b } -result {} test cursor-6.46 {check cursor-font cursor plus} -setup { button .b -text plus } -body { .b configure -cursor plus } -cleanup { destroy .b } -result {} test cursor-6.47 {check cursor-font cursor question_arrow} -setup { button .b -text question_arrow } -body { .b configure -cursor question_arrow } -cleanup { destroy .b } -result {} test cursor-6.48 {check cursor-font cursor right_ptr} -setup { button .b -text right_ptr } -body { .b configure -cursor right_ptr } -cleanup { destroy .b } -result {} test cursor-6.49 {check cursor-font cursor right_side} -setup { button .b -text right_side } -body { .b configure -cursor right_side } -cleanup { destroy .b } -result {} test cursor-6.50 {check cursor-font cursor right_tee} -setup { button .b -text right_tee } -body { .b configure -cursor right_tee } -cleanup { destroy .b } -result {} test cursor-6.51 {check cursor-font cursor rightbutton} -setup { button .b -text rightbutton } -body { .b configure -cursor rightbutton } -cleanup { destroy .b } -result {} test cursor-6.52 {check cursor-font cursor rtl_logo} -setup { button .b -text rtl_logo } -body { .b configure -cursor rtl_logo } -cleanup { destroy .b } -result {} test cursor-6.53 {check cursor-font cursor sailboat} -setup { button .b -text sailboat } -body { .b configure -cursor sailboat } -cleanup { destroy .b } -result {} test cursor-6.54 {check cursor-font cursor sb_down_arrow} -setup { button .b -text sb_down_arrow } -body { .b configure -cursor sb_down_arrow } -cleanup { destroy .b } -result {} test cursor-6.55 {check cursor-font cursor sb_h_double_arrow} -setup { button .b -text sb_h_double_arrow } -body { .b configure -cursor sb_h_double_arrow } -cleanup { destroy .b } -result {} test cursor-6.56 {check cursor-font cursor sb_left_arrow} -setup { button .b -text sb_left_arrow } -body { .b configure -cursor sb_left_arrow } -cleanup { destroy .b } -result {} test cursor-6.57 {check cursor-font cursor sb_right_arrow} -setup { button .b -text sb_right_arrow } -body { .b configure -cursor sb_right_arrow } -cleanup { destroy .b } -result {} test cursor-6.58 {check cursor-font cursor sb_up_arrow} -setup { button .b -text sb_up_arrow } -body { .b configure -cursor sb_up_arrow } -cleanup { destroy .b } -result {} test cursor-6.59 {check cursor-font cursor sb_v_double_arrow} -setup { button .b -text sb_v_double_arrow } -body { .b configure -cursor sb_v_double_arrow } -cleanup { destroy .b } -result {} test cursor-6.60 {check cursor-font cursor shuttle} -setup { button .b -text shuttle } -body { .b configure -cursor shuttle } -cleanup { destroy .b } -result {} test cursor-6.61 {check cursor-font cursor sizing} -setup { button .b -text sizing } -body { .b configure -cursor sizing } -cleanup { destroy .b } -result {} test cursor-6.62 {check cursor-font cursor spider} -setup { button .b -text spider } -body { .b configure -cursor spider } -cleanup { destroy .b } -result {} test cursor-6.63 {check cursor-font cursor spraycan} -setup { button .b -text spraycan } -body { .b configure -cursor spraycan } -cleanup { destroy .b } -result {} test cursor-6.64 {check cursor-font cursor star} -setup { button .b -text star } -body { .b configure -cursor star } -cleanup { destroy .b } -result {} test cursor-6.65 {check cursor-font cursor target} -setup { button .b -text target } -body { .b configure -cursor target } -cleanup { destroy .b } -result {} test cursor-6.66 {check cursor-font cursor tcross} -setup { button .b -text tcross } -body { .b configure -cursor tcross } -cleanup { destroy .b } -result {} test cursor-6.67 {check cursor-font cursor top_left_arrow} -setup { button .b -text top_left_arrow } -body { .b configure -cursor top_left_arrow } -cleanup { destroy .b } -result {} test cursor-6.68 {check cursor-font cursor top_left_corner} -setup { button .b -text top_left_corner } -body { .b configure -cursor top_left_corner } -cleanup { destroy .b } -result {} test cursor-6.69 {check cursor-font cursor top_right_corner} -setup { button .b -text top_right_corner } -body { .b configure -cursor top_right_corner } -cleanup { destroy .b } -result {} test cursor-6.70 {check cursor-font cursor top_side} -setup { button .b -text top_side } -body { .b configure -cursor top_side } -cleanup { destroy .b } -result {} test cursor-6.71 {check cursor-font cursor top_tee} -setup { button .b -text top_tee } -body { .b configure -cursor top_tee } -cleanup { destroy .b } -result {} test cursor-6.72 {check cursor-font cursor trek} -setup { button .b -text trek } -body { .b configure -cursor trek } -cleanup { destroy .b } -result {} test cursor-6.73 {check cursor-font cursor ul_angle} -setup { button .b -text ul_angle } -body { .b configure -cursor ul_angle } -cleanup { destroy .b } -result {} test cursor-6.74 {check cursor-font cursor umbrella} -setup { button .b -text umbrella } -body { .b configure -cursor umbrella } -cleanup { destroy .b } -result {} test cursor-6.75 {check cursor-font cursor ur_angle} -setup { button .b -text ur_angle } -body { .b configure -cursor ur_angle } -cleanup { destroy .b } -result {} test cursor-6.76 {check cursor-font cursor watch} -setup { button .b -text watch } -body { .b configure -cursor watch } -cleanup { destroy .b } -result {} test cursor-6.77 {check cursor-font cursor xterm} -setup { button .b -text xterm } -body { .b configure -cursor xterm } -cleanup { destroy .b } -result {} # Test cursor named "none", it is not defined in # the X cursor table. It is defined in a Tk specific # table of named cursors and should be available on # all platforms. test cursor-6.78 {test cursor named "none"} -setup { button .b -text CButton } -body { .b configure -cursor none .b cget -cursor } -cleanup { destroy .b } -result none test cursor-6.79 {test cursor named "none"} -setup { button .b -text CButton } -body { .b configure -cursor none .b configure -cursor {} .b cget -cursor } -cleanup { destroy .b } -result {} test cursor-6.80 {test cursor named "none"} -setup { button .b -text CButton } -body { .b configure -cursor none .b configure -cursor {} .b configure -cursor none .b cget -cursor } -cleanup { destroy .b } -result none test cursor-6.81 {test cursor named "none"} -setup { button .b -text CButton } -body { # Setting fg and bg does nothing for the none cursor # because it displays no fg or bg pixels. set results [list] .b configure -cursor none lappend results [.b cget -cursor] .b configure -cursor {none blue} lappend results [.b cget -cursor] .b configure -cursor {none blue green} lappend results [.b cget -cursor] .b configure -cursor {} lappend results [.b cget -cursor] set results } -cleanup { destroy .b unset results } -result {none {none blue} {none blue green} {}} # ------------------------------------------------------------------------- # Check the Windows specific cursors test cursor-7.1 {check Windows cursor no} -constraints win -setup { button .b -text no } -body { .b configure -cursor no } -cleanup { destroy .b } -result {} test cursor-7.2 {check Windows cursor starting} -constraints win -setup { button .b -text starting } -body { .b configure -cursor starting } -cleanup { destroy .b } -result {} test cursor-7.3 {check Windows cursor size} -constraints win -setup { button .b -text size } -body { .b configure -cursor size } -cleanup { destroy .b } -result {} test cursor-7.4 {check Windows cursor size_ne_sw} -constraints win -setup { button .b -text size_ne_sw } -body { .b configure -cursor size_ne_sw } -cleanup { destroy .b } -result {} test cursor-7.5 {check Windows cursor size_ns} -constraints win -setup { button .b -text size_ns } -body { .b configure -cursor size_ns } -cleanup { destroy .b } -result {} test cursor-7.6 {check Windows cursor size_nw_se} -constraints win -setup { button .b -text size_nw_se } -body { .b configure -cursor size_nw_se } -cleanup { destroy .b } -result {} test cursor-7.7 {check Windows cursor size_we} -constraints win -setup { button .b -text size_we } -body { .b configure -cursor size_we } -cleanup { destroy .b } -result {} test cursor-7.8 {check Windows cursor uparrow} -constraints win -setup { button .b -text uparrow } -body { .b configure -cursor uparrow } -cleanup { destroy .b } -result {} test cursor-7.9 {check Windows cursor wait} -constraints win -setup { button .b -text wait } -body { .b configure -cursor wait } -cleanup { destroy .b } -result {} # ------------------------------------------------------------------------- # cleanup cleanupTests return tk8.6.5/tests/winfo.test0000644003604700454610000003566312377375532013706 0ustar dgp771div# This file is a Tcl script to test out the "winfo" command. It is # organized in the standard fashion for Tcl tests. # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. package require tcltest 2.2 namespace import ::tcltest::* tcltest::configure {*}$argv tcltest::loadTestedCommands # eatColors -- # Creates a toplevel window and allocates enough colors in it to # use up all the slots in the colormap. # # Arguments: # w - Name of toplevel window to create. # options - Options for w, such as "-colormap new". proc eatColors {w {options ""}} { destroy $w eval toplevel $w $options wm geom $w +0+0 canvas $w.c -width 400 -height 200 -bd 0 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 {} \ -fill $color } } update } # XXX - This test file is woefully incomplete. At present, only a # few of the winfo options are tested. # ---------------------------------------------------------------------- test winfo-1.1 {"winfo atom" command} -body { winfo atom } -returnCodes error -result {wrong # args: should be "winfo atom ?-displayof window? name"} test winfo-1.2 {"winfo atom" command} -body { winfo atom a b } -returnCodes error -result {wrong # args: should be "winfo atom ?-displayof window? name"} test winfo-1.3 {"winfo atom" command} -body { winfo atom a b c d } -returnCodes error -result {wrong # args: should be "winfo atom ?-displayof window? name"} test winfo-1.4 {"winfo atom" command} -body { winfo atom -displayof geek foo } -returnCodes error -result {bad window path name "geek"} test winfo-1.5 {"winfo atom" command} -body { winfo atom PRIMARY } -result 1 test winfo-1.6 {"winfo atom" command} -body { winfo atom -displayof . PRIMARY } -result 1 test winfo-2.1 {"winfo atomname" command} -body { winfo atomname } -returnCodes error -result {wrong # args: should be "winfo atomname ?-displayof window? id"} test winfo-2.2 {"winfo atomname" command} -body { winfo atomname a b } -returnCodes error -result {wrong # args: should be "winfo atomname ?-displayof window? id"} test winfo-2.3 {"winfo atomname" command} -body { winfo atomname a b c d } -returnCodes error -result {wrong # args: should be "winfo atomname ?-displayof window? id"} test winfo-2.4 {"winfo atomname" command} -body { winfo atomname -displayof geek foo } -returnCodes error -result {bad window path name "geek"} test winfo-2.5 {"winfo atomname" command} -body { winfo atomname 44215 } -returnCodes error -result {no atom exists with id "44215"} test winfo-2.6 {"winfo atomname" command} -body { winfo atomname 2 } -result SECONDARY test winfo-2.7 {"winfo atom" command} -body { winfo atomname -displayof . 2 } -result SECONDARY test winfo-3.1 {"winfo colormapfull" command} -constraints { defaultPseudocolor8 } -body { winfo colormapfull } -returnCodes error -result {wrong # args: should be "winfo colormapfull window"} test winfo-3.2 {"winfo colormapfull" command} -constraints { defaultPseudocolor8 } -body { winfo colormapfull a b } -returnCodes error -result {wrong # args: should be "winfo colormapfull window"} test winfo-3.3 {"winfo colormapfull" command} -constraints { defaultPseudocolor8 } -body { winfo colormapfull foo } -returnCodes error -result {bad window path name "foo"} test winfo-3.4 {"winfo colormapfull" command} -constraints { unix defaultPseudocolor8 } -body { eatColors .t {-colormap new} set result [list [winfo colormapfull .] [winfo colormapfull .t]] .t.c delete 34 lappend result [winfo colormapfull .t] .t.c create rectangle 30 30 80 80 -fill #441739 lappend result [winfo colormapfull .t] .t.c create rectangle 40 40 90 90 -fill #ffeedd lappend result [winfo colormapfull .t] destroy .t.c lappend result [winfo colormapfull .t] } -cleanup { destroy .t } -result {0 1 0 0 1 0} test winfo-4.1 {"winfo containing" command} -body { winfo containing 22 } -returnCodes error -result {wrong # args: should be "winfo containing ?-displayof window? rootX rootY"} test winfo-4.2 {"winfo containing" command} -body { winfo containing a b c } -returnCodes error -result {wrong # args: should be "winfo containing ?-displayof window? rootX rootY"} test winfo-4.3 {"winfo containing" command} -body { winfo containing a b c d e } -returnCodes error -result {wrong # args: should be "winfo containing ?-displayof window? rootX rootY"} test winfo-4.4 {"winfo containing" command} -body { winfo containing -displayof geek 25 30 } -returnCodes error -result {bad window path name "geek"} test winfo-4.5 {"winfo containing" command} -body { } -setup { destroy .t } -body { toplevel .t -width 550 -height 400 frame .t.f -width 80 -height 60 -bd 2 -relief raised place .t.f -x 50 -y 50 wm geom .t +0+0 update raise .t winfo containing [winfo rootx .t.f] [winfo rooty .t.f] } -cleanup { destroy .t } -result .t.f test winfo-4.6 {"winfo containing" command} -constraints { nonPortable } -setup { destroy .t } -body { toplevel .t -width 550 -height 400 frame .t.f -width 80 -height 60 -bd 2 -relief raised place .t.f -x 50 -y 50 wm geom .t +0+0 update winfo containing [expr [winfo rootx .t.f]-1] [expr [winfo rooty .t.f]-1] } -cleanup { destroy .t } -result .t test winfo-4.7 {"winfo containing" command} -setup { destroy .t } -body { toplevel .t -width 550 -height 400 frame .t.f -width 80 -height 60 -bd 2 -relief raised place .t.f -x 50 -y 50 wm geom .t +0+0 update set x [winfo containing -display .t.f [expr [winfo rootx .t]+600] \ [expr [winfo rooty .t.f]+450]] expr {($x == ".") || ($x == "")} } -cleanup { destroy .t } -result {1} test winfo-5.1 {"winfo interps" command} -body { winfo interps a } -returnCodes error -result {wrong # args: should be "winfo interps ?-displayof window?"} test winfo-5.2 {"winfo interps" command} -body { winfo interps a b c } -returnCodes error -result {wrong # args: should be "winfo interps ?-displayof window?"} test winfo-5.3 {"winfo interps" command} -body { winfo interps -displayof geek } -returnCodes error -result {bad window path name "geek"} test winfo-5.4 {"winfo interps" command} -constraints unix -body { expr {[lsearch -exact [winfo interps] [tk appname]] >= 0} } -result {1} test winfo-5.5 {"winfo interps" command} -constraints unix -body { expr {[lsearch -exact [winfo interps -displayof .] [tk appname]] >= 0} } -result {1} test winfo-6.1 {"winfo exists" command} -body { winfo exists } -returnCodes error -result {wrong # args: should be "winfo exists window"} test winfo-6.2 {"winfo exists" command} -body { winfo exists a b } -returnCodes error -result {wrong # args: should be "winfo exists window"} test winfo-6.3 {"winfo exists" command} -body { winfo exists gorp } -result {0} test winfo-6.4 {"winfo exists" command} -body { winfo exists . } -result {1} test winfo-6.5 {"winfo exists" command} -setup { destroy .b } -body { button .b -text "Test button" set x [winfo exists .b] pack .b update bind .b {lappend x [winfo exists .x]} destroy .b lappend x [winfo exists .x] } -result {1 0 0} test winfo-7.1 {"winfo pathname" command} -body { winfo pathname } -returnCodes error -result {wrong # args: should be "winfo pathname ?-displayof window? id"} test winfo-7.2 {"winfo pathname" command} -body { winfo pathname a b } -returnCodes error -result {wrong # args: should be "winfo pathname ?-displayof window? id"} test winfo-7.3 {"winfo pathname" command} -body { winfo pathname a b c d } -returnCodes error -result {wrong # args: should be "winfo pathname ?-displayof window? id"} test winfo-7.4 {"winfo pathname" command} -body { winfo pathname -displayof geek 25 } -returnCodes error -result {bad window path name "geek"} test winfo-7.5 {"winfo pathname" command} -body { winfo pathname xyz } -returnCodes error -result {expected integer but got "xyz"} test winfo-7.6 {"winfo pathname" command} -body { winfo pathname 224 } -returnCodes error -result {window id "224" doesn't exist in this application} test winfo-7.7 {"winfo pathname" command} -setup { destroy .b button .b -text "Help" update } -body { winfo pathname -displayof .b [winfo id .] } -cleanup { destroy .b } -result {.} test winfo-7.8 {"winfo pathname" command} -constraints { unix testwrapper } -body { winfo pathname [testwrapper .] } -result {} test winfo-8.1 {"winfo pointerx" command} -setup { destroy .b button .b -text "Help" update } -body { catch [winfo pointerx .b] } -body { catch [winfo pointerx .b] } -result 1 test winfo-8.2 {"winfo pointery" command} -setup { destroy .b button .b -text "Help" update } -body { catch [winfo pointery .b] } -body { catch [winfo pointerx .b] } -result 1 test winfo-8.3 {"winfo pointerxy" command} -setup { destroy .b button .b -text "Help" update } -body { catch [winfo pointerxy .b] } -body { catch [winfo pointerx .b] } -result 1 test winfo-9.1 {"winfo viewable" command} -body { winfo viewable } -returnCodes error -result {wrong # args: should be "winfo viewable window"} test winfo-9.2 {"winfo viewable" command} -body { winfo viewable foo } -returnCodes error -result {bad window path name "foo"} test winfo-9.3 {"winfo viewable" command} -body { winfo viewable . } -result {1} test winfo-9.4 {"winfo viewable" command} -body { wm iconify . winfo viewable . } -cleanup { wm deiconify . } -result {0} test winfo-9.5 {"winfo viewable" command} -setup { deleteWindows } -body { frame .f1 -width 100 -height 100 -relief raised -bd 2 place .f1 -x 0 -y 0 frame .f1.f2 -width 50 -height 50 -relief raised -bd 2 place .f1.f2 -x 0 -y 0 update list [winfo viewable .f1] [winfo viewable .f1.f2] } -cleanup { deleteWindows } -result {1 1} test winfo-9.6 {"winfo viewable" command} -setup { deleteWindows } -body { frame .f1 -width 100 -height 100 -relief raised -bd 2 frame .f1.f2 -width 50 -height 50 -relief raised -bd 2 place .f1.f2 -x 0 -y 0 update list [winfo viewable .f1] [winfo viewable .f1.f2] } -cleanup { deleteWindows } -result {0 0} test winfo-9.7 {"winfo viewable" command} -setup { deleteWindows } -body { frame .f1 -width 100 -height 100 -relief raised -bd 2 place .f1 -x 0 -y 0 frame .f1.f2 -width 50 -height 50 -relief raised -bd 2 place .f1.f2 -x 0 -y 0 update wm iconify . list [winfo viewable .f1] [winfo viewable .f1.f2] } -cleanup { wm deiconify . deleteWindows } -result {0 0} test winfo-10.1 {"winfo visualid" command} -body { winfo visualid } -returnCodes error -result {wrong # args: should be "winfo visualid window"} test winfo-10.2 {"winfo visualid" command} -body { winfo visualid gorp } -returnCodes error -result {bad window path name "gorp"} test winfo-10.3 {"winfo visualid" command} -body { expr {2 + [winfo visualid .] - [winfo visualid .]} } -result {2} test winfo-11.1 {"winfo visualid" command} -body { winfo visualsavailable } -returnCodes error -result {wrong # args: should be "winfo visualsavailable window ?includeids?"} test winfo-11.2 {"winfo visualid" command} -body { winfo visualsavailable gorp } -returnCodes error -result {bad window path name "gorp"} test winfo-11.3 {"winfo visualid" command} -body { winfo visualsavailable . includeids foo } -returnCodes error -result {wrong # args: should be "winfo visualsavailable window ?includeids?"} test winfo-11.4 {"winfo visualid" command} -body { llength [lindex [winfo visualsa .] 0] } -result {2} test winfo-11.5 {"winfo visualid" command} -body { llength [lindex [winfo visualsa . includeids] 0] } -result {3} test winfo-11.6 {"winfo visualid" command} -body { set x [lindex [lindex [winfo visualsa . includeids] 0] 2] expr $x + 2 - $x } -result {2} test winfo-12.1 {GetDisplayOf procedure} -body { winfo atom - foo x } -returnCodes error -result {wrong # args: should be "winfo atom ?-displayof window? name"} test winfo-12.2 {GetDisplayOf procedure} -body { winfo atom -d bad_window x } -returnCodes error -result {bad window path name "bad_window"} # Some embedding tests # test winfo-13.1 {root coordinates of embedded toplevel} -setup { deleteWindows } -body { frame .con -container 1 pack .con -expand yes -fill both toplevel .emb -use [winfo id .con] -bd 0 -highlightthickness 0 button .emb.b pack .emb.b -expand yes -fill both update list rootx [expr {[winfo rootx .emb] == [winfo rootx .con]}] \ rooty [expr {[winfo rooty .emb] == [winfo rooty .con]}] } -cleanup { deleteWindows } -result {rootx 1 rooty 1} test winfo-13.2 {destroying embedded toplevel} -setup { deleteWindows } -body { frame .con -container 1 pack .con -expand yes -fill both toplevel .emb -use [winfo id .con] -bd 0 -highlightthickness 0 button .emb.b pack .emb.b -expand yes -fill both update destroy .emb update list embedded [winfo exists .emb.b] container [winfo exists .con] } -cleanup { deleteWindows } -result {embedded 0 container 1} test winfo-13.3 {destroying container window} -setup { deleteWindows } -body { frame .con -container 1 pack .con -expand yes -fill both toplevel .emb -use [winfo id .con] -bd 0 -highlightthickness 0 button .emb.b pack .emb.b -expand yes -fill both update destroy .con update list child [winfo exists .emb.b] parent [winfo exists .emb] } -cleanup { deleteWindows } -result {child 0 parent 0} test winfo-13.4 {[winfo containing] with embedded windows} -setup { deleteWindows } -body { frame .con -container 1 pack .con -expand yes -fill both toplevel .emb -use [winfo id .con] -bd 0 -highlightthickness 0 button .emb.b pack .emb.b -expand yes -fill both update button .b pack .b -expand yes -fill both update string compare .emb.b \ [winfo containing [winfo rootx .emb.b] [winfo rooty .emb.b]] } -cleanup { deleteWindows } -result 0 test winfo-14.1 {usage} -body { winfo ismapped } -returnCodes error -result {wrong # args: should be "winfo ismapped window"} test winfo-14.2 {usage} -body { winfo ismapped . . } -returnCodes error -result {wrong # args: should be "winfo ismapped window"} test winfo-14.3 {initially unmapped} -setup { destroy .t } -body { toplevel .t winfo ismapped .t } -cleanup { destroy .t } -result 0 test winfo-14.4 {mapped at idle time} -setup { destroy .t } -body { toplevel .t update idletasks winfo ismapped .t } -cleanup { destroy .t } -result 1 deleteWindows # cleanup cleanupTests return # Local variables: # mode: tcl # End: tk8.6.5/tests/pwrdLogo150.gif0000644003604700454610000000467111555562545014367 0ustar dgp771divGIF89aa̙f̙̙̙f̙fff3f333̙̙ffff3333fffffffff3ff333f3f3333f3! -dl-! ,a@pH,Ȥrl:·TBTجVzHj՚h&ѓt"FdgN~Yg}rgogYwWNZWftL~f NewɑפԿWMrڕOq Ǖ W-/i*`z F9/9- $6GSDZzB,nw64e4ޅHOtf) OXCeU(Qh T|P w$ kZF\RuF]Z --(v+)[Y =!W+]]_&/Ap j!b: {^= `U@Hf\?(Lq@ 0La&!]#]G \qAHX[(W,ƌ1aBW(t8AdG)(P=UuuAKM\'rR/Wd2a0訦GÎ?B#HƊ1Q0R %+0I{<QVtz' ynEpĹ0iIg΢L%ʫKAlphQ1eⲁZg2esmU&d;JÌyjL !"..v 䀥.kXůZMY' RlЯKLv%8ʣ~~A/9Mv%|50 J <U5\51\ 8iV=W;s=A tytQ넀K8eO#d"DjKV[wĽ ^mJvUma,9tTjm.A9036Ej;w o~BUyzU'S͌%+mgrP/>~g W˳f]Tw;|OaE^cWb!zghn wc!{wBx.DJLE'3B[2?]!.L@VD{`¦) ;cT6a%J$.aR*P >ᆧ O%>t[ `Ѽ1va Jh %V"h_d  جH6x4.AXy,uD:3$<.cYcxP za!Q>᱑lK! !zd:@ryG8 eU9JacEÝK@+4'`H"Oℎ@J@Mp0tiR¦$?5 r0D 5fsmA җ%]SJhI5E {ijR6L|*'ş4i-AN-(tD3"EE3rKDQfӈ "S iMQ@hBKDkK:#Vc!2XZ ȳ~# )|PԲZ=^Ek9jX̮x%^J ]o+V ="Pњ2Af\  Wlf`W,0Nb l9 kڔՂjs9 dQl,  8r@2B1V6)9 8Y[}  .Z% !5GHKeۉgDg,~Xvx+JIgsm¥ 1U 4|a9)"j/?bN54K"?\I"Yp= %;M~=)[yG߻,[)%tY4'hx枈V-M构 +(4TNY+ Pe*9'.7S;?a.)Fٜ ^2x5/4piT#%vI8/ t5hаQ jqKJ(_.2A|Lѐ^~l j^rK0\ ٭uS沾R}{z/p .ux>L[OϷ{\ 8?NrUJ:X%Oy*.r$_aN!;tk8.6.5/tests/msgbox.test0000644003604700454610000003525712377375532014062 0ustar dgp771div# This file is a Tcl script to test out Tk's "tk_messageBox" command. # It is organized in the standard fashion for Tcl tests. # # Copyright (c) 1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands namespace import -force tcltest::test test msgbox-1.1 {tk_messageBox command} -body { tk_messageBox -foo } -returnCodes error -result {bad option "-foo": must be -default, -detail, -icon, -message, -parent, -title, or -type} test msgbox-1.2 {tk_messageBox command} -body { tk_messageBox -foo bar } -returnCodes error -result {bad option "-foo": must be -default, -detail, -icon, -message, -parent, -title, or -type} test msgbox-1.3 {tk_messageBox command} -body { tk_messageBox -default } -returnCodes error -result {value for "-default" missing} test msgbox-1.4 {tk_messageBox command} -body { tk_messageBox -detail } -returnCodes error -result {value for "-detail" missing} test msgbox-1.5 {tk_messageBox command} -body { tk_messageBox -icon } -returnCodes error -result {value for "-icon" missing} test msgbox-1.6 {tk_messageBox command} -body { tk_messageBox -message } -returnCodes error -result {value for "-message" missing} test msgbox-1.7 {tk_messageBox command} -body { tk_messageBox -parent } -returnCodes error -result {value for "-parent" missing} test msgbox-1.8 {tk_messageBox command} -body { tk_messageBox -title } -returnCodes error -result {value for "-title" missing} test msgbox-1.9 {tk_messageBox command} -body { tk_messageBox -type } -returnCodes error -result {value for "-type" missing} test msgbox-1.10 {tk_messageBox command} -body { tk_messageBox -default } -returnCodes error -result {value for "-default" missing} test msgbox-1.11 {tk_messageBox command} -body { tk_messageBox -type foo } -returnCodes error -result {bad -type value "foo": must be abortretryignore, ok, okcancel, retrycancel, yesno, or yesnocancel} test msgbox-1.12 {tk_messageBox command} -constraints unix -body { tk_messageBox -default 1.1 } -returnCodes error -result {invalid default button "1.1"} test msgbox-1.13 {tk_messageBox command} -constraints macOrWin -body { tk_messageBox -default 1.1 } -returnCodes error -result {bad -default value "1.1": must be abort, retry, ignore, ok, cancel, no, or yes} test msgbox-1.14 {tk_messageBox command} -constraints unix -body { tk_messageBox -default foo } -returnCodes error -result {invalid default button "foo"} test msgbox-1.15 {tk_messageBox command} -constraints macOrWin -body { tk_messageBox -default foo } -returnCodes error -result {bad -default value "foo": must be abort, retry, ignore, ok, cancel, no, or yes} test msgbox-1.16 {tk_messageBox command} -constraints unix -body { tk_messageBox -type yesno -default 3 } -returnCodes error -result {invalid default button "3"} test msgbox-1.17 {tk_messageBox command} -constraints macOrWin -body { tk_messageBox -type yesno -default 3 } -returnCodes error -result {bad -default value "3": must be abort, retry, ignore, ok, cancel, no, or yes} test msgbox-1.18 {tk_messageBox command} -body { tk_messageBox -icon foo } -returnCodes error -result {bad -icon value "foo": must be error, info, question, or warning} test msgbox-1.19 {tk_messageBox command} -body { tk_messageBox -parent foo.bar } -returnCodes error -result {bad window path name "foo.bar"} catch {tk_messageBox -foo bar} set isNative [expr {[info commands tk::MessageBox] == ""}] proc ChooseMsg {parent btn} { global isNative if {!$isNative} { after 100 SendEventToMsg $parent $btn mouse } } proc ChooseMsgByKey {parent btn} { global isNative if {!$isNative} { after 100 SendEventToMsg $parent $btn key } } proc PressButton {btn} { event generate $btn event generate $btn -x 5 -y 5 event generate $btn -x 5 -y 5 } proc SendEventToMsg {parent btn type} { if {$parent != "."} { set w $parent.__tk__messagebox } else { set w .__tk__messagebox } if ![winfo ismapped $w.$btn] { update } if {$type == "mouse"} { PressButton $w.$btn } else { event generate $w focus $w event generate $w.$btn event generate $w -keysym Return } } # # Try out all combinations of (type) x (default button) and # (type) x (icon). # test msgbox-2.1 {tk_messageBox command} -constraints { nonUnixUserInteraction } -body { ChooseMsg . abort tk_messageBox -title Hi -message "Please press abort" -type abortretryignore } -result {abort} test msgbox-2.2 {tk_messageBox command -icon option} -constraints { nonUnixUserInteraction } -body { ChooseMsg . abort tk_messageBox -title Hi -message "Please press abort" \ -type abortretryignore -icon warning } -result {abort} test msgbox-2.3 {tk_messageBox command -icon option} -constraints { nonUnixUserInteraction } -body { ChooseMsg . abort tk_messageBox -title Hi -message "Please press abort" \ -type abortretryignore -icon error } -result {abort} test msgbox-2.4 {tk_messageBox command -icon option} -constraints { nonUnixUserInteraction } -body { ChooseMsg . abort tk_messageBox -title Hi -message "Please press abort" \ -type abortretryignore -icon info } -result {abort} test msgbox-2.5 {tk_messageBox command -icon option} -constraints { nonUnixUserInteraction } -body { ChooseMsg . abort tk_messageBox -title Hi -message "Please press abort" \ -type abortretryignore -icon question } -result {abort} test msgbox-2.6 {tk_messageBox command} -constraints { nonUnixUserInteraction } -body { ChooseMsg . abort tk_messageBox -title Hi -message "Please press abort" \ -type abortretryignore -default abort } -result {abort} test msgbox-2.7 {tk_messageBox command} -constraints { nonUnixUserInteraction } -body { ChooseMsg . retry tk_messageBox -title Hi -message "Please press retry" \ -type abortretryignore -default retry } -result {retry} test msgbox-2.8 {tk_messageBox command} -constraints { nonUnixUserInteraction } -body { ChooseMsg . ignore tk_messageBox -title Hi -message "Please press ignore" \ -type abortretryignore -default ignore } -result {ignore} test msgbox-2.9 {tk_messageBox command} -constraints { nonUnixUserInteraction } -body { ChooseMsg . ok tk_messageBox -title Hi -message "Please press ok" -type ok } -result {ok} test msgbox-2.10 {tk_messageBox command -icon option} -constraints { nonUnixUserInteraction } -body { ChooseMsg . ok tk_messageBox -title Hi -message "Please press ok" \ -type ok -icon warning } -result {ok} test msgbox-2.11 {tk_messageBox command -icon option} -constraints { nonUnixUserInteraction } -body { ChooseMsg . ok tk_messageBox -title Hi -message "Please press ok" \ -type ok -icon error } -result {ok} test msgbox-2.12 {tk_messageBox command -icon option} -constraints { nonUnixUserInteraction } -body { ChooseMsg . ok tk_messageBox -title Hi -message "Please press ok" \ -type ok -icon info } -result {ok} test msgbox-2.13 {tk_messageBox command -icon option} -constraints { nonUnixUserInteraction } -body { ChooseMsg . ok tk_messageBox -title Hi -message "Please press ok" \ -type ok -icon question } -result {ok} test msgbox-2.14 {tk_messageBox command} -constraints { nonUnixUserInteraction } -body { ChooseMsg . ok tk_messageBox -title Hi -message "Please press ok" \ -type ok -default ok } -result {ok} test msgbox-2.15 {tk_messageBox command} -constraints { nonUnixUserInteraction } -body { ChooseMsg . ok tk_messageBox -title Hi -message "Please press ok" -type okcancel } -result {ok} test msgbox-2.16 {tk_messageBox command -icon option} -constraints { nonUnixUserInteraction } -body { ChooseMsg . ok tk_messageBox -title Hi -message "Please press ok" \ -type okcancel -icon warning } -result {ok} test msgbox-2.17 {tk_messageBox command -icon option} -constraints { nonUnixUserInteraction } -body { ChooseMsg . ok tk_messageBox -title Hi -message "Please press ok" \ -type okcancel -icon error } -result {ok} test msgbox-2.18 {tk_messageBox command -icon option} -constraints { nonUnixUserInteraction } -body { ChooseMsg . ok tk_messageBox -title Hi -message "Please press ok" \ -type okcancel -icon info } -result {ok} test msgbox-2.19 {tk_messageBox command -icon option} -constraints { nonUnixUserInteraction } -body { ChooseMsg . ok tk_messageBox -title Hi -message "Please press ok" \ -type okcancel -icon question } -result {ok} test msgbox-2.20 {tk_messageBox command} -constraints { nonUnixUserInteraction } -body { ChooseMsg . ok tk_messageBox -title Hi -message "Please press ok" \ -type okcancel -default ok } -result {ok} test msgbox-2.21 {tk_messageBox command} -constraints { nonUnixUserInteraction } -body { ChooseMsg . cancel tk_messageBox -title Hi -message "Please press cancel" \ -type okcancel -default cancel } -result {cancel} test msgbox-2.22 {tk_messageBox command} -constraints { nonUnixUserInteraction } -body { ChooseMsg . retry tk_messageBox -title Hi -message "Please press retry" -type retrycancel } -result {retry} test msgbox-2.23 {tk_messageBox command -icon option} -constraints { nonUnixUserInteraction } -body { ChooseMsg . retry tk_messageBox -title Hi -message "Please press retry" \ -type retrycancel -icon warning } -result {retry} test msgbox-2.24 {tk_messageBox command -icon option} -constraints { nonUnixUserInteraction } -body { ChooseMsg . retry tk_messageBox -title Hi -message "Please press retry" \ -type retrycancel -icon error } -result {retry} test msgbox-2.25 {tk_messageBox command -icon option} -constraints { nonUnixUserInteraction } -body { ChooseMsg . retry tk_messageBox -title Hi -message "Please press retry" \ -type retrycancel -icon info } -result {retry} test msgbox-2.26 {tk_messageBox command -icon option} -constraints { nonUnixUserInteraction } -body { ChooseMsg . retry tk_messageBox -title Hi -message "Please press retry" \ -type retrycancel -icon question } -result {retry} test msgbox-2.27 {tk_messageBox command} -constraints { nonUnixUserInteraction } -body { ChooseMsg . retry tk_messageBox -title Hi -message "Please press retry" \ -type retrycancel -default retry } -result {retry} test msgbox-2.28 {tk_messageBox command} -constraints { nonUnixUserInteraction } -body { ChooseMsg . cancel tk_messageBox -title Hi -message "Please press cancel" \ -type retrycancel -default cancel } -result {cancel} test msgbox-2.29 {tk_messageBox command} -constraints { nonUnixUserInteraction } -body { ChooseMsg . yes tk_messageBox -title Hi -message "Please press yes" -type yesno } -result {yes} test msgbox-2.30 {tk_messageBox command -icon option} -constraints { nonUnixUserInteraction } -body { ChooseMsg . yes tk_messageBox -title Hi -message "Please press yes" \ -type yesno -icon warning } -result {yes} test msgbox-2.31 {tk_messageBox command -icon option} -constraints { nonUnixUserInteraction } -body { ChooseMsg . yes tk_messageBox -title Hi -message "Please press yes" \ -type yesno -icon error } -result {yes} test msgbox-2.32 {tk_messageBox command -icon option} -constraints { nonUnixUserInteraction } -body { ChooseMsg . yes tk_messageBox -title Hi -message "Please press yes" \ -type yesno -icon info } -result {yes} test msgbox-2.33 {tk_messageBox command -icon option} -constraints { nonUnixUserInteraction } -body { ChooseMsg . yes tk_messageBox -title Hi -message "Please press yes" \ -type yesno -icon question } -result {yes} test msgbox-2.34 {tk_messageBox command} -constraints { nonUnixUserInteraction } -body { ChooseMsg . yes tk_messageBox -title Hi -message "Please press yes" \ -type yesno -default yes } -result {yes} test msgbox-2.35 {tk_messageBox command} -constraints { nonUnixUserInteraction } -body { ChooseMsg . no tk_messageBox -title Hi -message "Please press no" \ -type yesno -default no } -result {no} test msgbox-2.36 {tk_messageBox command} -constraints { nonUnixUserInteraction } -body { ChooseMsg . yes tk_messageBox -title Hi -message "Please press yes" -type yesnocancel } -result {yes} test msgbox-2.37 {tk_messageBox command -icon option} -constraints { nonUnixUserInteraction } -body { ChooseMsg . yes tk_messageBox -title Hi -message "Please press yes" \ -type yesnocancel -icon warning } -result {yes} test msgbox-2.38 {tk_messageBox command -icon option} -constraints { nonUnixUserInteraction } -body { ChooseMsg . yes tk_messageBox -title Hi -message "Please press yes" \ -type yesnocancel -icon error } -result {yes} test msgbox-2.39 {tk_messageBox command -icon option} -constraints { nonUnixUserInteraction } -body { ChooseMsg . yes tk_messageBox -title Hi -message "Please press yes" \ -type yesnocancel -icon info } -result {yes} test msgbox-2.40 {tk_messageBox command -icon option} -constraints { nonUnixUserInteraction } -body { ChooseMsg . yes tk_messageBox -title Hi -message "Please press yes" \ -type yesnocancel -icon question } -result {yes} test msgbox-2.41 {tk_messageBox command} -constraints { nonUnixUserInteraction } -body { ChooseMsg . yes tk_messageBox -title Hi -message "Please press yes" \ -type yesnocancel -default yes } -result {yes} test msgbox-2.42 {tk_messageBox command} -constraints { nonUnixUserInteraction } -body { ChooseMsg . no tk_messageBox -title Hi -message "Please press no" \ -type yesnocancel -default no } -result {no} test msgbox-2.43 {tk_messageBox command} -constraints { nonUnixUserInteraction } -body { ChooseMsg . cancel tk_messageBox -title Hi -message "Please press cancel" \ -type yesnocancel -default cancel } -result {cancel} # These tests will hang your test suite if they fail. test msgbox-3.1 {tk_messageBox handles withdrawn parent} -constraints { nonUnixUserInteraction } -body { wm withdraw . ChooseMsg . "ok" tk_messageBox -title Hi -message "Please press ok" \ -type ok -default ok } -cleanup { wm deiconify . } -result {ok} test msgbox-3.2 {tk_messageBox handles iconified parent} -constraints { nonUnixUserInteraction } -body { wm iconify . ChooseMsg . "ok" tk_messageBox -title Hi -message "Please press ok" \ -type ok -default ok } -cleanup { wm deiconify . } -result {ok} # cleanup cleanupTests return tk8.6.5/tests/event.test0000644003604700454610000005264712620363651013674 0ustar dgp771div# This file is a Tcl script to test the code in tkEvent.c. It is # organized in the standard fashion for Tcl tests. # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994-1995 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands namespace import -force tcltest::test # XXX This test file is woefully incomplete. Right now it only tests # a few of the procedures in tkEvent.c. Please add more tests whenever # possible. # Setup table used to query key events. proc _init_keypress_lookup {} { global keypress_lookup scan A %c start scan Z %c finish for {set i $start} {$i <= $finish} {incr i} { set l [format %c $i] set keypress_lookup($l) $l } scan a %c start scan z %c finish for {set i $start} {$i <= $finish} {incr i} { set l [format %c $i] set keypress_lookup($l) $l } scan 0 %c start scan 9 %c finish for {set i $start} {$i <= $finish} {incr i} { set l [format %c $i] set keypress_lookup($l) $l } # Most punctuation array set keypress_lookup { ! exclam % percent & ampersand ( parenleft ) parenright * asterisk + plus , comma - minus . period / slash : colon < less = equal > greater ? question @ at ^ asciicircum _ underscore | bar ~ asciitilde ' apostrophe } # Characters with meaning to Tcl... array set keypress_lookup [list \ \" quotedbl \ \# numbersign \ \$ dollar \ \; semicolon \ \[ bracketleft \ \\ backslash \ \] bracketright \ \{ braceleft \ \} braceright \ " " space \ "\n" Return \ "\t" Tab] } # Lookup an event in the keypress table. # For example: # Q -> Q # . -> period # / -> slash # Delete -> Delete # Escape -> Escape proc _keypress_lookup {char} { global keypress_lookup if {! [info exists keypress_lookup]} { _init_keypress_lookup } if {$char == ""} { error "empty char" } if {[info exists keypress_lookup($char)]} { return $keypress_lookup($char) } else { return $char } } # Lookup and generate a pair of KeyPress and KeyRelease events proc _keypress {win key} { set keysym [_keypress_lookup $key] # Force focus to the window before delivering # each event so that a window manager using # a focus follows mouse will not steal away # the focus if the mouse is moved around. if {[focus] != $win} { focus -force $win } event generate $win _pause 50 if {[focus] != $win} { focus -force $win } event generate $win _pause 50 } # Call _keypress for each character in the given string proc _keypress_string {win string} { foreach letter [split $string ""] { _keypress $win $letter } } # Delay script execution for a given amount of time proc _pause {{msecs 1000}} { global _pause if {! [info exists _pause(number)]} { set _pause(number) 0 } set num [incr _pause(number)] set _pause($num) 0 after $msecs "set _pause($num) 1" vwait _pause($num) unset _pause($num) } # Helper proc to convert index to x y position proc _text_ind_to_x_y {text ind} { set bbox [$text bbox $ind] if {[llength $bbox] != 4} { error "got bbox \{$bbox\} from $text, index $ind" } foreach {x1 y1 width height} $bbox break set middle_y [expr {$y1 + ($height / 2)}] return [list $x1 $middle_y] } # Return selection only if owned by the given widget proc _get_selection {widget} { if {[string compare $widget [selection own]] != 0} { return "" } if {[catch {selection get} sel]} { return "" } return $sel } # Begining of the actual tests test event-1.1 {Tk_HandleEvent procedure, filter events for dead windows} -setup { deleteWindows set x {} } -body { button .b -text Test pack .b bindtags .b .b update bind .b { lappend x destroy event generate .b <1> event generate .b } bind .b <1> { lappend x button } destroy .b return $x } -cleanup { deleteWindows } -result {destroy} test event-1.2 {event generate } -setup { deleteWindows catch {unset ::event12result} } -body { set ::event12result 0 pack [entry .e] update bind .e {set ::event12result "1"} focus -force .e event generate .e destroy .e set ::event12result } -cleanup { deleteWindows } -result 1 test event-2.1(keypress) {type into entry widget and hit Return} -setup { deleteWindows } -body { set t [toplevel .t] set e [entry $t.e] pack $e set return_binding 0 bind $e {set return_binding 1} tkwait visibility $e _keypress_string $e HELLO\n list [$e get] $return_binding } -cleanup { deleteWindows } -result {HELLO 1} test event-2.2(keypress) {type into entry widget and then delete some text} -setup { deleteWindows } -body { set t [toplevel .t] set e [entry $t.e] pack $e tkwait visibility $e _keypress_string $e MELLO _keypress $e BackSpace _keypress $e BackSpace $e get } -cleanup { deleteWindows } -result {MEL} test event-2.3(keypress) {type into entry widget, triple click, hit Delete key, and then type some more} -setup { deleteWindows } -body { set t [toplevel .t] set e [entry $t.e] pack $e tkwait visibility $e _keypress_string $e JUMP set result [$e get] event generate $e for {set i 0} {$i < 3} {incr i} { _pause 100 event generate $e _pause 100 event generate $e } _keypress $e Delete _keypress_string $e UP lappend result [$e get] } -cleanup { deleteWindows } -result {JUMP UP} test event-2.4(keypress) {type into text widget and hit Return} -setup { deleteWindows } -body { set t [toplevel .t] set e [text $t.e] pack $e set return_binding 0 bind $e {set return_binding 1} tkwait visibility $e _keypress_string $e HELLO\n list [$e get 1.0 end] $return_binding } -cleanup { deleteWindows } -result [list "HELLO\n\n" 1] test event-2.5(keypress) {type into text widget and then delete some text} -setup { deleteWindows } -body { set t [toplevel .t] set e [text $t.e] pack $e tkwait visibility $e _keypress_string $e MELLO _keypress $e BackSpace _keypress $e BackSpace $e get 1.0 1.end } -cleanup { deleteWindows } -result {MEL} test event-2.6(keypress) {type into text widget, triple click, hit Delete key, and then type some more} -setup { deleteWindows } -body { set t [toplevel .t] set e [text $t.e] pack $e tkwait visibility $e _keypress_string $e JUMP set result [$e get 1.0 1.end] event generate $e for {set i 0} {$i < 3} {incr i} { _pause 100 event generate $e _pause 100 event generate $e } _keypress $e Delete _keypress_string $e UP lappend result [$e get 1.0 1.end] } -cleanup { deleteWindows } -result {JUMP UP} test event-3.1(click-drag) {click and drag in a text widget, this tests tkTextSelectTo in text.tcl} -setup { deleteWindows } -body { set t [toplevel .t] set e [text $t.e] pack $e tkwait visibility $e _keypress_string $e "A Tcl/Tk selection test!" set anchor 1.6 set selend 1.18 set result [list] lappend result [$e get 1.0 1.end] # Get the x,y coords of the second T in "Tcl/Tk" foreach {anchor_x anchor_y} [_text_ind_to_x_y $e $anchor] break # Click down to set the insert cursor position event generate $e event generate $e -x $anchor_x -y $anchor_y # Save the position of the insert cursor lappend result [$e index insert] # Now drag until selend is highlighted, then click up set current $anchor while {[$e compare $current <= $selend]} { foreach {current_x current_y} [_text_ind_to_x_y $e $current] break event generate $e -x $current_x -y $current_y set current [$e index [list $current + 1 char]] _pause 50 } event generate $e -x $current_x -y $current_y _pause 200 # Save the position of the insert cursor lappend result [$e index insert] # Save the highlighted text lappend result [_get_selection $e] # Now click and click and drag to the left, over "Tcl/Tk selection" event generate $e -x $current_x -y $current_y while {[$e compare $current >= [list $anchor - 4 char]]} { foreach {current_x current_y} [_text_ind_to_x_y $e $current] break event generate $e -x $current_x -y $current_y set current [$e index [list $current - 1 char]] _pause 50 } event generate $e -x $current_x -y $current_y _pause 200 # Save the position of the insert cursor lappend result [$e index insert] # Save the highlighted text lappend result [_get_selection $e] } -cleanup { deleteWindows } -result {{A Tcl/Tk selection test!} 1.6 1.18 {Tk selection} 1.2 {Tcl/Tk selection}} test event-3.2(click-drag) {click and drag in an entry widget, this tests tkEntryMouseSelect in entry.tcl} -setup { deleteWindows } -body { set t [toplevel .t] set e [entry $t.e] pack $e tkwait visibility $e _keypress_string $e "A Tcl/Tk selection!" set anchor 6 set selend 18 set result [list] lappend result [$e get] # Get the x,y coords of the second T in "Tcl/Tk" foreach {anchor_x anchor_y} [_text_ind_to_x_y $e $anchor] break # Click down to set the insert cursor position event generate $e event generate $e -x $anchor_x -y $anchor_y # Save the position of the insert cursor lappend result [$e index insert] # Now drag until selend is highlighted, then click up set current $anchor while {$current <= $selend} { foreach {current_x current_y} [_text_ind_to_x_y $e $current] break event generate $e -x $current_x -y $current_y incr current _pause 50 } event generate $e -x $current_x -y $current_y _pause 200 # Save the position of the insert cursor lappend result [$e index insert] # Save the highlighted text lappend result [_get_selection $e] # Now click and click and drag to the left, over "Tcl/Tk selection" event generate $e -x $current_x -y $current_y while {$current >= ($anchor - 4)} { foreach {current_x current_y} [_text_ind_to_x_y $e $current] break event generate $e -x $current_x -y $current_y incr current -1 _pause 50 } event generate $e -x $current_x -y $current_y _pause 200 # Save the position of the insert cursor lappend result [$e index insert] # Save the highlighted text lappend result [_get_selection $e] } -cleanup { deleteWindows } -result {{A Tcl/Tk selection!} 6 18 {Tk selection} 2 {Tcl/Tk selection}} test event-4.1(double-click-drag) {click down, click up, click down again, then drag in a text widget} -setup { deleteWindows } -body { set t [toplevel .t] set e [text $t.e] pack $e tkwait visibility $e _keypress_string $e "Word select test" set anchor 1.8 # Get the x,y coords of the second e in "select" foreach {anchor_x anchor_y} [_text_ind_to_x_y $e $anchor] break # Click down, release, then click down again event generate $e event generate $e -x $anchor_x -y $anchor_y _pause 50 event generate $e -x $anchor_x -y $anchor_y _pause 50 event generate $e -x $anchor_x -y $anchor_y _pause 50 # Save the highlighted text set result [list] lappend result [_get_selection $e] # Insert cursor should be at beginning of "select" lappend result [$e index insert] # Move mouse one character to the left set current [$e index [list $anchor - 1 char]] foreach {current_x current_y} [_text_ind_to_x_y $e $current] break event generate $e -x $current_x -y $current_y _pause 50 # Insert cursor should be before the l in "select" lappend result [$e index insert] # Selection should still be the word "select" lappend result [_get_selection $e] # Move mouse to the space before the word "select" set current [$e index [list $current - 3 char]] foreach {current_x current_y} [_text_ind_to_x_y $e $current] break event generate $e -x $current_x -y $current_y _pause 200 lappend result [$e index insert] lappend result [_get_selection $e] # Move mouse to the r in "Word" set current 1.2 foreach {current_x current_y} [_text_ind_to_x_y $e $current] break event generate $e -x $current_x -y $current_y _pause 50 # Selection should now be "Word select" lappend result [_get_selection $e] # Insert cursor should be before the r in "Word" lappend result [$e index insert] return $result } -cleanup { deleteWindows } -result {select 1.5 1.7 select 1.4 { select} {Word select} 1.2} test event-4.2(double-click-drag) {click down, click up, click down again, then drag in an entry widget} -setup { deleteWindows } -body { set t [toplevel .t] set e [entry $t.e] pack $e tkwait visibility $e _keypress_string $e "Word select test" set anchor 8 # Get the x,y coords of the second e in "select" foreach {anchor_x anchor_y} [_text_ind_to_x_y $e $anchor] break # Click down, release, then click down again event generate $e event generate $e -x $anchor_x -y $anchor_y _pause 50 event generate $e -x $anchor_x -y $anchor_y _pause 50 event generate $e -x $anchor_x -y $anchor_y _pause 50 set result [list] lappend result [_get_selection $e] # Insert cursor should be at the end of "select" lappend result [$e index insert] # Move mouse one character to the left set current [expr {$anchor - 1}] foreach {current_x current_y} [_text_ind_to_x_y $e $current] break event generate $e -x $current_x -y $current_y _pause 50 # Insert cursor should be before the l in "select" lappend result [$e index insert] # Selection should still be the word "select" lappend result [_get_selection $e] # Move mouse to the space before the word "select" set current [expr {$current - 3}] foreach {current_x current_y} [_text_ind_to_x_y $e $current] break event generate $e -x $current_x -y $current_y _pause 50 lappend result [$e index insert] lappend result [_get_selection $e] # Move mouse to the r in "Word" set current [expr {$current - 2}] foreach {current_x current_y} [_text_ind_to_x_y $e $current] break event generate $e -x $current_x -y $current_y _pause 50 # Selection should now be "Word select" lappend result [_get_selection $e] # Insert cursor should be before the r in "Word" lappend result [$e index insert] return $result } -cleanup { deleteWindows } -result {select 11 7 select 4 { select} {Word select} 2} test event-5.1(triple-click-drag) {Triple click and drag across lines in a text widget, this should extend the selection to the new line} -setup { deleteWindows } -body { set t [toplevel .t] set e [text $t.e] pack $e tkwait visibility $e _keypress_string $e "LINE ONE\nLINE TWO\nLINE THREE" set anchor 3.2 # Triple click one third line leaving mouse down foreach {anchor_x anchor_y} [_text_ind_to_x_y $e $anchor] break event generate $e event generate $e -x $anchor_x -y $anchor_y _pause 50 event generate $e -x $anchor_x -y $anchor_y _pause 50 event generate $e -x $anchor_x -y $anchor_y _pause 50 event generate $e -x $anchor_x -y $anchor_y _pause 50 event generate $e -x $anchor_x -y $anchor_y _pause 50 set result [list] lappend result [_get_selection $e] # Drag up to second line set current [$e index [list $anchor - 1 line]] foreach {current_x current_y} [_text_ind_to_x_y $e $current] break event generate $e -x $current_x -y $current_y _pause 50 lappend result [_get_selection $e] # Drag up to first line set current [$e index [list $current - 1 line]] foreach {current_x current_y} [_text_ind_to_x_y $e $current] break event generate $e -x $current_x -y $current_y _pause 50 lappend result [_get_selection $e] return $result } -cleanup { deleteWindows } -result [list "LINE THREE\n" "LINE TWO\nLINE THREE\n" \ "LINE ONE\nLINE TWO\nLINE THREE\n"] test event-6.1(button-state) {button press in a window that is then destroyed, when the mouse is moved into another window it should not generate a event since the mouse was not pressed down in that window} -setup { deleteWindows } -body { set t [toplevel .t] event generate $t destroy $t set t [toplevel .t] set motion nomotion bind $t {set motion inmotion} event generate $t return $motion } -cleanup { deleteWindows } -result {nomotion} test event-7.1(double-click) {A double click on a lone character in a text widget should select that character} -setup { deleteWindows } -body { set t [toplevel .t] set e [text $t.e] pack $e tkwait visibility $e focus -force $e _keypress_string $e "On A letter" set anchor 1.3 # Get x,y coords just inside the left # and right hand side of the letter A foreach {x1 y1 width height} [$e bbox $anchor] break set middle_y [expr {$y1 + ($height / 2)}] set left_x [expr {$x1 + 2}] set left_y $middle_y set right_x [expr {($x1 + $width) - 2}] set right_y $middle_y # Double click near left hand egde of the letter A event generate $e event generate $e -x $left_x -y $left_y _pause 50 event generate $e -x $left_x -y $left_y _pause 50 event generate $e -x $left_x -y $left_y _pause 50 event generate $e -x $left_x -y $left_y _pause 50 set result [list] lappend result [$e index insert] lappend result [_get_selection $e] # Clear selection by clicking at 0,0 event generate $e -x 0 -y 0 _pause 50 event generate $e -x 0 -y 0 _pause 50 # Double click near right hand edge of the letter A event generate $e -x $right_x -y $right_y _pause 50 event generate $e -x $right_x -y $right_y _pause 50 event generate $e -x $right_x -y $right_y _pause 50 event generate $e -x $right_x -y $right_y _pause 50 lappend result [$e index insert] lappend result [_get_selection $e] return $result } -cleanup { deleteWindows } -result {1.3 A 1.3 A} test event-7.2(double-click) {A double click on a lone character in an entry widget should select that character} -setup { deleteWindows } -body { set t [toplevel .t] set e [entry $t.e] pack $e tkwait visibility $e focus -force $e _keypress_string $e "On A letter" set anchor 3 # Get x,y coords just inside the left # and right hand side of the letter A foreach {x1 y1 width height} [$e bbox $anchor] break set middle_y [expr {$y1 + ($height / 2)}] set left_x [expr {$x1 + 2}] set left_y $middle_y set right_x [expr {($x1 + $width) - 2}] set right_y $middle_y # Double click near left hand egde of the letter A event generate $e event generate $e -x $left_x -y $left_y _pause 50 event generate $e -x $left_x -y $left_y _pause 50 event generate $e -x $left_x -y $left_y _pause 50 event generate $e -x $left_x -y $left_y _pause 50 set result [list] lappend result [$e index insert] lappend result [_get_selection $e] # Clear selection by clicking at 0,0 event generate $e -x 0 -y 0 _pause 50 event generate $e -x 0 -y 0 _pause 50 # Double click near right hand edge of the letter A event generate $e -x $right_x -y $right_y _pause 50 event generate $e -x $right_x -y $right_y _pause 50 event generate $e -x $right_x -y $right_y _pause 50 event generate $e -x $right_x -y $right_y _pause 50 lappend result [$e index insert] lappend result [_get_selection $e] return $result } -cleanup { deleteWindows } -result {4 A 4 A} # cleanup unset -nocomplain keypress_lookup rename _init_keypress_lookup {} rename _keypress_lookup {} rename _keypress {} rename _pause {} rename _text_ind_to_x_y {} rename _get_selection {} cleanupTests return tk8.6.5/tests/canvImg.test0000644003604700454610000006104612424437552014134 0ustar dgp771div# This file is a Tcl script to test out the procedures in tkCanvImg.c, # which implement canvas "image" items. It is organized in the standard # fashion for Tcl tests. # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. package require tcltest 2.2 namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands imageInit # Canvas used in every test case of the whole file canvas .c pack .c update test canvImg-1.1 {options for image items} -body { .c create image 50 50 -anchor nw -tags i1 .c itemconfigure i1 -anchor } -cleanup { .c delete all } -result {-anchor {} {} center nw} test canvImg-1.2 {options for image items} -body { .c create image 50 50 -anchor gorp -tags i1 } -cleanup { .c delete all } -returnCodes {error} -result {bad anchor position "gorp": must be n, ne, e, se, s, sw, w, nw, or center} test canvImg-1.3 {options for image items} -constraints testImageType -setup { image create test foo .c delete all } -body { .c create image 50 50 -image foo -tags i1 .c itemconfigure i1 -image } -cleanup { .c delete all image delete foo } -result {-image {} {} {} foo} test canvImg-1.4 {options for image items} -body { .c create image 50 50 -image unknown -tags i1 } -cleanup { .c delete all } -returnCodes {error} -result {image "unknown" doesn't exist} test canvImg-1.5 {options for image items} -constraints testImageType -setup { image create test foo .c delete all } -body { .c create image 50 50 -image foo -tags {i1 foo} .c itemconfigure i1 -tags } -cleanup { .c delete all image delete foo } -result {-tags {} {} {} {i1 foo}} test canvImg-2.1 {CreateImage procedure} -body { .c create image 40 } -cleanup { .c delete all } -returnCodes {error} -result {wrong # coordinates: expected 2, got 1} test canvImg-2.2 {CreateImage procedure} -body { .c create image 40 50 60 } -cleanup { .c delete all } -returnCodes {error} -result {unknown option "60"} test canvImg-2.3 {CreateImage procedure} -body { .c delete all set i [.c create image 50 50] list [lindex [.c itemconf $i -anchor] 4] \ [lindex [.c itemconf $i -image] 4] \ [lindex [.c itemconf $i -tags] 4] } -cleanup { .c delete all } -result {center {} {}} test canvImg-2.4 {CreateImage procedure} -body { .c create image xyz 40 } -cleanup { .c delete all } -returnCodes {error} -result {bad screen distance "xyz"} test canvImg-2.5 {CreateImage procedure} -body { .c create image 50 qrs } -cleanup { .c delete all } -returnCodes {error} -result {bad screen distance "qrs"} test canvImg-2.6 {CreateImage procedure} -constraints testImageType -body { .c create image 50 50 -gorp foo } -cleanup { .c delete all } -returnCodes {error} -result {unknown option "-gorp"} test canvImg-3.1 {ImageCoords procedure} -constraints testImageType -setup { image create test foo } -body { .c create image 50 100 -image foo -tags i1 format {%.6g %.6g} {*}[.c coords i1] } -cleanup { .c delete all image delete foo } -result {50 100} test canvImg-3.2 {ImageCoords procedure} -constraints testImageType -setup { image create test foo } -body { .c create image 50 100 -image foo -tags i1 .c coords i1 dumb 100 } -cleanup { .c delete all image delete foo } -returnCodes {error} -result {bad screen distance "dumb"} test canvImg-3.3 {ImageCoords procedure} -constraints testImageType -setup { image create test foo } -body { .c delete all .c create image 50 100 -image foo -tags i1 .c coords i1 250 dumb0 } -cleanup { .c delete all image delete foo } -returnCodes {error} -result {bad screen distance "dumb0"} test canvImg-3.4 {ImageCoords procedure} -constraints testImageType -setup { image create test foo } -body { .c delete all .c create image 50 100 -image foo -tags i1 .c coords i1 250 } -cleanup { .c delete all image delete foo } -returnCodes {error} -result {wrong # coordinates: expected 2, got 1} test canvImg-3.5 {ImageCoords procedure} -constraints testImageType -setup { image create test foo } -body { .c delete all .c create image 50 100 -image foo -tags i1 .c coords i1 250 300 400 } -cleanup { .c delete all image delete foo } -returnCodes {error} -result {wrong # coordinates: expected 0 or 2, got 3} test canvImg-4.1 {ConfiugreImage procedure} -constraints testImageType -setup { .c delete all } -body { image create test foo -variable x .c create image 50 100 -image foo -tags i1 update set x {} .c itemconfigure i1 -image {} update list $x [.c bbox i1] } -cleanup { .c delete all image delete foo } -result {{{foo free}} {}} test canvImg-4.2 {ConfiugreImage procedure} -constraints testImageType -setup { .c delete all } -body { 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 {} .c itemconfigure i1 -image foo2 update list $x $y [.c bbox i1] } -cleanup { .c delete all image delete foo image delete foo2 } -result {{{foo free}} {{foo2 get} {foo2 display 0 0 80 60 30 30}} {50 100 130 160}} test canvImg-4.3 {ConfiugreImage procedure} -constraints testImageType -setup { .c delete all } -body { 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 {} .c itemconfigure i1 -image lousy } -cleanup { .c delete all image delete foo foo2 } -returnCodes {error} -result {image "lousy" doesn't exist} test canvImg-5.1 {DeleteImage procedure} -constraints testImageType -setup { .c delete all imageCleanup } -body { image create test foo -variable x image create test foo2 -variable y image create test xyzzy -variable z .c create image 50 100 -image xyzzy -tags i1 update set names [lsort [imageNames]] image delete xyzzy set z {} set names2 [lsort [imageNames]] .c delete i1 update list $names $names2 $z [lsort [imageNames]] } -cleanup { imageCleanup .c delete all } -result {{foo foo2 xyzzy} {foo foo2} {} {foo foo2}} test canvImg-5.2 {DeleteImage procedure (don't delete non-existent image)} -body { .c delete all .c create image 50 100 -tags i1 update .c delete i1 update } -result {} test canvImg-6.1 {ComputeImageBbox procedure} -constraints testImageType -setup { image create test foo .c delete all } -body { .c create image 15.51 17.51 -image foo -tags i1 -anchor nw .c bbox i1 } -cleanup { .c delete all imageCleanup } -result {16 18 46 33} test canvImg-6.2 {ComputeImageBbox procedure} -constraints testImageType -setup { image create test foo .c delete all } -body { .c create image 15.49 17.49 -image foo -tags i1 -anchor nw .c bbox i1 } -cleanup { .c delete all imageCleanup } -result {15 17 45 32} test canvImg-6.3 {ComputeImageBbox procedure} -setup { .c delete all } -body { .c create image 20 30 -tags i1 -anchor nw .c bbox i1 } -cleanup { .c delete all } -result {} test canvImg-6.4 {ComputeImageBbox procedure} -constraints testImageType -setup { image create test foo .c delete all } -body { .c delete all .c create image 20 30 -image foo -tags i1 -anchor nw .c bbox i1 } -cleanup { .c delete all imageCleanup } -result {20 30 50 45} test canvImg-6.5 {ComputeImageBbox procedure} -constraints testImageType -setup { image create test foo .c delete all } -body { .c delete all .c create image 20 30 -image foo -tags i1 -anchor n .c bbox i1 } -cleanup { .c delete all imageCleanup } -result {5 30 35 45} test canvImg-6.6 {ComputeImageBbox procedure} -constraints testImageType -setup { image create test foo .c delete all } -body { .c delete all .c create image 20 30 -image foo -tags i1 -anchor ne .c bbox i1 } -cleanup { .c delete all imageCleanup } -result {-10 30 20 45} test canvImg-6.7 {ComputeImageBbox procedure} -constraints testImageType -setup { image create test foo .c delete all } -body { .c delete all .c create image 20 30 -image foo -tags i1 -anchor e .c bbox i1 } -cleanup { .c delete all imageCleanup } -result {-10 23 20 38} test canvImg-6.8 {ComputeImageBbox procedure} -constraints testImageType -setup { image create test foo .c delete all } -body { .c delete all .c create image 20 30 -image foo -tags i1 -anchor se .c bbox i1 } -cleanup { .c delete all imageCleanup } -result {-10 15 20 30} test canvImg-6.9 {ComputeImageBbox procedure} -constraints testImageType -setup { image create test foo .c delete all } -body { .c delete all .c create image 20 30 -image foo -tags i1 -anchor s .c bbox i1 } -cleanup { .c delete all imageCleanup } -result {5 15 35 30} test canvImg-6.10 {ComputeImageBbox procedure} -constraints { testImageType } -setup { image create test foo .c delete all } -body { .c delete all .c create image 20 30 -image foo -tags i1 -anchor sw .c bbox i1 } -cleanup { .c delete all image delete foo } -result {20 15 50 30} test canvImg-6.11 {ComputeImageBbox procedure} -constraints { testImageType } -setup { image create test foo .c delete all } -body { .c delete all .c create image 20 30 -image foo -tags i1 -anchor w .c bbox i1 } -cleanup { .c delete all image delete foo } -result {20 23 50 38} test canvImg-6.12 {ComputeImageBbox procedure} -constraints { testImageType } -setup { image create test foo .c delete all } -body { .c delete all .c create image 20 30 -image foo -tags i1 -anchor center .c bbox i1 } -cleanup { .c delete all image delete foo } -result {5 23 35 38} # The following test is non-portable because of differences in # coordinate rounding on some machines (does 0.5 round up?). test canvImg-7.1 {DisplayImage procedure} -constraints { nonPortable testImageType } -setup { .c delete all } -body { image create test foo -variable x .c create image 50 100 -image foo -tags i1 -anchor nw update set x {} .c create rect 55 110 65 115 -width 1 -outline black -fill white update set x } -result {{foo display 4 9 12 6 30 30}} test canvImg-7.2 {DisplayImage procedure, no image} -body { .c delete all .c create image 50 100 -tags i1 update .c create rect 55 110 65 115 -width 1 -outline black -fill white update } -result {} # image used in 8.* test cases if {[testConstraint testImageType]} { image create test foo } test canvImg-8.1 {ImageToArea procedure} -constraints testImageType -setup { .c create image 50 100 -image foo -tags image -anchor nw .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {} } -body { .c coords rect 50 70 80 81 .c gettags [.c find closest 70 90] } -cleanup { .c delete all } -result {rect} test canvImg-8.2 {ImageToArea procedure} -constraints testImageType -setup { .c create image 50 100 -image foo -tags image -anchor nw .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {} } -body { .c coords rect {*}{50 70 80 79} .c gettags [.c find closest {*}{70 90}] } -cleanup { .c delete all } -result {image} test canvImg-8.3 {ImageToArea procedure} -constraints testImageType -setup { .c create image 50 100 -image foo -tags image -anchor nw .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {} } -body { .c coords rect {*}{99 70 110 81} .c gettags [.c find closest {*}{90 90}] } -cleanup { .c delete all } -result {rect} test canvImg-8.4 {ImageToArea procedure} -constraints testImageType -setup { .c create image 50 100 -image foo -tags image -anchor nw .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {} } -body { .c coords rect {*}{101 70 110 79} .c gettags [.c find closest {*}{90 90}] } -cleanup { .c delete all } -result {image} test canvImg-8.5 {ImageToArea procedure} -constraints testImageType -setup { .c create image 50 100 -image foo -tags image -anchor nw .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {} } -body { .c coords rect {*}{99 100 110 115} .c gettags [.c find closest {*}{90 110}] } -cleanup { .c delete all } -result {rect} test canvImg-8.6 {ImageToArea procedure} -constraints testImageType -setup { .c create image 50 100 -image foo -tags image -anchor nw .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {} } -body { .c coords rect {*}{101 100 110 115} .c gettags [.c find closest {*}{90 110}] } -cleanup { .c delete all } -result {image} test canvImg-8.7 {ImageToArea procedure} -constraints testImageType -setup { .c create image 50 100 -image foo -tags image -anchor nw .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {} } -body { .c coords rect {*}{99 134 110 145} .c gettags [.c find closest {*}{90 125}] } -cleanup { .c delete all } -result {rect} test canvImg-8.8 {ImageToArea procedure} -constraints testImageType -setup { .c create image 50 100 -image foo -tags image -anchor nw .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {} } -body { .c coords rect {*}{101 136 110 145} .c gettags [.c find closest {*}{90 125}] } -cleanup { .c delete all } -result {image} test canvImg-8.9 {ImageToArea procedure} -constraints testImageType -setup { .c create image 50 100 -image foo -tags image -anchor nw .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {} } -body { .c coords rect {*}{50 134 80 145} .c gettags [.c find closest {*}{70 125}] } -cleanup { .c delete all } -result {rect} test canvImg-8.10 {ImageToArea procedure} -constraints testImageType -setup { .c create image 50 100 -image foo -tags image -anchor nw .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {} } -body { .c coords rect {*}{50 136 80 145} .c gettags [.c find closest {*}{70 125}] } -cleanup { .c delete all } -result {image} test canvImg-8.11 {ImageToArea procedure} -constraints testImageType -setup { .c create image 50 100 -image foo -tags image -anchor nw .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {} } -body { .c coords rect {*}{20 134 31 145} .c gettags [.c find closest {*}{40 125}] } -cleanup { .c delete all } -result {rect} test canvImg-8.12 {ImageToArea procedure} -constraints testImageType -setup { .c create image 50 100 -image foo -tags image -anchor nw .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {} } -body { .c coords rect {*}{20 136 29 145} .c gettags [.c find closest {*}{40 125}] } -cleanup { .c delete all } -result {image} test canvImg-8.13 {ImageToArea procedure} -constraints testImageType -setup { .c create image 50 100 -image foo -tags image -anchor nw .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {} } -body { .c coords rect {*}{20 100 31 115} .c gettags [.c find closest {*}{40 110}] } -cleanup { .c delete all } -result {rect} test canvImg-8.14 {ImageToArea procedure} -constraints testImageType -setup { .c create image 50 100 -image foo -tags image -anchor nw .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {} } -body { .c coords rect {*}{20 100 29 115} .c gettags [.c find closest {*}{40 110}] } -cleanup { .c delete all } -result {image} test canvImg-8.15 {ImageToArea procedure} -constraints testImageType -setup { .c create image 50 100 -image foo -tags image -anchor nw .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {} } -body { .c coords rect {*}{20 70 31 80} .c gettags [.c find closest {*}{40 90}] } -cleanup { .c delete all } -result {rect} test canvImg-8.16 {ImageToArea procedure} -constraints testImageType -setup { .c create image 50 100 -image foo -tags image -anchor nw .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {} } -body { .c coords rect {*}{20 70 29 79} .c gettags [.c find closest {*}{40 90}] } -cleanup { .c delete all } -result {image} test canvImg-8.17 {ImageToArea procedure} -constraints testImageType -setup { .c create image 50 100 -image foo -tags image -anchor nw .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {} } -body { .c coords rect {*}{60 70 69 109} .c gettags [.c find closest {*}{70 110}] } -cleanup { .c delete all } -result {image} test canvImg-8.18 {ImageToArea procedure} -constraints testImageType -setup { .c create image 50 100 -image foo -tags image -anchor nw .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {} } -body { .c coords rect {*}{60 70 71 111} .c gettags [.c find closest {*}{70 110}] } -cleanup { .c delete all } -result {rect} .c delete all test canvImg-8.19 {ImageToArea procedure} -constraints testImageType -body { .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find overlapping 60 0 70 99] } -cleanup { .c delete all } -result {} test canvImg-8.20 {ImageToArea procedure} -constraints testImageType -body { .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find overlapping 60 0 70 99.999] } -cleanup { .c delete all } -result {} test canvImg-8.21 {ImageToArea procedure} -constraints testImageType -body { .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find overlapping 60 0 70 101] } -cleanup { .c delete all } -result {image} test canvImg-8.22 {ImageToArea procedure} -constraints testImageType -body { .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find overlapping 81 105 120 115] } -cleanup { .c delete all } -result {} test canvImg-8.23 {ImageToArea procedure} -constraints testImageType -body { .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find overlapping 80.001 105 120 115] } -cleanup { .c delete all } -result {} test canvImg-8.24 {ImageToArea procedure} -constraints testImageType -body { .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find overlapping 79 105 120 115] } -cleanup { .c delete all } -result {image} test canvImg-8.25 {ImageToArea procedure} -constraints testImageType -body { .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find overlapping 60 116 70 150] } -cleanup { .c delete all } -result {} test canvImg-8.26 {ImageToArea procedure} -constraints testImageType -body { .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find overlapping 60 115.001 70 150] } -cleanup { .c delete all } -result {} test canvImg-8.27 {ImageToArea procedure} -constraints testImageType -body { .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find overlapping 60 114 70 150] } -cleanup { .c delete all } -result {image} test canvImg-8.28 {ImageToArea procedure} -constraints testImageType -body { .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find overlapping 0 105 49 115] } -cleanup { .c delete all } -result {} test canvImg-8.29 {ImageToArea procedure} -constraints testImageType -body { .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find overlapping 0 105 50 114.999] } -cleanup { .c delete all } -result {} test canvImg-8.30 {ImageToArea procedure} -constraints testImageType -body { .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find overlapping 0 105 51 115] } -cleanup { .c delete all } -result {image} test canvImg-8.31 {ImageToArea procedure} -constraints testImageType -body { .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find overlapping 0 0 49.999 99.999] } -cleanup { .c delete all } -result {} test canvImg-8.32 {ImageToArea procedure} -constraints testImageType -body { .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find overlapping 0 0 51 101] } -cleanup { .c delete all } -result {image} test canvImg-8.33 {ImageToArea procedure} -constraints testImageType -body { .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find overlapping 80 0 150 100] } -cleanup { .c delete all } -result {} test canvImg-8.34 {ImageToArea procedure} -constraints testImageType -body { .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find overlapping 79 0 150 101] } -cleanup { .c delete all } -result {image} test canvImg-8.35 {ImageToArea procedure} -constraints testImageType -body { .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find overlapping 80.001 115.001 150 180] } -cleanup { .c delete all } -result {} test canvImg-8.36 {ImageToArea procedure} -constraints testImageType -body { .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find overlapping 79 114 150 180] } -cleanup { .c delete all } -result {image} test canvImg-8.37 {ImageToArea procedure} -constraints testImageType -body { .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find overlapping 0 115 50 180] } -cleanup { .c delete all } -result {} test canvImg-8.38 {ImageToArea procedure} -constraints testImageType -body { .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find overlapping 0 114 51 180] } -cleanup { .c delete all } -result {image} test canvImg-8.39 {ImageToArea procedure} -constraints testImageType -body { .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find enclosed 0 0 200 200] } -cleanup { .c delete all } -result {image} test canvImg-8.40 {ImageToArea procedure} -constraints testImageType -body { .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find enclosed 49.999 99.999 80.001 115.001] } -cleanup { .c delete all } -result {image} test canvImg-8.41 {ImageToArea procedure} -constraints testImageType -body { .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find enclosed 51 100 80 115] } -cleanup { .c delete all } -result {} test canvImg-8.42 {ImageToArea procedure} -constraints testImageType -body { .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find enclosed 50 101 80 115] } -cleanup { .c delete all } -result {} test canvImg-8.43 {ImageToArea procedure} -constraints testImageType -body { .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find enclosed 50 100 79 115] } -cleanup { .c delete all } -result {} test canvImg-8.44 {ImageToArea procedure} -constraints testImageType -body { .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find enclosed 50 100 80 114] } -cleanup { .c delete all } -result {} if {[testConstraint testImageType]} { image delete foo } test canvImg-9.1 {DisplayImage procedure} -constraints testImageType -setup { .c delete all image create test foo } -body { .c create image 50 100 -image foo -tags image -anchor nw .c scale image 25 0 2.0 1.5 .c bbox image } -cleanup { .c delete all image delete foo } -result {75 150 105 165} test canvImg-10.1 {TranslateImage procedure} -constraints testImageType -setup { .c delete all } -body { image create test foo -variable x .c create image 50 100 -image foo -tags image -anchor nw update set x {} foo changed 2 4 6 8 30 15 update return $x } -cleanup { .c delete all image delete foo } -result {{foo display 2 4 6 8 30 30}} test canvImg-11.1 {TranslateImage procedure} -constraints testImageType -setup { .c delete all } -body { image create test foo -variable x .c create image 50 100 -image foo -tags image -anchor nw update set x {} foo changed 2 4 6 8 40 50 update return $x } -cleanup { .c delete all image delete foo } -result {{foo display 0 0 40 50 30 30}} test canvImg-11.2 {ImageChangedProc procedure} -constraints { testImageType } -setup { .c delete all } -body { image create test foo -variable x .c create image 50 100 -image foo -tags image -anchor center update set x {} foo changed 0 0 0 0 40 50 .c bbox image } -cleanup { .c delete all image delete foo } -result {30 75 70 125} test canvImg-11.3 {ImageChangedProc procedure} -constraints { testImageType } -setup { .c delete all } -body { image create test foo -variable x image create test foo2 -variable y foo changed 0 0 0 0 40 50 foo2 changed 0 0 0 0 80 60 .c create image 50 100 -image foo -tags image -anchor nw .c create image 70 110 -image foo2 -anchor nw update set y {} image create test foo -variable x update return $y } -cleanup { .c delete all image delete foo foo2 } -result {{foo2 display 0 0 20 40 50 40}} # cleanup imageFinish cleanupTests return # Local variables: # mode: tcl # End: tk8.6.5/tests/get.test0000644003604700454610000000565512424437553013334 0ustar dgp771div# This file is a Tcl script to test out the procedures in the file # tkGet.c. It is organized in the standard fashion for Tcl # white-box tests. # # Copyright (c) 1998 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands namespace import -force tcltest::test test get-1.1 {Tk_GetAnchorFromObj} -setup { button .b } -body { .b configure -anchor n .b cget -anchor } -cleanup { destroy .b } -result {n} test get-1.2 {Tk_GetAnchorFromObj} -setup { button .b } -body { .b configure -anchor ne .b cget -anchor } -cleanup { destroy .b } -result {ne} test get-1.3 {Tk_GetAnchorFromObj} -setup { button .b } -body { .b configure -anchor e .b cget -anchor } -cleanup { destroy .b } -result {e} test get-1.4 {Tk_GetAnchorFromObj} -setup { button .b } -body { .b configure -anchor se .b cget -anchor } -cleanup { destroy .b } -result {se} test get-1.5 {Tk_GetAnchorFromObj} -setup { button .b } -body { .b configure -anchor s .b cget -anchor } -cleanup { destroy .b } -result {s} test get-1.6 {Tk_GetAnchorFromObj} -setup { button .b } -body { .b configure -anchor sw .b cget -anchor } -cleanup { destroy .b } -result {sw} test get-1.7 {Tk_GetAnchorFromObj} -setup { button .b } -body { .b configure -anchor w .b cget -anchor } -cleanup { destroy .b } -result {w} test get-1.8 {Tk_GetAnchorFromObj} -setup { button .b } -body { .b configure -anchor nw .b cget -anchor } -cleanup { destroy .b } -result {nw} test get-1.9 {Tk_GetAnchorFromObj} -setup { button .b } -body { .b configure -anchor n .b cget -anchor } -cleanup { destroy .b } -result {n} test get-1.10 {Tk_GetAnchorFromObj} -setup { button .b } -body { .b configure -anchor center .b cget -anchor } -cleanup { destroy .b } -result {center} test get-1.11 {Tk_GetAnchorFromObj - error} -setup { button .b } -body { .b configure -anchor unknown } -cleanup { destroy .b } -returnCodes {error} -result {bad anchor "unknown": must be n, ne, e, se, s, sw, w, nw, or center} test get-2.1 {Tk_GetJustifyFromObj} -setup { button .b } -body { .b configure -justify left .b cget -justify } -cleanup { destroy .b } -result {left} test get-2.2 {Tk_GetJustifyFromObj} -setup { button .b } -body { .b configure -justify right .b cget -justify } -cleanup { destroy .b } -result {right} test get-2.3 {Tk_GetJustifyFromObj} -setup { button .b } -body { .b configure -justify center .b cget -justify } -cleanup { destroy .b } -result {center} test get-2.4 {Tk_GetJustifyFromObj - error} -setup { button .b } -body { .b configure -justify stupid } -cleanup { destroy .b } -returnCodes {error} -result {bad justification "stupid": must be left, right, or center} # cleanup cleanupTests return tk8.6.5/tests/unixFont.test0000644003604700454610000002515012077535536014363 0ustar dgp771div# 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 # programmatically (such as "does an underlined font appear to be # 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. # # Copyright (c) 1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. package require tcltest 2.1 eval tcltest::configure $argv tcltest::loadTestedCommands if {[tk windowingsystem] eq "x11"} { set xlsf [auto_execok xlsfonts] } foreach {constraint font} { hasArial arial hasCourierNew "courier new" hasTimesNew "times new roman" } { if {[tk windowingsystem] eq "x11"} { testConstraint $constraint 1 if {[llength $xlsf]} { if {![catch {eval exec $xlsf [list *-$font-*]} res] && ![string match *unmatched* $res]} { # Newer Unix systems have more default fonts installed, # so we can't rely on fallbacks for fonts to need to # fall back on anything. testConstraint $constraint 0 } } } else { testConstraint $constraint 0 } } catch {destroy .b} toplevel .b wm geom .b +0+0 update idletasks # Font should be fixed width and have chars missing below char 32, so can # test control char expansion and missing character code. set courier {Courier -10} set cx [font measure $courier 0] label .b.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left -text "0" -font fixed pack .b.l canvas .b.c -closeenough 0 set t [.b.c create text 0 0 -anchor nw -just left -font $courier] pack .b.c update set ax [winfo reqwidth .b.l] set ay [winfo reqheight .b.l] proc getsize {} { update return "[winfo reqwidth .b.l] [winfo reqheight .b.l]" } test unixfont-1.1 {TkpGetNativeFont procedure: not native} {unix noExceed} { list [catch {font measure {} xyz} msg] $msg } {1 {font "" doesn't exist}} test unixfont-1.2 {TkpGetNativeFont procedure: native} unix { font measure fixed 0 } {6} test unixfont-2.1 {TkpGetFontFromAttributes procedure: no family} unix { font actual {-size 10} set x {} } {} test unixfont-2.2 {TkpGetFontFromAttributes procedure: Times relatives} \ {unix noExceed hasTimesNew} { set x {} lappend x [lindex [font actual {-family "Times New Roman"}] 1] lappend x [lindex [font actual {-family "New York"}] 1] lappend x [lindex [font actual {-family "Times"}] 1] } {times times times} test unixfont-2.3 {TkpGetFontFromAttributes procedure: Courier relatives} \ {unix noExceed hasCourierNew} { set x {} lappend x [lindex [font actual {-family "Courier New"}] 1] lappend x [lindex [font actual {-family "Monaco"}] 1] lappend x [lindex [font actual {-family "Courier"}] 1] } {courier courier courier} test unixfont-2.4 {TkpGetFontFromAttributes procedure: Helvetica relatives} \ {unix noExceed hasArial} { set x {} lappend x [lindex [font actual {-family "Arial"}] 1] lappend x [lindex [font actual {-family "Geneva"}] 1] lappend x [lindex [font actual {-family "Helvetica"}] 1] } {helvetica helvetica helvetica} test unixfont-2.5 {TkpGetFontFromAttributes procedure: fallback} unix { font actual {-xyz-xyz-*-*-*-*-*-*-*-*-*-*-*-*} set x {} } {} test unixfont-2.6 {TkpGetFontFromAttributes: fallback to fixed family} unix { lindex [font actual {-family fixed -size 10}] 1 } {fixed} test unixfont-2.7 {TkpGetFontFromAttributes: fixed family not available!} unix { # no test available } {} test unixfont-2.8 {TkpGetFontFromAttributes: loop over returned font names} unix { lindex [font actual {-family fixed -size 31}] 1 } {fixed} test unixfont-2.9 {TkpGetFontFromAttributes: reject adobe courier if possible} {unix noExceed} { lindex [font actual {-family courier}] 1 } {courier} test unixfont-2.10 {TkpGetFontFromAttributes: scalable font found} unix { lindex [font actual {-family courier -size 37}] 3 } {37} test unixfont-2.11 {TkpGetFontFromAttributes: font cannot be loaded} unix { # On Linux, XListFonts() was returning names for fonts that do not # actually exist, causing the subsequent XLoadQueryFont() to fail # unexpectedly. Now falls back to another font if that happens. font actual {-size 14} set x {} } {} test unixfont-3.1 {TkpDeleteFont procedure} unix { font actual {-family xyz} set x {} } {} test unixfont-4.1 {TkpGetFontFamilies procedure} unix { font families set x {} } {} test unixfont-5.1 {Tk_MeasureChars procedure: no chars to be measured} unix { .b.l config -text "000000" -wrap [expr $ax*3] .b.l config -wrap 0 } {} test unixfont-5.2 {Tk_MeasureChars procedure: no right margin} unix { .b.l config -text "000000" } {} test unixfont-5.3 {Tk_MeasureChars procedure: loop over chars} unix { .b.l config -text "0" .b.l config -text "\377" .b.l config -text "0\3770\377" .b.l config -text "000000000000000" } {} .b.l config -wrap [expr $ax*10] test unixfont-5.4 {Tk_MeasureChars procedure: reached right edge} unix { .b.l config -text "0000000000000" getsize } "[expr $ax*10] [expr $ay*2]" test unixfont-5.5 {Tk_MeasureChars procedure: ran out of chars} unix { .b.l config -text "000000" getsize } "[expr $ax*6] $ay" test unixfont-5.6 {Tk_MeasureChars procedure: find last word} unix { .b.l config -text "000000 00000" getsize } "[expr $ax*6] [expr $ay*2]" test unixfont-5.7 {Tk_MeasureChars procedure: already saw space in line} unix { .b.l config -text "000000 00000" getsize } "[expr $ax*6] [expr $ay*2]" test unixfont-5.8 {Tk_MeasureChars procedure: internal spaces significant} unix { .b.l config -text "00 000 00000" getsize } "[expr $ax*7] [expr $ay*2]" test unixfont-5.9 {Tk_MeasureChars procedure: TK_PARTIAL_OK} unix { .b.c dchars $t 0 end .b.c insert $t 0 "0000" .b.c index $t @[expr int($ax*2.5)],1 } {2} test unixfont-5.10 {Tk_MeasureChars procedure: TK_AT_LEAST_ONE} unix { .b.l config -text "000000000000" getsize } "[expr $ax*10] [expr $ay*2]" test unixfont-5.11 {Tk_MeasureChars: TK_AT_LEAST_ONE + not even one char fit!} unix { set a [.b.l cget -wrap] .b.l config -text "000000" -wrap 1 set x [getsize] .b.l config -wrap $a set x } "$ax [expr $ay*6]" test unixfont-5.12 {Tk_MeasureChars procedure: include eol spaces} unix { .b.l config -text "000 \n000" getsize } "[expr $ax*6] [expr $ay*2]" test unixfont-6.1 {Tk_DrawChars procedure: loop test} unix { .b.l config -text "a" update } {} test unixfont-6.2 {Tk_DrawChars procedure: loop test} unix { .b.l config -text "abcd" update } {} test unixfont-6.3 {Tk_DrawChars procedure: special char} unix { .b.l config -text "\001" update } {} test unixfont-6.4 {Tk_DrawChars procedure: normal then special} unix { .b.l config -text "ab\001" update } {} test unixfont-6.5 {Tk_DrawChars procedure: ends with special} unix { .b.l config -text "ab\001" update } {} test unixfont-6.6 {Tk_DrawChars procedure: more normal chars at end} unix { .b.l config -text "ab\001def" update } {} test unixfont-7.1 {DrawChars procedure: no effects} unix { .b.l config -text "abc" update } {} test unixfont-7.2 {DrawChars procedure: underlining} unix { set f [.b.l cget -font] .b.l config -text "abc" -font "courier 10 underline" update .b.l config -font $f } {} test unixfont-7.3 {DrawChars procedure: overstrike} unix { set f [.b.l cget -font] .b.l config -text "abc" -font "courier 10 overstrike" update .b.l config -font $f } {} test unixfont-8.1 {AllocFont procedure: use old font} unix { font create xyz button .c -font xyz font configure xyz -family times update destroy .c font delete xyz } {} test unixfont-8.2 {AllocFont procedure: parse information from XLFD} unix { expr {[lindex [font actual {-family times -size 0}] 3] == 0} } {0} test unixfont-8.3 {AllocFont procedure: can't parse info from name} unix { catch {unset fontArray} # check that font actual returns the correct attributes. # the values of those attributes are system dependent. array set fontArray [font actual a12biluc] set result [lsort [array names fontArray]] catch {unset fontArray} set result } {-family -overstrike -size -slant -underline -weight} test unixfont-8.4 {AllocFont procedure: classify characters} unix { set x 0 incr x [font measure $courier "\u4000"] ;# 6 incr x [font measure $courier "\002"] ;# 4 incr x [font measure $courier "\012"] ;# 2 incr x [font measure $courier "\101"] ;# 1 set x } [expr $cx*13] test unixfont-8.5 {AllocFont procedure: setup widths of normal chars} unix { font metrics $courier -fixed } {1} test unixfont-8.6 {AllocFont procedure: setup widths of special chars} unix { set x 0 incr x [font measure $courier "\001"] ;# 4 incr x [font measure $courier "\002"] ;# 4 incr x [font measure $courier "\012"] ;# 2 set x } [expr $cx*10] test unixfont-8.7 {AllocFont procedure: XA_UNDERLINE_POSITION} unix { catch {font actual -adobe-courier-bold-i-normal--0-0-0-0-m-0-iso8859-1} set x {} } {} test unixfont-8.8 {AllocFont procedure: no XA_UNDERLINE_POSITION} unix { catch {font actual --symbol-medium-r-normal--0-0-0-0-p-0-sun-fontspecific} set x {} } {} test unixfont-8.9 {AllocFont procedure: XA_UNDERLINE_THICKNESS} unix { catch {font actual -adobe-courier-bold-i-normal--0-0-0-0-m-0-iso8859-1} set x {} } {} test unixfont-8.10 {AllocFont procedure: no XA_UNDERLINE_THICKNESS} unix { catch {font actual --symbol-medium-r-normal--0-0-0-0-p-0-sun-fontspecific} set x {} } {} test unixfont-8.11 {AllocFont procedure: XA_UNDERLINE_POSITION was 0} unix { catch {font actual -adobe-courier-bold-i-normal--0-0-0-0-m-0-iso8859-1} set x {} } {} test unixfont-9.1 {GetControlCharSubst procedure: 2 chars subst} unix { .b.c dchars $t 0 end .b.c insert $t 0 "0\a0" set x {} lappend x [.b.c index $t @[expr $ax*0],0] lappend x [.b.c index $t @[expr $ax*1],0] lappend x [.b.c index $t @[expr $ax*2],0] lappend x [.b.c index $t @[expr $ax*3],0] } {0 1 1 2} test unixfont-9.2 {GetControlCharSubst procedure: 4 chars subst} unix { .b.c dchars $t 0 end .b.c insert $t 0 "0\0010" set x {} lappend x [.b.c index $t @[expr $ax*0],0] lappend x [.b.c index $t @[expr $ax*1],0] lappend x [.b.c index $t @[expr $ax*2],0] lappend x [.b.c index $t @[expr $ax*3],0] lappend x [.b.c index $t @[expr $ax*4],0] lappend x [.b.c index $t @[expr $ax*5],0] } {0 1 1 1 1 2} # cleanup cleanupTests return tk8.6.5/tests/grab.test0000644003604700454610000001347312424437553013465 0ustar dgp771div# Tests for the grab command. # # This file contains a collection of tests for one or more of the Tk # built-in commands. Sourcing this file runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1998-2000 by Ajuba Solutions. # All rights reserved. package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands namespace import -force tcltest::test # There's currently no way to test the actual grab effect, per se, # in an automated test. Therefore, this test suite only covers the # interface to the grab command (ie, error messages, etc.) test grab-1.1 {Tk_GrabObjCmd} -body { grab } -returnCodes error -result {wrong # args: should be "grab ?-global? window" or "grab option ?arg ...?"} test grab-1.2 {Tk_GrabObjCmd} -body { rename grab grabTest1.2 grabTest1.2 } -cleanup { rename grabTest1.2 grab } -returnCodes error -result {wrong # args: should be "grabTest1.2 ?-global? window" or "grabTest1.2 option ?arg ...?"} test grab-1.3 {Tk_GrabObjCmd, "grab ?-global? window"} -body { grab .foo bar baz } -returnCodes error -result {wrong # args: should be "grab ?-global? window"} test grab-1.4 {Tk_GrabObjCmd, "grab ?-global? window"} -body { destroy .foo grab .foo } -returnCodes error -result {bad window path name ".foo"} test grab-1.5 {Tk_GrabObjCmd, "grab ?-global? window"} -body { grab -foo bar } -returnCodes error -result {bad option "-foo": must be -global} test grab-1.6 {Tk_GrabObjCmd, "grab ?-global? window"} -body { destroy .foo grab -global .foo } -returnCodes error -result {bad window path name ".foo"} test grab-1.7 {Tk_GrabObjCmd} -body { grab foo } -returnCodes error -result {bad option "foo": must be current, release, set, or status} test grab-1.8 {Tk_GrabObjCmd, "grab current ?window?"} -body { grab current foo bar } -returnCodes error -result {wrong # args: should be "grab current ?window?"} test grab-1.9 {Tk_GrabObjCmd, "grab current ?window?"} -body { destroy .foo grab current .foo } -returnCodes error -result {bad window path name ".foo"} test grab-1.10 {Tk_GrabObjCmd, "grab release window"} -body { grab release } -returnCodes error -result {wrong # args: should be "grab release window"} test grab-1.11 {Tk_GrabObjCmd, "grab release window"} -body { destroy .foo grab release .foo } -returnCodes ok -result {} test grab-1.12 {Tk_GrabObjCmd, "grab release window"} -body { grab release foo } -returnCodes ok -result {} test grab-1.13 {Tk_GrabObjCmd, "grab set ?-global? window"} -body { grab set } -returnCodes error -result {wrong # args: should be "grab set ?-global? window"} test grab-1.14 {Tk_GrabObjCmd, "grab set ?-global? window"} -body { grab set foo bar baz } -returnCodes error -result {wrong # args: should be "grab set ?-global? window"} test grab-1.15 {Tk_GrabObjCmd, "grab set ?-global? window"} -body { destroy .foo grab set .foo } -returnCodes error -result {bad window path name ".foo"} test grab-1.16 {Tk_GrabObjCmd, "grab set ?-global? window"} -body { grab set -foo bar } -returnCodes error -result {bad option "-foo": must be -global} test grab-1.17 {Tk_GrabObjCmd, "grab set ?-global? window"} -body { destroy .foo grab set -global .foo } -returnCodes error -result {bad window path name ".foo"} test grab-1.18 {Tk_GrabObjCmd, "grab status window"} -body { grab status } -returnCodes error -result {wrong # args: should be "grab status window"} test grab-1.19 {Tk_GrabObjCmd, "grab status window"} -body { grab status foo bar } -returnCodes error -result {wrong # args: should be "grab status window"} test grab-1.20 {Tk_GrabObjCmd, "grab status window"} -body { destroy .foo grab status .foo } -returnCodes error -result {bad window path name ".foo"} test grab-2.1 {Tk_GrabObjCmd, grab status gives correct status} -body { set curr [grab current .] if { [string length $curr] > 0 } { grab release $curr } grab status . } -cleanup { grab release . } -result {none} test grab-2.2 {Tk_GrabObjCmd, grab status gives correct status} -body { set curr [grab current .] if { [string length $curr] > 0 } { grab release $curr } grab . grab status . } -cleanup { grab release . } -result {local} test grab-2.3 {Tk_GrabObjCmd, grab status gives correct status} -body { set curr [grab current .] if { [string length $curr] > 0 } { grab release $curr } grab -global . grab status . } -cleanup { grab release . } -result {global} test grab-3.1 {Tk_GrabObjCmd, grab current gives correct information} -body { set curr [grab current .] if { [string length $curr] > 0 } { grab release $curr } return $curr } -result {} test grab-3.2 {Tk_GrabObjCmd, grab current gives correct information} -body { set curr [grab current .] if { [string length $curr] > 0 } { grab release $curr } grab . grab current } -cleanup { grab release . } -result {.} test grab-4.1 {Tk_GrabObjCmd, grab release releases grab} -body { set curr [grab current .] if { [string length $curr] > 0 } { grab release $curr } grab . set result [grab status .] grab release . lappend result [grab status .] grab -global . lappend result [grab status .] grab release . lappend result [grab status .] } -result {local none global none} test grab-5.1 {Tk_GrabObjCmd, grab set} -body { set curr [grab current .] if { [string length $curr] > 0 } { grab release $curr } grab set . list [grab current .] [grab status .] } -cleanup { grab release . } -result {. local} test grab-5.2 {Tk_GrabObjCmd, grab set} -body { set curr [grab current .] if { [string length $curr] > 0 } { grab release $curr } grab set -global . list [grab current .] [grab status .] } -cleanup { grab release . } -result {. global} cleanupTests return tk8.6.5/tests/menubut.test0000644003604700454610000006077212377375532014242 0ustar dgp771div# This file is a Tcl script to test menubuttons in Tk. It is # organized in the standard fashion for Tcl tests. # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # XXX This test file is woefully incomplete right now. If any part # XXX of a procedure has tests then the whole procedure has tests, # XXX but many procedures have no tests. package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands namespace import -force tcltest::test imageInit # Create entries in the option database to be sure that geometry options # like border width have predictable values. option add *Menubutton.borderWidth 2 option add *Menubutton.highlightThickness 2 option add *Menubutton.font {Helvetica -12 bold} option add *Button.borderWidth 2 option add *Button.highlightThickness 2 option add *Button.font {Helvetica -12 bold} menubutton .mb -text "Test" pack .mb update test menubutton-1.1 {configuration options} -body { .mb configure -activebackground #012345 .mb cget -activebackground } -cleanup { .mb configure -activebackground [lindex [.mb configure -activebackground] 3] } -result {#012345} test menubutton-1.2 {configuration options} -body { .mb configure -activebackground non-existent } -returnCodes error -result {unknown color name "non-existent"} test menubutton-1.3 {configuration options} -body { .mb configure -activeforeground #ff0000 .mb cget -activeforeground } -cleanup { .mb configure -activeforeground [lindex [.mb configure -activeforeground] 3] } -result {#ff0000} test menubutton-1.4 {configuration options} -body { .mb configure -activeforeground non-existent } -returnCodes error -result {unknown color name "non-existent"} test menubutton-1.5 {configuration options} -body { .mb configure -anchor nw .mb cget -anchor } -cleanup { .mb configure -anchor [lindex [.mb configure -anchor] 3] } -result {nw} test menubutton-1.6 {configuration options} -body { .mb configure -anchor bogus } -returnCodes error -result {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center} test menubutton-1.7 {configuration options} -body { .mb configure -background #ff0000 .mb cget -background } -cleanup { .mb configure -background [lindex [.mb configure -background] 3] } -result {#ff0000} test menubutton-1.8 {configuration options} -body { .mb configure -background non-existent } -returnCodes error -result {unknown color name "non-existent"} test menubutton-1.9 {configuration options} -body { .mb configure -bd 4 .mb cget -bd } -cleanup { .mb configure -bd [lindex [.mb configure -bd] 3] } -result {4} test menubutton-1.10 {configuration options} -body { .mb configure -bd badValue } -returnCodes error -result {bad screen distance "badValue"} test menubutton-1.11 {configuration options} -body { .mb configure -bg #ff0000 .mb cget -bg } -cleanup { .mb configure -bg [lindex [.mb configure -bg] 3] } -result {#ff0000} test menubutton-1.12 {configuration options} -body { .mb configure -bg non-existent } -returnCodes error -result {unknown color name "non-existent"} test menubutton-1.13 {configuration options} -body { .mb configure -bitmap questhead .mb cget -bitmap } -cleanup { .mb configure -bitmap [lindex [.mb configure -bitmap] 3] } -result {questhead} test menubutton-1.14 {configuration options} -body { .mb configure -bitmap badValue } -returnCodes error -result {bitmap "badValue" not defined} test menubutton-1.15 {configuration options} -body { .mb configure -borderwidth 1.3 .mb cget -borderwidth } -cleanup { .mb configure -borderwidth [lindex [.mb configure -borderwidth] 3] } -result {1} test menubutton-1.16 {configuration options} -body { .mb configure -borderwidth badValue } -returnCodes error -result {bad screen distance "badValue"} test menubutton-1.17 {configuration options} -body { .mb configure -cursor arrow .mb cget -cursor } -cleanup { .mb configure -cursor [lindex [.mb configure -cursor] 3] } -result {arrow} test menubutton-1.18 {configuration options} -body { .mb configure -cursor badValue } -returnCodes error -result {bad cursor spec "badValue"} test menubutton-1.19 {configuration options} -body { .mb configure -direction below .mb cget -direction } -cleanup { .mb configure -direction [lindex [.mb configure -direction] 3] } -result {below} test menubutton-1.20 {configuration options} -body { .mb configure -direction badValue } -returnCodes error -result {bad direction "badValue": must be above, below, flush, left, or right} test menubutton-1.21 {configuration options} -body { .mb configure -disabledforeground #00ff00 .mb cget -disabledforeground } -cleanup { .mb configure -disabledforeground [lindex [.mb configure -disabledforeground] 3] } -result {#00ff00} test menubutton-1.22 {configuration options} -body { .mb configure -disabledforeground xyzzy } -returnCodes error -result {unknown color name "xyzzy"} test menubutton-1.23 {configuration options} -body { .mb configure -fg #110022 .mb cget -fg } -cleanup { .mb configure -fg [lindex [.mb configure -fg] 3] } -result {#110022} test menubutton-1.24 {configuration options} -body { .mb configure -fg bogus } -returnCodes error -result {unknown color name "bogus"} test menubutton-1.25 {configuration options} -body { .mb configure -font {Helvetica 12} .mb cget -font } -cleanup { .mb configure -font [lindex [.mb configure -font] 3] } -result {Helvetica 12} test menubutton-1.26 {configuration options} -body { .mb configure -foreground #110022 .mb cget -foreground } -cleanup { .mb configure -foreground [lindex [.mb configure -foreground] 3] } -result {#110022} test menubutton-1.27 {configuration options} -body { .mb configure -foreground bogus } -returnCodes error -result {unknown color name "bogus"} test menubutton-1.28 {configuration options} -body { .mb configure -height 18 .mb cget -height } -cleanup { .mb configure -height [lindex [.mb configure -height] 3] } -result {18} test menubutton-1.29 {configuration options} -body { .mb configure -height 20.0 } -returnCodes error -result {expected integer but got "20.0"} test menubutton-1.30 {configuration options} -body { .mb configure -highlightbackground #112233 .mb cget -highlightbackground } -cleanup { .mb configure -highlightbackground [lindex [.mb configure -highlightbackground] 3] } -result {#112233} test menubutton-1.31 {configuration options} -body { .mb configure -highlightbackground ugly } -returnCodes error -result {unknown color name "ugly"} test menubutton-1.32 {configuration options} -body { .mb configure -highlightcolor #110022 .mb cget -highlightcolor } -cleanup { .mb configure -highlightcolor [lindex [.mb configure -highlightcolor] 3] } -result {#110022} test menubutton-1.33 {configuration options} -body { .mb configure -highlightcolor bogus } -returnCodes error -result {unknown color name "bogus"} test menubutton-1.34 {configuration options} -body { .mb configure -highlightthickness 18 .mb cget -highlightthickness } -cleanup { .mb configure -highlightthickness [lindex [.mb configure -highlightthickness] 3] } -result {18} test menubutton-1.35 {configuration options} -body { .mb configure -highlightthickness badValue } -returnCodes error -result {bad screen distance "badValue"} test menubutton-1.36 {configuration options} -constraints { testImageType } -setup { catch {image delete image1} image create test image1 } -body { .mb configure -image image1 .mb cget -image } -cleanup { .mb configure -image [lindex [.mb configure -image] 3] image create test image1 } -result {image1} test menubutton-1.37 {configuration options} -setup { catch {image delete bogus} } -body { .mb configure -image bogus } -cleanup { .mb configure -image [lindex [.mb configure -image] 3] } -returnCodes error -result {image "bogus" doesn't exist} test menubutton-1.38 {configuration options} -body { .mb configure -indicatoron yes .mb cget -indicatoron } -cleanup { .mb configure -indicatoron [lindex [.mb configure -indicatoron] 3] } -result {1} test menubutton-1.39 {configuration options} -body { .mb configure -indicatoron no_way } -returnCodes error -result {expected boolean value but got "no_way"} test menubutton-1.40 {configuration options} -body { .mb configure -justify right .mb cget -justify } -cleanup { .mb configure -justify [lindex [.mb configure -justify] 3] } -result {right} test menubutton-1.41 {configuration options} -body { .mb configure -justify bogus } -returnCodes error -result {bad justification "bogus": must be left, right, or center} test menubutton-1.42 {configuration options} -body { .mb configure -menu {any old string} .mb cget -menu } -cleanup { .mb configure -menu [lindex [.mb configure -menu] 3] } -result {any old string} test menubutton-1.43 {configuration options} -body { .mb configure -padx 12 .mb cget -padx } -cleanup { .mb configure -padx [lindex [.mb configure -padx] 3] } -result {12} test menubutton-1.44 {configuration options} -body { .mb configure -padx 420x } -returnCodes error -result {bad screen distance "420x"} test menubutton-1.45 {configuration options} -body { .mb configure -pady 12 .mb cget -pady } -cleanup { .mb configure -pady [lindex [.mb configure -pady] 3] } -result {12} test menubutton-1.46 {configuration options} -body { .mb configure -pady 420x } -returnCodes error -result {bad screen distance "420x"} test menubutton-1.47 {configuration options} -body { .mb configure -relief groove .mb cget -relief } -cleanup { .mb configure -relief [lindex [.mb configure -relief] 3] } -result {groove} test menubutton-1.48 {configuration options} -body { .mb configure -relief 1.5 } -returnCodes error -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken} test menubutton-1.49 {configuration options} -body { .mb configure -state normal .mb cget -state } -cleanup { .mb configure -state [lindex [.mb configure -state] 3] } -result {normal} test menubutton-1.50 {configuration options} -body { .mb configure -state bogus } -returnCodes error -result {bad state "bogus": must be active, disabled, or normal} test menubutton-1.51 {configuration options} -body { .mb configure -takefocus {any string} .mb cget -takefocus } -cleanup { .mb configure -takefocus [lindex [.mb configure -takefocus] 3] } -result {any string} test menubutton-1.52 {configuration options} -body { .mb configure -text {Sample text} .mb cget -text } -cleanup { .mb configure -text [lindex [.mb configure -text] 3] } -result {Sample text} test menubutton-1.53 {configuration options} -body { .mb configure -textvariable i .mb cget -textvariable } -cleanup { .mb configure -textvariable [lindex [.mb configure -textvariable] 3] } -result {i} test menubutton-1.54 {configuration options} -body { .mb configure -underline 5 .mb cget -underline } -cleanup { .mb configure -underline [lindex [.mb configure -underline] 3] } -result {5} test menubutton-1.55 {configuration options} -body { .mb configure -underline 3p } -returnCodes error -result {expected integer but got "3p"} test menubutton-1.56 {configuration options} -body { .mb configure -width 402 .mb cget -width } -cleanup { .mb configure -width [lindex [.mb configure -width] 3] } -result {402} test menubutton-1.57 {configuration options} -body { .mb configure -width 3p } -returnCodes error -result {expected integer but got "3p"} test menubutton-1.58 {configuration options} -body { .mb configure -wraplength 100 .mb cget -wraplength } -cleanup { .mb configure -wraplength [lindex [.mb configure -wraplength] 3] } -result {100} test menubutton-1.59 {configuration options} -body { .mb configure -wraplength 6x } -returnCodes error -result {bad screen distance "6x"} deleteWindows menubutton .mb -text "Test" pack .mb update test menubutton-2.1 {Tk_MenubuttonCmd procedure} -body { menubutton } -returnCodes error -result {wrong # args: should be "menubutton pathName ?-option value ...?"} test menubutton-2.2 {Tk_MenubuttonCmd procedure} -body { menubutton foo } -returnCodes error -result {bad window path name "foo"} test menubutton-2.3 {Tk_MenubuttonCmd procedure} -body { catch {destroy .mb} menubutton .mb winfo class .mb } -result {Menubutton} test menubutton-2.4 {Tk_ButtonCmd procedure} -setup { destroy .mb } -body { menubutton .mb -gorp foo } -returnCodes error -result {unknown option "-gorp"} test menubutton-2.5 {Tk_ButtonCmd procedure} -setup { destroy .mb } -body { catch {menubutton .mb -gorp foo} winfo exists .mb } -result 0 deleteWindows menubutton .mb -text "Test Menu" pack .mb test menubutton-3.1 {MenuButtonWidgetCmd procedure} -body { .mb } -returnCodes error -result {wrong # args: should be ".mb option ?arg ...?"} test menubutton-3.2 {ButtonWidgetCmd procedure, "cget" option} -body { .mb c } -returnCodes error -result {ambiguous option "c": must be cget or configure} test menubutton-3.3 {ButtonWidgetCmd procedure, "cget" option} -body { .mb cget } -returnCodes error -result {wrong # args: should be ".mb cget option"} test menubutton-3.4 {ButtonWidgetCmd procedure, "cget" option} -body { .mb cget a b } -returnCodes error -result {wrong # args: should be ".mb cget option"} test menubutton-3.5 {ButtonWidgetCmd procedure, "cget" option} -body { .mb cget -gorp } -returnCodes error -result {unknown option "-gorp"} test menubutton-3.6 {ButtonWidgetCmd procedure, "cget" option} -body { .mb configure -highlightthickness 3 .mb cget -highlightthickness } -result {3} test menubutton-3.7 {ButtonWidgetCmd procedure, "configure" option} -body { llength [.mb configure] } -result {33} test menubutton-3.8 {ButtonWidgetCmd procedure, "configure" option} -body { .mb configure -gorp } -returnCodes error -result {unknown option "-gorp"} test menubutton-3.9 {ButtonWidgetCmd procedure, "configure" option} -body { .mb co -bg #ffffff -fg } -returnCodes error -result {value for "-fg" missing} test menubutton-3.10 {ButtonWidgetCmd procedure, "configure" option} -body { .mb configure -fg #123456 .mb configure -bg #654321 lindex [.mb configure -fg] 4 } -result {#123456} test menubutton-3.11 {ButtonWidgetCmd procedure, "configure" option} -body { .mb foobar } -returnCodes error -result {bad option "foobar": must be cget or configure} deleteWindows # XXX Need to add tests for several procedures here. The tests for XXX # XXX ConfigureMenuButton aren't complete either. XXX test menubutton-4.1 {ConfigureMenuButton procedure} -setup { deleteWindows } -body { button .mb1 -text "Menubutton 1" .mb1 configure -width 1i } -cleanup { deleteWindows } -returnCodes error -result {expected integer but got "1i"} test menubutton-4.2 {ConfigureMenuButton procedure} -setup { deleteWindows } -body { button .mb1 -text "Menubutton 1" catch {.mb1 configure -width 1i} return $errorInfo } -cleanup { deleteWindows } -result {expected integer but got "1i" (processing -width option) invoked from within ".mb1 configure -width 1i"} test menubutton-4.3 {ConfigureMenuButton procedure} -setup { deleteWindows } -body { button .mb1 -text "Menubutton 1" .mb1 configure -height 0.5c } -cleanup { deleteWindows } -returnCodes error -result {expected integer but got "0.5c"} test menubutton-4.4 {ConfigureMenuButton procedure} -setup { deleteWindows } -body { button .mb1 -text "Menubutton 1" catch {.mb1 configure -height 0.5c} return $errorInfo } -cleanup { deleteWindows } -result {expected integer but got "0.5c" (processing -height option) invoked from within ".mb1 configure -height 0.5c"} test menubutton-4.5 {ConfigureMenuButton procedure} -setup { deleteWindows } -body { button .mb1 -bitmap questhead .mb1 configure -width abc } -cleanup { deleteWindows } -returnCodes error -result {bad screen distance "abc"} test menubutton-4.6 {ConfigureMenuButton procedure} -setup { deleteWindows } -body { button .mb1 -bitmap questhead catch {.mb1 configure -width abc} return $errorInfo } -cleanup { deleteWindows } -result {bad screen distance "abc" (processing -width option) invoked from within ".mb1 configure -width abc"} test menubutton-4.7 {ConfigureMenuButton procedure} -constraints { testImageType } -setup { deleteWindows imageCleanup } -body { image create test image1 button .mb1 -image image1 .mb1 configure -height 0.5x } -cleanup { deleteWindows imageCleanup } -returnCodes error -result {bad screen distance "0.5x"} test menubutton-4.8 {ConfigureMenuButton procedure} -constraints { testImageType } -setup { deleteWindows imageCleanup } -body { image create test image1 button .mb1 -image image1 catch {.mb1 configure -height 0.5x} return $errorInfo } -cleanup { deleteWindows imageCleanup } -result {bad screen distance "0.5x" (processing -height option) invoked from within ".mb1 configure -height 0.5x"} test menubutton-4.9 {ConfigureMenuButton procedure} -constraints { nonPortable fonts } -setup { deleteWindows } -body { button .mb1 -text "Sample text" -width 10 -height 2 pack .mb1 set result "[winfo reqwidth .mb1] [winfo reqheight .mb1]" .mb1 configure -bitmap questhead lappend result [winfo reqwidth .mb1] [winfo reqheight .mb1] } -cleanup { deleteWindows } -result {102 46 20 12} test menubutton-4.10 {ConfigureMenuButton procedure - bad direction} -setup { deleteWindows } -body { menubutton .mb -text "Test" .mb configure -direction badValue } -cleanup { deleteWindows } -returnCodes error -result {bad direction "badValue": must be above, below, flush, left, or right} test menubutton-4.11 {ConfigureMenuButton procedure - bad direction} -setup { deleteWindows } -body { menubutton .mb -text "Test" catch {.mb configure -direction badValue} list [.mb cget -direction] [destroy .mb] } -cleanup { deleteWindows } -result {below {}} # XXX Need to add tests for several procedures here. XXX test menubutton-5.1 {MenuButtonEventProc procedure} -setup { deleteWindows set x {} } -body { menubutton .mb1 -bg #543210 rename .mb1 .mb2 lappend x [winfo children .] lappend x [.mb2 cget -bg] destroy .mb1 lappend x [info command .mb*] [winfo children .] } -cleanup { deleteWindows } -result {.mb1 #543210 {} {}} test menubutton-6.1 {MenuButtonCmdDeletedProc procedure} -setup { deleteWindows } -body { menubutton .mb1 rename .mb1 {} list [info command .mb*] [winfo children .] } -cleanup { deleteWindows } -result {{} {}} test menubutton-7.1 {ComputeMenuButtonGeometry procedure} -constraints { testImageType } -setup { deleteWindows image create test image1 } -body { menubutton .mb -image image1 -bd 4 -highlightthickness 0 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] } -cleanup { deleteWindows imageCleanup } -result {38 23} test menubutton-7.2 {ComputeMenuButtonGeometry procedure} -constraints { testImageType } -setup { deleteWindows image create test image1 } -body { menubutton .mb -image image1 -bd 1 -highlightthickness 2 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] } -cleanup { deleteWindows imageCleanup } -result {36 21} test menubutton-7.3 {ComputeMenuButtonGeometry procedure} -constraints { testImageType } -setup { deleteWindows image create test image1 } -body { menubutton .mb -image image1 -bd 0 -highlightthickness 2 -padx 5 -pady 5 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] } -cleanup { deleteWindows imageCleanup } -result {34 19} test menubutton-7.4 {ComputeMenuButtonGeometry procedure} -constraints { testImageType } -setup { deleteWindows image create test image1 } -body { menubutton .mb -image image1 -bd 2 -relief raised -width 40 \ -highlightthickness 2 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] } -cleanup { deleteWindows imageCleanup } -result {48 23} test menubutton-7.5 {ComputeMenuButtonGeometry procedure} -constraints { testImageType } -setup { deleteWindows image create test image1 } -body { menubutton .mb -image image1 -bd 2 -relief raised -height 30 \ -highlightthickness 2 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] } -cleanup { deleteWindows imageCleanup } -result {38 38} test menubutton-7.6 {ComputeMenuButtonGeometry procedure} -setup { deleteWindows } -body { menubutton .mb -bitmap question -bd 2 -relief raised \ -highlightthickness 2 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] } -cleanup { deleteWindows } -result {25 35} test menubutton-7.7 {ComputeMenuButtonGeometry procedure} -setup { deleteWindows } -body { menubutton .mb -bitmap question -bd 2 -relief raised -width 40 \ -highlightthickness 1 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] } -cleanup { deleteWindows } -result {46 33} test menubutton-7.8 {ComputeMenuButtonGeometry procedure} -setup { deleteWindows } -body { menubutton .mb -bitmap question -bd 2 -relief raised -height 50 \ -highlightthickness 1 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] } -cleanup { deleteWindows } -result {23 56} test menubutton-7.9 {ComputeMenuButtonGeometry procedure} -constraints { fonts } -setup { deleteWindows } -body { menubutton .mb -text String -bd 2 -relief raised -padx 0 -pady 0 \ -highlightthickness 1 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] } -cleanup { deleteWindows } -result {42 20} test menubutton-7.10 {ComputeMenuButtonGeometry procedure} -constraints { fonts } -setup { deleteWindows } -body { menubutton .mb -text String -bd 2 -relief raised -width 20 \ -padx 0 -pady 0 -highlightthickness 1 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] } -cleanup { deleteWindows } -result {146 20} test menubutton-7.11 {ComputeMenuButtonGeometry procedure} -constraints { fonts } -setup { deleteWindows } -body { menubutton .mb -text String -bd 2 -relief raised -height 2 \ -padx 0 -pady 0 -highlightthickness 1 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] } -cleanup { deleteWindows } -result {42 34} test menubutton-7.12 {ComputeMenuButtonGeometry procedure} -constraints { fonts } -setup { deleteWindows } -body { menubutton .mb -text String -bd 2 -relief raised -padx 10 -pady 5 \ -highlightthickness 1 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] } -cleanup { deleteWindows } -result {62 30} test menubutton-7.13 {ComputeMenuButtonGeometry procedure} -constraints { nonPortable fonts } -setup { deleteWindows } -body { menubutton .mb -text String -bd 2 -relief raised \ -highlightthickness 1 -indicatoron 1 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] } -cleanup { deleteWindows } -result {78 28} test menubutton-7.14 {ComputeMenuButtonGeometry procedure} -constraints { testImageType unix nonPortable } -setup { deleteWindows image create test image1 } -body { # The following test is non-portable because the indicator's pixel # size varies to maintain constant absolute size. menubutton .mb -image image1 -bd 2 -relief raised \ -highlightthickness 2 -indicatoron 1 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] } -cleanup { deleteWindows imageCleanup } -result {64 23} test menubutton-7.15 {ComputeMenuButtonGeometry procedure} -constraints { testImageType win nonPortable } -setup { deleteWindows image create test image1 } -body { # The following test is non-portable because the indicator's pixel # size varies to maintain constant absolute size. menubutton .mb -image image1 -bd 2 -relief raised \ -highlightthickness 2 -indicatoron 1 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] } -cleanup { deleteWindows imageCleanup } -result {65 23} test menubutton-8.1 {menubutton vs hidden commands} -body { set l [interp hidden] deleteWindows menubutton .mb interp hide {} .mb destroy .mb set res1 [list [winfo children .] [interp hidden]] set res2 [list {} $l] expr {$res1 eq $res2} } -result 1 deleteWindows option clear imageFinish # cleanup cleanupTests return # Local variables: # mode: tcl # End: tk8.6.5/tests/option.file20000644003604700454610000000004211555562545014074 0ustar dgp771div*foo1: magenta foo2 missing colon tk8.6.5/tests/bind.test0000644003604700454610000051204612466651774013477 0ustar dgp771div# This file is a Tcl script to test out Tk's "bind" and "bindtags" # commands plus the procedures in tkBind.c. It is organized in the # standard fashion for Tcl tests. # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994-1995 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. package require tcltest 2.2 namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands tk useinputmethods 0 toplevel .t -width 100 -height 50 wm geom .t +0+0 update idletasks foreach p [event info] {event delete $p} foreach event [bind Test] { bind Test $event {} } foreach event [bind all] { bind all $event {} } proc unsetBindings {} { bind all {} bind Test {} bind Toplevel {} bind xyz {} bind {a b} {} bind .t {} } test bind-1.1 {bind command} -body { bind } -returnCodes error -result {wrong # args: should be "bind window ?pattern? ?command?"} test bind-1.2 {bind command} -body { bind a b c d } -returnCodes error -result {wrong # args: should be "bind window ?pattern? ?command?"} test bind-1.3 {bind command} -body { bind .gorp } -returnCodes error -result {bad window path name ".gorp"} test bind-1.4 {bind command} -body { bind foo } -returnCodes ok -result {} test bind-1.5 {bind command} -body { bind .t {} } -returnCodes ok -result {} test bind-1.6 {bind command} -body { frame .t.f bind .t.f {test script} set result [bind .t.f ] bind .t.f {} list $result [bind .t.f ] } -cleanup { destroy .t.f } -result {{test script} {}} test bind-1.7 {bind command} -body { frame .t.f bind .t.f {test script} bind .t.f {+more text} bind .t.f } -cleanup { destroy .t.f } -result {test script more text} test bind-1.8 {bind command} -body { bind .t {test script} } -returnCodes error -result {bad event type or keysym "gorp"} test bind-1.9 {bind command} -body { catch {bind .t {test script}} bind .t } -result {} test bind-1.10 {bind command} -body { bind .t } -returnCodes ok -result {} test bind-1.11 {bind command} -body { frame .t.f bind .t.f {script 1} bind .t.f {script 2} bind .t.f a {script for a} bind .t.f b {script for b} lsort [bind .t.f] } -cleanup { destroy .t.f } -result { a b} test bind-2.1 {bindtags command} -body { bindtags } -returnCodes error -result {wrong # args: should be "bindtags window ?taglist?"} test bind-2.2 {bindtags command} -body { bindtags a b c } -returnCodes error -result {wrong # args: should be "bindtags window ?taglist?"} test bind-2.3 {bindtags command} -body { bindtags .foo } -returnCodes error -result {bad window path name ".foo"} test bind-2.4 {bindtags command} -body { bindtags .t } -result {.t Toplevel all} test bind-2.5 {bindtags command} -body { frame .t.f bindtags .t.f } -cleanup { destroy .t.f } -result {.t.f Frame .t all} test bind-2.6 {bindtags command} -body { frame .t.f bindtags .t.f {{x y z} b c d} bindtags .t.f } -cleanup { destroy .t.f } -result {{x y z} b c d} test bind-2.7 {bindtags command} -body { frame .t.f bindtags .t.f {x y z} bindtags .t.f {} bindtags .t.f } -cleanup { destroy .t.f } -result {.t.f Frame .t all} test bind-2.8 {bindtags command} -body { frame .t.f bindtags .t.f {x y z} bindtags .t.f {a b c d} bindtags .t.f } -cleanup { destroy .t.f } -result {a b c d} test bind-2.9 {bindtags command} -body { frame .t.f bindtags .t.f {a b c} bindtags .t.f "\{" } -cleanup { destroy .t.f } -returnCodes error -result {unmatched open brace in list} test bind-2.10 {bindtags command} -body { frame .t.f bindtags .t.f {a b c} catch {bindtags .t.f "\{"} bindtags .t.f } -cleanup { destroy .t.f } -result {.t.f Frame .t all} test bind-2.11 {bindtags command} -body { frame .t.f bindtags .t.f {a b c} bindtags .t.f "a .gorp b" } -cleanup { destroy .t.f } -returnCodes ok test bind-2.12 {bindtags command} -body { frame .t.f bindtags .t.f {a b c} catch {bindtags .t.f "a .gorp b"} bindtags .t.f } -cleanup { destroy .t.f } -result {a .gorp b} test bind-3.1 {TkFreeBindingTags procedure} -body { frame .t.f bindtags .t.f "a b c d" destroy .t.f } -cleanup { destroy .t.f } -result {} test bind-3.2 {TkFreeBindingTags procedure} -body { frame .t.f catch {bindtags .t.f "a .gorp b .t.f"} destroy .t.f } -cleanup { destroy .t.f } -result {} test bind-4.1 {TkBindEventProc procedure} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f update set x {} } -body { bind all {lappend x "%W enter all"} bind Test {lappend x "%W enter frame"} bind Toplevel {lappend x "%W enter toplevel"} bind xyz {lappend x "%W enter xyz"} bind {a b} {lappend x "%W enter {a b}"} bind .t {lappend x "%W enter .t"} bind .t.f {lappend x "%W enter .t.f"} event generate .t.f return $x } -cleanup { destroy .t.f unsetBindings } -result {{.t.f enter .t.f} {.t.f enter frame} {.t.f enter .t} {.t.f enter all}} test bind-4.2 {TkBindEventProc procedure} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f update set x {} } -body { bind all {lappend x "%W enter all"} bind Test {lappend x "%W enter frame"} bind Toplevel {lappend x "%W enter toplevel"} bind xyz {lappend x "%W enter xyz"} bind {a b} {lappend x "%W enter {a b}"} bind .t {lappend x "%W enter .t"} bind .t.f {lappend x "%W enter .t.f"} bindtags .t.f {.t.f {a b} xyz} event generate .t.f return $x } -cleanup { destroy .t.f unsetBindings } -result {{.t.f enter .t.f} {.t.f enter {a b}} {.t.f enter xyz}} test bind-4.3 {TkBindEventProc procedure} -body { set x {} bind all {lappend x "%W enter all"} bind Test {lappend x "%W enter frame"} bind Toplevel {lappend x "%W enter toplevel"} bind xyz {lappend x "%W enter xyz"} bind {a b} {lappend x "%W enter {a b}"} bind .t {lappend x "%W enter .t"} event generate .t return $x } -cleanup { unsetBindings } -result {{.t enter .t} {.t enter toplevel} {.t enter all}} test bind-4.4 {TkBindEventProc procedure} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f frame .t.f3 -width 50 -height 50 pack .t.f3 update set x {} } -body { bind all {lappend x "%W enter all"} bind Test {lappend x "%W enter frame"} bind Toplevel {lappend x "%W enter toplevel"} bind xyz {lappend x "%W enter xyz"} bind {a b} {lappend x "%W enter {a b}"} bind .t {lappend x "%W enter .t"} bindtags .t.f {.t.f .t.f2 .t.f3} bind .t.f {lappend x "%W enter .t.f"} bind .t.f3 {lappend x "%W enter .t.f3"} event generate .t.f return $x } -cleanup { destroy .t.f .t.f3 unsetBindings } -result {{.t.f enter .t.f} {.t.f enter .t.f3}} test bind-4.5 {TkBindEventProc procedure} -setup { # This tests memory allocation for objPtr; it won't serve any useful # purpose unless run with some sort of allocation checker turned on. frame .t.f -class Test -width 150 -height 100 pack .t.f update } -body { bind all {lappend x "%W enter all"} bind Test {lappend x "%W enter frame"} bind Toplevel {lappend x "%W enter toplevel"} bind xyz {lappend x "%W enter xyz"} bind {a b} {lappend x "%W enter {a b}"} bind .t {lappend x "%W enter .t"} bindtags .t.f {a b c d e f g h i j k l m n o p q r s t u v w x y z} event generate .t.f } -cleanup { destroy .t.f unsetBindings } -result {} test bind-5.1 {Tk_CreateBindingTable procedure} -body { canvas .t.c .t.c bind foo } -cleanup { destroy .t.c } -result {} test bind-6.1 {Tk_DeleteBindTable procedure} -body { canvas .t.c .t.c bind foo <1> {string 1} .t.c create rectangle 0 0 100 100 .t.c bind 1 <2> {string 2} destroy .t.c } -cleanup { destroy .t.c } -result {} test bind-7.1 {Tk_CreateBinding procedure: bad binding} -body { canvas .t.c .t.c bind foo < } -cleanup { destroy .t.c } -returnCodes error -result {no event type or button # or keysym} test bind-7.3 {Tk_CreateBinding procedure: append} -body { canvas .t.c .t.c bind foo <1> "button 1" .t.c bind foo <1> "+more button 1" .t.c bind foo <1> } -cleanup { destroy .t.c } -result {button 1 more button 1} test bind-7.4 {Tk_CreateBinding procedure: append to non-existing} -body { canvas .t.c .t.c bind foo <1> "+button 1" .t.c bind foo <1> } -cleanup { destroy .t.c } -result {button 1} test bind-8.1 {Tk_CreateBinding: error} -body { bind . "xyz" } -returnCodes error -result {bad event type or keysym "xyz"} test bind-9.1 {Tk_DeleteBinding procedure} -body { frame .t.f -class Test -width 150 -height 100 bind .t.f < } -cleanup { destroy .t.f } -returnCodes ok test bind-9.2 {Tk_DeleteBinding procedure} -setup { set result {} } -body { frame .t.f -class Test -width 150 -height 100 foreach i {a b c d} { bind .t.f $i "binding for $i" } foreach i {b d a c} { bind .t.f $i {} lappend result [lsort [bind .t.f]] } return $result } -cleanup { destroy .t.f } -result {{a c d} {a c} c {}} test bind-9.3 {Tk_DeleteBinding procedure} -setup { set result {} } -body { frame .t.f -class Test -width 150 -height 100 foreach i {<1> } { bind .t.f $i "binding for $i" } foreach i { <1> } { bind .t.f $i {} lappend result [lsort [bind .t.f]] } return $result } -cleanup { destroy .t.f } -result {{ } { } {}} test bind-10.1 {Tk_GetBinding procedure} -body { canvas .t.c .t.c bind foo < } -cleanup { destroy .t.c } -returnCodes error -result {no event type or button # or keysym} test bind-10.2 {Tk_GetBinding procedure} -body { canvas .t.c .t.c bind foo a Test .t.c bind foo a } -cleanup { destroy .t.c } -result {Test} test bind-11.1 {Tk_GetAllBindings procedure} -body { frame .t.f foreach i "! a \\\{ ~ <> " { bind .t.f $i Test } lsort [bind .t.f] } -cleanup { destroy .t.f } -result {! <> a \{ ~} test bind-11.2 {Tk_GetAllBindings procedure} -body { frame .t.f foreach i " <1>" { bind .t.f $i Test } lsort [bind .t.f] } -cleanup { destroy .t.f } -result { } test bind-11.3 {Tk_GetAllBindings procedure} -body { frame .t.f foreach i " abcd ab" { bind .t.f $i Test } lsort [bind .t.f] } -cleanup { destroy .t.f } -result { ab abcd} test bind-12.1 {Tk_DeleteAllBindings procedure} -body { frame .t.f -class Test -width 150 -height 100 destroy .t.f } -result {} test bind-12.2 {Tk_DeleteAllBindings procedure} -body { frame .t.f -class Test -width 150 -height 100 foreach i "a b c " { bind .t.f $i x } destroy .t.f } -result {} test bind-13.1 {Tk_BindEvent procedure} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f focus -force .t.f update set x {} } -body { bind Test {lappend x "%W %K Test KeyPress"} bind all {lappend x "%W %K all KeyPress"} bind Test : {lappend x "%W %K Test :"} bind all _ {lappend x "%W %K all _"} bind .t.f : {lappend x "%W %K .t.f :"} event generate .t.f event generate .t.f event generate .t.f return $x } -cleanup { destroy .t.f bind all {} bind Test {} bind all _ {} bind Test : {} } -result {{.t.f colon .t.f :} {.t.f colon Test :} {.t.f colon all KeyPress} {.t.f plus Test KeyPress} {.t.f plus all KeyPress} {.t.f underscore Test KeyPress} {.t.f underscore all _}} test bind-13.2 {Tk_BindEvent procedure} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f focus -force .t.f update set x {} } -body { bind Test {lappend x "%W %K Test press any"; break} bind all {continue; lappend x "%W %K all press any"} bind .t.f : {lappend x "%W %K .t.f pressed colon"} event generate .t.f return $x } -cleanup { destroy .t.f bind all {} bind Test {} } -result {{.t.f colon .t.f pressed colon} {.t.f colon Test press any}} test bind-13.3 {Tk_BindEvent procedure} -setup { proc bgerror args {} frame .t.f -class Test -width 150 -height 100 pack .t.f focus -force .t.f update set x {} } -body { bind Test {lappend x "%W %K Test press any"; error Test} bind .t.f : {lappend x "%W %K .t.f pressed colon"} event generate .t.f update list $x $errorInfo } -cleanup { destroy .t.f bind Test {} rename bgerror {} } -result {{{.t.f colon .t.f pressed colon} {.t.f colon Test press any}} {Test while executing "error Test" (command bound to event)}} test bind-13.4 {Tk_BindEvent procedure} -setup { proc foo {} { set x 44 event generate .t.f } frame .t.f -class Test -width 150 -height 100 pack .t.f focus -force .t.f update set x {} } -body { bind Test : {lappend x "%W %K Test"} bind .t.f : {lappend x "%W %K .t.f"} foo return $x } -cleanup { destroy .t.f bind Test : {} } -result {{.t.f colon .t.f} {.t.f colon Test}} test bind-13.5 {Tk_BindEvent procedure} -body { bind all {lappend x "%W destroyed"} set x {} frame .t.g -gorp foo } -cleanup { bind all {} } -returnCodes error -result {unknown option "-gorp"} test bind-13.6 {Tk_BindEvent procedure} -body { bind all {lappend x "%W destroyed"} set x {} catch {frame .t.g -gorp foo} return $x } -cleanup { bind all {} } -result {{.t.g destroyed}} test bind-13.7 {Tk_BindEvent procedure} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f focus -force .t.f update set x {} } -body { bind .t.f : {lappend x "%W (.t.f binding)"} bind Test : {lappend x "%W (Test binding)"} bind all : {bind .t.f : {}; lappend x "%W (all binding)"} event generate .t.f return $x } -cleanup { bind Test : {} bind all : {} destroy .t.f } -result {{.t.f (.t.f binding)} {.t.f (Test binding)} {.t.f (all binding)}} test bind-13.8 {Tk_BindEvent procedure} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f focus -force .t.f update set x {} } -body { bind .t.f : {lappend x "%W (.t.f binding)"} bind Test : {lappend x "%W (Test binding)"} bind all : {destroy .t.f; lappend x "%W (all binding)"} event generate .t.f return $x } -cleanup { bind Test : {} bind all : {} destroy .t.f } -result {{.t.f (.t.f binding)} {.t.f (Test binding)} {.t.f (all binding)}} test bind-13.9 {Tk_BindEvent procedure} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f focus -force .t.f update set x {} } -body { bind .t.f <1> {lappend x "%W z (.t.f <1> binding)"} bind .t.f {lappend x "%W z (.t.f binding)"} event generate .t.f event generate .t.f return $x } -cleanup { destroy .t.f } -result {{.t.f z (.t.f <1> binding)} {.t.f z (.t.f binding)}} test bind-13.10 {Tk_BindEvent procedure: ignore NotifyInferior} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f focus -force .t.f update set x {} } -body { bind .t.f "lappend x Enter%#" bind .t.f "lappend x Leave%#" event generate .t.f -serial 100 -detail NotifyAncestor event generate .t.f -serial 101 -detail NotifyInferior event generate .t.f -serial 102 -detail NotifyAncestor event generate .t.f -serial 103 -detail NotifyInferior return $x } -cleanup { destroy .t.f } -result {Enter100 Leave102} test bind-13.11 {Tk_BindEvent procedure: collapse Motions} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f focus -force .t.f update set x {} } -body { bind .t.f "lappend x Motion%#(%x,%y)" event generate .t.f -serial 100 -x 100 -y 200 -when tail update event generate .t.f -serial 101 -x 200 -y 300 -when tail event generate .t.f -serial 102 -x 300 -y 400 -when tail update return $x } -cleanup { destroy .t.f } -result {Motion100(100,200) Motion102(300,400)} test bind-13.12 {Tk_BindEvent procedure: collapse repeating modifiers} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f focus -force .t.f update } -body { bind .t.f "lappend x %K%#" bind .t.f "lappend x %K%#" event generate .t.f -serial 100 -when tail event generate .t.f -serial 101 -when tail event generate .t.f -serial 102 -when tail event generate .t.f -serial 103 -when tail update } -cleanup { destroy .t.f } -result {} test bind-13.13 {Tk_BindEvent procedure: valid key detail} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f focus -force .t.f update set x {} } -body { bind .t.f "lappend x Key%K" bind .t.f "lappend x Release%K" event generate .t.f -keysym colon event generate .t.f -keysym colon return $x } -cleanup { destroy .t.f } -result {Keycolon Releasecolon} test bind-13.14 {Tk_BindEvent procedure: invalid key detail} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f focus -force .t.f update set x {} } -body { bind .t.f "lappend x Key%K" bind .t.f "lappend x Release%K" event generate .t.f -keycode 0 event generate .t.f -keycode 0 return $x } -cleanup { destroy .t.f } -result {Key?? Release??} test bind-13.15 {Tk_BindEvent procedure: button detail} -setup { frame .t.f -class Test -width 150 -height 100 pack .t.f focus -force .t.f update set x {} } -body { bind .t.f