diff options
| author | stanton <stanton> | 1998-09-29 00:25:03 (GMT) |
|---|---|---|
| committer | stanton <stanton> | 1998-09-29 00:25:03 (GMT) |
| commit | c16d45ef706cbb616125e57ec8a1f809bae3c9df (patch) | |
| tree | 99c199f65b7d32755dc8f0ee5cc773bd922a74a6 | |
| parent | d3b37a36ad09da1989ef6c53fd6fddc71deb2d72 (diff) | |
| download | tk-c16d45ef706cbb616125e57ec8a1f809bae3c9df.zip tk-c16d45ef706cbb616125e57ec8a1f809bae3c9df.tar.gz tk-c16d45ef706cbb616125e57ec8a1f809bae3c9df.tar.bz2 | |
initial tk8.1a2 version
242 files changed, 38287 insertions, 11965 deletions
@@ -1,25 +1,28 @@ The Tk Toolkit -SCCS: @(#) README 1.47 97/11/20 12:48:16 +SCCS: @(#) README 1.51 98/02/18 18:02:32 1. Introduction --------------- This directory and its descendants contain the sources and documentation for Tk, an X11 toolkit implemented with the Tcl scripting language. The -information here corresponds to Tk 8.0p2, which is the second patch update -for Tk 8.0. This release is designed to work with Tcl 8.0p2 and may not -work with any other version of Tcl. - -Tk 8.0 is a major release with significant new features such as native -look and feel on Macintoshes and PCs, a new font mechanism, application -embedding, and proper support for Safe-Tcl. See below for details. -There should be no backward incompatibilities in Tk 8.0 that affect -scripts. This patch release fixes various bugs in Tk 8.0; there are no -feature changes relative to Tk 8.0. - -Note: with Tk 8.0 the Tk version number skipped from 4.2 to 8.0. The -jump was made in order to synchronize the Tcl and Tk version numbers. +information here constitutes the 8.1a2 release, which is the second alpha +release for Tk 8.1. This release is still in experimental form and is +intended for expert early adopters who are willing to help us find and +fix problems. The release is certain to contain bugs and is not yet +feature-complete: we will probably add new features or change some of +the existing features before the final 8.1 release. Please let us know +about any problems you uncover. + +The most important change in Tk 8.1 is that it supports the new +internationalization features in Tcl 8.1. It also contains a new +library for handling configuration options some of the widgets have been +converted to use the Tcl object facilities. For details on features, +incompatibilities, and potential problems with this release, see the +Tcl/Tk 8.1 Web page at http://sunscript.sun.com/TclTkCore/8.1.html or +refer to the "changes" file in this directory, which contains a +historical record of all changes to Tk. 2. Documentation ---------------- @@ -57,7 +60,7 @@ that summarizes the new features and discusses how to deal with the changes in Tk 4.0 that are not backwards compatible. There is also an official home for Tcl and Tk on the Web: - http://www.smli.com/research/tcl + http://sunscript.sun.com These Web pages include release updates, reports on bug fixes and porting issues, HTML versions of the manual pages, and pointers to many other Tcl/Tk Web pages at other sites. Check them out! @@ -75,9 +78,9 @@ Before trying to compile Tk you should do the following things: available now for PCs and Macintoshes, and several flavors of UNIX. Binary releases are much easier to install than source releases. To find out whether a binary release is available for - your platform, check the home page for the Sun Tcl/Tk project - (http://www.sunlabs.com/research/tcl) and also check in the FTP - directory from which you retrieved the base distribution. + your platform, check the Tcl/Tk 8.1 Web page at + http://sunscript.sun.com/TclTkCore/8.1.html. Also, check in the + FTP directory from which you retrieved the base distribution. (b) Make sure you have the most recent patch release. Look in the FTP directory from which you retrieved this distribution to see @@ -85,30 +88,30 @@ Before trying to compile Tk you should do the following things: without changing any features, so you should normally use the latest patch release for the version of Tk that you want. Patch releases are available in two forms. A file like - tk8.0p1.tar.Z is a complete release for patch level 1 of Tk - version 8.0. If there is a file with a higher patch level than + tk8.1p1.tar.Z is a complete release for patch level 1 of Tk + version 8.1. If there is a file with a higher patch level than this release, just fetch the file with the highest patch level and use it. Patches are also available in the form of patch files that just contain the changes from one patch level to another. These - files have names like tk8.0p1.patch, tk8.0p2.patch, etc. They + files have names like tk8.1p1.patch, tk8.1p2.patch, etc. They may also have .gz or .Z extensions to indicate compression. To use one of these files, you apply it to an existing release with the "patch" program. Patches must be applied in order: - tk8.0p1.patch must be applied to an unpatched Tk 8.0 release - to produce a Tk 8.0p1 release; tk8.0p2.patch can then be - applied to Tk 8.0p1 to produce Tk 8.0p2, and so on. To apply an - uncompressed patch file such as tk8.0p1.patch, invoke a shell + tk8.1p1.patch must be applied to an unpatched Tk 8.1 release + to produce a Tk 8.1p1 release; tk8.1p2.patch can then be + applied to Tk 8.1p1 to produce Tk 8.1p2, and so on. To apply an + uncompressed patch file such as tk8.1p1.patch, invoke a shell command like the following from the directory containing this file: - patch -p < tk8.0p1.patch + patch -p < tk8.1p1.patch If the patch file has a .gz extension, it was compressed with gzip. To apply it, invoke a command like the following: - gunzip -c tk8.0p1.patch.gz | patch -p + gunzip -c tk8.1p1.patch.gz | patch -p If the patch file has a .Z extension, it was compressed with compress. To apply it, invoke a command like the following: - zcat tk8.0p1.patch.Z | patch -p + zcat tk8.1p1.patch.Z | patch -p If you're applying a patch to a release that has already been compiled, then before applying the patch you should cd to the "unix" subdirectory and type "make distclean" to restore the @@ -133,121 +136,7 @@ library/demos/widget is a script that you can use to invoke many individual demonstrations of Tk's facilities, see the code that produced the demos, and modify the code to try out alternatives. -5. Summary of changes in Tk 8.0 -------------------------------- - -Here is a list of the most important new features in Tk 8.0. The -release also includes several smaller feature changes and bug fixes. -See the "changes" file for a complete list of all changes. - - 1. Native look and feel. The widgets have been rewritten to provide - (nearly?) native look and feel on the Macintosh and PC. Many - widgets, including scrollbars, menus, and the button family, are - implemented with native platform widgets. Others, such as entries - and texts, have been modified to emulate native look and feel. - These changes are backwards compatible except that (a) some - configuration options are now ignored on some platforms and (b) you - must use the new menu mechanism described below to native look and - feel for menus. - - 2. There is a new interface for creating menus, where a menubar is - implemented as a menu widget instead of a frame containing menubuttons. - The -menu option for a toplevel is used to specify the name of the - menubar; the menu will be displayed *outside* the toplevel using - different mechanisms on each platform (e.g. on the Macintosh the menu - will appear at the top of the screen). See the menu demos in the - widget demo for examples. The old style of menu still works, but - does not provide native look and feel. Menus have several new - features: - - New "-columnbreak" and "-hideMargin" options make it possible - to create multi-column menus. - - It is now possible to manipulate the Apple and Help menus on - the Macintosh, and the system menu on Windows. It is also - possible to have a right justified Help menu on Unix. - - Menus now issue the virtual event <<MenuSelect>> whenever the - current item changes. Applications can use this to generate - help messages. - - There is a new "-direction" option for menubuttons, which - controls where the menu pops up revenues to the button. - - 3. The font mechanism in Tk has been completely reworked: - - Font names need not be nasty X LFDs: more intuitive names - like {Times 12 Bold} can also be used. See the manual entry - font.n for details. - - Font requests always succeed now. If the requested font is - not available, Tk finds the closest available font and uses - that one. - - Tk now supports named fonts whose precise attributes can be - changed dynamically. If a named font is changed, any widget - using that font updates itself to reflect the change. - - There is a new command "font" for creating named fonts and - querying various information about fonts. - - There are now officially supported C APIs for measuring and - displaying text. If you use these APIs now, your code will - automatically handle international text when internationalization - is added to Tk in a future release. See the manual entries - MeasureChar.3, TextLayout.3, and FontId.3. - - The old C procedures Tk_GetFontStruct, Tk_NameOfFontStruct, - and Tk_FreeFontStruct have been replaced with more portable - procedures Tk_GetFont, Tk_NameOfFont, and Tk_FreeFont. - - 4. Application embedding. It is now possible to embedded one Tcl/Tk - application inside another, using the -container option on frame - widgets and the -use option for toplevel widgets or on the command - line for wish. Embedding should be fully functional under Unix, - but the implementation is incomplete on the Macintosh and PC. - - 5. Tk now works correctly with Safe-Tcl: it can be loaded into - safe interpreters using safe::loadTk. - - 6. Text widgets now allow images to be embedded directly in the - text without using embedded windows. This is more efficient and - provides smoother scrolling. - - 7. Buttons have a new -default option for drawing default rings in - a platform-specific manner. - - 8. There is a new "gray75" bitmap, and the "gray25" bitmap is now - really 25% on (due to an ancient mistake, it had been only 12% on). - The Macintosh now supports native bitmaps, including new builtin - bitmaps "stop", "caution", and "note", plus the ability to use - bitmaps in the application's resource fork. - - 9. The "destroy" command now ignores windows that don't exist - instead of generating an error. - -Tk 8.0 introduces the following incompatibilities that may affect Tcl/Tk -scripts that worked under Tk 4.2 and earlier releases: - - 1. Font specifications such as "Times 12" now interpret the size - as points, whereas it used to be pixels (this was actually a bug, - since the behavior was documented as points). To get pixels now, - use a negative size such as "Times -12". - - 2. The -transient option for menus is no longer supported. You can - achieve the same effect with the -type field. - - 3. In the canvas "coords" command, polygons now return only the - points that were explicitly specified when the polygon was created - (they used to return an extra point if the polygon wasn't originally - closed). Internally, polygons are still closed automatically for - purposes of display and hit detection; the extra point just isn't - returned by the "coords" command. - - 4. The photo image mechanism now uses Tcl_Channels instead of FILEs, - in order to make it portable. FILEs are no longer used anywhere - in Tk. The procedure Tk_FindPhoto now requires an extra "interp" - argument in order to fix a bug where images in different interpreters - with the same name could get confused. - - 5. The procedures Tk_GetFontStruct, Tk_NameOfFontStruct, - and Tk_FreeFontStruct have been removed. - -Note: the new compiler in Tcl 8.0 may also affect Tcl/Tk scripts; check -the Tcl documentation for information on incompatibilities introduced by -Tcl 8.0. - -6. Tcl/Tk newsgroup +5. Tcl/Tk newsgroup ------------------- There is a network news group "comp.lang.tcl" intended for the exchange @@ -263,7 +152,7 @@ general interest. A bad e-mail return address may prevent you from getting answers to your questions. You may have to reconfigure your news reading software to ensure that it is supplying valid e-mail addresses. -7. Mailing lists +6. Mailing lists ---------------- A couple of Mailing List have been set up to discuss Macintosh or @@ -271,11 +160,11 @@ Windows related Tcl issues. In order to use these Mailing Lists you must have access to the internet. If you have access to the WWW the home pages for these mailing lists are located at the following URLs: - http://www.sunlabs.com/research/tcl/lists/mactcl-list.html + http://www.sunlabs.com/people/raymond.johnson/mactcl-list.html -and- - http://www.sunlabs.com/research/tcl/lists/wintcl-list.html + http://sunscript.sun.com/win/wintcl-list.html The home pages contain information about the lists and an HTML archive of all the past messages on the list. To subscribe send a message to: @@ -2,7 +2,7 @@ This file summarizes all changes made to Tk since version 1.0 was released on March 13, 1991. Changes that aren't backward compatible are marked specially. -SCCS: @(#) changes 1.252 97/11/25 08:31:19 +SCCS: @(#) changes 1.268 98/02/18 18:06:42 3/16/91 (bug fix) Modified tkWindow.c to remove Tk's Tcl commands from the interpreter when the main window is deleted (otherwise there will @@ -4010,19 +4010,19 @@ virtual events now go to the correct (focus) window. (RJ) 9/19/97 (bug fix) Made Macintosh tearoff menus non-resizable. (RJ) +10/9/97 (bug fix) Default font for new canvas text items was hardcoded to +"Helvetica 12" instead of using DEF_CANVTEXT_FONT defined in +tk{platform}Default.h like all the other widget settings. (CCS) + 10/9/97 (bug fix) Image code could cause crashes during "exit" under some conditions (such as an image named "place"). (JO) 10/9/97 (bug fix) Fixed bug that sometimes prevented listboxes from scrolling far enough horizontally to see the rightmost character. (JO) -10/9/97 (bug fix) Default font for new canvas text items was hardcoded to -"Helvetica 12" instead of using DEF_CANVTEXT_FONT defined in -tk{platform}Default.h like all the other widget settings. (CCS) - -10/10/97 (bug fix) In canvas text items, if the text ended with a \n, it -was not counted in the bbox height, as it did in tk4.2. This caused -"hello\n" to be the same height as "hello" and you couldn't see the +10/10/97 (bug fix) In canvas text items, if the text ended with a \n, it +was not counted in the bbox height, as it did in tk4.2. This caused +"hello\n" to be the same height as "hello" and you couldn't see the cursor positioned on the next line. (CCS) 10/10/97 (bug fix) The grid geometry manager didn't always properly @@ -4127,3 +4127,128 @@ widgets. (JI) Apple Universal Headers V. 3.0 so we can compile with CW Pro 2.0 (JI) ----------------- Released 8.0p2, 11/25/97 ----------------------- + +11/25/97 (security bug fix + added feature) Tk Safe Init now asks +the master's safe::TkInit for the 'argv' to use. This is transparently +dealt with by the safe::loadTk API. New optional "-display displayName" +argument to safe::loadTk, and the "-use" argument accepts both window +Ids and Tk window names: see loadTk(n). Made the ":0.0" default display +work on the Mac as it works on Windows and Unix. (DL) + +12/3/97 (bug fix/optimization) Removed unneeded and potentially dangerous +instances of double evaluations if "if" and "expr" statements from +the library files. It is recommended that unless you need a double +evaluation you always use "expr {...}" instead of "expr ..." and +"if {...} ..." instead of "if ... ...". It will also be faster +thanks to the byte compiler. (DL) + +12/3/97 (new feature) Added support for browser/plugin style embedding, +and made various other fixes to get the plugin working on the Mac. (JI) + +12/8/97 (bug fix) on Windows, using "winfo pathname" before "." was mapped +was crashing. (DL) + +---- Shipped as part of the plugin2.0b5 as 8.0p2Plugin1, Dec 8th 97 ---- + +12/97 (bug fix) more Macintosh embeding fixes needed for the plugin. (JI) + +Jan/9/98 (improvement) Allow applications to have custom init script +without having to patch the Tk core: Tk_Init will use an existing +"tkInit" proc if one exists in the interp where one tries to install Tk +instead of defining it's own (tkInit is the transient proc defined in +generic/tkInitScript.h that searches and sources tk.tcl and defines +the 'correct' tk_library). (DL) + +---- Shipped as part of the plugin2.0 as 8.0p2Plugin2, Jan 15th 98 ---- + +---------------------------------------------------------- +Changes for Tk 8.0 go above this line. +Changes for Tk 8.1 go below this line. +---------------------------------------------------------- + +1/16/98 (new feature) Tk now supports international characters sets: + - Font display mechanism overhauled to display Unicode strings + containing full set of international characters. You do not need + Unicode fonts on your system in order to use tk or see international + characters. For those familiar with the Japanese or Chinese patches, + there is no "-kanjifont" option. Characters from any available fonts + will automatically be used if the widget's originally selected font is + not capable of displaying a given character. + - Textual widgets are international aware. For instance, cursor + positioning commands would now move the cursor forwards/back by 1 + international character, not by 1 byte. + - Input Method Editors (IMEs) work on Mac and Windows. Unix is still in + progress. + +7/7/97 (new feature) The send command now works for Microsoft +Windows. It is implemented using Dynamic Data Exchange, and a new +command, dde, allows Tk to send more generic DDE commands to other +applications. (SRP) + +11/3/97 (new feature) Major overhaul of code that manages configuration +options to use Tcl_Obj structures instead of strings: + - There is a new set of procedures including Tk_CreateOptionTable, + Tk_InitOptions, and Tk_SetOptions, which replace Tk_ConfigureWidget + and related procedures. The old procedures are still available. + The new procedures use a new format for configuration tables. + See SetOptions.3 for more information. + - There are new procedures Tk_AllocColorFromObj, Tk_GetColorFromObj, + and Tk_FreeColorFromObj to manage colors using objects to hold the + name of the color and cache the corresponding XColor pointer. + There are similar procedures Tk_Alloc3DBorderFromObj, + Tk_AllocBitmapFromObj, Tk_AllocCursorFromObj, Tk_AllocFontFromObj, + and so on to manage borders, bitmaps, cursors, and fonts. + - The old-style procedures such as Tk_GetColor and Tk_GetBitmap no + longer take Tk_Uids for arguments; they just take strings. + - Menus, labels, buttons, checkbuttons, and radiobuttons have been + converted to use the new object-based configuration library. + (SRP & JO) + +11/7/97 (improvement) Changed code referring to "interp->result" to call +accessor functions like Tcl_SetResult(). + +12/23/97 (fix) Fixed transparency and web optimized the palette of +the images/ Tcl powered logos. (DL) + +12/16/97 (bug fix) Canvas and text "bind" subcommands generated an +error with no message if called to fetch a binding that didn't exist. +They now silently return without an error like the "bind" command. (SS) + +1/13/98 (bug fix) Keysyms for international characters were not being +reported properly under Windows. (SS) + +----------------- Released 8.1a1, 1/22/98 ----------------------- + +2/4/98 (bug fix) Calling XFreeFontNames() twice if couldn't allocate +font. (CCS) + +2/10/98 (bug fix) Inlined prolog.ps in tkCanvPs.c to make it accessible +from safe interpreters: canvas postscript now works in safe interps +(like in tk8.0plugin). (DL) + +2/11/98 (bug fix) Windows "send" to a remote interp wasn't propagating +$errorInfo correctly from the remote interp to the local invoking interp. +(CCS) + +2/11/98 (bug fix) Windows "send" should have accepted "--" to mean "no more +arguments". (CCS) + +2/11/98 (bug fix) Windows "send" was concatenating its arguments +incorrectly (not consistent with "eval", "uplevel", or Unix "send"). (CCS) + +2/18/98 (bug fix) Macintosh radiobuttons and checkbuttons now color +their backgrounds correctly under Appearance. The controls gadgets themselves +however, remain the Theme colors. (JI) + +2/18/98 (improvement) The corner pixels that peek through around the +rounded corners of the Mac button widget are now controlled by the +-highlightbackground, rather than the -background option. (JI) + +2/18/98 (improvement) Implemented the intra-application Send on the +Mac (RJ) + +2/18/98 (bug fix) Under X, a problem mapping from a fontStructPtr to an +XLFD (no XA_FONT attribute) would lead to dereferencing NULL. (CCS) + +----------------- Released 8.1a2, Feb 20 1998 ----------------------- + diff --git a/compat/stdlib.h b/compat/stdlib.h index 059ea29..5ffda0e 100644 --- a/compat/stdlib.h +++ b/compat/stdlib.h @@ -9,12 +9,12 @@ * declare all the procedures needed here (such as strtod). * * Copyright (c) 1991 The Regents of the University of California. - * Copyright (c) 1994 Sun Microsystems, Inc. + * Copyright (c) 1994-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) stdlib.h 1.10 96/02/15 14:43:54 + * SCCS: @(#) stdlib.h 1.12 98/01/21 21:04:59 */ #ifndef _STDLIB diff --git a/doc/3DBorder.3 b/doc/3DBorder.3 index 921a948..30b4f72 100644 --- a/doc/3DBorder.3 +++ b/doc/3DBorder.3 @@ -1,24 +1,32 @@ '\" '\" Copyright (c) 1990-1993 The Regents of the University of California. -'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" Copyright (c) 1994-1998 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" SCCS: @(#) 3DBorder.3 1.23 96/11/17 15:03:05 +'\" SCCS: @(#) 3DBorder.3 1.25 98/01/14 13:58:56 '\" .so man.macros -.TH Tk_Get3DBorder 3 4.0 Tk "Tk Library Procedures" +.TH Tk_Alloc3DBorderFromObj 3 8.1 Tk "Tk Library Procedures" .BS .SH NAME -Tk_Get3DBorder, Tk_Draw3DRectangle, Tk_Fill3DRectangle, Tk_Draw3DPolygon, Tk_Fill3DPolygon, Tk_3DVerticalBevel, Tk_3DHorizontalBevel, Tk_SetBackgroundFromBorder, Tk_NameOf3DBorder, Tk_3DBorderColor, Tk_3DBorderGC, Tk_Free3DBorder \- draw borders with three-dimensional appearance +Tk_Alloc3DBorderFromObj, Tk_Get3DBorder, Tk_Get3DBorderFromObj, Tk_Draw3DRectangle, Tk_Fill3DRectangle, Tk_Draw3DPolygon, Tk_Fill3DPolygon, Tk_3DVerticalBevel, Tk_3DHorizontalBevel, Tk_SetBackgroundFromBorder, Tk_NameOf3DBorder, Tk_3DBorderColor, Tk_3DBorderGC, Tk_Free3DBorderFromObj, Tk_Free3DBorder \- draw borders with three-dimensional appearance .SH SYNOPSIS .nf \fB#include <tk.h>\fR .sp +.VS 8.1 +Tk_3DBorder +\fBTk_Alloc3DBorderFromObj(\fIinterp, tkwin, objPtr\fB)\fR +.sp Tk_3DBorder \fBTk_Get3DBorder(\fIinterp, tkwin, colorName\fB)\fR .sp +Tk_3DBorder +\fBTk_Get3DBorderFromObj(\fItkwin, objPtr\fB)\fR +.VE +.sp void \fBTk_Draw3DRectangle(\fItkwin, drawable, border, x, y, width, height, borderWidth, relief\fB)\fR .sp @@ -49,6 +57,10 @@ XColor * GC * \fBTk_3DBorderGC(\fItkwin, border, which\fB)\fR .sp +.VS 8.1 +\fBTk_Free3DBorderFromObj(\fItkwin, objPtr\fB)\fR +.VE +.sp \fBTk_Free3DBorder(\fIborder\fB)\fR .SH ARGUMENTS .AS "Tk_3DBorder" borderWidth @@ -57,10 +69,15 @@ Interpreter to use for error reporting. .AP Tk_Window tkwin in Token for window (for all procedures except \fBTk_Get3DBorder\fR, must be the window for which the border was allocated). -.AP Tk_Uid colorName in -Textual description of color corresponding to background (flat areas). -Illuminated edges will be brighter than this and shadowed edges will -be darker than this. +.AP Tcl_Obj *objPtr in +.VS 8.1 +Pointer to object whose value describes color corresponding to +background (flat areas). Illuminated edges will be brighter than +this and shadowed edges will be darker than this. +.AP char *colorName in +Same as \fIobjPtr\fR except value is supplied as a string rather +than an object. +.VE .AP Drawable drawable in X token for window or pixmap; indicates where graphics are to be drawn. Must either be the X window for \fItkwin\fR or a pixmap with the @@ -129,22 +146,42 @@ Must be TK_3D_FLAT_GC, TK_3D_LIGHT_GC, or TK_3D_DARK_GC. .SH DESCRIPTION .PP These procedures provide facilities for drawing window borders in a -way that produces a three-dimensional appearance. \fBTk_Get3DBorder\fR +way that produces a three-dimensional appearance. +.VS 8.1 +\fBTk_Alloc3DBorderFromObj\fR allocates colors and Pixmaps needed to draw a border in the window -given by the \fItkwin\fR argument. The \fIcolorName\fR -argument indicates what colors should be used in the border. -\fIColorName\fR may be any value acceptable to \fBTk_GetColor\fR. -The color indicated by \fIcolorName\fR will not actually be used in +given by the \fItkwin\fR argument. The value of \fIobjPtr\fR +is a standard Tk color name that determines the border colors. +The color indicated by \fIobjPtr\fR will not actually be used in the border; it indicates the background color for the window (i.e. a color for flat surfaces). The illuminated portions of the border will appear brighter than indicated -by \fIcolorName\fR, and the shadowed portions of the border will appear -darker than \fIcolorName\fR. +by \fIobjPtr\fR, and the shadowed portions of the border will appear +darker than \fIobjPtr\fR. .PP -\fBTk_Get3DBorder\fR returns a token that may be used in later calls +\fBTk_Alloc3DBorderFromObj\fR returns a token that may be used in later calls to \fBTk_Draw3DRectangle\fR. If an error occurs in allocating information -for the border (e.g. \fIcolorName\fR isn't a legal color specifier), +for the border (e.g. a bogus color name was given) then NULL is returned and an error message is left in \fIinterp->result\fR. +If it returns successfully, \fBTk_Alloc3DBorderFromObj\fR caches +information about the return value in \fIobjPtr\fR, which speeds up +future calls to \fBTk_Alloc3DBorderFromObj\fR with the same \fIobjPtr\fR +and \fItkwin\fR. +.PP +\fBTk_Get3DBorder\fR is identical to \fBTk_Alloc3DBorderFromObj\fR except +that the color is specified with a string instead of an object. This +prevents \fBTk_Get3DBorder\fR from caching the return value, so +\fBTk_Get3DBorder\fR is less efficient than \fBTk_Alloc3DBorderFromObj\fR. +.PP +\fBTk_Get3DBorderFromObj\fR returns the token for an existing border, given +the window and color name used to create the border. +\fBTk_Get3DBorderFromObj\fR doesn't actually create the border; it must +already have been created with a previous call to +\fBTk_Alloc3DBorderFromObj\fR or \fBTk_Get3DBorder\fR. The return +value is cached in \fIobjPtr\fR, which speeds up +future calls to \fBTk_Get3DBorderFromObj\fR with the same \fIobjPtr\fR +and \fItkwin\fR. +.VE .PP Once a border structure has been created, \fBTk_Draw3DRectangle\fR may be invoked to draw the border. @@ -171,7 +208,7 @@ a groove or ridge around the exterior of the rectangle. \fBTk_Fill3DRectangle\fR is somewhat like \fBTk_Draw3DRectangle\fR except that it first fills the rectangular area with the background color (one corresponding -to the \fIcolorName\fR used to create \fIborder\fR). Then it calls +to the color used to create \fIborder\fR). Then it calls \fBTk_Draw3DRectangle\fR to draw a border just inside the outer edge of the rectangular area. The argument \fIrelief\fR indicates the desired effect (TK_RELIEF_FLAT means no border should be drawn; all that @@ -228,21 +265,19 @@ bottom bevel should be drawn with 0 for both arguments. The procedure \fBTk_SetBackgroundFromBorder\fR will modify the background pixel and/or pixmap of \fItkwin\fR to produce a result compatible with \fIborder\fR. For color displays, the resulting background will -just be the color given by the \fIcolorName\fR argument passed to -\fBTk_Get3DBorder\fR when \fIborder\fR was created; for monochrome +just be the color specified when \fIborder\fR was created; for monochrome displays, the resulting background will be a light stipple pattern, in order to distinguish the background from the illuminated portion of the border. .PP Given a token for a border, the procedure \fBTk_NameOf3DBorder\fR -will return the \fIcolorName\fR string that was passed to -\fBTk_Get3DBorder\fR to create the border. +will return the color name that was used to create the border. .PP The procedure \fBTk_3DBorderColor\fR returns the XColor structure that will be used for flat surfaces drawn for its \fIborder\fR argument by procedures like \fBTk_Fill3DRectangle\fR. -The return value corresponds to the \fIcolorName\fR passed to -\fBTk_Get3DBorder\fR. +The return value corresponds to the color name that was used to +create the border. The XColor, and its associated pixel value, will remain allocated as long as \fIborder\fR exists. .PP @@ -253,10 +288,18 @@ TK_3D_FLAT_GC returns the context used for flat surfaces, TK_3D_LIGHT_GC returns the context for light shadows, and TK_3D_DARK_GC returns the context for dark shadows. .PP -When a border is no longer needed, \fBTk_Free3DBorder\fR should -be called to release the resources associated with the border. -There should be exactly one call to \fBTk_Free3DBorder\fR for -each call to \fBTk_Get3DBorder\fR. +.VS 8.1 +When a border is no longer needed, \fBTk_Free3DBorderFromObj\fR +or \fBTk_Free3DBorder\fR should +be called to release the resources associated with it. +For \fBTk_Free3DBorderFromObj\fR the border to release is specified +with the window and color name used to create the +border; for \fBTk_Free3DBorder\fR the border to release is specified +with the Tk_3DBorder token for the border. +There should be exactly one call to \fBTk_Free3DBorderFromObj\fR or +\fBTk_Free3DBorder\fR for each call to \fBTk_Alloc3DBorderFromObj\fR +or \fBTk_Get3DBorder\fR. +.VE .SH KEYWORDS -3D, background, border, color, depressed, illumination, polygon, raised, shadow, three-dimensional effect +3D, background, border, color, depressed, illumination, object, polygon, raised, shadow, three-dimensional effect diff --git a/doc/ConfigWidg.3 b/doc/ConfigWidg.3 index 3178580..733870c 100644 --- a/doc/ConfigWidg.3 +++ b/doc/ConfigWidg.3 @@ -5,7 +5,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" SCCS: @(#) ConfigWidg.3 1.30 96/08/27 13:21:18 +'\" SCCS: @(#) ConfigWidg.3 1.32 98/01/02 13:18:16 '\" .so man.macros .TH Tk_ConfigureWidget 3 4.1 Tk "Tk Library Procedures" @@ -26,10 +26,11 @@ int \fBTk_ConfigureInfo(\fIinterp, tkwin, specs, widgRec, argvName, flags\fB)\fR .sp int +\fBTk_ConfigureValue(\fIinterp, tkwin, specs, widgRec, argvName, flags\fB)\fR .sp \fBTk_FreeOptions(\fIspecs, widgRec, display, flags\fB)\fR .SH ARGUMENTS -.AS Tk_ConfigSpec *widgRec +.AS Tk_ConfigSpec *widgRec in/out .AP Tcl_Interp *interp in Interpreter to use for returning error messages. .AP Tk_Window tkwin in diff --git a/doc/CrtWindow.3 b/doc/CrtWindow.3 index 7799ed0..561a2da 100644 --- a/doc/CrtWindow.3 +++ b/doc/CrtWindow.3 @@ -5,7 +5,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" @(#) CrtWindow.c 1.21 96/11/01 09:42:20 +'\" @(#) CrtWindow.3 1.21 96/11/01 09:42:20 '\" .so man.macros .TH Tk_CreateWindow 3 4.2 Tk "Tk Library Procedures" diff --git a/doc/GetAnchor.3 b/doc/GetAnchor.3 index 4c5cdfb..96ac879 100644 --- a/doc/GetAnchor.3 +++ b/doc/GetAnchor.3 @@ -1,21 +1,26 @@ '\" '\" Copyright (c) 1990 The Regents of the University of California. -'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" Copyright (c) 1994-1998 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" SCCS: @(#) GetAnchor.3 1.9 96/03/26 18:08:45 +'\" SCCS: @(#) GetAnchor.3 1.11 98/01/28 13:00:43 '\" .so man.macros -.TH Tk_GetAnchor 3 "" Tk "Tk Library Procedures" +.TH Tk_GetAnchorFromObj 3 8.1 Tk "Tk Library Procedures" .BS .SH NAME -Tk_GetAnchor, Tk_NameOfAnchor \- translate between strings and anchor positions +Tk_GetAnchorFromObj, Tk_GetAnchor, Tk_NameOfAnchor \- translate between strings and anchor positions .SH SYNOPSIS .nf \fB#include <tk.h>\fR .sp +.VS 8.1 +int +\fBTk_GetAnchorFromObj(\fIinterp, objPtr, anchorPtr\fB)\fR +.VE +.sp int \fBTk_GetAnchor(\fIinterp, string, anchorPtr\fB)\fR .sp @@ -24,35 +29,52 @@ char * .SH ARGUMENTS .AS "Tk_Anchor" *anchorPtr .AP Tcl_Interp *interp in -Interpreter to use for error reporting. +Interpreter to use for error reporting, or NULL. +.VS 8.1 br +.AP Tcl_Obj *objPtr in/out +String value contains name of anchor point: \fBn\fR, \fBne\fR, +\fBe\fR, \fBse\fR, \fBs\fR, \fBsw\fR, \fBw\fR, \fBnw\fR, or \fBcenter\fR; +internal rep will be modified to cache corresponding Tk_Anchor. .AP char *string in -String containing name of anchor point: one of ``n'', ``ne'', ``e'', ``se'', -``s'', ``sw'', ``w'', ``nw'', or ``center''. +Same as \fIobjPtr\fR except description of anchor point is passed as +a string. +.VE .AP int *anchorPtr out Pointer to location in which to store anchor position corresponding to -\fIstring\fR. +\fIobjPtr\fR or \fIstring\fR. .AP Tk_Anchor anchor in Anchor position, e.g. \fBTCL_ANCHOR_CENTER\fR. .BE .SH DESCRIPTION .PP -\fBTk_GetAnchor\fR places in \fI*anchorPtr\fR an anchor position +.VS 8.1 +\fBTk_GetAnchorFromObj\fR places in \fI*anchorPtr\fR an anchor position (enumerated type \fBTk_Anchor\fR) -corresponding to \fIstring\fR, which will be one of +corresponding to \fIobjPtr\fR's value. The result will be one of \fBTK_ANCHOR_N\fR, \fBTK_ANCHOR_NE\fR, \fBTK_ANCHOR_E\fR, \fBTK_ANCHOR_SE\fR, \fBTK_ANCHOR_S\fR, \fBTK_ANCHOR_SW\fR, \fBTK_ANCHOR_W\fR, \fBTK_ANCHOR_NW\fR, or \fBTK_ANCHOR_CENTER\fR. Anchor positions are typically used for indicating a point on an object -that will be used to position that object, e.g. \fBTK_ANCHOR_N\fR means +that will be used to position the object, e.g. \fBTK_ANCHOR_N\fR means position the top center point of the object at a particular place. .PP Under normal circumstances the return value is \fBTCL_OK\fR and \fIinterp\fR is unused. If \fIstring\fR doesn't contain a valid anchor position -or an abbreviation of one of these names, then an error message is -stored in \fIinterp->result\fR, \fBTCL_ERROR\fR is returned, and -\fI*anchorPtr\fR is unmodified. +or an abbreviation of one of these names, \fBTCL_ERROR\fR is returned, +\fI*anchorPtr\fR is unmodified, and an error message is +stored in \fIinterp\fR's result if \fIinterp\fR isn't NULL. +\fBTk_GetAnchorFromObj\fR caches information about the return +value in \fIobjPtr\fR, which speeds up future calls to +\fBTk_GetAnchorFromObj\fR with the same \fIobjPtr\fR. +.PP +\fBTk_GetAnchor\fR is identical to \fBTk_GetAnchorFromObj\fR except +that the description of the anchor is specified with a string instead +of an object. This prevents \fBTk_GetAnchor\fR from caching the +return value, so \fBTk_GetAnchor\fR is less efficient than +\fBTk_GetAnchorFromObj\fR. +.VE .PP \fBTk_NameOfAnchor\fR is the logical inverse of \fBTk_GetAnchor\fR. Given an anchor position such as \fBTK_ANCHOR_N\fR it returns a diff --git a/doc/GetBitmap.3 b/doc/GetBitmap.3 index efe7760..edc806c 100644 --- a/doc/GetBitmap.3 +++ b/doc/GetBitmap.3 @@ -1,23 +1,31 @@ '\" '\" Copyright (c) 1990 The Regents of the University of California. -'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" Copyright (c) 1994-1998 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" SCCS: @(#) GetBitmap.3 1.27 97/08/22 18:52:11 +'\" SCCS: @(#) GetBitmap.3 1.28 98/01/14 13:58:57 '\" .so man.macros -.TH Tk_GetBitmap 3 8.0 Tk "Tk Library Procedures" +.TH Tk_AllocBitmapFromObj 3 8.1 Tk "Tk Library Procedures" .BS .SH NAME -Tk_GetBitmap, Tk_DefineBitmap, Tk_NameOfBitmap, Tk_SizeOfBitmap, Tk_FreeBitmap, Tk_GetBitmapFromData \- maintain database of single-plane pixmaps +Tk_AllocBitmapFromObj, Tk_GetBitmap, Tk_GetBitmapFromObj, Tk_DefineBitmap, Tk_NameOfBitmap, Tk_SizeOfBitmap, Tk_FreeBitmapFromObj, Tk_FreeBitmap, Tk_GetBitmapFromData \- maintain database of single-plane pixmaps .SH SYNOPSIS .nf \fB#include <tk.h>\fR .sp +.VS 8.1 Pixmap -\fBTk_GetBitmap(\fIinterp, tkwin, id\fB)\fR +\fBTk_GetBitmapFromObj(\fIinterp, tkwin, objPtr\fB)\fR +.sp +Pixmap +\fBTk_GetBitmap(\fIinterp, tkwin, info\fB)\fR +.sp +Pixmap +\fBTk_GetBitmapFromObj(\fItkwin, objPtr\fB)\fR +.VE .sp int \fBTk_DefineBitmap(\fIinterp, nameId, source, width, height\fB)\fR @@ -27,16 +35,27 @@ Tk_Uid .sp \fBTk_SizeOfBitmap(\fIdisplay, bitmap, widthPtr, heightPtr\fB)\fR .sp +.VS 8.1 +\fBTk_FreeBitmapFromObj(\fItkwin, objPtr\fB)\fR +.VE +.sp \fBTk_FreeBitmap(\fIdisplay, bitmap\fB)\fR .SH ARGUMENTS .AS "unsigned long" *pixelPtr .AP Tcl_Interp *interp in -Interpreter to use for error reporting. +Interpreter to use for error reporting; if NULL then no error message +is left after errors. .AP Tk_Window tkwin in Token for window in which the bitmap will be used. -.AP Tk_Uid id in -Description of bitmap; see below for possible values. -.AP Tk_Uid nameId in +.VS 8.1 br +.AP Tcl_Obj *objPtr in/out +String value describes desired bitmap; internal rep will be +modified to cache pointer to corresponding Pixmap. +.AP char *info in +Same as \fIobjPtr\fR except description of bitmap is passed as a string and +resulting Pixmap isn't cached. +.VE +.AP char *name in Name for new bitmap to be defined. .AP char *source in Data for bitmap, in standard bitmap format. @@ -52,7 +71,8 @@ Pointer to word to fill in with \fIbitmap\fR's height. .AP Display *display in Display for which \fIbitmap\fR was allocated. .AP Pixmap bitmap in -Identifier for a bitmap allocated by \fBTk_GetBitmap\fR. +Identifier for a bitmap allocated by \fBTk_AllocBitmapFromObj\fR or +\fBTk_GetBitmap\fR. .BE .SH DESCRIPTION @@ -62,11 +82,13 @@ being used by an application. The procedures allow bitmaps to be re-used efficiently, thereby avoiding server overhead, and also allow bitmaps to be named with character strings. .PP -\fBTk_GetBitmap\fR takes as argument a Tk_Uid describing a bitmap. -It returns a Pixmap identifier for a bitmap corresponding to the -description. It re-uses an existing bitmap, if possible, and -creates a new one otherwise. At present, \fIid\fR must have -one of the following forms: +.VS 8.1 +\fBTk_AllocBitmapFromObj\fR returns a Pixmap identifier for a bitmap +that matches the description in \fIobjPtr\fR and is suitable for use +in \fItkwin\fR. It re-uses an existing bitmap, if possible, and +creates a new one otherwise. \fIObjPtr\fR's value must have one +of the following forms: +.VE .TP 20 \fB@\fIfileName\fR \fIFileName\fR must be the name of a file containing a bitmap @@ -166,15 +188,35 @@ A face with ballon words. A triangle with an exclamation point. .RE .LP -Under normal conditions, \fBTk_GetBitmap\fR +.VS 8.1 +Under normal conditions, \fBTk_AllocBitmapFromObj\fR returns an identifier for the requested bitmap. If an error -occurs in creating the bitmap, such as when \fIid\fR refers +occurs in creating the bitmap, such as when \fIobjPtr\fR refers to a non-existent file, then \fBNone\fR is returned and an error -message is left in \fIinterp->result\fR. +message is left in \fIinterp\fR's result if \fIinterp\fR isn't +NULL. \fBTk_AllocBitmapFromObj\fR caches information about the return +value in \fIobjPtr\fR, which speeds up future calls to procedures +such as \fBTk_AllocBitmapFromObj\fR and \fBTk_GetBitmapFromObj\fR. +.PP +\fBTk_GetBitmap\fR is identical to \fBTk_AllocBitmapFromObj\fR except +that the description of the bitmap is specified with a string instead +of an object. This prevents \fBTk_GetBitmap\fR from caching the +return value, so \fBTk_GetBitmap\fR is less efficient than +\fBTk_AllocBitmapFromObj\fR. +.PP +\fBTk_GetBitmapFromObj\fR returns the token for an existing bitmap, given +the window and description used to create the bitmap. +\fBTk_GetBitmapFromObj\fR doesn't actually create the bitmap; the bitmap +must already have been created with a previous call to +\fBTk_AllocBitmapFromObj\fR or \fBTk_GetBitmap\fR. The return +value is cached in \fIobjPtr\fR, which speeds up +future calls to \fBTk_GetBitmapFromObj\fR with the same \fIobjPtr\fR +and \fItkwin\fR. +.VE .PP \fBTk_DefineBitmap\fR associates a name with in-memory bitmap data so that the name can be used in later -calls to \fBTk_GetBitmap\fR. The \fInameId\fR +calls to \fBTk_AllocBitmapFromObj\fR or \fBTk_GetBitmap\fR. The \fInameId\fR argument gives a name for the bitmap; it must not previously have been used in a call to \fBTk_DefineBitmap\fR. The arguments \fIsource\fR, \fIwidth\fR, and \fIheight\fR @@ -186,7 +228,8 @@ TCL_ERROR is returned and an error message is left in Note: \fBTk_DefineBitmap\fR expects the memory pointed to by \fIsource\fR to be static: \fBTk_DefineBitmap\fR doesn't make a private copy of this memory, but uses the bytes pointed to -by \fIsource\fR later in calls to \fBTk_GetBitmap\fR. +by \fIsource\fR later in calls to \fBTk_AllocBitmapFromObj\fR or +\fBTk_GetBitmap\fR. .PP Typically \fBTk_DefineBitmap\fR is used by \fB#include\fR-ing a bitmap file directly into a C program and then referencing @@ -217,15 +260,15 @@ after the program has been compiled, or a different string could be provided to read a different file), but it is a little slower and requires the bitmap file to exist separately from the program. .PP -\fBTk_GetBitmap\fR maintains a -database of all the bitmaps that are currently in use. +Tk maintains a database of all the bitmaps that are currently in use. Whenever possible, it will return an existing bitmap rather than creating a new one. +When a bitmap is no longer used, Tk will release it automatically. This approach can substantially reduce server overhead, so -\fBTk_GetBitmap\fR should generally be used in preference to Xlib -procedures like \fBXReadBitmapFile\fR. +\fBTk_AllocBitmapFromObj\fR and \fBTk_GetBitmap\fR should generally +be used in preference to Xlib procedures like \fBXReadBitmapFile\fR. .PP -The bitmaps returned by \fBTk_GetBitmap\fR +The bitmaps returned by \fBTk_AllocBitmapFromObj\fR and \fBTk_GetBitmap\fR are shared, so callers should never modify them. If a bitmap must be modified dynamically, then it should be created by calling Xlib procedures such as \fBXReadBitmapFile\fR @@ -233,28 +276,33 @@ or \fBXCreatePixmap\fR directly. .PP The procedure \fBTk_NameOfBitmap\fR is roughly the inverse of \fBTk_GetBitmap\fR. -Given an X Pixmap argument, it returns the \fIid\fR that was +Given an X Pixmap argument, it returns the textual description that was passed to \fBTk_GetBitmap\fR when the bitmap was created. \fIBitmap\fR must have been the return value from a previous -call to \fBTk_GetBitmap\fR. +call to \fBTk_AllocBitmapFromObj\fR or \fBTk_GetBitmap\fR. .PP \fBTk_SizeOfBitmap\fR returns the dimensions of its \fIbitmap\fR argument in the words pointed to by the \fIwidthPtr\fR and \fIheightPtr\fR arguments. As with \fBTk_NameOfBitmap\fR, -\fIbitmap\fR must have been created by \fBTk_GetBitmap\fR. +\fIbitmap\fR must have been created by \fBTk_AllocBitmapFromObj\fR or +\fBTk_GetBitmap\fR. .PP -When a bitmap returned by \fBTk_GetBitmap\fR -is no longer needed, \fBTk_FreeBitmap\fR should be called to release it. -There should be exactly one call to \fBTk_FreeBitmap\fR for -each call to \fBTk_GetBitmap\fR. -When a bitmap is no longer in use anywhere (i.e. it has been freed as -many times as it has been gotten) \fBTk_FreeBitmap\fR will release -it to the X server and delete it from the database. +.VS 8.1 +When a bitmap is no longer needed, \fBTk_FreeBitmapFromObj\fR or +\fBTk_FreeBitmap\fR should be called to release it. +For \fBTk_FreeBitmapFromObj\fR the bitmap to release is specified +with the same information used to create it; for +\fBTk_FreeBitmap\fR the bitmap to release is specified +with its Pixmap token. +There should be exactly one call to \fBTk_FreeBitmapFromObj\fR +or \fBTk_FreeBitmap\fR for each call to \fBTk_AllocBitmapFromObj\fR or +\fBTk_GetBitmap\fR. +.VE .SH BUGS In determining whether an existing bitmap can be used to satisfy -a new request, \fBTk_GetBitmap\fR -considers only the immediate value of its \fIid\fR argument. For +a new request, \fBTk_AllocBitmapFromObj\fR and \fBTk_GetBitmap\fR +consider only the immediate value of the string description. For example, when a file name is passed to \fBTk_GetBitmap\fR, \fBTk_GetBitmap\fR will assume it is safe to re-use an existing bitmap created from the same file name: it will not check to diff --git a/doc/GetColor.3 b/doc/GetColor.3 index 7f89446..f989cb0 100644 --- a/doc/GetColor.3 +++ b/doc/GetColor.3 @@ -1,32 +1,44 @@ '\" -'\" Copyright (c) 1990, 1991 The Regents of the University of California. -'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" Copyright (c) 1990-1991 The Regents of the University of California. +'\" Copyright (c) 1994-1998 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" SCCS: @(#) GetColor.3 1.22 96/08/27 13:21:26 +'\" SCCS: @(#) GetColor.3 1.24 98/01/14 13:58:58 '\" .so man.macros -.TH Tk_GetColor 3 4.0 Tk "Tk Library Procedures" +.TH Tk_AllocColorFromObj 3 8.1 Tk "Tk Library Procedures" .BS .SH NAME -Tk_GetColor, Tk_GetColorByValue, Tk_NameOfColor, Tk_FreeColor \- maintain database of colors +Tk_AllocColorFromObj, Tk_GetColor, Tk_GetColorFromObj, Tk_GetColorByValue, Tk_NameOfColor, Tk_FreeColorFromObj, Tk_FreeColor \- maintain database of colors .SH SYNOPSIS .nf \fB#include <tk.h>\fR +.VS 8.1 .sp XColor * -\fBTk_GetColor\fR(\fIinterp, tkwin, nameId\fB)\fR +\fBTk_AllocColorFromObj(\fIinterp, tkwin, objPtr\fB)\fR .sp XColor * -\fBTk_GetColorByValue\fR(\fItkwin, prefPtr\fB)\fR +\fBTk_GetColor(\fIinterp, tkwin, name\fB)\fR +.sp +XColor * +\fBTk_GetColorFromObj(\fItkwin, objPtr\fB)\fR +.VE +.sp +XColor * +\fBTk_GetColorByValue(\fItkwin, prefPtr\fB)\fR .sp char * \fBTk_NameOfColor(\fIcolorPtr\fB)\fR .sp GC -\fBTk_GCForColor\fR(\fIcolorPtr, drawable\fR) +\fBTk_GCForColor(\fIcolorPtr, drawable\fB)\fR +.sp +.VS 8.1 +\fBTk_FreeColorFromObj(\fItkwin, objPtr\fB)\fR +.VE .sp \fBTk_FreeColor(\fIcolorPtr\fB)\fR .SH ARGUMENTS @@ -35,27 +47,39 @@ GC Interpreter to use for error reporting. .AP Tk_Window tkwin in Token for window in which color will be used. -.AP Tk_Uid nameId in -Textual description of desired color. +.VS 8.1 br +.AP Tcl_Obj *objPtr in/out +String value describes desired color; internal rep will be +modified to cache pointer to corresponding (XColor *). +.AP char *name in +Same as \fIobjPtr\fR except description of color is passed as a string and +resulting (XColor *) isn't cached. +.VE .AP XColor *prefPtr in Indicates red, green, and blue intensities of desired color. .AP XColor *colorPtr in Pointer to X color information. Must have been allocated by previous -call to \fBTk_GetColor\fR or \fBTk_GetColorByValue\fR, except when passed -to \fBTk_NameOfColor\fR. +call to \fBTk_AllocColorFromObj\fR, \fBTk_GetColor\fR or +\fBTk_GetColorByValue\fR, except when passed to \fBTk_NameOfColor\fR. .AP Drawable drawable in Drawable in which the result graphics context will be used. Must have same screen and depth as the window for which the color was allocated. .BE .SH DESCRIPTION +.VS 8.1 +.PP +These procedures manage the colors being used by a Tk application. +They allow colors to be shared whenever possible, so that colormap +space is preserved, and they pick closest available colors when +colormap space is exhausted. .PP -The \fBTk_GetColor\fR and \fBTk_GetColorByValue\fR procedures -locate pixel values that may be used to render particular -colors in the window given by \fItkwin\fR. In \fBTk_GetColor\fR -the desired color is specified with a Tk_Uid (\fInameId\fR), which -may have any of the following forms: +Given a textual description of a color, \fBTk_AllocColorFromObj\fR +locates a pixel value that may be used to render the color +in a particular window. The desired color is specified with an +object whose string value must have one of the following forms: +.VE .TP 20 \fIcolorname\fR Any of the valid textual names for a color defined in the @@ -76,38 +100,56 @@ When fewer than 16 bits are provided for each color, they represent the most significant bits of the color. For example, #3a7 is the same as #3000a0007000. .PP -In \fBTk_GetColorByValue\fR, the desired color is indicated with -the \fIred\fR, \fIgreen\fR, and \fIblue\fR fields of the structure -pointed to by \fIcolorPtr\fR. -.PP -If \fBTk_GetColor\fR or \fBTk_GetColorByValue\fR is successful -in allocating the desired color, then it returns a pointer to +.VS 8.1 +\fBTk_AllocColorFromObj\fR returns a pointer to an XColor structure; the structure indicates the exact intensities of the allocated color (which may differ slightly from those requested, depending on the limitations of the screen) and a pixel value -that may be used to draw in the color. -If the colormap for \fItkwin\fR is full, \fBTk_GetColor\fR -and \fBTk_GetColorByValue\fR will use the closest existing color -in the colormap. -If \fBTk_GetColor\fR encounters an error while allocating -the color (such as an unknown color name) then NULL is returned and -an error message is stored in \fIinterp->result\fR; -\fBTk_GetColorByValue\fR never returns an error. +that may be used to draw with the color in \fItkwin\fR. +If an error occurs in \fBTk_AllocColorFromObj\fR (such as an unknown +color name) then NULL is returned and an error message is stored in +\fIinterp\fR's result if \fIinterp\fR isn't NULL. +If the colormap for \fItkwin\fR is full, \fBTk_AllocColorFromObj\fR +will use the closest existing color in the colormap. +\fBTk_AllocColorFromObj\fR caches information about +the return value in \fIobjPtr\fR, which speeds up future calls to procedures +such as \fBTk_AllocColorFromObj\fR and \fBTk_GetColorFromObj\fR. +.PP +\fBTk_GetColor\fR is identical to \fBTk_AllocColorFromObj\fR except +that the description of the color is specified with a string instead +of an object. This prevents \fBTk_GetColor\fR from caching the +return value, so \fBTk_GetColor\fR is less efficient than +\fBTk_AllocColorFromObj\fR. +.PP +\fBTk_GetColorFromObj\fR returns the token for an existing color, given +the window and description used to create the color. +\fBTk_GetColorFromObj\fR doesn't actually create the color; the color +must already have been created with a previous call to +\fBTk_AllocColorFromObj\fR or \fBTk_GetColor\fR. The return +value is cached in \fIobjPtr\fR, which speeds up +future calls to \fBTk_GetColorFromObj\fR with the same \fIobjPtr\fR +and \fItkwin\fR. +.VE .PP -\fBTk_GetColor\fR and \fBTk_GetColorByValue\fR maintain a database +\fBTk_GetColorByValue\fR is similar to \fBTk_GetColor\fR except that +the desired color is indicated with the \fIred\fR, \fIgreen\fR, and +\fIblue\fR fields of the structure pointed to by \fIcolorPtr\fR. +.PP +This package maintains a database of all the colors currently in use. -If the same \fInameId\fR is requested multiple times from -\fBTk_GetColor\fR (e.g. by different windows), or if the +If the same color is requested multiple times from +\fBTk_GetColor\fR or \fBTk_AllocColorFromObj\fR (e.g. by different +windows), or if the same intensities are requested multiple times from \fBTk_GetColorByValue\fR, then existing pixel values will be re-used. Re-using an existing pixel avoids any interaction -with the X server, which makes the allocation much more -efficient. For this reason, you should generally use -\fBTk_GetColor\fR or \fBTk_GetColorByValue\fR -instead of Xlib procedures like \fBXAllocColor\fR, -\fBXAllocNamedColor\fR, or \fBXParseColor\fR. +with the window server, which makes the allocation much more +efficient. These procedures also provide a portable interface that +works across all platforms. For this reason, you should generally use +\fBTk_AllocColorFromObj\fR, \fBTk_GetColor\fR, or \fBTk_GetColorByValue\fR +instead of lower level procedures like \fBXAllocColor\fR. .PP -Since different calls to \fBTk_GetColor\fR or \fBTk_GetColorByValue\fR +Since different calls to this package may return the same shared pixel value, callers should never change the color of a pixel returned by the procedures. @@ -116,15 +158,16 @@ If you need to change a color value dynamically, you should use .PP The procedure \fBTk_NameOfColor\fR is roughly the inverse of \fBTk_GetColor\fR. If its \fIcolorPtr\fR argument was created -by \fBTk_GetColor\fR, then the return value is the \fInameId\fR -string that was passed to \fBTk_GetColor\fR to create the +by \fBTk_AllocColorFromObj\fR or \fBTk_GetColor\fR then the return value +is the string that was used to create the color. If \fIcolorPtr\fR was created by a call to \fBTk_GetColorByValue\fR, or by any other mechanism, then the return value is a string that could be passed to \fBTk_GetColor\fR to return the same color. Note: the string returned by \fBTk_NameOfColor\fR is -only guaranteed to persist until the next call to \fBTk_NameOfColor\fR. +only guaranteed to persist until the next call to +\fBTk_NameOfColor\fR. .PP -\fBTk_GCForColor\fR returns a graphics context whose \fBForeground\fR +\fBTk_GCForColor\fR returns a graphics context whose \fBforeground\fR field is the pixel allocated for \fIcolorPtr\fR and whose other fields all have default values. This provides an easy way to do basic drawing with a color. @@ -132,15 +175,16 @@ The graphics context is cached with the color and will exist only as long as \fIcolorPtr\fR exists; it is freed when the last reference to \fIcolorPtr\fR is freed by calling \fBTk_FreeColor\fR. .PP -When a pixel value returned by \fBTk_GetColor\fR or -\fBTk_GetColorByValue\fR is no longer -needed, \fBTk_FreeColor\fR should be called to release the color. -There should be exactly one call to \fBTk_FreeColor\fR for -each call to \fBTk_GetColor\fR or \fBTk_GetColorByValue\fR. -When a pixel value is no longer in -use anywhere (i.e. it has been freed as many times as it has been gotten) -\fBTk_FreeColor\fR will release it to the X server and delete it from -the database. - +.VS 8.1 +When a color is no longer needed \fBTk_FreeColorFromObj\fR or +\fBTk_FreeColor\fR should be called to release it. +For \fBTk_FreeColorFromObj\fR the color to release is specified +with the same information used to create it; for +\fBTk_FreeColor\fR the color to release is specified +with a pointer to its XColor structure. +There should be exactly one call to \fBTk_FreeColorFromObj\fR +or \fBTk_FreeColor\fR for each call to \fBTk_AllocColorFromObj\fR, +\fBTk_GetColor\fR, or \fBTk_GetColorByValue\fR. +.VE .SH KEYWORDS -color, intensity, pixel value +color, intensity, object, pixel value diff --git a/doc/GetCursor.3 b/doc/GetCursor.3 index 5f940c9..329498a 100644 --- a/doc/GetCursor.3 +++ b/doc/GetCursor.3 @@ -1,23 +1,31 @@ '\" '\" Copyright (c) 1990 The Regents of the University of California. -'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" Copyright (c) 1994-1998 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" SCCS: @(#) GetCursor.3 1.23 96/08/27 13:21:26 +'\" SCCS: @(#) GetCursor.3 1.24 98/01/14 13:58:59 '\" .so man.macros -.TH Tk_GetCursor 3 4.1 Tk "Tk Library Procedures" +.TH Tk_AllocCursorFromObj 3 8.1 Tk "Tk Library Procedures" .BS .SH NAME -Tk_GetCursor, Tk_GetCursorFromData, Tk_NameOfCursor, Tk_FreeCursor \- maintain database of cursors +Tk_AllocCursorFromObj, Tk_GetCursor, Tk_GetCursorFromObj, Tk_GetCursorFromData, Tk_NameOfCursor, Tk_FreeCursorFromObj, Tk_FreeCursor \- maintain database of cursors .SH SYNOPSIS .nf \fB#include <tk.h>\fR .sp +.VS 8.1 Tk_Cursor -\fBTk_GetCursor(\fIinterp, tkwin, nameId\fB)\fR +\fBTk_AllocCursorFromObj(\fIinterp, tkwin, objPtr\fB)\fR +.sp +Tk_Cursor +\fBTk_GetCursor(\fIinterp, tkwin, name\fB)\fR +.sp +Tk_Cursor +\fBTk_GetCursorFromObj(\fItkwin, objPtr\fB)\fR +.VE .sp Tk_Cursor \fBTk_GetCursorFromData(\fIinterp, tkwin, source, mask, width, height, xHot, yHot, fg, bg\fB)\fR @@ -25,6 +33,10 @@ Tk_Cursor char * \fBTk_NameOfCursor(\fIdisplay, cursor\fB)\fR .sp +.VS 8.1 +\fBTk_FreeCursorFromObj(\fItkwin, objPtr\fB)\fR +.VE +.sp \fBTk_FreeCursor(\fIdisplay, cursor\fB)\fR .SH ARGUMENTS .AS "unsigned long" *pixelPtr @@ -32,12 +44,18 @@ char * Interpreter to use for error reporting. .AP Tk_Window tkwin in Token for window in which the cursor will be used. -.AP Tk_Uid nameId in -Description of cursor; see below for possible values. +.VS 8.1 br +.AP Tcl_Obj *objPtr in/out +Description of cursor; see below for possible values. Internal rep will be +modified to cache pointer to corresponding Tk_Cursor. +.AP char *name in +Same as \fIobjPtr\fR except description of cursor is passed as a string and +resulting Tk_Cursor isn't cached. +.VE .AP char *source in -Data for cursor bitmap, in standard bitmap format. +Data for cursor cursor, in standard cursor format. .AP char *mask in -Data for mask bitmap, in standard bitmap format. +Data for mask cursor, in standard cursor format. .AP "int" width in Width of \fIsource\fR and \fImask\fR. .AP "int" height in @@ -53,7 +71,7 @@ Textual description of background color for cursor. .AP Display *display in Display for which \fIcursor\fR was allocated. .AP Tk_Cursor cursor in -Opaque Tk identifier for cursor. If passed to\fBTk_FreeCursor\fR, must +Opaque Tk identifier for cursor. If passed to \fBTk_FreeCursor\fR, must have been returned by some previous call to \fBTk_GetCursor\fR or \fBTk_GetCursorFromData\fR. .BE @@ -63,18 +81,25 @@ have been returned by some previous call to \fBTk_GetCursor\fR or These procedures manage a collection of cursors being used by an application. The procedures allow cursors to be re-used efficiently, thereby avoiding server overhead, and also -allow cursors to be named with character strings (actually Tk_Uids). +allow cursors to be named with character strings. .PP -\fBTk_GetCursor\fR takes as argument a Tk_Uid describing a cursor, -and returns an opaque Tk identifier for a cursor corresponding to the -description. -It re-uses an existing cursor if possible and -creates a new one otherwise. \fINameId\fR must be a standard Tcl +.VS 8.1 +\fBTk_AllocCursorFromObj\fR takes as argument an object describing a +cursor, and returns an opaque Tk identifier for a cursor corresponding +to the description. It re-uses an existing cursor if possible and +creates a new one otherwise. \fBTk_AllocCursorFromObj\fR caches +information about the return value in \fIobjPtr\fR, which speeds up +future calls to procedures such as \fBTk_AllocCursorFromObj\fR and +\fBTk_GetCursorFromObj\fR. If an error occurs in creating the cursor, +such as when \fIobjPtr\fR refers to a non-existent file, then \fBNone\fR +is returned and an error message will be stored in \fIinterp\fR's result +if \fIinterp\fR isn't NULL. \fIObjPtr\fR must contain a standard Tcl list with one of the following forms: +.VE .TP \fIname\fR\0[\fIfgColor\fR\0[\fIbgColor\fR]] -\fIName\fR is the name of a cursor in the standard X cursor font, -i.e., any of the names defined in \fBcursorfont.h\fR, without +\fIName\fR is the name of a cursor in the standard X cursor cursor, +i.e., any of the names defined in \fBcursorcursor.h\fR, without the \fBXC_\fR. Some example values are \fBX_cursor\fR, \fBhand2\fR, or \fBleft_ptr\fR. Appendix B of ``The X Window System'' by Scheifler & Gettys has illustrations showing what each of these @@ -86,9 +111,10 @@ will be no background color: the background will be transparent. If no colors are specified, then the cursor will use black for its foreground color and white for its background color. - -The Macintosh version of Tk also supports all of the X cursors. -Tk on the Mac will also accept any of the standard Mac cursors +.RS +.PP +The Macintosh version of Tk supports all of the X cursors and +will also accept any of the standard Mac cursors including \fBibeam\fR, \fBcrosshair\fR, \fBwatch\fR, \fBplus\fR, and \fBarrow\fR. In addition, Tk will load Macintosh cursor resources of the types \fBcrsr\fR (color) and \fBCURS\fR (black and white) by the @@ -96,11 +122,12 @@ name of the of the resource. The application and all its open dynamic library's resource files will be searched for the named cursor. If there are conflicts color cursors will always be loaded in preference to black and white cursors. +.RE .TP \fB@\fIsourceName\0maskName\0fgColor\0bgColor\fR In this form, \fIsourceName\fR and \fImaskName\fR are the names of -files describing bitmaps for the cursor's source bits and mask. -Each file must be in standard X11 or X10 bitmap format. +files describing cursors for the cursor's source bits and mask. +Each file must be in standard X11 or X10 cursor format. \fIFgColor\fR and \fIbgColor\fR indicate the colors to use for the cursor, in any of the forms acceptable to \fBTk_GetColor\fR. This @@ -112,10 +139,27 @@ used as mask also. This means that the cursor's background is transparent. This form of the command will not work on Macintosh or Windows computers. .PP +.VS 8.1 +\fBTk_GetCursor\fR is identical to \fBTk_AllocCursorFromObj\fR except +that the description of the cursor is specified with a string instead +of an object. This prevents \fBTk_GetCursor\fR from caching the +return value, so \fBTk_GetCursor\fR is less efficient than +\fBTk_AllocCursorFromObj\fR. +.PP +\fBTk_GetCursorFromObj\fR returns the token for an existing cursor, given +the window and description used to create the cursor. +\fBTk_GetCursorFromObj\fR doesn't actually create the cursor; the cursor +must already have been created with a previous call to +\fBTk_AllocCursorFromObj\fR or \fBTk_GetCursor\fR. The return +value is cached in \fIobjPtr\fR, which speeds up +future calls to \fBTk_GetCursorFromObj\fR with the same \fIobjPtr\fR +and \fItkwin\fR. +.VE +.PP \fBTk_GetCursorFromData\fR allows cursors to be created from -in-memory descriptions of their source and mask bitmaps. \fISource\fR -points to standard bitmap data for the cursor's source bits, and -\fImask\fR points to standard bitmap data describing +in-memory descriptions of their source and mask cursors. \fISource\fR +points to standard cursor data for the cursor's source bits, and +\fImask\fR points to standard cursor data describing which pixels of \fIsource\fR are to be drawn and which are to be considered transparent. \fIWidth\fR and \fIheight\fR give the dimensions of the cursor, \fIxHot\fR and \fIyHot\fR indicate the @@ -135,24 +179,26 @@ cursor = Tk_GetCursorFromData(interp, tkwin, source_bits, source_y_hot, Tk_GetUid("red"), Tk_GetUid("blue")); .CE .PP -Under normal conditions, \fBTk_GetCursor\fR and \fBTk_GetCursorFromData\fR +Under normal conditions \fBTk_GetCursorFromData\fR will return an identifier for the requested cursor. If an error -occurs in creating the cursor, such as when \fInameId\fR refers -to a non-existent file, then \fBNone\fR is returned and an error -message will be stored in \fIinterp->result\fR. +occurs in creating the cursor then \fBNone\fR is returned and an error +message will be stored in \fIinterp\fR's result. .PP -\fBTk_GetCursor\fR and \fBTk_GetCursorFromData\fR maintain a +\fBTk_AllocCursorFromObj\fR, \fBTk_GetCursor\fR, and +\fBTk_GetCursorFromData\fR maintain a database of all the cursors they have created. Whenever possible, -a call to \fBTk_GetCursor\fR or \fBTk_GetCursorFromData\fR will +a call to \fBTk_AllocCursorFromObj\fR, \fBTk_GetCursor\fR, or +\fBTk_GetCursorFromData\fR will return an existing cursor rather than creating a new one. This approach can substantially reduce server overhead, so the Tk procedures should generally be used in preference to Xlib procedures like \fBXCreateFontCursor\fR or \fBXCreatePixmapCursor\fR, which -create a new cursor on each call. +create a new cursor on each call. The Tk procedures are also more +portable than the lower-level X procedures. .PP The procedure \fBTk_NameOfCursor\fR is roughly the inverse of \fBTk_GetCursor\fR. If its \fIcursor\fR argument was created -by \fBTk_GetCursor\fR, then the return value is the \fInameId\fR +by \fBTk_GetCursor\fR, then the return value is the \fIname\fR argument that was passed to \fBTk_GetCursor\fR to create the cursor. If \fIcursor\fR was created by a call to \fBTk_GetCursorFromData\fR, or by any other mechanism, then the return value is a hexadecimal string @@ -162,17 +208,24 @@ only guaranteed to persist until the next call to \fBTk_NameOfCursor\fR. Also, this call is not portable except for cursors returned by \fBTk_GetCursor\fR. .PP -When a cursor returned by \fBTk_GetCursor\fR or \fBTk_GetCursorFromData\fR -is no longer needed, \fBTk_FreeCursor\fR should be called to release it. +.VS 8.1 +When a cursor returned by \fBTk_AllocCursorFromObj\fR, \fBTk_GetCursor\fR, +or \fBTk_GetCursorFromData\fR +is no longer needed, \fBTk_FreeCursorFromObj\fR or +\fBTk_FreeCursor\fR should be called to release it. +For \fBTk_FreeCursorFromObj\fR the cursor to release is specified +with the same information used to create it; for +\fBTk_FreeCursor\fR the cursor to release is specified +with its Tk_Cursor token. There should be exactly one call to \fBTk_FreeCursor\fR for -each call to \fBTk_GetCursor\fR or \fBTk_GetCursorFromData\fR. -When a cursor is no longer in use anywhere (i.e. it has been freed as -many times as it has been gotten) \fBTk_FreeCursor\fR will release -it to the X server and remove it from the database. +each call to \fBTk_AllocCursorFromObj\fR, \fBTk_GetCursor\fR, +or \fBTk_GetCursorFromData\fR. +.VE .SH BUGS In determining whether an existing cursor can be used to satisfy -a new request, \fBTk_GetCursor\fR and \fBTk_GetCursorFromData\fR +a new request, \fBTk_AllocCursorFromObj\fR, \fBTk_GetCursor\fR, +and \fBTk_GetCursorFromData\fR consider only the immediate values of their arguments. For example, when a file name is passed to \fBTk_GetCursor\fR, \fBTk_GetCursor\fR will assume it is safe to re-use an existing diff --git a/doc/GetFont.3 b/doc/GetFont.3 index ec6c052..006ea0d 100644 --- a/doc/GetFont.3 +++ b/doc/GetFont.3 @@ -1,74 +1,122 @@ '\" '\" Copyright (c) 1990-1992 The Regents of the University of California. -'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" Copyright (c) 1994-1998 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" SCCS: @(#) GetFont.3 1.11 96/07/31 14:07:40 +'\" SCCS: @(#) GetFont.3 1.12 98/01/14 13:58:59 '\" .so man.macros -.TH Tk_GetFont 3 "" Tk "Tk Library Procedures" +.TH Tk_AllocFontFromObj 3 8.1 Tk "Tk Library Procedures" .BS .SH NAME -Tk_GetFont, Tk_NameOfFont, Tk_FreeFont \- maintain database of fonts +Tk_AllocFontFromObj, Tk_GetFont, Tk_GetFontFromObj, Tk_NameOfFont, Tk_FreeFontFromObj, Tk_FreeFont \- maintain database of fonts .SH SYNOPSIS .nf \fB#include <tk.h>\fR .sp +.VS 8.1 Tk_Font -\fBTk_GetFont(\fIinterp, tkwin, string\fB)\fR +\fBTk_AllocFontFromObj(\fIinterp, tkwin, objPtr\fB)\fR +.sp +Tk_Font +\fBTk_GetFont(\fIinterp, tkwin, string\fB)\fR +.sp +Tk_Font +\fBTk_GetFontFromObj(\fItkwin, objPtr\fB)\fR +.VE .sp char * \fBTk_NameOfFont(\fItkfont\fB)\fR .sp +.VS 8.1 +Tk_Font +\fBTk_FreeFontFromObj(\fItkwin, objPtr\fB)\fR +.VE +.sp void \fBTk_FreeFont(\fItkfont\fB)\fR .SH ARGUMENTS .AS "const char" *tkfont .AP "Tcl_Interp" *interp in -Interpreter to use for error reporting. +Interpreter to use for error reporting. If NULL, then no error +messages are left after errors. .AP Tk_Window tkwin in -Token for window on the display in which font will be used. +Token for window in which font will be used. +.VS 8.1 br +.AP Tcl_Obj *objPtr in/out +Gives name or description of font. See documentation +for the \fBfont\fR command for details on acceptable formats. +Internal rep will be modified to cache corresponding Tk_Font. .AP "const char" *string in -Name or description of desired font. See documentation for the \fBfont\fR -command for details on acceptable formats. +Same as \fIobjPtr\fR except description of font is passed as a string and +resulting Tk_Font isn't cached. +.VE .AP Tk_Font tkfont in Opaque font token. .BE .SH DESCRIPTION .PP -\fBTk_GetFont\fR finds the font indicated by \fIstring\fR and returns a -token that represents the font. The return value can be used in subsequent -calls to procedures such as \fBTk_FontMetrics\fR, \fBTk_MeasureChars\fR, and -\fBTk_FreeFont\fR. The token returned by \fBTk_GetFont\fR will remain -valid until \fBTk_FreeFont\fR is called to release it. \fIString\fR can -be either a symbolic name or a font description; see the documentation for -the \fBfont\fR command for a description of the valid formats. If -\fBTk_GetFont\fR is unsuccessful (because, for example, \fIstring\fR was -not a valid font specification) then it returns \fBNULL\fR and stores an -error message in \fIinterp->result\fR. +.VS 8.1 +\fBTk_AllocFontFromObj\fR finds the font indicated by \fIobjPtr\fR and +returns a token that represents the font. The return value can be used +in subsequent calls to procedures such as \fBTk_FontMetrics\fR, +\fBTk_MeasureChars\fR, and \fBTk_FreeFont\fR. The Tk_Font token +will remain valid until +\fBTk_FreeFontFromObj\fR or \fBTk_FreeFont\fR is called to release it. +\fIObjPtr\fR can contain either a symbolic name or a font description; see +the documentation for the \fBfont\fR command for a description of the +valid formats. If \fBTk_AllocFontFromObj\fR is unsuccessful (because, +for example, \fIobjPtr\fR did not contain a valid font specification) then it +returns \fBNULL\fR and leaves an error message in \fIinterp\fR's result +if \fIinterp\fR isn't NULL. \fBTk_AllocFontFromObj\fR caches +information about the return +value in \fIobjPtr\fR, which speeds up future calls to procedures +such as \fBTk_AllocFontFromObj\fR and \fBTk_GetFontFromObj\fR. +.PP +\fBTk_GetFont\fR is identical to \fBTk_AllocFontFromObj\fR except +that the description of the font is specified with a string instead +of an object. This prevents \fBTk_GetFont\fR from caching the +matching Tk_Font, so \fBTk_GetFont\fR is less efficient than +\fBTk_AllocFontFromObj\fR. +.PP +\fBTk_GetFontFromObj\fR returns the token for an existing font, given +the window and description used to create the font. +\fBTk_GetFontFromObj\fR doesn't actually create the font; the font +must already have been created with a previous call to +\fBTk_AllocFontFromObj\fR or \fBTk_GetFont\fR. The return +value is cached in \fIobjPtr\fR, which speeds up +future calls to \fBTk_GetFontFromObj\fR with the same \fIobjPtr\fR +and \fItkwin\fR. +.VE .PP -\fBTk_GetFont\fR maintains a database of all fonts it has allocated. If -the same \fIstring\fR is requested multiple times (e.g. by different -windows or for different purposes), then additional calls for the same -\fIstring\fR will be handled without involving the platform-specific -graphics server. +\fBTk_AllocFontFromObj\fR and \fBTk_GetFont\fR maintain +a database of all fonts they have allocated. If +the same font is requested multiple times (e.g. by different +windows or for different purposes), then a single Tk_Font will be +shared for all uses. The underlying resources will be freed automatically +when no-one is using the font anymore. .PP The procedure \fBTk_NameOfFont\fR is roughly the inverse of \fBTk_GetFont\fR. Given a \fItkfont\fR that was created by -\fBTk_GetFont\fR, the return value is the \fIstring\fR argument that was +\fBTk_GetFont\fR (or \fBTk_AllocFontFromObj\fR), the return value is +the \fIstring\fR argument that was passed to \fBTk_GetFont\fR to create the font. The string returned by \fBTk_NameOfFont\fR is only guaranteed to persist until the \fItkfont\fR is deleted. The caller must not modify this string. .PP -When a font returned by \fBTk_GetFont\fR is no longer needed, -\fBTk_FreeFont\fR should be called to release it. There should be -exactly one call to \fBTk_FreeFont\fR for each call to \fBTk_GetFont\fR. -When a font is no longer in use anywhere (i.e. it has been freed as many -times as it has been gotten) \fBTk_FreeFont\fR will release any -platform-specific storage and delete it from the database. +.VS 8.1 +When a font is no longer needed, +\fBTk_FreeFontFromObj\fR or \fBTk_FreeFont\fR should be called to +release it. For \fBTk_FreeFontFromObj\fR the font to release is specified +with the same information used to create it; for +\fBTk_FreeFont\fR the font to release is specified +with its Tk_Font token. There should be +exactly one call to \fBTk_FreeFontFromObj\fR or \fBTk_FreeFont\fR +for each call to \fBTk_AllocFontFromObj\fR or \fBTk_GetFont\fR. +.VE .SH KEYWORDS font diff --git a/doc/GetJustify.3 b/doc/GetJustify.3 index 35ec0ae..1d5622d 100644 --- a/doc/GetJustify.3 +++ b/doc/GetJustify.3 @@ -1,22 +1,26 @@ '\" '\" Copyright (c) 1990-1994 The Regents of the University of California. -'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" Copyright (c) 1994-1998 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" SCCS: @(#) GetJustify.3 1.11 96/08/27 13:21:27 +'\" SCCS: @(#) GetJustify.3 1.12 98/01/14 13:59:00 '\" .so man.macros -.TH Tk_GetJustify 3 4.0 Tk "Tk Library Procedures" +.TH Tk_GetJustifyFromObj 3 8.1 Tk "Tk Library Procedures" .BS .SH NAME -Tk_GetJustify, Tk_NameOfJustify \- translate between strings and justification styles +Tk_GetJustifyFromObj, Tk_GetJustify, Tk_NameOfJustify \- translate between strings and justification styles .SH SYNOPSIS .nf \fB#include <tk.h>\fR .sp -Tk_Justify +.VS 8.1 +int +\fBTk_GetJustifyFromObj(\fIinterp, objPtr, justifyPtr\fB)\fR +.sp +int \fBTk_GetJustify(\fIinterp, string, justifyPtr\fB)\fR .sp char * @@ -24,21 +28,30 @@ char * .SH ARGUMENTS .AS "Tk_Justify" *justifyPtr .AP Tcl_Interp *interp in -Interpreter to use for error reporting. +Interpreter to use for error reporting, or NULL. +.VS 8.1 br +.AP Tcl_Obj *objPtr in/out +String value contains name of justification style (\fBleft\fR, \fBright\fR, or +\fBcenter\fR). The +internal rep will be modified to cache corresponding justify value. .AP char *string in -String containing name of justification style (``left'', ``right'', or -``center''). +Same as \fIobjPtr\fR except description of justification style is passed as +a string. +.VE .AP int *justifyPtr out Pointer to location in which to store justify value corresponding to -\fIstring\fR. +\fIobjPtr\fR or \fIstring\fR. .AP Tk_Justify justify in Justification style (one of the values listed below). .BE .SH DESCRIPTION .PP -\fBTk_GetJustify\fR places in \fI*justifyPtr\fR the justify value -corresponding to \fIstring\fR. This value will be one of the following: +.VS 8.1 +\fBTk_GetJustifyFromObj\fR places in \fI*justifyPtr\fR the justify value +corresponding to \fIobjPtr\fR's value. +.VE +This value will be one of the following: .TP \fBTK_JUSTIFY_LEFT\fR Means that the text on each line should start at the left edge of @@ -52,12 +65,23 @@ the line; as a result, the left edges of lines may be ragged. Means that the text on each line should be centered; as a result, both the left and right edges of lines may be ragged. .PP +.VS 8.1 Under normal circumstances the return value is \fBTCL_OK\fR and \fIinterp\fR is unused. -If \fIstring\fR doesn't contain a valid justification style -or an abbreviation of one of these names, then an error message is -stored in \fIinterp->result\fR, \fBTCL_ERROR\fR is returned, and -\fI*justifyPtr\fR is unmodified. +If \fIobjPtr\fR doesn't contain a valid justification style +or an abbreviation of one of these names, \fBTCL_ERROR\fR is returned, +\fI*justifyPtr\fR is unmodified, and an error message is +stored in \fIinterp\fR's result if \fIinterp\fR isn't NULL. +\fBTk_GetJustifyFromObj\fR caches information about the return +value in \fIobjPtr\fR, which speeds up future calls to +\fBTk_GetJustifyFromObj\fR with the same \fIobjPtr\fR. +.PP +\fBTk_GetJustify\fR is identical to \fBTk_GetJustifyFromObj\fR except +that the description of the justification is specified with a string instead +of an object. This prevents \fBTk_GetJustify\fR from caching the +return value, so \fBTk_GetJustify\fR is less efficient than +\fBTk_GetJustifyFromObj\fR. +.VE .PP \fBTk_NameOfJustify\fR is the logical inverse of \fBTk_GetJustify\fR. Given a justify value it returns a statically-allocated string diff --git a/doc/GetPixels.3 b/doc/GetPixels.3 index 6b26eb3..07d94c8 100644 --- a/doc/GetPixels.3 +++ b/doc/GetPixels.3 @@ -1,24 +1,34 @@ '\" '\" Copyright (c) 1990 The Regents of the University of California. -'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" Copyright (c) 1994-1998 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" SCCS: @(#) GetPixels.3 1.8 96/03/26 18:11:30 +'\" SCCS: @(#) GetPixels.3 1.9 98/01/14 13:59:00 '\" .so man.macros -.TH Tk_GetPixels 3 "" Tk "Tk Library Procedures" +.TH Tk_GetPixelsFromObj 3 8.1 Tk "Tk Library Procedures" .BS .SH NAME -Tk_GetPixels, Tk_GetScreenMM \- translate between strings and screen units +Tk_GetPixelsFromObj, Tk_GetPixels, Tk_GetMMFromObj, Tk_GetScreenMM \- translate between strings and screen units .SH SYNOPSIS .nf \fB#include <tk.h>\fR .sp +.VS 8.1 +int +\fBTk_GetPixelsFromObj(\fIinterp, tkwin, objPtr, intPtr\fB)\fR +.VE +.sp int \fBTk_GetPixels(\fIinterp, tkwin, string, intPtr\fB)\fR .sp +.VS 8.1 +int +\fBTk_GetMMFromObj(\fIinterp, tkwin, objPtr, doublePtr\fB)\fR +.VE +.sp int \fBTk_GetScreenMM(\fIinterp, tkwin, string, doublePtr\fB)\fR .SH ARGUMENTS @@ -27,9 +37,15 @@ int Interpreter to use for error reporting. .AP Tk_Window tkwin in Window whose screen geometry determines the conversion between absolute -units and pixels. +units and pixels. +.VS 8.1 br +.AP Tcl_Obj *objPtr in/out +String value specifies a distance on the screen; +internal rep will be modified to cache converted distance. .AP char *string in -String that specifies a distance on the screen. +Same as \fIobjPtr\fR except specification of distance is passed as +a string. +.VE .AP int *intPtr out Pointer to location in which to store converted distance in pixels. .AP double *doublePtr out @@ -38,10 +54,16 @@ Pointer to location in which to store converted distance in millimeters. .SH DESCRIPTION .PP -These two procedures take as argument a specification of distance on -the screen (\fIstring\fR) and compute the corresponding distance -either in integer pixels or floating-point millimeters. -In either case, \fIstring\fR specifies a screen distance as a +These procedures take as argument a specification of distance on +.VS 8.1 +the screen (\fIobjPtr\fR or \fIstring\fR) and compute the +.VE +corresponding distance either in integer pixels or floating-point millimeters. +In either case, +.VS 8.1 +\fIobjPtr\fR or \fIstring\fR +.VE +specifies a screen distance as a floating-point number followed by one of the following characters that indicates units: .TP @@ -61,16 +83,29 @@ The number specifies a distance in millimeters on the screen. The number specifies a distance in printer's points (1/72 inch) on the screen. .PP -\fBTk_GetPixels\fR converts \fIstring\fR to the nearest even -number of pixels and stores that value at \fI*intPtr\fR. -\fBTk_GetScreenMM\fR converts \fIstring\fR to millimeters and -stores the double-precision floating-point result at \fI*doublePtr\fR. -.PP -Both procedures return \fBTCL_OK\fR under normal circumstances. -If an error occurs (e.g. \fIstring\fR contains a number followed +.VS 8.1 +\fBTk_GetPixelsFromObj\fR converts the value of \fIobjPtr\fR to the +nearest even number of pixels and stores that value at \fI*intPtr\fR. +It returns \fBTCL_OK\fR under normal circumstances. +If an error occurs (e.g. \fIobjPtr\fR contains a number followed by a character that isn't one of the ones above) then \fBTCL_ERROR\fR is returned and an error message is left -in \fIinterp->result\fR. +in \fIinterp\fR's result if \fIinterp\fR isn't NULL. +\fBTk_GetPixelsFromObj\fR caches information about the return +value in \fIobjPtr\fR, which speeds up future calls to +\fBTk_GetPixelsFromObj\fR with the same \fIobjPtr\fR. +.PP +\fBTk_GetPixels\fR is identical to \fBTk_GetPixelsFromObj\fR except +that the screen distance is specified with a string instead +of an object. This prevents \fBTk_GetPixels\fR from caching the +return value, so \fBTk_GetAnchor\fR is less efficient than +\fBTk_GetPixelsFromObj\fR. +.PP +\fBTk_GetMMFromObj\fR and \fBTk_GetScreenMM\fR are similar to +\fBTk_GetPixelsFromObj\fR and \fBTk_GetPixels\fR (respectively) except +that they convert the screen distance to millimeters and +store a double-precision floating-point result at \fI*doublePtr\fR. +.VE .SH KEYWORDS centimeters, convert, inches, millimeters, pixels, points, screen units diff --git a/doc/GetRelief.3 b/doc/GetRelief.3 index d0eade4..37a7cb9 100644 --- a/doc/GetRelief.3 +++ b/doc/GetRelief.3 @@ -1,21 +1,26 @@ '\" '\" Copyright (c) 1990 The Regents of the University of California. -'\" Copyright (c) 1994-1996 Sun Microsystems, Inc. +'\" Copyright (c) 1994-1998 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" SCCS: @(#) GetRelief.3 1.11 96/11/17 14:54:49 +'\" SCCS: @(#) GetRelief.3 1.12 98/01/14 13:59:01 '\" .so man.macros -.TH Tk_GetRelief 3 "" Tk "Tk Library Procedures" +.TH Tk_GetReliefFromObj 3 8.1 Tk "Tk Library Procedures" .BS .SH NAME -Tk_GetRelief, Tk_NameOfRelief \- translate between strings and relief values +Tk_GetReliefFromObj, Tk_GetRelief, Tk_NameOfRelief \- translate between strings and relief values .SH SYNOPSIS .nf \fB#include <tk.h>\fR .sp +.VS 8.1 +int +\fBTk_GetReliefFromObj(\fIinterp, objPtr, reliefPtr\fB)\fR +.VE +.sp int \fBTk_GetRelief(\fIinterp, name, reliefPtr\fB)\fR .sp @@ -25,12 +30,18 @@ char * .AS "Tcl_Interp" *reliefPtr .AP Tcl_Interp *interp in Interpreter to use for error reporting. -.AP char *name in -String containing relief name (one of ``flat'', ``groove'', -``raised'', ``ridge'', ``solid'', or ``sunken''). +.VS 8.1 br +.AP Tcl_Obj *objPtr in/out +String value contains name of relief (one of \fBflat\fR, \fBgroove\fR, +\fBraised\fR, \fBridge\fR, \fBsolid\fR, or \fBsunken\fR); +internal rep will be modified to cache corresponding relief value. +.AP char *string in +Same as \fIobjPtr\fR except description of relief is passed as +a string. +.VE .AP int *reliefPtr out Pointer to location in which to store relief value corresponding to -\fIname\fR. +\fIobjPtr\fR or \fIname\fR. .AP int relief in Relief value (one of TK_RELIEF_FLAT, TK_RELIEF_RAISED, TK_RELIEF_SUNKEN, TK_RELIEF_GROOVE, TK_RELIEF_SOLID, or TK_RELIEF_RIDGE). @@ -38,20 +49,31 @@ TK_RELIEF_GROOVE, TK_RELIEF_SOLID, or TK_RELIEF_RIDGE). .SH DESCRIPTION .PP -\fBTk_GetRelief\fR places in \fI*reliefPtr\fR the relief value -corresponding to \fIname\fR. This value will be one of +.VS 8.1 +\fBTk_GetReliefFromObj\fR places in \fI*reliefPtr\fR the relief value +corresponding to the value of \fIobjPtr\fR. This value will be one of TK_RELIEF_FLAT, TK_RELIEF_RAISED, TK_RELIEF_SUNKEN, TK_RELIEF_GROOVE, TK_RELIEF_SOLID, or TK_RELIEF_RIDGE. Under normal circumstances the return value is TCL_OK and \fIinterp\fR is unused. -If \fIname\fR doesn't contain one of the valid relief names -or an abbreviation of one of them, then an error message -is stored in \fIinterp->result\fR, -TCL_ERROR is returned, and \fI*reliefPtr\fR is unmodified. +If \fIobjPtr\fR doesn't contain one of the valid relief names +or an abbreviation of one of them, then TCL_ERROR is returned, +\fI*reliefPtr\fR is unmodified, and an error message +is stored in \fIinterp\fR's result if \fIinterp\fR isn't NULL. +\fBTk_GetReliefFromObj\fR caches information about the return +value in \fIobjPtr\fR, which speeds up future calls to +\fBTk_GetReliefFromObj\fR with the same \fIobjPtr\fR. +.PP +\fBTk_GetRelief\fR is identical to \fBTk_GetReliefFromObj\fR except +that the description of the relief is specified with a string instead +of an object. This prevents \fBTk_GetRelief\fR from caching the +return value, so \fBTk_GetRelief\fR is less efficient than +\fBTk_GetReliefFromObj\fR. +.VE .PP \fBTk_NameOfRelief\fR is the logical inverse of \fBTk_GetRelief\fR. -Given a relief value it returns the corresponding string (``flat'', -``raised'', ``sunken'', ``groove'', ``solid'', or ``ridge''). +Given a relief value it returns the corresponding string (\fBflat\fR, +\fBraised\fR, \fBsunken\fR, \fBgroove\fR, \fBsolid\fR, or \fBridge\fR). If \fIrelief\fR isn't a legal relief value, then ``unknown relief'' is returned. diff --git a/doc/SetOptions.3 b/doc/SetOptions.3 new file mode 100644 index 0000000..a734395 --- /dev/null +++ b/doc/SetOptions.3 @@ -0,0 +1,502 @@ +'\" +'\" Copyright (c) 1998 Sun Microsystems, Inc. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" SCCS: @(#) SetOptions.3 1.6 98/01/10 15:33:01 +'\" +.so man.macros +.TH Tk_SetOptions 3 8.1 Tk "Tk Library Procedures" +.BS +.SH NAME +Tk_CreateOptionTable, Tk_DeleteOptionTable, Tk_InitOptions, Tk_SetOptions, Tk_FreeSavedOptions, Tk_RestoreSavedOptions, Tk_GetOptionValue, Tk_GetOptionInfo, Tk_FreeConfigOptions, Tk_Offset \- process configuration options +.SH SYNOPSIS +.nf +\fB#include <tk.h>\fR +.sp +Tk_OptionTable +\fBTk_CreateOptionTable(\fIinterp, templatePtr\fB)\fR +.sp +\fBTk_DeleteOptionTable(\fIoptionTable\fB)\fR +.sp +int +\fBTk_InitOptions(\fIinterp, recordPtr, optionTable, tkwin\fB)\fR +.sp +int +\fBTk_SetOptions(\fIinterp, recordPtr, optionTable, objc, objv, tkwin, savePtr, maskPtr\fB)\fR +.sp +\fBTk_FreeSavedOptions(\fIsavedPtr\fB)\fR +.sp +\fBTk_RestoreSavedOptions(\fIsavedPtr\fB)\fR +.sp +Tcl_Obj * +\fBTk_GetOptionValue(\fIinterp, recordPtr, optionTable, namePtr, tkwin\fB)\fR +.sp +Tcl_Obj * +\fBTk_GetOptionInfo(\fIinterp, recordPtr, optionTable, namePtr, tkwin\fB)\fR +.sp +\fBTk_FreeConfigOptions(\fIrecordPtr, optionTable, tkwin\fB)\fR +.sp +int +\fBTk_Offset(\fItype, field\fB)\fR +.SH ARGUMENTS +.AS Tk_SavedOptions "*CONST objv[]" in/out +.AP Tcl_Interp *interp in +A Tcl interpreter. Most procedures use this only for returning error +messages; if it is NULL then no error messages are returned. For +\fBTk_CreateOptionTable\fR the value cannot be NULL; it gives the +interpreter in which the option table will be used. +.AP Tk_OptionSpec *templatePtr in +Points to an array of static information that describes the configuration +options that are supported. Used to build a Tk_OptionTable. The information +pointed to by this argument must exist for the lifetime of the Tk_OptionTable. +.AP Tk_OptionTable optionTable in +Token for an option table. Must have been returned by a previous call +to \fBTk_CreateOptionTable\fR. +.AP char *recordPtr in/out +Points to structure in which values of configuration options are stored; +fields of this record are modified by procedures such as \fBTk_SetOptions\fR +and read by procedures such as \fBTk_GetOptionValue\fR. +.AP Tk_Window tkwin in +For options such as TK_OPTION_COLOR, this argument indicates +the window in which the option will be used. If \fIoptionTable\fR uses +no window-dependent options, then a NULL value may be supplied for +this argument. +.AP int objc in +Number of values in \fIobjv\fR. +.AP Tcl_Obj "*CONST objv[]" in +Command-line arguments for setting configuring options. +.AP Tk_SavedOptions *savePtr out +If not NULL, the structure pointed to by this argument is filled +in with the old values of any options that were modified and old +values are restored automatically if an error occurs in \fBTk_SetOptions\fR. +.AP int *maskPtr out +If not NULL, the word pointed to by \fImaskPtr\fR is filled in with the +bit-wise OR of the \fItypeMask\fR fields for the options that +were modified. +.AP Tk_SavedOptions *savedPtr in/out +Points to a structure previously filled in by \fBTk_SetOptions\fR with +old values of modified options. +.AP Tcl_Obj *namePtr in +The value of this object is the name of a particular option. If NULL +is passed to \fBTk_GetOptionInfo\fR then information is returned for +all options. Must not be NULL when \fBTk_GetOptionValue\fR is called. +.AP "type name" type in +The name of the type of a record. +.AP "field name" field in +The name of a field in records of type \fItype\fR. +.BE +.SH DESCRIPTION +.PP +These procedures handle most of the details of parsing configuration +options such as those for Tk widgets. Given a description of what +options are supported, these procedures handle all the details of +parsing options and storing their values into a C structure associated +with the widget or object. The procedures were designed primarily for +widgets in Tk, but they can also be used for other kinds of objects that +have configuration options. In the rest of this manual page ``widget'' will +be used to refer to the object whose options are being managed; in +practice the object may not actually be a widget. The term ``widget +record'' is used to refer to the C-level structure in +which information about a particular widget or object is stored. +.PP +Note: the easiest way to learn how to use these procedures is to +look at a working example. In Tk, the simplest example is the code +that implements the button family of widgets, which is an \fBtkButton.c\fR. +Other examples are in \fBtkSquare.c\fR and \fBtkMenu.c\fR. +.PP +In order to use these procedures, the code that implements the widget +must contain a static array of Tk_OptionSpec structures. This is a +template that describes the various options supported by that class of +widget; there is a separate template for each kind of widget. The +template contains information such as the name of each option, its type, +its default value, and where the value of the option is stored in the +widget record. See TEMPLATES below for more detail. +.PP +In order to process configuration options efficiently, the static +template must be augmented with additional information that is available +only at runtime. The procedure \fBTk_CreateOptionTable\fR creates this +dynamic information from the template and returns a Tk_OptionTable token +that describes both the static and dynamic information. All of the +other procedures, such as \fBTk_SetOptions\fR, take a Tk_OptionTable +token as argument. Typically, \fBTk_CreateOptionTable\fR is called the +first time that a widget of a particular class is created and the +resulting Tk_OptionTable is used in the future for all widgets of that +class. A Tk_OptionTable may be used only in a single interpreter, given +by the \fIinterp\fR argument to \fBTk_CreateOptionTable\fR. When an +option table is no longer needed \fBTk_DeleteOptionTable\fR should be +called to free all of its resources. All of the option tables +for a Tcl interpreter are freed automatically if the interpreter is deleted. +.PP +\fBTk_InitOptions\fR is invoked when a new widget is created to set +the default values for all of the widget's configuration options. +\fBTk_InitOptions\fR is passed a token for an option table (\fIoptionTable\fR) +and a pointer to a widget record (\fIrecordPtr\fR), which is the C +structure that holds information about this widget. \fBTk_InitOptions\fR +uses the information in the option table to +choose an appropriate default for each option, then it stores the default +value directly into the widget record, overwriting any information that +was already present in the widget record. \fBTk_InitOptions\fR normally +returns TCL_OK. If an error occurred while setting the default values +(e.g., because a default value was erroneous) then TCL_ERROR is returned +and an error message is left in \fIinterp\fR's result if \fIinterp\fR +isn't NULL. +.PP +\fBTk_SetOptions\fR is invoked to modify configuration options based +on information specified in a Tcl command. The command might be one that +creates a new widget, or a command that modifies options on an existing +widget. The \fIobjc\fR and \fIobjv\fR arguments describe the +values of the arguments from the Tcl command. \fIObjv\fR must contain +an even number of objects: the first object of each pair gives the name of +an option and the second object gives the new value for that option. +\fBTk_SetOptions\fR looks up each name in \fIoptionTable\fR, checks that +the new value of the option conforms to the type in \fIoptionTable\fR, +and stores the value of the option into the widget record given by +\fIrecordPtr\fR. \fBTk_SetOptions\fR normally returns TCL_OK. If +an error occurred (such as an unknown option name or an illegal option +value) then TCL_ERROR is returned and an error message is left in +\fIinterp\fR's result if \fIinterp\fR isn't NULL. +.PP +\fBTk_SetOptions\fR has two additional features. First, if the +\fImaskPtr\fR argument isn't NULL then it points to an integer +value that is filled in with information about the options that were +modified. For each option in the template passed to +\fBTk_CreateOptionTable\fR there is a \fItypeMask\fR field. The +bits of this field are defined by the code that implements the widget; +for example, each bit might correspond to a particular configuration option. +Alternatively, bits might be used functionally. For example, one bit might +be used for redisplay: all options that affect the widget's display, such +that changing the option requires the widget to be redisplayed, might have +that bit set. Another bit might indicate that the geometry of the widget +must be recomputed, and so on. \fBTk_SetOptions\fR OR's together the +\fItypeMask\fR fields from all the options that were modified and returns +this value at *\fImaskPtr\fR; the caller can then use this information +to optimize itself so that, for example, it doesn't redisplay the widget +if the modified options don't affect the widget's appearance. +.PP +The second additional feature of \fBTk_SetOptions\fR has to do with error +recovery. If an error occurs while processing configuration options, this +feature makes it possible to restore all the configuration options to their +previous values. Errors can occur either while processing options in +\fBTk_SetOptions\fR or later in the caller. In many cases the caller does +additional processing after \fBTk_SetOptions\fR returns; for example, it +might use an option value to set a trace on a variable and may detect +an error if the variable is an array instead of a scalar. Error recovery +is enabled by passing in a non-NULL value for the \fIsavePtr\fR argument +to \fBTk_SetOptions\fR; this should be a pointer to an uninitialized +Tk_SavedOptions structure on the caller's stack. \fBTk_SetOptions\fR +overwrites the structure pointed to by \fIsavePtr\fR with information +about the old values of any options modified by the procedure. +If \fBTk_SetOptions\fR returns successfully, the +caller uses the structure in one of two ways. If the caller completes +its processing of the new options without any errors, then it must pass +the structure to \fBTk_FreeSavedOptions\fR so that the old values can be +freed. If the caller detects an error in its processing of the new +options, then it should pass the structure to \fBTk_RestoreSavedOptions\fR, +which will copy the old values back into the widget record and free +the new values. +If \fBTk_SetOptions\fR detects an error then it automatically restores +any options that had already been modified and leaves *\fIsavePtr\fR in +an empty state: the caller need not call either \fBTk_FreeSavedOptions\fR or +\fBTk_RestoreSavedOptions\fR. +If the \fIsavePtr\fR argument to \fBTk_SetOptions\fR is NULL then +\fBTk_SetOptions\fR frees each old option value immediately when it sets a new +value for the option. In this case, if an error occurs in the third +option, the old values for the first two options cannot be restored. +.PP +\fBTk_GetOptionValue\fR returns the current value of a configuration option +for a particular widget. The \fInamePtr\fR argument contains the name of +an option; \fBTk_GetOptionValue\fR uses \fIoptionTable\fR +to lookup the option and extract its value from the widget record +pointed to by \fIrecordPtr\fR, then it returns an object containing +that value. If an error occurs (e.g., because \fInamePtr\fR contains an +unknown option name) then NULL is returned and an error message is left +in \fIinterp\fR's result unless \fIinterp\fR is NULL. +.PP +\fBTk_GetOptionInfo\fR returns information about configuration options in +a form suitable for \fBconfigure\fR widget commands. If the \fInamePtr\fR +argument is not NULL, it points to an object that gives the name of a +configuration option; \fBTk_GetOptionInfo\fR returns an object containing +a list with five elements, which are the name of the option, the name and +class used for the option in the option database, the default value for +the option, and the current value for the option. If the \fInamePtr\fR +argument is NULL, then \fBTk_GetOptionInfo\fR returns information about +all options in the form of a list of lists; each sublist describes one +option. Synonym options are handled differently depending on whether +\fInamePtr\fR is NULL: if \fInamePtr\fR is NULL then the sublist for +each synonym option has only two elements, which are the name of the +option and the name of the other option that it refers to; if \fInamePtr\fR +is non-NULL and names a synonym option then the object returned +is the five-element list +for the other option that the synonym refers to. If an error occurs +(e.g., because \fInamePtr\fR contains an unknown option name) then NULL +is returned and an error message is left in \fIinterp\fR's result unless +\fIinterp\fR is NULL. +.PP +\fBTk_FreeConfigOptions\fR must be invoked when a widget is deleted. +It frees all of the resources associated with any of the configuration +options defined in \fIrecordPtr\fR by \fIoptionTable\fR. +.PP +The \fBTk_Offset\fR macro is provided as a safe way of generating the +\fIobjOffset\fR and \fIinternalOffset\fR values for entries in +Tk_OptionSpec structures. It takes two arguments: the name of a type +of record, and the name of a field in that record. It returns the byte +offset of the named field in records of the given type. + +.SH "TEMPLATES" +.PP +The array of Tk_OptionSpec structures passed to \fBTk_CreateOptionTable\fR +via its \fItemplatePtr\fR argument describes the configuration options +supported by a particular class of widgets. Each structure specifies +one configuration option and has the following fields: +.CS +typedef struct { + Tk_OptionType \fItype\fR; + char *\fIoptionName\fR; + char *\fIdbName\fR; + char *\fIdbClass\fR; + char *\fIdefValue\fR; + int \fIobjOffset\fR; + int \fIinternalOffset\fR; + int \fIflags\fR; + ClientData \fIclientData\fR; + int \fItypeMask\fR; +} Tk_OptionSpec; +.CE +The \fItype\fR field indicates what kind of configuration option this is +(e.g. TK_OPTION_COLOR for a color value, or TK_OPTION_INT for +an integer value). \fIType\fR determines how the +value of the option is parsed (more on this below). +The \fIoptionName\fR field is a string such as \fB\-font\fR or \fB\-bg\fR; +it is the name used for the option in Tcl commands and passed to +procedures via the \fIobjc\fR or \fInamePtr\fR arguments. +The \fIdbName\fR and \fIdbClass\fR fields are used by \fBTk_InitOptions\fR +to look up a default value for this option in the option database; if +\fIdbName\fR is NULL then the option database is not used by +\fBTk_InitOptions\fR for this option. The \fIdefValue\fR field +specifies a default value for this configuration option if no +value is specified in the option database. The \fIobjOffset\fR and +\fIinternalOffset\fR fields indicate where to store the value of this +option in widget records (more on this below); values for the \fIobjOffset\fR +and \fIinternalOffset\fR fields should always be generated with the +\fBTk_Offset\fR macro. +The \fIflags\fR field contains additional information +to control the processing of this configuration option (see below +for details). +\fIClientData\fR provides additional type-specific data needed +by certain types. For instance, for TK_OPTION_COLOR types, +\fIclientData\fR is a string giving the default value to use on +monochrome displays. See the descriptions of the different types +below for details. +The last field, \fItypeMask\fR, is used by \fBTk_SetOptions\fR to +return information about which options were modified; see the description +of \fBTk_SetOptions\fR above for details. +.PP +When \fBTk_InitOptions\fR and \fBTk_SetOptions\fR store the value of an +option into the widget record, they can do it in either of two ways. +If the \fIobjOffset\fR field of the Tk_OptionSpec is greater than +or equal to zero, then the value of the option is stored as a +(Tcl_Obj *) at the location in the widget record given by \fIobjOffset\fR. +If the \fIinternalOffset\fR field of the Tk_OptionSpec is +greater than or equal to zero, then the value of the option is stored +in a type-specific internal form at the location in the widget record +given by \fIinternalOffset\fR. For example, if the option's type is +TK_OPTION_INT then the internal form is an integer. If the +\fIobjOffset\fR or \fIinternalOffset\fR field is negative then the +value is not stored in that form. At least one of the offsets must be +greater than or equal to zero. +.PP +The \fIflags\fR field consists of one or more bits ORed together. At +present only a single flag is supported: TK_OPTION_NULL_OK. If +this bit is set for an option then an empty string will be accepted as +the value for the option and the resulting internal form will be a +NULL pointer or \fBNone\fR, depending on the type of the option. +If the flag is not set then empty strings will result +in errors. +TK_OPTION_NULL_OK is typically used to allow a +feature to be turned off entirely, e.g. set a cursor value to +\fBNone\fR so that a window simply inherits its parent's cursor. +Not all option types support the TK_OPTION_NULL_OK +flag; for those that do, there is an explicit indication of that fact +in the descriptions below. +.PP +The \fItype\fR field of each Tk_OptionSpec structure determines +how to parse the value of that configuration option. The +legal value for \fItype\fR, and the corresponding actions, are +described below. If the type requires a \fItkwin\fR value to be +passed into procedures like \fBTk_SetOptions\fR, or if it uses +the \fIclientData\fR field of the Tk_OptionSpec, then it is indicated +explicitly; if not mentioned, the type requires neither \fItkwin\fR +nor \fIclientData\fR. +.TP +\fBTK_OPTION_ANCHOR\fR +The value must be a standard anchor position such as \fBne\fR or +\fBcenter\fR. The internal form is a Tk_Anchor value like the ones +returned by \fBTk_GetAnchorFromObj\fR. +.TP +\fBTK_OPTION_BITMAP\fR +The value must be a standard Tk bitmap name. The internal form is a +Pixmap token like the ones returned by \fBTk_AllocBitmapFromObj\fR. +This option type requires \fItkwin\fR to be supplied to procedures +such as \fBTk_SetOptions\fR, and it supports the TK_OPTION_NULL_OK flag. +.TP +\fBTK_OPTION_BOOLEAN\fR +The value must be a standard boolean value such as \fBtrue\fR or +\fBno\fR. The internal form is an integer with value 0 or 1. +.TP +\fBTK_OPTION_BORDER\fR +The value must be a standard color name such as \fBred\fR or \fB#ff8080\fR. +The internal form is a Tk_3DBorder token like the ones returned +by \fBTk_Alloc3DBorderFromObj\fR. +This option type requires \fItkwin\fR to be supplied to procedures +such as \fBTk_SetOptions\fR, and it supports the TK_OPTION_NULL_OK flag. +.TP +\fBTK_OPTION_COLOR\fR +The value must be a standard color name such as \fBred\fR or \fB#ff8080\fR. +The internal form is an (XColor *) token like the ones returned by +\fBTk_AllocColorFromObj\fR. +This option type requires \fItkwin\fR to be supplied to procedures +such as \fBTk_SetOptions\fR, and it supports the TK_OPTION_NULL_OK flag. +.TP +\fBTK_OPTION_CURSOR\fR +The value must be a standard cursor name such as \fBcross\fR or \fB@foo\fR. +The internal form is a Tk_Cursor token like the ones returned by +\fBTk_AllocCursorFromObj\fR. +This option type requires \fItkwin\fR to be supplied to procedures +such as \fBTk_SetOptions\fR, and when the option is set the cursor +for the window is changed by calling \fBXDefineCursor\fR. This +option type also supports the TK_OPTION_NULL_OK flag. +.TP +\fBTK_OPTION_DOUBLE\fR +The string value must be a floating-point number in +the format accepted by \fBstrtol\fR. The internal form is a C +\fBdouble\fR value. +.TP +\fBTK_OPTION_END\fR +Marks the end of the template. There must be a Tk_OptionSpec structure +with \fItype\fR TK_OPTION_END at the end of each template. If the +\fIclientData\fR field of this structure isn't NULL, then it points to +an additional array of Tk_OptionSpec's, which is itself terminated by +another TK_OPTION_END entry. Templates may be chained arbitrarily +deeply. This feature allows common options to be shared by several +widget classes. +.TP +\fBTK_OPTION_FONT\fR +The value must be a standard font name such as \fBTimes 16\fR. +The internal form is a Tk_Font handle like the ones returned by +\fBTk_AllocFontFromObj\fR. +This option type requires \fItkwin\fR to be supplied to procedures +such as \fBTk_SetOptions\fR, and it supports the TK_OPTION_NULL_OK flag. +.TP +\fBTK_OPTION_INT\fR +The string value must be an integer in the format accepted by +\fBstrtol\fR (e.g. \fB0\fR and \fB0x\fR prefixes may be used to +specify octal or hexadecimal numbers, respectively). The internal +form is a C \fBint\fR value. +.TP +\fBTK_OPTION_JUSTIFY\fR +The value must be a standard justification value such as \fBleft\fR. +The internal form is a Tk_Justify like the values returned by +\fBTk_GetJustifyFromObj\fR. +.TP +\fBTK_OPTION_PIXELS\fR +The value must specify a screen distance such as \fB2i\fR or \fB6.4\fR. +The internal form is an integer value giving a +distance in pixels, like the values returned by +\fBTk_GetPixelsFromObj\fR. Note: if the \fIobjOffset\fR field isn't +used then information about the original value of this option will be lost. +See \fBOBJOFFSET VS. INTERNALOFFSET\fR below for details. +.TP +\fBTK_OPTION_RELIEF\fR +The value must be standard relief such as \fBraised\fR. +The internal form is an integer relief value such as +TK_RELIEF_RAISED. +.TP +\fBTK_OPTION_STRING\fR +The value may be any string. The internal form is a (char *) pointer +that points to a dynamically allocated copy of the value. +This option type supports the TK_OPTION_NULL_OK flag. +.TP +\fBTK_OPTION_STRING_TABLE\fR +For this type, \fIclientData\fR is a pointer to an array of strings +suitable for passing to \fBTcl_GetIndexFromObj\fR. The value must +be one of the strings in the table, or a unique abbreviation of +one of the strings. The internal form is an integer giving the index +into the table of the matching string, like the return value +from \fBTcl_GetStringFromObj\fR. +.TP +\fBTK_OPTION_SYNONYM\fR +This type is used to provide alternative names for an option (for +example, \fB\-bg\fR is often used as a synonym for \fB\-background\fR). +The \fBclientData\fR field is a (char *) pointer that gives +the name of another option in the same table. Whenever the +synonym option is used, the information from the other option +will be used instead. +.TP +\fBTK_OPTION_WINDOW\fR +The value must be a window path name. The internal form is a +\fBTk_Window\fR token for the window. +This option type requires \fItkwin\fR to be supplied to procedures +such as \fBTk_SetOptions\fR (in order to identify the application), +and it supports the TK_OPTION_NULL_OK flag. + +.SH "STORAGE MANAGEMENT ISSUES" +.PP +If a field of a widget record has its offset stored in the \fIobjOffset\fR +or \fIinternalOffset\fR field of a Tk_OptionSpec structure then the +procedures described here will handle all of the storage allocation and +resource management issues associated with the field. When the value +of an option is changed, \fBTk_SetOptions\fR (or \fBTk_FreeSavedOptions\fR +will automatically free any resources associated with the old value, such as +Tk_Fonts for TK_OPTION_FONT options or dynamically allocated memory for +TK_OPTION_STRING options. For an option stored as an object using the +\fIobjOffset\fR field of a Tk_OptionSpec, the widget record shares the +object pointed to by the \fIobjv\fR value from the call to +\fBTk_SetOptions\fR. The reference count for this object is incremented +when a pointer to it is stored in the widget record and decremented when +the option is modified. When the widget is deleted +\fBTk_FreeConfigOptions\fR should be invoked; it will free the resources +associated with all options and decrement reference counts for any +objects. +.PP +However, the widget code is responsible for storing NULL or \fBNone\fR in +all pointer and token fields before invoking \fBTk_InitOptions\fR. +This is needed to allow proper cleanup in the rare case where +an error occurs in \fBTk_InitOptions\fR. + +.SH "OBJOFFSET VS. INTERNALOFFSET" +.PP +In most cases it is simplest to use the \fIinternalOffset\fR field of +a Tk_OptionSpec structure and not the \fIobjOffset\fR field. This +makes the internal form of the value immediately available to the +widget code so the value doesn't have to be extracted from an object +each time it is used. However, there are two cases where the +\fIobjOffset\fR field is useful. The first case is for +TK_OPTION_PIXELS options. In this case, the internal form is +an integer pixel value that is valid only for a particular screen. +If the value of the option is retrieved, it will be returned as a simple +number. For example, after the command \fB.b configure \-borderwidth 2m\fR, +the command \fB.b configure \-borderwidth\fR might return 7, which is the +integer pixel value corresponding to \fB2m\fR. Unfortunately, this loses +the original screen-independent value. Thus for TK_OPTION_PIXELS options +it is better to use the \fIobjOffset\fR field. In this case the original +value of the option is retained in the object and can be returned when +the option is retrieved. In most cases it is convenient to use the +\fIinternalOffset\fR field field as well, so that the integer value is +immediately available for use in the widget code (alternatively, +\fBTk_GetPixelsFromObj\fR can be used to extract the integer value from +the object whenever it is needed). Note: the problem of losing information +on retrievals exists only for TK_OPTION_PIXELS options. +.PP +The second reason to use the \fIobjOffset\fR field is in order to +implement new types of options not supported by these procedures. +To implement a new type of option, use TK_OPTION_STRING as +the type in the Tk_OptionSpec structure and set the \fIobjOffset\fR field +but not the \fIinternalOffset\fR field. Then, after calling +\fBTk_SetOptions\fR, convert the object to internal form yourself. + +.SH KEYWORDS +anchor, bitmap, boolean, border, color, configuration option, +cursor, double, font, integer, justify, +pixels, relief, screen distance, synonym diff --git a/doc/dde.n b/doc/dde.n new file mode 100644 index 0000000..1df6c87 --- /dev/null +++ b/doc/dde.n @@ -0,0 +1,100 @@ +'\" +'\" 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. +'\" +'\" SCCS: @(#) dde.n 1.3 98/01/28 12:48:08 +'\" +.so man.macros +.TH dde n 8.1 Tk "Tk Built-In Commands" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +dde \- Execute a Dynamic Data Exchange command +.SH SYNOPSIS +\fBdde ?\-async?\fR \fIcommand service topic \fR?\fIdata\fR? +.BE + +.SH DESCRIPTION +.PP +This command allows an application to send Dynamic Data Exchange (DDE) +command when running under Microsoft Windows. Dynamic Data Exchange is +a mechanism where applications can exchange raw data. Each DDE +transaction needs a \fIservice name\fR and a \fItopic\fR. Both the +\fIservice name\fR and \fItopic\fR are application defined; Tk uses +the service name \fBTk\fR, while the topic name is the name of the +interpreter given by \fBtk appname\fR. Other applications have their +own \fIservice names\fR and \fItopics\fR. For instance, Microsoft Excel +has the service name \fBExcel\fR. +.PP +The only option to the \fBsend\fR command is: +.TP +\fB\-async\fR +Requests asynchronous invocation. This is valid only for the +\fBexecute\fR subcommand. Normally, the \fBdde execute\fR subcommand +waits until the command completes, returning appropriate error +messages. When the \fB\-async\fR option is used, the command returns +immediately, and no error information is available. +.SH "DDE COMMANDS" +.PP +The following commands are a subset of the full Dynamic Data Exchange +set of commands. +.TP +\fBdde execute \fIservice topic data\fR +\fBdde execute\fR takes the \fIdata\fR and sends it to the server +indicated by \fIservice\fR with the topic indicated by +\fItopic\fR. Typically, \fIservice\fR is the name of an application, +and \fItopic\fR is a file to work on. The \fIdata\fR field is given +to the remote application. Typically, the application treats the +\fIdata\fR field as a script, and the script is run in the +application. The command returns an error if the script did not +run. If the \fB\-async\fR flag was used, the command +returns immediately with no error. +.TP +\fBdde request \fIservice topic item\fR +\fBdde request\fR is typically used to get the value of something; the +value of a cell in Microsoft Excel or the text of a selection in +Microsoft Word. \fIservice\fR is typically the name of an application, +\fItopic\fR is typically the name of the file, and \fIitem\fR is +application-specific. The command returns the value of \fIitem\fR as +defined in the application. +.TP +\fBdde services \fIservice topic\fR +\fBdde services\fR returns a list of service-topic pairs that +currently exist on the machine. If \fIservice\fR and \fItopic\fR are +both null strings ({}), then all service-topic pairs currently +available on the system are returned. If \fIservice\fR is null and +\fItopic\fR is not, then all services with the specified topic are +returned. If \fIservice\fR is not null and \fItopic\fR is, all topics +for a given service are returned. If both are not null, if that +service-topic pair currently exists, it is returned; otherwise, null +is returned. +.SH "DDE AND TK" +Tk always has a service name of "Tk". Each different interp of all +running Tk applications has a unique name. A list of running interps +can be retrieved using the \fBwinfo interps\fR command. A given +interp's name can be set with the \fBtk appname\fR. Each interp is +available as a DDE topic. So a \fBdde services Tk {}\fR command will +return a list of service-topic pairs, where each of the currently +running interps will be a topic. +.PP +When Tk processes a \fBdde execute\fR command, the data for the +execute is run as a script in the interp named by the topic of the +\fBdde execute\fR command. +.PP +When Tk processes a \fBdde request\fR command, it returns the value of +the variable given in the dde command in the context of the interp +named by the dde topic. Tk reserves the variable "$TK$EXECUTE$RESULT" +for internal use, and \fBdde request\fR commands for that variable +will give unpredictable results. +.PP +An external application which wishes to run a script in Tk should have +that script store its result in a variable, run the \fBdde execute\fR +command, and the run \fBdde request\fR to get the value of the +variable. +.SH KEYWORDS +application, dde, name, remote execution +.SH "SEE ALSO" +tk, winfo, send + diff --git a/doc/loadTk.n b/doc/loadTk.n index 16e3532..dbe7f86 100644 --- a/doc/loadTk.n +++ b/doc/loadTk.n @@ -4,7 +4,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" SCCS: @(#) loadTk.n 1.5 97/08/18 17:44:43 +'\" SCCS: @(#) loadTk.n 1.8 97/11/26 10:10:07 '\" .so man.macros .TH "Safe Tk" n 8.0 Tk "Tk Built-In Commands" @@ -13,7 +13,7 @@ .SH NAME loadTk \- Load Tk into a safe interpreter. .SH SYNOPSIS -\fB::safe::loadTk \fIslave\fR ?\fB\-use\fR \fIwindowId\fR? +\fB::safe::loadTk \fIslave\fR ?\fB\-use\fR \fIwindowId\fR? ?\fB\-display\fR \fIdisplayName\fR? .BE Safe Tk is based on Safe Tcl, which provides a mechanism @@ -31,9 +31,15 @@ The command returns the name of the safe interpreter. If \fB\-use\fR is specified, the window identified by the specified system dependent identifier \fIwindowId\fR is used to contain the \fB``.''\fR window of the safe interpreter; it can be any valid id, eventually -referencing a window belonging to another application. -Otherwise, a new toplevel window is created for the \fB``.''\fR window of -the safe interpreter. +referencing a window belonging to another application. As a convenience, +if the window you plan to use is a Tk Window of the application you +can use the window name (eg: \fB.x.y\fR) instead of its window Id +(\fB[winfo id .x.y]\fR). +When \fB\-use\fR is not specified, +a new toplevel window is created for the \fB``.''\fR window of +the safe interpreter. On X11 if you want the embedded window +to use another display than the default one, specify it with +\fB\-display\fR. See the \fBSECURITY ISSUES\fR section below for implementation details. .SH SECURITY ISSUES @@ -41,42 +47,26 @@ See the \fBSECURITY ISSUES\fR section below for implementation details. Please read the \fBsafe\fR manual page for Tcl to learn about the basic security considerations for Safe Tcl. .PP -Information in the safe interpreter should never be trusted for security -purposes. -However, because Tk initialization of the safe interpreter do use -local information, it is unsafe if the safe interpreter -could have gained control before Tk is loaded. -This will be fixed in an upcoming release, by making Tk initialization in a -safe interpreter use only information found in the interpreter's master -instead of relying on the (un)safe interpreter state. -.PP -You should therefore use \fBsafe::loadTk $slave\fR as soon as possible -after \fBsafe::interpCreate\fR and before any code is evaluated in the safe -interpreter. -The preferred sequence is: -.CS -set slave [::safe::loadTk [::safe::interpCreate]] -.CE -If you want to prevent safe interpreters from loading Tk entirely, you -should create the interpreter as follows: -.CS -::safe::interpCreate \-nostatics \-accesspath \fI{directories...}\fR -.CE -and you must also insure that the virtual access path \fIdirectories\fR for -the interpreter does not contain a dynamically loadable version of Tk. -.PP \fB::safe::loadTk\fR adds the value of \fBtk_library\fR taken from the master interpreter to the virtual access path of the safe interpreter so that auto-loading will work in the safe interpreter. -It also sets \fBenv(DISPLAY)\fR in the safe interpreter to the value of -\fBenv(DISPLAY)\fR in the master interpreter, if it exists. -Finally, it sets the slave's Tcl variable \fBargv\fR to \fB\-use\fR -\fIwindowId\fR in the safe interpreter. - +.PP +.PP +Tk initialization is now safe with respect to not trusting +the slave's state for startup. \fB::safe::loadTk\fR +registers the slave's name so +when the Tk initialization (\fBTk_SafeInit\fR) is called +and in turn calls the master's \fB::safe::InitTk\fR it will +return the desired \fBargv\fR equivalent (\fB\-use\fR +\fIwindowId\fR, correct \fB\-display\fR, etc...). +.PP When \fB\-use\fR is not used, the new toplevel created is specially decorated so the user is always aware that the user interface presented comes from a potentially unsafe code and can easily delete the corresponding interpreter. +.PP +On X11, conflicting \fB\-use\fR and \fB\-display\fR are likely +to generate a fatal X error. .SH "SEE ALSO" safe(n), interp(n), library(n), load(n), package(n), source(n), unknown(n) @@ -5,7 +5,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" SCCS: @(#) send.n 1.18 96/08/27 13:21:47 +'\" SCCS: @(#) send.n 1.19 97/07/07 16:53:29 '\" .so man.macros .TH send n 4.0 Tk "Tk Built-In Commands" @@ -70,8 +70,8 @@ command. .SH SECURITY .PP -The \fBsend\fR command is potentially a serious security loophole, -since any application that can connect to your X server can send +The \fBsend\fR command is potentially a serious security loophole. On Unix, +any application that can connect to your X server can send scripts to your applications. These incoming scripts can use Tcl to read and write your files and invoke subprocesses under your name. @@ -87,6 +87,15 @@ list of enabled hosts is empty. This means that applications cannot connect to your server unless they use some other form of authorization such as that provide by \fBxauth\fR. - +.VS +Under Windows, any application running on the current machine can send +Dynamic Data Exchange (DDE) commands which could read and write files and start +processes. Only the local machine can connect, however, so there are +no restrictions on which processes can connect. The \fBsend\fR command +uses DDE as its transport, and a \fBdde\fR command has been added to +Tk 8.0. +.VE .SH KEYWORDS -application, name, remote execution, security, send +.VS +application, dde, name, remote execution, security, send +.VE diff --git a/generic/prolog.ps b/generic/prolog.ps new file mode 100644 index 0000000..378d503 --- /dev/null +++ b/generic/prolog.ps @@ -0,0 +1,284 @@ +%%BeginProlog +50 dict begin + +% This is a standard prolog for Postscript generated by Tk's canvas +% widget. +% SCCS: @(#) prolog.ps 1.7 96/07/08 17:52:14 + +% The definitions below just define all of the variables used in +% any of the procedures here. This is needed for obscure reasons +% explained on p. 716 of the Postscript manual (Section H.2.7, +% "Initializing Variables," in the section on Encapsulated Postscript). + +/baseline 0 def +/stipimage 0 def +/height 0 def +/justify 0 def +/lineLength 0 def +/spacing 0 def +/stipple 0 def +/strings 0 def +/xoffset 0 def +/yoffset 0 def +/tmpstip null def + +% Define the array ISOLatin1Encoding (which specifies how characters are +% encoded for ISO-8859-1 fonts), if it isn't already present (Postscript +% level 2 is supposed to define it, but level 1 doesn't). + +systemdict /ISOLatin1Encoding known not { + /ISOLatin1Encoding [ + /space /space /space /space /space /space /space /space + /space /space /space /space /space /space /space /space + /space /space /space /space /space /space /space /space + /space /space /space /space /space /space /space /space + /space /exclam /quotedbl /numbersign /dollar /percent /ampersand + /quoteright + /parenleft /parenright /asterisk /plus /comma /minus /period /slash + /zero /one /two /three /four /five /six /seven + /eight /nine /colon /semicolon /less /equal /greater /question + /at /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 /bracketleft /backslash /bracketright /asciicircum /underscore + /quoteleft /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 /braceleft /bar /braceright /asciitilde /space + /space /space /space /space /space /space /space /space + /space /space /space /space /space /space /space /space + /dotlessi /grave /acute /circumflex /tilde /macron /breve /dotaccent + /dieresis /space /ring /cedilla /space /hungarumlaut /ogonek /caron + /space /exclamdown /cent /sterling /currency /yen /brokenbar /section + /dieresis /copyright /ordfeminine /guillemotleft /logicalnot /hyphen + /registered /macron + /degree /plusminus /twosuperior /threesuperior /acute /mu /paragraph + /periodcentered + /cedillar /onesuperior /ordmasculine /guillemotright /onequarter + /onehalf /threequarters /questiondown + /Agrave /Aacute /Acircumflex /Atilde /Adieresis /Aring /AE /Ccedilla + /Egrave /Eacute /Ecircumflex /Edieresis /Igrave /Iacute /Icircumflex + /Idieresis + /Eth /Ntilde /Ograve /Oacute /Ocircumflex /Otilde /Odieresis /multiply + /Oslash /Ugrave /Uacute /Ucircumflex /Udieresis /Yacute /Thorn + /germandbls + /agrave /aacute /acircumflex /atilde /adieresis /aring /ae /ccedilla + /egrave /eacute /ecircumflex /edieresis /igrave /iacute /icircumflex + /idieresis + /eth /ntilde /ograve /oacute /ocircumflex /otilde /odieresis /divide + /oslash /ugrave /uacute /ucircumflex /udieresis /yacute /thorn + /ydieresis + ] def +} if + +% font ISOEncode font +% This procedure changes the encoding of a font from the default +% Postscript encoding to ISOLatin1. It's typically invoked just +% before invoking "setfont". The body of this procedure comes from +% Section 5.6.1 of the Postscript book. + +/ISOEncode { + dup length dict begin + {1 index /FID ne {def} {pop pop} ifelse} forall + /Encoding ISOLatin1Encoding def + currentdict + end + + % I'm not sure why it's necessary to use "definefont" on this new + % font, but it seems to be important; just use the name "Temporary" + % for the font. + + /Temporary exch definefont +} bind def + +% StrokeClip +% +% This procedure converts the current path into a clip area under +% the assumption of stroking. It's a bit tricky because some Postscript +% interpreters get errors during strokepath for dashed lines. If +% this happens then turn off dashes and try again. + +/StrokeClip { + {strokepath} stopped { + (This Postscript printer gets limitcheck overflows when) = + (stippling dashed lines; lines will be printed solid instead.) = + [] 0 setdash strokepath} if + clip +} bind def + +% desiredSize EvenPixels closestSize +% +% The procedure below is used for stippling. Given the optimal size +% of a dot in a stipple pattern in the current user coordinate system, +% compute the closest size that is an exact multiple of the device's +% pixel size. This allows stipple patterns to be displayed without +% aliasing effects. + +/EvenPixels { + % Compute exact number of device pixels per stipple dot. + dup 0 matrix currentmatrix dtransform + dup mul exch dup mul add sqrt + + % Round to an integer, make sure the number is at least 1, and compute + % user coord distance corresponding to this. + dup round dup 1 lt {pop 1} if + exch div mul +} bind def + +% width height string StippleFill -- +% +% Given a path already set up and a clipping region generated from +% it, this procedure will fill the clipping region with a stipple +% pattern. "String" contains a proper image description of the +% stipple pattern and "width" and "height" give its dimensions. Each +% stipple dot is assumed to be about one unit across in the current +% user coordinate system. This procedure trashes the graphics state. + +/StippleFill { + % The following code is needed to work around a NeWSprint bug. + + /tmpstip 1 index def + + % Change the scaling so that one user unit in user coordinates + % corresponds to the size of one stipple dot. + 1 EvenPixels dup scale + + % Compute the bounding box occupied by the path (which is now + % the clipping region), and round the lower coordinates down + % to the nearest starting point for the stipple pattern. Be + % careful about negative numbers, since the rounding works + % differently on them. + + pathbbox + 4 2 roll + 5 index div dup 0 lt {1 sub} if cvi 5 index mul 4 1 roll + 6 index div dup 0 lt {1 sub} if cvi 6 index mul 3 2 roll + + % Stack now: width height string y1 y2 x1 x2 + % Below is a doubly-nested for loop to iterate across this area + % in units of the stipple pattern size, going up columns then + % across rows, blasting out a stipple-pattern-sized rectangle at + % each position + + 6 index exch { + 2 index 5 index 3 index { + % Stack now: width height string y1 y2 x y + + gsave + 1 index exch translate + 5 index 5 index true matrix tmpstip imagemask + grestore + } for + pop + } for + pop pop pop pop pop +} bind def + +% -- AdjustColor -- +% Given a color value already set for output by the caller, adjusts +% that value to a grayscale or mono value if requested by the CL +% variable. + +/AdjustColor { + CL 2 lt { + currentgray + CL 0 eq { + .5 lt {0} {1} ifelse + } if + setgray + } if +} bind def + +% x y strings spacing xoffset yoffset justify stipple DrawText -- +% This procedure does all of the real work of drawing text. The +% color and font must already have been set by the caller, and the +% following arguments must be on the stack: +% +% x, y - Coordinates at which to draw text. +% strings - An array of strings, one for each line of the text item, +% in order from top to bottom. +% spacing - Spacing between lines. +% xoffset - Horizontal offset for text bbox relative to x and y: 0 for +% nw/w/sw anchor, -0.5 for n/center/s, and -1.0 for ne/e/se. +% yoffset - Vertical offset for text bbox relative to x and y: 0 for +% nw/n/ne anchor, +0.5 for w/center/e, and +1.0 for sw/s/se. +% justify - 0 for left justification, 0.5 for center, 1 for right justify. +% stipple - Boolean value indicating whether or not text is to be +% drawn in stippled fashion. If text is stippled, +% procedure StippleText must have been defined to call +% StippleFill in the right way. +% +% Also, when this procedure is invoked, the color and font must already +% have been set for the text. + +/DrawText { + /stipple exch def + /justify exch def + /yoffset exch def + /xoffset exch def + /spacing exch def + /strings exch def + + % First scan through all of the text to find the widest line. + + /lineLength 0 def + strings { + stringwidth pop + dup lineLength gt {/lineLength exch def} {pop} ifelse + newpath + } forall + + % Compute the baseline offset and the actual font height. + + 0 0 moveto (TXygqPZ) false charpath + pathbbox dup /baseline exch def + exch pop exch sub /height exch def pop + newpath + + % Translate coordinates first so that the origin is at the upper-left + % corner of the text's bounding box. Remember that x and y for + % positioning are still on the stack. + + translate + lineLength xoffset mul + strings length 1 sub spacing mul height add yoffset mul translate + + % Now use the baseline and justification information to translate so + % that the origin is at the baseline and positioning point for the + % first line of text. + + justify lineLength mul baseline neg translate + + % Iterate over each of the lines to output it. For each line, + % compute its width again so it can be properly justified, then + % display it. + + strings { + dup stringwidth pop + justify neg mul 0 moveto + stipple { + + % The text is stippled, so turn it into a path and print + % by calling StippledText, which in turn calls StippleFill. + % Unfortunately, many Postscript interpreters will get + % overflow errors if we try to do the whole string at + % once, so do it a character at a time. + + gsave + /char (X) def + { + char 0 3 -1 roll put + currentpoint + gsave + char true charpath clip StippleText + grestore + char stringwidth translate + moveto + } forall + grestore + } {show} ifelse + 0 spacing neg translate + } forall +} bind def + +%%EndProlog diff --git a/generic/tk.h b/generic/tk.h index 3e470f0..ac48a9c 100644 --- a/generic/tk.h +++ b/generic/tk.h @@ -6,12 +6,12 @@ * * Copyright (c) 1989-1994 The Regents of the University of California. * Copyright (c) 1994 The Australian National University. - * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 1994-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tk.h 1.211 97/11/20 12:44:45 + * SCCS: @(#) tk.h 1.217 98/02/18 18:33:32 */ #ifndef _TK @@ -25,6 +25,7 @@ * win/makefile.bc * win/makefile.vc * library/tk.tcl + * README, win/README, unix/README, and mac/README * * The release level should be 0 for alpha, 1 for beta, and 2 for * final/patch. The release serial value is the number that follows the @@ -38,12 +39,12 @@ */ #define TK_MAJOR_VERSION 8 -#define TK_MINOR_VERSION 0 -#define TK_RELEASE_LEVEL 2 +#define TK_MINOR_VERSION 1 +#define TK_RELEASE_LEVEL 0 #define TK_RELEASE_SERIAL 2 -#define TK_VERSION "8.0" -#define TK_PATCH_LEVEL "8.0p2" +#define TK_VERSION "8.1" +#define TK_PATCH_LEVEL "8.1a2" /* * A special definition used to allow this header file to be included @@ -97,6 +98,7 @@ typedef struct Tk_ErrorHandler_ *Tk_ErrorHandler; typedef struct Tk_Font_ *Tk_Font; typedef struct Tk_Image__ *Tk_Image; typedef struct Tk_ImageMaster_ *Tk_ImageMaster; +typedef struct Tk_OptionTable_ *Tk_OptionTable; typedef struct Tk_TextLayout_ *Tk_TextLayout; typedef struct Tk_Window_ *Tk_Window; typedef struct Tk_3DBorder_ *Tk_3DBorder; @@ -108,54 +110,164 @@ typedef struct Tk_3DBorder_ *Tk_3DBorder; typedef char *Tk_Uid; /* - * Structure used to specify how to handle argv options. + * The enum below defines the valid types for Tk configuration options + * as implemented by Tk_InitOptions, Tk_SetOptions, etc. */ -typedef struct { - char *key; /* The key string that flags the option in the - * argv array. */ - int type; /* Indicates option type; see below. */ - char *src; /* Value to be used in setting dst; usage - * depends on type. */ - char *dst; /* Address of value to be modified; usage - * depends on type. */ - char *help; /* Documentation message describing this option. */ -} Tk_ArgvInfo; +typedef enum { + TK_OPTION_BOOLEAN, + TK_OPTION_INT, + TK_OPTION_DOUBLE, + TK_OPTION_STRING, + TK_OPTION_STRING_TABLE, + TK_OPTION_COLOR, + TK_OPTION_FONT, + TK_OPTION_BITMAP, + TK_OPTION_BORDER, + TK_OPTION_RELIEF, + TK_OPTION_CURSOR, + TK_OPTION_JUSTIFY, + TK_OPTION_ANCHOR, + TK_OPTION_SYNONYM, + TK_OPTION_PIXELS, + TK_OPTION_WINDOW, + TK_OPTION_END +} Tk_OptionType; /* - * Legal values for the type field of a Tk_ArgvInfo: see the user - * documentation for details. + * Structures of the following type are used by widgets to specify + * their configuration options. Typically each widget has a static + * array of these structures, where each element of the array describes + * a single configuration option. The array is passed to + * Tk_CreateOptionTable. */ -#define TK_ARGV_CONSTANT 15 -#define TK_ARGV_INT 16 -#define TK_ARGV_STRING 17 -#define TK_ARGV_UID 18 -#define TK_ARGV_REST 19 -#define TK_ARGV_FLOAT 20 -#define TK_ARGV_FUNC 21 -#define TK_ARGV_GENFUNC 22 -#define TK_ARGV_HELP 23 -#define TK_ARGV_CONST_OPTION 24 -#define TK_ARGV_OPTION_VALUE 25 -#define TK_ARGV_OPTION_NAME_VALUE 26 -#define TK_ARGV_END 27 +typedef struct Tk_OptionSpec { + Tk_OptionType type; /* Type of option, such as TK_OPTION_COLOR; + * see definitions above. Last option in + * table must have type TK_OPTION_END. */ + char *optionName; /* Name used to specify option in Tcl + * commands. */ + char *dbName; /* Name for option in option database. */ + char *dbClass; /* Class for option in database. */ + char *defValue; /* Default value for option if not specified + * in command line, the option database, + * or the system. */ + int objOffset; /* Where in record to store a Tcl_Obj * that + * holds the value of this option, specified + * as an offset in bytes from the start of + * the record. Use the Tk_Offset macro to + * generate values for this. -1 means don't + * store the Tcl_Obj in the record. */ + int internalOffset; /* Where in record to store the internal + * representation of the value of this option, + * such as an int or XColor *. This field + * is specified as an offset in bytes + * from the start of the record. Use the + * Tk_Offset macro to generate values for it. + * -1 means don't store the internal + * representation in the record. */ + int flags; /* Any combination of the values defined + * below. */ + ClientData clientData; /* An alternate place to put option-specific + * data. Used for the monochrome default value + * for colors, etc. */ + int typeMask; /* An arbitrary bit mask defined by the + * class manager; typically bits correspond + * to certain kinds of options such as all + * those that require a redisplay when they + * change. Tk_SetOptions returns the bit-wise + * OR of the typeMasks of all options that + * were changed. */ +} Tk_OptionSpec; /* - * Flag bits for passing to Tk_ParseArgv: + * Flag values for Tk_OptionSpec structures. These flags are shared by + * Tk_ConfigSpec structures, so be sure to coordinate any changes + * carefully. */ -#define TK_ARGV_NO_DEFAULTS 0x1 -#define TK_ARGV_NO_LEFTOVERS 0x2 -#define TK_ARGV_NO_ABBREV 0x4 -#define TK_ARGV_DONT_SKIP_FIRST_ARG 0x8 +#define TK_OPTION_NULL_OK 1 + +/* + * Macro to use to fill in "offset" fields of Tk_OptionSpecs. + * Computes number of bytes from beginning of structure to a + * given field. + */ + +#ifdef offsetof +#define Tk_Offset(type, field) ((int) offsetof(type, field)) +#else +#define Tk_Offset(type, field) ((int) ((char *) &((type *) 0)->field)) +#endif + +/* + * The following two structures are used for error handling. When + * configuration options are being modified, the old values are + * saved in a Tk_SavedOptions structure. If an error occurs, then the + * contents of the structure can be used to restore all of the old + * values. The contents of this structure are for the private use + * Tk. No-one outside Tk should ever read or write any of the fields + * of these structures. + */ + +typedef struct Tk_SavedOption { + struct TkOption *optionPtr; /* Points to information that describes + * the option. */ + Tcl_Obj *valuePtr; /* The old value of the option, in + * the form of a Tcl object; may be + * NULL if the value wasn't saved as + * an object. */ + double internalForm; /* The old value of the option, in + * some internal representation such + * as an int or (XColor *). Valid + * only if optionPtr->specPtr->objOffset + * is < 0. The space must be large + * enough to accommodate a double, a + * long, or a pointer; right now it + * looks like a double is big + * enough. Also, using a double + * guarantees that the field is + * properly aligned for storing large + * values. */ +} Tk_SavedOption; + +#ifdef TCL_MEM_DEBUG +# define TK_NUM_SAVED_OPTIONS 2 +#else +# define TK_NUM_SAVED_OPTIONS 20 +#endif + +typedef struct Tk_SavedOptions { + char *recordPtr; /* The data structure in which to + * restore configuration options. */ + Tk_Window tkwin; /* Window associated with recordPtr; + * needed to restore certain options. */ + int numItems; /* The number of valid items in + * items field. */ + Tk_SavedOption items[TK_NUM_SAVED_OPTIONS]; + /* Items used to hold old values. */ + struct Tk_SavedOptions *nextPtr; /* Points to next structure in list; + * needed if too many options changed + * to hold all the old values in a + * single structure. NULL means no + * more structures. */ +} Tk_SavedOptions; /* * Structure used to describe application-specific configuration * options: indicates procedures to call to parse an option and - * to return a text string describing an option. + * to return a text string describing an option. THESE ARE + * DEPRECATED; PLEASE USE THE NEW STRUCTURES LISTED ABOVE. */ +/* + * This is a temporary flag used while tkObjConfig and new widgets + * are in development. + */ + +#ifndef __NO_OLD_CONFIG + typedef int (Tk_OptionParseProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, Tk_Window tkwin, char *value, char *widgRec, int offset)); @@ -209,40 +321,15 @@ typedef struct Tk_ConfigSpec { * documentation for details. */ -#define TK_CONFIG_BOOLEAN 1 -#define TK_CONFIG_INT 2 -#define TK_CONFIG_DOUBLE 3 -#define TK_CONFIG_STRING 4 -#define TK_CONFIG_UID 5 -#define TK_CONFIG_COLOR 6 -#define TK_CONFIG_FONT 7 -#define TK_CONFIG_BITMAP 8 -#define TK_CONFIG_BORDER 9 -#define TK_CONFIG_RELIEF 10 -#define TK_CONFIG_CURSOR 11 -#define TK_CONFIG_ACTIVE_CURSOR 12 -#define TK_CONFIG_JUSTIFY 13 -#define TK_CONFIG_ANCHOR 14 -#define TK_CONFIG_SYNONYM 15 -#define TK_CONFIG_CAP_STYLE 16 -#define TK_CONFIG_JOIN_STYLE 17 -#define TK_CONFIG_PIXELS 18 -#define TK_CONFIG_MM 19 -#define TK_CONFIG_WINDOW 20 -#define TK_CONFIG_CUSTOM 21 -#define TK_CONFIG_END 22 - -/* - * Macro to use to fill in "offset" fields of Tk_ConfigInfos. - * Computes number of bytes from beginning of structure to a - * given field. - */ - -#ifdef offsetof -#define Tk_Offset(type, field) ((int) offsetof(type, field)) -#else -#define Tk_Offset(type, field) ((int) ((char *) &((type *) 0)->field)) -#endif +typedef enum { + TK_CONFIG_BOOLEAN, TK_CONFIG_INT, TK_CONFIG_DOUBLE, TK_CONFIG_STRING, + TK_CONFIG_UID, TK_CONFIG_COLOR, TK_CONFIG_FONT, TK_CONFIG_BITMAP, + TK_CONFIG_BORDER, TK_CONFIG_RELIEF, TK_CONFIG_CURSOR, + TK_CONFIG_ACTIVE_CURSOR, TK_CONFIG_JUSTIFY, TK_CONFIG_ANCHOR, + TK_CONFIG_SYNONYM, TK_CONFIG_CAP_STYLE, TK_CONFIG_JOIN_STYLE, + TK_CONFIG_PIXELS, TK_CONFIG_MM, TK_CONFIG_WINDOW, TK_CONFIG_CUSTOM, + TK_CONFIG_END +} Tk_ConfigTypes; /* * Possible values for flags argument to Tk_ConfigureWidget: @@ -251,18 +338,62 @@ typedef struct Tk_ConfigSpec { #define TK_CONFIG_ARGV_ONLY 1 /* - * Possible flag values for Tk_ConfigInfo structures. Any bits at + * Possible flag values for Tk_ConfigSpec structures. Any bits at * or above TK_CONFIG_USER_BIT may be used by clients for selecting * certain entries. Before changing any values here, coordinate with - * tkConfig.c (internal-use-only flags are defined there). + * tkOldConfig.c (internal-use-only flags are defined there). */ -#define TK_CONFIG_COLOR_ONLY 1 -#define TK_CONFIG_MONO_ONLY 2 -#define TK_CONFIG_NULL_OK 4 +#define TK_CONFIG_NULL_OK 1 +#define TK_CONFIG_COLOR_ONLY 2 +#define TK_CONFIG_MONO_ONLY 4 #define TK_CONFIG_DONT_SET_DEFAULT 8 #define TK_CONFIG_OPTION_SPECIFIED 0x10 #define TK_CONFIG_USER_BIT 0x100 +#endif /* __NO_OLD_CONFIG */ + +/* + * Structure used to specify how to handle argv options. + */ + +typedef struct { + char *key; /* The key string that flags the option in the + * argv array. */ + int type; /* Indicates option type; see below. */ + char *src; /* Value to be used in setting dst; usage + * depends on type. */ + char *dst; /* Address of value to be modified; usage + * depends on type. */ + char *help; /* Documentation message describing this option. */ +} Tk_ArgvInfo; + +/* + * Legal values for the type field of a Tk_ArgvInfo: see the user + * documentation for details. + */ + +#define TK_ARGV_CONSTANT 15 +#define TK_ARGV_INT 16 +#define TK_ARGV_STRING 17 +#define TK_ARGV_UID 18 +#define TK_ARGV_REST 19 +#define TK_ARGV_FLOAT 20 +#define TK_ARGV_FUNC 21 +#define TK_ARGV_GENFUNC 22 +#define TK_ARGV_HELP 23 +#define TK_ARGV_CONST_OPTION 24 +#define TK_ARGV_OPTION_VALUE 25 +#define TK_ARGV_OPTION_NAME_VALUE 26 +#define TK_ARGV_END 27 + +/* + * Flag bits for passing to Tk_ParseArgv: + */ + +#define TK_ARGV_NO_DEFAULTS 0x1 +#define TK_ARGV_NO_LEFTOVERS 0x2 +#define TK_ARGV_NO_ABBREV 0x4 +#define TK_ARGV_DONT_SKIP_FIRST_ARG 0x8 /* * Enumerated type for describing actions to be taken in response @@ -287,12 +418,12 @@ typedef enum { * Relief values returned by Tk_GetRelief: */ -#define TK_RELIEF_RAISED 1 -#define TK_RELIEF_FLAT 2 -#define TK_RELIEF_SUNKEN 4 -#define TK_RELIEF_GROOVE 8 -#define TK_RELIEF_RIDGE 16 -#define TK_RELIEF_SOLID 32 +#define TK_RELIEF_FLAT 0 +#define TK_RELIEF_GROOVE 1 +#define TK_RELIEF_RAISED 2 +#define TK_RELIEF_RIDGE 3 +#define TK_RELIEF_SOLID 4 +#define TK_RELIEF_SUNKEN 5 /* * "Which" argument values for Tk_3DBorderGC: @@ -715,6 +846,8 @@ typedef void Tk_ItemInsertProc _ANSI_ARGS_((Tk_Canvas canvas, typedef void Tk_ItemDCharsProc _ANSI_ARGS_((Tk_Canvas canvas, Tk_Item *itemPtr, int first, int last)); +#ifndef __NO_OLD_CONFIG + typedef struct Tk_ItemType { char *name; /* The name of this type of item, such * as "line". */ @@ -764,6 +897,8 @@ typedef struct Tk_ItemType { * a list. */ } Tk_ItemType; +#endif + /* * The following structure provides information about the selection and * the insertion cursor. It is needed by only a few items, such as @@ -782,16 +917,17 @@ typedef struct Tk_CanvasTextInfo { Tk_Item *selItemPtr; /* Pointer to selected item. NULL means * selection isn't in this canvas. * Writable by items. */ - int selectFirst; /* Index of first selected character. - * Writable by items. */ - int selectLast; /* Index of last selected character. - * Writable by items. */ + int selectFirst; /* Character index of first selected + * character. Writable by items. */ + int selectLast; /* Character index of last selected + * character. Writable by items. */ Tk_Item *anchorItemPtr; /* Item corresponding to "selectAnchor": * not necessarily selItemPtr. Read-only * to items. */ - int selectAnchor; /* Fixed end of selection (i.e. "select to" - * operation will use this as one end of the - * selection). Writable by items. */ + int selectAnchor; /* Character index of fixed end of + * selection (i.e. "select to" operation will + * use this as one end of the selection). + * Writable by items. */ Tk_3DBorder insertBorder; /* Used to draw vertical bar for insertion * cursor. Read-only to items. */ int insertWidth; /* Total width of insertion cursor. Read-only @@ -1043,6 +1179,16 @@ EXTERN void Tk_3DVerticalBevel _ANSI_ARGS_((Tk_Window tkwin, int relief)); EXTERN void Tk_AddOption _ANSI_ARGS_((Tk_Window tkwin, char *name, char *value, int priority)); +EXTERN Pixmap Tk_AllocBitmapFromObj _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, Tcl_Obj *objPtr)); +EXTERN Tk_3DBorder Tk_Alloc3DBorderFromObj _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, Tcl_Obj *objPtr)); +EXTERN XColor * Tk_AllocColorFromObj _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, Tcl_Obj *objPtr)); +EXTERN Tk_Cursor Tk_AllocCursorFromObj _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, Tcl_Obj *objPtr)); +EXTERN Tk_Font Tk_AllocFontFromObj _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, Tcl_Obj *objPtr)); EXTERN void Tk_BindEvent _ANSI_ARGS_((Tk_BindingTable bindingTable, XEvent *eventPtr, Tk_Window tkwin, int numObjects, ClientData *objectPtr)); @@ -1095,6 +1241,7 @@ EXTERN int Tk_ClipboardAppend _ANSI_ARGS_((Tcl_Interp *interp, char* buffer)); EXTERN int Tk_ClipboardClear _ANSI_ARGS_((Tcl_Interp *interp, Tk_Window tkwin)); +#ifndef __NO_OLD_CONFIG EXTERN int Tk_ConfigureInfo _ANSI_ARGS_((Tcl_Interp *interp, Tk_Window tkwin, Tk_ConfigSpec *specs, char *widgRec, char *argvName, int flags)); @@ -1105,6 +1252,7 @@ EXTERN int Tk_ConfigureWidget _ANSI_ARGS_((Tcl_Interp *interp, Tk_Window tkwin, Tk_ConfigSpec *specs, int argc, char **argv, char *widgRec, int flags)); +#endif EXTERN void Tk_ConfigureWindow _ANSI_ARGS_((Tk_Window tkwin, unsigned int valueMask, XWindowChanges *valuePtr)); EXTERN Tk_TextLayout Tk_ComputeTextLayout _ANSI_ARGS_((Tk_Font font, @@ -1127,7 +1275,11 @@ EXTERN void Tk_CreateGenericHandler _ANSI_ARGS_(( Tk_GenericProc *proc, ClientData clientData)); EXTERN void Tk_CreateImageType _ANSI_ARGS_(( Tk_ImageType *typePtr)); +#ifndef __NO_OLD_CONFIG EXTERN void Tk_CreateItemType _ANSI_ARGS_((Tk_ItemType *typePtr)); +#endif +EXTERN Tk_OptionTable Tk_CreateOptionTable _ANSI_ARGS_((Tcl_Interp *interp, + CONST Tk_OptionSpec *templatePtr)); EXTERN void Tk_CreatePhotoImageFormat _ANSI_ARGS_(( Tk_PhotoImageFormat *formatPtr)); EXTERN void Tk_CreateSelHandler _ANSI_ARGS_((Tk_Window tkwin, @@ -1160,6 +1312,8 @@ EXTERN void Tk_DeleteGenericHandler _ANSI_ARGS_(( Tk_GenericProc *proc, ClientData clientData)); EXTERN void Tk_DeleteImage _ANSI_ARGS_((Tcl_Interp *interp, char *name)); +EXTERN void Tk_DeleteOptionTable _ANSI_ARGS_(( + Tk_OptionTable optionTable)); EXTERN void Tk_DeleteSelHandler _ANSI_ARGS_((Tk_Window tkwin, Atom selection, Atom target)); EXTERN void Tk_DestroyWindow _ANSI_ARGS_((Tk_Window tkwin)); @@ -1195,18 +1349,34 @@ EXTERN Tk_PhotoHandle Tk_FindPhoto _ANSI_ARGS_((Tcl_Interp *interp, char *imageName)); EXTERN Font Tk_FontId _ANSI_ARGS_((Tk_Font font)); EXTERN void Tk_Free3DBorder _ANSI_ARGS_((Tk_3DBorder border)); +EXTERN void Tk_Free3DBorderFromObj _ANSI_ARGS_((Tk_Window tkwin, + Tcl_Obj *objPtr)); EXTERN void Tk_FreeBitmap _ANSI_ARGS_((Display *display, Pixmap bitmap)); +EXTERN void Tk_FreeBitmapFromObj _ANSI_ARGS_((Tk_Window tkwin, + Tcl_Obj *objPtr)); EXTERN void Tk_FreeColor _ANSI_ARGS_((XColor *colorPtr)); +EXTERN void Tk_FreeColorFromObj _ANSI_ARGS_((Tk_Window tkwin, + Tcl_Obj *objPtr)); EXTERN void Tk_FreeColormap _ANSI_ARGS_((Display *display, Colormap colormap)); +EXTERN void Tk_FreeConfigOptions _ANSI_ARGS_((char *recordPtr, + Tk_OptionTable optionToken, Tk_Window tkwin)); +EXTERN void Tk_FreeSavedOptions _ANSI_ARGS_(( + Tk_SavedOptions *savePtr)); EXTERN void Tk_FreeCursor _ANSI_ARGS_((Display *display, Tk_Cursor cursor)); -EXTERN void Tk_FreeFont _ANSI_ARGS_((Tk_Font)); +EXTERN void Tk_FreeCursorFromObj _ANSI_ARGS_((Tk_Window tkwin, + Tcl_Obj *objPtr)); +EXTERN void Tk_FreeFont _ANSI_ARGS_((Tk_Font tkfont)); +EXTERN void Tk_FreeFontFromObj _ANSI_ARGS_((Tk_Window tkwin, + Tcl_Obj *objPtr)); EXTERN void Tk_FreeGC _ANSI_ARGS_((Display *display, GC gc)); EXTERN void Tk_FreeImage _ANSI_ARGS_((Tk_Image image)); +#ifndef __NO_OLD_CONFIG EXTERN void Tk_FreeOptions _ANSI_ARGS_((Tk_ConfigSpec *specs, char *widgRec, Display *display, int needFlags)); +#endif EXTERN void Tk_FreePixmap _ANSI_ARGS_((Display *display, Pixmap pixmap)); EXTERN void Tk_FreeTextLayout _ANSI_ARGS_(( @@ -1217,41 +1387,58 @@ EXTERN GC Tk_GCForColor _ANSI_ARGS_((XColor *colorPtr, EXTERN void Tk_GeometryRequest _ANSI_ARGS_((Tk_Window tkwin, int reqWidth, int reqHeight)); EXTERN Tk_3DBorder Tk_Get3DBorder _ANSI_ARGS_((Tcl_Interp *interp, - Tk_Window tkwin, Tk_Uid colorName)); + Tk_Window tkwin, char *colorName)); +EXTERN Tk_3DBorder Tk_Get3DBorderFromObj _ANSI_ARGS_((Tk_Window tkwin, + Tcl_Obj *objPtr)); EXTERN void Tk_GetAllBindings _ANSI_ARGS_((Tcl_Interp *interp, Tk_BindingTable bindingTable, ClientData object)); EXTERN int Tk_GetAnchor _ANSI_ARGS_((Tcl_Interp *interp, char *string, Tk_Anchor *anchorPtr)); +EXTERN int Tk_GetAnchorFromObj _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr, Tk_Anchor *anchorPtr)); EXTERN char * Tk_GetAtomName _ANSI_ARGS_((Tk_Window tkwin, Atom atom)); EXTERN char * Tk_GetBinding _ANSI_ARGS_((Tcl_Interp *interp, Tk_BindingTable bindingTable, ClientData object, char *eventString)); EXTERN Pixmap Tk_GetBitmap _ANSI_ARGS_((Tcl_Interp *interp, - Tk_Window tkwin, Tk_Uid string)); + Tk_Window tkwin, char *string)); EXTERN Pixmap Tk_GetBitmapFromData _ANSI_ARGS_((Tcl_Interp *interp, Tk_Window tkwin, char *source, int width, int height)); +EXTERN Pixmap Tk_GetBitmapFromObj _ANSI_ARGS_((Tk_Window tkwin, + Tcl_Obj *objPtr)); EXTERN int Tk_GetCapStyle _ANSI_ARGS_((Tcl_Interp *interp, char *string, int *capPtr)); EXTERN XColor * Tk_GetColor _ANSI_ARGS_((Tcl_Interp *interp, - Tk_Window tkwin, Tk_Uid name)); + Tk_Window tkwin, char *name)); EXTERN XColor * Tk_GetColorByValue _ANSI_ARGS_((Tk_Window tkwin, XColor *colorPtr)); +EXTERN XColor * Tk_GetColorFromObj _ANSI_ARGS_((Tk_Window tkwin, + Tcl_Obj *objPtr)); EXTERN Colormap Tk_GetColormap _ANSI_ARGS_((Tcl_Interp *interp, Tk_Window tkwin, char *string)); EXTERN Tk_Cursor Tk_GetCursor _ANSI_ARGS_((Tcl_Interp *interp, - Tk_Window tkwin, Tk_Uid string)); + Tk_Window tkwin, char *string)); EXTERN Tk_Cursor Tk_GetCursorFromData _ANSI_ARGS_((Tcl_Interp *interp, Tk_Window tkwin, char *source, char *mask, int width, int height, int xHot, int yHot, Tk_Uid fg, Tk_Uid bg)); +EXTERN Tk_Cursor Tk_GetCursorFromObj _ANSI_ARGS_((Tk_Window tkwin, + Tcl_Obj *objPtr)); EXTERN Tk_Font Tk_GetFont _ANSI_ARGS_((Tcl_Interp *interp, Tk_Window tkwin, CONST char *string)); -EXTERN Tk_Font Tk_GetFontFromObj _ANSI_ARGS_((Tcl_Interp *interp, - Tk_Window tkwin, Tcl_Obj *objPtr)); +EXTERN Tk_Font Tk_GetFontFromObj _ANSI_ARGS_((Tk_Window tkwin, + Tcl_Obj *objPtr)); EXTERN void Tk_GetFontMetrics _ANSI_ARGS_((Tk_Font font, Tk_FontMetrics *fmPtr)); +EXTERN Tcl_Obj * Tk_GetOptionInfo _ANSI_ARGS_((Tcl_Interp *interp, + char *recordPtr, Tk_OptionTable optionTable, + Tcl_Obj *namePtr, Tk_Window tkwin)); +EXTERN Tcl_Obj * Tk_GetOptionValue _ANSI_ARGS_(( + Tcl_Interp *interp, char *recordPtr, + Tk_OptionTable optionTable, Tcl_Obj *namePtr, + Tk_Window tkwin)); EXTERN GC Tk_GetGC _ANSI_ARGS_((Tk_Window tkwin, unsigned long valueMask, XGCValues *valuePtr)); EXTERN Tk_Image Tk_GetImage _ANSI_ARGS_((Tcl_Interp *interp, @@ -1260,20 +1447,31 @@ EXTERN Tk_Image Tk_GetImage _ANSI_ARGS_((Tcl_Interp *interp, ClientData clientData)); EXTERN ClientData Tk_GetImageMasterData _ANSI_ARGS_ ((Tcl_Interp *interp, char *name, Tk_ImageType **typePtrPtr)); +#ifndef __NO_OLD_CONFIG EXTERN Tk_ItemType * Tk_GetItemTypes _ANSI_ARGS_((void)); +#endif EXTERN int Tk_GetJoinStyle _ANSI_ARGS_((Tcl_Interp *interp, char *string, int *joinPtr)); EXTERN int Tk_GetJustify _ANSI_ARGS_((Tcl_Interp *interp, char *string, Tk_Justify *justifyPtr)); +EXTERN int Tk_GetJustifyFromObj _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr, Tk_Justify *justifyPtr)); +EXTERN int Tk_GetMMFromObj _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, Tcl_Obj *objPtr, + double *doublePtr)); EXTERN int Tk_GetNumMainWindows _ANSI_ARGS_((void)); EXTERN Tk_Uid Tk_GetOption _ANSI_ARGS_((Tk_Window tkwin, char *name, char *className)); EXTERN int Tk_GetPixels _ANSI_ARGS_((Tcl_Interp *interp, Tk_Window tkwin, char *string, int *intPtr)); +EXTERN int Tk_GetPixelsFromObj _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, Tcl_Obj *objPtr, int *intPtr)); EXTERN Pixmap Tk_GetPixmap _ANSI_ARGS_((Display *display, Drawable d, int width, int height, int depth)); EXTERN int Tk_GetRelief _ANSI_ARGS_((Tcl_Interp *interp, char *name, int *reliefPtr)); +EXTERN int Tk_GetReliefFromObj _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr, int *resultPtr)); EXTERN void Tk_GetRootCoords _ANSI_ARGS_ ((Tk_Window tkwin, int *xPtr, int *yPtr)); EXTERN int Tk_GetScrollInfo _ANSI_ARGS_((Tcl_Interp *interp, @@ -1301,6 +1499,9 @@ EXTERN void Tk_ImageChanged _ANSI_ARGS_(( int width, int height, int imageWidth, int imageHeight)); EXTERN int Tk_Init _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN int Tk_InitOptions _ANSI_ARGS_(( + Tcl_Interp *interp, char *recordPtr, + Tk_OptionTable optionToken, Tk_Window tkwin)); EXTERN Atom Tk_InternAtom _ANSI_ARGS_((Tk_Window tkwin, char *name)); EXTERN int Tk_IntersectTextLayout _ANSI_ARGS_(( @@ -1376,6 +1577,8 @@ EXTERN void Tk_QueueWindowEvent _ANSI_ARGS_((XEvent *eventPtr, EXTERN void Tk_RedrawImage _ANSI_ARGS_((Tk_Image image, int imageX, int imageY, int width, int height, Drawable drawable, int drawableX, int drawableY)); +EXTERN void Tk_RestoreSavedOptions _ANSI_ARGS_(( + Tk_SavedOptions *savePtr)); EXTERN void Tk_ResizeWindow _ANSI_ARGS_((Tk_Window tkwin, int width, int height)); EXTERN int Tk_RestackWindow _ANSI_ARGS_((Tk_Window tkwin, @@ -1389,6 +1592,11 @@ EXTERN void Tk_SetBackgroundFromBorder _ANSI_ARGS_(( Tk_Window tkwin, Tk_3DBorder border)); EXTERN void Tk_SetClass _ANSI_ARGS_((Tk_Window tkwin, char *className)); +EXTERN int Tk_SetOptions _ANSI_ARGS_(( + Tcl_Interp *interp, char *recordPtr, + Tk_OptionTable optionTable, int objc, + Tcl_Obj *CONST objv[], Tk_Window tkwin, + Tk_SavedOptions *savePtr, int *maskPtr)); EXTERN void Tk_SetGrid _ANSI_ARGS_((Tk_Window tkwin, int reqWidth, int reqHeight, int gridWidth, int gridHeight)); @@ -1442,61 +1650,73 @@ EXTERN void Tk_UpdatePointer _ANSI_ARGS_((Tk_Window tkwin, EXTERN int Tk_AfterCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tk_BellCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_BellObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); EXTERN int Tk_BindCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); EXTERN int Tk_BindtagsCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tk_ButtonCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_ButtonObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); EXTERN int Tk_CanvasCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tk_CheckbuttonCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_CheckbuttonObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); EXTERN int Tk_ClipboardCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tk_ChooseColorCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tk_ChooseFontCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_ChooseColorObjCmd _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tk_ChooseDirectoryObjCmd _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tk_ChooseFontObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); EXTERN int Tk_DestroyCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); EXTERN int Tk_EntryCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tk_EventCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_EventObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); EXTERN int Tk_FileeventCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); EXTERN int Tk_FrameCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tk_FocusCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_FocusObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); EXTERN int Tk_FontObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +EXTERN int Tk_GetOpenFileObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +EXTERN int Tk_GetSaveFileObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tk_GetOpenFileCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tk_GetSaveFileCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); EXTERN int Tk_GrabCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); EXTERN int Tk_GridCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); EXTERN int Tk_ImageCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tk_LabelCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_LabelObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); EXTERN int Tk_ListboxCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); EXTERN int Tk_LowerCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tk_MenuCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); EXTERN int Tk_MenubuttonCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tk_MessageBoxCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_MessageBoxObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); EXTERN int Tk_MessageCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); EXTERN int Tk_OptionCmd _ANSI_ARGS_((ClientData clientData, @@ -1505,8 +1725,9 @@ EXTERN int Tk_PackCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); EXTERN int Tk_PlaceCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tk_RadiobuttonCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_RadiobuttonObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); EXTERN int Tk_RaiseCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); EXTERN int Tk_ScaleCmd _ANSI_ARGS_((ClientData clientData, @@ -1517,6 +1738,9 @@ EXTERN int Tk_SelectionCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); EXTERN int Tk_SendCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_SendObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); EXTERN int Tk_TextCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); EXTERN int Tk_TkObjCmd _ANSI_ARGS_((ClientData clientData, @@ -1526,8 +1750,9 @@ EXTERN int Tk_TkwaitCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); EXTERN int Tk_ToplevelCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tk_UpdateCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_UpdateObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); EXTERN int Tk_WinfoObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); diff --git a/generic/tk3d.c b/generic/tk3d.c index 53eec8b..36399cc 100644 --- a/generic/tk3d.c +++ b/generic/tk3d.c @@ -10,36 +10,162 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tk3d.c 1.60 97/01/13 17:23:10 + * SCCS: @(#) tk3d.c 1.67 97/12/24 15:50:00 */ -#include <tk3d.h> +#include "tk3d.h" /* - * Hash table to map from a border's values (color, etc.) to a - * Border structure for those values. + * Hash table to map from a string color name to a TkBorder structure + * that can be used to draw borders with that color. */ static Tcl_HashTable borderTable; -typedef struct { - Tk_Uid colorName; /* Color for border. */ - Colormap colormap; /* Colormap used for allocating border - * colors. */ - Screen *screen; /* Screen on which border will be drawn. */ -} BorderKey; static int initialized = 0; /* 0 means static structures haven't * been initialized yet. */ +/* + * The following table defines the string values for reliefs, which are + * used by Tk_GetReliefFromObj. + */ + +static char *reliefStrings[] = {"flat", "groove", "raised", "ridge", "solid", + "sunken", (char *) NULL}; /* * Forward declarations for procedures defined in this file: */ static void BorderInit _ANSI_ARGS_((void)); +static void DupBorderObjProc _ANSI_ARGS_((Tcl_Obj *srcObjPtr, + Tcl_Obj *dupObjPtr)); +static void FreeBorderObjProc _ANSI_ARGS_((Tcl_Obj *objPtr)); static int Intersect _ANSI_ARGS_((XPoint *a1Ptr, XPoint *a2Ptr, XPoint *b1Ptr, XPoint *b2Ptr, XPoint *iPtr)); +static void InitBorderObj _ANSI_ARGS_((Tcl_Obj *objPtr)); static void ShiftLine _ANSI_ARGS_((XPoint *p1Ptr, XPoint *p2Ptr, int distance, XPoint *p3Ptr)); + +/* + * The following structure defines the implementation of the "border" Tcl + * object, used for drawing. The border object remembers the hash table entry + * associated with a border. The actual allocation and deallocation of the + * border should be done by the configuration package when the border option + * is set. + */ + +static Tcl_ObjType borderObjType = { + "border", /* name */ + FreeBorderObjProc, /* freeIntRepProc */ + DupBorderObjProc, /* dupIntRepProc */ + NULL, /* updateStringProc */ + NULL /* setFromAnyProc */ +}; + +/* + *---------------------------------------------------------------------- + * + * Tk_AllocBorderFromObj -- + * + * Given a Tcl_Obj *, map the value to a corresponding + * Tk_3DBorder structure based on the tkwin given. + * + * Results: + * The return value is a token for a data structure describing a + * 3-D border. This token may be passed to procedures such as + * Tk_Draw3DRectangle and Tk_Free3DBorder. If an error prevented + * the border from being created then NULL is returned and an error + * message will be left in the interp's result. + * + * Side effects: + * The border is added to an internal database with a reference + * count. For each call to this procedure, there should eventually + * be a call to Tk_FreeBorderFromObj so that the database is + * cleaned up when borders aren't in use anymore. + * + *---------------------------------------------------------------------- + */ + +Tk_3DBorder +Tk_Alloc3DBorderFromObj(interp, tkwin, objPtr) + Tcl_Interp *interp; /* Interp for error results. */ + Tk_Window tkwin; /* Need the screen the border is used on.*/ + Tcl_Obj *objPtr; /* Object giving name of color for window + * background. */ +{ + TkBorder *borderPtr; + + if (objPtr->typePtr != &borderObjType) { + InitBorderObj(objPtr); + } + borderPtr = (TkBorder *) objPtr->internalRep.twoPtrValue.ptr1; + + /* + * If the object currently points to a TkBorder, see if it's the + * one we want. If so, increment its reference count and return. + */ + + if (borderPtr != NULL) { + if (borderPtr->resourceRefCount == 0) { + /* + * This is a stale reference: it refers to a border that's + * no longer in use. Clear the reference. + */ + + FreeBorderObjProc(objPtr); + borderPtr = NULL; + } else if ((Tk_Screen(tkwin) == borderPtr->screen) + && (Tk_Colormap(tkwin) == borderPtr->colormap)) { + borderPtr->resourceRefCount++; + return (Tk_3DBorder) borderPtr; + } + } + + /* + * The object didn't point to the border that we wanted. Search + * the list of borders with the same name to see if one of the + * others is the right one. + */ + + /* + * If the cached value is NULL, either the object type was not a + * color going in, or the object is a color type but had + * previously been freed. + * + * If the value is not NULL, the internal rep is the value + * of the color the last time this object was accessed. Check + * the screen and colormap of the last access, and if they + * match, we are done. + */ + + if (borderPtr != NULL) { + TkBorder *firstBorderPtr = + (TkBorder *) Tcl_GetHashValue(borderPtr->hashPtr); + FreeBorderObjProc(objPtr); + for (borderPtr = firstBorderPtr ; borderPtr != NULL; + borderPtr = borderPtr->nextPtr) { + if ((Tk_Screen(tkwin) == borderPtr->screen) + && (Tk_Colormap(tkwin) == borderPtr->colormap)) { + borderPtr->resourceRefCount++; + borderPtr->objRefCount++; + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) borderPtr; + return (Tk_3DBorder) borderPtr; + } + } + } + + /* + * Still no luck. Call Tk_Get3DBorder to allocate a new border. + */ + + borderPtr = (TkBorder *) Tk_Get3DBorder(interp, tkwin, + Tcl_GetString(objPtr)); + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) borderPtr; + if (borderPtr != NULL) { + borderPtr->objRefCount++; + } + return (Tk_3DBorder) borderPtr; +} /* *-------------------------------------------------------------- @@ -49,12 +175,11 @@ static void ShiftLine _ANSI_ARGS_((XPoint *p1Ptr, XPoint *p2Ptr, * Create a data structure for displaying a 3-D border. * * Results: - * The return value is a token for a data structure - * describing a 3-D border. This token may be passed - * to Tk_Draw3DRectangle and Tk_Free3DBorder. If an - * error prevented the border from being created then - * NULL is returned and an error message will be left - * in interp->result. + * The return value is a token for a data structure describing a + * 3-D border. This token may be passed to procedures such as + * Tk_Draw3DRectangle and Tk_Free3DBorder. If an error prevented + * the border from being created then NULL is returned and an error + * message will be left in the interp's result. * * Side effects: * Data structures, graphics contexts, etc. are allocated. @@ -69,70 +194,72 @@ Tk_Get3DBorder(interp, tkwin, colorName) Tcl_Interp *interp; /* Place to store an error message. */ Tk_Window tkwin; /* Token for window in which border will * be drawn. */ - Tk_Uid colorName; /* String giving name of color + char *colorName; /* String giving name of color * for window background. */ { - BorderKey key; Tcl_HashEntry *hashPtr; - register TkBorder *borderPtr; + TkBorder *borderPtr, *existingBorderPtr; int new; XGCValues gcValues; + XColor *bgColorPtr; if (!initialized) { BorderInit(); } - /* - * First, check to see if there's already a border that will work - * for this request. - */ - - key.colorName = colorName; - key.colormap = Tk_Colormap(tkwin); - key.screen = Tk_Screen(tkwin); - - hashPtr = Tcl_CreateHashEntry(&borderTable, (char *) &key, &new); + hashPtr = Tcl_CreateHashEntry(&borderTable, colorName, &new); if (!new) { - borderPtr = (TkBorder *) Tcl_GetHashValue(hashPtr); - borderPtr->refCount++; + existingBorderPtr = (TkBorder *) Tcl_GetHashValue(hashPtr); + for (borderPtr = existingBorderPtr; borderPtr != NULL; + borderPtr = borderPtr->nextPtr) { + if ((Tk_Screen(tkwin) == borderPtr->screen) + && (Tk_Colormap(tkwin) == borderPtr->colormap)) { + borderPtr->resourceRefCount++; + return (Tk_3DBorder) borderPtr; + } + } } else { - XColor *bgColorPtr; + existingBorderPtr = NULL; + } - /* - * No satisfactory border exists yet. Initialize a new one. - */ - - bgColorPtr = Tk_GetColor(interp, tkwin, colorName); - if (bgColorPtr == NULL) { + /* + * No satisfactory border exists yet. Initialize a new one. + */ + + bgColorPtr = Tk_GetColor(interp, tkwin, colorName); + if (bgColorPtr == NULL) { + if (new) { Tcl_DeleteHashEntry(hashPtr); - return NULL; } - - borderPtr = TkpGetBorder(); - borderPtr->screen = Tk_Screen(tkwin); - borderPtr->visual = Tk_Visual(tkwin); - borderPtr->depth = Tk_Depth(tkwin); - borderPtr->colormap = key.colormap; - borderPtr->refCount = 1; - borderPtr->bgColorPtr = bgColorPtr; - borderPtr->darkColorPtr = NULL; - borderPtr->lightColorPtr = NULL; - borderPtr->shadow = None; - borderPtr->bgGC = None; - borderPtr->darkGC = None; - borderPtr->lightGC = None; - borderPtr->hashPtr = hashPtr; - Tcl_SetHashValue(hashPtr, borderPtr); - - /* - * Create the information for displaying the background color, - * but delay the allocation of shadows until they are actually - * needed for drawing. - */ - - gcValues.foreground = borderPtr->bgColorPtr->pixel; - borderPtr->bgGC = Tk_GetGC(tkwin, GCForeground, &gcValues); + return NULL; } + + borderPtr = TkpGetBorder(); + borderPtr->screen = Tk_Screen(tkwin); + borderPtr->visual = Tk_Visual(tkwin); + borderPtr->depth = Tk_Depth(tkwin); + borderPtr->colormap = Tk_Colormap(tkwin); + borderPtr->resourceRefCount = 1; + borderPtr->objRefCount = 0; + borderPtr->bgColorPtr = bgColorPtr; + borderPtr->darkColorPtr = NULL; + borderPtr->lightColorPtr = NULL; + borderPtr->shadow = None; + borderPtr->bgGC = None; + borderPtr->darkGC = None; + borderPtr->lightGC = None; + borderPtr->hashPtr = hashPtr; + borderPtr->nextPtr = existingBorderPtr; + Tcl_SetHashValue(hashPtr, borderPtr); + + /* + * Create the information for displaying the background color, + * but delay the allocation of shadows until they are actually + * needed for drawing. + */ + + gcValues.foreground = borderPtr->bgColorPtr->pixel; + borderPtr->bgGC = Tk_GetGC(tkwin, GCForeground, &gcValues); return (Tk_3DBorder) borderPtr; } @@ -208,7 +335,7 @@ Tk_NameOf3DBorder(border) { TkBorder *borderPtr = (TkBorder *) border; - return ((BorderKey *) borderPtr->hashPtr->key.words)->colorName; + return borderPtr->hashPtr->key.string; } /* @@ -303,34 +430,51 @@ void Tk_Free3DBorder(border) Tk_3DBorder border; /* Token for border to be released. */ { - register TkBorder *borderPtr = (TkBorder *) border; + TkBorder *borderPtr = (TkBorder *) border; Display *display = DisplayOfScreen(borderPtr->screen); + TkBorder *prevPtr; - borderPtr->refCount--; - if (borderPtr->refCount == 0) { - TkpFreeBorder(borderPtr); - if (borderPtr->bgColorPtr != NULL) { - Tk_FreeColor(borderPtr->bgColorPtr); - } - if (borderPtr->darkColorPtr != NULL) { - Tk_FreeColor(borderPtr->darkColorPtr); - } - if (borderPtr->lightColorPtr != NULL) { - Tk_FreeColor(borderPtr->lightColorPtr); - } - if (borderPtr->shadow != None) { - Tk_FreeBitmap(display, borderPtr->shadow); - } - if (borderPtr->bgGC != None) { - Tk_FreeGC(display, borderPtr->bgGC); - } - if (borderPtr->darkGC != None) { - Tk_FreeGC(display, borderPtr->darkGC); + borderPtr->resourceRefCount--; + if (borderPtr->resourceRefCount > 0) { + return; + } + + prevPtr = (TkBorder *) Tcl_GetHashValue(borderPtr->hashPtr); + TkpFreeBorder(borderPtr); + if (borderPtr->bgColorPtr != NULL) { + Tk_FreeColor(borderPtr->bgColorPtr); + } + if (borderPtr->darkColorPtr != NULL) { + Tk_FreeColor(borderPtr->darkColorPtr); + } + if (borderPtr->lightColorPtr != NULL) { + Tk_FreeColor(borderPtr->lightColorPtr); + } + if (borderPtr->shadow != None) { + Tk_FreeBitmap(display, borderPtr->shadow); + } + if (borderPtr->bgGC != None) { + Tk_FreeGC(display, borderPtr->bgGC); + } + if (borderPtr->darkGC != None) { + Tk_FreeGC(display, borderPtr->darkGC); + } + if (borderPtr->lightGC != None) { + Tk_FreeGC(display, borderPtr->lightGC); + } + if (prevPtr == borderPtr) { + if (borderPtr->nextPtr == NULL) { + Tcl_DeleteHashEntry(borderPtr->hashPtr); + } else { + Tcl_SetHashValue(borderPtr->hashPtr, borderPtr->nextPtr); } - if (borderPtr->lightGC != None) { - Tk_FreeGC(display, borderPtr->lightGC); + } else { + while (prevPtr->nextPtr != borderPtr) { + prevPtr = prevPtr->nextPtr; } - Tcl_DeleteHashEntry(borderPtr->hashPtr); + prevPtr->nextPtr = borderPtr->nextPtr; + } + if (borderPtr->objRefCount == 0) { ckfree((char *) borderPtr); } } @@ -338,6 +482,105 @@ Tk_Free3DBorder(border) /* *---------------------------------------------------------------------- * + * Tk_Free3DBorderFromObj -- + * + * This procedure is called to release a border allocated by + * Tk_Alloc3DBorderFromObj. It does not throw away the Tcl_Obj *; + * it only gets rid of the hash table entry for this border + * and clears the cached value that is normally stored in the object. + * + * Results: + * None. + * + * Side effects: + * The reference count associated with the border represented by + * objPtr is decremented, and the border's resources are released + * to X if there are no remaining uses for it. + * + *---------------------------------------------------------------------- + */ + +void +Tk_Free3DBorderFromObj(tkwin, objPtr) + Tk_Window tkwin; /* The window this border lives in. Needed + * for the screen and colormap values. */ + Tcl_Obj *objPtr; /* The Tcl_Obj * to be freed. */ +{ + Tk_Free3DBorder(Tk_Get3DBorderFromObj(tkwin, objPtr)); +} + +/* + *--------------------------------------------------------------------------- + * + * FreeBorderObjProc -- + * + * This proc is called to release an object reference to a border. + * Called when the object's internal rep is released or when + * the cached borderPtr needs to be changed. + * + * Results: + * None. + * + * Side effects: + * The object reference count is decremented. When both it + * and the hash ref count go to zero, the border's resources + * are released. + * + *--------------------------------------------------------------------------- + */ + +static void +FreeBorderObjProc(objPtr) + Tcl_Obj *objPtr; /* The object we are releasing. */ +{ + TkBorder *borderPtr = (TkBorder *) objPtr->internalRep.twoPtrValue.ptr1; + + if (borderPtr != NULL) { + borderPtr->objRefCount--; + if ((borderPtr->objRefCount == 0) + && (borderPtr->resourceRefCount == 0)) { + ckfree((char *) borderPtr); + } + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) NULL; + } +} + +/* + *--------------------------------------------------------------------------- + * + * DupBorderObjProc -- + * + * When a cached border object is duplicated, this is called to + * update the internal reps. + * + * Results: + * None. + * + * Side effects: + * The border's objRefCount is incremented and the internal rep + * of the copy is set to point to it. + * + *--------------------------------------------------------------------------- + */ + +static void +DupBorderObjProc(srcObjPtr, dupObjPtr) + Tcl_Obj *srcObjPtr; /* The object we are copying from. */ + Tcl_Obj *dupObjPtr; /* The object we are copying to. */ +{ + TkBorder *borderPtr = (TkBorder *) srcObjPtr->internalRep.twoPtrValue.ptr1; + + dupObjPtr->typePtr = srcObjPtr->typePtr; + dupObjPtr->internalRep.twoPtrValue.ptr1 = (VOID *) borderPtr; + + if (borderPtr != NULL) { + borderPtr->objRefCount++; + } +} + +/* + *---------------------------------------------------------------------- + * * Tk_SetBackgroundFromBorder -- * * Change the background of a window to one appropriate for a given @@ -365,6 +608,35 @@ Tk_SetBackgroundFromBorder(tkwin, border) /* *---------------------------------------------------------------------- * + * Tk_GetReliefFromObj -- + * + * Return an integer value based on the value of the objPtr. + * + * Results: + * The return value is a standard Tcl result. If an error occurs during + * conversion, an error message is left in the interpreter's result + * unless "interp" is NULL. + * + * Side effects: + * The object gets converted by Tcl_GetIndexFromObj. + * + *---------------------------------------------------------------------- + */ + +int +Tk_GetReliefFromObj(interp, objPtr, resultPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Obj *objPtr; /* The object we are trying to get the + * value from. */ + int *resultPtr; /* Where to place the answer. */ +{ + return Tcl_GetIndexFromObj(interp, objPtr, reliefStrings, "relief", 0, + resultPtr); +} + +/* + *---------------------------------------------------------------------- + * * Tk_GetRelief -- * * Parse a relief description and return the corresponding @@ -407,8 +679,11 @@ Tk_GetRelief(interp, name, reliefPtr) } else if ((c == 's') && (strncmp(name, "sunken", length) == 0)) { *reliefPtr = TK_RELIEF_SUNKEN; } else { - sprintf(interp->result, "bad relief type \"%.50s\": must be %s", + char buf[200]; + + sprintf(buf, "bad relief type \"%.50s\": must be %s", name, "flat, groove, raised, ridge, solid, or sunken"); + Tcl_SetResult(interp, buf, TCL_VOLATILE); return TCL_ERROR; } return TCL_OK; @@ -785,7 +1060,7 @@ static void BorderInit() { initialized = 1; - Tcl_InitHashTable(&borderTable, sizeof(BorderKey)/sizeof(int)); + Tcl_InitHashTable(&borderTable, TCL_STRING_KEYS); } /* @@ -947,3 +1222,167 @@ Intersect(a1Ptr, a2Ptr, b1Ptr, b2Ptr, iPtr) } return 0; } + +/* + *---------------------------------------------------------------------- + * + * Tk_Get3DBorderFromObj -- + * + * Returns the border referred to by a Tcl object. The border must + * already have been allocated via a call to Tk_Alloc3DBorderFromObj + * or Tk_Get3DBorder. + * + * Results: + * Returns the Tk_3DBorder that matches the tkwin and the string rep + * of the name of the border given in objPtr. + * + * Side effects: + * If the object is not already a border, the conversion will free + * any old internal representation. + * + *---------------------------------------------------------------------- + */ + +Tk_3DBorder +Tk_Get3DBorderFromObj(tkwin, objPtr) + Tk_Window tkwin; + Tcl_Obj *objPtr; /* The object whose string value selects + * a border. */ +{ + TkBorder *borderPtr = NULL; + Tcl_HashEntry *hashPtr; + + if (objPtr->typePtr != &borderObjType) { + InitBorderObj(objPtr); + } + + borderPtr = (TkBorder *) objPtr->internalRep.twoPtrValue.ptr1; + if (borderPtr != NULL) { + if ((borderPtr->resourceRefCount > 0) + && (Tk_Screen(tkwin) == borderPtr->screen) + && (Tk_Colormap(tkwin) == borderPtr->colormap)) { + /* + * The object already points to the right border structure. + * Just return it. + */ + + return (Tk_3DBorder) borderPtr; + } + hashPtr = borderPtr->hashPtr; + FreeBorderObjProc(objPtr); + } else { + hashPtr = Tcl_FindHashEntry(&borderTable, Tcl_GetString(objPtr)); + if (hashPtr == NULL) { + goto error; + } + } + + /* + * At this point we've got a hash table entry, off of which hang + * one or more TkBorder structures. See if any of them will work. + */ + + for (borderPtr = (TkBorder *) Tcl_GetHashValue(hashPtr); + (borderPtr != NULL); borderPtr = borderPtr->nextPtr) { + if ((Tk_Screen(tkwin) == borderPtr->screen) + && (Tk_Colormap(tkwin) == borderPtr->colormap)) { + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) borderPtr; + borderPtr->objRefCount++; + return (Tk_3DBorder) borderPtr; + } + } + + error: + panic("Tk_Get3DBorderFromObj called with non-existent border!"); + /* + * The following code isn't reached; it's just there to please compilers. + */ + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * InitBorderObj -- + * + * Attempt to generate a border internal form for the Tcl object + * "objPtr". + * + * Results: + * The return value is a standard Tcl result. If an error occurs during + * conversion, an error message is left in the interpreter's result + * unless "interp" is NULL. + * + * Side effects: + * If no error occurs, a blank internal format for a border value + * is intialized. The final form cannot be done without a Tk_Window. + * + *---------------------------------------------------------------------- + */ + +static void +InitBorderObj(objPtr) + Tcl_Obj *objPtr; /* The object to convert. */ +{ + Tcl_ObjType *typePtr; + + /* + * Free the old internalRep before setting the new one. + */ + + Tcl_GetString(objPtr); + typePtr = objPtr->typePtr; + if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { + (*typePtr->freeIntRepProc)(objPtr); + } + objPtr->typePtr = &borderObjType; + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) NULL; +} + +/* + *---------------------------------------------------------------------- + * + * TkDebugBorder -- + * + * This procedure returns debugging information about a border. + * + * Results: + * The return value is a list with one sublist for each TkBorder + * corresponding to "name". Each sublist has two elements that + * contain the resourceRefCount and objRefCount fields from the + * TkBorder structure. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TkDebugBorder(tkwin, name) + Tk_Window tkwin; /* The window in which the border will be + * used (not currently used). */ + char *name; /* Name of the desired color. */ +{ + TkBorder *borderPtr; + Tcl_HashEntry *hashPtr; + Tcl_Obj *resultPtr, *objPtr; + + resultPtr = Tcl_NewObj(); + hashPtr = Tcl_FindHashEntry(&borderTable, name); + if (hashPtr != NULL) { + borderPtr = (TkBorder *) Tcl_GetHashValue(hashPtr); + if (borderPtr == NULL) { + panic("TkDebugBorder found empty hash table entry"); + } + for ( ; (borderPtr != NULL); borderPtr = borderPtr->nextPtr) { + objPtr = Tcl_NewObj(); + Tcl_ListObjAppendElement(NULL, objPtr, + Tcl_NewIntObj(borderPtr->resourceRefCount)); + Tcl_ListObjAppendElement(NULL, objPtr, + Tcl_NewIntObj(borderPtr->objRefCount)); + Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); + } + } + return resultPtr; +} diff --git a/generic/tk3d.h b/generic/tk3d.h index cd9ecd5..4e17eb3 100644 --- a/generic/tk3d.h +++ b/generic/tk3d.h @@ -4,12 +4,12 @@ * Declarations of types and functions shared by the 3d border * module. * - * Copyright (c) 1996 by Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tk3d.h 1.1 96/11/04 13:52:59 + * SCCS: @(#) tk3d.h 1.4 97/12/24 15:50:02 */ #ifndef _TK3D @@ -18,13 +18,13 @@ #include <tkInt.h> /* - * One of the following data structures is allocated for - * each 3-D border currently in use. Structures of this - * type are indexed by borderTable, so that a single - * structure can be shared for several uses. + * One of the following data structures is allocated for each 3-D border + * currently in use. Structures of this type are indexed by + * borderTable, so that a single structure can be shared for several + * uses. */ -typedef struct { +typedef struct TkBorder { Screen *screen; /* Screen on which the border will be used. */ Visual *visual; /* Visual for all windows and pixmaps using * the border. */ @@ -32,8 +32,18 @@ typedef struct { * the border will be used. */ Colormap colormap; /* Colormap out of which pixels are * allocated. */ - int refCount; /* Number of different users of - * this border. */ + int resourceRefCount; /* Number of active uses of this color (each + * active use corresponds to a call to + * Tk_Alloc3DBorderFromObj or Tk_Get3DBorder). + * If this count is 0, then this structure + * is no longer valid and it isn't present + * in borderTable: it is being kept around + * only because there are objects referring + * to it. The structure is freed when + * resourceRefCount and objRefCount are + * both 0. */ + int objRefCount; /* The number of Tcl objects that reference + * this structure. */ XColor *bgColorPtr; /* Background color (intensity * between lightColorPtr and * darkColorPtr). */ @@ -58,6 +68,11 @@ typedef struct { * haven't been allocated yet. */ Tcl_HashEntry *hashPtr; /* Entry in borderTable (needed in * order to delete structure). */ + struct TkBorder *nextPtr; /* Points to the next TkBorder structure with + * the same color name. Borders with the + * same name but different screens or + * colormaps are chained together off a + * single entry in borderTable. */ } TkBorder; diff --git a/generic/tkArgv.c b/generic/tkArgv.c index 5842687..66a703c 100644 --- a/generic/tkArgv.c +++ b/generic/tkArgv.c @@ -5,12 +5,12 @@ * argv-argc parsing. * * Copyright (c) 1990-1994 The Regents of the University of California. - * Copyright (c) 1994 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkArgv.c 1.21 97/04/25 16:50:27 + * SCCS: @(#) tkArgv.c 1.22 97/11/07 21:13:03 */ #include "tkPort.h" @@ -45,7 +45,7 @@ static void PrintUsage _ANSI_ARGS_((Tcl_Interp *interp, * * Results: * The return value is a standard Tcl return value. If an - * error occurs then an error message is left in interp->result. + * error occurs then an error message is left in the interp's result. * Under normal conditions, both *argcPtr and *argv are modified * to return the arguments that couldn't be processed here (they * didn't match the option table, or followed an TK_ARGV_REST @@ -291,10 +291,14 @@ Tk_ParseArgv(interp, tkwin, argcPtr, argv, argTable, flags) srcIndex += 2; argc -= 2; break; - default: - sprintf(interp->result, "bad argument type %d in Tk_ArgvInfo", + default: { + char buf[64 + TCL_INTEGER_SPACE]; + + sprintf(buf, "bad argument type %d in Tk_ArgvInfo", infoPtr->type); + Tcl_SetResult(interp, buf, TCL_VOLATILE); return TCL_ERROR; + } } } @@ -328,7 +332,7 @@ Tk_ParseArgv(interp, tkwin, argcPtr, argv, argTable, flags) * Generate a help string describing command-line options. * * Results: - * Interp->result will be modified to hold a help string + * The interp's result will be modified to hold a help string * describing all the options in argTable, plus all those * in the default table unless TK_ARGV_NO_DEFAULTS is * specified in flags. @@ -353,7 +357,7 @@ PrintUsage(interp, argTable, flags) int width, i, numSpaces; #define NUM_SPACES 20 static char spaces[] = " "; - char tmp[30]; + char tmp[TCL_DOUBLE_SPACE]; /* * First, compute the width of the widest option key, so that we diff --git a/generic/tkBind.c b/generic/tkBind.c index bb37b00..0aa0e9e 100644 --- a/generic/tkBind.c +++ b/generic/tkBind.c @@ -5,12 +5,12 @@ * with X events or sequences of X events. * * Copyright (c) 1989-1994 The Regents of the University of California. - * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkBind.c 1.133 97/07/01 17:59:53 + * SCCS: @(#) tkBind.c 1.144 98/02/18 17:08:07 */ #include "tkPort.h" @@ -571,6 +571,20 @@ static int flagArray[TK_LASTEVENT] = { }; /* + * The following table is used to map between the location where an + * generated event should be queued and the string used to specify the + * location. + */ + +static TkStateMap queuePosition[] = { + {-1, "now"}, + {TCL_QUEUE_HEAD, "head"}, + {TCL_QUEUE_MARK, "mark"}, + {TCL_QUEUE_TAIL, "tail"}, + {-2, NULL} +}; + +/* * The following tables are used as a two-way map between X's internal * numeric values for fields in an XEvent and the strings used in Tcl. The * tables are used both when constructing an XEvent from user input and @@ -644,7 +658,8 @@ static int GetVirtualEvent _ANSI_ARGS_((Tcl_Interp *interp, static Tk_Uid GetVirtualEventUid _ANSI_ARGS_((Tcl_Interp *interp, char *virtString)); static int HandleEventGenerate _ANSI_ARGS_((Tcl_Interp *interp, - Tk_Window main, int argc, char **argv)); + Tk_Window main, int objc, + Tcl_Obj *CONST objv[])); static void InitKeymapInfo _ANSI_ARGS_((TkDisplay *dispPtr)); static void InitVirtualEventTable _ANSI_ARGS_(( VirtualEventTable *vetPtr)); @@ -652,9 +667,14 @@ static PatSeq * MatchPatterns _ANSI_ARGS_((TkDisplay *dispPtr, BindingTable *bindPtr, PatSeq *psPtr, PatSeq *bestPtr, ClientData *objectPtr, PatSeq **sourcePtrPtr)); +static int NameToWindow _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window main, Tcl_Obj *objPtr, + Tk_Window *tkwinPtr)); static int ParseEventDescription _ANSI_ARGS_((Tcl_Interp *interp, char **eventStringPtr, Pattern *patPtr, unsigned long *eventMaskPtr)); +static void SetKeycodeAndState _ANSI_ARGS_((Tk_Window tkwin, + KeySym keySym, XEvent *eventPtr)); /* * The following define is used as a short circuit for the callback @@ -776,6 +796,7 @@ TkBindFree(mainPtr) bindInfoPtr = (BindInfo *) mainPtr->bindInfo; DeleteVirtualEventTable(&bindInfoPtr->virtualEventTable); + ckfree((char *) bindInfoPtr); mainPtr->bindInfo = NULL; } @@ -890,7 +911,7 @@ Tk_DeleteBindingTable(bindingTable) * Results: * The return value is 0 if an error occurred while setting * up the binding. In this case, an error message will be - * left in interp->result. If all went well then the return + * left in the interp's result. If all went well then the return * value is a mask of the event types that must be made * available to Tk_BindEvent in order to properly detect when * this binding triggers. This value can be used to determine @@ -995,7 +1016,7 @@ Tk_CreateBinding(interp, bindingTable, object, eventString, command, append) * Results: * The return value is 0 if an error occurred while setting * up the binding. In this case, an error message will be - * left in interp->result. If all went well then the return + * left in the interp's result. If all went well then the return * value is a mask of the event types that must be made * available to Tk_BindEvent in order to properly detect when * this binding triggers. This value can be used to determine @@ -1079,7 +1100,7 @@ TkCreateBindingProcedure(interp, bindingTable, object, eventString, * * Results: * The result is a standard Tcl return value. If an error - * occurs then interp->result will contain an error message. + * occurs then the interp's result will contain an error message. * * Side effects: * The binding given by object and eventString is removed @@ -1174,7 +1195,7 @@ Tk_DeleteBinding(interp, bindingTable, object, eventString) * given by bindingTable. If there is no binding for * eventString, or if eventString is improperly formed, * then NULL is returned and an error message is left in - * interp->result. The return value is semi-static: it + * the interp's result. The return value is semi-static: it * will persist until the binding is changed or deleted. * * Side effects: @@ -1217,7 +1238,7 @@ Tk_GetBinding(interp, bindingTable, object, eventString) * associated with a given object. * * Results: - * There is no return value. Interp->result is modified to + * There is no return value. The interp's result is modified to * hold a Tcl list with one entry for each binding associated * with object in bindingTable. Each entry in the list * contains the event string associated with one binding. @@ -1381,9 +1402,9 @@ Tk_BindEvent(bindingTable, eventPtr, tkwin, numObjects, objectPtr) { BindingTable *bindPtr; TkDisplay *dispPtr; + ScreenInfo *screenPtr; BindInfo *bindInfoPtr; TkDisplay *oldDispPtr; - ScreenInfo *screenPtr; XEvent *ringPtr; PatSeq *vMatchDetailList, *vMatchNoDetailList; int flags, oldScreen, i, deferModal; @@ -1614,12 +1635,12 @@ Tk_BindEvent(bindingTable, eventPtr, tkwin, numObjects, objectPtr) unsigned int oldSize, newSize; oldSize = sizeof(staticPending) - - sizeof(staticPending.matchArray) - + matchSpace * sizeof(PatSeq*); + - sizeof(staticPending.matchArray) + + matchSpace * sizeof(PatSeq*); matchSpace *= 2; newSize = sizeof(staticPending) - - sizeof(staticPending.matchArray) - + matchSpace * sizeof(PatSeq*); + - sizeof(staticPending.matchArray) + + matchSpace * sizeof(PatSeq*); new = (PendingBinding *) ckalloc(newSize); memcpy((VOID *) new, (VOID *) pendingPtr, oldSize); if (pendingPtr != &staticPending) { @@ -1650,7 +1671,7 @@ Tk_BindEvent(bindingTable, eventPtr, tkwin, numObjects, objectPtr) * * There are two tricks here: * 1. Bindings can be invoked from in the middle of Tcl commands, - * where interp->result is significant (for example, a widget + * where the interp's result is significant (for example, a widget * might be deleted because of an error in creating it, so the * result contains an error message that is eventually going to * be returned by the creating command). To preserve the result, @@ -1681,6 +1702,13 @@ Tk_BindEvent(bindingTable, eventPtr, tkwin, numObjects, objectPtr) } if (matchCount > 0) { + /* + * Remember the list of pending C binding callbacks, so we can mark + * them as deleted and not call them if the act of evaluating a C + * or Tcl binding deletes a C binding callback or even the whole + * window. + */ + pendingPtr->nextPtr = bindInfoPtr->pendingList; pendingPtr->tkwin = tkwin; pendingPtr->deleted = 0; @@ -1700,10 +1728,19 @@ Tk_BindEvent(bindingTable, eventPtr, tkwin, numObjects, objectPtr) end = p + Tcl_DStringLength(&scripts); i = 0; + /* + * Be carefule when dereferencing screenPtr or bindInfoPtr. If we + * evaluate something that destroys ".", bindInfoPtr would have been + * freed, but we can tell that by first checking to see if + * winPtr->mainPtr == NULL. + */ + while (p < end) { int code; - screenPtr->bindingDepth++; + if (winPtr->mainPtr != NULL) { + screenPtr->bindingDepth++; + } Tcl_AllowExceptions(interp); if (*p == '\0') { @@ -1729,7 +1766,10 @@ Tk_BindEvent(bindingTable, eventPtr, tkwin, numObjects, objectPtr) p += strlen(p); } p++; - screenPtr->bindingDepth--; + + if (winPtr->mainPtr != NULL) { + screenPtr->bindingDepth--; + } if (code != TCL_OK) { if (code == TCL_CONTINUE) { /* @@ -1759,8 +1799,9 @@ Tk_BindEvent(bindingTable, eventPtr, tkwin, numObjects, objectPtr) } } - if ((screenPtr->bindingDepth != 0) && - ((oldDispPtr != screenPtr->curDispPtr) + if ((winPtr->mainPtr != NULL) + && (screenPtr->bindingDepth != 0) + && ((oldDispPtr != screenPtr->curDispPtr) || (oldScreen != screenPtr->curScreenIndex))) { /* @@ -1777,14 +1818,21 @@ Tk_BindEvent(bindingTable, eventPtr, tkwin, numObjects, objectPtr) Tcl_DStringFree(&scripts); if (matchCount > 0) { - PendingBinding **curPtrPtr; + if (winPtr->mainPtr != NULL) { + /* + * Delete the pending list from the list of pending scripts + * for this window. + */ + + PendingBinding **curPtrPtr; - for (curPtrPtr = &bindInfoPtr->pendingList; ; ) { - if (*curPtrPtr == pendingPtr) { - *curPtrPtr = pendingPtr->nextPtr; - break; + for (curPtrPtr = &bindInfoPtr->pendingList; ; ) { + if (*curPtrPtr == pendingPtr) { + *curPtrPtr = pendingPtr->nextPtr; + break; + } + curPtrPtr = &(*curPtrPtr)->nextPtr; } - curPtrPtr = &(*curPtrPtr)->nextPtr; } if (pendingPtr != &staticPending) { ckfree((char *) pendingPtr); @@ -2164,7 +2212,8 @@ MatchPatterns(dispPtr, bindPtr, psPtr, bestPtr, objectPtr, sourcePtrPtr) bestPtr = matchPtr; bestSourcePtr = sourcePtr; - nextSequence: continue; + nextSequence: + continue; } *sourcePtrPtr = bestSourcePtr; @@ -2208,8 +2257,11 @@ ExpandPercents(winPtr, before, eventPtr, keySym, dsPtr) int number, flags, length; #define NUM_SIZE 40 char *string; + Tcl_DString buf; char numStorage[NUM_SIZE+1]; + Tcl_DStringInit(&buf); + if (eventPtr->type < TK_LASTEVENT) { flags = flagArray[eventPtr->type]; } else { @@ -2358,37 +2410,8 @@ ExpandPercents(winPtr, before, eventPtr, keySym, dsPtr) goto doNumber; case 'A': if (flags & KEY) { - int numChars; - - /* - * If we're using input methods and this is a keypress - * event, invoke XmbTkFindStateString. Otherwise just use - * the older XTkFindStateString. - */ - -#ifdef TK_USE_INPUT_METHODS - Status status; - if ((winPtr->inputContext != NULL) - && (eventPtr->type == KeyPress)) { - numChars = XmbLookupString(winPtr->inputContext, - &eventPtr->xkey, numStorage, NUM_SIZE, - (KeySym *) NULL, &status); - if ((status != XLookupChars) - && (status != XLookupBoth)) { - numChars = 0; - } - } else { - numChars = XLookupString(&eventPtr->xkey, numStorage, - NUM_SIZE, (KeySym *) NULL, - (XComposeStatus *) NULL); - } -#else /* TK_USE_INPUT_METHODS */ - numChars = XLookupString(&eventPtr->xkey, numStorage, - NUM_SIZE, (KeySym *) NULL, - (XComposeStatus *) NULL); -#endif /* TK_USE_INPUT_METHODS */ - numStorage[numChars] = '\0'; - string = numStorage; + Tcl_DStringFree(&buf); + string = TkpGetString(winPtr, eventPtr, &buf); } goto doString; case 'B': @@ -2482,6 +2505,7 @@ ExpandPercents(winPtr, before, eventPtr, keySym, dsPtr) Tcl_DStringSetLength(dsPtr, length + spaceNeeded); before += 2; } + Tcl_DStringFree(&buf); } /* @@ -2514,7 +2538,7 @@ ChangeScreen(interp, dispName, screenIndex) { Tcl_DString cmd; int code; - char screen[30]; + char screen[TCL_INTEGER_SPACE]; Tcl_DStringInit(&cmd); Tcl_DStringAppend(&cmd, "tkScreenChanged ", 16); @@ -2548,87 +2572,98 @@ ChangeScreen(interp, dispName, screenIndex) */ int -Tk_EventCmd(clientData, interp, argc, argv) - ClientData clientData; /* Main window associated with - * interpreter. */ +Tk_EventObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Main window associated with interpreter. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - int i; - size_t length; - char *option; + int index; Tk_Window tkwin; VirtualEventTable *vetPtr; TkBindInfo bindInfo; - - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " option ?arg1?\"", (char *) NULL); - return TCL_ERROR; - } - - option = argv[1]; - length = strlen(option); - if (length == 0) { - goto badopt; - } + static char *optionStrings[] = { + "add", "delete", "generate", "info", + NULL + }; + enum options { + EVENT_ADD, EVENT_DELETE, EVENT_GENERATE, EVENT_INFO + }; tkwin = (Tk_Window) clientData; bindInfo = ((TkWindow *) tkwin)->mainPtr->bindInfo; vetPtr = &((BindInfo *) bindInfo)->virtualEventTable; - if (strncmp(option, "add", length) == 0) { - if (argc < 4) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " add virtual sequence ?sequence ...?\"", (char *) NULL); - return TCL_ERROR; - } - for (i = 3; i < argc; i++) { - if (CreateVirtualEvent(interp, vetPtr, argv[2], argv[i]) - != TCL_OK) { + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + + switch ((enum options) index) { + case EVENT_ADD: { + int i; + char *name, *event; + + if (objc < 4) { + Tcl_WrongNumArgs(interp, 2, objv, + "virtual sequence ?sequence ...?"); return TCL_ERROR; } + name = Tcl_GetStringFromObj(objv[2], NULL); + for (i = 3; i < objc; i++) { + event = Tcl_GetStringFromObj(objv[i], NULL); + if (CreateVirtualEvent(interp, vetPtr, name, event) != TCL_OK) { + return TCL_ERROR; + } + } + break; } - } else if (strncmp(option, "delete", length) == 0) { - if (argc < 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " delete virtual ?sequence sequence ...?\"", - (char *) NULL); - return TCL_ERROR; - } - if (argc == 3) { - return DeleteVirtualEvent(interp, vetPtr, argv[2], NULL); - } - for (i = 3; i < argc; i++) { - if (DeleteVirtualEvent(interp, vetPtr, argv[2], argv[i]) - != TCL_OK) { + case EVENT_DELETE: { + int i; + char *name, *event; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, + "virtual ?sequence sequence ...?"); return TCL_ERROR; } + name = Tcl_GetStringFromObj(objv[2], NULL); + if (objc == 3) { + return DeleteVirtualEvent(interp, vetPtr, name, NULL); + } + for (i = 3; i < objc; i++) { + event = Tcl_GetStringFromObj(objv[i], NULL); + if (DeleteVirtualEvent(interp, vetPtr, name, event) != TCL_OK) { + return TCL_ERROR; + } + } + break; } - } else if (strncmp(option, "generate", length) == 0) { - if (argc < 4) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " generate window event ?options?\"", (char *) NULL); - return TCL_ERROR; + case EVENT_GENERATE: { + if (objc < 4) { + Tcl_WrongNumArgs(interp, 2, objv, "window event ?options?"); + return TCL_ERROR; + } + return HandleEventGenerate(interp, tkwin, objc - 2, objv + 2); + break; } - return HandleEventGenerate(interp, tkwin, argc - 2, argv + 2); - } else if (strncmp(option, "info", length) == 0) { - if (argc == 2) { - GetAllVirtualEvents(interp, vetPtr); - return TCL_OK; - } else if (argc == 3) { - return GetVirtualEvent(interp, vetPtr, argv[2]); - } else { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " info ?virtual?\"", (char *) NULL); - return TCL_ERROR; + case EVENT_INFO: { + if (objc == 2) { + GetAllVirtualEvents(interp, vetPtr); + return TCL_OK; + } else if (objc == 3) { + return GetVirtualEvent(interp, vetPtr, + Tcl_GetStringFromObj(objv[2], NULL)); + } else { + Tcl_WrongNumArgs(interp, 2, objv, "?virtual?"); + return TCL_ERROR; + } + break; } - } else { - badopt: - Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": should be add, delete, generate, info", (char *) NULL); - return TCL_ERROR; } return TCL_OK; } @@ -2715,8 +2750,8 @@ DeleteVirtualEventTable(vetPtr) * Results: * The return value is TCL_ERROR if an error occured while * creating the virtual binding. In this case, an error message - * will be left in interp->result. If all went well then the return - * value is TCL_OK. + * will be left in the interp's result. If all went well then the + * return value is TCL_OK. * * Side effects: * The virtual event may cause future calls to Tk_BindEvent to @@ -2821,7 +2856,7 @@ CreateVirtualEvent(interp, vetPtr, virtString, eventString) * * Results: * The result is a standard Tcl return value. If an error - * occurs then interp->result will contain an error message. + * occurs then the interp's result will contain an error message. * It is not an error to attempt to delete a virtual event that * does not exist or a definition that does not exist. * @@ -2873,7 +2908,10 @@ DeleteVirtualEvent(interp, vetPtr, virtString, eventString) eventPSPtr = FindSequence(interp, &vetPtr->patternTable, NULL, eventString, 0, 0, &eventMask); if (eventPSPtr == NULL) { - return (interp->result[0] != '\0') ? TCL_ERROR : TCL_OK; + char *string; + + string = Tcl_GetStringResult(interp); + return (string[0] != '\0') ? TCL_ERROR : TCL_OK; } } @@ -2975,12 +3013,12 @@ DeleteVirtualEvent(interp, vetPtr, virtString, eventString) * given virtual event. * * Results: - * The return value is TCL_OK and interp->result is filled with the + * The return value is TCL_OK and the interp's result is filled with the * string representation of the physical events associated with the * virtual event; if there are no physical events for the given virtual - * event, interp->result is filled with and empty string. If the + * event, the interp's result is filled with and empty string. If the * virtual event string is improperly formed, then TCL_ERROR is - * returned and an error message is left in interp->result. + * returned and an error message is left in the interp's result. * * Side effects: * None. @@ -3032,7 +3070,7 @@ GetVirtualEvent(interp, vetPtr, virtString) * event defined. * * Results: - * There is no return value. Interp->result is modified to + * There is no return value. The interp's result is modified to * hold a Tcl list with one entry for each virtual event in * nameTable. * @@ -3101,56 +3139,69 @@ GetAllVirtualEvents(interp, vetPtr) *--------------------------------------------------------------------------- */ static int -HandleEventGenerate(interp, main, argc, argv) - Tcl_Interp *interp; /* Interp for error messages and name lookup. */ - Tk_Window main; /* Main window associated with interp. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ +HandleEventGenerate(interp, main, objc, objv) + Tcl_Interp *interp; /* Interp for errors return and name lookup. */ + Tk_Window main; /* Main window associated with interp. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { + XEvent event; + char *name, *p; + int count, flags, synch, i, number; + Tcl_QueuePosition pos; Pattern pat; - Tk_Window tkwin; - char *p; + Tk_Window tkwin, tkwin2; + TkWindow *mainPtr; unsigned long eventMask; - int count, i, state, flags, synch; - Tcl_QueuePosition pos; - XEvent event; + static char *fieldStrings[] = { + "-when", "-above", "-borderwidth", "-button", + "-count", "-detail", "-focus", "-height", + "-keycode", "-keysym", "-mode", "-override", + "-place", "-root", "-rootx", "-rooty", + "-sendevent", "-serial", "-state", "-subwindow", + "-time", "-width", "-window", "-x", + "-y", NULL + }; + enum field { + EVENT_WHEN, EVENT_ABOVE, EVENT_BORDER, EVENT_BUTTON, + EVENT_COUNT, EVENT_DETAIL, EVENT_FOCUS, EVENT_HEIGHT, + EVENT_KEYCODE, EVENT_KEYSYM, EVENT_MODE, EVENT_OVERRIDE, + EVENT_PLACE, EVENT_ROOT, EVENT_ROOTX, EVENT_ROOTY, + EVENT_SEND, EVENT_SERIAL, EVENT_STATE, EVENT_SUBWINDOW, + EVENT_TIME, EVENT_WIDTH, EVENT_WINDOW, EVENT_X, + EVENT_Y + }; + + if (NameToWindow(interp, main, objv[0], &tkwin) != TCL_OK) { + return TCL_ERROR; + } - if (argv[0][0] == '.') { - tkwin = Tk_NameToWindow(interp, argv[0], main); - if (tkwin == NULL) { - return TCL_ERROR; - } - } else { - if (TkpScanWindowId(NULL, argv[0], &i) != TCL_OK) { - Tcl_AppendResult(interp, "bad window name/identifier \"", - argv[0], "\"", (char *) NULL); - return TCL_ERROR; - } - tkwin = Tk_IdToWindow(Tk_Display(main), (Window) i); - if ((tkwin == NULL) || (((TkWindow *) main)->mainPtr - != ((TkWindow *) tkwin)->mainPtr)) { - Tcl_AppendResult(interp, "window id \"", argv[0], - "\" doesn't exist in this application", (char *) NULL); - return TCL_ERROR; - } + mainPtr = (TkWindow *) main; + if ((tkwin == NULL) + || (mainPtr->mainPtr != ((TkWindow *) tkwin)->mainPtr)) { + char *name; + + name = Tcl_GetStringFromObj(objv[0], NULL); + Tcl_AppendResult(interp, "window id \"", name, + "\" doesn't exist in this application", (char *) NULL); + return TCL_ERROR; } - p = argv[1]; + name = Tcl_GetStringFromObj(objv[1], NULL); + + p = name; count = ParseEventDescription(interp, &p, &pat, &eventMask); if (count == 0) { return TCL_ERROR; } if (count != 1) { - interp->result = "Double or Triple modifier not allowed"; + Tcl_SetResult(interp, "Double or Triple modifier not allowed", + TCL_STATIC); return TCL_ERROR; } if (*p != '\0') { - interp->result = "only one event specification allowed"; - return TCL_ERROR; - } - if (argc & 1) { - Tcl_AppendResult(interp, "value for \"", argv[argc - 1], - "\" missing", (char *) NULL); + Tcl_SetResult(interp, "only one event specification allowed", + TCL_STATIC); return TCL_ERROR; } @@ -3165,34 +3216,7 @@ HandleEventGenerate(interp, main, argc, argv) if (flags & (KEY_BUTTON_MOTION_VIRTUAL)) { event.xkey.state = pat.needMods; if (flags & KEY) { - /* - * When mapping from a keysym to a keycode, need information about - * the modifier state that should be used so that when they call - * XKeycodeToKeysym taking into account the xkey.state, they will - * get back the original keysym. - */ - - if (pat.detail.keySym == NoSymbol) { - event.xkey.keycode = 0; - } else { - event.xkey.keycode = XKeysymToKeycode(event.xany.display, - pat.detail.keySym); - } - if (event.xkey.keycode != 0) { - for (state = 0; state < 4; state++) { - if (XKeycodeToKeysym(event.xany.display, - event.xkey.keycode, state) == pat.detail.keySym) { - if (state & 1) { - event.xkey.state |= ShiftMask; - } - if (state & 2) { - TkDisplay *dispPtr = ((TkWindow *) tkwin)->dispPtr; - event.xkey.state |= dispPtr->modeModMask; - } - break; - } - } - } + SetKeycodeAndState(tkwin, pat.detail.keySym, &event); } else if (flags & BUTTON) { event.xbutton.button = pat.detail.button; } else if (flags & VIRTUAL) { @@ -3210,366 +3234,396 @@ HandleEventGenerate(interp, main, argc, argv) synch = 1; pos = TCL_QUEUE_TAIL; - for (i = 2; i < argc; i += 2) { - char *field, *value; - Tk_Window tkwin2; - int number; - KeySym keysym; + for (i = 2; i < objc; i += 2) { + Tcl_Obj *optionPtr, *valuePtr; + int index; - field = argv[i]; - value = argv[i+1]; - - if (strcmp(field, "-when") == 0) { - if (strcmp(value, "now") == 0) { - synch = 1; - } else if (strcmp(value, "head") == 0) { - pos = TCL_QUEUE_HEAD; - synch = 0; - } else if (strcmp(value, "mark") == 0) { - pos = TCL_QUEUE_MARK; - synch = 0; - } else if (strcmp(value, "tail") == 0) { - pos = TCL_QUEUE_TAIL; + optionPtr = objv[i]; + valuePtr = objv[i + 1]; + + if (Tcl_GetIndexFromObj(interp, optionPtr, fieldStrings, "option", + TCL_EXACT, &index) != TCL_OK) { + return TCL_ERROR; + } + if (objc & 1) { + /* + * This test occurs after Tcl_GetIndexFromObj() so that + * "event generate <Button> -xyz" will return the error message + * that "-xyz" is a bad option, rather than that the value + * for "-xyz" is missing. + */ + + Tcl_AppendResult(interp, "value for \"", + Tcl_GetStringFromObj(optionPtr, NULL), "\" missing", + (char *) NULL); + return TCL_ERROR; + } + + switch ((enum field) index) { + case EVENT_WHEN: { + pos = (Tcl_QueuePosition) TkFindStateNumObj(interp, optionPtr, + queuePosition, valuePtr); + if ((int) pos < -1) { + return TCL_ERROR; + } synch = 0; - } else { - Tcl_AppendResult(interp, "bad position \"", value, - "\": should be now, head, mark, tail", (char *) NULL); - return TCL_ERROR; + if ((int) pos == -1) { + synch = 1; + } + break; } - } else if (strcmp(field, "-above") == 0) { - if (value[0] == '.') { - tkwin2 = Tk_NameToWindow(interp, value, main); - if (tkwin2 == NULL) { + case EVENT_ABOVE: { + if (NameToWindow(interp, tkwin, valuePtr, &tkwin2) != TCL_OK) { return TCL_ERROR; } - number = Tk_WindowId(tkwin2); - } else if (TkpScanWindowId(interp, value, &number) - != TCL_OK) { - return TCL_ERROR; - } - if (flags & CONFIG) { - event.xconfigure.above = number; - } else { - goto badopt; - } - } else if (strcmp(field, "-borderwidth") == 0) { - if (Tk_GetPixels(interp, tkwin, value, &number) != TCL_OK) { - return TCL_ERROR; + if (flags & CONFIG) { + event.xconfigure.above = Tk_WindowId(tkwin2); + } else { + goto badopt; + } + break; } - if (flags & (CREATE|CONFIG)) { - event.xcreatewindow.border_width = number; - } else { - goto badopt; + case EVENT_BORDER: { + if (Tk_GetPixelsFromObj(interp, tkwin, valuePtr, &number) != TCL_OK) { + return TCL_ERROR; + } + if (flags & (CREATE|CONFIG)) { + event.xcreatewindow.border_width = number; + } else { + goto badopt; + } + break; } - } else if (strcmp(field, "-button") == 0) { - if (Tcl_GetInt(interp, value, &number) != TCL_OK) { - return TCL_ERROR; + case EVENT_BUTTON: { + if (Tcl_GetIntFromObj(interp, valuePtr, &number) != TCL_OK) { + return TCL_ERROR; + } + if (flags & BUTTON) { + event.xbutton.button = number; + } else { + goto badopt; + } + break; } - if (flags & BUTTON) { - event.xbutton.button = number; - } else { - goto badopt; + case EVENT_COUNT: { + if (Tcl_GetIntFromObj(interp, valuePtr, &number) != TCL_OK) { + return TCL_ERROR; + } + if (flags & EXPOSE) { + event.xexpose.count = number; + } else { + goto badopt; + } + break; } - } else if (strcmp(field, "-count") == 0) { - if (Tcl_GetInt(interp, value, &number) != TCL_OK) { - return TCL_ERROR; + case EVENT_DETAIL: { + number = TkFindStateNumObj(interp, optionPtr, notifyDetail, + valuePtr); + if (number < 0) { + return TCL_ERROR; + } + if (flags & FOCUS) { + event.xfocus.detail = number; + } else if (flags & CROSSING) { + event.xcrossing.detail = number; + } else { + goto badopt; + } + break; } - if (flags & EXPOSE) { - event.xexpose.count = number; - } else { - goto badopt; + case EVENT_FOCUS: { + if (Tcl_GetBooleanFromObj(interp, valuePtr, &number) != TCL_OK) { + return TCL_ERROR; + } + if (flags & CROSSING) { + event.xcrossing.focus = number; + } else { + goto badopt; + } + break; } - } else if (strcmp(field, "-detail") == 0) { - number = TkFindStateNum(interp, field, notifyDetail, value); - if (number < 0) { - return TCL_ERROR; + case EVENT_HEIGHT: { + if (Tk_GetPixelsFromObj(interp, tkwin, valuePtr, &number) != TCL_OK) { + return TCL_ERROR; + } + if (flags & EXPOSE) { + event.xexpose.height = number; + } else if (flags & CONFIG) { + event.xconfigure.height = number; + } else { + goto badopt; + } + break; } - if (flags & FOCUS) { - event.xfocus.detail = number; - } else if (flags & CROSSING) { - event.xcrossing.detail = number; - } else { - goto badopt; + case EVENT_KEYCODE: { + if (Tcl_GetIntFromObj(interp, valuePtr, &number) != TCL_OK) { + return TCL_ERROR; + } + if (flags & KEY) { + event.xkey.keycode = number; + } else { + goto badopt; + } + break; } - } else if (strcmp(field, "-focus") == 0) { - if (Tcl_GetBoolean(interp, value, &number) != TCL_OK) { - return TCL_ERROR; + case EVENT_KEYSYM: { + KeySym keysym; + char *value; + + value = Tcl_GetStringFromObj(valuePtr, NULL); + keysym = TkStringToKeysym(value); + if (keysym == NoSymbol) { + Tcl_AppendResult(interp, "unknown keysym \"", value, "\"", + (char *) NULL); + return TCL_ERROR; + } + + SetKeycodeAndState(tkwin, keysym, &event); + if (event.xkey.keycode == 0) { + Tcl_AppendResult(interp, "no keycode for keysym \"", value, + "\"", (char *) NULL); + return TCL_ERROR; + } + if ((flags & KEY) == 0) { + goto badopt; + } + break; } - if (flags & CROSSING) { - event.xcrossing.focus = number; - } else { - goto badopt; + case EVENT_MODE: { + number = TkFindStateNumObj(interp, optionPtr, notifyMode, + valuePtr); + if (number < 0) { + return TCL_ERROR; + } + if (flags & CROSSING) { + event.xcrossing.mode = number; + } else if (flags & FOCUS) { + event.xfocus.mode = number; + } else { + goto badopt; + } + break; } - } else if (strcmp(field, "-height") == 0) { - if (Tk_GetPixels(interp, tkwin, value, &number) != TCL_OK) { - return TCL_ERROR; + case EVENT_OVERRIDE: { + if (Tcl_GetBooleanFromObj(interp, valuePtr, &number) != TCL_OK) { + return TCL_ERROR; + } + if (flags & CREATE) { + event.xcreatewindow.override_redirect = number; + } else if (flags & MAP) { + event.xmap.override_redirect = number; + } else if (flags & REPARENT) { + event.xreparent.override_redirect = number; + } else if (flags & CONFIG) { + event.xconfigure.override_redirect = number; + } else { + goto badopt; + } + break; } - if (flags & EXPOSE) { - event.xexpose.height = number; - } else if (flags & CONFIG) { - event.xconfigure.height = number; - } else { - goto badopt; + case EVENT_PLACE: { + number = TkFindStateNumObj(interp, optionPtr, circPlace, + valuePtr); + if (number < 0) { + return TCL_ERROR; + } + if (flags & CIRC) { + event.xcirculate.place = number; + } else { + goto badopt; + } + break; } - } else if (strcmp(field, "-keycode") == 0) { - if (Tcl_GetInt(interp, value, &number) != TCL_OK) { - return TCL_ERROR; + case EVENT_ROOT: { + if (NameToWindow(interp, tkwin, valuePtr, &tkwin2) != TCL_OK) { + return TCL_ERROR; + } + if (flags & (KEY_BUTTON_MOTION_VIRTUAL|CROSSING)) { + event.xkey.root = Tk_WindowId(tkwin2); + } else { + goto badopt; + } + break; } - if (flags & KEY) { - event.xkey.keycode = number; - } else { - goto badopt; + case EVENT_ROOTX: { + if (Tk_GetPixelsFromObj(interp, tkwin, valuePtr, &number) != TCL_OK) { + return TCL_ERROR; + } + if (flags & (KEY_BUTTON_MOTION_VIRTUAL|CROSSING)) { + event.xkey.x_root = number; + } else { + goto badopt; + } + break; } - } else if (strcmp(field, "-keysym") == 0) { - keysym = TkStringToKeysym(value); - if (keysym == NoSymbol) { - Tcl_AppendResult(interp, "unknown keysym \"", value, - "\"", (char *) NULL); - return TCL_ERROR; + case EVENT_ROOTY: { + if (Tk_GetPixelsFromObj(interp, tkwin, valuePtr, &number) != TCL_OK) { + return TCL_ERROR; + } + if (flags & (KEY_BUTTON_MOTION_VIRTUAL|CROSSING)) { + event.xkey.y_root = number; + } else { + goto badopt; + } + break; } - /* - * When mapping from a keysym to a keycode, need information about - * the modifier state that should be used so that when they call - * XKeycodeToKeysym taking into account the xkey.state, they will - * get back the original keysym. - */ + case EVENT_SEND: { + CONST char *value; - number = XKeysymToKeycode(event.xany.display, keysym); - if (number == 0) { - Tcl_AppendResult(interp, "no keycode for keysym \"", value, - "\"", (char *) NULL); - return TCL_ERROR; - } - for (state = 0; state < 4; state++) { - if (XKeycodeToKeysym(event.xany.display, (unsigned) number, - state) == keysym) { - if (state & 1) { - event.xkey.state |= ShiftMask; + value = Tcl_GetStringFromObj(valuePtr, NULL); + if (isdigit(UCHAR(value[0]))) { + /* + * Allow arbitrary integer values for the field; they + * are needed by a few of the tests in the Tk test suite. + */ + + if (Tcl_GetIntFromObj(interp, valuePtr, &number) + != TCL_OK) { + return TCL_ERROR; } - if (state & 2) { - TkDisplay *dispPtr = ((TkWindow *) tkwin)->dispPtr; - event.xkey.state |= dispPtr->modeModMask; + } else { + if (Tcl_GetBooleanFromObj(interp, valuePtr, &number) + != TCL_OK) { + return TCL_ERROR; } - break; } - } - if (flags & KEY) { - event.xkey.keycode = number; - } else { - goto badopt; - } - } else if (strcmp(field, "-mode") == 0) { - number = TkFindStateNum(interp, field, notifyMode, value); - if (number < 0) { - return TCL_ERROR; - } - if (flags & CROSSING) { - event.xcrossing.mode = number; - } else if (flags & FOCUS) { - event.xfocus.mode = number; - } else { - goto badopt; - } - } else if (strcmp(field, "-override") == 0) { - if (Tcl_GetBoolean(interp, value, &number) != TCL_OK) { - return TCL_ERROR; - } - if (flags & CREATE) { - event.xcreatewindow.override_redirect = number; - } else if (flags & MAP) { - event.xmap.override_redirect = number; - } else if (flags & REPARENT) { - event.xreparent.override_redirect = number; - } else if (flags & CONFIG) { - event.xconfigure.override_redirect = number; - } else { - goto badopt; - } - } else if (strcmp(field, "-place") == 0) { - number = TkFindStateNum(interp, field, circPlace, value); - if (number < 0) { - return TCL_ERROR; - } - if (flags & CIRC) { - event.xcirculate.place = number; - } else { - goto badopt; + event.xany.send_event = number; + break; } - } else if (strcmp(field, "-root") == 0) { - if (value[0] == '.') { - tkwin2 = Tk_NameToWindow(interp, value, main); - if (tkwin2 == NULL) { + case EVENT_SERIAL: { + if (Tcl_GetIntFromObj(interp, valuePtr, &number) != TCL_OK) { return TCL_ERROR; } - number = Tk_WindowId(tkwin2); - } else if (TkpScanWindowId(interp, value, &number) - != TCL_OK) { - return TCL_ERROR; - } - if (flags & (KEY_BUTTON_MOTION_VIRTUAL|CROSSING)) { - event.xkey.root = number; - } else { - goto badopt; - } - } else if (strcmp(field, "-rootx") == 0) { - if (Tk_GetPixels(interp, tkwin, value, &number) != TCL_OK) { - return TCL_ERROR; - } - if (flags & (KEY_BUTTON_MOTION_VIRTUAL|CROSSING)) { - event.xkey.x_root = number; - } else { - goto badopt; - } - } else if (strcmp(field, "-rooty") == 0) { - if (Tk_GetPixels(interp, tkwin, value, &number) != TCL_OK) { - return TCL_ERROR; + event.xany.serial = number; + break; } - if (flags & (KEY_BUTTON_MOTION_VIRTUAL|CROSSING)) { - event.xkey.y_root = number; - } else { - goto badopt; + case EVENT_STATE: { + if (flags & (KEY_BUTTON_MOTION_VIRTUAL|CROSSING)) { + if (Tcl_GetIntFromObj(interp, valuePtr, &number) + != TCL_OK) { + return TCL_ERROR; + } + if (flags & (KEY_BUTTON_MOTION_VIRTUAL)) { + event.xkey.state = number; + } else { + event.xcrossing.state = number; + } + } else if (flags & VISIBILITY) { + number = TkFindStateNumObj(interp, optionPtr, visNotify, + valuePtr); + if (number < 0) { + return TCL_ERROR; + } + event.xvisibility.state = number; + } else { + goto badopt; + } + break; } - } else if (strcmp(field, "-sendevent") == 0) { - if (isdigit(UCHAR(value[0]))) { - /* - * Allow arbitrary integer values for the field; they - * are needed by a few of the tests in the Tk test suite. - */ - - if (Tcl_GetInt(interp, value, &number) != TCL_OK) { + case EVENT_SUBWINDOW: { + if (NameToWindow(interp, tkwin, valuePtr, &tkwin2) != TCL_OK) { return TCL_ERROR; } - } else { - if (Tcl_GetBoolean(interp, value, &number) != TCL_OK) { - return TCL_ERROR; + if (flags & (KEY_BUTTON_MOTION_VIRTUAL|CROSSING)) { + event.xkey.subwindow = Tk_WindowId(tkwin2); + } else { + goto badopt; } + break; } - event.xany.send_event = number; - } else if (strcmp(field, "-serial") == 0) { - if (Tcl_GetInt(interp, value, &number) != TCL_OK) { - return TCL_ERROR; - } - event.xany.serial = number; - } else if (strcmp(field, "-state") == 0) { - if (flags & (KEY_BUTTON_MOTION_VIRTUAL|CROSSING)) { - if (Tcl_GetInt(interp, value, &number) != TCL_OK) { + case EVENT_TIME: { + if (Tcl_GetIntFromObj(interp, valuePtr, &number) != TCL_OK) { return TCL_ERROR; } - if (flags & (KEY_BUTTON_MOTION_VIRTUAL)) { - event.xkey.state = number; + if (flags & (KEY_BUTTON_MOTION_VIRTUAL|CROSSING)) { + event.xkey.time = (Time) number; + } else if (flags & PROP) { + event.xproperty.time = (Time) number; } else { - event.xcrossing.state = number; + goto badopt; } - } else if (flags & VISIBILITY) { - number = TkFindStateNum(interp, field, visNotify, value); - if (number < 0) { + break; + } + case EVENT_WIDTH: { + if (Tk_GetPixelsFromObj(interp, tkwin, valuePtr, &number) + != TCL_OK) { return TCL_ERROR; } - event.xvisibility.state = number; - } else { - goto badopt; - } - } else if (strcmp(field, "-subwindow") == 0) { - if (value[0] == '.') { - tkwin2 = Tk_NameToWindow(interp, value, main); - if (tkwin2 == NULL) { - return TCL_ERROR; + if (flags & EXPOSE) { + event.xexpose.width = number; + } else if (flags & (CREATE|CONFIG)) { + event.xcreatewindow.width = number; + } else { + goto badopt; } - number = Tk_WindowId(tkwin2); - } else if (TkpScanWindowId(interp, value, &number) - != TCL_OK) { - return TCL_ERROR; - } - if (flags & (KEY_BUTTON_MOTION_VIRTUAL|CROSSING)) { - event.xkey.subwindow = number; - } else { - goto badopt; - } - } else if (strcmp(field, "-time") == 0) { - if (Tcl_GetInt(interp, value, &number) != TCL_OK) { - return TCL_ERROR; - } - if (flags & (KEY_BUTTON_MOTION_VIRTUAL|CROSSING)) { - event.xkey.time = (Time) number; - } else if (flags & PROP) { - event.xproperty.time = (Time) number; - } else { - goto badopt; - } - } else if (strcmp(field, "-width") == 0) { - if (Tk_GetPixels(interp, tkwin, value, &number) != TCL_OK) { - return TCL_ERROR; - } - if (flags & EXPOSE) { - event.xexpose.width = number; - } else if (flags & (CREATE|CONFIG)) { - event.xcreatewindow.width = number; - } else { - goto badopt; + break; } - } else if (strcmp(field, "-window") == 0) { - if (value[0] == '.') { - tkwin2 = Tk_NameToWindow(interp, value, main); - if (tkwin2 == NULL) { + case EVENT_WINDOW: { + if (NameToWindow(interp, tkwin, valuePtr, &tkwin2) != TCL_OK) { return TCL_ERROR; } - number = Tk_WindowId(tkwin2); - } else if (TkpScanWindowId(interp, value, &number) - != TCL_OK) { - return TCL_ERROR; - } - if (flags & (CREATE|DESTROY|UNMAP|MAP|REPARENT|CONFIG - |GRAVITY|CIRC)) { - event.xcreatewindow.window = number; - } else { - goto badopt; - } - } else if (strcmp(field, "-x") == 0) { - int rootX, rootY; - if (Tk_GetPixels(interp, tkwin, value, &number) != TCL_OK) { - return TCL_ERROR; - } - Tk_GetRootCoords(tkwin, &rootX, &rootY); - rootX += number; - if (flags & (KEY_BUTTON_MOTION_VIRTUAL|CROSSING)) { - event.xkey.x = number; - event.xkey.x_root = rootX; - } else if (flags & EXPOSE) { - event.xexpose.x = number; - } else if (flags & (CREATE|CONFIG|GRAVITY)) { - event.xcreatewindow.x = number; - } else if (flags & REPARENT) { - event.xreparent.x = number; - } else { - goto badopt; + if (flags & (CREATE|DESTROY|UNMAP|MAP|REPARENT|CONFIG + |GRAVITY|CIRC)) { + event.xcreatewindow.window = Tk_WindowId(tkwin2); + } else { + goto badopt; + } + break; } - } else if (strcmp(field, "-y") == 0) { - int rootX, rootY; - if (Tk_GetPixels(interp, tkwin, value, &number) != TCL_OK) { - return TCL_ERROR; + case EVENT_X: { + int rootX, rootY; + + if (Tk_GetPixelsFromObj(interp, tkwin, valuePtr, &number) + != TCL_OK) { + return TCL_ERROR; + } + Tk_GetRootCoords(tkwin, &rootX, &rootY); + rootX += number; + if (flags & (KEY_BUTTON_MOTION_VIRTUAL|CROSSING)) { + event.xkey.x = number; + event.xkey.x_root = rootX; + } else if (flags & EXPOSE) { + event.xexpose.x = number; + } else if (flags & (CREATE|CONFIG|GRAVITY)) { + event.xcreatewindow.x = number; + } else if (flags & REPARENT) { + event.xreparent.x = number; + } else { + goto badopt; + } + break; } - Tk_GetRootCoords(tkwin, &rootX, &rootY); - rootY += number; - if (flags & (KEY_BUTTON_MOTION_VIRTUAL|CROSSING)) { - event.xkey.y = number; - event.xkey.y_root = rootY; - } else if (flags & EXPOSE) { - event.xexpose.y = number; - } else if (flags & (CREATE|CONFIG|GRAVITY)) { - event.xcreatewindow.y = number; - } else if (flags & REPARENT) { - event.xreparent.y = number; - } else { - goto badopt; + case EVENT_Y: { + int rootX, rootY; + + if (Tk_GetPixelsFromObj(interp, tkwin, valuePtr, &number) + != TCL_OK) { + return TCL_ERROR; + } + Tk_GetRootCoords(tkwin, &rootX, &rootY); + rootY += number; + if (flags & (KEY_BUTTON_MOTION_VIRTUAL|CROSSING)) { + event.xkey.y = number; + event.xkey.y_root = rootY; + } else if (flags & EXPOSE) { + event.xexpose.y = number; + } else if (flags & (CREATE|CONFIG|GRAVITY)) { + event.xcreatewindow.y = number; + } else if (flags & REPARENT) { + event.xreparent.y = number; + } else { + goto badopt; + } + break; } - } else { - badopt: - Tcl_AppendResult(interp, "bad option to ", argv[1], - " event: \"", field, "\"", (char *) NULL); - return TCL_ERROR; } + continue; + + badopt: + Tcl_AppendResult(interp, name, " event doesn't accept \"", + Tcl_GetStringFromObj(optionPtr, NULL), "\" option", NULL); + return TCL_ERROR; } - if (synch != 0) { Tk_HandleEvent(&event); } else { @@ -3577,6 +3631,80 @@ HandleEventGenerate(interp, main, argc, argv) } Tcl_ResetResult(interp); return TCL_OK; + +} +static int +NameToWindow(interp, main, objPtr, tkwinPtr) + Tcl_Interp *interp; /* Interp for error return and name lookup. */ + Tk_Window main; /* Main window of application. */ + Tcl_Obj *objPtr; /* Contains name or id string of window. */ + Tk_Window *tkwinPtr; /* Filled with token for window. */ +{ + char *name; + Tk_Window tkwin; + int id; + + name = Tcl_GetStringFromObj(objPtr, NULL); + if (name[0] == '.') { + tkwin = Tk_NameToWindow(interp, name, main); + if (tkwin == NULL) { + return TCL_ERROR; + } + *tkwinPtr = tkwin; + } else { + if (TkpScanWindowId(NULL, name, &id) != TCL_OK) { + Tcl_AppendResult(interp, "bad window name/identifier \"", + name, "\"", (char *) NULL); + return TCL_ERROR; + } + *tkwinPtr = Tk_IdToWindow(Tk_Display(main), (Window) id); + } + return TCL_OK; +} + + /* + * When mapping from a keysym to a keycode, need + * information about the modifier state that should be used + * so that when they call XKeycodeToKeysym taking into + * account the xkey.state, they will get back the original + * keysym. + */ + + +static void +SetKeycodeAndState(tkwin, keySym, eventPtr) + Tk_Window tkwin; + KeySym keySym; + XEvent *eventPtr; +{ + Display *display; + int state; + KeyCode keycode; + + display = Tk_Display(tkwin); + + if (keySym == NoSymbol) { + keycode = 0; + } else { + keycode = XKeysymToKeycode(display, keySym); + } + if (keycode != 0) { + for (state = 0; state < 4; state++) { + if (XKeycodeToKeysym(display, keycode, state) == keySym) { + if (state & 1) { + eventPtr->xkey.state |= ShiftMask; + } + if (state & 2) { + TkDisplay *dispPtr; + + dispPtr = ((TkWindow *) tkwin)->dispPtr; + eventPtr->xkey.state |= dispPtr->modeModMask; + } + break; + } + } + } + eventPtr->xkey.keycode = keycode; } /* @@ -3590,7 +3718,7 @@ HandleEventGenerate(interp, main, argc, argv) * Results: * The return value is NULL if the virtual event string was * not in the proper format. In this case, an error message - * will be left in interp->result. Otherwise the return + * will be left in the interp's result. Otherwise the return * value is a Tk_Uid that represents the virtual event. * * Side effects: @@ -3636,7 +3764,7 @@ GetVirtualEventUid(interp, virtString) * in patternTable that corresponds to eventString. If an error * was found while parsing eventString, or if "create" is 0 and * no pattern sequence previously existed, then NULL is returned - * and interp->result contains a message describing the problem. + * and the interp's result contains a message describing the problem. * If no pattern sequence previously existed for eventString, then * a new one is created with a NULL command field. In a successful * return, *maskPtr is filled in with a mask of the event types @@ -3712,8 +3840,9 @@ FindSequence(interp, patternTablePtr, object, eventString, create, if (eventMask & VirtualEventMask) { if (allowVirtual == 0) { - interp->result = - "virtual event not allowed in definition of another virtual event"; + Tcl_SetResult(interp, + "virtual event not allowed in definition of another virtual event", + TCL_STATIC); return NULL; } virtualFound = 1; @@ -3744,11 +3873,12 @@ FindSequence(interp, patternTablePtr, object, eventString, create, */ if (numPats == 0) { - interp->result = "no events specified in binding"; + Tcl_SetResult(interp, "no events specified in binding", TCL_STATIC); return NULL; } if ((numPats > 1) && (virtualFound != 0)) { - interp->result = "virtual events may not be composed"; + Tcl_SetResult(interp, "virtual events may not be composed", + TCL_STATIC); return NULL; } @@ -3774,6 +3904,14 @@ FindSequence(interp, patternTablePtr, object, eventString, create, if (new) { Tcl_DeleteHashEntry(hPtr); } + /* + * No binding exists for the sequence, so return an empty error. + * This is a special error that the caller will check for in order + * to silently ignore this case. This is a hack that maintains + * backward compatibility for Tk_GetBinding but the various "bind" + * commands silently ignore missing bindings. + */ + return NULL; } psPtr = (PatSeq *) ckalloc((unsigned) (sizeof(PatSeq) @@ -3863,8 +4001,10 @@ ParseEventDescription(interp, eventStringPtr, patPtr, if (isprint(UCHAR(*p))) { patPtr->detail.keySym = *p; } else { - sprintf(interp->result, - "bad ASCII character 0x%x", (unsigned char) *p); + char buf[64]; + + sprintf(buf, "bad ASCII character 0x%x", (unsigned char) *p); + Tcl_SetResult(interp, buf, TCL_VOLATILE); return 0; } } @@ -3904,11 +4044,13 @@ ParseEventDescription(interp, eventStringPtr, patPtr, char *field = p + 1; p = strchr(field, '>'); if (p == field) { - interp->result = "virtual event \"<<>>\" is badly formed"; + Tcl_SetResult(interp, "virtual event \"<<>>\" is badly formed", + TCL_STATIC); return 0; } if ((p == NULL) || (p[1] != '>')) { - interp->result = "missing \">\" in virtual binding"; + Tcl_SetResult(interp, "missing \">\" in virtual binding", + TCL_STATIC); return 0; } *p = '\0'; @@ -3995,7 +4137,8 @@ ParseEventDescription(interp, eventStringPtr, patPtr, } } } else if (eventFlags == 0) { - interp->result = "no event type or button # or keysym"; + Tcl_SetResult(interp, "no event type or button # or keysym", + TCL_STATIC); return 0; } @@ -4006,11 +4149,13 @@ ParseEventDescription(interp, eventStringPtr, patPtr, while (*p != '\0') { p++; if (*p == '>') { - interp->result = "extra characters after detail in binding"; + Tcl_SetResult(interp, + "extra characters after detail in binding", + TCL_STATIC); return 0; } } - interp->result = "missing \">\" in binding"; + Tcl_SetResult(interp, "missing \">\" in binding", TCL_STATIC); return 0; } p++; @@ -4085,7 +4230,7 @@ GetPatternString(psPtr, dsPtr) Tcl_DString *dsPtr; { Pattern *patPtr; - char c, buffer[10]; + char c, buffer[TCL_INTEGER_SPACE]; int patsLeft, needMods; ModInfo *modPtr; EventInfo *eiPtr; @@ -4506,7 +4651,7 @@ TkKeysymToString(keysym) * * Results: * Returns the result of evaluating script, including both a standard - * Tcl completion code and a string in interp->result. + * Tcl completion code and a string in the interp's result. * * Side effects: * None. diff --git a/generic/tkBitmap.c b/generic/tkBitmap.c index fe46b35..25c1d37 100644 --- a/generic/tkBitmap.c +++ b/generic/tkBitmap.c @@ -6,12 +6,12 @@ * also avoids interactions with the X server. * * Copyright (c) 1990-1994 The Regents of the University of California. - * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * Copyright (c) 1994-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkBitmap.c 1.45 97/07/24 17:27:38 + * SCCS: @(#) tkBitmap.c 1.56 98/01/19 11:47:55 */ #include "tkPort.h" @@ -51,28 +51,41 @@ * "nameTable". */ -typedef struct { +typedef struct TkBitmap { Pixmap bitmap; /* X identifier for bitmap. None means this * bitmap was created by Tk_DefineBitmap * and it isn't currently in use. */ int width, height; /* Dimensions of bitmap. */ Display *display; /* Display for which bitmap is valid. */ - int refCount; /* Number of active uses of bitmap. */ - Tcl_HashEntry *hashPtr; /* Entry in nameTable for this structure + int resourceRefCount; /* Number of active uses of this bitmap (each + * active use corresponds to a call to + * Tk_AllocBitmapFromObj or Tk_GetBitmap). + * If this count is 0, then this TkBitmap + * structure is no longer valid and it isn't + * present in nameTable: it is being kept + * around only because there are objects + * referring to it. The structure is freed + * when resourceRefCount and objRefCount + * are both 0. */ + int objRefCount; /* Number of Tcl_Obj's that reference + * this structure. */ + Tcl_HashEntry *nameHashPtr; /* Entry in nameTable for this structure + * (needed when deleting). */ + Tcl_HashEntry *idHashPtr; /* Entry in idTable for this structure * (needed when deleting). */ + struct TkBitmap *nextPtr; /* Points to the next TkBitmap structure with + * the same name. All bitmaps with the + * same name (but different displays) are + * chained together off a single entry in + * nameTable. */ } TkBitmap; /* - * Hash table to map from a textual description of a bitmap to the - * TkBitmap record for the bitmap, and key structure used in that - * hash table: + * Hash table to map from a textual name for a bitmap to the + * first TkBitmap record for that name: */ static Tcl_HashTable nameTable; -typedef struct { - Tk_Uid name; /* Textual name for desired bitmap. */ - Screen *screen; /* Screen on which bitmap will be used. */ -} NameKey; /* * Hash table that maps from <display + bitmap id> to the TkBitmap structure @@ -86,7 +99,7 @@ typedef struct { } IdKey; /* - * Hash table create by Tk_DefineBitmap to map from a name to a + * Hash table created by Tk_DefineBitmap to map from a name to a * collection of in-core data about a bitmap. The table is * indexed by the address of the data for the bitmap, and the entries * contain pointers to TkPredefBitmap structures. @@ -96,7 +109,7 @@ Tcl_HashTable tkPredefBitmapTable; /* * Hash table used by Tk_GetBitmapFromData to map from a collection - * of in-core data about a bitmap to a Tk_Uid giving an automatically- + * of in-core data about a bitmap to a reference giving an automatically- * generated name for the bitmap: */ @@ -114,6 +127,123 @@ static int initialized = 0; /* 0 means static structures haven't been */ static void BitmapInit _ANSI_ARGS_((void)); +static void DupBitmapObjProc _ANSI_ARGS_((Tcl_Obj *srcObjPtr, + Tcl_Obj *dupObjPtr)); +static void FreeBitmap _ANSI_ARGS_((TkBitmap *bitmapPtr)); +static void FreeBitmapObjProc _ANSI_ARGS_((Tcl_Obj *objPtr)); +static TkBitmap * GetBitmap _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, char *name)); +static TkBitmap * GetBitmapFromObj _ANSI_ARGS_((Tk_Window tkwin, + Tcl_Obj *objPtr)); +static void InitBitmapObj _ANSI_ARGS_((Tcl_Obj *objPtr)); + +/* + * The following structure defines the implementation of the "bitmap" Tcl + * object, which maps a string bitmap name to a TkBitmap object. The + * ptr1 field of the Tcl_Obj points to a TkBitmap object. + */ + +static Tcl_ObjType bitmapObjType = { + "bitmap", /* name */ + FreeBitmapObjProc, /* freeIntRepProc */ + DupBitmapObjProc, /* dupIntRepProc */ + NULL, /* updateStringProc */ + NULL /* setFromAnyProc */ +}; + +/* + *---------------------------------------------------------------------- + * + * Tk_AllocBitmapFromObj -- + * + * Given a Tcl_Obj *, map the value to a corresponding + * Pixmap structure based on the tkwin given. + * + * Results: + * The return value is the X identifer for the desired bitmap + * (i.e. a Pixmap with a single plane), unless string couldn't be + * parsed correctly. In this case, None is returned and an error + * message is left in the interp's result. The caller should never + * modify the bitmap that is returned, and should eventually call + * Tk_FreeBitmapFromObj when the bitmap is no longer needed. + * + * Side effects: + * The bitmap is added to an internal database with a reference count. + * For each call to this procedure, there should eventually be a call + * to Tk_FreeBitmapFromObj, so that the database can be cleaned up + * when bitmaps aren't needed anymore. + * + *---------------------------------------------------------------------- + */ + +Pixmap +Tk_AllocBitmapFromObj(interp, tkwin, objPtr) + Tcl_Interp *interp; /* Interp for error results. This may + * be NULL. */ + Tk_Window tkwin; /* Need the screen the bitmap is used on.*/ + Tcl_Obj *objPtr; /* Object describing bitmap; see manual + * entry for legal syntax of string value. */ +{ + TkBitmap *bitmapPtr; + + if (objPtr->typePtr != &bitmapObjType) { + InitBitmapObj(objPtr); + } + bitmapPtr = (TkBitmap *) objPtr->internalRep.twoPtrValue.ptr1; + + /* + * If the object currently points to a TkBitmap, see if it's the + * one we want. If so, increment its reference count and return. + */ + + if (bitmapPtr != NULL) { + if (bitmapPtr->resourceRefCount == 0) { + /* + * This is a stale reference: it refers to a TkBitmap that's + * no longer in use. Clear the reference. + */ + + FreeBitmapObjProc(objPtr); + bitmapPtr = NULL; + } else if (Tk_Display(tkwin) == bitmapPtr->display) { + bitmapPtr->resourceRefCount++; + return bitmapPtr->bitmap; + } + } + + /* + * The object didn't point to the TkBitmap that we wanted. Search + * the list of TkBitmaps with the same name to see if one of the + * others is the right one. + */ + + if (bitmapPtr != NULL) { + TkBitmap *firstBitmapPtr = + (TkBitmap *) Tcl_GetHashValue(bitmapPtr->nameHashPtr); + FreeBitmapObjProc(objPtr); + for (bitmapPtr = firstBitmapPtr; bitmapPtr != NULL; + bitmapPtr = bitmapPtr->nextPtr) { + if (Tk_Display(tkwin) == bitmapPtr->display) { + bitmapPtr->resourceRefCount++; + bitmapPtr->objRefCount++; + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) bitmapPtr; + return bitmapPtr->bitmap; + } + } + } + + /* + * Still no luck. Call GetBitmap to allocate a new TkBitmap object. + */ + + bitmapPtr = GetBitmap(interp, tkwin, Tcl_GetString(objPtr)); + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) bitmapPtr; + if (bitmapPtr == NULL) { + return None; + } + bitmapPtr->objRefCount++; + return bitmapPtr->bitmap; +} /* *---------------------------------------------------------------------- @@ -127,7 +257,7 @@ static void BitmapInit _ANSI_ARGS_((void)); * The return value is the X identifer for the desired bitmap * (i.e. a Pixmap with a single plane), unless string couldn't be * parsed correctly. In this case, None is returned and an error - * message is left in interp->result. The caller should never + * message is left in the interp's result. The caller should never * modify the bitmap that is returned, and should eventually call * Tk_FreeBitmap when the bitmap is no longer needed. * @@ -145,13 +275,54 @@ Tk_GetBitmap(interp, tkwin, string) Tcl_Interp *interp; /* Interpreter to use for error reporting, * this may be NULL. */ Tk_Window tkwin; /* Window in which bitmap will be used. */ - Tk_Uid string; /* Description of bitmap. See manual entry + char *string; /* Description of bitmap. See manual entry + * for details on legal syntax. */ +{ + TkBitmap *bitmapPtr = GetBitmap(interp, tkwin, string); + if (bitmapPtr == NULL) { + return None; + } + return bitmapPtr->bitmap; +} + +/* + *---------------------------------------------------------------------- + * + * GetBitmap -- + * + * Given a string describing a bitmap, locate (or create if necessary) + * a bitmap that fits the description. This routine returns the + * internal data structure for the bitmap. This avoids extra + * hash table lookups in Tk_AllocBitmapFromObj. + * + * Results: + * The return value is the X identifer for the desired bitmap + * (i.e. a Pixmap with a single plane), unless string couldn't be + * parsed correctly. In this case, None is returned and an error + * message is left in the interp's result. The caller should never + * modify the bitmap that is returned, and should eventually call + * Tk_FreeBitmap when the bitmap is no longer needed. + * + * Side effects: + * The bitmap is added to an internal database with a reference count. + * For each call to this procedure, there should eventually be a call + * to Tk_FreeBitmap or Tk_FreeBitmapFromObj, so that the database can + * be cleaned up when bitmaps aren't needed anymore. + * + *---------------------------------------------------------------------- + */ + +static TkBitmap * +GetBitmap(interp, tkwin, string) + Tcl_Interp *interp; /* Interpreter to use for error reporting, + * this may be NULL. */ + Tk_Window tkwin; /* Window in which bitmap will be used. */ + char *string; /* Description of bitmap. See manual entry * for details on legal syntax. */ { - NameKey nameKey; IdKey idKey; - Tcl_HashEntry *nameHashPtr, *idHashPtr, *predefHashPtr; - register TkBitmap *bitmapPtr; + Tcl_HashEntry *nameHashPtr, *predefHashPtr; + TkBitmap *bitmapPtr, *existingBitmapPtr; TkPredefBitmap *predefPtr; int new; Pixmap bitmap; @@ -162,13 +333,18 @@ Tk_GetBitmap(interp, tkwin, string) BitmapInit(); } - nameKey.name = string; - nameKey.screen = Tk_Screen(tkwin); - nameHashPtr = Tcl_CreateHashEntry(&nameTable, (char *) &nameKey, &new); + nameHashPtr = Tcl_CreateHashEntry(&nameTable, string, &new); if (!new) { - bitmapPtr = (TkBitmap *) Tcl_GetHashValue(nameHashPtr); - bitmapPtr->refCount++; - return bitmapPtr->bitmap; + existingBitmapPtr = (TkBitmap *) Tcl_GetHashValue(nameHashPtr); + for (bitmapPtr = existingBitmapPtr; bitmapPtr != NULL; + bitmapPtr = bitmapPtr->nextPtr) { + if (Tk_Display(tkwin) == bitmapPtr->display) { + bitmapPtr->resourceRefCount++; + return bitmapPtr; + } + } + } else { + existingBitmapPtr = NULL; } /* @@ -194,7 +370,7 @@ Tk_GetBitmap(interp, tkwin, string) goto error; } result = XReadBitmapFile(Tk_Display(tkwin), - RootWindowOfScreen(nameKey.screen), string, + RootWindowOfScreen(Tk_Screen(tkwin)), string, (unsigned int *) &width, (unsigned int *) &height, &bitmap, &dummy2, &dummy2); if (result != BitmapSuccess) { @@ -236,7 +412,8 @@ Tk_GetBitmap(interp, tkwin, string) } } else { bitmap = XCreateBitmapFromData(Tk_Display(tkwin), - RootWindowOfScreen(nameKey.screen), predefPtr->source, + RootWindowOfScreen(Tk_Screen(tkwin)), + predefPtr->source, (unsigned) width, (unsigned) height); } } @@ -251,22 +428,26 @@ Tk_GetBitmap(interp, tkwin, string) bitmapPtr->width = width; bitmapPtr->height = height; bitmapPtr->display = Tk_Display(tkwin); - bitmapPtr->refCount = 1; - bitmapPtr->hashPtr = nameHashPtr; + bitmapPtr->resourceRefCount = 1; + bitmapPtr->objRefCount = 0; + bitmapPtr->nameHashPtr = nameHashPtr; idKey.display = bitmapPtr->display; idKey.pixmap = bitmap; - idHashPtr = Tcl_CreateHashEntry(&idTable, (char *) &idKey, + bitmapPtr->idHashPtr = Tcl_CreateHashEntry(&idTable, (char *) &idKey, &new); if (!new) { panic("bitmap already registered in Tk_GetBitmap"); } + bitmapPtr->nextPtr = existingBitmapPtr; Tcl_SetHashValue(nameHashPtr, bitmapPtr); - Tcl_SetHashValue(idHashPtr, bitmapPtr); - return bitmapPtr->bitmap; + Tcl_SetHashValue(bitmapPtr->idHashPtr, bitmapPtr); + return bitmapPtr; error: - Tcl_DeleteHashEntry(nameHashPtr); - return None; + if (new) { + Tcl_DeleteHashEntry(nameHashPtr); + } + return NULL; } /* @@ -280,7 +461,7 @@ Tk_GetBitmap(interp, tkwin, string) * * Results: * A standard Tcl result. If an error occurs then TCL_ERROR is - * returned and a message is left in interp->result. + * returned and a message is left in the interp's result. * * Side effects: * "Name" is entered into the bitmap table and may be used from @@ -292,7 +473,7 @@ Tk_GetBitmap(interp, tkwin, string) int Tk_DefineBitmap(interp, name, source, width, height) Tcl_Interp *interp; /* Interpreter to use for error reporting. */ - Tk_Uid name; /* Name to use for bitmap. Must not already + char *name; /* Name to use for bitmap. Must not already * be defined as a bitmap. */ char *source; /* Address of bits for bitmap. */ int width; /* Width of bitmap. */ @@ -338,7 +519,7 @@ Tk_DefineBitmap(interp, name, source, width, height) *-------------------------------------------------------------- */ -Tk_Uid +char * Tk_NameOfBitmap(display, bitmap) Display *display; /* Display for which bitmap was * allocated. */ @@ -360,7 +541,7 @@ Tk_NameOfBitmap(display, bitmap) goto unknown; } bitmapPtr = (TkBitmap *) Tcl_GetHashValue(idHashPtr); - return ((NameKey *) bitmapPtr->hashPtr->key.words)->name; + return bitmapPtr->nameHashPtr->key.string; } /* @@ -413,6 +594,56 @@ Tk_SizeOfBitmap(display, bitmap, widthPtr, heightPtr) /* *---------------------------------------------------------------------- * + * FreeBitmap -- + * + * This procedure does all the work of releasing a bitmap allocated by + * Tk_GetBitmap or TkGetBitmapFromData. It is invoked by both + * Tk_FreeBitmap and Tk_FreeBitmapFromObj + * + * Results: + * None. + * + * Side effects: + * The reference count associated with bitmap is decremented, and + * it is officially deallocated if no-one is using it anymore. + * + *---------------------------------------------------------------------- + */ + +static void +FreeBitmap(bitmapPtr) + TkBitmap *bitmapPtr; /* Bitmap to be released. */ +{ + TkBitmap *prevPtr; + + bitmapPtr->resourceRefCount--; + if (bitmapPtr->resourceRefCount > 0) { + return; + } + + Tk_FreePixmap(bitmapPtr->display, bitmapPtr->bitmap); + Tcl_DeleteHashEntry(bitmapPtr->idHashPtr); + prevPtr = (TkBitmap *) Tcl_GetHashValue(bitmapPtr->nameHashPtr); + if (prevPtr == bitmapPtr) { + if (bitmapPtr->nextPtr == NULL) { + Tcl_DeleteHashEntry(bitmapPtr->nameHashPtr); + } else { + Tcl_SetHashValue(bitmapPtr->nameHashPtr, bitmapPtr->nextPtr); + } + } else { + while (prevPtr->nextPtr != bitmapPtr) { + prevPtr = prevPtr->nextPtr; + } + prevPtr->nextPtr = bitmapPtr->nextPtr; + } + if (bitmapPtr->objRefCount == 0) { + ckfree((char *) bitmapPtr); + } +} + +/* + *---------------------------------------------------------------------- + * * Tk_FreeBitmap -- * * This procedure is called to release a bitmap allocated by @@ -435,7 +666,6 @@ Tk_FreeBitmap(display, bitmap) Pixmap bitmap; /* Bitmap to be released. */ { Tcl_HashEntry *idHashPtr; - register TkBitmap *bitmapPtr; IdKey idKey; if (!initialized) { @@ -448,13 +678,105 @@ Tk_FreeBitmap(display, bitmap) if (idHashPtr == NULL) { panic("Tk_FreeBitmap received unknown bitmap argument"); } - bitmapPtr = (TkBitmap *) Tcl_GetHashValue(idHashPtr); - bitmapPtr->refCount--; - if (bitmapPtr->refCount == 0) { - Tk_FreePixmap(bitmapPtr->display, bitmapPtr->bitmap); - Tcl_DeleteHashEntry(idHashPtr); - Tcl_DeleteHashEntry(bitmapPtr->hashPtr); - ckfree((char *) bitmapPtr); + FreeBitmap((TkBitmap *) Tcl_GetHashValue(idHashPtr)); +} + +/* + *---------------------------------------------------------------------- + * + * Tk_FreeBitmapFromObj -- + * + * This procedure is called to release a bitmap allocated by + * Tk_AllocBitmapFromObj. It does not throw away the Tcl_Obj *; + * it only gets rid of the hash table entry for this bitmap + * and clears the cached value that is normally stored in the object. + * + * Results: + * None. + * + * Side effects: + * The reference count associated with the bitmap represented by + * objPtr is decremented, and the bitmap is released to X if there are + * no remaining uses for it. + * + *---------------------------------------------------------------------- + */ + +void +Tk_FreeBitmapFromObj(tkwin, objPtr) + Tk_Window tkwin; /* The window this bitmap lives in. Needed + * for the display value. */ + Tcl_Obj *objPtr; /* The Tcl_Obj * to be freed. */ +{ + FreeBitmap(GetBitmapFromObj(tkwin, objPtr)); +} + +/* + *--------------------------------------------------------------------------- + * + * FreeBitmapObjProc -- + * + * This proc is called to release an object reference to a bitmap. + * Called when the object's internal rep is released or when + * the cached bitmapPtr needs to be changed. + * + * Results: + * None. + * + * Side effects: + * The object reference count is decremented. When both it + * and the hash ref count go to zero, the color's resources + * are released. + * + *--------------------------------------------------------------------------- + */ + +static void +FreeBitmapObjProc(objPtr) + Tcl_Obj *objPtr; /* The object we are releasing. */ +{ + TkBitmap *bitmapPtr = (TkBitmap *) objPtr->internalRep.twoPtrValue.ptr1; + + if (bitmapPtr != NULL) { + bitmapPtr->objRefCount--; + if ((bitmapPtr->objRefCount == 0) + && (bitmapPtr->resourceRefCount == 0)) { + ckfree((char *) bitmapPtr); + } + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) NULL; + } +} + +/* + *--------------------------------------------------------------------------- + * + * DupBitmapObjProc -- + * + * When a cached bitmap object is duplicated, this is called to + * update the internal reps. + * + * Results: + * None. + * + * Side effects: + * The color's objRefCount is incremented and the internal rep + * of the copy is set to point to it. + * + *--------------------------------------------------------------------------- + */ + +static void +DupBitmapObjProc(srcObjPtr, dupObjPtr) + Tcl_Obj *srcObjPtr; /* The object we are copying from. */ + Tcl_Obj *dupObjPtr; /* The object we are copying to. */ +{ + TkBitmap *bitmapPtr = (TkBitmap *) srcObjPtr->internalRep.twoPtrValue.ptr1; + + dupObjPtr->typePtr = srcObjPtr->typePtr; + dupObjPtr->internalRep.twoPtrValue.ptr1 = (VOID *) bitmapPtr; + + if (bitmapPtr != NULL) { + bitmapPtr->objRefCount++; } } @@ -471,7 +793,7 @@ Tk_FreeBitmap(display, bitmap) * The return value is the X identifer for the desired bitmap * (a one-plane Pixmap), unless it couldn't be created properly. * In this case, None is returned and an error message is left in - * interp->result. The caller should never modify the bitmap that + * the interp's result. The caller should never modify the bitmap that * is returned, and should eventually call Tk_FreeBitmap when the * bitmap is no longer needed. * @@ -494,9 +816,9 @@ Tk_GetBitmapFromData(interp, tkwin, source, width, height) { DataKey nameKey; Tcl_HashEntry *dataHashPtr; - Tk_Uid name; int new; - char string[20]; + char string[16 + TCL_INTEGER_SPACE]; + char *name; static int autoNumber = 0; if (!initialized) { @@ -508,11 +830,11 @@ Tk_GetBitmapFromData(interp, tkwin, source, width, height) nameKey.height = height; dataHashPtr = Tcl_CreateHashEntry(&dataTable, (char *) &nameKey, &new); if (!new) { - name = (Tk_Uid) Tcl_GetHashValue(dataHashPtr); + name = (char *) Tcl_GetHashValue(dataHashPtr); } else { autoNumber++; sprintf(string, "_tk%d", autoNumber); - name = Tk_GetUid(string); + name = string; Tcl_SetHashValue(dataHashPtr, name); if (Tk_DefineBitmap(interp, name, source, width, height) != TCL_OK) { Tcl_DeleteHashEntry(dataHashPtr); @@ -525,6 +847,142 @@ Tk_GetBitmapFromData(interp, tkwin, source, width, height) /* *---------------------------------------------------------------------- * + * Tk_GetBitmapFromObj -- + * + * Returns the bitmap referred to by a Tcl object. The bitmap must + * already have been allocated via a call to Tk_AllocBitmapFromObj + * or Tk_GetBitmap. + * + * Results: + * Returns the Pixmap that matches the tkwin and the string rep + * of objPtr. + * + * Side effects: + * If the object is not already a bitmap, the conversion will free + * any old internal representation. + * + *---------------------------------------------------------------------- + */ + +Pixmap +Tk_GetBitmapFromObj(tkwin, objPtr) + Tk_Window tkwin; + Tcl_Obj *objPtr; /* The object from which to get pixels. */ +{ + TkBitmap *bitmapPtr = GetBitmapFromObj(tkwin, objPtr); + return bitmapPtr->bitmap; +} + +/* + *---------------------------------------------------------------------- + * + * GetBitmapFromObj -- + * + * Returns the bitmap referred to by a Tcl object. The bitmap must + * already have been allocated via a call to Tk_AllocBitmapFromObj + * or Tk_GetBitmap. + * + * Results: + * Returns the TkBitmap * that matches the tkwin and the string rep + * of objPtr. + * + * Side effects: + * If the object is not already a bitmap, the conversion will free + * any old internal representation. + * + *---------------------------------------------------------------------- + */ + +static TkBitmap * +GetBitmapFromObj(tkwin, objPtr) + Tk_Window tkwin; /* Window in which the bitmap will be used. */ + Tcl_Obj *objPtr; /* The object that describes the desired + * bitmap. */ +{ + TkBitmap *bitmapPtr; + Tcl_HashEntry *hashPtr; + + if (objPtr->typePtr != &bitmapObjType) { + InitBitmapObj(objPtr); + } + + bitmapPtr = (TkBitmap *) objPtr->internalRep.twoPtrValue.ptr1; + if (bitmapPtr != NULL) { + if ((bitmapPtr->resourceRefCount > 0) + && (Tk_Display(tkwin) == bitmapPtr->display)) { + return bitmapPtr; + } + hashPtr = bitmapPtr->nameHashPtr; + FreeBitmapObjProc(objPtr); + } else { + hashPtr = Tcl_FindHashEntry(&nameTable, Tcl_GetString(objPtr)); + if (hashPtr == NULL) { + goto error; + } + } + + /* + * At this point we've got a hash table entry, off of which hang + * one or more TkBitmap structures. See if any of them will work. + */ + + for (bitmapPtr = (TkBitmap *) Tcl_GetHashValue(hashPtr); + bitmapPtr != NULL; bitmapPtr = bitmapPtr->nextPtr) { + if (Tk_Display(tkwin) == bitmapPtr->display) { + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) bitmapPtr; + bitmapPtr->objRefCount++; + return bitmapPtr; + } + } + + error: + panic("GetBitmapFromObj called with non-existent bitmap!"); + /* + * The following code isn't reached; it's just there to please compilers. + */ + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * InitBitmapObj -- + * + * Bookeeping procedure to change an objPtr to a bitmap type. + * + * Results: + * None. + * + * Side effects: + * The old internal rep of the object is freed. The internal + * rep is cleared. The final form of the object is set + * by either Tk_AllocBitmapFromObj or GetBitmapFromObj. + * + *---------------------------------------------------------------------- + */ + +static void +InitBitmapObj(objPtr) + Tcl_Obj *objPtr; /* The object to convert. */ +{ + Tcl_ObjType *typePtr; + + /* + * Free the old internalRep before setting the new one. + */ + + Tcl_GetString(objPtr); + typePtr = objPtr->typePtr; + if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { + (*typePtr->freeIntRepProc)(objPtr); + } + objPtr->typePtr = &bitmapObjType; + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) NULL; +} + +/* + *---------------------------------------------------------------------- + * * BitmapInit -- * * Initialize the structures used for bitmap management. @@ -545,9 +1003,9 @@ BitmapInit() dummy = Tcl_CreateInterp(); initialized = 1; - Tcl_InitHashTable(&nameTable, sizeof(NameKey)/sizeof(int)); + Tcl_InitHashTable(&nameTable, TCL_STRING_KEYS); Tcl_InitHashTable(&dataTable, sizeof(DataKey)/sizeof(int)); - Tcl_InitHashTable(&tkPredefBitmapTable, TCL_ONE_WORD_KEYS); + Tcl_InitHashTable(&tkPredefBitmapTable, TCL_STRING_KEYS); /* * The call below is tricky: can't use sizeof(IdKey) because it @@ -583,3 +1041,51 @@ BitmapInit() Tcl_DeleteInterp(dummy); } + +/* + *---------------------------------------------------------------------- + * + * TkDebugBitmap -- + * + * This procedure returns debugging information about a bitmap. + * + * Results: + * The return value is a list with one sublist for each TkBitmap + * corresponding to "name". Each sublist has two elements that + * contain the resourceRefCount and objRefCount fields from the + * TkBitmap structure. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TkDebugBitmap(tkwin, name) + Tk_Window tkwin; /* The window in which the bitmap will be + * used (not currently used). */ + char *name; /* Name of the desired color. */ +{ + TkBitmap *bitmapPtr; + Tcl_HashEntry *hashPtr; + Tcl_Obj *resultPtr, *objPtr; + + resultPtr = Tcl_NewObj(); + hashPtr = Tcl_FindHashEntry(&nameTable, name); + if (hashPtr != NULL) { + bitmapPtr = (TkBitmap *) Tcl_GetHashValue(hashPtr); + if (bitmapPtr == NULL) { + panic("TkDebugBitmap found empty hash table entry"); + } + for ( ; (bitmapPtr != NULL); bitmapPtr = bitmapPtr->nextPtr) { + objPtr = Tcl_NewObj(); + Tcl_ListObjAppendElement(NULL, objPtr, + Tcl_NewIntObj(bitmapPtr->resourceRefCount)); + Tcl_ListObjAppendElement(NULL, objPtr, + Tcl_NewIntObj(bitmapPtr->objRefCount)); + Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); + } + } + return resultPtr; +} diff --git a/generic/tkButton.c b/generic/tkButton.c index c9c25c2..527e761 100644 --- a/generic/tkButton.c +++ b/generic/tkButton.c @@ -3,199 +3,448 @@ * * This module implements a collection of button-like * widgets for the Tk toolkit. The widgets implemented - * include labels, buttons, check buttons, and radio - * buttons. + * include labels, buttons, checkbuttons, and radiobuttons. * * Copyright (c) 1990-1994 The Regents of the University of California. - * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * Copyright (c) 1994-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkButton.c 1.144 97/07/31 09:04:57 + * SCCS: @(#) tkButton.c 1.150 98/02/06 19:06:00 */ #include "tkButton.h" #include "default.h" /* - * Class names for buttons, indexed by one of the type values above. + * Class names for buttons, indexed by one of the type values defined + * in tkButton.h. */ static char *classNames[] = {"Label", "Button", "Checkbutton", "Radiobutton"}; /* - * The class procedure table for the button widget. + * The following table defines the legal values for the -default option. + * It is used together with the "enum defaultValue" declaration in tkButton.h. */ -static int configFlags[] = {LABEL_MASK, BUTTON_MASK, - CHECK_BUTTON_MASK, RADIO_BUTTON_MASK}; +static char *defaultStrings[] = { + "active", "disabled", "normal", (char *) NULL +}; + +/* + * The following table defines the legal values for the -state option. + * It is used together with the "enum state" declaration in tkButton.h. + */ + +static char *stateStrings[] = { + "active", "disabled", "normal", (char *) NULL +}; /* - * Information used for parsing configuration specs: + * Information used for parsing configuration options. There is a + * separate table for each of the four widget classes. */ -Tk_ConfigSpec tkpButtonConfigSpecs[] = { - {TK_CONFIG_BORDER, "-activebackground", "activeBackground", "Foreground", - DEF_BUTTON_ACTIVE_BG_COLOR, Tk_Offset(TkButton, activeBorder), - BUTTON_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK - |TK_CONFIG_COLOR_ONLY}, - {TK_CONFIG_BORDER, "-activebackground", "activeBackground", "Foreground", - DEF_BUTTON_ACTIVE_BG_MONO, Tk_Offset(TkButton, activeBorder), - BUTTON_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK - |TK_CONFIG_MONO_ONLY}, - {TK_CONFIG_COLOR, "-activeforeground", "activeForeground", "Background", - DEF_BUTTON_ACTIVE_FG_COLOR, Tk_Offset(TkButton, activeFg), - BUTTON_MASK|TK_CONFIG_COLOR_ONLY}, - {TK_CONFIG_COLOR, "-activeforeground", "activeForeground", "Background", - DEF_CHKRAD_ACTIVE_FG_COLOR, Tk_Offset(TkButton, activeFg), - CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|TK_CONFIG_COLOR_ONLY}, - {TK_CONFIG_COLOR, "-activeforeground", "activeForeground", "Background", - DEF_BUTTON_ACTIVE_FG_MONO, Tk_Offset(TkButton, activeFg), - BUTTON_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK - |TK_CONFIG_MONO_ONLY}, - {TK_CONFIG_ANCHOR, "-anchor", "anchor", "Anchor", - DEF_BUTTON_ANCHOR, Tk_Offset(TkButton, anchor), ALL_MASK}, - {TK_CONFIG_BORDER, "-background", "background", "Background", - DEF_BUTTON_BG_COLOR, Tk_Offset(TkButton, normalBorder), - ALL_MASK | TK_CONFIG_COLOR_ONLY}, - {TK_CONFIG_BORDER, "-background", "background", "Background", - DEF_BUTTON_BG_MONO, Tk_Offset(TkButton, normalBorder), - ALL_MASK | TK_CONFIG_MONO_ONLY}, - {TK_CONFIG_SYNONYM, "-bd", "borderWidth", (char *) NULL, - (char *) NULL, 0, ALL_MASK}, - {TK_CONFIG_SYNONYM, "-bg", "background", (char *) NULL, - (char *) NULL, 0, ALL_MASK}, - {TK_CONFIG_BITMAP, "-bitmap", "bitmap", "Bitmap", - DEF_BUTTON_BITMAP, Tk_Offset(TkButton, bitmap), - ALL_MASK|TK_CONFIG_NULL_OK}, - {TK_CONFIG_PIXELS, "-borderwidth", "borderWidth", "BorderWidth", - DEF_BUTTON_BORDER_WIDTH, Tk_Offset(TkButton, borderWidth), ALL_MASK}, - {TK_CONFIG_STRING, "-command", "command", "Command", - DEF_BUTTON_COMMAND, Tk_Offset(TkButton, command), - BUTTON_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|TK_CONFIG_NULL_OK}, - {TK_CONFIG_ACTIVE_CURSOR, "-cursor", "cursor", "Cursor", - DEF_BUTTON_CURSOR, Tk_Offset(TkButton, cursor), - ALL_MASK|TK_CONFIG_NULL_OK}, - {TK_CONFIG_UID, "-default", "default", "Default", - DEF_BUTTON_DEFAULT, Tk_Offset(TkButton, defaultState), BUTTON_MASK}, - {TK_CONFIG_COLOR, "-disabledforeground", "disabledForeground", +static Tk_OptionSpec labelOptionSpecs[] = { + {TK_OPTION_ANCHOR, "-anchor", "anchor", "Anchor", + DEF_BUTTON_ANCHOR, -1, Tk_Offset(TkButton, anchor), 0, 0, 0}, + {TK_OPTION_BORDER, "-background", "background", "Background", + DEF_BUTTON_BG_COLOR, -1, Tk_Offset(TkButton, normalBorder), + 0, (ClientData) DEF_BUTTON_BG_MONO, 0}, + {TK_OPTION_SYNONYM, "-bd", (char *) NULL, (char *) NULL, + (char *) NULL, 0, -1, 0, (ClientData) "-borderwidth", 0}, + {TK_OPTION_SYNONYM, "-bg", (char *) NULL, (char *) NULL, + (char *) NULL, 0, -1, 0, (ClientData) "-background", 0}, + {TK_OPTION_BITMAP, "-bitmap", "bitmap", "Bitmap", + DEF_BUTTON_BITMAP, -1, Tk_Offset(TkButton, bitmap), + TK_OPTION_NULL_OK, 0, 0}, + {TK_OPTION_PIXELS, "-borderwidth", "borderWidth", "BorderWidth", + DEF_BUTTON_BORDER_WIDTH, Tk_Offset(TkButton, borderWidthPtr), + Tk_Offset(TkButton, borderWidth), 0, 0, 0}, + {TK_OPTION_CURSOR, "-cursor", "cursor", "Cursor", + DEF_BUTTON_CURSOR, -1, Tk_Offset(TkButton, cursor), + TK_OPTION_NULL_OK, 0, 0}, + {TK_OPTION_SYNONYM, "-fg", "foreground", (char *) NULL, + (char *) NULL, 0, -1, 0, (ClientData) "-foreground", 0}, + {TK_OPTION_FONT, "-font", "font", "Font", + DEF_BUTTON_FONT, -1, Tk_Offset(TkButton, tkfont), 0, 0, 0}, + {TK_OPTION_COLOR, "-foreground", "foreground", "Foreground", + DEF_BUTTON_FG, -1, Tk_Offset(TkButton, normalFg), 0, 0, 0}, + {TK_OPTION_STRING, "-height", "height", "Height", + DEF_BUTTON_HEIGHT, Tk_Offset(TkButton, heightPtr), -1, 0, 0, 0}, + {TK_OPTION_BORDER, "-highlightbackground", "highlightBackground", + "HighlightBackground", DEF_BUTTON_HIGHLIGHT_BG_COLOR, + -1, Tk_Offset(TkButton, highlightBorder), 0, + (ClientData) DEF_BUTTON_HIGHLIGHT_BG_MONO, 0}, + {TK_OPTION_COLOR, "-highlightcolor", "highlightColor", "HighlightColor", + DEF_BUTTON_HIGHLIGHT, -1, Tk_Offset(TkButton, highlightColorPtr), + 0, 0, 0}, + {TK_OPTION_PIXELS, "-highlightthickness", "highlightThickness", + "HighlightThickness", DEF_LABEL_HIGHLIGHT_WIDTH, + Tk_Offset(TkButton, highlightWidthPtr), + Tk_Offset(TkButton, highlightWidth), 0, 0, 0}, + {TK_OPTION_STRING, "-image", "image", "Image", + DEF_BUTTON_IMAGE, Tk_Offset(TkButton, imagePtr), -1, + TK_OPTION_NULL_OK, 0, 0}, + {TK_OPTION_JUSTIFY, "-justify", "justify", "Justify", + DEF_BUTTON_JUSTIFY, -1, Tk_Offset(TkButton, justify), 0, 0, 0}, + {TK_OPTION_PIXELS, "-padx", "padX", "Pad", + DEF_LABCHKRAD_PADX, Tk_Offset(TkButton, padXPtr), + Tk_Offset(TkButton, padX), 0, 0, 0}, + {TK_OPTION_PIXELS, "-pady", "padY", "Pad", + DEF_LABCHKRAD_PADY, Tk_Offset(TkButton, padYPtr), + Tk_Offset(TkButton, padY), 0, 0, 0}, + {TK_OPTION_RELIEF, "-relief", "relief", "Relief", + DEF_LABCHKRAD_RELIEF, -1, Tk_Offset(TkButton, relief), 0, 0, 0}, + {TK_OPTION_STRING, "-takefocus", "takeFocus", "TakeFocus", + DEF_LABEL_TAKE_FOCUS, Tk_Offset(TkButton, takeFocusPtr), -1, + TK_OPTION_NULL_OK, 0, 0}, + {TK_OPTION_STRING, "-text", "text", "Text", + DEF_BUTTON_TEXT, Tk_Offset(TkButton, textPtr), -1, 0, 0, 0}, + {TK_OPTION_STRING, "-textvariable", "textVariable", "Variable", + DEF_BUTTON_TEXT_VARIABLE, Tk_Offset(TkButton, textVarNamePtr), -1, + TK_OPTION_NULL_OK, 0, 0}, + {TK_OPTION_INT, "-underline", "underline", "Underline", + DEF_BUTTON_UNDERLINE, -1, Tk_Offset(TkButton, underline), 0, 0, 0}, + {TK_OPTION_STRING, "-width", "width", "Width", + DEF_BUTTON_WIDTH, Tk_Offset(TkButton, widthPtr), -1, 0, 0, 0}, + {TK_OPTION_PIXELS, "-wraplength", "wrapLength", "WrapLength", + DEF_BUTTON_WRAP_LENGTH, Tk_Offset(TkButton, wrapLengthPtr), + Tk_Offset(TkButton, wrapLength), 0, 0, 0}, + {TK_OPTION_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, 0, 0, 0} +}; + +static Tk_OptionSpec buttonOptionSpecs[] = { + {TK_OPTION_BORDER, "-activebackground", "activeBackground", "Foreground", + DEF_BUTTON_ACTIVE_BG_COLOR, -1, Tk_Offset(TkButton, activeBorder), + 0, (ClientData) DEF_BUTTON_ACTIVE_BG_MONO, 0}, + {TK_OPTION_COLOR, "-activeforeground", "activeForeground", "Background", + DEF_BUTTON_ACTIVE_FG_COLOR, -1, Tk_Offset(TkButton, activeFg), + TK_OPTION_NULL_OK, (ClientData) DEF_BUTTON_ACTIVE_FG_MONO, 0}, + {TK_OPTION_ANCHOR, "-anchor", "anchor", "Anchor", + DEF_BUTTON_ANCHOR, -1, Tk_Offset(TkButton, anchor), 0, 0, 0}, + {TK_OPTION_BORDER, "-background", "background", "Background", + DEF_BUTTON_BG_COLOR, -1, Tk_Offset(TkButton, normalBorder), + 0, (ClientData) DEF_BUTTON_BG_MONO, 0}, + {TK_OPTION_SYNONYM, "-bd", (char *) NULL, (char *) NULL, + (char *) NULL, 0, -1, 0, (ClientData) "-borderwidth", 0}, + {TK_OPTION_SYNONYM, "-bg", (char *) NULL, (char *) NULL, + (char *) NULL, 0, -1, 0, (ClientData) "-background", 0}, + {TK_OPTION_BITMAP, "-bitmap", "bitmap", "Bitmap", + DEF_BUTTON_BITMAP, -1, Tk_Offset(TkButton, bitmap), + TK_OPTION_NULL_OK, 0, 0}, + {TK_OPTION_PIXELS, "-borderwidth", "borderWidth", "BorderWidth", + DEF_BUTTON_BORDER_WIDTH, Tk_Offset(TkButton, borderWidthPtr), + Tk_Offset(TkButton, borderWidth), 0, 0, 0}, + {TK_OPTION_STRING, "-command", "command", "Command", + DEF_BUTTON_COMMAND, Tk_Offset(TkButton, commandPtr), -1, + TK_OPTION_NULL_OK, 0, 0}, + {TK_OPTION_CURSOR, "-cursor", "cursor", "Cursor", + DEF_BUTTON_CURSOR, -1, Tk_Offset(TkButton, cursor), + TK_OPTION_NULL_OK, 0, 0}, + {TK_OPTION_STRING_TABLE, "-default", "default", "Default", + DEF_BUTTON_DEFAULT, -1, Tk_Offset(TkButton, defaultState), + 0, (ClientData) defaultStrings, 0}, + {TK_OPTION_COLOR, "-disabledforeground", "disabledForeground", + "DisabledForeground", DEF_BUTTON_DISABLED_FG_COLOR, + -1, Tk_Offset(TkButton, disabledFg), TK_OPTION_NULL_OK, + (ClientData) DEF_BUTTON_DISABLED_FG_MONO, 0}, + {TK_OPTION_SYNONYM, "-fg", "foreground", (char *) NULL, + (char *) NULL, 0, -1, 0, (ClientData) "-foreground", 0}, + {TK_OPTION_FONT, "-font", "font", "Font", + DEF_BUTTON_FONT, -1, Tk_Offset(TkButton, tkfont), 0, 0, 0}, + {TK_OPTION_COLOR, "-foreground", "foreground", "Foreground", + DEF_BUTTON_FG, -1, Tk_Offset(TkButton, normalFg), 0, 0, 0}, + {TK_OPTION_STRING, "-height", "height", "Height", + DEF_BUTTON_HEIGHT, Tk_Offset(TkButton, heightPtr), -1, 0, 0, 0}, + {TK_OPTION_BORDER, "-highlightbackground", "highlightBackground", + "HighlightBackground", DEF_BUTTON_HIGHLIGHT_BG_COLOR, + -1, Tk_Offset(TkButton, highlightBorder), 0, + (ClientData) DEF_BUTTON_HIGHLIGHT_BG_MONO, 0}, + {TK_OPTION_COLOR, "-highlightcolor", "highlightColor", "HighlightColor", + DEF_BUTTON_HIGHLIGHT, -1, Tk_Offset(TkButton, highlightColorPtr), + 0, 0, 0}, + {TK_OPTION_PIXELS, "-highlightthickness", "highlightThickness", + "HighlightThickness", DEF_BUTTON_HIGHLIGHT_WIDTH, + Tk_Offset(TkButton, highlightWidthPtr), + Tk_Offset(TkButton, highlightWidth), 0, 0, 0}, + {TK_OPTION_STRING, "-image", "image", "Image", + DEF_BUTTON_IMAGE, Tk_Offset(TkButton, imagePtr), -1, + TK_OPTION_NULL_OK, 0, 0}, + {TK_OPTION_JUSTIFY, "-justify", "justify", "Justify", + DEF_BUTTON_JUSTIFY, -1, Tk_Offset(TkButton, justify), 0, 0, 0}, + {TK_OPTION_PIXELS, "-padx", "padX", "Pad", + DEF_BUTTON_PADX, Tk_Offset(TkButton, padXPtr), + Tk_Offset(TkButton, padX), 0, 0, 0}, + {TK_OPTION_PIXELS, "-pady", "padY", "Pad", + DEF_BUTTON_PADY, Tk_Offset(TkButton, padYPtr), + Tk_Offset(TkButton, padY), 0, 0, 0}, + {TK_OPTION_RELIEF, "-relief", "relief", "Relief", + DEF_BUTTON_RELIEF, -1, Tk_Offset(TkButton, relief), 0, 0, 0}, + {TK_OPTION_STRING_TABLE, "-state", "state", "State", + DEF_BUTTON_STATE, -1, Tk_Offset(TkButton, state), + 0, (ClientData) stateStrings, 0}, + {TK_OPTION_STRING, "-takefocus", "takeFocus", "TakeFocus", + DEF_BUTTON_TAKE_FOCUS, Tk_Offset(TkButton, takeFocusPtr), -1, + TK_OPTION_NULL_OK, 0, 0}, + {TK_OPTION_STRING, "-text", "text", "Text", + DEF_BUTTON_TEXT, Tk_Offset(TkButton, textPtr), -1, 0, 0, 0}, + {TK_OPTION_STRING, "-textvariable", "textVariable", "Variable", + DEF_BUTTON_TEXT_VARIABLE, Tk_Offset(TkButton, textVarNamePtr), -1, + TK_OPTION_NULL_OK, 0, 0}, + {TK_OPTION_INT, "-underline", "underline", "Underline", + DEF_BUTTON_UNDERLINE, -1, Tk_Offset(TkButton, underline), 0, 0, 0}, + {TK_OPTION_STRING, "-width", "width", "Width", + DEF_BUTTON_WIDTH, Tk_Offset(TkButton, widthPtr), -1, 0, 0, 0}, + {TK_OPTION_PIXELS, "-wraplength", "wrapLength", "WrapLength", + DEF_BUTTON_WRAP_LENGTH, Tk_Offset(TkButton, wrapLengthPtr), + Tk_Offset(TkButton, wrapLength), 0, 0, 0}, + {TK_OPTION_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, -1, 0, 0, 0} +}; + +static Tk_OptionSpec checkbuttonOptionSpecs[] = { + {TK_OPTION_BORDER, "-activebackground", "activeBackground", "Foreground", + DEF_BUTTON_ACTIVE_BG_COLOR, -1, Tk_Offset(TkButton, activeBorder), + 0, (ClientData) DEF_BUTTON_ACTIVE_BG_MONO, 0}, + {TK_OPTION_COLOR, "-activeforeground", "activeForeground", "Background", + DEF_CHKRAD_ACTIVE_FG_COLOR, -1, Tk_Offset(TkButton, activeFg), + TK_OPTION_NULL_OK, (ClientData) DEF_BUTTON_ACTIVE_FG_MONO, 0}, + {TK_OPTION_ANCHOR, "-anchor", "anchor", "Anchor", + DEF_BUTTON_ANCHOR, -1, Tk_Offset(TkButton, anchor), 0, 0, 0}, + {TK_OPTION_BORDER, "-background", "background", "Background", + DEF_BUTTON_BG_COLOR, -1, Tk_Offset(TkButton, normalBorder), + 0, (ClientData) DEF_BUTTON_BG_MONO, 0}, + {TK_OPTION_SYNONYM, "-bd", (char *) NULL, (char *) NULL, + (char *) NULL, 0, -1, 0, (ClientData) "-borderwidth", 0}, + {TK_OPTION_SYNONYM, "-bg", (char *) NULL, (char *) NULL, + (char *) NULL, 0, -1, 0, (ClientData) "-background", 0}, + {TK_OPTION_BITMAP, "-bitmap", "bitmap", "Bitmap", + DEF_BUTTON_BITMAP, -1, Tk_Offset(TkButton, bitmap), + TK_OPTION_NULL_OK, 0, 0}, + {TK_OPTION_PIXELS, "-borderwidth", "borderWidth", "BorderWidth", + DEF_BUTTON_BORDER_WIDTH, Tk_Offset(TkButton, borderWidthPtr), + Tk_Offset(TkButton, borderWidth), 0, 0, 0}, + {TK_OPTION_STRING, "-command", "command", "Command", + DEF_BUTTON_COMMAND, Tk_Offset(TkButton, commandPtr), -1, + TK_OPTION_NULL_OK, 0, 0}, + {TK_OPTION_CURSOR, "-cursor", "cursor", "Cursor", + DEF_BUTTON_CURSOR, -1, Tk_Offset(TkButton, cursor), + TK_OPTION_NULL_OK, 0, 0}, + {TK_OPTION_COLOR, "-disabledforeground", "disabledForeground", "DisabledForeground", DEF_BUTTON_DISABLED_FG_COLOR, - Tk_Offset(TkButton, disabledFg), BUTTON_MASK|CHECK_BUTTON_MASK - |RADIO_BUTTON_MASK|TK_CONFIG_COLOR_ONLY|TK_CONFIG_NULL_OK}, - {TK_CONFIG_COLOR, "-disabledforeground", "disabledForeground", - "DisabledForeground", DEF_BUTTON_DISABLED_FG_MONO, - Tk_Offset(TkButton, disabledFg), BUTTON_MASK|CHECK_BUTTON_MASK - |RADIO_BUTTON_MASK|TK_CONFIG_MONO_ONLY|TK_CONFIG_NULL_OK}, - {TK_CONFIG_SYNONYM, "-fg", "foreground", (char *) NULL, - (char *) NULL, 0, ALL_MASK}, - {TK_CONFIG_FONT, "-font", "font", "Font", - DEF_BUTTON_FONT, Tk_Offset(TkButton, tkfont), - ALL_MASK}, - {TK_CONFIG_COLOR, "-foreground", "foreground", "Foreground", - DEF_BUTTON_FG, Tk_Offset(TkButton, normalFg), LABEL_MASK|BUTTON_MASK}, - {TK_CONFIG_COLOR, "-foreground", "foreground", "Foreground", - DEF_CHKRAD_FG, Tk_Offset(TkButton, normalFg), CHECK_BUTTON_MASK - |RADIO_BUTTON_MASK}, - {TK_CONFIG_STRING, "-height", "height", "Height", - DEF_BUTTON_HEIGHT, Tk_Offset(TkButton, heightString), ALL_MASK}, - {TK_CONFIG_BORDER, "-highlightbackground", "highlightBackground", - "HighlightBackground", DEF_BUTTON_HIGHLIGHT_BG, - Tk_Offset(TkButton, highlightBorder), ALL_MASK}, - {TK_CONFIG_COLOR, "-highlightcolor", "highlightColor", "HighlightColor", - DEF_BUTTON_HIGHLIGHT, Tk_Offset(TkButton, highlightColorPtr), - ALL_MASK}, - {TK_CONFIG_PIXELS, "-highlightthickness", "highlightThickness", - "HighlightThickness", - DEF_LABEL_HIGHLIGHT_WIDTH, Tk_Offset(TkButton, highlightWidth), - LABEL_MASK}, - {TK_CONFIG_PIXELS, "-highlightthickness", "highlightThickness", - "HighlightThickness", - DEF_BUTTON_HIGHLIGHT_WIDTH, Tk_Offset(TkButton, highlightWidth), - BUTTON_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK}, - {TK_CONFIG_STRING, "-image", "image", "Image", - DEF_BUTTON_IMAGE, Tk_Offset(TkButton, imageString), - ALL_MASK|TK_CONFIG_NULL_OK}, - {TK_CONFIG_BOOLEAN, "-indicatoron", "indicatorOn", "IndicatorOn", - DEF_BUTTON_INDICATOR, Tk_Offset(TkButton, indicatorOn), - CHECK_BUTTON_MASK|RADIO_BUTTON_MASK}, - {TK_CONFIG_JUSTIFY, "-justify", "justify", "Justify", - DEF_BUTTON_JUSTIFY, Tk_Offset(TkButton, justify), ALL_MASK}, - {TK_CONFIG_STRING, "-offvalue", "offValue", "Value", - DEF_BUTTON_OFF_VALUE, Tk_Offset(TkButton, offValue), - CHECK_BUTTON_MASK}, - {TK_CONFIG_STRING, "-onvalue", "onValue", "Value", - DEF_BUTTON_ON_VALUE, Tk_Offset(TkButton, onValue), - CHECK_BUTTON_MASK}, - {TK_CONFIG_PIXELS, "-padx", "padX", "Pad", - DEF_BUTTON_PADX, Tk_Offset(TkButton, padX), BUTTON_MASK}, - {TK_CONFIG_PIXELS, "-padx", "padX", "Pad", - DEF_LABCHKRAD_PADX, Tk_Offset(TkButton, padX), - LABEL_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK}, - {TK_CONFIG_PIXELS, "-pady", "padY", "Pad", - DEF_BUTTON_PADY, Tk_Offset(TkButton, padY), BUTTON_MASK}, - {TK_CONFIG_PIXELS, "-pady", "padY", "Pad", - DEF_LABCHKRAD_PADY, Tk_Offset(TkButton, padY), - LABEL_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK}, - {TK_CONFIG_RELIEF, "-relief", "relief", "Relief", - DEF_BUTTON_RELIEF, Tk_Offset(TkButton, relief), BUTTON_MASK}, - {TK_CONFIG_RELIEF, "-relief", "relief", "Relief", - DEF_LABCHKRAD_RELIEF, Tk_Offset(TkButton, relief), - LABEL_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK}, - {TK_CONFIG_BORDER, "-selectcolor", "selectColor", "Background", - DEF_BUTTON_SELECT_COLOR, Tk_Offset(TkButton, selectBorder), - CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|TK_CONFIG_COLOR_ONLY - |TK_CONFIG_NULL_OK}, - {TK_CONFIG_BORDER, "-selectcolor", "selectColor", "Background", - DEF_BUTTON_SELECT_MONO, Tk_Offset(TkButton, selectBorder), - CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|TK_CONFIG_MONO_ONLY - |TK_CONFIG_NULL_OK}, - {TK_CONFIG_STRING, "-selectimage", "selectImage", "SelectImage", - DEF_BUTTON_SELECT_IMAGE, Tk_Offset(TkButton, selectImageString), - CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|TK_CONFIG_NULL_OK}, - {TK_CONFIG_UID, "-state", "state", "State", - DEF_BUTTON_STATE, Tk_Offset(TkButton, state), - BUTTON_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK}, - {TK_CONFIG_STRING, "-takefocus", "takeFocus", "TakeFocus", - DEF_LABEL_TAKE_FOCUS, Tk_Offset(TkButton, takeFocus), - LABEL_MASK|TK_CONFIG_NULL_OK}, - {TK_CONFIG_STRING, "-takefocus", "takeFocus", "TakeFocus", - DEF_BUTTON_TAKE_FOCUS, Tk_Offset(TkButton, takeFocus), - BUTTON_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|TK_CONFIG_NULL_OK}, - {TK_CONFIG_STRING, "-text", "text", "Text", - DEF_BUTTON_TEXT, Tk_Offset(TkButton, text), ALL_MASK}, - {TK_CONFIG_STRING, "-textvariable", "textVariable", "Variable", - DEF_BUTTON_TEXT_VARIABLE, Tk_Offset(TkButton, textVarName), - ALL_MASK|TK_CONFIG_NULL_OK}, - {TK_CONFIG_INT, "-underline", "underline", "Underline", - DEF_BUTTON_UNDERLINE, Tk_Offset(TkButton, underline), ALL_MASK}, - {TK_CONFIG_STRING, "-value", "value", "Value", - DEF_BUTTON_VALUE, Tk_Offset(TkButton, onValue), - RADIO_BUTTON_MASK}, - {TK_CONFIG_STRING, "-variable", "variable", "Variable", - DEF_RADIOBUTTON_VARIABLE, Tk_Offset(TkButton, selVarName), - RADIO_BUTTON_MASK}, - {TK_CONFIG_STRING, "-variable", "variable", "Variable", - DEF_CHECKBUTTON_VARIABLE, Tk_Offset(TkButton, selVarName), - CHECK_BUTTON_MASK|TK_CONFIG_NULL_OK}, - {TK_CONFIG_STRING, "-width", "width", "Width", - DEF_BUTTON_WIDTH, Tk_Offset(TkButton, widthString), ALL_MASK}, - {TK_CONFIG_PIXELS, "-wraplength", "wrapLength", "WrapLength", - DEF_BUTTON_WRAP_LENGTH, Tk_Offset(TkButton, wrapLength), ALL_MASK}, - {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, - (char *) NULL, 0, 0} + -1, Tk_Offset(TkButton, disabledFg), TK_OPTION_NULL_OK, + (ClientData) DEF_BUTTON_DISABLED_FG_MONO, 0}, + {TK_OPTION_SYNONYM, "-fg", "foreground", (char *) NULL, + (char *) NULL, 0, -1, 0, (ClientData) "-foreground", 0}, + {TK_OPTION_FONT, "-font", "font", "Font", + DEF_BUTTON_FONT, -1, Tk_Offset(TkButton, tkfont), 0, 0, 0}, + {TK_OPTION_COLOR, "-foreground", "foreground", "Foreground", + DEF_CHKRAD_FG, -1, Tk_Offset(TkButton, normalFg), 0, 0, 0}, + {TK_OPTION_STRING, "-height", "height", "Height", + DEF_BUTTON_HEIGHT, Tk_Offset(TkButton, heightPtr), -1, 0, 0, 0}, + {TK_OPTION_BORDER, "-highlightbackground", "highlightBackground", + "HighlightBackground", DEF_BUTTON_HIGHLIGHT_BG_COLOR, + -1, Tk_Offset(TkButton, highlightBorder), 0, + (ClientData) DEF_BUTTON_HIGHLIGHT_BG_MONO, 0}, + {TK_OPTION_COLOR, "-highlightcolor", "highlightColor", "HighlightColor", + DEF_BUTTON_HIGHLIGHT, -1, Tk_Offset(TkButton, highlightColorPtr), + 0, 0, 0}, + {TK_OPTION_PIXELS, "-highlightthickness", "highlightThickness", + "HighlightThickness", DEF_BUTTON_HIGHLIGHT_WIDTH, + Tk_Offset(TkButton, highlightWidthPtr), + Tk_Offset(TkButton, highlightWidth), 0, 0, 0}, + {TK_OPTION_STRING, "-image", "image", "Image", + DEF_BUTTON_IMAGE, Tk_Offset(TkButton, imagePtr), -1, + TK_OPTION_NULL_OK, 0, 0}, + {TK_OPTION_BOOLEAN, "-indicatoron", "indicatorOn", "IndicatorOn", + DEF_BUTTON_INDICATOR, -1, Tk_Offset(TkButton, indicatorOn), 0, 0, 0}, + {TK_OPTION_JUSTIFY, "-justify", "justify", "Justify", + DEF_BUTTON_JUSTIFY, -1, Tk_Offset(TkButton, justify), 0, 0, 0}, + {TK_OPTION_STRING, "-offvalue", "offValue", "Value", + DEF_BUTTON_OFF_VALUE, Tk_Offset(TkButton, offValuePtr), -1, 0, 0, 0}, + {TK_OPTION_STRING, "-onvalue", "onValue", "Value", + DEF_BUTTON_ON_VALUE, Tk_Offset(TkButton, onValuePtr), -1, 0, 0, 0}, + {TK_OPTION_PIXELS, "-padx", "padX", "Pad", + DEF_LABCHKRAD_PADX, Tk_Offset(TkButton, padXPtr), + Tk_Offset(TkButton, padX), 0, 0, 0}, + {TK_OPTION_PIXELS, "-pady", "padY", "Pad", + DEF_LABCHKRAD_PADY, Tk_Offset(TkButton, padYPtr), + Tk_Offset(TkButton, padY), 0, 0, 0}, + {TK_OPTION_RELIEF, "-relief", "relief", "Relief", + DEF_LABCHKRAD_RELIEF, -1, Tk_Offset(TkButton, relief), 0, 0, 0}, + {TK_OPTION_BORDER, "-selectcolor", "selectColor", "Background", + DEF_BUTTON_SELECT_COLOR, -1, Tk_Offset(TkButton, selectBorder), + TK_OPTION_NULL_OK, (ClientData) DEF_BUTTON_SELECT_MONO, 0}, + {TK_OPTION_STRING, "-selectimage", "selectImage", "SelectImage", + DEF_BUTTON_SELECT_IMAGE, Tk_Offset(TkButton, selectImagePtr), -1, + TK_OPTION_NULL_OK, 0, 0}, + {TK_OPTION_STRING_TABLE, "-state", "state", "State", + DEF_BUTTON_STATE, -1, Tk_Offset(TkButton, state), + 0, (ClientData) stateStrings, 0}, + {TK_OPTION_STRING, "-takefocus", "takeFocus", "TakeFocus", + DEF_BUTTON_TAKE_FOCUS, Tk_Offset(TkButton, takeFocusPtr), -1, + TK_OPTION_NULL_OK, 0, 0}, + {TK_OPTION_STRING, "-text", "text", "Text", + DEF_BUTTON_TEXT, Tk_Offset(TkButton, textPtr), -1, 0, 0, 0}, + {TK_OPTION_STRING, "-textvariable", "textVariable", "Variable", + DEF_BUTTON_TEXT_VARIABLE, Tk_Offset(TkButton, textVarNamePtr), -1, + TK_OPTION_NULL_OK, 0, 0}, + {TK_OPTION_INT, "-underline", "underline", "Underline", + DEF_BUTTON_UNDERLINE, -1, Tk_Offset(TkButton, underline), 0, 0, 0}, + {TK_OPTION_STRING, "-variable", "variable", "Variable", + DEF_CHECKBUTTON_VARIABLE, Tk_Offset(TkButton, selVarNamePtr), -1, + TK_OPTION_NULL_OK, 0, 0}, + {TK_OPTION_STRING, "-width", "width", "Width", + DEF_BUTTON_WIDTH, Tk_Offset(TkButton, widthPtr), -1, 0, 0, 0}, + {TK_OPTION_PIXELS, "-wraplength", "wrapLength", "WrapLength", + DEF_BUTTON_WRAP_LENGTH, Tk_Offset(TkButton, wrapLengthPtr), + Tk_Offset(TkButton, wrapLength), 0, 0, 0}, + {TK_OPTION_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, -1, 0, 0, 0} +}; + +static Tk_OptionSpec radiobuttonOptionSpecs[] = { + {TK_OPTION_BORDER, "-activebackground", "activeBackground", "Foreground", + DEF_BUTTON_ACTIVE_BG_COLOR, -1, Tk_Offset(TkButton, activeBorder), + 0, (ClientData) DEF_BUTTON_ACTIVE_BG_MONO, 0}, + {TK_OPTION_COLOR, "-activeforeground", "activeForeground", "Background", + DEF_CHKRAD_ACTIVE_FG_COLOR, -1, Tk_Offset(TkButton, activeFg), + TK_OPTION_NULL_OK, (ClientData) DEF_BUTTON_ACTIVE_FG_MONO, 0}, + {TK_OPTION_ANCHOR, "-anchor", "anchor", "Anchor", + DEF_BUTTON_ANCHOR, -1, Tk_Offset(TkButton, anchor), 0, 0, 0}, + {TK_OPTION_BORDER, "-background", "background", "Background", + DEF_BUTTON_BG_COLOR, -1, Tk_Offset(TkButton, normalBorder), + 0, (ClientData) DEF_BUTTON_BG_MONO, 0}, + {TK_OPTION_SYNONYM, "-bd", (char *) NULL, (char *) NULL, + (char *) NULL, 0, -1, 0, (ClientData) "-borderwidth", 0}, + {TK_OPTION_SYNONYM, "-bg", (char *) NULL, (char *) NULL, + (char *) NULL, 0, -1, 0, (ClientData) "-background", 0}, + {TK_OPTION_BITMAP, "-bitmap", "bitmap", "Bitmap", + DEF_BUTTON_BITMAP, -1, Tk_Offset(TkButton, bitmap), + TK_OPTION_NULL_OK, 0, 0}, + {TK_OPTION_PIXELS, "-borderwidth", "borderWidth", "BorderWidth", + DEF_BUTTON_BORDER_WIDTH, Tk_Offset(TkButton, borderWidthPtr), + Tk_Offset(TkButton, borderWidth), 0, 0, 0}, + {TK_OPTION_STRING, "-command", "command", "Command", + DEF_BUTTON_COMMAND, Tk_Offset(TkButton, commandPtr), -1, + TK_OPTION_NULL_OK, 0, 0}, + {TK_OPTION_CURSOR, "-cursor", "cursor", "Cursor", + DEF_BUTTON_CURSOR, -1, Tk_Offset(TkButton, cursor), + TK_OPTION_NULL_OK, 0, 0}, + {TK_OPTION_COLOR, "-disabledforeground", "disabledForeground", + "DisabledForeground", DEF_BUTTON_DISABLED_FG_COLOR, + -1, Tk_Offset(TkButton, disabledFg), TK_OPTION_NULL_OK, + (ClientData) DEF_BUTTON_DISABLED_FG_MONO, 0}, + {TK_OPTION_SYNONYM, "-fg", "foreground", (char *) NULL, + (char *) NULL, 0, -1, 0, (ClientData) "-foreground", 0}, + {TK_OPTION_FONT, "-font", "font", "Font", + DEF_BUTTON_FONT, -1, Tk_Offset(TkButton, tkfont), 0, 0, 0}, + {TK_OPTION_COLOR, "-foreground", "foreground", "Foreground", + DEF_CHKRAD_FG, -1, Tk_Offset(TkButton, normalFg), 0, 0, 0}, + {TK_OPTION_STRING, "-height", "height", "Height", + DEF_BUTTON_HEIGHT, Tk_Offset(TkButton, heightPtr), -1, 0, 0, 0}, + {TK_OPTION_BORDER, "-highlightbackground", "highlightBackground", + "HighlightBackground", DEF_BUTTON_HIGHLIGHT_BG_COLOR, + -1, Tk_Offset(TkButton, highlightBorder), 0, + (ClientData) DEF_BUTTON_HIGHLIGHT_BG_MONO, 0}, + {TK_OPTION_COLOR, "-highlightcolor", "highlightColor", "HighlightColor", + DEF_BUTTON_HIGHLIGHT, -1, Tk_Offset(TkButton, highlightColorPtr), + 0, 0, 0}, + {TK_OPTION_PIXELS, "-highlightthickness", "highlightThickness", + "HighlightThickness", DEF_BUTTON_HIGHLIGHT_WIDTH, + Tk_Offset(TkButton, highlightWidthPtr), + Tk_Offset(TkButton, highlightWidth), 0, 0, 0}, + {TK_OPTION_STRING, "-image", "image", "Image", + DEF_BUTTON_IMAGE, Tk_Offset(TkButton, imagePtr), -1, + TK_OPTION_NULL_OK, 0, 0}, + {TK_OPTION_BOOLEAN, "-indicatoron", "indicatorOn", "IndicatorOn", + DEF_BUTTON_INDICATOR, -1, Tk_Offset(TkButton, indicatorOn), + 0, 0, 0}, + {TK_OPTION_JUSTIFY, "-justify", "justify", "Justify", + DEF_BUTTON_JUSTIFY, -1, Tk_Offset(TkButton, justify), 0, 0, 0}, + {TK_OPTION_PIXELS, "-padx", "padX", "Pad", + DEF_LABCHKRAD_PADX, Tk_Offset(TkButton, padXPtr), + Tk_Offset(TkButton, padX), 0, 0, 0}, + {TK_OPTION_PIXELS, "-pady", "padY", "Pad", + DEF_LABCHKRAD_PADY, Tk_Offset(TkButton, padYPtr), + Tk_Offset(TkButton, padY), 0, 0, 0}, + {TK_OPTION_RELIEF, "-relief", "relief", "Relief", + DEF_LABCHKRAD_RELIEF, -1, Tk_Offset(TkButton, relief), 0, 0, 0}, + {TK_OPTION_BORDER, "-selectcolor", "selectColor", "Background", + DEF_BUTTON_SELECT_COLOR, -1, Tk_Offset(TkButton, selectBorder), + TK_OPTION_NULL_OK, (ClientData) DEF_BUTTON_SELECT_MONO, 0}, + {TK_OPTION_STRING, "-selectimage", "selectImage", "SelectImage", + DEF_BUTTON_SELECT_IMAGE, Tk_Offset(TkButton, selectImagePtr), -1, + TK_OPTION_NULL_OK, 0, 0}, + {TK_OPTION_STRING_TABLE, "-state", "state", "State", + DEF_BUTTON_STATE, -1, Tk_Offset(TkButton, state), + 0, (ClientData) stateStrings, 0}, + {TK_OPTION_STRING, "-takefocus", "takeFocus", "TakeFocus", + DEF_BUTTON_TAKE_FOCUS, Tk_Offset(TkButton, takeFocusPtr), -1, + TK_OPTION_NULL_OK, 0, 0}, + {TK_OPTION_STRING, "-text", "text", "Text", + DEF_BUTTON_TEXT, Tk_Offset(TkButton, textPtr), -1, 0, 0, 0}, + {TK_OPTION_STRING, "-textvariable", "textVariable", "Variable", + DEF_BUTTON_TEXT_VARIABLE, Tk_Offset(TkButton, textVarNamePtr), -1, + TK_OPTION_NULL_OK, 0, 0}, + {TK_OPTION_INT, "-underline", "underline", "Underline", + DEF_BUTTON_UNDERLINE, -1, Tk_Offset(TkButton, underline), 0, 0, 0}, + {TK_OPTION_STRING, "-value", "value", "Value", + DEF_BUTTON_VALUE, Tk_Offset(TkButton, onValuePtr), -1, 0, 0, 0}, + {TK_OPTION_STRING, "-variable", "variable", "Variable", + DEF_RADIOBUTTON_VARIABLE, Tk_Offset(TkButton, selVarNamePtr), -1, + 0, 0, 0}, + {TK_OPTION_STRING, "-width", "width", "Width", + DEF_BUTTON_WIDTH, Tk_Offset(TkButton, widthPtr), -1, 0, 0, 0}, + {TK_OPTION_PIXELS, "-wraplength", "wrapLength", "WrapLength", + DEF_BUTTON_WRAP_LENGTH, Tk_Offset(TkButton, wrapLengthPtr), + Tk_Offset(TkButton, wrapLength), 0, 0, 0}, + {TK_OPTION_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, -1, 0, 0, 0} }; /* - * String to print out in error messages, identifying options for - * widget commands for different types of labels or buttons: + * The following table maps from one of the type values defined in + * tkButton.h, such as TYPE_LABEL, to the option template for that + * class of widgets. */ -static char *optionStrings[] = { - "cget or configure", - "cget, configure, flash, or invoke", - "cget, configure, deselect, flash, invoke, select, or toggle", - "cget, configure, deselect, flash, invoke, or select" +static Tk_OptionSpec *optionSpecs[] = { + labelOptionSpecs, + buttonOptionSpecs, + checkbuttonOptionSpecs, + radiobuttonOptionSpecs +}; + +/* + * The following tables define the widget commands supported by + * each of the classes, and map the indexes into the string tables + * into a single enumerated type used to dispatch the widget command. + */ + +static char *commandNames[][8] = { + {"cget", "configure", (char *) NULL}, + {"cget", "configure", "flash", "invoke", (char *) NULL}, + {"cget", "configure", "deselect", "flash", "invoke", "select", + "toggle", (char *) NULL}, + {"cget", "configure", "deselect", "flash", "invoke", "select", + (char *) NULL} +}; +enum command { + COMMAND_CGET, COMMAND_CONFIGURE, COMMAND_DESELECT, COMMAND_FLASH, + COMMAND_INVOKE, COMMAND_SELECT, COMMAND_TOGGLE +}; +static enum command map[][8] = { + {COMMAND_CGET, COMMAND_CONFIGURE}, + {COMMAND_CGET, COMMAND_CONFIGURE, COMMAND_FLASH, COMMAND_INVOKE}, + {COMMAND_CGET, COMMAND_CONFIGURE, COMMAND_DESELECT, COMMAND_FLASH, + COMMAND_INVOKE, COMMAND_SELECT, COMMAND_TOGGLE}, + {COMMAND_CGET, COMMAND_CONFIGURE, COMMAND_DESELECT, COMMAND_FLASH, + COMMAND_INVOKE, COMMAND_SELECT} }; /* @@ -205,8 +454,8 @@ static char *optionStrings[] = { static void ButtonCmdDeletedProc _ANSI_ARGS_(( ClientData clientData)); static int ButtonCreate _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv, - int type)); + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[], int type)); static void ButtonEventProc _ANSI_ARGS_((ClientData clientData, XEvent *eventPtr)); static void ButtonImageProc _ANSI_ARGS_((ClientData clientData, @@ -221,13 +470,13 @@ static char * ButtonTextVarProc _ANSI_ARGS_((ClientData clientData, static char * ButtonVarProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, char *name1, char *name2, int flags)); -static int ButtonWidgetCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +static int ButtonWidgetObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); static int ConfigureButton _ANSI_ARGS_((Tcl_Interp *interp, - TkButton *butPtr, int argc, char **argv, - int flags)); + TkButton *butPtr, int objc, + Tcl_Obj *CONST objv[])); static void DestroyButton _ANSI_ARGS_((TkButton *butPtr)); - /* *-------------------------------------------------------------- @@ -249,47 +498,43 @@ static void DestroyButton _ANSI_ARGS_((TkButton *butPtr)); */ int -Tk_ButtonCmd(clientData, interp, argc, argv) - ClientData clientData; /* Main window associated with - * interpreter. */ +Tk_ButtonObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Either NULL or pointer to option table. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument values. */ { - return ButtonCreate(clientData, interp, argc, argv, TYPE_BUTTON); + return ButtonCreate(clientData, interp, objc, objv, TYPE_BUTTON); } int -Tk_CheckbuttonCmd(clientData, interp, argc, argv) - ClientData clientData; /* Main window associated with - * interpreter. */ +Tk_CheckbuttonObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Either NULL or pointer to option table. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument values. */ { - return ButtonCreate(clientData, interp, argc, argv, TYPE_CHECK_BUTTON); + return ButtonCreate(clientData, interp, objc, objv, TYPE_CHECK_BUTTON); } int -Tk_LabelCmd(clientData, interp, argc, argv) - ClientData clientData; /* Main window associated with - * interpreter. */ +Tk_LabelObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Either NULL or pointer to option table. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument values. */ { - return ButtonCreate(clientData, interp, argc, argv, TYPE_LABEL); + return ButtonCreate(clientData, interp, objc, objv, TYPE_LABEL); } int -Tk_RadiobuttonCmd(clientData, interp, argc, argv) - ClientData clientData; /* Main window associated with - * interpreter. */ +Tk_RadiobuttonObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Either NULL or pointer to option table. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument values. */ { - return ButtonCreate(clientData, interp, argc, argv, TYPE_RADIO_BUTTON); + return ButtonCreate(clientData, interp, objc, objv, TYPE_RADIO_BUTTON); } /* @@ -311,23 +556,42 @@ Tk_RadiobuttonCmd(clientData, interp, argc, argv) */ static int -ButtonCreate(clientData, interp, argc, argv, type) - ClientData clientData; /* Main window associated with - * interpreter. */ +ButtonCreate(clientData, interp, objc, objv, type) + ClientData clientData; /* Option table for this widget class, or + * NULL if not created yet. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument values. */ int type; /* Type of button to create: TYPE_LABEL, * TYPE_BUTTON, TYPE_CHECK_BUTTON, or * TYPE_RADIO_BUTTON. */ { - register TkButton *butPtr; - Tk_Window tkwin = (Tk_Window) clientData; - Tk_Window new; + TkButton *butPtr; + Tk_OptionTable optionTable; + Tk_Window tkwin; + + optionTable = (Tk_OptionTable) clientData; + if (optionTable == NULL) { + Tcl_CmdInfo info; + char *name; + + /* + * We haven't created the option table for this widget class + * yet. Do it now and save the table as the clientData for + * the command, so we'll have access to it in future + * invocations of the command. + */ - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " pathName ?options?\"", (char *) NULL); + TkpButtonSetDefaults(optionSpecs[type]); + optionTable = Tk_CreateOptionTable(interp, optionSpecs[type]); + name = Tcl_GetString(objv[0]); + Tcl_GetCommandInfo(interp, name, &info); + info.objClientData = (ClientData) optionTable; + Tcl_SetCommandInfo(interp, name, &info); + } + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "pathName ?options?"); return TCL_ERROR; } @@ -335,39 +599,43 @@ ButtonCreate(clientData, interp, argc, argv, type) * Create the new window. */ - new = Tk_CreateWindowFromPath(interp, tkwin, argv[1], (char *) NULL); - if (new == NULL) { + tkwin = Tk_CreateWindowFromPath(interp, Tk_MainWindow(interp), + Tcl_GetString(objv[1]), (char *) NULL); + if (tkwin == NULL) { return TCL_ERROR; } - Tk_SetClass(new, classNames[type]); - butPtr = TkpCreateButton(new); + Tk_SetClass(tkwin, classNames[type]); + butPtr = TkpCreateButton(tkwin); - TkSetClassProcs(new, &tkpButtonProcs, (ClientData) butPtr); + TkSetClassProcs(tkwin, &tkpButtonProcs, (ClientData) butPtr); /* * Initialize the data structure for the button. */ - butPtr->tkwin = new; - butPtr->display = Tk_Display(new); - butPtr->widgetCmd = Tcl_CreateCommand(interp, Tk_PathName(butPtr->tkwin), - ButtonWidgetCmd, (ClientData) butPtr, ButtonCmdDeletedProc); + butPtr->tkwin = tkwin; + butPtr->display = Tk_Display(tkwin); butPtr->interp = interp; + butPtr->widgetCmd = Tcl_CreateObjCommand(interp, Tk_PathName(tkwin), + ButtonWidgetObjCmd, (ClientData) butPtr, ButtonCmdDeletedProc); butPtr->type = type; - butPtr->text = NULL; + butPtr->optionTable = optionTable; + butPtr->textPtr = NULL; butPtr->underline = -1; - butPtr->textVarName = NULL; + butPtr->textVarNamePtr = NULL; butPtr->bitmap = None; - butPtr->imageString = NULL; + butPtr->imagePtr = NULL; butPtr->image = NULL; - butPtr->selectImageString = NULL; + butPtr->selectImagePtr = NULL; butPtr->selectImage = NULL; - butPtr->state = tkNormalUid; + butPtr->state = STATE_NORMAL; butPtr->normalBorder = NULL; butPtr->activeBorder = NULL; + butPtr->borderWidthPtr = NULL; butPtr->borderWidth = 0; butPtr->relief = TK_RELIEF_FLAT; + butPtr->highlightWidthPtr = NULL; butPtr->highlightWidth = 0; butPtr->highlightBorder = NULL; butPtr->highlightColorPtr = NULL; @@ -378,43 +646,53 @@ ButtonCreate(clientData, interp, argc, argv, type) butPtr->disabledFg = NULL; butPtr->normalTextGC = None; butPtr->activeTextGC = None; - butPtr->gray = None; butPtr->disabledGC = None; + butPtr->gray = None; butPtr->copyGC = None; - butPtr->widthString = NULL; - butPtr->heightString = NULL; + butPtr->widthPtr = NULL; butPtr->width = 0; + butPtr->heightPtr = NULL; butPtr->height = 0; + butPtr->wrapLengthPtr = NULL; butPtr->wrapLength = 0; + butPtr->padXPtr = NULL; butPtr->padX = 0; + butPtr->padYPtr = NULL; butPtr->padY = 0; butPtr->anchor = TK_ANCHOR_CENTER; butPtr->justify = TK_JUSTIFY_CENTER; - butPtr->textLayout = NULL; butPtr->indicatorOn = 0; butPtr->selectBorder = NULL; + butPtr->textWidth = 0; + butPtr->textHeight = 0; + butPtr->textLayout = NULL; butPtr->indicatorSpace = 0; butPtr->indicatorDiameter = 0; - butPtr->defaultState = tkDisabledUid; - butPtr->selVarName = NULL; - butPtr->onValue = NULL; - butPtr->offValue = NULL; + butPtr->defaultState = DEFAULT_DISABLED; + butPtr->selVarNamePtr = NULL; + butPtr->onValuePtr = NULL; + butPtr->offValuePtr = NULL; butPtr->cursor = None; - butPtr->command = NULL; - butPtr->takeFocus = NULL; + butPtr->takeFocusPtr = NULL; + butPtr->commandPtr = NULL; butPtr->flags = 0; Tk_CreateEventHandler(butPtr->tkwin, ExposureMask|StructureNotifyMask|FocusChangeMask, ButtonEventProc, (ClientData) butPtr); - if (ConfigureButton(interp, butPtr, argc - 2, argv + 2, - configFlags[type]) != TCL_OK) { + if (Tk_InitOptions(interp, (char *) butPtr, optionTable, tkwin) + != TCL_OK) { + Tk_DestroyWindow(butPtr->tkwin); + return TCL_ERROR; + } + if (ConfigureButton(interp, butPtr, objc - 2, objv + 2) != TCL_OK) { Tk_DestroyWindow(butPtr->tkwin); return TCL_ERROR; } - interp->result = Tk_PathName(butPtr->tkwin); + Tcl_SetStringObj(Tcl_GetObjResult(interp), Tk_PathName(butPtr->tkwin), + -1); return TCL_OK; } @@ -437,147 +715,161 @@ ButtonCreate(clientData, interp, argc, argv, type) */ static int -ButtonWidgetCmd(clientData, interp, argc, argv) +ButtonWidgetObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Information about button widget. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument values. */ { - register TkButton *butPtr = (TkButton *) clientData; - int result = TCL_OK; - size_t length; - int c; - - if (argc < 2) { - sprintf(interp->result, - "wrong # args: should be \"%.50s option ?arg arg ...?\"", - argv[0]); + TkButton *butPtr = (TkButton *) clientData; + int index; + int result; + Tcl_Obj *objPtr; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); return TCL_ERROR; } + result = Tcl_GetIndexFromObj(interp, objv[1], commandNames[butPtr->type], + "option", 0, &index); + if (result != TCL_OK) { + return result; + } Tcl_Preserve((ClientData) butPtr); - c = argv[1][0]; - length = strlen(argv[1]); - - if ((c == 'c') && (strncmp(argv[1], "cget", length) == 0) - && (length >= 2)) { - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " cget option\"", - (char *) NULL); - goto error; - } - result = Tk_ConfigureValue(interp, butPtr->tkwin, tkpButtonConfigSpecs, - (char *) butPtr, argv[2], configFlags[butPtr->type]); - } else if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0) - && (length >= 2)) { - if (argc == 2) { - result = Tk_ConfigureInfo(interp, butPtr->tkwin, - tkpButtonConfigSpecs, (char *) butPtr, (char *) NULL, - configFlags[butPtr->type]); - } else if (argc == 3) { - result = Tk_ConfigureInfo(interp, butPtr->tkwin, - tkpButtonConfigSpecs, (char *) butPtr, argv[2], - configFlags[butPtr->type]); - } else { - result = ConfigureButton(interp, butPtr, argc-2, argv+2, - configFlags[butPtr->type] | TK_CONFIG_ARGV_ONLY); - } - } else if ((c == 'd') && (strncmp(argv[1], "deselect", length) == 0) - && (butPtr->type >= TYPE_CHECK_BUTTON)) { - if (argc > 2) { - sprintf(interp->result, - "wrong # args: should be \"%.50s deselect\"", - argv[0]); - goto error; - } - if (butPtr->type == TYPE_CHECK_BUTTON) { - if (Tcl_SetVar(interp, butPtr->selVarName, butPtr->offValue, - TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { - result = TCL_ERROR; + + switch (map[butPtr->type][index]) { + case COMMAND_CGET: { + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "cget option"); + goto error; } - } else if (butPtr->flags & SELECTED) { - if (Tcl_SetVar(interp, butPtr->selVarName, "", - TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { - result = TCL_ERROR; - }; - } - } else if ((c == 'f') && (strncmp(argv[1], "flash", length) == 0) - && (butPtr->type != TYPE_LABEL)) { - int i; - - if (argc > 2) { - sprintf(interp->result, - "wrong # args: should be \"%.50s flash\"", - argv[0]); - goto error; - } - if (butPtr->state != tkDisabledUid) { - for (i = 0; i < 4; i++) { - butPtr->state = (butPtr->state == tkNormalUid) - ? tkActiveUid : tkNormalUid; - Tk_SetBackgroundFromBorder(butPtr->tkwin, - (butPtr->state == tkActiveUid) ? butPtr->activeBorder - : butPtr->normalBorder); - TkpDisplayButton((ClientData) butPtr); - - /* - * Special note: must cancel any existing idle handler - * for TkpDisplayButton; it's no longer needed, and TkpDisplayButton - * cleared the REDRAW_PENDING flag. - */ - - Tcl_CancelIdleCall(TkpDisplayButton, (ClientData) butPtr); - XFlush(butPtr->display); - Tcl_Sleep(50); + objPtr = Tk_GetOptionValue(interp, (char *) butPtr, + butPtr->optionTable, objv[2], butPtr->tkwin); + if (objPtr == NULL) { + goto error; + } else { + Tcl_SetObjResult(interp, objPtr); } + break; } - } else if ((c == 'i') && (strncmp(argv[1], "invoke", length) == 0) - && (butPtr->type > TYPE_LABEL)) { - if (argc > 2) { - sprintf(interp->result, - "wrong # args: should be \"%.50s invoke\"", - argv[0]); - goto error; + + case COMMAND_CONFIGURE: { + if (objc <= 3) { + objPtr = Tk_GetOptionInfo(interp, (char *) butPtr, + butPtr->optionTable, + (objc == 3) ? objv[2] : (Tcl_Obj *) NULL, + butPtr->tkwin); + if (objPtr == NULL) { + goto error; + } else { + Tcl_SetObjResult(interp, objPtr); + } + } else { + result = ConfigureButton(interp, butPtr, objc-2, objv+2); + } + break; } - if (butPtr->state != tkDisabledUid) { - result = TkInvokeButton(butPtr); + + case COMMAND_DESELECT: { + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "deselect"); + goto error; + } + if (butPtr->type == TYPE_CHECK_BUTTON) { + if (Tcl_SetObjVar2(interp, + Tcl_GetString(butPtr->selVarNamePtr), + NULL, butPtr->offValuePtr, + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) + == NULL) { + goto error; + } + } else if (butPtr->flags & SELECTED) { + if (Tcl_SetObjVar2(interp, + Tcl_GetString(butPtr->selVarNamePtr), NULL, + Tcl_NewObj(), + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) + == NULL) { + goto error; + } + } + break; } - } else if ((c == 's') && (strncmp(argv[1], "select", length) == 0) - && (butPtr->type >= TYPE_CHECK_BUTTON)) { - if (argc > 2) { - sprintf(interp->result, - "wrong # args: should be \"%.50s select\"", - argv[0]); - goto error; + + case COMMAND_FLASH: { + int i; + + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "flash"); + goto error; + } + if (butPtr->state != STATE_DISABLED) { + for (i = 0; i < 4; i++) { + if (butPtr->state == STATE_NORMAL) { + butPtr->state = STATE_ACTIVE; + Tk_SetBackgroundFromBorder(butPtr->tkwin, + butPtr->activeBorder); + } else { + butPtr->state = STATE_NORMAL; + Tk_SetBackgroundFromBorder(butPtr->tkwin, + butPtr->normalBorder); + } + TkpDisplayButton((ClientData) butPtr); + + /* + * Special note: must cancel any existing idle handler + * for TkpDisplayButton; it's no longer needed, and + * TkpDisplayButton cleared the REDRAW_PENDING flag. + */ + + Tcl_CancelIdleCall(TkpDisplayButton, (ClientData) butPtr); + XFlush(butPtr->display); + Tcl_Sleep(50); + } + } + break; } - if (Tcl_SetVar(interp, butPtr->selVarName, butPtr->onValue, - TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { - result = TCL_ERROR; + + case COMMAND_INVOKE: { + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "invoke"); + goto error; + } + if (butPtr->state != STATE_DISABLED) { + result = TkInvokeButton(butPtr); + } + break; } - } else if ((c == 't') && (strncmp(argv[1], "toggle", length) == 0) - && (length >= 2) && (butPtr->type == TYPE_CHECK_BUTTON)) { - if (argc > 2) { - sprintf(interp->result, - "wrong # args: should be \"%.50s toggle\"", - argv[0]); - goto error; + + case COMMAND_SELECT: { + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "select"); + goto error; + } + if (Tcl_SetObjVar2(interp, + Tcl_GetString(butPtr->selVarNamePtr), NULL, + butPtr->onValuePtr, + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) + == NULL) { + goto error; + } + break; } - if (butPtr->flags & SELECTED) { - if (Tcl_SetVar(interp, butPtr->selVarName, butPtr->offValue, - TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { - result = TCL_ERROR; + + case COMMAND_TOGGLE: { + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "toggle"); + goto error; } - } else { - if (Tcl_SetVar(interp, butPtr->selVarName, butPtr->onValue, - TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { - result = TCL_ERROR; + if (Tcl_SetObjVar2(interp, + Tcl_GetString(butPtr->selVarNamePtr), NULL, + (butPtr->flags & SELECTED) ? butPtr->offValuePtr + : butPtr->onValuePtr, + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) + == NULL) { + goto error; } + break; } - } else { - sprintf(interp->result, - "bad option \"%.50s\": must be %s", argv[1], - optionStrings[butPtr->type]); - goto error; } Tcl_Release((ClientData) butPtr); return result; @@ -592,15 +884,14 @@ ButtonWidgetCmd(clientData, interp, argc, argv) * * DestroyButton -- * - * This procedure is invoked by Tcl_EventuallyFree or Tcl_Release - * to clean up the internal structure of a button at a safe time - * (when no-one is using it anymore). + * This procedure is invoked by ButtonEventProc to free all the + * resources of a button and clean up its state. * * Results: * None. * * Side effects: - * Everything associated with the widget is freed up. + * Everything associated with the widget is freed. * *---------------------------------------------------------------------- */ @@ -609,14 +900,22 @@ static void DestroyButton(butPtr) TkButton *butPtr; /* Info about button widget. */ { + TkpDestroyButton(butPtr); + + butPtr->flags |= BUTTON_DELETED; + if (butPtr->flags & REDRAW_PENDING) { + Tcl_CancelIdleCall(TkpDisplayButton, (ClientData) butPtr); + } + /* * Free up all the stuff that requires special handling, then * let Tk_FreeOptions handle all the standard option-related * stuff. */ - if (butPtr->textVarName != NULL) { - Tcl_UntraceVar(butPtr->interp, butPtr->textVarName, + Tcl_DeleteCommandFromToken(butPtr->interp, butPtr->widgetCmd); + if (butPtr->textVarNamePtr != NULL) { + Tcl_UntraceVar(butPtr->interp, Tcl_GetString(butPtr->textVarNamePtr), TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, ButtonTextVarProc, (ClientData) butPtr); } @@ -632,24 +931,27 @@ DestroyButton(butPtr) if (butPtr->activeTextGC != None) { Tk_FreeGC(butPtr->display, butPtr->activeTextGC); } - if (butPtr->gray != None) { - Tk_FreeBitmap(butPtr->display, butPtr->gray); - } if (butPtr->disabledGC != None) { Tk_FreeGC(butPtr->display, butPtr->disabledGC); } + if (butPtr->gray != None) { + Tk_FreeBitmap(butPtr->display, butPtr->gray); + } if (butPtr->copyGC != None) { Tk_FreeGC(butPtr->display, butPtr->copyGC); } - if (butPtr->selVarName != NULL) { - Tcl_UntraceVar(butPtr->interp, butPtr->selVarName, + if (butPtr->textLayout != NULL) { + Tk_FreeTextLayout(butPtr->textLayout); + } + if (butPtr->selVarNamePtr != NULL) { + Tcl_UntraceVar(butPtr->interp, Tcl_GetString(butPtr->selVarNamePtr), TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, ButtonVarProc, (ClientData) butPtr); } - Tk_FreeTextLayout(butPtr->textLayout); - Tk_FreeOptions(tkpButtonConfigSpecs, (char *) butPtr, butPtr->display, - configFlags[butPtr->type]); - Tcl_EventuallyFree((ClientData)butPtr, TCL_DYNAMIC); + Tk_FreeConfigOptions((char *) butPtr, butPtr->optionTable, + butPtr->tkwin); + butPtr->tkwin = NULL; + Tcl_EventuallyFree((ClientData) butPtr, TCL_DYNAMIC); } /* @@ -657,13 +959,12 @@ DestroyButton(butPtr) * * ConfigureButton -- * - * This procedure is called to process an argv/argc list, plus - * the Tk option database, in order to configure (or - * reconfigure) a button widget. + * This procedure is called to process an objc/objv list to set + * configuration options for a button widget. * * Results: * The return value is a standard Tcl result. If TCL_ERROR is - * returned, then interp->result contains an error message. + * returned, then an error message is left in interp's result. * * Side effects: * Configuration information, such as text string, colors, font, @@ -674,199 +975,237 @@ DestroyButton(butPtr) */ static int -ConfigureButton(interp, butPtr, argc, argv, flags) +ConfigureButton(interp, butPtr, objc, objv) Tcl_Interp *interp; /* Used for error reporting. */ register TkButton *butPtr; /* Information about widget; may or may * not already have values for some fields. */ - int argc; /* Number of valid entries in argv. */ - char **argv; /* Arguments. */ - int flags; /* Flags to pass to Tk_ConfigureWidget. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument values. */ { + Tk_SavedOptions savedOptions; + int error; Tk_Image image; /* * Eliminate any existing trace on variables monitored by the button. */ - if (butPtr->textVarName != NULL) { - Tcl_UntraceVar(interp, butPtr->textVarName, + if (butPtr->textVarNamePtr != NULL) { + Tcl_UntraceVar(interp, Tcl_GetString(butPtr->textVarNamePtr), TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, ButtonTextVarProc, (ClientData) butPtr); } - if (butPtr->selVarName != NULL) { - Tcl_UntraceVar(interp, butPtr->selVarName, + if (butPtr->selVarNamePtr != NULL) { + Tcl_UntraceVar(interp, Tcl_GetString(butPtr->selVarNamePtr), TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, ButtonVarProc, (ClientData) butPtr); } - - - if (Tk_ConfigureWidget(interp, butPtr->tkwin, tkpButtonConfigSpecs, - argc, argv, (char *) butPtr, flags) != TCL_OK) { - return TCL_ERROR; - } - /* - * A few options need special processing, such as setting the - * background from a 3-D border, or filling in complicated - * defaults that couldn't be specified to Tk_ConfigureWidget. + * The following loop is potentially executed twice. During the + * first pass configuration options get set to their new values. + * If there is an error in this pass, we execute a second pass + * to restore all the options to their previous values. */ - if ((butPtr->state == tkActiveUid) && !Tk_StrictMotif(butPtr->tkwin)) { - Tk_SetBackgroundFromBorder(butPtr->tkwin, butPtr->activeBorder); - } else { - Tk_SetBackgroundFromBorder(butPtr->tkwin, butPtr->normalBorder); - if ((butPtr->state != tkNormalUid) && (butPtr->state != tkActiveUid) - && (butPtr->state != tkDisabledUid)) { - Tcl_AppendResult(interp, "bad state value \"", butPtr->state, - "\": must be normal, active, or disabled", (char *) NULL); - butPtr->state = tkNormalUid; - return TCL_ERROR; - } - } + for (error = 0; error <= 1; error++) { + if (!error) { + /* + * First pass: set options to new values. + */ - if ((butPtr->defaultState != tkActiveUid) - && (butPtr->defaultState != tkDisabledUid) - && (butPtr->defaultState != tkNormalUid)) { - Tcl_AppendResult(interp, "bad -default value \"", butPtr->defaultState, - "\": must be normal, active, or disabled", (char *) NULL); - butPtr->defaultState = tkDisabledUid; - return TCL_ERROR; - } + if (Tk_SetOptions(interp, (char *) butPtr, + butPtr->optionTable, objc, objv, + butPtr->tkwin, &savedOptions, (int *) NULL) != TCL_OK) { + continue; + } + } else { + /* + * Second pass: restore options to old values. + */ - if (butPtr->highlightWidth < 0) { - butPtr->highlightWidth = 0; - } + Tk_RestoreSavedOptions(&savedOptions); + } - if (butPtr->padX < 0) { - butPtr->padX = 0; - } - if (butPtr->padY < 0) { - butPtr->padY = 0; - } + /* + * A few options need special processing, such as setting the + * background from a 3-D border, or filling in complicated + * defaults that couldn't be specified to Tk_ConfigureWidget. + */ - if (butPtr->type >= TYPE_CHECK_BUTTON) { - char *value; + if ((butPtr->state == STATE_ACTIVE) + && !Tk_StrictMotif(butPtr->tkwin)) { + Tk_SetBackgroundFromBorder(butPtr->tkwin, butPtr->activeBorder); + } else { + Tk_SetBackgroundFromBorder(butPtr->tkwin, butPtr->normalBorder); + } + if (butPtr->borderWidth < 0) { + butPtr->borderWidth = 0; + } + if (butPtr->highlightWidth < 0) { + butPtr->highlightWidth = 0; + } + if (butPtr->padX < 0) { + butPtr->padX = 0; + } + if (butPtr->padY < 0) { + butPtr->padY = 0; + } - if (butPtr->selVarName == NULL) { - butPtr->selVarName = (char *) ckalloc((unsigned) - (strlen(Tk_Name(butPtr->tkwin)) + 1)); - strcpy(butPtr->selVarName, Tk_Name(butPtr->tkwin)); + if (butPtr->type >= TYPE_CHECK_BUTTON) { + Tcl_Obj *valuePtr; + char *name; + + if (butPtr->selVarNamePtr == NULL) { + butPtr->selVarNamePtr = Tcl_NewStringObj( + Tk_Name(butPtr->tkwin), -1); + Tcl_IncrRefCount(butPtr->selVarNamePtr); + } + name = Tcl_GetString(butPtr->selVarNamePtr); + + /* + * Select the button if the associated variable has the + * appropriate value, initialize the variable if it doesn't + * exist, then set a trace on the variable to monitor future + * changes to its value. + */ + + valuePtr = Tcl_GetObjVar2(interp, name, NULL, TCL_GLOBAL_ONLY); + butPtr->flags &= ~SELECTED; + if (valuePtr != NULL) { + if (strcmp(Tcl_GetString(valuePtr), + Tcl_GetString(butPtr->onValuePtr)) == 0) { + butPtr->flags |= SELECTED; + } + } else { + if (Tcl_SetObjVar2(interp, name, NULL, + (butPtr->type == TYPE_CHECK_BUTTON) + ? butPtr->offValuePtr : Tcl_NewObj(), + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) + == NULL) { + continue; + } + } } /* - * Select the button if the associated variable has the - * appropriate value, initialize the variable if it doesn't - * exist, then set a trace on the variable to monitor future - * changes to its value. + * Get the images for the widget, if there are any. Allocate the + * new images before freeing the old ones, so that the reference + * counts don't go to zero and cause image data to be discarded. */ - - value = Tcl_GetVar(interp, butPtr->selVarName, TCL_GLOBAL_ONLY); - butPtr->flags &= ~SELECTED; - if (value != NULL) { - if (strcmp(value, butPtr->onValue) == 0) { - butPtr->flags |= SELECTED; + + if (butPtr->imagePtr != NULL) { + image = Tk_GetImage(butPtr->interp, butPtr->tkwin, + Tcl_GetString(butPtr->imagePtr), ButtonImageProc, + (ClientData) butPtr); + if (image == NULL) { + continue; } } else { - if (Tcl_SetVar(interp, butPtr->selVarName, - (butPtr->type == TYPE_CHECK_BUTTON) ? butPtr->offValue : "", - TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { - return TCL_ERROR; + image = NULL; + } + if (butPtr->image != NULL) { + Tk_FreeImage(butPtr->image); + } + butPtr->image = image; + if (butPtr->selectImagePtr != NULL) { + image = Tk_GetImage(butPtr->interp, butPtr->tkwin, + Tcl_GetString(butPtr->selectImagePtr), + ButtonSelectImageProc, (ClientData) butPtr); + if (image == NULL) { + continue; } + } else { + image = NULL; } - Tcl_TraceVar(interp, butPtr->selVarName, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - ButtonVarProc, (ClientData) butPtr); - } - - /* - * Get the images for the widget, if there are any. Allocate the - * new images before freeing the old ones, so that the reference - * counts don't go to zero and cause image data to be discarded. - */ - - if (butPtr->imageString != NULL) { - image = Tk_GetImage(butPtr->interp, butPtr->tkwin, - butPtr->imageString, ButtonImageProc, (ClientData) butPtr); - if (image == NULL) { - return TCL_ERROR; + if (butPtr->selectImage != NULL) { + Tk_FreeImage(butPtr->selectImage); } - } else { - image = NULL; - } - if (butPtr->image != NULL) { - Tk_FreeImage(butPtr->image); - } - butPtr->image = image; - if (butPtr->selectImageString != NULL) { - image = Tk_GetImage(butPtr->interp, butPtr->tkwin, - butPtr->selectImageString, ButtonSelectImageProc, - (ClientData) butPtr); - if (image == NULL) { - return TCL_ERROR; + butPtr->selectImage = image; + + if ((butPtr->imagePtr == NULL) && (butPtr->bitmap == None) + && (butPtr->textVarNamePtr != NULL)) { + /* + * The button must display the value of a variable: set up a trace + * on the variable's value, create the variable if it doesn't + * exist, and fetch its current value. + */ + + char *name; + Tcl_Obj *valuePtr; + + name = Tcl_GetString(butPtr->textVarNamePtr); + valuePtr = Tcl_GetObjVar2(interp, name, NULL, TCL_GLOBAL_ONLY); + if (valuePtr == NULL) { + if (Tcl_SetObjVar2(interp, name, NULL, butPtr->textPtr, + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) + == NULL) { + continue; + } + } else { + if (butPtr->textPtr != NULL) { + Tcl_DecrRefCount(butPtr->textPtr); + } + butPtr->textPtr = valuePtr; + Tcl_IncrRefCount(butPtr->textPtr); + } } - } else { - image = NULL; - } - if (butPtr->selectImage != NULL) { - Tk_FreeImage(butPtr->selectImage); - } - butPtr->selectImage = image; - - if ((butPtr->image == NULL) && (butPtr->bitmap == None) - && (butPtr->textVarName != NULL)) { - /* - * The button must display the value of a variable: set up a trace - * on the variable's value, create the variable if it doesn't - * exist, and fetch its current value. - */ - - char *value; - - value = Tcl_GetVar(interp, butPtr->textVarName, TCL_GLOBAL_ONLY); - if (value == NULL) { - if (Tcl_SetVar(interp, butPtr->textVarName, butPtr->text, - TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { - return TCL_ERROR; + + if ((butPtr->bitmap != None) || (butPtr->imagePtr != NULL)) { + /* + * The button must display the contents of an image or + * bitmap. + */ + + if (Tk_GetPixelsFromObj(interp, butPtr->tkwin, butPtr->widthPtr, + &butPtr->width) != TCL_OK) { + widthError: + Tcl_AddErrorInfo(interp, "\n (processing -width option)"); + continue; + } + if (Tk_GetPixelsFromObj(interp, butPtr->tkwin, butPtr->heightPtr, + &butPtr->height) != TCL_OK) { + heightError: + Tcl_AddErrorInfo(interp, "\n (processing -height option)"); + continue; } } else { - if (butPtr->text != NULL) { - ckfree(butPtr->text); + /* + * The button displays an ordinary text string. + */ + + if (Tcl_GetIntFromObj(interp, butPtr->widthPtr, &butPtr->width) + != TCL_OK) { + goto widthError; + } + if (Tcl_GetIntFromObj(interp, butPtr->heightPtr, &butPtr->height) + != TCL_OK) { + goto heightError; } - butPtr->text = (char *) ckalloc((unsigned) (strlen(value) + 1)); - strcpy(butPtr->text, value); } - Tcl_TraceVar(interp, butPtr->textVarName, + break; + } + if (!error) { + Tk_FreeSavedOptions(&savedOptions); + } + + /* + * Reestablish the variable traces, if they're needed. + */ + + if (butPtr->textVarNamePtr != NULL) { + Tcl_TraceVar(interp, Tcl_GetString(butPtr->textVarNamePtr), TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, ButtonTextVarProc, (ClientData) butPtr); } - - if ((butPtr->bitmap != None) || (butPtr->image != NULL)) { - if (Tk_GetPixels(interp, butPtr->tkwin, butPtr->widthString, - &butPtr->width) != TCL_OK) { - widthError: - Tcl_AddErrorInfo(interp, "\n (processing -width option)"); - return TCL_ERROR; - } - if (Tk_GetPixels(interp, butPtr->tkwin, butPtr->heightString, - &butPtr->height) != TCL_OK) { - heightError: - Tcl_AddErrorInfo(interp, "\n (processing -height option)"); - return TCL_ERROR; - } - } else { - if (Tcl_GetInt(interp, butPtr->widthString, &butPtr->width) - != TCL_OK) { - goto widthError; - } - if (Tcl_GetInt(interp, butPtr->heightString, &butPtr->height) - != TCL_OK) { - goto heightError; - } + if (butPtr->selVarNamePtr != NULL) { + Tcl_TraceVar(interp, Tcl_GetString(butPtr->selVarNamePtr), + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + ButtonVarProc, (ClientData) butPtr); } TkButtonWorldChanged((ClientData) butPtr); - return TCL_OK; + return (error) ? TCL_ERROR : TCL_OK; } /* @@ -921,7 +1260,6 @@ TkButtonWorldChanged(instanceData) butPtr->normalTextGC = newGC; if (butPtr->activeFg != NULL) { - gcValues.font = Tk_FontId(butPtr->tkfont); gcValues.foreground = butPtr->activeFg->pixel; gcValues.background = Tk_3DBorderColor(butPtr->activeBorder)->pixel; mask = GCForeground | GCBackground | GCFont; @@ -933,17 +1271,15 @@ TkButtonWorldChanged(instanceData) } if (butPtr->type != TYPE_LABEL) { - gcValues.font = Tk_FontId(butPtr->tkfont); gcValues.background = Tk_3DBorderColor(butPtr->normalBorder)->pixel; - if ((butPtr->disabledFg != NULL) && (butPtr->imageString == NULL)) { + if ((butPtr->disabledFg != NULL) && (butPtr->imagePtr == NULL)) { gcValues.foreground = butPtr->disabledFg->pixel; mask = GCForeground | GCBackground | GCFont; } else { gcValues.foreground = gcValues.background; mask = GCForeground; if (butPtr->gray == None) { - butPtr->gray = Tk_GetBitmap(NULL, butPtr->tkwin, - Tk_GetUid("gray50")); + butPtr->gray = Tk_GetBitmap(NULL, butPtr->tkwin, "gray50"); } if (butPtr->gray != None) { gcValues.fill_style = FillStippled; @@ -1008,14 +1344,6 @@ ButtonEventProc(clientData, eventPtr) goto redraw; } else if (eventPtr->type == DestroyNotify) { - TkpDestroyButton(butPtr); - if (butPtr->tkwin != NULL) { - butPtr->tkwin = NULL; - Tcl_DeleteCommandFromToken(butPtr->interp, butPtr->widgetCmd); - } - if (butPtr->flags & REDRAW_PENDING) { - Tcl_CancelIdleCall(TkpDisplayButton, (ClientData) butPtr); - } DestroyButton(butPtr); } else if (eventPtr->type == FocusIn) { if (eventPtr->xfocus.detail != NotifyInferior) { @@ -1064,18 +1392,16 @@ ButtonCmdDeletedProc(clientData) ClientData clientData; /* Pointer to widget record for widget. */ { TkButton *butPtr = (TkButton *) clientData; - Tk_Window tkwin = butPtr->tkwin; /* * This procedure could be invoked either because the window was - * destroyed and the command was then deleted (in which case tkwin - * is NULL) or because the command was deleted, and then this procedure - * destroys the widget. + * destroyed and the command was then deleted or because the command + * was deleted, and then this procedure destroys the widget. The + * BUTTON_DELETED flag distinguishes these cases. */ - if (tkwin != NULL) { - butPtr->tkwin = NULL; - Tk_DestroyWindow(tkwin); + if (!(butPtr->flags & BUTTON_DELETED)) { + Tk_DestroyWindow(butPtr->tkwin); } } @@ -1091,7 +1417,7 @@ ButtonCmdDeletedProc(clientData) * * Results: * A standard Tcl return value. Information is also left in - * interp->result. + * the interp's result. * * Side effects: * Depends on the button and its associated command. @@ -1101,28 +1427,45 @@ ButtonCmdDeletedProc(clientData) int TkInvokeButton(butPtr) - register TkButton *butPtr; /* Information about button. */ + TkButton *butPtr; /* Information about button. */ { + char *name; + + if (butPtr->selVarNamePtr != NULL) { + name = Tcl_GetString(butPtr->selVarNamePtr); + } else { + /* + * This code should be executed only if the button is a + * label or regular button, in which case the variable should + * never be used. + */ + + name = NULL; + } if (butPtr->type == TYPE_CHECK_BUTTON) { if (butPtr->flags & SELECTED) { - if (Tcl_SetVar(butPtr->interp, butPtr->selVarName, butPtr->offValue, - TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { + if (Tcl_SetObjVar2(butPtr->interp, name, NULL, butPtr->offValuePtr, + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) + == NULL) { return TCL_ERROR; } } else { - if (Tcl_SetVar(butPtr->interp, butPtr->selVarName, butPtr->onValue, - TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { + if (Tcl_SetObjVar2(butPtr->interp, name, NULL, butPtr->onValuePtr, + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) + == NULL) { return TCL_ERROR; } } } else if (butPtr->type == TYPE_RADIO_BUTTON) { - if (Tcl_SetVar(butPtr->interp, butPtr->selVarName, butPtr->onValue, - TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { + if (Tcl_SetObjVar2(butPtr->interp, name, NULL, butPtr->onValuePtr, + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) + == NULL) { return TCL_ERROR; } } - if ((butPtr->type != TYPE_LABEL) && (butPtr->command != NULL)) { - return TkCopyAndGlobalEval(butPtr->interp, butPtr->command); + if ((butPtr->type != TYPE_LABEL) && (butPtr->commandPtr != NULL)) { + return Tcl_EvalObj(butPtr->interp, butPtr->commandPtr, + TCL_EVAL_GLOBAL); } return TCL_OK; } @@ -1156,7 +1499,10 @@ ButtonVarProc(clientData, interp, name1, name2, flags) int flags; /* Information about what happened. */ { register TkButton *butPtr = (TkButton *) clientData; - char *value; + char *name, *value; + Tcl_Obj *valuePtr; + + name = Tcl_GetString(butPtr->selVarNamePtr); /* * If the variable is being unset, then just re-establish the @@ -1166,7 +1512,7 @@ ButtonVarProc(clientData, interp, name1, name2, flags) if (flags & TCL_TRACE_UNSETS) { butPtr->flags &= ~SELECTED; if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) { - Tcl_TraceVar(interp, butPtr->selVarName, + Tcl_TraceVar(interp, name, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, ButtonVarProc, clientData); } @@ -1178,11 +1524,13 @@ ButtonVarProc(clientData, interp, name1, name2, flags) * the button. */ - value = Tcl_GetVar(interp, butPtr->selVarName, TCL_GLOBAL_ONLY); - if (value == NULL) { + valuePtr = Tcl_GetObjVar2(interp, name, NULL, TCL_GLOBAL_ONLY); + if (valuePtr == NULL) { value = ""; + } else { + value = Tcl_GetString(valuePtr); } - if (strcmp(value, butPtr->onValue) == 0) { + if (strcmp(value, Tcl_GetString(butPtr->onValuePtr)) == 0) { if (butPtr->flags & SELECTED) { return (char *) NULL; } @@ -1229,8 +1577,11 @@ ButtonTextVarProc(clientData, interp, name1, name2, flags) char *name2; /* Not used. */ int flags; /* Information about what happened. */ { - register TkButton *butPtr = (TkButton *) clientData; - char *value; + TkButton *butPtr = (TkButton *) clientData; + char *name; + Tcl_Obj *valuePtr; + + name = Tcl_GetString(butPtr->textVarNamePtr); /* * If the variable is unset, then immediately recreate it unless @@ -1239,24 +1590,22 @@ ButtonTextVarProc(clientData, interp, name1, name2, flags) if (flags & TCL_TRACE_UNSETS) { if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) { - Tcl_SetVar(interp, butPtr->textVarName, butPtr->text, + Tcl_SetObjVar2(interp, name, NULL, butPtr->textPtr, TCL_GLOBAL_ONLY); - Tcl_TraceVar(interp, butPtr->textVarName, + Tcl_TraceVar(interp, name, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, ButtonTextVarProc, clientData); } return (char *) NULL; } - value = Tcl_GetVar(interp, butPtr->textVarName, TCL_GLOBAL_ONLY); - if (value == NULL) { - value = ""; - } - if (butPtr->text != NULL) { - ckfree(butPtr->text); + valuePtr = Tcl_GetObjVar2(interp, name, NULL, TCL_GLOBAL_ONLY); + if (valuePtr == NULL) { + valuePtr = Tcl_NewObj(); } - butPtr->text = (char *) ckalloc((unsigned) (strlen(value) + 1)); - strcpy(butPtr->text, value); + Tcl_DecrRefCount(butPtr->textPtr); + butPtr->textPtr = valuePtr; + Tcl_IncrRefCount(butPtr->textPtr); TkpComputeButtonGeometry(butPtr); if ((butPtr->tkwin != NULL) && Tk_IsMapped(butPtr->tkwin) @@ -1273,7 +1622,7 @@ ButtonTextVarProc(clientData, interp, name1, name2, flags) * ButtonImageProc -- * * This procedure is invoked by the image code whenever the manager - * for an image does something that affects the size of contents + * for an image does something that affects the size or contents * of an image displayed in a button. * * Results: @@ -1311,7 +1660,7 @@ ButtonImageProc(clientData, x, y, width, height, imgWidth, imgHeight) * ButtonSelectImageProc -- * * This procedure is invoked by the image code whenever the manager - * for an image does something that affects the size of contents + * for an image does something that affects the size or contents * of the image displayed in a button when it is selected. * * Results: diff --git a/generic/tkButton.h b/generic/tkButton.h index 0d5b928..ebc7c7a 100644 --- a/generic/tkButton.h +++ b/generic/tkButton.h @@ -4,12 +4,12 @@ * Declarations of types and functions used to implement * button-like widgets. * - * Copyright (c) 1996 by Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkButton.h 1.5 97/06/06 11:19:24 + * SCCS: @(#) tkButton.h 1.8 98/01/09 09:48:06 */ #ifndef _TKBUTTON @@ -20,6 +20,22 @@ #endif /* + * Legal values for the "state" field of TkButton records. + */ + +enum state { + STATE_ACTIVE, STATE_DISABLED, STATE_NORMAL +}; + +/* + * Legal values for the "defaultState" field of TkButton records. + */ + +enum defaultState { + DEFAULT_ACTIVE, DEFAULT_DISABLED, DEFAULT_NORMAL +}; + +/* * A data structure of the following type is kept for each * widget managed by this file: */ @@ -31,69 +47,88 @@ typedef struct { * free up resources after tkwin is gone. */ Tcl_Interp *interp; /* Interpreter associated with button. */ Tcl_Command widgetCmd; /* Token for button's widget command. */ - int type; /* Type of widget: restricts operations - * that may be performed on widget. See - * below for possible values. */ + int type; /* Type of widget, such as TYPE_LABEL: + * restricts operations that may be performed + * on widget. See below for legal values. */ + Tk_OptionTable optionTable; /* Table that defines configuration options + * available for this widget. */ /* * Information about what's in the button. */ - char *text; /* Text to display in button (malloc'ed) - * or NULL. */ - int underline; /* Index of character to underline. < 0 means + Tcl_Obj *textPtr; /* Value of -text option: specifies text to + * display in button. */ + int underline; /* Value of -underline option: specifies + * index of character to underline. < 0 means * don't underline anything. */ - char *textVarName; /* Name of variable (malloc'ed) or NULL. - * If non-NULL, button displays the contents - * of this variable. */ - Pixmap bitmap; /* Bitmap to display or None. If not None - * then text and textVar are ignored. */ - char *imageString; /* Name of image to display (malloc'ed), or - * NULL. If non-NULL, bitmap, text, and - * textVarName are ignored. */ - Tk_Image image; /* Image to display in window, or NULL if - * none. */ - char *selectImageString; /* Name of image to display when selected - * (malloc'ed), or NULL. */ - Tk_Image selectImage; /* Image to display in window when selected, - * or NULL if none. Ignored if image is + Tcl_Obj *textVarNamePtr; /* Value of -textvariable option: specifies + * name of variable or NULL. If non-NULL, + * button displays the contents of this + * variable. */ + Pixmap bitmap; /* Value of -bitmap option. If not None, + * specifies bitmap to display and text and + * textVar are ignored. */ + Tcl_Obj *imagePtr; /* Value of -image option: specifies image + * to display in window, or NULL if none. + * If non-NULL, bitmap, text, and textVarName + * are ignored.*/ + Tk_Image image; /* Derived from imagePtr by calling + * Tk_GetImage, or NULL if imagePtr is NULL. */ + Tcl_Obj *selectImagePtr; /* Value of -selectimage option: specifies + * image to display in window when selected, + * or NULL if none. Ignored if imagePtr is * NULL. */ + Tk_Image selectImage; /* Derived from selectImagePtr by calling + * Tk_GetImage, or NULL if selectImagePtr + * is NULL. */ /* * Information used when displaying widget: */ - Tk_Uid state; /* State of button for display purposes: - * normal, active, or disabled. */ - Tk_3DBorder normalBorder; /* Structure used to draw 3-D - * border and background when window - * isn't active. NULL means no such - * border exists. */ - Tk_3DBorder activeBorder; /* Structure used to draw 3-D - * border and background when window - * is active. NULL means no such - * border exists. */ - int borderWidth; /* Width of border. */ - int relief; /* 3-d effect: TK_RELIEF_RAISED, etc. */ - int highlightWidth; /* Width in pixels of highlight to draw - * around widget when it has the focus. + enum state state; /* Value of -state option: specifies + * state of button for display purposes.*/ + Tk_3DBorder normalBorder; /* Value of -background option: specifies + * color for background (and border) when + * window isn't active. */ + Tk_3DBorder activeBorder; /* Value of -activebackground option: + * this is the color used to draw 3-D border + * and background when widget is active. */ + Tcl_Obj *borderWidthPtr; /* Value of -borderWidth option: specifies + * width of border in pixels. */ + int borderWidth; /* Integer value corresponding to + * borderWidthPtr. Always >= 0. */ + int relief; /* Value of -relief option: specifies 3-d + * effect for border, such as + * TK_RELIEF_RAISED. */ + Tcl_Obj *highlightWidthPtr; /* Value of -highlightthickness option: + * specifies width in pixels of highlight to + * draw around widget when it has the focus. * <= 0 means don't draw a highlight. */ - Tk_3DBorder highlightBorder; - /* Structure used to draw 3-D default ring - * and focus highlight area when highlight - * is off. */ - XColor *highlightColorPtr; /* Color for drawing traversal highlight. */ - + int highlightWidth; /* Integer value corresponding to + * highlightWidthPtr. Always >= 0. */ + Tk_3DBorder highlightBorder;/* Value of -highlightbackground option: + * specifies background with which to draw 3-D + * default ring and focus highlight area when + * highlight is off. */ + XColor *highlightColorPtr; /* Value of -highlightcolor option: + * specifies color for drawing traversal + * highlight. */ int inset; /* Total width of all borders, including * traversal highlight and 3-D border. * Indicates how much interior stuff must * be offset from outside edges to leave * room for borders. */ - Tk_Font tkfont; /* Information about text font, or NULL. */ - XColor *normalFg; /* Foreground color in normal mode. */ - XColor *activeFg; /* Foreground color in active mode. NULL - * means use normalFg instead. */ - XColor *disabledFg; /* Foreground color when disabled. NULL + Tk_Font tkfont; /* Value of -font option: specifies font + * to use for display text. */ + XColor *normalFg; /* Value of -font option: specifies foreground + * color in normal mode. */ + XColor *activeFg; /* Value of -activeforeground option: + * foreground color in active mode. NULL + * means use -foreground instead. */ + XColor *disabledFg; /* Value of -disabledforeground option: + * foreground color when disabled. NULL * means use normalFg with a 50% stipple * instead. */ GC normalTextGC; /* GC for drawing text in normal mode. Also @@ -101,36 +136,47 @@ typedef struct { * screen. */ GC activeTextGC; /* GC for drawing text in active mode (NULL * means use normalTextGC). */ - Pixmap gray; /* Pixmap for displaying disabled text if - * disabledFg is NULL. */ GC disabledGC; /* Used to produce disabled effect. If * disabledFg isn't NULL, this GC is used to * draw button text or icon. Otherwise * text or icon is drawn with normalGC and * this GC is used to stipple background * across it. For labels this is None. */ + Pixmap gray; /* Pixmap for displaying disabled text if + * disabledFg is NULL. */ GC copyGC; /* Used for copying information from an * off-screen pixmap to the screen. */ - char *widthString; /* Value of -width option. Malloc'ed. */ - char *heightString; /* Value of -height option. Malloc'ed. */ - int width, height; /* If > 0, these specify dimensions to request - * for window, in characters for text and in - * pixels for bitmaps. In this case the actual - * size of the text string or bitmap is - * ignored in computing desired window size. */ - int wrapLength; /* Line length (in pixels) at which to wrap + Tcl_Obj *widthPtr; /* Value of -width option. */ + int width; /* Integer value corresponding to widthPtr. */ + Tcl_Obj *heightPtr; /* Value of -height option. */ + int height; /* Integer value corresponding to heightPtr. */ + Tcl_Obj *wrapLengthPtr; /* Value of -wraplength option: specifies + * line length (in pixels) at which to wrap * onto next line. <= 0 means don't wrap * except at newlines. */ - int padX, padY; /* Extra space around text (pixels to leave - * on each side). Ignored for bitmaps and + int wrapLength; /* Integer value corresponding to + * wrapLengthPtr. */ + Tcl_Obj *padXPtr; /* Value of -padx option: specifies how many + * pixels of extra space to leave on left and + * right of text. Ignored for bitmaps and * images. */ - Tk_Anchor anchor; /* Where text/bitmap should be displayed - * inside button region. */ - Tk_Justify justify; /* Justification to use for multi-line text. */ - int indicatorOn; /* True means draw indicator, false means - * don't draw it. */ - Tk_3DBorder selectBorder; /* For drawing indicator background, or perhaps - * widget background, when selected. */ + int padX; /* Integer value corresponding to padXPtr. */ + Tcl_Obj *padYPtr; /* Value of -padx option: specifies how many + * pixels of extra space to leave above and + * below text. Ignored for bitmaps and + * images. */ + int padY; /* Integer value corresponding to padYPtr. */ + Tk_Anchor anchor; /* Value of -anchor option: specifies where + * text/bitmap should be displayed inside + * button region. */ + Tk_Justify justify; /* Value of -justify option: specifies how + * to align lines of multi-line text. */ + int indicatorOn; /* Value of -indicatoron option: 1 means + * draw indicator in checkbuttons and + * radiobuttons, 0 means don't draw it. */ + Tk_3DBorder selectBorder; /* Value of -selectcolor option: specifies + * color for drawing indicator background, or + * perhaps widget background, when selected. */ int textWidth; /* Width needed to display text as requested, * in pixels. */ int textHeight; /* Height needed to display text as requested, @@ -139,36 +185,42 @@ typedef struct { int indicatorSpace; /* Horizontal space (in pixels) allocated for * display of indicator. */ int indicatorDiameter; /* Diameter of indicator, in pixels. */ - Tk_Uid defaultState; /* State of default ring: normal, active, or - * disabled. */ - + enum defaultState defaultState; + /* Value of -default option, such as + * DEFAULT_NORMAL: specifies state + * of default ring for buttons (normal, + * active, or disabled). NULL for other + * classes. */ + /* * For check and radio buttons, the fields below are used * to manage the variable indicating the button's state. */ - char *selVarName; /* Name of variable used to control selected - * state of button. Malloc'ed (if - * not NULL). */ - char *onValue; /* Value to store in variable when - * this button is selected. Malloc'ed (if - * not NULL). */ - char *offValue; /* Value to store in variable when this - * button isn't selected. Malloc'ed - * (if not NULL). Valid only for check - * buttons. */ + Tcl_Obj *selVarNamePtr; /* Value of -variable option: specifies name + * of variable used to control selected + * state of button. */ + Tcl_Obj *onValuePtr; /* Value of -offvalue option: specifies value + * to store in variable when this button is + * selected. */ + Tcl_Obj *offValuePtr; /* Value of -offvalue option: specifies value + * to store in variable when this button + * isn't selected. Used only by + * checkbuttons. */ /* * Miscellaneous information: */ - Tk_Cursor cursor; /* Current cursor for window, or None. */ - char *takeFocus; /* Value of -takefocus option; not used in + Tk_Cursor cursor; /* Value of -cursor option: if not None, + * specifies current cursor for window. */ + Tcl_Obj *takeFocusPtr; /* Value of -takefocus option; not used in * the C code, but used by keyboard traversal - * scripts. Malloc'ed, but may be NULL. */ - char *command; /* Command to execute when button is - * invoked; valid for buttons only. - * If not NULL, it's malloc-ed. */ + * scripts. */ + Tcl_Obj *commandPtr; /* Value of -command option: specifies script + * to execute when button is invoked. If + * widget is label or has no command, this + * is NULL. */ int flags; /* Various flags; see below for * definitions. */ } TkButton; @@ -195,36 +247,31 @@ typedef struct { * so special highlight should be drawn. * GOT_FOCUS: Non-zero means this button currently * has the input focus. + * BUTTON_DELETED: Non-zero needs that this button has been + * deleted, or is in the process of being + * deleted. */ #define REDRAW_PENDING 1 #define SELECTED 2 #define GOT_FOCUS 4 - -/* - * Mask values used to selectively enable entries in the - * configuration specs: - */ - -#define LABEL_MASK TK_CONFIG_USER_BIT -#define BUTTON_MASK TK_CONFIG_USER_BIT << 1 -#define CHECK_BUTTON_MASK TK_CONFIG_USER_BIT << 2 -#define RADIO_BUTTON_MASK TK_CONFIG_USER_BIT << 3 -#define ALL_MASK (LABEL_MASK | BUTTON_MASK \ - | CHECK_BUTTON_MASK | RADIO_BUTTON_MASK) +#define BUTTON_DELETED 0x8 /* * Declaration of variables shared between the files in the button module. */ extern TkClassProcs tkpButtonProcs; -extern Tk_ConfigSpec tkpButtonConfigSpecs[]; /* * Declaration of procedures used in the implementation of the button * widget. */ +#ifndef TkpButtonSetDefaults +EXTERN void TkpButtonSetDefaults _ANSI_ARGS_(( + Tk_OptionSpec *specPtr)); +#endif EXTERN void TkButtonWorldChanged _ANSI_ARGS_(( ClientData instanceData)); EXTERN void TkpComputeButtonGeometry _ANSI_ARGS_(( diff --git a/generic/tkCanvArc.c b/generic/tkCanvArc.c index 26b62e7..4c97876 100644 --- a/generic/tkCanvArc.c +++ b/generic/tkCanvArc.c @@ -4,12 +4,12 @@ * This file implements arc items for canvas widgets. * * Copyright (c) 1992-1994 The Regents of the University of California. - * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkCanvArc.c 1.34 97/04/25 16:50:56 + * SCCS: @(#) tkCanvArc.c 1.35 97/11/07 21:14:21 */ #include <stdio.h> @@ -188,7 +188,7 @@ static Tk_Uid pieSliceUid = NULL; * Results: * A standard Tcl return value. If an error occurred in * creating the item, then an error message is left in - * interp->result; in this case itemPtr is + * the interp's result; in this case itemPtr is * left uninitialized, so it can be safely freed by the * caller. * @@ -276,7 +276,7 @@ CreateArc(interp, canvas, itemPtr, argc, argv) * on what it does. * * Results: - * Returns TCL_OK or TCL_ERROR, and sets interp->result. + * Returns TCL_OK or TCL_ERROR, and sets the interp's result. * * Side effects: * The coordinates for the given item may be changed. @@ -319,9 +319,10 @@ ArcCoords(interp, canvas, itemPtr, argc, argv) } ComputeArcBbox(canvas, arcPtr); } else { - sprintf(interp->result, - "wrong # coordinates: expected 0 or 4, got %d", - argc); + char buf[64 + TCL_INTEGER_SPACE]; + + sprintf(buf, "wrong # coordinates: expected 0 or 4, got %d", argc); + Tcl_SetResult(interp, buf, TCL_VOLATILE); return TCL_ERROR; } return TCL_OK; @@ -337,7 +338,7 @@ ArcCoords(interp, canvas, itemPtr, argc, argv) * * Results: * A standard Tcl result code. If an error occurs, then - * an error message is left in interp->result. + * an error message is left in the interp's result. * * Side effects: * Configuration information, such as colors and stipple @@ -1574,7 +1575,7 @@ AngleInRange(x, y, start, extent) * Results: * The return value is a standard Tcl result. If an error * occurs in generating Postscript then an error message is - * left in interp->result, replacing whatever used + * left in the interp's result, replacing whatever used * to be there. If no error occurs, then Postscript for the * item is appended to the result. * diff --git a/generic/tkCanvBmap.c b/generic/tkCanvBmap.c index fff0638..4786dd6 100644 --- a/generic/tkCanvBmap.c +++ b/generic/tkCanvBmap.c @@ -4,12 +4,12 @@ * This file implements bitmap items for canvas widgets. * * Copyright (c) 1992-1994 The Regents of the University of California. - * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkCanvBmap.c 1.30 96/05/03 10:49:00 + * SCCS: @(#) tkCanvBmap.c 1.31 97/11/07 21:14:33 */ #include <stdio.h> @@ -129,7 +129,7 @@ Tk_ItemType tkBitmapType = { * Results: * A standard Tcl return value. If an error occurred in * creating the item, then an error message is left in - * interp->result; in this case itemPtr is left uninitialized, + * the interp's result; in this case itemPtr is left uninitialized, * so it can be safely freed by the caller. * * Side effects: @@ -194,7 +194,7 @@ CreateBitmap(interp, canvas, itemPtr, argc, argv) * details on what it does. * * Results: - * Returns TCL_OK or TCL_ERROR, and sets interp->result. + * Returns TCL_OK or TCL_ERROR, and sets the interp's result. * * Side effects: * The coordinates for the given item may be changed. @@ -228,8 +228,10 @@ BitmapCoords(interp, canvas, itemPtr, argc, argv) } ComputeBitmapBbox(canvas, bmapPtr); } else { - sprintf(interp->result, - "wrong # coordinates: expected 0 or 2, got %d", argc); + char buf[64 + TCL_INTEGER_SPACE]; + + sprintf(buf, "wrong # coordinates: expected 0 or 2, got %d", argc); + Tcl_SetResult(interp, buf, TCL_VOLATILE); return TCL_ERROR; } return TCL_OK; @@ -245,7 +247,7 @@ BitmapCoords(interp, canvas, itemPtr, argc, argv) * * Results: * A standard Tcl result code. If an error occurs, then - * an error message is left in interp->result. + * an error message is left in the interp's result. * * Side effects: * Configuration information may be set for itemPtr. @@ -690,7 +692,7 @@ TranslateBitmap(canvas, itemPtr, deltaX, deltaY) * Results: * The return value is a standard Tcl result. If an error * occurs in generating Postscript then an error message is - * left in interp->result, replacing whatever used to be there. + * left in the interp's result, replacing whatever used to be there. * If no error occurs, then Postscript for the item is appended * to the result. * @@ -715,7 +717,7 @@ BitmapToPostscript(interp, canvas, itemPtr, prepass) double x, y; int width, height, rowsAtOnce, rowsThisTime; int curRow; - char buffer[200]; + char buffer[100 + TCL_DOUBLE_SPACE * 2 + TCL_INTEGER_SPACE * 4]; if (bmapPtr->bitmap == None) { return TCL_OK; @@ -749,7 +751,7 @@ BitmapToPostscript(interp, canvas, itemPtr, prepass) if (bmapPtr->bgColor != NULL) { sprintf(buffer, "%.15g %.15g moveto %d 0 rlineto 0 %d rlineto %d %s\n", - x, y, width, height, -width,"0 rlineto closepath"); + x, y, width, height, -width, "0 rlineto closepath"); Tcl_AppendResult(interp, buffer, (char *) NULL); if (Tk_CanvasPsColor(interp, canvas, bmapPtr->bgColor) != TCL_OK) { return TCL_ERROR; diff --git a/generic/tkCanvImg.c b/generic/tkCanvImg.c index 55169f7..258ca8d 100644 --- a/generic/tkCanvImg.c +++ b/generic/tkCanvImg.c @@ -4,12 +4,12 @@ * This file implements image items for canvas widgets. * * Copyright (c) 1994 The Regents of the University of California. - * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkCanvImg.c 1.18 96/05/03 10:49:09 + * SCCS: @(#) tkCanvImg.c 1.19 97/11/07 21:14:48 */ #include <stdio.h> @@ -126,7 +126,7 @@ Tk_ItemType tkImageType = { * Results: * A standard Tcl return value. If an error occurred in * creating the item, then an error message is left in - * interp->result; in this case itemPtr is left uninitialized, + * the interp's result; in this case itemPtr is left uninitialized, * so it can be safely freed by the caller. * * Side effects: @@ -190,7 +190,7 @@ CreateImage(interp, canvas, itemPtr, argc, argv) * details on what it does. * * Results: - * Returns TCL_OK or TCL_ERROR, and sets interp->result. + * Returns TCL_OK or TCL_ERROR, and sets the interp's result. * * Side effects: * The coordinates for the given item may be changed. @@ -224,8 +224,10 @@ ImageCoords(interp, canvas, itemPtr, argc, argv) } ComputeImageBbox(canvas, imgPtr); } else { - sprintf(interp->result, - "wrong # coordinates: expected 0 or 2, got %d", argc); + char buf[64]; + + sprintf(buf, "wrong # coordinates: expected 0 or 2, got %d", argc); + Tcl_SetResult(interp, buf, TCL_VOLATILE); return TCL_ERROR; } return TCL_OK; @@ -241,7 +243,7 @@ ImageCoords(interp, canvas, itemPtr, argc, argv) * * Results: * A standard Tcl result code. If an error occurs, then - * an error message is left in interp->result. + * an error message is left in the interp's result. * * Side effects: * Configuration information may be set for itemPtr. diff --git a/generic/tkCanvLine.c b/generic/tkCanvLine.c index 97cd1f5..bf2afd9 100644 --- a/generic/tkCanvLine.c +++ b/generic/tkCanvLine.c @@ -4,12 +4,12 @@ * This file implements line items for canvas widgets. * * Copyright (c) 1991-1994 The Regents of the University of California. - * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkCanvLine.c 1.46 97/04/25 16:51:02 + * SCCS: @(#) tkCanvLine.c 1.47 97/11/07 21:14:57 */ #include <stdio.h> @@ -207,7 +207,7 @@ static Tk_Uid bothUid = NULL; * Results: * A standard Tcl return value. If an error occurred in * creating the item, then an error message is left in - * interp->result; in this case itemPtr is left uninitialized, + * the interp's result; in this case itemPtr is left uninitialized, * so it can be safely freed by the caller. * * Side effects: @@ -302,7 +302,7 @@ CreateLine(interp, canvas, itemPtr, argc, argv) * on what it does. * * Results: - * Returns TCL_OK or TCL_ERROR, and sets interp->result. + * Returns TCL_OK or TCL_ERROR, and sets the interp's result. * * Side effects: * The coordinates for the given item may be changed. @@ -403,7 +403,7 @@ LineCoords(interp, canvas, itemPtr, argc, argv) * * Results: * A standard Tcl result code. If an error occurs, then - * an error message is left in interp->result. + * an error message is left in the interp's result. * * Side effects: * Configuration information, such as colors and stipple @@ -1449,7 +1449,7 @@ ConfigureArrows(canvas, linePtr) * Results: * The return value is a standard Tcl result. If an error * occurs in generating Postscript then an error message is - * left in interp->result, replacing whatever used + * left in the interp's result, replacing whatever used * to be there. If no error occurs, then Postscript for the * item is appended to the result. * @@ -1471,7 +1471,7 @@ LineToPostscript(interp, canvas, itemPtr, prepass) * final Postscript is being created. */ { LineItem *linePtr = (LineItem *) itemPtr; - char buffer[200]; + char buffer[64 + TCL_INTEGER_SPACE]; char *style; if (linePtr->fg == NULL) { @@ -1589,7 +1589,7 @@ LineToPostscript(interp, canvas, itemPtr, prepass) * Results: * The return value is a standard Tcl result. If an error * occurs in generating Postscript then an error message is - * left in interp->result, replacing whatever used + * left in the interp's result, replacing whatever used * to be there. If no error occurs, then Postscript for the * arrowhead is appended to the result. * diff --git a/generic/tkCanvPoly.c b/generic/tkCanvPoly.c index 1320438..9e672c5 100644 --- a/generic/tkCanvPoly.c +++ b/generic/tkCanvPoly.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkCanvPoly.c 1.37 97/04/29 15:39:16 + * SCCS: @(#) tkCanvPoly.c 1.38 97/11/07 21:15:07 */ #include <stdio.h> @@ -150,7 +150,7 @@ Tk_ItemType tkPolygonType = { * Results: * A standard Tcl return value. If an error occurred in * creating the item, then an error message is left in - * interp->result; in this case itemPtr is + * the interp's result; in this case itemPtr is * left uninitialized, so it can be safely freed by the * caller. * @@ -234,7 +234,7 @@ CreatePolygon(interp, canvas, itemPtr, argc, argv) * on what it does. * * Results: - * Returns TCL_OK or TCL_ERROR, and sets interp->result. + * Returns TCL_OK or TCL_ERROR, and sets the interp's result. * * Side effects: * The coordinates for the given item may be changed. @@ -327,7 +327,7 @@ PolygonCoords(interp, canvas, itemPtr, argc, argv) * * Results: * A standard Tcl result code. If an error occurs, then - * an error message is left in interp->result. + * an error message is left in the interp's result. * * Side effects: * Configuration information, such as colors and stipple @@ -919,7 +919,7 @@ TranslatePolygon(canvas, itemPtr, deltaX, deltaY) * Results: * The return value is a standard Tcl result. If an error * occurs in generating Postscript then an error message is - * left in interp->result, replacing whatever used + * left in the interp's result, replacing whatever used * to be there. If no error occurs, then Postscript for the * item is appended to the result. * @@ -940,7 +940,6 @@ PolygonToPostscript(interp, canvas, itemPtr, prepass) * collect font information; 0 means * final Postscript is being created. */ { - char string[100]; PolygonItem *polyPtr = (PolygonItem *) itemPtr; /* @@ -977,6 +976,8 @@ PolygonToPostscript(interp, canvas, itemPtr, prepass) */ if (polyPtr->outlineColor != NULL) { + char string[32 + TCL_INTEGER_SPACE]; + if (!polyPtr->smooth) { Tk_CanvasPsPath(interp, canvas, polyPtr->coordPtr, polyPtr->numPoints); diff --git a/generic/tkCanvPs.c b/generic/tkCanvPs.c index 9bad194..dcc6cee 100644 --- a/generic/tkCanvPs.c +++ b/generic/tkCanvPs.c @@ -6,12 +6,12 @@ * procedures used for generating Postscript. * * Copyright (c) 1991-1994 The Regents of the University of California. - * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkCanvPs.c 1.57 97/10/28 18:08:39 + * SCCS: @(#) tkCanvPs.c 1.62 98/02/10 10:28:12 */ #include "tkInt.h" @@ -112,6 +112,320 @@ static Tk_ConfigSpec configSpecs[] = { }; /* + * The prolog data. Generated by str2c from prolog.ps + * This was split in small chunks by str2c because + * some C compiler have limitations on the size of static strings. + * (str2c is a small tcl script in tcl's tool directory (source release)) + */ +static CONST char * CONST prolog[]= { + /* Start of part 1 (2000 characters) */ + "%%BeginProlog\n\ +50 dict begin\n\ +\n\ +% This is a standard prolog for Postscript generated by Tk's canvas\n\ +% widget.\n\ +% SCCS: @(#) prolog.ps 1.7 96/07/08 17:52:14\n\ +\n\ +% The definitions below just define all of the variables used in\n\ +% any of the procedures here. This is needed for obscure reasons\n\ +% explained on p. 716 of the Postscript manual (Section H.2.7,\n\ +% \"Initializing Variables,\" in the section on Encapsulated Postscript).\n\ +\n\ +/baseline 0 def\n\ +/stipimage 0 def\n\ +/height 0 def\n\ +/justify 0 def\n\ +/lineLength 0 def\n\ +/spacing 0 def\n\ +/stipple 0 def\n\ +/strings 0 def\n\ +/xoffset 0 def\n\ +/yoffset 0 def\n\ +/tmpstip null def\n\ +\n\ +% Define the array ISOLatin1Encoding (which specifies how characters are\n\ +% encoded for ISO-8859-1 fonts), if it isn't already present (Postscript\n\ +% level 2 is supposed to define it, but level 1 doesn't).\n\ +\n\ +systemdict /ISOLatin1Encoding known not {\n\ + /ISOLatin1Encoding [\n\ + /space /space /space /space /space /space /space /space\n\ + /space /space /space /space /space /space /space /space\n\ + /space /space /space /space /space /space /space /space\n\ + /space /space /space /space /space /space /space /space\n\ + /space /exclam /quotedbl /numbersign /dollar /percent /ampersand\n\ + /quoteright\n\ + /parenleft /parenright /asterisk /plus /comma /minus /period /slash\n\ + /zero /one /two /three /four /five /six /seven\n\ + /eight /nine /colon /semicolon /less /equal /greater /question\n\ + /at /A /B /C /D /E /F /G\n\ + /H /I /J /K /L /M /N /O\n\ + /P /Q /R /S /T /U /V /W\n\ + /X /Y /Z /bracketleft /backslash /bracketright /asciicircum /underscore\n\ + /quoteleft /a /b /c /d /e /f /g\n\ + /h /i /j /k /l /m /n /o\n\ + /p /q /r /s /t /u /v /w\n\ + /x /y /z /braceleft /bar /braceright /asciitilde /space\n\ + /space /space /space /space /space /space /space /space\n\ + /space /space /space /space /space /space /space /space\n\ + /dotlessi /grave /acute /circumflex /tilde /macron /breve /dotaccent\n\ + /dieresis /space /ring /cedilla /space /hungarumlaut /ogonek /caron\n\ + /space /exclamdown /cent /sterling /currency /yen /brokenbar /section\n\ + /dieresis /copyright /ordfem", + /* End of part 1 */ + + /* Start of part 2 (2000 characters) */ + "inine /guillemotleft /logicalnot /hyphen\n\ + /registered /macron\n\ + /degree /plusminus /twosuperior /threesuperior /acute /mu /paragraph\n\ + /periodcentered\n\ + /cedillar /onesuperior /ordmasculine /guillemotright /onequarter\n\ + /onehalf /threequarters /questiondown\n\ + /Agrave /Aacute /Acircumflex /Atilde /Adieresis /Aring /AE /Ccedilla\n\ + /Egrave /Eacute /Ecircumflex /Edieresis /Igrave /Iacute /Icircumflex\n\ + /Idieresis\n\ + /Eth /Ntilde /Ograve /Oacute /Ocircumflex /Otilde /Odieresis /multiply\n\ + /Oslash /Ugrave /Uacute /Ucircumflex /Udieresis /Yacute /Thorn\n\ + /germandbls\n\ + /agrave /aacute /acircumflex /atilde /adieresis /aring /ae /ccedilla\n\ + /egrave /eacute /ecircumflex /edieresis /igrave /iacute /icircumflex\n\ + /idieresis\n\ + /eth /ntilde /ograve /oacute /ocircumflex /otilde /odieresis /divide\n\ + /oslash /ugrave /uacute /ucircumflex /udieresis /yacute /thorn\n\ + /ydieresis\n\ + ] def\n\ +} if\n\ +\n\ +% font ISOEncode font\n\ +% This procedure changes the encoding of a font from the default\n\ +% Postscript encoding to ISOLatin1. It's typically invoked just\n\ +% before invoking \"setfont\". The body of this procedure comes from\n\ +% Section 5.6.1 of the Postscript book.\n\ +\n\ +/ISOEncode {\n\ + dup length dict begin\n\ + {1 index /FID ne {def} {pop pop} ifelse} forall\n\ + /Encoding ISOLatin1Encoding def\n\ + currentdict\n\ + end\n\ +\n\ + % I'm not sure why it's necessary to use \"definefont\" on this new\n\ + % font, but it seems to be important; just use the name \"Temporary\"\n\ + % for the font.\n\ +\n\ + /Temporary exch definefont\n\ +} bind def\n\ +\n\ +% StrokeClip\n\ +%\n\ +% This procedure converts the current path into a clip area under\n\ +% the assumption of stroking. It's a bit tricky because some Postscript\n\ +% interpreters get errors during strokepath for dashed lines. If\n\ +% this happens then turn off dashes and try again.\n\ +\n\ +/StrokeClip {\n\ + {strokepath} stopped {\n\ + (This Postscript printer gets limitcheck overflows when) =\n\ + (stippling dashed lines; lines will be printed solid instead.) =\n\ + [] 0 setdash strokepath} if\n\ + clip\n\ +} bind def\n\ +\n\ +% d", + /* End of part 2 */ + + /* Start of part 3 (2000 characters) */ + "esiredSize EvenPixels closestSize\n\ +%\n\ +% The procedure below is used for stippling. Given the optimal size\n\ +% of a dot in a stipple pattern in the current user coordinate system,\n\ +% compute the closest size that is an exact multiple of the device's\n\ +% pixel size. This allows stipple patterns to be displayed without\n\ +% aliasing effects.\n\ +\n\ +/EvenPixels {\n\ + % Compute exact number of device pixels per stipple dot.\n\ + dup 0 matrix currentmatrix dtransform\n\ + dup mul exch dup mul add sqrt\n\ +\n\ + % Round to an integer, make sure the number is at least 1, and compute\n\ + % user coord distance corresponding to this.\n\ + dup round dup 1 lt {pop 1} if\n\ + exch div mul\n\ +} bind def\n\ +\n\ +% width height string StippleFill --\n\ +%\n\ +% Given a path already set up and a clipping region generated from\n\ +% it, this procedure will fill the clipping region with a stipple\n\ +% pattern. \"String\" contains a proper image description of the\n\ +% stipple pattern and \"width\" and \"height\" give its dimensions. Each\n\ +% stipple dot is assumed to be about one unit across in the current\n\ +% user coordinate system. This procedure trashes the graphics state.\n\ +\n\ +/StippleFill {\n\ + % The following code is needed to work around a NeWSprint bug.\n\ +\n\ + /tmpstip 1 index def\n\ +\n\ + % Change the scaling so that one user unit in user coordinates\n\ + % corresponds to the size of one stipple dot.\n\ + 1 EvenPixels dup scale\n\ +\n\ + % Compute the bounding box occupied by the path (which is now\n\ + % the clipping region), and round the lower coordinates down\n\ + % to the nearest starting point for the stipple pattern. Be\n\ + % careful about negative numbers, since the rounding works\n\ + % differently on them.\n\ +\n\ + pathbbox\n\ + 4 2 roll\n\ + 5 index div dup 0 lt {1 sub} if cvi 5 index mul 4 1 roll\n\ + 6 index div dup 0 lt {1 sub} if cvi 6 index mul 3 2 roll\n\ +\n\ + % Stack now: width height string y1 y2 x1 x2\n\ + % Below is a doubly-nested for loop to iterate across this area\n\ + % in units of the stipple pattern size, going up columns then\n\ + % acr", + /* End of part 3 */ + + /* Start of part 4 (2000 characters) */ + "oss rows, blasting out a stipple-pattern-sized rectangle at\n\ + % each position\n\ +\n\ + 6 index exch {\n\ + 2 index 5 index 3 index {\n\ + % Stack now: width height string y1 y2 x y\n\ +\n\ + gsave\n\ + 1 index exch translate\n\ + 5 index 5 index true matrix tmpstip imagemask\n\ + grestore\n\ + } for\n\ + pop\n\ + } for\n\ + pop pop pop pop pop\n\ +} bind def\n\ +\n\ +% -- AdjustColor --\n\ +% Given a color value already set for output by the caller, adjusts\n\ +% that value to a grayscale or mono value if requested by the CL\n\ +% variable.\n\ +\n\ +/AdjustColor {\n\ + CL 2 lt {\n\ + currentgray\n\ + CL 0 eq {\n\ + .5 lt {0} {1} ifelse\n\ + } if\n\ + setgray\n\ + } if\n\ +} bind def\n\ +\n\ +% x y strings spacing xoffset yoffset justify stipple DrawText --\n\ +% This procedure does all of the real work of drawing text. The\n\ +% color and font must already have been set by the caller, and the\n\ +% following arguments must be on the stack:\n\ +%\n\ +% x, y - Coordinates at which to draw text.\n\ +% strings - An array of strings, one for each line of the text item,\n\ +% in order from top to bottom.\n\ +% spacing - Spacing between lines.\n\ +% xoffset - Horizontal offset for text bbox relative to x and y: 0 for\n\ +% nw/w/sw anchor, -0.5 for n/center/s, and -1.0 for ne/e/se.\n\ +% yoffset - Vertical offset for text bbox relative to x and y: 0 for\n\ +% nw/n/ne anchor, +0.5 for w/center/e, and +1.0 for sw/s/se.\n\ +% justify - 0 for left justification, 0.5 for center, 1 for right justify.\n\ +% stipple - Boolean value indicating whether or not text is to be\n\ +% drawn in stippled fashion. If text is stippled,\n\ +% procedure StippleText must have been defined to call\n\ +% StippleFill in the right way.\n\ +%\n\ +% Also, when this procedure is invoked, the color and font must already\n\ +% have been set for the text.\n\ +\n\ +/DrawText {\n\ + /stipple exch def\n\ + /justify exch def\n\ + /yoffset exch def\n\ + /xoffset exch def\n\ + /spacing exch def\n\ + /strings exch def\n\ +\n\ + % First scan through all of the text to find the widest line.\n\ +\n\ + /lineLength 0 def\n\ + strings {\n\ + stringwidth pop\n\ + dup lineLength gt {/lineLength exch def}", + /* End of part 4 */ + + /* Start of part 5 (1546 characters) */ + " {pop} ifelse\n\ + newpath\n\ + } forall\n\ +\n\ + % Compute the baseline offset and the actual font height.\n\ +\n\ + 0 0 moveto (TXygqPZ) false charpath\n\ + pathbbox dup /baseline exch def\n\ + exch pop exch sub /height exch def pop\n\ + newpath\n\ +\n\ + % Translate coordinates first so that the origin is at the upper-left\n\ + % corner of the text's bounding box. Remember that x and y for\n\ + % positioning are still on the stack.\n\ +\n\ + translate\n\ + lineLength xoffset mul\n\ + strings length 1 sub spacing mul height add yoffset mul translate\n\ +\n\ + % Now use the baseline and justification information to translate so\n\ + % that the origin is at the baseline and positioning point for the\n\ + % first line of text.\n\ +\n\ + justify lineLength mul baseline neg translate\n\ +\n\ + % Iterate over each of the lines to output it. For each line,\n\ + % compute its width again so it can be properly justified, then\n\ + % display it.\n\ +\n\ + strings {\n\ + dup stringwidth pop\n\ + justify neg mul 0 moveto\n\ + stipple {\n\ +\n\ + % The text is stippled, so turn it into a path and print\n\ + % by calling StippledText, which in turn calls StippleFill.\n\ + % Unfortunately, many Postscript interpreters will get\n\ + % overflow errors if we try to do the whole string at\n\ + % once, so do it a character at a time.\n\ +\n\ + gsave\n\ + /char (X) def\n\ + {\n\ + char 0 3 -1 roll put\n\ + currentpoint\n\ + gsave\n\ + char true charpath clip StippleText\n\ + grestore\n\ + char stringwidth translate\n\ + moveto\n\ + } forall\n\ + grestore\n\ + } {show} ifelse\n\ + 0 spacing neg translate\n\ + } forall\n\ +} bind def\n\ +\n\ +%%EndProlog\n\ +", + /* End of part 5 */ + + NULL /* End of data marker */ +}; + +/* * Forward declarations for procedures defined later in this file: */ @@ -164,6 +478,7 @@ TkCanvPostscriptCmd(canvasPtr, interp, argc, argv) Tcl_HashSearch search; Tcl_HashEntry *hPtr; Tcl_DString buffer; + CONST char * CONST *chunk; /* *---------------------------------------------------------------- @@ -398,7 +713,7 @@ TkCanvPostscriptCmd(canvasPtr, interp, argc, argv) "%%Creator: Tk Canvas Widget\n", (char *) NULL); #if !(defined(__WIN32__) || defined(MAC_TCL)) if (!Tcl_IsSafe(interp)) { - struct passwd *pwPtr = getpwuid(getuid()); + struct passwd *pwPtr = getpwuid(getuid()); /* INTL: Native. */ Tcl_AppendResult(canvasPtr->interp, "%%For: ", (pwPtr != NULL) ? pwPtr->pw_gecos : "Unknown", "\n", (char *) NULL); @@ -409,7 +724,7 @@ TkCanvPostscriptCmd(canvasPtr, interp, argc, argv) Tk_PathName(canvasPtr->tkwin), "\n", (char *) NULL); time(&now); Tcl_AppendResult(canvasPtr->interp, "%%CreationDate: ", - ctime(&now), (char *) NULL); + ctime(&now), (char *) NULL); /* INTL: Native. */ if (!psInfo.rotate) { sprintf(string, "%d %d %d %d", (int) (psInfo.pageX + psInfo.scale*deltaX), @@ -443,16 +758,14 @@ TkCanvPostscriptCmd(canvasPtr, interp, argc, argv) Tcl_AppendResult(canvasPtr->interp, "%%EndComments\n\n", (char *) NULL); /* - * Read a standard prolog file in a native way and insert it into - * the Postscript. + * Insert the prolog */ - - if (TkGetNativeProlog(canvasPtr->interp) != TCL_OK) { - result = TCL_ERROR; - goto cleanup; + for (chunk=prolog; *chunk; chunk++) { + Tcl_AppendResult(interp, *chunk, (char *) NULL); } + if (psInfo.chan != NULL) { - Tcl_Write(psInfo.chan, canvasPtr->interp->result, -1); + Tcl_Write(psInfo.chan, Tcl_GetStringResult(canvasPtr->interp), -1); Tcl_ResetResult(canvasPtr->interp); } @@ -499,7 +812,7 @@ TkCanvPostscriptCmd(canvasPtr, interp, argc, argv) Tcl_AppendResult(canvasPtr->interp, string, " lineto closepath clip newpath\n", (char *) NULL); if (psInfo.chan != NULL) { - Tcl_Write(psInfo.chan, canvasPtr->interp->result, -1); + Tcl_Write(psInfo.chan, Tcl_GetStringResult(canvasPtr->interp), -1); Tcl_ResetResult(canvasPtr->interp); } @@ -524,7 +837,7 @@ TkCanvPostscriptCmd(canvasPtr, interp, argc, argv) result = (*itemPtr->typePtr->postscriptProc)(canvasPtr->interp, (Tk_Canvas) canvasPtr, itemPtr, 0); if (result != TCL_OK) { - char msg[100]; + char msg[64 + TCL_INTEGER_SPACE]; sprintf(msg, "\n (generating Postscript for item %d)", itemPtr->id); @@ -533,7 +846,7 @@ TkCanvPostscriptCmd(canvasPtr, interp, argc, argv) } Tcl_AppendResult(canvasPtr->interp, "grestore\n", (char *) NULL); if (psInfo.chan != NULL) { - Tcl_Write(psInfo.chan, canvasPtr->interp->result, -1); + Tcl_Write(psInfo.chan, Tcl_GetStringResult(canvasPtr->interp), -1); Tcl_ResetResult(canvasPtr->interp); } } @@ -548,7 +861,7 @@ TkCanvPostscriptCmd(canvasPtr, interp, argc, argv) Tcl_AppendResult(canvasPtr->interp, "restore showpage\n\n", "%%Trailer\nend\n%%EOF\n", (char *) NULL); if (psInfo.chan != NULL) { - Tcl_Write(psInfo.chan, canvasPtr->interp->result, -1); + Tcl_Write(psInfo.chan, Tcl_GetStringResult(canvasPtr->interp), -1); Tcl_ResetResult(canvasPtr->interp); } @@ -604,9 +917,9 @@ TkCanvPostscriptCmd(canvasPtr, interp, argc, argv) * * Results: * Returns a standard Tcl return value. If an error occurs - * then an error message will be left in interp->result. + * then an error message will be left in the interp's result. * If no error occurs, then additional Postscript will be - * appended to interp->result. + * appended to the interp's result. * * Side effects: * None. @@ -685,9 +998,9 @@ Tk_CanvasPsColor(interp, canvas, colorPtr) * * Results: * Returns a standard Tcl return value. If an error occurs - * then an error message will be left in interp->result. + * then an error message will be left in the interp's result. * If no error occurs, then additional Postscript will be - * appended to the interp->result. + * appended to the interp's result. * * Side effects: * The Postscript font name is entered into psInfoPtr->fontTable @@ -707,7 +1020,7 @@ Tk_CanvasPsFont(interp, canvas, tkfont) TkCanvas *canvasPtr = (TkCanvas *) canvas; TkPostscriptInfo *psInfoPtr = canvasPtr->psInfoPtr; char *end; - char pointString[20]; + char pointString[TCL_INTEGER_SPACE]; Tcl_DString ds; int i, points; @@ -779,9 +1092,9 @@ Tk_CanvasPsFont(interp, canvas, tkfont) * * Results: * Returns a standard Tcl return value. If an error occurs - * then an error message will be left in interp->result. + * then an error message will be left in the interp's result. * If no error occurs, then additional Postscript will be - * appended to interp->result. + * appended to the interp's result. * * Side effects: * None. @@ -878,9 +1191,9 @@ Tk_CanvasPsBitmap(interp, canvas, bitmap, startX, startY, width, height) * * Results: * Returns a standard Tcl return value. If an error occurs - * then an error message will be left in interp->result. + * then an error message will be left in the interp's result. * If no error occurs, then additional Postscript will be - * appended to interp->result. + * appended to the interp's result. * * Side effects: * None. @@ -898,7 +1211,7 @@ Tk_CanvasPsStipple(interp, canvas, bitmap) TkCanvas *canvasPtr = (TkCanvas *) canvas; TkPostscriptInfo *psInfoPtr = canvasPtr->psInfoPtr; int width, height; - char string[100]; + char string[TCL_INTEGER_SPACE * 2]; Window dummyRoot; int dummyX, dummyY; unsigned dummyBorderwidth, dummyDepth; @@ -966,7 +1279,7 @@ Tk_CanvasPsY(canvas, y) * commands to create the path. * * Results: - * Postscript commands get appended to what's in interp->result. + * Postscript commands get appended to what's in the interp's result. * * Side effects: * None. @@ -1015,7 +1328,7 @@ Tk_CanvasPsPath(interp, canvas, coordPtr, numPoints) * TCL_OK is returned, then everything went well and the * screen distance is stored at *doublePtr; otherwise * TCL_ERROR is returned and an error message is left in - * interp->result. + * the interp's result. * * Side effects: * None. @@ -1072,92 +1385,3 @@ GetPostscriptPoints(interp, string, doublePtr) *doublePtr = d; return TCL_OK; } - -/* - *-------------------------------------------------------------- - * - * TkGetProlog -- - * - * Locate and load the postscript prolog. - * - * Results: - * A standard Tcl Result. If everything is OK the prolog - * will be located in the result string of the interpreter. - * - * Side effects: - * None. - * - *-------------------------------------------------------------- - */ - -int -TkGetProlog(interp) - Tcl_Interp *interp; /* Places the prolog in the result. */ -{ - char *libDir; - Tcl_Channel chan; - Tcl_DString buffer, buffer2; - char *prologPathParts[2]; - int bufferSize; - char *prologBuffer; - - libDir = Tcl_GetVar(interp, "tk_library", TCL_GLOBAL_ONLY); - if (libDir == NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't find library directory: ", - "tk_library variable doesn't exist", (char *) NULL); - return TCL_ERROR; - } - Tcl_TranslateFileName(interp, libDir, &buffer); - prologPathParts[0] = buffer.string; - prologPathParts[1] = "prolog.ps"; - Tcl_DStringInit(&buffer2); - Tcl_JoinPath(2, prologPathParts, &buffer2); - Tcl_DStringFree(&buffer); - - /* - * Compute size of file by seeking to the end of the file. This will - * overallocate if we are performing CRLF translation. - */ - - chan = Tcl_OpenFileChannel(NULL, buffer2.string, "r", 0); - if (chan == NULL) { - /* - * We have to set the error message ourselves because the - * interp's result need to be reset. - */ - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't open \"", - buffer2.string, "\": ", Tcl_PosixError(interp), (char *) NULL); - Tcl_DStringFree(&buffer2); - return TCL_ERROR; - } - - bufferSize = Tcl_Seek(chan, 0L, SEEK_END); - (void) Tcl_Seek(chan, 0L, SEEK_SET); - if (bufferSize < 0) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "error seeking to end of file \"", - buffer2.string, "\": ", Tcl_PosixError(interp), (char *) NULL); - Tcl_Close(NULL, chan); - Tcl_DStringFree(&buffer2); - return TCL_ERROR; - - } - prologBuffer = (char *) ckalloc((unsigned) bufferSize+1); - bufferSize = Tcl_Read(chan, prologBuffer, bufferSize); - Tcl_Close(NULL, chan); - if (bufferSize < 0) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "error reading file \"", buffer2.string, - "\": ", Tcl_PosixError(interp), (char *) NULL); - Tcl_DStringFree(&buffer2); - return TCL_ERROR; - } - Tcl_DStringFree(&buffer2); - prologBuffer[bufferSize] = 0; - Tcl_AppendResult(interp, prologBuffer, (char *) NULL); - ckfree(prologBuffer); - - return TCL_OK; -} diff --git a/generic/tkCanvText.c b/generic/tkCanvText.c index 2938ba1..0e624cc 100644 --- a/generic/tkCanvText.c +++ b/generic/tkCanvText.c @@ -4,12 +4,12 @@ * This file implements text items for canvas widgets. * * Copyright (c) 1991-1994 The Regents of the University of California. - * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkCanvText.c 1.68 97/10/09 17:44:53 + * SCCS: @(#) tkCanvText.c 1.70 97/11/07 21:15:29 */ #include <stdio.h> @@ -36,8 +36,8 @@ typedef struct TextItem { */ double x, y; /* Positioning point for text. */ - int insertPos; /* Insertion cursor is displayed just to left - * of character with this index. */ + int insertPos; /* Byte index of character just before which + * the insertion cursor is displayed. */ /* * Configuration settings that are updated by Tk_ConfigureWidget. @@ -57,7 +57,7 @@ typedef struct TextItem { * configuration settings above. */ - int numChars; /* Number of non-NULL characters in text. */ + int numBytes; /* Length of text in bytes. */ Tk_TextLayout textLayout; /* Cached text layout information. */ int leftEdge; /* Pixel location of the left edge of the * text item; where the left border of the @@ -154,26 +154,26 @@ static void TranslateText _ANSI_ARGS_((Tk_Canvas canvas, */ Tk_ItemType tkTextType = { - "text", /* name */ - sizeof(TextItem), /* itemSize */ - CreateText, /* createProc */ - configSpecs, /* configSpecs */ - ConfigureText, /* configureProc */ - TextCoords, /* coordProc */ - DeleteText, /* deleteProc */ - DisplayCanvText, /* displayProc */ - 0, /* alwaysRedraw */ - TextToPoint, /* pointProc */ - TextToArea, /* areaProc */ - TextToPostscript, /* postscriptProc */ - ScaleText, /* scaleProc */ - TranslateText, /* translateProc */ - GetTextIndex, /* indexProc */ - SetTextCursor, /* icursorProc */ - GetSelText, /* selectionProc */ - TextInsert, /* insertProc */ - TextDeleteChars, /* dTextProc */ - (Tk_ItemType *) NULL /* nextPtr */ + "text", /* name */ + sizeof(TextItem), /* itemSize */ + CreateText, /* createProc */ + configSpecs, /* configSpecs */ + ConfigureText, /* configureProc */ + TextCoords, /* coordProc */ + DeleteText, /* deleteProc */ + DisplayCanvText, /* displayProc */ + 0, /* alwaysRedraw */ + TextToPoint, /* pointProc */ + TextToArea, /* areaProc */ + TextToPostscript, /* postscriptProc */ + ScaleText, /* scaleProc */ + TranslateText, /* translateProc */ + GetTextIndex, /* indexProc */ + SetTextCursor, /* icursorProc */ + GetSelText, /* selectionProc */ + TextInsert, /* insertProc */ + TextDeleteChars, /* dTextProc */ + (Tk_ItemType *) NULL /* nextPtr */ }; /* @@ -187,7 +187,7 @@ Tk_ItemType tkTextType = { * Results: * A standard Tcl return value. If an error occurred in * creating the item then an error message is left in - * interp->result; in this case itemPtr is left uninitialized + * the interp's result; in this case itemPtr is left uninitialized * so it can be safely freed by the caller. * * Side effects: @@ -198,12 +198,12 @@ Tk_ItemType tkTextType = { static int CreateText(interp, canvas, itemPtr, argc, argv) - Tcl_Interp *interp; /* Interpreter for error reporting. */ - Tk_Canvas canvas; /* Canvas to hold new item. */ - Tk_Item *itemPtr; /* Record to hold new item; header - * has been initialized by caller. */ - int argc; /* Number of arguments in argv. */ - char **argv; /* Arguments describing rectangle. */ + Tcl_Interp *interp; /* Interpreter for error reporting. */ + Tk_Canvas canvas; /* Canvas to hold new item. */ + Tk_Item *itemPtr; /* Record to hold new item; header has been + * initialized by caller. */ + int argc; /* Number of arguments in argv. */ + char **argv; /* Arguments describing rectangle. */ { TextItem *textPtr = (TextItem *) itemPtr; @@ -215,8 +215,8 @@ CreateText(interp, canvas, itemPtr, argc, argv) } /* - * Carry out initialization that is needed in order to clean - * up after errors during the the remainder of this procedure. + * Carry out initialization that is needed in order to clean up after + * errors during the the remainder of this procedure. */ textPtr->textInfoPtr = Tk_CanvasGetTextInfo(canvas); @@ -231,7 +231,7 @@ CreateText(interp, canvas, itemPtr, argc, argv) textPtr->text = NULL; textPtr->width = 0; - textPtr->numChars = 0; + textPtr->numBytes = 0; textPtr->textLayout = NULL; textPtr->leftEdge = 0; textPtr->rightEdge = 0; @@ -266,7 +266,7 @@ CreateText(interp, canvas, itemPtr, argc, argv) * details on what it does. * * Results: - * Returns TCL_OK or TCL_ERROR, and sets interp->result. + * Returns TCL_OK or TCL_ERROR, and sets the interp's result. * * Side effects: * The coordinates for the given item may be changed. @@ -276,14 +276,12 @@ CreateText(interp, canvas, itemPtr, argc, argv) static int TextCoords(interp, canvas, itemPtr, argc, argv) - Tcl_Interp *interp; /* Used for error reporting. */ - Tk_Canvas canvas; /* Canvas containing item. */ - Tk_Item *itemPtr; /* Item whose coordinates are to be - * read or modified. */ - int argc; /* Number of coordinates supplied in - * argv. */ - char **argv; /* Array of coordinates: x1, y1, - * x2, y2, ... */ + Tcl_Interp *interp; /* Used for error reporting. */ + Tk_Canvas canvas; /* Canvas containing item. */ + Tk_Item *itemPtr; /* Item whose coordinates are to be read or + * modified. */ + int argc; /* Number of coordinates supplied in argv. */ + char **argv; /* Array of coordinates: x1, y1, x2, y2, ... */ { TextItem *textPtr = (TextItem *) itemPtr; char x[TCL_DOUBLE_SPACE], y[TCL_DOUBLE_SPACE]; @@ -300,8 +298,10 @@ TextCoords(interp, canvas, itemPtr, argc, argv) } ComputeTextBbox(canvas, textPtr); } else { - sprintf(interp->result, - "wrong # coordinates: expected 0 or 2, got %d", argc); + char buf[64 + TCL_INTEGER_SPACE]; + + sprintf(buf, "wrong # coordinates: expected 0 or 2, got %d", argc); + Tcl_SetResult(interp, buf, TCL_VOLATILE); return TCL_ERROR; } return TCL_OK; @@ -317,7 +317,7 @@ TextCoords(interp, canvas, itemPtr, argc, argv) * * Results: * A standard Tcl result code. If an error occurs, then - * an error message is left in interp->result. + * an error message is left in the interp's result. * * Side effects: * Configuration information, such as colors and stipple @@ -400,22 +400,25 @@ ConfigureText(interp, canvas, itemPtr, argc, argv, flags) * to keep them inside the item. */ - textPtr->numChars = strlen(textPtr->text); + textPtr->numBytes = strlen(textPtr->text); if (textInfoPtr->selItemPtr == itemPtr) { - if (textInfoPtr->selectFirst >= textPtr->numChars) { + int numChars; + + numChars = Tcl_NumUtfChars(textPtr->text, textPtr->numBytes); + if (textInfoPtr->selectFirst >= numChars) { textInfoPtr->selItemPtr = NULL; } else { - if (textInfoPtr->selectLast >= textPtr->numChars) { - textInfoPtr->selectLast = textPtr->numChars-1; + if (textInfoPtr->selectLast >= numChars) { + textInfoPtr->selectLast = numChars - 1; } if ((textInfoPtr->anchorItemPtr == itemPtr) - && (textInfoPtr->selectAnchor >= textPtr->numChars)) { - textInfoPtr->selectAnchor = textPtr->numChars-1; + && (textInfoPtr->selectAnchor >= numChars)) { + textInfoPtr->selectAnchor = numChars - 1; } } } - if (textPtr->insertPos >= textPtr->numChars) { - textPtr->insertPos = textPtr->numChars; + if (textPtr->insertPos >= textPtr->numBytes) { + textPtr->insertPos = textPtr->numBytes; } ComputeTextBbox(canvas, textPtr); @@ -441,10 +444,9 @@ ConfigureText(interp, canvas, itemPtr, argc, argv, flags) static void DeleteText(canvas, itemPtr, display) - Tk_Canvas canvas; /* Info about overall canvas widget. */ - Tk_Item *itemPtr; /* Item that is being deleted. */ - Display *display; /* Display containing window for - * canvas. */ + Tk_Canvas canvas; /* Info about overall canvas widget. */ + Tk_Item *itemPtr; /* Item that is being deleted. */ + Display *display; /* Display containing window for canvas. */ { TextItem *textPtr = (TextItem *) itemPtr; @@ -494,16 +496,15 @@ DeleteText(canvas, itemPtr, display) static void ComputeTextBbox(canvas, textPtr) - Tk_Canvas canvas; /* Canvas that contains item. */ - TextItem *textPtr; /* Item whose bbos is to be - * recomputed. */ + Tk_Canvas canvas; /* Canvas that contains item. */ + TextItem *textPtr; /* Item whose bbox is to be recomputed. */ { Tk_CanvasTextInfo *textInfoPtr; int leftX, topY, width, height, fudge; Tk_FreeTextLayout(textPtr->textLayout); textPtr->textLayout = Tk_ComputeTextLayout(textPtr->tkfont, - textPtr->text, textPtr->numChars, textPtr->width, + textPtr->text, textPtr->numBytes, textPtr->width, textPtr->justify, 0, &width, &height); /* @@ -591,13 +592,12 @@ ComputeTextBbox(canvas, textPtr) static void DisplayCanvText(canvas, itemPtr, display, drawable, x, y, width, height) - Tk_Canvas canvas; /* Canvas that contains item. */ - Tk_Item *itemPtr; /* Item to be displayed. */ - Display *display; /* Display on which to draw item. */ - Drawable drawable; /* Pixmap or window in which to draw - * item. */ - int x, y, width, height; /* Describes region of canvas that - * must be redisplayed (not used). */ + Tk_Canvas canvas; /* Canvas that contains item. */ + Tk_Item *itemPtr; /* Item to be displayed. */ + Display *display; /* Display on which to draw item. */ + Drawable drawable; /* Pixmap or window in which to draw item. */ + int x, y, width, height; /* Describes region of canvas that must be + * redisplayed (not used). */ { TextItem *textPtr; Tk_CanvasTextInfo *textInfoPtr; @@ -624,23 +624,31 @@ DisplayCanvText(canvas, itemPtr, display, drawable, x, y, width, height) selFirst = -1; selLast = 0; /* lint. */ if (textInfoPtr->selItemPtr == itemPtr) { - selFirst = textInfoPtr->selectFirst; - selLast = textInfoPtr->selectLast; - if (selLast >= textPtr->numChars) { - selLast = textPtr->numChars - 1; + char *text; + int numChars, selFirstChar, selLastChar; + + text = textPtr->text; + numChars = Tcl_NumUtfChars(text, textPtr->numBytes); + selFirstChar = textInfoPtr->selectFirst; + selLastChar = textInfoPtr->selectLast; + if (selLastChar >= numChars) { + selLastChar = numChars - 1; } - if ((selFirst >= 0) && (selFirst <= selLast)) { + if ((selFirstChar >= 0) && (selFirstChar <= selLastChar)) { + int xFirst, yFirst, hFirst; + int xLast, yLast; + /* * Draw a special background under the selection. */ - int xFirst, yFirst, hFirst; - int xLast, yLast, wLast; + selFirst = Tcl_UtfAtIndex(text, selFirstChar) - text; + selLast = Tcl_UtfAtIndex(text, selLastChar + 1) - text; - Tk_CharBbox(textPtr->textLayout, selFirst, - &xFirst, &yFirst, NULL, &hFirst); - Tk_CharBbox(textPtr->textLayout, selLast, - &xLast, &yLast, &wLast, NULL); + Tk_CharBbox(textPtr->textLayout, selFirst, &xFirst, &yFirst, + NULL, &hFirst); + Tk_CharBbox(textPtr->textLayout, selLast, &xLast, &yLast, + NULL, NULL); /* * If the selection spans the end of this line, then display @@ -653,7 +661,7 @@ DisplayCanvText(canvas, itemPtr, display, drawable, x, y, width, height) height = hFirst; for (y = yFirst ; y <= yLast; y += height) { if (y == yLast) { - width = (xLast + wLast) - x; + width = xLast - x; } else { width = textPtr->rightEdge - textPtr->leftEdge - x; } @@ -754,36 +762,43 @@ DisplayCanvText(canvas, itemPtr, display, drawable, x, y, width, height) */ static void -TextInsert(canvas, itemPtr, beforeThis, string) +TextInsert(canvas, itemPtr, index, string) Tk_Canvas canvas; /* Canvas containing text item. */ Tk_Item *itemPtr; /* Text item to be modified. */ - int beforeThis; /* Index of character before which text is + int index; /* Character index before which string is * to be inserted. */ char *string; /* New characters to be inserted. */ { TextItem *textPtr = (TextItem *) itemPtr; - int length; - char *new; + int numChars, byteIndex, byteCount, charsAdded; + char *new, *text; Tk_CanvasTextInfo *textInfoPtr = textPtr->textInfoPtr; - length = strlen(string); - if (length == 0) { - return; + text = textPtr->text; + numChars = Tcl_NumUtfChars(text, textPtr->numBytes); + + if (index < 0) { + index = 0; } - if (beforeThis < 0) { - beforeThis = 0; + if (index > numChars) { + index = numChars; } - if (beforeThis > textPtr->numChars) { - beforeThis = textPtr->numChars; + byteIndex = Tcl_UtfAtIndex(text, index) - text; + byteCount = strlen(string); + if (byteCount == 0) { + return; } - new = (char *) ckalloc((unsigned) (textPtr->numChars + length + 1)); - strncpy(new, textPtr->text, (size_t) beforeThis); - strcpy(new+beforeThis, string); - strcpy(new+beforeThis+length, textPtr->text+beforeThis); - ckfree(textPtr->text); + new = (char *) ckalloc((unsigned) textPtr->numBytes + byteCount + 1); + memcpy(new, text, (size_t) byteIndex); + strcpy(new + byteIndex, string); + strcpy(new + byteIndex + byteCount, text + byteIndex); + + ckfree(text); textPtr->text = new; - textPtr->numChars += length; + textPtr->numBytes += byteCount; + + charsAdded = Tcl_NumUtfChars(new, textPtr->numBytes) - numChars; /* * Inserting characters invalidates indices such as those for the @@ -791,19 +806,19 @@ TextInsert(canvas, itemPtr, beforeThis, string) */ if (textInfoPtr->selItemPtr == itemPtr) { - if (textInfoPtr->selectFirst >= beforeThis) { - textInfoPtr->selectFirst += length; + if (textInfoPtr->selectFirst >= index) { + textInfoPtr->selectFirst += charsAdded; } - if (textInfoPtr->selectLast >= beforeThis) { - textInfoPtr->selectLast += length; + if (textInfoPtr->selectLast >= index) { + textInfoPtr->selectLast += charsAdded; } if ((textInfoPtr->anchorItemPtr == itemPtr) - && (textInfoPtr->selectAnchor >= beforeThis)) { - textInfoPtr->selectAnchor += length; + && (textInfoPtr->selectAnchor >= index)) { + textInfoPtr->selectAnchor += charsAdded; } } - if (textPtr->insertPos >= beforeThis) { - textPtr->insertPos += length; + if (textPtr->insertPos >= byteIndex) { + textPtr->insertPos += byteCount; } ComputeTextBbox(canvas, textPtr); } @@ -830,31 +845,41 @@ static void TextDeleteChars(canvas, itemPtr, first, last) Tk_Canvas canvas; /* Canvas containing itemPtr. */ Tk_Item *itemPtr; /* Item in which to delete characters. */ - int first; /* Index of first character to delete. */ - int last; /* Index of last character to delete. */ + int first; /* Character index of first character to + * delete. */ + int last; /* Character index of last character to + * delete (inclusive). */ { TextItem *textPtr = (TextItem *) itemPtr; - int count; - char *new; + int count, numChars, byteIndex, byteCount, charsRemoved; + char *new, *text; Tk_CanvasTextInfo *textInfoPtr = textPtr->textInfoPtr; + text = textPtr->text; + numChars = Tcl_NumUtfChars(text, textPtr->numBytes); if (first < 0) { first = 0; } - if (last >= textPtr->numChars) { - last = textPtr->numChars-1; + if (last >= numChars) { + last = numChars - 1; } if (first > last) { return; } count = last + 1 - first; - new = (char *) ckalloc((unsigned) (textPtr->numChars + 1 - count)); - strncpy(new, textPtr->text, (size_t) first); - strcpy(new+first, textPtr->text+last+1); - ckfree(textPtr->text); + byteIndex = Tcl_UtfAtIndex(text, first) - text; + byteCount = Tcl_UtfAtIndex(text + byteIndex, count) - (text + byteIndex); + + new = (char *) ckalloc((unsigned) (textPtr->numBytes + 1 - byteCount)); + memcpy(new, text, (size_t) byteIndex); + strcpy(new + byteIndex, text + byteIndex + byteCount); + + ckfree(text); textPtr->text = new; - textPtr->numChars -= count; + textPtr->numBytes -= byteCount; + + charsRemoved = numChars - Tcl_NumUtfChars(new, textPtr->numBytes); /* * Update indexes for the selection and cursor to reflect the @@ -863,15 +888,15 @@ TextDeleteChars(canvas, itemPtr, first, last) if (textInfoPtr->selItemPtr == itemPtr) { if (textInfoPtr->selectFirst > first) { - textInfoPtr->selectFirst -= count; + textInfoPtr->selectFirst -= charsRemoved; if (textInfoPtr->selectFirst < first) { textInfoPtr->selectFirst = first; } } if (textInfoPtr->selectLast >= first) { - textInfoPtr->selectLast -= count; - if (textInfoPtr->selectLast < (first-1)) { - textInfoPtr->selectLast = (first-1); + textInfoPtr->selectLast -= charsRemoved; + if (textInfoPtr->selectLast < first - 1) { + textInfoPtr->selectLast = first - 1; } } if (textInfoPtr->selectFirst > textInfoPtr->selectLast) { @@ -879,16 +904,16 @@ TextDeleteChars(canvas, itemPtr, first, last) } if ((textInfoPtr->anchorItemPtr == itemPtr) && (textInfoPtr->selectAnchor > first)) { - textInfoPtr->selectAnchor -= count; + textInfoPtr->selectAnchor -= charsRemoved; if (textInfoPtr->selectAnchor < first) { textInfoPtr->selectAnchor = first; } } } - if (textPtr->insertPos > first) { - textPtr->insertPos -= count; - if (textPtr->insertPos < first) { - textPtr->insertPos = first; + if (textPtr->insertPos > byteIndex) { + textPtr->insertPos -= byteCount; + if (textPtr->insertPos < byteIndex) { + textPtr->insertPos = byteIndex; } } ComputeTextBbox(canvas, textPtr); @@ -987,11 +1012,11 @@ TextToArea(canvas, itemPtr, rectPtr) /* ARGSUSED */ static void ScaleText(canvas, itemPtr, originX, originY, scaleX, scaleY) - Tk_Canvas canvas; /* Canvas containing rectangle. */ - Tk_Item *itemPtr; /* Rectangle to be scaled. */ - double originX, originY; /* Origin about which to scale rect. */ - double scaleX; /* Amount to scale in X direction. */ - double scaleY; /* Amount to scale in Y direction. */ + Tk_Canvas canvas; /* Canvas containing rectangle. */ + Tk_Item *itemPtr; /* Rectangle to be scaled. */ + double originX, originY; /* Origin about which to scale rect. */ + double scaleX; /* Amount to scale in X direction. */ + double scaleY; /* Amount to scale in Y direction. */ { TextItem *textPtr = (TextItem *) itemPtr; @@ -1022,10 +1047,9 @@ ScaleText(canvas, itemPtr, originX, originY, scaleX, scaleY) static void TranslateText(canvas, itemPtr, deltaX, deltaY) - Tk_Canvas canvas; /* Canvas containing item. */ - Tk_Item *itemPtr; /* Item that is being moved. */ - double deltaX, deltaY; /* Amount by which item is to be - * moved. */ + Tk_Canvas canvas; /* Canvas containing item. */ + Tk_Item *itemPtr; /* Item that is being moved. */ + double deltaX, deltaY; /* Amount by which item is to be moved. */ { TextItem *textPtr = (TextItem *) itemPtr; @@ -1046,7 +1070,7 @@ TranslateText(canvas, itemPtr, deltaX, deltaY) * A standard Tcl result. If all went well, then *indexPtr is * filled in with the index (into itemPtr) corresponding to * string. Otherwise an error message is left in - * interp->result. + * the interp's result. * * Side effects: * None. @@ -1062,7 +1086,8 @@ GetTextIndex(interp, canvas, itemPtr, string, indexPtr) * specified. */ char *string; /* Specification of a particular character * in itemPtr's text. */ - int *indexPtr; /* Where to store converted index. */ + int *indexPtr; /* Where to store converted character + * index. */ { TextItem *textPtr = (TextItem *) itemPtr; size_t length; @@ -1074,25 +1099,27 @@ GetTextIndex(interp, canvas, itemPtr, string, indexPtr) length = strlen(string); if ((c == 'e') && (strncmp(string, "end", length) == 0)) { - *indexPtr = textPtr->numChars; + *indexPtr = Tcl_UtfAtIndex(textPtr->text, textPtr->numBytes) + - textPtr->text; } else if ((c == 'i') && (strncmp(string, "insert", length) == 0)) { - *indexPtr = textPtr->insertPos; + *indexPtr = Tcl_UtfAtIndex(textPtr->text, textPtr->insertPos) + - textPtr->text; } else if ((c == 's') && (strncmp(string, "sel.first", length) == 0) && (length >= 5)) { if (textInfoPtr->selItemPtr != itemPtr) { - interp->result = "selection isn't in item"; + Tcl_SetResult(interp, "selection isn't in item", TCL_STATIC); return TCL_ERROR; } *indexPtr = textInfoPtr->selectFirst; } else if ((c == 's') && (strncmp(string, "sel.last", length) == 0) && (length >= 5)) { if (textInfoPtr->selItemPtr != itemPtr) { - interp->result = "selection isn't in item"; + Tcl_SetResult(interp, "selection isn't in item", TCL_STATIC); return TCL_ERROR; } *indexPtr = textInfoPtr->selectLast; } else if (c == '@') { - int x, y; + int x, y, byteIndex; double tmp; char *end, *p; @@ -1108,18 +1135,22 @@ GetTextIndex(interp, canvas, itemPtr, string, indexPtr) goto badIndex; } y = (int) ((tmp < 0) ? tmp - 0.5 : tmp + 0.5); - *indexPtr = Tk_PointToChar(textPtr->textLayout, + byteIndex = Tk_PointToChar(textPtr->textLayout, x + canvasPtr->scrollX1 - textPtr->leftEdge, y + canvasPtr->scrollY1 - textPtr->header.y1); + *indexPtr = Tcl_UtfAtIndex(textPtr->text, byteIndex) - textPtr->text; } else if (Tcl_GetInt(interp, string, indexPtr) == TCL_OK) { + int numChars; + + numChars = Tcl_NumUtfChars(textPtr->text, textPtr->numBytes); if (*indexPtr < 0){ *indexPtr = 0; - } else if (*indexPtr > textPtr->numChars) { - *indexPtr = textPtr->numChars; + } else if (*indexPtr > numChars) { + *indexPtr = numChars; } } else { /* - * Some of the paths here leave messages in interp->result, + * Some of the paths here leave messages in the interp's result, * so we have to clear it out before storing our own message. */ @@ -1151,18 +1182,18 @@ GetTextIndex(interp, canvas, itemPtr, string, indexPtr) /* ARGSUSED */ static void SetTextCursor(canvas, itemPtr, index) - Tk_Canvas canvas; /* Record describing canvas widget. */ - Tk_Item *itemPtr; /* Text item in which cursor position - * is to be set. */ - int index; /* Index of character just before which - * cursor is to be positioned. */ + Tk_Canvas canvas; /* Record describing canvas widget. */ + Tk_Item *itemPtr; /* Text item in which cursor position is to + * be set. */ + int index; /* Byte index of character just before which + * cursor is to be positioned. */ { TextItem *textPtr = (TextItem *) itemPtr; if (index < 0) { textPtr->insertPos = 0; - } else if (index > textPtr->numChars) { - textPtr->insertPos = textPtr->numChars; + } else if (index > textPtr->numBytes) { + textPtr->insertPos = textPtr->numBytes; } else { textPtr->insertPos = index; } @@ -1191,34 +1222,38 @@ SetTextCursor(canvas, itemPtr, index) static int GetSelText(canvas, itemPtr, offset, buffer, maxBytes) - Tk_Canvas canvas; /* Canvas containing selection. */ - Tk_Item *itemPtr; /* Text item containing selection. */ - int offset; /* Offset within selection of first - * character to be returned. */ - char *buffer; /* Location in which to place - * selection. */ - int maxBytes; /* Maximum number of bytes to place - * at buffer, not including terminating - * NULL character. */ + Tk_Canvas canvas; /* Canvas containing selection. */ + Tk_Item *itemPtr; /* Text item containing selection. */ + int offset; /* Byte offset within selection of first + * character to be returned. */ + char *buffer; /* Location in which to place selection. */ + int maxBytes; /* Maximum number of bytes to place at + * buffer, not including terminating NULL + * character. */ { TextItem *textPtr = (TextItem *) itemPtr; - int count; + int byteCount; + char *text, *selStart, *selEnd; Tk_CanvasTextInfo *textInfoPtr = textPtr->textInfoPtr; - count = textInfoPtr->selectLast + 1 - textInfoPtr->selectFirst - offset; - if (textInfoPtr->selectLast == textPtr->numChars) { - count -= 1; + if ((textInfoPtr->selectFirst < 0) || + (textInfoPtr->selectFirst > textInfoPtr->selectLast)) { + return 0; } - if (count > maxBytes) { - count = maxBytes; + text = textPtr->text; + selStart = Tcl_UtfAtIndex(text, textInfoPtr->selectFirst); + selEnd = Tcl_UtfAtIndex(selStart, + textInfoPtr->selectLast + 1 - textInfoPtr->selectFirst); + byteCount = selEnd - selStart - offset; + if (byteCount > maxBytes) { + byteCount = maxBytes; } - if (count <= 0) { + if (byteCount <= 0) { return 0; } - strncpy(buffer, textPtr->text + textInfoPtr->selectFirst + offset, - (size_t) count); - buffer[count] = '\0'; - return count; + memcpy(buffer, selStart + offset, (size_t) byteCount); + buffer[byteCount] = '\0'; + return byteCount; } /* @@ -1232,7 +1267,7 @@ GetSelText(canvas, itemPtr, offset, buffer, maxBytes) * Results: * The return value is a standard Tcl result. If an error * occurs in generating Postscript then an error message is - * left in interp->result, replacing whatever used + * left in the interp's result, replacing whatever used * to be there. If no error occurs, then Postscript for the * item is appended to the result. * @@ -1244,14 +1279,12 @@ GetSelText(canvas, itemPtr, offset, buffer, maxBytes) static int TextToPostscript(interp, canvas, itemPtr, prepass) - Tcl_Interp *interp; /* Leave Postscript or error message - * here. */ - Tk_Canvas canvas; /* Information about overall canvas. */ - Tk_Item *itemPtr; /* Item for which Postscript is - * wanted. */ - int prepass; /* 1 means this is a prepass to - * collect font information; 0 means - * final Postscript is being created. */ + Tcl_Interp *interp; /* Leave Postscript or error message here. */ + Tk_Canvas canvas; /* Information about overall canvas. */ + Tk_Item *itemPtr; /* Item for which Postscript is wanted. */ + int prepass; /* 1 means this is a prepass to collect + * font information; 0 means final Postscript + * is being created. */ { TextItem *textPtr = (TextItem *) itemPtr; int x, y; diff --git a/generic/tkCanvUtil.c b/generic/tkCanvUtil.c index 9b52a80..a71b851 100644 --- a/generic/tkCanvUtil.c +++ b/generic/tkCanvUtil.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkCanvUtil.c 1.7 96/05/03 10:54:22 + * SCCS: @(#) tkCanvUtil.c 1.8 97/11/07 21:19:06 */ #include "tk.h" @@ -177,7 +177,7 @@ Tk_CanvasWindowCoords(canvas, x, y, screenXPtr, screenYPtr) * TCL_OK is returned, then everything went well and the * canvas coordinate is stored at *doublePtr; otherwise * TCL_ERROR is returned and an error message is left in - * interp->result. + * the interp's result. * * Side effects: * None. diff --git a/generic/tkCanvWind.c b/generic/tkCanvWind.c index 61b21da..59f2c87 100644 --- a/generic/tkCanvWind.c +++ b/generic/tkCanvWind.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkCanvWind.c 1.29 97/10/14 10:40:54 + * SCCS: @(#) tkCanvWind.c 1.30 97/11/07 21:15:39 */ #include <stdio.h> @@ -147,7 +147,7 @@ static Tk_GeomMgr canvasGeomType = { * Results: * A standard Tcl return value. If an error occurred in * creating the item, then an error message is left in - * interp->result; in this case itemPtr is + * the interp's result; in this case itemPtr is * left uninitialized, so it can be safely freed by the * caller. * @@ -214,7 +214,7 @@ CreateWinItem(interp, canvas, itemPtr, argc, argv) * details on what it does. * * Results: - * Returns TCL_OK or TCL_ERROR, and sets interp->result. + * Returns TCL_OK or TCL_ERROR, and sets the interp's result. * * Side effects: * The coordinates for the given item may be changed. @@ -248,8 +248,10 @@ WinItemCoords(interp, canvas, itemPtr, argc, argv) } ComputeWindowBbox(canvas, winItemPtr); } else { - sprintf(interp->result, - "wrong # coordinates: expected 0 or 2, got %d", argc); + char buf[64 + TCL_INTEGER_SPACE]; + + sprintf(buf, "wrong # coordinates: expected 0 or 2, got %d", argc); + Tcl_SetResult(interp, buf, TCL_VOLATILE); return TCL_ERROR; } return TCL_OK; @@ -265,7 +267,7 @@ WinItemCoords(interp, canvas, itemPtr, argc, argv) * * Results: * A standard Tcl result code. If an error occurs, then - * an error message is left in interp->result. + * an error message is left in the interp's result. * * Side effects: * Configuration information may be set for itemPtr. diff --git a/generic/tkCanvas.c b/generic/tkCanvas.c index b093226..f7e7576 100644 --- a/generic/tkCanvas.c +++ b/generic/tkCanvas.c @@ -6,12 +6,12 @@ * objects such as rectangles, lines, and texts. * * Copyright (c) 1991-1994 The Regents of the University of California. - * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkCanvas.c 1.126 97/07/31 09:05:52 + * SCCS: @(#) tkCanvas.c 1.128 97/12/16 16:20:11 */ #include "default.h" @@ -369,7 +369,7 @@ Tk_CanvasCmd(clientData, interp, argc, argv) goto error; } - interp->result = Tk_PathName(canvasPtr->tkwin); + Tcl_SetResult(interp, Tk_PathName(canvasPtr->tkwin), TCL_STATIC); return TCL_OK; error: @@ -472,7 +472,10 @@ CanvasWidgetCmd(clientData, interp, argc, argv) } } if (gotAny) { - sprintf(interp->result, "%d %d %d %d", x1, y1, x2, y2); + char buf[TCL_INTEGER_SPACE * 4]; + + sprintf(buf, "%d %d %d %d", x1, y1, x2, y2); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } } else if ((c == 'b') && (strncmp(argv[1], "bind", length) == 0) && (length >= 2)) { @@ -562,15 +565,30 @@ CanvasWidgetCmd(clientData, interp, argc, argv) command = Tk_GetBinding(interp, canvasPtr->bindingTable, object, argv[3]); if (command == NULL) { - goto error; + char *string; + + string = Tcl_GetStringResult(interp); + /* + * Ignore missing binding errors. This is a special hack + * that relies on the error message returned by FindSequence + * in tkBind.c. + */ + + if (string[0] != '\0') { + goto error; + } else { + Tcl_ResetResult(interp); + } + } else { + Tcl_SetResult(interp, command, TCL_STATIC); } - interp->result = command; } else { Tk_GetAllBindings(interp, canvasPtr->bindingTable, object); } } else if ((c == 'c') && (strcmp(argv[1], "canvasx") == 0)) { int x; double grid; + char buf[TCL_DOUBLE_SPACE]; if ((argc < 3) || (argc > 4)) { Tcl_AppendResult(interp, "wrong # args: should be \"", @@ -590,10 +608,12 @@ CanvasWidgetCmd(clientData, interp, argc, argv) grid = 0.0; } x += canvasPtr->xOrigin; - Tcl_PrintDouble(interp, GridAlign((double) x, grid), interp->result); + Tcl_PrintDouble(interp, GridAlign((double) x, grid), buf); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } else if ((c == 'c') && (strcmp(argv[1], "canvasy") == 0)) { int y; double grid; + char buf[TCL_DOUBLE_SPACE]; if ((argc < 3) || (argc > 4)) { Tcl_AppendResult(interp, "wrong # args: should be \"", @@ -613,7 +633,8 @@ CanvasWidgetCmd(clientData, interp, argc, argv) grid = 0.0; } y += canvasPtr->yOrigin; - Tcl_PrintDouble(interp, GridAlign((double) y, grid), interp->result); + Tcl_PrintDouble(interp, GridAlign((double) y, grid), buf); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } else if ((c == 'c') && (strncmp(argv[1], "cget", length) == 0) && (length >= 2)) { if (argc != 3) { @@ -664,6 +685,7 @@ CanvasWidgetCmd(clientData, interp, argc, argv) Tk_ItemType *typePtr; Tk_ItemType *matchPtr = NULL; Tk_Item *itemPtr; + char buf[TCL_INTEGER_SPACE]; if (argc < 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", @@ -713,7 +735,8 @@ CanvasWidgetCmd(clientData, interp, argc, argv) Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, itemPtr->x1, itemPtr->y1, itemPtr->x2, itemPtr->y2); canvasPtr->flags |= REPICK_NEEDED; - sprintf(interp->result, "%d", itemPtr->id); + sprintf(buf, "%d", itemPtr->id); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } else if ((c == 'd') && (strncmp(argv[1], "dchars", length) == 0) && (length >= 2)) { int first, last; @@ -853,7 +876,10 @@ CanvasWidgetCmd(clientData, interp, argc, argv) itemPtr = canvasPtr->textInfo.focusItemPtr; if (argc == 2) { if (itemPtr != NULL) { - sprintf(interp->result, "%d", itemPtr->id); + char buf[TCL_INTEGER_SPACE]; + + sprintf(buf, "%d", itemPtr->id); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } goto done; } @@ -923,6 +949,7 @@ CanvasWidgetCmd(clientData, interp, argc, argv) } else if ((c == 'i') && (strncmp(argv[1], "index", length) == 0) && (length >= 3)) { int index; + char buf[TCL_INTEGER_SPACE]; if (argc != 4) { Tcl_AppendResult(interp, "wrong # args: should be \"", @@ -945,7 +972,8 @@ CanvasWidgetCmd(clientData, interp, argc, argv) itemPtr, argv[3], &index) != TCL_OK) { goto error; } - sprintf(interp->result, "%d", index); + sprintf(buf, "%d", index); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } else if ((c == 'i') && (strncmp(argv[1], "insert", length) == 0) && (length >= 3)) { int beforeThis; @@ -1129,7 +1157,7 @@ CanvasWidgetCmd(clientData, interp, argc, argv) goto error; } if ((xScale == 0.0) || (yScale == 0.0)) { - interp->result = "scale factor cannot be zero"; + Tcl_SetResult(interp, "scale factor cannot be zero", TCL_STATIC); goto error; } for (itemPtr = StartTagSearch(canvasPtr, argv[2], &search); @@ -1264,8 +1292,10 @@ CanvasWidgetCmd(clientData, interp, argc, argv) goto error; } if (canvasPtr->textInfo.selItemPtr != NULL) { - sprintf(interp->result, "%d", - canvasPtr->textInfo.selItemPtr->id); + char buf[TCL_INTEGER_SPACE]; + + sprintf(buf, "%d", canvasPtr->textInfo.selItemPtr->id); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } } else if ((c == 't') && (strncmp(argv[2], "to", length) == 0)) { if (argc != 5) { @@ -1289,7 +1319,7 @@ CanvasWidgetCmd(clientData, interp, argc, argv) } itemPtr = StartTagSearch(canvasPtr, argv[2], &search); if (itemPtr != NULL) { - interp->result = itemPtr->typePtr->name; + Tcl_SetResult(interp, itemPtr->typePtr->name, TCL_STATIC); } } else if ((c == 'x') && (strncmp(argv[1], "xview", length) == 0)) { int count, type; @@ -1301,7 +1331,7 @@ CanvasWidgetCmd(clientData, interp, argc, argv) PrintScrollFractions(canvasPtr->xOrigin + canvasPtr->inset, canvasPtr->xOrigin + Tk_Width(canvasPtr->tkwin) - canvasPtr->inset, canvasPtr->scrollX1, - canvasPtr->scrollX2, interp->result); + canvasPtr->scrollX2, Tcl_GetStringResult(interp)); } else { type = Tk_GetScrollInfo(interp, argc, argv, &fraction, &count); switch (type) { @@ -1339,7 +1369,7 @@ CanvasWidgetCmd(clientData, interp, argc, argv) PrintScrollFractions(canvasPtr->yOrigin + canvasPtr->inset, canvasPtr->yOrigin + Tk_Height(canvasPtr->tkwin) - canvasPtr->inset, canvasPtr->scrollY1, - canvasPtr->scrollY2, interp->result); + canvasPtr->scrollY2, Tcl_GetStringResult(interp)); } else { type = Tk_GetScrollInfo(interp, argc, argv, &fraction, &count); switch (type) { @@ -1456,7 +1486,7 @@ DestroyCanvas(memPtr) * * Results: * The return value is a standard Tcl result. If TCL_ERROR is - * returned, then interp->result contains an error message. + * returned, then the interp's result contains an error message. * * Side effects: * Configuration information, such as colors, border width, @@ -2344,7 +2374,7 @@ NextItem(searchPtr) * * Side effects: * If tag is NULL then itemPtr's id is added as a list element - * to interp->result; otherwise tag is added to itemPtr's + * to the interp's result; otherwise tag is added to itemPtr's * list of tags. * *-------------------------------------------------------------- @@ -2366,7 +2396,8 @@ DoItem(interp, itemPtr, tag) */ if (tag == NULL) { - char msg[30]; + char msg[TCL_INTEGER_SPACE]; + sprintf(msg, "%d", itemPtr->id); Tcl_AppendElement(interp, msg); return; @@ -2420,9 +2451,9 @@ DoItem(interp, itemPtr, tag) * Results: * A standard Tcl return value. If newTag is NULL, then a * list of ids from all the items that match argc/argv is - * returned in interp->result. If newTag is NULL, then - * the normal interp->result is an empty string. If an error - * occurs, then interp->result will hold an error message. + * returned in the interp's result. If newTag is NULL, then + * the normal the interp's result is an empty string. If an error + * occurs, then the interp's result will hold an error message. * * Side effects: * If newTag is non-NULL, then all the items that match the @@ -2445,7 +2476,7 @@ FindItems(interp, canvasPtr, argc, argv, newTag, cmdName, option) char *newTag; /* If non-NULL, gives new tag to set * on all found items; if NULL, then * ids of found items are returned - * in interp->result. */ + * in the interp's result. */ char *cmdName; /* Name of original Tcl command, for * use in error messages. */ char *option; /* For error messages: gives option @@ -2651,9 +2682,9 @@ FindItems(interp, canvasPtr, argc, argv, newTag, cmdName, option) * Results: * A standard Tcl return value. If newTag is NULL, then a * list of ids from all the items overlapping or enclosed - * by the rectangle given by argc is returned in interp->result. - * If newTag is NULL, then the normal interp->result is an - * empty string. If an error occurs, then interp->result will + * by the rectangle given by argc is returned in the interp's result. + * If newTag is NULL, then the normal the interp's result is an + * empty string. If an error occurs, then the interp's result will * hold an error message. * * Side effects: @@ -2676,7 +2707,7 @@ FindArea(interp, canvasPtr, argv, uid, enclosed) Tk_Uid uid; /* If non-NULL, gives new tag to set * on all found items; if NULL, then * ids of found items are returned - * in interp->result. */ + * in the interp's result. */ int enclosed; /* 0 means overlapping or enclosed * items are OK, 1 means only enclosed * items are OK. */ diff --git a/generic/tkClipboard.c b/generic/tkClipboard.c index e1c9510..5e2074d 100644 --- a/generic/tkClipboard.c +++ b/generic/tkClipboard.c @@ -6,12 +6,12 @@ * supplied on demand to requesting applications. * * Copyright (c) 1994 The Regents of the University of California. - * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkClipboard.c 1.15 96/05/03 10:51:08 + * SCCS: @(#) tkClipboard.c 1.16 97/11/07 21:16:25 */ #include "tkInt.h" @@ -226,7 +226,7 @@ ClipboardLostSel(clientData) * * Results: * A standard Tcl result. If an error occurs, an error message is - * left in interp->result. + * left in the interp's result. * * Side effects: * From now on, requests for the CLIPBOARD selection will be @@ -311,7 +311,7 @@ Tk_ClipboardClear(interp, tkwin) * * Results: * A standard Tcl result. If an error is returned, an error message - * is left in interp->result. + * is left in the interp's result. * * Side effects: * The specified buffer will be copied onto the end of the clipboard. @@ -528,9 +528,10 @@ Tk_ClipboardCmd(clientData, interp, argc, argv) } return Tk_ClipboardClear(interp, tkwin); } else { - sprintf(interp->result, - "bad option \"%.50s\": must be clear or append", - argv[1]); + char buf[100 + TCL_INTEGER_SPACE]; + + sprintf(buf, "bad option \"%.50s\": must be clear or append", argv[1]); + Tcl_SetResult(interp, buf, TCL_VOLATILE); return TCL_ERROR; } } @@ -546,8 +547,8 @@ Tk_ClipboardCmd(clientData, interp, argc, argv) * * Results: * The result is a standard Tcl return value, which is normally TCL_OK. - * If an error occurs then an error message is left in interp->result - * and TCL_ERROR is returned. + * If an error occurs then an error message is left in the interp's + * result and TCL_ERROR is returned. * * Side effects: * Sets up the clipWindow and related data structures. diff --git a/generic/tkCmds.c b/generic/tkCmds.c index 34e2867..ab75057 100644 --- a/generic/tkCmds.c +++ b/generic/tkCmds.c @@ -5,12 +5,12 @@ * that didn't fit in any particular file of the toolkit. * * Copyright (c) 1990-1994 The Regents of the University of California. - * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkCmds.c 1.125 97/05/20 16:16:33 + * SCCS: @(#) tkCmds.c 1.130 97/11/07 21:16:34 */ #include "tkPort.h" @@ -33,7 +33,7 @@ static void WaitWindowProc _ANSI_ARGS_((ClientData clientData, /* *---------------------------------------------------------------------- * - * Tk_BellCmd -- + * Tk_BellObjCmd -- * * This procedure is invoked to process the "bell" Tcl command. * See the user documentation for details on what it does. @@ -48,29 +48,30 @@ static void WaitWindowProc _ANSI_ARGS_((ClientData clientData, */ int -Tk_BellCmd(clientData, interp, argc, argv) +Tk_BellObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Main window associated with interpreter. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { + static char *bellOptions[] = {"-displayof", (char *) NULL}; Tk_Window tkwin = (Tk_Window) clientData; - size_t length; + char *displayName; + int index; - if ((argc != 1) && (argc != 3)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ?-displayof window?\"", (char *) NULL); + if ((objc != 1) && (objc != 3)) { + Tcl_WrongNumArgs(interp, 1, objv, "?-displayof window?"); return TCL_ERROR; } - if (argc == 3) { - length = strlen(argv[1]); - if ((length < 2) || (strncmp(argv[1], "-displayof", length) != 0)) { - Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be -displayof", (char *) NULL); + if (objc == 3) { + if (Tcl_GetIndexFromObj(interp, objv[1], bellOptions, "option", 0, + &index) != TCL_OK) { return TCL_ERROR; } - tkwin = Tk_NameToWindow(interp, argv[2], tkwin); + displayName = Tcl_GetStringFromObj(objv[2], (int *) NULL); + + tkwin = Tk_NameToWindow(interp, displayName, tkwin); if (tkwin == NULL) { return TCL_ERROR; } @@ -151,7 +152,7 @@ Tk_BindCmd(clientData, interp, argc, argv) Tcl_ResetResult(interp); return TCL_OK; } - interp->result = command; + Tcl_SetResult(interp, command, TCL_STATIC); } else { Tk_GetAllBindings(interp, winPtr->mainPtr->bindingTable, object); } @@ -595,7 +596,7 @@ Tk_TkObjCmd(clientData, interp, objc, objv) string = Tcl_GetStringFromObj(objv[2], NULL); winPtr->nameUid = Tk_GetUid(Tk_SetAppName(tkwin, string)); } - Tcl_SetStringObj(Tcl_GetObjResult(interp), winPtr->nameUid, -1); + Tcl_AppendResult(interp, winPtr->nameUid, NULL); break; } case TK_SCALING: { @@ -797,7 +798,7 @@ WaitWindowProc(clientData, eventPtr) /* *---------------------------------------------------------------------- * - * Tk_UpdateCmd -- + * Tk_UpdateObjCmd -- * * This procedure is invoked to process the "update" Tcl command. * See the user documentation for details on what it does. @@ -813,28 +814,27 @@ WaitWindowProc(clientData, eventPtr) /* ARGSUSED */ int -Tk_UpdateCmd(clientData, interp, argc, argv) +Tk_UpdateObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Main window associated with * interpreter. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - int flags; + static char *updateOptions[] = {"idletasks", (char *) NULL}; + int flags, index; TkDisplay *dispPtr; - if (argc == 1) { + if (objc == 1) { flags = TCL_DONT_WAIT; - } else if (argc == 2) { - if (strncmp(argv[1], "idletasks", strlen(argv[1])) != 0) { - Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be idletasks", (char *) NULL); + } else if (objc == 2) { + if (Tcl_GetIndexFromObj(interp, objv[1], updateOptions, "option", 0, + &index) != TCL_OK) { return TCL_ERROR; } flags = TCL_IDLE_EVENTS; } else { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " ?idletasks?\"", (char *) NULL); + Tcl_WrongNumArgs(interp, 1, objv, "?idletasks?"); return TCL_ERROR; } @@ -846,7 +846,7 @@ Tk_UpdateCmd(clientData, interp, argc, argv) * Thus, don't use any information from tkwin after calling * Tcl_DoOneEvent. */ - + while (1) { while (Tcl_DoOneEvent(flags) != 0) { /* Empty loop body */ @@ -895,10 +895,10 @@ Tk_WinfoObjCmd(clientData, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { int index, x, y, width, height, useX, useY, class, skip; - char buf[128]; char *string; TkWindow *winPtr; Tk_Window tkwin; + Tcl_Obj *resultPtr; static TkStateMap visualMap[] = { {PseudoColor, "pseudocolor"}, @@ -971,85 +971,73 @@ Tk_WinfoObjCmd(clientData, interp, objc, objv) } } winPtr = (TkWindow *) tkwin; + resultPtr = Tcl_GetObjResult(interp); switch ((enum options) index) { case WIN_CELLS: { - Tcl_ResetResult(interp); - Tcl_SetIntObj(Tcl_GetObjResult(interp), - Tk_Visual(tkwin)->map_entries); + Tcl_SetIntObj(resultPtr, Tk_Visual(tkwin)->map_entries); break; } case WIN_CHILDREN: { Tcl_Obj *strPtr; - Tcl_ResetResult(interp); winPtr = winPtr->childList; for ( ; winPtr != NULL; winPtr = winPtr->nextPtr) { strPtr = Tcl_NewStringObj(winPtr->pathName, -1); - Tcl_ListObjAppendElement(NULL, - Tcl_GetObjResult(interp), strPtr); + Tcl_ListObjAppendElement(NULL, resultPtr, strPtr); } break; } case WIN_CLASS: { - Tcl_ResetResult(interp); - Tcl_SetStringObj(Tcl_GetObjResult(interp), Tk_Class(tkwin), -1); + Tcl_SetStringObj(resultPtr, Tk_Class(tkwin), -1); break; } case WIN_COLORMAPFULL: { - Tcl_ResetResult(interp); - Tcl_SetBooleanObj(Tcl_GetObjResult(interp), + Tcl_SetBooleanObj(resultPtr, TkpCmapStressed(tkwin, Tk_Colormap(tkwin))); break; } case WIN_DEPTH: { - Tcl_ResetResult(interp); - Tcl_SetIntObj(Tcl_GetObjResult(interp), Tk_Depth(tkwin)); + Tcl_SetIntObj(resultPtr, Tk_Depth(tkwin)); break; } case WIN_GEOMETRY: { - Tcl_ResetResult(interp); + char buf[16 + TCL_INTEGER_SPACE * 4]; + sprintf(buf, "%dx%d+%d+%d", Tk_Width(tkwin), Tk_Height(tkwin), Tk_X(tkwin), Tk_Y(tkwin)); - Tcl_SetStringObj(Tcl_GetObjResult(interp), buf, -1); + Tcl_SetStringObj(resultPtr, buf, -1); break; } case WIN_HEIGHT: { - Tcl_ResetResult(interp); - Tcl_SetIntObj(Tcl_GetObjResult(interp), Tk_Height(tkwin)); + Tcl_SetIntObj(resultPtr, Tk_Height(tkwin)); break; } case WIN_ID: { + char buf[TCL_INTEGER_SPACE]; + Tk_MakeWindowExist(tkwin); TkpPrintWindowId(buf, Tk_WindowId(tkwin)); - Tcl_ResetResult(interp); - Tcl_SetStringObj(Tcl_GetObjResult(interp), buf, -1); + Tcl_SetStringObj(resultPtr, buf, -1); break; } case WIN_ISMAPPED: { - Tcl_ResetResult(interp); - Tcl_SetBooleanObj(Tcl_GetObjResult(interp), - (int) Tk_IsMapped(tkwin)); + Tcl_SetBooleanObj(resultPtr, (int) Tk_IsMapped(tkwin)); break; } case WIN_MANAGER: { - Tcl_ResetResult(interp); if (winPtr->geomMgrPtr != NULL) { - Tcl_SetStringObj(Tcl_GetObjResult(interp), - winPtr->geomMgrPtr->name, -1); + Tcl_SetStringObj(resultPtr, winPtr->geomMgrPtr->name, -1); } break; } case WIN_NAME: { - Tcl_ResetResult(interp); - Tcl_SetStringObj(Tcl_GetObjResult(interp), Tk_Name(tkwin), -1); + Tcl_SetStringObj(resultPtr, Tk_Name(tkwin), -1); break; } case WIN_PARENT: { - Tcl_ResetResult(interp); if (winPtr->parentPtr != NULL) { - Tcl_SetStringObj(Tcl_GetObjResult(interp), - winPtr->parentPtr->pathName, -1); + Tcl_SetStringObj(resultPtr, winPtr->parentPtr->pathName, -1); } break; } @@ -1075,80 +1063,66 @@ Tk_WinfoObjCmd(clientData, interp, objc, objv) } else { TkGetPointerCoords((Tk_Window) winPtr, &x, &y); } - Tcl_ResetResult(interp); if (useX & useY) { + char buf[TCL_INTEGER_SPACE * 2]; + sprintf(buf, "%d %d", x, y); - Tcl_SetStringObj(Tcl_GetObjResult(interp), buf, -1); + Tcl_SetStringObj(resultPtr, buf, -1); } else if (useX) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), x); + Tcl_SetIntObj(resultPtr, x); } else { - Tcl_SetIntObj(Tcl_GetObjResult(interp), y); + Tcl_SetIntObj(resultPtr, y); } break; } case WIN_REQHEIGHT: { - Tcl_ResetResult(interp); - Tcl_SetIntObj(Tcl_GetObjResult(interp), Tk_ReqHeight(tkwin)); + Tcl_SetIntObj(resultPtr, Tk_ReqHeight(tkwin)); break; } case WIN_REQWIDTH: { - Tcl_ResetResult(interp); - Tcl_SetIntObj(Tcl_GetObjResult(interp), Tk_ReqWidth(tkwin)); + Tcl_SetIntObj(resultPtr, Tk_ReqWidth(tkwin)); break; } case WIN_ROOTX: { Tk_GetRootCoords(tkwin, &x, &y); - Tcl_ResetResult(interp); - Tcl_SetIntObj(Tcl_GetObjResult(interp), x); + Tcl_SetIntObj(resultPtr, x); break; } case WIN_ROOTY: { Tk_GetRootCoords(tkwin, &x, &y); - Tcl_ResetResult(interp); - Tcl_SetIntObj(Tcl_GetObjResult(interp), y); + Tcl_SetIntObj(resultPtr, y); break; } case WIN_SCREEN: { + char buf[TCL_INTEGER_SPACE]; + sprintf(buf, "%d", Tk_ScreenNumber(tkwin)); - Tcl_ResetResult(interp); - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - Tk_DisplayName(tkwin), ".", buf, NULL); + Tcl_AppendStringsToObj(resultPtr, Tk_DisplayName(tkwin), ".", + buf, NULL); break; } case WIN_SCREENCELLS: { - Tcl_ResetResult(interp); - Tcl_SetIntObj(Tcl_GetObjResult(interp), - CellsOfScreen(Tk_Screen(tkwin))); + Tcl_SetIntObj(resultPtr, CellsOfScreen(Tk_Screen(tkwin))); break; } case WIN_SCREENDEPTH: { - Tcl_ResetResult(interp); - Tcl_SetIntObj(Tcl_GetObjResult(interp), - DefaultDepthOfScreen(Tk_Screen(tkwin))); + Tcl_SetIntObj(resultPtr, DefaultDepthOfScreen(Tk_Screen(tkwin))); break; } case WIN_SCREENHEIGHT: { - Tcl_ResetResult(interp); - Tcl_SetIntObj(Tcl_GetObjResult(interp), - HeightOfScreen(Tk_Screen(tkwin))); + Tcl_SetIntObj(resultPtr, HeightOfScreen(Tk_Screen(tkwin))); break; } case WIN_SCREENWIDTH: { - Tcl_ResetResult(interp); - Tcl_SetIntObj(Tcl_GetObjResult(interp), - WidthOfScreen(Tk_Screen(tkwin))); + Tcl_SetIntObj(resultPtr, WidthOfScreen(Tk_Screen(tkwin))); break; } case WIN_SCREENMMHEIGHT: { - Tcl_ResetResult(interp); - Tcl_SetIntObj(Tcl_GetObjResult(interp), - HeightMMOfScreen(Tk_Screen(tkwin))); + Tcl_SetIntObj(resultPtr, HeightMMOfScreen(Tk_Screen(tkwin))); break; } case WIN_SCREENMMWIDTH: { - Tcl_ResetResult(interp); - Tcl_SetIntObj(Tcl_GetObjResult(interp), - WidthMMOfScreen(Tk_Screen(tkwin))); + Tcl_SetIntObj(resultPtr, WidthMMOfScreen(Tk_Screen(tkwin))); break; } case WIN_SCREENVISUAL: { @@ -1162,9 +1136,7 @@ Tk_WinfoObjCmd(clientData, interp, objc, objv) case WIN_TOPLEVEL: { winPtr = GetToplevel(tkwin); if (winPtr != NULL) { - Tcl_ResetResult(interp); - Tcl_SetStringObj(Tcl_GetObjResult(interp), - winPtr->pathName, -1); + Tcl_SetStringObj(resultPtr, winPtr->pathName, -1); } break; } @@ -1181,8 +1153,7 @@ Tk_WinfoObjCmd(clientData, interp, objc, objv) break; } } - Tcl_ResetResult(interp); - Tcl_SetBooleanObj(Tcl_GetObjResult(interp), viewable); + Tcl_SetBooleanObj(resultPtr, viewable); break; } case WIN_VISUAL: { @@ -1193,54 +1164,47 @@ Tk_WinfoObjCmd(clientData, interp, objc, objv) if (string == NULL) { string = "unknown"; } - Tcl_ResetResult(interp); - Tcl_SetStringObj(Tcl_GetObjResult(interp), string, -1); + Tcl_SetStringObj(resultPtr, string, -1); break; } case WIN_VISUALID: { - Tcl_ResetResult(interp); + char buf[TCL_INTEGER_SPACE]; + sprintf(buf, "0x%x", (unsigned int) XVisualIDFromVisual(Tk_Visual(tkwin))); - Tcl_SetStringObj(Tcl_GetObjResult(interp), buf, -1); + Tcl_SetStringObj(resultPtr, buf, -1); break; } case WIN_VROOTHEIGHT: { Tk_GetVRootGeometry(tkwin, &x, &y, &width, &height); - Tcl_ResetResult(interp); - Tcl_SetIntObj(Tcl_GetObjResult(interp), height); + Tcl_SetIntObj(resultPtr, height); break; } case WIN_VROOTWIDTH: { Tk_GetVRootGeometry(tkwin, &x, &y, &width, &height); - Tcl_ResetResult(interp); - Tcl_SetIntObj(Tcl_GetObjResult(interp), width); + Tcl_SetIntObj(resultPtr, width); break; } case WIN_VROOTX: { Tk_GetVRootGeometry(tkwin, &x, &y, &width, &height); - Tcl_ResetResult(interp); - Tcl_SetIntObj(Tcl_GetObjResult(interp), x); + Tcl_SetIntObj(resultPtr, x); break; } case WIN_VROOTY: { Tk_GetVRootGeometry(tkwin, &x, &y, &width, &height); - Tcl_ResetResult(interp); - Tcl_SetIntObj(Tcl_GetObjResult(interp), y); + Tcl_SetIntObj(resultPtr, y); break; } case WIN_WIDTH: { - Tcl_ResetResult(interp); - Tcl_SetIntObj(Tcl_GetObjResult(interp), Tk_Width(tkwin)); + Tcl_SetIntObj(resultPtr, Tk_Width(tkwin)); break; } case WIN_X: { - Tcl_ResetResult(interp); - Tcl_SetIntObj(Tcl_GetObjResult(interp), Tk_X(tkwin)); + Tcl_SetIntObj(resultPtr, Tk_X(tkwin)); break; } case WIN_Y: { - Tcl_ResetResult(interp); - Tcl_SetIntObj(Tcl_GetObjResult(interp), Tk_Y(tkwin)); + Tcl_SetIntObj(resultPtr, Tk_Y(tkwin)); break; } @@ -1259,9 +1223,7 @@ Tk_WinfoObjCmd(clientData, interp, objc, objv) } objv += skip; string = Tcl_GetStringFromObj(objv[2], NULL); - Tcl_ResetResult(interp); - Tcl_SetLongObj(Tcl_GetObjResult(interp), - (long) Tk_InternAtom(tkwin, string)); + Tcl_SetLongObj(resultPtr, (long) Tk_InternAtom(tkwin, string)); break; } case WIN_ATOMNAME: { @@ -1280,15 +1242,14 @@ Tk_WinfoObjCmd(clientData, interp, objc, objv) if (Tcl_GetLongFromObj(interp, objv[2], &id) != TCL_OK) { return TCL_ERROR; } - Tcl_ResetResult(interp); name = Tk_GetAtomName(tkwin, (Atom) id); if (strcmp(name, "?bad atom?") == 0) { string = Tcl_GetStringFromObj(objv[2], NULL); - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + Tcl_AppendStringsToObj(resultPtr, "no atom exists with id \"", string, "\"", NULL); return TCL_ERROR; } - Tcl_SetStringObj(Tcl_GetObjResult(interp), name, -1); + Tcl_SetStringObj(resultPtr, name, -1); break; } case WIN_CONTAINING: { @@ -1312,9 +1273,7 @@ Tk_WinfoObjCmd(clientData, interp, objc, objv) } tkwin = Tk_CoordsToWindow(x, y, tkwin); if (tkwin != NULL) { - Tcl_ResetResult(interp); - Tcl_SetStringObj(Tcl_GetObjResult(interp), - Tk_PathName(tkwin), -1); + Tcl_SetStringObj(resultPtr, Tk_PathName(tkwin), -1); } break; } @@ -1351,9 +1310,7 @@ Tk_WinfoObjCmd(clientData, interp, objc, objv) Tk_IdToWindow(Tk_Display(tkwin), (Window) id); if ((winPtr == NULL) || (winPtr->mainPtr != ((TkWindow *) tkwin)->mainPtr)) { - Tcl_ResetResult(interp); - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "window id \"", string, + Tcl_AppendStringsToObj(resultPtr, "window id \"", string, "\" doesn't exist in this application", (char *) NULL); return TCL_ERROR; } @@ -1366,9 +1323,7 @@ Tk_WinfoObjCmd(clientData, interp, objc, objv) tkwin = (Tk_Window) winPtr; if (Tk_PathName(tkwin) != NULL) { - Tcl_ResetResult(interp); - Tcl_SetStringObj(Tcl_GetObjResult(interp), - Tk_PathName(tkwin), -1); + Tcl_SetStringObj(resultPtr, Tk_PathName(tkwin), -1); } break; } @@ -1386,12 +1341,14 @@ Tk_WinfoObjCmd(clientData, interp, objc, objv) } string = Tcl_GetStringFromObj(objv[2], NULL); winPtr = (TkWindow *) Tk_NameToWindow(interp, string, tkwin); + Tcl_ResetResult(interp); + resultPtr = Tcl_GetObjResult(interp); + alive = 1; if ((winPtr == NULL) || (winPtr->flags & TK_ALREADY_DEAD)) { alive = 0; } - Tcl_ResetResult(interp); /* clear any error msg */ - Tcl_SetBooleanObj(Tcl_GetObjResult(interp), alive); + Tcl_SetBooleanObj(resultPtr, alive); break; } case WIN_FPIXELS: { @@ -1411,9 +1368,8 @@ Tk_WinfoObjCmd(clientData, interp, objc, objv) return TCL_ERROR; } pixels = mm * WidthOfScreen(Tk_Screen(tkwin)) - / WidthMMOfScreen(Tk_Screen(tkwin)); - Tcl_ResetResult(interp); - Tcl_SetDoubleObj(Tcl_GetObjResult(interp), pixels); + / WidthMMOfScreen(Tk_Screen(tkwin)); + Tcl_SetDoubleObj(resultPtr, pixels); break; } case WIN_PIXELS: { @@ -1432,12 +1388,12 @@ Tk_WinfoObjCmd(clientData, interp, objc, objv) if (Tk_GetPixels(interp, tkwin, string, &pixels) != TCL_OK) { return TCL_ERROR; } - Tcl_ResetResult(interp); - Tcl_SetIntObj(Tcl_GetObjResult(interp), pixels); + Tcl_SetIntObj(resultPtr, pixels); break; } case WIN_RGB: { XColor *colorPtr; + char buf[TCL_INTEGER_SPACE * 3]; if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "window colorName"); @@ -1456,16 +1412,16 @@ Tk_WinfoObjCmd(clientData, interp, objc, objv) sprintf(buf, "%d %d %d", colorPtr->red, colorPtr->green, colorPtr->blue); Tk_FreeColor(colorPtr); - Tcl_ResetResult(interp); - Tcl_SetStringObj(Tcl_GetObjResult(interp), buf, -1); + Tcl_SetStringObj(resultPtr, buf, -1); break; } case WIN_VISUALSAVAILABLE: { XVisualInfo template, *visInfoPtr; int count, i; - char visualIdString[16]; int includeVisualId; Tcl_Obj *strPtr; + char buf[16 + TCL_INTEGER_SPACE]; + char visualIdString[TCL_INTEGER_SPACE]; if (objc == 3) { includeVisualId = 0; @@ -1487,9 +1443,8 @@ Tk_WinfoObjCmd(clientData, interp, objc, objv) template.screen = Tk_ScreenNumber(tkwin); visInfoPtr = XGetVisualInfo(Tk_Display(tkwin), VisualScreenMask, &template, &count); - Tcl_ResetResult(interp); if (visInfoPtr == NULL) { - Tcl_SetStringObj(Tcl_GetObjResult(interp), + Tcl_SetStringObj(resultPtr, "can't find any visuals for screen", -1); return TCL_ERROR; } @@ -1506,8 +1461,7 @@ Tk_WinfoObjCmd(clientData, interp, objc, objv) strcat(buf, visualIdString); } strPtr = Tcl_NewStringObj(buf, -1); - Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), - strPtr); + Tcl_ListObjAppendElement(NULL, resultPtr, strPtr); } XFree((char *) visInfoPtr); break; diff --git a/generic/tkColor.c b/generic/tkColor.c index 781971c..abaaf02 100644 --- a/generic/tkColor.c +++ b/generic/tkColor.c @@ -6,48 +6,33 @@ * map color names to pixel values. * * Copyright (c) 1990-1994 The Regents of the University of California. - * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkColor.c 1.44 96/11/04 13:55:25 + * SCCS: @(#) tkColor.c 1.55 97/12/24 15:52:02 */ -#include <tkColor.h> +#include "tkColor.h" /* - * A two-level data structure is used to manage the color database. - * The top level consists of one entry for each color name that is - * currently active, and the bottom level contains one entry for each - * pixel value that is still in use. The distinction between - * levels is necessary because the same pixel may have several - * different names. There are two hash tables, one used to index into - * each of the data structures. The name hash table is used when - * allocating colors, and the pixel hash table is used when freeing - * colors. - */ - - -/* - * Hash table for name -> TkColor mapping, and key structure used to - * index into that table: + * There are two global hash tables used for managing colors. The + * first one, nameTable, maps from string color names like "red" or + * "#00ff80" to TkColor structures. It is used by Tk_AllocColorFromObj + * Tk_GetColor. The second table, valueTable, maps from integer + * RGB values to TkColor structures. It is used by Tk_GetColorByValue */ static Tcl_HashTable nameTable; -typedef struct { - Tk_Uid name; /* Name of desired color. */ - Colormap colormap; /* Colormap from which color will be - * allocated. */ - Display *display; /* Display for colormap. */ -} NameKey; +static Tcl_HashTable valueTable; +static int initialized = 0; /* 0 means static structures haven't been + * initialized yet. */ /* - * Hash table for value -> TkColor mapping, and key structure used to - * index into that table: + * Structures of the following following type are used as keys for valueTable. */ -static Tcl_HashTable valueTable; typedef struct { int red, green, blue; /* Values for desired color. */ Colormap colormap; /* Colormap from which color will be @@ -55,14 +40,125 @@ typedef struct { Display *display; /* Display for colormap. */ } ValueKey; -static int initialized = 0; /* 0 means static structures haven't been - * initialized yet. */ - /* * Forward declarations for procedures defined in this file: */ static void ColorInit _ANSI_ARGS_((void)); +static void DupColorObjProc _ANSI_ARGS_((Tcl_Obj *srcObjPtr, + Tcl_Obj *dupObjPtr)); +static void FreeColorObjProc _ANSI_ARGS_((Tcl_Obj *objPtr)); +static void InitColorObj _ANSI_ARGS_((Tcl_Obj *objPtr)); + +/* + * The following structure defines the implementation of the "color" Tcl + * object, which maps a string color name to a TkColor object. The + * ptr1 field of the Tcl_Obj points to a TkColor object. + */ + +static Tcl_ObjType colorObjType = { + "color", /* name */ + FreeColorObjProc, /* freeIntRepProc */ + DupColorObjProc, /* dupIntRepProc */ + NULL, /* updateStringProc */ + NULL /* setFromAnyProc */ +}; + +/* + *---------------------------------------------------------------------- + * + * Tk_AllocColorFromObj -- + * + * Given a Tcl_Obj *, map the value to a corresponding + * XColor structure based on the tkwin given. + * + * Results: + * The return value is a pointer to an XColor structure that + * indicates the red, blue, and green intensities for the color + * given by the string in objPtr, and also specifies a pixel value + * to use to draw in that color. If an error occurs, NULL is + * returned and an error message will be left in interp's result + * (unless interp is NULL). + * + * Side effects: + * The color is added to an internal database with a reference count. + * For each call to this procedure, there should eventually be a call + * to Tk_FreeColorFromObj so that the database is cleaned up when colors + * aren't in use anymore. + * + *---------------------------------------------------------------------- + */ + +XColor * +Tk_AllocColorFromObj(interp, tkwin, objPtr) + Tcl_Interp *interp; /* Used only for error reporting. If NULL, + * then no messages are provided. */ + Tk_Window tkwin; /* Window in which the color will be used.*/ + Tcl_Obj *objPtr; /* Object that describes the color; string + * value is a color name such as "red" or + * "#ff0000".*/ +{ + TkColor *tkColPtr; + + if (objPtr->typePtr != &colorObjType) { + InitColorObj(objPtr); + } + tkColPtr = (TkColor *) objPtr->internalRep.twoPtrValue.ptr1; + + /* + * If the object currently points to a TkColor, see if it's the + * one we want. If so, increment its reference count and return. + */ + + if (tkColPtr != NULL) { + if (tkColPtr->resourceRefCount == 0) { + /* + * This is a stale reference: it refers to a TkColor that's + * no longer in use. Clear the reference. + */ + + FreeColorObjProc(objPtr); + tkColPtr = NULL; + } else if ((Tk_Screen(tkwin) == tkColPtr->screen) + && (Tk_Colormap(tkwin) == tkColPtr->colormap)) { + tkColPtr->resourceRefCount++; + return (XColor *) tkColPtr; + } + } + + /* + * The object didn't point to the TkColor that we wanted. Search + * the list of TkColors with the same name to see if one of the + * other TkColors is the right one. + */ + + if (tkColPtr != NULL) { + TkColor *firstColorPtr = + (TkColor *) Tcl_GetHashValue(tkColPtr->hashPtr); + FreeColorObjProc(objPtr); + for (tkColPtr = firstColorPtr; tkColPtr != NULL; + tkColPtr = tkColPtr->nextPtr) { + if ((Tk_Screen(tkwin) == tkColPtr->screen) + && (Tk_Colormap(tkwin) == tkColPtr->colormap)) { + tkColPtr->resourceRefCount++; + tkColPtr->objRefCount++; + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) tkColPtr; + return (XColor *) tkColPtr; + } + } + } + + /* + * Still no luck. Call Tk_GetColor to allocate a new TkColor object. + */ + + tkColPtr = (TkColor *) Tk_GetColor(interp, tkwin, Tcl_GetString(objPtr)); + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) tkColPtr; + if (tkColPtr != NULL) { + tkColPtr->objRefCount++; + } + return (XColor *) tkColPtr; +} /* *---------------------------------------------------------------------- @@ -77,7 +173,7 @@ static void ColorInit _ANSI_ARGS_((void)); * indicates the red, blue, and green intensities for the color * given by "name", and also specifies a pixel value to use to * draw in that color. If an error occurs, NULL is returned and - * an error message will be left in interp->result. + * an error message will be left in the interp's result. * * Side effects: * The color is added to an internal database with a reference count. @@ -93,14 +189,13 @@ Tk_GetColor(interp, tkwin, name) Tcl_Interp *interp; /* Place to leave error message if * color can't be found. */ Tk_Window tkwin; /* Window in which color will be used. */ - Tk_Uid name; /* Name of color to allocated (in form + char *name; /* Name of color to be allocated (in form * suitable for passing to XParseColor). */ { - NameKey nameKey; Tcl_HashEntry *nameHashPtr; int new; TkColor *tkColPtr; - Display *display = Tk_Display(tkwin); + TkColor *existingColPtr; if (!initialized) { ColorInit(); @@ -111,14 +206,19 @@ Tk_GetColor(interp, tkwin, name) * name. */ - nameKey.name = name; - nameKey.colormap = Tk_Colormap(tkwin); - nameKey.display = display; - nameHashPtr = Tcl_CreateHashEntry(&nameTable, (char *) &nameKey, &new); + nameHashPtr = Tcl_CreateHashEntry(&nameTable, name, &new); if (!new) { - tkColPtr = (TkColor *) Tcl_GetHashValue(nameHashPtr); - tkColPtr->refCount++; - return &tkColPtr->color; + existingColPtr = (TkColor *) Tcl_GetHashValue(nameHashPtr); + for (tkColPtr = existingColPtr; tkColPtr != NULL; + tkColPtr = tkColPtr->nextPtr) { + if ((tkColPtr->screen == Tk_Screen(tkwin)) + && (Tk_Colormap(tkwin) == tkColPtr->colormap)) { + tkColPtr->resourceRefCount++; + return &tkColPtr->color; + } + } + } else { + existingColPtr = NULL; } /* @@ -137,7 +237,9 @@ Tk_GetColor(interp, tkwin, name) "\"", (char *) NULL); } } - Tcl_DeleteHashEntry(nameHashPtr); + if (new) { + Tcl_DeleteHashEntry(nameHashPtr); + } return (XColor *) NULL; } @@ -148,11 +250,13 @@ Tk_GetColor(interp, tkwin, name) tkColPtr->magic = COLOR_MAGIC; tkColPtr->gc = None; tkColPtr->screen = Tk_Screen(tkwin); - tkColPtr->colormap = nameKey.colormap; + tkColPtr->colormap = Tk_Colormap(tkwin); tkColPtr->visual = Tk_Visual(tkwin); - tkColPtr->refCount = 1; + tkColPtr->resourceRefCount = 1; + tkColPtr->objRefCount = 0; tkColPtr->tablePtr = &nameTable; tkColPtr->hashPtr = nameHashPtr; + tkColPtr->nextPtr = existingColPtr; Tcl_SetHashValue(nameHashPtr, tkColPtr); return &tkColPtr->color; @@ -211,7 +315,7 @@ Tk_GetColorByValue(tkwin, colorPtr) valueHashPtr = Tcl_CreateHashEntry(&valueTable, (char *) &valueKey, &new); if (!new) { tkColPtr = (TkColor *) Tcl_GetHashValue(valueHashPtr); - tkColPtr->refCount++; + tkColPtr->resourceRefCount++; return &tkColPtr->color; } @@ -226,9 +330,11 @@ Tk_GetColorByValue(tkwin, colorPtr) tkColPtr->screen = Tk_Screen(tkwin); tkColPtr->colormap = valueKey.colormap; tkColPtr->visual = Tk_Visual(tkwin); - tkColPtr->refCount = 1; + tkColPtr->resourceRefCount = 1; + tkColPtr->objRefCount = 0; tkColPtr->tablePtr = &valueTable; tkColPtr->hashPtr = valueHashPtr; + tkColPtr->nextPtr = NULL; Tcl_SetHashValue(valueHashPtr, tkColPtr); return &tkColPtr->color; } @@ -264,7 +370,7 @@ Tk_NameOfColor(colorPtr) if ((tkColPtr->magic == COLOR_MAGIC) && (tkColPtr->tablePtr == &nameTable)) { - return ((NameKey *) tkColPtr->hashPtr->key.words)->name; + return tkColPtr->hashPtr->key.string; } sprintf(string, "#%04x%04x%04x", colorPtr->red, colorPtr->green, colorPtr->blue); @@ -347,8 +453,9 @@ Tk_FreeColor(colorPtr) * allocated by Tk_GetColor or * Tk_GetColorByValue. */ { - register TkColor *tkColPtr = (TkColor *) colorPtr; + TkColor *tkColPtr = (TkColor *) colorPtr; Screen *screen = tkColPtr->screen; + TkColor *prevPtr; /* * Do a quick sanity check to make sure this color was really @@ -359,15 +466,45 @@ Tk_FreeColor(colorPtr) panic("Tk_FreeColor called with bogus color"); } - tkColPtr->refCount--; - if (tkColPtr->refCount == 0) { - if (tkColPtr->gc != None) { - XFreeGC(DisplayOfScreen(screen), tkColPtr->gc); - tkColPtr->gc = None; + tkColPtr->resourceRefCount--; + if (tkColPtr->resourceRefCount > 0) { + return; + } + + /* + * This color is no longer being actively used, so free the color + * resources associated with it and remove it from the hash table. + * no longer any objects referencing it. + */ + + if (tkColPtr->gc != None) { + XFreeGC(DisplayOfScreen(screen), tkColPtr->gc); + tkColPtr->gc = None; + } + TkpFreeColor(tkColPtr); + + prevPtr = (TkColor *) Tcl_GetHashValue(tkColPtr->hashPtr); + if (prevPtr == tkColPtr) { + if (tkColPtr->nextPtr == NULL) { + Tcl_DeleteHashEntry(tkColPtr->hashPtr); + } else { + Tcl_SetHashValue(tkColPtr->hashPtr, tkColPtr->nextPtr); + } + } else { + while (prevPtr->nextPtr != tkColPtr) { + prevPtr = prevPtr->nextPtr; } - TkpFreeColor(tkColPtr); - Tcl_DeleteHashEntry(tkColPtr->hashPtr); - tkColPtr->magic = 0; + prevPtr->nextPtr = tkColPtr->nextPtr; + } + + /* + * Free the TkColor structure if there are no objects referencing + * it. However, if there are objects referencing it then keep the + * structure around; it will get freed when the last reference is + * cleared + */ + + if (tkColPtr->objRefCount == 0) { ckfree((char *) tkColPtr); } } @@ -375,6 +512,221 @@ Tk_FreeColor(colorPtr) /* *---------------------------------------------------------------------- * + * Tk_FreeColorFromObj -- + * + * This procedure is called to release a color allocated by + * Tk_AllocColorFromObj. It does not throw away the Tcl_Obj *; + * it only gets rid of the hash table entry for this color + * and clears the cached value that is normally stored in the object. + * + * Results: + * None. + * + * Side effects: + * The reference count associated with the color represented by + * objPtr is decremented, and the color is released to X if there are + * no remaining uses for it. + * + *---------------------------------------------------------------------- + */ + +void +Tk_FreeColorFromObj(tkwin, objPtr) + Tk_Window tkwin; /* The window this color lives in. Needed + * for the screen and colormap values. */ + Tcl_Obj *objPtr; /* The Tcl_Obj * to be freed. */ +{ + Tk_FreeColor(Tk_GetColorFromObj(tkwin, objPtr)); +} + +/* + *--------------------------------------------------------------------------- + * + * FreeColorObjProc -- + * + * This proc is called to release an object reference to a color. + * Called when the object's internal rep is released or when + * the cached tkColPtr needs to be changed. + * + * Results: + * None. + * + * Side effects: + * The object reference count is decremented. When both it + * and the hash ref count go to zero, the color's resources + * are released. + * + *--------------------------------------------------------------------------- + */ + +static void +FreeColorObjProc(objPtr) + Tcl_Obj *objPtr; /* The object we are releasing. */ +{ + TkColor *tkColPtr = (TkColor *) objPtr->internalRep.twoPtrValue.ptr1; + + if (tkColPtr != NULL) { + tkColPtr->objRefCount--; + if ((tkColPtr->objRefCount == 0) + && (tkColPtr->resourceRefCount == 0)) { + ckfree((char *) tkColPtr); + } + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) NULL; + } +} + +/* + *--------------------------------------------------------------------------- + * + * DupColorObjProc -- + * + * When a cached color object is duplicated, this is called to + * update the internal reps. + * + * Results: + * None. + * + * Side effects: + * The color's objRefCount is incremented and the internal rep + * of the copy is set to point to it. + * + *--------------------------------------------------------------------------- + */ + +static void +DupColorObjProc(srcObjPtr, dupObjPtr) + Tcl_Obj *srcObjPtr; /* The object we are copying from. */ + Tcl_Obj *dupObjPtr; /* The object we are copying to. */ +{ + TkColor *tkColPtr = (TkColor *) srcObjPtr->internalRep.twoPtrValue.ptr1; + + dupObjPtr->typePtr = srcObjPtr->typePtr; + dupObjPtr->internalRep.twoPtrValue.ptr1 = (VOID *) tkColPtr; + + if (tkColPtr != NULL) { + tkColPtr->objRefCount++; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tk_GetColorFromObj -- + * + * Returns the color referred to by a Tcl object. The color must + * already have been allocated via a call to Tk_AllocColorFromObj + * or Tk_GetColor. + * + * Results: + * Returns the XColor * that matches the tkwin and the string rep + * of objPtr. + * + * Side effects: + * If the object is not already a color, the conversion will free + * any old internal representation. + * + *---------------------------------------------------------------------- + */ + +XColor * +Tk_GetColorFromObj(tkwin, objPtr) + Tk_Window tkwin; /* The window in which the color will be + * used. */ + Tcl_Obj *objPtr; /* String value contains the name of the + * desired color. */ +{ + TkColor *tkColPtr; + Tcl_HashEntry *hashPtr; + + if (objPtr->typePtr != &colorObjType) { + InitColorObj(objPtr); + } + + tkColPtr = (TkColor *) objPtr->internalRep.twoPtrValue.ptr1; + if (tkColPtr != NULL) { + if ((tkColPtr->resourceRefCount > 0) + && (Tk_Screen(tkwin) == tkColPtr->screen) + && (Tk_Colormap(tkwin) == tkColPtr->colormap)) { + /* + * The object already points to the right TkColor structure. + * Just return it. + */ + + return (XColor *) tkColPtr; + } + hashPtr = tkColPtr->hashPtr; + FreeColorObjProc(objPtr); + } else { + hashPtr = Tcl_FindHashEntry(&nameTable, Tcl_GetString(objPtr)); + if (hashPtr == NULL) { + goto error; + } + } + + /* + * At this point we've got a hash table entry, off of which hang + * one or more TkColor structures. See if any of them will work. + */ + + for (tkColPtr = (TkColor *) Tcl_GetHashValue(hashPtr); + (tkColPtr != NULL); tkColPtr = tkColPtr->nextPtr) { + if ((Tk_Screen(tkwin) == tkColPtr->screen) + && (Tk_Colormap(tkwin) == tkColPtr->colormap)) { + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) tkColPtr; + tkColPtr->objRefCount++; + return (XColor *) tkColPtr; + } + } + + error: + panic(" Tk_GetColorFromObj called with non-existent color!"); + /* + * The following code isn't reached; it's just there to please compilers. + */ + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * InitColorObj -- + * + * Bookeeping procedure to change an objPtr to a color type. + * + * Results: + * None. + * + * Side effects: + * The old internal rep of the object is freed. The object's + * type is set to color with a NULL TkColor pointer (the pointer + * will be set later by either Tk_AllocColorFromObj or + * Tk_GetColorFromObj). + * + *---------------------------------------------------------------------- + */ + +static void +InitColorObj(objPtr) + Tcl_Obj *objPtr; /* The object to convert. */ +{ + Tcl_ObjType *typePtr; + + /* + * Free the old internalRep before setting the new one. + */ + + Tcl_GetString(objPtr); + typePtr = objPtr->typePtr; + if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { + (*typePtr->freeIntRepProc)(objPtr); + } + objPtr->typePtr = &colorObjType; + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) NULL; +} + +/* + *---------------------------------------------------------------------- + * * ColorInit -- * * Initialize the structure used for color management. @@ -392,6 +744,54 @@ static void ColorInit() { initialized = 1; - Tcl_InitHashTable(&nameTable, sizeof(NameKey)/sizeof(int)); + Tcl_InitHashTable(&nameTable, TCL_STRING_KEYS); Tcl_InitHashTable(&valueTable, sizeof(ValueKey)/sizeof(int)); } + +/* + *---------------------------------------------------------------------- + * + * TkDebugColor -- + * + * This procedure returns debugging information about a color. + * + * Results: + * The return value is a list with one sublist for each TkColor + * corresponding to "name". Each sublist has two elements that + * contain the resourceRefCount and objRefCount fields from the + * TkColor structure. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TkDebugColor(tkwin, name) + Tk_Window tkwin; /* The window in which the color will be + * used (not currently used). */ + char *name; /* Name of the desired color. */ +{ + TkColor *tkColPtr; + Tcl_HashEntry *hashPtr; + Tcl_Obj *resultPtr, *objPtr; + + resultPtr = Tcl_NewObj(); + hashPtr = Tcl_FindHashEntry(&nameTable, name); + if (hashPtr != NULL) { + tkColPtr = (TkColor *) Tcl_GetHashValue(hashPtr); + if (tkColPtr == NULL) { + panic("TkDebugColor found empty hash table entry"); + } + for ( ; (tkColPtr != NULL); tkColPtr = tkColPtr->nextPtr) { + objPtr = Tcl_NewObj(); + Tcl_ListObjAppendElement(NULL, objPtr, + Tcl_NewIntObj(tkColPtr->resourceRefCount)); + Tcl_ListObjAppendElement(NULL, objPtr, + Tcl_NewIntObj(tkColPtr->objRefCount)); + Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); + } + } + return resultPtr; +} diff --git a/generic/tkColor.h b/generic/tkColor.h index 9653243..1ab252e 100644 --- a/generic/tkColor.h +++ b/generic/tkColor.h @@ -4,12 +4,12 @@ * Declarations of data types and functions used by the * Tk color module. * - * Copyright (c) 1996 by Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkColor.h 1.1 96/10/22 16:53:09 + * SCCS: @(#) tkColor.h 1.6 97/12/24 15:52:05 */ #ifndef _TKCOLOR @@ -19,8 +19,8 @@ /* * One of the following data structures is used to keep track of - * each color that the color module has allocated from the X display - * server. + * each color that is being used by the application; typically there + * is a colormap entry allocated for each of these colors. */ #define COLOR_MAGIC ((unsigned int) 0x46140277) @@ -38,11 +38,30 @@ typedef struct TkColor { Colormap colormap; /* Colormap from which this entry was * allocated. */ Visual *visual; /* Visual associated with colormap. */ - int refCount; /* Number of uses of this structure. */ + int resourceRefCount; /* Number of active uses of this color (each + * active use corresponds to a call to + * Tk_AllocColorFromObj or Tk_GetColor). + * If this count is 0, then this TkColor + * structure is no longer valid and it isn't + * present in a hash table: it is being + * kept around only because there are objects + * referring to it. The structure is freed + * when resourceRefCount and objRefCount + * are both 0. */ + int objRefCount; /* The number of Tcl objects that reference + * this structure. */ Tcl_HashTable *tablePtr; /* Hash table that indexes this structure * (needed when deleting structure). */ Tcl_HashEntry *hashPtr; /* Pointer to hash table entry for this * structure. (for use in deleting entry). */ + struct TkColor *nextPtr; /* Points to the next TkColor structure with + * the same color name. Colors with the + * same name but different screens or + * colormaps are chained together off a + * single entry in nameTable. For colors in + * valueTable (those allocated by + * Tk_GetColorByValue) this field is always + * NULL. */ } TkColor; /* diff --git a/generic/tkConfig.c b/generic/tkConfig.c index 2204714..52501d6 100644 --- a/generic/tkConfig.c +++ b/generic/tkConfig.c @@ -1,579 +1,1623 @@ /* * tkConfig.c -- * - * This file contains the Tk_ConfigureWidget procedure. + * This file contains procedures that manage configuration options + * for widgets and other things. * - * Copyright (c) 1990-1994 The Regents of the University of California. - * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * Copyright (c) 1997-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkConfig.c 1.53 96/04/26 10:29:31 + * SCCS: @(#) tkConfig.c 1.51 98/01/19 11:49:18 */ -#include "tkPort.h" +/* + * Temporary flag for working on new config package. + */ + +#define __NO_OLD_CONFIG + #include "tk.h" +#include "tkInt.h" +#include "tkPort.h" +#include "tkFont.h" + +/* + * The following definition is an AssocData key used to keep track of + * all of the option tables that have been created for an interpreter. + */ + +#define OPTION_HASH_KEY "TkOptionTable" /* - * Values for "flags" field of Tk_ConfigSpec structures. Be sure - * to coordinate these values with those defined in tk.h - * (TK_CONFIG_COLOR_ONLY, etc.). There must not be overlap! + * The following two structures are used along with Tk_OptionSpec + * structures to manage configuration options. Tk_OptionSpecs are + * static templates that are compiled into the code of a widget + * or other object manager. However, to look up options efficiently + * we need to supplement the static information with additional + * dynamic information, and this dynamic information may be different + * for each application. Thus we create structures of the following + * two types to hold all of the dynamic information; this is done + * by Tk_CreateOptionTable. + * + * One of the following structures corresponds to each Tk_OptionSpec. + * These structures exist as arrays inside TkOptionTable structures. + */ + +typedef struct TkOption { + CONST Tk_OptionSpec *specPtr; /* The original spec from the template + * passed to Tk_CreateOptionTable.*/ + Tk_Uid dbNameUID; /* The Uid form of the option database + * name. */ + Tk_Uid dbClassUID; /* The Uid form of the option database + * class name. */ + Tcl_Obj *defaultPtr; /* Default value for this option. */ + union { + Tcl_Obj *monoColorPtr; /* For color and border options, this + * is an alternate default value to + * use on monochrome displays. */ + struct TkOption *synonymPtr; /* For synonym options, this points to + * the master entry. */ + } extra; + int flags; /* Miscellaneous flag values; see + * below for definitions. */ +} Option; + +/* + * Flag bits defined for Option structures: * - * INIT - Non-zero means (char *) things have been - * converted to Tk_Uid's. + * OPTION_NEEDS_FREEING - 1 means that FreeResources must be + * invoke to free resources associated with + * the option when it is no longer needed. */ -#define INIT 0x20 +#define OPTION_NEEDS_FREEING 1 + +/* + * One of the following exists for each Tk_OptionSpec array that has + * been passed to Tk_CreateOptionTable. + */ + +typedef struct OptionTable { + int refCount; /* Counts the number of uses of this + * table (the number of times + * Tk_CreateOptionTable has returned + * it). This can be greater than 1 if + * it is shared along several option + * table chains, or if the same table + * is used for multiple purposes. */ + Tcl_HashEntry *hashEntryPtr; /* Hash table entry that refers to this + * table; used to delete the entry. */ + struct OptionTable *nextPtr; /* If templatePtr was part of a chain + * of templates, this points to the + * table corresponding to the next + * template in the chain. */ + int numOptions; /* The number of items in the options + * array below. */ + Option options[1]; /* Information about the individual + * options in the table. This must be + * the last field in the structure: + * the actual size of the array will + * be numOptions, not 1. */ +} OptionTable; /* * Forward declarations for procedures defined later in this file: */ -static int DoConfig _ANSI_ARGS_((Tcl_Interp *interp, - Tk_Window tkwin, Tk_ConfigSpec *specPtr, - Tk_Uid value, int valueIsUid, char *widgRec)); -static Tk_ConfigSpec * FindConfigSpec _ANSI_ARGS_((Tcl_Interp *interp, - Tk_ConfigSpec *specs, char *argvName, - int needFlags, int hateFlags)); -static char * FormatConfigInfo _ANSI_ARGS_((Tcl_Interp *interp, - Tk_Window tkwin, Tk_ConfigSpec *specPtr, - char *widgRec)); -static char * FormatConfigValue _ANSI_ARGS_((Tcl_Interp *interp, - Tk_Window tkwin, Tk_ConfigSpec *specPtr, - char *widgRec, char *buffer, - Tcl_FreeProc **freeProcPtr)); +static int DoObjConfig _ANSI_ARGS_((Tcl_Interp *interp, + char *recordPtr, Option *optionPtr, + Tcl_Obj *valuePtr, Tk_Window tkwin, + Tk_SavedOption *savePtr)); +static void DestroyOptionHashTable _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp)); +static void FreeResources _ANSI_ARGS_((Option *optionPtr, + Tcl_Obj *objPtr, char *internalPtr, + Tk_Window tkwin)); +static Tcl_Obj * GetConfigList _ANSI_ARGS_((char *recordPtr, + Option *optionPtr, Tk_Window tkwin)); +static Tcl_Obj * GetObjectForOption _ANSI_ARGS_((char *recordPtr, + Option *optionPtr, Tk_Window tkwin)); +static Option * GetOptionFromObj _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr, OptionTable *tablePtr)); +static int ObjectIsEmpty _ANSI_ARGS_((Tcl_Obj *objPtr)); +static int SetOptionFromAny _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); + +/* + * The structure below defines an object type that is used to cache the + * result of looking up an option name. If an object has this type, then + * its internalPtr1 field points to the OptionTable in which it was looked up, + * and the internalPtr2 field points to the entry that matched. + */ + +Tcl_ObjType optionType = { + "option", /* name */ + (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ + (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ + (Tcl_UpdateStringProc *) NULL, /* updateStringProc */ + SetOptionFromAny /* setFromAnyProc */ +}; /* *-------------------------------------------------------------- * - * Tk_ConfigureWidget -- + * Tk_CreateOptionTable -- * - * Process command-line options and database options to - * fill in fields of a widget record with resources and - * other parameters. + * Given a template for configuration options, this procedure + * creates a table that may be used to look up options efficiently. * * Results: - * A standard Tcl return value. In case of an error, - * interp->result will hold an error message. + * Returns a token to a structure that can be passed to procedures + * such as Tk_InitOptions, Tk_SetOptions, and Tk_FreeConfigOptions. * * Side effects: - * The fields of widgRec get filled in with information - * from argc/argv and the option database. Old information - * in widgRec's fields gets recycled. + * Storage is allocated. * *-------------------------------------------------------------- */ -int -Tk_ConfigureWidget(interp, tkwin, specs, argc, argv, widgRec, flags) - Tcl_Interp *interp; /* Interpreter for error reporting. */ - Tk_Window tkwin; /* Window containing widget (needed to - * set up X resources). */ - Tk_ConfigSpec *specs; /* Describes legal options. */ - int argc; /* Number of elements in argv. */ - char **argv; /* Command-line options. */ - char *widgRec; /* Record whose fields are to be - * modified. Values must be properly - * initialized. */ - int flags; /* Used to specify additional flags - * that must be present in config specs - * for them to be considered. Also, - * may have TK_CONFIG_ARGV_ONLY set. */ +Tk_OptionTable +Tk_CreateOptionTable(interp, templatePtr) + Tcl_Interp *interp; /* Interpreter associated with the + * application in which this table + * will be used. */ + CONST Tk_OptionSpec *templatePtr; /* Static information about the + * configuration options. */ { - register Tk_ConfigSpec *specPtr; - Tk_Uid value; /* Value of option from database. */ - int needFlags; /* Specs must contain this set of flags - * or else they are not considered. */ - int hateFlags; /* If a spec contains any bits here, it's - * not considered. */ - - needFlags = flags & ~(TK_CONFIG_USER_BIT - 1); - if (Tk_Depth(tkwin) <= 1) { - hateFlags = TK_CONFIG_COLOR_ONLY; - } else { - hateFlags = TK_CONFIG_MONO_ONLY; + Tcl_HashTable *hashTablePtr; + Tcl_HashEntry *hashEntryPtr; + int newEntry; + OptionTable *tablePtr; + CONST Tk_OptionSpec *specPtr, *specPtr2; + Option *optionPtr; + int numOptions, i; + + /* + * We use an AssocData value in the interpreter to keep a hash + * table of all the option tables we've created for this application. + * This is used for two purposes. First, it allows us to share the + * tables (e.g. in several chains) and second, we use the deletion + * callback for the AssocData to delete all the option tables when + * the interpreter is deleted. The code below finds the hash table + * or creates a new one if it doesn't already exist. + */ + + hashTablePtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, OPTION_HASH_KEY, + NULL); + if (hashTablePtr == NULL) { + hashTablePtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(hashTablePtr, TCL_ONE_WORD_KEYS); + Tcl_SetAssocData(interp, OPTION_HASH_KEY, DestroyOptionHashTable, + (ClientData) hashTablePtr); + } + + /* + * See if a table has already been created for this template. If + * so, just reuse the existing table. + */ + + hashEntryPtr = Tcl_CreateHashEntry(hashTablePtr, (char *) templatePtr, + &newEntry); + if (!newEntry) { + tablePtr = (OptionTable *) Tcl_GetHashValue(hashEntryPtr); + tablePtr->refCount++; + return (Tk_OptionTable) tablePtr; + } + + /* + * Count the number of options in the template, then create the + * table structure. + */ + + numOptions = 0; + for (specPtr = templatePtr; specPtr->type != TK_OPTION_END; specPtr++) { + numOptions++; } + tablePtr = (OptionTable *) (ckalloc(sizeof(OptionTable) + + ((numOptions - 1) * sizeof(Option)))); + tablePtr->refCount = 1; + tablePtr->hashEntryPtr = hashEntryPtr; + tablePtr->nextPtr = NULL; + tablePtr->numOptions = numOptions; /* - * Pass one: scan through all the option specs, replacing strings - * with Tk_Uids (if this hasn't been done already) and clearing - * the TK_CONFIG_OPTION_SPECIFIED flags. + * Initialize all of the Option structures in the table. */ - for (specPtr = specs; specPtr->type != TK_CONFIG_END; specPtr++) { - if (!(specPtr->specFlags & INIT) && (specPtr->argvName != NULL)) { + for (specPtr = templatePtr, optionPtr = tablePtr->options; + specPtr->type != TK_OPTION_END; specPtr++, optionPtr++) { + optionPtr->specPtr = specPtr; + optionPtr->dbNameUID = NULL; + optionPtr->dbClassUID = NULL; + optionPtr->defaultPtr = NULL; + optionPtr->extra.monoColorPtr = NULL; + optionPtr->flags = 0; + + if (specPtr->type == TK_OPTION_SYNONYM) { + /* + * This is a synonym option; find the master option that it + * refers to and create a pointer from the synonym to the + * master. + */ + + for (specPtr2 = templatePtr, i = 0; ; specPtr2++, i++) { + if (specPtr2->type == TK_OPTION_END) { + panic("Tk_CreateOptionTable couldn't find synonym"); + } + if (strcmp(specPtr2->optionName, + (char *) specPtr->clientData) == 0) { + optionPtr->extra.synonymPtr = tablePtr->options + i; + break; + } + } + } else { if (specPtr->dbName != NULL) { - specPtr->dbName = Tk_GetUid(specPtr->dbName); + optionPtr->dbNameUID = Tk_GetUid(specPtr->dbName); } if (specPtr->dbClass != NULL) { - specPtr->dbClass = Tk_GetUid(specPtr->dbClass); + optionPtr->dbClassUID = + Tk_GetUid(specPtr->dbClass); } if (specPtr->defValue != NULL) { - specPtr->defValue = Tk_GetUid(specPtr->defValue); + optionPtr->defaultPtr = + Tcl_NewStringObj(specPtr->defValue, -1); + Tcl_IncrRefCount(optionPtr->defaultPtr); + } + if (((specPtr->type == TK_OPTION_COLOR) + || (specPtr->type == TK_OPTION_BORDER)) + && (specPtr->clientData != NULL)) { + optionPtr->extra.monoColorPtr = + Tcl_NewStringObj((char *) specPtr->clientData, -1); + Tcl_IncrRefCount(optionPtr->extra.monoColorPtr); } } - specPtr->specFlags = (specPtr->specFlags & ~TK_CONFIG_OPTION_SPECIFIED) - | INIT; + if (((specPtr->type == TK_OPTION_STRING) + && (specPtr->internalOffset >= 0)) + || (specPtr->type == TK_OPTION_COLOR) + || (specPtr->type == TK_OPTION_FONT) + || (specPtr->type == TK_OPTION_BITMAP) + || (specPtr->type == TK_OPTION_BORDER) + || (specPtr->type == TK_OPTION_CURSOR)) { + optionPtr->flags |= OPTION_NEEDS_FREEING; + } } + tablePtr->hashEntryPtr = hashEntryPtr; + Tcl_SetHashValue(hashEntryPtr, tablePtr); /* - * Pass two: scan through all of the arguments, processing those - * that match entries in the specs. + * Finally, check to see if this template chains to another template + * with additional options. If so, call ourselves recursively to + * create the next table(s). */ - for ( ; argc > 0; argc -= 2, argv += 2) { - specPtr = FindConfigSpec(interp, specs, *argv, needFlags, hateFlags); - if (specPtr == NULL) { - return TCL_ERROR; + if (specPtr->clientData != NULL) { + tablePtr->nextPtr = (OptionTable *) Tk_CreateOptionTable(interp, + (Tk_OptionSpec *) specPtr->clientData); + } + + return (Tk_OptionTable) tablePtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_DeleteOptionTable -- + * + * Called to release resources used by an option table when + * the table is no longer needed. + * + * Results: + * None. + * + * Side effects: + * The option table and associated resources (such as additional + * option tables chained off it) are destroyed. + * + *---------------------------------------------------------------------- + */ + +void +Tk_DeleteOptionTable(optionTable) + Tk_OptionTable optionTable; /* The option table to delete. */ +{ + OptionTable *tablePtr = (OptionTable *) optionTable; + Option *optionPtr; + int count; + + tablePtr->refCount--; + if (tablePtr->refCount > 0) { + return; + } + + if (tablePtr->nextPtr != NULL) { + Tk_DeleteOptionTable((Tk_OptionTable) tablePtr->nextPtr); + } + + for (count = tablePtr->numOptions - 1, optionPtr = tablePtr->options; + count > 0; count--, optionPtr++) { + if (optionPtr->defaultPtr != NULL) { + Tcl_DecrRefCount(optionPtr->defaultPtr); + } + if (((optionPtr->specPtr->type == TK_OPTION_COLOR) + || (optionPtr->specPtr->type == TK_OPTION_BORDER)) + && (optionPtr->extra.monoColorPtr != NULL)) { + Tcl_DecrRefCount(optionPtr->extra.monoColorPtr); } + } + Tcl_DeleteHashEntry(tablePtr->hashEntryPtr); + ckfree((char *) tablePtr); +} + +/* + *---------------------------------------------------------------------- + * + * DestroyOptionHashTable -- + * + * This procedure is the deletion callback associated with the + * AssocData entry created by Tk_CreateOptionTable. It is + * invoked when an interpreter is deleted, and deletes all of + * the option tables associated with that interpreter. + * + * Results: + * None. + * + * Side effects: + * The option hash table is destroyed along with all of the + * OptionTable structures that it refers to. + * + *---------------------------------------------------------------------- + */ + +static void +DestroyOptionHashTable(clientData, interp) + ClientData clientData; /* The hash table we are destroying */ + Tcl_Interp *interp; /* The interpreter we are destroying */ +{ + Tcl_HashTable *hashTablePtr = (Tcl_HashTable *) clientData; + Tcl_HashSearch search; + Tcl_HashEntry *hashEntryPtr; + OptionTable *tablePtr; + + for (hashEntryPtr = Tcl_FirstHashEntry(hashTablePtr, &search); + hashEntryPtr != NULL; + hashEntryPtr = Tcl_NextHashEntry(&search)) { + tablePtr = (OptionTable *) Tcl_GetHashValue(hashEntryPtr); /* - * Process the entry. + * The following statements do two tricky things: + * 1. They ensure that the option table is deleted, even if + * there are outstanding references to it. + * 2. They ensure that Tk_DeleteOptionTable doesn't delete + * other tables chained from this one; we'll do it when + * we come across the hash table entry for the chained + * table (in fact, the chained table may already have + * been deleted). */ - if (argc < 2) { - Tcl_AppendResult(interp, "value for \"", *argv, - "\" missing", (char *) NULL); - return TCL_ERROR; - } - if (DoConfig(interp, tkwin, specPtr, argv[1], 0, widgRec) != TCL_OK) { - char msg[100]; + tablePtr->refCount = 1; + tablePtr->nextPtr = NULL; + Tk_DeleteOptionTable((Tk_OptionTable) tablePtr); + } + Tcl_DeleteHashTable(hashTablePtr); + ckfree((char *) hashTablePtr); +} + +/* + *-------------------------------------------------------------- + * + * Tk_InitOptions -- + * + * This procedure is invoked when an object such as a widget + * is created. It supplies an initial value for each configuration + * option (the value may come from the option database, a system + * default, or the default in the option table). + * + * Results: + * The return value is TCL_OK if the procedure completed + * successfully, and TCL_ERROR if one of the initial values was + * bogus. If an error occurs and interp isn't NULL, then an + * error message will be left in its result. + * + * Side effects: + * Fields of recordPtr are filled in with initial values. + * + *-------------------------------------------------------------- + */ - sprintf(msg, "\n (processing \"%.40s\" option)", - specPtr->argvName); - Tcl_AddErrorInfo(interp, msg); +int +Tk_InitOptions(interp, recordPtr, optionTable, tkwin) + Tcl_Interp *interp; /* Interpreter for error reporting. NULL + * means don't leave an error message. */ + char *recordPtr; /* Pointer to the record to configure. + * Note: the caller should have properly + * initialized the record with NULL + * pointers for each option value. */ + Tk_OptionTable optionTable; /* The token which matches the config + * specs for the widget in question. */ + Tk_Window tkwin; /* Certain options types (such as + * TK_OPTION_COLOR) need fields out + * of the window they are used in to + * be able to calculate their values. + * Not needed unless one of these + * options is in the configSpecs record. */ +{ + OptionTable *tablePtr = (OptionTable *) optionTable; + Option *optionPtr; + int count; + char *value; + Tcl_Obj *valuePtr; + enum { + OPTION_DATABASE, SYSTEM_DEFAULT, TABLE_DEFAULT + } source; + + /* + * If this table chains to other tables, handle their initialization + * first. That way, if both tables refer to the same field of the + * record, the value in the first table will win. + */ + + if (tablePtr->nextPtr != NULL) { + if (Tk_InitOptions(interp, recordPtr, + (Tk_OptionTable) tablePtr->nextPtr, tkwin) != TCL_OK) { return TCL_ERROR; } - specPtr->specFlags |= TK_CONFIG_OPTION_SPECIFIED; } /* - * Pass three: scan through all of the specs again; if no - * command-line argument matched a spec, then check for info - * in the option database. If there was nothing in the - * database, then use the default. + * Iterate over all of the options in the table, initializing each in + * turn. */ - if (!(flags & TK_CONFIG_ARGV_ONLY)) { - for (specPtr = specs; specPtr->type != TK_CONFIG_END; specPtr++) { - if ((specPtr->specFlags & TK_CONFIG_OPTION_SPECIFIED) - || (specPtr->argvName == NULL) - || (specPtr->type == TK_CONFIG_SYNONYM)) { - continue; + for (optionPtr = tablePtr->options, count = tablePtr->numOptions; + count > 0; optionPtr++, count--) { + + if (optionPtr->specPtr->type == TK_OPTION_SYNONYM) { + continue; + } + source = TABLE_DEFAULT; + + /* + * We look in three places for the initial value, using the first + * non-NULL value that we find. First, check the option database. + */ + + valuePtr = NULL; + if (optionPtr->dbNameUID != NULL) { + value = Tk_GetOption(tkwin, optionPtr->dbNameUID, + optionPtr->dbClassUID); + if (value != NULL) { + valuePtr = Tcl_NewStringObj(value, -1); + source = OPTION_DATABASE; } - if (((specPtr->specFlags & needFlags) != needFlags) - || (specPtr->specFlags & hateFlags)) { - continue; + } + + /* + * Second, check for a system-specific default value. + */ + + if ((valuePtr == NULL) + && (optionPtr->dbNameUID != NULL)) { + valuePtr = TkpGetSystemDefault(tkwin, optionPtr->dbNameUID, + optionPtr->dbClassUID); + if (valuePtr != NULL) { + source = SYSTEM_DEFAULT; } - value = NULL; - if (specPtr->dbName != NULL) { - value = Tk_GetOption(tkwin, specPtr->dbName, specPtr->dbClass); + } + + /* + * Third and last, use the default value supplied by the option + * table. In the case of color objects, we pick one of two + * values depending on whether the screen is mono or color. + */ + + if (valuePtr == NULL) { + if ((tkwin != NULL) + && ((optionPtr->specPtr->type == TK_OPTION_COLOR) + || (optionPtr->specPtr->type == TK_OPTION_BORDER)) + && (Tk_Depth(tkwin) <= 1) + && (optionPtr->extra.monoColorPtr != NULL)) { + valuePtr = optionPtr->extra.monoColorPtr; + } else { + valuePtr = optionPtr->defaultPtr; } - if (value != NULL) { - if (DoConfig(interp, tkwin, specPtr, value, 1, widgRec) != - TCL_OK) { - char msg[200]; + } + + if (valuePtr == NULL) { + continue; + } + + if (DoObjConfig(interp, recordPtr, optionPtr, valuePtr, tkwin, + (Tk_SavedOption *) NULL) != TCL_OK) { + if (interp != NULL) { + char msg[200]; - sprintf(msg, "\n (%s \"%.50s\" in widget \"%.50s\")", - "database entry for", - specPtr->dbName, Tk_PathName(tkwin)); - Tcl_AddErrorInfo(interp, msg); - return TCL_ERROR; + switch (source) { + case OPTION_DATABASE: + sprintf(msg, "\n (database entry for \"%.50s\")", + optionPtr->specPtr->optionName); + break; + case SYSTEM_DEFAULT: + sprintf(msg, "\n (system default for \"%.50s\")", + optionPtr->specPtr->optionName); + break; + case TABLE_DEFAULT: + sprintf(msg, "\n (default value for \"%.50s\")", + optionPtr->specPtr->optionName); } - } else { - value = specPtr->defValue; - if ((value != NULL) && !(specPtr->specFlags - & TK_CONFIG_DONT_SET_DEFAULT)) { - if (DoConfig(interp, tkwin, specPtr, value, 1, widgRec) != - TCL_OK) { - char msg[200]; - - sprintf(msg, - "\n (%s \"%.50s\" in widget \"%.50s\")", - "default value for", - specPtr->dbName, Tk_PathName(tkwin)); - Tcl_AddErrorInfo(interp, msg); - return TCL_ERROR; - } + if (tkwin != NULL) { + sprintf(msg + strlen(msg) - 1, " in widget \"%.50s\")", + Tk_PathName(tkwin)); } + Tcl_AddErrorInfo(interp, msg); } + return TCL_ERROR; } } - return TCL_OK; } /* *-------------------------------------------------------------- * - * FindConfigSpec -- + * DoObjConfig -- * - * Search through a table of configuration specs, looking for - * one that matches a given argvName. + * This procedure applies a new value for a configuration option + * to the record being configured. * * Results: - * The return value is a pointer to the matching entry, or NULL - * if nothing matched. In that case an error message is left - * in interp->result. + * The return value is TCL_OK if the procedure completed + * successfully. If an error occurred then TCL_ERROR is + * returned and an error message is left in interp's result, if + * interp isn't NULL. In addition, if oldValuePtrPtr isn't + * NULL then it *oldValuePtrPtr is filled in with a pointer + * to the option's old value. * * Side effects: - * None. + * RecordPtr gets modified to hold the new value in the form of + * a Tcl_Obj, an internal representation, or both. The old + * value is freed if oldValuePtrPtr is NULL. * *-------------------------------------------------------------- */ -static Tk_ConfigSpec * -FindConfigSpec(interp, specs, argvName, needFlags, hateFlags) - Tcl_Interp *interp; /* Used for reporting errors. */ - Tk_ConfigSpec *specs; /* Pointer to table of configuration - * specifications for a widget. */ - char *argvName; /* Name (suitable for use in a "config" - * command) identifying particular option. */ - int needFlags; /* Flags that must be present in matching - * entry. */ - int hateFlags; /* Flags that must NOT be present in - * matching entry. */ +static int +DoObjConfig(interp, recordPtr, optionPtr, valuePtr, tkwin, savedOptionPtr) + Tcl_Interp *interp; /* Interpreter for error reporting. If + * NULL, then no message is left if an error + * occurs. */ + char *recordPtr; /* The record to modify to hold the new + * option value. */ + Option *optionPtr; /* Pointer to information about the + * option. */ + Tcl_Obj *valuePtr; /* New value for option. */ + Tk_Window tkwin; /* Window in which option will be used (needed + * to allocate resources for some options). + * May be NULL if the option doesn't + * require window-related resources. */ + Tk_SavedOption *savedOptionPtr; + /* If NULL, the old value for the option will + * be freed. If non-NULL, the old value will + * be stored here, and it becomes the property + * of the caller (the caller must eventually + * free the old value). */ { - register Tk_ConfigSpec *specPtr; - register char c; /* First character of current argument. */ - Tk_ConfigSpec *matchPtr; /* Matching spec, or NULL. */ - size_t length; - - c = argvName[1]; - length = strlen(argvName); - matchPtr = NULL; - for (specPtr = specs; specPtr->type != TK_CONFIG_END; specPtr++) { - if (specPtr->argvName == NULL) { - continue; + Tcl_Obj **slotPtrPtr, *oldPtr; + char *internalPtr; /* Points to location in record where + * internal representation of value should + * be stored, or NULL. */ + char *oldInternalPtr; /* Points to location in which to save old + * internal representation of value. */ + Tk_SavedOption internal; /* Used to save the old internal representation + * of the value if savedOptionPtr is NULL. */ + CONST Tk_OptionSpec *specPtr; + int nullOK; + + /* + * Save the old object form for the value, if there is one. + */ + + specPtr = optionPtr->specPtr; + if (specPtr->objOffset >= 0) { + slotPtrPtr = (Tcl_Obj **) (recordPtr + specPtr->objOffset); + oldPtr = *slotPtrPtr; + } else { + slotPtrPtr = NULL; + oldPtr = NULL; + } + + /* + * Apply the new value in a type-specific way. Also remember the + * old object and internal forms, if they exist. + */ + + if (specPtr->internalOffset >= 0) { + internalPtr = recordPtr + specPtr->internalOffset; + } else { + internalPtr = NULL; + } + if (savedOptionPtr != NULL) { + savedOptionPtr->optionPtr = optionPtr; + savedOptionPtr->valuePtr = oldPtr; + oldInternalPtr = (char *) &savedOptionPtr->internalForm; + } else { + oldInternalPtr = (char *) &internal.internalForm; + } + nullOK = (optionPtr->specPtr->flags & TK_OPTION_NULL_OK); + switch (optionPtr->specPtr->type) { + case TK_OPTION_BOOLEAN: { + int new; + + if (Tcl_GetBooleanFromObj(interp, valuePtr, &new) + != TCL_OK) { + return TCL_ERROR; + } + if (internalPtr != NULL) { + *((int *) oldInternalPtr) = *((int *) internalPtr); + *((int *) internalPtr) = new; + } + break; } - if ((specPtr->argvName[1] != c) - || (strncmp(specPtr->argvName, argvName, length) != 0)) { - continue; + case TK_OPTION_INT: { + int new; + + if (Tcl_GetIntFromObj(interp, valuePtr, &new) != TCL_OK) { + return TCL_ERROR; + } + if (internalPtr != NULL) { + *((int *) oldInternalPtr) = *((int *) internalPtr); + *((int *) internalPtr) = new; + } + break; } - if (((specPtr->specFlags & needFlags) != needFlags) - || (specPtr->specFlags & hateFlags)) { - continue; + case TK_OPTION_DOUBLE: { + double new; + + if (Tcl_GetDoubleFromObj(interp, valuePtr, &new) + != TCL_OK) { + return TCL_ERROR; + } + if (internalPtr != NULL) { + *((double *) oldInternalPtr) = *((double *) internalPtr); + *((double *) internalPtr) = new; + } + break; + } + case TK_OPTION_STRING: { + char *new, *value; + int length; + + if (nullOK && ObjectIsEmpty(valuePtr)) { + valuePtr = NULL; + } + if (internalPtr != NULL) { + if (valuePtr != NULL) { + value = Tcl_GetStringFromObj(valuePtr, &length); + new = ckalloc((unsigned) (length + 1)); + strcpy(new, value); + } else { + new = NULL; + } + *((char **) oldInternalPtr) = *((char **) internalPtr); + *((char **) internalPtr) = new; + } + break; } - if (specPtr->argvName[length] == 0) { - matchPtr = specPtr; - goto gotMatch; + case TK_OPTION_STRING_TABLE: { + int new; + + if (Tcl_GetIndexFromObj(interp, valuePtr, + (char **) optionPtr->specPtr->clientData, + optionPtr->specPtr->optionName+1, 0, &new) != TCL_OK) { + return TCL_ERROR; + } + if (internalPtr != NULL) { + *((int *) oldInternalPtr) = *((int *) internalPtr); + *((int *) internalPtr) = new; + } + break; } - if (matchPtr != NULL) { - Tcl_AppendResult(interp, "ambiguous option \"", argvName, - "\"", (char *) NULL); - return (Tk_ConfigSpec *) NULL; + case TK_OPTION_COLOR: { + XColor *newPtr; + + if (nullOK && ObjectIsEmpty(valuePtr)) { + valuePtr = NULL; + newPtr = NULL; + } else { + newPtr = Tk_AllocColorFromObj(interp, tkwin, valuePtr); + if (newPtr == NULL) { + return TCL_ERROR; + } + } + if (internalPtr != NULL) { + *((XColor **) oldInternalPtr) = *((XColor **) internalPtr); + *((XColor **) internalPtr) = newPtr; + } + break; } - matchPtr = specPtr; - } + case TK_OPTION_FONT: { + Tk_Font new; - if (matchPtr == NULL) { - Tcl_AppendResult(interp, "unknown option \"", argvName, - "\"", (char *) NULL); - return (Tk_ConfigSpec *) NULL; + if (nullOK && ObjectIsEmpty(valuePtr)) { + valuePtr = NULL; + new = NULL; + } else { + new = Tk_AllocFontFromObj(interp, tkwin, valuePtr); + if (new == NULL) { + return TCL_ERROR; + } + } + if (internalPtr != NULL) { + *((Tk_Font *) oldInternalPtr) = *((Tk_Font *) internalPtr); + *((Tk_Font *) internalPtr) = new; + } + break; + } + case TK_OPTION_BITMAP: { + Pixmap new; + + if (nullOK && ObjectIsEmpty(valuePtr)) { + valuePtr = NULL; + new = None; + } else { + new = Tk_AllocBitmapFromObj(interp, tkwin, valuePtr); + if (new == None) { + return TCL_ERROR; + } + } + if (internalPtr != NULL) { + *((Pixmap *) oldInternalPtr) = *((Pixmap *) internalPtr); + *((Pixmap *) internalPtr) = new; + } + break; + } + case TK_OPTION_BORDER: { + Tk_3DBorder new; + + if (nullOK && ObjectIsEmpty(valuePtr)) { + valuePtr = NULL; + new = NULL; + } else { + new = Tk_Alloc3DBorderFromObj(interp, tkwin, valuePtr); + if (new == NULL) { + return TCL_ERROR; + } + } + if (internalPtr != NULL) { + *((Tk_3DBorder *) oldInternalPtr) = + *((Tk_3DBorder *) internalPtr); + *((Tk_3DBorder *) internalPtr) = new; + } + break; + } + case TK_OPTION_RELIEF: { + int new; + + if (Tk_GetReliefFromObj(interp, valuePtr, &new) != TCL_OK) { + return TCL_ERROR; + } + if (internalPtr != NULL) { + *((int *) oldInternalPtr) = *((int *) internalPtr); + *((int *) internalPtr) = new; + } + break; + } + case TK_OPTION_CURSOR: { + Tk_Cursor new; + + if (nullOK && ObjectIsEmpty(valuePtr)) { + new = None; + valuePtr = NULL; + } else { + new = Tk_AllocCursorFromObj(interp, tkwin, valuePtr); + if (new == None) { + return TCL_ERROR; + } + } + if (internalPtr != NULL) { + *((Tk_Cursor *) oldInternalPtr) = *((Tk_Cursor *) internalPtr); + *((Tk_Cursor *) internalPtr) = new; + } + Tk_DefineCursor(tkwin, new); + break; + } + case TK_OPTION_JUSTIFY: { + Tk_Justify new; + + if (Tk_GetJustifyFromObj(interp, valuePtr, &new) != TCL_OK) { + return TCL_ERROR; + } + if (internalPtr != NULL) { + *((Tk_Justify *) oldInternalPtr) + = *((Tk_Justify *) internalPtr); + *((Tk_Justify *) internalPtr) = new; + } + break; + } + case TK_OPTION_ANCHOR: { + Tk_Anchor new; + + if (Tk_GetAnchorFromObj(interp, valuePtr, &new) != TCL_OK) { + return TCL_ERROR; + } + if (internalPtr != NULL) { + *((Tk_Anchor *) oldInternalPtr) + = *((Tk_Anchor *) internalPtr); + *((Tk_Anchor *) internalPtr) = new; + } + break; + } + case TK_OPTION_PIXELS: { + int new; + + if (Tk_GetPixelsFromObj(interp, tkwin, valuePtr, + &new) != TCL_OK) { + return TCL_ERROR; + } + if (internalPtr != NULL) { + *((int *) oldInternalPtr) = *((int *) internalPtr); + *((int *) internalPtr) = new; + } + break; + } + case TK_OPTION_WINDOW: { + Tk_Window new; + + if (nullOK && ObjectIsEmpty(valuePtr)) { + valuePtr = NULL; + new = None; + } else { + if (TkGetWindowFromObj(interp, tkwin, valuePtr, &new) + != TCL_OK) { + return TCL_ERROR; + } + } + if (internalPtr != NULL) { + *((Tk_Window *) oldInternalPtr) = *((Tk_Window *) internalPtr); + *((Tk_Window *) internalPtr) = new; + } + break; + } + default: { + sprintf(interp->result, "bad config table: unknown type %d", + optionPtr->specPtr->type); + return TCL_ERROR; + } } /* - * Found a matching entry. If it's a synonym, then find the - * entry that it's a synonym for. + * Release resources associated with the old value, if we're not + * returning it to the caller, then install the new object value into + * the record. */ - gotMatch: - specPtr = matchPtr; - if (specPtr->type == TK_CONFIG_SYNONYM) { - for (specPtr = specs; ; specPtr++) { - if (specPtr->type == TK_CONFIG_END) { - Tcl_AppendResult(interp, - "couldn't find synonym for option \"", - argvName, "\"", (char *) NULL); - return (Tk_ConfigSpec *) NULL; - } - if ((specPtr->dbName == matchPtr->dbName) - && (specPtr->type != TK_CONFIG_SYNONYM) - && ((specPtr->specFlags & needFlags) == needFlags) - && !(specPtr->specFlags & hateFlags)) { - break; - } + if (savedOptionPtr == NULL) { + if (optionPtr->flags & OPTION_NEEDS_FREEING) { + FreeResources(optionPtr, oldPtr, oldInternalPtr, tkwin); + } + if (oldPtr != NULL) { + Tcl_DecrRefCount(oldPtr); + } + } + if (slotPtrPtr != NULL) { + *slotPtrPtr = valuePtr; + if (valuePtr != NULL) { + Tcl_IncrRefCount(valuePtr); } } - return specPtr; + return TCL_OK; } /* - *-------------------------------------------------------------- + *---------------------------------------------------------------------- * - * DoConfig -- + * ObjectIsEmpty -- * - * This procedure applies a single configuration option - * to a widget record. + * This procedure tests whether the string value of an object is + * empty. * * Results: - * A standard Tcl return value. + * The return value is 1 if the string value of objPtr has length + * zero, and 0 otherwise. * * Side effects: - * WidgRec is modified as indicated by specPtr and value. - * The old value is recycled, if that is appropriate for - * the value type. + * None. * - *-------------------------------------------------------------- + *---------------------------------------------------------------------- */ static int -DoConfig(interp, tkwin, specPtr, value, valueIsUid, widgRec) - Tcl_Interp *interp; /* Interpreter for error reporting. */ - Tk_Window tkwin; /* Window containing widget (needed to - * set up X resources). */ - Tk_ConfigSpec *specPtr; /* Specifier to apply. */ - char *value; /* Value to use to fill in widgRec. */ - int valueIsUid; /* Non-zero means value is a Tk_Uid; - * zero means it's an ordinary string. */ - char *widgRec; /* Record whose fields are to be - * modified. Values must be properly - * initialized. */ +ObjectIsEmpty(objPtr) + Tcl_Obj *objPtr; /* Object to test. May be NULL. */ { - char *ptr; - Tk_Uid uid; - int nullValue; + int length; - nullValue = 0; - if ((*value == 0) && (specPtr->specFlags & TK_CONFIG_NULL_OK)) { - nullValue = 1; + if (objPtr == NULL) { + return 1; + } + if (objPtr->bytes != NULL) { + return (objPtr->length == 0); } + Tcl_GetStringFromObj(objPtr, &length); + return (length == 0); +} + +/* + *---------------------------------------------------------------------- + * + * GetOptionFromObj -- + * + * This procedure searches through a chained option table to find + * the entry for a particular option name. + * + * Results: + * The return value is a pointer to the matching entry, or NULL + * if no matching entry could be found. If NULL is returned and + * interp is not NULL than an error message is left in its result. + * Note: if the matching entry is a synonym then this procedure + * returns a pointer to the synonym entry, *not* the "real" entry + * that the synonym refers to. + * + * Side effects: + * Information about the matching entry is cached in the object + * containing the name, so that future lookups can proceed more + * quickly. + * + *---------------------------------------------------------------------- + */ - do { - ptr = widgRec + specPtr->offset; - switch (specPtr->type) { - case TK_CONFIG_BOOLEAN: - if (Tcl_GetBoolean(interp, value, (int *) ptr) != TCL_OK) { - return TCL_ERROR; - } - break; - case TK_CONFIG_INT: - if (Tcl_GetInt(interp, value, (int *) ptr) != TCL_OK) { - return TCL_ERROR; - } - break; - case TK_CONFIG_DOUBLE: - if (Tcl_GetDouble(interp, value, (double *) ptr) != TCL_OK) { - return TCL_ERROR; - } - break; - case TK_CONFIG_STRING: { - char *old, *new; +static Option * +GetOptionFromObj(interp, objPtr, tablePtr) + Tcl_Interp *interp; /* Used only for error reporting; if NULL + * no message is left after an error. */ + Tcl_Obj *objPtr; /* Object whose string value is to be + * looked up in the option table. */ + OptionTable *tablePtr; /* Table in which to look up objPtr. */ +{ + Option *bestPtr, *optionPtr; + OptionTable *tablePtr2; + char *p1, *p2, *name; + int count; - if (nullValue) { - new = NULL; - } else { - new = (char *) ckalloc((unsigned) (strlen(value) + 1)); - strcpy(new, value); - } - old = *((char **) ptr); - if (old != NULL) { - ckfree(old); + /* + * First, check to see if the object already has the answer cached. + */ + + if (objPtr->typePtr == &optionType) { + if (objPtr->internalRep.twoPtrValue.ptr1 == (VOID *) tablePtr) { + return (Option *) objPtr->internalRep.twoPtrValue.ptr2; + } + } + + /* + * The answer isn't cached. Search through all of the option tables + * in the chain to find the best match. Some tricky aspects: + * + * 1. We have to accept unique abbreviations. + * 2. The same name could appear in different tables in the chain. + * If this happens, we use the entry from the first table. We + * have to be careful to distinguish this case from an ambiguous + * abbreviation. + */ + + bestPtr = NULL; + name = Tcl_GetStringFromObj(objPtr, (int *) NULL); + for (tablePtr2 = tablePtr; tablePtr2 != NULL; + tablePtr2 = tablePtr2->nextPtr) { + for (optionPtr = tablePtr2->options, count = tablePtr2->numOptions; + count > 0; optionPtr++, count--) { + for (p1 = name, p2 = optionPtr->specPtr->optionName; + *p1 == *p2; p1++, p2++) { + if (*p1 == 0) { + /* + * This is an exact match. We're done. + */ + + bestPtr = optionPtr; + goto done; } - *((char **) ptr) = new; - break; } - case TK_CONFIG_UID: - if (nullValue) { - *((Tk_Uid *) ptr) = NULL; - } else { - uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value); - *((Tk_Uid *) ptr) = uid; - } - break; - case TK_CONFIG_COLOR: { - XColor *newPtr, *oldPtr; + if (*p1 == 0) { + /* + * The name is an abbreviation for this option. Keep + * to make sure that the abbreviation only matches one + * option name. If we've already found a match in the + * past, then it is an error unless the full names for + * the two options are identical; in this case, the first + * option overrides the second. + */ - if (nullValue) { - newPtr = NULL; + if (bestPtr == NULL) { + bestPtr = optionPtr; } else { - uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value); - newPtr = Tk_GetColor(interp, tkwin, uid); - if (newPtr == NULL) { - return TCL_ERROR; + if (strcmp(bestPtr->specPtr->optionName, + optionPtr->specPtr->optionName) != 0) { + goto error; } } - oldPtr = *((XColor **) ptr); - if (oldPtr != NULL) { - Tk_FreeColor(oldPtr); - } - *((XColor **) ptr) = newPtr; - break; } - case TK_CONFIG_FONT: { - Tk_Font new; + } + } + if (bestPtr == NULL) { + goto error; + } - if (nullValue) { - new = NULL; - } else { - new = Tk_GetFont(interp, tkwin, value); - if (new == NULL) { - return TCL_ERROR; - } - } - Tk_FreeFont(*((Tk_Font *) ptr)); - *((Tk_Font *) ptr) = new; - break; + done: + if ((objPtr->typePtr != NULL) + && (objPtr->typePtr->freeIntRepProc != NULL)) { + objPtr->typePtr->freeIntRepProc(objPtr); + } + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) tablePtr; + objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) bestPtr; + objPtr->typePtr = &optionType; + return bestPtr; + + error: + if (interp != NULL) { + Tcl_AppendResult(interp, "unknown option \"", name, + "\"", (char *) NULL); + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * SetOptionFromAny -- + * + * This procedure is called to convert a Tcl object to option + * internal form. However, this doesn't make sense (need to have a + * table of options in order to do the conversion) so the + * procedure always generates an error. + * + * Results: + * The return value is always TCL_ERROR, and an error message is + * left in interp's result if interp isn't NULL. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +SetOptionFromAny(interp, objPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr; /* The object to convert. */ +{ + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "can't convert value to option except via GetOptionFromObj API", + -1); + return TCL_ERROR; +} + +/* + *-------------------------------------------------------------- + * + * Tk_SetOptions -- + * + * Process one or more name-value pairs for configuration options + * and fill in fields of a record with new values. + * + * Results: + * If all goes well then TCL_OK is returned and the old values of + * any modified objects are saved in *savePtr, if it isn't NULL (the + * caller must eventually call Tk_RestoreSavedOptions or + * Tk_FreeSavedOptions to free the contents of *savePtr). In + * addition, if maskPtr isn't NULL then *maskPtr is filled in with + * the OR of the typeMask bits from all modified options. If an + * error occurs then TCL_ERROR is returned and a message + * is left in interp's result unless interp is NULL; nothing is + * saved in *savePtr or *maskPtr in this case. + * + * Side effects: + * The fields of recordPtr get filled in with object pointers + * from objc/objv. Old information in widgRec's fields gets + * recycled. Information may be left at *savePtr. + * + *-------------------------------------------------------------- + */ + +int +Tk_SetOptions(interp, recordPtr, optionTable, objc, objv, tkwin, savePtr, + maskPtr) + Tcl_Interp *interp; /* Interpreter for error reporting. + * If NULL, then no error message is + * returned.*/ + char *recordPtr; /* The record to configure. */ + Tk_OptionTable optionTable; /* Describes valid options. */ + int objc; /* The number of elements in objv. */ + Tcl_Obj *CONST objv[]; /* Contains one or more name-value + * pairs. */ + Tk_Window tkwin; /* Window associated with the thing + * being configured; needed for some + * options (such as colors). */ + Tk_SavedOptions *savePtr; /* If non-NULL, the old values of + * modified options are saved here + * so that they can be restored + * after an error. */ + int *maskPtr; /* It non-NULL, this word is modified + * on a successful return to hold the + * bit-wise OR of the typeMask fields + * of all options that were modified + * by this call. Used by the caller + * to figure out which options + * actually changed. */ +{ + OptionTable *tablePtr = (OptionTable *) optionTable; + Option *optionPtr; + Tk_SavedOptions *lastSavePtr, *newSavePtr; + int mask; + + if (savePtr != NULL) { + savePtr->recordPtr = recordPtr; + savePtr->tkwin = tkwin; + savePtr->numItems = 0; + savePtr->nextPtr = NULL; + } + lastSavePtr = savePtr; + + /* + * Scan through all of the arguments, processing those + * that match entries in the option table. + */ + + mask = 0; + for ( ; objc > 0; objc -= 2, objv += 2) { + optionPtr = GetOptionFromObj(interp, objv[0], tablePtr); + if (optionPtr == NULL) { + goto error; + } + if (optionPtr->specPtr->type == TK_OPTION_SYNONYM) { + optionPtr = optionPtr->extra.synonymPtr; + } + + if (objc < 2) { + if (interp != NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "value for \"", Tcl_GetStringFromObj(*objv, NULL), + "\" missing", (char *) NULL); + goto error; } - case TK_CONFIG_BITMAP: { - Pixmap new, old; + } + if ((savePtr != NULL) + && (lastSavePtr->numItems >= TK_NUM_SAVED_OPTIONS)) { + /* + * We've run out of space for saving old option values. Allocate + * more space. + */ - if (nullValue) { - new = None; - } else { - uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value); - new = Tk_GetBitmap(interp, tkwin, uid); - if (new == None) { - return TCL_ERROR; - } + newSavePtr = (Tk_SavedOptions *) ckalloc(sizeof( + Tk_SavedOptions)); + newSavePtr->recordPtr = recordPtr; + newSavePtr->tkwin = tkwin; + newSavePtr->numItems = 0; + newSavePtr->nextPtr = NULL; + lastSavePtr->nextPtr = newSavePtr; + lastSavePtr = newSavePtr; + } + if (DoObjConfig(interp, recordPtr, optionPtr, objv[1], tkwin, + (savePtr != NULL) ? &lastSavePtr->items[lastSavePtr->numItems] + : (Tk_SavedOption *) NULL) != TCL_OK) { + char msg[100]; + + sprintf(msg, "\n (processing \"%.40s\" option)", + Tcl_GetStringFromObj(*objv, NULL)); + Tcl_AddErrorInfo(interp, msg); + goto error; + } + if (savePtr != NULL) { + lastSavePtr->numItems++; + } + mask |= optionPtr->specPtr->typeMask; + } + if (maskPtr != NULL) { + *maskPtr = mask; + } + return TCL_OK; + + error: + if (savePtr != NULL) { + Tk_RestoreSavedOptions(savePtr); + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_RestoreSavedOptions -- + * + * This procedure undoes the effect of a previous call to + * Tk_SetOptions by restoring all of the options to their value + * before the call to Tk_SetOptions. + * + * Results: + * None. + * + * Side effects: + * The configutation record is restored and all the information + * stored in savePtr is freed. + * + *---------------------------------------------------------------------- + */ + +void +Tk_RestoreSavedOptions(savePtr) + Tk_SavedOptions *savePtr; /* Holds saved option information; must + * have been passed to Tk_SetOptions. */ +{ + int i; + Option *optionPtr; + Tcl_Obj *newPtr; /* New object value of option, which we + * replace with old value and free. Taken + * from record. */ + char *internalPtr; /* Points to internal value of option in + * record. */ + CONST Tk_OptionSpec *specPtr; + + /* + * Be sure to restore the options in the opposite order they were + * set. This is important because it's possible that the same + * option name was used twice in a single call to Tk_SetOptions. + */ + + if (savePtr->nextPtr != NULL) { + Tk_RestoreSavedOptions(savePtr->nextPtr); + ckfree((char *) savePtr->nextPtr); + savePtr->nextPtr = NULL; + } + for (i = savePtr->numItems - 1; i >= 0; i--) { + optionPtr = savePtr->items[i].optionPtr; + specPtr = optionPtr->specPtr; + + /* + * First free the new value of the option, which is currently + * in the record. + */ + + if (specPtr->objOffset >= 0) { + newPtr = *((Tcl_Obj **) (savePtr->recordPtr + specPtr->objOffset)); + } else { + newPtr = NULL; + } + if (specPtr->internalOffset >= 0) { + internalPtr = savePtr->recordPtr + specPtr->internalOffset; + } else { + internalPtr = NULL; + } + if (optionPtr->flags & OPTION_NEEDS_FREEING) { + FreeResources(optionPtr, newPtr, internalPtr, savePtr->tkwin); + } + if (newPtr != NULL) { + Tcl_DecrRefCount(newPtr); + } + + /* + * Now restore the old value of the option. + */ + + if (specPtr->objOffset >= 0) { + *((Tcl_Obj **) (savePtr->recordPtr + specPtr->objOffset)) + = savePtr->items[i].valuePtr; + } + if (specPtr->internalOffset >= 0) { + switch (specPtr->type) { + case TK_OPTION_BOOLEAN: { + *((int *) internalPtr) + = *((int *) &savePtr->items[i].internalForm); + break; } - old = *((Pixmap *) ptr); - if (old != None) { - Tk_FreeBitmap(Tk_Display(tkwin), old); + case TK_OPTION_INT: { + *((int *) internalPtr) + = *((int *) &savePtr->items[i].internalForm); + break; } - *((Pixmap *) ptr) = new; - break; - } - case TK_CONFIG_BORDER: { - Tk_3DBorder new, old; - - if (nullValue) { - new = NULL; - } else { - uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value); - new = Tk_Get3DBorder(interp, tkwin, uid); - if (new == NULL) { - return TCL_ERROR; - } + case TK_OPTION_DOUBLE: { + *((double *) internalPtr) + = *((double *) &savePtr->items[i].internalForm); + break; } - old = *((Tk_3DBorder *) ptr); - if (old != NULL) { - Tk_Free3DBorder(old); + case TK_OPTION_STRING: { + *((char **) internalPtr) + = *((char **) &savePtr->items[i].internalForm); + break; } - *((Tk_3DBorder *) ptr) = new; - break; - } - case TK_CONFIG_RELIEF: - uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value); - if (Tk_GetRelief(interp, uid, (int *) ptr) != TCL_OK) { - return TCL_ERROR; + case TK_OPTION_STRING_TABLE: { + *((int *) internalPtr) + = *((int *) &savePtr->items[i].internalForm); + break; } - break; - case TK_CONFIG_CURSOR: - case TK_CONFIG_ACTIVE_CURSOR: { - Tk_Cursor new, old; - - if (nullValue) { - new = None; - } else { - uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value); - new = Tk_GetCursor(interp, tkwin, uid); - if (new == None) { - return TCL_ERROR; - } + case TK_OPTION_COLOR: { + *((XColor **) internalPtr) + = *((XColor **) &savePtr->items[i].internalForm); + break; } - old = *((Tk_Cursor *) ptr); - if (old != None) { - Tk_FreeCursor(Tk_Display(tkwin), old); + case TK_OPTION_FONT: { + *((Tk_Font *) internalPtr) + = *((Tk_Font *) &savePtr->items[i].internalForm); + break; } - *((Tk_Cursor *) ptr) = new; - if (specPtr->type == TK_CONFIG_ACTIVE_CURSOR) { - Tk_DefineCursor(tkwin, new); + case TK_OPTION_BITMAP: { + *((Pixmap *) internalPtr) + = *((Pixmap *) &savePtr->items[i].internalForm); + break; } - break; - } - case TK_CONFIG_JUSTIFY: - uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value); - if (Tk_GetJustify(interp, uid, (Tk_Justify *) ptr) != TCL_OK) { - return TCL_ERROR; + case TK_OPTION_BORDER: { + *((Tk_3DBorder *) internalPtr) + = *((Tk_3DBorder *) &savePtr->items[i].internalForm); + break; } - break; - case TK_CONFIG_ANCHOR: - uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value); - if (Tk_GetAnchor(interp, uid, (Tk_Anchor *) ptr) != TCL_OK) { - return TCL_ERROR; + case TK_OPTION_RELIEF: { + *((int *) internalPtr) + = *((int *) &savePtr->items[i].internalForm); + break; } - break; - case TK_CONFIG_CAP_STYLE: - uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value); - if (Tk_GetCapStyle(interp, uid, (int *) ptr) != TCL_OK) { - return TCL_ERROR; + case TK_OPTION_CURSOR: { + *((Tk_Cursor *) internalPtr) + = *((Tk_Cursor *) &savePtr->items[i].internalForm); + Tk_DefineCursor(savePtr->tkwin, + *((Tk_Cursor *) internalPtr)); + break; } - break; - case TK_CONFIG_JOIN_STYLE: - uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value); - if (Tk_GetJoinStyle(interp, uid, (int *) ptr) != TCL_OK) { - return TCL_ERROR; + case TK_OPTION_JUSTIFY: { + *((Tk_Justify *) internalPtr) + = *((Tk_Justify *) &savePtr->items[i].internalForm); + break; } - break; - case TK_CONFIG_PIXELS: - if (Tk_GetPixels(interp, tkwin, value, (int *) ptr) - != TCL_OK) { - return TCL_ERROR; + case TK_OPTION_ANCHOR: { + *((Tk_Anchor *) internalPtr) + = *((Tk_Anchor *) &savePtr->items[i].internalForm); + break; } - break; - case TK_CONFIG_MM: - if (Tk_GetScreenMM(interp, tkwin, value, (double *) ptr) - != TCL_OK) { - return TCL_ERROR; + case TK_OPTION_PIXELS: { + *((int *) internalPtr) + = *((int *) &savePtr->items[i].internalForm); + break; + } + case TK_OPTION_WINDOW: { + *((Tk_Window *) internalPtr) + = *((Tk_Window *) &savePtr->items[i].internalForm); + break; + } + default: { + panic("bad option type in Tk_RestoreSavedOptions"); } - break; - case TK_CONFIG_WINDOW: { - Tk_Window tkwin2; + } + } + } + savePtr->numItems = 0; +} + +/* + *-------------------------------------------------------------- + * + * Tk_FreeSavedOptions -- + * + * Free all of the saved configuration option values from a + * previous call to Tk_SetOptions. + * + * Results: + * None. + * + * Side effects: + * Storage and system resources are freed. + * + *-------------------------------------------------------------- + */ - if (nullValue) { - tkwin2 = NULL; - } else { - tkwin2 = Tk_NameToWindow(interp, value, tkwin); - if (tkwin2 == NULL) { - return TCL_ERROR; - } +void +Tk_FreeSavedOptions(savePtr) + Tk_SavedOptions *savePtr; /* Contains options saved in a previous + * call to Tk_SetOptions. */ +{ + int count; + Tk_SavedOption *savedOptionPtr; + + if (savePtr->nextPtr != NULL) { + Tk_FreeSavedOptions(savePtr->nextPtr); + ckfree((char *) savePtr->nextPtr); + } + for (count = savePtr->numItems, + savedOptionPtr = &savePtr->items[savePtr->numItems-1]; + count > 0; count--, savedOptionPtr--) { + if (savedOptionPtr->optionPtr->flags & OPTION_NEEDS_FREEING) { + FreeResources(savedOptionPtr->optionPtr, savedOptionPtr->valuePtr, + (char *) &savedOptionPtr->internalForm, savePtr->tkwin); + } + if (savedOptionPtr->valuePtr != NULL) { + Tcl_DecrRefCount(savedOptionPtr->valuePtr); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tk_FreeConfigOptions -- + * + * Free all resources associated with configuration options. + * + * Results: + * None. + * + * Side effects: + * All of the Tcl_Obj's in recordPtr that are controlled by + * configuration options in optionTable are freed. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +void +Tk_FreeConfigOptions(recordPtr, optionTable, tkwin) + char *recordPtr; /* Record whose fields contain current + * values for options. */ + Tk_OptionTable optionTable; /* Describes legal options. */ + Tk_Window tkwin; /* Window associated with recordPtr; needed + * for freeing some options. */ +{ + OptionTable *tablePtr; + Option *optionPtr; + int count; + Tcl_Obj **oldPtrPtr, *oldPtr; + char *oldInternalPtr; + CONST Tk_OptionSpec *specPtr; + + for (tablePtr = (OptionTable *) optionTable; tablePtr != NULL; + tablePtr = tablePtr->nextPtr) { + for (optionPtr = tablePtr->options, count = tablePtr->numOptions; + count > 0; optionPtr++, count--) { + specPtr = optionPtr->specPtr; + if (specPtr->type == TK_OPTION_SYNONYM) { + continue; + } + if (specPtr->objOffset >= 0) { + oldPtrPtr = (Tcl_Obj **) (recordPtr + specPtr->objOffset); + oldPtr = *oldPtrPtr; + *oldPtrPtr = NULL; + } else { + oldPtr = NULL; + } + if (specPtr->internalOffset >= 0) { + oldInternalPtr = recordPtr + specPtr->internalOffset; + } else { + oldInternalPtr = NULL; + } + if (optionPtr->flags & OPTION_NEEDS_FREEING) { + FreeResources(optionPtr, oldPtr, oldInternalPtr, tkwin); + } + if (oldPtr != NULL) { + Tcl_DecrRefCount(oldPtr); + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * FreeResources -- + * + * Free system resources associated with a configuration option, + * such as colors or fonts. + * + * Results: + * None. + * + * Side effects: + * Any system resources associated with objPtr are released. However, + * objPtr itself is not freed. + * + *---------------------------------------------------------------------- + */ + +static void +FreeResources(optionPtr, objPtr, internalPtr, tkwin) + Option *optionPtr; /* Description of the configuration option. */ + Tcl_Obj *objPtr; /* The current value of the option, specified + * as an object. */ + char *internalPtr; /* A pointer to an internal representation for + * the option's value, such as an int or + * (XColor *). Only valid if + * optionPtr->specPtr->internalOffset >= 0. */ + Tk_Window tkwin; /* The window in which this option is used. */ +{ + int internalFormExists; + + /* + * If there exists an internal form for the value, use it to free + * resources (also zero out the internal form). If there is no + * internal form, then use the object form. + */ + + internalFormExists = optionPtr->specPtr->internalOffset >= 0; + switch (optionPtr->specPtr->type) { + case TK_OPTION_STRING: + if (internalFormExists) { + if (*((char **) internalPtr) != NULL) { + ckfree(*((char **) internalPtr)); + *((char **) internalPtr) = NULL; } - *((Tk_Window *) ptr) = tkwin2; - break; } - case TK_CONFIG_CUSTOM: - if ((*specPtr->customPtr->parseProc)( - specPtr->customPtr->clientData, interp, tkwin, - value, widgRec, specPtr->offset) != TCL_OK) { - return TCL_ERROR; + break; + case TK_OPTION_COLOR: + if (internalFormExists) { + if (*((XColor **) internalPtr) != NULL) { + Tk_FreeColor(*((XColor **) internalPtr)); + *((XColor **) internalPtr) = NULL; } - break; - default: { - sprintf(interp->result, "bad config table: unknown type %d", - specPtr->type); - return TCL_ERROR; + } else if (objPtr != NULL) { + Tk_FreeColorFromObj(tkwin, objPtr); } - } - specPtr++; - } while ((specPtr->argvName == NULL) && (specPtr->type != TK_CONFIG_END)); - return TCL_OK; + break; + case TK_OPTION_FONT: + if (internalFormExists) { + Tk_FreeFont(*((Tk_Font *) internalPtr)); + *((Tk_Font *) internalPtr) = NULL; + } else if (objPtr != NULL) { + Tk_FreeFontFromObj(tkwin, objPtr); + } + break; + case TK_OPTION_BITMAP: + if (internalFormExists) { + if (*((Pixmap *) internalPtr) != None) { + Tk_FreeBitmap(Tk_Display(tkwin), *((Pixmap *) internalPtr)); + *((Pixmap *) internalPtr) = None; + } + } else if (objPtr != NULL) { + Tk_FreeBitmapFromObj(tkwin, objPtr); + } + break; + case TK_OPTION_BORDER: + if (internalFormExists) { + if (*((Tk_3DBorder *) internalPtr) != NULL) { + Tk_Free3DBorder(*((Tk_3DBorder *) internalPtr)); + *((Tk_3DBorder *) internalPtr) = NULL; + } + } else if (objPtr != NULL) { + Tk_Free3DBorderFromObj(tkwin, objPtr); + } + break; + case TK_OPTION_CURSOR: + if (internalFormExists) { + if (*((Tk_Cursor *) internalPtr) != None) { + Tk_FreeCursor(Tk_Display(tkwin), + *((Tk_Cursor *) internalPtr)); + *((Tk_Cursor *) internalPtr) = None; + } + } else if (objPtr != NULL) { + Tk_FreeCursorFromObj(tkwin, objPtr); + } + break; + default: + break; + } } /* *-------------------------------------------------------------- * - * Tk_ConfigureInfo -- + * Tk_GetOptionInfo -- * - * Return information about the configuration options - * for a window, and their current values. + * Returns a list object containing complete information about + * either a single option or all the configuration options in a + * table. * * Results: - * Always returns TCL_OK. Interp->result will be modified - * hold a description of either a single configuration option - * available for "widgRec" via "specs", or all the configuration - * options available. In the "all" case, the result will - * available for "widgRec" via "specs". The result will - * be a list, each of whose entries describes one option. - * Each entry will itself be a list containing the option's - * name for use on command lines, database name, database - * class, default value, and current value (empty string - * if none). For options that are synonyms, the list will - * contain only two values: name and synonym name. If the - * "name" argument is non-NULL, then the only information - * returned is that for the named argument (i.e. the corresponding - * entry in the overall list is returned). + * This procedure normally returns a pointer to an object. + * If namePtr isn't NULL, then the result object is a list with + * five elements: the option's name, its database name, database + * class, default value, and current value. If the option is a + * synonym then the list will contain only two values: the option + * name and the name of the option it refers to. If namePtr is + * NULL, then information is returned for every option in the + * option table: the result will have one sub-list (in the form + * described above) for each option in the table. If an error + * occurs (e.g. because namePtr isn't valid) then NULL is returned + * and an error message will be left in interp's result unless + * interp is NULL. * * Side effects: * None. @@ -581,47 +1625,40 @@ DoConfig(interp, tkwin, specPtr, value, valueIsUid, widgRec) *-------------------------------------------------------------- */ -int -Tk_ConfigureInfo(interp, tkwin, specs, widgRec, argvName, flags) - Tcl_Interp *interp; /* Interpreter for error reporting. */ - Tk_Window tkwin; /* Window corresponding to widgRec. */ - Tk_ConfigSpec *specs; /* Describes legal options. */ - char *widgRec; /* Record whose fields contain current +Tcl_Obj * +Tk_GetOptionInfo(interp, recordPtr, optionTable, namePtr, tkwin) + Tcl_Interp *interp; /* Interpreter for error reporting. If + * NULL, then no error message is created. */ + char *recordPtr; /* Record whose fields contain current * values for options. */ - char *argvName; /* If non-NULL, indicates a single option - * whose info is to be returned. Otherwise - * info is returned for all options. */ - int flags; /* Used to specify additional flags - * that must be present in config specs - * for them to be considered. */ + Tk_OptionTable optionTable; /* Describes all the legal options. */ + Tcl_Obj *namePtr; /* If non-NULL, the string value selects + * a single option whose info is to be + * returned. Otherwise info is returned for + * all options in optionTable. */ + Tk_Window tkwin; /* Window associated with recordPtr; needed + * to compute correct default value for some + * options. */ { - register Tk_ConfigSpec *specPtr; - int needFlags, hateFlags; - char *list; - char *leader = "{"; - - needFlags = flags & ~(TK_CONFIG_USER_BIT - 1); - if (Tk_Depth(tkwin) <= 1) { - hateFlags = TK_CONFIG_COLOR_ONLY; - } else { - hateFlags = TK_CONFIG_MONO_ONLY; - } + Tcl_Obj *resultPtr; + OptionTable *tablePtr = (OptionTable *) optionTable; + Option *optionPtr; + int count; /* * If information is only wanted for a single configuration * spec, then handle that one spec specially. */ - Tcl_SetResult(interp, (char *) NULL, TCL_STATIC); - if (argvName != NULL) { - specPtr = FindConfigSpec(interp, specs, argvName, needFlags, - hateFlags); - if (specPtr == NULL) { - return TCL_ERROR; + if (namePtr != NULL) { + optionPtr = GetOptionFromObj(interp, namePtr, tablePtr); + if (optionPtr == NULL) { + return (Tcl_Obj *) NULL; + } + if (optionPtr->specPtr->type == TK_OPTION_SYNONYM) { + optionPtr = optionPtr->extra.synonymPtr; } - interp->result = FormatConfigInfo(interp, tkwin, specPtr, widgRec); - interp->freeProc = TCL_DYNAMIC; - return TCL_OK; + return GetConfigList(recordPtr, optionPtr, tkwin); } /* @@ -629,29 +1666,21 @@ Tk_ConfigureInfo(interp, tkwin, specs, widgRec, argvName, flags) * their information. */ - for (specPtr = specs; specPtr->type != TK_CONFIG_END; specPtr++) { - if ((argvName != NULL) && (specPtr->argvName != argvName)) { - continue; + resultPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + for (; tablePtr != NULL; tablePtr = tablePtr->nextPtr) { + for (optionPtr = tablePtr->options, count = tablePtr->numOptions; + count > 0; optionPtr++, count--) { + Tcl_ListObjAppendElement(interp, resultPtr, + GetConfigList(recordPtr, optionPtr, tkwin)); } - if (((specPtr->specFlags & needFlags) != needFlags) - || (specPtr->specFlags & hateFlags)) { - continue; - } - if (specPtr->argvName == NULL) { - continue; - } - list = FormatConfigInfo(interp, tkwin, specPtr, widgRec); - Tcl_AppendResult(interp, leader, list, "}", (char *) NULL); - ckfree(list); - leader = " {"; } - return TCL_OK; + return resultPtr; } /* *-------------------------------------------------------------- * - * FormatConfigInfo -- + * GetConfigList -- * * Create a valid Tcl list holding the configuration information * for a single configuration option. @@ -666,67 +1695,78 @@ Tk_ConfigureInfo(interp, tkwin, specs, widgRec, argvName, flags) *-------------------------------------------------------------- */ -static char * -FormatConfigInfo(interp, tkwin, specPtr, widgRec) - Tcl_Interp *interp; /* Interpreter to use for things - * like floating-point precision. */ - Tk_Window tkwin; /* Window corresponding to widget. */ - register Tk_ConfigSpec *specPtr; /* Pointer to information describing - * option. */ - char *widgRec; /* Pointer to record holding current - * values of info for widget. */ +static Tcl_Obj * +GetConfigList(recordPtr, optionPtr, tkwin) + char *recordPtr; /* Pointer to record holding current + * values of configuration options. */ + Option *optionPtr; /* Pointer to information describing a + * particular option. */ + Tk_Window tkwin; /* Window corresponding to recordPtr. */ { - char *argv[6], *result; - char buffer[200]; - Tcl_FreeProc *freeProc = (Tcl_FreeProc *) NULL; - - argv[0] = specPtr->argvName; - argv[1] = specPtr->dbName; - argv[2] = specPtr->dbClass; - argv[3] = specPtr->defValue; - if (specPtr->type == TK_CONFIG_SYNONYM) { - return Tcl_Merge(2, argv); - } - argv[4] = FormatConfigValue(interp, tkwin, specPtr, widgRec, buffer, - &freeProc); - if (argv[1] == NULL) { - argv[1] = ""; - } - if (argv[2] == NULL) { - argv[2] = ""; - } - if (argv[3] == NULL) { - argv[3] = ""; - } - if (argv[4] == NULL) { - argv[4] = ""; - } - result = Tcl_Merge(5, argv); - if (freeProc != NULL) { - if ((freeProc == TCL_DYNAMIC) || (freeProc == (Tcl_FreeProc *) free)) { - ckfree(argv[4]); + Tcl_Obj *listPtr, *elementPtr; + + listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + Tcl_ListObjAppendElement((Tcl_Interp *) NULL, listPtr, + Tcl_NewStringObj(optionPtr->specPtr->optionName, -1)); + + if (optionPtr->specPtr->type == TK_OPTION_SYNONYM) { + elementPtr = Tcl_NewStringObj( + optionPtr->extra.synonymPtr->specPtr->optionName, -1); + Tcl_ListObjAppendElement((Tcl_Interp *) NULL, listPtr, elementPtr); + } else { + if (optionPtr->dbNameUID == NULL) { + elementPtr = Tcl_NewObj(); + } else { + elementPtr = Tcl_NewStringObj(optionPtr->dbNameUID, -1); + } + Tcl_ListObjAppendElement((Tcl_Interp *) NULL, listPtr, elementPtr); + + if (optionPtr->dbClassUID == NULL) { + elementPtr = Tcl_NewObj(); } else { - (*freeProc)(argv[4]); + elementPtr = Tcl_NewStringObj(optionPtr->dbClassUID, -1); } + Tcl_ListObjAppendElement((Tcl_Interp *) NULL, listPtr, elementPtr); + + if ((tkwin != NULL) && ((optionPtr->specPtr->type == TK_OPTION_COLOR) + || (optionPtr->specPtr->type == TK_OPTION_BORDER)) + && (Tk_Depth(tkwin) <= 1) + && (optionPtr->extra.monoColorPtr != NULL)) { + elementPtr = optionPtr->extra.monoColorPtr; + } else if (optionPtr->defaultPtr != NULL) { + elementPtr = optionPtr->defaultPtr; + } else { + elementPtr = Tcl_NewObj(); + } + Tcl_ListObjAppendElement((Tcl_Interp *) NULL, listPtr, elementPtr); + + if (optionPtr->specPtr->objOffset >= 0) { + elementPtr = *((Tcl_Obj **) (recordPtr + + optionPtr->specPtr->objOffset)); + if (elementPtr == NULL) { + elementPtr = Tcl_NewObj(); + } + } else { + elementPtr = GetObjectForOption(recordPtr, optionPtr, tkwin); + } + Tcl_ListObjAppendElement((Tcl_Interp *) NULL, listPtr, elementPtr); } - return result; + return listPtr; } /* *---------------------------------------------------------------------- * - * FormatConfigValue -- + * GetObjectForOption -- * - * This procedure formats the current value of a configuration - * option. + * This procedure is called to create an object that contains the + * value for an option. It is invoked by GetConfigList and + * Tk_GetOptionValue when only the internal form of an option is + * stored in the record. * * Results: - * The return value is the formatted value of the option given - * by specPtr and widgRec. If the value is static, so that it - * need not be freed, *freeProcPtr will be set to NULL; otherwise - * *freeProcPtr will be set to the address of a procedure to - * free the result, and the caller must invoke this procedure - * when it is finished with the result. + * The return value is a pointer to a Tcl object. The caller + * must call Tcl_IncrRefCount on this object to preserve it. * * Side effects: * None. @@ -734,146 +1774,130 @@ FormatConfigInfo(interp, tkwin, specPtr, widgRec) *---------------------------------------------------------------------- */ -static char * -FormatConfigValue(interp, tkwin, specPtr, widgRec, buffer, freeProcPtr) - Tcl_Interp *interp; /* Interpreter for use in real conversions. */ - Tk_Window tkwin; /* Window corresponding to widget. */ - Tk_ConfigSpec *specPtr; /* Pointer to information describing option. - * Must not point to a synonym option. */ - char *widgRec; /* Pointer to record holding current - * values of info for widget. */ - char *buffer; /* Static buffer to use for small values. - * Must have at least 200 bytes of storage. */ - Tcl_FreeProc **freeProcPtr; /* Pointer to word to fill in with address - * of procedure to free the result, or NULL - * if result is static. */ +static Tcl_Obj * +GetObjectForOption(recordPtr, optionPtr, tkwin) + char *recordPtr; /* Pointer to record holding current + * values of configuration options. */ + Option *optionPtr; /* Pointer to information describing an + * option whose internal value is stored + * in *recordPtr. */ + Tk_Window tkwin; /* Window corresponding to recordPtr. */ { - char *ptr, *result; - - *freeProcPtr = NULL; - ptr = widgRec + specPtr->offset; - result = ""; - switch (specPtr->type) { - case TK_CONFIG_BOOLEAN: - if (*((int *) ptr) == 0) { - result = "0"; - } else { - result = "1"; - } + Tcl_Obj *objPtr; + char *internalPtr; /* Points to internal value of option in + * record. */ + + internalPtr = recordPtr + optionPtr->specPtr->internalOffset; + objPtr = NULL; + switch (optionPtr->specPtr->type) { + case TK_OPTION_BOOLEAN: { + objPtr = Tcl_NewIntObj(*((int *) internalPtr)); break; - case TK_CONFIG_INT: - sprintf(buffer, "%d", *((int *) ptr)); - result = buffer; + } + case TK_OPTION_INT: { + objPtr = Tcl_NewIntObj(*((int *) internalPtr)); break; - case TK_CONFIG_DOUBLE: - Tcl_PrintDouble(interp, *((double *) ptr), buffer); - result = buffer; + } + case TK_OPTION_DOUBLE: { + objPtr = Tcl_NewDoubleObj(*((double *) internalPtr)); break; - case TK_CONFIG_STRING: - result = (*(char **) ptr); - if (result == NULL) { - result = ""; - } + } + case TK_OPTION_STRING: { + objPtr = Tcl_NewStringObj(*((char **) internalPtr), -1); break; - case TK_CONFIG_UID: { - Tk_Uid uid = *((Tk_Uid *) ptr); - if (uid != NULL) { - result = uid; - } + } + case TK_OPTION_STRING_TABLE: { + objPtr = Tcl_NewStringObj( + ((char **) optionPtr->specPtr->clientData)[ + *((int *) internalPtr)], -1); break; } - case TK_CONFIG_COLOR: { - XColor *colorPtr = *((XColor **) ptr); + case TK_OPTION_COLOR: { + XColor *colorPtr = *((XColor **) internalPtr); if (colorPtr != NULL) { - result = Tk_NameOfColor(colorPtr); + objPtr = Tcl_NewStringObj(Tk_NameOfColor(colorPtr), -1); } break; } - case TK_CONFIG_FONT: { - Tk_Font tkfont = *((Tk_Font *) ptr); + case TK_OPTION_FONT: { + Tk_Font tkfont = *((Tk_Font *) internalPtr); if (tkfont != NULL) { - result = Tk_NameOfFont(tkfont); + objPtr = Tcl_NewStringObj(Tk_NameOfFont(tkfont), -1); } break; } - case TK_CONFIG_BITMAP: { - Pixmap pixmap = *((Pixmap *) ptr); + case TK_OPTION_BITMAP: { + Pixmap pixmap = *((Pixmap *) internalPtr); if (pixmap != None) { - result = Tk_NameOfBitmap(Tk_Display(tkwin), pixmap); + objPtr = Tcl_NewStringObj(Tk_NameOfBitmap(Tk_Display(tkwin), + pixmap), -1); } break; } - case TK_CONFIG_BORDER: { - Tk_3DBorder border = *((Tk_3DBorder *) ptr); + case TK_OPTION_BORDER: { + Tk_3DBorder border = *((Tk_3DBorder *) internalPtr); if (border != NULL) { - result = Tk_NameOf3DBorder(border); + objPtr = Tcl_NewStringObj(Tk_NameOf3DBorder(border), -1); } break; } - case TK_CONFIG_RELIEF: - result = Tk_NameOfRelief(*((int *) ptr)); + case TK_OPTION_RELIEF: { + objPtr = Tcl_NewStringObj(Tk_NameOfRelief( + *((int *) internalPtr)), -1); break; - case TK_CONFIG_CURSOR: - case TK_CONFIG_ACTIVE_CURSOR: { - Tk_Cursor cursor = *((Tk_Cursor *) ptr); + } + case TK_OPTION_CURSOR: { + Tk_Cursor cursor = *((Tk_Cursor *) internalPtr); if (cursor != None) { - result = Tk_NameOfCursor(Tk_Display(tkwin), cursor); + objPtr = Tcl_NewStringObj( + Tk_NameOfCursor(Tk_Display(tkwin), cursor), -1); } break; } - case TK_CONFIG_JUSTIFY: - result = Tk_NameOfJustify(*((Tk_Justify *) ptr)); + case TK_OPTION_JUSTIFY: { + objPtr = Tcl_NewStringObj(Tk_NameOfJustify( + *((Tk_Justify *) internalPtr)), -1); break; - case TK_CONFIG_ANCHOR: - result = Tk_NameOfAnchor(*((Tk_Anchor *) ptr)); - break; - case TK_CONFIG_CAP_STYLE: - result = Tk_NameOfCapStyle(*((int *) ptr)); - break; - case TK_CONFIG_JOIN_STYLE: - result = Tk_NameOfJoinStyle(*((int *) ptr)); - break; - case TK_CONFIG_PIXELS: - sprintf(buffer, "%d", *((int *) ptr)); - result = buffer; + } + case TK_OPTION_ANCHOR: { + objPtr = Tcl_NewStringObj(Tk_NameOfAnchor( + *((Tk_Anchor *) internalPtr)), -1); break; - case TK_CONFIG_MM: - Tcl_PrintDouble(interp, *((double *) ptr), buffer); - result = buffer; + } + case TK_OPTION_PIXELS: { + objPtr = Tcl_NewIntObj(*((int *) internalPtr)); break; - case TK_CONFIG_WINDOW: { - Tk_Window tkwin; - - tkwin = *((Tk_Window *) ptr); + } + case TK_OPTION_WINDOW: { + Tk_Window tkwin = *((Tk_Window *) internalPtr); if (tkwin != NULL) { - result = Tk_PathName(tkwin); + objPtr = Tcl_NewStringObj(Tk_PathName(tkwin), -1); } break; } - case TK_CONFIG_CUSTOM: - result = (*specPtr->customPtr->printProc)( - specPtr->customPtr->clientData, tkwin, widgRec, - specPtr->offset, freeProcPtr); - break; - default: - result = "?? unknown type ??"; + default: { + panic("bad option type in GetObjectForOption"); + } + } + if (objPtr == NULL) { + objPtr = Tcl_NewObj(); } - return result; + return objPtr; } /* *---------------------------------------------------------------------- * - * Tk_ConfigureValue -- + * Tk_GetOptionValue -- * * This procedure returns the current value of a configuration - * option for a widget. + * option. * * Results: - * The return value is a standard Tcl completion code (TCL_OK or - * TCL_ERROR). Interp->result will be set to hold either the value - * of the option given by argvName (if TCL_OK is returned) or - * an error message (if TCL_ERROR is returned). + * The return value is the object holding the current value of + * the option given by namePtr. If no such option exists, then + * the return value is NULL and an error message is left in + * interp's result (if interp isn't NULL). * * Side effects: * None. @@ -881,110 +1905,113 @@ FormatConfigValue(interp, tkwin, specPtr, widgRec, buffer, freeProcPtr) *---------------------------------------------------------------------- */ -int -Tk_ConfigureValue(interp, tkwin, specs, widgRec, argvName, flags) - Tcl_Interp *interp; /* Interpreter for error reporting. */ - Tk_Window tkwin; /* Window corresponding to widgRec. */ - Tk_ConfigSpec *specs; /* Describes legal options. */ - char *widgRec; /* Record whose fields contain current +Tcl_Obj * +Tk_GetOptionValue(interp, recordPtr, optionTable, namePtr, tkwin) + Tcl_Interp *interp; /* Interpreter for error reporting. If + * NULL then no messages are provided for + * errors. */ + char *recordPtr; /* Record whose fields contain current * values for options. */ - char *argvName; /* Gives the command-line name for the + Tk_OptionTable optionTable; /* Describes legal options. */ + Tcl_Obj *namePtr; /* Gives the command-line name for the * option whose value is to be returned. */ - int flags; /* Used to specify additional flags - * that must be present in config specs - * for them to be considered. */ + Tk_Window tkwin; /* Window corresponding to recordPtr. */ { - Tk_ConfigSpec *specPtr; - int needFlags, hateFlags; + OptionTable *tablePtr = (OptionTable *) optionTable; + Option *optionPtr; + Tcl_Obj *resultPtr; - needFlags = flags & ~(TK_CONFIG_USER_BIT - 1); - if (Tk_Depth(tkwin) <= 1) { - hateFlags = TK_CONFIG_COLOR_ONLY; - } else { - hateFlags = TK_CONFIG_MONO_ONLY; + optionPtr = GetOptionFromObj(interp, namePtr, tablePtr); + if (optionPtr == NULL) { + return NULL; } - specPtr = FindConfigSpec(interp, specs, argvName, needFlags, hateFlags); - if (specPtr == NULL) { - return TCL_ERROR; + if (optionPtr->specPtr->type == TK_OPTION_SYNONYM) { + optionPtr = optionPtr->extra.synonymPtr; } - interp->result = FormatConfigValue(interp, tkwin, specPtr, widgRec, - interp->result, &interp->freeProc); - return TCL_OK; + if (optionPtr->specPtr->objOffset >= 0) { + resultPtr = *((Tcl_Obj **) (recordPtr + optionPtr->specPtr->objOffset)); + if (resultPtr == NULL) { + /* + * This option has a null value and is represented by a null + * object pointer. We can't return the null pointer, since that + * would indicate an error. Instead, return a new empty object. + */ + + resultPtr = Tcl_NewObj(); + } + } else { + resultPtr = GetObjectForOption(recordPtr, optionPtr, tkwin); + } + return resultPtr; } /* *---------------------------------------------------------------------- * - * Tk_FreeOptions -- + * TkDebugConfig -- * - * Free up all resources associated with configuration options. + * This is a debugging procedure that returns information about + * one of the configuration tables that currently exists for an + * interpreter. * * Results: - * None. + * If the specified table exists in the given interpreter, then a + * list is returned describing the table and any other tables that + * it chains to: for each table there will be three list elements + * giving the reference count for the table, the number of elements + * in the table, and the command-line name for the first option + * in the table. If the table doesn't exist in the interpreter + * then an empty object is returned. The reference count for the + * returned object is 0. * * Side effects: - * Any resource in widgRec that is controlled by a configuration - * option (e.g. a Tk_3DBorder or XColor) is freed in the appropriate - * fashion. + * None. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ -void -Tk_FreeOptions(specs, widgRec, display, needFlags) - Tk_ConfigSpec *specs; /* Describes legal options. */ - char *widgRec; /* Record whose fields contain current - * values for options. */ - Display *display; /* X display; needed for freeing some - * resources. */ - int needFlags; /* Used to specify additional flags - * that must be present in config specs - * for them to be considered. */ +Tcl_Obj * +TkDebugConfig(interp, table) + Tcl_Interp *interp; /* Interpreter in which the table is + * defined. */ + Tk_OptionTable table; /* Table about which information is to + * be returned. May not necessarily + * exist in the interpreter anymore. */ { - register Tk_ConfigSpec *specPtr; - char *ptr; + OptionTable *tablePtr = (OptionTable *) table; + Tcl_HashTable *hashTablePtr; + Tcl_HashEntry *hashEntryPtr; + Tcl_HashSearch search; + Tcl_Obj *objPtr; - for (specPtr = specs; specPtr->type != TK_CONFIG_END; specPtr++) { - if ((specPtr->specFlags & needFlags) != needFlags) { - continue; - } - ptr = widgRec + specPtr->offset; - switch (specPtr->type) { - case TK_CONFIG_STRING: - if (*((char **) ptr) != NULL) { - ckfree(*((char **) ptr)); - *((char **) ptr) = NULL; - } - break; - case TK_CONFIG_COLOR: - if (*((XColor **) ptr) != NULL) { - Tk_FreeColor(*((XColor **) ptr)); - *((XColor **) ptr) = NULL; - } - break; - case TK_CONFIG_FONT: - Tk_FreeFont(*((Tk_Font *) ptr)); - *((Tk_Font *) ptr) = NULL; - break; - case TK_CONFIG_BITMAP: - if (*((Pixmap *) ptr) != None) { - Tk_FreeBitmap(display, *((Pixmap *) ptr)); - *((Pixmap *) ptr) = None; - } - break; - case TK_CONFIG_BORDER: - if (*((Tk_3DBorder *) ptr) != NULL) { - Tk_Free3DBorder(*((Tk_3DBorder *) ptr)); - *((Tk_3DBorder *) ptr) = NULL; - } - break; - case TK_CONFIG_CURSOR: - case TK_CONFIG_ACTIVE_CURSOR: - if (*((Tk_Cursor *) ptr) != None) { - Tk_FreeCursor(display, *((Tk_Cursor *) ptr)); - *((Tk_Cursor *) ptr) = None; - } + objPtr = Tcl_NewObj(); + hashTablePtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, OPTION_HASH_KEY, + NULL); + if (hashTablePtr == NULL) { + return objPtr; + } + + /* + * Scan all the tables for this interpreter to make sure that the + * one we want still is valid. + */ + + for (hashEntryPtr = Tcl_FirstHashEntry(hashTablePtr, &search); + hashEntryPtr != NULL; + hashEntryPtr = Tcl_NextHashEntry(&search)) { + if (tablePtr == (OptionTable *) Tcl_GetHashValue(hashEntryPtr)) { + for ( ; tablePtr != NULL; tablePtr = tablePtr->nextPtr) { + Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr, + Tcl_NewIntObj(tablePtr->refCount)); + Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr, + Tcl_NewIntObj(tablePtr->numOptions)); + Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr, + Tcl_NewStringObj( + tablePtr->options[0].specPtr->optionName, + -1)); + } + break; } } + return objPtr; } diff --git a/generic/tkConsole.c b/generic/tkConsole.c index c213371..6c721e5 100644 --- a/generic/tkConsole.c +++ b/generic/tkConsole.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkConsole.c 1.54 97/10/17 10:46:08 + * SCCS: @(#) tkConsole.c 1.55 98/01/02 17:40:37 */ #include "tk.h" @@ -29,6 +29,8 @@ typedef struct ConsoleInfo { static Tcl_Interp *gStdoutInterp = NULL; +EXTERN void TclInitSubsystems _ANSI_ARGS_((CONST char *argv0)); + /* * Forward declarations for procedures defined later in this file: * @@ -100,11 +102,14 @@ TkConsoleCreate() { Tcl_Channel consoleChannel; + TclInitSubsystems(NULL); + consoleChannel = Tcl_CreateChannel(&consoleChannelType, "console0", (ClientData) TCL_STDIN, TCL_READABLE); if (consoleChannel != NULL) { Tcl_SetChannelOption(NULL, consoleChannel, "-translation", "lf"); Tcl_SetChannelOption(NULL, consoleChannel, "-buffering", "none"); + Tcl_SetChannelOption(NULL, consoleChannel, "-encoding", "utf-8"); } Tcl_SetStdChannel(consoleChannel, TCL_STDIN); consoleChannel = Tcl_CreateChannel(&consoleChannelType, "console1", @@ -112,6 +117,7 @@ TkConsoleCreate() if (consoleChannel != NULL) { Tcl_SetChannelOption(NULL, consoleChannel, "-translation", "lf"); Tcl_SetChannelOption(NULL, consoleChannel, "-buffering", "none"); + Tcl_SetChannelOption(NULL, consoleChannel, "-encoding", "utf-8"); } Tcl_SetStdChannel(consoleChannel, TCL_STDOUT); consoleChannel = Tcl_CreateChannel(&consoleChannelType, "console2", @@ -119,6 +125,7 @@ TkConsoleCreate() if (consoleChannel != NULL) { Tcl_SetChannelOption(NULL, consoleChannel, "-translation", "lf"); Tcl_SetChannelOption(NULL, consoleChannel, "-buffering", "none"); + Tcl_SetChannelOption(NULL, consoleChannel, "-encoding", "utf-8"); } Tcl_SetStdChannel(consoleChannel, TCL_STDERR); } diff --git a/generic/tkCursor.c b/generic/tkCursor.c index e185109..9a8f971 100644 --- a/generic/tkCursor.c +++ b/generic/tkCursor.c @@ -6,12 +6,12 @@ * also avoids round-trips to the X server. * * Copyright (c) 1990-1994 The Regents of the University of California. - * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkCursor.c 1.27 96/02/15 18:52:40 + * SCCS: @(#) tkCursor.c 1.35 98/01/19 11:50:15 */ #include "tkPort.h" @@ -25,16 +25,11 @@ */ /* - * Hash table to map from a textual description of a cursor to the - * TkCursor record for the cursor, and key structure used in that - * hash table: + * Hash table to map from a string name for a cursor to the TkCursor + * record for the cursor: */ static Tcl_HashTable nameTable; -typedef struct { - Tk_Uid name; /* Textual name for desired cursor. */ - Display *display; /* Display for which cursor will be used. */ -} NameKey; /* * Hash table to map from a collection of in-core data about a @@ -71,6 +66,125 @@ static int initialized = 0; /* 0 means static structures haven't been */ static void CursorInit _ANSI_ARGS_((void)); +static void DupCursorObjProc _ANSI_ARGS_((Tcl_Obj *srcObjPtr, + Tcl_Obj *dupObjPtr)); +static void FreeCursor _ANSI_ARGS_((TkCursor *cursorPtr)); +static void FreeCursorObjProc _ANSI_ARGS_((Tcl_Obj *objPtr)); +static TkCursor * GetCursor _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, char *name)); +static TkCursor * GetCursorFromObj _ANSI_ARGS_((Tk_Window tkwin, + Tcl_Obj *objPtr)); +static void InitCursorObj _ANSI_ARGS_((Tcl_Obj *objPtr)); + +/* + * The following structure defines the implementation of the "cursor" Tcl + * object, used for drawing. The color object remembers the hash table + * entry associated with a color. The actual allocation and deallocation + * of the color should be done by the configuration package when the cursor + * option is set. + */ + +static Tcl_ObjType cursorObjType = { + "cursor", /* name */ + FreeCursorObjProc, /* freeIntRepProc */ + DupCursorObjProc, /* dupIntRepProc */ + NULL, /* updateStringProc */ + NULL /* setFromAnyProc */ +}; + +/* + *---------------------------------------------------------------------- + * + * Tk_AllocCursorFromObj -- + * + * Given a Tcl_Obj *, map the value to a corresponding + * Tk_Cursor structure based on the tkwin given. + * + * Results: + * The return value is the X identifer for the desired cursor, + * unless objPtr couldn't be parsed correctly. In this case, + * None is returned and an error message is left in the interp's result. + * The caller should never modify the cursor that is returned, and + * should eventually call Tk_FreeCursorFromObj when the cursor is no + * longer needed. + * + * Side effects: + * The cursor is added to an internal database with a reference count. + * For each call to this procedure, there should eventually be a call + * to Tk_FreeCursorFromObj, so that the database can be cleaned up + * when cursors aren't needed anymore. + * + *---------------------------------------------------------------------- + */ + +Tk_Cursor +Tk_AllocCursorFromObj(interp, tkwin, objPtr) + Tcl_Interp *interp; /* Interp for error results. */ + Tk_Window tkwin; /* Window in which the cursor will be used.*/ + Tcl_Obj *objPtr; /* Object describing cursor; see manual + * entry for description of legal + * syntax of this obj's string rep. */ +{ + TkCursor *cursorPtr; + + if (objPtr->typePtr != &cursorObjType) { + InitCursorObj(objPtr); + } + cursorPtr = (TkCursor *) objPtr->internalRep.twoPtrValue.ptr1; + + /* + * If the object currently points to a TkCursor, see if it's the + * one we want. If so, increment its reference count and return. + */ + + if (cursorPtr != NULL) { + if (cursorPtr->resourceRefCount == 0) { + /* + * This is a stale reference: it refers to a TkCursor that's + * no longer in use. Clear the reference. + */ + FreeCursorObjProc(objPtr); + cursorPtr = NULL; + } else if (Tk_Display(tkwin) == cursorPtr->display) { + cursorPtr->resourceRefCount++; + return cursorPtr->cursor; + } + } + + /* + * The object didn't point to the TkCursor that we wanted. Search + * the list of TkCursors with the same name to see if one of the + * other TkCursors is the right one. + */ + + if (cursorPtr != NULL) { + TkCursor *firstCursorPtr = + (TkCursor *) Tcl_GetHashValue(cursorPtr->hashPtr); + FreeCursorObjProc(objPtr); + for (cursorPtr = firstCursorPtr; cursorPtr != NULL; + cursorPtr = cursorPtr->nextPtr) { + if (Tk_Display(tkwin) == cursorPtr->display) { + cursorPtr->resourceRefCount++; + cursorPtr->objRefCount++; + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) cursorPtr; + return cursorPtr->cursor; + } + } + } + + /* + * Still no luck. Call GetCursor to allocate a new TkCursor object. + */ + + cursorPtr = GetCursor(interp, tkwin, Tcl_GetString(objPtr)); + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) cursorPtr; + if (cursorPtr == NULL) { + return None; + } else { + cursorPtr->objRefCount++; + return cursorPtr->cursor; + } +} /* *---------------------------------------------------------------------- @@ -83,7 +197,7 @@ static void CursorInit _ANSI_ARGS_((void)); * Results: * The return value is the X identifer for the desired cursor, * unless string couldn't be parsed correctly. In this case, - * None is returned and an error message is left in interp->result. + * None is returned and an error message is left in the interp's result. * The caller should never modify the cursor that is returned, and * should eventually call Tk_FreeCursor when the cursor is no longer * needed. @@ -101,52 +215,104 @@ Tk_Cursor Tk_GetCursor(interp, tkwin, string) 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 + char *string; /* Description of cursor. See manual entry + * for details on legal syntax. */ +{ + TkCursor *cursorPtr = GetCursor(interp, tkwin, string); + if (cursorPtr == NULL) { + return None; + } + return cursorPtr->cursor; +} + +/* + *---------------------------------------------------------------------- + * + * GetCursor -- + * + * Given a string describing a cursor, locate (or create if necessary) + * a cursor that fits the description. This routine returns the + * internal data structure for the cursor, which avoids extra + * hash table lookups in Tk_AllocCursorFromObj. + * + * Results: + * The return value is a pointer to the TkCursor for the desired + * cursor, unless string couldn't be parsed correctly. In this + * case, NULL is returned and an error message is left in the + * interp's result. The caller should never modify the cursor that + * is returned, and should eventually call Tk_FreeCursor when the + * cursor is no longer needed. + * + * Side effects: + * The cursor is added to an internal database with a reference count. + * For each call to this procedure, there should eventually be a call + * to Tk_FreeCursor, so that the database can be cleaned up when cursors + * aren't needed anymore. + * + *---------------------------------------------------------------------- + */ + +static TkCursor * +GetCursor(interp, tkwin, string) + Tcl_Interp *interp; /* Interpreter to use for error reporting. */ + Tk_Window tkwin; /* Window in which cursor will be used. */ + char *string; /* Description of cursor. See manual entry * for details on legal syntax. */ { - NameKey nameKey; IdKey idKey; - Tcl_HashEntry *nameHashPtr, *idHashPtr; + Tcl_HashEntry *nameHashPtr; register TkCursor *cursorPtr; + TkCursor *existingCursorPtr = NULL; int new; if (!initialized) { CursorInit(); } - nameKey.name = string; - nameKey.display = Tk_Display(tkwin); - nameHashPtr = Tcl_CreateHashEntry(&nameTable, (char *) &nameKey, &new); + nameHashPtr = Tcl_CreateHashEntry(&nameTable, string, &new); if (!new) { - cursorPtr = (TkCursor *) Tcl_GetHashValue(nameHashPtr); - cursorPtr->refCount++; - return cursorPtr->cursor; + existingCursorPtr = (TkCursor *) Tcl_GetHashValue(nameHashPtr); + for (cursorPtr = existingCursorPtr; cursorPtr != NULL; + cursorPtr = cursorPtr->nextPtr) { + if (Tk_Display(tkwin) == cursorPtr->display) { + cursorPtr->resourceRefCount++; + return cursorPtr; + } + } + } else { + existingCursorPtr = NULL; } cursorPtr = TkGetCursorByName(interp, tkwin, string); if (cursorPtr == NULL) { - Tcl_DeleteHashEntry(nameHashPtr); - return None; + if (new) { + Tcl_DeleteHashEntry(nameHashPtr); + } + return NULL; } /* * Add information about this cursor to our database. */ - cursorPtr->refCount = 1; + cursorPtr->display = Tk_Display(tkwin); + cursorPtr->resourceRefCount = 1; + cursorPtr->objRefCount = 0; cursorPtr->otherTable = &nameTable; cursorPtr->hashPtr = nameHashPtr; - idKey.display = nameKey.display; + idKey.display = Tk_Display(tkwin); idKey.cursor = cursorPtr->cursor; - idHashPtr = Tcl_CreateHashEntry(&idTable, (char *) &idKey, &new); + cursorPtr->idHashPtr = Tcl_CreateHashEntry(&idTable, (char *) &idKey, + &new); if (!new) { panic("cursor already registered in Tk_GetCursor"); } + cursorPtr->nextPtr = existingCursorPtr; Tcl_SetHashValue(nameHashPtr, cursorPtr); - Tcl_SetHashValue(idHashPtr, cursorPtr); + Tcl_SetHashValue(cursorPtr->idHashPtr, cursorPtr); - return cursorPtr->cursor; + return cursorPtr; } /* @@ -160,7 +326,7 @@ Tk_GetCursor(interp, tkwin, string) * Results: * The return value is the X identifer for the desired cursor, * unless it couldn't be created properly. In this case, None is - * returned and an error message is left in interp->result. The + * returned and an error message is left in the interp's result. The * caller should never modify the cursor that is returned, and * should eventually call Tk_FreeCursor when the cursor is no * longer needed. @@ -188,7 +354,7 @@ Tk_GetCursorFromData(interp, tkwin, source, mask, width, height, { DataKey dataKey; IdKey idKey; - Tcl_HashEntry *dataHashPtr, *idHashPtr; + Tcl_HashEntry *dataHashPtr; register TkCursor *cursorPtr; int new; XColor fgColor, bgColor; @@ -209,7 +375,7 @@ Tk_GetCursorFromData(interp, tkwin, source, mask, width, height, dataHashPtr = Tcl_CreateHashEntry(&dataTable, (char *) &dataKey, &new); if (!new) { cursorPtr = (TkCursor *) Tcl_GetHashValue(dataHashPtr); - cursorPtr->refCount++; + cursorPtr->resourceRefCount++; return cursorPtr->cursor; } @@ -236,17 +402,19 @@ Tk_GetCursorFromData(interp, tkwin, source, mask, width, height, goto error; } - cursorPtr->refCount = 1; + cursorPtr->resourceRefCount = 1; cursorPtr->otherTable = &dataTable; cursorPtr->hashPtr = dataHashPtr; + cursorPtr->objRefCount = 0; idKey.display = dataKey.display; idKey.cursor = cursorPtr->cursor; - idHashPtr = Tcl_CreateHashEntry(&idTable, (char *) &idKey, &new); + cursorPtr->idHashPtr = Tcl_CreateHashEntry(&idTable, (char *) &idKey, + &new); if (!new) { panic("cursor already registered in Tk_GetCursorFromData"); } Tcl_SetHashValue(dataHashPtr, cursorPtr); - Tcl_SetHashValue(idHashPtr, cursorPtr); + Tcl_SetHashValue(cursorPtr->idHashPtr, cursorPtr); return cursorPtr->cursor; error: @@ -301,7 +469,57 @@ Tk_NameOfCursor(display, cursor) if (cursorPtr->otherTable != &nameTable) { goto printid; } - return ((NameKey *) cursorPtr->hashPtr->key.words)->name; + return cursorPtr->hashPtr->key.string; +} + +/* + *---------------------------------------------------------------------- + * + * FreeCursor -- + * + * This procedure is invoked by both Tk_FreeCursor and + * Tk_FreeCursorFromObj; it does all the real work of deallocating + * a cursor. + * + * Results: + * None. + * + * Side effects: + * The reference count associated with cursor is decremented, and + * it is officially deallocated if no-one is using it anymore. + * + *---------------------------------------------------------------------- + */ + +static void +FreeCursor(cursorPtr) + TkCursor *cursorPtr; /* Cursor to be released. */ +{ + TkCursor *prevPtr; + + cursorPtr->resourceRefCount--; + if (cursorPtr->resourceRefCount > 0) { + return; + } + + Tcl_DeleteHashEntry(cursorPtr->idHashPtr); + prevPtr = (TkCursor *) Tcl_GetHashValue(cursorPtr->hashPtr); + if (prevPtr == cursorPtr) { + if (cursorPtr->nextPtr == NULL) { + Tcl_DeleteHashEntry(cursorPtr->hashPtr); + } else { + Tcl_SetHashValue(cursorPtr->hashPtr, cursorPtr->nextPtr); + } + } else { + while (prevPtr->nextPtr != cursorPtr) { + prevPtr = prevPtr->nextPtr; + } + prevPtr->nextPtr = cursorPtr->nextPtr; + } + TkpFreeCursor(cursorPtr); + if (cursorPtr->objRefCount == 0) { + ckfree((char *) cursorPtr); + } } /* @@ -329,7 +547,6 @@ Tk_FreeCursor(display, cursor) { IdKey idKey; Tcl_HashEntry *idHashPtr; - register TkCursor *cursorPtr; if (!initialized) { panic("Tk_FreeCursor called before Tk_GetCursor"); @@ -341,18 +558,245 @@ Tk_FreeCursor(display, cursor) if (idHashPtr == NULL) { panic("Tk_FreeCursor received unknown cursor argument"); } - cursorPtr = (TkCursor *) Tcl_GetHashValue(idHashPtr); - cursorPtr->refCount--; - if (cursorPtr->refCount == 0) { - Tcl_DeleteHashEntry(cursorPtr->hashPtr); - Tcl_DeleteHashEntry(idHashPtr); - TkFreeCursor(cursorPtr); + FreeCursor((TkCursor *) Tcl_GetHashValue(idHashPtr)); +} + +/* + *---------------------------------------------------------------------- + * + * Tk_FreeCursorFromObj -- + * + * This procedure is called to release a cursor allocated by + * Tk_AllocCursorFromObj. It does not throw away the Tcl_Obj *; + * it only gets rid of the hash table entry for this cursor + * and clears the cached value that is normally stored in the object. + * + * Results: + * None. + * + * Side effects: + * The reference count associated with the cursor represented by + * objPtr is decremented, and the cursor is released to X if there are + * no remaining uses for it. + * + *---------------------------------------------------------------------- + */ + +void +Tk_FreeCursorFromObj(tkwin, objPtr) + Tk_Window tkwin; /* The window this cursor lives in. Needed + * for the display value. */ + Tcl_Obj *objPtr; /* The Tcl_Obj * to be freed. */ +{ + FreeCursor(GetCursorFromObj(tkwin, objPtr)); +} + +/* + *--------------------------------------------------------------------------- + * + * FreeCursorFromObjProc -- + * + * This proc is called to release an object reference to a cursor. + * Called when the object's internal rep is released or when + * the cached tkColPtr needs to be changed. + * + * Results: + * None. + * + * Side effects: + * The object reference count is decremented. When both it + * and the hash ref count go to zero, the color's resources + * are released. + * + *--------------------------------------------------------------------------- + */ + +static void +FreeCursorObjProc(objPtr) + Tcl_Obj *objPtr; /* The object we are releasing. */ +{ + TkCursor *cursorPtr = (TkCursor *) objPtr->internalRep.twoPtrValue.ptr1; + + if (cursorPtr != NULL) { + cursorPtr->objRefCount--; + if ((cursorPtr->objRefCount == 0) + && (cursorPtr->resourceRefCount == 0)) { + ckfree((char *) cursorPtr); + } + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) NULL; + } +} + +/* + *--------------------------------------------------------------------------- + * + * DupCursorObjProc -- + * + * When a cached cursor object is duplicated, this is called to + * update the internal reps. + * + * Results: + * None. + * + * Side effects: + * The color's objRefCount is incremented and the internal rep + * of the copy is set to point to it. + * + *--------------------------------------------------------------------------- + */ + +static void +DupCursorObjProc(srcObjPtr, dupObjPtr) + Tcl_Obj *srcObjPtr; /* The object we are copying from. */ + Tcl_Obj *dupObjPtr; /* The object we are copying to. */ +{ + TkCursor *cursorPtr = (TkCursor *) srcObjPtr->internalRep.twoPtrValue.ptr1; + + dupObjPtr->typePtr = srcObjPtr->typePtr; + dupObjPtr->internalRep.twoPtrValue.ptr1 = (VOID *) cursorPtr; + + if (cursorPtr != NULL) { + cursorPtr->objRefCount++; } } /* *---------------------------------------------------------------------- * + * Tk_GetCursorFromObj -- + * + * Returns the cursor referred to buy a Tcl object. The cursor must + * already have been allocated via a call to Tk_AllocCursorFromObj or + * Tk_GetCursor. + * + * Results: + * Returns the Tk_Cursor that matches the tkwin and the string rep + * of the name of the cursor given in objPtr. + * + * Side effects: + * If the object is not already a cursor, the conversion will free + * any old internal representation. + * + *---------------------------------------------------------------------- + */ + +Tk_Cursor +Tk_GetCursorFromObj(tkwin, objPtr) + Tk_Window tkwin; + Tcl_Obj *objPtr; /* The object from which to get pixels. */ +{ + TkCursor *cursorPtr = GetCursorFromObj(tkwin, objPtr); + return cursorPtr->cursor; +} + +/* + *---------------------------------------------------------------------- + * + * GetCursorFromObj -- + * + * Returns the cursor referred to by a Tcl object. The cursor must + * already have been allocated via a call to Tk_AllocCursorFromObj + * or Tk_GetCursor. + * + * Results: + * Returns the TkCursor * that matches the tkwin and the string rep + * of the name of the cursor given in objPtr. + * + * Side effects: + * If the object is not already a cursor, the conversion will free + * any old internal representation. + * + *---------------------------------------------------------------------- + */ + +static TkCursor * +GetCursorFromObj(tkwin, objPtr) + Tk_Window tkwin; /* Window in which the cursor will be used. */ + Tcl_Obj *objPtr; /* The object that describes the desired + * cursor. */ +{ + TkCursor *cursorPtr; + Tcl_HashEntry *hashPtr; + + if (objPtr->typePtr != &cursorObjType) { + InitCursorObj(objPtr); + } + + cursorPtr = (TkCursor *) objPtr->internalRep.twoPtrValue.ptr1; + if (cursorPtr != NULL) { + if (Tk_Display(tkwin) == cursorPtr->display) { + return cursorPtr; + } + hashPtr = cursorPtr->hashPtr; + } else { + hashPtr = Tcl_FindHashEntry(&nameTable, Tcl_GetString(objPtr)); + if (hashPtr == NULL) { + goto error; + } + } + + /* + * At this point we've got a hash table entry, off of which hang + * one or more TkCursor structures. See if any of them will work. + */ + + for (cursorPtr = (TkCursor *) Tcl_GetHashValue(hashPtr); + cursorPtr != NULL; cursorPtr = cursorPtr->nextPtr) { + if (Tk_Display(tkwin) != cursorPtr->display) { + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) cursorPtr; + cursorPtr->objRefCount++; + return cursorPtr; + } + } + + error: + panic("GetCursorFromObj called with non-existent cursor!"); + /* + * The following code isn't reached; it's just there to please compilers. + */ + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * InitCursorObj -- + * + * Bookeeping procedure to change an objPtr to a cursor type. + * + * Results: + * None. + * + * Side effects: + * The old internal rep of the object is freed. The internal + * rep is cleared. The final form of the object is set + * by either Tk_AllocCursorFromObj or GetCursorFromObj. + * + *---------------------------------------------------------------------- + */ + +static void +InitCursorObj(objPtr) + Tcl_Obj *objPtr; /* The object to convert. */ +{ + Tcl_ObjType *typePtr; + + /* + * Free the old internalRep before setting the new one. + */ + + Tcl_GetString(objPtr); + typePtr = objPtr->typePtr; + if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { + (*typePtr->freeIntRepProc)(objPtr); + } + objPtr->typePtr = &cursorObjType; + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) NULL; +} + +/* + *---------------------------------------------------------------------- + * * CursorInit -- * * Initialize the structures used for cursor management. @@ -370,7 +814,7 @@ static void CursorInit() { initialized = 1; - Tcl_InitHashTable(&nameTable, sizeof(NameKey)/sizeof(int)); + Tcl_InitHashTable(&nameTable, TCL_STRING_KEYS); Tcl_InitHashTable(&dataTable, sizeof(DataKey)/sizeof(int)); /* @@ -382,3 +826,51 @@ CursorInit() Tcl_InitHashTable(&idTable, (sizeof(Display *) + sizeof(Tk_Cursor)) /sizeof(int)); } + +/* + *---------------------------------------------------------------------- + * + * TkDebugCursor -- + * + * This procedure returns debugging information about a cursor. + * + * Results: + * The return value is a list with one sublist for each TkCursor + * corresponding to "name". Each sublist has two elements that + * contain the resourceRefCount and objRefCount fields from the + * TkCursor structure. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TkDebugCursor(tkwin, name) + Tk_Window tkwin; /* The window in which the cursor will be + * used (not currently used). */ + char *name; /* Name of the desired color. */ +{ + TkCursor *cursorPtr; + Tcl_HashEntry *hashPtr; + Tcl_Obj *resultPtr, *objPtr; + + resultPtr = Tcl_NewObj(); + hashPtr = Tcl_FindHashEntry(&nameTable, name); + if (hashPtr != NULL) { + cursorPtr = (TkCursor *) Tcl_GetHashValue(hashPtr); + if (cursorPtr == NULL) { + panic("TkDebugCursor found empty hash table entry"); + } + for ( ; (cursorPtr != NULL); cursorPtr = cursorPtr->nextPtr) { + objPtr = Tcl_NewObj(); + Tcl_ListObjAppendElement(NULL, objPtr, + Tcl_NewIntObj(cursorPtr->resourceRefCount)); + Tcl_ListObjAppendElement(NULL, objPtr, + Tcl_NewIntObj(cursorPtr->objRefCount)); + Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); + } + } + return resultPtr; +} diff --git a/generic/tkEntry.c b/generic/tkEntry.c index 35cc66c..e64f661 100644 --- a/generic/tkEntry.c +++ b/generic/tkEntry.c @@ -6,12 +6,12 @@ * the string to be edited. * * Copyright (c) 1990-1994 The Regents of the University of California. - * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkEntry.c 1.112 97/11/06 16:56:16 + * SCCS: @(#) tkEntry.c 1.119 98/01/21 22:20:55 */ #include "tkInt.h" @@ -39,17 +39,17 @@ typedef struct { char *string; /* Pointer to storage for string; * NULL-terminated; malloc-ed. */ - int insertPos; /* Index of character before which next - * typed character will be inserted. */ + int insertPos; /* Character index before which next typed + * character will be inserted. */ /* * Information about what's selected, if any. */ - int selectFirst; /* Index of first selected character (-1 means - * nothing selected. */ - int selectLast; /* Index of last selected character (-1 means - * nothing selected. */ + int selectFirst; /* Character index of first selected + * character (-1 means nothing selected. */ + int selectLast; /* Character index just after last selected + * character (-1 means nothing selected. */ int selectAnchor; /* Fixed end of selection (i.e. "select to" * operation will use this as one end of the * selection). */ @@ -60,8 +60,8 @@ typedef struct { int scanMarkX; /* X-position at which scan started (e.g. * button was pressed here). */ - int scanMarkIndex; /* Index of character that was at left of - * window when scan started. */ + int scanMarkIndex; /* Character index of character that was at + * left of window when scan started. */ /* * Configuration settings that are updated by Tk_ConfigureWidget. @@ -118,20 +118,27 @@ typedef struct { * configuration settings above. */ - int numChars; /* Number of non-NULL characters in - * string (may be 0). */ - char *displayString; /* If non-NULL, points to string with same + int numBytes; /* Length of string in bytes. */ + int numChars; /* Length of string in characters. Both + * string and displayString have the same + * character length, but may have different + * byte lengths due to being made from + * different UTF-8 characters. */ + char *displayString; /* String to use when displaying. This may + * be a pointer to string, or a pointer to + * malloced memory with the same character * length as string but whose characters - * are all equal to showChar. Malloc'ed. */ + * are all equal to showChar. */ + int numDisplayBytes; /* Length of displayString in bytes. */ int inset; /* Number of pixels on the left and right * sides that are taken up by XPAD, borderWidth * (if any), and highlightWidth (if any). */ Tk_TextLayout textLayout; /* Cached text layout information. */ int layoutX, layoutY; /* Origin for layout. */ - int leftIndex; /* Index of left-most character visible in - * window. */ int leftX; /* X position at which character at leftIndex * is drawn (varies depending on justify). */ + int leftIndex; /* Character index of left-most character + * visible in window. */ Tcl_TimerToken insertBlinkHandler; /* Timer handler used to blink cursor on and * off. */ @@ -357,12 +364,12 @@ Tk_EntryCmd(clientData, interp, argc, argv) char **argv; /* Argument strings. */ { Tk_Window tkwin = (Tk_Window) clientData; - register Entry *entryPtr; + Entry *entryPtr; Tk_Window new; if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " pathName ?options?\"", (char *) NULL); + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " pathName ?options?\"", (char *) NULL); return TCL_ERROR; } @@ -419,14 +426,16 @@ Tk_EntryCmd(clientData, interp, argc, argv) entryPtr->prefWidth = 0; entryPtr->scrollCmd = NULL; + entryPtr->numBytes = 0; entryPtr->numChars = 0; - entryPtr->displayString = NULL; + entryPtr->displayString = entryPtr->string; + entryPtr->numDisplayBytes = 0; entryPtr->inset = XPAD; entryPtr->textLayout = NULL; entryPtr->layoutX = 0; entryPtr->layoutY = 0; - entryPtr->leftIndex = 0; entryPtr->leftX = 0; + entryPtr->leftIndex = 0; entryPtr->insertBlinkHandler = (Tcl_TimerToken) NULL; entryPtr->textGC = None; entryPtr->selTextGC = None; @@ -445,7 +454,7 @@ Tk_EntryCmd(clientData, interp, argc, argv) goto error; } - interp->result = Tk_PathName(entryPtr->tkwin); + Tcl_SetResult(interp, Tk_PathName(entryPtr->tkwin), TCL_STATIC); return TCL_OK; error: @@ -473,12 +482,12 @@ Tk_EntryCmd(clientData, interp, argc, argv) static int EntryWidgetCmd(clientData, interp, argc, argv) - ClientData clientData; /* Information about entry widget. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + ClientData clientData; /* Information about entry widget. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ { - register Entry *entryPtr = (Entry *) clientData; + Entry *entryPtr = (Entry *) clientData; int result = TCL_OK; size_t length; int c; @@ -492,8 +501,9 @@ EntryWidgetCmd(clientData, interp, argc, argv) c = argv[1][0]; length = strlen(argv[1]); if ((c == 'b') && (strncmp(argv[1], "bbox", length) == 0)) { - int index; - int x, y, width, height; + int index, byteIndex, x, y, width, height; + char *string; + char buf[TCL_INTEGER_SPACE * 4]; if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", @@ -507,9 +517,12 @@ EntryWidgetCmd(clientData, interp, argc, argv) if ((index == entryPtr->numChars) && (index > 0)) { index--; } - Tk_CharBbox(entryPtr->textLayout, index, &x, &y, &width, &height); - sprintf(interp->result, "%d %d %d %d", - x + entryPtr->layoutX, y + entryPtr->layoutY, width, height); + string = entryPtr->displayString; + byteIndex = Tcl_UtfAtIndex(string, index) - string; + Tk_CharBbox(entryPtr->textLayout, byteIndex, &x, &y, &width, &height); + sprintf(buf, "%d %d %d %d", x + entryPtr->layoutX, + y + entryPtr->layoutY, width, height); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } else if ((c == 'c') && (strncmp(argv[1], "cget", length) == 0) && (length >= 2)) { if (argc != 3) { @@ -545,14 +558,14 @@ EntryWidgetCmd(clientData, interp, argc, argv) goto error; } if (argc == 3) { - last = first+1; + last = first + 1; } else { if (GetEntryIndex(interp, entryPtr, argv[3], &last) != TCL_OK) { goto error; } } if ((last >= first) && (entryPtr->state == tkNormalUid)) { - DeleteChars(entryPtr, first, last-first); + DeleteChars(entryPtr, first, last - first); } } else if ((c == 'g') && (strncmp(argv[1], "get", length) == 0)) { if (argc != 2) { @@ -560,7 +573,7 @@ EntryWidgetCmd(clientData, interp, argc, argv) argv[0], " get\"", (char *) NULL); goto error; } - interp->result = entryPtr->string; + Tcl_SetResult(interp, entryPtr->string, TCL_STATIC); } else if ((c == 'i') && (strncmp(argv[1], "icursor", length) == 0) && (length >= 2)) { if (argc != 3) { @@ -577,6 +590,7 @@ EntryWidgetCmd(clientData, interp, argc, argv) } else if ((c == 'i') && (strncmp(argv[1], "index", length) == 0) && (length >= 3)) { int index; + char buf[TCL_INTEGER_SPACE]; if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", @@ -586,7 +600,8 @@ EntryWidgetCmd(clientData, interp, argc, argv) if (GetEntryIndex(interp, entryPtr, argv[2], &index) != TCL_OK) { goto error; } - sprintf(interp->result, "%d", index); + sprintf(buf, "%d", index); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } else if ((c == 'i') && (strncmp(argv[1], "insert", length) == 0) && (length >= 3)) { int index; @@ -644,8 +659,9 @@ EntryWidgetCmd(clientData, interp, argc, argv) argv[0], " selection clear\"", (char *) NULL); goto error; } - if (entryPtr->selectFirst != -1) { - entryPtr->selectFirst = entryPtr->selectLast = -1; + if (entryPtr->selectFirst >= 0) { + entryPtr->selectFirst = -1; + entryPtr->selectLast = -1; EventuallyRedraw(entryPtr); } goto done; @@ -655,10 +671,10 @@ EntryWidgetCmd(clientData, interp, argc, argv) argv[0], " selection present\"", (char *) NULL); goto error; } - if (entryPtr->selectFirst == -1) { - interp->result = "0"; + if (entryPtr->selectFirst < 0) { + Tcl_SetResult(interp, "0", TCL_STATIC); } else { - interp->result = "1"; + Tcl_SetResult(interp, "1", TCL_STATIC); } goto done; } @@ -676,7 +692,7 @@ EntryWidgetCmd(clientData, interp, argc, argv) } if (entryPtr->selectFirst >= 0) { int half1, half2; - + half1 = (entryPtr->selectFirst + entryPtr->selectLast)/2; half2 = (entryPtr->selectFirst + entryPtr->selectLast + 1)/2; if (index < half1) { @@ -710,7 +726,8 @@ EntryWidgetCmd(clientData, interp, argc, argv) goto error; } if (index >= index2) { - entryPtr->selectFirst = entryPtr->selectLast = -1; + entryPtr->selectFirst = -1; + entryPtr->selectLast = -1; } else { entryPtr->selectFirst = index; entryPtr->selectLast = index2; @@ -737,41 +754,52 @@ EntryWidgetCmd(clientData, interp, argc, argv) goto error; } } else if ((c == 'x') && (strncmp(argv[1], "xview", length) == 0)) { - int index, type, count, charsPerPage; - double fraction, first, last; + int index; if (argc == 2) { + double first, last; + char buf[TCL_DOUBLE_SPACE * 2]; + EntryVisibleRange(entryPtr, &first, &last); - sprintf(interp->result, "%g %g", first, last); + sprintf(buf, "%g %g", first, last); + Tcl_SetResult(interp, buf, TCL_VOLATILE); goto done; } else if (argc == 3) { if (GetEntryIndex(interp, entryPtr, argv[2], &index) != TCL_OK) { goto error; } } else { - type = Tk_GetScrollInfo(interp, argc, argv, &fraction, &count); + double fraction; + int count; + index = entryPtr->leftIndex; - switch (type) { - case TK_SCROLL_ERROR: + switch (Tk_GetScrollInfo(interp, argc, argv, &fraction, &count)) { + case TK_SCROLL_ERROR: { goto error; - case TK_SCROLL_MOVETO: + } + case TK_SCROLL_MOVETO: { index = (int) ((fraction * entryPtr->numChars) + 0.5); break; - case TK_SCROLL_PAGES: + } + case TK_SCROLL_PAGES: { + int charsPerPage; + charsPerPage = ((Tk_Width(entryPtr->tkwin) - - 2*entryPtr->inset) / entryPtr->avgWidth) - 2; + - 2 * entryPtr->inset) / entryPtr->avgWidth) - 2; if (charsPerPage < 1) { charsPerPage = 1; } - index += charsPerPage*count; + index += count * charsPerPage; break; - case TK_SCROLL_UNITS: + } + case TK_SCROLL_UNITS: { index += count; break; + } } } if (index >= entryPtr->numChars) { - index = entryPtr->numChars-1; + index = entryPtr->numChars - 1; } if (index < 0) { index = 0; @@ -818,7 +846,7 @@ static void DestroyEntry(memPtr) char *memPtr; /* Info about entry widget. */ { - register Entry *entryPtr = (Entry *) memPtr; + Entry *entryPtr = (Entry *) memPtr; /* * Free up all the stuff that requires special handling, then @@ -839,7 +867,7 @@ DestroyEntry(memPtr) Tk_FreeGC(entryPtr->display, entryPtr->selTextGC); } Tcl_DeleteTimerHandler(entryPtr->insertBlinkHandler); - if (entryPtr->displayString != NULL) { + if (entryPtr->displayString != entryPtr->string) { ckfree(entryPtr->displayString); } Tk_FreeTextLayout(entryPtr->textLayout); @@ -858,7 +886,7 @@ DestroyEntry(memPtr) * * Results: * The return value is a standard Tcl result. If TCL_ERROR is - * returned, then interp->result contains an error message. + * returned, then the interp's result contains an error message. * * Side effects: * Configuration information, such as colors, border width, @@ -871,8 +899,8 @@ DestroyEntry(memPtr) static int ConfigureEntry(interp, entryPtr, argc, argv, flags) Tcl_Interp *interp; /* Used for error reporting. */ - register Entry *entryPtr; /* Information about widget; may or may - * not already have values for some fields. */ + Entry *entryPtr; /* Information about widget; may or may not + * already have values for some fields. */ int argc; /* Number of valid entries in argv. */ char **argv; /* Arguments. */ int flags; /* Flags to pass to Tk_ConfigureWidget. */ @@ -1057,13 +1085,14 @@ static void DisplayEntry(clientData) ClientData clientData; /* Information about window. */ { - register Entry *entryPtr = (Entry *) clientData; - register Tk_Window tkwin = entryPtr->tkwin; - int baseY, selStartX, selEndX, cursorX, x, w; + Entry *entryPtr = (Entry *) clientData; + Tk_Window tkwin = entryPtr->tkwin; + int baseY, selStartX, selEndX, cursorX; int xBound; Tk_FontMetrics fm; Pixmap pixmap; - int showSelection; + int showSelection, selFirstByte, selLastByte, leftByte; + char *string; entryPtr->flags &= ~REDRAW_PENDING; if ((entryPtr->tkwin == NULL) || !Tk_IsMapped(tkwin)) { @@ -1118,18 +1147,25 @@ DisplayEntry(clientData) Tk_Fill3DRectangle(tkwin, pixmap, entryPtr->normalBorder, 0, 0, Tk_Width(tkwin), Tk_Height(tkwin), 0, TK_RELIEF_FLAT); - if (showSelection && (entryPtr->selectLast > entryPtr->leftIndex)) { + + string = entryPtr->displayString; + if (showSelection + && (entryPtr->selectLast > entryPtr->leftIndex)) { if (entryPtr->selectFirst <= entryPtr->leftIndex) { selStartX = entryPtr->leftX; } else { - Tk_CharBbox(entryPtr->textLayout, entryPtr->selectFirst, - &x, NULL, NULL, NULL); - selStartX = x + entryPtr->layoutX; + selFirstByte = Tcl_UtfAtIndex(string, entryPtr->selectFirst) + - string; + Tk_CharBbox(entryPtr->textLayout, selFirstByte, &selStartX, NULL, + NULL, NULL); + selStartX += entryPtr->layoutX; } if ((selStartX - entryPtr->selBorderWidth) < xBound) { - Tk_CharBbox(entryPtr->textLayout, entryPtr->selectLast - 1, - &x, NULL, &w, NULL); - selEndX = x + w + entryPtr->layoutX; + selLastByte = Tcl_UtfAtIndex(string, entryPtr->selectLast) + - string; + Tk_CharBbox(entryPtr->textLayout, selLastByte, &selEndX, NULL, + NULL, NULL); + selEndX += entryPtr->layoutX; Tk_Fill3DRectangle(tkwin, pixmap, entryPtr->selBorder, selStartX - entryPtr->selBorderWidth, baseY - fm.ascent - entryPtr->selBorderWidth, @@ -1151,30 +1187,24 @@ DisplayEntry(clientData) if ((entryPtr->insertPos >= entryPtr->leftIndex) && (entryPtr->state == tkNormalUid) && (entryPtr->flags & GOT_FOCUS)) { - if (entryPtr->insertPos == 0) { - cursorX = 0; - } else if (entryPtr->insertPos >= entryPtr->numChars) { - Tk_CharBbox(entryPtr->textLayout, entryPtr->numChars - 1, - &x, NULL, &w, NULL); - cursorX = x + w; - } else { - Tk_CharBbox(entryPtr->textLayout, entryPtr->insertPos, - &x, NULL, NULL, NULL); - cursorX = x; - } + int insertByte; + + insertByte = Tcl_UtfAtIndex(string, entryPtr->insertPos) + - string; + Tk_CharBbox(entryPtr->textLayout, insertByte, &cursorX, NULL, + NULL, NULL); cursorX += entryPtr->layoutX; cursorX -= (entryPtr->insertWidth)/2; if (cursorX < xBound) { if (entryPtr->flags & CURSOR_ON) { Tk_Fill3DRectangle(tkwin, pixmap, entryPtr->insertBorder, - cursorX, baseY - fm.ascent, - entryPtr->insertWidth, fm.ascent + fm.descent, - entryPtr->insertBorderWidth, TK_RELIEF_RAISED); + cursorX, baseY - fm.ascent, entryPtr->insertWidth, + fm.ascent + fm.descent, entryPtr->insertBorderWidth, + TK_RELIEF_RAISED); } else if (entryPtr->insertBorder == entryPtr->selBorder) { Tk_Fill3DRectangle(tkwin, pixmap, entryPtr->normalBorder, - cursorX, baseY - fm.ascent, - entryPtr->insertWidth, fm.ascent + fm.descent, - 0, TK_RELIEF_FLAT); + cursorX, baseY - fm.ascent, entryPtr->insertWidth, + fm.ascent + fm.descent, 0, TK_RELIEF_FLAT); } } } @@ -1184,22 +1214,25 @@ DisplayEntry(clientData) * selected portion on top of it. */ + leftByte = Tcl_UtfAtIndex(string, entryPtr->leftIndex) - string; Tk_DrawTextLayout(entryPtr->display, pixmap, entryPtr->textGC, entryPtr->textLayout, entryPtr->layoutX, entryPtr->layoutY, - entryPtr->leftIndex, entryPtr->numChars); - - if (showSelection && (entryPtr->selTextGC != entryPtr->textGC) && - (entryPtr->selectFirst < entryPtr->selectLast)) { - int first; + leftByte, entryPtr->numDisplayBytes); - if (entryPtr->selectFirst - entryPtr->leftIndex < 0) { - first = entryPtr->leftIndex; + if (showSelection + && (entryPtr->selTextGC != entryPtr->textGC) + && (entryPtr->selectFirst < entryPtr->selectLast)) { + if (entryPtr->selectFirst < entryPtr->leftIndex) { + selFirstByte = leftByte; } else { - first = entryPtr->selectFirst; + selFirstByte = Tcl_UtfAtIndex(string, entryPtr->selectFirst) + - string; } + selLastByte = Tcl_UtfAtIndex(string, entryPtr->selectLast) + - string; Tk_DrawTextLayout(entryPtr->display, pixmap, entryPtr->selTextGC, entryPtr->textLayout, entryPtr->layoutX, entryPtr->layoutY, - first, entryPtr->selectLast); + selFirstByte, selLastByte); } /* @@ -1210,8 +1243,8 @@ DisplayEntry(clientData) if (entryPtr->relief != TK_RELIEF_FLAT) { Tk_Draw3DRectangle(tkwin, pixmap, entryPtr->normalBorder, entryPtr->highlightWidth, entryPtr->highlightWidth, - Tk_Width(tkwin) - 2*entryPtr->highlightWidth, - Tk_Height(tkwin) - 2*entryPtr->highlightWidth, + Tk_Width(tkwin) - 2 * entryPtr->highlightWidth, + Tk_Height(tkwin) - 2 * entryPtr->highlightWidth, entryPtr->borderWidth, entryPtr->relief); } if (entryPtr->highlightWidth != 0) { @@ -1259,38 +1292,45 @@ DisplayEntry(clientData) static void EntryComputeGeometry(entryPtr) - Entry *entryPtr; /* Widget record for entry. */ + Entry *entryPtr; /* Widget record for entry. */ { int totalLength, overflow, maxOffScreen, rightX; - int height, width, i; + int height, width, i, leftByte; Tk_FontMetrics fm; - char *p, *displayString; + char *p; + + if (entryPtr->displayString != entryPtr->string) { + ckfree(entryPtr->displayString); + entryPtr->displayString = entryPtr->string; + entryPtr->numDisplayBytes = entryPtr->numBytes; + } /* * If we're displaying a special character instead of the value of * the entry, recompute the displayString. */ - if (entryPtr->displayString != NULL) { - ckfree(entryPtr->displayString); - entryPtr->displayString = NULL; - } if (entryPtr->showChar != NULL) { - entryPtr->displayString = (char *) ckalloc((unsigned) - (entryPtr->numChars + 1)); - for (p = entryPtr->displayString, i = entryPtr->numChars; i > 0; - i--, p++) { - *p = entryPtr->showChar[0]; - } - *p = 0; - displayString = entryPtr->displayString; - } else { - displayString = entryPtr->string; + Tcl_UniChar ch; + char buf[TCL_UTF_MAX]; + int size; + + Tcl_UtfToUniChar(entryPtr->showChar, &ch); + size = Tcl_UniCharToUtf(ch, buf); + entryPtr->numDisplayBytes = entryPtr->numChars * size; + entryPtr->displayString = + (char *) ckalloc((unsigned) (entryPtr->numDisplayBytes + 1)); + + p = entryPtr->displayString; + for (i = entryPtr->numChars; --i >= 0; ) { + p += Tcl_UniCharToUtf(ch, p); + } + *p = '\0'; } Tk_FreeTextLayout(entryPtr->textLayout); entryPtr->textLayout = Tk_ComputeTextLayout(entryPtr->tkfont, - displayString, entryPtr->numChars, 0, entryPtr->justify, - TK_IGNORE_NEWLINES, &totalLength, &height); + entryPtr->displayString, entryPtr->numDisplayBytes, 0, + entryPtr->justify, TK_IGNORE_NEWLINES, &totalLength, &height); entryPtr->layoutY = (Tk_Height(entryPtr->tkwin) - height) / 2; @@ -1325,13 +1365,14 @@ EntryComputeGeometry(entryPtr) Tk_CharBbox(entryPtr->textLayout, maxOffScreen, &rightX, NULL, NULL, NULL); if (rightX < overflow) { - maxOffScreen += 1; + maxOffScreen++; } if (entryPtr->leftIndex > maxOffScreen) { entryPtr->leftIndex = maxOffScreen; } - Tk_CharBbox(entryPtr->textLayout, entryPtr->leftIndex, - &rightX, NULL, NULL, NULL); + leftByte = Tcl_UtfAtIndex(entryPtr->displayString, entryPtr->leftIndex) + - entryPtr->displayString; + Tk_CharBbox(entryPtr->textLayout, leftByte, &rightX, NULL, NULL, NULL); entryPtr->leftX = entryPtr->inset; entryPtr->layoutX = entryPtr->leftX - rightX; } @@ -1368,28 +1409,51 @@ EntryComputeGeometry(entryPtr) */ static void -InsertChars(entryPtr, index, string) - register Entry *entryPtr; /* Entry that is to get the new - * elements. */ +InsertChars(entryPtr, index, value) + Entry *entryPtr; /* Entry that is to get the new elements. */ int index; /* Add the new elements before this - * element. */ - char *string; /* New characters to add (NULL-terminated + * character index. */ + char *value; /* New characters to add (NULL-terminated * string). */ { - int length; - char *new; + int byteIndex, byteCount, oldChars, charsAdded, newByteCount; + char *new, *string; - length = strlen(string); - if (length == 0) { + string = entryPtr->string; + byteIndex = Tcl_UtfAtIndex(string, index) - string; + byteCount = strlen(value); + if (byteCount == 0) { return; } - new = (char *) ckalloc((unsigned) (entryPtr->numChars + length + 1)); - strncpy(new, entryPtr->string, (size_t) index); - strcpy(new+index, string); - strcpy(new+index+length, entryPtr->string+index); - ckfree(entryPtr->string); + + newByteCount = entryPtr->numBytes + byteCount + 1; + new = (char *) ckalloc((unsigned) newByteCount); + memcpy(new, string, (size_t) byteIndex); + strcpy(new + byteIndex, value); + strcpy(new + byteIndex + byteCount, string + byteIndex); + + ckfree(string); entryPtr->string = new; - entryPtr->numChars += length; + + /* + * The following construction is used because inserting improperly + * formed UTF-8 sequences between other improperly formed UTF-8 + * sequences could result in actually forming valid UTF-8 sequences; + * the number of characters added may not be Tcl_NumUtfChars(string, -1), + * because of context. The actual number of characters added is how + * many characters were are in the string now minus the number that + * used to be there. + */ + + oldChars = entryPtr->numChars; + entryPtr->numChars = Tcl_NumUtfChars(new, -1); + charsAdded = entryPtr->numChars - oldChars; + entryPtr->numBytes += byteCount; + + if (entryPtr->displayString == string) { + entryPtr->displayString = new; + entryPtr->numDisplayBytes = entryPtr->numBytes; + } /* * Inserting characters invalidates all indexes into the string. @@ -1400,19 +1464,20 @@ InsertChars(entryPtr, index, string) */ if (entryPtr->selectFirst >= index) { - entryPtr->selectFirst += length; + entryPtr->selectFirst += charsAdded; } if (entryPtr->selectLast > index) { - entryPtr->selectLast += length; + entryPtr->selectLast += charsAdded; } - if ((entryPtr->selectAnchor > index) || (entryPtr->selectFirst >= index)) { - entryPtr->selectAnchor += length; + if ((entryPtr->selectAnchor > index) + || (entryPtr->selectFirst >= index)) { + entryPtr->selectAnchor += charsAdded; } if (entryPtr->leftIndex > index) { - entryPtr->leftIndex += length; + entryPtr->leftIndex += charsAdded; } if (entryPtr->insertPos >= index) { - entryPtr->insertPos += length; + entryPtr->insertPos += charsAdded; } EntryValueChanged(entryPtr); } @@ -1436,11 +1501,12 @@ InsertChars(entryPtr, index, string) static void DeleteChars(entryPtr, index, count) - register Entry *entryPtr; /* Entry widget to modify. */ + Entry *entryPtr; /* Entry widget to modify. */ int index; /* Index of first character to delete. */ int count; /* How many characters to delete. */ { - char *new; + int byteIndex, byteCount, newByteCount; + char *new, *string; if ((index + count) > entryPtr->numChars) { count = entryPtr->numChars - index; @@ -1449,12 +1515,24 @@ DeleteChars(entryPtr, index, count) return; } - new = (char *) ckalloc((unsigned) (entryPtr->numChars + 1 - count)); - strncpy(new, entryPtr->string, (size_t) index); - strcpy(new+index, entryPtr->string+index+count); + string = entryPtr->string; + byteIndex = Tcl_UtfAtIndex(string, index) - string; + byteCount = Tcl_UtfAtIndex(string + byteIndex, count) - (string + byteIndex); + + newByteCount = entryPtr->numBytes + 1 - byteCount; + new = (char *) ckalloc((unsigned) newByteCount); + memcpy(new, string, (size_t) byteIndex); + strcpy(new + byteIndex, string + byteIndex + byteCount); + ckfree(entryPtr->string); entryPtr->string = new; entryPtr->numChars -= count; + entryPtr->numBytes -= byteCount; + + if (entryPtr->displayString == string) { + entryPtr->displayString = new; + entryPtr->numDisplayBytes = entryPtr->numBytes; + } /* * Deleting characters results in the remaining characters being @@ -1463,21 +1541,22 @@ DeleteChars(entryPtr, index, count) */ if (entryPtr->selectFirst >= index) { - if (entryPtr->selectFirst >= (index+count)) { + if (entryPtr->selectFirst >= (index + count)) { entryPtr->selectFirst -= count; } else { entryPtr->selectFirst = index; } } if (entryPtr->selectLast >= index) { - if (entryPtr->selectLast >= (index+count)) { + if (entryPtr->selectLast >= (index + count)) { entryPtr->selectLast -= count; } else { entryPtr->selectLast = index; } } if (entryPtr->selectLast <= entryPtr->selectFirst) { - entryPtr->selectFirst = entryPtr->selectLast = -1; + entryPtr->selectFirst = -1; + entryPtr->selectLast = -1; } if (entryPtr->selectAnchor >= index) { if (entryPtr->selectAnchor >= (index+count)) { @@ -1487,14 +1566,14 @@ DeleteChars(entryPtr, index, count) } } if (entryPtr->leftIndex > index) { - if (entryPtr->leftIndex >= (index+count)) { + if (entryPtr->leftIndex >= (index + count)) { entryPtr->leftIndex -= count; } else { entryPtr->leftIndex = index; } } if (entryPtr->insertPos >= index) { - if (entryPtr->insertPos >= (index+count)) { + if (entryPtr->insertPos >= (index + count)) { entryPtr->insertPos -= count; } else { entryPtr->insertPos = index; @@ -1580,24 +1659,37 @@ EntryValueChanged(entryPtr) static void EntrySetValue(entryPtr, value) - register Entry *entryPtr; /* Entry whose value is to be - * changed. */ - char *value; /* New text to display in entry. */ + Entry *entryPtr; /* Entry whose value is to be changed. */ + char *value; /* New text to display in entry. */ { + char *oldSource; + + oldSource = entryPtr->string; + ckfree(entryPtr->string); - entryPtr->numChars = strlen(value); - entryPtr->string = (char *) ckalloc((unsigned) (entryPtr->numChars + 1)); + entryPtr->numBytes = strlen(value); + entryPtr->numChars = Tcl_NumUtfChars(value, entryPtr->numBytes); + entryPtr->string = + (char *) ckalloc((unsigned) (entryPtr->numBytes + 1)); strcpy(entryPtr->string, value); - if (entryPtr->selectFirst != -1) { + + if (entryPtr->displayString == oldSource) { + entryPtr->displayString = entryPtr->string; + entryPtr->numDisplayBytes = entryPtr->numBytes; + } + + if (entryPtr->selectFirst >= 0) { if (entryPtr->selectFirst >= entryPtr->numChars) { - entryPtr->selectFirst = entryPtr->selectLast = -1; + entryPtr->selectFirst = -1; + entryPtr->selectLast = -1; } else if (entryPtr->selectLast > entryPtr->numChars) { entryPtr->selectLast = entryPtr->numChars; } } if (entryPtr->leftIndex >= entryPtr->numChars) { - entryPtr->leftIndex = entryPtr->numChars-1; - if (entryPtr->leftIndex < 0) { + if (entryPtr->numChars > 0) { + entryPtr->leftIndex = entryPtr->numChars - 1; + } else { entryPtr->leftIndex = 0; } } @@ -1702,7 +1794,7 @@ EntryCmdDeletedProc(clientData) } /* - *-------------------------------------------------------------- + *--------------------------------------------------------------------------- * * GetEntryIndex -- * @@ -1710,16 +1802,16 @@ EntryCmdDeletedProc(clientData) * or an error. * * Results: - * A standard Tcl result. If all went well, then *indexPtr is + * A standard Tcl result. If all went well, then *byteIndexPtr is * filled in with the index (into entryPtr) corresponding to * string. The index value is guaranteed to lie between 0 and - * the number of characters in the string, inclusive. If an - * error occurs then an error message is left in interp->result. + * the number of bytes in the string, inclusive. If an + * error occurs then an error message is left in the interp's result. * * Side effects: * None. * - *-------------------------------------------------------------- + *--------------------------------------------------------------------------- */ static int @@ -1728,7 +1820,8 @@ GetEntryIndex(interp, entryPtr, string, indexPtr) Entry *entryPtr; /* Entry for which the index is being * specified. */ char *string; /* Specifies character in entryPtr. */ - int *indexPtr; /* Where to store converted index. */ + int *indexPtr; /* Where to store converted character + * index. */ { size_t length; @@ -1741,7 +1834,7 @@ GetEntryIndex(interp, entryPtr, string, indexPtr) badIndex: /* - * Some of the paths here leave messages in interp->result, + * Some of the paths here leave messages in the interp's result, * so we have to clear it out before storing our own message. */ @@ -1763,8 +1856,8 @@ GetEntryIndex(interp, entryPtr, string, indexPtr) goto badIndex; } } else if (string[0] == 's') { - if (entryPtr->selectFirst == -1) { - interp->result = "selection isn't in entry"; + if (entryPtr->selectFirst < 0) { + Tcl_SetResult(interp, "selection isn't in entry", TCL_STATIC); return TCL_ERROR; } if (length < 5) { @@ -1778,9 +1871,9 @@ GetEntryIndex(interp, entryPtr, string, indexPtr) goto badIndex; } } else if (string[0] == '@') { - int x, roundUp; + int x, roundUp, byteIndex; - if (Tcl_GetInt(interp, string+1, &x) != TCL_OK) { + if (Tcl_GetInt(interp, string + 1, &x) != TCL_OK) { goto badIndex; } if (x < entryPtr->inset) { @@ -1791,8 +1884,9 @@ GetEntryIndex(interp, entryPtr, string, indexPtr) x = Tk_Width(entryPtr->tkwin) - entryPtr->inset - 1; roundUp = 1; } - *indexPtr = Tk_PointToChar(entryPtr->textLayout, + byteIndex = Tk_PointToChar(entryPtr->textLayout, x - entryPtr->layoutX, 0); + *indexPtr = Tcl_NumUtfChars(entryPtr->displayString, byteIndex); /* * Special trick: if the x-position was off-screen to the right, @@ -1812,7 +1906,7 @@ GetEntryIndex(interp, entryPtr, string, indexPtr) *indexPtr = 0; } else if (*indexPtr > entryPtr->numChars) { *indexPtr = entryPtr->numChars; - } + } } return TCL_OK; } @@ -1836,9 +1930,8 @@ GetEntryIndex(interp, entryPtr, string, indexPtr) static void EntryScanTo(entryPtr, x) - register Entry *entryPtr; /* Information about widget. */ - int x; /* X-coordinate to use for scan - * operation. */ + Entry *entryPtr; /* Information about widget. */ + int x; /* X-coordinate to use for scan operation. */ { int newLeftIndex; @@ -1854,19 +1947,24 @@ EntryScanTo(entryPtr, x) */ newLeftIndex = entryPtr->scanMarkIndex - - (10*(x - entryPtr->scanMarkX))/entryPtr->avgWidth; + - (10 * (x - entryPtr->scanMarkX)) / entryPtr->avgWidth; if (newLeftIndex >= entryPtr->numChars) { - newLeftIndex = entryPtr->scanMarkIndex = entryPtr->numChars-1; + newLeftIndex = entryPtr->scanMarkIndex = entryPtr->numChars - 1; entryPtr->scanMarkX = x; } if (newLeftIndex < 0) { newLeftIndex = entryPtr->scanMarkIndex = 0; entryPtr->scanMarkX = x; } + if (newLeftIndex != entryPtr->leftIndex) { entryPtr->leftIndex = newLeftIndex; entryPtr->flags |= UPDATE_SCROLLBAR; EntryComputeGeometry(entryPtr); + if (newLeftIndex != entryPtr->leftIndex) { + entryPtr->scanMarkIndex = entryPtr->leftIndex; + entryPtr->scanMarkX = x; + } EventuallyRedraw(entryPtr); } } @@ -1890,10 +1988,9 @@ EntryScanTo(entryPtr, x) static void EntrySelectTo(entryPtr, index) - register Entry *entryPtr; /* Information about widget. */ - int index; /* Index of element that is to - * become the "other" end of the - * selection. */ + Entry *entryPtr; /* Information about widget. */ + int index; /* Character index of element that is to + * become the "other" end of the selection. */ { int newFirst, newLast; @@ -1956,38 +2053,35 @@ EntrySelectTo(entryPtr, index) static int EntryFetchSelection(clientData, offset, buffer, maxBytes) - ClientData clientData; /* Information about entry widget. */ - int offset; /* Offset within selection of first - * character to be returned. */ - char *buffer; /* Location in which to place - * selection. */ - int maxBytes; /* Maximum number of bytes to place - * at buffer, not including terminating - * NULL character. */ + ClientData clientData; /* Information about entry widget. */ + int offset; /* Byte offset within selection of first + * character to be returned. */ + char *buffer; /* Location in which to place selection. */ + int maxBytes; /* Maximum number of bytes to place at + * buffer, not including terminating NULL + * character. */ { Entry *entryPtr = (Entry *) clientData; - int count; - char *displayString; + int byteCount; + char *string, *selStart, *selEnd; if ((entryPtr->selectFirst < 0) || !(entryPtr->exportSelection)) { return -1; } - count = entryPtr->selectLast - entryPtr->selectFirst - offset; - if (count > maxBytes) { - count = maxBytes; + string = entryPtr->displayString; + selStart = Tcl_UtfAtIndex(string, entryPtr->selectFirst); + selEnd = Tcl_UtfAtIndex(selStart, + entryPtr->selectLast - entryPtr->selectFirst); + byteCount = selEnd - selStart - offset; + if (byteCount > maxBytes) { + byteCount = maxBytes; } - if (count <= 0) { + if (byteCount <= 0) { return 0; } - if (entryPtr->displayString == NULL) { - displayString = entryPtr->string; - } else { - displayString = entryPtr->displayString; - } - strncpy(buffer, displayString + entryPtr->selectFirst + offset, - (size_t) count); - buffer[count] = '\0'; - return count; + memcpy(buffer, selStart + offset, (size_t) byteCount); + buffer[byteCount] = '\0'; + return byteCount; } /* @@ -2010,7 +2104,7 @@ EntryFetchSelection(clientData, offset, buffer, maxBytes) static void EntryLostSelection(clientData) - ClientData clientData; /* Information about entry widget. */ + ClientData clientData; /* Information about entry widget. */ { Entry *entryPtr = (Entry *) clientData; @@ -2023,7 +2117,7 @@ EntryLostSelection(clientData) */ #ifdef ALWAYS_SHOW_SELECTION - if ((entryPtr->selectFirst != -1) && entryPtr->exportSelection) { + if ((entryPtr->selectFirst >= 0) && entryPtr->exportSelection) { entryPtr->selectFirst = -1; entryPtr->selectLast = -1; EventuallyRedraw(entryPtr); @@ -2052,7 +2146,7 @@ EntryLostSelection(clientData) static void EventuallyRedraw(entryPtr) - register Entry *entryPtr; /* Information about widget. */ + Entry *entryPtr; /* Information about widget. */ { if ((entryPtr->tkwin == NULL) || !Tk_IsMapped(entryPtr->tkwin)) { return; @@ -2091,36 +2185,38 @@ EventuallyRedraw(entryPtr) static void EntryVisibleRange(entryPtr, firstPtr, lastPtr) - Entry *entryPtr; /* Information about widget. */ - double *firstPtr; /* Return position of first visible - * character in widget. */ - double *lastPtr; /* Return position of char just after - * last visible one. */ + Entry *entryPtr; /* Information about widget. */ + double *firstPtr; /* Return position of first visible + * character in widget. */ + double *lastPtr; /* Return position of char just after last + * visible one. */ { - int charsInWindow; + int bytesInWindow, leftByte, charsInWindow; + char *string; if (entryPtr->numChars == 0) { *firstPtr = 0.0; *lastPtr = 1.0; } else { - charsInWindow = Tk_PointToChar(entryPtr->textLayout, + string = entryPtr->displayString; + + bytesInWindow = Tk_PointToChar(entryPtr->textLayout, Tk_Width(entryPtr->tkwin) - entryPtr->inset - - entryPtr->layoutX - 1, 0) + 1; - if (charsInWindow > entryPtr->numChars) { - /* - * If all chars were visible, then charsInWindow will be - * the index just after the last char that was visible. - */ - - charsInWindow = entryPtr->numChars; + - entryPtr->layoutX - 1, 0); + if (bytesInWindow < entryPtr->numDisplayBytes) { + bytesInWindow = Tcl_UtfNext(string + bytesInWindow) - string; } - charsInWindow -= entryPtr->leftIndex; - if (charsInWindow == 0) { - charsInWindow = 1; + bytesInWindow -= entryPtr->leftIndex; + if (bytesInWindow == 0) { + bytesInWindow = 1; } - *firstPtr = ((double) entryPtr->leftIndex)/entryPtr->numChars; - *lastPtr = ((double) (entryPtr->leftIndex + charsInWindow)) - /entryPtr->numChars; + + leftByte = Tcl_UtfAtIndex(string, entryPtr->leftIndex) - string; + charsInWindow = Tcl_NumUtfChars(string + leftByte, bytesInWindow); + + *firstPtr = (double) entryPtr->leftIndex / entryPtr->numChars; + *lastPtr = (double) (entryPtr->leftIndex + charsInWindow) + / entryPtr->numChars; } } @@ -2148,7 +2244,7 @@ static void EntryUpdateScrollbar(entryPtr) Entry *entryPtr; /* Information about widget. */ { - char args[100]; + char args[TCL_DOUBLE_SPACE * 2]; int code; double first, last; Tcl_Interp *interp; @@ -2193,7 +2289,7 @@ static void EntryBlinkProc(clientData) ClientData clientData; /* Pointer to record describing entry. */ { - register Entry *entryPtr = (Entry *) clientData; + Entry *entryPtr = (Entry *) clientData; if (!(entryPtr->flags & GOT_FOCUS) || (entryPtr->insertOffTime == 0)) { return; @@ -2230,7 +2326,7 @@ EntryBlinkProc(clientData) static void EntryFocusProc(entryPtr, gotFocus) - register Entry *entryPtr; /* Entry that got or lost focus. */ + Entry *entryPtr; /* Entry that got or lost focus. */ int gotFocus; /* 1 means window is getting focus, 0 means * it's losing it. */ { @@ -2276,7 +2372,7 @@ EntryTextVarProc(clientData, interp, name1, name2, flags) char *name2; /* Not used. */ int flags; /* Information about what happened. */ { - register Entry *entryPtr = (Entry *) clientData; + Entry *entryPtr = (Entry *) clientData; char *value; /* diff --git a/generic/tkFileFilter.c b/generic/tkFileFilter.c index 1b7e61a..8f25149 100644 --- a/generic/tkFileFilter.c +++ b/generic/tkFileFilter.c @@ -9,8 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkFileFilter.c 1.6 97/04/30 15:55:35 - * + * SCCS: @(#) tkFileFilter.c 1.7 97/05/06 13:49:51 */ #include "tkInt.h" diff --git a/generic/tkFocus.c b/generic/tkFocus.c index fe8f2c5..f4085da 100644 --- a/generic/tkFocus.c +++ b/generic/tkFocus.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkFocus.c 1.48 97/10/31 09:55:22 + * SCCS: @(#) tkFocus.c 1.51 97/11/07 21:16:51 */ #include "tkInt.h" @@ -106,7 +106,7 @@ static void SetFocus _ANSI_ARGS_((TkWindow *winPtr, int force)); /* *-------------------------------------------------------------- * - * Tk_FocusCmd -- + * Tk_FocusObjCmd -- * * This procedure is invoked to process the "focus" Tcl command. * See the user documentation for details on what it does. @@ -121,28 +121,30 @@ static void SetFocus _ANSI_ARGS_((TkWindow *winPtr, int force)); */ int -Tk_FocusCmd(clientData, interp, argc, argv) +Tk_FocusObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Main window associated with * interpreter. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { + static char *focusOptions[] = {"-displayof", "-force", "-lastfor", + (char *) NULL}; Tk_Window tkwin = (Tk_Window) clientData; TkWindow *winPtr = (TkWindow *) clientData; TkWindow *newPtr, *focusWinPtr, *topLevelPtr; ToplevelFocusInfo *tlFocusPtr; - char c; - size_t length; + char *windowName; + int index; /* * If invoked with no arguments, just return the current focus window. */ - if (argc == 1) { + if (objc == 1) { focusWinPtr = TkGetFocusWin(winPtr); if (focusWinPtr != NULL) { - interp->result = focusWinPtr->pathName; + Tcl_SetResult(interp, focusWinPtr->pathName, TCL_STATIC); } return TCL_OK; } @@ -152,12 +154,18 @@ Tk_FocusCmd(clientData, interp, argc, argv) * on that window. */ - if (argc == 2) { - if (argv[1][0] == 0) { + if (objc == 2) { + windowName = Tcl_GetStringFromObj(objv[1], (int *) NULL); + + /* + * The empty string case exists for backwards compatibility. + */ + + if (windowName[0] == '\0') { return TCL_OK; } - if (argv[1][0] == '.') { - newPtr = (TkWindow *) Tk_NameToWindow(interp, argv[1], tkwin); + if (windowName[0] == '.') { + newPtr = (TkWindow *) Tk_NameToWindow(interp, windowName, tkwin); if (newPtr == NULL) { return TCL_ERROR; } @@ -168,65 +176,72 @@ Tk_FocusCmd(clientData, interp, argc, argv) } } - length = strlen(argv[1]); - c = argv[1][1]; - if ((c == 'd') && (strncmp(argv[1], "-displayof", length) == 0)) { - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " -displayof window\"", (char *) NULL); - return TCL_ERROR; - } - newPtr = (TkWindow *) Tk_NameToWindow(interp, argv[2], tkwin); - if (newPtr == NULL) { - return TCL_ERROR; - } - newPtr = TkGetFocusWin(newPtr); - if (newPtr != NULL) { - interp->result = newPtr->pathName; - } - } else if ((c == 'f') && (strncmp(argv[1], "-force", length) == 0)) { - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " -force window\"", (char *) NULL); - return TCL_ERROR; - } - if (argv[2][0] == 0) { - return TCL_OK; - } - newPtr = (TkWindow *) Tk_NameToWindow(interp, argv[2], tkwin); - if (newPtr == NULL) { - return TCL_ERROR; - } - SetFocus(newPtr, 1); - } else if ((c == 'l') && (strncmp(argv[1], "-lastfor", length) == 0)) { - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " -lastfor window\"", (char *) NULL); - return TCL_ERROR; + if (Tcl_GetIndexFromObj(interp, objv[1], focusOptions, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "window"); + return TCL_ERROR; + } + switch (index) { + case 0: { /* -displayof */ + windowName = Tcl_GetStringFromObj(objv[2], (int *) NULL); + newPtr = (TkWindow *) Tk_NameToWindow(interp, windowName, tkwin); + if (newPtr == NULL) { + return TCL_ERROR; + } + newPtr = TkGetFocusWin(newPtr); + if (newPtr != NULL) { + Tcl_SetResult(interp, newPtr->pathName, TCL_STATIC); + } + break; } - newPtr = (TkWindow *) Tk_NameToWindow(interp, argv[2], tkwin); - if (newPtr == NULL) { - return TCL_ERROR; + case 1: { /* -force */ + windowName = Tcl_GetStringFromObj(objv[2], (int *) NULL); + + /* + * The empty string case exists for backwards compatibility. + */ + + if (windowName[0] == '\0') { + return TCL_OK; + } + newPtr = (TkWindow *) Tk_NameToWindow(interp, windowName, tkwin); + if (newPtr == NULL) { + return TCL_ERROR; + } + SetFocus(newPtr, 1); + break; } - for (topLevelPtr = newPtr; topLevelPtr != NULL; - topLevelPtr = topLevelPtr->parentPtr) { - if (topLevelPtr->flags & TK_TOP_LEVEL) { - for (tlFocusPtr = newPtr->mainPtr->tlFocusPtr; - tlFocusPtr != NULL; - tlFocusPtr = tlFocusPtr->nextPtr) { - if (tlFocusPtr->topLevelPtr == topLevelPtr) { - interp->result = tlFocusPtr->focusWinPtr->pathName; - return TCL_OK; + case 2: { /* -lastfor */ + windowName = Tcl_GetStringFromObj(objv[2], (int *) NULL); + newPtr = (TkWindow *) Tk_NameToWindow(interp, windowName, tkwin); + if (newPtr == NULL) { + return TCL_ERROR; + } + for (topLevelPtr = newPtr; topLevelPtr != NULL; + topLevelPtr = topLevelPtr->parentPtr) { + if (topLevelPtr->flags & TK_TOP_LEVEL) { + for (tlFocusPtr = newPtr->mainPtr->tlFocusPtr; + tlFocusPtr != NULL; + tlFocusPtr = tlFocusPtr->nextPtr) { + if (tlFocusPtr->topLevelPtr == topLevelPtr) { + Tcl_SetResult(interp, + tlFocusPtr->focusWinPtr->pathName, + TCL_STATIC); + return TCL_OK; + } } + Tcl_SetResult(interp, topLevelPtr->pathName, TCL_STATIC); + return TCL_OK; } - interp->result = topLevelPtr->pathName; - return TCL_OK; } + break; + } + default: { + panic("bad const entries to focusOptions in focus command"); } - } else { - Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be -displayof, -force, or -lastfor", (char *) NULL); - return TCL_ERROR; } return TCL_OK; } diff --git a/generic/tkFont.c b/generic/tkFont.c index 11929b6..593c506 100644 --- a/generic/tkFont.c +++ b/generic/tkFont.c @@ -6,14 +6,15 @@ * displaying text. * * Copyright (c) 1990-1994 The Regents of the University of California. - * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 1994-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkFont.c 1.74 97/10/10 14:34:11 + * SCCS: @(#) tkFont.c 1.88 98/02/11 17:44:51 */ +#include "tkPort.h" #include "tkInt.h" #include "tkFont.h" @@ -25,26 +26,19 @@ typedef struct TkFontInfo { Tcl_HashTable fontCache; /* Map a string to an existing Tk_Font. - * Keys are CachedFontKey structs, values are - * TkFont structs. */ + * Keys are string font names, values are + * TkFont pointers. */ Tcl_HashTable namedTable; /* Map a name to a set of attributes for a * font, used when constructing a Tk_Font from * a named font description. Keys are - * Tk_Uids, values are NamedFont structs. */ + * strings, values are NamedFont pointers. */ TkMainInfo *mainPtr; /* Application that owns this structure. */ - int updatePending; + int updatePending; /* Non-zero when a World Changed event has + * already been queued to handle a change to + * a named font. */ } TkFontInfo; /* - * The following structure is used as a key in the fontCache. - */ - -typedef struct CachedFontKey { - Display *display; /* Display for which font was constructed. */ - Tk_Uid string; /* String that describes font. */ -} CachedFontKey; - -/* * The following data structure is used to keep track of the font attributes * for each named font that has been defined. The named font is only deleted * when the last reference to it goes away. @@ -168,13 +162,6 @@ static TkStateMap xlfdSetwidthMap[] = { {TK_SW_UNKNOWN, NULL} }; -static TkStateMap xlfdCharsetMap[] = { - {TK_CS_NORMAL, "iso8859"}, - {TK_CS_SYMBOL, "adobe"}, - {TK_CS_SYMBOL, "sun"}, - {TK_CS_OTHER, NULL} -}; - /* * The following structure and defines specify the valid builtin options * when configuring a set of font attributes. @@ -196,7 +183,135 @@ static char *fontOpt[] = { #define FONT_SLANT 3 #define FONT_UNDERLINE 4 #define FONT_OVERSTRIKE 5 -#define FONT_NUMFIELDS 6 /* Length of fontOpt array. */ +#define FONT_NUMFIELDS 6 + +/* + * Hardcoded font aliases. These are used to describe (mostly) identical + * fonts whose names differ from platform to platform. If the + * user-supplied font name matches any of the names in one of the alias + * lists, the other names in the alias list are also automatically tried. + */ + +static char *timesAliases[] = { + "Times", /* Unix. */ + "Times New Roman", /* Windows. */ + "New York", /* Mac. */ + NULL +}; + +static char *helveticaAliases[] = { + "Helvetica", /* Unix. */ + "Arial", /* Windows. */ + "Geneva", /* Mac. */ + NULL +}; + +static char *courierAliases[] = { + "Courier", /* Unix and Mac. */ + "Courier New", /* Windows. */ + NULL +}; + +static char *minchoAliases[] = { + "mincho", /* Unix. */ + "\357\274\255\357\274\263 \346\230\216\346\234\235", + /* Windows (MS mincho). */ + "\346\234\254\346\230\216\346\234\235\342\210\222\357\274\255", + /* Mac (honmincho-M). */ + NULL +}; + +static char *gothicAliases[] = { + "gothic", /* Unix. */ + "\357\274\255\357\274\263 \343\202\264\343\202\267\343\203\203\343\202\257", + /* Windows (MS goshikku). */ + "\344\270\270\343\202\264\343\202\267\343\203\203\343\202\257\342\210\222\357\274\255", + /* Mac (goshikku-M). */ + NULL +}; + +static char *dingbatsAliases[] = { + "dingbats", "zapfdingbats", "itc zapfdingbats", + /* Unix. */ + /* Windows. */ + "zapf dingbats", /* Mac. */ + NULL +}; + +static char **fontAliases[] = { + timesAliases, + helveticaAliases, + courierAliases, + minchoAliases, + gothicAliases, + dingbatsAliases, + NULL +}; + +/* + * Hardcoded font classes. If the character cannot be found in the base + * font, the classes are examined in order to see if some other similar + * font should be examined also. + */ + +static char *systemClass[] = { + "fixed", /* Unix. */ + /* Windows. */ + "chicago", "osaka", "sistemny", /* Mac. */ + NULL +}; + +static char *serifClass[] = { + "times", "palatino", "mincho", /* All platforms. */ + "song ti", /* Unix. */ + "ms serif", "simplified arabic", /* Windows. */ + "latinski", /* Mac. */ + NULL +}; + +static char *sansClass[] = { + "helvetica", "gothic", /* All platforms. */ + /* Unix. */ + "ms sans serif", "traditional arabic", + /* Windows. */ + "bastion", /* Mac. */ + NULL +}; + +static char *monoClass[] = { + "courier", "gothic", /* All platforms. */ + "fangsong ti", /* Unix. */ + "simplified arabic fixed", /* Windows. */ + "monaco", "pryamoy", /* Mac. */ + NULL +}; + +static char *symbolClass[] = { + "symbol", "dingbats", "wingdings", NULL +}; + +static char **fontFallbacks[] = { + systemClass, + serifClass, + sansClass, + monoClass, + symbolClass, + NULL +}; + +/* + * Global fallbacks. If the character could not be found in the preferred + * fallback list, this list is examined. If the character still cannot be + * found, all font families in the system are examined. + */ + +static char *globalFontClass[] = { + "symbol", /* All platforms. */ + /* Unix. */ + "lucida sans unicode", /* Windows. */ + "chicago", /* Mac. */ + NULL +}; #define GetFontAttributes(tkfont) \ ((CONST TkFontAttributes *) &((TkFont *) (tkfont))->fa) @@ -208,7 +323,13 @@ static char *fontOpt[] = { static int ConfigAttributesObj _ANSI_ARGS_((Tcl_Interp *interp, Tk_Window tkwin, int objc, Tcl_Obj *CONST objv[], TkFontAttributes *faPtr)); +static int CreateNamedFont _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, CONST char *name, + TkFontAttributes *faPtr)); +static void DupFontObjProc _ANSI_ARGS_((Tcl_Obj *srcObjPtr, + Tcl_Obj *dupObjPtr)); static int FieldSpecified _ANSI_ARGS_((CONST char *field)); +static void FreeFontObjProc _ANSI_ARGS_((Tcl_Obj *objPtr)); static int GetAttributeInfoObj _ANSI_ARGS_((Tcl_Interp *interp, CONST TkFontAttributes *faPtr, Tcl_Obj *objPtr)); static LayoutChunk * NewChunk _ANSI_ARGS_((TextLayout **layoutPtrPtr, @@ -218,12 +339,27 @@ static int ParseFontNameObj _ANSI_ARGS_((Tcl_Interp *interp, Tk_Window tkwin, Tcl_Obj *objPtr, TkFontAttributes *faPtr)); static void RecomputeWidgets _ANSI_ARGS_((TkWindow *winPtr)); +static int SetFontFromAny _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); static void TheWorldHasChanged _ANSI_ARGS_(( ClientData clientData)); -static void UpdateDependantFonts _ANSI_ARGS_((TkFontInfo *fiPtr, +static void UpdateDependentFonts _ANSI_ARGS_((TkFontInfo *fiPtr, Tk_Window tkwin, Tcl_HashEntry *namedHashPtr)); - +/* + * The following structure defines the implementation of the "font" Tcl + * object, used for drawing. The internalRep.twoPtrValue.ptr1 field of + * each font object points to the TkFont structure for the font, or + * NULL. + */ + +static Tcl_ObjType fontObjType = { + "font", /* name */ + FreeFontObjProc, /* freeIntRepProc */ + DupFontObjProc, /* dupIntRepProc */ + NULL, /* updateStringProc */ + SetFontFromAny /* setFromAnyProc */ +}; /* @@ -236,8 +372,8 @@ static void UpdateDependantFonts _ANSI_ARGS_((TkFontInfo *fiPtr, * package on a per application basis. * * Results: - * Returns a token that must be stored in the TkMainInfo for this - * application. + * Stores a token in the mainPtr to hold information needed by this + * package on a per application basis. * * Side effects: * Memory allocated. @@ -251,11 +387,13 @@ TkFontPkgInit(mainPtr) TkFontInfo *fiPtr; fiPtr = (TkFontInfo *) ckalloc(sizeof(TkFontInfo)); - Tcl_InitHashTable(&fiPtr->fontCache, sizeof(CachedFontKey) / sizeof(int)); - Tcl_InitHashTable(&fiPtr->namedTable, TCL_ONE_WORD_KEYS); + Tcl_InitHashTable(&fiPtr->fontCache, TCL_STRING_KEYS); + Tcl_InitHashTable(&fiPtr->namedTable, TCL_STRING_KEYS); fiPtr->mainPtr = mainPtr; fiPtr->updatePending = 0; mainPtr->fontInfoPtr = fiPtr; + + TkpFontPkgInit(mainPtr); } /* @@ -281,12 +419,21 @@ TkFontPkgFree(mainPtr) TkMainInfo *mainPtr; /* The application being deleted. */ { TkFontInfo *fiPtr; - Tcl_HashEntry *hPtr; + Tcl_HashEntry *hPtr, *searchPtr; Tcl_HashSearch search; + int fontsLeft; fiPtr = mainPtr->fontInfoPtr; - if (fiPtr->fontCache.numEntries != 0) { + fontsLeft = 0; + for (searchPtr = Tcl_FirstHashEntry(&fiPtr->fontCache, &search); + searchPtr != NULL; + searchPtr = Tcl_NextHashEntry(&search)) { + fontsLeft++; + fprintf(stderr, "Font %s still in cache.\n", + Tcl_GetHashKey(&fiPtr->fontCache, searchPtr)); + } + if (fontsLeft) { panic("TkFontPkgFree: all fonts should have been freed already"); } Tcl_DeleteHashTable(&fiPtr->fontCache); @@ -368,7 +515,7 @@ Tk_FontObjCmd(clientData, interp, objc, objv) "font ?-displayof window? ?option?"); return TCL_ERROR; } - tkfont = Tk_GetFontFromObj(interp, tkwin, objv[2]); + tkfont = Tk_AllocFontFromObj(interp, tkwin, objv[2]); if (tkfont == NULL) { return TCL_ERROR; } @@ -394,14 +541,14 @@ Tk_FontObjCmd(clientData, interp, objc, objv) Tcl_WrongNumArgs(interp, 2, objv, "fontname ?options?"); return TCL_ERROR; } - string = Tk_GetUid(Tcl_GetStringFromObj(objv[2], NULL)); + string = Tcl_GetString(objv[2]); namedHashPtr = Tcl_FindHashEntry(&fiPtr->namedTable, string); nfPtr = NULL; /* lint. */ if (namedHashPtr != NULL) { nfPtr = (NamedFont *) Tcl_GetHashValue(namedHashPtr); } if ((namedHashPtr == NULL) || (nfPtr->deletePending != 0)) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "named font \"", string, + Tcl_AppendResult(interp, "named font \"", string, "\" doesn't exist", NULL); return TCL_ERROR; } @@ -412,7 +559,7 @@ Tk_FontObjCmd(clientData, interp, objc, objv) } else { result = ConfigAttributesObj(interp, tkwin, objc - 3, objv + 3, &nfPtr->fa); - UpdateDependantFonts(fiPtr, tkwin, namedHashPtr); + UpdateDependentFonts(fiPtr, tkwin, namedHashPtr); return result; } return GetAttributeInfoObj(interp, &nfPtr->fa, objPtr); @@ -420,7 +567,7 @@ Tk_FontObjCmd(clientData, interp, objc, objv) case FONT_CREATE: { int skip, i; char *name; - char buf[32]; + char buf[16 + TCL_INTEGER_SPACE]; TkFontAttributes fa; Tcl_HashEntry *namedHashPtr; @@ -428,7 +575,7 @@ Tk_FontObjCmd(clientData, interp, objc, objv) if (objc < 3) { name = NULL; } else { - name = Tcl_GetStringFromObj(objv[2], NULL); + name = Tcl_GetString(objv[2]); if (name[0] == '-') { name = NULL; } @@ -440,8 +587,7 @@ Tk_FontObjCmd(clientData, interp, objc, objv) for (i = 1; ; i++) { sprintf(buf, "font%d", i); - namedHashPtr = Tcl_FindHashEntry(&fiPtr->namedTable, - Tk_GetUid(buf)); + namedHashPtr = Tcl_FindHashEntry(&fiPtr->namedTable, buf); if (namedHashPtr == NULL) { break; } @@ -454,10 +600,10 @@ Tk_FontObjCmd(clientData, interp, objc, objv) &fa) != TCL_OK) { return TCL_ERROR; } - if (TkCreateNamedFont(interp, tkwin, name, &fa) != TCL_OK) { + if (CreateNamedFont(interp, tkwin, name, &fa) != TCL_OK) { return TCL_ERROR; } - Tcl_SetStringObj(Tcl_GetObjResult(interp), name, -1); + Tcl_AppendResult(interp, name, NULL); break; } case FONT_DELETE: { @@ -476,10 +622,10 @@ Tk_FontObjCmd(clientData, interp, objc, objv) return TCL_ERROR; } for (i = 2; i < objc; i++) { - string = Tk_GetUid(Tcl_GetStringFromObj(objv[i], NULL)); + string = Tcl_GetString(objv[i]); namedHashPtr = Tcl_FindHashEntry(&fiPtr->namedTable, string); if (namedHashPtr == NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "named font \"", string, + Tcl_AppendResult(interp, "named font \"", string, "\" doesn't exist", (char *) NULL); return TCL_ERROR; } @@ -511,6 +657,7 @@ Tk_FontObjCmd(clientData, interp, objc, objv) char *string; Tk_Font tkfont; int length, skip; + Tcl_Obj *resultPtr; skip = TkGetDisplayOf(interp, objc - 3, objv + 3, &tkwin); if (skip < 0) { @@ -521,17 +668,17 @@ Tk_FontObjCmd(clientData, interp, objc, objv) "font ?-displayof window? text"); return TCL_ERROR; } - tkfont = Tk_GetFontFromObj(interp, tkwin, objv[2]); + tkfont = Tk_AllocFontFromObj(interp, tkwin, objv[2]); if (tkfont == NULL) { return TCL_ERROR; } string = Tcl_GetStringFromObj(objv[3 + skip], &length); - Tcl_SetIntObj(Tcl_GetObjResult(interp), Tk_TextWidth(tkfont, string, length)); + resultPtr = Tcl_GetObjResult(interp); + Tcl_SetIntObj(resultPtr, Tk_TextWidth(tkfont, string, length)); Tk_FreeFont(tkfont); break; } case FONT_METRICS: { - char buf[64]; Tk_Font tkfont; int skip, index, i; CONST TkFontMetrics *fmPtr; @@ -548,7 +695,7 @@ Tk_FontObjCmd(clientData, interp, objc, objv) "font ?-displayof window? ?option?"); return TCL_ERROR; } - tkfont = Tk_GetFontFromObj(interp, tkwin, objv[2]); + tkfont = Tk_AllocFontFromObj(interp, tkwin, objv[2]); if (tkfont == NULL) { return TCL_ERROR; } @@ -556,11 +703,13 @@ Tk_FontObjCmd(clientData, interp, objc, objv) objv += skip; fmPtr = GetFontMetrics(tkfont); if (objc == 3) { + char buf[64 + TCL_INTEGER_SPACE * 4]; + sprintf(buf, "-ascent %d -descent %d -linespace %d -fixed %d", fmPtr->ascent, fmPtr->descent, fmPtr->ascent + fmPtr->descent, fmPtr->fixed); - Tcl_SetStringObj(Tcl_GetObjResult(interp), buf, -1); + Tcl_AppendResult(interp, buf, NULL); } else { if (Tcl_GetIndexFromObj(interp, objv[3], switches, "metric", 0, &index) != TCL_OK) { @@ -582,22 +731,23 @@ Tk_FontObjCmd(clientData, interp, objc, objv) } case FONT_NAMES: { char *string; - Tcl_Obj *strPtr; NamedFont *nfPtr; Tcl_HashSearch search; Tcl_HashEntry *namedHashPtr; + Tcl_Obj *strPtr, *resultPtr; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "names"); return TCL_ERROR; } + resultPtr = Tcl_GetObjResult(interp); namedHashPtr = Tcl_FirstHashEntry(&fiPtr->namedTable, &search); while (namedHashPtr != NULL) { nfPtr = (NamedFont *) Tcl_GetHashValue(namedHashPtr); if (nfPtr->deletePending == 0) { string = Tcl_GetHashKey(&fiPtr->namedTable, namedHashPtr); strPtr = Tcl_NewStringObj(string, -1); - Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), strPtr); + Tcl_ListObjAppendElement(NULL, resultPtr, strPtr); } namedHashPtr = Tcl_NextHashEntry(&search); } @@ -610,7 +760,7 @@ Tk_FontObjCmd(clientData, interp, objc, objv) /* *--------------------------------------------------------------------------- * - * UpdateDependantFonts, TheWorldHasChanged, RecomputeWidgets -- + * UpdateDependentFonts, TheWorldHasChanged, RecomputeWidgets -- * * Called when the attributes of a named font changes. Updates all * the instantiated fonts that depend on that named font and then @@ -627,7 +777,7 @@ Tk_FontObjCmd(clientData, interp, objc, objv) */ static void -UpdateDependantFonts(fiPtr, tkwin, namedHashPtr) +UpdateDependentFonts(fiPtr, tkwin, namedHashPtr) TkFontInfo *fiPtr; /* Info about application's fonts. */ Tk_Window tkwin; /* A window in the application. */ Tcl_HashEntry *namedHashPtr;/* The named font that is changing. */ @@ -647,15 +797,16 @@ UpdateDependantFonts(fiPtr, tkwin, namedHashPtr) return; } - cacheHashPtr = Tcl_FirstHashEntry(&fiPtr->fontCache, &search); while (cacheHashPtr != NULL) { - fontPtr = (TkFont *) Tcl_GetHashValue(cacheHashPtr); - if (fontPtr->namedHashPtr == namedHashPtr) { - TkpGetFontFromAttributes(fontPtr, tkwin, &nfPtr->fa); - if (fiPtr->updatePending == 0) { - fiPtr->updatePending = 1; - Tcl_DoWhenIdle(TheWorldHasChanged, (ClientData) fiPtr); + for (fontPtr = (TkFont *) Tcl_GetHashValue(cacheHashPtr); + fontPtr->nextPtr != NULL; fontPtr = fontPtr->nextPtr) { + if (fontPtr->namedHashPtr == namedHashPtr) { + TkpGetFontFromAttributes(fontPtr, tkwin, &nfPtr->fa); + if (fiPtr->updatePending == 0) { + fiPtr->updatePending = 1; + Tcl_DoWhenIdle(TheWorldHasChanged, (ClientData) fiPtr); + } } } cacheHashPtr = Tcl_NextHashEntry(&search); @@ -690,7 +841,7 @@ RecomputeWidgets(winPtr) /* *--------------------------------------------------------------------------- * - * TkCreateNamedFont -- + * CreateNamedFont -- * * Create the specified named font with the given attributes in the * named font table associated with the interp. @@ -698,7 +849,7 @@ RecomputeWidgets(winPtr) * Results: * Returns TCL_OK if the font was successfully created, or TCL_ERROR * if the named font already existed. If TCL_ERROR is returned, an - * error message is left in interp->result. + * error message is left in the interp's result. * * Side effects: * Assume there used to exist a named font by the specified name, and @@ -711,8 +862,8 @@ RecomputeWidgets(winPtr) *--------------------------------------------------------------------------- */ -int -TkCreateNamedFont(interp, tkwin, name, faPtr) +static int +CreateNamedFont(interp, tkwin, name, faPtr) Tcl_Interp *interp; /* Interp for error return. */ Tk_Window tkwin; /* A window associated with interp. */ CONST char *name; /* Name for the new named font. */ @@ -725,14 +876,13 @@ TkCreateNamedFont(interp, tkwin, name, faPtr) fiPtr = ((TkWindow *) tkwin)->mainPtr->fontInfoPtr; - name = Tk_GetUid(name); namedHashPtr = Tcl_CreateHashEntry(&fiPtr->namedTable, name, &new); if (new == 0) { nfPtr = (NamedFont *) Tcl_GetHashValue(namedHashPtr); if (nfPtr->deletePending == 0) { - interp->result[0] = '\0'; - Tcl_AppendResult(interp, "font \"", name, + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "named font \"", name, "\" already exists", (char *) NULL); return TCL_ERROR; } @@ -745,7 +895,7 @@ TkCreateNamedFont(interp, tkwin, name, faPtr) nfPtr->fa = *faPtr; nfPtr->deletePending = 0; - UpdateDependantFonts(fiPtr, tkwin, namedHashPtr); + UpdateDependentFonts(fiPtr, tkwin, namedHashPtr); return TCL_OK; } @@ -769,13 +919,13 @@ TkCreateNamedFont(interp, tkwin, name, faPtr) * Results: * The return value is token for the font, or NULL if an error * prevented the font from being created. If NULL is returned, an - * error message will be left in interp->result. + * error message will be left in the interp's result. * * Side effects: - * Calls Tk_GetFontFromObj(), which modifies interp's result object, - * then copies the string from the result object into interp->result. - * This procedure will go away when Tk_ConfigureWidget() is - * made into an object command. + * The font is added to an internal database with a reference + * count. For each call to this procedure, there should eventually + * be a call to Tk_FreeFont() or Tk_FreeFontFromObj() so that the + * database is cleaned up when fonts aren't in use anymore. * *--------------------------------------------------------------------------- */ @@ -787,26 +937,20 @@ Tk_GetFont(interp, tkwin, string) CONST char *string; /* String describing font, as: named font, * native format, or parseable string. */ { + Tk_Font tkfont; Tcl_Obj *strPtr; - Tk_Font tkfont; - - strPtr = Tcl_NewStringObj((char *) string, -1); - - tkfont = Tk_GetFontFromObj(interp, tkwin, strPtr); - if (tkfont == NULL) { - Tcl_SetResult(interp, - Tcl_GetStringFromObj(Tcl_GetObjResult(interp), NULL), - TCL_VOLATILE); - } - Tcl_DecrRefCount(strPtr); /* done with object */ + strPtr = Tcl_NewStringObj((char *) string, -1); + Tcl_IncrRefCount(strPtr); + tkfont = Tk_AllocFontFromObj(interp, tkwin, strPtr); + Tcl_DecrRefCount(strPtr); return tkfont; } /* *--------------------------------------------------------------------------- * - * Tk_GetFontFromObj -- + * Tk_AllocFontFromObj -- * * Given a string description of a font, map the description to a * corresponding Tk_Font that represents the font. @@ -819,46 +963,77 @@ Tk_GetFont(interp, tkwin, string) * Side effects: * The font is added to an internal database with a reference * count. For each call to this procedure, there should eventually - * be a call to Tk_FreeFont() so that the database is cleaned up when - * fonts aren't in use anymore. + * be a call to Tk_FreeFont() or Tk_FreeFontFromObj() so that the + * database is cleaned up when fonts aren't in use anymore. * *--------------------------------------------------------------------------- */ Tk_Font -Tk_GetFontFromObj(interp, tkwin, objPtr) +Tk_AllocFontFromObj(interp, tkwin, objPtr) Tcl_Interp *interp; /* Interp for database and error return. */ - Tk_Window tkwin; /* For display on which font will be used. */ + Tk_Window tkwin; /* For screen on which font will be used. */ Tcl_Obj *objPtr; /* Object describing font, as: named font, * native format, or parseable string. */ { TkFontInfo *fiPtr; - CachedFontKey key; Tcl_HashEntry *cacheHashPtr, *namedHashPtr; - TkFont *fontPtr; + TkFont *fontPtr, *firstFontPtr, *oldFontPtr; int new, descent; NamedFont *nfPtr; - char *string; - + fiPtr = ((TkWindow *) tkwin)->mainPtr->fontInfoPtr; - string = Tcl_GetStringFromObj(objPtr, NULL); + if (objPtr->typePtr != &fontObjType) { + SetFontFromAny(interp, objPtr); + } - key.display = Tk_Display(tkwin); - key.string = Tk_GetUid(string); - cacheHashPtr = Tcl_CreateHashEntry(&fiPtr->fontCache, (char *) &key, &new); + oldFontPtr = (TkFont *) objPtr->internalRep.twoPtrValue.ptr1; - if (new == 0) { - /* - * We have already constructed a font with this description for - * this display. Bump the reference count of the cached font. - */ + if (oldFontPtr != NULL) { + if (oldFontPtr->resourceRefCount == 0) { + /* + * This is a stale reference: it refers to a TkFont that's + * no longer in use. Clear the reference. + */ + + FreeFontObjProc(objPtr); + oldFontPtr = NULL; + } else if (Tk_Screen(tkwin) == oldFontPtr->screen) { + oldFontPtr->resourceRefCount++; + return (Tk_Font) oldFontPtr; + } + } + + /* + * Next, search the list of fonts that have the name we want, to see + * if one of them is for the right screen. + */ - fontPtr = (TkFont *) Tcl_GetHashValue(cacheHashPtr); - fontPtr->refCount++; - return (Tk_Font) fontPtr; + new = 0; + if (oldFontPtr != NULL) { + cacheHashPtr = oldFontPtr->cacheHashPtr; + FreeFontObjProc(objPtr); + } else { + cacheHashPtr = Tcl_CreateHashEntry(&fiPtr->fontCache, + Tcl_GetString(objPtr), &new); + } + firstFontPtr = (TkFont *) Tcl_GetHashValue(cacheHashPtr); + for (fontPtr = firstFontPtr; (fontPtr != NULL); + fontPtr = fontPtr->nextPtr) { + if (Tk_Screen(tkwin) == fontPtr->screen) { + fontPtr->resourceRefCount++; + fontPtr->objRefCount++; + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) fontPtr; + return (Tk_Font) fontPtr; + } } - namedHashPtr = Tcl_FindHashEntry(&fiPtr->namedTable, key.string); + /* + * The desired font isn't in the table. Make a new one. + */ + + namedHashPtr = Tcl_FindHashEntry(&fiPtr->namedTable, + Tcl_GetString(objPtr)); if (namedHashPtr != NULL) { /* * Construct a font based on a named font. @@ -873,15 +1048,19 @@ Tk_GetFontFromObj(interp, tkwin, objPtr) * Native font? */ - fontPtr = TkpGetNativeFont(tkwin, string); + fontPtr = TkpGetNativeFont(tkwin, Tcl_GetString(objPtr)); if (fontPtr == NULL) { TkFontAttributes fa; + Tcl_Obj *dupObjPtr = Tcl_DuplicateObj(objPtr); - TkInitFontAttributes(&fa); - if (ParseFontNameObj(interp, tkwin, objPtr, &fa) != TCL_OK) { - Tcl_DeleteHashEntry(cacheHashPtr); + if (ParseFontNameObj(interp, tkwin, dupObjPtr, &fa) != TCL_OK) { + if (new) { + Tcl_DeleteHashEntry(cacheHashPtr); + } + Tcl_DecrRefCount(dupObjPtr); return NULL; } + Tcl_DecrRefCount(dupObjPtr); /* * String contained the attributes inline. @@ -890,13 +1069,16 @@ Tk_GetFontFromObj(interp, tkwin, objPtr) fontPtr = TkpGetFontFromAttributes(NULL, tkwin, &fa); } } - Tcl_SetHashValue(cacheHashPtr, fontPtr); - fontPtr->refCount = 1; - fontPtr->cacheHashPtr = cacheHashPtr; - fontPtr->namedHashPtr = namedHashPtr; + fontPtr->resourceRefCount = 1; + fontPtr->objRefCount = 1; + fontPtr->cacheHashPtr = cacheHashPtr; + fontPtr->namedHashPtr = namedHashPtr; + fontPtr->screen = Tk_Screen(tkwin); + fontPtr->nextPtr = firstFontPtr; + Tcl_SetHashValue(cacheHashPtr, fontPtr); - Tk_MeasureChars((Tk_Font) fontPtr, "0", 1, 0, 0, &fontPtr->tabWidth); + Tk_MeasureChars((Tk_Font) fontPtr, "0", 1, -1, 0, &fontPtr->tabWidth); if (fontPtr->tabWidth == 0) { fontPtr->tabWidth = fontPtr->fm.maxWidth; } @@ -918,7 +1100,7 @@ Tk_GetFontFromObj(interp, tkwin, objPtr) descent = fontPtr->fm.descent; fontPtr->underlinePos = descent / 2; - fontPtr->underlineHeight = fontPtr->fa.pointsize / 10; + fontPtr->underlineHeight = TkFontGetPixels(tkwin, fontPtr->fa.size) / 10; if (fontPtr->underlineHeight == 0) { fontPtr->underlineHeight = 1; } @@ -936,10 +1118,125 @@ Tk_GetFontFromObj(interp, tkwin, objPtr) } } + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) fontPtr; return (Tk_Font) fontPtr; } /* + *---------------------------------------------------------------------- + * + * Tk_GetFontFromObj -- + * + * Find the font that corresponds to a given object. The font must + * have already been created by Tk_GetFont or Tk_AllocFontFromObj. + * + * Results: + * The return value is a token for the font that matches objPtr + * and is suitable for use in tkwin. + * + * Side effects: + * If the object is not already a font ref, the conversion will free + * any old internal representation. + * + *---------------------------------------------------------------------- + */ + +Tk_Font +Tk_GetFontFromObj(tkwin, objPtr) + Tk_Window tkwin; /* The window that the font will be used in. */ + Tcl_Obj *objPtr; /* The object from which to get the font. */ +{ + TkFontInfo *fiPtr = ((TkWindow *) tkwin)->mainPtr->fontInfoPtr; + TkFont *fontPtr; + Tcl_HashEntry *hashPtr; + + if (objPtr->typePtr != &fontObjType) { + SetFontFromAny((Tcl_Interp *) NULL, objPtr); + } + + fontPtr = (TkFont *) objPtr->internalRep.twoPtrValue.ptr1; + + if (fontPtr != NULL) { + if (fontPtr->resourceRefCount == 0) { + /* + * This is a stale reference: it refers to a TkFont that's + * no longer in use. Clear the reference. + */ + + FreeFontObjProc(objPtr); + fontPtr = NULL; + } else if (Tk_Screen(tkwin) == fontPtr->screen) { + return (Tk_Font) fontPtr; + } + } + + /* + * Next, search the list of fonts that have the name we want, to see + * if one of them is for the right screen. + */ + + if (fontPtr != NULL) { + hashPtr = fontPtr->cacheHashPtr; + FreeFontObjProc(objPtr); + } else { + hashPtr = Tcl_FindHashEntry(&fiPtr->fontCache, Tcl_GetString(objPtr)); + } + if (hashPtr != NULL) { + for (fontPtr = (TkFont *) Tcl_GetHashValue(hashPtr); fontPtr != NULL; + fontPtr = fontPtr->nextPtr) { + if (Tk_Screen(tkwin) == fontPtr->screen) { + fontPtr->objRefCount++; + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) fontPtr; + return (Tk_Font) fontPtr; + } + } + } + + panic("Tk_GetFontFromObj called with non-existent font!"); + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * SetFontFromAny -- + * + * Convert the internal representation of a Tcl object to the + * font internal form. + * + * Results: + * Always returns TCL_OK. + * + * Side effects: + * The object is left with its typePtr pointing to fontObjType. + * The TkFont pointer is NULL. + * + *---------------------------------------------------------------------- + */ + +static int +SetFontFromAny(interp, objPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr; /* The object to convert. */ +{ + Tcl_ObjType *typePtr; + + /* + * Free the old internalRep before setting the new one. + */ + + Tcl_GetString(objPtr); + typePtr = objPtr->typePtr; + if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { + (*typePtr->freeIntRepProc)(objPtr); + } + objPtr->typePtr = &fontObjType; + objPtr->internalRep.twoPtrValue.ptr1 = NULL; + + return TCL_OK; +} + +/* *--------------------------------------------------------------------------- * * Tk_NameOfFont -- @@ -963,14 +1260,9 @@ Tk_NameOfFont(tkfont) Tk_Font tkfont; /* Font whose name is desired. */ { TkFont *fontPtr; - Tcl_HashEntry *hPtr; - CachedFontKey *keyPtr; fontPtr = (TkFont *) tkfont; - hPtr = fontPtr->cacheHashPtr; - - keyPtr = (CachedFontKey *) Tcl_GetHashKey(hPtr->tablePtr, hPtr); - return (char *) keyPtr->string; + return fontPtr->cacheHashPtr->key.string; } /* @@ -994,30 +1286,144 @@ void Tk_FreeFont(tkfont) Tk_Font tkfont; /* Font to be released. */ { - TkFont *fontPtr; + TkFont *fontPtr, *prevPtr; NamedFont *nfPtr; if (tkfont == NULL) { return; } fontPtr = (TkFont *) tkfont; - fontPtr->refCount--; - if (fontPtr->refCount == 0) { - if (fontPtr->namedHashPtr != NULL) { - /* - * The font is being deleted. Determine if the associated named - * font definition should and/or can be deleted too. - */ + fontPtr->resourceRefCount--; + if (fontPtr->resourceRefCount > 0) { + return; + } + if (fontPtr->namedHashPtr != NULL) { + /* + * This font derived from a named font. Reduce the reference + * count on the named font and free it if no-one else is + * using it. + */ - nfPtr = (NamedFont *) Tcl_GetHashValue(fontPtr->namedHashPtr); - nfPtr->refCount--; - if ((nfPtr->refCount == 0) && (nfPtr->deletePending != 0)) { - Tcl_DeleteHashEntry(fontPtr->namedHashPtr); - ckfree((char *) nfPtr); - } + nfPtr = (NamedFont *) Tcl_GetHashValue(fontPtr->namedHashPtr); + nfPtr->refCount--; + if ((nfPtr->refCount == 0) && (nfPtr->deletePending != 0)) { + Tcl_DeleteHashEntry(fontPtr->namedHashPtr); + ckfree((char *) nfPtr); + } + } + + prevPtr = (TkFont *) Tcl_GetHashValue(fontPtr->cacheHashPtr); + if (prevPtr == fontPtr) { + if (fontPtr->nextPtr == NULL) { + Tcl_DeleteHashEntry(fontPtr->cacheHashPtr); + } else { + Tcl_SetHashValue(fontPtr->cacheHashPtr, fontPtr->nextPtr); + } + } else { + while (prevPtr->nextPtr != fontPtr) { + prevPtr = prevPtr->nextPtr; + } + prevPtr->nextPtr = fontPtr->nextPtr; + } + + TkpDeleteFont(fontPtr); + if (fontPtr->objRefCount == 0) { + ckfree((char *) fontPtr); + } +} + +/* + *--------------------------------------------------------------------------- + * + * Tk_FreeFontFromObj -- + * + * Called to release a font inside a Tcl_Obj *. Decrements the refCount + * of the font and removes it from the hash tables if necessary. + * + * Results: + * None. + * + * Side effects: + * The reference count associated with font is decremented, and + * only deallocated when no one is using it. + * + *--------------------------------------------------------------------------- + */ + +void +Tk_FreeFontFromObj(tkwin, objPtr) + Tk_Window tkwin; /* The window this font lives in. Needed + * for the screen value. */ + Tcl_Obj *objPtr; /* The Tcl_Obj * to be freed. */ +{ + Tk_FreeFont(Tk_GetFontFromObj(tkwin, objPtr)); +} + +/* + *--------------------------------------------------------------------------- + * + * FreeFontObjProc -- + * + * This proc is called to release an object reference to a font. + * Called when the object's internal rep is released or when + * the cached fontPtr needs to be changed. + * + * Results: + * None. + * + * Side effects: + * The object reference count is decremented. When both it + * and the hash ref count go to zero, the font's resources + * are released. + * + *--------------------------------------------------------------------------- + */ + +static void +FreeFontObjProc(objPtr) + Tcl_Obj *objPtr; /* The object we are releasing. */ +{ + TkFont *fontPtr = (TkFont *) objPtr->internalRep.twoPtrValue.ptr1; + + if (fontPtr != NULL) { + fontPtr->objRefCount--; + if ((fontPtr->resourceRefCount == 0) && (fontPtr->objRefCount == 0)) { + ckfree((char *) fontPtr); + objPtr->internalRep.twoPtrValue.ptr1 = NULL; } - Tcl_DeleteHashEntry(fontPtr->cacheHashPtr); - TkpDeleteFont(fontPtr); + } +} + +/* + *--------------------------------------------------------------------------- + * + * DupFontObjProc -- + * + * When a cached font object is duplicated, this is called to + * update the internal reps. + * + * Results: + * None. + * + * Side effects: + * The font's objRefCount is incremented and the internal rep + * of the copy is set to point to it. + * + *--------------------------------------------------------------------------- + */ + +static void +DupFontObjProc(srcObjPtr, dupObjPtr) + Tcl_Obj *srcObjPtr; /* The object we are copying from. */ + Tcl_Obj *dupObjPtr; /* The object we are copying to. */ +{ + TkFont *fontPtr = (TkFont *) srcObjPtr->internalRep.twoPtrValue.ptr1; + + dupObjPtr->typePtr = srcObjPtr->typePtr; + dupObjPtr->internalRep.twoPtrValue.ptr1 = (VOID *) fontPtr; + + if (fontPtr != NULL) { + fontPtr->objRefCount++; } } @@ -1112,7 +1518,6 @@ Tk_GetFontMetrics(tkfont, fmPtr) *--------------------------------------------------------------------------- */ - int Tk_PostscriptFontName(tkfont, dsPtr) Tk_Font tkfont; /* Font in which text will be printed. */ @@ -1154,6 +1559,8 @@ Tk_PostscriptFontName(tkfont, dsPtr) } else if (strcasecmp(family, "ZapfDingbats") == 0) { family = "ZapfDingbats"; } else { + Tcl_UniChar ch; + /* * Inline, capitalize the first letter of each word, lowercase the * rest of the letters in each word, and then take out the spaces @@ -1165,16 +1572,19 @@ Tk_PostscriptFontName(tkfont, dsPtr) src = dest = Tcl_DStringValue(dsPtr) + len; upper = 1; - for (; *src != '\0'; src++, dest++) { - while (isspace(UCHAR(*src))) { + for (; *src != '\0'; ) { + while (isspace(UCHAR(*src))) { /* INTL: ISO space */ src++; upper = 1; } - *dest = *src; - if ((upper != 0) && (islower(UCHAR(*src)))) { - *dest = toupper(UCHAR(*src)); + src += Tcl_UtfToUniChar(src, &ch); + if (upper) { + ch = Tcl_UniCharToUpper(ch); + upper = 0; + } else { + ch = Tcl_UniCharToLower(ch); } - upper = 0; + dest += Tcl_UniCharToUtf(ch, dest); } *dest = '\0'; Tcl_DStringSetLength(dsPtr, dest - Tcl_DStringValue(dsPtr)); @@ -1251,7 +1661,7 @@ Tk_PostscriptFontName(tkfont, dsPtr) } } - return fontPtr->fa.pointsize; + return fontPtr->fa.size; } /* @@ -1284,7 +1694,7 @@ Tk_TextWidth(tkfont, string, numChars) if (numChars < 0) { numChars = strlen(string); } - Tk_MeasureChars(tkfont, string, numChars, 0, 0, &width); + Tk_MeasureChars(tkfont, string, numChars, -1, 0, &width); return width; } @@ -1332,8 +1742,8 @@ Tk_UnderlineChars(display, drawable, gc, tkfont, string, x, y, firstChar, fontPtr = (TkFont *) tkfont; - Tk_MeasureChars(tkfont, string, firstChar, 0, 0, &startX); - Tk_MeasureChars(tkfont, string, lastChar, 0, 0, &endX); + Tk_MeasureChars(tkfont, string, firstChar, -1, 0, &startX); + Tk_MeasureChars(tkfont, string, lastChar, -1, 0, &endX); XFillRectangle(display, drawable, gc, x + startX, y + fontPtr->underlinePos, (unsigned int) (endX - startX), @@ -1399,13 +1809,11 @@ Tk_ComputeTextLayout(tkfont, string, numChars, wrapLength, justify, flags, TextLayout *layoutPtr; LayoutChunk *chunkPtr; CONST TkFontMetrics *fmPtr; -#define MAX_LINES 50 - int staticLineLengths[MAX_LINES]; + Tcl_DString lineBuffer; int *lineLengths; - int maxLines, curLine, layoutHeight; + int curLine, layoutHeight; - lineLengths = staticLineLengths; - maxLines = MAX_LINES; + Tcl_DStringInit(&lineBuffer); fontPtr = (TkFont *) tkfont; fmPtr = &fontPtr->fm; @@ -1415,6 +1823,9 @@ Tk_ComputeTextLayout(tkfont, string, numChars, wrapLength, justify, flags, if (numChars < 0) { numChars = strlen(string); } + if (wrapLength == 0) { + wrapLength = -1; + } maxChunks = 1; @@ -1438,7 +1849,6 @@ Tk_ComputeTextLayout(tkfont, string, numChars, wrapLength, justify, flags, flags &= TK_IGNORE_TABS | TK_IGNORE_NEWLINES; flags |= TK_WHOLE_WORDS | TK_AT_LEAST_ONE; - curLine = 0; for (start = string; start < end; ) { if (start >= special) { /* @@ -1515,7 +1925,7 @@ Tk_ComputeTextLayout(tkfont, string, numChars, wrapLength, justify, flags, * Consume all extra spaces at end of line. */ - while ((start < end) && isspace(UCHAR(*start))) { + while ((start < end) && isspace(UCHAR(*start))) { /* INTL: ISO space */ if (!(flags & TK_IGNORE_NEWLINES)) { if ((*start == '\n') || (*start == '\r')) { break; @@ -1537,7 +1947,7 @@ Tk_ComputeTextLayout(tkfont, string, numChars, wrapLength, justify, flags, if (charsThisChunk > 0) { chunkPtr->numChars += Tk_MeasureChars(tkfont, chunkPtr->start + chunkPtr->numChars, charsThisChunk, - 0, 0, &chunkPtr->totalWidth); + -1, 0, &chunkPtr->totalWidth); chunkPtr->totalWidth += curX; } } @@ -1559,19 +1969,7 @@ Tk_ComputeTextLayout(tkfont, string, numChars, wrapLength, justify, flags, * can be centered or right justified, if necessary. */ - if (curLine >= maxLines) { - int *newLengths; - - newLengths = (int *) ckalloc(2 * maxLines * sizeof(int)); - memcpy((void *) newLengths, lineLengths, maxLines * sizeof(int)); - if (lineLengths != staticLineLengths) { - ckfree((char *) lineLengths); - } - lineLengths = newLengths; - maxLines *= 2; - } - lineLengths[curLine] = curX; - curLine++; + Tcl_DStringAppend(&lineBuffer, (char *) &curX, sizeof(curX)); curX = 0; baseline += height; @@ -1588,6 +1986,7 @@ Tk_ComputeTextLayout(tkfont, string, numChars, wrapLength, justify, flags, chunkPtr = NewChunk(&layoutPtr, &maxChunks, start, 0, curX, 1000000000, baseline); chunkPtr->numDisplayChars = -1; + Tcl_DStringAppend(&lineBuffer, (char *) &curX, sizeof(curX)); baseline += height; } } @@ -1600,6 +1999,7 @@ Tk_ComputeTextLayout(tkfont, string, numChars, wrapLength, justify, flags, curLine = 0; chunkPtr = layoutPtr->chunks; y = chunkPtr->y; + lineLengths = (int *) Tcl_DStringValue(&lineBuffer); for (n = 0; n < layoutPtr->numChunks; n++) { int extra; @@ -1643,9 +2043,7 @@ Tk_ComputeTextLayout(tkfont, string, numChars, wrapLength, justify, flags, if (heightPtr != NULL) { *heightPtr = layoutHeight; } - if (lineLengths != staticLineLengths) { - ckfree((char *) lineLengths); - } + Tcl_DStringFree(&lineBuffer); return (Tk_TextLayout) layoutPtr; } @@ -1737,7 +2135,7 @@ Tk_DrawTextLayout(display, drawable, gc, layout, x, y, firstChar, lastChar) firstChar = 0; } else { Tk_MeasureChars(layoutPtr->tkfont, chunkPtr->start, firstChar, - 0, 0, &drawX); + -1, 0, &drawX); } if (lastChar < numDisplayChars) { numDisplayChars = lastChar; @@ -1910,9 +2308,9 @@ Tk_PointToChar(layout, x, y) return chunkPtr->start - layoutPtr->string; } n = Tk_MeasureChars((Tk_Font) fontPtr, chunkPtr->start, - chunkPtr->numChars, x + 1 - chunkPtr->x, - TK_PARTIAL_OK, &dummy); - return (chunkPtr->start + n - 1) - layoutPtr->string; + chunkPtr->numChars, x - chunkPtr->x, + 0, &dummy); + return (chunkPtr->start + n) - layoutPtr->string; } lastPtr = chunkPtr; chunkPtr++; @@ -2016,11 +2414,11 @@ Tk_CharBbox(layout, index, xPtr, yPtr, widthPtr, heightPtr) } } else if (index < chunkPtr->numChars) { if (xPtr != NULL) { - Tk_MeasureChars(tkfont, chunkPtr->start, index, 0, 0, &x); + Tk_MeasureChars(tkfont, chunkPtr->start, index, -1, 0, &x); x += chunkPtr->x; } if (widthPtr != NULL) { - Tk_MeasureChars(tkfont, chunkPtr->start + index, 1, 0, 0, &w); + Tk_MeasureChars(tkfont, chunkPtr->start + index, 1, -1, 0, &w); } goto check; } @@ -2276,7 +2674,7 @@ Tk_IntersectTextLayout(layout, x, y, width, height) * location of the baseline for the string. * * Results: - * Interp->result is modified to hold the Postscript code that + * The interp's result is modified to hold the Postscript code that * will render the text layout. * * Side effects: @@ -2359,36 +2757,6 @@ Tk_TextLayoutToPostscript(interp, layout) /* *--------------------------------------------------------------------------- * - * TkInitFontAttributes -- - * - * Initialize the font attributes structure to contain sensible - * values. This must be called before using any other font - * attributes functions. - * - * Results: - * None. - * - * Side effects. - * None. - * - *--------------------------------------------------------------------------- - */ - -void -TkInitFontAttributes(faPtr) - TkFontAttributes *faPtr; /* The attributes structure to initialize. */ -{ - faPtr->family = NULL; - faPtr->pointsize = 0; - faPtr->weight = TK_FW_NORMAL; - faPtr->slant = TK_FS_ROMAN; - faPtr->underline = 0; - faPtr->overstrike = 0; -} - -/* - *--------------------------------------------------------------------------- - * * ConfigAttributesObj -- * * Process command line options to fill in fields of a properly @@ -2419,68 +2787,74 @@ ConfigAttributesObj(interp, tkwin, objc, objv, faPtr) * be properly initialized. */ { int i, n, index; - Tcl_Obj *value; - char *option, *string; + Tcl_Obj *optionPtr, *valuePtr; + char *value; - if (objc & 1) { - string = Tcl_GetStringFromObj(objv[objc - 1], NULL); - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "missing value for \"", - string, "\" option", (char *) NULL); - return TCL_ERROR; - } - for (i = 0; i < objc; i += 2) { - option = Tcl_GetStringFromObj(objv[i], NULL); - value = objv[i + 1]; + optionPtr = objv[i]; + valuePtr = objv[i + 1]; - if (Tcl_GetIndexFromObj(interp, objv[i], fontOpt, "option", 1, + if (Tcl_GetIndexFromObj(interp, optionPtr, fontOpt, "option", 1, &index) != TCL_OK) { return TCL_ERROR; } + if (objc & 1) { + /* + * This test occurs after Tcl_GetIndexFromObj() so that + * "font create xyz -xyz" will return the error message + * that "-xyz" is a bad option, rather than that the value + * for "-xyz" is missing. + */ + + Tcl_AppendResult(interp, "value for \"", + Tcl_GetString(optionPtr), "\" option missing", + (char *) NULL); + return TCL_ERROR; + } + switch (index) { - case FONT_FAMILY: - string = Tcl_GetStringFromObj(value, NULL); - faPtr->family = Tk_GetUid(string); + case FONT_FAMILY: { + value = Tcl_GetString(valuePtr); + faPtr->family = Tk_GetUid(value); break; - - case FONT_SIZE: - if (Tcl_GetIntFromObj(interp, value, &n) != TCL_OK) { + } + case FONT_SIZE: { + if (Tcl_GetIntFromObj(interp, valuePtr, &n) != TCL_OK) { return TCL_ERROR; } - faPtr->pointsize = n; + faPtr->size = n; break; - - case FONT_WEIGHT: - string = Tcl_GetStringFromObj(value, NULL); - n = TkFindStateNum(interp, option, weightMap, string); + } + case FONT_WEIGHT: { + n = TkFindStateNumObj(interp, optionPtr, weightMap, valuePtr); if (n == TK_FW_UNKNOWN) { return TCL_ERROR; } faPtr->weight = n; break; - - case FONT_SLANT: - string = Tcl_GetStringFromObj(value, NULL); - n = TkFindStateNum(interp, option, slantMap, string); + } + case FONT_SLANT: { + n = TkFindStateNumObj(interp, optionPtr, slantMap, valuePtr); if (n == TK_FS_UNKNOWN) { return TCL_ERROR; } faPtr->slant = n; break; - - case FONT_UNDERLINE: - if (Tcl_GetBooleanFromObj(interp, value, &n) != TCL_OK) { + } + case FONT_UNDERLINE: { + if (Tcl_GetBooleanFromObj(interp, valuePtr, &n) != TCL_OK) { return TCL_ERROR; } faPtr->underline = n; break; - - case FONT_OVERSTRIKE: - if (Tcl_GetBooleanFromObj(interp, value, &n) != TCL_OK) { + } + case FONT_OVERSTRIKE: { + if (Tcl_GetBooleanFromObj(interp, valuePtr, &n) != TCL_OK) { return TCL_ERROR; } faPtr->overstrike = n; break; + } } } return TCL_OK; @@ -2515,18 +2889,19 @@ GetAttributeInfoObj(interp, faPtr, objPtr) CONST TkFontAttributes *faPtr; /* The font attributes to inspect. */ Tcl_Obj *objPtr; /* If non-NULL, indicates the single * option whose value is to be - * returned. Otherwise - * information is returned for - * all options. */ + * returned. Otherwise information is + * returned for all options. */ { - int i, index, start, end, num; + int i, index, start, end; char *str; - Tcl_Obj *newPtr; + Tcl_Obj *optionPtr, *valuePtr, *resultPtr; + + resultPtr = Tcl_GetObjResult(interp); start = 0; end = FONT_NUMFIELDS; if (objPtr != NULL) { - if (Tcl_GetIndexFromObj(interp, objPtr, fontOpt, "option", 1, + if (Tcl_GetIndexFromObj(interp, objPtr, fontOpt, "option", TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } @@ -2534,55 +2909,43 @@ GetAttributeInfoObj(interp, faPtr, objPtr) end = index + 1; } + valuePtr = NULL; for (i = start; i < end; i++) { - str = NULL; - num = 0; /* Needed only to prevent compiler - * warning. */ switch (i) { case FONT_FAMILY: str = faPtr->family; - if (str == NULL) { - str = ""; - } + valuePtr = Tcl_NewStringObj(str, ((str == NULL) ? 0 : -1)); break; case FONT_SIZE: - num = faPtr->pointsize; + valuePtr = Tcl_NewIntObj(faPtr->size); break; case FONT_WEIGHT: str = TkFindStateString(weightMap, faPtr->weight); + valuePtr = Tcl_NewStringObj(str, -1); break; case FONT_SLANT: str = TkFindStateString(slantMap, faPtr->slant); + valuePtr = Tcl_NewStringObj(str, -1); break; case FONT_UNDERLINE: - num = faPtr->underline; + valuePtr = Tcl_NewBooleanObj(faPtr->underline); break; case FONT_OVERSTRIKE: - num = faPtr->overstrike; + valuePtr = Tcl_NewBooleanObj(faPtr->overstrike); break; } - if (objPtr == NULL) { - Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), - Tcl_NewStringObj(fontOpt[i], -1)); - if (str != NULL) { - newPtr = Tcl_NewStringObj(str, -1); - } else { - newPtr = Tcl_NewIntObj(num); - } - Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), - newPtr); - } else { - if (str != NULL) { - Tcl_SetStringObj(Tcl_GetObjResult(interp), str, -1); - } else { - Tcl_SetIntObj(Tcl_GetObjResult(interp), num); - } + if (objPtr != NULL) { + Tcl_SetObjResult(interp, valuePtr); + return TCL_OK; } + optionPtr = Tcl_NewStringObj(fontOpt[i], -1); + Tcl_ListObjAppendElement(NULL, resultPtr, optionPtr); + Tcl_ListObjAppendElement(NULL, resultPtr, valuePtr); } return TCL_OK; } @@ -2597,7 +2960,7 @@ GetAttributeInfoObj(interp, faPtr, objPtr) * * The string rep of the object can be one of the following forms: * XLFD (see X documentation) - * "Family [size [style] [style ...]]" + * "family [size] [style1 [style2 ...]" * "-option value [-option value ...]" * * Results: @@ -2614,20 +2977,25 @@ GetAttributeInfoObj(interp, faPtr, objPtr) static int ParseFontNameObj(interp, tkwin, objPtr, faPtr) - Tcl_Interp *interp; /* Interp for error return. */ + Tcl_Interp *interp; /* Interp for error return. Must not be + * NULL. */ Tk_Window tkwin; /* For display on which font is used. */ Tcl_Obj *objPtr; /* Parseable font description object. */ - TkFontAttributes *faPtr; /* Font attributes structure whose fields - * are to be modified. Structure must already - * be properly initialized. */ + TkFontAttributes *faPtr; /* Filled with attributes parsed from font + * name. Any attributes that were not + * specified in font name are filled with + * default values. */ { char *dash; int objc, result, i, n; Tcl_Obj **objv; - TkXLFDAttributes xa; + Tcl_Obj *resultPtr; char *string; - string = Tcl_GetStringFromObj(objPtr, NULL); + TkInitFontAttributes(faPtr); + resultPtr = Tcl_GetObjResult(interp); + + string = Tcl_GetString(objPtr); if (*string == '-') { /* * This may be an XLFD or an "-option value" string. @@ -2640,7 +3008,8 @@ ParseFontNameObj(interp, tkwin, objPtr, faPtr) goto xlfd; } dash = strchr(string + 1, '-'); - if ((dash != NULL) && (!isspace(UCHAR(dash[-1])))) { + if ((dash != NULL) + && (!isspace(UCHAR(dash[-1])))) { /* INTL: ISO space */ goto xlfd; } @@ -2653,15 +3022,16 @@ ParseFontNameObj(interp, tkwin, objPtr, faPtr) if (*string == '*') { /* - * This appears to be an XLFD. + * This is appears to be an XLFD. Under Unix, all valid XLFDs were + * already handled by TkpGetNativeFont. If we are here, either we + * have something that initially looks like an XLFD but isn't or we + * have encountered an XLFD on Windows or Mac. */ xlfd: - xa.fa = *faPtr; - result = TkParseXLFD(string, &xa); + result = TkFontParseXLFD(string, faPtr, NULL); if (result == TCL_OK) { - *faPtr = xa.fa; - return result; + return TCL_OK; } } @@ -2670,21 +3040,19 @@ ParseFontNameObj(interp, tkwin, objPtr, faPtr) * "font size style" list. */ - if (Tcl_ListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) { - return TCL_ERROR; - } - if (objc < 1) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "font \"", string, - "\" doesn't exist", (char *) NULL); + if ((Tcl_ListObjGetElements(NULL, objPtr, &objc, &objv) != TCL_OK) + || (objc < 1)) { + Tcl_AppendResult(interp, "font \"", string, "\" doesn't exist", + (char *) NULL); return TCL_ERROR; } - faPtr->family = Tk_GetUid(Tcl_GetStringFromObj(objv[0], NULL)); + faPtr->family = Tk_GetUid(Tcl_GetString(objv[0])); if (objc > 1) { if (Tcl_GetIntFromObj(interp, objv[1], &n) != TCL_OK) { return TCL_ERROR; } - faPtr->pointsize = n; + faPtr->size = n; } i = 2; @@ -2695,23 +3063,22 @@ ParseFontNameObj(interp, tkwin, objPtr, faPtr) i = 0; } for ( ; i < objc; i++) { - string = Tcl_GetStringFromObj(objv[i], NULL); - n = TkFindStateNum(NULL, NULL, weightMap, string); + n = TkFindStateNumObj(NULL, NULL, weightMap, objv[i]); if (n != TK_FW_UNKNOWN) { faPtr->weight = n; continue; } - n = TkFindStateNum(NULL, NULL, slantMap, string); + n = TkFindStateNumObj(NULL, NULL, slantMap, objv[i]); if (n != TK_FS_UNKNOWN) { faPtr->slant = n; continue; } - n = TkFindStateNum(NULL, NULL, underlineMap, string); + n = TkFindStateNumObj(NULL, NULL, underlineMap, objv[i]); if (n != 0) { faPtr->underline = n; continue; } - n = TkFindStateNum(NULL, NULL, overstrikeMap, string); + n = TkFindStateNumObj(NULL, NULL, overstrikeMap, objv[i]); if (n != 0) { faPtr->overstrike = n; continue; @@ -2721,9 +3088,8 @@ ParseFontNameObj(interp, tkwin, objPtr, faPtr) * Unknown style. */ - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "unknown font style \"", string, "\"", - (char *) NULL); + Tcl_AppendResult(interp, "unknown font style \"", + Tcl_GetString(objv[i]), "\"", (char *) NULL); return TCL_ERROR; } return TCL_OK; @@ -2732,7 +3098,67 @@ ParseFontNameObj(interp, tkwin, objPtr, faPtr) /* *--------------------------------------------------------------------------- * - * TkParseXLFD -- + * NewChunk -- + * + * Helper function for Tk_ComputeTextLayout(). Encapsulates a + * measured set of characters in a chunk that can be quickly + * drawn. + * + * Results: + * A pointer to the new chunk in the text layout. + * + * Side effects: + * The text layout is reallocated to hold more chunks as necessary. + * + * Currently, Tk_ComputeTextLayout() stores contiguous ranges of + * "normal" characters in a chunk, along with individual tab + * and newline chars in their own chunks. All characters in the + * text layout are accounted for. + * + *--------------------------------------------------------------------------- + */ +static LayoutChunk * +NewChunk(layoutPtrPtr, maxPtr, start, numChars, curX, newX, y) + TextLayout **layoutPtrPtr; + int *maxPtr; + CONST char *start; + int numChars; + int curX; + int newX; + int y; +{ + TextLayout *layoutPtr; + LayoutChunk *chunkPtr; + int maxChunks; + size_t s; + + layoutPtr = *layoutPtrPtr; + maxChunks = *maxPtr; + if (layoutPtr->numChunks == maxChunks) { + maxChunks *= 2; + s = sizeof(TextLayout) + ((maxChunks - 1) * sizeof(LayoutChunk)); + layoutPtr = (TextLayout *) ckrealloc((char *) layoutPtr, s); + + *layoutPtrPtr = layoutPtr; + *maxPtr = maxChunks; + } + chunkPtr = &layoutPtr->chunks[layoutPtr->numChunks]; + chunkPtr->start = start; + chunkPtr->numChars = numChars; + chunkPtr->numDisplayChars = numChars; + chunkPtr->x = curX; + chunkPtr->y = y; + chunkPtr->totalWidth = newX - curX; + chunkPtr->displayWidth = newX - curX; + layoutPtr->numChunks++; + + return chunkPtr; +} + +/* + *--------------------------------------------------------------------------- + * + * TkFontParseXLFD -- * * Break up a fully specified XLFD into a set of font attributes. * @@ -2748,18 +3174,31 @@ ParseFontNameObj(interp, tkwin, objPtr, faPtr) */ int -TkParseXLFD(string, xaPtr) +TkFontParseXLFD(string, faPtr, xaPtr) CONST char *string; /* Parseable font description string. */ - TkXLFDAttributes *xaPtr; /* XLFD attributes structure whose fields - * are to be modified. Structure must already - * be properly initialized. */ + TkFontAttributes *faPtr; /* Filled with attributes parsed from font + * name. Any attributes that were not + * specified in font name are filled with + * default values. */ + TkXLFDAttributes *xaPtr; /* Filled with X-specific attributes parsed + * from font name. Any attributes that were + * not specified in font name are filled with + * default values. May be NULL if such + * information is not desired. */ { char *src; CONST char *str; int i, j; char *field[XLFD_NUMFIELDS + 2]; Tcl_DString ds; + TkXLFDAttributes xa; + if (xaPtr == NULL) { + xaPtr = &xa; + } + TkInitFontAttributes(faPtr); + TkInitXLFDAttributes(xaPtr); + memset(field, '\0', sizeof(field)); str = string; @@ -2773,27 +3212,32 @@ TkParseXLFD(string, xaPtr) field[0] = src; for (i = 0; *src != '\0'; src++) { - if (isupper(UCHAR(*src))) { - *src = tolower(UCHAR(*src)); + if (!(*src & 0x90) + && isupper(UCHAR(*src))) { /* INTL: 7-bit ISO only. */ + *src = tolower(UCHAR(*src)); /* INTL: 7-bit ISO only. */ } if (*src == '-') { i++; - if (i > XLFD_NUMFIELDS) { - break; + if (i == XLFD_NUMFIELDS) { + continue; } *src = '\0'; field[i] = src + 1; + if (i > XLFD_NUMFIELDS) { + break; + } } } /* - * An XLFD of the form -adobe-times-medium-r-*-12-*-* is pretty common, + * An XLFD of the form -adobe-times-medium-r-*-12-*-* is pretty common, * but it is (strictly) malformed, because the first * is eliding both * the Setwidth and the Addstyle fields. If the Addstyle field is a * number, then assume the above incorrect form was used and shift all - * the rest of the fields up by one, so the number gets interpreted + * the rest of the fields right by one, so the number gets interpreted * as a pixelsize. This fix is so that we don't get a million reports - * that "it works under X, but gives a syntax error under Windows". + * that "it works under X (as a native font name), but gives a syntax + * error under Windows (as a parsed set of attributes)". */ if ((i > XLFD_ADD_STYLE) && (FieldSpecified(field[XLFD_ADD_STYLE]))) { @@ -2820,19 +3264,19 @@ TkParseXLFD(string, xaPtr) } if (FieldSpecified(field[XLFD_FAMILY])) { - xaPtr->fa.family = Tk_GetUid(field[XLFD_FAMILY]); + faPtr->family = Tk_GetUid(field[XLFD_FAMILY]); } if (FieldSpecified(field[XLFD_WEIGHT])) { - xaPtr->fa.weight = TkFindStateNum(NULL, NULL, xlfdWeightMap, + faPtr->weight = TkFindStateNum(NULL, NULL, xlfdWeightMap, field[XLFD_WEIGHT]); } if (FieldSpecified(field[XLFD_SLANT])) { xaPtr->slant = TkFindStateNum(NULL, NULL, xlfdSlantMap, field[XLFD_SLANT]); if (xaPtr->slant == TK_FS_ROMAN) { - xaPtr->fa.slant = TK_FS_ROMAN; + faPtr->slant = TK_FS_ROMAN; } else { - xaPtr->fa.slant = TK_FS_ITALIC; + faPtr->slant = TK_FS_ITALIC; } } if (FieldSpecified(field[XLFD_SETWIDTH])) { @@ -2843,9 +3287,12 @@ TkParseXLFD(string, xaPtr) /* XLFD_ADD_STYLE ignored. */ /* - * Pointsize in tenths of a point, but treat it as tenths of a pixel. + * Pointsize in tenths of a point, but treat it as tenths of a pixel + * for historical compatibility. */ + faPtr->size = 12; + if (FieldSpecified(field[XLFD_POINT_SIZE])) { if (field[XLFD_POINT_SIZE][0] == '[') { /* @@ -2858,10 +3305,10 @@ TkParseXLFD(string, xaPtr) * the purpose of, so I ignore them. */ - xaPtr->fa.pointsize = atoi(field[XLFD_POINT_SIZE] + 1); + faPtr->size = atoi(field[XLFD_POINT_SIZE] + 1); } else if (Tcl_GetInt(NULL, field[XLFD_POINT_SIZE], - &xaPtr->fa.pointsize) == TCL_OK) { - xaPtr->fa.pointsize /= 10; + &faPtr->size) == TCL_OK) { + faPtr->size /= 10; } else { return TCL_ERROR; } @@ -2883,14 +3330,14 @@ TkParseXLFD(string, xaPtr) * the purpose of, so I ignore them. */ - xaPtr->fa.pointsize = atoi(field[XLFD_PIXEL_SIZE] + 1); + faPtr->size = atoi(field[XLFD_PIXEL_SIZE] + 1); } else if (Tcl_GetInt(NULL, field[XLFD_PIXEL_SIZE], - &xaPtr->fa.pointsize) != TCL_OK) { + &faPtr->size) != TCL_OK) { return TCL_ERROR; } } - xaPtr->fa.pointsize = -xaPtr->fa.pointsize; + faPtr->size = -faPtr->size; /* XLFD_RESOLUTION_X ignored. */ @@ -2900,14 +3347,9 @@ TkParseXLFD(string, xaPtr) /* XLFD_AVERAGE_WIDTH ignored. */ - if (FieldSpecified(field[XLFD_REGISTRY])) { - xaPtr->charset = TkFindStateNum(NULL, NULL, xlfdCharsetMap, - field[XLFD_REGISTRY]); + if (FieldSpecified(field[XLFD_CHARSET])) { + xaPtr->charset = Tk_GetUid(field[XLFD_CHARSET]); } - if (FieldSpecified(field[XLFD_ENCODING])) { - xaPtr->encoding = atoi(field[XLFD_ENCODING]); - } - Tcl_DStringFree(&ds); return TCL_OK; } @@ -2949,60 +3391,223 @@ FieldSpecified(field) /* *--------------------------------------------------------------------------- * - * NewChunk -- + * TkFontGetPixels -- * - * Helper function for Tk_ComputeTextLayout(). Encapsulates a - * measured set of characters in a chunk that can be quickly - * drawn. + * Given a font size specification (as described in the TkFontAttributes + * structure) return the number of pixels it represents. * * Results: - * A pointer to the new chunk in the text layout. + * As above. * * Side effects: - * The text layout is reallocated to hold more chunks as necessary. + * None. * - * Currently, Tk_ComputeTextLayout() stores contiguous ranges of - * "normal" characters in a chunk, along with individual tab - * and newline chars in their own chunks. All characters in the - * text layout are accounted for. + *--------------------------------------------------------------------------- + */ + +int +TkFontGetPixels(tkwin, size) + Tk_Window tkwin; /* For point->pixel conversion factor. */ + int size; /* Font size. */ +{ + double d; + + if (size < 0) { + return -size; + } + + d = size * 25.4 / 72.0; + d *= WidthOfScreen(Tk_Screen(tkwin)); + d /= WidthMMOfScreen(Tk_Screen(tkwin)); + return (int) (d + 0.5); +} + +/* + *--------------------------------------------------------------------------- + * + * TkFontGetPoints -- + * + * Given a font size specification (as described in the TkFontAttributes + * structure) return the number of points it represents. + * + * Results: + * As above. + * + * Side effects: + * None. * *--------------------------------------------------------------------------- */ -static LayoutChunk * -NewChunk(layoutPtrPtr, maxPtr, start, numChars, curX, newX, y) - TextLayout **layoutPtrPtr; - int *maxPtr; - CONST char *start; - int numChars; - int curX; - int newX; - int y; + +int +TkFontGetPoints(tkwin, size) + Tk_Window tkwin; /* For pixel->point conversion factor. */ + int size; /* Font size. */ { - TextLayout *layoutPtr; - LayoutChunk *chunkPtr; - int maxChunks; - size_t s; - - layoutPtr = *layoutPtrPtr; - maxChunks = *maxPtr; - if (layoutPtr->numChunks == maxChunks) { - maxChunks *= 2; - s = sizeof(TextLayout) + ((maxChunks - 1) * sizeof(LayoutChunk)); - layoutPtr = (TextLayout *) ckrealloc((char *) layoutPtr, s); + double d; - *layoutPtrPtr = layoutPtr; - *maxPtr = maxChunks; + if (size >= 0) { + return size; } - chunkPtr = &layoutPtr->chunks[layoutPtr->numChunks]; - chunkPtr->start = start; - chunkPtr->numChars = numChars; - chunkPtr->numDisplayChars = numChars; - chunkPtr->x = curX; - chunkPtr->y = y; - chunkPtr->totalWidth = newX - curX; - chunkPtr->displayWidth = newX - curX; - layoutPtr->numChunks++; - return chunkPtr; + d = -size * 72.0 / 25.4; + d *= WidthMMOfScreen(Tk_Screen(tkwin)); + d /= WidthOfScreen(Tk_Screen(tkwin)); + return (int) (d + 0.5); } + +/* + *------------------------------------------------------------------------- + * + * TkFontGetAliasList -- + * + * Given a font name, find the list of all aliases for that font + * name. One of the names in this list will probably be the name + * that this platform expects when asking for the font. + * + * Results: + * As above. The return value is NULL if the font name has no + * aliases. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +char ** +TkFontGetAliasList(faceName) + CONST char *faceName; /* Font name to test for aliases. */ +{ + int i, j; + for (i = 0; fontAliases[i] != NULL; i++) { + for (j = 0; fontAliases[i][j] != NULL; j++) { + if (strcasecmp(faceName, fontAliases[i][j]) == 0) { + return fontAliases[i]; + } + } + } + return NULL; +} + +/* + *------------------------------------------------------------------------- + * + * TkFontGetFallbacks -- + * + * Get the list of font fallbacks that the platform-specific code + * can use to try to find the closest matching font the name + * requested. + * + * Results: + * As above. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +char *** +TkFontGetFallbacks() +{ + return fontFallbacks; +} + +/* + *------------------------------------------------------------------------- + * + * TkFontGetGlobalClass -- + * + * Get the list of fonts to try if the requested font name does not + * exist and no fallbacks for that font name could be used either. + * The names in this list are considered preferred over all the other + * font names in the system when looking for a last-ditch fallback. + * + * Results: + * As above. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +char ** +TkFontGetGlobalClass() +{ + return globalFontClass; +} + +/* + *------------------------------------------------------------------------- + * + * TkFontGetSymbolClass -- + * + * Get the list of fonts that are symbolic; used if the operating + * system cannot apriori identify symbolic fonts on its own. + * + * Results: + * As above. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +char ** +TkFontGetSymbolClass() +{ + return symbolClass; +} + +/* + *---------------------------------------------------------------------- + * + * TkDebugFont -- + * + * This procedure returns debugging information about a font. + * + * Results: + * The return value is a list with one sublist for each TkFont + * corresponding to "name". Each sublist has two elements that + * contain the resourceRefCount and objRefCount fields from the + * TkFont structure. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TkDebugFont(tkwin, name) + Tk_Window tkwin; /* The window in which the font will be + * used (not currently used). */ + char *name; /* Name of the desired color. */ +{ + TkFont *fontPtr; + Tcl_HashEntry *hashPtr; + Tcl_Obj *resultPtr, *objPtr; + + resultPtr = Tcl_NewObj(); + hashPtr = Tcl_FindHashEntry( + &((TkWindow *) tkwin)->mainPtr->fontInfoPtr->fontCache, name); + if (hashPtr != NULL) { + fontPtr = (TkFont *) Tcl_GetHashValue(hashPtr); + if (fontPtr == NULL) { + panic("TkDebugFont found empty hash table entry"); + } + for ( ; (fontPtr != NULL); fontPtr = fontPtr->nextPtr) { + objPtr = Tcl_NewObj(); + Tcl_ListObjAppendElement(NULL, objPtr, + Tcl_NewIntObj(fontPtr->resourceRefCount)); + Tcl_ListObjAppendElement(NULL, objPtr, + Tcl_NewIntObj(fontPtr->objRefCount)); + Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); + } + } + return resultPtr; +} diff --git a/generic/tkFont.h b/generic/tkFont.h index 758c329..05b116e 100644 --- a/generic/tkFont.h +++ b/generic/tkFont.h @@ -5,12 +5,12 @@ * specific parts of the font package. This information is not * visible outside of the font package. * - * Copyright (c) 1996 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkFont.h 1.11 97/05/07 14:44:13 + * SCCS: @(#) tkFont.h 1.16 97/12/23 15:00:07 */ #ifndef _TKFONT @@ -23,8 +23,9 @@ */ typedef struct TkFontAttributes { - Tk_Uid family; /* Font family. The most important field. */ - int pointsize; /* Pointsize of font, 0 for default size, or + Tk_Uid family; /* Font family, or NULL to represent + * plaform-specific default system font. */ + int size; /* Pointsize of font, 0 for default size, or * negative number meaning pixel size. */ int weight; /* Weight flag; see below for def'n. */ int slant; /* Slant flag; see below for def'n. */ @@ -86,13 +87,25 @@ typedef struct TkFont { * Fields used and maintained exclusively by generic code. */ - int refCount; /* Number of users of the TkFont. */ + int resourceRefCount; /* Number of active uses of this font (each + * active use corresponds to a call to + * Tk_AllocFontFromTable or Tk_GetFont). + * If this count is 0, then this TkFont + * structure is no longer valid and it isn't + * present in a hash table: it is being + * kept around only because there are objects + * referring to it. The structure is freed + * when resourceRefCount and objRefCount + * are both 0. */ + int objRefCount; /* The number of Tcl objects that reference + * this structure. */ Tcl_HashEntry *cacheHashPtr;/* Entry in font cache for this structure, * used when deleting it. */ Tcl_HashEntry *namedHashPtr;/* Pointer to hash table entry that * corresponds to the named font that the * tkfont was based on, or NULL if the tkfont * was not based on a named font. */ + Screen *screen; /* The screen where this font is valid. */ int tabWidth; /* Width of tabs in this font (pixels). */ int underlinePos; /* Offset from baseline to origin of * underline bar (used for drawing underlines @@ -101,7 +114,7 @@ typedef struct TkFont { * underlines on a non-underlined font). */ /* - * Fields in the generic font structure that are filled in by + * Fields used in the generic code that are filled in by * platform-specific code. */ @@ -116,6 +129,11 @@ typedef struct TkFont { * that was used to create this font. */ TkFontMetrics fm; /* Font metrics determined when font was * created. */ + struct TkFont *nextPtr; /* Points to the next TkFont structure with + * the same name. All fonts with the + * same name (but different displays) are + * chained together off a single entry in + * a hash table. */ } TkFont; /* @@ -125,16 +143,12 @@ typedef struct TkFont { */ typedef struct TkXLFDAttributes { - TkFontAttributes fa; /* Standard set of font attributes. */ Tk_Uid foundry; /* The foundry of the font. */ int slant; /* The tristate value for the slant, which * is significant under X. */ int setwidth; /* The proportionate width, see below for * definition. */ - int charset; /* The character set encoding (the glyph - * family), see below for definition. */ - int encoding; /* Variations within a charset for the - * glyphs above character 127. */ + Tk_Uid charset; /* The actual charset string. */ } TkXLFDAttributes; /* @@ -150,15 +164,6 @@ typedef struct TkXLFDAttributes { * stored in the setwidth field. */ /* - * Possible values for the "charset" field in a TkXLFDAttributes structure. - * The charset is the set of glyphs that are used in the font. - */ - -#define TK_CS_NORMAL 0 -#define TK_CS_SYMBOL 1 -#define TK_CS_OTHER 2 - -/* * The following defines specify the meaning of the fields in a fully * qualified XLFD. */ @@ -175,28 +180,33 @@ typedef struct TkXLFDAttributes { #define XLFD_RESOLUTION_Y 9 #define XLFD_SPACING 10 #define XLFD_AVERAGE_WIDTH 11 -#define XLFD_REGISTRY 12 -#define XLFD_ENCODING 13 -#define XLFD_NUMFIELDS 14 /* Number of fields in XLFD. */ +#define XLFD_CHARSET 12 +#define XLFD_NUMFIELDS 13 /* Number of fields in XLFD. */ /* - * Exported from generic code to platform-specific code. + * Low-level API exported by generic code to platform-specific code. */ -EXTERN int TkCreateNamedFont _ANSI_ARGS_((Tcl_Interp *interp, - Tk_Window tkwin, CONST char *name, - TkFontAttributes *faPtr)); -EXTERN void TkInitFontAttributes _ANSI_ARGS_(( - TkFontAttributes *faPtr)); -EXTERN int TkParseXLFD _ANSI_ARGS_((CONST char *string, - TkXLFDAttributes *xaPtr)); +#define TkInitFontAttributes(fa) memset((fa), 0, sizeof(TkFontAttributes)); +#define TkInitXLFDAttributes(xa) memset((xa), 0, sizeof(TkXLFDAttributes)); + +EXTERN int TkFontParseXLFD _ANSI_ARGS_((CONST char *string, + TkFontAttributes *faPtr, TkXLFDAttributes *xaPtr)); +EXTERN char ** TkFontGetAliasList _ANSI_ARGS_((CONST char *faceName)); +EXTERN char *** TkFontGetFallbacks _ANSI_ARGS_((void)); +EXTERN int TkFontGetPixels _ANSI_ARGS_((Tk_Window tkwin, + int size)); +EXTERN int TkFontGetPoints _ANSI_ARGS_((Tk_Window tkwin, + int size)); +EXTERN char ** TkFontGetGlobalClass _ANSI_ARGS_((void)); +EXTERN char ** TkFontGetSymbolClass _ANSI_ARGS_((void)); /* - * Common APIs exported to tkFont.c from all platform-specific - * implementations. + * Low-level API exported by platform-specific code to generic code. */ EXTERN void TkpDeleteFont _ANSI_ARGS_((TkFont *tkFontPtr)); +EXTERN void TkpFontPkgInit _ANSI_ARGS_((TkMainInfo *mainPtr)); EXTERN TkFont * TkpGetFontFromAttributes _ANSI_ARGS_(( TkFont *tkFontPtr, Tk_Window tkwin, CONST TkFontAttributes *faPtr)); diff --git a/generic/tkFrame.c b/generic/tkFrame.c index a11f566..0709a69 100644 --- a/generic/tkFrame.c +++ b/generic/tkFrame.c @@ -7,12 +7,12 @@ * attributes. * * Copyright (c) 1990-1994 The Regents of the University of California. - * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkFrame.c 1.82 97/08/08 17:26:26 + * SCCS: @(#) tkFrame.c 1.83 97/11/07 21:18:51 */ #include "default.h" @@ -441,7 +441,7 @@ TkCreateFrame(clientData, interp, argc, argv, toplevel, appName) if (toplevel) { Tcl_DoWhenIdle(MapFrame, (ClientData) framePtr); } - interp->result = Tk_PathName(new); + Tcl_SetResult(interp, Tk_PathName(new), TCL_STATIC); return TCL_OK; error: @@ -597,7 +597,7 @@ DestroyFrame(memPtr) * * Results: * The return value is a standard Tcl result. If TCL_ERROR is - * returned, then interp->result contains an error message. + * returned, then the interp's result contains an error message. * * Side effects: * Configuration information, such as text string, colors, font, diff --git a/generic/tkGet.c b/generic/tkGet.c index 56258a6..a980199 100644 --- a/generic/tkGet.c +++ b/generic/tkGet.c @@ -8,18 +8,27 @@ * files. * * Copyright (c) 1991-1994 The Regents of the University of California. - * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkGet.c 1.13 96/04/26 10:25:46 + * SCCS: @(#) tkGet.c 1.15 97/12/22 11:04:29 */ #include "tkInt.h" #include "tkPort.h" /* + * The following tables defines the string values for reliefs, which are + * used by Tk_GetAnchorFromObj and Tk_GetJustifyFromObj. + */ + +static char *anchorStrings[] = {"n", "ne", "e", "se", "s", "sw", "w", "nw", + "center", (char *) NULL}; +static char *justifyStrings[] = {"left", "right", "center", (char *) NULL}; + +/* * The hash table below is used to keep track of all the Tk_Uids created * so far. */ @@ -28,6 +37,43 @@ static Tcl_HashTable uidTable; static int initialized = 0; /* + *---------------------------------------------------------------------- + * + * Tk_GetAnchorFromObj -- + * + * Return a Tk_Anchor value based on the value of the objPtr. + * + * Results: + * The return value is a standard Tcl result. If an error occurs during + * conversion, an error message is left in the interpreter's result + * unless "interp" is NULL. + * + * Side effects: + * The object gets converted by Tcl_GetIndexFromObj. + * + *---------------------------------------------------------------------- + */ + +int +Tk_GetAnchorFromObj(interp, objPtr, anchorPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Obj *objPtr; /* The object we are trying to get the + * value from. */ + Tk_Anchor *anchorPtr; /* Where to place the Tk_Anchor that + * corresponds to the string value of + * objPtr. */ +{ + int index, code; + + code = Tcl_GetIndexFromObj(interp, objPtr, anchorStrings, "anchor", 0, + &index); + if (code == TCL_OK) { + *anchorPtr = (Tk_Anchor) index; + } + return code; +} + +/* *-------------------------------------------------------------- * * Tk_GetAnchor -- @@ -39,7 +85,7 @@ static int initialized = 0; * TCL_OK is returned, then everything went well and the * position is stored at *anchorPtr; otherwise TCL_ERROR * is returned and an error message is left in - * interp->result. + * the interp's result. * * Side effects: * None. @@ -155,7 +201,7 @@ Tk_NameOfAnchor(anchor) * TCL_OK is returned, then everything went well and the * justification is stored at *joinPtr; otherwise * TCL_ERROR is returned and an error message is left in - * interp->result. + * the interp's result. * * Side effects: * None. @@ -237,7 +283,7 @@ Tk_NameOfJoinStyle(join) * TCL_OK is returned, then everything went well and the * justification is stored at *capPtr; otherwise * TCL_ERROR is returned and an error message is left in - * interp->result. + * the interp's result. * * Side effects: * None. @@ -308,6 +354,43 @@ Tk_NameOfCapStyle(cap) } /* + *---------------------------------------------------------------------- + * + * Tk_GetJustifyFromObj -- + * + * Return a Tk_Justify value based on the value of the objPtr. + * + * Results: + * The return value is a standard Tcl result. If an error occurs during + * conversion, an error message is left in the interpreter's result + * unless "interp" is NULL. + * + * Side effects: + * The object gets converted by Tcl_GetIndexFromObj. + * + *---------------------------------------------------------------------- + */ + +int +Tk_GetJustifyFromObj(interp, objPtr, justifyPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Obj *objPtr; /* The object we are trying to get the + * value from. */ + Tk_Justify *justifyPtr; /* Where to place the Tk_Justify that + * corresponds to the string value of + * objPtr. */ +{ + int index, code; + + code = Tcl_GetIndexFromObj(interp, objPtr, justifyStrings, + "justification", 0, &index); + if (code == TCL_OK) { + *justifyPtr = (Tk_Justify) index; + } + return code; +} + +/* *-------------------------------------------------------------- * * Tk_GetJustify -- @@ -319,7 +402,7 @@ Tk_NameOfCapStyle(cap) * TCL_OK is returned, then everything went well and the * justification is stored at *justifyPtr; otherwise * TCL_ERROR is returned and an error message is left in - * interp->result. + * the interp's result. * * Side effects: * None. @@ -439,7 +522,7 @@ Tk_GetUid(string) * TCL_OK is returned, then everything went well and the * screen distance is stored at *doublePtr; otherwise * TCL_ERROR is returned and an error message is left in - * interp->result. + * the interp's result. * * Side effects: * None. @@ -515,7 +598,7 @@ Tk_GetScreenMM(interp, tkwin, string, doublePtr) * TCL_OK is returned, then everything went well and the * rounded pixel distance is stored at *intPtr; otherwise * TCL_ERROR is returned and an error message is left in - * interp->result. + * the interp's result. * * Side effects: * None. diff --git a/generic/tkGrab.c b/generic/tkGrab.c index 869e0b3..b088563 100644 --- a/generic/tkGrab.c +++ b/generic/tkGrab.c @@ -4,12 +4,12 @@ * This file provides procedures that implement grabs for Tk. * * Copyright (c) 1992-1994 The Regents of the University of California. - * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkGrab.c 1.52 97/03/21 11:14:34 + * SCCS: @(#) tkGrab.c 1.53 97/11/07 21:19:38 */ #include "tkPort.h" @@ -238,7 +238,8 @@ Tk_GrabCmd(clientData, interp, argc, argv) } dispPtr = ((TkWindow *) tkwin)->dispPtr; if (dispPtr->eventualGrabWinPtr != NULL) { - interp->result = dispPtr->eventualGrabWinPtr->pathName; + Tcl_SetResult(interp, dispPtr->eventualGrabWinPtr->pathName, + TCL_STATIC); } } else { for (dispPtr = tkDisplayList; dispPtr != NULL; @@ -303,11 +304,11 @@ Tk_GrabCmd(clientData, interp, argc, argv) } dispPtr = winPtr->dispPtr; if (dispPtr->eventualGrabWinPtr != winPtr) { - interp->result = "none"; + Tcl_SetResult(interp, "none", TCL_STATIC); } else if (dispPtr->grabFlags & GRAB_GLOBAL) { - interp->result = "global"; + Tcl_SetResult(interp, "global", TCL_STATIC); } else { - interp->result = "local"; + Tcl_SetResult(interp, "local", TCL_STATIC); } } else { Tcl_AppendResult(interp, "unknown or ambiguous option \"", argv[1], @@ -329,7 +330,7 @@ Tk_GrabCmd(clientData, interp, argc, argv) * Results: * A standard Tcl result is returned. TCL_OK is the normal return * value; if the grab could not be set then TCL_ERROR is returned - * and interp->result will hold an error message. + * and the interp's result will hold an error message. * * Side effects: * Once this call completes successfully, no window outside the @@ -366,7 +367,8 @@ Tk_Grab(interp, tkwin, grabGlobal) } if (dispPtr->eventualGrabWinPtr->mainPtr != winPtr->mainPtr) { alreadyGrabbed: - interp->result = "grab failed: another application has grab"; + Tcl_SetResult(interp, "grab failed: another application has grab", + TCL_STATIC); return TCL_ERROR; } Tk_Ungrab((Tk_Window) dispPtr->eventualGrabWinPtr); @@ -432,15 +434,18 @@ Tk_Grab(interp, tkwin, grabGlobal) if (grabResult != 0) { grabError: if (grabResult == GrabNotViewable) { - interp->result = "grab failed: window not viewable"; + Tcl_SetResult(interp, "grab failed: window not viewable", + TCL_STATIC); } else if (grabResult == AlreadyGrabbed) { goto alreadyGrabbed; } else if (grabResult == GrabFrozen) { - interp->result = "grab failed: keyboard or pointer frozen"; + Tcl_SetResult(interp, + "grab failed: keyboard or pointer frozen", TCL_STATIC); } else if (grabResult == GrabInvalidTime) { - interp->result = "grab failed: invalid time"; + Tcl_SetResult(interp, "grab failed: invalid time", + TCL_STATIC); } else { - char msg[100]; + char msg[64 + TCL_INTEGER_SPACE]; sprintf(msg, "grab failed for unknown reason (code %d)", grabResult); diff --git a/generic/tkGrid.c b/generic/tkGrid.c index ea11a01..f21782f 100644 --- a/generic/tkGrid.c +++ b/generic/tkGrid.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkGrid.c 1.39 97/10/10 10:12:03 + * SCCS: @(#) tkGrid.c 1.40 97/11/07 21:18:05 */ #include "tkInt.h" @@ -314,6 +314,7 @@ Tk_GridCmd(clientData, interp, argc, argv) int endX, endY; /* last column/row in the layout */ int x=0, y=0; /* starting pixels for this bounding box */ int width, height; /* size of the bounding box */ + char buf[TCL_INTEGER_SPACE * 4]; if (argc!=3 && argc != 5 && argc != 7) { Tcl_AppendResult(interp, "wrong number of arguments: ", @@ -351,7 +352,7 @@ Tk_GridCmd(clientData, interp, argc, argv) gridPtr = masterPtr->masterDataPtr; if (gridPtr == NULL) { - sprintf(interp->result, "%d %d %d %d",0,0,0,0); + Tcl_SetResult(interp, "0 0 0 0", TCL_STATIC); return(TCL_OK); } @@ -360,7 +361,7 @@ Tk_GridCmd(clientData, interp, argc, argv) endY = MAX(gridPtr->rowEnd, gridPtr->rowMax); if ((endX == 0) || (endY == 0)) { - sprintf(interp->result, "%d %d %d %d",0,0,0,0); + Tcl_SetResult(interp, "0 0 0 0", TCL_STATIC); return(TCL_OK); } if (argc == 3) { @@ -406,8 +407,9 @@ Tk_GridCmd(clientData, interp, argc, argv) height = gridPtr->rowPtr[row2].offset - y; } - sprintf(interp->result, "%d %d %d %d", - x + gridPtr->startX, y + gridPtr->startY, width, height); + sprintf(buf, "%d %d %d %d", x + gridPtr->startX, y + gridPtr->startY, + width, height); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } else if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0)) { if (argv[2][0] != '.') { Tcl_AppendResult(interp, "bad argument \"", argv[2], @@ -456,7 +458,7 @@ Tk_GridCmd(clientData, interp, argc, argv) } else if ((c == 'i') && (strncmp(argv[1], "info", length) == 0)) { register Gridder *slavePtr; Tk_Window slave; - char buffer[70]; + char buffer[64 + TCL_INTEGER_SPACE * 4]; if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", @@ -469,7 +471,7 @@ Tk_GridCmd(clientData, interp, argc, argv) } slavePtr = GetGrid(slave); if (slavePtr->masterPtr == NULL) { - interp->result[0] = '\0'; + Tcl_ResetResult(interp); return TCL_OK; } @@ -491,6 +493,7 @@ Tk_GridCmd(clientData, interp, argc, argv) int x, y; /* Offset in pixels, from edge of parent. */ int i, j; /* Corresponding column and row indeces. */ int endX, endY; /* end of grid */ + char buf[TCL_INTEGER_SPACE * 2]; if (argc != 5) { Tcl_AppendResult(interp, "wrong # args: should be \"", @@ -512,7 +515,7 @@ Tk_GridCmd(clientData, interp, argc, argv) masterPtr = GetGrid(master); if (masterPtr->masterDataPtr == NULL) { - sprintf(interp->result, "%d %d", -1, -1); + Tcl_SetResult(interp, "-1 -1", TCL_STATIC); return TCL_OK; } gridPtr = masterPtr->masterDataPtr; @@ -551,7 +554,8 @@ Tk_GridCmd(clientData, interp, argc, argv) } } - sprintf(interp->result, "%d %d", i, j); + sprintf(buf, "%d %d", i, j); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } else if ((c == 'p') && (strncmp(argv[1], "propagate", length) == 0)) { Tk_Window master; int propagate; @@ -568,7 +572,9 @@ Tk_GridCmd(clientData, interp, argc, argv) } masterPtr = GetGrid(master); if (argc == 3) { - interp->result = (masterPtr->flags & DONT_PROPAGATE) ? "0" : "1"; + Tcl_SetResult(interp, + ((masterPtr->flags & DONT_PROPAGATE) ? "0" : "1"), + TCL_STATIC); return TCL_OK; } if (Tcl_GetBoolean(interp, argv[3], &propagate) != TCL_OK) { @@ -606,13 +612,16 @@ Tk_GridCmd(clientData, interp, argc, argv) masterPtr = GetGrid(master); if (masterPtr->masterDataPtr != NULL) { + char buf[TCL_INTEGER_SPACE * 2]; + SetGridSize(masterPtr); gridPtr = masterPtr->masterDataPtr; - sprintf(interp->result, "%d %d", - MAX(gridPtr->columnEnd, gridPtr->columnMax), - MAX(gridPtr->rowEnd, gridPtr->rowMax)); + sprintf(buf, "%d %d", + MAX(gridPtr->columnEnd, gridPtr->columnMax), + MAX(gridPtr->rowEnd, gridPtr->rowMax)); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } else { - sprintf(interp->result, "%d %d",0, 0); + Tcl_SetResult(interp, "0 0", TCL_STATIC); } } else if ((c == 's') && (strncmp(argv[1], "slaves", length) == 0) && (length > 1)) { @@ -754,12 +763,16 @@ Tk_GridCmd(clientData, interp, argc, argv) Tcl_Free((char *)argvPtr); } if ((argc == 4) && (ok == TCL_OK)) { - sprintf(interp->result,"-minsize %d -pad %d -weight %d", + char buf[64 + TCL_INTEGER_SPACE * 3]; + + sprintf(buf, "-minsize %d -pad %d -weight %d", slotPtr[slot].minSize,slotPtr[slot].pad, slotPtr[slot].weight); + Tcl_SetResult(interp, buf, TCL_VOLATILE); return (TCL_OK); } else if (argc == 4) { - sprintf(interp->result,"-minsize %d -pad %d -weight %d", 0,0,0); + Tcl_SetResult(interp, "-minsize 0 -pad 0 -weight 0", + TCL_STATIC); return (TCL_OK); } @@ -780,8 +793,12 @@ Tk_GridCmd(clientData, interp, argc, argv) } if (strncmp(argv[i], "-minsize", length) == 0) { if (argc == 5) { - int value = ok == TCL_OK ? slotPtr[slot].minSize : 0; - sprintf(interp->result,"%d",value); + char buf[TCL_INTEGER_SPACE]; + int value; + + value = (ok == TCL_OK) ? slotPtr[slot].minSize : 0; + sprintf(buf, "%d", value); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } else if (Tk_GetPixels(interp, master, argv[i+1], &size) != TCL_OK) { Tcl_Free((char *)argvPtr); @@ -793,8 +810,12 @@ Tk_GridCmd(clientData, interp, argc, argv) else if (strncmp(argv[i], "-weight", length) == 0) { int wt; if (argc == 5) { - int value = ok == TCL_OK ? slotPtr[slot].weight : 0; - sprintf(interp->result,"%d",value); + char buf[TCL_INTEGER_SPACE]; + int value; + + value = (ok == TCL_OK) ? slotPtr[slot].weight : 0; + sprintf(buf, "%d", value); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } else if (Tcl_GetInt(interp, argv[i+1], &wt) != TCL_OK) { Tcl_Free((char *)argvPtr); return TCL_ERROR; @@ -809,8 +830,12 @@ Tk_GridCmd(clientData, interp, argc, argv) } else if (strncmp(argv[i], "-pad", length) == 0) { if (argc == 5) { - int value = ok == TCL_OK ? slotPtr[slot].pad : 0; - sprintf(interp->result,"%d",value); + char buf[TCL_INTEGER_SPACE]; + int value; + + value = (ok == TCL_OK) ? slotPtr[slot].pad : 0; + sprintf(buf, "%d", value); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } else if (Tk_GetPixels(interp, master, argv[i+1], &size) != TCL_OK) { Tcl_Free((char *)argvPtr); @@ -2107,7 +2132,7 @@ GridStructureProc(clientData, eventPtr) * * Results: * TCL_OK is returned if all went well. Otherwise, TCL_ERROR is - * returned and interp->result is set to contain an error message. + * returned and the interp's result is set to contain an error message. * * Side effects: * Slave windows get taken over by the grid. @@ -2281,7 +2306,8 @@ ConfigureSlaves(interp, tkwin, argc, argv) return TCL_ERROR; } if (other == slave) { - sprintf(interp->result,"Window can't be managed in itself"); + Tcl_SetResult(interp, "Window can't be managed in itself", + TCL_STATIC); return TCL_ERROR; } masterPtr = GetGrid(other); diff --git a/generic/tkImage.c b/generic/tkImage.c index 251fe30..47a8c1b 100644 --- a/generic/tkImage.c +++ b/generic/tkImage.c @@ -6,12 +6,12 @@ * widgets. * * Copyright (c) 1994 The Regents of the University of California. - * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkImage.c 1.15 97/10/09 09:57:50 + * SCCS: @(#) tkImage.c 1.16 97/11/07 21:17:09 */ #include "tkInt.h" @@ -146,7 +146,7 @@ Tk_ImageCmd(clientData, interp, argc, argv) Image *imagePtr; Tcl_HashEntry *hPtr; Tcl_HashSearch search; - char idString[30], *name; + char idString[16 + TCL_INTEGER_SPACE], *name; static int id = 0; if (argc < 2) { @@ -248,7 +248,9 @@ Tk_ImageCmd(clientData, interp, argc, argv) imagePtr->instanceData = (*typePtr->getProc)( imagePtr->tkwin, masterPtr->masterData); } - interp->result = Tcl_GetHashKey(&winPtr->mainPtr->imageTable, hPtr); + Tcl_SetResult(interp, + Tcl_GetHashKey(&winPtr->mainPtr->imageTable, hPtr), + TCL_STATIC); } else if ((c == 'd') && (strncmp(argv[1], "delete", length) == 0)) { for (i = 2; i < argc; i++) { hPtr = Tcl_FindHashEntry(&winPtr->mainPtr->imageTable, argv[i]); @@ -261,6 +263,8 @@ Tk_ImageCmd(clientData, interp, argc, argv) DeleteImage(masterPtr); } } else if ((c == 'h') && (strncmp(argv[1], "height", length) == 0)) { + char buf[TCL_INTEGER_SPACE]; + if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " height name\"", (char *) NULL); @@ -273,7 +277,8 @@ Tk_ImageCmd(clientData, interp, argc, argv) return TCL_ERROR; } masterPtr = (ImageMaster *) Tcl_GetHashValue(hPtr); - sprintf(interp->result, "%d", masterPtr->height); + sprintf(buf, "%d", masterPtr->height); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } else if ((c == 'n') && (strncmp(argv[1], "names", length) == 0)) { if (argc != 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], @@ -299,7 +304,7 @@ Tk_ImageCmd(clientData, interp, argc, argv) } masterPtr = (ImageMaster *) Tcl_GetHashValue(hPtr); if (masterPtr->typePtr != NULL) { - interp->result = masterPtr->typePtr->name; + Tcl_SetResult(interp, masterPtr->typePtr->name, TCL_STATIC); } } else if ((c == 't') && (strcmp(argv[1], "types") == 0)) { if (argc != 2) { @@ -312,6 +317,8 @@ Tk_ImageCmd(clientData, interp, argc, argv) Tcl_AppendElement(interp, typePtr->name); } } else if ((c == 'w') && (strncmp(argv[1], "width", length) == 0)) { + char buf[TCL_INTEGER_SPACE]; + if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " width name\"", (char *) NULL); @@ -324,7 +331,8 @@ Tk_ImageCmd(clientData, interp, argc, argv) return TCL_ERROR; } masterPtr = (ImageMaster *) Tcl_GetHashValue(hPtr); - sprintf(interp->result, "%d", masterPtr->width); + sprintf(buf, "%d", masterPtr->width); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } else { Tcl_AppendResult(interp, "bad option \"", argv[1], "\": must be create, delete, height, names, type, types,", @@ -416,7 +424,7 @@ Tk_NameOfImage(imageMaster) * Results: * The return value is a token for the image. If there is no image * by the given name, then NULL is returned and an error message is - * left in interp->result. + * left in the interp's result. * * Side effects: * Tk records the fact that the widget is using the image, and diff --git a/generic/tkImgBmap.c b/generic/tkImgBmap.c index f8a1d6e..4a09afc 100644 --- a/generic/tkImgBmap.c +++ b/generic/tkImgBmap.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkImgBmap.c 1.33 97/07/31 09:08:22 + * SCCS: @(#) tkImgBmap.c 1.34 97/11/07 21:17:15 */ #include "tkInt.h" @@ -227,7 +227,7 @@ ImgBmapCreate(interp, name, argc, argv, typePtr, master, clientDataPtr) * * Results: * A standard Tcl return value. If TCL_ERROR is returned then - * an error message is left in masterPtr->interp->result. + * an error message is left in the masterPtr->interp's result. * * Side effects: * Existing instances of the image will be redisplayed to match @@ -278,7 +278,8 @@ ImgBmapConfigureMaster(masterPtr, argc, argv, flags) if ((masterPtr->maskFileString != NULL) || (masterPtr->maskDataString != NULL)) { if (masterPtr->data == NULL) { - masterPtr->interp->result = "can't have mask without bitmap"; + Tcl_SetResult(masterPtr->interp, "can't have mask without bitmap", + TCL_STATIC); return TCL_ERROR; } masterPtr->maskData = TkGetBitmapData(masterPtr->interp, @@ -291,7 +292,8 @@ ImgBmapConfigureMaster(masterPtr, argc, argv, flags) || (maskHeight != masterPtr->height)) { ckfree(masterPtr->maskData); masterPtr->maskData = NULL; - masterPtr->interp->result = "bitmap and mask have different sizes"; + Tcl_SetResult(masterPtr->interp, + "bitmap and mask have different sizes", TCL_STATIC); return TCL_ERROR; } } @@ -451,7 +453,7 @@ ImgBmapConfigureInstance(instancePtr) * *heightPtr. *hotXPtr and *hotYPtr are set to the bitmap * hotspot if one is defined, otherwise they are set to -1, -1. * If an error occurred, NULL is returned and an error message is - * left in interp->result. + * left in the interp's result. * * Side effects: * A bitmap is created. @@ -615,7 +617,7 @@ TkGetBitmapData(interp, string, fileName, widthPtr, heightPtr, return data; error: - interp->result = "format error in bitmap data"; + Tcl_SetResult(interp, "format error in bitmap data", TCL_STATIC); errorCleanup: if (data != NULL) { ckfree(data); @@ -725,9 +727,8 @@ ImgBmapCmd(clientData, interp, argc, argv) size_t length; if (argc < 2) { - sprintf(interp->result, - "wrong # args: should be \"%.50s option ?arg arg ...?\"", - argv[0]); + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option ?arg arg ...?\"", (char *) NULL); return TCL_ERROR; } c = argv[1][0]; diff --git a/generic/tkImgGIF.c b/generic/tkImgGIF.c index a2ad081..34ea255 100644 --- a/generic/tkImgGIF.c +++ b/generic/tkImgGIF.c @@ -27,7 +27,7 @@ * | provided "as is" without express or implied warranty. | * +-------------------------------------------------------------------+ * - * SCCS: @(#) tkImgGIF.c 1.19 97/08/13 15:23:45 + * SCCS: @(#) tkImgGIF.c 1.20 97/11/07 21:20:21 */ /* @@ -184,7 +184,7 @@ FileMatchGIF(chan, fileName, formatString, widthPtr, heightPtr) * * Results: * A standard TCL completion code. If TCL_ERROR is returned - * then an error message is left in interp->result. + * then an error message is left in the interp's result. * * Side effects: * The access position in file f is changed, and new data is @@ -287,12 +287,14 @@ FileReadGIF(interp, chan, fileName, formatString, imageHandle, destX, destY, */ if (Fread(buf, 1, 1, chan) != 1) { - interp->result = - "error reading extension function code in GIF image"; + Tcl_SetResult(interp, + "error reading extension function code in GIF image", + TCL_STATIC); goto error; } if (DoExtension(chan, buf[0], &transparent) < 0) { - interp->result = "error reading extension in GIF image"; + Tcl_SetResult(interp, "error reading extension in GIF image", + TCL_STATIC); goto error; } continue; @@ -306,7 +308,9 @@ FileReadGIF(interp, chan, fileName, formatString, imageHandle, destX, destY, } if (Fread(buf, 1, 9, chan) != 9) { - interp->result = "couldn't read left/top/width/height in GIF image"; + Tcl_SetResult(interp, + "couldn't read left/top/width/height in GIF image", + TCL_STATIC); goto error; } @@ -418,7 +422,7 @@ StringMatchGIF(string, formatString, widthPtr, heightPtr) * * Results: * A standard TCL completion code. If TCL_ERROR is returned - * then an error message is left in interp->result. + * then an error message is left in the interp's result. * * Side effects: * new data is added to the image given by imageHandle. This @@ -619,7 +623,7 @@ ReadImage(interp, imagePtr, chan, len, rows, cmap, } if (LWZReadByte(chan, 1, c) < 0) { - interp->result = "format error in GIF image"; + Tcl_SetResult(interp, "format error in GIF image", TCL_STATIC); return TCL_ERROR; } diff --git a/generic/tkImgPPM.c b/generic/tkImgPPM.c index 3a54003..8beaf8d 100644 --- a/generic/tkImgPPM.c +++ b/generic/tkImgPPM.c @@ -13,7 +13,7 @@ * Department of Computer Science, * Australian National University. * - * SCCS: @(#) tkImgPPM.c 1.16 97/10/28 14:51:46 + * SCCS: @(#) tkImgPPM.c 1.17 97/11/07 21:18:55 */ #include "tkInt.h" @@ -110,7 +110,7 @@ FileMatchPPM(chan, fileName, formatString, widthPtr, heightPtr) * * Results: * A standard TCL completion code. If TCL_ERROR is returned - * then an error message is left in interp->result. + * then an error message is left in the interp's result. * * Side effects: * The access position in file f is changed, and new data is @@ -151,7 +151,7 @@ FileReadPPM(interp, chan, fileName, formatString, imageHandle, destX, destY, return TCL_ERROR; } if ((maxIntensity <= 0) || (maxIntensity >= 256)) { - char buffer[30]; + char buffer[TCL_INTEGER_SPACE]; sprintf(buffer, "%d", maxIntensity); Tcl_AppendResult(interp, "PPM image file \"", fileName, @@ -243,7 +243,7 @@ FileReadPPM(interp, chan, fileName, formatString, imageHandle, destX, destY, * * Results: * A standard TCL completion code. If TCL_ERROR is returned - * then an error message is left in interp->result. + * then an error message is left in the interp's result. * * Side effects: * Data is written to the file given by "fileName". @@ -262,7 +262,7 @@ FileWritePPM(interp, fileName, formatString, blockPtr) int w, h; int greenOffset, blueOffset, nBytes; unsigned char *pixelPtr, *pixLinePtr; - char header[30]; + char header[16 + TCL_INTEGER_SPACE * 2]; chan = Tcl_OpenFileChannel(interp, fileName, "w", 0666); if (chan == NULL) { diff --git a/generic/tkImgPhoto.c b/generic/tkImgPhoto.c index 86fbf80..8a89b48 100644 --- a/generic/tkImgPhoto.c +++ b/generic/tkImgPhoto.c @@ -15,7 +15,7 @@ * Department of Computer Science, * Australian National University. * - * SCCS: @(#) tkImgPhoto.c 1.60 97/08/08 11:32:46 + * SCCS: @(#) tkImgPhoto.c 1.61 97/11/07 21:19:00 */ #include "tkInt.h" @@ -522,7 +522,6 @@ ImgPhotoCmd(clientData, interp, argc, argv) unsigned char *pixelPtr; Tk_PhotoImageBlock block; Tk_Window tkwin; - char string[16]; XColor color; Tk_PhotoImageFormat *imageFormat; int imageWidth, imageHeight; @@ -678,6 +677,8 @@ ImgPhotoCmd(clientData, interp, argc, argv) * photo get command - first parse and check parameters. */ + char string[TCL_INTEGER_SPACE * 3]; + if (argc != 4) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " get x y\"", (char *) NULL); @@ -1254,7 +1255,7 @@ ParseSubcommandOptions(optPtr, interp, allowedOptions, optIndexPtr, argc, argv) * * Results: * A standard Tcl return value. If TCL_ERROR is returned then - * an error message is left in masterPtr->interp->result. + * an error message is left in the masterPtr->interp's result. * * Side effects: * Existing instances of the image will be redisplayed to match @@ -1597,7 +1598,7 @@ ImgPhotoGet(tkwin, masterData) int mono, nRed, nGreen, nBlue; XVisualInfo visualInfo, *visInfoPtr; XRectangle validBox; - char buf[16]; + char buf[TCL_INTEGER_SPACE * 3]; int numVisuals; XColor *white, *black; XGCValues gcValues; diff --git a/generic/tkInitScript.h b/generic/tkInitScript.h index e86d16e..3809a01 100644 --- a/generic/tkInitScript.h +++ b/generic/tkInitScript.h @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkInitScript.h 1.3 97/08/11 19:12:28 + * SCCS: @(#) tkInitScript.h 1.4 98/01/09 13:37:34 */ @@ -22,10 +22,15 @@ * initialization. * When called from a safe interpreter, it does not use file exists. * we don't use pwd either because of safe interpreters. + * + * We leave the door open to the application by using an existing + * tkInit proc which if it exists is responsible for finding and sourcing + * tk.tcl themselves. With that, an application that wish to ignore + * the env(TK_LIBRARY) or have special initialization need can do it. */ -static char initScript[] = -"proc tkInit {} {\n\ +static char initScript[] = "if {[info proc tkInit]==\"\"} {\n\ + proc tkInit {} {\n\ global tk_library tk_version tk_patchLevel env errorInfo\n\ rename tkInit {}\n\ set errors \"\"\n\ @@ -68,6 +73,7 @@ static char initScript[] = append msg \"$errors\n\n\"\n\ append msg \"This probably means that Tk wasn't installed properly.\n\"\n\ error $msg\n\ + }\n\ }\n\ tkInit"; diff --git a/generic/tkInt.h b/generic/tkInt.h index b5dd92d..cf9eb5e 100644 --- a/generic/tkInt.h +++ b/generic/tkInt.h @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkInt.h 1.204 97/10/31 09:55:20 + * SCCS: @(#) tkInt.h 1.212 98/02/10 10:34:03 */ #ifndef _TKINT @@ -81,11 +81,30 @@ typedef struct TkClassProcs { typedef struct TkCursor { Tk_Cursor cursor; /* System specific identifier for cursor. */ - int refCount; /* Number of active uses of cursor. */ + Display *display; /* Display containing cursor. Needed for + * disposal and retrieval of cursors. */ + int resourceRefCount; /* Number of active uses of this cursor (each + * active use corresponds to a call to + * Tk_AllocPreserveFromObj or Tk_GetPreserve). + * If this count is 0, then this structure + * is no longer valid and it isn't present + * in a hash table: it is being kept around + * only because there are objects referring + * to it. The structure is freed when + * resourceRefCount and objRefCount are + * both 0. */ + int objRefCount; /* Number of Tcl objects that reference + * this structure.. */ Tcl_HashTable *otherTable; /* Second table (other than idTable) used * to index this entry. */ Tcl_HashEntry *hashPtr; /* Entry in otherTable for this structure * (needed when deleting). */ + Tcl_HashEntry *idHashPtr; /* Entry in idTable for this structure + * (needed when deleting). */ + struct TkCursor *nextPtr; /* Points to the next TkCursor structure with + * the same name. Cursors with the same + * name but different displays are chained + * together off a single hash table entry. */ } TkCursor; /* @@ -409,10 +428,10 @@ typedef struct TkMainInfo { /* Used in conjunction with "bind" command * to bind events to Tcl commands. */ TkBindInfo bindInfo; /* Information used by tkBind.c on a per - * interpreter basis. */ + * application basis. */ struct TkFontInfo *fontInfoPtr; - /* Hold named font tables. Used only by - * tkFont.c. */ + /* Information used by tkFont.c on a per + * application basis. */ /* * Information used only by tkFocus.c and tk*Embed.c: @@ -744,6 +763,7 @@ EXTERN int TkCreateFrame _ANSI_ARGS_((ClientData clientData, int toplevel, char *appName)); EXTERN Tk_Window TkCreateMainWindow _ANSI_ARGS_((Tcl_Interp *interp, char *screenName, char *baseName)); +EXTERN int TkCreateMenuCmd _ANSI_ARGS_((Tcl_Interp *interp)); #ifndef TkCreateRegion EXTERN TkRegion TkCreateRegion _ANSI_ARGS_((void)); #endif @@ -751,6 +771,18 @@ EXTERN Time TkCurrentTime _ANSI_ARGS_((TkDisplay *dispPtr)); EXTERN int TkDeadAppCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); EXTERN void TkDeleteAllImages _ANSI_ARGS_((TkMainInfo *mainPtr)); +EXTERN Tcl_Obj * TkDebugBitmap _ANSI_ARGS_(( Tk_Window tkwin, + char *name)); +EXTERN Tcl_Obj * TkDebugBorder _ANSI_ARGS_(( Tk_Window tkwin, + char *name)); +EXTERN Tcl_Obj * TkDebugCursor _ANSI_ARGS_(( Tk_Window tkwin, + char *name)); +EXTERN Tcl_Obj * TkDebugColor _ANSI_ARGS_(( Tk_Window tkwin, + char *name)); +EXTERN Tcl_Obj * TkDebugConfig _ANSI_ARGS_((Tcl_Interp *interp, + Tk_OptionTable table)); +EXTERN Tcl_Obj * TkDebugFont _ANSI_ARGS_(( Tk_Window tkwin, + char *name)); #ifndef TkDestroyRegion EXTERN void TkDestroyRegion _ANSI_ARGS_((TkRegion rgn)); #endif @@ -767,6 +799,9 @@ EXTERN void TkFillPolygon _ANSI_ARGS_((Tk_Canvas canvas, EXTERN int TkFindStateNum _ANSI_ARGS_((Tcl_Interp *interp, CONST char *option, CONST TkStateMap *mapPtr, CONST char *strKey)); +EXTERN int TkFindStateNumObj _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *optionPtr, CONST TkStateMap *mapPtr, + Tcl_Obj *keyPtr)); EXTERN char * TkFindStateString _ANSI_ARGS_(( CONST TkStateMap *mapPtr, int numKey)); EXTERN void TkFocusDeadWindow _ANSI_ARGS_((TkWindow *winPtr)); @@ -777,7 +812,6 @@ EXTERN TkWindow * TkFocusKeyEvent _ANSI_ARGS_((TkWindow *winPtr, EXTERN void TkFontPkgInit _ANSI_ARGS_((TkMainInfo *mainPtr)); EXTERN void TkFontPkgFree _ANSI_ARGS_((TkMainInfo *mainPtr)); EXTERN void TkFreeBindingTags _ANSI_ARGS_((TkWindow *winPtr)); -EXTERN void TkFreeCursor _ANSI_ARGS_((TkCursor *cursorPtr)); EXTERN void TkFreeWindowId _ANSI_ARGS_((TkDisplay *dispPtr, Window w)); EXTERN void TkGenerateActivateEvents _ANSI_ARGS_(( @@ -802,14 +836,13 @@ EXTERN int TkGetInterpNames _ANSI_ARGS_((Tcl_Interp *interp, EXTERN int TkGetMiterPoints _ANSI_ARGS_((double p1[], double p2[], double p3[], double width, double m1[], double m2[])); -#ifndef TkGetNativeProlog -EXTERN int TkGetNativeProlog _ANSI_ARGS_((Tcl_Interp *interp)); -#endif EXTERN void TkGetPointerCoords _ANSI_ARGS_((Tk_Window tkwin, int *xPtr, int *yPtr)); -EXTERN int TkGetProlog _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN void TkGetServerInfo _ANSI_ARGS_((Tcl_Interp *interp, Tk_Window tkwin)); +EXTERN int TkGetWindowFromObj _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, Tcl_Obj *objPtr, + Tk_Window *windowPtr)); EXTERN void TkGrabDeadWindow _ANSI_ARGS_((TkWindow *winPtr)); EXTERN int TkGrabState _ANSI_ARGS_((TkWindow *winPtr)); EXTERN TkWindow * TkIDToWindow _ANSI_ARGS_((Window window, @@ -867,6 +900,7 @@ EXTERN void TkpDefineNativeBitmaps _ANSI_ARGS_((void)); #endif EXTERN void TkpDisplayWarning _ANSI_ARGS_((char *msg, char *title)); +EXTERN void TkpFreeCursor _ANSI_ARGS_((TkCursor *cursorPtr)); EXTERN void TkpGetAppName _ANSI_ARGS_((Tcl_Interp *interp, Tcl_DString *name)); EXTERN unsigned long TkpGetMS _ANSI_ARGS_((void)); @@ -875,6 +909,12 @@ EXTERN Pixmap TkpGetNativeAppBitmap _ANSI_ARGS_((Display *display, char *name, int *width, int *height)); #endif EXTERN TkWindow * TkpGetOtherWindow _ANSI_ARGS_((TkWindow *winPtr)); +EXTERN char * TkpGetString _ANSI_ARGS_((TkWindow *winPtr, + XEvent *eventPtr, Tcl_DString *dsPtr)); +EXTERN void TkpGetSubFonts _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Font tkfont)); +EXTERN Tcl_Obj * TkpGetSystemDefault _ANSI_ARGS_((Tk_Window tkwin, + char *dbName, char *className)); EXTERN TkWindow * TkpGetWrapperWindow _ANSI_ARGS_((TkWindow *winPtr)); EXTERN int TkpInit _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN void TkpInitializeMenuBindings _ANSI_ARGS_(( diff --git a/generic/tkListbox.c b/generic/tkListbox.c index 234130d..84b8b0c 100644 --- a/generic/tkListbox.c +++ b/generic/tkListbox.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkListbox.c 1.120 97/10/29 13:06:59 + * SCCS: @(#) tkListbox.c 1.122 98/02/11 18:00:20 */ #include "tkPort.h" @@ -428,7 +428,7 @@ Tk_ListboxCmd(clientData, interp, argc, argv) goto error; } - interp->result = Tk_PathName(listPtr->tkwin); + Tcl_SetResult(interp, Tk_PathName(listPtr->tkwin), TCL_STATIC); return TCL_OK; error: @@ -518,12 +518,14 @@ ListboxWidgetCmd(clientData, interp, argc, argv) if ((index >= listPtr->topIndex) && (index < listPtr->numElements) && (index < (listPtr->topIndex + listPtr->fullLines + listPtr->partialLine))) { + char buf[TCL_INTEGER_SPACE * 4]; + x = listPtr->inset + listPtr->selBorderWidth - listPtr->xOffset; y = ((index - listPtr->topIndex)*listPtr->lineHeight) + listPtr->inset + listPtr->selBorderWidth; Tk_GetFontMetrics(listPtr->tkfont, &fm); - sprintf(interp->result, "%d %d %d %d", x, y, elPtr->pixelWidth, - fm.linespace); + sprintf(buf, "%d %d %d %d", x, y, elPtr->pixelWidth, fm.linespace); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } } else if ((c == 'c') && (strncmp(argv[1], "cget", length) == 0) && (length >= 2)) { @@ -550,7 +552,6 @@ ListboxWidgetCmd(clientData, interp, argc, argv) } else if ((c == 'c') && (strncmp(argv[1], "curselection", length) == 0) && (length >= 2)) { int i, count; - char index[20]; Element *elPtr; if (argc != 2) { @@ -563,6 +564,8 @@ ListboxWidgetCmd(clientData, interp, argc, argv) for (i = 0, elPtr = listPtr->firstPtr; elPtr != NULL; i++, elPtr = elPtr->nextPtr) { if (elPtr->selected) { + char index[TCL_INTEGER_SPACE]; + sprintf(index, "%d", i); Tcl_AppendElement(interp, index); count++; @@ -609,8 +612,10 @@ ListboxWidgetCmd(clientData, interp, argc, argv) if (GetListboxIndex(interp, listPtr, argv[2], 0, &first) != TCL_OK) { goto error; } - if ((argc == 4) && (GetListboxIndex(interp, listPtr, argv[3], - 0, &last) != TCL_OK)) { + last = first; + if ((argc == 4) + && (GetListboxIndex(interp, listPtr, argv[3], 0, + &last) != TCL_OK)) { goto error; } if (first >= listPtr->numElements) { @@ -627,7 +632,7 @@ ListboxWidgetCmd(clientData, interp, argc, argv) if (elPtr != NULL) { if (argc == 3) { if (first >= 0) { - interp->result = elPtr->text; + Tcl_SetResult(interp, elPtr->text, TCL_STATIC); } } else { for ( ; i <= last; i++, elPtr = elPtr->nextPtr) { @@ -638,6 +643,7 @@ ListboxWidgetCmd(clientData, interp, argc, argv) } else if ((c == 'i') && (strncmp(argv[1], "index", length) == 0) && (length >= 3)) { int index; + char buf[TCL_INTEGER_SPACE]; if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", @@ -649,7 +655,8 @@ ListboxWidgetCmd(clientData, interp, argc, argv) != TCL_OK) { goto error; } - sprintf(interp->result, "%d", index); + sprintf(buf, "%d", index); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } else if ((c == 'i') && (strncmp(argv[1], "insert", length) == 0) && (length >= 3)) { int index; @@ -667,6 +674,7 @@ ListboxWidgetCmd(clientData, interp, argc, argv) InsertEls(listPtr, index, argc-3, argv+3); } else if ((c == 'n') && (strncmp(argv[1], "nearest", length) == 0)) { int index, y; + char buf[TCL_INTEGER_SPACE]; if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", @@ -677,7 +685,8 @@ ListboxWidgetCmd(clientData, interp, argc, argv) goto error; } index = NearestListboxElement(listPtr, y); - sprintf(interp->result, "%d", index); + sprintf(buf, "%d", index); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } else if ((c == 's') && (length >= 2) && (strncmp(argv[1], "scan", length) == 0)) { int x, y; @@ -788,7 +797,7 @@ ListboxWidgetCmd(clientData, interp, argc, argv) goto error; } if ((first < 0) || (first >= listPtr->numElements)) { - interp->result = "0"; + Tcl_SetResult(interp, "0", TCL_STATIC); goto done; } for (elPtr = listPtr->firstPtr, i = 0; i < first; @@ -796,9 +805,9 @@ ListboxWidgetCmd(clientData, interp, argc, argv) /* Empty loop body. */ } if (elPtr->selected) { - interp->result = "1"; + Tcl_SetResult(interp, "1", TCL_STATIC); } else { - interp->result = "0"; + Tcl_SetResult(interp, "0", TCL_STATIC); } } else if ((c == 's') && (strncmp(argv[2], "set", length) == 0)) { ListboxSelect(listPtr, first, last, 1); @@ -810,12 +819,15 @@ ListboxWidgetCmd(clientData, interp, argc, argv) } } else if ((c == 's') && (length >= 2) && (strncmp(argv[1], "size", length) == 0)) { + char buf[TCL_INTEGER_SPACE]; + if (argc != 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " size\"", (char *) NULL); goto error; } - sprintf(interp->result, "%d", listPtr->numElements); + sprintf(buf, "%d", listPtr->numElements); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } else if ((c == 'x') && (strncmp(argv[1], "xview", length) == 0)) { int index, count, type, windowWidth, windowUnits; int offset = 0; /* Initialized to stop gcc warnings. */ @@ -825,15 +837,18 @@ ListboxWidgetCmd(clientData, interp, argc, argv) - 2*(listPtr->inset + listPtr->selBorderWidth); if (argc == 2) { if (listPtr->maxWidth == 0) { - interp->result = "0 1"; + Tcl_SetResult(interp, "0 1", TCL_STATIC); } else { + char buf[TCL_DOUBLE_SPACE * 2]; + fraction = listPtr->xOffset/((double) listPtr->maxWidth); fraction2 = (listPtr->xOffset + windowWidth) /((double) listPtr->maxWidth); if (fraction2 > 1.0) { fraction2 = 1.0; } - sprintf(interp->result, "%g %g", fraction, fraction2); + sprintf(buf, "%g %g", fraction, fraction2); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } } else if (argc == 3) { if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) { @@ -869,15 +884,18 @@ ListboxWidgetCmd(clientData, interp, argc, argv) if (argc == 2) { if (listPtr->numElements == 0) { - interp->result = "0 1"; + Tcl_SetResult(interp, "0 1", TCL_STATIC); } else { + char buf[TCL_DOUBLE_SPACE * 2]; + fraction = listPtr->topIndex/((double) listPtr->numElements); fraction2 = (listPtr->topIndex+listPtr->fullLines) /((double) listPtr->numElements); if (fraction2 > 1.0) { fraction2 = 1.0; } - sprintf(interp->result, "%g %g", fraction, fraction2); + sprintf(buf, "%g %g", fraction, fraction2); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } } else if (argc == 3) { if (GetListboxIndex(interp, listPtr, argv[2], 0, &index) @@ -986,7 +1004,7 @@ DestroyListbox(memPtr) * * Results: * The return value is a standard Tcl result. If TCL_ERROR is - * returned, then interp->result contains an error message. + * returned, then the interp's result contains an error message. * * Side effects: * Configuration information, such as colors, border width, @@ -1718,7 +1736,7 @@ ListboxCmdDeletedProc(clientData) * Results: * A standard Tcl result. If all went well, then *indexPtr is * filled in with the index (into listPtr) corresponding to - * string. Otherwise an error message is left in interp->result. + * string. Otherwise an error message is left in the interp's result. * * Side effects: * None. diff --git a/generic/tkMacWinMenu.c b/generic/tkMacWinMenu.c index 8ae403b..e66fa48 100644 --- a/generic/tkMacWinMenu.c +++ b/generic/tkMacWinMenu.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkMacWinMenu.c 1.39 97/04/09 14:56:59 + * SCCS: @(#) tkMacWinMenu.c 1.41 97/10/22 15:05:23 */ #include "tkMenu.h" @@ -67,7 +67,7 @@ PreprocessMenu(menuPtr) finished = 1; for (index = 0; index < menuPtr->numEntries; index++) { if ((menuPtr->entries[index]->type == CASCADE_ENTRY) - && (menuPtr->entries[index]->name != NULL)) { + && (menuPtr->entries[index]->namePtr != NULL)) { if ((menuPtr->entries[index]->childMenuRefPtr != NULL) && (menuPtr->entries[index]->childMenuRefPtr->menuPtr != NULL)) { diff --git a/generic/tkMain.c b/generic/tkMain.c index ed823bd..e34067d 100644 --- a/generic/tkMain.c +++ b/generic/tkMain.c @@ -8,12 +8,12 @@ * for Tk applications. * * Copyright (c) 1990-1994 The Regents of the University of California. - * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkMain.c 1.154 97/08/29 10:40:43 + * SCCS: @(#) tkMain.c 1.158 98/01/20 22:46:33 */ #include <ctype.h> @@ -93,10 +93,11 @@ Tk_Main(argc, argv, appInitProc) * to execute commands. */ { char *args, *fileName; - char buf[20]; + char buf[TCL_INTEGER_SPACE]; int code; size_t length; Tcl_Channel inChannel, outChannel; + Tcl_DString argString; Tcl_FindExecutable(argv[0]); interp = Tcl_CreateInterp(); @@ -131,12 +132,19 @@ Tk_Main(argc, argv, appInitProc) */ args = Tcl_Merge(argc-1, argv+1); + Tcl_ExternalToUtfDString(NULL, args, -1, &argString); Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY); + Tcl_DStringFree(&argString); ckfree(args); sprintf(buf, "%d", argc-1); + + if (fileName == NULL) { + Tcl_ExternalToUtfDString(NULL, argv[0], -1, &argString); + } else { + fileName = Tcl_ExternalToUtfDString(NULL, fileName, -1, &argString); + } Tcl_SetVar(interp, "argc", buf, TCL_GLOBAL_ONLY); - Tcl_SetVar(interp, "argv0", (fileName != NULL) ? fileName : argv[0], - TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "argv0", Tcl_DStringValue(&argString), TCL_GLOBAL_ONLY); /* * Set the "tcl_interactive" variable. @@ -162,7 +170,8 @@ Tk_Main(argc, argv, appInitProc) */ if ((*appInitProc)(interp) != TCL_OK) { - TkpDisplayWarning(interp->result, "Application initialization failed"); + TkpDisplayWarning(Tcl_GetStringResult(interp), + "Application initialization failed"); } /* @@ -205,6 +214,7 @@ Tk_Main(argc, argv, appInitProc) Prompt(interp, 0); } } + Tcl_DStringFree(&argString); outChannel = Tcl_GetStdChannel(TCL_STDOUT); if (outChannel) { @@ -294,16 +304,13 @@ StdinProc(clientData, mask) (ClientData) chan); } Tcl_DStringFree(&command); - if (*interp->result != 0) { + if (Tcl_GetStringResult(interp)[0] != '\0') { if ((code != TCL_OK) || (tty)) { - /* - * The statement below used to call "printf", but that resulted - * in core dumps under Solaris 2.3 if the result was very long. - * - * NOTE: This probably will not work under Windows either. - */ - - puts(interp->result); + chan = Tcl_GetStdChannel(TCL_STDOUT); + if (chan) { + Tcl_WriteObj(chan, Tcl_GetObjResult(interp)); + Tcl_WriteChars(chan, "\n", 1); + } } } @@ -361,7 +368,7 @@ defaultPrompt: outChannel = Tcl_GetChannel(interp, "stdout", NULL); if (outChannel != (Tcl_Channel) NULL) { - Tcl_Write(outChannel, "% ", 2); + Tcl_WriteChars(outChannel, "% ", 2); } } } else { @@ -377,8 +384,8 @@ defaultPrompt: errChannel = Tcl_GetChannel(interp, "stderr", NULL); if (errChannel != (Tcl_Channel) NULL) { - Tcl_Write(errChannel, interp->result, -1); - Tcl_Write(errChannel, "\n", 1); + Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); + Tcl_WriteChars(errChannel, "\n", 1); } goto defaultPrompt; } diff --git a/generic/tkMenu.c b/generic/tkMenu.c index 05a6b4a..f7b0880 100644 --- a/generic/tkMenu.c +++ b/generic/tkMenu.c @@ -7,12 +7,12 @@ * and drawing code for menus is in the file tkMenuDraw.c * * Copyright (c) 1990-1994 The Regents of the University of California. - * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 1994-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkMenu.c 1.148 97/10/29 09:22:00 + * SCCS: @(#) tkMenu.c 1.165 98/02/11 19:02:31 */ /* @@ -68,6 +68,7 @@ * */ +#define __NO_OLD_CONFIG #include "tkPort.h" #include "tkMenu.h" @@ -81,161 +82,213 @@ static int menusInitialized; /* Whether or not the hash tables, etc., have * to update code in TkpMenuInit that changes the font string entry. */ -Tk_ConfigSpec tkMenuEntryConfigSpecs[] = { - {TK_CONFIG_BORDER, "-activebackground", (char *) NULL, (char *) NULL, - DEF_MENU_ENTRY_ACTIVE_BG, Tk_Offset(TkMenuEntry, activeBorder), - COMMAND_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|CASCADE_MASK - |TK_CONFIG_NULL_OK}, - {TK_CONFIG_COLOR, "-activeforeground", (char *) NULL, (char *) NULL, - DEF_MENU_ENTRY_ACTIVE_FG, Tk_Offset(TkMenuEntry, activeFg), - COMMAND_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|CASCADE_MASK - |TK_CONFIG_NULL_OK}, - {TK_CONFIG_STRING, "-accelerator", (char *) NULL, (char *) NULL, - DEF_MENU_ENTRY_ACCELERATOR, Tk_Offset(TkMenuEntry, accel), - COMMAND_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|CASCADE_MASK - |TK_CONFIG_NULL_OK}, - {TK_CONFIG_BORDER, "-background", (char *) NULL, (char *) NULL, - DEF_MENU_ENTRY_BG, Tk_Offset(TkMenuEntry, border), - COMMAND_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|CASCADE_MASK - |SEPARATOR_MASK|TEAROFF_MASK|TK_CONFIG_NULL_OK}, - {TK_CONFIG_BITMAP, "-bitmap", (char *) NULL, (char *) NULL, - DEF_MENU_ENTRY_BITMAP, Tk_Offset(TkMenuEntry, bitmap), - COMMAND_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|CASCADE_MASK - |TK_CONFIG_NULL_OK}, - {TK_CONFIG_BOOLEAN, "-columnbreak", (char *) NULL, (char *) NULL, - DEF_MENU_ENTRY_COLUMN_BREAK, Tk_Offset(TkMenuEntry, columnBreak), - COMMAND_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|CASCADE_MASK}, - {TK_CONFIG_STRING, "-command", (char *) NULL, (char *) NULL, - DEF_MENU_ENTRY_COMMAND, Tk_Offset(TkMenuEntry, command), - COMMAND_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|CASCADE_MASK - |TK_CONFIG_NULL_OK}, - {TK_CONFIG_FONT, "-font", (char *) NULL, (char *) NULL, - DEF_MENU_ENTRY_FONT, Tk_Offset(TkMenuEntry, tkfont), - COMMAND_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|CASCADE_MASK - |TK_CONFIG_NULL_OK}, - {TK_CONFIG_COLOR, "-foreground", (char *) NULL, (char *) NULL, - DEF_MENU_ENTRY_FG, Tk_Offset(TkMenuEntry, fg), - COMMAND_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|CASCADE_MASK - |TK_CONFIG_NULL_OK}, - {TK_CONFIG_BOOLEAN, "-hidemargin", (char *) NULL, (char *) NULL, - DEF_MENU_ENTRY_HIDE_MARGIN, Tk_Offset(TkMenuEntry, hideMargin), - COMMAND_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|CASCADE_MASK - |SEPARATOR_MASK|TEAROFF_MASK}, - {TK_CONFIG_STRING, "-image", (char *) NULL, (char *) NULL, - DEF_MENU_ENTRY_IMAGE, Tk_Offset(TkMenuEntry, imageString), - COMMAND_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|CASCADE_MASK - |TK_CONFIG_NULL_OK}, - {TK_CONFIG_BOOLEAN, "-indicatoron", (char *) NULL, (char *) NULL, - DEF_MENU_ENTRY_INDICATOR, Tk_Offset(TkMenuEntry, indicatorOn), - CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|TK_CONFIG_DONT_SET_DEFAULT}, - {TK_CONFIG_STRING, "-label", (char *) NULL, (char *) NULL, - DEF_MENU_ENTRY_LABEL, Tk_Offset(TkMenuEntry, label), - COMMAND_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|CASCADE_MASK}, - {TK_CONFIG_STRING, "-menu", (char *) NULL, (char *) NULL, - DEF_MENU_ENTRY_MENU, Tk_Offset(TkMenuEntry, name), - CASCADE_MASK|TK_CONFIG_NULL_OK}, - {TK_CONFIG_STRING, "-offvalue", (char *) NULL, (char *) NULL, - DEF_MENU_ENTRY_OFF_VALUE, Tk_Offset(TkMenuEntry, offValue), - CHECK_BUTTON_MASK}, - {TK_CONFIG_STRING, "-onvalue", (char *) NULL, (char *) NULL, - DEF_MENU_ENTRY_ON_VALUE, Tk_Offset(TkMenuEntry, onValue), - CHECK_BUTTON_MASK}, - {TK_CONFIG_COLOR, "-selectcolor", (char *) NULL, (char *) NULL, - DEF_MENU_ENTRY_SELECT, Tk_Offset(TkMenuEntry, indicatorFg), - CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|TK_CONFIG_NULL_OK}, - {TK_CONFIG_STRING, "-selectimage", (char *) NULL, (char *) NULL, - DEF_MENU_ENTRY_SELECT_IMAGE, Tk_Offset(TkMenuEntry, selectImageString), - CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|TK_CONFIG_NULL_OK}, - {TK_CONFIG_UID, "-state", (char *) NULL, (char *) NULL, - DEF_MENU_ENTRY_STATE, Tk_Offset(TkMenuEntry, state), - COMMAND_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|CASCADE_MASK - |TEAROFF_MASK|TK_CONFIG_DONT_SET_DEFAULT}, - {TK_CONFIG_STRING, "-value", (char *) NULL, (char *) NULL, - DEF_MENU_ENTRY_VALUE, Tk_Offset(TkMenuEntry, onValue), - RADIO_BUTTON_MASK|TK_CONFIG_NULL_OK}, - {TK_CONFIG_STRING, "-variable", (char *) NULL, (char *) NULL, - DEF_MENU_ENTRY_CHECK_VARIABLE, Tk_Offset(TkMenuEntry, name), - CHECK_BUTTON_MASK|TK_CONFIG_NULL_OK}, - {TK_CONFIG_STRING, "-variable", (char *) NULL, (char *) NULL, - DEF_MENU_ENTRY_RADIO_VARIABLE, Tk_Offset(TkMenuEntry, name), - RADIO_BUTTON_MASK}, - {TK_CONFIG_INT, "-underline", (char *) NULL, (char *) NULL, - DEF_MENU_ENTRY_UNDERLINE, Tk_Offset(TkMenuEntry, underline), - COMMAND_MASK|CHECK_BUTTON_MASK|RADIO_BUTTON_MASK|CASCADE_MASK - |TK_CONFIG_DONT_SET_DEFAULT}, - {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, - (char *) NULL, 0, 0} +char *tkMenuStateStrings[] = {"active", "normal", "disabled", (char *) NULL}; + +static char *menuEntryTypeStrings[] = {"cascade", "checkbutton", "command", + "radiobutton", "separator", (char *) NULL}; + +Tk_OptionSpec tkBasicMenuEntryConfigSpecs[] = { + {TK_OPTION_BORDER, "-activebackground", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_ACTIVE_BG, Tk_Offset(TkMenuEntry, activeBorderPtr), -1, + TK_OPTION_NULL_OK}, + {TK_OPTION_COLOR, "-activeforeground", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_ACTIVE_FG, + Tk_Offset(TkMenuEntry, activeFgPtr), -1, TK_OPTION_NULL_OK}, + {TK_OPTION_STRING, "-accelerator", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_ACCELERATOR, + Tk_Offset(TkMenuEntry, accelPtr), -1, TK_OPTION_NULL_OK}, + {TK_OPTION_BORDER, "-background", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_BG, + Tk_Offset(TkMenuEntry, borderPtr), -1, TK_OPTION_NULL_OK}, + {TK_OPTION_BITMAP, "-bitmap", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_BITMAP, + Tk_Offset(TkMenuEntry, bitmapPtr), -1, TK_OPTION_NULL_OK}, + {TK_OPTION_BOOLEAN, "-columnbreak", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_COLUMN_BREAK, + Tk_Offset(TkMenuEntry, columnBreakPtr), -1}, + {TK_OPTION_STRING, "-command", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_COMMAND, + Tk_Offset(TkMenuEntry, commandPtr), -1, TK_OPTION_NULL_OK}, + {TK_OPTION_FONT, "-font", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_FONT, + Tk_Offset(TkMenuEntry, fontPtr), -1, TK_OPTION_NULL_OK}, + {TK_OPTION_COLOR, "-foreground", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_FG, + Tk_Offset(TkMenuEntry, fgPtr), -1, TK_OPTION_NULL_OK}, + {TK_OPTION_BOOLEAN, "-hidemargin", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_HIDE_MARGIN, + Tk_Offset(TkMenuEntry, hideMarginPtr), -1}, + {TK_OPTION_STRING, "-image", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_IMAGE, + Tk_Offset(TkMenuEntry, imagePtr), -1, TK_OPTION_NULL_OK}, + {TK_OPTION_STRING, "-label", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_LABEL, + Tk_Offset(TkMenuEntry, labelPtr), -1, 0}, + {TK_OPTION_STRING_TABLE, "-state", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_STATE, + Tk_Offset(TkMenuEntry, statePtr), -1, 0, + (ClientData) tkMenuStateStrings}, + {TK_OPTION_INT, "-underline", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_UNDERLINE, -1, Tk_Offset(TkMenuEntry, underline)}, + {TK_OPTION_END} }; +Tk_OptionSpec tkSeparatorEntryConfigSpecs[] = { + {TK_OPTION_BORDER, "-background", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_BG, + Tk_Offset(TkMenuEntry, borderPtr), -1, TK_OPTION_NULL_OK}, + {TK_OPTION_END} +}; + +Tk_OptionSpec tkCheckButtonEntryConfigSpecs[] = { + {TK_OPTION_BOOLEAN, "-indicatoron", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_INDICATOR, + Tk_Offset(TkMenuEntry, indicatorOnPtr), -1}, + {TK_OPTION_STRING, "-offvalue", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_OFF_VALUE, + Tk_Offset(TkMenuEntry, offValuePtr), -1}, + {TK_OPTION_STRING, "-onvalue", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_ON_VALUE, + Tk_Offset(TkMenuEntry, onValuePtr), -1}, + {TK_OPTION_COLOR, "-selectcolor", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_SELECT, + Tk_Offset(TkMenuEntry, indicatorFgPtr), -1, TK_OPTION_NULL_OK}, + {TK_OPTION_STRING, "-selectimage", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_SELECT_IMAGE, + Tk_Offset(TkMenuEntry, selectImagePtr), -1, TK_OPTION_NULL_OK}, + {TK_OPTION_STRING, "-variable", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_CHECK_VARIABLE, + Tk_Offset(TkMenuEntry, namePtr), -1, TK_OPTION_NULL_OK}, + {TK_OPTION_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, -1, 0, (ClientData) tkBasicMenuEntryConfigSpecs} +}; + +Tk_OptionSpec tkRadioButtonEntryConfigSpecs[] = { + {TK_OPTION_BOOLEAN, "-indicatoron", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_INDICATOR, + Tk_Offset(TkMenuEntry, indicatorOnPtr), -1}, + {TK_OPTION_COLOR, "-selectcolor", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_SELECT, + Tk_Offset(TkMenuEntry, indicatorFgPtr), -1, TK_OPTION_NULL_OK}, + {TK_OPTION_STRING, "-selectimage", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_SELECT_IMAGE, + Tk_Offset(TkMenuEntry, selectImagePtr), -1, TK_OPTION_NULL_OK}, + {TK_OPTION_STRING, "-value", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_VALUE, + Tk_Offset(TkMenuEntry, onValuePtr), -1, TK_OPTION_NULL_OK}, + {TK_OPTION_STRING, "-variable", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_RADIO_VARIABLE, + Tk_Offset(TkMenuEntry, namePtr), -1, 0}, + {TK_OPTION_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, -1, 0, (ClientData) tkBasicMenuEntryConfigSpecs} +}; + +Tk_OptionSpec tkCascadeEntryConfigSpecs[] = { + {TK_OPTION_STRING, "-menu", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_MENU, + Tk_Offset(TkMenuEntry, namePtr), -1, TK_OPTION_NULL_OK}, + {TK_OPTION_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, -1, 0, (ClientData) tkBasicMenuEntryConfigSpecs} +}; + +Tk_OptionSpec tkTearoffEntryConfigSpecs[] = { + {TK_OPTION_BORDER, "-background", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_BG, + Tk_Offset(TkMenuEntry, borderPtr), -1, TK_OPTION_NULL_OK}, + {TK_OPTION_STRING_TABLE, "-state", (char *) NULL, (char *) NULL, + DEF_MENU_ENTRY_STATE, Tk_Offset(TkMenuEntry, statePtr), -1, 0, + (ClientData) tkMenuStateStrings}, + {TK_OPTION_END} +}; + +static Tk_OptionSpec *specsArray[] = { + tkCascadeEntryConfigSpecs, tkCheckButtonEntryConfigSpecs, + tkBasicMenuEntryConfigSpecs, tkRadioButtonEntryConfigSpecs, + tkSeparatorEntryConfigSpecs, tkTearoffEntryConfigSpecs}; + /* - * Configuration specs valid for the menu as a whole. If this changes, be sure - * to update code in TkpMenuInit that changes the font string entry. + * Menu type strings for use with Tcl_GetIndexFromObj. */ -Tk_ConfigSpec tkMenuConfigSpecs[] = { - {TK_CONFIG_BORDER, "-activebackground", "activeBackground", "Foreground", - DEF_MENU_ACTIVE_BG_COLOR, Tk_Offset(TkMenu, activeBorder), - TK_CONFIG_COLOR_ONLY}, - {TK_CONFIG_BORDER, "-activebackground", "activeBackground", "Foreground", - DEF_MENU_ACTIVE_BG_MONO, Tk_Offset(TkMenu, activeBorder), - TK_CONFIG_MONO_ONLY}, - {TK_CONFIG_PIXELS, "-activeborderwidth", "activeBorderWidth", +static char *menuTypeStrings[] = {"normal", "tearoff", "menubar", + (char *) NULL}; + +Tk_OptionSpec tkMenuConfigSpecs[] = { + {TK_OPTION_BORDER, "-activebackground", "activeBackground", + "Foreground", DEF_MENU_ACTIVE_BG_COLOR, + Tk_Offset(TkMenu, activeBorderPtr), -1, 0, + (ClientData) DEF_MENU_ACTIVE_BG_MONO}, + {TK_OPTION_PIXELS, "-activeborderwidth", "activeBorderWidth", "BorderWidth", DEF_MENU_ACTIVE_BORDER_WIDTH, - Tk_Offset(TkMenu, activeBorderWidth), 0}, - {TK_CONFIG_COLOR, "-activeforeground", "activeForeground", "Background", - DEF_MENU_ACTIVE_FG_COLOR, Tk_Offset(TkMenu, activeFg), - TK_CONFIG_COLOR_ONLY}, - {TK_CONFIG_COLOR, "-activeforeground", "activeForeground", "Background", - DEF_MENU_ACTIVE_FG_MONO, Tk_Offset(TkMenu, activeFg), - TK_CONFIG_MONO_ONLY}, - {TK_CONFIG_BORDER, "-background", "background", "Background", - DEF_MENU_BG_COLOR, Tk_Offset(TkMenu, border), TK_CONFIG_COLOR_ONLY}, - {TK_CONFIG_BORDER, "-background", "background", "Background", - DEF_MENU_BG_MONO, Tk_Offset(TkMenu, border), TK_CONFIG_MONO_ONLY}, - {TK_CONFIG_SYNONYM, "-bd", "borderWidth", (char *) NULL, - (char *) NULL, 0, 0}, - {TK_CONFIG_SYNONYM, "-bg", "background", (char *) NULL, - (char *) NULL, 0, 0}, - {TK_CONFIG_PIXELS, "-borderwidth", "borderWidth", "BorderWidth", - DEF_MENU_BORDER_WIDTH, Tk_Offset(TkMenu, borderWidth), 0}, - {TK_CONFIG_ACTIVE_CURSOR, "-cursor", "cursor", "Cursor", - DEF_MENU_CURSOR, Tk_Offset(TkMenu, cursor), TK_CONFIG_NULL_OK}, - {TK_CONFIG_COLOR, "-disabledforeground", "disabledForeground", + Tk_Offset(TkMenu, activeBorderWidthPtr), -1}, + {TK_OPTION_COLOR, "-activeforeground", "activeForeground", + "Background", DEF_MENU_ACTIVE_FG_COLOR, + Tk_Offset(TkMenu, activeFgPtr), -1, 0, + (ClientData) DEF_MENU_ACTIVE_FG_MONO}, + {TK_OPTION_BORDER, "-background", "background", "Background", + DEF_MENU_BG_COLOR, Tk_Offset(TkMenu, borderPtr), -1, 0, + (ClientData) DEF_MENU_BG_MONO}, + {TK_OPTION_SYNONYM, "-bd", (char *) NULL, (char *) NULL, + (char *) NULL, 0, -1, 0, (ClientData) "-borderwidth"}, + {TK_OPTION_SYNONYM, "-bg", (char *) NULL, (char *) NULL, + (char *) NULL, 0, -1, 0, (ClientData) "-background"}, + {TK_OPTION_PIXELS, "-borderwidth", "borderWidth", "BorderWidth", + DEF_MENU_BORDER_WIDTH, + Tk_Offset(TkMenu, borderWidthPtr), -1, 0}, + {TK_OPTION_CURSOR, "-cursor", "cursor", "Cursor", + DEF_MENU_CURSOR, + Tk_Offset(TkMenu, cursorPtr), -1, TK_OPTION_NULL_OK}, + {TK_OPTION_COLOR, "-disabledforeground", "disabledForeground", "DisabledForeground", DEF_MENU_DISABLED_FG_COLOR, - Tk_Offset(TkMenu, disabledFg), TK_CONFIG_COLOR_ONLY|TK_CONFIG_NULL_OK}, - {TK_CONFIG_COLOR, "-disabledforeground", "disabledForeground", - "DisabledForeground", DEF_MENU_DISABLED_FG_MONO, - Tk_Offset(TkMenu, disabledFg), TK_CONFIG_MONO_ONLY|TK_CONFIG_NULL_OK}, - {TK_CONFIG_SYNONYM, "-fg", "foreground", (char *) NULL, - (char *) NULL, 0, 0}, - {TK_CONFIG_FONT, "-font", "font", "Font", - DEF_MENU_FONT, Tk_Offset(TkMenu, tkfont), 0}, - {TK_CONFIG_COLOR, "-foreground", "foreground", "Foreground", - DEF_MENU_FG, Tk_Offset(TkMenu, fg), 0}, - {TK_CONFIG_STRING, "-postcommand", "postCommand", "Command", - DEF_MENU_POST_COMMAND, Tk_Offset(TkMenu, postCommand), - TK_CONFIG_NULL_OK}, - {TK_CONFIG_RELIEF, "-relief", "relief", "Relief", - DEF_MENU_RELIEF, Tk_Offset(TkMenu, relief), 0}, - {TK_CONFIG_COLOR, "-selectcolor", "selectColor", "Background", - DEF_MENU_SELECT_COLOR, Tk_Offset(TkMenu, indicatorFg), - TK_CONFIG_COLOR_ONLY}, - {TK_CONFIG_COLOR, "-selectcolor", "selectColor", "Background", - DEF_MENU_SELECT_MONO, Tk_Offset(TkMenu, indicatorFg), - TK_CONFIG_MONO_ONLY}, - {TK_CONFIG_STRING, "-takefocus", "takeFocus", "TakeFocus", - DEF_MENU_TAKE_FOCUS, Tk_Offset(TkMenu, takeFocus), TK_CONFIG_NULL_OK}, - {TK_CONFIG_BOOLEAN, "-tearoff", "tearOff", "TearOff", - DEF_MENU_TEAROFF, Tk_Offset(TkMenu, tearOff), 0}, - {TK_CONFIG_STRING, "-tearoffcommand", "tearOffCommand", "TearOffCommand", - DEF_MENU_TEAROFF_CMD, Tk_Offset(TkMenu, tearOffCommand), - TK_CONFIG_NULL_OK}, - {TK_CONFIG_STRING, "-title", "title", "Title", - DEF_MENU_TITLE, Tk_Offset(TkMenu, title), TK_CONFIG_NULL_OK}, - {TK_CONFIG_STRING, "-type", "type", "Type", - DEF_MENU_TYPE, Tk_Offset(TkMenu, menuTypeName), TK_CONFIG_NULL_OK}, - {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, - (char *) NULL, 0, 0} + Tk_Offset(TkMenu, disabledFgPtr), -1, TK_OPTION_NULL_OK, + (ClientData) DEF_MENU_DISABLED_FG_MONO}, + {TK_OPTION_SYNONYM, "-fg", (char *) NULL, (char *) NULL, + (char *) NULL, 0, -1, 0, (ClientData) "-foreground"}, + {TK_OPTION_FONT, "-font", "font", "Font", + DEF_MENU_FONT, Tk_Offset(TkMenu, fontPtr), -1}, + {TK_OPTION_COLOR, "-foreground", "foreground", "Foreground", + DEF_MENU_FG, Tk_Offset(TkMenu, fgPtr), -1}, + {TK_OPTION_STRING, "-postcommand", "postCommand", "Command", + DEF_MENU_POST_COMMAND, + Tk_Offset(TkMenu, postCommandPtr), -1, TK_OPTION_NULL_OK}, + {TK_OPTION_RELIEF, "-relief", "relief", "Relief", + DEF_MENU_RELIEF, Tk_Offset(TkMenu, reliefPtr), -1}, + {TK_OPTION_COLOR, "-selectcolor", "selectColor", "Background", + DEF_MENU_SELECT_COLOR, Tk_Offset(TkMenu, indicatorFgPtr), -1, 0, + (ClientData) DEF_MENU_SELECT_MONO}, + {TK_OPTION_STRING, "-takefocus", "takeFocus", "TakeFocus", + DEF_MENU_TAKE_FOCUS, + Tk_Offset(TkMenu, takeFocusPtr), -1, TK_OPTION_NULL_OK}, + {TK_OPTION_BOOLEAN, "-tearoff", "tearOff", "TearOff", + DEF_MENU_TEAROFF, + Tk_Offset(TkMenu, tearoffPtr), -1}, + {TK_OPTION_STRING, "-tearoffcommand", "tearOffCommand", + "TearOffCommand", DEF_MENU_TEAROFF_CMD, + Tk_Offset(TkMenu, tearoffCommandPtr), -1, TK_OPTION_NULL_OK}, + {TK_OPTION_STRING, "-title", "title", "Title", + DEF_MENU_TITLE, Tk_Offset(TkMenu, titlePtr), -1, + TK_OPTION_NULL_OK}, + {TK_OPTION_STRING_TABLE, "-type", "type", "Type", + DEF_MENU_TYPE, Tk_Offset(TkMenu, menuTypePtr), -1, TK_OPTION_NULL_OK, + (ClientData) menuTypeStrings}, + {TK_OPTION_END} +}; + +/* + * Command line options. Put here because MenuCmd has to look at them + * along with MenuWidgetObjCmd. + */ + +static char *menuOptions[] = { + "activate", "add", "cget", "clone", "configure", "delete", "entrycget", + "entryconfigure", "index", "insert", "invoke", "post", "postcascade", + "type", "unpost", "yposition", (char *) NULL +}; +enum options { + MENU_ACTIVATE, MENU_ADD, MENU_CGET, MENU_CLONE, MENU_CONFIGURE, + MENU_DELETE, MENU_ENTRYCGET, MENU_ENTRYCONFIGURE, MENU_INDEX, + MENU_INSERT, MENU_INVOKE, MENU_POST, MENU_POSTCASCADE, MENU_TYPE, + MENU_UNPOST, MENU_YPOSITION }; /* @@ -243,15 +296,14 @@ Tk_ConfigSpec tkMenuConfigSpecs[] = { */ static int CloneMenu _ANSI_ARGS_((TkMenu *menuPtr, - char *newMenuName, char *newMenuTypeString)); + Tcl_Obj *newMenuName, Tcl_Obj *newMenuTypeString)); static int ConfigureMenu _ANSI_ARGS_((Tcl_Interp *interp, - TkMenu *menuPtr, int argc, char **argv, - int flags)); + TkMenu *menuPtr, int objc, Tcl_Obj *CONST objv[])); static int ConfigureMenuCloneEntries _ANSI_ARGS_(( Tcl_Interp *interp, TkMenu *menuPtr, int index, - int argc, char **argv, int flags)); + int objc, Tcl_Obj *CONST objv[])); static int ConfigureMenuEntry _ANSI_ARGS_((TkMenuEntry *mePtr, - int argc, char **argv, int flags)); + int objc, Tcl_Obj *CONST objv[])); static void DeleteMenuCloneEntries _ANSI_ARGS_((TkMenu *menuPtr, int first, int last)); static void DestroyMenuHashTable _ANSI_ARGS_(( @@ -262,10 +314,13 @@ static int GetIndexFromCoords _ANSI_ARGS_((Tcl_Interp *interp, TkMenu *menuPtr, char *string, int *indexPtr)); static int MenuDoYPosition _ANSI_ARGS_((Tcl_Interp *interp, - TkMenu *menuPtr, char *arg)); + TkMenu *menuPtr, Tcl_Obj *objPtr)); static int MenuAddOrInsert _ANSI_ARGS_((Tcl_Interp *interp, - TkMenu *menuPtr, char *indexString, int argc, - char **argv)); + TkMenu *menuPtr, Tcl_Obj *indexPtr, int objc, + Tcl_Obj *CONST objv[])); +static int MenuCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); static void MenuCmdDeletedProc _ANSI_ARGS_(( ClientData clientData)); static TkMenuEntry * MenuNewEntry _ANSI_ARGS_((TkMenu *menuPtr, int index, @@ -273,10 +328,12 @@ static TkMenuEntry * MenuNewEntry _ANSI_ARGS_((TkMenu *menuPtr, int index, static char * MenuVarProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, char *name1, char *name2, int flags)); -static int MenuWidgetCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +static int MenuWidgetObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); static void MenuWorldChanged _ANSI_ARGS_(( ClientData instanceData)); +static int PostProcessEntry _ANSI_ARGS_((TkMenuEntry *mePtr)); static void RecursivelyDeleteMenu _ANSI_ARGS_((TkMenu *menuPtr)); static void UnhookCascadeEntry _ANSI_ARGS_((TkMenuEntry *mePtr)); @@ -290,13 +347,61 @@ static TkClassProcs menuClass = { NULL, /* createProc. */ MenuWorldChanged /* geometryProc. */ }; + +/* + *-------------------------------------------------------------- + * + * Tk_CreateMenuCmd -- + * + * Called by Tk at initialization time to create the menu + * command. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ +int +TkCreateMenuCmd(interp) + Tcl_Interp *interp; /* Interpreter we are creating the + * command in. */ +{ + TkMenuOptionTables *optionTablesPtr = + (TkMenuOptionTables *) ckalloc(sizeof(TkMenuOptionTables)); + + optionTablesPtr->menuOptionTable = + Tk_CreateOptionTable(interp, tkMenuConfigSpecs); + optionTablesPtr->entryOptionTables[TEAROFF_ENTRY] = + Tk_CreateOptionTable(interp, specsArray[TEAROFF_ENTRY]); + optionTablesPtr->entryOptionTables[COMMAND_ENTRY] = + Tk_CreateOptionTable(interp, specsArray[COMMAND_ENTRY]); + optionTablesPtr->entryOptionTables[CASCADE_ENTRY] = + Tk_CreateOptionTable(interp, specsArray[CASCADE_ENTRY]); + optionTablesPtr->entryOptionTables[SEPARATOR_ENTRY] = + Tk_CreateOptionTable(interp, specsArray[SEPARATOR_ENTRY]); + optionTablesPtr->entryOptionTables[RADIO_BUTTON_ENTRY] = + Tk_CreateOptionTable(interp, specsArray[RADIO_BUTTON_ENTRY]); + optionTablesPtr->entryOptionTables[CHECK_BUTTON_ENTRY] = + Tk_CreateOptionTable(interp, specsArray[CHECK_BUTTON_ENTRY]); + + Tcl_CreateObjCommand(interp, "menu", MenuCmd, + (ClientData) optionTablesPtr, NULL); + + if (Tcl_IsSafe(interp)) { + Tcl_HideCommand(interp, "menu", "menu"); + } + return TCL_OK; +} /* *-------------------------------------------------------------- * - * Tk_MenuCmd -- + * MenuCmd -- * * This procedure is invoked to process the "menu" Tcl * command. See the user documentation for details on @@ -311,48 +416,45 @@ static TkClassProcs menuClass = { *-------------------------------------------------------------- */ -int -Tk_MenuCmd(clientData, interp, argc, argv) +static int +MenuCmd(clientData, interp, objc, objv) ClientData clientData; /* Main window associated with * interpreter. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument strings. */ { - Tk_Window tkwin = (Tk_Window) clientData; + Tk_Window tkwin = Tk_MainWindow(interp); Tk_Window new; register TkMenu *menuPtr; TkMenuReferences *menuRefPtr; - int i, len; - char *arg, c; + int i, index; int toplevel; + char *windowName; + static char *typeStringList[] = {"-type", (char *) NULL}; + TkMenuOptionTables *optionTablesPtr = (TkMenuOptionTables *) clientData; - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " pathName ?options?\"", (char *) NULL); + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "pathName ?options?"); return TCL_ERROR; } TkMenuInit(); toplevel = 1; - for (i = 2; i < argc; i += 2) { - arg = argv[i]; - len = strlen(arg); - if (len < 2) { - continue; - } - c = arg[1]; - if ((c == 't') && (strncmp(arg, "-type", strlen(arg)) == 0) - && (len >= 3)) { - if (strcmp(argv[i + 1], "menubar") == 0) { + for (i = 2; i < (objc - 1); i++) { + if (Tcl_GetIndexFromObj(NULL, objv[i], typeStringList, NULL, 0, &index) + != TCL_ERROR) { + if ((Tcl_GetIndexFromObj(NULL, objv[i + 1], menuTypeStrings, NULL, + 0, &index) == TCL_OK) && (index == MENUBAR)) { toplevel = 0; } break; } } - new = Tk_CreateWindowFromPath(interp, tkwin, argv[1], toplevel ? "" + windowName = Tcl_GetStringFromObj(objv[1], NULL); + new = Tk_CreateWindowFromPath(interp, tkwin, windowName, toplevel ? "" : NULL); if (new == NULL) { return TCL_ERROR; @@ -366,27 +468,27 @@ Tk_MenuCmd(clientData, interp, argc, argv) menuPtr->tkwin = new; menuPtr->display = Tk_Display(new); menuPtr->interp = interp; - menuPtr->widgetCmd = Tcl_CreateCommand(interp, - Tk_PathName(menuPtr->tkwin), MenuWidgetCmd, + menuPtr->widgetCmd = Tcl_CreateObjCommand(interp, + Tk_PathName(menuPtr->tkwin), MenuWidgetObjCmd, (ClientData) menuPtr, MenuCmdDeletedProc); menuPtr->entries = NULL; menuPtr->numEntries = 0; menuPtr->active = -1; - menuPtr->border = NULL; - menuPtr->borderWidth = 0; - menuPtr->relief = TK_RELIEF_FLAT; - menuPtr->activeBorder = NULL; - menuPtr->activeBorderWidth = 0; - menuPtr->tkfont = NULL; - menuPtr->fg = NULL; - menuPtr->disabledFg = NULL; - menuPtr->activeFg = NULL; - menuPtr->indicatorFg = NULL; - menuPtr->tearOff = 1; - menuPtr->tearOffCommand = NULL; - menuPtr->cursor = None; - menuPtr->takeFocus = NULL; - menuPtr->postCommand = NULL; + menuPtr->borderPtr = NULL; + menuPtr->borderWidthPtr = NULL; + menuPtr->reliefPtr = NULL; + menuPtr->activeBorderPtr = NULL; + menuPtr->activeBorderWidthPtr = NULL; + menuPtr->fontPtr = NULL; + menuPtr->fgPtr = NULL; + menuPtr->disabledFgPtr = NULL; + menuPtr->activeFgPtr = NULL; + menuPtr->indicatorFgPtr = NULL; + menuPtr->tearoffPtr = NULL; + menuPtr->tearoffCommandPtr = NULL; + menuPtr->cursorPtr = None; + menuPtr->takeFocusPtr = NULL; + menuPtr->postCommandPtr = NULL; menuPtr->postCommandGeneration = 0; menuPtr->postedCascade = NULL; menuPtr->nextInstancePtr = NULL; @@ -394,24 +496,38 @@ Tk_MenuCmd(clientData, interp, argc, argv) menuPtr->menuType = UNKNOWN_TYPE; menuPtr->menuFlags = 0; menuPtr->parentTopLevelPtr = NULL; - menuPtr->menuTypeName = NULL; - menuPtr->title = NULL; + menuPtr->menuTypePtr = NULL; + menuPtr->titlePtr = NULL; + menuPtr->errorStructPtr = NULL; + menuPtr->optionTablesPtr = optionTablesPtr; TkMenuInitializeDrawingFields(menuPtr); + Tk_SetClass(menuPtr->tkwin, "Menu"); + TkSetClassProcs(menuPtr->tkwin, &menuClass, (ClientData) menuPtr); + if (Tk_InitOptions(interp, (char *) menuPtr, + menuPtr->optionTablesPtr->menuOptionTable, menuPtr->tkwin) + != TCL_OK) { + Tk_DestroyWindow(menuPtr->tkwin); + ckfree((char *) menuPtr); + return TCL_ERROR; + } + + menuRefPtr = TkCreateMenuReferences(menuPtr->interp, Tk_PathName(menuPtr->tkwin)); menuRefPtr->menuPtr = menuPtr; menuPtr->menuRefPtr = menuRefPtr; if (TCL_OK != TkpNewMenu(menuPtr)) { - goto error; + Tk_DestroyWindow(menuPtr->tkwin); + ckfree((char *) menuPtr); + return TCL_ERROR; } - Tk_SetClass(menuPtr->tkwin, "Menu"); - TkSetClassProcs(menuPtr->tkwin, &menuClass, (ClientData) menuPtr); Tk_CreateEventHandler(new, ExposureMask|StructureNotifyMask|ActivateMask, TkMenuEventProc, (ClientData) menuPtr); - if (ConfigureMenu(interp, menuPtr, argc-2, argv+2, 0) != TCL_OK) { - goto error; + if (ConfigureMenu(interp, menuPtr, objc - 2, objv + 2) != TCL_OK) { + Tk_DestroyWindow(menuPtr->tkwin); + return TCL_ERROR; } /* @@ -434,8 +550,8 @@ Tk_MenuCmd(clientData, interp, argc, argv) if (menuRefPtr->parentEntryPtr != NULL) { TkMenuEntry *cascadeListPtr = menuRefPtr->parentEntryPtr; TkMenuEntry *nextCascadePtr; - char *newMenuName; - char *newArgv[2]; + Tcl_Obj *newMenuName; + Tcl_Obj *newObjv[2]; while (cascadeListPtr != NULL) { @@ -454,28 +570,38 @@ Tk_MenuCmd(clientData, interp, argc, argv) || ((menuPtr->masterMenuPtr == menuPtr) && ((cascadeListPtr->menuPtr->masterMenuPtr == cascadeListPtr->menuPtr)))) { - newArgv[0] = "-menu"; - newArgv[1] = Tk_PathName(menuPtr->tkwin); - ConfigureMenuEntry(cascadeListPtr, 2, newArgv, - TK_CONFIG_ARGV_ONLY); + newObjv[0] = Tcl_NewStringObj("-menu", -1); + newObjv[1] = Tcl_NewStringObj(Tk_PathName(menuPtr->tkwin), -1); + Tcl_IncrRefCount(newObjv[0]); + Tcl_IncrRefCount(newObjv[1]); + ConfigureMenuEntry(cascadeListPtr, 2, newObjv); + Tcl_DecrRefCount(newObjv[0]); + Tcl_DecrRefCount(newObjv[1]); } else { + Tcl_Obj *normalPtr = Tcl_NewStringObj("normal", -1); + Tcl_Obj *windowNamePtr = Tcl_NewStringObj( + Tk_PathName(cascadeListPtr->menuPtr->tkwin), -1); + + Tcl_IncrRefCount(normalPtr); + Tcl_IncrRefCount(windowNamePtr); newMenuName = TkNewMenuName(menuPtr->interp, - Tk_PathName(cascadeListPtr->menuPtr->tkwin), - menuPtr); - CloneMenu(menuPtr, newMenuName, "normal"); + windowNamePtr, menuPtr); + Tcl_IncrRefCount(newMenuName); + CloneMenu(menuPtr, newMenuName, normalPtr); /* * Now we can set the new menu instance to be the cascade entry * of the parent's instance. */ - newArgv[0] = "-menu"; - newArgv[1] = newMenuName; - ConfigureMenuEntry(cascadeListPtr, 2, newArgv, - TK_CONFIG_ARGV_ONLY); - if (newMenuName != NULL) { - ckfree(newMenuName); - } + newObjv[0] = Tcl_NewStringObj("-menu", -1); + newObjv[1] = newMenuName; + Tcl_IncrRefCount(newObjv[0]); + ConfigureMenuEntry(cascadeListPtr, 2, newObjv); + Tcl_DecrRefCount(normalPtr); + Tcl_DecrRefCount(newObjv[0]); + Tcl_DecrRefCount(newObjv[1]); + Tcl_DecrRefCount(windowNamePtr); } cascadeListPtr = nextCascadePtr; } @@ -507,18 +633,14 @@ Tk_MenuCmd(clientData, interp, argc, argv) } } - interp->result = Tk_PathName(menuPtr->tkwin); + Tcl_SetResult(interp, Tk_PathName(menuPtr->tkwin), TCL_STATIC); return TCL_OK; - - error: - Tk_DestroyWindow(menuPtr->tkwin); - return TCL_ERROR; } /* *-------------------------------------------------------------- * - * MenuWidgetCmd -- + * MenuWidgetObjCmd -- * * This procedure is invoked to process the Tcl command * that corresponds to a widget managed by this module. @@ -534,317 +656,358 @@ Tk_MenuCmd(clientData, interp, argc, argv) */ static int -MenuWidgetCmd(clientData, interp, argc, argv) +MenuWidgetObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Information about menu widget. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument strings. */ { register TkMenu *menuPtr = (TkMenu *) clientData; register TkMenuEntry *mePtr; int result = TCL_OK; - size_t length; - int c; + int option; - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " option ?arg arg ...?\"", (char *) NULL); + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], menuOptions, "option", 0, + &option) != TCL_OK) { return TCL_ERROR; } Tcl_Preserve((ClientData) menuPtr); - c = argv[1][0]; - length = strlen(argv[1]); - if ((c == 'a') && (strncmp(argv[1], "activate", length) == 0) - && (length >= 2)) { - int index; - - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " activate index\"", (char *) NULL); - goto error; - } - if (TkGetMenuIndex(interp, menuPtr, argv[2], 0, &index) != TCL_OK) { - goto error; - } - if (menuPtr->active == index) { - goto done; - } - if (index >= 0) { - if ((menuPtr->entries[index]->type == SEPARATOR_ENTRY) - || (menuPtr->entries[index]->state == tkDisabledUid)) { - index = -1; + + switch ((enum options) option) { + case MENU_ACTIVATE: { + int index; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "activate index"); + goto error; + } + if (TkGetMenuIndex(interp, menuPtr, objv[2], 0, &index) + != TCL_OK) { + goto error; + } + if (menuPtr->active == index) { + goto done; } + if (index >= 0) { + if (menuPtr->entries[index]->type == SEPARATOR_ENTRY) { + int state; + + Tcl_GetIndexFromObj(interp, + menuPtr->entries[index]->statePtr, + tkMenuStateStrings, NULL, 0, &state); + if (state == ENTRY_DISABLED) { + index = -1; + } + } + } + result = TkActivateMenuEntry(menuPtr, index); + break; } - result = TkActivateMenuEntry(menuPtr, index); - } else if ((c == 'a') && (strncmp(argv[1], "add", length) == 0) - && (length >= 2)) { - if (argc < 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " add type ?options?\"", (char *) NULL); - goto error; + case MENU_ADD: + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "add type ?options?"); + goto error; + } + + if (MenuAddOrInsert(interp, menuPtr, (Tcl_Obj *) NULL, + objc - 2, objv + 2) != TCL_OK) { + goto error; + } + break; + case MENU_CGET: { + Tcl_Obj *resultPtr; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "cget option"); + goto error; + } + resultPtr = Tk_GetOptionValue(interp, (char *) menuPtr, + menuPtr->optionTablesPtr->menuOptionTable, objv[2], + menuPtr->tkwin); + if (resultPtr == NULL) { + goto error; + } + Tcl_SetObjResult(interp, resultPtr); + break; } - if (MenuAddOrInsert(interp, menuPtr, (char *) NULL, - argc-2, argv+2) != TCL_OK) { - goto error; + case MENU_CLONE: + if ((objc < 3) || (objc > 4)) { + Tcl_WrongNumArgs(interp, 1, objv, + "clone newMenuName ?menuType?"); + goto error; + } + result = CloneMenu(menuPtr, objv[2], (objc == 3) ? NULL : objv[3]); + break; + case MENU_CONFIGURE: { + Tcl_Obj *resultPtr; + + if (objc == 2) { + resultPtr = Tk_GetOptionInfo(interp, (char *) menuPtr, + menuPtr->optionTablesPtr->menuOptionTable, + (Tcl_Obj *) NULL, menuPtr->tkwin); + if (resultPtr == NULL) { + result = TCL_ERROR; + } else { + result = TCL_OK; + Tcl_SetObjResult(interp, resultPtr); + } + } else if (objc == 3) { + resultPtr = Tk_GetOptionInfo(interp, (char *) menuPtr, + menuPtr->optionTablesPtr->menuOptionTable, + objv[2], menuPtr->tkwin); + if (resultPtr == NULL) { + result = TCL_ERROR; + } else { + result = TCL_OK; + Tcl_SetObjResult(interp, resultPtr); + } + } else { + result = ConfigureMenu(interp, menuPtr, objc - 2, objv + 2); + } + if (result != TCL_OK) { + goto error; + } + break; } - } else if ((c == 'c') && (strncmp(argv[1], "cget", length) == 0) - && (length >= 2)) { - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " cget option\"", - (char *) NULL); - goto error; + case MENU_DELETE: { + int first, last, tearoff; + + if ((objc != 3) && (objc != 4)) { + Tcl_WrongNumArgs(interp, 1, objv, "delete first ?last?"); + goto error; + } + if (TkGetMenuIndex(interp, menuPtr, objv[2], 0, &first) + != TCL_OK) { + goto error; + } + if (objc == 3) { + last = first; + } else { + if (TkGetMenuIndex(interp, menuPtr, objv[3], 0, &last) + != TCL_OK) { + goto error; + } + } + Tcl_GetBooleanFromObj(interp, menuPtr->tearoffPtr, &tearoff); + if (tearoff && (first == 0)) { + + /* + * Sorry, can't delete the tearoff entry; must reconfigure + * the menu. + */ + + first = 1; + } + if ((first < 0) || (last < first)) { + goto done; + } + DeleteMenuCloneEntries(menuPtr, first, last); + break; } - result = Tk_ConfigureValue(interp, menuPtr->tkwin, tkMenuConfigSpecs, - (char *) menuPtr, argv[2], 0); - } else if ((c == 'c') && (strncmp(argv[1], "clone", length) == 0) - && (length >=2)) { - if ((argc < 3) || (argc > 4)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " clone newMenuName ?menuType?\"", - (char *) NULL); - goto error; - } - result = CloneMenu(menuPtr, argv[2], (argc == 3) ? NULL : argv[3]); - } else if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0) - && (length >= 2)) { - if (argc == 2) { - result = Tk_ConfigureInfo(interp, menuPtr->tkwin, - tkMenuConfigSpecs, (char *) menuPtr, (char *) NULL, 0); - } else if (argc == 3) { - result = Tk_ConfigureInfo(interp, menuPtr->tkwin, - tkMenuConfigSpecs, (char *) menuPtr, argv[2], 0); - } else { - result = ConfigureMenu(interp, menuPtr, argc-2, argv+2, - TK_CONFIG_ARGV_ONLY); + case MENU_ENTRYCGET: { + int index; + Tcl_Obj *resultPtr; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "entrycget index option"); + goto error; + } + if (TkGetMenuIndex(interp, menuPtr, objv[2], 0, &index) + != TCL_OK) { + goto error; + } + if (index < 0) { + goto done; + } + mePtr = menuPtr->entries[index]; + Tcl_Preserve((ClientData) mePtr); + resultPtr = Tk_GetOptionValue(interp, (char *) mePtr, + mePtr->optionTable, objv[3], menuPtr->tkwin); + Tcl_Release((ClientData) mePtr); + if (resultPtr == NULL) { + goto error; + } + Tcl_SetObjResult(interp, resultPtr); + break; } - } else if ((c == 'd') && (strncmp(argv[1], "delete", length) == 0)) { - int first, last; + case MENU_ENTRYCONFIGURE: { + int index; + Tcl_Obj *resultPtr; - if ((argc != 3) && (argc != 4)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " delete first ?last?\"", (char *) NULL); - goto error; + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, + "entryconfigure index ?option value ...?"); + goto error; + } + if (TkGetMenuIndex(interp, menuPtr, objv[2], 0, &index) + != TCL_OK) { + goto error; + } + if (index < 0) { + goto done; + } + mePtr = menuPtr->entries[index]; + Tcl_Preserve((ClientData) mePtr); + if (objc == 3) { + resultPtr = Tk_GetOptionInfo(interp, (char *) mePtr, + mePtr->optionTable, (Tcl_Obj *) NULL, menuPtr->tkwin); + if (resultPtr == NULL) { + result = TCL_ERROR; + } else { + result = TCL_OK; + Tcl_SetObjResult(interp, resultPtr); + } + } else if (objc == 4) { + resultPtr = Tk_GetOptionInfo(interp, (char *) mePtr, + mePtr->optionTable, objv[3], menuPtr->tkwin); + if (resultPtr == NULL) { + result = TCL_ERROR; + } else { + result = TCL_OK; + Tcl_SetObjResult(interp, resultPtr); + } + } else { + result = ConfigureMenuCloneEntries(interp, menuPtr, index, + objc - 3, objv + 3); + } + Tcl_Release((ClientData) mePtr); + break; } - if (TkGetMenuIndex(interp, menuPtr, argv[2], 0, &first) != TCL_OK) { - goto error; + case MENU_INDEX: { + int index; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "index string"); + goto error; + } + if (TkGetMenuIndex(interp, menuPtr, objv[2], 0, &index) + != TCL_OK) { + goto error; + } + if (index < 0) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1)); + } else { + Tcl_SetObjResult(interp, Tcl_NewIntObj(index)); + } + break; } - if (argc == 3) { - last = first; - } else { - if (TkGetMenuIndex(interp, menuPtr, argv[3], 0, &last) != TCL_OK) { - goto error; + case MENU_INSERT: + if (objc < 4) { + Tcl_WrongNumArgs(interp, 1, objv, + "insert index type ?options?"); + goto error; + } + if (MenuAddOrInsert(interp, menuPtr, objv[2], objc - 3, + objv + 3) != TCL_OK) { + goto error; } + break; + case MENU_INVOKE: { + int index; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "invoke index"); + goto error; + } + if (TkGetMenuIndex(interp, menuPtr, objv[2], 0, &index) + != TCL_OK) { + goto error; + } + if (index < 0) { + goto done; + } + result = TkInvokeMenu(interp, menuPtr, index); + break; } - if (menuPtr->tearOff && (first == 0)) { + case MENU_POST: { + int x, y; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "post x y"); + goto error; + } + if ((Tcl_GetIntFromObj(interp, objv[2], &x) != TCL_OK) + || (Tcl_GetIntFromObj(interp, objv[3], &y) != TCL_OK)) { + goto error; + } /* - * Sorry, can't delete the tearoff entry; must reconfigure - * the menu. + * Tearoff menus are posted differently on Mac and Windows than + * non-tearoffs. TkpPostMenu does not actually map the menu's + * window on those platforms, and popup menus have to be + * handled specially. */ - first = 1; - } - if ((first < 0) || (last < first)) { - goto done; - } - DeleteMenuCloneEntries(menuPtr, first, last); - } else if ((c == 'e') && (length >= 7) - && (strncmp(argv[1], "entrycget", length) == 0)) { - int index; - - if (argc != 4) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " entrycget index option\"", - (char *) NULL); - goto error; - } - if (TkGetMenuIndex(interp, menuPtr, argv[2], 0, &index) != TCL_OK) { - goto error; - } - if (index < 0) { - goto done; - } - mePtr = menuPtr->entries[index]; - Tcl_Preserve((ClientData) mePtr); - result = Tk_ConfigureValue(interp, menuPtr->tkwin, - tkMenuEntryConfigSpecs, (char *) mePtr, argv[3], - COMMAND_MASK << mePtr->type); - Tcl_Release((ClientData) mePtr); - } else if ((c == 'e') && (length >= 7) - && (strncmp(argv[1], "entryconfigure", length) == 0)) { - int index; - - if (argc < 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " entryconfigure index ?option value ...?\"", - (char *) NULL); - goto error; - } - if (TkGetMenuIndex(interp, menuPtr, argv[2], 0, &index) != TCL_OK) { - goto error; - } - if (index < 0) { - goto done; - } - mePtr = menuPtr->entries[index]; - Tcl_Preserve((ClientData) mePtr); - if (argc == 3) { - result = Tk_ConfigureInfo(interp, menuPtr->tkwin, - tkMenuEntryConfigSpecs, (char *) mePtr, (char *) NULL, - COMMAND_MASK << mePtr->type); - } else if (argc == 4) { - result = Tk_ConfigureInfo(interp, menuPtr->tkwin, - tkMenuEntryConfigSpecs, (char *) mePtr, argv[3], - COMMAND_MASK << mePtr->type); - } else { - result = ConfigureMenuCloneEntries(interp, menuPtr, index, - argc-3, argv+3, - TK_CONFIG_ARGV_ONLY | COMMAND_MASK << mePtr->type); - } - Tcl_Release((ClientData) mePtr); - } else if ((c == 'i') && (strncmp(argv[1], "index", length) == 0) - && (length >= 3)) { - int index; - - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " index string\"", (char *) NULL); - goto error; - } - if (TkGetMenuIndex(interp, menuPtr, argv[2], 0, &index) != TCL_OK) { - goto error; - } - if (index < 0) { - interp->result = "none"; - } else { - sprintf(interp->result, "%d", index); - } - } else if ((c == 'i') && (strncmp(argv[1], "insert", length) == 0) - && (length >= 3)) { - if (argc < 4) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " insert index type ?options?\"", (char *) NULL); - goto error; - } - if (MenuAddOrInsert(interp, menuPtr, argv[2], - argc-3, argv+3) != TCL_OK) { - goto error; + if (menuPtr->menuType != TEAROFF_MENU) { + result = TkpPostMenu(interp, menuPtr, x, y); + } else { + result = TkPostTearoffMenu(interp, menuPtr, x, y); + } + break; } - } else if ((c == 'i') && (strncmp(argv[1], "invoke", length) == 0) - && (length >= 3)) { - int index; + case MENU_POSTCASCADE: { + int index; - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " invoke index\"", (char *) NULL); - goto error; - } - if (TkGetMenuIndex(interp, menuPtr, argv[2], 0, &index) != TCL_OK) { - goto error; - } - if (index < 0) { - goto done; - } - result = TkInvokeMenu(interp, menuPtr, index); - } else if ((c == 'p') && (strncmp(argv[1], "post", length) == 0) - && (length == 4)) { - int x, y; - - if (argc != 4) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " post x y\"", (char *) NULL); - goto error; - } - if ((Tcl_GetInt(interp, argv[2], &x) != TCL_OK) - || (Tcl_GetInt(interp, argv[3], &y) != TCL_OK)) { - goto error; - } + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "postcascade index"); + goto error; + } - /* - * Tearoff menus are posted differently on Mac and Windows than - * non-tearoffs. TkpPostMenu does not actually map the menu's - * window on those platforms, and popup menus have to be - * handled specially. - */ - - if (menuPtr->menuType != TEAROFF_MENU) { - result = TkpPostMenu(interp, menuPtr, x, y); - } else { - result = TkPostTearoffMenu(interp, menuPtr, x, y); - } - } else if ((c == 'p') && (strncmp(argv[1], "postcascade", length) == 0) - && (length > 4)) { - int index; - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " postcascade index\"", (char *) NULL); - goto error; + if (TkGetMenuIndex(interp, menuPtr, objv[2], 0, &index) + != TCL_OK) { + goto error; + } + if ((index < 0) || (menuPtr->entries[index]->type + != CASCADE_ENTRY)) { + result = TkPostSubmenu(interp, menuPtr, (TkMenuEntry *) NULL); + } else { + result = TkPostSubmenu(interp, menuPtr, + menuPtr->entries[index]); + } + break; } - if (TkGetMenuIndex(interp, menuPtr, argv[2], 0, &index) != TCL_OK) { - goto error; + case MENU_TYPE: { + int index; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "type index"); + goto error; + } + if (TkGetMenuIndex(interp, menuPtr, objv[2], 0, &index) + != TCL_OK) { + goto error; + } + if (index < 0) { + goto done; + } + if (menuPtr->entries[index]->type == TEAROFF_ENTRY) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("tearoff", -1)); + } else { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + menuEntryTypeStrings[menuPtr->entries[index]->type], + -1)); + } + break; } - if ((index < 0) || (menuPtr->entries[index]->type != CASCADE_ENTRY)) { + case MENU_UNPOST: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "unpost"); + goto error; + } + Tk_UnmapWindow(menuPtr->tkwin); result = TkPostSubmenu(interp, menuPtr, (TkMenuEntry *) NULL); - } else { - result = TkPostSubmenu(interp, menuPtr, menuPtr->entries[index]); - } - } else if ((c == 't') && (strncmp(argv[1], "type", length) == 0)) { - int index; - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " type index\"", (char *) NULL); - goto error; - } - if (TkGetMenuIndex(interp, menuPtr, argv[2], 0, &index) != TCL_OK) { - goto error; - } - if (index < 0) { - goto done; - } - mePtr = menuPtr->entries[index]; - switch (mePtr->type) { - case COMMAND_ENTRY: - interp->result = "command"; - break; - case SEPARATOR_ENTRY: - interp->result = "separator"; - break; - case CHECK_BUTTON_ENTRY: - interp->result = "checkbutton"; - break; - case RADIO_BUTTON_ENTRY: - interp->result = "radiobutton"; - break; - case CASCADE_ENTRY: - interp->result = "cascade"; - break; - case TEAROFF_ENTRY: - interp->result = "tearoff"; - break; - } - } else if ((c == 'u') && (strncmp(argv[1], "unpost", length) == 0)) { - if (argc != 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " unpost\"", (char *) NULL); - goto error; - } - Tk_UnmapWindow(menuPtr->tkwin); - result = TkPostSubmenu(interp, menuPtr, (TkMenuEntry *) NULL); - } else if ((c == 'y') && (strncmp(argv[1], "yposition", length) == 0)) { - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " yposition index\"", (char *) NULL); - goto error; - } - result = MenuDoYPosition(interp, menuPtr, argv[2]); - } else { - Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be activate, add, cget, clone, configure, delete, ", - "entrycget, entryconfigure, index, insert, invoke, ", - "post, postcascade, type, unpost, or yposition", - (char *) NULL); - goto error; + break; + case MENU_YPOSITION: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "yposition index"); + goto error; + } + result = MenuDoYPosition(interp, menuPtr, objv[2]); + break; } done: Tcl_Release((ClientData) menuPtr); @@ -854,7 +1017,6 @@ MenuWidgetCmd(clientData, interp, argc, argv) Tcl_Release((ClientData) menuPtr); return TCL_ERROR; } - /* *---------------------------------------------------------------------- @@ -883,50 +1045,74 @@ TkInvokeMenu(interp, menuPtr, index) { int result = TCL_OK; TkMenuEntry *mePtr; + int state; if (index < 0) { goto done; } mePtr = menuPtr->entries[index]; - if (mePtr->state == tkDisabledUid) { + Tcl_GetIndexFromObj(NULL, mePtr->statePtr, tkMenuStateStrings, NULL, 0, + &state); + if (state == ENTRY_DISABLED) { goto done; } Tcl_Preserve((ClientData) mePtr); if (mePtr->type == TEAROFF_ENTRY) { - Tcl_DString commandDString; - - Tcl_DStringInit(&commandDString); - Tcl_DStringAppendElement(&commandDString, "tkTearOffMenu"); - Tcl_DStringAppendElement(&commandDString, Tk_PathName(menuPtr->tkwin)); - result = Tcl_Eval(interp, Tcl_DStringValue(&commandDString)); - Tcl_DStringFree(&commandDString); - } else if (mePtr->type == CHECK_BUTTON_ENTRY) { + Tcl_Obj *objv[2]; + + objv[0] = Tcl_NewStringObj("tkTearOffMenu", -1); + Tcl_IncrRefCount(objv[0]); + objv[1] = Tcl_NewStringObj(Tk_PathName(menuPtr->tkwin), -1); + Tcl_IncrRefCount(objv[1]); + result = Tcl_EvalObjv(interp, 2, objv, "", -1, 0); + Tcl_DecrRefCount(objv[0]); + Tcl_DecrRefCount(objv[1]); + } else if ((mePtr->type == CHECK_BUTTON_ENTRY) + && (mePtr->namePtr != NULL)) { + Tcl_Obj *valuePtr; + char *name; + if (mePtr->entryFlags & ENTRY_SELECTED) { - if (Tcl_SetVar(interp, mePtr->name, mePtr->offValue, - TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { - result = TCL_ERROR; - } + valuePtr = mePtr->offValuePtr; } else { - if (Tcl_SetVar(interp, mePtr->name, mePtr->onValue, - TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { - result = TCL_ERROR; - } + valuePtr = mePtr->onValuePtr; } - } else if (mePtr->type == RADIO_BUTTON_ENTRY) { - if (Tcl_SetVar(interp, mePtr->name, mePtr->onValue, + if (valuePtr == NULL) { + valuePtr = Tcl_NewStringObj("", -1); + } + Tcl_IncrRefCount(valuePtr); + name = Tcl_GetStringFromObj(mePtr->namePtr, NULL); + if (Tcl_SetObjVar2(interp, name, NULL, valuePtr, TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { result = TCL_ERROR; } + Tcl_DecrRefCount(valuePtr); + } else if ((mePtr->type == RADIO_BUTTON_ENTRY) + && (mePtr->namePtr != NULL)) { + Tcl_Obj *valuePtr = mePtr->onValuePtr; + char *name = Tcl_GetStringFromObj(mePtr->namePtr, NULL); + + if (valuePtr == NULL) { + valuePtr = Tcl_NewStringObj("", -1); + } + Tcl_IncrRefCount(valuePtr); + if (Tcl_SetObjVar2(interp, name, NULL, valuePtr, + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { + result = TCL_ERROR; + } + Tcl_DecrRefCount(valuePtr); } - if ((result == TCL_OK) && (mePtr->command != NULL)) { - result = TkCopyAndGlobalEval(interp, mePtr->command); + if ((result == TCL_OK) && (mePtr->commandPtr != NULL)) { + Tcl_Obj *commandPtr = mePtr->commandPtr; + + Tcl_IncrRefCount(commandPtr); + result = Tcl_EvalObj(interp, commandPtr, TCL_EVAL_GLOBAL); + Tcl_DecrRefCount(commandPtr); } Tcl_Release((ClientData) mePtr); done: return result; } - - /* *---------------------------------------------------------------------- @@ -951,13 +1137,12 @@ static void DestroyMenuInstance(menuPtr) TkMenu *menuPtr; /* Info about menu widget. */ { - int i, numEntries = menuPtr->numEntries; + int i; TkMenu *menuInstancePtr; TkMenuEntry *cascadePtr, *nextCascadePtr; - char *newArgv[2]; + Tcl_Obj *newObjv[2]; TkMenu *parentMasterMenuPtr; TkMenuEntry *parentMasterEntryPtr; - TkMenu *parentMenuPtr; /* * If the menu has any cascade menu entries pointing to it, the cascade @@ -979,18 +1164,23 @@ DestroyMenuInstance(menuPtr) TkFreeMenuReferences(menuPtr->menuRefPtr); for (; cascadePtr != NULL; cascadePtr = nextCascadePtr) { - parentMenuPtr = cascadePtr->menuPtr; nextCascadePtr = cascadePtr->nextCascadePtr; if (menuPtr->masterMenuPtr != menuPtr) { + Tcl_Obj *menuNamePtr = Tcl_NewStringObj("-menu", -1); + parentMasterMenuPtr = cascadePtr->menuPtr->masterMenuPtr; parentMasterEntryPtr = parentMasterMenuPtr->entries[cascadePtr->index]; - newArgv[0] = "-menu"; - newArgv[1] = parentMasterEntryPtr->name; - ConfigureMenuEntry(cascadePtr, 2, newArgv, TK_CONFIG_ARGV_ONLY); + newObjv[0] = menuNamePtr; + newObjv[1] = parentMasterEntryPtr->namePtr; + Tcl_IncrRefCount(newObjv[0]); + Tcl_IncrRefCount(newObjv[1]); + ConfigureMenuEntry(cascadePtr, 2, newObjv); + Tcl_DecrRefCount(newObjv[0]); + Tcl_DecrRefCount(newObjv[1]); } else { - ConfigureMenuEntry(cascadePtr, 0, (char **) NULL, 0); + ConfigureMenuEntry(cascadePtr, 0, (Tcl_Obj **) NULL); } } @@ -1010,20 +1200,27 @@ DestroyMenuInstance(menuPtr) /* * Free up all the stuff that requires special handling, then - * let Tk_FreeOptions handle all the standard option-related + * let Tk_FreeConfigurationOptions handle all the standard option-related * stuff. */ - for (i = numEntries - 1; i >= 0; i--) { + for (i = menuPtr->numEntries; --i >= 0; ) { + /* + * As each menu entry is deleted from the end of the array of + * entries, decrement menuPtr->numEntries. Otherwise, the act of + * deleting menu entry i will dereference freed memory attempting + * to queue a redraw for menu entries (i+1)...numEntries. + */ + DestroyMenuEntry((char *) menuPtr->entries[i]); + menuPtr->numEntries = i; } if (menuPtr->entries != NULL) { ckfree((char *) menuPtr->entries); } TkMenuFreeDrawOptions(menuPtr); - Tk_FreeOptions(tkMenuConfigSpecs, (char *) menuPtr, menuPtr->display, 0); - - Tcl_EventuallyFree((ClientData) menuPtr, TCL_DYNAMIC); + Tk_FreeConfigOptions((char *) menuPtr, + menuPtr->optionTablesPtr->menuOptionTable, menuPtr->tkwin); } /* @@ -1202,7 +1399,7 @@ DestroyMenuEntry(memPtr) /* * Free up all the stuff that requires special handling, then - * let Tk_FreeOptions handle all the standard option-related + * let Tk_FreeConfigurationOptions handle all the standard option-related * stuff. */ @@ -1215,15 +1412,17 @@ DestroyMenuEntry(memPtr) if (mePtr->selectImage != NULL) { Tk_FreeImage(mePtr->selectImage); } - if (mePtr->name != NULL) { - Tcl_UntraceVar(menuPtr->interp, mePtr->name, + if (((mePtr->type == CHECK_BUTTON_ENTRY) + || (mePtr->type == RADIO_BUTTON_ENTRY)) + && (mePtr->namePtr != NULL)) { + char *varName = Tcl_GetStringFromObj(mePtr->namePtr, NULL); + Tcl_UntraceVar(menuPtr->interp, varName, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, MenuVarProc, (ClientData) mePtr); } TkpDestroyMenuEntry(mePtr); TkMenuEntryFreeDrawOptions(mePtr); - Tk_FreeOptions(tkMenuEntryConfigSpecs, (char *) mePtr, menuPtr->display, - (COMMAND_MASK << mePtr->type)); + Tk_FreeConfigOptions((char *) mePtr, mePtr->optionTable, menuPtr->tkwin); ckfree((char *) mePtr); } @@ -1259,7 +1458,6 @@ MenuWorldChanged(instanceData) TkpConfigureMenuEntry(menuPtr->entries[i]); } } - /* *---------------------------------------------------------------------- @@ -1272,7 +1470,7 @@ MenuWorldChanged(instanceData) * * Results: * The return value is a standard Tcl result. If TCL_ERROR is - * returned, then interp->result contains an error message. + * returned, then the interp's result contains an error message. * * Side effects: * Configuration information, such as colors, font, etc. get set @@ -1282,23 +1480,33 @@ MenuWorldChanged(instanceData) */ static int -ConfigureMenu(interp, menuPtr, argc, argv, flags) +ConfigureMenu(interp, menuPtr, objc, objv) Tcl_Interp *interp; /* Used for error reporting. */ register TkMenu *menuPtr; /* Information about widget; may or may * not already have values for some fields. */ - int argc; /* Number of valid entries in argv. */ - char **argv; /* Arguments. */ - int flags; /* Flags to pass to Tk_ConfigureWidget. */ + int objc; /* Number of valid entries in argv. */ + Tcl_Obj *CONST objv[]; /* Arguments. */ { int i; - TkMenu* menuListPtr; + TkMenu *menuListPtr, *cleanupPtr; + int result; + int tearoff; for (menuListPtr = menuPtr->masterMenuPtr; menuListPtr != NULL; menuListPtr = menuListPtr->nextInstancePtr) { - - if (Tk_ConfigureWidget(interp, menuListPtr->tkwin, - tkMenuConfigSpecs, argc, argv, (char *) menuListPtr, - flags) != TCL_OK) { + menuListPtr->errorStructPtr = (Tk_SavedOptions *) + ckalloc(sizeof(Tk_SavedOptions)); + result = Tk_SetOptions(interp, (char *) menuListPtr, + menuListPtr->optionTablesPtr->menuOptionTable, objc, objv, + menuListPtr->tkwin, menuListPtr->errorStructPtr, (int *) NULL); + if (result != TCL_OK) { + for (cleanupPtr = menuPtr->masterMenuPtr; + cleanupPtr != menuListPtr; + cleanupPtr = cleanupPtr->nextInstancePtr) { + Tk_RestoreSavedOptions(cleanupPtr->errorStructPtr); + ckfree((char *) cleanupPtr->errorStructPtr); + cleanupPtr->errorStructPtr = NULL; + } return TCL_ERROR; } @@ -1310,33 +1518,58 @@ ConfigureMenu(interp, menuPtr, argc, argv, flags) */ if (menuListPtr->menuType == UNKNOWN_TYPE) { - if (strcmp(menuListPtr->menuTypeName, "menubar") == 0) { - menuListPtr->menuType = MENUBAR; - } else if (strcmp(menuListPtr->menuTypeName, "tearoff") == 0) { - menuListPtr->menuType = TEAROFF_MENU; - } else { - menuListPtr->menuType = MASTER_MENU; + Tcl_GetIndexFromObj(NULL, menuListPtr->menuTypePtr, + menuTypeStrings, NULL, 0, &menuListPtr->menuType); + + /* + * Configure the new window to be either a pop-up menu + * or a tear-off menu. + * We don't do this for menubars since they are not toplevel + * windows. Also, since this gets called before CloneMenu has + * a chance to set the menuType field, we have to look at the + * menuTypeName field to tell that this is a menu bar. + */ + + if (menuListPtr->menuType == MASTER_MENU) { + TkpMakeMenuWindow(menuListPtr->tkwin, 1); + } else if (menuListPtr->menuType == TEAROFF_MENU) { + TkpMakeMenuWindow(menuListPtr->tkwin, 0); } } - + + /* * Depending on the -tearOff option, make sure that there is or * isn't an initial tear-off entry at the beginning of the menu. */ - if (menuListPtr->tearOff) { + Tcl_GetBooleanFromObj(NULL, menuListPtr->tearoffPtr, &tearoff); + if (tearoff) { if ((menuListPtr->numEntries == 0) || (menuListPtr->entries[0]->type != TEAROFF_ENTRY)) { if (MenuNewEntry(menuListPtr, 0, TEAROFF_ENTRY) == NULL) { + if (menuListPtr->errorStructPtr != NULL) { + for (cleanupPtr = menuPtr->masterMenuPtr; + cleanupPtr != menuListPtr; + cleanupPtr = cleanupPtr->nextInstancePtr) { + Tk_RestoreSavedOptions(cleanupPtr->errorStructPtr); + ckfree((char *) cleanupPtr->errorStructPtr); + cleanupPtr->errorStructPtr = NULL; + } + Tk_RestoreSavedOptions(cleanupPtr->errorStructPtr); + ckfree((char *) cleanupPtr->errorStructPtr); + cleanupPtr->errorStructPtr = NULL; + } return TCL_ERROR; } } } else if ((menuListPtr->numEntries > 0) && (menuListPtr->entries[0]->type == TEAROFF_ENTRY)) { int i; - + Tcl_EventuallyFree((ClientData) menuListPtr->entries[0], DestroyMenuEntry); + for (i = 0; i < menuListPtr->numEntries - 1; i++) { menuListPtr->entries[i] = menuListPtr->entries[i + 1]; menuListPtr->entries[i]->index = i; @@ -1349,21 +1582,6 @@ ConfigureMenu(interp, menuPtr, argc, argv, flags) } TkMenuConfigureDrawOptions(menuListPtr); - - /* - * Configure the new window to be either a pop-up menu - * or a tear-off menu. - * We don't do this for menubars since they are not toplevel - * windows. Also, since this gets called before CloneMenu has - * a chance to set the menuType field, we have to look at the - * menuTypeName field to tell that this is a menu bar. - */ - - if (strcmp(menuListPtr->menuTypeName, "normal") == 0) { - TkpMakeMenuWindow(menuListPtr->tkwin, 1); - } else if (strcmp(menuListPtr->menuTypeName, "tearoff") == 0) { - TkpMakeMenuWindow(menuListPtr->tkwin, 0); - } /* * After reconfiguring a menu, we need to reconfigure all of the @@ -1376,28 +1594,35 @@ ConfigureMenu(interp, menuPtr, argc, argv, flags) TkMenuEntry *mePtr; mePtr = menuListPtr->entries[i]; - ConfigureMenuEntry(mePtr, 0, - (char **) NULL, TK_CONFIG_ARGV_ONLY - | COMMAND_MASK << mePtr->type); + ConfigureMenuEntry(mePtr, 0, (Tcl_Obj **) NULL); } TkEventuallyRecomputeMenu(menuListPtr); } + for (cleanupPtr = menuPtr->masterMenuPtr; cleanupPtr != NULL; + cleanupPtr = cleanupPtr->nextInstancePtr) { + Tk_FreeSavedOptions(cleanupPtr->errorStructPtr); + ckfree((char *) cleanupPtr->errorStructPtr); + cleanupPtr->errorStructPtr = NULL; + } + return TCL_OK; } + /* *---------------------------------------------------------------------- * - * ConfigureMenuEntry -- + * PostProcessEntry -- * - * This procedure is called to process an argv/argc list in order - * to configure (or reconfigure) one entry in a menu. + * This is called by ConfigureMenuEntry to do all of the configuration + * after Tk_SetOptions is called. This is separate + * so that error handling is easier. * * Results: * The return value is a standard Tcl result. If TCL_ERROR is - * returned, then interp->result contains an error message. + * returned, then the interp's result contains an error message. * * Side effects: * Configuration information such as label and accelerator get @@ -1407,55 +1632,29 @@ ConfigureMenu(interp, menuPtr, argc, argv, flags) */ static int -ConfigureMenuEntry(mePtr, argc, argv, flags) - register TkMenuEntry *mePtr; /* Information about menu entry; may - * or may not already have values for - * some fields. */ - int argc; /* Number of valid entries in argv. */ - char **argv; /* Arguments. */ - int flags; /* Additional flags to pass to - * Tk_ConfigureWidget. */ +PostProcessEntry(mePtr) + TkMenuEntry *mePtr; /* The entry we are configuring. */ { TkMenu *menuPtr = mePtr->menuPtr; int index = mePtr->index; + char *name; Tk_Image image; /* - * If this entry is a check button or radio button, then remove - * its old trace procedure. - */ - - if ((mePtr->name != NULL) - && ((mePtr->type == CHECK_BUTTON_ENTRY) - || (mePtr->type == RADIO_BUTTON_ENTRY))) { - Tcl_UntraceVar(menuPtr->interp, mePtr->name, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - MenuVarProc, (ClientData) mePtr); - } - - if (menuPtr->tkwin != NULL) { - if (Tk_ConfigureWidget(menuPtr->interp, menuPtr->tkwin, - tkMenuEntryConfigSpecs, argc, argv, (char *) mePtr, - flags | (COMMAND_MASK << mePtr->type)) != TCL_OK) { - return TCL_ERROR; - } - } - - /* * The code below handles special configuration stuff not taken * care of by Tk_ConfigureWidget, such as special processing for * defaults, sizing strings, graphics contexts, etc. */ - if (mePtr->label == NULL) { + if (mePtr->labelPtr == NULL) { mePtr->labelLength = 0; } else { - mePtr->labelLength = strlen(mePtr->label); + Tcl_GetStringFromObj(mePtr->labelPtr, &mePtr->labelLength); } - if (mePtr->accel == NULL) { + if (mePtr->accelPtr == NULL) { mePtr->accelLength = 0; } else { - mePtr->accelLength = strlen(mePtr->accel); + Tcl_GetStringFromObj(mePtr->accelPtr, &mePtr->accelLength); } /* @@ -1464,9 +1663,8 @@ ConfigureMenuEntry(mePtr, argc, argv, flags) * cascades have to be updated. */ - if ((mePtr->type == CASCADE_ENTRY) && (mePtr->name != NULL)) { + if ((mePtr->type == CASCADE_ENTRY) && (mePtr->namePtr != NULL)) { TkMenuEntry *cascadeEntryPtr; - TkMenu *cascadeMenuPtr; int alreadyThere; TkMenuReferences *menuRefPtr; char *oldHashKey = NULL; /* Initialization only needed to @@ -1482,19 +1680,18 @@ ConfigureMenuEntry(mePtr, argc, argv, flags) * BUG: We are not recloning for special case #3 yet. */ + name = Tcl_GetStringFromObj(mePtr->namePtr, NULL); if (mePtr->childMenuRefPtr != NULL) { oldHashKey = Tcl_GetHashKey(TkGetMenuHashTable(menuPtr->interp), mePtr->childMenuRefPtr->hashEntryPtr); - if (strcmp(oldHashKey, mePtr->name) != 0) { + if (strcmp(oldHashKey, name) != 0) { UnhookCascadeEntry(mePtr); } } if ((mePtr->childMenuRefPtr == NULL) - || (strcmp(oldHashKey, mePtr->name) != 0)) { - menuRefPtr = TkCreateMenuReferences(menuPtr->interp, - mePtr->name); - cascadeMenuPtr = menuRefPtr->menuPtr; + || (strcmp(oldHashKey, name) != 0)) { + menuRefPtr = TkCreateMenuReferences(menuPtr->interp, name); mePtr->childMenuRefPtr = menuRefPtr; if (menuRefPtr->parentEntryPtr == NULL) { @@ -1531,52 +1728,15 @@ ConfigureMenuEntry(mePtr, argc, argv, flags) return TCL_ERROR; } - if ((mePtr->type == CHECK_BUTTON_ENTRY) - || (mePtr->type == RADIO_BUTTON_ENTRY)) { - char *value; - - if (mePtr->name == NULL) { - mePtr->name = - (char *) ckalloc((unsigned) (mePtr->labelLength + 1)); - strcpy(mePtr->name, (mePtr->label == NULL) ? "" : mePtr->label); - } - if (mePtr->onValue == NULL) { - mePtr->onValue = (char *) ckalloc((unsigned) - (mePtr->labelLength + 1)); - strcpy(mePtr->onValue, (mePtr->label == NULL) ? "" : mePtr->label); - } - - /* - * Select the entry if the associated variable has the - * appropriate value, initialize the variable if it doesn't - * exist, then set a trace on the variable to monitor future - * changes to its value. - */ - - value = Tcl_GetVar(menuPtr->interp, mePtr->name, TCL_GLOBAL_ONLY); - mePtr->entryFlags &= ~ENTRY_SELECTED; - if (value != NULL) { - if (strcmp(value, mePtr->onValue) == 0) { - mePtr->entryFlags |= ENTRY_SELECTED; - } - } else { - Tcl_SetVar(menuPtr->interp, mePtr->name, - (mePtr->type == CHECK_BUTTON_ENTRY) ? mePtr->offValue : "", - TCL_GLOBAL_ONLY); - } - Tcl_TraceVar(menuPtr->interp, mePtr->name, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - MenuVarProc, (ClientData) mePtr); - } - /* * Get the images for the entry, if there are any. Allocate the * new images before freeing the old ones, so that the reference * counts don't go to zero and cause image data to be discarded. */ - if (mePtr->imageString != NULL) { - image = Tk_GetImage(menuPtr->interp, menuPtr->tkwin, mePtr->imageString, + if (mePtr->imagePtr != NULL) { + char *imageString = Tcl_GetStringFromObj(mePtr->imagePtr, NULL); + image = Tk_GetImage(menuPtr->interp, menuPtr->tkwin, imageString, TkMenuImageProc, (ClientData) mePtr); if (image == NULL) { return TCL_ERROR; @@ -1588,8 +1748,10 @@ ConfigureMenuEntry(mePtr, argc, argv, flags) Tk_FreeImage(mePtr->image); } mePtr->image = image; - if (mePtr->selectImageString != NULL) { - image = Tk_GetImage(menuPtr->interp, menuPtr->tkwin, mePtr->selectImageString, + if (mePtr->selectImagePtr != NULL) { + char *selectImageString = Tcl_GetStringFromObj( + mePtr->selectImagePtr, NULL); + image = Tk_GetImage(menuPtr->interp, menuPtr->tkwin, selectImageString, TkMenuSelectImageProc, (ClientData) mePtr); if (image == NULL) { return TCL_ERROR; @@ -1602,7 +1764,71 @@ ConfigureMenuEntry(mePtr, argc, argv, flags) } mePtr->selectImage = image; - TkEventuallyRecomputeMenu(menuPtr); + if ((mePtr->type == CHECK_BUTTON_ENTRY) + || (mePtr->type == RADIO_BUTTON_ENTRY)) { + Tcl_Obj *valuePtr; + char *name; + + if (mePtr->namePtr == NULL) { + if (mePtr->labelPtr == NULL) { + mePtr->namePtr = NULL; + } else { + mePtr->namePtr = Tcl_DuplicateObj(mePtr->labelPtr); + Tcl_IncrRefCount(mePtr->namePtr); + } + } + if (mePtr->onValuePtr == NULL) { + if (mePtr->labelPtr == NULL) { + mePtr->onValuePtr = NULL; + } else { + mePtr->onValuePtr = Tcl_DuplicateObj(mePtr->labelPtr); + Tcl_IncrRefCount(mePtr->onValuePtr); + } + } + + /* + * Select the entry if the associated variable has the + * appropriate value, initialize the variable if it doesn't + * exist, then set a trace on the variable to monitor future + * changes to its value. + */ + + if (mePtr->namePtr != NULL) { + char *name = Tcl_GetStringFromObj(mePtr->namePtr, NULL); + valuePtr = Tcl_GetObjVar2(menuPtr->interp, name, NULL, + TCL_GLOBAL_ONLY); + } else { + valuePtr = NULL; + } + mePtr->entryFlags &= ~ENTRY_SELECTED; + if (valuePtr != NULL) { + if (mePtr->onValuePtr != NULL) { + char *value = Tcl_GetStringFromObj(valuePtr, NULL); + char *onValue = Tcl_GetStringFromObj(mePtr->onValuePtr, + NULL); + + + if (strcmp(value, onValue) == 0) { + mePtr->entryFlags |= ENTRY_SELECTED; + } + } + } else { + if (mePtr->namePtr != NULL) { + char *name = Tcl_GetStringFromObj(mePtr->namePtr, NULL); + Tcl_SetObjVar2(menuPtr->interp, name, NULL, + (mePtr->type == CHECK_BUTTON_ENTRY) + ? mePtr->offValuePtr : + Tcl_NewStringObj("", 0), + TCL_GLOBAL_ONLY); + } + } + if (mePtr->namePtr != NULL) { + name = Tcl_GetStringFromObj(mePtr->namePtr, NULL); + Tcl_TraceVar(menuPtr->interp, name, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + MenuVarProc, (ClientData) mePtr); + } + } return TCL_OK; } @@ -1610,13 +1836,78 @@ ConfigureMenuEntry(mePtr, argc, argv, flags) /* *---------------------------------------------------------------------- * + * ConfigureMenuEntry -- + * + * This procedure is called to process an argv/argc list in order + * to configure (or reconfigure) one entry in a menu. + * + * Results: + * The return value is a standard Tcl result. If TCL_ERROR is + * returned, then the interp's result contains an error message. + * + * Side effects: + * Configuration information such as label and accelerator get + * set for mePtr; old resources get freed, if there were any. + * + *---------------------------------------------------------------------- + */ + +static int +ConfigureMenuEntry(mePtr, objc, objv) + register TkMenuEntry *mePtr; /* Information about menu entry; may + * or may not already have values for + * some fields. */ + int objc; /* Number of valid entries in argv. */ + Tcl_Obj *CONST objv[]; /* Arguments. */ +{ + TkMenu *menuPtr = mePtr->menuPtr; + Tk_SavedOptions errorStruct; + int result; + + /* + * If this entry is a check button or radio button, then remove + * its old trace procedure. + */ + + if ((mePtr->namePtr != NULL) + && ((mePtr->type == CHECK_BUTTON_ENTRY) + || (mePtr->type == RADIO_BUTTON_ENTRY))) { + char *name = Tcl_GetStringFromObj(mePtr->namePtr, NULL); + Tcl_UntraceVar(menuPtr->interp, name, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + MenuVarProc, (ClientData) mePtr); + } + + result = TCL_OK; + if (menuPtr->tkwin != NULL) { + if (Tk_SetOptions(menuPtr->interp, (char *) mePtr, + mePtr->optionTable, objc, objv, menuPtr->tkwin, + &errorStruct, (int *) NULL) != TCL_OK) { + return TCL_ERROR; + } + result = PostProcessEntry(mePtr); + if (result != TCL_OK) { + Tk_RestoreSavedOptions(&errorStruct); + PostProcessEntry(mePtr); + } + Tk_FreeSavedOptions(&errorStruct); + } + + TkEventuallyRecomputeMenu(menuPtr); + + return result; +} + +/* + *---------------------------------------------------------------------- + * * ConfigureMenuCloneEntries -- * * Calls ConfigureMenuEntry for each menu in the clone chain. * * Results: * The return value is a standard Tcl result. If TCL_ERROR is - * returned, then interp->result contains an error message. + * returned, then the interp's result contains an error message. * * Side effects: * Configuration information such as label and accelerator get @@ -1626,22 +1917,21 @@ ConfigureMenuEntry(mePtr, argc, argv, flags) */ static int -ConfigureMenuCloneEntries(interp, menuPtr, index, argc, argv, flags) +ConfigureMenuCloneEntries(interp, menuPtr, index, objc, objv) Tcl_Interp *interp; /* Used for error reporting. */ TkMenu *menuPtr; /* Information about whole menu. */ int index; /* Index of mePtr within menuPtr's * entries. */ - int argc; /* Number of valid entries in argv. */ - char **argv; /* Arguments. */ - int flags; /* Additional flags to pass to - * Tk_ConfigureWidget. */ + int objc; /* Number of valid entries in argv. */ + Tcl_Obj *CONST objv[]; /* Arguments. */ { TkMenuEntry *mePtr; TkMenu *menuListPtr; - char *oldCascadeName = NULL, *newMenuName = NULL; - int cascadeEntryChanged; + int cascadeEntryChanged = 0; TkMenuReferences *oldCascadeMenuRefPtr, *cascadeMenuRefPtr = NULL; - + Tcl_Obj *oldCascadePtr = NULL; + char *newCascadeName; + /* * Cascades are kind of tricky here. This is special case #3 in the comment * at the top of this file. Basically, if a menu is the master menu of a @@ -1653,21 +1943,47 @@ ConfigureMenuCloneEntries(interp, menuPtr, index, argc, argv, flags) mePtr = menuPtr->masterMenuPtr->entries[index]; if (mePtr->type == CASCADE_ENTRY) { - oldCascadeName = mePtr->name; + oldCascadePtr = mePtr->namePtr; + if (oldCascadePtr != NULL) { + Tcl_IncrRefCount(oldCascadePtr); + } } - if (ConfigureMenuEntry(mePtr, argc, argv, flags) != TCL_OK) { + if (ConfigureMenuEntry(mePtr, objc, objv) != TCL_OK) { return TCL_ERROR; } - cascadeEntryChanged = (mePtr->type == CASCADE_ENTRY) - && (oldCascadeName != mePtr->name); + if (mePtr->type == CASCADE_ENTRY) { + char *oldCascadeName; + + if (mePtr->namePtr != NULL) { + newCascadeName = Tcl_GetStringFromObj(mePtr->namePtr, NULL); + } else { + newCascadeName = NULL; + } + + if ((oldCascadePtr == NULL) && (mePtr->namePtr == NULL)) { + cascadeEntryChanged = 0; + } else if (((oldCascadePtr == NULL) && (mePtr->namePtr != NULL)) + || ((oldCascadePtr != NULL) + && (mePtr->namePtr == NULL))) { + cascadeEntryChanged = 1; + } else { + oldCascadeName = Tcl_GetStringFromObj(oldCascadePtr, + NULL); + cascadeEntryChanged = (strcmp(oldCascadeName, newCascadeName) + == 0); + } + if (oldCascadePtr != NULL) { + Tcl_DecrRefCount(oldCascadePtr); + } + } if (cascadeEntryChanged) { - newMenuName = mePtr->name; - if (newMenuName != NULL) { + if (mePtr->namePtr != NULL) { + newCascadeName = Tcl_GetStringFromObj(mePtr->namePtr, NULL); cascadeMenuRefPtr = TkFindMenuReferences(menuPtr->interp, - mePtr->name); + newCascadeName); } } @@ -1677,9 +1993,9 @@ ConfigureMenuCloneEntries(interp, menuPtr, index, argc, argv, flags) mePtr = menuListPtr->entries[index]; - if (cascadeEntryChanged && (mePtr->name != NULL)) { - oldCascadeMenuRefPtr = TkFindMenuReferences(menuPtr->interp, - mePtr->name); + if (cascadeEntryChanged && (mePtr->namePtr != NULL)) { + oldCascadeMenuRefPtr = TkFindMenuReferencesObj(menuPtr->interp, + mePtr->namePtr); if ((oldCascadeMenuRefPtr != NULL) && (oldCascadeMenuRefPtr->menuPtr != NULL)) { @@ -1687,25 +2003,36 @@ ConfigureMenuCloneEntries(interp, menuPtr, index, argc, argv, flags) } } - if (ConfigureMenuEntry(mePtr, argc, argv, flags) != TCL_OK) { + if (ConfigureMenuEntry(mePtr, objc, objv) != TCL_OK) { return TCL_ERROR; } - if (cascadeEntryChanged && (newMenuName != NULL)) { + if (cascadeEntryChanged && (mePtr->namePtr != NULL)) { if (cascadeMenuRefPtr->menuPtr != NULL) { - char *newArgV[2]; - char *newCloneName; - - newCloneName = TkNewMenuName(menuPtr->interp, - Tk_PathName(menuListPtr->tkwin), + Tcl_Obj *newObjv[2]; + Tcl_Obj *newCloneNamePtr; + Tcl_Obj *pathNamePtr = Tcl_NewStringObj( + Tk_PathName(menuListPtr->tkwin), -1); + Tcl_Obj *normalPtr = Tcl_NewStringObj("normal", -1); + Tcl_Obj *menuObjPtr = Tcl_NewStringObj("menu", -1); + + Tcl_IncrRefCount(pathNamePtr); + newCloneNamePtr = TkNewMenuName(menuPtr->interp, + pathNamePtr, cascadeMenuRefPtr->menuPtr); - CloneMenu(cascadeMenuRefPtr->menuPtr, newCloneName, - "normal"); - - newArgV[0] = "-menu"; - newArgV[1] = newCloneName; - ConfigureMenuEntry(mePtr, 2, newArgV, flags); - ckfree(newCloneName); + Tcl_IncrRefCount(newCloneNamePtr); + Tcl_IncrRefCount(normalPtr); + CloneMenu(cascadeMenuRefPtr->menuPtr, newCloneNamePtr, + normalPtr); + + newObjv[0] = menuObjPtr; + newObjv[1] = newCloneNamePtr; + Tcl_IncrRefCount(menuObjPtr); + ConfigureMenuEntry(mePtr, 2, newObjv); + Tcl_DecrRefCount(newCloneNamePtr); + Tcl_DecrRefCount(pathNamePtr); + Tcl_DecrRefCount(normalPtr); + Tcl_DecrRefCount(menuObjPtr); } } } @@ -1724,7 +2051,7 @@ ConfigureMenuCloneEntries(interp, menuPtr, index, argc, argv, flags) * A standard Tcl result. If all went well, then *indexPtr is * filled in with the entry index corresponding to string * (ranges from -1 to the number of entries in the menu minus - * one). Otherwise an error message is left in interp->result. + * one). Otherwise an error message is left in the interp's result. * * Side effects: * None. @@ -1733,38 +2060,39 @@ ConfigureMenuCloneEntries(interp, menuPtr, index, argc, argv, flags) */ int -TkGetMenuIndex(interp, menuPtr, string, lastOK, indexPtr) +TkGetMenuIndex(interp, menuPtr, objPtr, lastOK, indexPtr) Tcl_Interp *interp; /* For error messages. */ TkMenu *menuPtr; /* Menu for which the index is being * specified. */ - char *string; /* Specification of an entry in menu. See + Tcl_Obj *objPtr; /* Specification of an entry in menu. See * manual entry for valid .*/ int lastOK; /* Non-zero means its OK to return index * just *after* last entry. */ - int *indexPtr; /* Where to store converted relief. */ + int *indexPtr; /* Where to store converted index. */ { int i; + char *string = Tcl_GetStringFromObj(objPtr, NULL); if ((string[0] == 'a') && (strcmp(string, "active") == 0)) { *indexPtr = menuPtr->active; - return TCL_OK; + goto success; } if (((string[0] == 'l') && (strcmp(string, "last") == 0)) || ((string[0] == 'e') && (strcmp(string, "end") == 0))) { *indexPtr = menuPtr->numEntries - ((lastOK) ? 0 : 1); - return TCL_OK; + goto success; } if ((string[0] == 'n') && (strcmp(string, "none") == 0)) { *indexPtr = -1; - return TCL_OK; + goto success; } if (string[0] == '@') { if (GetIndexFromCoords(interp, menuPtr, string, indexPtr) == TCL_OK) { - return TCL_OK; + goto success; } } @@ -1780,25 +2108,29 @@ TkGetMenuIndex(interp, menuPtr, string, lastOK, indexPtr) i = -1; } *indexPtr = i; - return TCL_OK; + goto success; } Tcl_SetResult(interp, (char *) NULL, TCL_STATIC); } for (i = 0; i < menuPtr->numEntries; i++) { - char *label; - - label = menuPtr->entries[i]->label; + Tcl_Obj *labelPtr = menuPtr->entries[i]->labelPtr; + char *label = (labelPtr == NULL) ? NULL + : Tcl_GetStringFromObj(labelPtr, NULL); + if ((label != NULL) - && (Tcl_StringMatch(menuPtr->entries[i]->label, string))) { + && (Tcl_StringMatch(label, string))) { *indexPtr = i; - return TCL_OK; + goto success; } } Tcl_AppendResult(interp, "bad menu entry index \"", string, "\"", (char *) NULL); return TCL_ERROR; + +success: + return TCL_OK; } /* @@ -1834,7 +2166,6 @@ MenuCmdDeletedProc(clientData) */ if (tkwin != NULL) { - menuPtr->tkwin = NULL; Tk_DestroyWindow(tkwin); } } @@ -1890,41 +2221,53 @@ MenuNewEntry(menuPtr, index, type) mePtr = (TkMenuEntry *) ckalloc(sizeof(TkMenuEntry)); menuPtr->entries[index] = mePtr; mePtr->type = type; + mePtr->optionTable = menuPtr->optionTablesPtr->entryOptionTables[type]; mePtr->menuPtr = menuPtr; - mePtr->label = NULL; + mePtr->labelPtr = NULL; mePtr->labelLength = 0; mePtr->underline = -1; - mePtr->bitmap = None; - mePtr->imageString = NULL; + mePtr->bitmapPtr = NULL; + mePtr->imagePtr = NULL; mePtr->image = NULL; - mePtr->selectImageString = NULL; + mePtr->selectImagePtr = NULL; mePtr->selectImage = NULL; - mePtr->accel = NULL; + mePtr->accelPtr = NULL; mePtr->accelLength = 0; - mePtr->state = tkNormalUid; - mePtr->border = NULL; - mePtr->fg = NULL; - mePtr->activeBorder = NULL; - mePtr->activeFg = NULL; - mePtr->tkfont = NULL; - mePtr->indicatorOn = 1; - mePtr->indicatorFg = NULL; - mePtr->columnBreak = 0; - mePtr->hideMargin = 0; - mePtr->command = NULL; - mePtr->name = NULL; + mePtr->statePtr = Tcl_NewStringObj("disabled", -1); + Tcl_IncrRefCount(mePtr->statePtr); + mePtr->borderPtr = NULL; + mePtr->fgPtr = NULL; + mePtr->activeBorderPtr = NULL; + mePtr->activeFgPtr = NULL; + mePtr->fontPtr = NULL; + mePtr->indicatorOnPtr = Tcl_NewBooleanObj(1); + Tcl_IncrRefCount(mePtr->indicatorOnPtr); + mePtr->indicatorFgPtr = NULL; + mePtr->columnBreakPtr = Tcl_NewBooleanObj(0); + Tcl_IncrRefCount(mePtr->columnBreakPtr); + mePtr->hideMarginPtr = Tcl_NewBooleanObj(0); + Tcl_IncrRefCount(mePtr->hideMarginPtr); + mePtr->commandPtr = NULL; + mePtr->namePtr = NULL; mePtr->childMenuRefPtr = NULL; - mePtr->onValue = NULL; - mePtr->offValue = NULL; + mePtr->onValuePtr = NULL; + mePtr->offValuePtr = NULL; mePtr->entryFlags = 0; mePtr->index = index; mePtr->nextCascadePtr = NULL; + if (Tk_InitOptions(menuPtr->interp, (char *) mePtr, + mePtr->optionTable, menuPtr->tkwin) != TCL_OK) { + ckfree((char *) mePtr); + return NULL; + } TkMenuInitializeEntryDrawingFields(mePtr); if (TkpMenuNewEntry(mePtr) != TCL_OK) { + Tk_FreeConfigOptions((char *) mePtr, mePtr->optionTable, + menuPtr->tkwin); ckfree((char *) mePtr); return NULL; } - + return mePtr; } @@ -1946,25 +2289,25 @@ MenuNewEntry(menuPtr, index, type) */ static int -MenuAddOrInsert(interp, menuPtr, indexString, argc, argv) +MenuAddOrInsert(interp, menuPtr, indexPtr, objc, objv) Tcl_Interp *interp; /* Used for error reporting. */ TkMenu *menuPtr; /* Widget in which to create new * entry. */ - char *indexString; /* String describing index at which + Tcl_Obj *indexPtr; /* Object describing index at which * to insert. NULL means insert at * end. */ - int argc; /* Number of elements in argv. */ - char **argv; /* Arguments to command: first arg + int objc; /* Number of elements in objv. */ + Tcl_Obj *CONST objv[]; /* Arguments to command: first arg * is type of entry, others are * config options. */ { - int c, type, index; - size_t length; + int type, index; TkMenuEntry *mePtr; TkMenu *menuListPtr; + int tearoff; - if (indexString != NULL) { - if (TkGetMenuIndex(interp, menuPtr, indexString, 1, &index) + if (indexPtr != NULL) { + if (TkGetMenuIndex(interp, menuPtr, indexPtr, 1, &index) != TCL_OK) { return TCL_ERROR; } @@ -1972,11 +2315,13 @@ MenuAddOrInsert(interp, menuPtr, indexString, argc, argv) index = menuPtr->numEntries; } if (index < 0) { + char *indexString = Tcl_GetStringFromObj(indexPtr, NULL); Tcl_AppendResult(interp, "bad index \"", indexString, "\"", (char *) NULL); return TCL_ERROR; } - if (menuPtr->tearOff && (index == 0)) { + Tcl_GetBooleanFromObj(NULL, menuPtr->tearoffPtr, &tearoff); + if (tearoff && (index == 0)) { index = 1; } @@ -1984,30 +2329,11 @@ MenuAddOrInsert(interp, menuPtr, indexString, argc, argv) * Figure out the type of the new entry. */ - c = argv[0][0]; - length = strlen(argv[0]); - if ((c == 'c') && (strncmp(argv[0], "cascade", length) == 0) - && (length >= 2)) { - type = CASCADE_ENTRY; - } else if ((c == 'c') && (strncmp(argv[0], "checkbutton", length) == 0) - && (length >= 2)) { - type = CHECK_BUTTON_ENTRY; - } else if ((c == 'c') && (strncmp(argv[0], "command", length) == 0) - && (length >= 2)) { - type = COMMAND_ENTRY; - } else if ((c == 'r') - && (strncmp(argv[0], "radiobutton", length) == 0)) { - type = RADIO_BUTTON_ENTRY; - } else if ((c == 's') - && (strncmp(argv[0], "separator", length) == 0)) { - type = SEPARATOR_ENTRY; - } else { - Tcl_AppendResult(interp, "bad menu entry type \"", - argv[0], "\": must be cascade, checkbutton, ", - "command, radiobutton, or separator", (char *) NULL); + if (Tcl_GetIndexFromObj(interp, objv[0], menuEntryTypeStrings, + "menu entry type", 0, &type) != TCL_OK) { return TCL_ERROR; } - + /* * Now we have to add an entry for every instance related to this menu. */ @@ -2019,9 +2345,9 @@ MenuAddOrInsert(interp, menuPtr, indexString, argc, argv) if (mePtr == NULL) { return TCL_ERROR; } - if (ConfigureMenuEntry(mePtr, argc-1, argv+1, 0) != TCL_OK) { + if (ConfigureMenuEntry(mePtr, objc - 1, objv + 1) != TCL_OK) { TkMenu *errorMenuPtr; - int i; + int i; for (errorMenuPtr = menuPtr->masterMenuPtr; errorMenuPtr != NULL; @@ -2054,28 +2380,40 @@ MenuAddOrInsert(interp, menuPtr, indexString, argc, argv) */ if ((menuPtr != menuListPtr) && (type == CASCADE_ENTRY)) { - if ((mePtr->name != NULL) && (mePtr->childMenuRefPtr != NULL) + if ((mePtr->namePtr != NULL) + && (mePtr->childMenuRefPtr != NULL) && (mePtr->childMenuRefPtr->menuPtr != NULL)) { TkMenu *cascadeMenuPtr = mePtr->childMenuRefPtr->menuPtr->masterMenuPtr; - char *newCascadeName; - char *newArgv[2]; + Tcl_Obj *newCascadePtr; + Tcl_Obj *menuNamePtr = Tcl_NewStringObj("-menu", -1); + Tcl_Obj *windowNamePtr = + Tcl_NewStringObj(Tk_PathName(menuListPtr->tkwin), -1); + Tcl_Obj *normalPtr = Tcl_NewStringObj("normal", -1); + Tcl_Obj *newObjv[2]; TkMenuReferences *menuRefPtr; - - newCascadeName = TkNewMenuName(menuListPtr->interp, - Tk_PathName(menuListPtr->tkwin), - cascadeMenuPtr); - CloneMenu(cascadeMenuPtr, newCascadeName, "normal"); + + Tcl_IncrRefCount(windowNamePtr); + newCascadePtr = TkNewMenuName(menuListPtr->interp, + windowNamePtr, cascadeMenuPtr); + Tcl_IncrRefCount(newCascadePtr); + Tcl_IncrRefCount(normalPtr); + CloneMenu(cascadeMenuPtr, newCascadePtr, normalPtr); - menuRefPtr = TkFindMenuReferences(menuListPtr->interp, - newCascadeName); + menuRefPtr = TkFindMenuReferencesObj(menuListPtr->interp, + newCascadePtr); if (menuRefPtr == NULL) { panic("CloneMenu failed inside of MenuAddOrInsert."); } - newArgv[0] = "-menu"; - newArgv[1] = newCascadeName; - ConfigureMenuEntry(mePtr, 2, newArgv, 0); - ckfree(newCascadeName); + newObjv[0] = menuNamePtr; + newObjv[1] = newCascadePtr; + Tcl_IncrRefCount(menuNamePtr); + Tcl_IncrRefCount(newCascadePtr); + ConfigureMenuEntry(mePtr, 2, newObjv); + Tcl_DecrRefCount(newCascadePtr); + Tcl_DecrRefCount(menuNamePtr); + Tcl_DecrRefCount(windowNamePtr); + Tcl_DecrRefCount(normalPtr); } } } @@ -2112,6 +2450,8 @@ MenuVarProc(clientData, interp, name1, name2, flags) TkMenuEntry *mePtr = (TkMenuEntry *) clientData; TkMenu *menuPtr; char *value; + char *name = Tcl_GetStringFromObj(mePtr->namePtr, NULL); + char *onValue; menuPtr = mePtr->menuPtr; @@ -2123,7 +2463,7 @@ MenuVarProc(clientData, interp, name1, name2, flags) if (flags & TCL_TRACE_UNSETS) { mePtr->entryFlags &= ~ENTRY_SELECTED; if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) { - Tcl_TraceVar(interp, mePtr->name, + Tcl_TraceVar(interp, name, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, MenuVarProc, clientData); } @@ -2137,17 +2477,22 @@ MenuVarProc(clientData, interp, name1, name2, flags) * the menu entry. */ - value = Tcl_GetVar(interp, mePtr->name, TCL_GLOBAL_ONLY); + value = Tcl_GetVar(interp, name, TCL_GLOBAL_ONLY); if (value == NULL) { value = ""; } - if (strcmp(value, mePtr->onValue) == 0) { - if (mePtr->entryFlags & ENTRY_SELECTED) { + if (mePtr->onValuePtr != NULL) { + onValue = Tcl_GetStringFromObj(mePtr->onValuePtr, NULL); + if (strcmp(value, onValue) == 0) { + if (mePtr->entryFlags & ENTRY_SELECTED) { + return (char *) NULL; + } + mePtr->entryFlags |= ENTRY_SELECTED; + } else if (mePtr->entryFlags & ENTRY_SELECTED) { + mePtr->entryFlags &= ~ENTRY_SELECTED; + } else { return (char *) NULL; } - mePtr->entryFlags |= ENTRY_SELECTED; - } else if (mePtr->entryFlags & ENTRY_SELECTED) { - mePtr->entryFlags &= ~ENTRY_SELECTED; } else { return (char *) NULL; } @@ -2184,6 +2529,7 @@ TkActivateMenuEntry(menuPtr, index) { register TkMenuEntry *mePtr; int result = TCL_OK; + int state; if (menuPtr->active >= 0) { mePtr = menuPtr->entries[menuPtr->active]; @@ -2193,15 +2539,21 @@ TkActivateMenuEntry(menuPtr, index) * might already have been changed to disabled). */ - if (mePtr->state == tkActiveUid) { - mePtr->state = tkNormalUid; + Tcl_GetIndexFromObj(NULL, mePtr->statePtr, tkMenuStateStrings, + NULL, 0, &state); + if (state == ENTRY_ACTIVE) { + Tcl_DecrRefCount(mePtr->statePtr); + mePtr->statePtr = Tcl_NewStringObj("normal", -1); + Tcl_IncrRefCount(mePtr->statePtr); } TkEventuallyRedrawMenu(menuPtr, menuPtr->entries[menuPtr->active]); } menuPtr->active = index; if (index >= 0) { mePtr = menuPtr->entries[index]; - mePtr->state = tkActiveUid; + Tcl_DecrRefCount(mePtr->statePtr); + mePtr->statePtr = Tcl_NewStringObj("active", -1); + Tcl_IncrRefCount(mePtr->statePtr); TkEventuallyRedrawMenu(menuPtr, mePtr); } return result; @@ -2237,9 +2589,13 @@ TkPostCommand(menuPtr) * the menu's geometry if needed. */ - if (menuPtr->postCommand != NULL) { - result = TkCopyAndGlobalEval(menuPtr->interp, - menuPtr->postCommand); + if (menuPtr->postCommandPtr != NULL) { + Tcl_Obj *postCommandPtr = menuPtr->postCommandPtr; + + Tcl_IncrRefCount(postCommandPtr); + result = Tcl_EvalObj(menuPtr->interp, postCommandPtr, + TCL_EVAL_GLOBAL); + Tcl_DecrRefCount(postCommandPtr); if (result != TCL_OK) { return result; } @@ -2269,64 +2625,54 @@ TkPostCommand(menuPtr) */ static int -CloneMenu(menuPtr, newMenuName, newMenuTypeString) +CloneMenu(menuPtr, newMenuNamePtr, newMenuTypePtr) TkMenu *menuPtr; /* The menu we are going to clone */ - char *newMenuName; /* The name to give the new menu */ - char *newMenuTypeString; /* What kind of menu is this, a normal menu + Tcl_Obj *newMenuNamePtr; /* The name to give the new menu */ + Tcl_Obj *newMenuTypePtr; /* What kind of menu is this, a normal menu * a menubar, or a tearoff? */ { int returnResult; - int menuType; - size_t length; + int menuType, i; TkMenuReferences *menuRefPtr; - Tcl_Obj *commandObjPtr; + Tcl_Obj *menuDupCommandArray[4]; - if (newMenuTypeString == NULL) { + if (newMenuTypePtr == NULL) { menuType = MASTER_MENU; } else { - length = strlen(newMenuTypeString); - if (strncmp(newMenuTypeString, "normal", length) == 0) { - menuType = MASTER_MENU; - } else if (strncmp(newMenuTypeString, "tearoff", length) == 0) { - menuType = TEAROFF_MENU; - } else if (strncmp(newMenuTypeString, "menubar", length) == 0) { - menuType = MENUBAR; - } else { - Tcl_AppendResult(menuPtr->interp, - "bad menu type - must be normal, tearoff, or menubar", - (char *) NULL); - return TCL_ERROR; - } + if (Tcl_GetIndexFromObj(menuPtr->interp, newMenuTypePtr, + menuTypeStrings, "menu type", 0, &menuType) != TCL_OK) { + return TCL_ERROR; + } } - commandObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - Tcl_ListObjAppendElement(menuPtr->interp, commandObjPtr, - Tcl_NewStringObj("tkMenuDup", -1)); - Tcl_ListObjAppendElement(menuPtr->interp, commandObjPtr, - Tcl_NewStringObj(Tk_PathName(menuPtr->tkwin), -1)); - Tcl_ListObjAppendElement(menuPtr->interp, commandObjPtr, - Tcl_NewStringObj(newMenuName, -1)); - if ((newMenuTypeString == NULL) || (newMenuTypeString[0] == '\0')) { - Tcl_ListObjAppendElement(menuPtr->interp, commandObjPtr, - Tcl_NewStringObj("normal", -1)); + menuDupCommandArray[0] = Tcl_NewStringObj("tkMenuDup", -1); + menuDupCommandArray[1] = Tcl_NewStringObj(Tk_PathName(menuPtr->tkwin), -1); + menuDupCommandArray[2] = newMenuNamePtr; + if (newMenuTypePtr == NULL) { + menuDupCommandArray[3] = Tcl_NewStringObj("normal", -1); } else { - Tcl_ListObjAppendElement(menuPtr->interp, commandObjPtr, - Tcl_NewStringObj(newMenuTypeString, -1)); + menuDupCommandArray[3] = newMenuTypePtr; + } + for (i = 0; i < 4; i++) { + Tcl_IncrRefCount(menuDupCommandArray[i]); } - Tcl_IncrRefCount(commandObjPtr); Tcl_Preserve((ClientData) menuPtr); - returnResult = Tcl_EvalObj(menuPtr->interp, commandObjPtr); - Tcl_DecrRefCount(commandObjPtr); + returnResult = Tcl_EvalObjv(menuPtr->interp, 4, menuDupCommandArray, "", + -1, 0); + for (i = 0; i < 4; i++) { + Tcl_DecrRefCount(menuDupCommandArray[i]); + } /* * Make sure the tcl command actually created the clone. */ if ((returnResult == TCL_OK) && - ((menuRefPtr = TkFindMenuReferences(menuPtr->interp, newMenuName)) - != (TkMenuReferences *) NULL) + ((menuRefPtr = TkFindMenuReferencesObj(menuPtr->interp, + newMenuNamePtr)) != (TkMenuReferences *) NULL) && (menuPtr->numEntries == menuRefPtr->menuPtr->numEntries)) { TkMenu *newMenuPtr = menuRefPtr->menuPtr; + Tcl_Obj *newObjv[3]; char *newArgv[3]; int i, numElements; @@ -2359,8 +2705,8 @@ CloneMenu(menuPtr, newMenuName, newMenuTypeString) if (Tk_BindtagsCmd((ClientData)newMenuPtr->tkwin, newMenuPtr->interp, 2, newArgv) == TCL_OK) { char *windowName; - Tcl_Obj *bindingsPtr = - Tcl_NewStringObj(newMenuPtr->interp->result, -1); + Tcl_Obj *bindingsPtr = + Tcl_DuplicateObj(Tcl_GetObjResult(newMenuPtr->interp)); Tcl_Obj *elementPtr; Tcl_ListObjLength(newMenuPtr->interp, bindingsPtr, &numElements); @@ -2372,11 +2718,12 @@ CloneMenu(menuPtr, newMenuName, newMenuTypeString) == 0) { Tcl_Obj *newElementPtr = Tcl_NewStringObj( Tk_PathName(newMenuPtr->masterMenuPtr->tkwin), -1); + Tcl_IncrRefCount(newElementPtr); Tcl_ListObjReplace(menuPtr->interp, bindingsPtr, i + 1, 0, 1, &newElementPtr); newArgv[2] = Tcl_GetStringFromObj(bindingsPtr, NULL); - Tk_BindtagsCmd((ClientData)newMenuPtr->tkwin, - menuPtr->interp, 3, newArgv); + Tk_BindtagsCmd((ClientData)newMenuPtr->tkwin, + menuPtr->interp, 3, newArgv); break; } } @@ -2389,30 +2736,35 @@ CloneMenu(menuPtr, newMenuName, newMenuTypeString) */ for (i = 0; i < menuPtr->numEntries; i++) { - char *newCascadeName; TkMenuReferences *cascadeRefPtr; TkMenu *oldCascadePtr; if ((menuPtr->entries[i]->type == CASCADE_ENTRY) - && (menuPtr->entries[i]->name != NULL)) { + && (menuPtr->entries[i]->namePtr != NULL)) { cascadeRefPtr = - TkFindMenuReferences(menuPtr->interp, - menuPtr->entries[i]->name); + TkFindMenuReferencesObj(menuPtr->interp, + menuPtr->entries[i]->namePtr); if ((cascadeRefPtr != NULL) && (cascadeRefPtr->menuPtr)) { - char *nameString; + Tcl_Obj *windowNamePtr = + Tcl_NewStringObj(Tk_PathName(newMenuPtr->tkwin), + -1); + Tcl_Obj *newCascadePtr; oldCascadePtr = cascadeRefPtr->menuPtr; - nameString = Tk_PathName(newMenuPtr->tkwin); - newCascadeName = TkNewMenuName(menuPtr->interp, - nameString, oldCascadePtr); - CloneMenu(oldCascadePtr, newCascadeName, NULL); - - newArgv[0] = "-menu"; - newArgv[1] = newCascadeName; - ConfigureMenuEntry(newMenuPtr->entries[i], 2, newArgv, - TK_CONFIG_ARGV_ONLY); - ckfree(newCascadeName); + Tcl_IncrRefCount(windowNamePtr); + newCascadePtr = TkNewMenuName(menuPtr->interp, + windowNamePtr, oldCascadePtr); + Tcl_IncrRefCount(newCascadePtr); + CloneMenu(oldCascadePtr, newCascadePtr, NULL); + + newObjv[0] = Tcl_NewStringObj("-menu", -1); + newObjv[1] = newCascadePtr; + Tcl_IncrRefCount(newObjv[0]); + ConfigureMenuEntry(newMenuPtr->entries[i], 2, newObjv); + Tcl_DecrRefCount(newObjv[0]); + Tcl_DecrRefCount(newCascadePtr); + Tcl_DecrRefCount(windowNamePtr); } } } @@ -2442,22 +2794,24 @@ CloneMenu(menuPtr, newMenuName, newMenuTypeString) */ static int -MenuDoYPosition(interp, menuPtr, arg) +MenuDoYPosition(interp, menuPtr, objPtr) Tcl_Interp *interp; TkMenu *menuPtr; - char *arg; + Tcl_Obj *objPtr; { int index; TkRecomputeMenu(menuPtr); - if (TkGetMenuIndex(interp, menuPtr, arg, 0, &index) != TCL_OK) { + if (TkGetMenuIndex(interp, menuPtr, objPtr, 0, &index) != TCL_OK) { goto error; } + Tcl_ResetResult(interp); if (index < 0) { - interp->result = "0"; + Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); } else { - sprintf(interp->result, "%d", menuPtr->entries[index]->y); + Tcl_SetObjResult(interp, Tcl_NewIntObj(menuPtr->entries[index]->y)); } + return TCL_OK; error: @@ -2507,7 +2861,8 @@ GetIndexFromCoords(interp, menuPtr, string, indexPtr) goto error; } } else { - x = menuPtr->borderWidth; + Tk_GetPixelsFromObj(interp, menuPtr->tkwin, + menuPtr->borderWidthPtr, &x); } for (i = 0; i < menuPtr->numEntries; i++) { @@ -2583,65 +2938,66 @@ RecursivelyDeleteMenu(menuPtr) *---------------------------------------------------------------------- */ -char * -TkNewMenuName(interp, parentName, menuPtr) +Tcl_Obj * +TkNewMenuName(interp, parentPtr, menuPtr) Tcl_Interp *interp; /* The interp the new name has to live in.*/ - char *parentName; /* The prefix path of the new name. */ + Tcl_Obj *parentPtr; /* The prefix path of the new name. */ TkMenu *menuPtr; /* The menu we are cloning. */ { - Tcl_DString resultDString; - Tcl_DString childDString; + Tcl_Obj *resultPtr = NULL; /* Initialization needed only to prevent + * compiler warning. */ + Tcl_Obj *childPtr; char *destString; - int offset, i; - int doDot = parentName[strlen(parentName) - 1] != '.'; + int i; + int doDot; Tcl_CmdInfo cmdInfo; - char *returnString; Tcl_HashTable *nameTablePtr = NULL; TkWindow *winPtr = (TkWindow *) menuPtr->tkwin; + char *parentName = Tcl_GetStringFromObj(parentPtr, NULL); + if (winPtr->mainPtr != NULL) { nameTablePtr = &(winPtr->mainPtr->nameTable); } - - Tcl_DStringInit(&childDString); - Tcl_DStringAppend(&childDString, Tk_PathName(menuPtr->tkwin), -1); - for (destString = Tcl_DStringValue(&childDString); + + doDot = parentName[strlen(parentName) - 1] != '.'; + + childPtr = Tcl_NewStringObj(Tk_PathName(menuPtr->tkwin), -1); + for (destString = Tcl_GetStringFromObj(childPtr, NULL); *destString != '\0'; destString++) { if (*destString == '.') { *destString = '#'; } } - offset = 0; - for (i = 0; ; i++) { if (i == 0) { - Tcl_DStringInit(&resultDString); - Tcl_DStringAppend(&resultDString, parentName, -1); + resultPtr = Tcl_DuplicateObj(parentPtr); if (doDot) { - Tcl_DStringAppend(&resultDString, ".", -1); + Tcl_AppendToObj(resultPtr, ".", -1); } - Tcl_DStringAppend(&resultDString, - Tcl_DStringValue(&childDString), -1); - destString = Tcl_DStringValue(&resultDString); + Tcl_AppendObjToObj(resultPtr, childPtr); } else { - if (i == 1) { - offset = Tcl_DStringLength(&resultDString); - Tcl_DStringSetLength(&resultDString, offset + 10); - destString = Tcl_DStringValue(&resultDString); - } - sprintf(destString + offset, "%d", i); + Tcl_Obj *intPtr; + + Tcl_DecrRefCount(resultPtr); + resultPtr = Tcl_DuplicateObj(parentPtr); + if (doDot) { + Tcl_AppendToObj(resultPtr, ".", -1); + } + Tcl_AppendObjToObj(resultPtr, childPtr); + intPtr = Tcl_NewIntObj(i); + Tcl_AppendObjToObj(resultPtr, intPtr); + Tcl_DecrRefCount(intPtr); } + destString = Tcl_GetStringFromObj(resultPtr, NULL); if ((Tcl_GetCommandInfo(interp, destString, &cmdInfo) == 0) && ((nameTablePtr == NULL) || (Tcl_FindHashEntry(nameTablePtr, destString) == NULL))) { break; } } - returnString = ckalloc(strlen(destString) + 1); - strcpy(returnString, destString); - Tcl_DStringFree(&resultDString); - Tcl_DStringFree(&childDString); - return returnString; + Tcl_DecrRefCount(childPtr); + return resultPtr; } /* @@ -2756,32 +3112,45 @@ TkSetWindowMenuBar(interp, tkwin, oldMenuName, menuName) menuPtr = menuRefPtr->menuPtr; if (menuPtr != NULL) { - char *cloneMenuName; + Tcl_Obj *cloneMenuPtr; TkMenuReferences *cloneMenuRefPtr; - char *newArgv[4]; + Tcl_Obj *newObjv[4]; + Tcl_Obj *windowNamePtr = Tcl_NewStringObj(Tk_PathName(tkwin), + -1); + Tcl_Obj *menubarPtr = Tcl_NewStringObj("menubar", -1); /* * Clone the menu and all of the cascades underneath it. */ - cloneMenuName = TkNewMenuName(interp, Tk_PathName(tkwin), + Tcl_IncrRefCount(windowNamePtr); + cloneMenuPtr = TkNewMenuName(interp, windowNamePtr, menuPtr); - CloneMenu(menuPtr, cloneMenuName, "menubar"); + Tcl_IncrRefCount(cloneMenuPtr); + Tcl_IncrRefCount(menubarPtr); + CloneMenu(menuPtr, cloneMenuPtr, menubarPtr); - cloneMenuRefPtr = TkFindMenuReferences(interp, cloneMenuName); + cloneMenuRefPtr = TkFindMenuReferencesObj(interp, cloneMenuPtr); if ((cloneMenuRefPtr != NULL) && (cloneMenuRefPtr->menuPtr != NULL)) { + Tcl_Obj *cursorPtr = Tcl_NewStringObj("-cursor", -1); + Tcl_Obj *nullPtr = Tcl_NewStringObj("", -1); cloneMenuRefPtr->menuPtr->parentTopLevelPtr = tkwin; menuBarPtr = cloneMenuRefPtr->menuPtr; - newArgv[0] = "-cursor"; - newArgv[1] = ""; + newObjv[0] = cursorPtr; + newObjv[1] = nullPtr; + Tcl_IncrRefCount(cursorPtr); + Tcl_IncrRefCount(nullPtr); ConfigureMenu(menuPtr->interp, cloneMenuRefPtr->menuPtr, - 2, newArgv, TK_CONFIG_ARGV_ONLY); + 2, newObjv); + Tcl_DecrRefCount(cursorPtr); + Tcl_DecrRefCount(nullPtr); } TkpSetWindowMenuBar(tkwin, menuBarPtr); - - ckfree(cloneMenuName); + Tcl_DecrRefCount(cloneMenuPtr); + Tcl_DecrRefCount(menubarPtr); + Tcl_DecrRefCount(windowNamePtr); } else { TkpSetWindowMenuBar(tkwin, NULL); } @@ -2948,6 +3317,35 @@ TkFindMenuReferences(interp, pathName) /* *---------------------------------------------------------------------- * + * TkFindMenuReferencesObj -- + * + * Given a pathname, gives back a pointer to the TkMenuReferences + * structure. + * + * Results: + * Returns a pointer to a menu reference structure. Should not + * be freed by calller; when a field of the reference is cleared, + * TkFreeMenuReferences should be called. Returns NULL if no reference + * with this pathname exists. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +TkMenuReferences * +TkFindMenuReferencesObj(interp, objPtr) + Tcl_Interp *interp; /* The interp the menu is living in. */ + Tcl_Obj *objPtr; /* The path of the menu widget */ +{ + char *pathName = Tcl_GetStringFromObj(objPtr, NULL); + return TkFindMenuReferences(interp, pathName); +} + +/* + *---------------------------------------------------------------------- + * * TkFreeMenuReferences -- * * This is called after one of the fields in a menu reference diff --git a/generic/tkMenu.h b/generic/tkMenu.h index 6f30d72..0a55913 100644 --- a/generic/tkMenu.h +++ b/generic/tkMenu.h @@ -3,12 +3,12 @@ * * Declarations shared among all of the files that implement menu widgets. * - * Copyright (c) 1996-1997 by Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkMenu.h 1.60 97/06/20 14:43:21 + * SCCS: @(#) tkMenu.h 1.71 98/01/20 16:39:03 */ #ifndef _TKMENU @@ -42,55 +42,59 @@ typedef struct TkMenuEntry { int type; /* Type of menu entry; see below for * valid types. */ struct TkMenu *menuPtr; /* Menu with which this entry is associated. */ - char *label; /* Main text label displayed in entry (NULL - * if no label). Malloc'ed. */ + Tk_OptionTable optionTable; /* Option table for this menu entry. */ + Tcl_Obj *labelPtr; /* Main text label displayed in entry (NULL + * if no label). */ int labelLength; /* Number of non-NULL characters in label. */ - Tk_Uid state; /* State of button for display purposes: + Tcl_Obj *statePtr; /* State of button for display purposes: * normal, active, or disabled. */ - int underline; /* Index of character to underline. */ - Pixmap bitmap; /* Bitmap to display in menu entry, or None. + int underline; /* Value of -underline option: specifies index + * of character to underline (<0 means don't + * underline anything). */ + Tcl_Obj *underlinePtr; /* Index of character to underline. */ + Tcl_Obj *bitmapPtr; /* Bitmap to display in menu entry, or None. * If not None then label is ignored. */ - char *imageString; /* Name of image to display (malloc'ed), or + Tcl_Obj *imagePtr; /* Name of image to display, or * NULL. If non-NULL, bitmap, text, and * textVarName are ignored. */ Tk_Image image; /* Image to display in menu entry, or NULL if * none. */ - char *selectImageString; /* Name of image to display when selected - * (malloc'ed), or NULL. */ + Tcl_Obj *selectImagePtr; /* Name of image to display when selected, or + * NULL. */ Tk_Image selectImage; /* Image to display in entry when selected, * or NULL if none. Ignored if image is * NULL. */ - char *accel; /* Accelerator string displayed at right + Tcl_Obj *accelPtr; /* Accelerator string displayed at right * of menu entry. NULL means no such * accelerator. Malloc'ed. */ int accelLength; /* Number of non-NULL characters in * accelerator. */ - int indicatorOn; /* True means draw indicator, false means + Tcl_Obj *indicatorOnPtr; /* True means draw indicator, false means * don't draw it. */ /* * Display attributes */ - Tk_3DBorder border; /* Structure used to draw background for + Tcl_Obj *borderPtr; /* Structure used to draw background for * entry. NULL means use overall border * for menu. */ - XColor *fg; /* Foreground color to use for entry. NULL + Tcl_Obj *fgPtr; /* Foreground color to use for entry. NULL * means use foreground color from menu. */ - Tk_3DBorder activeBorder; /* Used to draw background and border when + Tcl_Obj *activeBorderPtr; /* Used to draw background and border when * element is active. NULL means use * activeBorder from menu. */ - XColor *activeFg; /* Foreground color to use when entry is + Tcl_Obj *activeFgPtr; /* Foreground color to use when entry is * active. NULL means use active foreground * from menu. */ - XColor *indicatorFg; /* Color for indicators in radio and check + Tcl_Obj *indicatorFgPtr; /* Color for indicators in radio and check * button entries. NULL means use indicatorFg * GC from menu. */ - Tk_Font tkfont; /* Text font for menu entries. NULL means + Tcl_Obj *fontPtr; /* Text font for menu entries. NULL means * use overall font for menu. */ - int columnBreak; /* If this is 0, this item appears below + Tcl_Obj *columnBreakPtr; /* If this is 0, this item appears below * the item in front of it. If this is * 1, this item starts a new column. */ - int hideMargin; /* If this is 0, then the item has enough + Tcl_Obj *hideMarginPtr; /* If this is 0, then the item has enough * margin to accomodate a standard check * mark and a default right margin. If this * is 1, then the item has no such margins. @@ -109,15 +113,15 @@ typedef struct TkMenuEntry { * Information used to implement this entry's action: */ - char *command; /* Command to invoke when entry is invoked. + Tcl_Obj *commandPtr; /* Command to invoke when entry is invoked. * Malloc'ed. */ - char *name; /* Name of variable (for check buttons and + Tcl_Obj *namePtr; /* Name of variable (for check buttons and * radio buttons) or menu (for cascade * entries). Malloc'ed.*/ - char *onValue; /* Value to store in variable when selected + Tcl_Obj *onValuePtr; /* Value to store in variable when selected * (only for radio and check buttons). * Malloc'ed. */ - char *offValue; /* Value to store in variable when not + Tcl_Obj *offValuePtr; /* Value to store in variable when not * selected (only for check buttons). * Malloc'ed. */ @@ -174,7 +178,7 @@ typedef struct TkMenuEntry { * does not yet exist. */ TkMenuPlatformEntryData platformEntryData; /* The data for the specific type of menu. - * Depends on platform and menu type what + * Depends on platform and menu type what * kind of options are in this structure. */ } TkMenuEntry; @@ -186,9 +190,9 @@ typedef struct TkMenuEntry { * button and that it should be drawn in * the "selected" state. * ENTRY_NEEDS_REDISPLAY: Non-zero means the entry should be redisplayed. - * ENTRY_LAST_COLUMN: Used by the drawing code. If the entry is in the - * last column, the space to its right needs to - * be filled. + * ENTRY_LAST_COLUMN: Used by the drawing code. If the entry is in + * the last column, the space to its right needs + * to be filled. * ENTRY_PLATFORM_FLAG1 - 4 These flags are reserved for use by the * platform-dependent implementation of menus * and should not be used by anything else. @@ -206,25 +210,22 @@ typedef struct TkMenuEntry { * Types defined for MenuEntries: */ -#define COMMAND_ENTRY 0 -#define SEPARATOR_ENTRY 1 -#define CHECK_BUTTON_ENTRY 2 -#define RADIO_BUTTON_ENTRY 3 -#define CASCADE_ENTRY 4 -#define TEAROFF_ENTRY 5 +#define CASCADE_ENTRY 0 +#define CHECK_BUTTON_ENTRY 1 +#define COMMAND_ENTRY 2 +#define RADIO_BUTTON_ENTRY 3 +#define SEPARATOR_ENTRY 4 +#define TEAROFF_ENTRY 5 /* - * Mask bits for above types: + * Menu states */ -#define COMMAND_MASK TK_CONFIG_USER_BIT -#define SEPARATOR_MASK (TK_CONFIG_USER_BIT << 1) -#define CHECK_BUTTON_MASK (TK_CONFIG_USER_BIT << 2) -#define RADIO_BUTTON_MASK (TK_CONFIG_USER_BIT << 3) -#define CASCADE_MASK (TK_CONFIG_USER_BIT << 4) -#define TEAROFF_MASK (TK_CONFIG_USER_BIT << 5) -#define ALL_MASK (COMMAND_MASK | SEPARATOR_MASK \ - | CHECK_BUTTON_MASK | RADIO_BUTTON_MASK | CASCADE_MASK | TEAROFF_MASK) +EXTERN char *tkMenuStateStrings[]; + +#define ENTRY_ACTIVE 0 +#define ENTRY_NORMAL 1 +#define ENTRY_DISABLED 2 /* * A data structure of the following type is kept for each @@ -248,7 +249,7 @@ typedef struct TkMenu { * nothing active. */ int menuType; /* MASTER_MENU, TEAROFF_MENU, or MENUBAR. * See below for definitions. */ - char *menuTypeName; /* Used to control whether created tkwin + Tcl_Obj *menuTypePtr; /* Used to control whether created tkwin * is a toplevel or not. "normal", "menubar", * or "toplevel" */ @@ -256,20 +257,21 @@ typedef struct TkMenu { * Information used when displaying widget: */ - Tk_3DBorder border; /* Structure used to draw 3-D + Tcl_Obj *borderPtr; /* Structure used to draw 3-D * border and background for menu. */ - int borderWidth; /* Width of border around whole menu. */ - Tk_3DBorder activeBorder; /* Used to draw background and border for + Tcl_Obj *borderWidthPtr; /* Width of border around whole menu. */ + Tcl_Obj *activeBorderPtr; /* Used to draw background and border for * active element (if any). */ - int activeBorderWidth; /* Width of border around active element. */ - int relief; /* 3-d effect: TK_RELIEF_RAISED, etc. */ - Tk_Font tkfont; /* Text font for menu entries. */ - XColor *fg; /* Foreground color for entries. */ - XColor *disabledFg; /* Foreground color when disabled. NULL + Tcl_Obj *activeBorderWidthPtr; + /* Width of border around active element. */ + Tcl_Obj *reliefPtr; /* 3-d effect: TK_RELIEF_RAISED, etc. */ + Tcl_Obj *fontPtr; /* Text font for menu entries. */ + Tcl_Obj *fgPtr; /* Foreground color for entries. */ + Tcl_Obj *disabledFgPtr; /* Foreground color when disabled. NULL * means use normalFg with a 50% stipple * instead. */ - XColor *activeFg; /* Foreground color for active entry. */ - XColor *indicatorFg; /* Color for indicators in radio and check + Tcl_Obj *activeFgPtr; /* Foreground color for active entry. */ + Tcl_Obj *indicatorFgPtr; /* Color for indicators in radio and check * button entries. */ Pixmap gray; /* Bitmap for drawing disabled entries in * a stippled fashion. None means not @@ -300,7 +302,7 @@ typedef struct TkMenu { * Miscellaneous information: */ - int tearOff; /* 1 means this menu can be torn off. On some + Tcl_Obj *tearoffPtr; /* 1 means this menu can be torn off. On some * platforms, the user can drag an outline * of the menu by just dragging outside of * the menu, and the tearoff is created where @@ -308,17 +310,17 @@ typedef struct TkMenu { * indicator (such as a dashed stripe) is * drawn, and when the menu is selected, the * tearoff is created. */ - char *title; /* The title to use when this menu is torn + Tcl_Obj *titlePtr; /* The title to use when this menu is torn * off. If this is NULL, a default scheme * will be used to generate a title for * tearoff. */ - char *tearOffCommand; /* If non-NULL, points to a command to + Tcl_Obj *tearoffCommandPtr; /* If non-NULL, points to a command to * run whenever the menu is torn-off. */ - char *takeFocus; /* Value of -takefocus option; not used in + Tcl_Obj *takeFocusPtr; /* Value of -takefocus option; not used in * the C code, but used by keyboard traversal * scripts. Malloc'ed, but may be NULL. */ - Tk_Cursor cursor; /* Current cursor for window, or None. */ - char *postCommand; /* Used to detect cycles in cascade hierarchy + Tcl_Obj *cursorPtr; /* Current cursor for window, or None. */ + Tcl_Obj *postCommandPtr; /* Used to detect cycles in cascade hierarchy * trees when preprocessing postcommands * on some platforms. See PostMenu for * more details. */ @@ -336,6 +338,9 @@ typedef struct TkMenu { /* A pointer to the original menu for this * clone chain. Points back to this structure * if this menu is a master menu. */ + struct TkMenuOptionTables *optionTablesPtr; + /* A pointer to the collection of option tables + * that work with menus and menu entries. */ Tk_Window parentTopLevelPtr;/* If this menu is a menubar, this is the * toplevel that owns the menu. Only applicable * for menubar clones. @@ -355,6 +360,13 @@ typedef struct TkMenu { * Depends on platform and menu type what * kind of options are in this structure. */ + Tk_OptionSpec *extensionPtr; + /* Needed by the configuration package for + * this widget to be extended. */ + Tk_SavedOptions *errorStructPtr; + /* We actually have to allocate these because + * multiple menus get changed during one + * ConfigureMenu call. */ } TkMenu; /* @@ -402,6 +414,16 @@ typedef struct TkMenuReferences { } TkMenuReferences; /* + * This structure contains all of the option tables that are needed + * by menus. + */ + +typedef struct TkMenuOptionTables { + Tk_OptionTable menuOptionTable; /* The option table for menus. */ + Tk_OptionTable entryOptionTables[6];/* The tables for menu entries. */ +} TkMenuOptionTables; + +/* * Flag bits for menus: * * REDRAW_PENDING: Non-zero means a DoWhenIdle handler @@ -448,13 +470,6 @@ typedef struct TkMenuReferences { #define DECORATION_BORDER_WIDTH 2 /* - * Configuration specs. Needed for platform-specific default initializations. - */ - -EXTERN Tk_ConfigSpec tkMenuEntryConfigSpecs[]; -EXTERN Tk_ConfigSpec tkMenuConfigSpecs[]; - -/* * Menu-related procedures that are shared among Tk modules but not exported * to the outside world: */ @@ -465,21 +480,26 @@ EXTERN void TkBindMenu _ANSI_ARGS_(( Tk_Window tkwin, TkMenu *menuPtr)); EXTERN TkMenuReferences * TkCreateMenuReferences _ANSI_ARGS_((Tcl_Interp *interp, - char *pathName)); + char *name)); EXTERN void TkDestroyMenu _ANSI_ARGS_((TkMenu *menuPtr)); -EXTERN void TkEventuallyRecomputeMenu _ANSI_ARGS_((TkMenu *menuPtr)); +EXTERN void TkEventuallyRecomputeMenu _ANSI_ARGS_(( + TkMenu *menuPtr)); EXTERN void TkEventuallyRedrawMenu _ANSI_ARGS_(( TkMenu *menuPtr, TkMenuEntry *mePtr)); EXTERN TkMenuReferences * TkFindMenuReferences _ANSI_ARGS_((Tcl_Interp *interp, - char *pathName)); + char *name)); +EXTERN TkMenuReferences * + TkFindMenuReferencesObj _ANSI_ARGS_(( + Tcl_Interp *interp, Tcl_Obj *namePtr)); EXTERN void TkFreeMenuReferences _ANSI_ARGS_(( TkMenuReferences *menuRefPtr)); EXTERN Tcl_HashTable * TkGetMenuHashTable _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN int TkGetMenuIndex _ANSI_ARGS_((Tcl_Interp *interp, - TkMenu *menuPtr, char *string, int lastOK, + TkMenu *menuPtr, Tcl_Obj *objPtr, int lastOK, int *indexPtr)); -EXTERN void TkMenuInitializeDrawingFields _ANSI_ARGS_((TkMenu *menuPtr)); +EXTERN void TkMenuInitializeDrawingFields _ANSI_ARGS_(( + TkMenu *menuPtr)); EXTERN void TkMenuInitializeEntryDrawingFields _ANSI_ARGS_(( TkMenuEntry *mePtr)); EXTERN int TkInvokeMenu _ANSI_ARGS_((Tcl_Interp *interp, @@ -501,8 +521,8 @@ EXTERN void TkMenuSelectImageProc _ANSI_ARGS_ ((ClientData clientData, int x, int y, int width, int height, int imgWidth, int imgHeight)); -EXTERN char * TkNewMenuName _ANSI_ARGS_((Tcl_Interp *interp, - char *parentName, TkMenu *menuPtr)); +EXTERN Tcl_Obj * TkNewMenuName _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *parentNamePtr, TkMenu *menuPtr)); EXTERN int TkPostCommand _ANSI_ARGS_((TkMenu *menuPtr)); EXTERN int TkPostSubmenu _ANSI_ARGS_((Tcl_Interp *interp, TkMenu *menuPtr, TkMenuEntry *mePtr)); @@ -516,7 +536,8 @@ EXTERN void TkRecomputeMenu _ANSI_ARGS_((TkMenu *menuPtr)); * common code. */ -EXTERN void TkpComputeMenubarGeometry _ANSI_ARGS_((TkMenu *menuPtr)); +EXTERN void TkpComputeMenubarGeometry _ANSI_ARGS_(( + TkMenu *menuPtr)); EXTERN void TkpComputeStandardMenuGeometry _ANSI_ARGS_ ((TkMenu *menuPtr)); EXTERN int TkpConfigureMenuEntry diff --git a/generic/tkMenuDraw.c b/generic/tkMenuDraw.c index be218a0..373d59d 100644 --- a/generic/tkMenuDraw.c +++ b/generic/tkMenuDraw.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkMenuDraw.c 1.46 97/10/28 14:26:00 + * SCCS: @(#) tkMenuDraw.c 1.52 98/01/12 16:27:29 */ #include "tkMenu.h" @@ -31,7 +31,7 @@ static void DisplayMenu _ANSI_ARGS_((ClientData clientData)); * TkMenuInitializeDrawingFields -- * * Fills in drawing fields of a new menu. Called when new menu is - * created by Tk_MenuCmd. + * created by MenuCmd. * * Results: * None. @@ -188,6 +188,9 @@ TkMenuConfigureDrawOptions(menuPtr) XGCValues gcValues; GC newGC; unsigned long mask; + Tk_3DBorder border, activeBorder; + Tk_Font tkfont; + XColor *fg, *activeFg, *indicatorFg; /* * A few options need special processing, such as setting the @@ -195,11 +198,14 @@ TkMenuConfigureDrawOptions(menuPtr) * defaults that couldn't be specified to Tk_ConfigureWidget. */ - Tk_SetBackgroundFromBorder(menuPtr->tkwin, menuPtr->border); + border = Tk_Get3DBorderFromObj(menuPtr->tkwin, menuPtr->borderPtr); + Tk_SetBackgroundFromBorder(menuPtr->tkwin, border); - gcValues.font = Tk_FontId(menuPtr->tkfont); - gcValues.foreground = menuPtr->fg->pixel; - gcValues.background = Tk_3DBorderColor(menuPtr->border)->pixel; + tkfont = Tk_GetFontFromObj(menuPtr->tkwin, menuPtr->fontPtr); + gcValues.font = Tk_FontId(tkfont); + fg = Tk_GetColorFromObj(menuPtr->tkwin, menuPtr->fgPtr); + gcValues.foreground = fg->pixel; + gcValues.background = Tk_3DBorderColor(border)->pixel; newGC = Tk_GetGC(menuPtr->tkwin, GCForeground|GCBackground|GCFont, &gcValues); if (menuPtr->textGC != None) { @@ -207,17 +213,21 @@ TkMenuConfigureDrawOptions(menuPtr) } menuPtr->textGC = newGC; - gcValues.font = Tk_FontId(menuPtr->tkfont); - gcValues.background = Tk_3DBorderColor(menuPtr->border)->pixel; - if (menuPtr->disabledFg != NULL) { - gcValues.foreground = menuPtr->disabledFg->pixel; + gcValues.font = Tk_FontId(tkfont); + gcValues.background = Tk_3DBorderColor(border)->pixel; + if (menuPtr->disabledFgPtr != NULL) { + XColor *disabledFg; + + disabledFg = Tk_GetColorFromObj(menuPtr->tkwin, + menuPtr->disabledFgPtr); + gcValues.foreground = disabledFg->pixel; mask = GCForeground|GCBackground|GCFont; } else { gcValues.foreground = gcValues.background; mask = GCForeground; if (menuPtr->gray == None) { menuPtr->gray = Tk_GetBitmap(menuPtr->interp, menuPtr->tkwin, - Tk_GetUid("gray50")); + "gray50"); } if (menuPtr->gray != None) { gcValues.fill_style = FillStippled; @@ -231,10 +241,10 @@ TkMenuConfigureDrawOptions(menuPtr) } menuPtr->disabledGC = newGC; - gcValues.foreground = Tk_3DBorderColor(menuPtr->border)->pixel; + gcValues.foreground = Tk_3DBorderColor(border)->pixel; if (menuPtr->gray == None) { menuPtr->gray = Tk_GetBitmap(menuPtr->interp, menuPtr->tkwin, - Tk_GetUid("gray50")); + "gray50"); } if (menuPtr->gray != None) { gcValues.fill_style = FillStippled; @@ -247,10 +257,12 @@ TkMenuConfigureDrawOptions(menuPtr) } menuPtr->disabledImageGC = newGC; - gcValues.font = Tk_FontId(menuPtr->tkfont); - gcValues.foreground = menuPtr->activeFg->pixel; - gcValues.background = - Tk_3DBorderColor(menuPtr->activeBorder)->pixel; + gcValues.font = Tk_FontId(tkfont); + activeFg = Tk_GetColorFromObj(menuPtr->tkwin, menuPtr->activeFgPtr); + gcValues.foreground = activeFg->pixel; + activeBorder = Tk_Get3DBorderFromObj(menuPtr->tkwin, + menuPtr->activeBorderPtr); + gcValues.background = Tk_3DBorderColor(activeBorder)->pixel; newGC = Tk_GetGC(menuPtr->tkwin, GCForeground|GCBackground|GCFont, &gcValues); if (menuPtr->activeGC != None) { @@ -258,8 +270,10 @@ TkMenuConfigureDrawOptions(menuPtr) } menuPtr->activeGC = newGC; - gcValues.foreground = menuPtr->indicatorFg->pixel; - gcValues.background = Tk_3DBorderColor(menuPtr->border)->pixel; + indicatorFg = Tk_GetColorFromObj(menuPtr->tkwin, + menuPtr->indicatorFgPtr); + gcValues.foreground = indicatorFg->pixel; + gcValues.background = Tk_3DBorderColor(border)->pixel; newGC = Tk_GetGC(menuPtr->tkwin, GCForeground|GCBackground|GCFont, &gcValues); if (menuPtr->indicatorGC != None) { @@ -296,10 +310,14 @@ TkMenuConfigureEntryDrawOptions(mePtr, index) unsigned long mask; Tk_Font tkfont; TkMenu *menuPtr = mePtr->menuPtr; + int state; - tkfont = (mePtr->tkfont == NULL) ? menuPtr->tkfont : mePtr->tkfont; + tkfont = Tk_GetFontFromObj(menuPtr->tkwin, + (mePtr->fontPtr != NULL) ? mePtr->fontPtr : menuPtr->fontPtr); - if (mePtr->state == tkActiveUid) { + Tcl_GetIndexFromObj(NULL, mePtr->statePtr, tkMenuStateStrings, + NULL, 0, &state); + if (state == ENTRY_ACTIVE) { if (index != menuPtr->active) { TkActivateMenuEntry(menuPtr, index); } @@ -307,30 +325,24 @@ TkMenuConfigureEntryDrawOptions(mePtr, index) if (index == menuPtr->active) { TkActivateMenuEntry(menuPtr, -1); } - if ((mePtr->state != tkNormalUid) - && (mePtr->state != tkDisabledUid)) { - Tcl_AppendResult(menuPtr->interp, "bad state value \"", - mePtr->state, - "\": must be normal, active, or disabled", (char *) NULL); - mePtr->state = tkNormalUid; - return TCL_ERROR; - } } - if ((mePtr->tkfont != NULL) - || (mePtr->border != NULL) - || (mePtr->fg != NULL) - || (mePtr->activeBorder != NULL) - || (mePtr->activeFg != NULL) - || (mePtr->indicatorFg != NULL)) { - gcValues.foreground = (mePtr->fg != NULL) - ? mePtr->fg->pixel - : menuPtr->fg->pixel; - gcValues.background = Tk_3DBorderColor( - (mePtr->border != NULL) - ? mePtr->border - : menuPtr->border) - ->pixel; + if ((mePtr->fontPtr != NULL) + || (mePtr->borderPtr != NULL) + || (mePtr->fgPtr != NULL) + || (mePtr->activeBorderPtr != NULL) + || (mePtr->activeFgPtr != NULL) + || (mePtr->indicatorFgPtr != NULL)) { + XColor *fg, *indicatorFg, *activeFg; + Tk_3DBorder border, activeBorder; + + fg = Tk_GetColorFromObj(menuPtr->tkwin, (mePtr->fgPtr != NULL) + ? mePtr->fgPtr : menuPtr->fgPtr); + gcValues.foreground = fg->pixel; + border = Tk_Get3DBorderFromObj(menuPtr->tkwin, + (mePtr->borderPtr != NULL) ? mePtr->borderPtr + : menuPtr->borderPtr); + gcValues.background = Tk_3DBorderColor(border)->pixel; gcValues.font = Tk_FontId(tkfont); @@ -345,17 +357,20 @@ TkMenuConfigureEntryDrawOptions(mePtr, index) GCForeground|GCBackground|GCFont|GCGraphicsExposures, &gcValues); - if (mePtr->indicatorFg != NULL) { - gcValues.foreground = mePtr->indicatorFg->pixel; - } else if (menuPtr->indicatorFg != NULL) { - gcValues.foreground = menuPtr->indicatorFg->pixel; - } + indicatorFg = Tk_GetColorFromObj(menuPtr->tkwin, + (mePtr->indicatorFgPtr != NULL) ? mePtr->indicatorFgPtr + : menuPtr->indicatorFgPtr); + gcValues.foreground = indicatorFg->pixel; newIndicatorGC = Tk_GetGC(menuPtr->tkwin, GCForeground|GCBackground|GCGraphicsExposures, &gcValues); - if ((menuPtr->disabledFg != NULL) || (mePtr->image != NULL)) { - gcValues.foreground = menuPtr->disabledFg->pixel; + if ((menuPtr->disabledFgPtr != NULL) || (mePtr->image != NULL)) { + XColor *disabledFg; + + disabledFg = Tk_GetColorFromObj(menuPtr->tkwin, + menuPtr->disabledFgPtr); + gcValues.foreground = disabledFg->pixel; mask = GCForeground|GCBackground|GCFont|GCGraphicsExposures; } else { gcValues.foreground = gcValues.background; @@ -365,13 +380,15 @@ TkMenuConfigureEntryDrawOptions(mePtr, index) } newDisabledGC = Tk_GetGC(menuPtr->tkwin, mask, &gcValues); - gcValues.foreground = (mePtr->activeFg != NULL) - ? mePtr->activeFg->pixel - : menuPtr->activeFg->pixel; - gcValues.background = Tk_3DBorderColor( - (mePtr->activeBorder != NULL) - ? mePtr->activeBorder - : menuPtr->activeBorder)->pixel; + activeFg = Tk_GetColorFromObj(menuPtr->tkwin, + (mePtr->activeFgPtr != NULL) ? mePtr->activeFgPtr + : menuPtr->activeFgPtr); + activeBorder = Tk_Get3DBorderFromObj(menuPtr->tkwin, + (mePtr->activeBorderPtr != NULL) ? mePtr->activeBorderPtr + : menuPtr->activeBorderPtr); + + gcValues.foreground = activeFg->pixel; + gcValues.background = Tk_3DBorderColor(activeBorder)->pixel; newActiveGC = Tk_GetGC(menuPtr->tkwin, GCForeground|GCBackground|GCFont|GCGraphicsExposures, &gcValues); @@ -475,7 +492,7 @@ TkRecomputeMenu(menuPtr) void TkEventuallyRedrawMenu(menuPtr, mePtr) register TkMenu *menuPtr; /* Information about menu to redraw. */ - register TkMenuEntry *mePtr; /* Entry to redraw. NULL means redraw + register TkMenuEntry *mePtr;/* Entry to redraw. NULL means redraw * all the entries in the menu. */ { int i; @@ -616,21 +633,31 @@ DisplayMenu(clientData) register TkMenuEntry *mePtr; register Tk_Window tkwin = menuPtr->tkwin; int index, strictMotif; - Tk_Font tkfont = menuPtr->tkfont; + Tk_Font tkfont; Tk_FontMetrics menuMetrics; int width; + int borderWidth; + int columnBreak; + Tk_3DBorder border; + int activeBorderWidth; + int relief; + menuPtr->menuFlags &= ~REDRAW_PENDING; if ((menuPtr->tkwin == NULL) || !Tk_IsMapped(tkwin)) { return; } + Tk_GetPixelsFromObj(NULL, menuPtr->tkwin, menuPtr->borderWidthPtr, + &borderWidth); + border = Tk_Get3DBorderFromObj(menuPtr->tkwin, menuPtr->borderPtr); + Tk_GetPixelsFromObj(NULL, menuPtr->tkwin, + menuPtr->activeBorderWidthPtr, &activeBorderWidth); + if (menuPtr->menuType == MENUBAR) { - Tk_Fill3DRectangle(tkwin, Tk_WindowId(tkwin), menuPtr->border, - menuPtr->borderWidth, menuPtr->borderWidth, - Tk_Width(tkwin) - 2 * menuPtr->borderWidth, - Tk_Height(tkwin) - 2 * menuPtr->borderWidth, 0, - TK_RELIEF_FLAT); + Tk_Fill3DRectangle(tkwin, Tk_WindowId(tkwin), border, borderWidth, + borderWidth, Tk_Width(tkwin) - 2 * borderWidth, + Tk_Height(tkwin) - 2 * borderWidth, 0, TK_RELIEF_FLAT); } strictMotif = Tk_StrictMotif(menuPtr->tkwin); @@ -640,7 +667,8 @@ DisplayMenu(clientData) * all of the time. */ - Tk_GetFontMetrics(menuPtr->tkfont, &menuMetrics); + tkfont = Tk_GetFontFromObj(menuPtr->tkwin, menuPtr->fontPtr); + Tk_GetFontMetrics(tkfont, &menuMetrics); /* * Loop through all of the entries, drawing them one at a time. @@ -660,22 +688,22 @@ DisplayMenu(clientData) } else { if (mePtr->entryFlags & ENTRY_LAST_COLUMN) { width = Tk_Width(menuPtr->tkwin) - mePtr->x - - menuPtr->activeBorderWidth; + - activeBorderWidth; } else { - width = mePtr->width + menuPtr->borderWidth; + width = mePtr->width + borderWidth; } } TkpDrawMenuEntry(mePtr, Tk_WindowId(menuPtr->tkwin), tkfont, &menuMetrics, mePtr->x, mePtr->y, width, mePtr->height, strictMotif, 1); - if ((index > 0) && (menuPtr->menuType != MENUBAR) - && mePtr->columnBreak) { + Tcl_GetBooleanFromObj(NULL, mePtr->columnBreakPtr, &columnBreak); + if ((index > 0) && (menuPtr->menuType != MENUBAR) && columnBreak) { mePtr = menuPtr->entries[index - 1]; - Tk_Fill3DRectangle(tkwin, Tk_WindowId(tkwin), menuPtr->border, + Tk_Fill3DRectangle(tkwin, Tk_WindowId(tkwin), border, mePtr->x, mePtr->y + mePtr->height, mePtr->width, - Tk_Height(tkwin) - mePtr->y - mePtr->height - - menuPtr->activeBorderWidth, 0, + Tk_Height(tkwin) - mePtr->y - mePtr->height - + activeBorderWidth, 0, TK_RELIEF_FLAT); } } @@ -684,28 +712,29 @@ DisplayMenu(clientData) int x, y, height; if (menuPtr->numEntries == 0) { - x = y = menuPtr->borderWidth; - width = Tk_Width(tkwin) - 2 * menuPtr->activeBorderWidth; - height = Tk_Height(tkwin) - 2 * menuPtr->activeBorderWidth; + x = y = borderWidth; + width = Tk_Width(tkwin) - 2 * activeBorderWidth; + height = Tk_Height(tkwin) - 2 * activeBorderWidth; } else { mePtr = menuPtr->entries[menuPtr->numEntries - 1]; Tk_Fill3DRectangle(tkwin, Tk_WindowId(tkwin), - menuPtr->border, mePtr->x, mePtr->y + mePtr->height, - mePtr->width, Tk_Height(tkwin) - mePtr->y - mePtr->height - - menuPtr->activeBorderWidth, 0, + border, mePtr->x, mePtr->y + mePtr->height, mePtr->width, + Tk_Height(tkwin) - mePtr->y - mePtr->height + - activeBorderWidth, 0, TK_RELIEF_FLAT); x = mePtr->x + mePtr->width; y = mePtr->y + mePtr->height; - width = Tk_Width(tkwin) - x - menuPtr->activeBorderWidth; - height = Tk_Height(tkwin) - y - menuPtr->activeBorderWidth; + width = Tk_Width(tkwin) - x - activeBorderWidth; + height = Tk_Height(tkwin) - y - activeBorderWidth; } - Tk_Fill3DRectangle(tkwin, Tk_WindowId(tkwin), menuPtr->border, x, y, + Tk_Fill3DRectangle(tkwin, Tk_WindowId(tkwin), border, x, y, width, height, 0, TK_RELIEF_FLAT); } + Tk_GetReliefFromObj(NULL, menuPtr->reliefPtr, &relief); Tk_Draw3DRectangle(menuPtr->tkwin, Tk_WindowId(tkwin), - menuPtr->border, 0, 0, Tk_Width(tkwin), Tk_Height(tkwin), - menuPtr->borderWidth, menuPtr->relief); + border, 0, 0, Tk_Width(tkwin), Tk_Height(tkwin), borderWidth, + relief); } /* @@ -739,11 +768,12 @@ TkMenuEventProc(clientData, eventPtr) TkEventuallyRecomputeMenu(menuPtr); TkEventuallyRedrawMenu(menuPtr, (TkMenuEntry *) NULL); } else if (eventPtr->type == ActivateNotify) { - if (menuPtr->menuType == TEAROFF_MENU) { - TkpSetMainMenubar(menuPtr->interp, menuPtr->tkwin, NULL); - } + if (menuPtr->menuType == TEAROFF_MENU) { + TkpSetMainMenubar(menuPtr->interp, menuPtr->tkwin, NULL); + } } else if (eventPtr->type == DestroyNotify) { if (menuPtr->tkwin != NULL) { + TkDestroyMenu(menuPtr); menuPtr->tkwin = NULL; Tcl_DeleteCommandFromToken(menuPtr->interp, menuPtr->widgetCmd); } @@ -753,7 +783,7 @@ TkMenuEventProc(clientData, eventPtr) if (menuPtr->menuFlags & RESIZE_PENDING) { Tcl_CancelIdleCall(ComputeMenuGeometry, (ClientData) menuPtr); } - TkDestroyMenu(menuPtr); + Tcl_EventuallyFree((ClientData) menuPtr, TCL_DYNAMIC); } } @@ -921,7 +951,6 @@ TkPostSubmenu(interp, menuPtr, mePtr) * posted. NULL means make sure that * no submenu is posted. */ { - char string[30]; int result, x, y; if (mePtr == menuPtr->postedCascade) { @@ -929,6 +958,8 @@ TkPostSubmenu(interp, menuPtr, mePtr) } if (menuPtr->postedCascade != NULL) { + char *name = Tcl_GetStringFromObj(menuPtr->postedCascade->namePtr, + NULL); /* * Note: when unposting a submenu, we have to redraw the entire @@ -948,17 +979,15 @@ TkPostSubmenu(interp, menuPtr, mePtr) */ TkEventuallyRedrawMenu(menuPtr, (TkMenuEntry *) NULL); - result = Tcl_VarEval(interp, menuPtr->postedCascade->name, - " unpost", (char *) NULL); + result = Tcl_VarEval(interp, name, " unpost", (char *) NULL); menuPtr->postedCascade = NULL; if (result != TCL_OK) { return result; } } - if ((mePtr != NULL) && (mePtr->name != NULL) + if ((mePtr != NULL) && (mePtr->namePtr != NULL) && Tk_IsMapped(menuPtr->tkwin)) { - /* * Position the cascade with its upper left corner slightly * below and to the left of the upper right corner of the @@ -967,10 +996,13 @@ TkPostSubmenu(interp, menuPtr, mePtr) * The menu has to redrawn so that the entry can change relief. */ + char string[TCL_INTEGER_SPACE * 2]; + char *name; + + name = Tcl_GetStringFromObj(mePtr->namePtr, NULL); Tk_GetRootCoords(menuPtr->tkwin, &x, &y); AdjustMenuCoords(menuPtr, mePtr, &x, &y, string); - result = Tcl_VarEval(interp, mePtr->name, " post ", string, - (char *) NULL); + result = Tcl_VarEval(interp, name, " post ", string, (char *) NULL); if (result != TCL_OK) { return result; } @@ -1009,10 +1041,15 @@ AdjustMenuCoords(menuPtr, mePtr, xPtr, yPtr, string) *xPtr += mePtr->x; *yPtr += mePtr->y + mePtr->height; } else { - *xPtr += Tk_Width(menuPtr->tkwin) - menuPtr->borderWidth - - menuPtr->activeBorderWidth - 2; - *yPtr += mePtr->y - + menuPtr->activeBorderWidth + 2; + int borderWidth, activeBorderWidth; + + Tk_GetPixelsFromObj(NULL, menuPtr->tkwin, menuPtr->borderWidthPtr, + &borderWidth); + Tk_GetPixelsFromObj(NULL, menuPtr->tkwin, + menuPtr->activeBorderWidthPtr, &activeBorderWidth); + *xPtr += Tk_Width(menuPtr->tkwin) - borderWidth - activeBorderWidth + - 2; + *yPtr += mePtr->y + activeBorderWidth + 2; } sprintf(string, "%d %d", *xPtr, *yPtr); } diff --git a/generic/tkMenubutton.c b/generic/tkMenubutton.c index ca2070e..8b5ba1b 100644 --- a/generic/tkMenubutton.c +++ b/generic/tkMenubutton.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkMenubutton.c 1.94 97/07/31 09:10:37 + * SCCS: @(#) tkMenubutton.c 1.95 97/11/07 21:20:06 */ #include "tkMenubutton.h" @@ -267,7 +267,7 @@ Tk_MenubuttonCmd(clientData, interp, argc, argv) return TCL_ERROR; } - interp->result = Tk_PathName(mbPtr->tkwin); + Tcl_SetResult(interp, Tk_PathName(mbPtr->tkwin), TCL_STATIC); return TCL_OK; } @@ -409,7 +409,7 @@ DestroyMenuButton(memPtr) * * Results: * The return value is a standard Tcl result. If TCL_ERROR is - * returned, then interp->result contains an error message. + * returned, then the interp's result contains an error message. * * Side effects: * Configuration information, such as text string, colors, font, diff --git a/generic/tkMessage.c b/generic/tkMessage.c index 1984bac..0a0e214 100644 --- a/generic/tkMessage.c +++ b/generic/tkMessage.c @@ -6,12 +6,12 @@ * in a window according to a particular aspect ratio. * * Copyright (c) 1990-1994 The Regents of the University of California. - * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkMessage.c 1.75 97/07/31 09:11:14 + * SCCS: @(#) tkMessage.c 1.76 97/11/07 21:20:11 */ #include "tkPort.h" @@ -274,7 +274,7 @@ Tk_MessageCmd(clientData, interp, argc, argv) goto error; } - interp->result = Tk_PathName(msgPtr->tkwin); + Tcl_SetResult(interp, Tk_PathName(msgPtr->tkwin), TCL_STATIC); return TCL_OK; error: @@ -401,7 +401,7 @@ DestroyMessage(memPtr) * * Results: * The return value is a standard Tcl result. If TCL_ERROR is - * returned, then interp->result contains an error message. + * returned, then the interp's result contains an error message. * * Side effects: * Configuration information, such as text string, colors, font, diff --git a/generic/tkObj.c b/generic/tkObj.c new file mode 100644 index 0000000..35149eb --- /dev/null +++ b/generic/tkObj.c @@ -0,0 +1,659 @@ +/* + * tkObj.c -- + * + * This file contains procedures that implement the common Tk object + * types + * + * 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. + * + * SCCS: @(#) tkObj.c 1.14 98/01/19 12:00:30 + */ + +#include "tkInt.h" + +/* + * The following structure is the internal representation for pixel objects. + */ + +typedef struct PixelRep { + double value; + int units; + Tk_Window tkwin; + int returnValue; +} PixelRep; + +#define SIMPLE_PIXELREP(objPtr) \ + ((objPtr)->internalRep.twoPtrValue.ptr2 == 0) + +#define SET_SIMPLEPIXEL(objPtr, intval) \ + (objPtr)->internalRep.twoPtrValue.ptr1 = (VOID *) (intval); \ + (objPtr)->internalRep.twoPtrValue.ptr2 = 0 + +#define GET_SIMPLEPIXEL(objPtr) \ + ((int) (objPtr)->internalRep.twoPtrValue.ptr1) + +#define SET_COMPLEXPIXEL(objPtr, repPtr) \ + (objPtr)->internalRep.twoPtrValue.ptr1 = 0; \ + (objPtr)->internalRep.twoPtrValue.ptr2 = (VOID *) repPtr + +#define GET_COMPLEXPIXEL(objPtr) \ + ((PixelRep *) (objPtr)->internalRep.twoPtrValue.ptr2) + + +/* + * The following structure is the internal representation for mm objects. + */ + +typedef struct MMRep { + double value; + int units; + Tk_Window tkwin; + double returnValue; +} MMRep; + +/* + * Prototypes for procedures defined later in this file: + */ + +static void DupMMInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, + Tcl_Obj *copyPtr)); +static void DupPixelInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, + Tcl_Obj *copyPtr)); +static void FreeMMInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr)); +static void FreePixelInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr)); +static int SetMMFromAny _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); +static int SetPixelFromAny _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); +static int SetWindowFromAny _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); + +/* + * The following structure defines the implementation of the "pixel" + * Tcl object, used for measuring distances. The pixel object remembers + * its initial display-independant settings. + */ + +static Tcl_ObjType pixelObjType = { + "pixel", /* name */ + FreePixelInternalRep, /* freeIntRepProc */ + DupPixelInternalRep, /* dupIntRepProc */ + NULL, /* updateStringProc */ + SetPixelFromAny /* setFromAnyProc */ +}; + +/* + * The following structure defines the implementation of the "pixel" + * Tcl object, used for measuring distances. The pixel object remembers + * its initial display-independant settings. + */ + +static Tcl_ObjType mmObjType = { + "mm", /* name */ + FreeMMInternalRep, /* freeIntRepProc */ + DupMMInternalRep, /* dupIntRepProc */ + NULL, /* updateStringProc */ + SetMMFromAny /* setFromAnyProc */ +}; + +/* + * The following structure defines the implementation of the "window" + * Tcl object. + */ + +static Tcl_ObjType windowObjType = { + "window", /* name */ + (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ + (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ + NULL, /* updateStringProc */ + SetWindowFromAny /* setFromAnyProc */ +}; + + + +/* + *---------------------------------------------------------------------- + * + * Tk_GetPixelsFromObj -- + * + * Attempt to return a pixel value from the Tcl object "objPtr". If the + * object is not already a pixel value, an attempt will be made to convert + * it to one. + * + * Results: + * The return value is a standard Tcl object result. If an error occurs + * during conversion, an error message is left in the interpreter's + * result unless "interp" is NULL. + * + * Side effects: + * If the object is not already a pixel, the conversion will free + * any old internal representation. + * + *---------------------------------------------------------------------- + */ + +int +Tk_GetPixelsFromObj(interp, tkwin, objPtr, intPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + Tk_Window tkwin; + Tcl_Obj *objPtr; /* The object from which to get pixels. */ + int *intPtr; /* Place to store resulting pixels. */ +{ + int result; + double d; + PixelRep *pixelPtr; + static double bias[] = { + 1.0, 10.0, 25.4, 25.4 / 72.0 + }; + + if (objPtr->typePtr != &pixelObjType) { + result = SetPixelFromAny(interp, objPtr); + if (result != TCL_OK) { + return result; + } + } + + if (SIMPLE_PIXELREP(objPtr)) { + *intPtr = GET_SIMPLEPIXEL(objPtr); + } else { + pixelPtr = GET_COMPLEXPIXEL(objPtr); + if (pixelPtr->tkwin != tkwin) { + d = pixelPtr->value; + if (pixelPtr->units >= 0) { + d *= bias[pixelPtr->units] * WidthOfScreen(Tk_Screen(tkwin)); + d /= WidthMMOfScreen(Tk_Screen(tkwin)); + } + if (d < 0) { + pixelPtr->returnValue = (int) (d - 0.5); + } else { + pixelPtr->returnValue = (int) (d + 0.5); + } + pixelPtr->tkwin = tkwin; + } + *intPtr = pixelPtr->returnValue; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FreePixelInternalRep -- + * + * Deallocate the storage associated with a pixel object's internal + * representation. + * + * Results: + * None. + * + * Side effects: + * Frees objPtr's internal representation and sets objPtr's + * internalRep to NULL. + * + *---------------------------------------------------------------------- + */ + +static void +FreePixelInternalRep(objPtr) + Tcl_Obj *objPtr; /* Pixel object with internal rep to free. */ +{ + PixelRep *pixelPtr; + + if (!SIMPLE_PIXELREP(objPtr)) { + pixelPtr = GET_COMPLEXPIXEL(objPtr); + ckfree((char *) pixelPtr); + } + SET_SIMPLEPIXEL(objPtr, 0); +} + +/* + *---------------------------------------------------------------------- + * + * DupPixelInternalRep -- + * + * Initialize the internal representation of a pixel Tcl_Obj to a + * copy of the internal representation of an existing pixel object. + * + * Results: + * None. + * + * Side effects: + * copyPtr's internal rep is set to the pixel corresponding to + * srcPtr's internal rep. + * + *---------------------------------------------------------------------- + */ + +static void +DupPixelInternalRep(srcPtr, copyPtr) + register Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ + register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ +{ + PixelRep *oldPtr, *newPtr; + + copyPtr->typePtr = srcPtr->typePtr; + + if (SIMPLE_PIXELREP(srcPtr)) { + SET_SIMPLEPIXEL(copyPtr, GET_SIMPLEPIXEL(srcPtr)); + } else { + oldPtr = GET_COMPLEXPIXEL(srcPtr); + newPtr = (PixelRep *) ckalloc(sizeof(PixelRep)); + newPtr->value = oldPtr->value; + newPtr->units = oldPtr->units; + newPtr->tkwin = oldPtr->tkwin; + newPtr->returnValue = oldPtr->returnValue; + SET_COMPLEXPIXEL(copyPtr, newPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * SetPixelFromAny -- + * + * Attempt to generate a pixel internal form for the Tcl object + * "objPtr". + * + * Results: + * The return value is a standard Tcl result. If an error occurs during + * conversion, an error message is left in the interpreter's result + * unless "interp" is NULL. + * + * Side effects: + * If no error occurs, a pixel representation of the object is + * stored internally and the type of "objPtr" is set to pixel. + * + *---------------------------------------------------------------------- + */ + +static int +SetPixelFromAny(interp, objPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr; /* The object to convert. */ +{ + Tcl_ObjType *typePtr; + char *string, *rest; + double d; + int i, units; + PixelRep *pixelPtr; + + string = Tcl_GetStringFromObj(objPtr, NULL); + + d = strtod(string, &rest); + if (rest == string) { + /* + * Must copy string before resetting the result in case a caller + * is trying to convert the interpreter's result to pixels. + */ + + char buf[100]; + + error: + sprintf(buf, "bad screen distance \"%.50s\"", string); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, buf, NULL); + return TCL_ERROR; + } + while ((*rest != '\0') && isspace(UCHAR(*rest))) { + rest++; + } + switch (*rest) { + case '\0': + units = -1; + break; + + case 'm': + units = 0; + break; + + case 'c': + units = 1; + break; + + case 'i': + units = 2; + break; + + case 'p': + units = 3; + break; + + default: + goto error; + } + + /* + * Free the old internalRep before setting the new one. + */ + + typePtr = objPtr->typePtr; + if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { + (*typePtr->freeIntRepProc)(objPtr); + } + + objPtr->typePtr = &pixelObjType; + + i = (int) d; + if ((units < 0) && (i == d)) { + SET_SIMPLEPIXEL(objPtr, i); + } else { + pixelPtr = (PixelRep *) ckalloc(sizeof(PixelRep)); + pixelPtr->value = d; + pixelPtr->units = units; + pixelPtr->tkwin = NULL; + pixelPtr->returnValue = i; + SET_COMPLEXPIXEL(objPtr, pixelPtr); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_GetMMFromObj -- + * + * Attempt to return an mm value from the Tcl object "objPtr". If the + * object is not already an mm value, an attempt will be made to convert + * it to one. + * + * Results: + * The return value is a standard Tcl object result. If an error occurs + * during conversion, an error message is left in the interpreter's + * result unless "interp" is NULL. + * + * Side effects: + * If the object is not already a pixel, the conversion will free + * any old internal representation. + * + *---------------------------------------------------------------------- + */ + +int +Tk_GetMMFromObj(interp, tkwin, objPtr, doublePtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + Tk_Window tkwin; + Tcl_Obj *objPtr; /* The object from which to get mms. */ + double *doublePtr; /* Place to store resulting millimeters. */ +{ + int result; + double d; + MMRep *mmPtr; + static double bias[] = { + 10.0, 25.4, 1.0, 25.4 / 72.0 + }; + + if (objPtr->typePtr != &mmObjType) { + result = SetMMFromAny(interp, objPtr); + if (result != TCL_OK) { + return result; + } + } + + mmPtr = (MMRep *) objPtr->internalRep.otherValuePtr; + if (mmPtr->tkwin != tkwin) { + d = mmPtr->value; + if (mmPtr->units == -1) { + d /= WidthOfScreen(Tk_Screen(tkwin)); + d *= WidthMMOfScreen(Tk_Screen(tkwin)); + } else { + d *= bias[mmPtr->units]; + } + mmPtr->tkwin = tkwin; + mmPtr->returnValue = d; + } + *doublePtr = mmPtr->returnValue; + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FreeMMInternalRep -- + * + * Deallocate the storage associated with a mm object's internal + * representation. + * + * Results: + * None. + * + * Side effects: + * Frees objPtr's internal representation and sets objPtr's + * internalRep to NULL. + * + *---------------------------------------------------------------------- + */ + +static void +FreeMMInternalRep(objPtr) + Tcl_Obj *objPtr; /* MM object with internal rep to free. */ +{ + ckfree((char *) objPtr->internalRep.otherValuePtr); + objPtr->internalRep.otherValuePtr = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * DupMMInternalRep -- + * + * Initialize the internal representation of a pixel Tcl_Obj to a + * copy of the internal representation of an existing pixel object. + * + * Results: + * None. + * + * Side effects: + * copyPtr's internal rep is set to the pixel corresponding to + * srcPtr's internal rep. + * + *---------------------------------------------------------------------- + */ + +static void +DupMMInternalRep(srcPtr, copyPtr) + register Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ + register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ +{ + MMRep *oldPtr, *newPtr; + + copyPtr->typePtr = srcPtr->typePtr; + oldPtr = (MMRep *) srcPtr->internalRep.otherValuePtr; + newPtr = (MMRep *) ckalloc(sizeof(MMRep)); + newPtr->value = oldPtr->value; + newPtr->units = oldPtr->units; + newPtr->tkwin = oldPtr->tkwin; + newPtr->returnValue = oldPtr->returnValue; + copyPtr->internalRep.otherValuePtr = (VOID *) newPtr; +} + +/* + *---------------------------------------------------------------------- + * + * SetMMFromAny -- + * + * Attempt to generate a mm internal form for the Tcl object + * "objPtr". + * + * Results: + * The return value is a standard Tcl result. If an error occurs during + * conversion, an error message is left in the interpreter's result + * unless "interp" is NULL. + * + * Side effects: + * If no error occurs, a mm representation of the object is + * stored internally and the type of "objPtr" is set to mm. + * + *---------------------------------------------------------------------- + */ + +static int +SetMMFromAny(interp, objPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr; /* The object to convert. */ +{ + Tcl_ObjType *typePtr; + char *string, *rest; + double d; + int units; + MMRep *mmPtr; + + string = Tcl_GetStringFromObj(objPtr, NULL); + + d = strtod(string, &rest); + if (rest == string) { + /* + * Must copy string before resetting the result in case a caller + * is trying to convert the interpreter's result to mms. + */ + + error: + Tcl_AppendResult(interp, "bad screen distance \"", string, + "\"", (char *) NULL); + return TCL_ERROR; + } + while ((*rest != '\0') && isspace(UCHAR(*rest))) { + rest++; + } + switch (*rest) { + case '\0': + units = -1; + break; + + case 'c': + units = 0; + break; + + case 'i': + units = 1; + break; + + case 'm': + units = 2; + break; + + case 'p': + units = 3; + break; + + default: + goto error; + } + + /* + * Free the old internalRep before setting the new one. + */ + + typePtr = objPtr->typePtr; + if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { + (*typePtr->freeIntRepProc)(objPtr); + } + + objPtr->typePtr = &mmObjType; + + mmPtr = (MMRep *) ckalloc(sizeof(MMRep)); + mmPtr->value = d; + mmPtr->units = units; + mmPtr->tkwin = NULL; + mmPtr->returnValue = d; + objPtr->internalRep.otherValuePtr = (VOID *) mmPtr; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TkGetWindowFromObj -- + * + * Attempt to return a Tk_Window from the Tcl object "objPtr". If the + * object is not already a Tk_Window, an attempt will be made to convert + * it to one. + * + * Results: + * The return value is a standard Tcl object result. If an error occurs + * during conversion, an error message is left in the interpreter's + * result unless "interp" is NULL. + * + * Side effects: + * If the object is not already a Tk_Window, the conversion will free + * any old internal representation. + * + *---------------------------------------------------------------------- + */ + +int +TkGetWindowFromObj(interp, tkwin, objPtr, windowPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + Tk_Window tkwin; /* A token to get the main window from. */ + register Tcl_Obj *objPtr; /* The object from which to get boolean. */ + Tk_Window *windowPtr; /* Place to store resulting window. */ +{ + register int result; + Tk_Window lastWindow; + + result = SetWindowFromAny(interp, objPtr); + if (result != TCL_OK) { + return result; + } + + lastWindow = (Tk_Window) objPtr->internalRep.twoPtrValue.ptr1; + if (tkwin != lastWindow) { + Tk_Window foundWindow = Tk_NameToWindow(interp, + Tcl_GetStringFromObj(objPtr, NULL), tkwin); + + if (foundWindow == NULL) { + return TCL_ERROR; + } + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) tkwin; + objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) foundWindow; + } + *windowPtr = (Tk_Window) objPtr->internalRep.twoPtrValue.ptr2; + + return result; +} + +/* + *---------------------------------------------------------------------- + * + * SetWindowFromAny -- + * + * Attempt to generate a Tk_Window internal form for the Tcl object + * "objPtr". + * + * Results: + * The return value is a standard Tcl result. If an error occurs during + * conversion, an error message is left in the interpreter's result + * unless "interp" is NULL. + * + * Side effects: + * If no error occurs, a standard window value is stored as "objPtr"s + * internal representation and the type of "objPtr" is set to Tk_Window. + * + *---------------------------------------------------------------------- + */ + +static int +SetWindowFromAny(interp, objPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr; /* The object to convert. */ +{ + Tcl_ObjType *typePtr; + + /* + * Free the old internalRep before setting the new one. + */ + + Tcl_GetStringFromObj(objPtr, NULL); + typePtr = objPtr->typePtr; + if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { + (*typePtr->freeIntRepProc)(objPtr); + } + objPtr->typePtr = &windowObjType; + objPtr->internalRep.twoPtrValue.ptr1 = NULL; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; + + return TCL_OK; +} diff --git a/generic/tkOldConfig.c b/generic/tkOldConfig.c new file mode 100644 index 0000000..c171521 --- /dev/null +++ b/generic/tkOldConfig.c @@ -0,0 +1,996 @@ +/* + * tkOldConfig.c -- + * + * This file contains the Tk_ConfigureWidget procedure. THIS FILE + * IS HERE FOR BACKWARD COMPATIBILITY; THE NEW CONFIGURATION + * PACKAGE SHOULD BE USED FOR NEW PROJECTS. + * + * Copyright (c) 1990-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. + * + * SCCS: @(#) tkOldConfig.c 1.56 98/02/11 17:46:46 + */ + +#include "tkPort.h" +#include "tk.h" + +/* + * Values for "flags" field of Tk_ConfigSpec structures. Be sure + * to coordinate these values with those defined in tk.h + * (TK_CONFIG_COLOR_ONLY, etc.). There must not be overlap! + * + * INIT - Non-zero means (char *) things have been + * converted to Tk_Uid's. + */ + +#define INIT 0x20 + +/* + * Forward declarations for procedures defined later in this file: + */ + +static int DoConfig _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, Tk_ConfigSpec *specPtr, + Tk_Uid value, int valueIsUid, char *widgRec)); +static Tk_ConfigSpec * FindConfigSpec _ANSI_ARGS_((Tcl_Interp *interp, + Tk_ConfigSpec *specs, char *argvName, + int needFlags, int hateFlags)); +static char * FormatConfigInfo _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, Tk_ConfigSpec *specPtr, + char *widgRec)); +static char * FormatConfigValue _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, Tk_ConfigSpec *specPtr, + char *widgRec, char *buffer, + Tcl_FreeProc **freeProcPtr)); + +/* + *-------------------------------------------------------------- + * + * Tk_ConfigureWidget -- + * + * Process command-line options and database options to + * fill in fields of a widget record with resources and + * other parameters. + * + * Results: + * A standard Tcl return value. In case of an error, + * the interp's result will hold an error message. + * + * Side effects: + * The fields of widgRec get filled in with information + * from argc/argv and the option database. Old information + * in widgRec's fields gets recycled. + * + *-------------------------------------------------------------- + */ + +int +Tk_ConfigureWidget(interp, tkwin, specs, argc, argv, widgRec, flags) + Tcl_Interp *interp; /* Interpreter for error reporting. */ + Tk_Window tkwin; /* Window containing widget (needed to + * set up X resources). */ + Tk_ConfigSpec *specs; /* Describes legal options. */ + int argc; /* Number of elements in argv. */ + char **argv; /* Command-line options. */ + char *widgRec; /* Record whose fields are to be + * modified. Values must be properly + * initialized. */ + int flags; /* Used to specify additional flags + * that must be present in config specs + * for them to be considered. Also, + * may have TK_CONFIG_ARGV_ONLY set. */ +{ + register Tk_ConfigSpec *specPtr; + Tk_Uid value; /* Value of option from database. */ + int needFlags; /* Specs must contain this set of flags + * or else they are not considered. */ + int hateFlags; /* If a spec contains any bits here, it's + * not considered. */ + + needFlags = flags & ~(TK_CONFIG_USER_BIT - 1); + if (Tk_Depth(tkwin) <= 1) { + hateFlags = TK_CONFIG_COLOR_ONLY; + } else { + hateFlags = TK_CONFIG_MONO_ONLY; + } + + /* + * Pass one: scan through all the option specs, replacing strings + * with Tk_Uids (if this hasn't been done already) and clearing + * the TK_CONFIG_OPTION_SPECIFIED flags. + */ + + for (specPtr = specs; specPtr->type != TK_CONFIG_END; specPtr++) { + if (!(specPtr->specFlags & INIT) && (specPtr->argvName != NULL)) { + if (specPtr->dbName != NULL) { + specPtr->dbName = Tk_GetUid(specPtr->dbName); + } + if (specPtr->dbClass != NULL) { + specPtr->dbClass = Tk_GetUid(specPtr->dbClass); + } + if (specPtr->defValue != NULL) { + specPtr->defValue = Tk_GetUid(specPtr->defValue); + } + } + specPtr->specFlags = (specPtr->specFlags & ~TK_CONFIG_OPTION_SPECIFIED) + | INIT; + } + + /* + * Pass two: scan through all of the arguments, processing those + * that match entries in the specs. + */ + + for ( ; argc > 0; argc -= 2, argv += 2) { + specPtr = FindConfigSpec(interp, specs, *argv, needFlags, hateFlags); + if (specPtr == NULL) { + return TCL_ERROR; + } + + /* + * Process the entry. + */ + + if (argc < 2) { + Tcl_AppendResult(interp, "value for \"", *argv, + "\" missing", (char *) NULL); + return TCL_ERROR; + } + if (DoConfig(interp, tkwin, specPtr, argv[1], 0, widgRec) != TCL_OK) { + char msg[100]; + + sprintf(msg, "\n (processing \"%.40s\" option)", + specPtr->argvName); + Tcl_AddErrorInfo(interp, msg); + return TCL_ERROR; + } + specPtr->specFlags |= TK_CONFIG_OPTION_SPECIFIED; + } + + /* + * Pass three: scan through all of the specs again; if no + * command-line argument matched a spec, then check for info + * in the option database. If there was nothing in the + * database, then use the default. + */ + + if (!(flags & TK_CONFIG_ARGV_ONLY)) { + for (specPtr = specs; specPtr->type != TK_CONFIG_END; specPtr++) { + if ((specPtr->specFlags & TK_CONFIG_OPTION_SPECIFIED) + || (specPtr->argvName == NULL) + || (specPtr->type == TK_CONFIG_SYNONYM)) { + continue; + } + if (((specPtr->specFlags & needFlags) != needFlags) + || (specPtr->specFlags & hateFlags)) { + continue; + } + value = NULL; + if (specPtr->dbName != NULL) { + value = Tk_GetOption(tkwin, specPtr->dbName, specPtr->dbClass); + } + if (value != NULL) { + if (DoConfig(interp, tkwin, specPtr, value, 1, widgRec) != + TCL_OK) { + char msg[200]; + + sprintf(msg, "\n (%s \"%.50s\" in widget \"%.50s\")", + "database entry for", + specPtr->dbName, Tk_PathName(tkwin)); + Tcl_AddErrorInfo(interp, msg); + return TCL_ERROR; + } + } else { + value = specPtr->defValue; + if ((value != NULL) && !(specPtr->specFlags + & TK_CONFIG_DONT_SET_DEFAULT)) { + if (DoConfig(interp, tkwin, specPtr, value, 1, widgRec) != + TCL_OK) { + char msg[200]; + + sprintf(msg, + "\n (%s \"%.50s\" in widget \"%.50s\")", + "default value for", + specPtr->dbName, Tk_PathName(tkwin)); + Tcl_AddErrorInfo(interp, msg); + return TCL_ERROR; + } + } + } + } + } + + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * FindConfigSpec -- + * + * Search through a table of configuration specs, looking for + * one that matches a given argvName. + * + * Results: + * The return value is a pointer to the matching entry, or NULL + * if nothing matched. In that case an error message is left + * in the interp's result. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static Tk_ConfigSpec * +FindConfigSpec(interp, specs, argvName, needFlags, hateFlags) + Tcl_Interp *interp; /* Used for reporting errors. */ + Tk_ConfigSpec *specs; /* Pointer to table of configuration + * specifications for a widget. */ + char *argvName; /* Name (suitable for use in a "config" + * command) identifying particular option. */ + int needFlags; /* Flags that must be present in matching + * entry. */ + int hateFlags; /* Flags that must NOT be present in + * matching entry. */ +{ + register Tk_ConfigSpec *specPtr; + register char c; /* First character of current argument. */ + Tk_ConfigSpec *matchPtr; /* Matching spec, or NULL. */ + size_t length; + + c = argvName[1]; + length = strlen(argvName); + matchPtr = NULL; + for (specPtr = specs; specPtr->type != TK_CONFIG_END; specPtr++) { + if (specPtr->argvName == NULL) { + continue; + } + if ((specPtr->argvName[1] != c) + || (strncmp(specPtr->argvName, argvName, length) != 0)) { + continue; + } + if (((specPtr->specFlags & needFlags) != needFlags) + || (specPtr->specFlags & hateFlags)) { + continue; + } + if (specPtr->argvName[length] == 0) { + matchPtr = specPtr; + goto gotMatch; + } + if (matchPtr != NULL) { + Tcl_AppendResult(interp, "ambiguous option \"", argvName, + "\"", (char *) NULL); + return (Tk_ConfigSpec *) NULL; + } + matchPtr = specPtr; + } + + if (matchPtr == NULL) { + Tcl_AppendResult(interp, "unknown option \"", argvName, + "\"", (char *) NULL); + return (Tk_ConfigSpec *) NULL; + } + + /* + * Found a matching entry. If it's a synonym, then find the + * entry that it's a synonym for. + */ + + gotMatch: + specPtr = matchPtr; + if (specPtr->type == TK_CONFIG_SYNONYM) { + for (specPtr = specs; ; specPtr++) { + if (specPtr->type == TK_CONFIG_END) { + Tcl_AppendResult(interp, + "couldn't find synonym for option \"", + argvName, "\"", (char *) NULL); + return (Tk_ConfigSpec *) NULL; + } + if ((specPtr->dbName == matchPtr->dbName) + && (specPtr->type != TK_CONFIG_SYNONYM) + && ((specPtr->specFlags & needFlags) == needFlags) + && !(specPtr->specFlags & hateFlags)) { + break; + } + } + } + return specPtr; +} + +/* + *-------------------------------------------------------------- + * + * DoConfig -- + * + * This procedure applies a single configuration option + * to a widget record. + * + * Results: + * A standard Tcl return value. + * + * Side effects: + * WidgRec is modified as indicated by specPtr and value. + * The old value is recycled, if that is appropriate for + * the value type. + * + *-------------------------------------------------------------- + */ + +static int +DoConfig(interp, tkwin, specPtr, value, valueIsUid, widgRec) + Tcl_Interp *interp; /* Interpreter for error reporting. */ + Tk_Window tkwin; /* Window containing widget (needed to + * set up X resources). */ + Tk_ConfigSpec *specPtr; /* Specifier to apply. */ + char *value; /* Value to use to fill in widgRec. */ + int valueIsUid; /* Non-zero means value is a Tk_Uid; + * zero means it's an ordinary string. */ + char *widgRec; /* Record whose fields are to be + * modified. Values must be properly + * initialized. */ +{ + char *ptr; + Tk_Uid uid; + int nullValue; + + nullValue = 0; + if ((*value == 0) && (specPtr->specFlags & TK_CONFIG_NULL_OK)) { + nullValue = 1; + } + + do { + ptr = widgRec + specPtr->offset; + switch (specPtr->type) { + case TK_CONFIG_BOOLEAN: + if (Tcl_GetBoolean(interp, value, (int *) ptr) != TCL_OK) { + return TCL_ERROR; + } + break; + case TK_CONFIG_INT: + if (Tcl_GetInt(interp, value, (int *) ptr) != TCL_OK) { + return TCL_ERROR; + } + break; + case TK_CONFIG_DOUBLE: + if (Tcl_GetDouble(interp, value, (double *) ptr) != TCL_OK) { + return TCL_ERROR; + } + break; + case TK_CONFIG_STRING: { + char *old, *new; + + if (nullValue) { + new = NULL; + } else { + new = (char *) ckalloc((unsigned) (strlen(value) + 1)); + strcpy(new, value); + } + old = *((char **) ptr); + if (old != NULL) { + ckfree(old); + } + *((char **) ptr) = new; + break; + } + case TK_CONFIG_UID: + if (nullValue) { + *((Tk_Uid *) ptr) = NULL; + } else { + uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value); + *((Tk_Uid *) ptr) = uid; + } + break; + case TK_CONFIG_COLOR: { + XColor *newPtr, *oldPtr; + + if (nullValue) { + newPtr = NULL; + } else { + uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value); + newPtr = Tk_GetColor(interp, tkwin, uid); + if (newPtr == NULL) { + return TCL_ERROR; + } + } + oldPtr = *((XColor **) ptr); + if (oldPtr != NULL) { + Tk_FreeColor(oldPtr); + } + *((XColor **) ptr) = newPtr; + break; + } + case TK_CONFIG_FONT: { + Tk_Font new; + + if (nullValue) { + new = NULL; + } else { + new = Tk_GetFont(interp, tkwin, value); + if (new == NULL) { + return TCL_ERROR; + } + } + Tk_FreeFont(*((Tk_Font *) ptr)); + *((Tk_Font *) ptr) = new; + break; + } + case TK_CONFIG_BITMAP: { + Pixmap new, old; + + if (nullValue) { + new = None; + } else { + uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value); + new = Tk_GetBitmap(interp, tkwin, uid); + if (new == None) { + return TCL_ERROR; + } + } + old = *((Pixmap *) ptr); + if (old != None) { + Tk_FreeBitmap(Tk_Display(tkwin), old); + } + *((Pixmap *) ptr) = new; + break; + } + case TK_CONFIG_BORDER: { + Tk_3DBorder new, old; + + if (nullValue) { + new = NULL; + } else { + uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value); + new = Tk_Get3DBorder(interp, tkwin, uid); + if (new == NULL) { + return TCL_ERROR; + } + } + old = *((Tk_3DBorder *) ptr); + if (old != NULL) { + Tk_Free3DBorder(old); + } + *((Tk_3DBorder *) ptr) = new; + break; + } + case TK_CONFIG_RELIEF: + uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value); + if (Tk_GetRelief(interp, uid, (int *) ptr) != TCL_OK) { + return TCL_ERROR; + } + break; + case TK_CONFIG_CURSOR: + case TK_CONFIG_ACTIVE_CURSOR: { + Tk_Cursor new, old; + + if (nullValue) { + new = None; + } else { + uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value); + new = Tk_GetCursor(interp, tkwin, uid); + if (new == None) { + return TCL_ERROR; + } + } + old = *((Tk_Cursor *) ptr); + if (old != None) { + Tk_FreeCursor(Tk_Display(tkwin), old); + } + *((Tk_Cursor *) ptr) = new; + if (specPtr->type == TK_CONFIG_ACTIVE_CURSOR) { + Tk_DefineCursor(tkwin, new); + } + break; + } + case TK_CONFIG_JUSTIFY: + uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value); + if (Tk_GetJustify(interp, uid, (Tk_Justify *) ptr) != TCL_OK) { + return TCL_ERROR; + } + break; + case TK_CONFIG_ANCHOR: + uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value); + if (Tk_GetAnchor(interp, uid, (Tk_Anchor *) ptr) != TCL_OK) { + return TCL_ERROR; + } + break; + case TK_CONFIG_CAP_STYLE: + uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value); + if (Tk_GetCapStyle(interp, uid, (int *) ptr) != TCL_OK) { + return TCL_ERROR; + } + break; + case TK_CONFIG_JOIN_STYLE: + uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value); + if (Tk_GetJoinStyle(interp, uid, (int *) ptr) != TCL_OK) { + return TCL_ERROR; + } + break; + case TK_CONFIG_PIXELS: + if (Tk_GetPixels(interp, tkwin, value, (int *) ptr) + != TCL_OK) { + return TCL_ERROR; + } + break; + case TK_CONFIG_MM: + if (Tk_GetScreenMM(interp, tkwin, value, (double *) ptr) + != TCL_OK) { + return TCL_ERROR; + } + break; + case TK_CONFIG_WINDOW: { + Tk_Window tkwin2; + + if (nullValue) { + tkwin2 = NULL; + } else { + tkwin2 = Tk_NameToWindow(interp, value, tkwin); + if (tkwin2 == NULL) { + return TCL_ERROR; + } + } + *((Tk_Window *) ptr) = tkwin2; + break; + } + case TK_CONFIG_CUSTOM: + if ((*specPtr->customPtr->parseProc)( + specPtr->customPtr->clientData, interp, tkwin, + value, widgRec, specPtr->offset) != TCL_OK) { + return TCL_ERROR; + } + break; + default: { + char buf[64 + TCL_INTEGER_SPACE]; + + sprintf(buf, "bad config table: unknown type %d", + specPtr->type); + Tcl_SetResult(interp, buf, TCL_VOLATILE); + return TCL_ERROR; + } + } + specPtr++; + } while ((specPtr->argvName == NULL) && (specPtr->type != TK_CONFIG_END)); + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * Tk_ConfigureInfo -- + * + * Return information about the configuration options + * for a window, and their current values. + * + * Results: + * Always returns TCL_OK. The interp's result will be modified + * hold a description of either a single configuration option + * available for "widgRec" via "specs", or all the configuration + * options available. In the "all" case, the result will + * available for "widgRec" via "specs". The result will + * be a list, each of whose entries describes one option. + * Each entry will itself be a list containing the option's + * name for use on command lines, database name, database + * class, default value, and current value (empty string + * if none). For options that are synonyms, the list will + * contain only two values: name and synonym name. If the + * "name" argument is non-NULL, then the only information + * returned is that for the named argument (i.e. the corresponding + * entry in the overall list is returned). + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +int +Tk_ConfigureInfo(interp, tkwin, specs, widgRec, argvName, flags) + Tcl_Interp *interp; /* Interpreter for error reporting. */ + Tk_Window tkwin; /* Window corresponding to widgRec. */ + Tk_ConfigSpec *specs; /* Describes legal options. */ + char *widgRec; /* Record whose fields contain current + * values for options. */ + char *argvName; /* If non-NULL, indicates a single option + * whose info is to be returned. Otherwise + * info is returned for all options. */ + int flags; /* Used to specify additional flags + * that must be present in config specs + * for them to be considered. */ +{ + register Tk_ConfigSpec *specPtr; + int needFlags, hateFlags; + char *list; + char *leader = "{"; + + needFlags = flags & ~(TK_CONFIG_USER_BIT - 1); + if (Tk_Depth(tkwin) <= 1) { + hateFlags = TK_CONFIG_COLOR_ONLY; + } else { + hateFlags = TK_CONFIG_MONO_ONLY; + } + + /* + * If information is only wanted for a single configuration + * spec, then handle that one spec specially. + */ + + Tcl_SetResult(interp, (char *) NULL, TCL_STATIC); + if (argvName != NULL) { + specPtr = FindConfigSpec(interp, specs, argvName, needFlags, + hateFlags); + if (specPtr == NULL) { + return TCL_ERROR; + } + Tcl_SetResult(interp, + FormatConfigInfo(interp, tkwin, specPtr, widgRec), + TCL_DYNAMIC); + return TCL_OK; + } + + /* + * Loop through all the specs, creating a big list with all + * their information. + */ + + for (specPtr = specs; specPtr->type != TK_CONFIG_END; specPtr++) { + if ((argvName != NULL) && (specPtr->argvName != argvName)) { + continue; + } + if (((specPtr->specFlags & needFlags) != needFlags) + || (specPtr->specFlags & hateFlags)) { + continue; + } + if (specPtr->argvName == NULL) { + continue; + } + list = FormatConfigInfo(interp, tkwin, specPtr, widgRec); + Tcl_AppendResult(interp, leader, list, "}", (char *) NULL); + ckfree(list); + leader = " {"; + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * FormatConfigInfo -- + * + * Create a valid Tcl list holding the configuration information + * for a single configuration option. + * + * Results: + * A Tcl list, dynamically allocated. The caller is expected to + * arrange for this list to be freed eventually. + * + * Side effects: + * Memory is allocated. + * + *-------------------------------------------------------------- + */ + +static char * +FormatConfigInfo(interp, tkwin, specPtr, widgRec) + Tcl_Interp *interp; /* Interpreter to use for things + * like floating-point precision. */ + Tk_Window tkwin; /* Window corresponding to widget. */ + register Tk_ConfigSpec *specPtr; /* Pointer to information describing + * option. */ + char *widgRec; /* Pointer to record holding current + * values of info for widget. */ +{ + char *argv[6], *result; + char buffer[200]; + Tcl_FreeProc *freeProc = (Tcl_FreeProc *) NULL; + + argv[0] = specPtr->argvName; + argv[1] = specPtr->dbName; + argv[2] = specPtr->dbClass; + argv[3] = specPtr->defValue; + if (specPtr->type == TK_CONFIG_SYNONYM) { + return Tcl_Merge(2, argv); + } + argv[4] = FormatConfigValue(interp, tkwin, specPtr, widgRec, buffer, + &freeProc); + if (argv[1] == NULL) { + argv[1] = ""; + } + if (argv[2] == NULL) { + argv[2] = ""; + } + if (argv[3] == NULL) { + argv[3] = ""; + } + if (argv[4] == NULL) { + argv[4] = ""; + } + result = Tcl_Merge(5, argv); + if (freeProc != NULL) { + if ((freeProc == TCL_DYNAMIC) || (freeProc == (Tcl_FreeProc *) free)) { + ckfree(argv[4]); + } else { + (*freeProc)(argv[4]); + } + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * FormatConfigValue -- + * + * This procedure formats the current value of a configuration + * option. + * + * Results: + * The return value is the formatted value of the option given + * by specPtr and widgRec. If the value is static, so that it + * need not be freed, *freeProcPtr will be set to NULL; otherwise + * *freeProcPtr will be set to the address of a procedure to + * free the result, and the caller must invoke this procedure + * when it is finished with the result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static char * +FormatConfigValue(interp, tkwin, specPtr, widgRec, buffer, freeProcPtr) + Tcl_Interp *interp; /* Interpreter for use in real conversions. */ + Tk_Window tkwin; /* Window corresponding to widget. */ + Tk_ConfigSpec *specPtr; /* Pointer to information describing option. + * Must not point to a synonym option. */ + char *widgRec; /* Pointer to record holding current + * values of info for widget. */ + char *buffer; /* Static buffer to use for small values. + * Must have at least 200 bytes of storage. */ + Tcl_FreeProc **freeProcPtr; /* Pointer to word to fill in with address + * of procedure to free the result, or NULL + * if result is static. */ +{ + char *ptr, *result; + + *freeProcPtr = NULL; + ptr = widgRec + specPtr->offset; + result = ""; + switch (specPtr->type) { + case TK_CONFIG_BOOLEAN: + if (*((int *) ptr) == 0) { + result = "0"; + } else { + result = "1"; + } + break; + case TK_CONFIG_INT: + sprintf(buffer, "%d", *((int *) ptr)); + result = buffer; + break; + case TK_CONFIG_DOUBLE: + Tcl_PrintDouble(interp, *((double *) ptr), buffer); + result = buffer; + break; + case TK_CONFIG_STRING: + result = (*(char **) ptr); + if (result == NULL) { + result = ""; + } + break; + case TK_CONFIG_UID: { + Tk_Uid uid = *((Tk_Uid *) ptr); + if (uid != NULL) { + result = uid; + } + break; + } + case TK_CONFIG_COLOR: { + XColor *colorPtr = *((XColor **) ptr); + if (colorPtr != NULL) { + result = Tk_NameOfColor(colorPtr); + } + break; + } + case TK_CONFIG_FONT: { + Tk_Font tkfont = *((Tk_Font *) ptr); + if (tkfont != NULL) { + result = Tk_NameOfFont(tkfont); + } + break; + } + case TK_CONFIG_BITMAP: { + Pixmap pixmap = *((Pixmap *) ptr); + if (pixmap != None) { + result = Tk_NameOfBitmap(Tk_Display(tkwin), pixmap); + } + break; + } + case TK_CONFIG_BORDER: { + Tk_3DBorder border = *((Tk_3DBorder *) ptr); + if (border != NULL) { + result = Tk_NameOf3DBorder(border); + } + break; + } + case TK_CONFIG_RELIEF: + result = Tk_NameOfRelief(*((int *) ptr)); + break; + case TK_CONFIG_CURSOR: + case TK_CONFIG_ACTIVE_CURSOR: { + Tk_Cursor cursor = *((Tk_Cursor *) ptr); + if (cursor != None) { + result = Tk_NameOfCursor(Tk_Display(tkwin), cursor); + } + break; + } + case TK_CONFIG_JUSTIFY: + result = Tk_NameOfJustify(*((Tk_Justify *) ptr)); + break; + case TK_CONFIG_ANCHOR: + result = Tk_NameOfAnchor(*((Tk_Anchor *) ptr)); + break; + case TK_CONFIG_CAP_STYLE: + result = Tk_NameOfCapStyle(*((int *) ptr)); + break; + case TK_CONFIG_JOIN_STYLE: + result = Tk_NameOfJoinStyle(*((int *) ptr)); + break; + case TK_CONFIG_PIXELS: + sprintf(buffer, "%d", *((int *) ptr)); + result = buffer; + break; + case TK_CONFIG_MM: + Tcl_PrintDouble(interp, *((double *) ptr), buffer); + result = buffer; + break; + case TK_CONFIG_WINDOW: { + Tk_Window tkwin; + + tkwin = *((Tk_Window *) ptr); + if (tkwin != NULL) { + result = Tk_PathName(tkwin); + } + break; + } + case TK_CONFIG_CUSTOM: + result = (*specPtr->customPtr->printProc)( + specPtr->customPtr->clientData, tkwin, widgRec, + specPtr->offset, freeProcPtr); + break; + default: + result = "?? unknown type ??"; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_ConfigureValue -- + * + * This procedure returns the current value of a configuration + * option for a widget. + * + * Results: + * The return value is a standard Tcl completion code (TCL_OK or + * TCL_ERROR). The interp's result will be set to hold either the value + * of the option given by argvName (if TCL_OK is returned) or + * an error message (if TCL_ERROR is returned). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tk_ConfigureValue(interp, tkwin, specs, widgRec, argvName, flags) + Tcl_Interp *interp; /* Interpreter for error reporting. */ + Tk_Window tkwin; /* Window corresponding to widgRec. */ + Tk_ConfigSpec *specs; /* Describes legal options. */ + char *widgRec; /* Record whose fields contain current + * values for options. */ + char *argvName; /* Gives the command-line name for the + * option whose value is to be returned. */ + int flags; /* Used to specify additional flags + * that must be present in config specs + * for them to be considered. */ +{ + Tk_ConfigSpec *specPtr; + int needFlags, hateFlags; + + needFlags = flags & ~(TK_CONFIG_USER_BIT - 1); + if (Tk_Depth(tkwin) <= 1) { + hateFlags = TK_CONFIG_COLOR_ONLY; + } else { + hateFlags = TK_CONFIG_MONO_ONLY; + } + specPtr = FindConfigSpec(interp, specs, argvName, needFlags, hateFlags); + if (specPtr == NULL) { + return TCL_ERROR; + } + interp->result = FormatConfigValue(interp, tkwin, specPtr, widgRec, + interp->result, &interp->freeProc); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_FreeOptions -- + * + * Free up all resources associated with configuration options. + * + * Results: + * None. + * + * Side effects: + * Any resource in widgRec that is controlled by a configuration + * option (e.g. a Tk_3DBorder or XColor) is freed in the appropriate + * fashion. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +void +Tk_FreeOptions(specs, widgRec, display, needFlags) + Tk_ConfigSpec *specs; /* Describes legal options. */ + char *widgRec; /* Record whose fields contain current + * values for options. */ + Display *display; /* X display; needed for freeing some + * resources. */ + int needFlags; /* Used to specify additional flags + * that must be present in config specs + * for them to be considered. */ +{ + register Tk_ConfigSpec *specPtr; + char *ptr; + + for (specPtr = specs; specPtr->type != TK_CONFIG_END; specPtr++) { + if ((specPtr->specFlags & needFlags) != needFlags) { + continue; + } + ptr = widgRec + specPtr->offset; + switch (specPtr->type) { + case TK_CONFIG_STRING: + if (*((char **) ptr) != NULL) { + ckfree(*((char **) ptr)); + *((char **) ptr) = NULL; + } + break; + case TK_CONFIG_COLOR: + if (*((XColor **) ptr) != NULL) { + Tk_FreeColor(*((XColor **) ptr)); + *((XColor **) ptr) = NULL; + } + break; + case TK_CONFIG_FONT: + Tk_FreeFont(*((Tk_Font *) ptr)); + *((Tk_Font *) ptr) = NULL; + break; + case TK_CONFIG_BITMAP: + if (*((Pixmap *) ptr) != None) { + Tk_FreeBitmap(display, *((Pixmap *) ptr)); + *((Pixmap *) ptr) = None; + } + break; + case TK_CONFIG_BORDER: + if (*((Tk_3DBorder *) ptr) != NULL) { + Tk_Free3DBorder(*((Tk_3DBorder *) ptr)); + *((Tk_3DBorder *) ptr) = NULL; + } + break; + case TK_CONFIG_CURSOR: + case TK_CONFIG_ACTIVE_CURSOR: + if (*((Tk_Cursor *) ptr) != None) { + Tk_FreeCursor(display, *((Tk_Cursor *) ptr)); + *((Tk_Cursor *) ptr) = None; + } + } + } +} diff --git a/generic/tkOption.c b/generic/tkOption.c index b2bef64..3815f85 100644 --- a/generic/tkOption.c +++ b/generic/tkOption.c @@ -6,12 +6,12 @@ * with windows either by name or by class or both. * * Copyright (c) 1990-1994 The Regents of the University of California. - * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkOption.c 1.57 96/10/17 15:16:45 + * SCCS: @(#) tkOption.c 1.59 97/11/17 12:53:36 */ #include "tkPort.h" @@ -530,7 +530,7 @@ Tk_OptionCmd(clientData, interp, argc, argv) } value = Tk_GetOption(window, argv[3], argv[4]); if (value != NULL) { - interp->result = value; + Tcl_SetResult(interp, value, TCL_STATIC); } return TCL_OK; } else if ((c == 'r') && (strncmp(argv[1], "readfile", length) == 0)) { @@ -674,7 +674,7 @@ TkOptionClassChanged(winPtr) * Results: * The return value is the integer priority level corresponding * to string, or -1 if string doesn't point to a valid priority level. - * In this case, an error message is left in interp->result. + * In this case, an error message is left in the interp's result. * * Side effects: * None. @@ -734,7 +734,7 @@ ParsePriority(interp, string) * Results: * The return value is a standard Tcl return code. In the case of * an error in parsing string, TCL_ERROR will be returned and an - * error message will be left in interp->result. The memory at + * error message will be left in the interp's result. The memory at * string is totally trashed by this procedure. If you care about * its contents, make a copy before calling here. * @@ -797,8 +797,10 @@ AddFromString(interp, tkwin, string, priority) dst = name = src; while (*src != ':') { if ((*src == '\0') || (*src == '\n')) { - sprintf(interp->result, "missing colon on line %d", - lineNum); + char buf[32 + TCL_INTEGER_SPACE]; + + sprintf(buf, "missing colon on line %d", lineNum); + Tcl_SetResult(interp, buf, TCL_VOLATILE); return TCL_ERROR; } if ((src[0] == '\\') && (src[1] == '\n')) { @@ -830,7 +832,10 @@ AddFromString(interp, tkwin, string, priority) src++; } if (*src == '\0') { - sprintf(interp->result, "missing value on line %d", lineNum); + char buf[32 + TCL_INTEGER_SPACE]; + + sprintf(buf, "missing value on line %d", lineNum); + Tcl_SetResult(interp, buf, TCL_VOLATILE); return TCL_ERROR; } @@ -842,8 +847,10 @@ AddFromString(interp, tkwin, string, priority) dst = value = src; while (*src != '\n') { if (*src == '\0') { - sprintf(interp->result, "missing newline on line %d", - lineNum); + char buf[32 + TCL_INTEGER_SPACE]; + + sprintf(buf, "missing newline on line %d", lineNum); + Tcl_SetResult(interp, buf, TCL_VOLATILE); return TCL_ERROR; } if ((src[0] == '\\') && (src[1] == '\n')) { @@ -879,7 +886,7 @@ AddFromString(interp, tkwin, string, priority) * Results: * The return value is a standard Tcl return code. In the case of * an error in parsing string, TCL_ERROR will be returned and an - * error message will be left in interp->result. + * error message will be left in the interp's result. * * Side effects: * None. diff --git a/generic/tkPack.c b/generic/tkPack.c index 4ff1049..2a7361c 100644 --- a/generic/tkPack.c +++ b/generic/tkPack.c @@ -5,12 +5,12 @@ * geometry manager for Tk. * * Copyright (c) 1990-1994 The Regents of the University of California. - * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkPack.c 1.64 96/05/03 10:51:52 + * SCCS: @(#) tkPack.c 1.65 97/11/07 21:17:36 */ #include "tkPort.h" @@ -281,7 +281,7 @@ Tk_PackCmd(clientData, interp, argc, argv) } else if ((c == 'i') && (strncmp(argv[1], "info", length) == 0)) { register Packer *slavePtr; Tk_Window slave; - char buffer[300]; + char buffer[64 + TCL_INTEGER_SPACE * 4]; static char *sideNames[] = {"top", "bottom", "left", "right"}; if (argc != 3) { @@ -342,9 +342,9 @@ Tk_PackCmd(clientData, interp, argc, argv) masterPtr = GetPacker(master); if (argc == 3) { if (masterPtr->flags & DONT_PROPAGATE) { - interp->result = "0"; + Tcl_SetResult(interp, "0", TCL_STATIC); } else { - interp->result = "1"; + Tcl_SetResult(interp, "1", TCL_STATIC); } return TCL_OK; } @@ -1398,7 +1398,7 @@ PackStructureProc(clientData, eventPtr) * * Results: * TCL_OK is returned if all went well. Otherwise, TCL_ERROR is - * returned and interp->result is set to contain an error message. + * returned and the interp's result is set to contain an error message. * * Side effects: * Slave windows get taken over by the packer. diff --git a/generic/tkPlace.c b/generic/tkPlace.c index 15ddcef..b3f8b08 100644 --- a/generic/tkPlace.c +++ b/generic/tkPlace.c @@ -5,12 +5,12 @@ * for Tk based on absolute placement or "rubber-sheet" placement. * * Copyright (c) 1992-1994 The Regents of the University of California. - * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkPlace.c 1.27 96/08/20 17:05:31 + * SCCS: @(#) tkPlace.c 1.28 97/11/07 21:17:41 */ #include "tkPort.h" @@ -243,7 +243,7 @@ Tk_PlaceCmd(clientData, interp, argc, argv) Tk_UnmapWindow(tkwin); ckfree((char *) slavePtr); } else if ((c == 'i') && (strncmp(argv[1], "info", length) == 0)) { - char buffer[50]; + char buffer[32 + TCL_INTEGER_SPACE]; if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", @@ -467,7 +467,7 @@ FindMaster(tkwin) * * Results: * A standard Tcl result. If an error occurs then a message is - * left in interp->result. + * left in the interp's result. * * Side effects: * Information in slavePtr may change, and slavePtr's master is diff --git a/generic/tkRectOval.c b/generic/tkRectOval.c index d1ba71c..5d2bd95 100644 --- a/generic/tkRectOval.c +++ b/generic/tkRectOval.c @@ -5,12 +5,12 @@ * widgets. * * Copyright (c) 1991-1994 The Regents of the University of California. - * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkRectOval.c 1.40 96/05/03 10:52:21 + * SCCS: @(#) tkRectOval.c 1.41 97/11/07 21:17:51 */ #include <stdio.h> @@ -157,7 +157,7 @@ Tk_ItemType tkOvalType = { * Results: * A standard Tcl return value. If an error occurred in * creating the item, then an error message is left in - * interp->result; in this case itemPtr is left uninitialized, + * the interp's result; in this case itemPtr is left uninitialized, * so it can be safely freed by the caller. * * Side effects: @@ -230,7 +230,7 @@ CreateRectOval(interp, canvas, itemPtr, argc, argv) * for details on what it does. * * Results: - * Returns TCL_OK or TCL_ERROR, and sets interp->result. + * Returns TCL_OK or TCL_ERROR, and sets the interp's result. * * Side effects: * The coordinates for the given item may be changed. @@ -273,9 +273,10 @@ RectOvalCoords(interp, canvas, itemPtr, argc, argv) } ComputeRectOvalBbox(canvas, rectOvalPtr); } else { - sprintf(interp->result, - "wrong # coordinates: expected 0 or 4, got %d", - argc); + char buf[64 + TCL_INTEGER_SPACE]; + + sprintf(buf, "wrong # coordinates: expected 0 or 4, got %d", argc); + Tcl_SetResult(interp, buf, TCL_VOLATILE); return TCL_ERROR; } return TCL_OK; @@ -292,7 +293,7 @@ RectOvalCoords(interp, canvas, itemPtr, argc, argv) * * Results: * A standard Tcl result code. If an error occurs, then - * an error message is left in interp->result. + * an error message is left in the interp's result. * * Side effects: * Configuration information, such as colors and stipple @@ -942,7 +943,7 @@ TranslateRectOval(canvas, itemPtr, deltaX, deltaY) * Results: * The return value is a standard Tcl result. If an error * occurs in generating Postscript then an error message is - * left in interp->result, replacing whatever used to be there. + * left in the interp's result, replacing whatever used to be there. * If no error occurs, then Postscript for the rectangle is * appended to the result. * @@ -962,7 +963,7 @@ RectOvalToPostscript(interp, canvas, itemPtr, prepass) * collect font information; 0 means * final Postscript is being created. */ { - char pathCmd[500], string[100]; + char pathCmd[500]; RectOvalItem *rectOvalPtr = (RectOvalItem *) itemPtr; double y1, y2; @@ -1016,6 +1017,8 @@ RectOvalToPostscript(interp, canvas, itemPtr, prepass) */ if (rectOvalPtr->outlineColor != NULL) { + char string[32 + TCL_INTEGER_SPACE]; + Tcl_AppendResult(interp, pathCmd, (char *) NULL); sprintf(string, "%d setlinewidth", rectOvalPtr->width); Tcl_AppendResult(interp, string, diff --git a/generic/tkScale.c b/generic/tkScale.c index 6c78150..ba75549 100644 --- a/generic/tkScale.c +++ b/generic/tkScale.c @@ -12,12 +12,12 @@ * permission. * * Copyright (c) 1990-1994 The Regents of the University of California. - * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkScale.c 1.88 97/07/31 09:11:57 + * SCCS: @(#) tkScale.c 1.89 97/11/07 21:20:16 */ #include "tkPort.h" @@ -261,7 +261,7 @@ Tk_ScaleCmd(clientData, interp, argc, argv) goto error; } - interp->result = Tk_PathName(scalePtr->tkwin); + Tcl_SetResult(interp, Tk_PathName(scalePtr->tkwin), TCL_STATIC); return TCL_OK; error: @@ -334,6 +334,7 @@ ScaleWidgetCmd(clientData, interp, argc, argv) && (length >= 3)) { int x, y ; double value; + char buf[TCL_INTEGER_SPACE * 2]; if ((argc != 2) && (argc != 3)) { Tcl_AppendResult(interp, "wrong # args: should be \"", @@ -356,10 +357,12 @@ ScaleWidgetCmd(clientData, interp, argc, argv) y = scalePtr->horizTroughY + scalePtr->width/2 + scalePtr->borderWidth; } - sprintf(interp->result, "%d %d", x, y); + sprintf(buf, "%d %d", x, y); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } else if ((c == 'g') && (strncmp(argv[1], "get", length) == 0)) { double value; int x, y; + char buf[TCL_DOUBLE_SPACE]; if ((argc != 2) && (argc != 4)) { Tcl_AppendResult(interp, "wrong # args: should be \"", @@ -375,7 +378,8 @@ ScaleWidgetCmd(clientData, interp, argc, argv) } value = TkpPixelToValue(scalePtr, x, y); } - sprintf(interp->result, scalePtr->format, value); + sprintf(buf, scalePtr->format, value); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } else if ((c == 'i') && (strncmp(argv[1], "identify", length) == 0)) { int x, y, thing; @@ -390,9 +394,15 @@ ScaleWidgetCmd(clientData, interp, argc, argv) } thing = TkpScaleElement(scalePtr, x,y); switch (thing) { - case TROUGH1: interp->result = "trough1"; break; - case SLIDER: interp->result = "slider"; break; - case TROUGH2: interp->result = "trough2"; break; + case TROUGH1: + Tcl_SetResult(interp, "trough1", TCL_STATIC); + break; + case SLIDER: + Tcl_SetResult(interp, "slider", TCL_STATIC); + break; + case TROUGH2: + Tcl_SetResult(interp, "trough2", TCL_STATIC); + break; } } else if ((c == 's') && (strncmp(argv[1], "set", length) == 0)) { double value; @@ -481,7 +491,7 @@ DestroyScale(memPtr) * * Results: * The return value is a standard Tcl result. If TCL_ERROR is - * returned, then interp->result contains an error message. + * returned, then the interp's result contains an error message. * * Side effects: * Configuration information, such as colors, border width, diff --git a/generic/tkScrollbar.c b/generic/tkScrollbar.c index 3025a78..fa0094a 100644 --- a/generic/tkScrollbar.c +++ b/generic/tkScrollbar.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkScrollbar.c 1.94 97/07/31 09:12:44 + * SCCS: @(#) tkScrollbar.c 1.95 97/11/07 21:18:28 */ #include "tkPort.h" @@ -193,7 +193,7 @@ Tk_ScrollbarCmd(clientData, interp, argc, argv) return TCL_ERROR; } - interp->result = Tk_PathName(scrollPtr->tkwin); + Tcl_SetResult(interp, Tk_PathName(scrollPtr->tkwin), TCL_STATIC); return TCL_OK; } @@ -240,9 +240,15 @@ ScrollbarWidgetCmd(clientData, interp, argc, argv) int oldActiveField; if (argc == 2) { switch (scrollPtr->activeField) { - case TOP_ARROW: interp->result = "arrow1"; break; - case SLIDER: interp->result = "slider"; break; - case BOTTOM_ARROW: interp->result = "arrow2"; break; + case TOP_ARROW: + Tcl_SetResult(interp, "arrow1", TCL_STATIC); + break; + case SLIDER: + Tcl_SetResult(interp, "slider", TCL_STATIC); + break; + case BOTTOM_ARROW: + Tcl_SetResult(interp, "arrow2", TCL_STATIC); + break; } goto done; } @@ -292,6 +298,7 @@ ScrollbarWidgetCmd(clientData, interp, argc, argv) } else if ((c == 'd') && (strncmp(argv[1], "delta", length) == 0)) { int xDelta, yDelta, pixels, length; double fraction; + char buf[TCL_DOUBLE_SPACE]; if (argc != 4) { Tcl_AppendResult(interp, "wrong # args: should be \"", @@ -316,10 +323,12 @@ ScrollbarWidgetCmd(clientData, interp, argc, argv) } else { fraction = ((double) pixels / (double) length); } - sprintf(interp->result, "%g", fraction); + sprintf(buf, "%g", fraction); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } else if ((c == 'f') && (strncmp(argv[1], "fraction", length) == 0)) { int x, y, pos, length; double fraction; + char buf[TCL_DOUBLE_SPACE]; if (argc != 4) { Tcl_AppendResult(interp, "wrong # args: should be \"", @@ -349,7 +358,8 @@ ScrollbarWidgetCmd(clientData, interp, argc, argv) } else if (fraction > 1.0) { fraction = 1.0; } - sprintf(interp->result, "%g", fraction); + sprintf(buf, "%g", fraction); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } else if ((c == 'g') && (strncmp(argv[1], "get", length) == 0)) { if (argc != 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", @@ -363,9 +373,12 @@ ScrollbarWidgetCmd(clientData, interp, argc, argv) Tcl_PrintDouble(interp, scrollPtr->lastFraction, last); Tcl_AppendResult(interp, first, " ", last, (char *) NULL); } else { - sprintf(interp->result, "%d %d %d %d", scrollPtr->totalUnits, + char buf[TCL_INTEGER_SPACE * 4]; + + sprintf(buf, "%d %d %d %d", scrollPtr->totalUnits, scrollPtr->windowUnits, scrollPtr->firstUnit, scrollPtr->lastUnit); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } } else if ((c == 'i') && (strncmp(argv[1], "identify", length) == 0)) { int x, y, thing; @@ -381,11 +394,21 @@ ScrollbarWidgetCmd(clientData, interp, argc, argv) } thing = TkpScrollbarPosition(scrollPtr, x,y); switch (thing) { - case TOP_ARROW: interp->result = "arrow1"; break; - case TOP_GAP: interp->result = "trough1"; break; - case SLIDER: interp->result = "slider"; break; - case BOTTOM_GAP: interp->result = "trough2"; break; - case BOTTOM_ARROW: interp->result = "arrow2"; break; + case TOP_ARROW: + Tcl_SetResult(interp, "arrow1", TCL_STATIC); + break; + case TOP_GAP: + Tcl_SetResult(interp, "trough1", TCL_STATIC); + break; + case SLIDER: + Tcl_SetResult(interp, "slider", TCL_STATIC); + break; + case BOTTOM_GAP: + Tcl_SetResult(interp, "trough2", TCL_STATIC); + break; + case BOTTOM_ARROW: + Tcl_SetResult(interp, "arrow2", TCL_STATIC); + break; } } else if ((c == 's') && (strncmp(argv[1], "set", length) == 0)) { int totalUnits, windowUnits, firstUnit, lastUnit; @@ -488,7 +511,7 @@ ScrollbarWidgetCmd(clientData, interp, argc, argv) * * Results: * The return value is a standard Tcl result. If TCL_ERROR is - * returned, then interp->result contains an error message. + * returned, then the interp's result contains an error message. * * Side effects: * Configuration information, such as colors, border width, diff --git a/generic/tkSelect.c b/generic/tkSelect.c index 7263e30..d43c121 100644 --- a/generic/tkSelect.c +++ b/generic/tkSelect.c @@ -6,12 +6,12 @@ * and Tcl commands. * * Copyright (c) 1990-1993 The Regents of the University of California. - * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkSelect.c 1.57 96/05/03 10:52:40 + * SCCS: @(#) tkSelect.c 1.58 97/11/07 21:17:56 */ #include "tkInt.h" @@ -431,7 +431,7 @@ Tk_ClearSelection(tkwin, selection) * 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 interp->result. + * then an error message is left in the interp's result. * * Side effects: * The standard X11 protocols are used to retrieve the @@ -457,7 +457,7 @@ Tk_ClearSelection(tkwin, selection) * the "portion" arguments in separate calls will contain * successive parts of the selection. Proc should normally * return TCL_OK. If it detects an error then it should return - * TCL_ERROR and leave an error message in interp->result; the + * TCL_ERROR and leave an error message in the interp's result; the * remainder of the selection retrieval will be aborted. * *-------------------------------------------------------------- @@ -602,9 +602,8 @@ Tk_SelectionCmd(clientData, interp, argc, argv) char **args; if (argc < 2) { - sprintf(interp->result, - "wrong # args: should be \"%.50s option ?arg arg ...?\"", - argv[0]); + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option ?arg arg ...?\"", (char *) NULL); return TCL_ERROR; } c = argv[1][0]; @@ -854,7 +853,7 @@ Tk_SelectionCmd(clientData, interp, argc, argv) if ((infoPtr != NULL) && (infoPtr->owner != winPtr->dispPtr->clipWindow)) { - interp->result = Tk_PathName(infoPtr->owner); + Tcl_SetResult(interp, Tk_PathName(infoPtr->owner), TCL_STATIC); } return TCL_OK; } @@ -878,9 +877,8 @@ Tk_SelectionCmd(clientData, interp, argc, argv) Tk_OwnSelection(tkwin, selection, LostSelection, (ClientData) lostPtr); return TCL_OK; } else { - sprintf(interp->result, - "bad option \"%.50s\": must be clear, get, handle, or own", - argv[1]); + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be clear, get, handle, or own", (char *) NULL); return TCL_ERROR; } } @@ -1155,11 +1153,12 @@ HandleTclCommand(clientData, offset, buffer, maxBytes) Tcl_DStringInit(&oldResult); Tcl_DStringGetResult(interp, &oldResult); if (TkCopyAndGlobalEval(interp, command) == TCL_OK) { - length = strlen(interp->result); + length = strlen(Tcl_GetStringResult(interp)); if (length > maxBytes) { length = maxBytes; } - memcpy((VOID *) buffer, (VOID *) interp->result, (size_t) length); + memcpy((VOID *) buffer, (VOID *) Tcl_GetStringResult(interp), + (size_t) length); buffer[length] = '\0'; } else { length = -1; @@ -1302,8 +1301,7 @@ LostSelection(clientData) ClientData clientData; /* Pointer to CommandInfo structure. */ { LostCommand *lostPtr = (LostCommand *) clientData; - char *oldResultString; - Tcl_FreeProc *oldFreeProc; + Tcl_Obj *objPtr; Tcl_Interp *interp; interp = lostPtr->interp; @@ -1314,22 +1312,16 @@ LostSelection(clientData) * restore it after executing the command. */ - oldFreeProc = interp->freeProc; - if (oldFreeProc != TCL_STATIC) { - oldResultString = interp->result; - } else { - oldResultString = (char *) ckalloc((unsigned) - (strlen(interp->result) + 1)); - strcpy(oldResultString, interp->result); - oldFreeProc = TCL_DYNAMIC; - } - interp->freeProc = TCL_STATIC; + objPtr = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(objPtr); + Tcl_ResetResult(interp); + if (TkCopyAndGlobalEval(interp, lostPtr->command) != TCL_OK) { Tcl_BackgroundError(interp); } - Tcl_FreeResult(interp); - interp->result = oldResultString; - interp->freeProc = oldFreeProc; + + Tcl_SetObjResult(interp, objPtr); + Tcl_DecrRefCount(objPtr); Tcl_Release((ClientData) interp); diff --git a/generic/tkSquare.c b/generic/tkSquare.c index eff8181..bdb9e29 100644 --- a/generic/tkSquare.c +++ b/generic/tkSquare.c @@ -1,23 +1,24 @@ /* * tkSquare.c -- * - * This module implements "square" widgets. A "square" is - * a widget that displays a single square that can be moved - * around and resized. This file is intended as an example + * This module implements "square" widgets that are object + * based. A "square" is a widget that displays a single square that can + * be moved around and resized. This file is intended as an example * of how to build a widget; it isn't included in the * normal wish, but it is included in "tktest". * - * Copyright (c) 1991-1994 The Regents of the University of California. - * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkSquare.c 1.19 97/07/31 09:13:13 + * SCCS: @(#) tkSquare.c 1.25 97/12/22 11:05:09 */ #include "tkPort.h" +#define __NO_OLD_CONFIG #include "tk.h" +#include "tkInt.h" /* * A data structure of the following type is kept for each square @@ -31,22 +32,24 @@ typedef struct { Display *display; /* X's token for the window's display. */ Tcl_Interp *interp; /* Interpreter associated with widget. */ Tcl_Command widgetCmd; /* Token for square's widget command. */ - int x, y; /* Position of square's upper-left corner + Tk_OptionTable optionTable; /* Token representing the configuration + * specifications. */ + Tcl_Obj *xPtr, *yPtr; /* Position of square's upper-left corner * within widget. */ - int size; /* Width and height of square. */ + int x, y; + Tcl_Obj *sizeObjPtr; /* Width and height of square. */ /* * Information used when displaying widget: */ - int borderWidth; /* Width of 3-D border around whole widget. */ - Tk_3DBorder bgBorder; /* Used for drawing background. */ - Tk_3DBorder fgBorder; /* For drawing square. */ - int relief; /* Indicates whether window as a whole is - * raised, sunken, or flat. */ + Tcl_Obj *borderWidthPtr; /* Width of 3-D border around whole widget. */ + Tcl_Obj *bgBorderPtr; + Tcl_Obj *fgBorderPtr; + Tcl_Obj *reliefPtr; GC gc; /* Graphics context for copying from * off-screen pixmap onto screen. */ - int doubleBuffer; /* Non-zero means double-buffer redisplay + Tcl_Obj *doubleBufferPtr; /* Non-zero means double-buffer redisplay * with pixmap; zero means draw straight * onto the display. */ int updatePending; /* Non-zero means a call to SquareDisplay @@ -57,49 +60,52 @@ typedef struct { * Information used for argv parsing. */ -static Tk_ConfigSpec configSpecs[] = { - {TK_CONFIG_BORDER, "-background", "background", "Background", - "#d9d9d9", Tk_Offset(Square, bgBorder), TK_CONFIG_COLOR_ONLY}, - {TK_CONFIG_BORDER, "-background", "background", "Background", - "white", Tk_Offset(Square, bgBorder), TK_CONFIG_MONO_ONLY}, - {TK_CONFIG_SYNONYM, "-bd", "borderWidth", (char *) NULL, - (char *) NULL, 0, 0}, - {TK_CONFIG_SYNONYM, "-bg", "background", (char *) NULL, - (char *) NULL, 0, 0}, - {TK_CONFIG_PIXELS, "-borderwidth", "borderWidth", "BorderWidth", - "2", Tk_Offset(Square, borderWidth), 0}, - {TK_CONFIG_INT, "-dbl", "doubleBuffer", "DoubleBuffer", - "1", Tk_Offset(Square, doubleBuffer), 0}, - {TK_CONFIG_SYNONYM, "-fg", "foreground", (char *) NULL, - (char *) NULL, 0, 0}, - {TK_CONFIG_BORDER, "-foreground", "foreground", "Foreground", - "#b03060", Tk_Offset(Square, fgBorder), TK_CONFIG_COLOR_ONLY}, - {TK_CONFIG_BORDER, "-foreground", "foreground", "Foreground", - "black", Tk_Offset(Square, fgBorder), TK_CONFIG_MONO_ONLY}, - {TK_CONFIG_RELIEF, "-relief", "relief", "Relief", - "raised", Tk_Offset(Square, relief), 0}, - {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, - (char *) NULL, 0, 0} +static Tk_OptionSpec configSpecs[] = { + {TK_OPTION_BORDER, "-background", "background", "Background", + "#d9d9d9", Tk_Offset(Square, bgBorderPtr), -1, 0, + (ClientData) "white"}, + {TK_OPTION_SYNONYM, "-bd", (char *) NULL, (char *) NULL, + (char *) NULL, 0, -1, 0, (ClientData) "-borderwidth"}, + {TK_OPTION_SYNONYM, "-bg", (char *) NULL, (char *) NULL, + (char *) NULL, 0, -1, 0, (ClientData) "-background"}, + {TK_OPTION_PIXELS, "-borderwidth", "borderWidth", "BorderWidth", + "2", Tk_Offset(Square, borderWidthPtr), -1}, + {TK_OPTION_BOOLEAN, "-dbl", "doubleBuffer", "DoubleBuffer", + "1", Tk_Offset(Square, doubleBufferPtr) -1,}, + {TK_OPTION_SYNONYM, "-fg", (char *) NULL, (char *) NULL, + (char *) NULL, 0, -1, 0, (ClientData) "-foreground"}, + {TK_OPTION_BORDER, "-foreground", "foreground", "Foreground", + "#b03060", Tk_Offset(Square, fgBorderPtr), -1, 0, + (ClientData) "black"}, + {TK_OPTION_PIXELS, "-posx", "posx", "PosX", "0", + Tk_Offset(Square, xPtr), -1}, + {TK_OPTION_PIXELS, "-posy", "posy", "PosY", "0", + Tk_Offset(Square, yPtr), -1}, + {TK_OPTION_RELIEF, "-relief", "relief", "Relief", + "raised", Tk_Offset(Square, reliefPtr), -1}, + {TK_OPTION_PIXELS, "-size", "size", "Size", "20", + Tk_Offset(Square, sizeObjPtr), -1}, + {TK_OPTION_END} }; /* * Forward declarations for procedures defined later in this file: */ -int SquareCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -static void SquareCmdDeletedProc _ANSI_ARGS_(( +int SquareObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj * CONST objv[])); +static void SquareDeletedProc _ANSI_ARGS_(( ClientData clientData)); static int SquareConfigure _ANSI_ARGS_((Tcl_Interp *interp, - Square *squarePtr, int argc, char **argv, - int flags)); + Square *squarePtr)); static void SquareDestroy _ANSI_ARGS_((char *memPtr)); static void SquareDisplay _ANSI_ARGS_((ClientData clientData)); static void KeepInWindow _ANSI_ARGS_((Square *squarePtr)); -static void SquareEventProc _ANSI_ARGS_((ClientData clientData, +static void SquareObjEventProc _ANSI_ARGS_((ClientData clientData, XEvent *eventPtr)); static int SquareWidgetCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *, int argc, char **argv)); + Tcl_Interp *, int objc, Tcl_Obj * CONST objv[])); /* *-------------------------------------------------------------- @@ -119,24 +125,41 @@ static int SquareWidgetCmd _ANSI_ARGS_((ClientData clientData, */ int -SquareCmd(clientData, interp, argc, argv) +SquareObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Main window associated with * interpreter. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj * CONST objv[]; /* Argument objects. */ { - Tk_Window main = (Tk_Window) clientData; Square *squarePtr; Tk_Window tkwin; + Tk_OptionTable optionTable = (Tk_OptionTable) clientData; + Tcl_CmdInfo info; + char *commandName; + + if (optionTable == NULL) { + /* + * The first time this procedure is invoked, optionTable will + * be NULL. We then create the option table from the template + * and store the table pointer as the command's clinical so + * we'll have easy access to it in the future. + */ + + optionTable = Tk_CreateOptionTable(interp, configSpecs); + commandName = Tcl_GetStringFromObj(objv[0], (int *) NULL); + Tcl_GetCommandInfo(interp, commandName, &info); + info.clientData = (ClientData) optionTable; + Tcl_SetCommandInfo(interp, commandName, &info); + } - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " pathName ?options?\"", (char *) NULL); + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "pathName ?options?"); return TCL_ERROR; } - tkwin = Tk_CreateWindowFromPath(interp, main, argv[1], (char *) NULL); + tkwin = Tk_CreateWindowFromPath(interp, Tk_MainWindow(interp), + Tcl_GetStringFromObj(objv[1], NULL), (char *) NULL); if (tkwin == NULL) { return TCL_ERROR; } @@ -150,29 +173,47 @@ SquareCmd(clientData, interp, argc, argv) squarePtr->tkwin = tkwin; squarePtr->display = Tk_Display(tkwin); squarePtr->interp = interp; - squarePtr->widgetCmd = Tcl_CreateCommand(interp, + squarePtr->widgetCmd = Tcl_CreateObjCommand(interp, Tk_PathName(squarePtr->tkwin), SquareWidgetCmd, - (ClientData) squarePtr, SquareCmdDeletedProc); + (ClientData) squarePtr, SquareDeletedProc); + squarePtr->xPtr = NULL; + squarePtr->yPtr = NULL; squarePtr->x = 0; squarePtr->y = 0; - squarePtr->size = 20; - squarePtr->borderWidth = 0; - squarePtr->bgBorder = NULL; - squarePtr->fgBorder = NULL; - squarePtr->relief = TK_RELIEF_FLAT; + squarePtr->sizeObjPtr = NULL; + squarePtr->borderWidthPtr = NULL; + squarePtr->bgBorderPtr = NULL; + squarePtr->fgBorderPtr = NULL; + squarePtr->reliefPtr = NULL; squarePtr->gc = None; - squarePtr->doubleBuffer = 1; + squarePtr->doubleBufferPtr = NULL; squarePtr->updatePending = 0; + squarePtr->optionTable = optionTable; - Tk_CreateEventHandler(squarePtr->tkwin, ExposureMask|StructureNotifyMask, - SquareEventProc, (ClientData) squarePtr); - if (SquareConfigure(interp, squarePtr, argc-2, argv+2, 0) != TCL_OK) { + if (Tk_InitOptions(interp, (char *) squarePtr, optionTable, tkwin) + != TCL_OK) { Tk_DestroyWindow(squarePtr->tkwin); + ckfree((char *) squarePtr); return TCL_ERROR; } - interp->result = Tk_PathName(squarePtr->tkwin); + Tk_CreateEventHandler(squarePtr->tkwin, ExposureMask|StructureNotifyMask, + SquareObjEventProc, (ClientData) squarePtr); + if (Tk_SetOptions(interp, (char *) squarePtr, optionTable, objc - 2, + objv + 2, tkwin, NULL, (int *) NULL) != TCL_OK) { + goto error; + } + if (SquareConfigure(interp, squarePtr) != TCL_OK) { + goto error; + } + + Tcl_SetObjResult(interp, Tcl_NewStringObj(Tk_PathName(squarePtr->tkwin), + -1)); return TCL_OK; + +error: + Tk_DestroyWindow(squarePtr->tkwin); + return TCL_ERROR; } /* @@ -194,92 +235,79 @@ SquareCmd(clientData, interp, argc, argv) */ static int -SquareWidgetCmd(clientData, interp, argc, argv) +SquareWidgetCmd(clientData, interp, objc, objv) ClientData clientData; /* Information about square widget. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj * CONST objv[]; /* Argument objects. */ { Square *squarePtr = (Square *) clientData; int result = TCL_OK; - size_t length; - char c; + static char *squareOptions[] = {"cget", "configure", (char *) NULL}; + enum { + SQUARE_CGET, SQUARE_CONFIGURE + }; + Tcl_Obj *resultObjPtr; + int index; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg...?"); + return TCL_ERROR; + } - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " option ?arg arg ...?\"", (char *) NULL); + if (Tcl_GetIndexFromObj(interp, objv[1], squareOptions, "command", + 0, &index) != TCL_OK) { return TCL_ERROR; } + Tcl_Preserve((ClientData) squarePtr); - c = argv[1][0]; - length = strlen(argv[1]); - if ((c == 'c') && (strncmp(argv[1], "cget", length) == 0) - && (length >= 2)) { - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " cget option\"", - (char *) NULL); - goto error; - } - result = Tk_ConfigureValue(interp, squarePtr->tkwin, configSpecs, - (char *) squarePtr, argv[2], 0); - } else if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0) - && (length >= 2)) { - if (argc == 2) { - result = Tk_ConfigureInfo(interp, squarePtr->tkwin, configSpecs, - (char *) squarePtr, (char *) NULL, 0); - } else if (argc == 3) { - result = Tk_ConfigureInfo(interp, squarePtr->tkwin, configSpecs, - (char *) squarePtr, argv[2], 0); - } else { - result = SquareConfigure(interp, squarePtr, argc-2, argv+2, - TK_CONFIG_ARGV_ONLY); - } - } else if ((c == 'p') && (strncmp(argv[1], "position", length) == 0)) { - if ((argc != 2) && (argc != 4)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " position ?x y?\"", (char *) NULL); - goto error; - } - if (argc == 4) { - if ((Tk_GetPixels(interp, squarePtr->tkwin, argv[2], - &squarePtr->x) != TCL_OK) || (Tk_GetPixels(interp, - squarePtr->tkwin, argv[3], &squarePtr->y) != TCL_OK)) { + + switch (index) { + case SQUARE_CGET: { + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "option"); goto error; } - KeepInWindow(squarePtr); - } - sprintf(interp->result, "%d %d", squarePtr->x, squarePtr->y); - } else if ((c == 's') && (strncmp(argv[1], "size", length) == 0)) { - if ((argc != 2) && (argc != 3)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " size ?amount?\"", (char *) NULL); - goto error; + resultObjPtr = Tk_GetOptionValue(interp, (char *) squarePtr, + squarePtr->optionTable, objv[2], squarePtr->tkwin); + if (resultObjPtr == NULL) { + result = TCL_ERROR; + } else { + Tcl_SetObjResult(interp, resultObjPtr); + } + break; } - if (argc == 3) { - int i; - - if (Tk_GetPixels(interp, squarePtr->tkwin, argv[2], &i) != TCL_OK) { - goto error; + case SQUARE_CONFIGURE: { + resultObjPtr = NULL; + if (objc == 2) { + resultObjPtr = Tk_GetOptionInfo(interp, (char *) squarePtr, + squarePtr->optionTable, (Tcl_Obj *) NULL, + squarePtr->tkwin); + if (resultObjPtr == NULL) { + result = TCL_ERROR; + } + } else if (objc == 3) { + resultObjPtr = Tk_GetOptionInfo(interp, (char *) squarePtr, + squarePtr->optionTable, objv[2], squarePtr->tkwin); + if (resultObjPtr == NULL) { + result = TCL_ERROR; + } + } else { + result = Tk_SetOptions(interp, (char *) squarePtr, + squarePtr->optionTable, objc - 2, objv + 2, + squarePtr->tkwin, NULL, (int *) NULL); + if (result == TCL_OK) { + result = SquareConfigure(interp, squarePtr); + } + if (!squarePtr->updatePending) { + Tcl_DoWhenIdle(SquareDisplay, (ClientData) squarePtr); + squarePtr->updatePending = 1; + } } - if ((i <= 0) || (i > 100)) { - Tcl_AppendResult(interp, "bad size \"", argv[2], - "\"", (char *) NULL); - goto error; + if (resultObjPtr != NULL) { + Tcl_SetObjResult(interp, resultObjPtr); } - squarePtr->size = i; - KeepInWindow(squarePtr); } - sprintf(interp->result, "%d", squarePtr->size); - } else { - Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be cget, configure, position, or size", - (char *) NULL); - goto error; - } - if (!squarePtr->updatePending) { - Tcl_DoWhenIdle(SquareDisplay, (ClientData) squarePtr); - squarePtr->updatePending = 1; } Tcl_Release((ClientData) squarePtr); return result; @@ -300,7 +328,7 @@ SquareWidgetCmd(clientData, interp, argc, argv) * * Results: * The return value is a standard Tcl result. If TCL_ERROR is - * returned, then interp->result contains an error message. + * returned, then the interp's result contains an error message. * * Side effects: * Configuration information, such as colors, border width, @@ -311,27 +339,25 @@ SquareWidgetCmd(clientData, interp, argc, argv) */ static int -SquareConfigure(interp, squarePtr, argc, argv, flags) +SquareConfigure(interp, squarePtr) Tcl_Interp *interp; /* Used for error reporting. */ Square *squarePtr; /* Information about widget. */ - int argc; /* Number of valid entries in argv. */ - char **argv; /* Arguments. */ - int flags; /* Flags to pass to - * Tk_ConfigureWidget. */ { - if (Tk_ConfigureWidget(interp, squarePtr->tkwin, configSpecs, - argc, argv, (char *) squarePtr, flags) != TCL_OK) { - return TCL_ERROR; - } + int borderWidth; + Tk_3DBorder bgBorder; + int doubleBuffer; /* * Set the background for the window and create a graphics context * for use during redisplay. */ + bgBorder = Tk_Get3DBorderFromObj(squarePtr->tkwin, + squarePtr->bgBorderPtr); Tk_SetWindowBackground(squarePtr->tkwin, - Tk_3DBorderColor(squarePtr->bgBorder)->pixel); - if ((squarePtr->gc == None) && (squarePtr->doubleBuffer)) { + Tk_3DBorderColor(bgBorder)->pixel); + Tcl_GetBooleanFromObj(NULL, squarePtr->doubleBufferPtr, &doubleBuffer); + if ((squarePtr->gc == None) && (doubleBuffer)) { XGCValues gcValues; gcValues.function = GXcopy; gcValues.graphics_exposures = False; @@ -345,18 +371,21 @@ SquareConfigure(interp, squarePtr, argc, argv, flags) */ Tk_GeometryRequest(squarePtr->tkwin, 200, 150); - Tk_SetInternalBorder(squarePtr->tkwin, squarePtr->borderWidth); + Tk_GetPixelsFromObj(NULL, squarePtr->tkwin, squarePtr->borderWidthPtr, + &borderWidth); + Tk_SetInternalBorder(squarePtr->tkwin, borderWidth); if (!squarePtr->updatePending) { Tcl_DoWhenIdle(SquareDisplay, (ClientData) squarePtr); squarePtr->updatePending = 1; } + KeepInWindow(squarePtr); return TCL_OK; } /* *-------------------------------------------------------------- * - * SquareEventProc -- + * SquareObjEventProc -- * * This procedure is invoked by the Tk dispatcher for various * events on squares. @@ -372,7 +401,7 @@ SquareConfigure(interp, squarePtr, argc, argv, flags) */ static void -SquareEventProc(clientData, eventPtr) +SquareObjEventProc(clientData, eventPtr) ClientData clientData; /* Information about window. */ XEvent *eventPtr; /* Information about event. */ { @@ -391,6 +420,11 @@ SquareEventProc(clientData, eventPtr) } } else if (eventPtr->type == DestroyNotify) { if (squarePtr->tkwin != NULL) { + Tk_FreeConfigOptions((char *) squarePtr, squarePtr->optionTable, + squarePtr->tkwin); + if (squarePtr->gc != None) { + Tk_FreeGC(squarePtr->display, squarePtr->gc); + } squarePtr->tkwin = NULL; Tcl_DeleteCommandFromToken(squarePtr->interp, squarePtr->widgetCmd); @@ -405,7 +439,7 @@ SquareEventProc(clientData, eventPtr) /* *---------------------------------------------------------------------- * - * SquareCmdDeletedProc -- + * SquareDeletedProc -- * * This procedure is invoked when a widget command is deleted. If * the widget isn't already in the process of being destroyed, @@ -421,7 +455,7 @@ SquareEventProc(clientData, eventPtr) */ static void -SquareCmdDeletedProc(clientData) +SquareDeletedProc(clientData) ClientData clientData; /* Pointer to widget record for widget. */ { Square *squarePtr = (Square *) clientData; @@ -435,7 +469,6 @@ SquareCmdDeletedProc(clientData) */ if (tkwin != NULL) { - squarePtr->tkwin = NULL; Tk_DestroyWindow(tkwin); } } @@ -466,6 +499,9 @@ SquareDisplay(clientData) Tk_Window tkwin = squarePtr->tkwin; Pixmap pm = None; Drawable d; + int borderWidth, size, relief; + Tk_3DBorder bgBorder, fgBorder; + int doubleBuffer; squarePtr->updatePending = 0; if (!Tk_IsMapped(tkwin)) { @@ -476,7 +512,8 @@ SquareDisplay(clientData) * Create a pixmap for double-buffering, if necessary. */ - if (squarePtr->doubleBuffer) { + Tcl_GetBooleanFromObj(NULL, squarePtr->doubleBufferPtr, &doubleBuffer); + if (doubleBuffer) { pm = Tk_GetPixmap(Tk_Display(tkwin), Tk_WindowId(tkwin), Tk_Width(tkwin), Tk_Height(tkwin), DefaultDepthOfScreen(Tk_Screen(tkwin))); @@ -489,22 +526,29 @@ SquareDisplay(clientData) * Redraw the widget's background and border. */ - Tk_Fill3DRectangle(tkwin, d, squarePtr->bgBorder, 0, 0, Tk_Width(tkwin), - Tk_Height(tkwin), squarePtr->borderWidth, squarePtr->relief); + Tk_GetPixelsFromObj(NULL, squarePtr->tkwin, squarePtr->borderWidthPtr, + &borderWidth); + bgBorder = Tk_Get3DBorderFromObj(squarePtr->tkwin, + squarePtr->bgBorderPtr); + Tk_GetReliefFromObj(NULL, squarePtr->reliefPtr, &relief); + Tk_Fill3DRectangle(tkwin, d, bgBorder, 0, 0, Tk_Width(tkwin), + Tk_Height(tkwin), borderWidth, relief); /* * Display the square. */ - Tk_Fill3DRectangle(tkwin, d, squarePtr->fgBorder, squarePtr->x, - squarePtr->y, squarePtr->size, squarePtr->size, - squarePtr->borderWidth, TK_RELIEF_RAISED); + Tk_GetPixelsFromObj(NULL, squarePtr->tkwin, squarePtr->sizeObjPtr, &size); + fgBorder = Tk_Get3DBorderFromObj(squarePtr->tkwin, + squarePtr->fgBorderPtr); + Tk_Fill3DRectangle(tkwin, d, fgBorder, squarePtr->x, squarePtr->y, size, + size, borderWidth, TK_RELIEF_RAISED); /* * If double-buffered, copy to the screen and release the pixmap. */ - if (squarePtr->doubleBuffer) { + if (doubleBuffer) { XCopyArea(Tk_Display(tkwin), pm, Tk_WindowId(tkwin), squarePtr->gc, 0, 0, (unsigned) Tk_Width(tkwin), (unsigned) Tk_Height(tkwin), 0, 0); @@ -535,11 +579,7 @@ SquareDestroy(memPtr) char *memPtr; /* Info about square widget. */ { Square *squarePtr = (Square *) memPtr; - - Tk_FreeOptions(configSpecs, (char *) squarePtr, squarePtr->display, 0); - if (squarePtr->gc != None) { - Tk_FreeGC(squarePtr->display, squarePtr->gc); - } + ckfree((char *) squarePtr); } @@ -565,16 +605,26 @@ static void KeepInWindow(squarePtr) register Square *squarePtr; /* Pointer to widget record. */ { - int i, bd; + int i, bd, relief; + int borderWidth, size; + + Tk_GetPixelsFromObj(NULL, squarePtr->tkwin, squarePtr->borderWidthPtr, + &borderWidth); + Tk_GetPixelsFromObj(NULL, squarePtr->tkwin, squarePtr->xPtr, + &squarePtr->x); + Tk_GetPixelsFromObj(NULL, squarePtr->tkwin, squarePtr->yPtr, + &squarePtr->y); + Tk_GetPixelsFromObj(NULL, squarePtr->tkwin, squarePtr->sizeObjPtr, &size); + Tk_GetReliefFromObj(NULL, squarePtr->reliefPtr, &relief); bd = 0; - if (squarePtr->relief != TK_RELIEF_FLAT) { - bd = squarePtr->borderWidth; + if (relief != TK_RELIEF_FLAT) { + bd = borderWidth; } - i = (Tk_Width(squarePtr->tkwin) - bd) - (squarePtr->x + squarePtr->size); + i = (Tk_Width(squarePtr->tkwin) - bd) - (squarePtr->x + size); if (i < 0) { squarePtr->x += i; } - i = (Tk_Height(squarePtr->tkwin) - bd) - (squarePtr->y + squarePtr->size); + i = (Tk_Height(squarePtr->tkwin) - bd) - (squarePtr->y + size); if (i < 0) { squarePtr->y += i; } diff --git a/generic/tkTest.c b/generic/tkTest.c index dab43d0..173e1b7 100644 --- a/generic/tkTest.c +++ b/generic/tkTest.c @@ -12,11 +12,12 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkTest.c 1.50 97/11/06 16:56:32 + * SCCS: @(#) tkTest.c 1.57 98/01/30 15:27:07 */ #include "tkInt.h" -#include "tkPort.h" +#include "tkPort.h" +#include "tkText.h" #ifdef __WIN32__ #include "tkWinInt.h" @@ -102,8 +103,8 @@ static NewApp *newAppPtr = NULL; * Declaration for the square widget's class command procedure: */ -extern int SquareCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char *argv[])); +extern int SquareObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[])); typedef struct CBinding { Tcl_Interp *interp; @@ -112,6 +113,32 @@ typedef struct CBinding { } CBinding; /* + * Header for trivial configuration command items. + */ + +#define ODD TK_CONFIG_USER_BIT +#define EVEN (TK_CONFIG_USER_BIT << 1) + +enum { + NONE, + ODD_TYPE, + EVEN_TYPE +}; + +typedef struct TrivialCommandHeader { + Tcl_Interp *interp; /* The interp that this command + * lives in. */ + Tk_OptionTable optionTable; /* The option table that go with + * this command. */ + Tk_Window tkwin; /* For widgets, the window associated + * with this widget. */ + Tcl_Command widgetCmd; /* For widgets, the command associated + * with this widget. */ +} TrivialCommandHeader; + + + +/* * Forward declarations for procedures defined later in this file: */ @@ -124,12 +151,23 @@ static int ImageCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); static int TestcbindCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); -#ifdef __WIN32__ -static int TestclipboardCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int argc, char **argv)); -#endif +static int TestbitmapObjCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj * CONST objv[])); +static int TestborderObjCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj * CONST objv[])); +static int TestcolorObjCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj * CONST objv[])); +static int TestcursorObjCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj * CONST objv[])); static int TestdeleteappsCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); +static int TestfontObjCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); static int TestmakeexistCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); static int TestmenubarCmd _ANSI_ARGS_((ClientData dummy, @@ -138,14 +176,26 @@ static int TestmenubarCmd _ANSI_ARGS_((ClientData dummy, static int TestmetricsCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); #endif +static int TestobjconfigObjCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj * CONST objv[])); +static int TestpropCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); static int TestsendCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); -static int TestpropCmd _ANSI_ARGS_((ClientData dummy, +static int TesttextCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); #if !(defined(__WIN32__) || defined(MAC_TCL)) static int TestwrapperCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); #endif +static void TrivialCmdDeletedProc _ANSI_ARGS_(( + ClientData clientData)); +static int TrivialConfigObjCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj * CONST objv[])); +static void TrivialEventProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); /* * External (platform specific) initialization routine: @@ -153,7 +203,7 @@ static int TestwrapperCmd _ANSI_ARGS_((ClientData dummy, EXTERN int TkplatformtestInit _ANSI_ARGS_(( Tcl_Interp *interp)); -#ifndef MAC_TCL +#if !(defined(__WIN32__) || defined(MAC_TCL)) #define TkplatformtestInit(x) TCL_OK #endif @@ -167,7 +217,7 @@ EXTERN int TkplatformtestInit _ANSI_ARGS_(( * * Results: * Returns a standard Tcl completion code, and leaves an error - * message in interp->result if an error occurs. + * message in the interp's result if an error occurs. * * Side effects: * Creates several test commands. @@ -189,18 +239,26 @@ Tktest_Init(interp) return TCL_ERROR; } - Tcl_CreateCommand(interp, "square", SquareCmd, + Tcl_CreateObjCommand(interp, "square", SquareObjCmd, + (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testcbind", TestcbindCmd, (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL); -#ifdef __WIN32__ - Tcl_CreateCommand(interp, "testclipboard", TestclipboardCmd, + Tcl_CreateObjCommand(interp, "testbitmap", TestbitmapObjCmd, (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL); -#endif - Tcl_CreateCommand(interp, "testcbind", TestcbindCmd, + Tcl_CreateObjCommand(interp, "testborder", TestborderObjCmd, + (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "testcolor", TestcolorObjCmd, + (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "testcursor", TestcursorObjCmd, (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testdeleteapps", TestdeleteappsCmd, (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testembed", TkpTestembedCmd, (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "testobjconfig", TestobjconfigObjCmd, + (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "testfont", TestfontObjCmd, + (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testmakeexist", TestmakeexistCmd, (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testmenubar", TestmenubarCmd, @@ -213,6 +271,8 @@ Tktest_Init(interp) (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testsend", TestsendCmd, (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testtext", TesttextCmd, + (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL); #if !(defined(__WIN32__) || defined(MAC_TCL)) Tcl_CreateCommand(interp, "testwrapper", TestwrapperCmd, (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL); @@ -237,48 +297,6 @@ Tktest_Init(interp) /* *---------------------------------------------------------------------- * - * TestclipboardCmd -- - * - * This procedure implements the testclipboard command. It provides - * a way to determine the actual contents of the Windows clipboard. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -#ifdef __WIN32__ -static int -TestclipboardCmd(clientData, interp, argc, argv) - ClientData clientData; /* Main window for application. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - TkWindow *winPtr = (TkWindow *) clientData; - HGLOBAL handle; - char *data; - - if (OpenClipboard(NULL)) { - handle = GetClipboardData(CF_TEXT); - if (handle != NULL) { - data = GlobalLock(handle); - Tcl_AppendResult(interp, data, (char *) NULL); - GlobalUnlock(handle); - } - CloseClipboard(); - } - return TCL_OK; -} -#endif - -/* - *---------------------------------------------------------------------- - * * TestcbindCmd -- * * This procedure implements the "testcbinding" command. It provides @@ -386,6 +404,146 @@ CBindingFreeProc(clientData) /* *---------------------------------------------------------------------- * + * TestbitmapObjCmd -- + * + * This procedure implements the "testbitmap" command, which is used + * to test color resource handling in tkBitmap tmp.c. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestbitmapObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Main window for application. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "bitmap"); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, TkDebugBitmap(Tk_MainWindow(interp), + Tcl_GetString(objv[1]))); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestborderObjCmd -- + * + * This procedure implements the "testborder" command, which is used + * to test color resource handling in tkBorder.c. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestborderObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Main window for application. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "border"); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, TkDebugBorder(Tk_MainWindow(interp), + Tcl_GetString(objv[1]))); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestcolorObjCmd -- + * + * This procedure implements the "testcolor" command, which is used + * to test color resource handling in tkColor.c. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestcolorObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Main window for application. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "color"); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, TkDebugColor(Tk_MainWindow(interp), + Tcl_GetString(objv[1]))); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestcursorObjCmd -- + * + * This procedure implements the "testcursor" command, which is used + * to test color resource handling in tkCursor.c. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestcursorObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Main window for application. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "cursor"); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, TkDebugCursor(Tk_MainWindow(interp), + Tcl_GetString(objv[1]))); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TestdeleteappsCmd -- * * This procedure implements the "testdeleteapps" command. It cleans @@ -424,6 +582,956 @@ TestdeleteappsCmd(clientData, interp, argc, argv) /* *---------------------------------------------------------------------- * + * TestobjconfigObjCmd -- + * + * This procedure implements the "testobjconfig" command, + * which is used to test the procedures in tkConfig.c. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestobjconfigObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Main window for application. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + static char *options[] = {"alltypes", "chain1", "chain2", + "configerror", "delete", "info", "internal", "new", + "notenoughparams", "twowindows", (char *) NULL}; + enum { + ALL_TYPES, + CHAIN1, + CHAIN2, + CONFIG_ERROR, + DEL, /* Can't use DELETE: VC++ compiler barfs. */ + INFO, + INTERNAL, + NEW, + NOT_ENOUGH_PARAMS, + TWO_WINDOWS + }; + static Tk_OptionTable tables[11]; /* Holds pointers to option tables + * created by commands below; indexed + * with same values as "options" + * array. */ + Tk_Window mainWin = (Tk_Window) clientData; + Tk_Window tkwin; + int index, result = TCL_OK; + + /* + * Structures used by the "chain1" subcommand and also shared by + * the "chain2" subcommand: + */ + + typedef struct ExtensionWidgetRecord { + TrivialCommandHeader header; + Tcl_Obj *base1ObjPtr; + Tcl_Obj *base2ObjPtr; + Tcl_Obj *extension3ObjPtr; + Tcl_Obj *extension4ObjPtr; + Tcl_Obj *extension5ObjPtr; + } ExtensionWidgetRecord; + static Tk_OptionSpec baseSpecs[] = { + {TK_OPTION_STRING, + "-one", "one", "One", "one", + Tk_Offset(ExtensionWidgetRecord, base1ObjPtr), -1}, + {TK_OPTION_STRING, + "-two", "two", "Two", "two", + Tk_Offset(ExtensionWidgetRecord, base2ObjPtr), -1}, + {TK_OPTION_END} + }; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "command"); + return TCL_ERROR; + } + + if (Tcl_GetIndexFromObj(interp, objv[1], options, "command", 0, &index) + != TCL_OK) { + return TCL_ERROR; + } + + switch (index) { + case ALL_TYPES: { + typedef struct TypesRecord { + TrivialCommandHeader header; + Tcl_Obj *booleanPtr; + Tcl_Obj *integerPtr; + Tcl_Obj *doublePtr; + Tcl_Obj *stringPtr; + Tcl_Obj *stringTablePtr; + Tcl_Obj *colorPtr; + Tcl_Obj *fontPtr; + Tcl_Obj *bitmapPtr; + Tcl_Obj *borderPtr; + Tcl_Obj *reliefPtr; + Tcl_Obj *cursorPtr; + Tcl_Obj *activeCursorPtr; + Tcl_Obj *justifyPtr; + Tcl_Obj *anchorPtr; + Tcl_Obj *pixelPtr; + Tcl_Obj *mmPtr; + } TypesRecord; + TypesRecord *recordPtr; + static char *stringTable[] = {"one", "two", "three", "four", + (char *) NULL}; + static Tk_OptionSpec typesSpecs[] = { + {TK_OPTION_BOOLEAN, + "-boolean", "boolean", "Boolean", + "1", Tk_Offset(TypesRecord, booleanPtr), -1, 0, 0, 0x1}, + {TK_OPTION_INT, + "-integer", "integer", "Integer", + "7", Tk_Offset(TypesRecord, integerPtr), -1, 0, 0, 0x2}, + {TK_OPTION_DOUBLE, + "-double", "double", "Double", + "3.14159", Tk_Offset(TypesRecord, doublePtr), -1, 0, 0, + 0x4}, + {TK_OPTION_STRING, + "-string", "string", "String", + "foo", Tk_Offset(TypesRecord, stringPtr), -1, + TK_CONFIG_NULL_OK, 0, 0x8}, + {TK_OPTION_STRING_TABLE, + "-stringtable", "StringTable", "stringTable", + "one", Tk_Offset(TypesRecord, stringTablePtr), -1, + TK_CONFIG_NULL_OK, (ClientData) stringTable, 0x10}, + {TK_OPTION_COLOR, + "-color", "color", "Color", + "red", Tk_Offset(TypesRecord, colorPtr), -1, + TK_CONFIG_NULL_OK, (ClientData) "black", 0x20}, + {TK_OPTION_FONT, + "-font", "font", "Font", + "Helvetica 12", + Tk_Offset(TypesRecord, fontPtr), -1, + TK_CONFIG_NULL_OK, 0, 0x40}, + {TK_OPTION_BITMAP, + "-bitmap", "bitmap", "Bitmap", + "gray50", + Tk_Offset(TypesRecord, bitmapPtr), -1, + TK_CONFIG_NULL_OK, 0, 0x80}, + {TK_OPTION_BORDER, + "-border", "border", "Border", + "blue", Tk_Offset(TypesRecord, borderPtr), -1, + TK_CONFIG_NULL_OK, (ClientData) "white", 0x100}, + {TK_OPTION_RELIEF, + "-relief", "relief", "Relief", + "raised", + Tk_Offset(TypesRecord, reliefPtr), -1, + TK_CONFIG_NULL_OK, 0, 0x200}, + {TK_OPTION_CURSOR, + "-cursor", "cursor", "Cursor", + "xterm", + Tk_Offset(TypesRecord, cursorPtr), -1, + TK_CONFIG_NULL_OK, 0, 0x400}, + {TK_OPTION_JUSTIFY, + "-justify", (char *) NULL, (char *) NULL, + "left", + Tk_Offset(TypesRecord, justifyPtr), -1, + TK_CONFIG_NULL_OK, 0, 0x800}, + {TK_OPTION_ANCHOR, + "-anchor", "anchor", "Anchor", + (char *) NULL, + Tk_Offset(TypesRecord, anchorPtr), -1, + TK_CONFIG_NULL_OK, 0, 0x1000}, + {TK_OPTION_PIXELS, + "-pixel", "pixel", "Pixel", + "1", Tk_Offset(TypesRecord, pixelPtr), -1, + TK_CONFIG_NULL_OK, 0, 0x2000}, + {TK_OPTION_SYNONYM, + "-synonym", (char *) NULL, (char *) NULL, + (char *) NULL, 0, -1, 0, (ClientData) "-color", + 0x8000}, + {TK_OPTION_END} + }; + Tk_OptionTable optionTable; + Tk_Window tkwin; + optionTable = Tk_CreateOptionTable(interp, + typesSpecs); + tables[index] = optionTable; + tkwin = Tk_CreateWindowFromPath(interp, (Tk_Window) clientData, + Tcl_GetStringFromObj(objv[2], NULL), (char *) NULL); + if (tkwin == NULL) { + return TCL_ERROR; + } + Tk_SetClass(tkwin, "Test"); + + recordPtr = (TypesRecord *) ckalloc(sizeof(TypesRecord)); + recordPtr->header.interp = interp; + recordPtr->header.optionTable = optionTable; + recordPtr->header.tkwin = tkwin; + recordPtr->booleanPtr = NULL; + recordPtr->integerPtr = NULL; + recordPtr->doublePtr = NULL; + recordPtr->stringPtr = NULL; + recordPtr->colorPtr = NULL; + recordPtr->fontPtr = NULL; + recordPtr->bitmapPtr = NULL; + recordPtr->borderPtr = NULL; + recordPtr->reliefPtr = NULL; + recordPtr->cursorPtr = NULL; + recordPtr->justifyPtr = NULL; + recordPtr->anchorPtr = NULL; + recordPtr->pixelPtr = NULL; + recordPtr->mmPtr = NULL; + recordPtr->stringTablePtr = NULL; + result = Tk_InitOptions(interp, (char *) recordPtr, optionTable, + tkwin); + if (result == TCL_OK) { + recordPtr->header.widgetCmd = Tcl_CreateObjCommand(interp, + Tcl_GetStringFromObj(objv[2], NULL), + TrivialConfigObjCmd, (ClientData) recordPtr, + TrivialCmdDeletedProc); + Tk_CreateEventHandler(tkwin, StructureNotifyMask, + TrivialEventProc, (ClientData) recordPtr); + result = Tk_SetOptions(interp, (char *) recordPtr, + optionTable, objc - 3, objv + 3, tkwin, + (Tk_SavedOptions *) NULL, (int *) NULL); + if (result != TCL_OK) { + Tk_DestroyWindow(tkwin); + } + } else { + Tk_DestroyWindow(tkwin); + ckfree((char *) recordPtr); + } + if (result == TCL_OK) { + Tcl_SetObjResult(interp, objv[2]); + } + break; + } + + case CHAIN1: { + ExtensionWidgetRecord *recordPtr; + Tk_Window tkwin; + Tk_OptionTable optionTable; + + tkwin = Tk_CreateWindowFromPath(interp, (Tk_Window) clientData, + Tcl_GetStringFromObj(objv[2], NULL), (char *) NULL); + if (tkwin == NULL) { + return TCL_ERROR; + } + Tk_SetClass(tkwin, "Test"); + optionTable = Tk_CreateOptionTable(interp, baseSpecs); + tables[index] = optionTable; + + recordPtr = (ExtensionWidgetRecord *) ckalloc( + sizeof(ExtensionWidgetRecord)); + recordPtr->header.interp = interp; + recordPtr->header.optionTable = optionTable; + recordPtr->header.tkwin = tkwin; + recordPtr->base1ObjPtr = recordPtr->base2ObjPtr = NULL; + recordPtr->extension3ObjPtr = recordPtr->extension4ObjPtr = NULL; + result = Tk_InitOptions(interp, (char *) recordPtr, optionTable, + tkwin); + if (result == TCL_OK) { + result = Tk_SetOptions(interp, (char *) recordPtr, optionTable, + objc - 3, objv + 3, tkwin, (Tk_SavedOptions *) NULL, + (int *) NULL); + if (result != TCL_OK) { + Tk_FreeConfigOptions((char *) recordPtr, optionTable, + tkwin); + } + } + if (result == TCL_OK) { + recordPtr->header.widgetCmd = Tcl_CreateObjCommand(interp, + Tcl_GetStringFromObj(objv[2], NULL), + TrivialConfigObjCmd, (ClientData) recordPtr, + TrivialCmdDeletedProc); + Tk_CreateEventHandler(tkwin, StructureNotifyMask, + TrivialEventProc, (ClientData) recordPtr); + Tcl_SetObjResult(interp, objv[2]); + } + break; + } + + case CHAIN2: { + ExtensionWidgetRecord *recordPtr; + static Tk_OptionSpec extensionSpecs[] = { + {TK_OPTION_STRING, + "-three", "three", "Three", "three", + Tk_Offset(ExtensionWidgetRecord, extension3ObjPtr), + -1}, + {TK_OPTION_STRING, + "-four", "four", "Four", "four", + Tk_Offset(ExtensionWidgetRecord, extension4ObjPtr), + -1}, + {TK_OPTION_STRING, + "-two", "two", "Two", "two and a half", + Tk_Offset(ExtensionWidgetRecord, base2ObjPtr), + -1}, + {TK_OPTION_STRING, + "-oneAgain", "oneAgain", "OneAgain", "one again", + Tk_Offset(ExtensionWidgetRecord, extension5ObjPtr), + -1}, + {TK_OPTION_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, -1, 0, (ClientData) baseSpecs} + }; + Tk_Window tkwin; + Tk_OptionTable optionTable; + + tkwin = Tk_CreateWindowFromPath(interp, (Tk_Window) clientData, + Tcl_GetStringFromObj(objv[2], NULL), (char *) NULL); + if (tkwin == NULL) { + return TCL_ERROR; + } + Tk_SetClass(tkwin, "Test"); + optionTable = Tk_CreateOptionTable(interp, extensionSpecs); + tables[index] = optionTable; + + recordPtr = (ExtensionWidgetRecord *) ckalloc( + sizeof(ExtensionWidgetRecord)); + recordPtr->header.interp = interp; + recordPtr->header.optionTable = optionTable; + recordPtr->header.tkwin = tkwin; + recordPtr->base1ObjPtr = recordPtr->base2ObjPtr = NULL; + recordPtr->extension3ObjPtr = recordPtr->extension4ObjPtr = NULL; + recordPtr->extension5ObjPtr = NULL; + result = Tk_InitOptions(interp, (char *) recordPtr, optionTable, + tkwin); + if (result == TCL_OK) { + result = Tk_SetOptions(interp, (char *) recordPtr, optionTable, + objc - 3, objv + 3, tkwin, (Tk_SavedOptions *) NULL, + (int *) NULL); + if (result != TCL_OK) { + Tk_FreeConfigOptions((char *) recordPtr, optionTable, + tkwin); + } + } + if (result == TCL_OK) { + recordPtr->header.widgetCmd = Tcl_CreateObjCommand(interp, + Tcl_GetStringFromObj(objv[2], NULL), + TrivialConfigObjCmd, (ClientData) recordPtr, + TrivialCmdDeletedProc); + Tk_CreateEventHandler(tkwin, StructureNotifyMask, + TrivialEventProc, (ClientData) recordPtr); + Tcl_SetObjResult(interp, objv[2]); + } + break; + } + + case CONFIG_ERROR: { + typedef struct ErrorWidgetRecord { + Tcl_Obj *intPtr; + } ErrorWidgetRecord; + ErrorWidgetRecord widgetRecord; + static Tk_OptionSpec errorSpecs[] = { + {TK_OPTION_INT, + "-int", "integer", "Integer", + "bogus", Tk_Offset(ErrorWidgetRecord, intPtr)}, + {TK_OPTION_END} + }; + Tk_OptionTable optionTable; + + widgetRecord.intPtr = NULL; + optionTable = Tk_CreateOptionTable(interp, errorSpecs); + tables[index] = optionTable; + return Tk_InitOptions(interp, (char *) &widgetRecord, optionTable, + (Tk_Window) NULL); + } + + case DEL: { + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "tableName"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[2], options, "table", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + if (tables[index] != NULL) { + Tk_DeleteOptionTable(tables[index]); + } + break; + } + + case INFO: { + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "tableName"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[2], options, "table", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, TkDebugConfig(interp, tables[index])); + break; + } + + case INTERNAL: { + /* + * This command is similar to the "alltypes" command except + * that it stores all the configuration options as internal + * forms instead of objects. + */ + + typedef struct InternalRecord { + TrivialCommandHeader header; + int boolean; + int integer; + double doubleValue; + char *string; + int index; + XColor *colorPtr; + Tk_Font tkfont; + Pixmap bitmap; + Tk_3DBorder border; + int relief; + Tk_Cursor cursor; + Tk_Justify justify; + Tk_Anchor anchor; + int pixels; + double mm; + Tk_Window tkwin; + } InternalRecord; + InternalRecord *recordPtr; + static char *internalStringTable[] = { + "one", "two", "three", "four", (char *) NULL + }; + static Tk_OptionSpec internalSpecs[] = { + {TK_OPTION_BOOLEAN, + "-boolean", "boolean", "Boolean", + "1", -1, Tk_Offset(InternalRecord, boolean), 0, 0, 0x1}, + {TK_OPTION_INT, + "-integer", "integer", "Integer", + "148962237", -1, Tk_Offset(InternalRecord, integer), + 0, 0, 0x2}, + {TK_OPTION_DOUBLE, + "-double", "double", "Double", + "3.14159", -1, Tk_Offset(InternalRecord, doubleValue), + 0, 0, 0x4}, + {TK_OPTION_STRING, + "-string", "string", "String", + "foo", -1, Tk_Offset(InternalRecord, string), + TK_CONFIG_NULL_OK, 0, 0x8}, + {TK_OPTION_STRING_TABLE, + "-stringtable", "StringTable", "stringTable", + "one", -1, Tk_Offset(InternalRecord, index), + TK_CONFIG_NULL_OK, (ClientData) internalStringTable, + 0x10}, + {TK_OPTION_COLOR, + "-color", "color", "Color", + "red", -1, Tk_Offset(InternalRecord, colorPtr), + TK_CONFIG_NULL_OK, (ClientData) "black", 0x20}, + {TK_OPTION_FONT, + "-font", "font", "Font", + "Helvetica 12", -1, Tk_Offset(InternalRecord, tkfont), + TK_CONFIG_NULL_OK, 0, 0x40}, + {TK_OPTION_BITMAP, + "-bitmap", "bitmap", "Bitmap", + "gray50", -1, Tk_Offset(InternalRecord, bitmap), + TK_CONFIG_NULL_OK, 0, 0x80}, + {TK_OPTION_BORDER, + "-border", "border", "Border", + "blue", -1, Tk_Offset(InternalRecord, border), + TK_CONFIG_NULL_OK, (ClientData) "white", 0x100}, + {TK_OPTION_RELIEF, + "-relief", "relief", "Relief", + "raised", -1, Tk_Offset(InternalRecord, relief), + TK_CONFIG_NULL_OK, 0, 0x200}, + {TK_OPTION_CURSOR, + "-cursor", "cursor", "Cursor", + "xterm", -1, Tk_Offset(InternalRecord, cursor), + TK_CONFIG_NULL_OK, 0, 0x400}, + {TK_OPTION_JUSTIFY, + "-justify", (char *) NULL, (char *) NULL, + "left", -1, Tk_Offset(InternalRecord, justify), + TK_CONFIG_NULL_OK, 0, 0x800}, + {TK_OPTION_ANCHOR, + "-anchor", "anchor", "Anchor", + (char *) NULL, -1, Tk_Offset(InternalRecord, anchor), + TK_CONFIG_NULL_OK, 0, 0x1000}, + {TK_OPTION_PIXELS, + "-pixel", "pixel", "Pixel", + "1", -1, Tk_Offset(InternalRecord, pixels), + TK_CONFIG_NULL_OK, 0, 0x2000}, + {TK_OPTION_WINDOW, + "-window", "window", "Window", + (char *) NULL, -1, Tk_Offset(InternalRecord, tkwin), + TK_CONFIG_NULL_OK, 0, 0}, + {TK_OPTION_SYNONYM, + "-synonym", (char *) NULL, (char *) NULL, + (char *) NULL, -1, -1, 0, (ClientData) "-color", + 0x8000}, + {TK_OPTION_END} + }; + Tk_OptionTable optionTable; + Tk_Window tkwin; + optionTable = Tk_CreateOptionTable(interp, internalSpecs); + tables[index] = optionTable; + tkwin = Tk_CreateWindowFromPath(interp, (Tk_Window) clientData, + Tcl_GetStringFromObj(objv[2], NULL), (char *) NULL); + if (tkwin == NULL) { + return TCL_ERROR; + } + Tk_SetClass(tkwin, "Test"); + + recordPtr = (InternalRecord *) ckalloc(sizeof(InternalRecord)); + recordPtr->header.interp = interp; + recordPtr->header.optionTable = optionTable; + recordPtr->header.tkwin = tkwin; + recordPtr->boolean = 0; + recordPtr->integer = 0; + recordPtr->doubleValue = 0.0; + recordPtr->string = NULL; + recordPtr->index = 0; + recordPtr->colorPtr = NULL; + recordPtr->tkfont = NULL; + recordPtr->bitmap = None; + recordPtr->border = NULL; + recordPtr->relief = TK_RELIEF_FLAT; + recordPtr->cursor = NULL; + recordPtr->justify = TK_JUSTIFY_LEFT; + recordPtr->anchor = TK_ANCHOR_N; + recordPtr->pixels = 0; + recordPtr->mm = 0.0; + recordPtr->tkwin = NULL; + result = Tk_InitOptions(interp, (char *) recordPtr, optionTable, + tkwin); + if (result == TCL_OK) { + recordPtr->header.widgetCmd = Tcl_CreateObjCommand(interp, + Tcl_GetStringFromObj(objv[2], NULL), + TrivialConfigObjCmd, (ClientData) recordPtr, + TrivialCmdDeletedProc); + Tk_CreateEventHandler(tkwin, StructureNotifyMask, + TrivialEventProc, (ClientData) recordPtr); + result = Tk_SetOptions(interp, (char *) recordPtr, + optionTable, objc - 3, objv + 3, tkwin, + (Tk_SavedOptions *) NULL, (int *) NULL); + if (result != TCL_OK) { + Tk_DestroyWindow(tkwin); + } + } else { + Tk_DestroyWindow(tkwin); + ckfree((char *) recordPtr); + } + if (result == TCL_OK) { + Tcl_SetObjResult(interp, objv[2]); + } + break; + } + + case NEW: { + typedef struct FiveRecord { + TrivialCommandHeader header; + Tcl_Obj *one; + Tcl_Obj *two; + Tcl_Obj *three; + Tcl_Obj *four; + Tcl_Obj *five; + } FiveRecord; + FiveRecord *recordPtr; + static Tk_OptionSpec smallSpecs[] = { + {TK_OPTION_INT, + "-one", "one", "One", + "1", + Tk_Offset(FiveRecord, one), -1}, + {TK_OPTION_INT, + "-two", "two", "Two", + "2", + Tk_Offset(FiveRecord, two), -1}, + {TK_OPTION_INT, + "-three", "three", "Three", + "3", + Tk_Offset(FiveRecord, three), -1}, + {TK_OPTION_INT, + "-four", "four", "Four", + "4", + Tk_Offset(FiveRecord, four), -1}, + {TK_OPTION_STRING, + "-five", NULL, NULL, + NULL, + Tk_Offset(FiveRecord, five), -1}, + {TK_OPTION_END} + }; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "new name ?options?"); + return TCL_ERROR; + } + + recordPtr = (FiveRecord *) ckalloc(sizeof(FiveRecord)); + recordPtr->header.interp = interp; + recordPtr->header.optionTable = Tk_CreateOptionTable(interp, + smallSpecs); + tables[index] = recordPtr->header.optionTable; + recordPtr->header.tkwin = NULL; + recordPtr->one = recordPtr->two = recordPtr->three = NULL; + recordPtr->four = recordPtr->five = NULL; + Tcl_SetObjResult(interp, objv[2]); + result = Tk_InitOptions(interp, (char *) recordPtr, + recordPtr->header.optionTable, (Tk_Window) NULL); + if (result == TCL_OK) { + result = Tk_SetOptions(interp, (char *) recordPtr, + recordPtr->header.optionTable, objc - 3, objv + 3, + (Tk_Window) NULL, (Tk_SavedOptions *) NULL, + (int *) NULL); + if (result == TCL_OK) { + recordPtr->header.widgetCmd = Tcl_CreateObjCommand(interp, + Tcl_GetStringFromObj(objv[2], NULL), + TrivialConfigObjCmd, (ClientData) recordPtr, + TrivialCmdDeletedProc); + } else { + Tk_FreeConfigOptions((char *) recordPtr, + recordPtr->header.optionTable, (Tk_Window) NULL); + } + } + if (result != TCL_OK) { + ckfree((char *) recordPtr); + } + + break; + } + case NOT_ENOUGH_PARAMS: { + typedef struct NotEnoughRecord { + Tcl_Obj *fooObjPtr; + } NotEnoughRecord; + NotEnoughRecord record; + static Tk_OptionSpec errorSpecs[] = { + {TK_OPTION_INT, + "-foo", "foo", "Foo", + "0", Tk_Offset(NotEnoughRecord, fooObjPtr)}, + {TK_OPTION_END} + }; + Tcl_Obj *newObjPtr = Tcl_NewStringObj("-foo", -1); + Tk_OptionTable optionTable; + + record.fooObjPtr = NULL; + + tkwin = Tk_CreateWindowFromPath(interp, mainWin, + ".config", (char *) NULL); + Tk_SetClass(tkwin, "Config"); + optionTable = Tk_CreateOptionTable(interp, errorSpecs); + tables[index] = optionTable; + Tk_InitOptions(interp, (char *) &record, optionTable, tkwin); + if (Tk_SetOptions(interp, (char *) &record, optionTable, + 1, &newObjPtr, tkwin, (Tk_SavedOptions *) NULL, + (int *) NULL) + != TCL_OK) { + result = TCL_ERROR; + } + Tcl_DecrRefCount(newObjPtr); + Tk_FreeConfigOptions( (char *) &record, optionTable, tkwin); + Tk_DestroyWindow(tkwin); + return result; + } + + case TWO_WINDOWS: { + typedef struct SlaveRecord { + TrivialCommandHeader header; + Tcl_Obj *windowPtr; + } SlaveRecord; + SlaveRecord *recordPtr; + static Tk_OptionSpec slaveSpecs[] = { + {TK_OPTION_WINDOW, + "-window", "window", "Window", + ".bar", Tk_Offset(SlaveRecord, windowPtr), -1, + TK_CONFIG_NULL_OK}, + {TK_OPTION_END} + }; + Tk_Window tkwin = Tk_CreateWindowFromPath(interp, + (Tk_Window) clientData, + Tcl_GetStringFromObj(objv[2], NULL), (char *) NULL); + if (tkwin == NULL) { + return TCL_ERROR; + } + Tk_SetClass(tkwin, "Test"); + + recordPtr = (SlaveRecord *) ckalloc(sizeof(SlaveRecord)); + recordPtr->header.interp = interp; + recordPtr->header.optionTable = Tk_CreateOptionTable(interp, + slaveSpecs); + tables[index] = recordPtr->header.optionTable; + recordPtr->header.tkwin = tkwin; + recordPtr->windowPtr = NULL; + + result = Tk_InitOptions(interp, (char *) recordPtr, + recordPtr->header.optionTable, tkwin); + if (result == TCL_OK) { + result = Tk_SetOptions(interp, (char *) recordPtr, + recordPtr->header.optionTable, objc - 3, objv + 3, + tkwin, (Tk_SavedOptions *) NULL, (int *) NULL); + if (result == TCL_OK) { + recordPtr->header.widgetCmd = Tcl_CreateObjCommand(interp, + Tcl_GetStringFromObj(objv[2], NULL), + TrivialConfigObjCmd, (ClientData) recordPtr, + TrivialCmdDeletedProc); + Tk_CreateEventHandler(tkwin, StructureNotifyMask, + TrivialEventProc, (ClientData) recordPtr); + Tcl_SetObjResult(interp, objv[2]); + } else { + Tk_FreeConfigOptions((char *) recordPtr, + recordPtr->header.optionTable, tkwin); + } + } + if (result != TCL_OK) { + Tk_DestroyWindow(tkwin); + ckfree((char *) recordPtr); + } + + } + } + + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TrivialConfigObjCmd -- + * + * This command is used to test the configuration package. It only + * handles the "configure" and "cget" subcommands. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TrivialConfigObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Main window for application. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + int result = TCL_OK; + static char *options[] = {"cget", "configure", "csave", (char *) NULL}; + enum { + CGET, CONFIGURE, CSAVE + }; + Tcl_Obj *resultObjPtr; + int index, mask; + TrivialCommandHeader *headerPtr = (TrivialCommandHeader *) clientData; + Tk_Window tkwin = headerPtr->tkwin; + Tk_SavedOptions saved; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg...?"); + return TCL_ERROR; + } + + if (Tcl_GetIndexFromObj(interp, objv[1], options, "command", + 0, &index) != TCL_OK) { + return TCL_ERROR; + } + + Tcl_Preserve(clientData); + + switch (index) { + case CGET: { + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "option"); + result = TCL_ERROR; + goto done; + } + resultObjPtr = Tk_GetOptionValue(interp, (char *) clientData, + headerPtr->optionTable, objv[2], tkwin); + if (resultObjPtr != NULL) { + Tcl_SetObjResult(interp, resultObjPtr); + result = TCL_OK; + } else { + result = TCL_ERROR; + } + break; + } + case CONFIGURE: { + if (objc == 2) { + resultObjPtr = Tk_GetOptionInfo(interp, (char *) clientData, + headerPtr->optionTable, (Tcl_Obj *) NULL, tkwin); + if (resultObjPtr == NULL) { + result = TCL_ERROR; + } else { + Tcl_SetObjResult(interp, resultObjPtr); + } + } else if (objc == 3) { + resultObjPtr = Tk_GetOptionInfo(interp, (char *) clientData, + headerPtr->optionTable, objv[2], tkwin); + if (resultObjPtr == NULL) { + result = TCL_ERROR; + } else { + Tcl_SetObjResult(interp, resultObjPtr); + } + } else { + result = Tk_SetOptions(interp, (char *) clientData, + headerPtr->optionTable, objc - 2, objv + 2, + tkwin, (Tk_SavedOptions *) NULL, &mask); + if (result == TCL_OK) { + Tcl_SetIntObj(Tcl_GetObjResult(interp), mask); + } + } + break; + } + case CSAVE: { + result = Tk_SetOptions(interp, (char *) clientData, + headerPtr->optionTable, objc - 2, objv + 2, + tkwin, &saved, &mask); + Tk_FreeSavedOptions(&saved); + if (result == TCL_OK) { + Tcl_SetIntObj(Tcl_GetObjResult(interp), mask); + } + break; + } + } +done: + Tcl_Release(clientData); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TrivialCmdDeletedProc -- + * + * This procedure is invoked when a widget command is deleted. If + * the widget isn't already in the process of being destroyed, + * this command destroys it. + * + * Results: + * None. + * + * Side effects: + * The widget is destroyed. + * + *---------------------------------------------------------------------- + */ + +static void +TrivialCmdDeletedProc(clientData) + ClientData clientData; /* Pointer to widget record for widget. */ +{ + TrivialCommandHeader *headerPtr = (TrivialCommandHeader *) clientData; + Tk_Window tkwin = headerPtr->tkwin; + + if (tkwin != NULL) { + Tk_DestroyWindow(tkwin); + } else if (headerPtr->optionTable != NULL) { + /* + * This is a "new" object, which doesn't have a window, so + * we can't depend on cleaning up in the event procedure. + * Free its resources here. + */ + + Tk_FreeConfigOptions((char *) clientData, + headerPtr->optionTable, (Tk_Window) NULL); + Tcl_EventuallyFree(clientData, TCL_DYNAMIC); + } +} + +/* + *-------------------------------------------------------------- + * + * TrivialEventProc -- + * + * A dummy event proc. + * + * Results: + * None. + * + * Side effects: + * When the window gets deleted, internal structures get + * cleaned up. + * + *-------------------------------------------------------------- + */ + +static void +TrivialEventProc(clientData, eventPtr) + ClientData clientData; /* Information about window. */ + XEvent *eventPtr; /* Information about event. */ +{ + TrivialCommandHeader *headerPtr = (TrivialCommandHeader *) clientData; + + if (eventPtr->type == DestroyNotify) { + if (headerPtr->tkwin != NULL) { + Tk_FreeConfigOptions((char *) clientData, + headerPtr->optionTable, headerPtr->tkwin); + headerPtr->optionTable = NULL; + headerPtr->tkwin = NULL; + Tcl_DeleteCommandFromToken(headerPtr->interp, + headerPtr->widgetCmd); + } + Tcl_EventuallyFree(clientData, TCL_DYNAMIC); + } +} + +/* + *---------------------------------------------------------------------- + * + * TestfontObjCmd -- + * + * This procedure implements the "testfont" command, which is used + * to test TkFont objects. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestfontObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Main window for application. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + static char *options[] = {"counts", "subfonts", (char *) NULL}; + enum option {COUNTS, SUBFONTS}; + int index; + Tk_Window tkwin; + Tk_Font tkfont; + + tkwin = (Tk_Window) clientData; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "option fontName"); + return TCL_ERROR; + } + + if (Tcl_GetIndexFromObj(interp, objv[1], options, "command", 0, &index) + != TCL_OK) { + return TCL_ERROR; + } + + switch ((enum option) index) { + case COUNTS: { + Tcl_SetObjResult(interp, TkDebugFont(Tk_MainWindow(interp), + Tcl_GetString(objv[2]))); + break; + } + case SUBFONTS: { + tkfont = Tk_AllocFontFromObj(interp, tkwin, objv[2]); + if (tkfont == NULL) { + return TCL_ERROR; + } + TkpGetSubFonts(interp, tkfont); + Tk_FreeFont(tkfont); + break; + } + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * ImageCreate -- * * This procedure is called by the Tk image code to create "test" @@ -523,7 +1631,8 @@ ImageCmd(clientData, interp, argc, argv) if (strcmp(argv[1], "changed") == 0) { if (argc != 8) { Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " changed x y width height imageWidth imageHeight", + argv[0], + " changed x y width height imageWidth imageHeight", (char *) NULL); return TCL_ERROR; } @@ -617,7 +1726,7 @@ ImageDisplay(clientData, display, drawable, imageX, imageY, width, height, * imageX and imageY. */ { TImageInstance *instPtr = (TImageInstance *) clientData; - char buffer[200]; + char buffer[200 + TCL_INTEGER_SPACE * 6]; sprintf(buffer, "%s display %d %d %d %d %d %d", instPtr->masterPtr->imageName, imageX, imageY, width, height, @@ -734,12 +1843,12 @@ TestmakeexistCmd(clientData, interp, argc, argv) int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { - Tk_Window main = (Tk_Window) clientData; + Tk_Window mainWin = (Tk_Window) clientData; int i; Tk_Window tkwin; for (i = 1; i < argc; i++) { - tkwin = Tk_NameToWindow(interp, argv[i], main); + tkwin = Tk_NameToWindow(interp, argv[i], mainWin); if (tkwin == NULL) { return TCL_ERROR; } @@ -776,7 +1885,7 @@ TestmenubarCmd(clientData, interp, argc, argv) char **argv; /* Argument strings. */ { #ifdef __UNIX__ - Tk_Window main = (Tk_Window) clientData; + Tk_Window mainWin = (Tk_Window) clientData; Tk_Window tkwin, menubar; if (argc < 2) { @@ -791,14 +1900,14 @@ TestmenubarCmd(clientData, interp, argc, argv) "window toplevel menubar\"", (char *) NULL); return TCL_ERROR; } - tkwin = Tk_NameToWindow(interp, argv[2], main); + tkwin = Tk_NameToWindow(interp, argv[2], mainWin); if (tkwin == NULL) { return TCL_ERROR; } if (argv[3][0] == 0) { TkUnixSetMenubar(tkwin, NULL); } else { - menubar = Tk_NameToWindow(interp, argv[3], main); + menubar = Tk_NameToWindow(interp, argv[3], mainWin); if (menubar == NULL) { return TCL_ERROR; } @@ -812,7 +1921,8 @@ TestmenubarCmd(clientData, interp, argc, argv) return TCL_OK; #else - interp->result = "testmenubar is supported only under Unix"; + Tcl_SetResult(interp, "testmenubar is supported only under Unix", + TCL_STATIC); return TCL_ERROR; #endif } @@ -842,7 +1952,7 @@ TestmetricsCmd(clientData, interp, argc, argv) int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { - char buf[200]; + char buf[TCL_INTEGER_SPACE]; if (argc < 2) { Tcl_AppendResult(interp, "wrong # args; must be \"", argv[0], @@ -874,7 +1984,7 @@ TestmetricsCmd(clientData, interp, argc, argv) { Tk_Window tkwin = (Tk_Window) clientData; TkWindow *winPtr; - char buf[200]; + char buf[TCL_INTEGER_SPACE]; if (argc != 3) { Tcl_AppendResult(interp, "wrong # args; must be \"", argv[0], @@ -927,7 +2037,7 @@ TestpropCmd(clientData, interp, argc, argv) int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { - Tk_Window main = (Tk_Window) clientData; + Tk_Window mainWin = (Tk_Window) clientData; int result, actualFormat; unsigned long bytesAfter, length, value; Atom actualType, propName; @@ -942,9 +2052,9 @@ TestpropCmd(clientData, interp, argc, argv) } w = strtoul(argv[1], &end, 0); - propName = Tk_InternAtom(main, argv[2]); + propName = Tk_InternAtom(mainWin, argv[2]); property = NULL; - result = XGetWindowProperty(Tk_Display(main), + result = XGetWindowProperty(Tk_Display(mainWin), w, propName, 0, 100000, False, AnyPropertyType, &actualType, &actualFormat, &length, &bytesAfter, (unsigned char **) &property); @@ -1005,7 +2115,9 @@ TestsendCmd(clientData, interp, argc, argv) int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { +#if !(defined(__WIN32__) || defined(MAC_TCL)) TkWindow *winPtr = (TkWindow *) clientData; +#endif if (argc < 2) { Tcl_AppendResult(interp, "wrong # args; must be \"", argv[0], @@ -1073,7 +2185,10 @@ TestsendCmd(clientData, interp, argc, argv) } } } else if (strcmp(argv[1], "serial") == 0) { - sprintf(interp->result, "%d", tkSendSerial+1); + char buf[TCL_INTEGER_SPACE]; + + sprintf(buf, "%d", tkSendSerial+1); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } else { Tcl_AppendResult(interp, "bad option \"", argv[1], "\": must be bogus, prop, or serial", (char *) NULL); @@ -1083,6 +2198,85 @@ TestsendCmd(clientData, interp, argc, argv) return TCL_OK; } +/* + *---------------------------------------------------------------------- + * + * TesttextCmd -- + * + * This procedure implements the "testtext" command. It provides + * a set of functions for testing text widgets and the associated + * functions in tkText*.c. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Depends on option; see below. + * + *---------------------------------------------------------------------- + */ + +static int +TesttextCmd(clientData, interp, argc, argv) + ClientData clientData; /* Main window for application. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + TkText *textPtr; + size_t len; + int lineIndex, byteIndex, byteOffset; + TkTextIndex index; + char buf[64]; + Tcl_CmdInfo info; + + if (argc < 3) { + return TCL_ERROR; + } + + if (Tcl_GetCommandInfo(interp, argv[1], &info) == 0) { + return TCL_ERROR; + } + textPtr = (TkText *) info.clientData; + len = strlen(argv[2]); + if (strncmp(argv[2], "byteindex", len) == 0) { + if (argc != 5) { + return TCL_ERROR; + } + lineIndex = atoi(argv[3]) - 1; + byteIndex = atoi(argv[4]); + + TkTextMakeByteIndex(textPtr->tree, lineIndex, byteIndex, &index); + } else if (strncmp(argv[2], "forwbytes", len) == 0) { + if (argc != 5) { + return TCL_ERROR; + } + if (TkTextGetIndex(interp, textPtr, argv[3], &index) != TCL_OK) { + return TCL_ERROR; + } + byteOffset = atoi(argv[4]); + TkTextIndexForwBytes(&index, byteOffset, &index); + } else if (strncmp(argv[2], "backbytes", len) == 0) { + if (argc != 5) { + return TCL_ERROR; + } + if (TkTextGetIndex(interp, textPtr, argv[3], &index) != TCL_OK) { + return TCL_ERROR; + } + byteOffset = atoi(argv[4]); + TkTextIndexBackBytes(&index, byteOffset, &index); + } else { + return TCL_ERROR; + } + + TkTextSetMark(textPtr, "insert", &index); + TkTextPrintIndex(&index, buf); + sprintf(buf + strlen(buf), " %d", index.byteIndex); + Tcl_AppendResult(interp, buf, NULL); + + return TCL_OK; +} + #if !(defined(__WIN32__) || defined(MAC_TCL)) /* *---------------------------------------------------------------------- @@ -1127,7 +2321,10 @@ TestwrapperCmd(clientData, interp, argc, argv) wrapperPtr = TkpGetWrapperWindow(winPtr); if (wrapperPtr != NULL) { - TkpPrintWindowId(interp->result, Tk_WindowId(wrapperPtr)); + char buf[TCL_INTEGER_SPACE]; + + TkpPrintWindowId(buf, Tk_WindowId(wrapperPtr)); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } return TCL_OK; } diff --git a/generic/tkText.c b/generic/tkText.c index 643aea0..3e15552 100644 --- a/generic/tkText.c +++ b/generic/tkText.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkText.c 1.104 97/10/13 15:18:24 + * SCCS: @(#) tkText.c 1.108 98/01/12 15:55:43 */ #include "default.h" @@ -290,7 +290,7 @@ Tk_TextCmd(clientData, interp, argc, argv) textPtr->prevWidth = Tk_Width(new); textPtr->prevHeight = Tk_Height(new); TkTextCreateDInfo(textPtr); - TkTextMakeIndex(textPtr->tree, 0, 0, &startIndex); + TkTextMakeByteIndex(textPtr->tree, 0, 0, &startIndex); TkTextSetYView(textPtr, &startIndex, 0); textPtr->selTagPtr = NULL; textPtr->selBorder = NULL; @@ -322,7 +322,8 @@ Tk_TextCmd(clientData, interp, argc, argv) */ textPtr->selTagPtr = TkTextCreateTag(textPtr, "sel"); - textPtr->selTagPtr->reliefString = (char *) ckalloc(7); + textPtr->selTagPtr->reliefString = + (char *) ckalloc(sizeof(DEF_TEXT_SELECT_RELIEF)); strcpy(textPtr->selTagPtr->reliefString, DEF_TEXT_SELECT_RELIEF); textPtr->selTagPtr->relief = TK_RELIEF_RAISED; textPtr->currentMarkPtr = TkTextSetMark(textPtr, "current", &startIndex); @@ -343,7 +344,7 @@ Tk_TextCmd(clientData, interp, argc, argv) Tk_DestroyWindow(textPtr->tkwin); return TCL_ERROR; } - interp->result = Tk_PathName(textPtr->tkwin); + Tcl_SetResult(interp, Tk_PathName(textPtr->tkwin), TCL_STATIC); return TCL_OK; } @@ -401,7 +402,10 @@ TextWidgetCmd(clientData, interp, argc, argv) goto done; } if (TkTextCharBbox(textPtr, &index1, &x, &y, &width, &height) == 0) { - sprintf(interp->result, "%d %d %d %d", x, y, width, height); + char buf[TCL_INTEGER_SPACE * 4]; + + sprintf(buf, "%d %d %d %d", x, y, width, height); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } } else if ((c == 'c') && (strncmp(argv[1], "cget", length) == 0) && (length >= 2)) { @@ -459,7 +463,7 @@ TextWidgetCmd(clientData, interp, argc, argv) } else { goto compareError; } - interp->result = (value) ? "1" : "0"; + Tcl_SetResult(interp, ((value) ? "1" : "0"), TCL_STATIC); } else if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0) && (length >= 3)) { if (argc == 2) { @@ -481,7 +485,7 @@ TextWidgetCmd(clientData, interp, argc, argv) goto done; } if (argc == 2) { - interp->result = (tkBTreeDebug) ? "1" : "0"; + Tcl_SetResult(interp, ((tkBTreeDebug) ? "1" : "0"), TCL_STATIC); } else { if (Tcl_GetBoolean(interp, argv[2], &tkBTreeDebug) != TCL_OK) { result = TCL_ERROR; @@ -517,8 +521,10 @@ TextWidgetCmd(clientData, interp, argc, argv) } if (TkTextDLineInfo(textPtr, &index1, &x, &y, &width, &height, &base) == 0) { - sprintf(interp->result, "%d %d %d %d %d", x, y, width, - height, base); + char buf[TCL_INTEGER_SPACE * 5]; + + sprintf(buf, "%d %d %d %d %d", x, y, width, height, base); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } } else if ((c == 'g') && (strncmp(argv[1], "get", length) == 0)) { if ((argc != 3) && (argc != 4)) { @@ -551,10 +557,10 @@ TextWidgetCmd(clientData, interp, argc, argv) if (index1.linePtr == index2.linePtr) { int last2; - if (index2.charIndex == index1.charIndex) { + if (index2.byteIndex == index1.byteIndex) { break; } - last2 = index2.charIndex - index1.charIndex + offset; + last2 = index2.byteIndex - index1.byteIndex + offset; if (last2 < last) { last = last2; } @@ -566,10 +572,12 @@ TextWidgetCmd(clientData, interp, argc, argv) (char *) NULL); segPtr->body.chars[last] = savedChar; } - TkTextIndexForwChars(&index1, last-offset, &index1); + TkTextIndexForwBytes(&index1, last-offset, &index1); } } else if ((c == 'i') && (strncmp(argv[1], "index", length) == 0) && (length >= 3)) { + char buf[200]; + if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " index index\"", @@ -581,7 +589,8 @@ TextWidgetCmd(clientData, interp, argc, argv) result = TCL_ERROR; goto done; } - TkTextPrintIndex(&index1, interp->result); + TkTextPrintIndex(&index1, buf); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } else if ((c == 'i') && (strncmp(argv[1], "insert", length) == 0) && (length >= 3)) { int i, j, numTags; @@ -604,7 +613,7 @@ TextWidgetCmd(clientData, interp, argc, argv) for (j = 3; j < argc; j += 2) { InsertChars(textPtr, &index1, argv[j]); if (argc > (j+1)) { - TkTextIndexForwChars(&index1, (int) strlen(argv[j]), + TkTextIndexForwBytes(&index1, (int) strlen(argv[j]), &index2); oldTagArrayPtr = TkBTreeGetTags(&index1, &numTags); if (oldTagArrayPtr != NULL) { @@ -745,7 +754,7 @@ DestroyText(memPtr) * * Results: * The return value is a standard Tcl result. If TCL_ERROR is - * returned, then interp->result contains an error message. + * returned, then the interp's result contains an error message. * * Side effects: * Configuration information, such as text string, colors, font, @@ -882,8 +891,8 @@ ConfigureText(interp, textPtr, argc, argv, flags) TkTextSearch search; TkTextIndex first, last; - TkTextMakeIndex(textPtr->tree, 0, 0, &first); - TkTextMakeIndex(textPtr->tree, + TkTextMakeByteIndex(textPtr->tree, 0, 0, &first); + TkTextMakeByteIndex(textPtr->tree, TkBTreeNumLines(textPtr->tree), 0, &last); TkBTreeStartSearch(&first, &last, textPtr->selTagPtr, &search); if (TkBTreeCharTagged(&first, textPtr->selTagPtr) @@ -1114,7 +1123,7 @@ InsertChars(textPtr, indexPtr, string) lineIndex = TkBTreeLineIndex(indexPtr->linePtr); if (lineIndex == TkBTreeNumLines(textPtr->tree)) { lineIndex--; - TkTextMakeIndex(textPtr->tree, lineIndex, 1000000, indexPtr); + TkTextMakeByteIndex(textPtr->tree, lineIndex, 1000000, indexPtr); } /* @@ -1127,16 +1136,16 @@ InsertChars(textPtr, indexPtr, string) resetView = offset = 0; if (indexPtr->linePtr == textPtr->topIndex.linePtr) { resetView = 1; - offset = textPtr->topIndex.charIndex; - if (offset > indexPtr->charIndex) { + offset = textPtr->topIndex.byteIndex; + if (offset > indexPtr->byteIndex) { offset += strlen(string); } } TkTextChanged(textPtr, indexPtr, indexPtr); TkBTreeInsertChars(indexPtr, string); if (resetView) { - TkTextMakeIndex(textPtr->tree, lineIndex, 0, &newTop); - TkTextIndexForwChars(&newTop, offset, &newTop); + TkTextMakeByteIndex(textPtr->tree, lineIndex, 0, &newTop); + TkTextIndexForwBytes(&newTop, offset, &newTop); TkTextSetYView(textPtr, &newTop, 0); } @@ -1175,7 +1184,7 @@ DeleteChars(textPtr, index1String, index2String) * delete the one character given by * index1String. */ { - int line1, line2, line, charIndex, resetView; + int line1, line2, line, byteIndex, resetView; TkTextIndex index1, index2; /* @@ -1226,7 +1235,7 @@ DeleteChars(textPtr, index1String, index2String) oldIndex2 = index2; TkTextIndexBackChars(&oldIndex2, 1, &index2); line2--; - if ((index1.charIndex == 0) && (line1 != 0)) { + if ((index1.byteIndex == 0) && (line1 != 0)) { TkTextIndexBackChars(&index1, 1, &index1); line1--; } @@ -1249,7 +1258,9 @@ DeleteChars(textPtr, index1String, index2String) */ TkTextChanged(textPtr, &index1, &index2); - resetView = line = charIndex = 0; + resetView = 0; + line = 0; + byteIndex = 0; if (TkTextIndexCmp(&index2, &textPtr->topIndex) >= 0) { if (TkTextIndexCmp(&index1, &textPtr->topIndex) <= 0) { /* @@ -1259,7 +1270,7 @@ DeleteChars(textPtr, index1String, index2String) resetView = 1; line = line1; - charIndex = index1.charIndex; + byteIndex = index1.byteIndex; } else if (index1.linePtr == textPtr->topIndex.linePtr) { /* * Deletion range starts on top line but after topIndex. @@ -1268,7 +1279,7 @@ DeleteChars(textPtr, index1String, index2String) resetView = 1; line = line1; - charIndex = textPtr->topIndex.charIndex; + byteIndex = textPtr->topIndex.byteIndex; } } else if (index2.linePtr == textPtr->topIndex.linePtr) { /* @@ -1279,16 +1290,16 @@ DeleteChars(textPtr, index1String, index2String) resetView = 1; line = line2; - charIndex = textPtr->topIndex.charIndex; + byteIndex = textPtr->topIndex.byteIndex; if (index1.linePtr != index2.linePtr) { - charIndex -= index2.charIndex; + byteIndex -= index2.byteIndex; } else { - charIndex -= (index2.charIndex - index1.charIndex); + byteIndex -= (index2.byteIndex - index1.byteIndex); } } TkBTreeDeleteChars(&index1, &index2); if (resetView) { - TkTextMakeIndex(textPtr->tree, line, charIndex, &index1); + TkTextMakeByteIndex(textPtr->tree, line, byteIndex, &index1); TkTextSetYView(textPtr, &index1, 0); } @@ -1352,12 +1363,12 @@ TextFetchSelection(clientData, offset, buffer, maxBytes) */ if (offset == 0) { - TkTextMakeIndex(textPtr->tree, 0, 0, &textPtr->selIndex); + TkTextMakeByteIndex(textPtr->tree, 0, 0, &textPtr->selIndex); textPtr->abortSelections = 0; } else if (textPtr->abortSelections) { return 0; } - TkTextMakeIndex(textPtr->tree, TkBTreeNumLines(textPtr->tree), 0, &eof); + TkTextMakeByteIndex(textPtr->tree, TkBTreeNumLines(textPtr->tree), 0, &eof); TkBTreeStartSearch(&textPtr->selIndex, &eof, textPtr->selTagPtr, &search); if (!TkBTreeCharTagged(&textPtr->selIndex, textPtr->selTagPtr)) { if (!TkBTreeNextTag(&search)) { @@ -1404,8 +1415,8 @@ TextFetchSelection(clientData, offset, buffer, maxBytes) if (textPtr->selIndex.linePtr == search.curIndex.linePtr) { int leftInRange; - leftInRange = search.curIndex.charIndex - - textPtr->selIndex.charIndex; + leftInRange = search.curIndex.byteIndex + - textPtr->selIndex.byteIndex; if (leftInRange < chunkSize) { chunkSize = leftInRange; if (chunkSize <= 0) { @@ -1420,7 +1431,7 @@ TextFetchSelection(clientData, offset, buffer, maxBytes) maxBytes -= chunkSize; count += chunkSize; } - TkTextIndexForwChars(&textPtr->selIndex, chunkSize, + TkTextIndexForwBytes(&textPtr->selIndex, chunkSize, &textPtr->selIndex); } @@ -1477,8 +1488,8 @@ TkTextLostSelection(clientData) * just remove the "sel" tag from everything in the widget. */ - TkTextMakeIndex(textPtr->tree, 0, 0, &start); - TkTextMakeIndex(textPtr->tree, TkBTreeNumLines(textPtr->tree), 0, &end); + TkTextMakeByteIndex(textPtr->tree, 0, 0, &start); + TkTextMakeByteIndex(textPtr->tree, TkBTreeNumLines(textPtr->tree), 0, &end); TkTextRedrawTag(textPtr, &start, &end, textPtr->selTagPtr, 1); TkBTreeTag(&start, &end, textPtr->selTagPtr, 0); #endif @@ -1556,8 +1567,8 @@ TextSearchCmd(textPtr, interp, argc, argv) { int backwards, exact, c, i, argsLeft, noCase, leftToScan; size_t length; - int numLines, startingLine, startingChar, lineNum, firstChar, lastChar; - int code, matchLength, matchChar, passes, stopLine, searchWholeText; + int numLines, startingLine, startingByte, lineNum, firstByte, lastByte; + int code, matchLength, matchByte, passes, stopLine, searchWholeText; int patLength; char *arg, *pattern, *varName, *p, *startOfLine; char buffer[20]; @@ -1594,7 +1605,8 @@ TextSearchCmd(textPtr, interp, argc, argv) backwards = 1; } else if ((c == 'c') && (strncmp(argv[i], "-count", length) == 0)) { if (i >= (argc-1)) { - interp->result = "no value given for \"-count\" option"; + Tcl_SetResult(interp, "no value given for \"-count\" option", + TCL_STATIC); return TCL_ERROR; } i++; @@ -1631,11 +1643,7 @@ TextSearchCmd(textPtr, interp, argc, argv) Tcl_DStringInit(&patDString); Tcl_DStringAppend(&patDString, pattern, -1); pattern = Tcl_DStringValue(&patDString); - for (p = pattern; *p != 0; p++) { - if (isupper(UCHAR(*p))) { - *p = tolower(UCHAR(*p)); - } - } + Tcl_UtfToLower(pattern); } if (TkTextGetIndex(interp, textPtr, argv[i+1], &index) != TCL_OK) { @@ -1643,15 +1651,15 @@ TextSearchCmd(textPtr, interp, argc, argv) } numLines = TkBTreeNumLines(textPtr->tree); startingLine = TkBTreeLineIndex(index.linePtr); - startingChar = index.charIndex; + startingByte = index.byteIndex; if (startingLine >= numLines) { if (backwards) { startingLine = TkBTreeNumLines(textPtr->tree) - 1; - startingChar = TkBTreeCharsInLine(TkBTreeFindLine(textPtr->tree, + startingByte = TkBTreeBytesInLine(TkBTreeFindLine(textPtr->tree, startingLine)); } else { startingLine = 0; - startingChar = 0; + startingByte = 0; } } if (argsLeft == 1) { @@ -1719,11 +1727,8 @@ TextSearchCmd(textPtr, interp, argc, argv) */ if (noCase) { - for (p = Tcl_DStringValue(&line); *p != 0; p++) { - if (isupper(UCHAR(*p))) { - *p = tolower(UCHAR(*p)); - } - } + Tcl_DStringSetLength(&line, + Tcl_UtfToLower(Tcl_DStringValue(&line))); } /* @@ -1732,9 +1737,9 @@ TextSearchCmd(textPtr, interp, argc, argv) * in the line. */ - matchChar = -1; - firstChar = 0; - lastChar = INT_MAX; + matchByte = -1; + firstByte = 0; + lastByte = INT_MAX; if (lineNum == startingLine) { int indexInDString; @@ -1748,8 +1753,8 @@ TextSearchCmd(textPtr, interp, argc, argv) * character. */ - indexInDString = startingChar; - for (segPtr = linePtr->segPtr, leftToScan = startingChar; + indexInDString = startingByte; + for (segPtr = linePtr->segPtr, leftToScan = startingByte; leftToScan > 0; segPtr = segPtr->nextPtr) { if (segPtr->typePtr != &tkTextCharType) { indexInDString -= segPtr->size; @@ -1763,8 +1768,8 @@ TextSearchCmd(textPtr, interp, argc, argv) * Only use the last part of the line. */ - firstChar = indexInDString; - if (firstChar >= Tcl_DStringLength(&line)) { + firstByte = indexInDString; + if (firstByte >= Tcl_DStringLength(&line)) { goto nextLine; } } else { @@ -1772,13 +1777,14 @@ TextSearchCmd(textPtr, interp, argc, argv) * Use only the first part of the line. */ - lastChar = indexInDString; + lastByte = indexInDString; } } do { int thisLength; if (exact) { - p = strstr(startOfLine + firstChar, pattern); + p = strstr(startOfLine + firstByte, /* INTL: Native. */ + pattern); if (p == NULL) { break; } @@ -1789,7 +1795,7 @@ TextSearchCmd(textPtr, interp, argc, argv) int match; match = Tcl_RegExpExec(interp, regexp, - startOfLine + firstChar, startOfLine); + startOfLine + firstByte, startOfLine); if (match < 0) { code = TCL_ERROR; goto done; @@ -1801,12 +1807,12 @@ TextSearchCmd(textPtr, interp, argc, argv) i = start - startOfLine; thisLength = end - start; } - if (i >= lastChar) { + if (i >= lastByte) { break; } - matchChar = i; + matchByte = i; matchLength = thisLength; - firstChar = matchChar+1; + firstByte = matchByte + 1; } while (backwards); /* @@ -1815,7 +1821,7 @@ TextSearchCmd(textPtr, interp, argc, argv) * specified. */ - if (matchChar >= 0) { + if (matchByte >= 0) { /* * The index information returned by the regular expression * parser only considers textual information: it doesn't @@ -1824,10 +1830,10 @@ TextSearchCmd(textPtr, interp, argc, argv) * matchChar and matchCount. */ - for (segPtr = linePtr->segPtr, leftToScan = matchChar; + for (segPtr = linePtr->segPtr, leftToScan = matchByte; leftToScan >= 0; segPtr = segPtr->nextPtr) { if (segPtr->typePtr != &tkTextCharType) { - matchChar += segPtr->size; + matchByte += segPtr->size; continue; } leftToScan -= segPtr->size; @@ -1840,7 +1846,7 @@ TextSearchCmd(textPtr, interp, argc, argv) } leftToScan -= segPtr->size; } - TkTextMakeIndex(textPtr->tree, lineNum, matchChar, &index); + TkTextMakeByteIndex(textPtr->tree, lineNum, matchByte, &index); if (!searchWholeText) { if (!backwards && (TkTextIndexCmp(&index, &stopIndex) >= 0)) { goto done; @@ -1857,7 +1863,8 @@ TextSearchCmd(textPtr, interp, argc, argv) goto done; } } - TkTextPrintIndex(&index, interp->result); + TkTextPrintIndex(&index, buffer); + Tcl_SetResult(interp, buffer, TCL_VOLATILE); goto done; } @@ -1906,7 +1913,7 @@ TextSearchCmd(textPtr, interp, argc, argv) * The return value is a pointer to a malloc'ed structure holding * parsed information about the tab stops. If an error occurred * then the return value is NULL and an error message is left in - * interp->result. + * the interp's result. * * Side effects: * Memory is allocated for the structure that is returned. It is @@ -2104,10 +2111,10 @@ TextDumpCmd(textPtr, interp, argc, argv) } if (index1.linePtr == index2.linePtr) { DumpLine(interp, textPtr, what, index1.linePtr, - index1.charIndex, index2.charIndex, lineno, command); + index1.byteIndex, index2.byteIndex, lineno, command); } else { DumpLine(interp, textPtr, what, index1.linePtr, - index1.charIndex, 32000000, lineno, command); + index1.byteIndex, 32000000, lineno, command); linePtr = index1.linePtr; while ((linePtr = TkBTreeNextLine(linePtr)) != (TkTextLine *)NULL) { lineno++; @@ -2118,14 +2125,14 @@ TextDumpCmd(textPtr, interp, argc, argv) lineno, command); } DumpLine(interp, textPtr, what, index2.linePtr, 0, - index2.charIndex, lineno, command); + index2.byteIndex, lineno, command); } /* * Special case to get the leftovers hiding at the end mark. */ if (atEnd) { DumpLine(interp, textPtr, what & ~TK_DUMP_TEXT, index2.linePtr, - 0, 1, lineno, command); + 0, 1, lineno, command); } return TCL_OK; @@ -2143,12 +2150,12 @@ TextDumpCmd(textPtr, interp, argc, argv) * None, but see DumpSegment. */ static void -DumpLine(interp, textPtr, what, linePtr, start, end, lineno, command) +DumpLine(interp, textPtr, what, linePtr, startByte, endByte, lineno, command) Tcl_Interp *interp; TkText *textPtr; int what; /* bit flags to select segment types */ TkTextLine *linePtr; /* The current line */ - int start, end; /* Character range to dump */ + int startByte, endByte; /* Byte range to dump */ int lineno; /* Line number for indices dump */ char *command; /* Script to apply to the segment */ { @@ -2163,25 +2170,25 @@ DumpLine(interp, textPtr, what, linePtr, start, end, lineno, command) * window */ for (offset = 0, segPtr = linePtr->segPtr ; - (offset < end) && (segPtr != (TkTextSegment *)NULL) ; + (offset < endByte) && (segPtr != (TkTextSegment *)NULL) ; offset += segPtr->size, segPtr = segPtr->nextPtr) { if ((what & TK_DUMP_TEXT) && (segPtr->typePtr == &tkTextCharType) && - (offset + segPtr->size > start)) { + (offset + segPtr->size > startByte)) { char savedChar; /* Last char used in the seg */ int last = segPtr->size; /* Index of savedChar */ int first = 0; /* Index of first char in seg */ - if (offset + segPtr->size > end) { - last = end - offset; + if (offset + segPtr->size > endByte) { + last = endByte - offset; } - if (start > offset) { - first = start - offset; + if (startByte > offset) { + first = startByte - offset; } savedChar = segPtr->body.chars[last]; segPtr->body.chars[last] = '\0'; DumpSegment(interp, "text", segPtr->body.chars + first, command, lineno, offset + first, what); segPtr->body.chars[last] = savedChar; - } else if ((offset >= start)) { + } else if ((offset >= startByte)) { if ((what & TK_DUMP_MARK) && (segPtr->typePtr->name[0] == 'm')) { TkTextMark *markPtr = (TkTextMark *)&segPtr->body; char *name = Tcl_GetHashKey(&textPtr->markTable, markPtr->hPtr); @@ -2237,11 +2244,11 @@ DumpSegment(interp, key, value, command, lineno, offset, what) char *value; /* Segment value */ char *command; /* Script callback */ int lineno; /* Line number for indices dump */ - int offset; /* Character position */ + int offset; /* Byte position */ int what; /* Look for TK_DUMP_INDEX bit */ { char buffer[30]; - sprintf(buffer, "%d.%d", lineno, offset); + sprintf(buffer, "%d.%d", lineno, offset); if (command == (char *) NULL) { Tcl_AppendElement(interp, key); Tcl_AppendElement(interp, value); diff --git a/generic/tkText.h b/generic/tkText.h index a7999d2..5648fb9 100644 --- a/generic/tkText.h +++ b/generic/tkText.h @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkText.h 1.46 96/11/25 11:26:12 + * SCCS: @(#) tkText.h 1.47 98/01/08 13:41:18 */ #ifndef _TKTEXT @@ -176,7 +176,7 @@ typedef struct TkTextIndex { TkTextBTree tree; /* Tree containing desired position. */ TkTextLine *linePtr; /* Pointer to line containing position * of interest. */ - int charIndex; /* Index within line of desired + int byteIndex; /* Index within line of desired * character (0 means first one). */ } TkTextIndex; @@ -241,7 +241,7 @@ struct TkTextDispChunk { * a given x-location. */ Tk_ChunkBboxProc *bboxProc; /* Procedure to find bounding box * of character in chunk. */ - int numChars; /* Number of characters that will be + int numBytes; /* Number of bytes that will be * displayed in the chunk. */ int minAscent; /* Minimum space above the baseline * needed by this chunk. */ @@ -256,7 +256,7 @@ struct TkTextDispChunk { * of line. */ int breakIndex; /* Index within chunk of last * acceptable position for a line - * (break just before this character). + * (break just before this byte index). * <= 0 means don't break during or * immediately after this chunk. */ ClientData clientData; /* Additional information for use @@ -730,6 +730,7 @@ extern int TkBTreeCharTagged _ANSI_ARGS_((TkTextIndex *indexPtr, TkTextTag *tagPtr)); extern void TkBTreeCheck _ANSI_ARGS_((TkTextBTree tree)); extern int TkBTreeCharsInLine _ANSI_ARGS_((TkTextLine *linePtr)); +extern int TkBTreeBytesInLine _ANSI_ARGS_((TkTextLine *linePtr)); extern TkTextBTree TkBTreeCreate _ANSI_ARGS_((TkText *textPtr)); extern void TkBTreeDestroy _ANSI_ARGS_((TkTextBTree tree)); extern void TkBTreeDeleteChars _ANSI_ARGS_((TkTextIndex *index1Ptr, @@ -784,23 +785,35 @@ extern int TkTextGetIndex _ANSI_ARGS_((Tcl_Interp *interp, TkTextIndex *indexPtr)); extern TkTextTabArray * TkTextGetTabs _ANSI_ARGS_((Tcl_Interp *interp, Tk_Window tkwin, char *string)); -extern void TkTextIndexBackChars _ANSI_ARGS_((TkTextIndex *srcPtr, - int count, TkTextIndex *dstPtr)); -extern int TkTextIndexCmp _ANSI_ARGS_((TkTextIndex *index1Ptr, - TkTextIndex *index2Ptr)); -extern void TkTextIndexForwChars _ANSI_ARGS_((TkTextIndex *srcPtr, - int count, TkTextIndex *dstPtr)); -extern TkTextSegment * TkTextIndexToSeg _ANSI_ARGS_((TkTextIndex *indexPtr, - int *offsetPtr)); +extern void TkTextIndexBackBytes _ANSI_ARGS_(( + CONST TkTextIndex *srcPtr, int count, + TkTextIndex *dstPtr)); +extern void TkTextIndexBackChars _ANSI_ARGS_(( + CONST TkTextIndex *srcPtr, int count, + TkTextIndex *dstPtr)); +extern int TkTextIndexCmp _ANSI_ARGS_(( + CONST TkTextIndex *index1Ptr, + CONST TkTextIndex *index2Ptr)); +extern void TkTextIndexForwBytes _ANSI_ARGS_(( + CONST TkTextIndex *srcPtr, int count, + TkTextIndex *dstPtr)); +extern void TkTextIndexForwChars _ANSI_ARGS_(( + CONST TkTextIndex *srcPtr, int count, + TkTextIndex *dstPtr)); +extern TkTextSegment * TkTextIndexToSeg _ANSI_ARGS_(( + CONST TkTextIndex *indexPtr, int *offsetPtr)); extern void TkTextInsertDisplayProc _ANSI_ARGS_(( TkTextDispChunk *chunkPtr, int x, int y, int height, int baseline, Display *display, Drawable dst, int screenY)); extern void TkTextLostSelection _ANSI_ARGS_(( ClientData clientData)); -extern TkTextIndex * TkTextMakeIndex _ANSI_ARGS_((TkTextBTree tree, +extern TkTextIndex * TkTextMakeCharIndex _ANSI_ARGS_((TkTextBTree tree, int lineIndex, int charIndex, TkTextIndex *indexPtr)); +extern TkTextIndex * TkTextMakeByteIndex _ANSI_ARGS_((TkTextBTree tree, + int lineIndex, int byteIndex, + TkTextIndex *indexPtr)); extern int TkTextMarkCmd _ANSI_ARGS_((TkText *textPtr, Tcl_Interp *interp, int argc, char **argv)); extern int TkTextMarkNameToIndex _ANSI_ARGS_((TkText *textPtr, @@ -812,8 +825,8 @@ extern void TkTextPickCurrent _ANSI_ARGS_((TkText *textPtr, XEvent *eventPtr)); extern void TkTextPixelIndex _ANSI_ARGS_((TkText *textPtr, int x, int y, TkTextIndex *indexPtr)); -extern void TkTextPrintIndex _ANSI_ARGS_((TkTextIndex *indexPtr, - char *string)); +extern void TkTextPrintIndex _ANSI_ARGS_(( + CONST TkTextIndex *indexPtr, char *string)); extern void TkTextRedrawRegion _ANSI_ARGS_((TkText *textPtr, int x, int y, int width, int height)); extern void TkTextRedrawTag _ANSI_ARGS_((TkText *textPtr, @@ -824,8 +837,9 @@ extern int TkTextScanCmd _ANSI_ARGS_((TkText *textPtr, Tcl_Interp *interp, int argc, char **argv)); extern int TkTextSeeCmd _ANSI_ARGS_((TkText *textPtr, Tcl_Interp *interp, int argc, char **argv)); -extern int TkTextSegToOffset _ANSI_ARGS_((TkTextSegment *segPtr, - TkTextLine *linePtr)); +extern int TkTextSegToOffset _ANSI_ARGS_(( + CONST TkTextSegment *segPtr, + CONST TkTextLine *linePtr)); extern TkTextSegment * TkTextSetMark _ANSI_ARGS_((TkText *textPtr, char *name, TkTextIndex *indexPtr)); extern void TkTextSetYView _ANSI_ARGS_((TkText *textPtr, diff --git a/generic/tkTextBTree.c b/generic/tkTextBTree.c index 2fd7deb..907b7d9 100644 --- a/generic/tkTextBTree.c +++ b/generic/tkTextBTree.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkTextBTree.c 1.37 97/04/25 16:52:00 + * SCCS: @(#) tkTextBTree.c 1.38 98/01/08 13:40:24 */ #include "tkInt.h" @@ -535,7 +535,7 @@ SplitSeg(indexPtr) TkTextSegment *prevPtr, *segPtr; int count; - for (count = indexPtr->charIndex, prevPtr = NULL, + for (count = indexPtr->byteIndex, prevPtr = NULL, segPtr = indexPtr->linePtr->segPtr; segPtr != NULL; count -= segPtr->size, prevPtr = segPtr, segPtr = segPtr->nextPtr) { if (segPtr->size > count) { @@ -1530,7 +1530,7 @@ FindTagStart(tree, tagPtr, indexPtr) */ indexPtr->tree = tree; indexPtr->linePtr = linePtr; - indexPtr->charIndex = offset; + indexPtr->byteIndex = offset; return segPtr; } } @@ -1619,7 +1619,7 @@ FindTagEnd(tree, tagPtr, indexPtr) } indexPtr->tree = tree; indexPtr->linePtr = lastLinePtr; - indexPtr->charIndex = lastoffset2; + indexPtr->byteIndex = lastoffset2; return last2SegPtr; } @@ -1694,7 +1694,7 @@ TkBTreeStartSearch(index1Ptr, index2Ptr, tagPtr, searchPtr) searchPtr->curIndex = *index1Ptr; searchPtr->segPtr = NULL; searchPtr->nextPtr = TkTextIndexToSeg(index1Ptr, &offset); - searchPtr->curIndex.charIndex -= offset; + searchPtr->curIndex.byteIndex -= offset; } searchPtr->lastPtr = TkTextIndexToSeg(index2Ptr, (int *) NULL); searchPtr->tagPtr = tagPtr; @@ -1709,9 +1709,9 @@ TkBTreeStartSearch(index1Ptr, index2Ptr, tagPtr, searchPtr) * the range, unless the range is artificially moved up to index0. */ if (((index1Ptr == &index0) && - (index1Ptr->charIndex > index2Ptr->charIndex)) || + (index1Ptr->byteIndex > index2Ptr->byteIndex)) || ((index1Ptr != &index0) && - (index1Ptr->charIndex >= index2Ptr->charIndex))) { + (index1Ptr->byteIndex >= index2Ptr->byteIndex))) { searchPtr->linesLeft = 0; } } @@ -1793,7 +1793,7 @@ TkBTreeStartSearchBack(index1Ptr, index2Ptr, tagPtr, searchPtr) } searchPtr->segPtr = NULL; searchPtr->nextPtr = TkTextIndexToSeg(&searchPtr->curIndex, &offset); - searchPtr->curIndex.charIndex -= offset; + searchPtr->curIndex.byteIndex -= offset; /* * Adjust the end of the search so it does find toggles that are right @@ -1801,7 +1801,7 @@ TkBTreeStartSearchBack(index1Ptr, index2Ptr, tagPtr, searchPtr) */ if ((TkBTreeLineIndex(index2Ptr->linePtr) == 0) && - (index2Ptr->charIndex == 0)) { + (index2Ptr->byteIndex == 0)) { backOne = *index2Ptr; searchPtr->lastPtr = NULL; /* Signals special case for 1.0 */ } else { @@ -1819,7 +1819,7 @@ TkBTreeStartSearchBack(index1Ptr, index2Ptr, tagPtr, searchPtr) * first. */ - if (index1Ptr->charIndex <= backOne.charIndex) { + if (index1Ptr->byteIndex <= backOne.byteIndex) { searchPtr->linesLeft = 0; } } @@ -1889,7 +1889,7 @@ TkBTreeNextTag(searchPtr) searchPtr->tagPtr = segPtr->body.toggle.tagPtr; return 1; } - searchPtr->curIndex.charIndex += segPtr->size; + searchPtr->curIndex.byteIndex += segPtr->size; } /* @@ -1906,7 +1906,7 @@ TkBTreeNextTag(searchPtr) } if (searchPtr->curIndex.linePtr != NULL) { segPtr = searchPtr->curIndex.linePtr->segPtr; - searchPtr->curIndex.charIndex = 0; + searchPtr->curIndex.byteIndex = 0; continue; } if (nodePtr == searchPtr->tagPtr->tagRootPtr) { @@ -1972,7 +1972,7 @@ TkBTreeNextTag(searchPtr) */ searchPtr->curIndex.linePtr = nodePtr->children.linePtr; - searchPtr->curIndex.charIndex = 0; + searchPtr->curIndex.byteIndex = 0; segPtr = searchPtr->curIndex.linePtr->segPtr; if (searchPtr->linesLeft <= 0) { goto searchOver; @@ -2022,7 +2022,7 @@ TkBTreePrevTag(searchPtr) register TkTextLine *linePtr, *prevLinePtr; register Node *nodePtr, *node2Ptr, *prevNodePtr; register Summary *summaryPtr; - int charIndex; + int byteIndex; int pastLast; /* Saw last marker during scan */ int linesSkipped; @@ -2041,7 +2041,7 @@ TkBTreePrevTag(searchPtr) /* * Check for the last toggle before the current segment on this line. */ - charIndex = 0; + byteIndex = 0; if (searchPtr->lastPtr == NULL) { /* * Search back to the very beginning, so pastLast is irrelevent. @@ -2058,13 +2058,13 @@ TkBTreePrevTag(searchPtr) && (searchPtr->allTags || (segPtr->body.toggle.tagPtr == searchPtr->tagPtr))) { prevPtr = segPtr; - searchPtr->curIndex.charIndex = charIndex; + searchPtr->curIndex.byteIndex = byteIndex; } if (segPtr == searchPtr->lastPtr) { prevPtr = NULL; /* Segments earlier than last don't count */ pastLast = 1; } - charIndex += segPtr->size; + byteIndex += segPtr->size; } if (prevPtr != NULL) { if (searchPtr->linesLeft == 1 && !pastLast) { @@ -2191,7 +2191,7 @@ TkBTreePrevTag(searchPtr) /* empty loop body */ ; } searchPtr->curIndex.linePtr = prevLinePtr; - searchPtr->curIndex.charIndex = 0; + searchPtr->curIndex.byteIndex = 0; if (searchPtr->linesLeft <= 0) { goto searchOver; } @@ -2241,7 +2241,7 @@ TkBTreeCharTagged(indexPtr, tagPtr) toggleSegPtr = NULL; for (index = 0, segPtr = indexPtr->linePtr->segPtr; - (index + segPtr->size) <= indexPtr->charIndex; + (index + segPtr->size) <= indexPtr->byteIndex; index += segPtr->size, segPtr = segPtr->nextPtr) { if (((segPtr->typePtr == &tkTextToggleOnType) || (segPtr->typePtr == &tkTextToggleOffType)) @@ -2360,7 +2360,7 @@ TkBTreeGetTags(indexPtr, numTagsPtr) */ for (index = 0, segPtr = indexPtr->linePtr->segPtr; - (index + segPtr->size) <= indexPtr->charIndex; + (index + segPtr->size) <= indexPtr->byteIndex; index += segPtr->size, segPtr = segPtr->nextPtr) { if ((segPtr->typePtr == &tkTextToggleOnType) || (segPtr->typePtr == &tkTextToggleOffType)) { @@ -3588,6 +3588,25 @@ TkBTreeCharsInLine(linePtr) count = 0; for (segPtr = linePtr->segPtr; segPtr != NULL; segPtr = segPtr->nextPtr) { + if (segPtr->typePtr == &tkTextCharType) { + count += Tcl_NumUtfChars(segPtr->body.chars, segPtr->size); + } else { + count += segPtr->size; + } + } + return count; +} + +int +TkBTreeBytesInLine(linePtr) + TkTextLine *linePtr; /* Line whose characters should be + * counted. */ +{ + TkTextSegment *segPtr; + int count; + + count = 0; + for (segPtr = linePtr->segPtr; segPtr != NULL; segPtr = segPtr->nextPtr) { count += segPtr->size; } return count; diff --git a/generic/tkTextDisp.c b/generic/tkTextDisp.c index 8d9c022..8193440 100644 --- a/generic/tkTextDisp.c +++ b/generic/tkTextDisp.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkTextDisp.c 1.124 97/07/11 18:01:03 + * SCCS: @(#) tkTextDisp.c 1.127 98/01/08 13:41:28 */ #include "tkPort.h" @@ -98,7 +98,7 @@ typedef struct TextStyle { typedef struct DLine { TkTextIndex index; /* Identifies first character in text * that is displayed on this line. */ - int count; /* Number of characters accounted for by this + int byteCount; /* Number of bytes accounted for by this * display line, including a trailing space * or newline that isn't actually displayed. */ int y; /* Y-position at which line is supposed to @@ -199,7 +199,7 @@ typedef struct TextDInfo { * Information used for scrolling: */ - int newCharOffset; /* Desired x scroll position, measured as the + int newByteOffset; /* Desired x scroll position, measured as the * number of average-size characters off-screen * to the left for a line with no left * margin. */ @@ -222,8 +222,9 @@ typedef struct TextDInfo { * The following information is used to implement scanning: */ - int scanMarkChar; /* Character that was at the left edge of - * the window when the scan started. */ + int scanMarkIndex; /* Byte index of character that was at the + * left edge of the window when the scan + * started. */ int scanMarkX; /* X-position of mouse at time scan started. */ int scanTotalScroll; /* Total scrolling (in screen lines) that has * occurred since scanMarkY was set. */ @@ -254,9 +255,9 @@ typedef struct TextDInfo { */ typedef struct CharInfo { - int numChars; /* Number of characters to display. */ - char chars[4]; /* Characters to display. Actual size - * will be numChars, not 4. THIS MUST BE + int numBytes; /* Number of bytes to display. */ + char chars[4]; /* UTF characters to display. Actual size + * will be numBytes, not 4. THIS MUST BE * THE LAST FIELD IN THE STRUCTURE. */ } CharInfo; @@ -331,7 +332,7 @@ static void GetYView _ANSI_ARGS_((Tcl_Interp *interp, static DLine * LayoutDLine _ANSI_ARGS_((TkText *textPtr, TkTextIndex *indexPtr)); static int MeasureChars _ANSI_ARGS_((Tk_Font tkfont, - CONST char *source, int maxChars, int startX, + CONST char *source, int maxBytes, int startX, int maxX, int tabOrigin, int *nextXPtr)); static void MeasureUp _ANSI_ARGS_((TkText *textPtr, TkTextIndex *srcPtr, int distance, @@ -381,14 +382,14 @@ TkTextCreateDInfo(textPtr) dInfoPtr->scrollGC = Tk_GetGC(textPtr->tkwin, GCGraphicsExposures, &gcValues); dInfoPtr->topOfEof = 0; - dInfoPtr->newCharOffset = 0; + dInfoPtr->newByteOffset = 0; dInfoPtr->curPixelOffset = 0; dInfoPtr->maxLength = 0; dInfoPtr->xScrollFirst = -1; dInfoPtr->xScrollLast = -1; dInfoPtr->yScrollFirst = -1; dInfoPtr->yScrollLast = -1; - dInfoPtr->scanMarkChar = 0; + dInfoPtr->scanMarkIndex = 0; dInfoPtr->scanMarkX = 0; dInfoPtr->scanTotalScroll = 0; dInfoPtr->scanMarkY = 0; @@ -739,12 +740,14 @@ LayoutDLine(textPtr, indexPtr) * point, if any. */ TkTextIndex breakIndex; /* Index of first character in * breakChunkPtr. */ - int breakCharOffset; /* Character within breakChunkPtr just - * to right of best break point. */ + int breakByteOffset; /* Byte offset of character within + * breakChunkPtr just to right of best + * break point. */ int noCharsYet; /* Non-zero means that no characters * have been placed on the line yet. */ int justify; /* How to justify line: taken from - * style for first character in line. */ + * style for the first character in + * line. */ int jIndent; /* Additional indentation (beyond * margins) due to justification. */ int rMargin; /* Right margin width for line. */ @@ -758,17 +761,18 @@ LayoutDLine(textPtr, indexPtr) * contains a tab. */ TkTextDispChunk *tabChunkPtr; /* Pointer to the chunk containing * the previous tab stop. */ - int maxChars; /* Maximum number of characters to + int maxBytes; /* Maximum number of bytes to * include in this chunk. */ - TkTextTabArray *tabArrayPtr; /* Tab stops for line; taken from - * style for first character on line. */ + TkTextTabArray *tabArrayPtr; /* Tab stops for line; taken from + * style for the first character on + * line. */ int tabSize; /* Number of pixels consumed by current * tab stop. */ TkTextDispChunk *lastCharChunkPtr; /* Pointer to last chunk in display - * lines with numChars > 0. Used to + * lines with numBytes > 0. Used to * drop 0-sized chunks from the end * of the line. */ - int offset, ascent, descent, code; + int byteOffset, ascent, descent, code; StyleValues *sValuePtr; /* @@ -777,7 +781,7 @@ LayoutDLine(textPtr, indexPtr) dlPtr = (DLine *) ckalloc(sizeof(DLine)); dlPtr->index = *indexPtr; - dlPtr->count = 0; + dlPtr->byteCount = 0; dlPtr->y = 0; dlPtr->oldY = -1; dlPtr->height = 0; @@ -798,7 +802,7 @@ LayoutDLine(textPtr, indexPtr) chunkPtr = NULL; noCharsYet = 1; breakChunkPtr = NULL; - breakCharOffset = 0; + breakByteOffset = 0; justify = TK_JUSTIFY_LEFT; tabIndex = -1; tabChunkPtr = NULL; @@ -814,16 +818,16 @@ LayoutDLine(textPtr, indexPtr) * with zero size (such as the insertion cursor's mark). */ - for (offset = curIndex.charIndex, segPtr = curIndex.linePtr->segPtr; - (offset > 0) && (offset >= segPtr->size); - offset -= segPtr->size, segPtr = segPtr->nextPtr) { + for (byteOffset = curIndex.byteIndex, segPtr = curIndex.linePtr->segPtr; + (byteOffset > 0) && (byteOffset >= segPtr->size); + byteOffset -= segPtr->size, segPtr = segPtr->nextPtr) { /* Empty loop body. */ } while (segPtr != NULL) { if (segPtr->typePtr->layoutProc == NULL) { segPtr = segPtr->nextPtr; - offset = 0; + byteOffset = 0; continue; } if (chunkPtr == NULL) { @@ -843,11 +847,11 @@ LayoutDLine(textPtr, indexPtr) justify = chunkPtr->stylePtr->sValuePtr->justify; rMargin = chunkPtr->stylePtr->sValuePtr->rMargin; wrapMode = chunkPtr->stylePtr->sValuePtr->wrapMode; - x = ((curIndex.charIndex == 0) + x = ((curIndex.byteIndex == 0) ? chunkPtr->stylePtr->sValuePtr->lMargin1 : chunkPtr->stylePtr->sValuePtr->lMargin2); if (wrapMode == tkTextNoneUid) { - maxX = INT_MAX; + maxX = -1; } else { maxX = textPtr->dInfoPtr->maxX - textPtr->dInfoPtr->x - rMargin; @@ -863,14 +867,14 @@ LayoutDLine(textPtr, indexPtr) */ gotTab = 0; - maxChars = segPtr->size - offset; + maxBytes = segPtr->size - byteOffset; if (justify == TK_JUSTIFY_LEFT) { if (segPtr->typePtr == &tkTextCharType) { char *p; - for (p = segPtr->body.chars + offset; *p != 0; p++) { + for (p = segPtr->body.chars + byteOffset; *p != 0; p++) { if (*p == '\t') { - maxChars = (p + 1 - segPtr->body.chars) - offset; + maxBytes = (p + 1 - segPtr->body.chars) - byteOffset; gotTab = 1; break; } @@ -880,7 +884,7 @@ LayoutDLine(textPtr, indexPtr) chunkPtr->x = x; code = (*segPtr->typePtr->layoutProc)(textPtr, &curIndex, segPtr, - offset, maxX-tabSize, maxChars, noCharsYet, wrapMode, + byteOffset, maxX-tabSize, maxBytes, noCharsYet, wrapMode, chunkPtr); if (code <= 0) { FreeStyle(textPtr, chunkPtr->stylePtr); @@ -891,7 +895,7 @@ LayoutDLine(textPtr, indexPtr) */ segPtr = segPtr->nextPtr; - offset = 0; + byteOffset = 0; continue; } @@ -905,7 +909,7 @@ LayoutDLine(textPtr, indexPtr) } break; } - if (chunkPtr->numChars > 0) { + if (chunkPtr->numBytes > 0) { noCharsYet = 0; lastCharChunkPtr = chunkPtr; } @@ -917,11 +921,11 @@ LayoutDLine(textPtr, indexPtr) lastChunkPtr = chunkPtr; x += chunkPtr->width; if (chunkPtr->breakIndex > 0) { - breakCharOffset = chunkPtr->breakIndex; + breakByteOffset = chunkPtr->breakIndex; breakIndex = curIndex; breakChunkPtr = chunkPtr; } - if (chunkPtr->numChars != maxChars) { + if (chunkPtr->numBytes != maxBytes) { break; } @@ -940,14 +944,14 @@ LayoutDLine(textPtr, indexPtr) tabIndex++; tabChunkPtr = chunkPtr; tabSize = SizeOfTab(textPtr, tabArrayPtr, tabIndex, x, maxX); - if (tabSize >= (maxX - x)) { + if ((maxX >= 0) && (tabSize >= maxX - x)) { break; } } - curIndex.charIndex += chunkPtr->numChars; - offset += chunkPtr->numChars; - if (offset >= segPtr->size) { - offset = 0; + curIndex.byteIndex += chunkPtr->numBytes; + byteOffset += chunkPtr->numBytes; + if (byteOffset >= segPtr->size) { + byteOffset = 0; segPtr = segPtr->nextPtr; } chunkPtr = NULL; @@ -973,10 +977,10 @@ LayoutDLine(textPtr, indexPtr) */ breakChunkPtr = lastCharChunkPtr; - breakCharOffset = breakChunkPtr->numChars; + breakByteOffset = breakChunkPtr->numBytes; } if ((breakChunkPtr != NULL) && ((lastChunkPtr != breakChunkPtr) - || (breakCharOffset != lastChunkPtr->numChars))) { + || (breakByteOffset != lastChunkPtr->numBytes))) { while (1) { chunkPtr = breakChunkPtr->nextPtr; if (chunkPtr == NULL) { @@ -987,11 +991,11 @@ LayoutDLine(textPtr, indexPtr) (*chunkPtr->undisplayProc)(textPtr, chunkPtr); ckfree((char *) chunkPtr); } - if (breakCharOffset != breakChunkPtr->numChars) { + if (breakByteOffset != breakChunkPtr->numBytes) { (*breakChunkPtr->undisplayProc)(textPtr, breakChunkPtr); - segPtr = TkTextIndexToSeg(&breakIndex, &offset); + segPtr = TkTextIndexToSeg(&breakIndex, &byteOffset); (*segPtr->typePtr->layoutProc)(textPtr, &breakIndex, - segPtr, offset, maxX, breakCharOffset, 0, + segPtr, byteOffset, maxX, breakByteOffset, 0, wrapMode, breakChunkPtr); } lastChunkPtr = breakChunkPtr; @@ -1008,7 +1012,7 @@ LayoutDLine(textPtr, indexPtr) /* * Make one more pass over the line to recompute various things - * like its height, length, and total number of characters. Also + * like its height, length, and total number of bytes. Also * modify the x-locations of chunks to reflect justification. * If we're not wrapping, I'm not sure what is the best way to * handle left and center justification: should the total length, @@ -1034,7 +1038,7 @@ LayoutDLine(textPtr, indexPtr) for (chunkPtr = dlPtr->chunkPtr; chunkPtr != NULL; chunkPtr = chunkPtr->nextPtr) { chunkPtr->x += jIndent; - dlPtr->count += chunkPtr->numChars; + dlPtr->byteCount += chunkPtr->numBytes; if (chunkPtr->minAscent > ascent) { ascent = chunkPtr->minAscent; } @@ -1057,7 +1061,7 @@ LayoutDLine(textPtr, indexPtr) dlPtr->baseline = ascent + (dlPtr->height - ascent - descent)/2; } sValuePtr = dlPtr->chunkPtr->stylePtr->sValuePtr; - if (dlPtr->index.charIndex == 0) { + if (dlPtr->index.byteIndex == 0) { dlPtr->spaceAbove = sValuePtr->spacing1; } else { dlPtr->spaceAbove = sValuePtr->spacing2 - sValuePtr->spacing2/2; @@ -1210,7 +1214,7 @@ UpdateDisplayInfo(textPtr) * index within the line. */ - if (index.charIndex == dlPtr->index.charIndex) { + if (index.byteIndex == dlPtr->index.byteIndex) { /* * Case (a) -- can use existing display line as-is. */ @@ -1221,7 +1225,7 @@ UpdateDisplayInfo(textPtr) } goto lineOK; } - if (index.charIndex < dlPtr->index.charIndex) { + if (index.byteIndex < dlPtr->index.byteIndex) { goto makeNewDLine; } @@ -1248,7 +1252,7 @@ UpdateDisplayInfo(textPtr) lineOK: dlPtr->y = y; y += dlPtr->height; - TkTextIndexForwChars(&index, dlPtr->count, &index); + TkTextIndexForwBytes(&index, dlPtr->byteCount, &index); prevPtr = dlPtr; dlPtr = dlPtr->nextPtr; @@ -1299,7 +1303,7 @@ UpdateDisplayInfo(textPtr) */ if (y < maxY) { - int lineNum, spaceLeft, charsToCount; + int lineNum, spaceLeft, bytesToCount; DLine *lowestPtr; /* @@ -1312,22 +1316,22 @@ UpdateDisplayInfo(textPtr) spaceLeft = maxY - y; lineNum = TkBTreeLineIndex(dInfoPtr->dLinePtr->index.linePtr); - charsToCount = dInfoPtr->dLinePtr->index.charIndex; - if (charsToCount == 0) { - charsToCount = INT_MAX; + bytesToCount = dInfoPtr->dLinePtr->index.byteIndex; + if (bytesToCount == 0) { + bytesToCount = INT_MAX; lineNum--; } for ( ; (lineNum >= 0) && (spaceLeft > 0); lineNum--) { index.linePtr = TkBTreeFindLine(textPtr->tree, lineNum); - index.charIndex = 0; + index.byteIndex = 0; lowestPtr = NULL; do { dlPtr = LayoutDLine(textPtr, &index); dlPtr->nextPtr = lowestPtr; lowestPtr = dlPtr; - TkTextIndexForwChars(&index, dlPtr->count, &index); - charsToCount -= dlPtr->count; - } while ((charsToCount > 0) + TkTextIndexForwBytes(&index, dlPtr->byteCount, &index); + bytesToCount -= dlPtr->byteCount; + } while ((bytesToCount > 0) && (index.linePtr == lowestPtr->index.linePtr)); /* @@ -1354,7 +1358,7 @@ UpdateDisplayInfo(textPtr) } } FreeDLines(textPtr, lowestPtr, (DLine *) NULL, 0); - charsToCount = INT_MAX; + bytesToCount = INT_MAX; } /* @@ -1441,13 +1445,13 @@ UpdateDisplayInfo(textPtr) } maxOffset = (dInfoPtr->maxLength - (dInfoPtr->maxX - dInfoPtr->x) + textPtr->charWidth - 1)/textPtr->charWidth; - if (dInfoPtr->newCharOffset > maxOffset) { - dInfoPtr->newCharOffset = maxOffset; + if (dInfoPtr->newByteOffset > maxOffset) { + dInfoPtr->newByteOffset = maxOffset; } - if (dInfoPtr->newCharOffset < 0) { - dInfoPtr->newCharOffset = 0; + if (dInfoPtr->newByteOffset < 0) { + dInfoPtr->newByteOffset = 0; } - pixelOffset = dInfoPtr->newCharOffset * textPtr->charWidth; + pixelOffset = dInfoPtr->newByteOffset * textPtr->charWidth; if (pixelOffset != dInfoPtr->curPixelOffset) { dInfoPtr->curPixelOffset = pixelOffset; for (dlPtr = dInfoPtr->dLinePtr; dlPtr != NULL; @@ -2591,7 +2595,7 @@ TkTextChanged(textPtr, index1Ptr, index2Ptr) */ rounded = *index1Ptr; - rounded.charIndex = 0; + rounded.byteIndex = 0; firstPtr = FindDLine(dInfoPtr->dLinePtr, &rounded); if (firstPtr == NULL) { return; @@ -2667,7 +2671,7 @@ TkTextRedrawTag(textPtr, index1Ptr, index2Ptr, tagPtr, withTag) */ if (index2Ptr == NULL) { - index2Ptr = TkTextMakeIndex(textPtr->tree, + index2Ptr = TkTextMakeByteIndex(textPtr->tree, TkBTreeNumLines(textPtr->tree), 0, &endOfText); } @@ -2721,13 +2725,13 @@ TkTextRedrawTag(textPtr, index1Ptr, index2Ptr, tagPtr, withTag) * previous character. */ - if (curIndexPtr->charIndex == 0) { + if (curIndexPtr->byteIndex == 0) { dlPtr = FindDLine(dlPtr, curIndexPtr); } else { TkTextIndex tmp; tmp = *curIndexPtr; - tmp.charIndex -= 1; + tmp.byteIndex -= 1; dlPtr = FindDLine(dlPtr, &tmp); } if (dlPtr == NULL) { @@ -2746,7 +2750,7 @@ TkTextRedrawTag(textPtr, index1Ptr, index2Ptr, tagPtr, withTag) } endPtr = FindDLine(dlPtr, endIndexPtr); if ((endPtr != NULL) && (endPtr->index.linePtr == endIndexPtr->linePtr) - && (endPtr->index.charIndex < endIndexPtr->charIndex)) { + && (endPtr->index.byteIndex < endIndexPtr->byteIndex)) { endPtr = endPtr->nextPtr; } @@ -2858,7 +2862,7 @@ TkTextRelayoutWindow(textPtr) * or options could change the way lines wrap. */ - if (textPtr->topIndex.charIndex != 0) { + if (textPtr->topIndex.byteIndex != 0) { MeasureUp(textPtr, &textPtr->topIndex, 0, &textPtr->topIndex); } @@ -2925,7 +2929,7 @@ TkTextSetYView(textPtr, indexPtr, pickPlace) * without redisplaying it all. */ - if (indexPtr->charIndex == 0) { + if (indexPtr->byteIndex == 0) { textPtr->topIndex = *indexPtr; } else { MeasureUp(textPtr, indexPtr, 0, &textPtr->topIndex); @@ -2953,7 +2957,7 @@ TkTextSetYView(textPtr, indexPtr, pickPlace) dlPtr = NULL; } else if ((dlPtr->index.linePtr == indexPtr->linePtr) - && (dlPtr->index.charIndex <= indexPtr->charIndex)) { + && (dlPtr->index.byteIndex <= indexPtr->byteIndex)) { return; } } @@ -3051,37 +3055,37 @@ MeasureUp(textPtr, srcPtr, distance, dstPtr) TkTextIndex *dstPtr; /* Index to fill in with result. */ { int lineNum; /* Number of current line. */ - int charsToCount; /* Maximum number of characters to measure - * in current line. */ + int bytesToCount; /* Maximum number of bytes to measure in + * current line. */ TkTextIndex bestIndex; /* Best candidate seen so far for result. */ TkTextIndex index; DLine *dlPtr, *lowestPtr; int noBestYet; /* 1 means bestIndex hasn't been set. */ noBestYet = 1; - charsToCount = srcPtr->charIndex + 1; + bytesToCount = srcPtr->byteIndex + 1; index.tree = srcPtr->tree; for (lineNum = TkBTreeLineIndex(srcPtr->linePtr); lineNum >= 0; lineNum--) { /* * Layout an entire text line (potentially > 1 display line). * For the first line, which contains srcPtr, only layout the - * part up through srcPtr (charsToCount is non-infinite to + * part up through srcPtr (bytesToCount is non-infinite to * accomplish this). Make a list of all the display lines * in backwards order (the lowest DLine on the screen is first * in the list). */ index.linePtr = TkBTreeFindLine(srcPtr->tree, lineNum); - index.charIndex = 0; + index.byteIndex = 0; lowestPtr = NULL; do { dlPtr = LayoutDLine(textPtr, &index); dlPtr->nextPtr = lowestPtr; lowestPtr = dlPtr; - TkTextIndexForwChars(&index, dlPtr->count, &index); - charsToCount -= dlPtr->count; - } while ((charsToCount > 0) && (index.linePtr == dlPtr->index.linePtr)); + TkTextIndexForwBytes(&index, dlPtr->byteCount, &index); + bytesToCount -= dlPtr->byteCount; + } while ((bytesToCount > 0) && (index.linePtr == dlPtr->index.linePtr)); /* * Scan through the display lines to see if we've covered enough @@ -3108,7 +3112,7 @@ MeasureUp(textPtr, srcPtr, distance, dstPtr) if (distance < 0) { return; } - charsToCount = INT_MAX; /* Consider all chars. in next line. */ + bytesToCount = INT_MAX; /* Consider all chars. in next line. */ } /* @@ -3116,7 +3120,7 @@ MeasureUp(textPtr, srcPtr, distance, dstPtr) * in the text. */ - TkTextMakeIndex(textPtr->tree, 0, 0, dstPtr); + TkTextMakeByteIndex(textPtr->tree, 0, 0, dstPtr); } /* @@ -3148,7 +3152,7 @@ TkTextSeeCmd(textPtr, interp, argc, argv) { TextDInfo *dInfoPtr = textPtr->dInfoPtr; TkTextIndex index; - int x, y, width, height, lineWidth, charCount, oneThird, delta; + int x, y, width, height, lineWidth, byteCount, oneThird, delta; DLine *dlPtr; TkTextDispChunk *chunkPtr; @@ -3193,12 +3197,12 @@ TkTextSeeCmd(textPtr, interp, argc, argv) */ dlPtr = FindDLine(dInfoPtr->dLinePtr, &index); - charCount = index.charIndex - dlPtr->index.charIndex; + byteCount = index.byteIndex - dlPtr->index.byteIndex; for (chunkPtr = dlPtr->chunkPtr; ; chunkPtr = chunkPtr->nextPtr) { - if (charCount < chunkPtr->numChars) { + if (byteCount < chunkPtr->numBytes) { break; } - charCount -= chunkPtr->numChars; + byteCount -= chunkPtr->numBytes; } /* @@ -3206,7 +3210,7 @@ TkTextSeeCmd(textPtr, interp, argc, argv) * the character within the chunk. */ - (*chunkPtr->bboxProc)(chunkPtr, charCount, dlPtr->y + dlPtr->spaceAbove, + (*chunkPtr->bboxProc)(chunkPtr, byteCount, dlPtr->y + dlPtr->spaceAbove, dlPtr->height - dlPtr->spaceAbove - dlPtr->spaceBelow, dlPtr->baseline - dlPtr->spaceAbove, &x, &y, &width, &height); @@ -3214,18 +3218,18 @@ TkTextSeeCmd(textPtr, interp, argc, argv) oneThird = lineWidth/3; if (delta < 0) { if (delta < -oneThird) { - dInfoPtr->newCharOffset = (x - lineWidth/2)/textPtr->charWidth; + dInfoPtr->newByteOffset = (x - lineWidth/2)/textPtr->charWidth; } else { - dInfoPtr->newCharOffset -= ((-delta) + textPtr->charWidth - 1) + dInfoPtr->newByteOffset -= ((-delta) + textPtr->charWidth - 1) / textPtr->charWidth; } } else { delta -= (lineWidth - width); if (delta > 0) { if (delta > oneThird) { - dInfoPtr->newCharOffset = (x - lineWidth/2)/textPtr->charWidth; + dInfoPtr->newByteOffset = (x - lineWidth/2)/textPtr->charWidth; } else { - dInfoPtr->newCharOffset += (delta + textPtr->charWidth - 1) + dInfoPtr->newByteOffset += (delta + textPtr->charWidth - 1) / textPtr->charWidth; } } else { @@ -3280,7 +3284,7 @@ TkTextXviewCmd(textPtr, interp, argc, argv) return TCL_OK; } - newOffset = dInfoPtr->newCharOffset; + newOffset = dInfoPtr->newByteOffset; type = Tk_GetScrollInfo(interp, argc, argv, &fraction, &count); switch (type) { case TK_SCROLL_ERROR: @@ -3301,14 +3305,14 @@ TkTextXviewCmd(textPtr, interp, argc, argv) if (charsPerPage < 1) { charsPerPage = 1; } - newOffset += charsPerPage*count; + newOffset += charsPerPage * count; break; case TK_SCROLL_UNITS: newOffset += count; break; } - dInfoPtr->newCharOffset = newOffset; + dInfoPtr->newByteOffset = newOffset; dInfoPtr->flags |= DINFO_OUT_OF_DATE; if (!(dInfoPtr->flags & REDRAW_PENDING)) { dInfoPtr->flags |= REDRAW_PENDING; @@ -3344,7 +3348,7 @@ ScrollByLines(textPtr, offset) * means that information earlier in the * text becomes visible. */ { - int i, charsToCount, lineNum; + int i, bytesToCount, lineNum; TkTextIndex new, index; TkTextLine *lastLinePtr; TextDInfo *dInfoPtr = textPtr->dInfoPtr; @@ -3357,21 +3361,21 @@ ScrollByLines(textPtr, offset) * it counts lines instead of pixels. */ - charsToCount = textPtr->topIndex.charIndex + 1; + bytesToCount = textPtr->topIndex.byteIndex + 1; index.tree = textPtr->tree; offset--; /* Skip line containing topIndex. */ for (lineNum = TkBTreeLineIndex(textPtr->topIndex.linePtr); lineNum >= 0; lineNum--) { index.linePtr = TkBTreeFindLine(textPtr->tree, lineNum); - index.charIndex = 0; + index.byteIndex = 0; lowestPtr = NULL; do { dlPtr = LayoutDLine(textPtr, &index); dlPtr->nextPtr = lowestPtr; lowestPtr = dlPtr; - TkTextIndexForwChars(&index, dlPtr->count, &index); - charsToCount -= dlPtr->count; - } while ((charsToCount > 0) + TkTextIndexForwBytes(&index, dlPtr->byteCount, &index); + bytesToCount -= dlPtr->byteCount; + } while ((bytesToCount > 0) && (index.linePtr == dlPtr->index.linePtr)); for (dlPtr = lowestPtr; dlPtr != NULL; dlPtr = dlPtr->nextPtr) { @@ -3391,7 +3395,7 @@ ScrollByLines(textPtr, offset) if (offset >= 0) { goto scheduleUpdate; } - charsToCount = INT_MAX; + bytesToCount = INT_MAX; } /* @@ -3399,7 +3403,7 @@ ScrollByLines(textPtr, offset) * in the text. */ - TkTextMakeIndex(textPtr->tree, 0, 0, &textPtr->topIndex); + TkTextMakeByteIndex(textPtr->tree, 0, 0, &textPtr->topIndex); } else { /* * Scrolling down, to show later information in the text. @@ -3411,7 +3415,7 @@ ScrollByLines(textPtr, offset) for (i = 0; i < offset; i++) { dlPtr = LayoutDLine(textPtr, &textPtr->topIndex); dlPtr->nextPtr = NULL; - TkTextIndexForwChars(&textPtr->topIndex, dlPtr->count, &new); + TkTextIndexForwBytes(&textPtr->topIndex, dlPtr->byteCount, &new); FreeDLines(textPtr, dlPtr, (DLine *) NULL, 0); if (new.linePtr == lastLinePtr) { break; @@ -3455,7 +3459,7 @@ TkTextYviewCmd(textPtr, interp, argc, argv) * argv[1] is "yview". */ { TextDInfo *dInfoPtr = textPtr->dInfoPtr; - int pickPlace, lineNum, type, charsInLine; + int pickPlace, lineNum, type, bytesInLine; Tk_FontMetrics fm; int pixels, count; size_t switchLength; @@ -3493,7 +3497,7 @@ TkTextYviewCmd(textPtr, interp, argc, argv) } if ((argc == 3) || pickPlace) { if (Tcl_GetInt(interp, argv[2+pickPlace], &lineNum) == TCL_OK) { - TkTextMakeIndex(textPtr->tree, lineNum, 0, &index); + TkTextMakeByteIndex(textPtr->tree, lineNum, 0, &index); TkTextSetYView(textPtr, &index, 0); return TCL_OK; } @@ -3528,11 +3532,11 @@ TkTextYviewCmd(textPtr, interp, argc, argv) } fraction *= TkBTreeNumLines(textPtr->tree); lineNum = (int) fraction; - TkTextMakeIndex(textPtr->tree, lineNum, 0, &index); - charsInLine = TkBTreeCharsInLine(index.linePtr); - index.charIndex = (int)((charsInLine * (fraction-lineNum)) + 0.5); - if (index.charIndex >= charsInLine) { - TkTextMakeIndex(textPtr->tree, lineNum+1, 0, &index); + TkTextMakeByteIndex(textPtr->tree, lineNum, 0, &index); + bytesInLine = TkBTreeBytesInLine(index.linePtr); + index.byteIndex = (int)((bytesInLine * (fraction-lineNum)) + 0.5); + if (index.byteIndex >= bytesInLine) { + TkTextMakeByteIndex(textPtr->tree, lineNum + 1, 0, &index); } TkTextSetYView(textPtr, &index, 0); break; @@ -3570,7 +3574,7 @@ TkTextYviewCmd(textPtr, interp, argc, argv) do { dlPtr = LayoutDLine(textPtr, &textPtr->topIndex); dlPtr->nextPtr = NULL; - TkTextIndexForwChars(&textPtr->topIndex, dlPtr->count, + TkTextIndexForwBytes(&textPtr->topIndex, dlPtr->byteCount, &new); pixels -= dlPtr->height; FreeDLines(textPtr, dlPtr, (DLine *) NULL, 0); @@ -3622,7 +3626,7 @@ TkTextScanCmd(textPtr, interp, argc, argv) { TextDInfo *dInfoPtr = textPtr->dInfoPtr; TkTextIndex index; - int c, x, y, totalScroll, newChar, maxChar; + int c, x, y, totalScroll, newByte, maxByte; Tk_FontMetrics fm; size_t length; @@ -3652,18 +3656,20 @@ TkTextScanCmd(textPtr, interp, argc, argv) * moving again). */ - newChar = dInfoPtr->scanMarkChar + (10*(dInfoPtr->scanMarkX - x)) + newByte = dInfoPtr->scanMarkIndex + (10*(dInfoPtr->scanMarkX - x)) / (textPtr->charWidth); - maxChar = 1 + (dInfoPtr->maxLength - (dInfoPtr->maxX - dInfoPtr->x) + maxByte = 1 + (dInfoPtr->maxLength - (dInfoPtr->maxX - dInfoPtr->x) + textPtr->charWidth - 1)/textPtr->charWidth; - if (newChar < 0) { - dInfoPtr->scanMarkChar = newChar = 0; + if (newByte < 0) { + newByte = 0; + dInfoPtr->scanMarkIndex = 0; dInfoPtr->scanMarkX = x; - } else if (newChar > maxChar) { - dInfoPtr->scanMarkChar = newChar = maxChar; + } else if (newByte > maxByte) { + newByte = maxByte; + dInfoPtr->scanMarkIndex = maxByte; dInfoPtr->scanMarkX = x; } - dInfoPtr->newCharOffset = newChar; + dInfoPtr->newByteOffset = newByte; Tk_GetFontMetrics(textPtr->tkfont, &fm); totalScroll = (10*(dInfoPtr->scanMarkY - y)) / fm.linespace; @@ -3672,13 +3678,13 @@ TkTextScanCmd(textPtr, interp, argc, argv) ScrollByLines(textPtr, totalScroll-dInfoPtr->scanTotalScroll); dInfoPtr->scanTotalScroll = totalScroll; if ((index.linePtr == textPtr->topIndex.linePtr) && - (index.charIndex == textPtr->topIndex.charIndex)) { + (index.byteIndex == textPtr->topIndex.byteIndex)) { dInfoPtr->scanTotalScroll = 0; dInfoPtr->scanMarkY = y; } } } else if ((c == 'm') && (strncmp(argv[2], "mark", length) == 0)) { - dInfoPtr->scanMarkChar = dInfoPtr->newCharOffset; + dInfoPtr->scanMarkIndex = dInfoPtr->newByteOffset; dInfoPtr->scanMarkX = x; dInfoPtr->scanTotalScroll = 0; dInfoPtr->scanMarkY = y; @@ -3705,11 +3711,11 @@ TkTextScanCmd(textPtr, interp, argc, argv) * Tcl script to report them to the text's associated scrollbar. * * Results: - * If report is zero, then interp->result is filled in with + * If report is zero, then the interp's result is filled in with * two real numbers separated by a space, giving the position of * the left and right edges of the window as fractions from 0 to * 1, where 0 means the left edge of the text and 1 means the right - * edge. If report is non-zero, then interp->result isn't modified + * edge. If report is non-zero, then the interp's result isn't modified * directly, but instead a script is evaluated in interp to report * the new horizontal scroll position to the scrollbar (if the scroll * position hasn't changed then no script is invoked). @@ -3724,13 +3730,13 @@ static void GetXView(interp, textPtr, report) Tcl_Interp *interp; /* If "report" is FALSE, string * describing visible range gets - * stored in interp->result. */ + * stored in the interp's result. */ TkText *textPtr; /* Information about text widget. */ int report; /* Non-zero means report info to * scrollbar if it has changed. */ { TextDInfo *dInfoPtr = textPtr->dInfoPtr; - char buffer[200]; + char buffer[TCL_DOUBLE_SPACE * 2]; double first, last; int code; @@ -3747,7 +3753,8 @@ GetXView(interp, textPtr, report) last = 1.0; } if (!report) { - sprintf(interp->result, "%g %g", first, last); + sprintf(buffer, "%g %g", first, last); + Tcl_SetResult(interp, buffer, TCL_VOLATILE); return; } if ((first == dInfoPtr->xScrollFirst) && (last == dInfoPtr->xScrollLast)) { @@ -3775,11 +3782,11 @@ GetXView(interp, textPtr, report) * Tcl script to report them to the text's associated scrollbar. * * Results: - * If report is zero, then interp->result is filled in with + * If report is zero, then the interp's result is filled in with * two real numbers separated by a space, giving the position of * the top and bottom of the window as fractions from 0 to 1, where * 0 means the beginning of the text and 1 means the end. If - * report is non-zero, then interp->result isn't modified directly, + * report is non-zero, then the interp's result isn't modified directly, * but a script is evaluated in interp to report the new scroll * position to the scrollbar (if the scroll position hasn't changed * then no script is invoked). @@ -3794,22 +3801,22 @@ static void GetYView(interp, textPtr, report) Tcl_Interp *interp; /* If "report" is FALSE, string * describing visible range gets - * stored in interp->result. */ + * stored in the interp's result. */ TkText *textPtr; /* Information about text widget. */ int report; /* Non-zero means report info to * scrollbar if it has changed. */ { TextDInfo *dInfoPtr = textPtr->dInfoPtr; - char buffer[200]; + char buffer[TCL_DOUBLE_SPACE * 2]; double first, last; DLine *dlPtr; int totalLines, code, count; dlPtr = dInfoPtr->dLinePtr; totalLines = TkBTreeNumLines(textPtr->tree); - first = ((double) TkBTreeLineIndex(dlPtr->index.linePtr)) - + ((double) dlPtr->index.charIndex) - / (TkBTreeCharsInLine(dlPtr->index.linePtr)); + first = (double) TkBTreeLineIndex(dlPtr->index.linePtr) + + (double) dlPtr->index.byteIndex + / TkBTreeBytesInLine(dlPtr->index.linePtr); first /= totalLines; while (1) { if ((dlPtr->y + dlPtr->height) > dInfoPtr->maxY) { @@ -3821,17 +3828,18 @@ GetYView(interp, textPtr, report) break; } if (dlPtr->nextPtr == NULL) { - count = dlPtr->count; + count = dlPtr->byteCount; break; } dlPtr = dlPtr->nextPtr; } last = ((double) TkBTreeLineIndex(dlPtr->index.linePtr)) - + ((double) (dlPtr->index.charIndex + count)) - / (TkBTreeCharsInLine(dlPtr->index.linePtr)); + + ((double) (dlPtr->index.byteIndex + count)) + / (TkBTreeBytesInLine(dlPtr->index.linePtr)); last /= totalLines; if (!report) { - sprintf(interp->result, "%g %g", first, last); + sprintf(buffer, "%g %g", first, last); + Tcl_SetResult(interp, buffer, TCL_VOLATILE); return; } if ((first == dInfoPtr->yScrollFirst) && (last == dInfoPtr->yScrollLast)) { @@ -3840,8 +3848,7 @@ GetYView(interp, textPtr, report) dInfoPtr->yScrollFirst = first; dInfoPtr->yScrollLast = last; sprintf(buffer, " %g %g", first, last); - code = Tcl_VarEval(interp, textPtr->yScrollCmd, - buffer, (char *) NULL); + code = Tcl_VarEval(interp, textPtr->yScrollCmd, buffer, (char *) NULL); if (code != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (vertical scrolling command executed by text)"); @@ -3913,7 +3920,7 @@ FindDLine(dlPtr, indexPtr) * Now get to the right position within the text line. */ - while (indexPtr->charIndex >= (dlPtr->index.charIndex + dlPtr->count)) { + while (indexPtr->byteIndex >= (dlPtr->index.byteIndex + dlPtr->byteCount)) { dlPtr = dlPtr->nextPtr; if ((dlPtr == NULL) || (dlPtr->index.linePtr != indexPtr->linePtr)) { break; @@ -4005,21 +4012,22 @@ TkTextPixelIndex(textPtr, x, y, indexPtr) *indexPtr = dlPtr->index; x = x - dInfoPtr->x + dInfoPtr->curPixelOffset; for (chunkPtr = dlPtr->chunkPtr; x >= (chunkPtr->x + chunkPtr->width); - indexPtr->charIndex += chunkPtr->numChars, + indexPtr->byteIndex += chunkPtr->numBytes, chunkPtr = chunkPtr->nextPtr) { if (chunkPtr->nextPtr == NULL) { - indexPtr->charIndex += chunkPtr->numChars - 1; + indexPtr->byteIndex += chunkPtr->numBytes; + TkTextIndexBackChars(indexPtr, 1, indexPtr); return; } } /* - * If the chunk has more than one character in it, ask it which + * If the chunk has more than one byte in it, ask it which * character is at the desired location. */ - if (chunkPtr->numChars > 1) { - indexPtr->charIndex += (*chunkPtr->measureProc)(chunkPtr, x); + if (chunkPtr->numBytes > 1) { + indexPtr->byteIndex += (*chunkPtr->measureProc)(chunkPtr, x); } } @@ -4056,7 +4064,7 @@ TkTextCharBbox(textPtr, indexPtr, xPtr, yPtr, widthPtr, heightPtr) TextDInfo *dInfoPtr = textPtr->dInfoPtr; DLine *dlPtr; register TkTextDispChunk *chunkPtr; - int index; + int byteIndex; /* * Make sure that all of the screen layout information is up to date. @@ -4080,15 +4088,15 @@ TkTextCharBbox(textPtr, indexPtr, xPtr, yPtr, widthPtr, heightPtr) * index. */ - index = indexPtr->charIndex - dlPtr->index.charIndex; + byteIndex = indexPtr->byteIndex - dlPtr->index.byteIndex; for (chunkPtr = dlPtr->chunkPtr; ; chunkPtr = chunkPtr->nextPtr) { if (chunkPtr == NULL) { return -1; } - if (index < chunkPtr->numChars) { + if (byteIndex < chunkPtr->numBytes) { break; } - index -= chunkPtr->numChars; + byteIndex -= chunkPtr->numBytes; } /* @@ -4099,12 +4107,12 @@ TkTextCharBbox(textPtr, indexPtr, xPtr, yPtr, widthPtr, heightPtr) * horizontal scrolling. */ - (*chunkPtr->bboxProc)(chunkPtr, index, dlPtr->y + dlPtr->spaceAbove, + (*chunkPtr->bboxProc)(chunkPtr, byteIndex, dlPtr->y + dlPtr->spaceAbove, dlPtr->height - dlPtr->spaceAbove - dlPtr->spaceBelow, dlPtr->baseline - dlPtr->spaceAbove, xPtr, yPtr, widthPtr, heightPtr); *xPtr = *xPtr + dInfoPtr->x - dInfoPtr->curPixelOffset; - if ((index == (chunkPtr->numChars-1)) && (chunkPtr->nextPtr == NULL)) { + if ((byteIndex == (chunkPtr->numBytes - 1)) && (chunkPtr->nextPtr == NULL)) { /* * Last character in display line. Give it all the space up to * the line. @@ -4203,7 +4211,7 @@ TkTextDLineInfo(textPtr, indexPtr, xPtr, yPtr, widthPtr, heightPtr, basePtr) * * This procedure is the "layoutProc" for character segments. * - * Results: +n * Results: * If there is something to display for the chunk then a * non-zero value is returned and the fields of chunkPtr * will be filled in (see the declaration of TkTextDispChunk @@ -4220,17 +4228,17 @@ TkTextDLineInfo(textPtr, indexPtr, xPtr, yPtr, widthPtr, heightPtr, basePtr) */ int -TkTextCharLayoutProc(textPtr, indexPtr, segPtr, offset, maxX, maxChars, +TkTextCharLayoutProc(textPtr, indexPtr, segPtr, byteOffset, maxX, maxBytes, noCharsYet, wrapMode, chunkPtr) TkText *textPtr; /* Text widget being layed out. */ TkTextIndex *indexPtr; /* Index of first character to lay out * (corresponds to segPtr and offset). */ TkTextSegment *segPtr; /* Segment being layed out. */ - int offset; /* Offset within segment of first character - * to consider. */ + int byteOffset; /* Byte offset within segment of first + * character to consider. */ int maxX; /* Chunk must not occupy pixels at this * position or higher. */ - int maxChars; /* Chunk must not include more than this + int maxBytes; /* Chunk must not include more than this * many characters. */ int noCharsYet; /* Non-zero means no characters have been * assigned to this display line yet. */ @@ -4242,7 +4250,7 @@ TkTextCharLayoutProc(textPtr, indexPtr, segPtr, offset, maxX, maxChars, * been set by the caller. */ { Tk_Font tkfont; - int nextX, charsThatFit, count; + int nextX, bytesThatFit, count; CharInfo *ciPtr; char *p; TkTextSegment *nextPtr; @@ -4260,17 +4268,19 @@ TkTextCharLayoutProc(textPtr, indexPtr, segPtr, offset, maxX, maxChars, * is a white space character. */ - p = segPtr->body.chars + offset; + p = segPtr->body.chars + byteOffset; tkfont = chunkPtr->stylePtr->sValuePtr->tkfont; - charsThatFit = MeasureChars(tkfont, p, maxChars, chunkPtr->x, maxX, 0, + bytesThatFit = MeasureChars(tkfont, p, maxBytes, chunkPtr->x, maxX, 0, &nextX); - if (charsThatFit < maxChars) { - if ((charsThatFit == 0) && noCharsYet) { - charsThatFit = 1; - MeasureChars(tkfont, p, 1, chunkPtr->x, INT_MAX, 0, &nextX); + if (bytesThatFit < maxBytes) { + if ((bytesThatFit == 0) && noCharsYet) { + Tcl_UniChar ch; + + bytesThatFit = MeasureChars(tkfont, p, Tcl_UtfToUniChar(p, &ch), + chunkPtr->x, -1, 0, &nextX); } - if ((nextX < maxX) && ((p[charsThatFit] == ' ') - || (p[charsThatFit] == '\t'))) { + if ((nextX < maxX) && ((p[bytesThatFit] == ' ') + || (p[bytesThatFit] == '\t'))) { /* * Space characters are funny, in that they are considered * to fit if there is at least one pixel of space left on the @@ -4278,17 +4288,17 @@ TkTextCharLayoutProc(textPtr, indexPtr, segPtr, offset, maxX, maxChars, */ nextX = maxX; - charsThatFit++; + bytesThatFit++; } - if (p[charsThatFit] == '\n') { + if (p[bytesThatFit] == '\n') { /* * A newline character takes up no space, so if the previous * character fits then so does the newline. */ - charsThatFit++; + bytesThatFit++; } - if (charsThatFit == 0) { + if (bytesThatFit == 0) { return 0; } } @@ -4305,19 +4315,19 @@ TkTextCharLayoutProc(textPtr, indexPtr, segPtr, offset, maxX, maxChars, chunkPtr->undisplayProc = CharUndisplayProc; chunkPtr->measureProc = CharMeasureProc; chunkPtr->bboxProc = CharBboxProc; - chunkPtr->numChars = charsThatFit; + chunkPtr->numBytes = bytesThatFit; chunkPtr->minAscent = fm.ascent + chunkPtr->stylePtr->sValuePtr->offset; chunkPtr->minDescent = fm.descent - chunkPtr->stylePtr->sValuePtr->offset; chunkPtr->minHeight = 0; chunkPtr->width = nextX - chunkPtr->x; chunkPtr->breakIndex = -1; ciPtr = (CharInfo *) ckalloc((unsigned) - (sizeof(CharInfo) - 3 + charsThatFit)); + (sizeof(CharInfo) - 3 + bytesThatFit)); chunkPtr->clientData = (ClientData) ciPtr; - ciPtr->numChars = charsThatFit; - strncpy(ciPtr->chars, p, (size_t) charsThatFit); - if (p[charsThatFit-1] == '\n') { - ciPtr->numChars--; + ciPtr->numBytes = bytesThatFit; + strncpy(ciPtr->chars, p, (size_t) bytesThatFit); + if (p[bytesThatFit - 1] == '\n') { + ciPtr->numBytes--; } /* @@ -4328,21 +4338,21 @@ TkTextCharLayoutProc(textPtr, indexPtr, segPtr, offset, maxX, maxChars, */ if (wrapMode != tkTextWordUid) { - chunkPtr->breakIndex = chunkPtr->numChars; + chunkPtr->breakIndex = chunkPtr->numBytes; } else { - for (count = charsThatFit, p += charsThatFit-1; count > 0; + for (count = bytesThatFit, p += bytesThatFit - 1; count > 0; count--, p--) { if (isspace(UCHAR(*p))) { chunkPtr->breakIndex = count; break; } } - if ((charsThatFit+offset) == segPtr->size) { + if ((bytesThatFit + byteOffset) == segPtr->size) { for (nextPtr = segPtr->nextPtr; nextPtr != NULL; nextPtr = nextPtr->nextPtr) { if (nextPtr->size != 0) { if (nextPtr->typePtr != &tkTextCharType) { - chunkPtr->breakIndex = chunkPtr->numChars; + chunkPtr->breakIndex = chunkPtr->numBytes; } break; } @@ -4389,7 +4399,7 @@ CharDisplayProc(chunkPtr, x, y, height, baseline, display, dst, screenY) CharInfo *ciPtr = (CharInfo *) chunkPtr->clientData; TextStyle *stylePtr; StyleValues *sValuePtr; - int offsetChars, offsetX; + int offsetBytes, offsetX; if ((x + chunkPtr->width) <= 0) { /* @@ -4411,30 +4421,29 @@ CharDisplayProc(chunkPtr, x, y, height, baseline, display, dst, screenY) */ offsetX = x; - offsetChars = 0; + offsetBytes = 0; if (x < 0) { - offsetChars = MeasureChars(sValuePtr->tkfont, ciPtr->chars, - ciPtr->numChars, x, 0, x - chunkPtr->x, &offsetX); + offsetBytes = MeasureChars(sValuePtr->tkfont, ciPtr->chars, + ciPtr->numBytes, x, 0, x - chunkPtr->x, &offsetX); } /* * Draw the text, underline, and overstrike for this chunk. */ - if (ciPtr->numChars > offsetChars) { - int numChars = ciPtr->numChars - offsetChars; - char *string = ciPtr->chars + offsetChars; + if (ciPtr->numBytes > offsetBytes) { + int numBytes = ciPtr->numBytes - offsetBytes; + char *string = ciPtr->chars + offsetBytes; - if ((numChars > 0) && (string[numChars - 1] == '\t')) { - numChars--; + if ((numBytes > 0) && (string[numBytes - 1] == '\t')) { + numBytes--; } Tk_DrawChars(display, dst, stylePtr->fgGC, sValuePtr->tkfont, string, - numChars, offsetX, y + baseline - sValuePtr->offset); + numBytes, offsetX, y + baseline - sValuePtr->offset); if (sValuePtr->underline) { Tk_UnderlineChars(display, dst, stylePtr->fgGC, sValuePtr->tkfont, - ciPtr->chars + offsetChars, offsetX, - y + baseline - sValuePtr->offset, - 0, numChars); + ciPtr->chars + offsetBytes, offsetX, + y + baseline - sValuePtr->offset, 0, numBytes); } if (sValuePtr->overstrike) { @@ -4442,10 +4451,10 @@ CharDisplayProc(chunkPtr, x, y, height, baseline, display, dst, screenY) Tk_GetFontMetrics(sValuePtr->tkfont, &fm); Tk_UnderlineChars(display, dst, stylePtr->fgGC, sValuePtr->tkfont, - ciPtr->chars + offsetChars, offsetX, + ciPtr->chars + offsetBytes, offsetX, y + baseline - sValuePtr->offset - fm.descent - (fm.ascent * 3) / 10, - 0, numChars); + 0, numBytes); } } } @@ -4507,7 +4516,8 @@ CharMeasureProc(chunkPtr, x) int endX; return MeasureChars(chunkPtr->stylePtr->sValuePtr->tkfont, ciPtr->chars, - chunkPtr->numChars-1, chunkPtr->x, x, 0, &endX); + chunkPtr->numBytes - 1, chunkPtr->x, x, 0, &endX); + /* CHAR OFFSET */ } /* @@ -4534,11 +4544,11 @@ CharMeasureProc(chunkPtr, x) */ static void -CharBboxProc(chunkPtr, index, y, lineHeight, baseline, xPtr, yPtr, +CharBboxProc(chunkPtr, byteIndex, y, lineHeight, baseline, xPtr, yPtr, widthPtr, heightPtr) TkTextDispChunk *chunkPtr; /* Chunk containing desired char. */ - int index; /* Index of desired character within - * the chunk. */ + int byteIndex; /* Byte offset of desired character + * within the chunk. */ int y; /* Topmost pixel in area allocated * for this line. */ int lineHeight; /* Height of line, in pixels. */ @@ -4557,10 +4567,10 @@ CharBboxProc(chunkPtr, index, y, lineHeight, baseline, xPtr, yPtr, int maxX; maxX = chunkPtr->width + chunkPtr->x; - MeasureChars(chunkPtr->stylePtr->sValuePtr->tkfont, ciPtr->chars, index, - chunkPtr->x, 1000000, 0, xPtr); + MeasureChars(chunkPtr->stylePtr->sValuePtr->tkfont, ciPtr->chars, + byteIndex, chunkPtr->x, -1, 0, xPtr); - if (index == ciPtr->numChars) { + if (byteIndex == ciPtr->numBytes) { /* * This situation only happens if the last character in a line * is a space character, in which case it absorbs all of the @@ -4568,8 +4578,8 @@ CharBboxProc(chunkPtr, index, y, lineHeight, baseline, xPtr, yPtr, */ *widthPtr = maxX - *xPtr; - } else if ((ciPtr->chars[index] == '\t') - && (index == (ciPtr->numChars-1))) { + } else if ((ciPtr->chars[byteIndex] == '\t') + && (byteIndex == ciPtr->numBytes - 1)) { /* * The desired character is a tab character that terminates a * chunk; give it all the space left in the chunk. @@ -4578,7 +4588,7 @@ CharBboxProc(chunkPtr, index, y, lineHeight, baseline, xPtr, yPtr, *widthPtr = maxX - *xPtr; } else { MeasureChars(chunkPtr->stylePtr->sValuePtr->tkfont, - ciPtr->chars + index, 1, *xPtr, 1000000, 0, widthPtr); + ciPtr->chars + byteIndex, 1, *xPtr, -1, 0, widthPtr); if (*widthPtr > maxX) { *widthPtr = maxX - *xPtr; } else { @@ -4713,7 +4723,7 @@ AdjustForTab(textPtr, tabArrayPtr, index, chunkPtr) continue; } ciPtr = (CharInfo *) chunkPtr2->clientData; - for (p = ciPtr->chars, i = 0; i < ciPtr->numChars; p++, i++) { + for (p = ciPtr->chars, i = 0; i < ciPtr->numBytes; p++, i++) { if (isdigit(UCHAR(*p))) { gotDigit = 1; } else if ((*p == '.') || (*p == ',')) { @@ -4734,7 +4744,7 @@ AdjustForTab(textPtr, tabArrayPtr, index, chunkPtr) ciPtr = (CharInfo *) decimalChunkPtr->clientData; MeasureChars(decimalChunkPtr->stylePtr->sValuePtr->tkfont, - ciPtr->chars, decimal, decimalChunkPtr->x, 1000000, 0, &curX); + ciPtr->chars, decimal, decimalChunkPtr->x, -1, 0, &curX); desired = tabX - (curX - x); goto update; } else { @@ -4759,7 +4769,7 @@ AdjustForTab(textPtr, tabArrayPtr, index, chunkPtr) update: delta = desired - x; - MeasureChars(textPtr->tkfont, " ", 1, 0, INT_MAX, 0, &spaceWidth); + MeasureChars(textPtr->tkfont, " ", 1, 0, -1, 0, &spaceWidth); if (delta < spaceWidth) { delta = spaceWidth; } @@ -4864,7 +4874,7 @@ SizeOfTab(textPtr, tabArrayPtr, index, x, maxX) } done: - MeasureChars(textPtr->tkfont, " ", 1, 0, INT_MAX, 0, &spaceWidth); + MeasureChars(textPtr->tkfont, " ", 1, 0, -1, 0, &spaceWidth); if (result < spaceWidth) { result = spaceWidth; } @@ -4934,7 +4944,7 @@ NextTabStop(tkfont, x, tabOrigin) * is specified. * * Results: - * The return value is the number of characters from source + * The return value is the number of bytes from source * that fit in the span given by startX and maxX. *nextXPtr * is filled in with the x-coordinate at which the first * character that didn't fit would be drawn, if it were to @@ -4947,11 +4957,11 @@ NextTabStop(tkfont, x, tabOrigin) */ static int -MeasureChars(tkfont, source, maxChars, startX, maxX, tabOrigin, nextXPtr) +MeasureChars(tkfont, source, maxBytes, startX, maxX, tabOrigin, nextXPtr) Tk_Font tkfont; /* Font in which to draw characters. */ CONST char *source; /* Characters to be displayed. Need not * be NULL-terminated. */ - int maxChars; /* Maximum # of characters to consider from + int maxBytes; /* Maximum # of bytes to consider from * source. */ int startX; /* X-position at which first character will * be drawn. */ @@ -4968,7 +4978,7 @@ MeasureChars(tkfont, source, maxChars, startX, maxX, tabOrigin, nextXPtr) ch = 0; /* lint. */ curX = startX; special = source; - end = source + maxChars; + end = source + maxBytes; for (start = source; start < end; ) { if (start >= special) { /* @@ -4988,7 +4998,7 @@ MeasureChars(tkfont, source, maxChars, startX, maxX, tabOrigin, nextXPtr) * string). Process characters between start and special. */ - if (curX >= maxX) { + if ((maxX >= 0) && (curX >= maxX)) { break; } start += Tk_MeasureChars(tkfont, start, special - start, maxX - curX, diff --git a/generic/tkTextImage.c b/generic/tkTextImage.c index b5e363f..dae1751 100644 --- a/generic/tkTextImage.c +++ b/generic/tkTextImage.c @@ -5,12 +5,12 @@ * nested inside text widgets. It also implements the "image" * widget command for texts. * - * Copyright (c) 1996 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkTextImage.c 1.7 97/08/25 15:47:27 + * SCCS: @(#) tkTextImage.c 1.10 98/01/08 13:41:36 */ #include "tk.h" @@ -221,7 +221,7 @@ TkTextImageCmd(textPtr, interp, argc, argv) lineIndex = TkBTreeLineIndex(index.linePtr); if (lineIndex == TkBTreeNumLines(textPtr->tree)) { lineIndex--; - TkTextMakeIndex(textPtr->tree, lineIndex, 1000000, &index); + TkTextMakeByteIndex(textPtr->tree, lineIndex, 1000000, &index); } /* @@ -288,7 +288,7 @@ TkTextImageCmd(textPtr, interp, argc, argv) * * Results: * The return value is a standard Tcl result. If TCL_ERROR is - * returned, then interp->result contains an error message.. + * returned, then the interp's result contains an error message.. * * Side effects: * Configuration information for the embedded image changes, @@ -384,7 +384,7 @@ EmbImageConfigure(textPtr, eiPtr, argc, argv) Tcl_DStringAppend(&newName,name, -1); if (conflict) { - char buf[10]; + char buf[4 + TCL_INTEGER_SPACE]; sprintf(buf, "#%d",count+1); Tcl_DStringAppend(&newName,buf, -1); } @@ -642,7 +642,7 @@ EmbImageLayoutProc(textPtr, indexPtr, eiPtr, offset, maxX, maxChars, chunkPtr->undisplayProc = (Tk_ChunkUndisplayProc *) NULL; chunkPtr->measureProc = (Tk_ChunkMeasureProc *) NULL; chunkPtr->bboxProc = EmbImageBboxProc; - chunkPtr->numChars = 1; + chunkPtr->numBytes = 1; if (eiPtr->body.ei.align == ALIGN_BASELINE) { chunkPtr->minAscent = height - eiPtr->body.ei.padY; chunkPtr->minDescent = eiPtr->body.ei.padY; @@ -857,7 +857,7 @@ TkTextImageIndex(textPtr, name, indexPtr) eiPtr = (TkTextSegment *) Tcl_GetHashValue(hPtr); indexPtr->tree = textPtr->tree; indexPtr->linePtr = eiPtr->body.ei.linePtr; - indexPtr->charIndex = TkTextSegToOffset(eiPtr, indexPtr->linePtr); + indexPtr->byteIndex = TkTextSegToOffset(eiPtr, indexPtr->linePtr); return 1; } @@ -893,6 +893,6 @@ EmbImageProc(clientData, x, y, width, height, imgWidth, imgHeight) index.tree = eiPtr->body.ei.textPtr->tree; index.linePtr = eiPtr->body.ei.linePtr; - index.charIndex = TkTextSegToOffset(eiPtr, eiPtr->body.ei.linePtr); + index.byteIndex = TkTextSegToOffset(eiPtr, eiPtr->body.ei.linePtr); TkTextChanged(eiPtr->body.ei.textPtr, &index, &index); } diff --git a/generic/tkTextIndex.c b/generic/tkTextIndex.c index d88d88a..8805a29 100644 --- a/generic/tkTextIndex.c +++ b/generic/tkTextIndex.c @@ -5,12 +5,12 @@ * text widgets. * * Copyright (c) 1992-1994 The Regents of the University of California. - * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkTextIndex.c 1.15 97/06/17 17:49:24 + * SCCS: @(#) tkTextIndex.c 1.18 98/01/12 15:33:45 */ #include "default.h" @@ -34,27 +34,118 @@ static char * StartEnd _ANSI_ARGS_(( char *string, TkTextIndex *indexPtr)); /* - *-------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * TkTextMakeIndex -- + * TkTextMakeByteIndex -- * - * Given a line index and a character index, look things up - * in the B-tree and fill in a TkTextIndex structure. + * Given a line index and a byte index, look things up in the B-tree + * and fill in a TkTextIndex structure. * * Results: - * The structure at *indexPtr is filled in with information - * about the character at lineIndex and charIndex (or the - * closest existing character, if the specified one doesn't - * exist), and indexPtr is returned as result. + * The structure at *indexPtr is filled in with information about the + * character at lineIndex and byteIndex (or the closest existing + * character, if the specified one doesn't exist), and indexPtr is + * returned as result. * * Side effects: * None. * - *-------------------------------------------------------------- + *--------------------------------------------------------------------------- */ TkTextIndex * -TkTextMakeIndex(tree, lineIndex, charIndex, indexPtr) +TkTextMakeByteIndex(tree, lineIndex, byteIndex, indexPtr) + TkTextBTree tree; /* Tree that lineIndex and charIndex refer + * to. */ + int lineIndex; /* Index of desired line (0 means first + * line of text). */ + int byteIndex; /* Byte index of desired character. */ + TkTextIndex *indexPtr; /* Structure to fill in. */ +{ + TkTextSegment *segPtr; + int index; + char *p, *start; + Tcl_UniChar ch; + + indexPtr->tree = tree; + if (lineIndex < 0) { + lineIndex = 0; + byteIndex = 0; + } + if (byteIndex < 0) { + byteIndex = 0; + } + indexPtr->linePtr = TkBTreeFindLine(tree, lineIndex); + if (indexPtr->linePtr == NULL) { + indexPtr->linePtr = TkBTreeFindLine(tree, TkBTreeNumLines(tree)); + byteIndex = 0; + } + if (byteIndex == 0) { + indexPtr->byteIndex = byteIndex; + return indexPtr; + } + + /* + * Verify that the index is within the range of the line and points + * to a valid character boundary. + */ + + index = 0; + for (segPtr = indexPtr->linePtr->segPtr; ; segPtr = segPtr->nextPtr) { + if (segPtr == NULL) { + /* + * Use the index of the last character in the line. Since + * the last character on the line is guaranteed to be a '\n', + * we can back up a constant sizeof(char) bytes. + */ + + indexPtr->byteIndex = index - sizeof(char); + break; + } + if (index + segPtr->size > byteIndex) { + indexPtr->byteIndex = byteIndex; + if ((byteIndex > index) && (segPtr->typePtr == &tkTextCharType)) { + /* + * Prevent UTF-8 character from being split up by ensuring + * that byteIndex falls on a character boundary. If index + * falls in the middle of a UTF-8 character, it will be + * adjusted to the end of that UTF-8 character. + */ + + start = segPtr->body.chars + (byteIndex - index); + p = Tcl_UtfPrev(start, segPtr->body.chars); + p += Tcl_UtfToUniChar(p, &ch); + indexPtr->byteIndex += p - start; + } + break; + } + index += segPtr->size; + } + return indexPtr; +} + +/* + *--------------------------------------------------------------------------- + * + * TkTextMakeCharIndex -- + * + * Given a line index and a character index, look things up in the + * B-tree and fill in a TkTextIndex structure. + * + * Results: + * The structure at *indexPtr is filled in with information about the + * character at lineIndex and charIndex (or the closest existing + * character, if the specified one doesn't exist), and indexPtr is + * returned as result. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +TkTextIndex * +TkTextMakeCharIndex(tree, lineIndex, charIndex, indexPtr) TkTextBTree tree; /* Tree that lineIndex and charIndex refer * to. */ int lineIndex; /* Index of desired line (0 means first @@ -63,7 +154,9 @@ TkTextMakeIndex(tree, lineIndex, charIndex, indexPtr) TkTextIndex *indexPtr; /* Structure to fill in. */ { register TkTextSegment *segPtr; - int index; + char *p, *start, *end; + int index, offset; + Tcl_UniChar ch; indexPtr->tree = tree; if (lineIndex < 0) { @@ -84,53 +177,76 @@ TkTextMakeIndex(tree, lineIndex, charIndex, indexPtr) * If not, just use the index of the last character in the line. */ - for (index = 0, segPtr = indexPtr->linePtr->segPtr; ; - segPtr = segPtr->nextPtr) { + index = 0; + for (segPtr = indexPtr->linePtr->segPtr; ; segPtr = segPtr->nextPtr) { if (segPtr == NULL) { - indexPtr->charIndex = index-1; + /* + * Use the index of the last character in the line. Since + * the last character on the line is guaranteed to be a '\n', + * we can back up a constant sizeof(char) bytes. + */ + + indexPtr->byteIndex = index - sizeof(char); break; } - index += segPtr->size; - if (index > charIndex) { - indexPtr->charIndex = charIndex; - break; + if (segPtr->typePtr == &tkTextCharType) { + /* + * Turn character offset into a byte offset. + */ + + start = segPtr->body.chars; + end = start + segPtr->size; + for (p = start; p < end; p += offset) { + if (charIndex == 0) { + indexPtr->byteIndex = index; + return indexPtr; + } + charIndex--; + offset = Tcl_UtfToUniChar(p, &ch); + index += offset; + } + } else { + if (charIndex < segPtr->size) { + indexPtr->byteIndex = index; + break; + } + charIndex -= segPtr->size; + index += segPtr->size; } } return indexPtr; } /* - *-------------------------------------------------------------- + *--------------------------------------------------------------------------- * * TkTextIndexToSeg -- * - * Given an index, this procedure returns the segment and - * offset within segment for the index. + * Given an index, this procedure returns the segment and offset + * within segment for the index. * * Results: - * The return value is a pointer to the segment referred to - * by indexPtr; this will always be a segment with non-zero - * size. The variable at *offsetPtr is set to hold the - * integer offset within the segment of the character - * given by indexPtr. + * The return value is a pointer to the segment referred to by + * indexPtr; this will always be a segment with non-zero size. The + * variable at *offsetPtr is set to hold the integer offset within + * the segment of the character given by indexPtr. * * Side effects: * None. * - *-------------------------------------------------------------- + *--------------------------------------------------------------------------- */ TkTextSegment * TkTextIndexToSeg(indexPtr, offsetPtr) - TkTextIndex *indexPtr; /* Text index. */ - int *offsetPtr; /* Where to store offset within - * segment, or NULL if offset isn't - * wanted. */ + CONST TkTextIndex *indexPtr;/* Text index. */ + int *offsetPtr; /* Where to store offset within segment, or + * NULL if offset isn't wanted. */ { - register TkTextSegment *segPtr; + TkTextSegment *segPtr; int offset; - for (offset = indexPtr->charIndex, segPtr = indexPtr->linePtr->segPtr; + for (offset = indexPtr->byteIndex, segPtr = indexPtr->linePtr->segPtr; offset >= segPtr->size; offset -= segPtr->size, segPtr = segPtr->nextPtr) { /* Empty loop body. */ @@ -142,30 +258,29 @@ TkTextIndexToSeg(indexPtr, offsetPtr) } /* - *-------------------------------------------------------------- + *--------------------------------------------------------------------------- * * TkTextSegToOffset -- * - * Given a segment pointer and the line containing it, this - * procedure returns the offset of the segment within its - * line. + * Given a segment pointer and the line containing it, this procedure + * returns the offset of the segment within its line. * * Results: - * The return value is the offset (within its line) of the - * first character in segPtr. + * The return value is the offset (within its line) of the first + * character in segPtr. * * Side effects: * None. * - *-------------------------------------------------------------- + *--------------------------------------------------------------------------- */ int TkTextSegToOffset(segPtr, linePtr) - TkTextSegment *segPtr; /* Segment whose offset is desired. */ - TkTextLine *linePtr; /* Line containing segPtr. */ + CONST TkTextSegment *segPtr;/* Segment whose offset is desired. */ + CONST TkTextLine *linePtr; /* Line containing segPtr. */ { - TkTextSegment *segPtr2; + CONST TkTextSegment *segPtr2; int offset; offset = 0; @@ -177,23 +292,22 @@ TkTextSegToOffset(segPtr, linePtr) } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * * TkTextGetIndex -- * - * Given a string, return the line and character indices that - * it describes. + * Given a string, return the index that is described. * * Results: - * The return value is a standard Tcl return result. If - * TCL_OK is returned, then everything went well and the index - * at *indexPtr is filled in; otherwise TCL_ERROR is returned - * and an error message is left in interp->result. + * The return value is a standard Tcl return result. If TCL_OK is + * returned, then everything went well and the index at *indexPtr is + * filled in; otherwise TCL_ERROR is returned and an error message + * is left in the interp's result. * * Side effects: * None. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ int @@ -203,8 +317,7 @@ TkTextGetIndex(interp, textPtr, string, indexPtr) char *string; /* Textual description of position. */ TkTextIndex *indexPtr; /* Index structure to fill in. */ { - register char *p; - char *end, *endOfBase; + char *p, *end, *endOfBase; Tcl_HashEntry *hPtr; TkTextTag *tagPtr; TkTextSearch search; @@ -259,8 +372,8 @@ TkTextGetIndex(interp, textPtr, string, indexPtr) goto tryxy; } tagPtr = (TkTextTag *) Tcl_GetHashValue(hPtr); - TkTextMakeIndex(textPtr->tree, 0, 0, &first); - TkTextMakeIndex(textPtr->tree, TkBTreeNumLines(textPtr->tree), 0, + TkTextMakeByteIndex(textPtr->tree, 0, 0, &first); + TkTextMakeByteIndex(textPtr->tree, TkBTreeNumLines(textPtr->tree), 0, &last); TkBTreeStartSearch(&first, &last, tagPtr, &search); if (!TkBTreeCharTagged(&first, tagPtr) && !TkBTreeNextTag(&search)) { @@ -324,7 +437,7 @@ TkTextGetIndex(interp, textPtr, string, indexPtr) } endOfBase = end; } - TkTextMakeIndex(textPtr->tree, lineIndex, charIndex, indexPtr); + TkTextMakeCharIndex(textPtr->tree, lineIndex, charIndex, indexPtr); goto gotBase; } @@ -353,7 +466,7 @@ TkTextGetIndex(interp, textPtr, string, indexPtr) * Base position is end of text. */ - TkTextMakeIndex(textPtr->tree, TkBTreeNumLines(textPtr->tree), + TkTextMakeByteIndex(textPtr->tree, TkBTreeNumLines(textPtr->tree), 0, indexPtr); goto gotBase; } else { @@ -420,13 +533,12 @@ TkTextGetIndex(interp, textPtr, string, indexPtr) } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * * TkTextPrintIndex -- - * * - * This procedure generates a string description of an index, - * suitable for reading in again later. + * This procedure generates a string description of an index, suitable + * for reading in again later. * * Results: * The characters pointed to by string are modified. @@ -434,49 +546,69 @@ TkTextGetIndex(interp, textPtr, string, indexPtr) * Side effects: * None. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ void TkTextPrintIndex(indexPtr, string) - TkTextIndex *indexPtr; /* Pointer to index. */ + CONST TkTextIndex *indexPtr;/* Pointer to index. */ char *string; /* Place to store the position. Must have * at least TK_POS_CHARS characters. */ { + TkTextSegment *segPtr; + int numBytes, charIndex; + + numBytes = indexPtr->byteIndex; + charIndex = 0; + for (segPtr = indexPtr->linePtr->segPtr; ; segPtr = segPtr->nextPtr) { + if (numBytes < segPtr->size) { + break; + } + if (segPtr->typePtr == &tkTextCharType) { + charIndex += Tcl_NumUtfChars(segPtr->body.chars, segPtr->size); + } else { + charIndex += segPtr->size; + } + numBytes -= segPtr->size; + } + if (segPtr->typePtr == &tkTextCharType) { + charIndex += Tcl_NumUtfChars(segPtr->body.chars, numBytes); + } else { + charIndex += numBytes; + } sprintf(string, "%d.%d", TkBTreeLineIndex(indexPtr->linePtr) + 1, - indexPtr->charIndex); + charIndex); } /* - *-------------------------------------------------------------- + *--------------------------------------------------------------------------- * * TkTextIndexCmp -- * - * Compare two indices to see which one is earlier in - * the text. + * Compare two indices to see which one is earlier in the text. * * Results: - * The return value is 0 if index1Ptr and index2Ptr refer - * to the same position in the file, -1 if index1Ptr refers - * to an earlier position than index2Ptr, and 1 otherwise. + * The return value is 0 if index1Ptr and index2Ptr refer to the same + * position in the file, -1 if index1Ptr refers to an earlier position + * than index2Ptr, and 1 otherwise. * * Side effects: * None. * - *-------------------------------------------------------------- + *--------------------------------------------------------------------------- */ int TkTextIndexCmp(index1Ptr, index2Ptr) - TkTextIndex *index1Ptr; /* First index. */ - TkTextIndex *index2Ptr; /* Second index. */ + CONST TkTextIndex *index1Ptr; /* First index. */ + CONST TkTextIndex *index2Ptr; /* Second index. */ { int line1, line2; if (index1Ptr->linePtr == index2Ptr->linePtr) { - if (index1Ptr->charIndex < index2Ptr->charIndex) { + if (index1Ptr->byteIndex < index2Ptr->byteIndex) { return -1; - } else if (index1Ptr->charIndex > index2Ptr->charIndex) { + } else if (index1Ptr->byteIndex > index2Ptr->byteIndex) { return 1; } else { return 0; @@ -494,23 +626,23 @@ TkTextIndexCmp(index1Ptr, index2Ptr) } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * * ForwBack -- * - * This procedure handles +/- modifiers for indices to adjust - * the index forwards or backwards. + * This procedure handles +/- modifiers for indices to adjust the + * index forwards or backwards. * * Results: - * If the modifier in string is successfully parsed then the - * return value is the address of the first character after the - * modifier, and *indexPtr is updated to reflect the modifier. - * If there is a syntax error in the modifier then NULL is returned. + * If the modifier in string is successfully parsed then the return + * value is the address of the first character after the modifier, + * and *indexPtr is updated to reflect the modifier. If there is a + * syntax error in the modifier then NULL is returned. * * Side effects: * None. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ static char * @@ -550,7 +682,7 @@ ForwBack(string, indexPtr) */ units = p; - while ((*p != 0) && !isspace(UCHAR(*p)) && (*p != '+') && (*p != '-')) { + while ((*p != '\0') && !isspace(UCHAR(*p)) && (*p != '+') && (*p != '-')) { p++; } length = p - units; @@ -578,7 +710,18 @@ ForwBack(string, indexPtr) lineIndex = 0; } } - TkTextMakeIndex(indexPtr->tree, lineIndex, indexPtr->charIndex, + /* + * This doesn't work quite right if using a proportional font or + * UTF-8 characters with varying numbers of bytes. The cursor will + * bop around, keeping a constant number of bytes (not characters) + * from the left edge (but making sure not to split any UTF-8 + * characters), regardless of the x-position the index corresponds + * to. The proper way to do this is to get the x-position of the + * index and then pick the character at the same x-position in the + * new line. + */ + + TkTextMakeByteIndex(indexPtr->tree, lineIndex, indexPtr->byteIndex, indexPtr); } else { return NULL; @@ -587,44 +730,42 @@ ForwBack(string, indexPtr) } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * TkTextIndexForwChars -- + * TkTextIndexForwBytes -- * - * Given an index for a text widget, this procedure creates a - * new index that points "count" characters ahead of the source - * index. + * Given an index for a text widget, this procedure creates a new + * index that points "count" bytes ahead of the source index. * * Results: - * *dstPtr is modified to refer to the character "count" characters - * after srcPtr, or to the last character in the file if there aren't - * "count" characters left in the file. + * *dstPtr is modified to refer to the character "count" bytes after + * srcPtr, or to the last character in the TkText if there aren't + * "count" bytes left. * * Side effects: * None. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ - /* ARGSUSED */ void -TkTextIndexForwChars(srcPtr, count, dstPtr) - TkTextIndex *srcPtr; /* Source index. */ - int count; /* How many characters forward to - * move. May be negative. */ - TkTextIndex *dstPtr; /* Destination index: gets modified. */ +TkTextIndexForwBytes(srcPtr, byteCount, dstPtr) + CONST TkTextIndex *srcPtr; /* Source index. */ + int byteCount; /* How many bytes forward to move. May be + * negative. */ + TkTextIndex *dstPtr; /* Destination index: gets modified. */ { TkTextLine *linePtr; TkTextSegment *segPtr; int lineLength; - if (count < 0) { - TkTextIndexBackChars(srcPtr, -count, dstPtr); + if (byteCount < 0) { + TkTextIndexBackBytes(srcPtr, -byteCount, dstPtr); return; } *dstPtr = *srcPtr; - dstPtr->charIndex += count; + dstPtr->byteIndex += byteCount; while (1) { /* * Compute the length of the current line. @@ -641,13 +782,13 @@ TkTextIndexForwChars(srcPtr, count, dstPtr) * Otherwise go on to the next line. */ - if (dstPtr->charIndex < lineLength) { + if (dstPtr->byteIndex < lineLength) { return; } - dstPtr->charIndex -= lineLength; + dstPtr->byteIndex -= lineLength; linePtr = TkBTreeNextLine(dstPtr->linePtr); if (linePtr == NULL) { - dstPtr->charIndex = lineLength - 1; + dstPtr->byteIndex = lineLength - 1; return; } dstPtr->linePtr = linePtr; @@ -655,44 +796,133 @@ TkTextIndexForwChars(srcPtr, count, dstPtr) } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * TkTextIndexBackChars -- + * TkTextIndexForwChars -- * - * Given an index for a text widget, this procedure creates a - * new index that points "count" characters earlier than the - * source index. + * Given an index for a text widget, this procedure creates a new + * index that points "count" characters ahead of the source index. * * Results: * *dstPtr is modified to refer to the character "count" characters - * before srcPtr, or to the first character in the file if there aren't - * "count" characters earlier than srcPtr. + * after srcPtr, or to the last character in the TkText if there + * aren't "count" characters left in the file. * * Side effects: * None. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- + */ + +void +TkTextIndexForwChars(srcPtr, charCount, dstPtr) + CONST TkTextIndex *srcPtr; /* Source index. */ + int charCount; /* How many characters forward to move. + * May be negative. */ + TkTextIndex *dstPtr; /* Destination index: gets modified. */ +{ + TkTextLine *linePtr; + TkTextSegment *segPtr; + int byteOffset; + char *start, *end, *p; + Tcl_UniChar ch; + + if (charCount < 0) { + TkTextIndexBackChars(srcPtr, -charCount, dstPtr); + return; + } + + *dstPtr = *srcPtr; + + /* + * Find seg that contains src byteIndex. + * Move forward specified number of chars. + */ + + segPtr = TkTextIndexToSeg(dstPtr, &byteOffset); + while (1) { + /* + * Go through each segment in line looking for specified character + * index. + */ + + for ( ; segPtr != NULL; segPtr = segPtr->nextPtr) { + if (segPtr->typePtr == &tkTextCharType) { + start = segPtr->body.chars + byteOffset; + end = segPtr->body.chars + segPtr->size; + for (p = start; p < end; p += Tcl_UtfToUniChar(p, &ch)) { + if (charCount == 0) { + dstPtr->byteIndex += (p - start); + return; + } + charCount--; + } + } else { + if (charCount < segPtr->size - byteOffset) { + dstPtr->byteIndex += charCount; + return; + } + charCount -= segPtr->size - byteOffset; + } + dstPtr->byteIndex += segPtr->size - byteOffset; + byteOffset = 0; + } + + /* + * Go to the next line. If we are at the end of the text item, + * back up one byte (for the terminal '\n' character) and return + * that index. + */ + + linePtr = TkBTreeNextLine(dstPtr->linePtr); + if (linePtr == NULL) { + dstPtr->byteIndex -= sizeof(char); + return; + } + dstPtr->linePtr = linePtr; + dstPtr->byteIndex = 0; + segPtr = dstPtr->linePtr->segPtr; + } +} + +/* + *--------------------------------------------------------------------------- + * + * TkTextIndexBackBytes -- + * + * Given an index for a text widget, this procedure creates a new + * index that points "count" bytes earlier than the source index. + * + * Results: + * *dstPtr is modified to refer to the character "count" bytes before + * srcPtr, or to the first character in the TkText if there aren't + * "count" bytes earlier than srcPtr. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- */ void -TkTextIndexBackChars(srcPtr, count, dstPtr) - TkTextIndex *srcPtr; /* Source index. */ - int count; /* How many characters backward to - * move. May be negative. */ - TkTextIndex *dstPtr; /* Destination index: gets modified. */ +TkTextIndexBackBytes(srcPtr, byteCount, dstPtr) + CONST TkTextIndex *srcPtr; /* Source index. */ + int byteCount; /* How many bytes backward to move. May be + * negative. */ + TkTextIndex *dstPtr; /* Destination index: gets modified. */ { TkTextSegment *segPtr; int lineIndex; - if (count < 0) { - TkTextIndexForwChars(srcPtr, -count, dstPtr); + if (byteCount < 0) { + TkTextIndexForwBytes(srcPtr, -byteCount, dstPtr); return; } *dstPtr = *srcPtr; - dstPtr->charIndex -= count; + dstPtr->byteIndex -= byteCount; lineIndex = -1; - while (dstPtr->charIndex < 0) { + while (dstPtr->byteIndex < 0) { /* * Move back one line in the text. If we run off the beginning * of the file then just return the first character in the text. @@ -702,7 +932,7 @@ TkTextIndexBackChars(srcPtr, count, dstPtr) lineIndex = TkBTreeLineIndex(dstPtr->linePtr); } if (lineIndex == 0) { - dstPtr->charIndex = 0; + dstPtr->byteIndex = 0; return; } lineIndex--; @@ -714,8 +944,124 @@ TkTextIndexBackChars(srcPtr, count, dstPtr) for (segPtr = dstPtr->linePtr->segPtr; segPtr != NULL; segPtr = segPtr->nextPtr) { - dstPtr->charIndex += segPtr->size; + dstPtr->byteIndex += segPtr->size; + } + } +} + +/* + *--------------------------------------------------------------------------- + * + * TkTextIndexBackChars -- + * + * Given an index for a text widget, this procedure creates a new + * index that points "count" characters earlier than the source index. + * + * Results: + * *dstPtr is modified to refer to the character "count" characters + * before srcPtr, or to the first character in the file if there + * aren't "count" characters earlier than srcPtr. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +void +TkTextIndexBackChars(srcPtr, charCount, dstPtr) + CONST TkTextIndex *srcPtr; /* Source index. */ + int charCount; /* How many characters backward to move. + * May be negative. */ + TkTextIndex *dstPtr; /* Destination index: gets modified. */ +{ + TkTextSegment *segPtr, *oldPtr; + int lineIndex, segSize; + char *p, *start, *end; + + if (charCount <= 0) { + TkTextIndexForwChars(srcPtr, -charCount, dstPtr); + return; + } + + *dstPtr = *srcPtr; + + /* + * Find offset within seg that contains byteIndex. + * Move backward specified number of chars. + */ + + lineIndex = -1; + + segSize = dstPtr->byteIndex; + for (segPtr = dstPtr->linePtr->segPtr; ; segPtr = segPtr->nextPtr) { + if (segSize <= segPtr->size) { + break; + } + segSize -= segPtr->size; + } + while (1) { + if (segPtr->typePtr == &tkTextCharType) { + start = segPtr->body.chars; + end = segPtr->body.chars + segSize; + for (p = end; ; p = Tcl_UtfPrev(p, start)) { + if (charCount == 0) { + dstPtr->byteIndex -= (end - p); + return; + } + if (p == start) { + break; + } + charCount--; + } + } else { + if (charCount < segSize) { + dstPtr->byteIndex -= charCount; + return; + } + charCount -= segSize; + } + dstPtr->byteIndex -= segSize; + + /* + * Move back into previous segment. + */ + + oldPtr = segPtr; + segPtr = dstPtr->linePtr->segPtr; + if (segPtr != oldPtr) { + for ( ; segPtr->nextPtr != oldPtr; segPtr = segPtr->nextPtr) { + /* Empty body. */ + } + segSize = segPtr->size; + continue; + } + + /* + * Move back to previous line. + */ + + if (lineIndex < 0) { + lineIndex = TkBTreeLineIndex(dstPtr->linePtr); + } + if (lineIndex == 0) { + dstPtr->byteIndex = 0; + return; + } + lineIndex--; + dstPtr->linePtr = TkBTreeFindLine(dstPtr->tree, lineIndex); + + /* + * Compute the length of the line and add that to dstPtr->byteIndex. + */ + + oldPtr = dstPtr->linePtr->segPtr; + for (segPtr = oldPtr; segPtr != NULL; segPtr = segPtr->nextPtr) { + dstPtr->byteIndex += segPtr->size; + oldPtr = segPtr; } + segPtr = oldPtr; + segSize = segPtr->size; } } @@ -762,15 +1108,15 @@ StartEnd(string, indexPtr) length = p-string; if ((*string == 'l') && (strncmp(string, "lineend", length) == 0) && (length >= 5)) { - indexPtr->charIndex = 0; + indexPtr->byteIndex = 0; for (segPtr = indexPtr->linePtr->segPtr; segPtr != NULL; segPtr = segPtr->nextPtr) { - indexPtr->charIndex += segPtr->size; + indexPtr->byteIndex += segPtr->size; } - indexPtr->charIndex -= 1; + indexPtr->byteIndex -= sizeof(char); } else if ((*string == 'l') && (strncmp(string, "linestart", length) == 0) && (length >= 5)) { - indexPtr->charIndex = 0; + indexPtr->byteIndex = 0; } else if ((*string == 'w') && (strncmp(string, "wordend", length) == 0) && (length >= 5)) { int firstChar = 1; @@ -791,7 +1137,7 @@ StartEnd(string, indexPtr) firstChar = 0; } offset += 1; - indexPtr->charIndex += 1; + indexPtr->byteIndex += sizeof(char); if (offset >= segPtr->size) { segPtr = TkTextIndexToSeg(indexPtr, &offset); } @@ -820,10 +1166,10 @@ StartEnd(string, indexPtr) firstChar = 0; } offset -= 1; - indexPtr->charIndex -= 1; + indexPtr->byteIndex -= sizeof(char); if (offset < 0) { - if (indexPtr->charIndex < 0) { - indexPtr->charIndex = 0; + if (indexPtr->byteIndex < 0) { + indexPtr->byteIndex = 0; goto done; } segPtr = TkTextIndexToSeg(indexPtr, &offset); diff --git a/generic/tkTextMark.c b/generic/tkTextMark.c index 0d12c98..cf16c49 100644 --- a/generic/tkTextMark.c +++ b/generic/tkTextMark.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkTextMark.c 1.18 97/10/20 11:12:50 + * SCCS: @(#) tkTextMark.c 1.20 98/01/08 13:40:45 */ #include "tkInt.h" @@ -134,9 +134,9 @@ TkTextMarkCmd(textPtr, interp, argc, argv) markPtr = (TkTextSegment *) Tcl_GetHashValue(hPtr); if (argc == 4) { if (markPtr->typePtr == &tkTextRightMarkType) { - interp->result = "right"; + Tcl_SetResult(interp, "right", TCL_STATIC); } else { - interp->result = "left"; + Tcl_SetResult(interp, "left", TCL_STATIC); } return TCL_OK; } @@ -319,10 +319,10 @@ TkTextMarkSegToIndex(textPtr, markPtr, indexPtr) indexPtr->tree = textPtr->tree; indexPtr->linePtr = markPtr->body.mark.linePtr; - indexPtr->charIndex = 0; + indexPtr->byteIndex = 0; for (segPtr = indexPtr->linePtr->segPtr; segPtr != markPtr; segPtr = segPtr->nextPtr) { - indexPtr->charIndex += segPtr->size; + indexPtr->byteIndex += segPtr->size; } } @@ -468,7 +468,7 @@ MarkLayoutProc(textPtr, indexPtr, segPtr, offset, maxX, maxChars, chunkPtr->undisplayProc = InsertUndisplayProc; chunkPtr->measureProc = (Tk_ChunkMeasureProc *) NULL; chunkPtr->bboxProc = (Tk_ChunkBboxProc *) NULL; - chunkPtr->numChars = 0; + chunkPtr->numBytes = 0; chunkPtr->minAscent = 0; chunkPtr->minDescent = 0; chunkPtr->minHeight = 0; @@ -669,7 +669,7 @@ MarkFindNext(interp, textPtr, string) return TCL_ERROR; } for (offset = 0, segPtr = index.linePtr->segPtr; - segPtr != NULL && offset < index.charIndex; + segPtr != NULL && offset < index.byteIndex; offset += segPtr->size, segPtr = segPtr->nextPtr) { /* Empty loop body */ ; } @@ -692,7 +692,7 @@ MarkFindNext(interp, textPtr, string) if (index.linePtr == (TkTextLine *) NULL) { return TCL_OK; } - index.charIndex = 0; + index.byteIndex = 0; segPtr = index.linePtr->segPtr; } } @@ -742,7 +742,7 @@ MarkFindPrev(interp, textPtr, string) return TCL_ERROR; } for (offset = 0, segPtr = index.linePtr->segPtr; - segPtr != NULL && offset < index.charIndex; + segPtr != NULL && offset < index.byteIndex; offset += segPtr->size, segPtr = segPtr->nextPtr) { /* Empty loop body */ ; } diff --git a/generic/tkTextTag.c b/generic/tkTextTag.c index b5b04be..61c817e 100644 --- a/generic/tkTextTag.c +++ b/generic/tkTextTag.c @@ -6,12 +6,12 @@ * related to tags. * * Copyright (c) 1992-1994 The Regents of the University of California. - * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkTextTag.c 1.39 97/02/07 13:51:52 + * SCCS: @(#) tkTextTag.c 1.42 98/01/12 15:55:55 */ #include "default.h" @@ -235,9 +235,22 @@ TkTextTagCmd(textPtr, interp, argc, argv) command = Tk_GetBinding(interp, textPtr->bindingTable, (ClientData) tagPtr, argv[4]); if (command == NULL) { - return TCL_ERROR; + char *string = Tcl_GetStringResult(interp); + + /* + * Ignore missing binding errors. This is a special hack + * that relies on the error message returned by FindSequence + * in tkBind.c. + */ + + if (string[0] != '\0') { + return TCL_ERROR; + } else { + Tcl_ResetResult(interp); + } + } else { + Tcl_SetResult(interp, command, TCL_STATIC); } - interp->result = command; } else { Tk_GetAllBindings(interp, textPtr->bindingTable, (ClientData) tagPtr); @@ -448,10 +461,10 @@ TkTextTagCmd(textPtr, interp, argc, argv) TkTextRedrawTag(textPtr, (TkTextIndex *) NULL, (TkTextIndex *) NULL, tagPtr, 1); } - TkBTreeTag(TkTextMakeIndex(textPtr->tree, 0, 0, &first), - TkTextMakeIndex(textPtr->tree, - TkBTreeNumLines(textPtr->tree), 0, &last), - tagPtr, 0); + TkTextMakeByteIndex(textPtr->tree, 0, 0, &first); + TkTextMakeByteIndex(textPtr->tree, TkBTreeNumLines(textPtr->tree), + 0, &last), + TkBTreeTag(&first, &last, tagPtr, 0); Tcl_DeleteHashEntry(hPtr); if (textPtr->bindingTable != NULL) { Tk_DeleteAllBindings(textPtr->bindingTable, @@ -552,7 +565,7 @@ TkTextTagCmd(textPtr, interp, argc, argv) if (TkTextGetIndex(interp, textPtr, argv[4], &index1) != TCL_OK) { return TCL_ERROR; } - TkTextMakeIndex(textPtr->tree, TkBTreeNumLines(textPtr->tree), + TkTextMakeByteIndex(textPtr->tree, TkBTreeNumLines(textPtr->tree), 0, &last); if (argc == 5) { index2 = last; @@ -582,7 +595,7 @@ TkTextTagCmd(textPtr, interp, argc, argv) * skip to the end of this tagged range. */ - for (segPtr = index1.linePtr->segPtr, offset = index1.charIndex; + for (segPtr = index1.linePtr->segPtr, offset = index1.byteIndex; offset >= 0; offset -= segPtr->size, segPtr = segPtr->nextPtr) { if ((offset == 0) && (segPtr->typePtr == &tkTextToggleOnType) @@ -631,7 +644,7 @@ TkTextTagCmd(textPtr, interp, argc, argv) return TCL_ERROR; } if (argc == 5) { - TkTextMakeIndex(textPtr->tree, 0, 0, &index2); + TkTextMakeByteIndex(textPtr->tree, 0, 0, &index2); } else if (TkTextGetIndex(interp, textPtr, argv[5], &index2) != TCL_OK) { return TCL_ERROR; @@ -651,7 +664,7 @@ TkTextTagCmd(textPtr, interp, argc, argv) } if (tSearch.segPtr->typePtr == &tkTextToggleOnType) { TkTextPrintIndex(&tSearch.curIndex, position1); - TkTextMakeIndex(textPtr->tree, TkBTreeNumLines(textPtr->tree), + TkTextMakeByteIndex(textPtr->tree, TkBTreeNumLines(textPtr->tree), 0, &last); TkBTreeStartSearch(&tSearch.curIndex, &last, tagPtr, &tSearch); TkBTreeNextTag(&tSearch); @@ -711,8 +724,8 @@ TkTextTagCmd(textPtr, interp, argc, argv) if (tagPtr == NULL) { return TCL_OK; } - TkTextMakeIndex(textPtr->tree, 0, 0, &first); - TkTextMakeIndex(textPtr->tree, TkBTreeNumLines(textPtr->tree), + TkTextMakeByteIndex(textPtr->tree, 0, 0, &first); + TkTextMakeByteIndex(textPtr->tree, TkBTreeNumLines(textPtr->tree), 0, &last); TkBTreeStartSearch(&first, &last, tagPtr, &tSearch); if (TkBTreeCharTagged(&first, tagPtr)) { @@ -828,7 +841,7 @@ TkTextCreateTag(textPtr, tagName) * Results: * If tagName is defined in textPtr, a pointer to its TkTextTag * structure is returned. Otherwise NULL is returned and an - * error message is recorded in interp->result unless interp + * error message is recorded in the interp's result unless interp * is NULL. * * Side effects: diff --git a/generic/tkTextWind.c b/generic/tkTextWind.c index 6452d13..c8a3a13 100644 --- a/generic/tkTextWind.c +++ b/generic/tkTextWind.c @@ -6,12 +6,12 @@ * widget command for texts. * * Copyright (c) 1994 The Regents of the University of California. - * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkTextWind.c 1.14 97/04/25 16:52:09 + * SCCS: @(#) tkTextWind.c 1.16 98/01/08 13:41:05 */ #include "tk.h" @@ -244,7 +244,7 @@ TkTextWindowCmd(textPtr, interp, argc, argv) lineIndex = TkBTreeLineIndex(index.linePtr); if (lineIndex == TkBTreeNumLines(textPtr->tree)) { lineIndex--; - TkTextMakeIndex(textPtr->tree, lineIndex, 1000000, &index); + TkTextMakeByteIndex(textPtr->tree, lineIndex, 1000000, &index); } /* @@ -311,7 +311,7 @@ TkTextWindowCmd(textPtr, interp, argc, argv) * * Results: * The return value is a standard Tcl result. If TCL_ERROR is - * returned, then interp->result contains an error message.. + * returned, then the interp's result contains an error message.. * * Side effects: * Configuration information for the embedded window changes, @@ -541,7 +541,7 @@ EmbWinStructureProc(clientData, eventPtr) ewPtr->body.ew.tkwin = NULL; index.tree = ewPtr->body.ew.textPtr->tree; index.linePtr = ewPtr->body.ew.linePtr; - index.charIndex = TkTextSegToOffset(ewPtr, ewPtr->body.ew.linePtr); + index.byteIndex = TkTextSegToOffset(ewPtr, ewPtr->body.ew.linePtr); TkTextChanged(ewPtr->body.ew.textPtr, &index, &index); } @@ -575,7 +575,7 @@ EmbWinRequestProc(clientData, tkwin) index.tree = ewPtr->body.ew.textPtr->tree; index.linePtr = ewPtr->body.ew.linePtr; - index.charIndex = TkTextSegToOffset(ewPtr, ewPtr->body.ew.linePtr); + index.byteIndex = TkTextSegToOffset(ewPtr, ewPtr->body.ew.linePtr); TkTextChanged(ewPtr->body.ew.textPtr, &index, &index); } @@ -620,7 +620,7 @@ EmbWinLostSlaveProc(clientData, tkwin) ewPtr->body.ew.tkwin = NULL; index.tree = ewPtr->body.ew.textPtr->tree; index.linePtr = ewPtr->body.ew.linePtr; - index.charIndex = TkTextSegToOffset(ewPtr, ewPtr->body.ew.linePtr); + index.byteIndex = TkTextSegToOffset(ewPtr, ewPtr->body.ew.linePtr); TkTextChanged(ewPtr->body.ew.textPtr, &index, &index); } @@ -778,7 +778,7 @@ EmbWinLayoutProc(textPtr, indexPtr, ewPtr, offset, maxX, maxChars, goto gotWindow; } Tcl_DStringInit(&name); - Tcl_DStringAppend(&name, textPtr->interp->result, -1); + Tcl_DStringAppend(&name, Tcl_GetStringResult(textPtr->interp), -1); Tcl_ResetResult(textPtr->interp); ewPtr->body.ew.tkwin = Tk_NameToWindow(textPtr->interp, Tcl_DStringValue(&name), textPtr->tkwin); @@ -847,7 +847,7 @@ EmbWinLayoutProc(textPtr, indexPtr, ewPtr, offset, maxX, maxChars, chunkPtr->undisplayProc = EmbWinUndisplayProc; chunkPtr->measureProc = (Tk_ChunkMeasureProc *) NULL; chunkPtr->bboxProc = EmbWinBboxProc; - chunkPtr->numChars = 1; + chunkPtr->numBytes = 1; if (ewPtr->body.ew.align == ALIGN_BASELINE) { chunkPtr->minAscent = height - ewPtr->body.ew.padY; chunkPtr->minDescent = ewPtr->body.ew.padY; @@ -1171,6 +1171,6 @@ TkTextWindowIndex(textPtr, name, indexPtr) ewPtr = (TkTextSegment *) Tcl_GetHashValue(hPtr); indexPtr->tree = textPtr->tree; indexPtr->linePtr = ewPtr->body.ew.linePtr; - indexPtr->charIndex = TkTextSegToOffset(ewPtr, indexPtr->linePtr); + indexPtr->byteIndex = TkTextSegToOffset(ewPtr, indexPtr->linePtr); return 1; } diff --git a/generic/tkTrig.c b/generic/tkTrig.c index 52dd8ba..f3976d5 100644 --- a/generic/tkTrig.c +++ b/generic/tkTrig.c @@ -7,12 +7,12 @@ * used by canvases. * * Copyright (c) 1992-1994 The Regents of the University of California. - * Copyright (c) 1994 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkTrig.c 1.27 97/03/07 11:34:35 + * SCCS: @(#) tkTrig.c 1.28 97/11/07 21:18:39 */ #include <stdio.h> @@ -1195,7 +1195,7 @@ TkMakeBezierCurve(canvas, pointPtr, numPoints, numSteps, xPoints, dblPoints) * * Results: * None. Postscript commands to generate the path are appended - * to interp->result. + * to the interp's result. * * Side effects: * None. diff --git a/generic/tkUtil.c b/generic/tkUtil.c index ddb3db0..f0d2e0c 100644 --- a/generic/tkUtil.c +++ b/generic/tkUtil.c @@ -6,16 +6,30 @@ * a focus highlight. * * Copyright (c) 1994 The Regents of the University of California. - * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkUtil.c 1.13 97/06/06 11:16:22 + * SCCS: @(#) tkUtil.c 1.17 98/01/02 17:39:19 */ #include "tkInt.h" #include "tkPort.h" + +/* + * The structure below defines the implementation of the "statekey" + * Tcl object, used for quickly finding a mapping in a TkStateMap. + */ + +static Tcl_ObjType stateKeyType = { + "statekey", /* name */ + (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ + (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ + (Tcl_UpdateStringProc *) NULL, /* updateStringProc */ + (Tcl_SetFromAnyProc *) NULL /* setFromAnyProc */ +}; + /* *---------------------------------------------------------------------- @@ -132,7 +146,7 @@ Tk_DrawFocusHighlight(tkwin, gc, width, drawable) * took. If TK_SCROLL_MOVETO, *dblPtr is filled in with the * desired position; if TK_SCROLL_PAGES or TK_SCROLL_UNITS, * *intPtr is filled in with the number of lines to move (may be - * negative); if TK_SCROLL_ERROR, interp->result contains an + * negative); if TK_SCROLL_ERROR, the interp's result contains an * error message. * * Side effects: @@ -310,7 +324,7 @@ TkFindStateString(mapPtr, numKey) * Returns the numKey associated with the last element (the NULL * string one) in the table if strKey was not equal to any of the * string keys in the table. In that case, an error message is - * also left in interp->result (if interp is not NULL). + * also left in the interp's result (if interp is not NULL). * * Side effects. * None. @@ -319,29 +333,70 @@ TkFindStateString(mapPtr, numKey) */ int -TkFindStateNum(interp, field, mapPtr, strKey) +TkFindStateNum(interp, option, mapPtr, strKey) Tcl_Interp *interp; /* Interp for error reporting. */ - CONST char *field; /* String to use when constructing error. */ + CONST char *option; /* String to use when constructing error. */ CONST TkStateMap *mapPtr; /* Lookup table. */ CONST char *strKey; /* String to try to find in lookup table. */ { CONST TkStateMap *mPtr; - if (mapPtr->strKey == NULL) { - panic("TkFindStateNum: no choices in lookup table"); + for (mPtr = mapPtr; mPtr->strKey != NULL; mPtr++) { + if (strcmp(strKey, mPtr->strKey) == 0) { + return mPtr->numKey; + } + } + if (interp != NULL) { + mPtr = mapPtr; + Tcl_AppendResult(interp, "bad ", option, " value \"", strKey, + "\": must be ", mPtr->strKey, (char *) NULL); + for (mPtr++; mPtr->strKey != NULL; mPtr++) { + Tcl_AppendResult(interp, + ((mPtr[1].strKey != NULL) ? ", " : ", or "), + mPtr->strKey, (char *) NULL); + } + } + return mPtr->numKey; +} + +int +TkFindStateNumObj(interp, optionPtr, mapPtr, keyPtr) + Tcl_Interp *interp; /* Interp for error reporting. */ + Tcl_Obj *optionPtr; /* String to use when constructing error. */ + CONST TkStateMap *mapPtr; /* Lookup table. */ + Tcl_Obj *keyPtr; /* String key to find in lookup table. */ +{ + CONST TkStateMap *mPtr; + CONST char *key; + CONST Tcl_ObjType *typePtr; + + if ((keyPtr->typePtr == &stateKeyType) + && (keyPtr->internalRep.twoPtrValue.ptr1 == (VOID *) mapPtr)) { + return (int) keyPtr->internalRep.twoPtrValue.ptr2; } + key = Tcl_GetStringFromObj(keyPtr, NULL); for (mPtr = mapPtr; mPtr->strKey != NULL; mPtr++) { - if (strcmp(strKey, mPtr->strKey) == 0) { + if (strcmp(key, mPtr->strKey) == 0) { + typePtr = keyPtr->typePtr; + if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { + (*typePtr->freeIntRepProc)(keyPtr); + } + keyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) mapPtr; + keyPtr->internalRep.twoPtrValue.ptr2 = (VOID *) mPtr->numKey; + keyPtr->typePtr = &stateKeyType; return mPtr->numKey; } } if (interp != NULL) { mPtr = mapPtr; - Tcl_AppendResult(interp, "bad ", field, " value \"", strKey, + Tcl_AppendResult(interp, "bad ", + Tcl_GetStringFromObj(optionPtr, NULL), " value \"", key, "\": must be ", mPtr->strKey, (char *) NULL); for (mPtr++; mPtr->strKey != NULL; mPtr++) { - Tcl_AppendResult(interp, ", ", mPtr->strKey, (char *) NULL); + Tcl_AppendResult(interp, + ((mPtr[1].strKey != NULL) ? ", " : ", or "), + mPtr->strKey, (char *) NULL); } } return mPtr->numKey; diff --git a/generic/tkVisual.c b/generic/tkVisual.c index 207b905..cd3e5d4 100644 --- a/generic/tkVisual.c +++ b/generic/tkVisual.c @@ -6,12 +6,12 @@ * prototype implementation by Paul Mackerras. * * Copyright (c) 1994 The Regents of the University of California. - * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkVisual.c 1.19 97/04/25 16:52:17 + * SCCS: @(#) tkVisual.c 1.20 97/11/07 21:18:48 */ #include "tkInt.h" @@ -74,7 +74,7 @@ struct TkColormap { * Results: * The return value is normally a pointer to a visual. If an * error occurred in looking up the visual, NULL is returned and - * an error message is left in interp->result. The depth of the + * an error message is left in the interp's result. The depth of the * visual is returned to *depthPtr under normal returns. If * colormapPtr is non-NULL, then this procedure also finds a * suitable colormap for use with the visual in tkwin, and it @@ -243,7 +243,8 @@ Tk_GetVisual(interp, tkwin, string, depthPtr, colormapPtr) visInfoList = XGetVisualInfo(Tk_Display(tkwin), mask, &template, &numVisuals); if (visInfoList == NULL) { - interp->result = "couldn't find an appropriate visual"; + Tcl_SetResult(interp, "couldn't find an appropriate visual", + TCL_STATIC); return NULL; } @@ -352,7 +353,7 @@ Tk_GetVisual(interp, tkwin, string, depthPtr, colormapPtr) * Results: * The return value is normally the X resource identifier for the * colormap. If an error occurs, None is returned and an error - * message is placed in interp->result. + * message is placed in the interp's result. * * Side effects: * A reference count is incremented for the colormap, so diff --git a/generic/tkWindow.c b/generic/tkWindow.c index fc9060a..8efc8d6 100644 --- a/generic/tkWindow.c +++ b/generic/tkWindow.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkWindow.c 1.233 97/10/31 09:55:23 + * SCCS: @(#) tkWindow.c 1.237 98/01/12 15:56:12 */ #include "tkPort.h" @@ -94,6 +94,10 @@ typedef struct { int isSafe; /* If !0, this command will be exposed in * a safe interpreter. Otherwise it will be * hidden in a safe interpreter. */ + int passMainWindow; /* 0 means provide NULL clientData to + * command procedure; 1 means pass main + * window as clientData to command + * procedure. */ } TkCmd; static TkCmd commands[] = { @@ -101,62 +105,67 @@ static TkCmd commands[] = { * Commands that are part of the intrinsics: */ - {"bell", Tk_BellCmd, NULL, 0}, - {"bind", Tk_BindCmd, NULL, 1}, - {"bindtags", Tk_BindtagsCmd, NULL, 1}, - {"clipboard", Tk_ClipboardCmd, NULL, 0}, - {"destroy", Tk_DestroyCmd, NULL, 1}, - {"event", Tk_EventCmd, NULL, 1}, - {"focus", Tk_FocusCmd, NULL, 1}, - {"font", NULL, Tk_FontObjCmd, 1}, - {"grab", Tk_GrabCmd, NULL, 0}, - {"grid", Tk_GridCmd, NULL, 1}, - {"image", Tk_ImageCmd, NULL, 1}, - {"lower", Tk_LowerCmd, NULL, 1}, - {"option", Tk_OptionCmd, NULL, 1}, - {"pack", Tk_PackCmd, NULL, 1}, - {"place", Tk_PlaceCmd, NULL, 1}, - {"raise", Tk_RaiseCmd, NULL, 1}, - {"selection", Tk_SelectionCmd, NULL, 0}, - {"tk", NULL, Tk_TkObjCmd, 0}, - {"tkwait", Tk_TkwaitCmd, NULL, 1}, - {"tk_chooseColor", Tk_ChooseColorCmd, NULL, 0}, - {"tk_getOpenFile", Tk_GetOpenFileCmd, NULL, 0}, - {"tk_getSaveFile", Tk_GetSaveFileCmd, NULL, 0}, - {"tk_messageBox", Tk_MessageBoxCmd, NULL, 0}, - {"update", Tk_UpdateCmd, NULL, 1}, - {"winfo", NULL, Tk_WinfoObjCmd, 1}, - {"wm", Tk_WmCmd, NULL, 0}, + {"bell", NULL, Tk_BellObjCmd, 0, 1}, + {"bind", Tk_BindCmd, NULL, 1, 1}, + {"bindtags", Tk_BindtagsCmd, NULL, 1, 1}, + {"clipboard", Tk_ClipboardCmd, NULL, 0, 1}, + {"destroy", Tk_DestroyCmd, NULL, 1, 1}, + {"event", NULL, Tk_EventObjCmd, 1, 1}, + {"focus", NULL, Tk_FocusObjCmd, 1, 1}, + {"font", NULL, Tk_FontObjCmd, 1, 1}, + {"grab", Tk_GrabCmd, NULL, 0, 1}, + {"grid", Tk_GridCmd, NULL, 1, 1}, + {"image", Tk_ImageCmd, NULL, 1, 1}, + {"lower", Tk_LowerCmd, NULL, 1, 1}, + {"option", Tk_OptionCmd, NULL, 1, 1}, + {"pack", Tk_PackCmd, NULL, 1, 1}, + {"place", Tk_PlaceCmd, NULL, 1, 1}, + {"raise", Tk_RaiseCmd, NULL, 1, 1}, + {"selection", Tk_SelectionCmd, NULL, 0, 1}, + {"tk", NULL, Tk_TkObjCmd, 0, 1}, + {"tkwait", Tk_TkwaitCmd, NULL, 1, 1}, +#if defined(__WIN32__) || defined(MAC_TCL) + {"tk_chooseColor", NULL, Tk_ChooseColorObjCmd, 0, 1}, + {"tk_chooseDirectory", NULL, Tk_ChooseDirectoryObjCmd, 0, 1}, + {"tk_getOpenFile", NULL, Tk_GetOpenFileObjCmd, 0, 1}, + {"tk_getSaveFile", NULL, Tk_GetSaveFileObjCmd, 0, 1}, +#endif +#ifdef __WIN32__ + {"tk_messageBox", NULL, Tk_MessageBoxObjCmd, 0, 1}, +#endif + {"update", NULL, Tk_UpdateObjCmd, 1, 1}, + {"winfo", NULL, Tk_WinfoObjCmd, 1, 1}, + {"wm", Tk_WmCmd, NULL, 0, 1}, /* * Widget class commands. */ - {"button", Tk_ButtonCmd, NULL, 1}, - {"canvas", Tk_CanvasCmd, NULL, 1}, - {"checkbutton", Tk_CheckbuttonCmd, NULL, 1}, - {"entry", Tk_EntryCmd, NULL, 1}, - {"frame", Tk_FrameCmd, NULL, 1}, - {"label", Tk_LabelCmd, NULL, 1}, - {"listbox", Tk_ListboxCmd, NULL, 1}, - {"menu", Tk_MenuCmd, NULL, 0}, - {"menubutton", Tk_MenubuttonCmd, NULL, 1}, - {"message", Tk_MessageCmd, NULL, 1}, - {"radiobutton", Tk_RadiobuttonCmd, NULL, 1}, - {"scale", Tk_ScaleCmd, NULL, 1}, - {"scrollbar", Tk_ScrollbarCmd, NULL, 1}, - {"text", Tk_TextCmd, NULL, 1}, - {"toplevel", Tk_ToplevelCmd, NULL, 0}, + + {"button", NULL, Tk_ButtonObjCmd, 1, 0}, + {"canvas", Tk_CanvasCmd, NULL, 1, 1}, + {"checkbutton", NULL, Tk_CheckbuttonObjCmd, 1, 0}, + {"entry", Tk_EntryCmd, NULL, 1, 1}, + {"frame", Tk_FrameCmd, NULL, 1, 1}, + {"label", NULL, Tk_LabelObjCmd, 1, 0}, + {"listbox", Tk_ListboxCmd, NULL, 1, 1}, + {"menubutton", Tk_MenubuttonCmd, NULL, 1, 1}, + {"message", Tk_MessageCmd, NULL, 1, 1}, + {"radiobutton", NULL, Tk_RadiobuttonObjCmd, 1, 0}, + {"scale", Tk_ScaleCmd, NULL, 1, 1}, + {"scrollbar", Tk_ScrollbarCmd, NULL, 1, 1}, + {"text", Tk_TextCmd, NULL, 1, 1}, + {"toplevel", Tk_ToplevelCmd, NULL, 0, 1}, /* * Misc. */ #ifdef MAC_TCL - {"unsupported1", TkUnsupported1Cmd, NULL, 1}, + {"unsupported1", TkUnsupported1Cmd, NULL, 1, 1}, #endif {(char *) NULL, (int (*) _ANSI_ARGS_((ClientData, Tcl_Interp *, int, char **))) NULL, NULL, 0} }; - + /* * The variables and table below are used to parse arguments from * the "argv" variable in Tk_Init. @@ -221,7 +230,7 @@ static void UnlinkWindow _ANSI_ARGS_((TkWindow *winPtr)); * The return value is a token for the new window, or NULL if * an error prevented the new window from being created. If * NULL is returned, an error message will be left in - * interp->result. + * the interp's result. * * Side effects: * A new window structure is allocated locally. An X @@ -331,7 +340,7 @@ CreateTopLevelWindow(interp, parent, name, screenName) * Results: * The return value is a pointer to information about the display, * or NULL if the display couldn't be opened. In this case, an - * error message is left in interp->result. The location at + * error message is left in the interp's result. The location at * *screenPtr is overwritten with the screen number parsed from * screenName. * @@ -364,8 +373,9 @@ GetScreen(interp, screenName, screenPtr) screenName = TkGetDefaultScreenName(interp, screenName); if (screenName == NULL) { - interp->result = - "no display name and no $DISPLAY environment variable"; + Tcl_SetResult(interp, + "no display name and no $DISPLAY environment variable", + TCL_STATIC); return (TkDisplay *) NULL; } length = strlen(screenName); @@ -442,7 +452,10 @@ GetScreen(interp, screenName, screenPtr) } } if (screenId >= ScreenCount(dispPtr->display)) { - sprintf(interp->result, "bad screen number \"%d\"", screenId); + char buf[32 + TCL_INTEGER_SPACE]; + + sprintf(buf, "bad screen number \"%d\"", screenId); + Tcl_SetResult(interp, buf, TCL_VOLATILE); return (TkDisplay *) NULL; } *screenPtr = screenId; @@ -675,7 +688,7 @@ NameWindow(interp, winPtr, parentPtr, name) * The return value is a token for the new window, or NULL if * an error prevented the new window from being created. If * NULL is returned, an error message will be left in - * interp->result. + * the interp's result. * * Side effects: * A new window structure is allocated locally; "interp" is @@ -703,6 +716,7 @@ TkCreateMainWindow(interp, screenName, baseName) register TkMainInfo *mainPtr; register TkWindow *winPtr; register TkCmd *cmdPtr; + ClientData clientData; /* * Panic if someone updated the TkWindow structure without @@ -774,12 +788,17 @@ TkCreateMainWindow(interp, screenName, baseName) if ((cmdPtr->cmdProc == NULL) && (cmdPtr->objProc == NULL)) { panic("TkCreateMainWindow: builtin command with NULL string and object procs"); } + if (cmdPtr->passMainWindow) { + clientData = (ClientData) tkwin; + } else { + clientData = (ClientData) NULL; + } if (cmdPtr->cmdProc != NULL) { Tcl_CreateCommand(interp, cmdPtr->name, cmdPtr->cmdProc, - (ClientData) tkwin, (void (*) _ANSI_ARGS_((ClientData))) NULL); + clientData, (void (*) _ANSI_ARGS_((ClientData))) NULL); } else { Tcl_CreateObjCommand(interp, cmdPtr->name, cmdPtr->objProc, - (ClientData) tkwin, NULL); + clientData, NULL); } if (isSafe) { if (!(cmdPtr->isSafe)) { @@ -788,6 +807,8 @@ TkCreateMainWindow(interp, screenName, baseName) } } + TkCreateMenuCmd(interp); + /* * Set variables for the intepreter. */ @@ -811,7 +832,7 @@ TkCreateMainWindow(interp, screenName, baseName) * The return value is a token for the new window. This * is not the same as X's token for the window. If an error * occurred in creating the window (e.g. no such display or - * screen), then an error message is left in interp->result and + * screen), then an error message is left in the interp's result and * NULL is returned. * * Side effects: @@ -825,7 +846,7 @@ TkCreateMainWindow(interp, screenName, baseName) Tk_Window Tk_CreateWindow(interp, parent, name, screenName) Tcl_Interp *interp; /* Interpreter to use for error reporting. - * Interp->result is assumed to be + * the interp's result is assumed to be * initialized by the caller. */ Tk_Window parent; /* Token for parent of new window. */ char *name; /* Name for new window. Must be unique @@ -878,7 +899,7 @@ Tk_CreateWindow(interp, parent, name, screenName) * The return value is a token for the new window. This * is not the same as X's token for the window. If an error * occurred in creating the window (e.g. no such display or - * screen), then an error message is left in interp->result and + * screen), then an error message is left in the interp's result and * NULL is returned. * * Side effects: @@ -892,7 +913,7 @@ Tk_CreateWindow(interp, parent, name, screenName) Tk_Window Tk_CreateWindowFromPath(interp, tkwin, pathName, screenName) Tcl_Interp *interp; /* Interpreter to use for error reporting. - * Interp->result is assumed to be + * the interp's result is assumed to be * initialized by the caller. */ Tk_Window tkwin; /* Token for any window in application * that is to contain new window. */ @@ -1993,7 +2014,7 @@ TkSetClassProcs(tkwin, procs, instanceData) * Results: * The return result is either a token for the window corresponding * to "name", or else NULL to indicate that there is no such - * window. In this case, an error message is left in interp->result. + * window. In this case, an error message is left in the interp's result. * * Side effects: * None. @@ -2274,7 +2295,7 @@ Tk_RestackWindow(tkwin, aboveBelow, other) * Results: * If interp has a Tk application associated with it, the main * window for the application is returned. Otherwise NULL is - * returned and an error message is left in interp->result. + * returned and an error message is left in the interp's result. * * Side effects: * None. @@ -2296,7 +2317,7 @@ Tk_MainWindow(interp) return (Tk_Window) mainPtr->winPtr; } } - interp->result = "this isn't a Tk application"; + Tcl_SetResult(interp, "this isn't a Tk application", TCL_STATIC); return NULL; } @@ -2504,7 +2525,7 @@ DeleteWindowsExitProc(clientData) * the arguments that are extracted). * * Results: - * Returns a standard Tcl completion code and sets interp->result + * Returns a standard Tcl completion code and sets the interp's result * if there is an error. * * Side effects: @@ -2529,7 +2550,7 @@ Tk_Init(interp) * invokes the internal procedure that does the real work. * * Results: - * Returns a standard Tcl completion code and sets interp->result + * Returns a standard Tcl completion code and sets the interp's result * if there is an error. * * Side effects: @@ -2589,8 +2610,8 @@ Tk_SafeInit(interp) * * * Results: - * A standard Tcl result. Also leaves an error message in interp->result - * if there was an error. + * A standard Tcl result. Also leaves an error message in the interp's + * result if there was an error. * * Side effects: * Depends on the initialization scripts that are invoked. @@ -2606,7 +2627,6 @@ Initialize(interp) int argc, code; char **argv, *args[20]; Tcl_DString class; - char buffer[30]; /* * Start by initializing all the static variables to default acceptable @@ -2624,14 +2644,89 @@ Initialize(interp) rest = 0; /* - * If there is an "argv" variable, get its value, extract out - * relevant arguments from it, and rewrite the variable without - * the arguments that we used. + * We start by resetting the result because it might not be clean */ + Tcl_ResetResult(interp); + + if (Tcl_IsSafe(interp)) { + /* + * Get the clearance to start Tk and the "argv" parameters + * from the master. + */ + Tcl_DString ds; + + /* + * Step 1 : find the master and construct the interp name + * (could be a function if new APIs were ok). + * We could also construct the path while walking, but there + * is no API to get the name of an interp either. + */ + Tcl_Interp *master = interp; - p = Tcl_GetVar2(interp, "argv", (char *) NULL, TCL_GLOBAL_ONLY); + while (1) { + master = Tcl_GetMaster(master); + if (master == NULL) { + Tcl_DStringFree(&ds); + Tcl_AppendResult(interp, "NULL master", (char *) NULL); + return TCL_ERROR; + } + if (!Tcl_IsSafe(master)) { + /* Found the trusted master. */ + break; + } + } + /* + * Construct the name (rewalk...) + */ + if (Tcl_GetInterpPath(master, interp) != TCL_OK) { + Tcl_AppendResult(interp, "error in Tcl_GetInterpPath", + (char *) NULL); + return TCL_ERROR; + } + /* + * Build the string to eval. + */ + Tcl_DStringInit(&ds); + Tcl_DStringAppendElement(&ds, "::safe::TkInit"); + Tcl_DStringAppendElement(&ds, Tcl_GetStringResult(master)); + + /* + * Step 2 : Eval in the master. The argument is the *reversed* + * interp path of the slave. + */ + + if (Tcl_Eval(master, Tcl_DStringValue(&ds)) != TCL_OK) { + /* + * We might want to transfer the error message or not. + * We don't. (no API to do it and maybe security reasons). + */ + Tcl_DStringFree(&ds); + Tcl_AppendResult(interp, + "not allowed to start Tk by master's safe::TkInit", + (char *) NULL); + return TCL_ERROR; + } + Tcl_DStringFree(&ds); + /* + * Use the master's result as argv. + * Note: We don't use the Obj interfaces to avoid dealing with + * cross interp refcounting and changing the code below. + */ + + p = Tcl_GetStringResult(master); + } else { + /* + * If there is an "argv" variable, get its value, extract out + * relevant arguments from it, and rewrite the variable without + * the arguments that we used. + */ + + p = Tcl_GetVar2(interp, "argv", (char *) NULL, TCL_GLOBAL_ONLY); + } argv = NULL; if (p != NULL) { + char buffer[TCL_INTEGER_SPACE]; + if (Tcl_SplitList(interp, p, &argc, &argv) != TCL_OK) { argError: Tcl_AddErrorInfo(interp, @@ -2668,8 +2763,8 @@ Initialize(interp) } p = Tcl_DStringValue(&class); - if (islower(UCHAR(*p))) { - *p = toupper(UCHAR(*p)); + if (*p) { + Tcl_UtfToTitle(p); } /* diff --git a/library/bgerror.tcl b/library/bgerror.tcl index d2b1cdc..ccfaccb 100644 --- a/library/bgerror.tcl +++ b/library/bgerror.tcl @@ -4,7 +4,7 @@ # posts a dialog box with the error message and gives the user a chance # to see a more detailed stack trace. # -# SCCS: @(#) bgerror.tcl 1.16 97/08/06 09:19:50 +# SCCS: @(#) bgerror.tcl 1.17 97/12/03 15:28:53 # # Copyright (c) 1992-1994 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. @@ -82,10 +82,10 @@ proc bgerror err { wm withdraw $w update idletasks - set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \ - - [winfo vrootx [winfo parent $w]]] - set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \ - - [winfo vrooty [winfo parent $w]]] + set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \ + - [winfo vrootx [winfo parent $w]]}] + set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 \ + - [winfo vrooty [winfo parent $w]]}] wm geom $w +$x+$y wm deiconify $w diff --git a/library/button.tcl b/library/button.tcl index b017b80..665f7b6 100644 --- a/library/button.tcl +++ b/library/button.tcl @@ -4,7 +4,7 @@ # checkbutton, and radiobutton widgets and provides procedures # that help in implementing those bindings. # -# SCCS: @(#) button.tcl 1.22 96/11/14 14:49:11 +# SCCS: @(#) button.tcl 1.23 97/12/03 15:28:54 # # Copyright (c) 1992-1994 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. @@ -69,12 +69,12 @@ if {$tcl_platform(platform) == "windows"} { } if {$tcl_platform(platform) == "unix"} { bind Checkbutton <Return> { - if !$tk_strictMotif { + if {!$tk_strictMotif} { tkCheckRadioInvoke %W } } bind Radiobutton <Return> { - if !$tk_strictMotif { + if {!$tk_strictMotif} { tkCheckRadioInvoke %W } } diff --git a/library/clrpick.tcl b/library/clrpick.tcl index af5f980..383f799 100644 --- a/library/clrpick.tcl +++ b/library/clrpick.tcl @@ -3,7 +3,7 @@ # Color selection dialog for platforms that do not support a # standard color selection dialog. # -# SCCS: @(#) clrpick.tcl 1.3 96/09/05 09:59:24 +# SCCS: @(#) clrpick.tcl 1.4 97/12/03 15:28:55 # # Copyright (c) 1996 Sun Microsystems, Inc. # @@ -59,7 +59,7 @@ proc tkColorDialog {args} { tkColorDialog_Config $w $args tkColorDialog_InitValues $w - if ![winfo exists $w] { + if {![winfo exists $w]} { toplevel $w -class tkColorDialog tkColorDialog_BuildDialog $w } @@ -72,10 +72,10 @@ proc tkColorDialog {args} { wm withdraw $w update idletasks - set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \ - - [winfo vrootx [winfo parent $w]]] - set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \ - - [winfo vrooty [winfo parent $w]]] + set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \ + - [winfo vrootx [winfo parent $w]]}] + set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 \ + - [winfo vrooty [winfo parent $w]]}] wm geom $w +$x+$y wm deiconify $w wm title $w $data(-title) @@ -120,19 +120,19 @@ proc tkColorDialog_InitValues {w} { # IntensityIncr is the difference in color intensity between a colorbar # and its neighbors. - set data(intensityIncr) [expr 256 / $data(NUM_COLORBARS)] + set data(intensityIncr) [expr {256 / $data(NUM_COLORBARS)}] # ColorbarWidth is the width of each colorbar set data(colorbarWidth) \ - [expr $data(BARS_WIDTH) / $data(NUM_COLORBARS)] + [expr {$data(BARS_WIDTH) / $data(NUM_COLORBARS)}] # Indent is the width of the space at the left and right side of the # colorbar. It is always half the selector polygon width, because the # polygon extends into the space. - set data(indent) [expr $data(PLGN_WIDTH) / 2] + set data(indent) [expr {$data(PLGN_WIDTH) / 2}] set data(colorPad) 2 - set data(selPad) [expr $data(PLGN_WIDTH) / 2] + set data(selPad) [expr {$data(PLGN_WIDTH) / 2}] # # minX is the x coordinate of the first colorbar @@ -142,13 +142,13 @@ proc tkColorDialog_InitValues {w} { # # maxX is the x coordinate of the last colorbar # - set data(maxX) [expr $data(BARS_WIDTH) + $data(indent)-1] + set data(maxX) [expr {$data(BARS_WIDTH) + $data(indent)-1}] # # canvasWidth is the width of the entire canvas, including the indents # - set data(canvasWidth) [expr $data(BARS_WIDTH) + \ - $data(PLGN_WIDTH)] + set data(canvasWidth) [expr {$data(BARS_WIDTH) + \ + $data(PLGN_WIDTH)}] # Set the initial color, specified by -initialcolor, or the # color chosen by the user the last time. @@ -156,9 +156,9 @@ proc tkColorDialog_InitValues {w} { set data(finalColor) $data(-initialcolor) set rgb [winfo rgb . $data(selection)] - set data(red,intensity) [expr [lindex $rgb 0]/0x100] - set data(green,intensity) [expr [lindex $rgb 1]/0x100] - set data(blue,intensity) [expr [lindex $rgb 2]/0x100] + set data(red,intensity) [expr {[lindex $rgb 0]/0x100}] + set data(green,intensity) [expr {[lindex $rgb 1]/0x100}] + set data(blue,intensity) [expr {[lindex $rgb 2]/0x100}] } # tkColorDialog_Config -- @@ -181,10 +181,10 @@ proc tkColorDialog_Config {w argList} { # tclParseConfigSpec $w $specs "" $argList - if ![string compare $data(-title) ""] { + if {![string compare $data(-title) ""]} { set data(-title) " " } - if ![string compare $data(-initialcolor) ""] { + if {![string compare $data(-initialcolor) ""]} { if {[info exists tkPriv(selectColor)] && \ [string compare $tkPriv(selectColor) ""]} { set data(-initialcolor) $tkPriv(selectColor) @@ -192,12 +192,12 @@ proc tkColorDialog_Config {w argList} { set data(-initialcolor) [. cget -background] } } else { - if [catch {winfo rgb . $data(-initialcolor)} err] { + if {[catch {winfo rgb . $data(-initialcolor)} err]} { error $err } } - if ![winfo exists $data(-parent)] { + if {![winfo exists $data(-parent)]} { error "bad window path name \"$data(-parent)\"" } } @@ -233,8 +233,8 @@ proc tkColorDialog_BuildDialog {w} { pack $box -side left -fill both set height [expr \ - [winfo reqheight $box.entry] - \ - 2*([$box.entry cget -highlightthickness] + [$box.entry cget -bd])] + {[winfo reqheight $box.entry] - \ + 2*([$box.entry cget -highlightthickness] + [$box.entry cget -bd])}] canvas $f.color -height $height\ -width $data(BARS_WIDTH) -relief sunken -bd 2 @@ -341,7 +341,7 @@ proc tkColorDialog_SetRGBValue {w color} { proc tkColorDialog_XToRgb {w x} { upvar #0 $w data - return [expr ($x * $data(intensityIncr))/ $data(colorbarWidth)] + return [expr {($x * $data(intensityIncr))/ $data(colorbarWidth)}] } # tkColorDialog_RgbToX @@ -351,7 +351,7 @@ proc tkColorDialog_XToRgb {w x} { proc tkColorDialog_RgbToX {w color} { upvar #0 $w data - return [expr ($color * $data(colorbarWidth)/ $data(intensityIncr))] + return [expr {($color * $data(colorbarWidth)/ $data(intensityIncr))}] } @@ -370,7 +370,7 @@ proc tkColorDialog_DrawColorScale {w c {create 0}} { set sel $data($c,sel) # First handle the case that we are creating everything for the first time. - if $create { + if {$create} { # First remove all the lines that already exist. if { $data(lines,$c,last) > $data(lines,$c,start)} { for {set i $data(lines,$c,start)} \ @@ -379,7 +379,7 @@ proc tkColorDialog_DrawColorScale {w c {create 0}} { } } # Delete the selector if it exists - if [info exists data($c,index)] { + if {[info exists data($c,index)]} { $sel delete $data($c,index) } @@ -418,10 +418,10 @@ proc tkColorDialog_DrawColorScale {w c {create 0}} { # Draw the color bars. set highlightW [expr \ - [$col cget -highlightthickness] + [$col cget -bd]] + {[$col cget -highlightthickness] + [$col cget -bd]}] for {set i 0} { $i < $data(NUM_COLORBARS)} { incr i} { - set intensity [expr $i * $data(intensityIncr)] - set startx [expr $i * $data(colorbarWidth) + $highlightW] + set intensity [expr {$i * $data(intensityIncr)}] + set startx [expr {$i * $data(colorbarWidth) + $highlightW}] if { $c == "red" } { set color [format "#%02x%02x%02x" \ $intensity \ @@ -439,10 +439,10 @@ proc tkColorDialog_DrawColorScale {w c {create 0}} { $intensity] } - if $create { + if {$create} { set index [$col create rect $startx $highlightW \ - [expr $startx +$data(colorbarWidth)] \ - [expr [winfo height $col] + $highlightW]\ + [expr {$startx +$data(colorbarWidth)}] \ + [expr {[winfo height $col] + $highlightW}]\ -fill $color -outline $color] } else { $col itemconf $l -fill $color -outline $color @@ -451,9 +451,9 @@ proc tkColorDialog_DrawColorScale {w c {create 0}} { } $sel raise $data($c,index) - if $create { + if {$create} { set data(lines,$c,last) $index - set data(lines,$c,start) [expr $index - $data(NUM_COLORBARS) + 1 ] + set data(lines,$c,start) [expr {$index - $data(NUM_COLORBARS) + 1}] } tkColorDialog_RedrawFinalColor $w @@ -539,7 +539,7 @@ proc tkColorDialog_RedrawColorBars {w colorChanged} { proc tkColorDialog_StartMove {w sel color x delta {dontMove 0}} { upvar #0 $w data - if !$dontMove { + if {!$dontMove} { tkColorDialog_MoveSelector $w $sel $color $x $delta } } @@ -561,11 +561,11 @@ proc tkColorDialog_MoveSelector {w sel color x delta} { if { $x < 0 } { set x 0 } elseif { $x >= $data(BARS_WIDTH)} { - set x [expr $data(BARS_WIDTH) - 1] + set x [expr {$data(BARS_WIDTH) - 1}] } - set diff [expr $x - $data($color,x)] + set diff [expr {$x - $data($color,x)}] $sel move $data($color,index) $diff 0 - set data($color,x) [expr $data($color,x) + $diff] + set data($color,x) [expr {$data($color,x) + $diff}] # Return the x value that it was actually set at return $x @@ -617,14 +617,14 @@ proc tkColorDialog_HandleSelEntry {w} { set text [string trim $data(selection)] # Check to make sure that the color is valid - if [catch {set color [winfo rgb . $text]} ] { + if {[catch {set color [winfo rgb . $text]} ]} { set data(selection) $data(finalColor) return } - set R [expr [lindex $color 0]/0x100] - set G [expr [lindex $color 1]/0x100] - set B [expr [lindex $color 2]/0x100] + set R [expr {[lindex $color 0]/0x100}] + set G [expr {[lindex $color 1]/0x100}] + set B [expr {[lindex $color 2]/0x100}] tkColorDialog_SetRGBValue $w "$R $G $B" set data(selection) $text @@ -638,9 +638,9 @@ proc tkColorDialog_HandleRGBEntry {w} { upvar #0 $w data foreach c {red green blue} { - if [catch { - set data($c,intensity) [expr int($data($c,intensity))] - }] { + if {[catch { + set data($c,intensity) [expr {int($data($c,intensity))}] + }]} { set data($c,intensity) 0 } diff --git a/library/comdlg.tcl b/library/comdlg.tcl index 4f00217..cc2a895 100644 --- a/library/comdlg.tcl +++ b/library/comdlg.tcl @@ -3,7 +3,7 @@ # Some functions needed for the common dialog boxes. Probably need to go # in a different file. # -# SCCS: @(#) comdlg.tcl 1.4 96/09/05 09:07:54 +# SCCS: @(#) comdlg.tcl 1.6 97/12/03 17:09:19 # # Copyright (c) 1996 Sun Microsystems, Inc. # @@ -52,13 +52,12 @@ proc tclParseConfigSpec {w specs flags argList} { set verproc($cmdsw) [lindex $spec 4] } - if {[expr [llength $argList] %2] != 0} { - foreach {cmdsw value} $argList { - if ![info exists cmd($cmdsw)] { - error "unknown option \"$cmdsw\", must be [tclListValidFlags cmd]" - } + if {[llength $argList] & 1} { + set cmdsw [lindex $argList end] + if {![info exists cmd($cmdsw)]} { + error "bad option \"$cmdsw\": must be [tclListValidFlags cmd]" } - error "value for \"[lindex $argList end]\" missing" + error "value for \"$cmdsw\" missing" } # 2: set the default values @@ -70,8 +69,8 @@ proc tclParseConfigSpec {w specs flags argList} { # 3: parse the argument list # foreach {cmdsw value} $argList { - if ![info exists cmd($cmdsw)] { - error "unknown option \"$cmdsw\", must be [tclListValidFlags cmd]" + if {![info exists cmd($cmdsw)]} { + error "bad option \"$cmdsw\": must be [tclListValidFlags cmd]" } set data($cmdsw) $value } @@ -90,7 +89,7 @@ proc tclListValidFlags {v} { append errormsg "$separator$cmdsw" incr i if {$i == $len} { - set separator " or " + set separator ", or " } else { set separator ", " } @@ -137,10 +136,10 @@ proc tclVerifyInteger {string} { # proc tkFocusGroup_Create {t} { global tkPriv - if [string compare [winfo toplevel $t] $t] { + if {[string compare [winfo toplevel $t] $t]} { error "$t is not a toplevel window" } - if ![info exists tkPriv(fg,$t)] { + if {![info exists tkPriv(fg,$t)]} { set tkPriv(fg,$t) 1 set tkPriv(focus,$t) "" bind $t <FocusIn> "tkFocusGroup_In $t %W %d" @@ -156,7 +155,7 @@ proc tkFocusGroup_Create {t} { # proc tkFocusGroup_BindIn {t w cmd} { global tkFocusIn tkPriv - if ![info exists tkPriv(fg,$t)] { + if {![info exists tkPriv(fg,$t)]} { error "focus group \"$t\" doesn't exist" } set tkFocusIn($t,$w) $cmd @@ -171,7 +170,7 @@ proc tkFocusGroup_BindIn {t w cmd} { # proc tkFocusGroup_BindOut {t w cmd} { global tkFocusOut tkPriv - if ![info exists tkPriv(fg,$t)] { + if {![info exists tkPriv(fg,$t)]} { error "focus group \"$t\" doesn't exist" } set tkFocusOut($t,$w) $cmd @@ -185,7 +184,7 @@ proc tkFocusGroup_BindOut {t w cmd} { proc tkFocusGroup_Destroy {t w} { global tkPriv tkFocusIn tkFocusOut - if ![string compare $t $w] { + if {![string compare $t $w]} { unset tkPriv(fg,$t) unset tkPriv(focus,$t) @@ -196,8 +195,8 @@ proc tkFocusGroup_Destroy {t w} { unset tkFocusOut($name) } } else { - if [info exists tkPriv(focus,$t)] { - if ![string compare $tkPriv(focus,$t) $w] { + if {[info exists tkPriv(focus,$t)]} { + if {![string compare $tkPriv(focus,$t) $w]} { set tkPriv(focus,$t) "" } } @@ -218,14 +217,14 @@ proc tkFocusGroup_Destroy {t w} { proc tkFocusGroup_In {t w detail} { global tkPriv tkFocusIn - if ![info exists tkFocusIn($t,$w)] { + if {![info exists tkFocusIn($t,$w)]} { set tkFocusIn($t,$w) "" return } - if ![info exists tkPriv(focus,$t)] { + if {![info exists tkPriv(focus,$t)]} { return } - if ![string compare $tkPriv(focus,$t) $w] { + if {![string compare $tkPriv(focus,$t) $w]} { # This is already in focus # return @@ -250,10 +249,10 @@ proc tkFocusGroup_Out {t w detail} { # This is caused by mouse moving out of the window return } - if ![info exists tkPriv(focus,$t)] { + if {![info exists tkPriv(focus,$t)]} { return } - if ![info exists tkFocusOut($t,$w)] { + if {![info exists tkFocusOut($t,$w)]} { return } else { eval $tkFocusOut($t,$w) @@ -280,18 +279,18 @@ proc tkFDGetFileTypes {string} { set label [lindex $t 0] set exts {} - if [info exists hasDoneType($label)] { + if {[info exists hasDoneType($label)]} { continue } set name "$label (" set sep "" foreach ext $fileTypes($label) { - if ![string compare $ext ""] { + if {![string compare $ext ""]} { continue } regsub {^[.]} $ext "*." ext - if ![info exists hasGotExt($label,$ext)] { + if {![info exists hasGotExt($label,$ext)]} { append name $sep$ext lappend exts $ext set hasGotExt($label,$ext) 1 diff --git a/library/console.tcl b/library/console.tcl index d2c28b2..c046e21 100644 --- a/library/console.tcl +++ b/library/console.tcl @@ -4,7 +4,7 @@ # can be used by non-unix systems that do not have built-in support # for shells. # -# SCCS: @(#) console.tcl 1.45 97/09/17 16:52:40 +# SCCS: @(#) console.tcl 1.47 98/01/02 17:42:06 # # Copyright (c) 1995-1997 Sun Microsystems, Inc. # @@ -108,7 +108,7 @@ proc tkConsoleSource {} { -filetypes {{"Tcl Scripts" .tcl} {"All Files" *}}] if {"$filename" != ""} { set cmd [list source $filename] - if [catch {consoleinterp eval $cmd} result] { + if {[catch {consoleinterp eval $cmd} result]} { tkConsoleOutput stderr "$result\n" } } @@ -136,12 +136,12 @@ proc tkConsoleInvoke {args} { } if {$cmd == ""} { tkConsolePrompt - } elseif [info complete $cmd] { + } elseif {[info complete $cmd]} { .console mark set output end .console tag delete input set result [consoleinterp record $cmd] if {$result != ""} { - .console insert insert "$result\n" + puts $result } tkConsoleHistory reset tkConsolePrompt @@ -168,7 +168,7 @@ proc tkConsoleHistory {cmd} { prev { incr histNum -1 if {$histNum == 0} { - set cmd {history event [expr [history nextid] -1]} + set cmd {history event [expr {[history nextid] -1}]} } else { set cmd "history event $histNum" } @@ -182,7 +182,7 @@ proc tkConsoleHistory {cmd} { next { incr histNum if {$histNum == 0} { - set cmd {history event [expr [history nextid] -1]} + set cmd {history event [expr {[history nextid] -1}]} } elseif {$histNum > 0} { set cmd "" set histNum 1 @@ -213,7 +213,7 @@ proc tkConsolePrompt {{partial normal}} { if {$partial == "normal"} { set temp [.console index "end - 1 char"] .console mark set output end - if [consoleinterp eval "info exists tcl_prompt1"] { + if {[consoleinterp eval "info exists tcl_prompt1"]} { consoleinterp eval "eval \[set tcl_prompt1\]" } else { puts -nonewline "% " @@ -221,7 +221,7 @@ proc tkConsolePrompt {{partial normal}} { } else { set temp [.console index output] .console mark set output end - if [consoleinterp eval "info exists tcl_prompt2"] { + if {[consoleinterp eval "info exists tcl_prompt2"]} { consoleinterp eval "eval \[set tcl_prompt2\]" } else { puts -nonewline "> " @@ -271,7 +271,7 @@ proc tkConsoleBind {win} { if {[%W tag nextrange sel 1.0 end] != ""} { %W tag remove sel sel.first promptEnd } else { - if [%W compare insert < promptEnd] { + if {[%W compare insert < promptEnd]} { break } } @@ -280,14 +280,14 @@ proc tkConsoleBind {win} { if {[%W tag nextrange sel 1.0 end] != ""} { %W tag remove sel sel.first promptEnd } else { - if [%W compare insert <= promptEnd] { + if {[%W compare insert <= promptEnd]} { break } } } foreach left {Control-a Home} { bind $win <$left> { - if [%W compare insert < promptEnd] { + if {[%W compare insert < promptEnd]} { tkTextSetCursor %W {insert linestart} } else { tkTextSetCursor %W promptEnd @@ -302,32 +302,32 @@ proc tkConsoleBind {win} { } } bind $win <Control-d> { - if [%W compare insert < promptEnd] { + if {[%W compare insert < promptEnd]} { break } } bind $win <Control-k> { - if [%W compare insert < promptEnd] { + if {[%W compare insert < promptEnd]} { %W mark set insert promptEnd } } bind $win <Control-t> { - if [%W compare insert < promptEnd] { + if {[%W compare insert < promptEnd]} { break } } bind $win <Meta-d> { - if [%W compare insert < promptEnd] { + if {[%W compare insert < promptEnd]} { break } } bind $win <Meta-BackSpace> { - if [%W compare insert <= promptEnd] { + if {[%W compare insert <= promptEnd]} { break } } bind $win <Control-h> { - if [%W compare insert <= promptEnd] { + if {[%W compare insert <= promptEnd]} { break } } @@ -353,7 +353,7 @@ proc tkConsoleBind {win} { } foreach left {Control-b Left} { bind $win <$left> { - if [%W compare insert == promptEnd] { + if {[%W compare insert == promptEnd]} { break } tkTextSetCursor %W insert-1c diff --git a/library/demos/style.tcl b/library/demos/style.tcl index 6ed31f8..bb1d29b 100644 --- a/library/demos/style.tcl +++ b/library/demos/style.tcl @@ -3,7 +3,7 @@ # This demonstration script creates a text widget that illustrates the # various display styles that may be set for tags. # -# SCCS: @(#) style.tcl 1.8 97/04/18 11:41:47 +# SCCS: @(#) style.tcl 1.9 97/05/06 13:59:06 if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." diff --git a/library/dialog.tcl b/library/dialog.tcl index a9fcfa5..1c4a5ba 100644 --- a/library/dialog.tcl +++ b/library/dialog.tcl @@ -3,7 +3,7 @@ # This file defines the procedure tk_dialog, which creates a dialog # box containing a bitmap, a message, and one or more buttons. # -# SCCS: @(#) dialog.tcl 1.33 97/06/06 11:20:04 +# SCCS: @(#) dialog.tcl 1.35 97/12/19 16:07:49 # # Copyright (c) 1992-1993 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. @@ -61,16 +61,17 @@ proc tk_dialog {w title text bitmap default args} { pack $w.top -side top -fill both -expand 1 # 2. Fill the top part with bitmap and message (use the option - # database for -wraplength so that it can be overridden by - # the caller). + # database for -wraplength and -font so that they can be + # overridden by the caller). option add *Dialog.msg.wrapLength 3i widgetDefault - label $w.msg -justify left -text $text if {$tcl_platform(platform) == "macintosh"} { - $w.msg configure -font system + option add *Dialog.msg.font system widgetDefault } else { - $w.msg configure -font {Times 18} + option add *Dialog.msg.font {Times 18} widgetDefault } + + label $w.msg -justify left -text $text pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m if {$bitmap != ""} { if {($tcl_platform(platform) == "macintosh") && ($bitmap == "error")} { @@ -126,10 +127,10 @@ proc tk_dialog {w title text bitmap default args} { wm withdraw $w update idletasks - set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \ - - [winfo vrootx [winfo parent $w]]] - set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \ - - [winfo vrooty [winfo parent $w]]] + set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \ + - [winfo vrootx [winfo parent $w]]}] + set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 \ + - [winfo vrooty [winfo parent $w]]}] wm geom $w +$x+$y wm deiconify $w diff --git a/library/entry.tcl b/library/entry.tcl index 4a0b764..5668b6b 100644 --- a/library/entry.tcl +++ b/library/entry.tcl @@ -3,7 +3,7 @@ # This file defines the default bindings for Tk entry widgets and provides # procedures that help in implementing those bindings. # -# SCCS: @(#) entry.tcl 1.49 97/09/17 19:08:48 +# SCCS: @(#) entry.tcl 1.50 97/12/03 15:28:57 # # Copyright (c) 1992-1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. @@ -34,7 +34,7 @@ bind Entry <<Cut>> { if {![catch {set data [string range [%W get] [%W index sel.first]\ - [expr [%W index sel.last] - 1]]}]} { + [expr {[%W index sel.last] - 1}]]}]} { clipboard clear -displayof %W clipboard append -displayof %W $data %W delete sel.first sel.last @@ -42,7 +42,7 @@ bind Entry <<Cut>> { } bind Entry <<Copy>> { if {![catch {set data [string range [%W get] [%W index sel.first]\ - [expr [%W index sel.last] - 1]]}]} { + [expr {[%W index sel.last] - 1}]]}]} { clipboard clear -displayof %W clipboard append -displayof %W $data } @@ -115,17 +115,17 @@ bind Entry <ButtonRelease-2> { } bind Entry <Left> { - tkEntrySetCursor %W [expr [%W index insert] - 1] + tkEntrySetCursor %W [expr {[%W index insert] - 1}] } bind Entry <Right> { - tkEntrySetCursor %W [expr [%W index insert] + 1] + tkEntrySetCursor %W [expr {[%W index insert] + 1}] } bind Entry <Shift-Left> { - tkEntryKeySelect %W [expr [%W index insert] - 1] + tkEntryKeySelect %W [expr {[%W index insert] - 1}] tkEntrySeeInsert %W } bind Entry <Shift-Right> { - tkEntryKeySelect %W [expr [%W index insert] + 1] + tkEntryKeySelect %W [expr {[%W index insert] + 1}] tkEntrySeeInsert %W } bind Entry <Control-Left> { @@ -158,7 +158,7 @@ bind Entry <Shift-End> { } bind Entry <Delete> { - if [%W selection present] { + if {[%W selection present]} { %W delete sel.first sel.last } else { %W delete insert @@ -213,67 +213,67 @@ bind Entry <Insert> { # Additional emacs-like bindings: bind Entry <Control-a> { - if !$tk_strictMotif { + if {!$tk_strictMotif} { tkEntrySetCursor %W 0 } } bind Entry <Control-b> { - if !$tk_strictMotif { - tkEntrySetCursor %W [expr [%W index insert] - 1] + if {!$tk_strictMotif} { + tkEntrySetCursor %W [expr {[%W index insert] - 1}] } } bind Entry <Control-d> { - if !$tk_strictMotif { + if {!$tk_strictMotif} { %W delete insert } } bind Entry <Control-e> { - if !$tk_strictMotif { + if {!$tk_strictMotif} { tkEntrySetCursor %W end } } bind Entry <Control-f> { - if !$tk_strictMotif { - tkEntrySetCursor %W [expr [%W index insert] + 1] + if {!$tk_strictMotif} { + tkEntrySetCursor %W [expr {[%W index insert] + 1}] } } bind Entry <Control-h> { - if !$tk_strictMotif { + if {!$tk_strictMotif} { tkEntryBackspace %W } } bind Entry <Control-k> { - if !$tk_strictMotif { + if {!$tk_strictMotif} { %W delete insert end } } bind Entry <Control-t> { - if !$tk_strictMotif { + if {!$tk_strictMotif} { tkEntryTranspose %W } } bind Entry <Meta-b> { - if !$tk_strictMotif { + if {!$tk_strictMotif} { tkEntrySetCursor %W [tkEntryPreviousWord %W insert] } } bind Entry <Meta-d> { - if !$tk_strictMotif { + if {!$tk_strictMotif} { %W delete insert [tkEntryNextWord %W insert] } } bind Entry <Meta-f> { - if !$tk_strictMotif { + if {!$tk_strictMotif} { tkEntrySetCursor %W [tkEntryNextWord %W insert] } } bind Entry <Meta-BackSpace> { - if !$tk_strictMotif { + if {!$tk_strictMotif} { %W delete [tkEntryPreviousWord %W insert] insert } } bind Entry <Meta-Delete> { - if !$tk_strictMotif { + if {!$tk_strictMotif} { %W delete [tkEntryPreviousWord %W insert] insert } } @@ -281,7 +281,7 @@ bind Entry <Meta-Delete> { # A few additional bindings of my own. bind Entry <2> { - if !$tk_strictMotif { + if {!$tk_strictMotif} { %W scan mark %x set tkPriv(x) %x set tkPriv(y) %y @@ -289,7 +289,7 @@ bind Entry <2> { } } bind Entry <B2-Motion> { - if !$tk_strictMotif { + if {!$tk_strictMotif} { if {abs(%x-$tkPriv(x)) > 2} { set tkPriv(mouseMoved) 1 } @@ -356,7 +356,7 @@ proc tkEntryMouseSelect {w x} { } switch $tkPriv(selectMode) { char { - if $tkPriv(mouseMoved) { + if {$tkPriv(mouseMoved)} { if {$cur < $anchor} { $w selection range $cur $anchor } elseif {$cur > $anchor} { @@ -369,10 +369,10 @@ proc tkEntryMouseSelect {w x} { word { if {$cur < [$w index anchor]} { set before [tcl_wordBreakBefore [$w get] $cur] - set after [tcl_wordBreakAfter [$w get] [expr $anchor-1]] + set after [tcl_wordBreakAfter [$w get] [expr {$anchor-1}]] } else { set before [tcl_wordBreakBefore [$w get] $anchor] - set after [tcl_wordBreakAfter [$w get] [expr $cur - 1]] + set after [tcl_wordBreakAfter [$w get] [expr {$cur - 1}]] } if {$before < 0} { set before 0 @@ -440,7 +440,7 @@ proc tkEntryAutoScan {w} { # actually been moved to this position yet). proc tkEntryKeySelect {w new} { - if ![$w selection present] { + if {![$w selection present]} { $w selection from insert $w selection to $new } else { @@ -482,7 +482,7 @@ proc tkEntryInsert {w s} { # w - The entry window in which to backspace. proc tkEntryBackspace w { - if [$w selection present] { + if {[$w selection present]} { $w delete sel.first sel.last } else { set x [expr {[$w index insert] - 1}] @@ -491,7 +491,7 @@ proc tkEntryBackspace w { set range [$w xview] set left [lindex $range 0] set right [lindex $range 1] - $w xview moveto [expr $left - ($right - $left)/2.0] + $w xview moveto [expr {$left - ($right - $left)/2.0}] } } } @@ -547,11 +547,11 @@ proc tkEntryTranspose w { if {$i < [$w index end]} { incr i } - set first [expr $i-2] + set first [expr {$i-2}] if {$first < 0} { return } - set new [string index [$w get] [expr $i-1]][string index [$w get] $first] + set new [string index [$w get] [expr {$i-1}]][string index [$w get] $first] $w delete $first $i $w insert insert $new tkEntrySeeInsert $w diff --git a/library/focus.tcl b/library/focus.tcl index bf0476d..0847e4c 100644 --- a/library/focus.tcl +++ b/library/focus.tcl @@ -3,7 +3,7 @@ # This file defines several procedures for managing the input # focus. # -# SCCS: @(#) focus.tcl 1.17 96/02/16 10:48:21 +# SCCS: @(#) focus.tcl 1.18 97/12/03 15:28:58 # # Copyright (c) 1994-1995 Sun Microsystems, Inc. # @@ -167,9 +167,9 @@ proc tk_focusFollowsMouse {} { set script { if {("%d" == "NotifyAncestor") || ("%d" == "NotifyNonlinear") || ("%d" == "NotifyInferior")} { - if [tkFocusOK %W] { - focus %W - } + if {[tkFocusOK %W]} { + focus %W + } } } if {$old != ""} { diff --git a/library/images/logo.eps b/library/images/logo.eps new file mode 100644 index 0000000..0d05d34 --- /dev/null +++ b/library/images/logo.eps @@ -0,0 +1,2091 @@ +%!PS-Adobe-3.0 EPSF-3.0 +%%Creator: Adobe Illustrator(TM) 5.5 +%%For: (Bud Northern) (Mark Anderson Design) +%%Title: (TCL/TK LOGO.ILLUS) +%%CreationDate: (8/1/96) (4:58 PM) +%%BoundingBox: 251 331 371 512 +%%HiResBoundingBox: 251.3386 331.5616 370.5213 511.775 +%%DocumentProcessColors: Cyan Magenta Yellow +%%DocumentSuppliedResources: procset Adobe_level2_AI5 1.0 0 +%%+ procset Adobe_IllustratorA_AI5 1.0 0 +%AI5_FileFormat 1.2 +%AI3_ColorUsage: Color +%%DocumentCustomColors: (TCL RED) +%%CMYKCustomColor: 0 0.45 1 0 (Orange) +%%+ 0 0.25 1 0 (Orange Yellow) +%%+ 0 0.79 0.91 0 (TCL RED) +%AI3_TemplateBox: 306 396 306 396 +%AI3_TileBox: 12 12 600 780 +%AI3_DocumentPreview: Macintosh_ColorPic +%AI5_ArtSize: 612 792 +%AI5_RulerUnits: 0 +%AI5_ArtFlags: 1 0 0 1 0 0 1 1 0 +%AI5_TargetResolution: 800 +%AI5_NumLayers: 1 +%AI5_OpenToView: 90 576 2 938 673 18 1 1 2 40 +%AI5_OpenViewLayers: 7 +%%EndComments +%%BeginProlog +%%BeginResource: procset Adobe_level2_AI5 1.0 0 +%%Title: (Adobe Illustrator (R) Version 5.0 Level 2 Emulation) +%%Version: 1.0 +%%CreationDate: (04/10/93) () +%%Copyright: ((C) 1987-1993 Adobe Systems Incorporated All Rights Reserved) +userdict /Adobe_level2_AI5 21 dict dup begin + put + /packedarray where not + { + userdict begin + /packedarray + { + array astore readonly + } bind def + /setpacking /pop load def + /currentpacking false def + end + 0 + } if + pop + userdict /defaultpacking currentpacking put true setpacking + /initialize + { + Adobe_level2_AI5 begin + } bind def + /terminate + { + currentdict Adobe_level2_AI5 eq + { + end + } if + } bind def + mark + /setcustomcolor where not + { + /findcmykcustomcolor + { + 5 packedarray + } bind def + /setcustomcolor + { + exch aload pop pop + 4 + { + 4 index mul 4 1 roll + } repeat + 5 -1 roll pop + setcmykcolor + } + def + } if + + /gt38? mark {version cvx exec} stopped {cleartomark true} {38 gt exch pop} ifelse def + userdict /deviceDPI 72 0 matrix defaultmatrix dtransform dup mul exch dup mul add sqrt put + userdict /level2? + systemdict /languagelevel known dup + { + pop systemdict /languagelevel get 2 ge + } if + put + level2? not + { + /setcmykcolor where not + { + /setcmykcolor + { + exch .11 mul add exch .59 mul add exch .3 mul add + 1 exch sub setgray + } def + } if + /currentcmykcolor where not + { + /currentcmykcolor + { + 0 0 0 1 currentgray sub + } def + } if + /setoverprint where not + { + /setoverprint /pop load def + } if + /selectfont where not + { + /selectfont + { + exch findfont exch + dup type /arraytype eq + { + makefont + } + { + scalefont + } ifelse + setfont + } bind def + } if + /cshow where not + { + /cshow + { + [ + 0 0 5 -1 roll aload pop + ] cvx bind forall + } bind def + } if + } if + cleartomark + /anyColor? + { + add add add 0 ne + } bind def + /testColor + { + gsave + setcmykcolor currentcmykcolor + grestore + } bind def + /testCMYKColorThrough + { + testColor anyColor? + } bind def + userdict /composite? + level2? + { + gsave 1 1 1 1 setcmykcolor currentcmykcolor grestore + add add add 4 eq + } + { + 1 0 0 0 testCMYKColorThrough + 0 1 0 0 testCMYKColorThrough + 0 0 1 0 testCMYKColorThrough + 0 0 0 1 testCMYKColorThrough + and and and + } ifelse + put + composite? not + { + userdict begin + gsave + /cyan? 1 0 0 0 testCMYKColorThrough def + /magenta? 0 1 0 0 testCMYKColorThrough def + /yellow? 0 0 1 0 testCMYKColorThrough def + /black? 0 0 0 1 testCMYKColorThrough def + grestore + /isCMYKSep? cyan? magenta? yellow? black? or or or def + /customColor? isCMYKSep? not def + end + } if + end defaultpacking setpacking +%%EndResource +%%BeginResource: procset Adobe_IllustratorA_AI5 1.1 0 +%%Title: (Adobe Illustrator (R) Version 5.0 Abbreviated Prolog) +%%Version: 1.1 +%%CreationDate: (3/7/1994) () +%%Copyright: ((C) 1987-1994 Adobe Systems Incorporated All Rights Reserved) +currentpacking true setpacking +userdict /Adobe_IllustratorA_AI5_vars 70 dict dup begin +put +/_lp /none def +/_pf +{ +} def +/_ps +{ +} def +/_psf +{ +} def +/_pss +{ +} def +/_pjsf +{ +} def +/_pjss +{ +} def +/_pola 0 def +/_doClip 0 def +/cf currentflat def +/_tm matrix def +/_renderStart +[ +/e0 /r0 /a0 /o0 /e1 /r1 /a1 /i0 +] def +/_renderEnd +[ +null null null null /i1 /i1 /i1 /i1 +] def +/_render -1 def +/_rise 0 def +/_ax 0 def +/_ay 0 def +/_cx 0 def +/_cy 0 def +/_leading +[ +0 0 +] def +/_ctm matrix def +/_mtx matrix def +/_sp 16#020 def +/_hyphen (-) def +/_fScl 0 def +/_cnt 0 def +/_hs 1 def +/_nativeEncoding 0 def +/_useNativeEncoding 0 def +/_tempEncode 0 def +/_pntr 0 def +/_tDict 2 dict def +/_wv 0 def +/Tx +{ +} def +/Tj +{ +} def +/CRender +{ +} def +/_AI3_savepage +{ +} def +/_gf null def +/_cf 4 array def +/_if null def +/_of false def +/_fc +{ +} def +/_gs null def +/_cs 4 array def +/_is null def +/_os false def +/_sc +{ +} def +/discardSave null def +/buffer 256 string def +/beginString null def +/endString null def +/endStringLength null def +/layerCnt 1 def +/layerCount 1 def +/perCent (%) 0 get def +/perCentSeen? false def +/newBuff null def +/newBuffButFirst null def +/newBuffLast null def +/clipForward? false def +end +userdict /Adobe_IllustratorA_AI5 74 dict dup begin +put +/initialize +{ + Adobe_IllustratorA_AI5 dup begin + Adobe_IllustratorA_AI5_vars begin + discardDict + { + bind pop pop + } forall + dup /nc get begin + { + dup xcheck 1 index type /operatortype ne and + { + bind + } if + pop pop + } forall + end + newpath +} def +/terminate +{ + end + end +} def +/_ +null def +/ddef +{ + Adobe_IllustratorA_AI5_vars 3 1 roll put +} def +/xput +{ + dup load dup length exch maxlength eq + { + dup dup load dup + length 2 mul dict copy def + } if + load begin + def + end +} def +/npop +{ + { + pop + } repeat +} def +/sw +{ + dup length exch stringwidth + exch 5 -1 roll 3 index mul add + 4 1 roll 3 1 roll mul add +} def +/swj +{ + dup 4 1 roll + dup length exch stringwidth + exch 5 -1 roll 3 index mul add + 4 1 roll 3 1 roll mul add + 6 2 roll /_cnt 0 ddef + { + 1 index eq + { + /_cnt _cnt 1 add ddef + } if + } forall + pop + exch _cnt mul exch _cnt mul 2 index add 4 1 roll 2 index add 4 1 roll pop pop +} def +/ss +{ + 4 1 roll + { + 2 npop + (0) exch 2 copy 0 exch put pop + gsave + false charpath currentpoint + 4 index setmatrix + stroke + grestore + moveto + 2 copy rmoveto + } exch cshow + 3 npop +} def +/jss +{ + 4 1 roll + { + 2 npop + (0) exch 2 copy 0 exch put + gsave + _sp eq + { + exch 6 index 6 index 6 index 5 -1 roll widthshow + currentpoint + } + { + false charpath currentpoint + 4 index setmatrix stroke + } ifelse + grestore + moveto + 2 copy rmoveto + } exch cshow + 6 npop +} def +/sp +{ + { + 2 npop (0) exch + 2 copy 0 exch put pop + false charpath + 2 copy rmoveto + } exch cshow + 2 npop +} def +/jsp +{ + { + 2 npop + (0) exch 2 copy 0 exch put + _sp eq + { + exch 5 index 5 index 5 index 5 -1 roll widthshow + } + { + false charpath + } ifelse + 2 copy rmoveto + } exch cshow + 5 npop +} def +/pl +{ + transform + 0.25 sub round 0.25 add exch + 0.25 sub round 0.25 add exch + itransform +} def +/setstrokeadjust where +{ + pop true setstrokeadjust + /c + { + curveto + } def + /C + /c load def + /v + { + currentpoint 6 2 roll curveto + } def + /V + /v load def + /y + { + 2 copy curveto + } def + /Y + /y load def + /l + { + lineto + } def + /L + /l load def + /m + { + moveto + } def +} +{ + /c + { + pl curveto + } def + /C + /c load def + /v + { + currentpoint 6 2 roll pl curveto + } def + /V + /v load def + /y + { + pl 2 copy curveto + } def + /Y + /y load def + /l + { + pl lineto + } def + /L + /l load def + /m + { + pl moveto + } def +} ifelse +/d +{ + setdash +} def +/cf +{ +} def +/i +{ + dup 0 eq + { + pop cf + } if + setflat +} def +/j +{ + setlinejoin +} def +/J +{ + setlinecap +} def +/M +{ + setmiterlimit +} def +/w +{ + setlinewidth +} def +/H +{ +} def +/h +{ + closepath +} def +/N +{ + _pola 0 eq + { + _doClip 1 eq + { + clip /_doClip 0 ddef + } if + newpath + } + { + /CRender + { + N + } ddef + } ifelse +} def +/n +{ + N +} def +/F +{ + _pola 0 eq + { + _doClip 1 eq + { + gsave _pf grestore clip newpath /_lp /none ddef _fc + /_doClip 0 ddef + } + { + _pf + } ifelse + } + { + /CRender + { + F + } ddef + } ifelse +} def +/f +{ + closepath + F +} def +/S +{ + _pola 0 eq + { + _doClip 1 eq + { + gsave _ps grestore clip newpath /_lp /none ddef _sc + /_doClip 0 ddef + } + { + _ps + } ifelse + } + { + /CRender + { + S + } ddef + } ifelse +} def +/s +{ + closepath + S +} def +/B +{ + _pola 0 eq + { + _doClip 1 eq + gsave F grestore + { + gsave S grestore clip newpath /_lp /none ddef _sc + /_doClip 0 ddef + } + { + S + } ifelse + } + { + /CRender + { + B + } ddef + } ifelse +} def +/b +{ + closepath + B +} def +/W +{ + /_doClip 1 ddef +} def +/* +{ + count 0 ne + { + dup type /stringtype eq + { + pop + } if + } if + newpath +} def +/u +{ +} def +/U +{ +} def +/q +{ + _pola 0 eq + { + gsave + } if +} def +/Q +{ + _pola 0 eq + { + grestore + } if +} def +/*u +{ + _pola 1 add /_pola exch ddef +} def +/*U +{ + _pola 1 sub /_pola exch ddef + _pola 0 eq + { + CRender + } if +} def +/D +{ + pop +} def +/*w +{ +} def +/*W +{ +} def +/` +{ + /_i save ddef + clipForward? + { + nulldevice + } if + 6 1 roll 4 npop + concat pop + userdict begin + /showpage + { + } def + 0 setgray + 0 setlinecap + 1 setlinewidth + 0 setlinejoin + 10 setmiterlimit + [] 0 setdash + /setstrokeadjust where {pop false setstrokeadjust} if + newpath + 0 setgray + false setoverprint +} def +/~ +{ + end + _i restore +} def +/O +{ + 0 ne + /_of exch ddef + /_lp /none ddef +} def +/R +{ + 0 ne + /_os exch ddef + /_lp /none ddef +} def +/g +{ + /_gf exch ddef + /_fc + { + _lp /fill ne + { + _of setoverprint + _gf setgray + /_lp /fill ddef + } if + } ddef + /_pf + { + _fc + fill + } ddef + /_psf + { + _fc + ashow + } ddef + /_pjsf + { + _fc + awidthshow + } ddef + /_lp /none ddef +} def +/G +{ + /_gs exch ddef + /_sc + { + _lp /stroke ne + { + _os setoverprint + _gs setgray + /_lp /stroke ddef + } if + } ddef + /_ps + { + _sc + stroke + } ddef + /_pss + { + _sc + ss + } ddef + /_pjss + { + _sc + jss + } ddef + /_lp /none ddef +} def +/k +{ + _cf astore pop + /_fc + { + _lp /fill ne + { + _of setoverprint + _cf aload pop setcmykcolor + /_lp /fill ddef + } if + } ddef + /_pf + { + _fc + fill + } ddef + /_psf + { + _fc + ashow + } ddef + /_pjsf + { + _fc + awidthshow + } ddef + /_lp /none ddef +} def +/K +{ + _cs astore pop + /_sc + { + _lp /stroke ne + { + _os setoverprint + _cs aload pop setcmykcolor + /_lp /stroke ddef + } if + } ddef + /_ps + { + _sc + stroke + } ddef + /_pss + { + _sc + ss + } ddef + /_pjss + { + _sc + jss + } ddef + /_lp /none ddef +} def +/x +{ + /_gf exch ddef + findcmykcustomcolor + /_if exch ddef + /_fc + { + _lp /fill ne + { + _of setoverprint + _if _gf 1 exch sub setcustomcolor + /_lp /fill ddef + } if + } ddef + /_pf + { + _fc + fill + } ddef + /_psf + { + _fc + ashow + } ddef + /_pjsf + { + _fc + awidthshow + } ddef + /_lp /none ddef +} def +/X +{ + /_gs exch ddef + findcmykcustomcolor + /_is exch ddef + /_sc + { + _lp /stroke ne + { + _os setoverprint + _is _gs 1 exch sub setcustomcolor + /_lp /stroke ddef + } if + } ddef + /_ps + { + _sc + stroke + } ddef + /_pss + { + _sc + ss + } ddef + /_pjss + { + _sc + jss + } ddef + /_lp /none ddef +} def +/A +{ + pop +} def +/annotatepage +{ +userdict /annotatepage 2 copy known {get exec} {pop pop} ifelse +} def +/discard +{ + save /discardSave exch store + discardDict begin + /endString exch store + gt38? + { + 2 add + } if + load + stopped + pop + end + discardSave restore +} bind def +userdict /discardDict 7 dict dup begin +put +/pre38Initialize +{ + /endStringLength endString length store + /newBuff buffer 0 endStringLength getinterval store + /newBuffButFirst newBuff 1 endStringLength 1 sub getinterval store + /newBuffLast newBuff endStringLength 1 sub 1 getinterval store +} def +/shiftBuffer +{ + newBuff 0 newBuffButFirst putinterval + newBuffLast 0 + currentfile read not + { + stop + } if + put +} def +0 +{ + pre38Initialize + mark + currentfile newBuff readstring exch pop + { + { + newBuff endString eq + { + cleartomark stop + } if + shiftBuffer + } loop + } + { + stop + } ifelse +} def +1 +{ + pre38Initialize + /beginString exch store + mark + currentfile newBuff readstring exch pop + { + { + newBuff beginString eq + { + /layerCount dup load 1 add store + } + { + newBuff endString eq + { + /layerCount dup load 1 sub store + layerCount 0 eq + { + cleartomark stop + } if + } if + } ifelse + shiftBuffer + } loop + } + { + stop + } ifelse +} def +2 +{ + mark + { + currentfile buffer readline not + { + stop + } if + endString eq + { + cleartomark stop + } if + } loop +} def +3 +{ + /beginString exch store + /layerCnt 1 store + mark + { + currentfile buffer readline not + { + stop + } if + dup beginString eq + { + pop /layerCnt dup load 1 add store + } + { + endString eq + { + layerCnt 1 eq + { + cleartomark stop + } + { + /layerCnt dup load 1 sub store + } ifelse + } if + } ifelse + } loop +} def +end +userdict /clipRenderOff 15 dict dup begin +put +{ + /n /N /s /S /f /F /b /B +} +{ + { + _doClip 1 eq + { + /_doClip 0 ddef clip + } if + newpath + } def +} forall +/Tr /pop load def +/Bb {} def +/BB /pop load def +/Bg {12 npop} def +/Bm {6 npop} def +/Bc /Bm load def +/Bh {4 npop} def +end +/Lb +{ + 4 npop + 6 1 roll + pop + 4 1 roll + pop pop pop + 0 eq + { + 0 eq + { + (%AI5_BeginLayer) 1 (%AI5_EndLayer--) discard + } + { + /clipForward? true def + + /Tx /pop load def + /Tj /pop load def + currentdict end clipRenderOff begin begin + } ifelse + } + { + 0 eq + { + save /discardSave exch store + } if + } ifelse +} bind def +/LB +{ + discardSave dup null ne + { + restore + } + { + pop + clipForward? + { + currentdict + end + end + begin + + /clipForward? false ddef + } if + } ifelse +} bind def +/Pb +{ + pop pop + 0 (%AI5_EndPalette) discard +} bind def +/Np +{ + 0 (%AI5_End_NonPrinting--) discard +} bind def +/Ln /pop load def +/Ap +/pop load def +/Ar +{ + 72 exch div + 0 dtransform dup mul exch dup mul add sqrt + dup 1 lt + { + pop 1 + } if + setflat +} def +/Mb +{ + q +} def +/Md +{ +} def +/MB +{ + Q +} def +/nc 3 dict def +nc begin +/setgray +{ + pop +} bind def +/setcmykcolor +{ + 4 npop +} bind def +/setcustomcolor +{ + 2 npop +} bind def +currentdict readonly pop +end +currentdict readonly pop +end +setpacking +%%EndResource +%%EndProlog +%%BeginSetup +Adobe_level2_AI5 /initialize get exec +Adobe_IllustratorA_AI5 /initialize get exec +%AI5_Begin_NonPrinting +Np +%AI3_BeginPattern: (Yellow Stripe) +(Yellow Stripe) 8.4499 4.6 80.4499 76.6 [ +%AI3_Tile +(0 O 0 R 0 0.4 1 0 k 0 0.4 1 0 K) @ +( +800 Ar +0 J 0 j 3.6 w 4 M []0 d +%AI3_Note: +0 D +8.1999 8.1999 m +80.6999 8.1999 L +S +8.1999 22.6 m +80.6999 22.6 L +S +8.1999 37.0001 m +80.6999 37.0001 L +S +8.1999 51.3999 m +80.6999 51.3999 L +S +8.1999 65.8 m +80.6999 65.8 L +S +8.1999 15.3999 m +80.6999 15.3999 L +S +8.1999 29.8 m +80.6999 29.8 L +S +8.1999 44.1999 m +80.6999 44.1999 L +S +8.1999 58.6 m +80.6999 58.6 L +S +8.1999 73.0001 m +80.6999 73.0001 L +S +) & +] E +%AI3_EndPattern +%AI5_End_NonPrinting-- +%AI5_Begin_NonPrinting +Np +3 Bn +%AI5_BeginGradient: (Black & White) +(Black & White) 0 2 Bd +[ +< +FFFEFDFCFBFAF9F8F7F6F5F4F3F2F1F0EFEEEDECEBEAE9E8E7E6E5E4E3E2E1E0DFDEDDDCDBDAD9D8 +D7D6D5D4D3D2D1D0CFCECDCCCBCAC9C8C7C6C5C4C3C2C1C0BFBEBDBCBBBAB9B8B7B6B5B4B3B2B1B0 +AFAEADACABAAA9A8A7A6A5A4A3A2A1A09F9E9D9C9B9A999897969594939291908F8E8D8C8B8A8988 +87868584838281807F7E7D7C7B7A797877767574737271706F6E6D6C6B6A69686766656463626160 +5F5E5D5C5B5A595857565554535251504F4E4D4C4B4A494847464544434241403F3E3D3C3B3A3938 +37363534333231302F2E2D2C2B2A292827262524232221201F1E1D1C1B1A19181716151413121110 +0F0E0D0C0B0A09080706050403020100 +> +0 %_Br +[ +0 0 50 100 %_Bs +1 0 50 0 %_Bs +BD +%AI5_EndGradient +%AI5_BeginGradient: (Red & Yellow) +(Red & Yellow) 0 2 Bd +[ +0 +< +000102030405060708090A0B0C0D0E0F101112131415161718191A1B1C1D1E1F2021222324252627 +28292A2B2C2D2E2F303132333435363738393A3B3C3D3E3F404142434445464748494A4B4C4D4E4F +505152535455565758595A5B5C5D5E5F606162636465666768696A6B6C6D6E6F7071727374757677 +78797A7B7C7D7E7F808182838485868788898A8B8C8D8E8F909192939495969798999A9B9C9D9E9F +A0A1A2A3A4A5A6A7A8A9AAABACADAEAFB0B1B2B3B4B5B6B7B8B9BABBBCBDBEBFC0C1C2C3C4C5C6C7 +C8C9CACBCCCDCECFD0D1D2D3D4D5D6D7D8D9DADBDCDDDEDFE0E1E2E3E4E5E6E7E8E9EAEBECEDEEEF +F0F1F2F3F4F5F6F7F8F9FAFBFCFDFEFF +> +< +FFFFFEFEFDFDFDFCFCFBFBFBFAFAF9F9F9F8F8F7F7F7F6F6F5F5F5F4F4F3F3F3F2F2F1F1F1F0F0EF +EFEFEEEEEDEDEDECECEBEBEBEAEAE9E9E9E8E8E7E7E7E6E6E5E5E5E4E4E3E3E3E2E2E1E1E1E0E0DF +DFDFDEDEDDDDDDDCDCDBDBDBDADAD9D9D9D8D8D7D7D7D6D6D5D5D5D4D4D3D3D3D2D2D1D1D1D0D0CF +CFCFCECECDCDCDCCCCCBCBCBCACAC9C9C9C8C8C7C7C7C6C6C5C5C5C4C4C3C3C3C2C2C1C1C1C0C0BF +BFBFBEBEBDBDBDBCBCBBBBBBBABAB9B9B9B8B8B7B7B7B6B6B5B5B5B4B4B3B3B3B2B2B1B1B1B0B0AF +AFAFAEAEADADADACACABABABAAAAA9A9A9A8A8A7A7A7A6A6A5A5A5A4A4A3A3A3A2A2A1A1A1A0A09F +9F9F9E9E9D9D9D9C9C9B9B9B9A9A9999 +> +0 +1 %_Br +[ +0 1 0.6 0 1 50 100 %_Bs +0 0 1 0 1 50 0 %_Bs +BD +%AI5_EndGradient +%AI5_BeginGradient: (Yellow & Blue Radial) +(Yellow & Blue Radial) 1 2 Bd +[ +< +000102030405060708090A0B0C0D0E0F101112131415161718191A1B1C1D1E1F2021222324252627 +28292A2B2C2D2E2F303132333435363738393A3B3C3D3E3F404142434445464748494A4B4C4D4E4F +505152535455565758595A5B5C5D5E5F606162636465666768696A6B6C6D6E6F7071727374757677 +78797A7B7C7D7E7F808182838485868788898A8B8C8D8E8F909192939495969798999A9B9C9D9E9F +A0A1A2A3A4A5A6A7A8A9AAABACADAEAFB0B1B2B3B4B5B6B7B8B9BABBBCBDBEBFC0C1C2C3C4C5C6C7 +C8C9CACBCCCDCECFD0D1D2D3D4D5D6D7D8D9DADBDCDDDEDFE0E1E2E3E4E5E6E7E8E9EAEBECEDEEEF +F0F1F2F3F4F5F6F7F8F9FAFBFCFDFEFF +> +< +1415161718191A1B1C1D1E1F1F202122232425262728292A2A2B2C2D2E2F30313233343536363738 +393A3B3C3D3E3F40414142434445464748494A4B4C4D4D4E4F50515253545556575858595A5B5C5D +5E5F60616263646465666768696A6B6C6D6E6F6F707172737475767778797A7B7B7C7D7E7F808182 +83848586868788898A8B8C8D8E8F90919292939495969798999A9B9C9D9D9E9FA0A1A2A3A4A5A6A7 +A8A9A9AAABACADAEAFB0B1B2B3B4B4B5B6B7B8B9BABBBCBDBEBFC0C0C1C2C3C4C5C6C7C8C9CACBCB +CCCDCECFD0D1D2D3D4D5D6D7D7D8D9DADBDCDDDEDFE0E1E2E2E3E4E5E6E7E8E9EAEBECEDEEEEEFF0 +F1F2F3F4F5F6F7F8F9F9FAFBFCFDFEFF +> +< +ABAAAAA9A8A7A7A6A5A5A4A3A3A2A1A1A09F9F9E9D9D9C9B9B9A9999989797969595949393929191 +908F8F8E8D8D8C8B8B8A8989888787868585848383828181807F7F7E7D7D7C7B7B7A797978777776 +7575747373727171706F6F6E6D6D6C6B6B6A6969686767666565646362626160605F5E5E5D5C5C5B +5A5A5958585756565554545352525150504F4E4E4D4C4C4B4A4A4948484746464544444342424140 +403F3E3E3D3C3C3B3A3A3938383736363534343332323130302F2E2E2D2C2C2B2A2A292828272626 +25242423222121201F1F1E1D1D1C1B1B1A1919181717161515141313121111100F0F0E0D0D0C0B0B +0A090908070706050504030302010100 +> +0 +1 %_Br +[ +0 0.08 0.67 0 1 50 14 %_Bs +1 1 0 0 1 50 100 %_Bs +BD +%AI5_EndGradient +%AI5_End_NonPrinting-- +%AI5_BeginPalette +144 170 Pb +Pn +Pc +1 g +Pc +0 g +Pc +0 0 0 0 k +Pc +0.75 g +Pc +0.5 g +Pc +0.25 g +Pc +0 g +Pc +Bb +2 (Black & White) -4014 4716 0 0 1 0 0 1 0 0 Bg +0 BB +Pc +0.25 0 0 0 k +Pc +0.5 0 0 0 k +Pc +0.75 0 0 0 k +Pc +1 0 0 0 k +Pc +0.25 0.25 0 0 k +Pc +0.5 0.5 0 0 k +Pc +0.75 0.75 0 0 k +Pc +1 1 0 0 k +Pc +Bb +2 (Red & Yellow) -4014 4716 0 0 1 0 0 1 0 0 Bg +0 BB +Pc +0 0.25 0 0 k +Pc +0 0.5 0 0 k +Pc +0 0.75 0 0 k +Pc +0 1 0 0 k +Pc +0 0.25 0.25 0 k +Pc +0 0.5 0.5 0 k +Pc +0 0.75 0.75 0 k +Pc +0 1 1 0 k +Pc +Bb +0 0 0 0 Bh +2 (Yellow & Blue Radial) -4014 4716 0 0 1 0 0 1 0 0 Bg +0 BB +Pc +0 0 0.25 0 k +Pc +0 0 0.5 0 k +Pc +0 0 0.75 0 k +Pc +0 0 1 0 k +Pc +0.25 0 0.25 0 k +Pc +0.5 0 0.5 0 k +Pc +0.75 0 0.75 0 k +Pc +1 0 1 0 k +Pc +(Yellow Stripe) 0 0 1 1 0 0 0 0 0 [1 0 0 1 0 0] p +Pc +0.25 0.125 0 0 k +Pc +0.5 0.25 0 0 k +Pc +0.75 0.375 0 0 k +Pc +1 0.5 0 0 k +Pc +0.125 0.25 0 0 k +Pc +0.25 0.5 0 0 k +Pc +0.375 0.75 0 0 k +Pc +0.5 1 0 0 k +Pc +0.375 0.375 0.75 0 k +Pc +0 0.25 0.125 0 k +Pc +0 0.5 0.25 0 k +Pc +0 0.75 0.375 0 k +Pc +0 1 0.5 0 k +Pc +0 0.125 0.25 0 k +Pc +0 0.25 0.5 0 k +Pc +0 0.375 0.75 0 k +Pc +0 0.5 1 0 k +Pc +0 0.79 0.91 0 (TCL RED) 0 x +Pc +0.125 0 0.25 0 k +Pc +0.25 0 0.5 0 k +Pc +0.375 0 0.75 0 k +Pc +0.5 0 1 0 k +Pc +0.25 0 0.125 0 k +Pc +0.5 0 0.25 0 k +Pc +0.75 0 0.375 0 k +Pc +1 0 0.5 0 k +Pc +0.5 1 0 0 k +Pc +0.25 0.125 0.125 0 k +Pc +0.5 0.25 0.25 0 k +Pc +0.75 0.375 0.375 0 k +Pc +1 0.5 0.5 0 k +Pc +0.25 0.25 0.125 0 k +Pc +0.5 0.5 0.25 0 k +Pc +0.75 0.75 0.375 0 k +Pc +1 1 0.5 0 k +Pc +0 1 0.5 0 k +Pc +0.125 0.25 0.125 0 k +Pc +0.25 0.5 0.25 0 k +Pc +0.375 0.75 0.375 0 k +Pc +0.5 1 0.5 0 k +Pc +0.125 0.25 0.25 0 k +Pc +0.25 0.5 0.5 0 k +Pc +0.375 0.75 0.75 0 k +Pc +0.5 1 1 0 k +Pc +0.75 0.75 0.375 0 k +Pc +0.125 0.125 0.25 0 k +Pc +0.25 0.25 0.5 0 k +Pc +0.375 0.375 0.75 0 k +Pc +0.5 0.5 1 0 k +Pc +0.25 0.125 0.25 0 k +Pc +0.5 0.25 0.5 0 k +Pc +0.75 0.375 0.75 0 k +Pc +1 0.5 1 0 k +Pc +0 0.79 0.91 0 (TCL RED) 0 x +Pc +0 0 0 0 k +Pc +Pc +Pc +Pc +Pc +Pc +Pc +Pc +1 0.5 0.5 0 k +Pc +0 0 0 0 k +Pc +Pc +Pc +Pc +Pc +Pc +Pc +Pc +0 0.25 1 0 (Orange Yellow) 0 x +Pc +0 0 0 0 k +Pc +Pc +Pc +Pc +Pc +Pc +Pc +Pc +0 1 0.5 0 k +Pc +0 0 0 0 k +Pc +Pc +Pc +Pc +Pc +Pc +Pc +Pc +1 0 0.5 0 k +Pc +0 0 0 0 k +Pc +Pc +Pc +Pc +Pc +Pc +Pc +Pc +0 0.45 1 0 (Orange) 0 x +Pc +0 0 0 0 k +Pc +Pc +Pc +Pc +Pc +Pc +Pc +Pc +0.375 0.375 0.75 0 k +Pc +0 0 0 0 k +Pc +Pc +Pc +Pc +Pc +Pc +Pc +Pc +0 0.79 0.91 0 (TCL RED) 0 x +Pc +0 0 0 0 k +Pc +Pc +Pc +Pc +Pc +Pc +Pc +Pc +1 0.65 0 0 k +Pc +0 0 0 0 k +Pc +Pc +Pc +Pc +Pc +Pc +Pc +Pc +0 0 1 0 k +Pc +PB +%AI5_EndPalette +%%EndSetup +%AI5_BeginLayer +1 1 1 1 0 0 0 79 128 255 Lb +(Layer 1) Ln +0 A +u +1 Ap +0 O +0 0.79 0.91 0 (TCL RED) 0 x +800 Ar +0 J 0 j 1.25 w 4 M []0 d +%AI3_Note: +0 D +294.5207 335.3041 m +368.2181 333.001 L +363.6121 423.9713 L +370.5213 507.1689 L +336.5513 505.4417 L +320.7179 511.775 L +251.3386 508.0325 L +254.7931 425.9866 L +251.3386 331.5616 L +294.5207 335.3041 L +f +u +0 Ap +1 0.65 0 0 k +1 w +318.1366 400.9627 m +311.8663 399.2526 l +315.2864 407.5177 l +318.7064 430.6032 l +314.4314 431.4581 l +319.5616 438.5832 l +325.9526 462.6014 l +314.7164 460.2436 l +320.6412 471.0911 326.9284 478.1557 v +318.7064 484.469 l +292.2183 472.8011 299.3434 434.8954 v +293.8679 435.8542 l +299.1189 396.1175 l +294.6797 394.9775 l +299.2277 385.6974 305.5963 381.2973 v +306.1744 380.8979 297.6162 412.3629 306.7363 443.7133 c +307.5914 441.7183 l +300.3238 408.3015 307.5914 381.2973 v +307.9261 380.656 311.5598 381.0836 v +318.1366 393.4813 318.1366 400.9627 v +f +u +*u +1 g +271.4311 372.5074 m +272.7184 372.5074 L +272.7184 375.1913 L +273.2858 375.1913 273.8313 375.1913 274.3768 375.2786 c +274.3768 372.5074 L +276.2969 372.5074 L +276.2969 372.0056 L +274.3768 372.0056 L +274.3768 365.3286 L +274.3768 364.9359 274.3768 364.3467 275.2059 364.3467 c +275.7733 364.3467 276.0787 364.7395 276.4279 365.1541 c +276.777 364.9141 L +276.3624 364.0849 275.2932 363.583 274.4204 363.583 c +272.8494 363.583 272.6748 364.434 272.6748 365.4814 c +272.6748 372.0056 L +271.4311 372.0056 L +271.4311 372.5074 l +f +*U +*u +290.5617 366.5724 m +290.0598 365.0232 289.187 363.6703 286.9178 363.583 c +283.5356 363.583 282.5101 366.3978 282.5101 367.9034 c +282.5101 371.7874 285.6304 372.7256 286.8741 372.7256 c +288.2924 372.7256 290.2999 372.071 290.2999 370.3909 c +290.2999 369.8018 289.9289 369.2344 289.318 369.2344 c +288.7288 369.2344 288.2924 369.6272 288.2924 370.26 c +288.2924 371.111 288.9907 371.2201 288.9907 371.4601 c +288.9907 372.0492 287.616 372.2892 287.136 372.2892 c +285.0412 372.2892 284.4957 370.7618 284.4957 367.9034 c +284.4957 366.5942 284.823 365.5905 284.9539 365.285 c +285.2812 364.5649 285.9577 364.1067 287.0923 364.0413 c +288.3579 363.9758 289.5798 365.0013 290.1035 366.5724 C +290.5617 366.5724 l +f +*U +*u +296.6 363.8667 m +296.6 364.3686 L +298.2802 364.3686 L +298.2802 378.3989 L +296.6 378.3989 L +296.6 378.9007 L +297.5383 378.9007 L +298.3457 378.9007 299.1966 378.9444 299.9822 379.0971 c +299.9822 364.3686 L +301.6623 364.3686 L +301.6623 363.8667 L +296.6 363.8667 l +f +*U +*u +317.4527 372.5074 m +318.7401 372.5074 L +318.7401 375.1913 L +319.3074 375.1913 319.8529 375.1913 320.3984 375.2786 c +320.3984 372.5074 L +322.3186 372.5074 L +322.3186 372.0056 L +320.3984 372.0056 L +320.3984 365.3286 L +320.3984 364.9359 320.3984 364.3467 321.2276 364.3467 c +321.7949 364.3467 322.1004 364.7395 322.4495 365.1541 c +322.7986 364.9141 L +322.384 364.0849 321.3148 363.583 320.442 363.583 c +318.871 363.583 318.6964 364.434 318.6964 365.4814 c +318.6964 372.0056 L +317.4527 372.0056 L +317.4527 372.5074 l +f +*U +*u +333.7467 372.0056 m +333.7467 372.5074 L +337.3252 372.5074 L +337.3252 372.0056 L +335.9942 372.0056 L +332.983 369.3872 L +337.1288 364.3686 L +338.0453 364.3686 L +338.0453 363.8667 L +333.8995 363.8667 L +333.8995 364.3686 L +334.9905 364.3686 L +331.3465 368.798 L +335.0341 371.9401 L +335.0341 372.0056 L +333.7467 372.0056 l +f +328.4881 363.8667 m +328.4881 364.3686 L +329.6227 364.3686 L +329.6227 378.3989 L +328.4881 378.3989 L +328.4881 378.9007 L +328.8809 378.9007 L +329.6882 378.9007 330.5392 378.9444 331.3247 379.0971 c +331.3247 364.3686 L +332.6339 364.3686 L +332.6339 363.8667 L +328.4881 363.8667 l +f +*U +u +309.5341 446.5364 m +305.6878 429.3874 306.7947 401.5837 v +307.1266 393.2441 308.0387 385.5779 309.1527 378.9301 C +309.1587 378.9297 L +309.8832 373.0923 310.3679 370.9791 312.2568 363.9454 C +312.1466 359.4091 L +297.0216 407.7015 309.5341 446.5364 V +f +318.8187 461.4058 m +322.2203 463.1 327.0966 463.7165 v +332.427 453.9463 319.3087 437.2655 v +327.1346 454.735 325.2889 460.2079 v +323.225 461.4903 318.8187 461.4058 v +f +317.2065 432.0795 m +320.2613 431.3723 321.7279 432.5601 v +318.8383 421.2839 319.5958 415.0813 v +320.3533 408.8787 314.8881 404.9079 y +319.5435 410.7982 318.0802 415.5959 v +317.0657 418.9214 318.2006 427.4326 319.4809 430.1349 c +318.2853 430.3025 317.2065 432.0795 v +f +314.1861 402.3703 m +319.2343 402.9744 319.7646 405.5244 v +320.3824 390.2725 313.3689 383.9873 v +318.7204 392.3347 317.8807 400.9697 v +314.1861 402.3703 l +f +299.9864 396.0219 m +298.3586 394.1986 293.4739 398.2203 v +295.0301 387.9694 304.6978 383.2767 v +298.0444 388.2897 296.2519 393.7045 v +298.6029 394.3966 299.9864 396.0219 v +f +298.4281 399.9096 m +291.8229 416.6749 293.2382 439.3286 v +294.7808 435.2261 299.738 433.7875 v +297.4026 433.3101 296.0372 433.517 v +292.5816 423.9535 298.4281 399.9096 v +f +326.1736 477.812 m +323.6983 496.0028 308.2122 477.6066 v +295.8813 462.9582 297.3508 450.5217 298.1072 443.5831 c +298.3007 441.8079 295.8131 462.1138 309.3231 475.4768 c +322.8328 488.8398 325.8846 478.5879 326.1736 477.812 c +f +U +0 0 1 0 k +303.3623 493.3274 m +291.211 496.7978 287.3437 456.5222 v +284.3599 468.9535 292.0777 486.5353 v +299.7955 504.1172 303.3623 493.3274 y +f +288.2873 496.2718 m +282.0897 486.9502 283.4958 477.0213 v +278.7953 495.712 288.2873 496.2718 v +f +333.8987 470.1328 m +341.2276 472.8361 330.7334 445.5571 v +336.1654 453.5292 339.5844 466.0531 v +341.7789 474.0903 333.8987 470.1328 y +f +345.752 472.2583 m +350.9334 467.5681 347.2615 461.3636 v +356.4779 471.0481 345.752 472.2583 v +f +U +*u +273.1765 354.3318 m +273.1765 353.7507 273.1305 353.2908 272.5159 353.2908 c +271.8846 353.2908 271.8554 353.7674 271.8554 354.3318 c +271.8554 356.485 L +272.148 356.485 L +272.148 354.3486 L +272.148 353.8259 272.1773 353.5751 272.5159 353.5751 c +272.8504 353.5751 272.8839 353.8259 272.8839 354.3486 c +272.8839 356.485 L +273.1765 356.485 L +273.1765 354.3318 l +f +*U +*u +277.1612 356.485 m +276.9062 356.485 L +276.9062 354.3862 l +276.9062 354.2482 276.9271 354.1061 276.9355 353.9681 C +276.9229 353.9681 l +276.8937 354.0768 276.8644 354.1855 276.8268 354.2942 C +276.1035 356.485 L +275.8484 356.485 L +275.8484 353.3326 L +276.1035 353.3326 L +276.1035 355.2474 l +276.1035 355.4523 276.0826 355.653 276.07 355.8579 C +276.0867 355.8579 l +276.1244 355.7241 276.1495 355.5819 276.1954 355.4523 C +276.9062 353.3326 L +277.1612 353.3326 l +277.1612 356.485 L +f +*U +*u +280.1421 353.3326 m +279.8494 353.3326 L +279.8494 356.485 L +280.1421 356.485 L +280.1421 353.3326 l +f +*U +*u +283.5141 353.3326 m +283.2549 353.3326 L +282.6194 356.485 L +282.9205 356.485 L +283.3344 354.1897 L +283.3511 354.1102 283.3678 353.9054 283.3845 353.7632 c +283.4013 353.7632 L +283.4138 353.9054 283.4305 354.1144 283.4431 354.1897 c +283.8528 356.485 L +284.1496 356.485 L +283.5141 353.3326 l +f +*U +*u +287.6238 356.2174 m +286.9256 356.2174 L +286.9256 355.1053 L +287.6029 355.1053 L +287.6029 354.8377 L +286.9256 354.8377 L +286.9256 353.6002 L +287.6238 353.6002 L +287.6238 353.3326 L +286.6329 353.3326 L +286.6329 356.485 L +287.6238 356.485 L +287.6238 356.2174 l +f +*U +*u +290.2278 353.3326 m +290.2278 356.485 L +290.5414 356.485 L +290.9804 356.485 291.4026 356.4515 291.4026 355.6823 c +291.4026 355.2809 291.3148 354.8879 290.8089 354.8712 c +291.5072 353.3326 L +291.1978 353.3326 L +290.5288 354.8753 L +290.5205 354.8753 L +290.5205 353.3326 L +290.2278 353.3326 l +f +290.5205 355.1137 m +290.625 355.1137 L +291.0347 355.1137 291.1016 355.2558 291.1016 355.6697 c +291.1016 356.1672 290.9511 356.2174 290.579 356.2174 c +290.5205 356.2174 L +290.5205 355.1137 l +f +*U +*u +295.0981 355.9875 m +294.9727 356.1296 294.8347 356.2425 294.634 356.2425 c +294.3414 356.2425 294.1783 356 294.1783 355.7324 c +294.1783 355.3645 294.4459 355.1931 294.7176 355.0091 c +294.9852 354.821 295.2528 354.6203 295.2528 354.1855 c +295.2528 353.7256 294.9559 353.2908 294.4626 353.2908 c +294.287 353.2908 294.1072 353.341 293.9651 353.4497 c +293.9651 353.8301 L +294.0989 353.688 294.2745 353.5751 294.4751 353.5751 c +294.7845 353.5751 294.9559 353.8468 294.9518 354.1311 c +294.9559 354.4991 294.6842 354.6621 294.4166 354.8503 c +294.149 355.0342 293.8773 355.2391 293.8773 355.6906 c +293.8773 356.1129 294.1365 356.5268 294.6006 356.5268 c +294.7887 356.5268 294.9476 356.4641 295.0981 356.3596 C +295.0981 355.9875 l +f +*U +*u +299.0865 353.3326 m +298.773 353.3326 L +298.6559 353.9806 L +297.9869 353.9806 L +297.8741 353.3326 L +297.5605 353.3326 L +298.1793 356.485 L +298.4552 356.485 L +299.0865 353.3326 l +f +298.6099 354.2357 m +298.4009 355.444 L +298.3632 355.6572 298.3465 355.8746 298.3214 356.0878 c +298.3047 356.0878 L +298.2754 355.8746 298.2545 355.6572 298.2211 355.444 c +298.0371 354.2357 L +298.6099 354.2357 l +f +*U +*u +301.8124 353.6002 m +302.4981 353.6002 L +302.4981 353.3326 L +301.5198 353.3326 L +301.5198 356.485 L +301.8124 356.485 L +301.8124 353.6002 l +f +*U +*u +309.0754 355.9875 m +308.95 356.1296 308.812 356.2425 308.6114 356.2425 c +308.3187 356.2425 308.1556 356 308.1556 355.7324 c +308.1556 355.3645 308.4232 355.1931 308.695 355.0091 c +308.9626 354.821 309.2301 354.6203 309.2301 354.1855 c +309.2301 353.7256 308.9333 353.2908 308.4399 353.2908 c +308.2643 353.2908 308.0846 353.341 307.9424 353.4497 c +307.9424 353.8301 L +308.0762 353.688 308.2518 353.5751 308.4525 353.5751 c +308.7619 353.5751 308.9333 353.8468 308.9291 354.1311 c +308.9333 354.4991 308.6615 354.6621 308.3939 354.8503 c +308.1264 355.0342 307.8546 355.2391 307.8546 355.6906 c +307.8546 356.1129 308.1138 356.5268 308.5779 356.5268 c +308.766 356.5268 308.9249 356.4641 309.0754 356.3596 C +309.0754 355.9875 l +f +*U +*u +312.9468 353.7172 m +312.8339 353.6378 312.7001 353.5751 312.558 353.5751 c +311.9977 353.5751 311.9977 354.5492 311.9977 354.9172 c +311.9977 355.5025 312.0688 356.2425 312.5789 356.2425 c +312.7252 356.2425 312.8297 356.184 312.9468 356.1045 C +312.9468 356.4265 l +312.8506 356.4975 312.6918 356.5268 312.5747 356.5268 c +311.7134 356.5268 311.6967 355.306 311.6967 354.7959 c +311.6967 354.2566 311.8054 353.2908 312.5454 353.2908 c +312.6834 353.2908 312.8381 353.3451 312.9468 353.4204 c +312.9468 353.7172 L +f +*U +*u +315.5053 353.3326 m +315.5053 356.485 L +315.8188 356.485 L +316.2578 356.485 316.6801 356.4515 316.6801 355.6823 c +316.6801 355.2809 316.5923 354.8879 316.0864 354.8712 c +316.7846 353.3326 L +316.4752 353.3326 L +315.8063 354.8753 L +315.7979 354.8753 L +315.7979 353.3326 L +315.5053 353.3326 l +f +315.7979 355.1137 m +315.9025 355.1137 L +316.3122 355.1137 316.3791 355.2558 316.3791 355.6697 c +316.3791 356.1672 316.2286 356.2174 315.8565 356.2174 c +315.7979 356.2174 L +315.7979 355.1137 l +f +*U +*u +319.5728 353.3326 m +319.2802 353.3326 L +319.2802 356.485 L +319.5728 356.485 L +319.5728 353.3326 l +f +*U +*u +322.2551 353.3326 m +322.2551 356.485 L +322.5812 356.485 L +323.0327 356.485 323.4341 356.4432 323.4341 355.6655 c +323.4341 355.0551 323.2209 354.8419 322.623 354.8419 c +322.5477 354.8419 L +322.5477 353.3326 L +322.2551 353.3326 l +f +322.5477 355.1095 m +322.6606 355.1095 L +323.0703 355.1095 323.1205 355.26 323.1331 355.6655 c +323.1331 356.1004 323.016 356.2174 322.6063 356.2174 c +322.5477 356.2174 L +322.5477 355.1095 l +f +*U +*u +326.9539 356.485 m +325.7164 356.485 L +325.7164 356.2174 L +326.1888 356.2174 L +326.1888 353.3326 L +326.4815 353.3326 L +326.4815 356.2174 L +326.9539 356.2174 l +326.9539 356.485 L +f +*U +*u +329.7077 353.3326 m +329.4151 353.3326 L +329.4151 356.485 L +329.7077 356.485 L +329.7077 353.3326 l +f +*U +*u +333.7028 353.3326 m +333.4477 353.3326 L +332.737 355.4523 L +332.691 355.5819 332.6659 355.7241 332.6283 355.8579 c +332.6116 355.8579 L +332.6241 355.653 332.645 355.4523 332.645 355.2474 c +332.645 353.3326 L +332.39 353.3326 L +332.39 356.485 L +332.645 356.485 L +333.3683 354.2942 L +333.4059 354.1855 333.4352 354.0768 333.4645 353.9681 c +333.477 353.9681 L +333.4686 354.1061 333.4477 354.2482 333.4477 354.3862 c +333.4477 356.485 L +333.7028 356.485 L +333.7028 353.3326 l +f +*U +*u +336.9846 354.9966 m +337.7037 354.9966 L +337.7037 354.4154 L +337.7037 353.9179 337.6787 353.2908 337.0264 353.2908 c +336.3617 353.2908 336.299 353.989 336.299 354.9841 c +336.299 355.7283 336.3868 356.5268 337.0557 356.5268 c +337.432 356.5268 337.6201 356.276 337.6996 355.9331 c +337.4111 355.8202 L +337.3776 356.0084 337.2982 356.2425 337.0682 356.2425 c +336.6334 356.2383 336.6 355.5652 336.6 355.0091 c +336.6 353.8427 336.7463 353.5751 337.0515 353.5751 c +337.3818 353.5751 337.4111 353.8176 337.4111 354.4907 c +337.4111 354.729 L +336.9846 354.729 L +336.9846 354.9966 l +f +*U +U +U +337.6667 -3924 m +(N) * +337.6667 4716 m +(N) * +LB +%AI5_EndLayer-- +%%PageTrailer +gsave annotatepage grestore showpage +%%Trailer +Adobe_IllustratorA_AI5 /terminate get exec +Adobe_level2_AI5 /terminate get exec +%%EOF diff --git a/library/images/pwrdLogo.eps b/library/images/pwrdLogo.eps new file mode 100644 index 0000000..e11d9e9 --- /dev/null +++ b/library/images/pwrdLogo.eps @@ -0,0 +1,1897 @@ +%!PS-Adobe-3.0 EPSF-3.0 +%%Creator: Adobe Illustrator(TM) 5.5 +%%For: (Bud Northern) (Mark Anderson Design) +%%Title: (TCL PWRD LOGO.ILLUS) +%%CreationDate: (8/1/96) (4:59 PM) +%%BoundingBox: 242 302 377 513 +%%HiResBoundingBox: 242.0523 302.5199 376.3322 512.5323 +%%DocumentProcessColors: Cyan Magenta Yellow +%%DocumentSuppliedResources: procset Adobe_level2_AI5 1.0 0 +%%+ procset Adobe_IllustratorA_AI5 1.0 0 +%AI5_FileFormat 1.2 +%AI3_ColorUsage: Color +%%CMYKCustomColor: 0 0.45 1 0 (Orange) +%%+ 0 0.25 1 0 (Orange Yellow) +%%+ 0 0.79 0.91 0 (PANTONE Warm Red CV) +%%+ 0 0.79 0.91 0 (TCL RED) +%AI3_TemplateBox: 306 396 306 396 +%AI3_TileBox: 12 12 600 780 +%AI3_DocumentPreview: Macintosh_ColorPic +%AI5_ArtSize: 612 792 +%AI5_RulerUnits: 0 +%AI5_ArtFlags: 1 0 0 1 0 0 1 1 0 +%AI5_TargetResolution: 800 +%AI5_NumLayers: 1 +%AI5_OpenToView: 102 564 2 938 673 18 1 1 2 40 +%AI5_OpenViewLayers: 7 +%%EndComments +%%BeginProlog +%%BeginResource: procset Adobe_level2_AI5 1.0 0 +%%Title: (Adobe Illustrator (R) Version 5.0 Level 2 Emulation) +%%Version: 1.0 +%%CreationDate: (04/10/93) () +%%Copyright: ((C) 1987-1993 Adobe Systems Incorporated All Rights Reserved) +userdict /Adobe_level2_AI5 21 dict dup begin + put + /packedarray where not + { + userdict begin + /packedarray + { + array astore readonly + } bind def + /setpacking /pop load def + /currentpacking false def + end + 0 + } if + pop + userdict /defaultpacking currentpacking put true setpacking + /initialize + { + Adobe_level2_AI5 begin + } bind def + /terminate + { + currentdict Adobe_level2_AI5 eq + { + end + } if + } bind def + mark + /setcustomcolor where not + { + /findcmykcustomcolor + { + 5 packedarray + } bind def + /setcustomcolor + { + exch aload pop pop + 4 + { + 4 index mul 4 1 roll + } repeat + 5 -1 roll pop + setcmykcolor + } + def + } if + + /gt38? mark {version cvx exec} stopped {cleartomark true} {38 gt exch pop} ifelse def + userdict /deviceDPI 72 0 matrix defaultmatrix dtransform dup mul exch dup mul add sqrt put + userdict /level2? + systemdict /languagelevel known dup + { + pop systemdict /languagelevel get 2 ge + } if + put + level2? not + { + /setcmykcolor where not + { + /setcmykcolor + { + exch .11 mul add exch .59 mul add exch .3 mul add + 1 exch sub setgray + } def + } if + /currentcmykcolor where not + { + /currentcmykcolor + { + 0 0 0 1 currentgray sub + } def + } if + /setoverprint where not + { + /setoverprint /pop load def + } if + /selectfont where not + { + /selectfont + { + exch findfont exch + dup type /arraytype eq + { + makefont + } + { + scalefont + } ifelse + setfont + } bind def + } if + /cshow where not + { + /cshow + { + [ + 0 0 5 -1 roll aload pop + ] cvx bind forall + } bind def + } if + } if + cleartomark + /anyColor? + { + add add add 0 ne + } bind def + /testColor + { + gsave + setcmykcolor currentcmykcolor + grestore + } bind def + /testCMYKColorThrough + { + testColor anyColor? + } bind def + userdict /composite? + level2? + { + gsave 1 1 1 1 setcmykcolor currentcmykcolor grestore + add add add 4 eq + } + { + 1 0 0 0 testCMYKColorThrough + 0 1 0 0 testCMYKColorThrough + 0 0 1 0 testCMYKColorThrough + 0 0 0 1 testCMYKColorThrough + and and and + } ifelse + put + composite? not + { + userdict begin + gsave + /cyan? 1 0 0 0 testCMYKColorThrough def + /magenta? 0 1 0 0 testCMYKColorThrough def + /yellow? 0 0 1 0 testCMYKColorThrough def + /black? 0 0 0 1 testCMYKColorThrough def + grestore + /isCMYKSep? cyan? magenta? yellow? black? or or or def + /customColor? isCMYKSep? not def + end + } if + end defaultpacking setpacking +%%EndResource +%%BeginResource: procset Adobe_IllustratorA_AI5 1.1 0 +%%Title: (Adobe Illustrator (R) Version 5.0 Abbreviated Prolog) +%%Version: 1.1 +%%CreationDate: (3/7/1994) () +%%Copyright: ((C) 1987-1994 Adobe Systems Incorporated All Rights Reserved) +currentpacking true setpacking +userdict /Adobe_IllustratorA_AI5_vars 70 dict dup begin +put +/_lp /none def +/_pf +{ +} def +/_ps +{ +} def +/_psf +{ +} def +/_pss +{ +} def +/_pjsf +{ +} def +/_pjss +{ +} def +/_pola 0 def +/_doClip 0 def +/cf currentflat def +/_tm matrix def +/_renderStart +[ +/e0 /r0 /a0 /o0 /e1 /r1 /a1 /i0 +] def +/_renderEnd +[ +null null null null /i1 /i1 /i1 /i1 +] def +/_render -1 def +/_rise 0 def +/_ax 0 def +/_ay 0 def +/_cx 0 def +/_cy 0 def +/_leading +[ +0 0 +] def +/_ctm matrix def +/_mtx matrix def +/_sp 16#020 def +/_hyphen (-) def +/_fScl 0 def +/_cnt 0 def +/_hs 1 def +/_nativeEncoding 0 def +/_useNativeEncoding 0 def +/_tempEncode 0 def +/_pntr 0 def +/_tDict 2 dict def +/_wv 0 def +/Tx +{ +} def +/Tj +{ +} def +/CRender +{ +} def +/_AI3_savepage +{ +} def +/_gf null def +/_cf 4 array def +/_if null def +/_of false def +/_fc +{ +} def +/_gs null def +/_cs 4 array def +/_is null def +/_os false def +/_sc +{ +} def +/discardSave null def +/buffer 256 string def +/beginString null def +/endString null def +/endStringLength null def +/layerCnt 1 def +/layerCount 1 def +/perCent (%) 0 get def +/perCentSeen? false def +/newBuff null def +/newBuffButFirst null def +/newBuffLast null def +/clipForward? false def +end +userdict /Adobe_IllustratorA_AI5 74 dict dup begin +put +/initialize +{ + Adobe_IllustratorA_AI5 dup begin + Adobe_IllustratorA_AI5_vars begin + discardDict + { + bind pop pop + } forall + dup /nc get begin + { + dup xcheck 1 index type /operatortype ne and + { + bind + } if + pop pop + } forall + end + newpath +} def +/terminate +{ + end + end +} def +/_ +null def +/ddef +{ + Adobe_IllustratorA_AI5_vars 3 1 roll put +} def +/xput +{ + dup load dup length exch maxlength eq + { + dup dup load dup + length 2 mul dict copy def + } if + load begin + def + end +} def +/npop +{ + { + pop + } repeat +} def +/sw +{ + dup length exch stringwidth + exch 5 -1 roll 3 index mul add + 4 1 roll 3 1 roll mul add +} def +/swj +{ + dup 4 1 roll + dup length exch stringwidth + exch 5 -1 roll 3 index mul add + 4 1 roll 3 1 roll mul add + 6 2 roll /_cnt 0 ddef + { + 1 index eq + { + /_cnt _cnt 1 add ddef + } if + } forall + pop + exch _cnt mul exch _cnt mul 2 index add 4 1 roll 2 index add 4 1 roll pop pop +} def +/ss +{ + 4 1 roll + { + 2 npop + (0) exch 2 copy 0 exch put pop + gsave + false charpath currentpoint + 4 index setmatrix + stroke + grestore + moveto + 2 copy rmoveto + } exch cshow + 3 npop +} def +/jss +{ + 4 1 roll + { + 2 npop + (0) exch 2 copy 0 exch put + gsave + _sp eq + { + exch 6 index 6 index 6 index 5 -1 roll widthshow + currentpoint + } + { + false charpath currentpoint + 4 index setmatrix stroke + } ifelse + grestore + moveto + 2 copy rmoveto + } exch cshow + 6 npop +} def +/sp +{ + { + 2 npop (0) exch + 2 copy 0 exch put pop + false charpath + 2 copy rmoveto + } exch cshow + 2 npop +} def +/jsp +{ + { + 2 npop + (0) exch 2 copy 0 exch put + _sp eq + { + exch 5 index 5 index 5 index 5 -1 roll widthshow + } + { + false charpath + } ifelse + 2 copy rmoveto + } exch cshow + 5 npop +} def +/pl +{ + transform + 0.25 sub round 0.25 add exch + 0.25 sub round 0.25 add exch + itransform +} def +/setstrokeadjust where +{ + pop true setstrokeadjust + /c + { + curveto + } def + /C + /c load def + /v + { + currentpoint 6 2 roll curveto + } def + /V + /v load def + /y + { + 2 copy curveto + } def + /Y + /y load def + /l + { + lineto + } def + /L + /l load def + /m + { + moveto + } def +} +{ + /c + { + pl curveto + } def + /C + /c load def + /v + { + currentpoint 6 2 roll pl curveto + } def + /V + /v load def + /y + { + pl 2 copy curveto + } def + /Y + /y load def + /l + { + pl lineto + } def + /L + /l load def + /m + { + pl moveto + } def +} ifelse +/d +{ + setdash +} def +/cf +{ +} def +/i +{ + dup 0 eq + { + pop cf + } if + setflat +} def +/j +{ + setlinejoin +} def +/J +{ + setlinecap +} def +/M +{ + setmiterlimit +} def +/w +{ + setlinewidth +} def +/H +{ +} def +/h +{ + closepath +} def +/N +{ + _pola 0 eq + { + _doClip 1 eq + { + clip /_doClip 0 ddef + } if + newpath + } + { + /CRender + { + N + } ddef + } ifelse +} def +/n +{ + N +} def +/F +{ + _pola 0 eq + { + _doClip 1 eq + { + gsave _pf grestore clip newpath /_lp /none ddef _fc + /_doClip 0 ddef + } + { + _pf + } ifelse + } + { + /CRender + { + F + } ddef + } ifelse +} def +/f +{ + closepath + F +} def +/S +{ + _pola 0 eq + { + _doClip 1 eq + { + gsave _ps grestore clip newpath /_lp /none ddef _sc + /_doClip 0 ddef + } + { + _ps + } ifelse + } + { + /CRender + { + S + } ddef + } ifelse +} def +/s +{ + closepath + S +} def +/B +{ + _pola 0 eq + { + _doClip 1 eq + gsave F grestore + { + gsave S grestore clip newpath /_lp /none ddef _sc + /_doClip 0 ddef + } + { + S + } ifelse + } + { + /CRender + { + B + } ddef + } ifelse +} def +/b +{ + closepath + B +} def +/W +{ + /_doClip 1 ddef +} def +/* +{ + count 0 ne + { + dup type /stringtype eq + { + pop + } if + } if + newpath +} def +/u +{ +} def +/U +{ +} def +/q +{ + _pola 0 eq + { + gsave + } if +} def +/Q +{ + _pola 0 eq + { + grestore + } if +} def +/*u +{ + _pola 1 add /_pola exch ddef +} def +/*U +{ + _pola 1 sub /_pola exch ddef + _pola 0 eq + { + CRender + } if +} def +/D +{ + pop +} def +/*w +{ +} def +/*W +{ +} def +/` +{ + /_i save ddef + clipForward? + { + nulldevice + } if + 6 1 roll 4 npop + concat pop + userdict begin + /showpage + { + } def + 0 setgray + 0 setlinecap + 1 setlinewidth + 0 setlinejoin + 10 setmiterlimit + [] 0 setdash + /setstrokeadjust where {pop false setstrokeadjust} if + newpath + 0 setgray + false setoverprint +} def +/~ +{ + end + _i restore +} def +/O +{ + 0 ne + /_of exch ddef + /_lp /none ddef +} def +/R +{ + 0 ne + /_os exch ddef + /_lp /none ddef +} def +/g +{ + /_gf exch ddef + /_fc + { + _lp /fill ne + { + _of setoverprint + _gf setgray + /_lp /fill ddef + } if + } ddef + /_pf + { + _fc + fill + } ddef + /_psf + { + _fc + ashow + } ddef + /_pjsf + { + _fc + awidthshow + } ddef + /_lp /none ddef +} def +/G +{ + /_gs exch ddef + /_sc + { + _lp /stroke ne + { + _os setoverprint + _gs setgray + /_lp /stroke ddef + } if + } ddef + /_ps + { + _sc + stroke + } ddef + /_pss + { + _sc + ss + } ddef + /_pjss + { + _sc + jss + } ddef + /_lp /none ddef +} def +/k +{ + _cf astore pop + /_fc + { + _lp /fill ne + { + _of setoverprint + _cf aload pop setcmykcolor + /_lp /fill ddef + } if + } ddef + /_pf + { + _fc + fill + } ddef + /_psf + { + _fc + ashow + } ddef + /_pjsf + { + _fc + awidthshow + } ddef + /_lp /none ddef +} def +/K +{ + _cs astore pop + /_sc + { + _lp /stroke ne + { + _os setoverprint + _cs aload pop setcmykcolor + /_lp /stroke ddef + } if + } ddef + /_ps + { + _sc + stroke + } ddef + /_pss + { + _sc + ss + } ddef + /_pjss + { + _sc + jss + } ddef + /_lp /none ddef +} def +/x +{ + /_gf exch ddef + findcmykcustomcolor + /_if exch ddef + /_fc + { + _lp /fill ne + { + _of setoverprint + _if _gf 1 exch sub setcustomcolor + /_lp /fill ddef + } if + } ddef + /_pf + { + _fc + fill + } ddef + /_psf + { + _fc + ashow + } ddef + /_pjsf + { + _fc + awidthshow + } ddef + /_lp /none ddef +} def +/X +{ + /_gs exch ddef + findcmykcustomcolor + /_is exch ddef + /_sc + { + _lp /stroke ne + { + _os setoverprint + _is _gs 1 exch sub setcustomcolor + /_lp /stroke ddef + } if + } ddef + /_ps + { + _sc + stroke + } ddef + /_pss + { + _sc + ss + } ddef + /_pjss + { + _sc + jss + } ddef + /_lp /none ddef +} def +/A +{ + pop +} def +/annotatepage +{ +userdict /annotatepage 2 copy known {get exec} {pop pop} ifelse +} def +/discard +{ + save /discardSave exch store + discardDict begin + /endString exch store + gt38? + { + 2 add + } if + load + stopped + pop + end + discardSave restore +} bind def +userdict /discardDict 7 dict dup begin +put +/pre38Initialize +{ + /endStringLength endString length store + /newBuff buffer 0 endStringLength getinterval store + /newBuffButFirst newBuff 1 endStringLength 1 sub getinterval store + /newBuffLast newBuff endStringLength 1 sub 1 getinterval store +} def +/shiftBuffer +{ + newBuff 0 newBuffButFirst putinterval + newBuffLast 0 + currentfile read not + { + stop + } if + put +} def +0 +{ + pre38Initialize + mark + currentfile newBuff readstring exch pop + { + { + newBuff endString eq + { + cleartomark stop + } if + shiftBuffer + } loop + } + { + stop + } ifelse +} def +1 +{ + pre38Initialize + /beginString exch store + mark + currentfile newBuff readstring exch pop + { + { + newBuff beginString eq + { + /layerCount dup load 1 add store + } + { + newBuff endString eq + { + /layerCount dup load 1 sub store + layerCount 0 eq + { + cleartomark stop + } if + } if + } ifelse + shiftBuffer + } loop + } + { + stop + } ifelse +} def +2 +{ + mark + { + currentfile buffer readline not + { + stop + } if + endString eq + { + cleartomark stop + } if + } loop +} def +3 +{ + /beginString exch store + /layerCnt 1 store + mark + { + currentfile buffer readline not + { + stop + } if + dup beginString eq + { + pop /layerCnt dup load 1 add store + } + { + endString eq + { + layerCnt 1 eq + { + cleartomark stop + } + { + /layerCnt dup load 1 sub store + } ifelse + } if + } ifelse + } loop +} def +end +userdict /clipRenderOff 15 dict dup begin +put +{ + /n /N /s /S /f /F /b /B +} +{ + { + _doClip 1 eq + { + /_doClip 0 ddef clip + } if + newpath + } def +} forall +/Tr /pop load def +/Bb {} def +/BB /pop load def +/Bg {12 npop} def +/Bm {6 npop} def +/Bc /Bm load def +/Bh {4 npop} def +end +/Lb +{ + 4 npop + 6 1 roll + pop + 4 1 roll + pop pop pop + 0 eq + { + 0 eq + { + (%AI5_BeginLayer) 1 (%AI5_EndLayer--) discard + } + { + /clipForward? true def + + /Tx /pop load def + /Tj /pop load def + currentdict end clipRenderOff begin begin + } ifelse + } + { + 0 eq + { + save /discardSave exch store + } if + } ifelse +} bind def +/LB +{ + discardSave dup null ne + { + restore + } + { + pop + clipForward? + { + currentdict + end + end + begin + + /clipForward? false ddef + } if + } ifelse +} bind def +/Pb +{ + pop pop + 0 (%AI5_EndPalette) discard +} bind def +/Np +{ + 0 (%AI5_End_NonPrinting--) discard +} bind def +/Ln /pop load def +/Ap +/pop load def +/Ar +{ + 72 exch div + 0 dtransform dup mul exch dup mul add sqrt + dup 1 lt + { + pop 1 + } if + setflat +} def +/Mb +{ + q +} def +/Md +{ +} def +/MB +{ + Q +} def +/nc 3 dict def +nc begin +/setgray +{ + pop +} bind def +/setcmykcolor +{ + 4 npop +} bind def +/setcustomcolor +{ + 2 npop +} bind def +currentdict readonly pop +end +currentdict readonly pop +end +setpacking +%%EndResource +%%EndProlog +%%BeginSetup +Adobe_level2_AI5 /initialize get exec +Adobe_IllustratorA_AI5 /initialize get exec +%AI5_Begin_NonPrinting +Np +%AI3_BeginPattern: (Yellow Stripe) +(Yellow Stripe) 8.4499 4.6 80.4499 76.6 [ +%AI3_Tile +(0 O 0 R 0 0.4 1 0 k 0 0.4 1 0 K) @ +( +800 Ar +0 J 0 j 3.6 w 4 M []0 d +%AI3_Note: +0 D +8.1999 8.1999 m +80.6999 8.1999 L +S +8.1999 22.6 m +80.6999 22.6 L +S +8.1999 37.0001 m +80.6999 37.0001 L +S +8.1999 51.3999 m +80.6999 51.3999 L +S +8.1999 65.8 m +80.6999 65.8 L +S +8.1999 15.3999 m +80.6999 15.3999 L +S +8.1999 29.8 m +80.6999 29.8 L +S +8.1999 44.1999 m +80.6999 44.1999 L +S +8.1999 58.6 m +80.6999 58.6 L +S +8.1999 73.0001 m +80.6999 73.0001 L +S +) & +] E +%AI3_EndPattern +%AI5_End_NonPrinting-- +%AI5_Begin_NonPrinting +Np +3 Bn +%AI5_BeginGradient: (Black & White) +(Black & White) 0 2 Bd +[ +< +FFFEFDFCFBFAF9F8F7F6F5F4F3F2F1F0EFEEEDECEBEAE9E8E7E6E5E4E3E2E1E0DFDEDDDCDBDAD9D8 +D7D6D5D4D3D2D1D0CFCECDCCCBCAC9C8C7C6C5C4C3C2C1C0BFBEBDBCBBBAB9B8B7B6B5B4B3B2B1B0 +AFAEADACABAAA9A8A7A6A5A4A3A2A1A09F9E9D9C9B9A999897969594939291908F8E8D8C8B8A8988 +87868584838281807F7E7D7C7B7A797877767574737271706F6E6D6C6B6A69686766656463626160 +5F5E5D5C5B5A595857565554535251504F4E4D4C4B4A494847464544434241403F3E3D3C3B3A3938 +37363534333231302F2E2D2C2B2A292827262524232221201F1E1D1C1B1A19181716151413121110 +0F0E0D0C0B0A09080706050403020100 +> +0 %_Br +[ +0 0 50 100 %_Bs +1 0 50 0 %_Bs +BD +%AI5_EndGradient +%AI5_BeginGradient: (Red & Yellow) +(Red & Yellow) 0 2 Bd +[ +0 +< +000102030405060708090A0B0C0D0E0F101112131415161718191A1B1C1D1E1F2021222324252627 +28292A2B2C2D2E2F303132333435363738393A3B3C3D3E3F404142434445464748494A4B4C4D4E4F +505152535455565758595A5B5C5D5E5F606162636465666768696A6B6C6D6E6F7071727374757677 +78797A7B7C7D7E7F808182838485868788898A8B8C8D8E8F909192939495969798999A9B9C9D9E9F +A0A1A2A3A4A5A6A7A8A9AAABACADAEAFB0B1B2B3B4B5B6B7B8B9BABBBCBDBEBFC0C1C2C3C4C5C6C7 +C8C9CACBCCCDCECFD0D1D2D3D4D5D6D7D8D9DADBDCDDDEDFE0E1E2E3E4E5E6E7E8E9EAEBECEDEEEF +F0F1F2F3F4F5F6F7F8F9FAFBFCFDFEFF +> +< +FFFFFEFEFDFDFDFCFCFBFBFBFAFAF9F9F9F8F8F7F7F7F6F6F5F5F5F4F4F3F3F3F2F2F1F1F1F0F0EF +EFEFEEEEEDEDEDECECEBEBEBEAEAE9E9E9E8E8E7E7E7E6E6E5E5E5E4E4E3E3E3E2E2E1E1E1E0E0DF +DFDFDEDEDDDDDDDCDCDBDBDBDADAD9D9D9D8D8D7D7D7D6D6D5D5D5D4D4D3D3D3D2D2D1D1D1D0D0CF +CFCFCECECDCDCDCCCCCBCBCBCACAC9C9C9C8C8C7C7C7C6C6C5C5C5C4C4C3C3C3C2C2C1C1C1C0C0BF +BFBFBEBEBDBDBDBCBCBBBBBBBABAB9B9B9B8B8B7B7B7B6B6B5B5B5B4B4B3B3B3B2B2B1B1B1B0B0AF +AFAFAEAEADADADACACABABABAAAAA9A9A9A8A8A7A7A7A6A6A5A5A5A4A4A3A3A3A2A2A1A1A1A0A09F +9F9F9E9E9D9D9D9C9C9B9B9B9A9A9999 +> +0 +1 %_Br +[ +0 1 0.6 0 1 50 100 %_Bs +0 0 1 0 1 50 0 %_Bs +BD +%AI5_EndGradient +%AI5_BeginGradient: (Yellow & Blue Radial) +(Yellow & Blue Radial) 1 2 Bd +[ +< +000102030405060708090A0B0C0D0E0F101112131415161718191A1B1C1D1E1F2021222324252627 +28292A2B2C2D2E2F303132333435363738393A3B3C3D3E3F404142434445464748494A4B4C4D4E4F +505152535455565758595A5B5C5D5E5F606162636465666768696A6B6C6D6E6F7071727374757677 +78797A7B7C7D7E7F808182838485868788898A8B8C8D8E8F909192939495969798999A9B9C9D9E9F +A0A1A2A3A4A5A6A7A8A9AAABACADAEAFB0B1B2B3B4B5B6B7B8B9BABBBCBDBEBFC0C1C2C3C4C5C6C7 +C8C9CACBCCCDCECFD0D1D2D3D4D5D6D7D8D9DADBDCDDDEDFE0E1E2E3E4E5E6E7E8E9EAEBECEDEEEF +F0F1F2F3F4F5F6F7F8F9FAFBFCFDFEFF +> +< +1415161718191A1B1C1D1E1F1F202122232425262728292A2A2B2C2D2E2F30313233343536363738 +393A3B3C3D3E3F40414142434445464748494A4B4C4D4D4E4F50515253545556575858595A5B5C5D +5E5F60616263646465666768696A6B6C6D6E6F6F707172737475767778797A7B7B7C7D7E7F808182 +83848586868788898A8B8C8D8E8F90919292939495969798999A9B9C9D9D9E9FA0A1A2A3A4A5A6A7 +A8A9A9AAABACADAEAFB0B1B2B3B4B4B5B6B7B8B9BABBBCBDBEBFC0C0C1C2C3C4C5C6C7C8C9CACBCB +CCCDCECFD0D1D2D3D4D5D6D7D7D8D9DADBDCDDDEDFE0E1E2E2E3E4E5E6E7E8E9EAEBECEDEEEEEFF0 +F1F2F3F4F5F6F7F8F9F9FAFBFCFDFEFF +> +< +ABAAAAA9A8A7A7A6A5A5A4A3A3A2A1A1A09F9F9E9D9D9C9B9B9A9999989797969595949393929191 +908F8F8E8D8D8C8B8B8A8989888787868585848383828181807F7F7E7D7D7C7B7B7A797978777776 +7575747373727171706F6F6E6D6D6C6B6B6A6969686767666565646362626160605F5E5E5D5C5C5B +5A5A5958585756565554545352525150504F4E4E4D4C4C4B4A4A4948484746464544444342424140 +403F3E3E3D3C3C3B3A3A3938383736363534343332323130302F2E2E2D2C2C2B2A2A292828272626 +25242423222121201F1F1E1D1D1C1B1B1A1919181717161515141313121111100F0F0E0D0D0C0B0B +0A090908070706050504030302010100 +> +0 +1 %_Br +[ +0 0.08 0.67 0 1 50 14 %_Bs +1 1 0 0 1 50 100 %_Bs +BD +%AI5_EndGradient +%AI5_End_NonPrinting-- +%AI5_BeginPalette +144 161 Pb +Pn +Pc +1 g +Pc +0 g +Pc +0 0 0 0 k +Pc +0.75 g +Pc +0.5 g +Pc +0.25 g +Pc +0 g +Pc +Bb +2 (Black & White) -4014 4716 0 0 1 0 0 1 0 0 Bg +0 BB +Pc +0.25 0 0 0 k +Pc +0.5 0 0 0 k +Pc +0.75 0 0 0 k +Pc +1 0 0 0 k +Pc +0.25 0.25 0 0 k +Pc +0.5 0.5 0 0 k +Pc +0.75 0.75 0 0 k +Pc +1 1 0 0 k +Pc +Bb +2 (Red & Yellow) -4014 4716 0 0 1 0 0 1 0 0 Bg +0 BB +Pc +0 0.25 0 0 k +Pc +0 0.5 0 0 k +Pc +0 0.75 0 0 k +Pc +0 1 0 0 k +Pc +0 0.25 0.25 0 k +Pc +0 0.5 0.5 0 k +Pc +0 0.75 0.75 0 k +Pc +0 1 1 0 k +Pc +Bb +0 0 0 0 Bh +2 (Yellow & Blue Radial) -4014 4716 0 0 1 0 0 1 0 0 Bg +0 BB +Pc +0 0 0.25 0 k +Pc +0 0 0.5 0 k +Pc +0 0 0.75 0 k +Pc +0 0 1 0 k +Pc +0.25 0 0.25 0 k +Pc +0.5 0 0.5 0 k +Pc +0.75 0 0.75 0 k +Pc +1 0 1 0 k +Pc +(Yellow Stripe) 0 0 1 1 0 0 0 0 0 [1 0 0 1 0 0] p +Pc +0.25 0.125 0 0 k +Pc +0.5 0.25 0 0 k +Pc +0.75 0.375 0 0 k +Pc +1 0.5 0 0 k +Pc +0.125 0.25 0 0 k +Pc +0.25 0.5 0 0 k +Pc +0.375 0.75 0 0 k +Pc +0.5 1 0 0 k +Pc +0.375 0.375 0.75 0 k +Pc +0 0.25 0.125 0 k +Pc +0 0.5 0.25 0 k +Pc +0 0.75 0.375 0 k +Pc +0 1 0.5 0 k +Pc +0 0.125 0.25 0 k +Pc +0 0.25 0.5 0 k +Pc +0 0.375 0.75 0 k +Pc +0 0.5 1 0 k +Pc +0 0.79 0.91 0 (PANTONE Warm Red CV) 0 x +Pc +0.125 0 0.25 0 k +Pc +0.25 0 0.5 0 k +Pc +0.375 0 0.75 0 k +Pc +0.5 0 1 0 k +Pc +0.25 0 0.125 0 k +Pc +0.5 0 0.25 0 k +Pc +0.75 0 0.375 0 k +Pc +1 0 0.5 0 k +Pc +0.5 1 0 0 k +Pc +0.25 0.125 0.125 0 k +Pc +0.5 0.25 0.25 0 k +Pc +0.75 0.375 0.375 0 k +Pc +1 0.5 0.5 0 k +Pc +0.25 0.25 0.125 0 k +Pc +0.5 0.5 0.25 0 k +Pc +0.75 0.75 0.375 0 k +Pc +1 1 0.5 0 k +Pc +0 1 0.5 0 k +Pc +0.125 0.25 0.125 0 k +Pc +0.25 0.5 0.25 0 k +Pc +0.375 0.75 0.375 0 k +Pc +0.5 1 0.5 0 k +Pc +0.125 0.25 0.25 0 k +Pc +0.25 0.5 0.5 0 k +Pc +0.375 0.75 0.75 0 k +Pc +0.5 1 1 0 k +Pc +0.75 0.75 0.375 0 k +Pc +0.125 0.125 0.25 0 k +Pc +0.25 0.25 0.5 0 k +Pc +0.375 0.375 0.75 0 k +Pc +0.5 0.5 1 0 k +Pc +0.25 0.125 0.25 0 k +Pc +0.5 0.25 0.5 0 k +Pc +0.75 0.375 0.75 0 k +Pc +1 0.5 1 0 k +Pc +0 0.79 0.91 0 (PANTONE Warm Red CV) 0 x +Pc +0 0 0 0 k +Pc +Pc +Pc +Pc +Pc +Pc +Pc +Pc +1 0.5 0.5 0 k +Pc +0 0 0 0 k +Pc +Pc +Pc +Pc +Pc +Pc +Pc +Pc +0 0.25 1 0 (Orange Yellow) 0 x +Pc +0 0 0 0 k +Pc +Pc +Pc +Pc +Pc +Pc +Pc +Pc +0 1 0.5 0 k +Pc +0 0 0 0 k +Pc +Pc +Pc +Pc +Pc +Pc +Pc +Pc +1 0 0.5 0 k +Pc +0 0 0 0 k +Pc +Pc +Pc +Pc +Pc +Pc +Pc +Pc +0 0.45 1 0 (Orange) 0 x +Pc +0 0 0 0 k +Pc +Pc +Pc +Pc +Pc +Pc +Pc +Pc +0.375 0.375 0.75 0 k +Pc +0 0 0 0 k +Pc +Pc +Pc +Pc +Pc +Pc +Pc +Pc +0 0.79 0.91 0 (PANTONE Warm Red CV) 0 x +Pc +0 0 0 0 k +Pc +Pc +Pc +Pc +Pc +Pc +Pc +Pc +1 0.65 0 0 k +Pc +0 0 0 0 k +Pc +Pc +Pc +Pc +Pc +Pc +Pc +Pc +0 0 1 0 k +Pc +PB +%AI5_EndPalette +%%EndSetup +%AI5_BeginLayer +1 1 1 1 0 0 0 79 128 255 Lb +(Layer 1) Ln +0 A +1 Ap +0 O +1 0.65 0 0 k +800 Ar +0 J 0 j 1 w 4 M []0 d +%AI3_Note: +0 D +285.0121 311.7976 m +357.5043 302.5199 L +361.6071 392.7105 L +376.3322 474.1377 L +342.6527 475.6628 L +327.6333 483.4165 L +258.8269 486.3189 L +254.4361 405.0427 L +242.0523 312.2099 L +285.0121 311.7976 L +f +0 0.79 0.91 0 k +1.25 w +295.4466 337.6172 m +368.4943 335.3343 L +363.9288 425.5026 L +370.7771 507.9667 L +337.1066 506.2547 L +321.4128 512.5323 L +252.6452 508.8228 L +256.0692 427.5002 L +252.6452 333.9077 L +295.4466 337.6172 L +f +u +0 Ap +1 0.65 0 0 k +1 w +320.532 390.6149 m +312.9017 388.534 l +317.0637 398.5921 l +321.2256 426.6854 l +316.0232 427.7258 l +322.2662 436.3965 l +330.0436 465.6249 l +316.3701 462.7557 l +323.5798 475.9563 331.2311 484.5534 v +321.2256 492.2363 l +288.9913 478.0373 297.6622 431.9088 v +290.9988 433.0755 l +297.3888 384.7188 l +291.9867 383.3315 l +297.5214 372.0383 305.2714 366.6837 v +305.9749 366.1976 295.5601 404.4882 306.6587 442.6395 c +307.6992 440.2117 l +298.855 399.5459 307.6992 366.6837 v +308.1064 365.9033 312.5286 366.4235 v +320.532 381.5106 320.532 390.6149 v +f +u +*u +1 g +263.6948 355.9856 m +265.2612 355.9856 L +265.2612 359.2513 L +265.9515 359.2513 266.6153 359.2513 267.2791 359.3575 c +267.2791 355.9856 L +269.6155 355.9856 L +269.6155 355.3749 L +267.2791 355.3749 L +267.2791 347.2505 L +267.2791 346.7726 267.2791 346.0558 268.288 346.0558 c +268.9783 346.0558 269.35 346.5337 269.7748 347.0381 c +270.1996 346.7461 L +269.6951 345.7372 268.3942 345.1265 267.3322 345.1265 c +265.4205 345.1265 265.2081 346.162 265.2081 347.4364 c +265.2081 355.3749 L +263.6948 355.3749 L +263.6948 355.9856 l +f +*U +*u +285.7796 348.7639 m +285.1689 346.8788 284.1069 345.2327 281.3457 345.1265 c +277.2304 345.1265 275.9825 348.5515 275.9825 350.3835 c +275.9825 355.1094 279.7792 356.2511 281.2926 356.2511 c +283.0184 356.2511 285.461 355.4546 285.461 353.4102 c +285.461 352.6934 285.0096 352.003 284.2662 352.003 c +283.5494 352.003 283.0184 352.481 283.0184 353.2509 c +283.0184 354.2864 283.868 354.4191 283.868 354.7112 c +283.868 355.428 282.1953 355.7201 281.6112 355.7201 c +279.0624 355.7201 278.3986 353.8616 278.3986 350.3835 c +278.3986 348.7905 278.7969 347.5691 278.9562 347.1974 c +279.3544 346.3213 280.1775 345.7637 281.5581 345.6841 c +283.098 345.6044 284.5848 346.8523 285.222 348.7639 C +285.7796 348.7639 l +f +*U +*u +291.9344 345.4717 m +291.9344 346.0823 L +293.9788 346.0823 L +293.9788 363.1542 L +291.9344 363.1542 L +291.9344 363.7648 L +293.0761 363.7648 L +294.0585 363.7648 295.0939 363.8179 296.0497 364.0038 c +296.0497 346.0823 L +298.0941 346.0823 L +298.0941 345.4717 L +291.9344 345.4717 l +f +*U +u +310.0634 446.075 m +305.3828 425.2059 306.7298 391.3708 v +307.1338 381.222 308.2436 371.8929 309.5993 363.8029 C +309.6066 363.8025 L +310.4883 356.6987 311.0781 354.1272 313.3768 345.5676 C +313.2426 340.0473 L +294.8367 398.8155 310.0634 446.075 V +f +321.3622 464.1699 m +325.5016 466.2317 331.4359 466.9819 v +337.9224 455.0924 321.9584 434.793 v +331.4821 456.0522 329.2358 462.7122 v +326.7243 464.2727 321.3622 464.1699 v +f +319.4002 428.4819 m +323.1177 427.6214 324.9024 429.0668 v +321.386 415.3445 322.3077 407.7964 v +323.2297 400.2483 316.5788 395.4159 y +322.2441 402.584 320.4635 408.4226 v +319.2289 412.4694 320.6101 422.8271 322.1681 426.1155 c +320.7131 426.3196 319.4002 428.4819 v +f +315.7246 392.3281 m +321.8677 393.0631 322.5131 396.1662 v +323.265 377.6058 314.7299 369.9571 v +321.2425 380.1152 320.2206 390.6235 v +315.7246 392.3281 l +f +298.4445 384.6023 m +296.4635 382.3836 290.5192 387.2778 v +292.4131 374.803 304.1781 369.0924 v +296.0814 375.1928 293.9 381.7824 v +296.7611 382.6245 298.4445 384.6023 v +f +296.5483 389.3335 m +288.5102 409.7356 290.2325 437.3036 v +292.1098 432.3112 298.1424 430.5604 v +295.3003 429.9794 293.6387 430.2313 v +289.4335 418.5932 296.5483 389.3335 v +f +330.3126 484.1353 m +327.3003 506.2722 308.4549 483.8853 v +293.4491 466.0592 295.2373 450.9247 296.1578 442.4811 c +296.3932 440.3206 293.366 465.0316 309.8067 481.2933 c +326.2471 497.5553 329.9609 485.0794 330.3126 484.1353 c +f +U +0 0 1 0 k +302.5528 503.0164 m +287.7656 507.2395 283.0593 458.227 v +279.4282 473.3549 288.8204 494.7509 v +298.2122 516.1468 302.5528 503.0164 y +f +284.2076 506.5994 m +276.6655 495.2557 278.3767 483.1729 v +272.6565 505.9183 284.2076 506.5994 v +f +339.7135 474.7902 m +348.6321 478.0799 335.8615 444.8834 v +342.4718 454.5848 346.6326 469.8253 v +349.303 479.6062 339.7135 474.7902 y +f +354.1382 477.3767 m +360.4435 471.669 355.9752 464.1187 v +367.1908 475.904 354.1382 477.3767 v +f +U +U +*u +1 g +258.2029 317.4593 m +256.6821 317.4593 L +256.6821 325.2598 L +258.7512 325.2598 L +260.3858 325.2598 261.4514 324.608 261.4514 322.839 c +261.4514 321.1837 260.5513 320.3767 258.9581 320.3767 c +258.2029 320.3767 L +258.2029 317.4593 l +f +1 D +258.2029 321.6389 m +258.5132 321.6389 L +259.4133 321.6389 259.8995 321.8354 259.8995 322.8493 c +259.8995 323.8528 259.3202 323.9976 258.4719 323.9976 c +258.2029 323.9976 L +258.2029 321.6389 l +f +*U +*u +0 D +269.0694 321.3699 m +269.0694 323.5528 270.6523 325.4667 272.9283 325.4667 c +275.2043 325.4667 276.7871 323.5528 276.7871 321.3699 c +276.7871 319.1353 275.2043 317.2524 272.9283 317.2524 c +270.6523 317.2524 269.0694 319.1353 269.0694 321.3699 c +f +1 D +270.6419 321.432 m +270.6419 320.2526 271.6351 318.7525 272.9283 318.7525 c +274.2215 318.7525 275.2146 320.2526 275.2146 321.432 c +275.2146 322.6941 274.2628 323.9666 272.9283 323.9666 c +271.5937 323.9666 270.6419 322.6941 270.6419 321.432 c +f +*U +*u +0 D +287.2943 319.9422 m +287.315 319.9422 L +288.8668 325.3632 L +289.7668 325.3632 L +291.3807 319.9422 L +291.4014 319.9422 L +292.9326 325.2598 L +294.5258 325.2598 L +291.8877 317.3041 L +290.7704 317.3041 L +289.2185 322.4044 L +289.1978 322.4044 L +287.7288 317.3041 L +286.6115 317.3041 L +284.1286 325.2598 L +285.7218 325.2598 L +287.2943 319.9422 l +f +*U +*u +303.7595 323.9356 m +303.7595 322.2182 L +306.1803 322.2182 L +306.1803 320.894 L +303.7595 320.894 L +303.7595 318.7835 L +306.2734 318.7835 L +306.2734 317.4593 L +302.2387 317.4593 L +302.2387 325.2598 L +306.2734 325.2598 L +306.2734 323.9356 L +303.7595 323.9356 l +f +*U +*u +319.8602 317.4593 m +318.0187 317.4593 L +316.1255 320.6043 L +316.1048 320.6043 L +316.1048 317.4593 L +314.5841 317.4593 L +314.5841 325.2598 L +316.6428 325.2598 L +318.1843 325.2598 319.2499 324.577 319.2499 322.9114 c +319.2499 321.9182 318.7015 320.925 317.6567 320.7492 C +319.8602 317.4593 l +f +1 D +316.1048 321.6699 m +316.3014 321.6699 L +317.1394 321.6699 317.7291 321.9182 317.7291 322.87 c +317.7291 323.8321 317.1187 324.0183 316.3117 324.0183 c +316.1048 324.0183 L +316.1048 321.6699 l +f +*U +*u +0 D +329.1754 323.9356 m +329.1754 322.2182 L +331.5962 322.2182 L +331.5962 320.894 L +329.1754 320.894 L +329.1754 318.7835 L +331.6894 318.7835 L +331.6894 317.4593 L +327.6546 317.4593 L +327.6546 325.2598 L +331.6894 325.2598 L +331.6894 323.9356 L +329.1754 323.9356 l +f +*U +*u +340 325.2598 m +342.1725 325.2598 L +344.4279 325.2598 345.9383 323.5735 345.9383 321.3492 c +345.9383 319.156 344.3865 317.4593 342.1622 317.4593 c +340 317.4593 L +340 325.2598 l +f +1 D +341.5208 318.7835 m +341.7691 318.7835 L +343.6416 318.7835 344.3658 319.8181 344.3658 321.3596 c +344.3658 323.0562 343.4968 323.9356 341.7691 323.9356 c +341.5208 323.9356 L +341.5208 318.7835 l +f +*U +LB +%AI5_EndLayer-- +%%PageTrailer +gsave annotatepage grestore showpage +%%Trailer +Adobe_IllustratorA_AI5 /terminate get exec +Adobe_level2_AI5 /terminate get exec +%%EOF diff --git a/library/images/pwrdLogo100.gif b/library/images/pwrdLogo100.gif Binary files differnew file mode 100644 index 0000000..d2f8cbb --- /dev/null +++ b/library/images/pwrdLogo100.gif diff --git a/library/images/pwrdLogo150.gif b/library/images/pwrdLogo150.gif Binary files differnew file mode 100644 index 0000000..89eec7c --- /dev/null +++ b/library/images/pwrdLogo150.gif diff --git a/library/images/pwrdLogo175.gif b/library/images/pwrdLogo175.gif Binary files differnew file mode 100644 index 0000000..02dcd92 --- /dev/null +++ b/library/images/pwrdLogo175.gif diff --git a/library/images/pwrdLogo200.gif b/library/images/pwrdLogo200.gif Binary files differnew file mode 100644 index 0000000..66426bf --- /dev/null +++ b/library/images/pwrdLogo200.gif diff --git a/library/images/pwrdLogo75.gif b/library/images/pwrdLogo75.gif Binary files differnew file mode 100644 index 0000000..e75925c --- /dev/null +++ b/library/images/pwrdLogo75.gif diff --git a/library/listbox.tcl b/library/listbox.tcl index 4e84b3a..b2ad4d3 100644 --- a/library/listbox.tcl +++ b/library/listbox.tcl @@ -3,7 +3,7 @@ # This file defines the default bindings for Tk listbox widgets # and provides procedures that help in implementing those bindings. # -# SCCS: @(#) listbox.tcl 1.21 97/06/10 17:13:55 +# SCCS: @(#) listbox.tcl 1.22 97/12/03 15:28:59 # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994-1995 Sun Microsystems, Inc. @@ -33,7 +33,7 @@ # makes that unnecessary. bind Listbox <1> { - if [winfo exists %W] { + if {[winfo exists %W]} { tkListboxBeginSelect %W [%W index @%x,%y] } } @@ -186,7 +186,7 @@ bind Listbox <B2-Motion> { proc tkListboxBeginSelect {w el} { global tkPriv if {[$w cget -selectmode] == "multiple"} { - if [$w selection includes $el] { + if {[$w selection includes $el]} { $w selection clear $el } else { $w selection set $el @@ -224,7 +224,7 @@ proc tkListboxMotion {w el} { } extended { set i $tkPriv(listboxPrev) - if [$w selection includes anchor] { + if {[$w selection includes anchor]} { $w selection clear $i $el $w selection set anchor $el } else { @@ -290,7 +290,7 @@ proc tkListboxBeginToggle {w el} { set tkPriv(listboxSelection) [$w curselection] set tkPriv(listboxPrev) $el $w selection anchor $el - if [$w selection includes $el] { + if {[$w selection includes $el]} { $w selection clear $el } else { $w selection set $el @@ -340,7 +340,7 @@ proc tkListboxAutoScan {w} { proc tkListboxUpDown {w amount} { global tkPriv - $w activate [expr [$w index active] + $amount] + $w activate [expr {[$w index active] + $amount}] $w see active switch [$w cget -selectmode] { browse { @@ -371,7 +371,7 @@ proc tkListboxExtendUpDown {w amount} { if {[$w cget -selectmode] != "extended"} { return } - $w activate [expr [$w index active] + $amount] + $w activate [expr {[$w index active] + $amount}] $w see active tkListboxMotion $w [$w index active] } @@ -392,7 +392,7 @@ proc tkListboxDataExtend {w el} { if {$mode == "extended"} { $w activate $el $w see $el - if [$w selection includes anchor] { + if {[$w selection includes anchor]} { tkListboxMotion $w $el } } elseif {$mode == "multiple"} { diff --git a/library/menu.tcl b/library/menu.tcl index 21b69d9..eaa694f 100644 --- a/library/menu.tcl +++ b/library/menu.tcl @@ -4,7 +4,7 @@ # It also implements keyboard traversal of menus and implements a few # other utility procedures related to menus. # -# SCCS: @(#) menu.tcl 1.103 97/10/31 15:26:08 +# SCCS: @(#) menu.tcl 1.104 97/12/03 15:28:59 # # Copyright (c) 1992-1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. @@ -218,7 +218,7 @@ proc tkMbLeave w { global tkPriv set tkPriv(inMenubutton) {} - if ![winfo exists $w] { + if {![winfo exists $w]} { return } if {[$w cget -state] == "active"} { @@ -273,29 +273,29 @@ proc tkMbPost {w {x {}} {y {}}} { # the menu just below the menubutton, as for a pull-down. update idletasks - if [catch { + if {[catch { switch [$w cget -direction] { above { set x [winfo rootx $w] - set y [expr [winfo rooty $w] - [winfo reqheight $menu]] + set y [expr {[winfo rooty $w] - [winfo reqheight $menu]}] $menu post $x $y } below { set x [winfo rootx $w] - set y [expr [winfo rooty $w] + [winfo height $w]] + set y [expr {[winfo rooty $w] + [winfo height $w]}] $menu post $x $y } left { - set x [expr [winfo rootx $w] - [winfo reqwidth $menu]] - set y [expr (2 * [winfo rooty $w] + [winfo height $w]) / 2] + set x [expr {[winfo rootx $w] - [winfo reqwidth $menu]}] + set y [expr {(2 * [winfo rooty $w] + [winfo height $w]) / 2}] set entry [tkMenuFindName $menu [$w cget -text]] - if [$w cget -indicatoron] { + if {[$w cget -indicatoron]} { if {$entry == [$menu index last]} { - incr y [expr -([$menu yposition $entry] \ - + [winfo reqheight $menu])/2] + incr y [expr {-([$menu yposition $entry] \ + + [winfo reqheight $menu])/2}] } else { - incr y [expr -([$menu yposition $entry] \ - + [$menu yposition [expr $entry+1]])/2] + incr y [expr {-([$menu yposition $entry] \ + + [$menu yposition [expr {$entry+1}]])/2}] } } $menu post $x $y @@ -305,16 +305,16 @@ proc tkMbPost {w {x {}} {y {}}} { } } right { - set x [expr [winfo rootx $w] + [winfo width $w]] - set y [expr (2 * [winfo rooty $w] + [winfo height $w]) / 2] + set x [expr {[winfo rootx $w] + [winfo width $w]}] + set y [expr {(2 * [winfo rooty $w] + [winfo height $w]) / 2}] set entry [tkMenuFindName $menu [$w cget -text]] - if [$w cget -indicatoron] { + if {[$w cget -indicatoron]} { if {$entry == [$menu index last]} { - incr y [expr -([$menu yposition $entry] \ - + [winfo reqheight $menu])/2] + incr y [expr {-([$menu yposition $entry] \ + + [winfo reqheight $menu])/2}] } else { - incr y [expr -([$menu yposition $entry] \ - + [$menu yposition [expr $entry+1]])/2] + incr y [expr {-([$menu yposition $entry] \ + + [$menu yposition [expr {$entry+1}]])/2}] } } $menu post $x $y @@ -324,18 +324,18 @@ proc tkMbPost {w {x {}} {y {}}} { } } default { - if [$w cget -indicatoron] { + if {[$w cget -indicatoron]} { if {$y == ""} { - set x [expr [winfo rootx $w] + [winfo width $w]/2] - set y [expr [winfo rooty $w] + [winfo height $w]/2] + set x [expr {[winfo rootx $w] + [winfo width $w]/2}] + set y [expr {[winfo rooty $w] + [winfo height $w]/2}] } tkPostOverPoint $menu $x $y [tkMenuFindName $menu [$w cget -text]] } else { - $menu post [winfo rootx $w] [expr [winfo rooty $w]+[winfo height $w]] + $menu post [winfo rootx $w] [expr {[winfo rooty $w]+[winfo height $w]}] } } } - } msg] { + } msg]} { # Error posting menu (e.g. bogus -postcommand). Unpost it and # reflect the error. @@ -781,7 +781,7 @@ proc tkMenuNextMenu {menu direction} { } set buttons [winfo children [winfo parent $w]] set length [llength $buttons] - set i [expr [lsearch -exact $buttons $w] + $count] + set i [expr {[lsearch -exact $buttons $w] + $count}] while 1 { while {$i < 0} { incr i $length @@ -820,13 +820,13 @@ proc tkMenuNextEntry {menu count} { if {[$menu index last] == "none"} { return } - set length [expr [$menu index last]+1] + set length [expr {[$menu index last]+1}] set quitAfter $length set active [$menu index active] if {$active == "none"} { set i 0 } else { - set i [expr $active + $count] + set i [expr {$active + $count}] } while 1 { if {$quitAfter <= 0} { @@ -1020,9 +1020,9 @@ proc tkTraverseWithinMenu {w char} { return } for {set i 0} {$i <= $last} {incr i} { - if [catch {set char2 [string index \ + if {[catch {set char2 [string index \ [$w entrycget $i -label] \ - [$w entrycget $i -underline]]}] { + [$w entrycget $i -underline]]}]} { continue } if {[string compare $char [string tolower $char2]] == 0} { @@ -1105,7 +1105,7 @@ proc tkMenuFindName {menu s} { return } for {set i 0} {$i <= $last} {incr i} { - if ![catch {$menu entrycget $i -label} label] { + if {![catch {$menu entrycget $i -label} label]} { if {$label == $s} { return $i } @@ -1131,13 +1131,13 @@ proc tkPostOverPoint {menu x y {entry {}}} { if {$entry != {}} { if {$entry == [$menu index last]} { - incr y [expr -([$menu yposition $entry] \ - + [winfo reqheight $menu])/2] + incr y [expr {-([$menu yposition $entry] \ + + [winfo reqheight $menu])/2}] } else { - incr y [expr -([$menu yposition $entry] \ - + [$menu yposition [expr $entry+1]])/2] + incr y [expr {-([$menu yposition $entry] \ + + [$menu yposition [expr {$entry+1}]])/2}] } - incr x [expr -[winfo reqwidth $menu]/2] + incr x [expr {-[winfo reqwidth $menu]/2}] } $menu post $x $y if {($entry != {}) && ([$menu entrycget $entry -state] != "disabled")} { diff --git a/library/msgbox.tcl b/library/msgbox.tcl index 07df82b..5724508 100644 --- a/library/msgbox.tcl +++ b/library/msgbox.tcl @@ -3,7 +3,7 @@ # Implements messageboxes for platforms that do not have native # messagebox support. # -# SCCS: @(#) msgbox.tcl 1.8 97/07/28 17:20:01 +# SCCS: @(#) msgbox.tcl 1.11 97/12/19 16:07:48 # # Copyright (c) 1994-1997 Sun Microsystems, Inc. # @@ -49,7 +49,7 @@ proc tkMessageBox {args} { tclParseConfigSpec $w $specs "" $args if {[lsearch {info warning error question} $data(-icon)] == -1} { - error "invalid icon \"$data(-icon)\", must be error, info, question or warning" + error "bad -icon value \"$data(-icon)\": must be error, info, question, or warning" } if {$tcl_platform(platform) == "macintosh"} { if {$data(-icon) == "error"} { @@ -61,7 +61,7 @@ proc tkMessageBox {args} { } } - if ![winfo exists $data(-parent)] { + if {![winfo exists $data(-parent)]} { error "bad window path name \"$data(-parent)\"" } @@ -107,27 +107,27 @@ proc tkMessageBox {args} { } } default { - error "invalid message box type \"$data(-type)\", must be abortretryignore, ok, okcancel, retrycancel, yesno or yesnocancel" + error "bad -type value \"$data(-type)\": must be abortretryignore, ok, okcancel, retrycancel, yesno, or yesnocancel" } } - if [string compare $data(-default) ""] { + if {[string compare $data(-default) ""]} { set valid 0 foreach btn $buttons { - if ![string compare [lindex $btn 0] $data(-default)] { + if {![string compare [lindex $btn 0] $data(-default)]} { set valid 1 break } } - if !$valid { - error "invalid default button \"$data(-default)\"" + if {!$valid} { + error "bad -default value \"$data(-default)\": must be abort, retry, ignore, ok, cancel, no, or yes" } } # 2. Set the dialog to be a child window of $parent # # - if [string compare $data(-parent) .] { + if {[string compare $data(-parent) .]} { set w $data(-parent).__tk__messagebox } else { set w .__tk__messagebox @@ -156,14 +156,17 @@ proc tkMessageBox {args} { } # 4. Fill the top part with bitmap and message (use the option - # database for -wraplength so that it can be overridden by - # the caller). + # database for -wraplength and -font so that they can be + # overridden by the caller). option add *Dialog.msg.wrapLength 3i widgetDefault - label $w.msg -justify left -text $data(-message) - catch {$w.msg configure -font \ - -Adobe-Times-Medium-R-Normal--*-180-*-*-*-*-*-* + if {$tcl_platform(platform) == "macintosh"} { + option add *Dialog.msg.font system widgetDefault + } else { + option add *Dialog.msg.font {Times 18} widgetDefault } + + label $w.msg -justify left -text $data(-message) pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m if {$data(-icon) != ""} { label $w.bitmap -bitmap $data(-icon) @@ -176,7 +179,7 @@ proc tkMessageBox {args} { foreach but $buttons { set name [lindex $but 0] set opts [lrange $but 1 end] - if ![string compare $opts {}] { + if {![string compare $opts {}]} { # Capitalize the first letter of $name set capName \ [string toupper \ @@ -186,7 +189,7 @@ proc tkMessageBox {args} { eval button $w.$name $opts -command [list "set tkPriv(button) $name"] - if ![string compare $name $data(-default)] { + if {![string compare $name $data(-default)]} { $w.$name configure -default active } pack $w.$name -in $w.bot -side left -expand 1 \ @@ -206,7 +209,7 @@ proc tkMessageBox {args} { # 6. Create a binding for <Return> on the dialog if there is a # default button. - if [string compare $data(-default) ""] { + if {[string compare $data(-default) ""]} { bind $w <Return> "tkButtonInvoke $w.$data(-default)" } @@ -216,10 +219,10 @@ proc tkMessageBox {args} { wm withdraw $w update idletasks - set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \ - - [winfo vrootx [winfo parent $w]]] - set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \ - - [winfo vrooty [winfo parent $w]]] + set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \ + - [winfo vrootx [winfo parent $w]]}] + set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 \ + - [winfo vrooty [winfo parent $w]]}] wm geom $w +$x+$y wm deiconify $w @@ -231,7 +234,7 @@ proc tkMessageBox {args} { set grabStatus [grab status $oldGrab] } grab $w - if [string compare $data(-default) ""] { + if {[string compare $data(-default) ""]} { focus $w.$data(-default) } else { focus $w diff --git a/library/optMenu.tcl b/library/optMenu.tcl index 32ca096c..2b15f91 100644 --- a/library/optMenu.tcl +++ b/library/optMenu.tcl @@ -3,7 +3,7 @@ # This file defines the procedure tk_optionMenu, which creates # an option button and its associated menu. # -# SCCS: @(#) optMenu.tcl 1.11 97/08/22 14:21:13 +# SCCS: @(#) optMenu.tcl 1.12 97/12/03 15:29:01 # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. @@ -30,7 +30,7 @@ proc tk_optionMenu {w varName firstValue args} { upvar #0 $varName var - if ![info exists var] { + if {![info exists var]} { set var $firstValue } menubutton $w -textvariable $varName -indicatoron 1 -menu $w.menu \ diff --git a/library/palette.tcl b/library/palette.tcl index 5d5318e..b6d8313 100644 --- a/library/palette.tcl +++ b/library/palette.tcl @@ -3,7 +3,7 @@ # This file contains procedures that change the color palette used # by Tk. # -# SCCS: @(#) palette.tcl 1.11 97/06/23 20:35:44 +# SCCS: @(#) palette.tcl 1.12 97/12/03 15:29:02 # # Copyright (c) 1995-1997 Sun Microsystems, Inc. # @@ -34,41 +34,41 @@ proc tk_setPalette {args} { } else { array set new $args } - if ![info exists new(background)] { + if {![info exists new(background)]} { error "must specify a background color" } - if ![info exists new(foreground)] { + if {![info exists new(foreground)]} { set new(foreground) black } set bg [winfo rgb . $new(background)] set fg [winfo rgb . $new(foreground)] - set darkerBg [format #%02x%02x%02x [expr (9*[lindex $bg 0])/2560] \ - [expr (9*[lindex $bg 1])/2560] [expr (9*[lindex $bg 2])/2560]] + set darkerBg [format #%02x%02x%02x [expr {(9*[lindex $bg 0])/2560}] \ + [expr {(9*[lindex $bg 1])/2560}] [expr {(9*[lindex $bg 2])/2560}]] foreach i {activeForeground insertBackground selectForeground \ highlightColor} { - if ![info exists new($i)] { + if {![info exists new($i)]} { set new($i) $new(foreground) } } - if ![info exists new(disabledForeground)] { + if {![info exists new(disabledForeground)]} { set new(disabledForeground) [format #%02x%02x%02x \ - [expr (3*[lindex $bg 0] + [lindex $fg 0])/1024] \ - [expr (3*[lindex $bg 1] + [lindex $fg 1])/1024] \ - [expr (3*[lindex $bg 2] + [lindex $fg 2])/1024]] + [expr {(3*[lindex $bg 0] + [lindex $fg 0])/1024}] \ + [expr {(3*[lindex $bg 1] + [lindex $fg 1])/1024}] \ + [expr {(3*[lindex $bg 2] + [lindex $fg 2])/1024}]] } - if ![info exists new(highlightBackground)] { + if {![info exists new(highlightBackground)]} { set new(highlightBackground) $new(background) } - if ![info exists new(activeBackground)] { + if {![info exists new(activeBackground)]} { # Pick a default active background that islighter than the # normal background. To do this, round each color component # up by 15% or 1/3 of the way to full white, whichever is # greater. foreach i {0 1 2} { - set light($i) [expr [lindex $bg $i]/256] - set inc1 [expr ($light($i)*15)/100] - set inc2 [expr (255-$light($i))/3] + set light($i) [expr {[lindex $bg $i]/256}] + set inc1 [expr {($light($i)*15)/100}] + set inc2 [expr {(255-$light($i))/3}] if {$inc1 > $inc2} { incr light($i) $inc1 } else { @@ -81,13 +81,13 @@ proc tk_setPalette {args} { set new(activeBackground) [format #%02x%02x%02x $light(0) \ $light(1) $light(2)] } - if ![info exists new(selectBackground)] { + if {![info exists new(selectBackground)]} { set new(selectBackground) $darkerBg } - if ![info exists new(troughColor)] { + if {![info exists new(troughColor)]} { set new(troughColor) $darkerBg } - if ![info exists new(selectColor)] { + if {![info exists new(selectColor)]} { set new(selectColor) #b03060 } @@ -188,18 +188,18 @@ proc tkRecolorTree {w colors} { proc tkDarken {color percent} { set l [winfo rgb . $color] - set red [expr [lindex $l 0]/256] - set green [expr [lindex $l 1]/256] - set blue [expr [lindex $l 2]/256] - set red [expr ($red*$percent)/100] + set red [expr {[lindex $l 0]/256}] + set green [expr {[lindex $l 1]/256}] + set blue [expr {[lindex $l 2]/256}] + set red [expr {($red*$percent)/100}] if {$red > 255} { set red 255 } - set green [expr ($green*$percent)/100] + set green [expr {($green*$percent)/100}] if {$green > 255} { set green 255 } - set blue [expr ($blue*$percent)/100] + set blue [expr {($blue*$percent)/100}] if {$blue > 255} { set blue 255 } diff --git a/library/safetk.tcl b/library/safetk.tcl index 1cabcd5..30574de 100644 --- a/library/safetk.tcl +++ b/library/safetk.tcl @@ -2,7 +2,7 @@ # # Support procs to use Tk in safe interpreters. # -# SCCS: @(#) safetk.tcl 1.8 97/10/29 14:59:16 +# SCCS: @(#) safetk.tcl 1.13 98/01/15 13:40:46 # # Copyright (c) 1997 Sun Microsystems, Inc. # @@ -13,20 +13,16 @@ # # -# Note: It is UNSAFE to let any untrusted code being executed +# Note: It is now ok to let untrusted code being executed # between the creation of the interp and the actual loading -# of Tk in that interp. -# You should "loadTk $slave" right after safe::tkInterpCreate -# Otherwise, if you are using an application with Tk -# and don't want safe slaves to have access to Tk, potentially -# in a malevolent way, you should use -# ::safe::interpCreate -nostatics -accesspath {directories...} -# where the directory list does NOT contain any Tk dynamically -# loadable library +# of Tk in that interp because the C side Tk_Init will +# now look up the master interp and ask its safe::TkInit +# for the actual parameters to use for it's initialization (if allowed), +# not relying on the slave state. # # We use opt (optional arguments parsing) -package require opt 0.1; +package require opt 0.4.1; namespace eval ::safe { @@ -35,20 +31,22 @@ namespace eval ::safe { # # tkInterpInit : prepare the slave interpreter for tk loading - # + # most of the real job is done by loadTk # returns the slave name (tkInterpInit does) # - proc ::safe::tkInterpInit {slave} { + proc ::safe::tkInterpInit {slave argv} { global env tk_library - if {[info exists env(DISPLAY)]} { - $slave eval [list set env(DISPLAY) $env(DISPLAY)]; - } + + # Clear Tk's access for that interp (path). + allowTk $slave $argv + # there seems to be an obscure case where the tk_library # variable value is changed to point to a sym link destination # dir instead of the sym link itself, and thus where the $tk_library # would then not be anymore one of the auto_path dir, so we use # the addToAccessPath which adds if it's not already in instead - # of the more conventional findInAccessPath + # of the more conventional findInAccessPath. + # Might be usefull for masters without Tk really loaded too. ::interp eval $slave [list set tk_library [::safe::interpAddToAccessPath $slave $tk_library]] return $slave; } @@ -67,23 +65,81 @@ proc ::safe::loadTk {} {} ::tcl::OptProc loadTk { {slave -interp "name of the slave interpreter"} {-use -windowId {} "window Id to use (new toplevel otherwise)"} + {-display -displayName {} "display name to use (current one otherwise)"} } { + set displayGiven [::tcl::OptProcArgGiven "-display"] + if {!$displayGiven} { + # Try to get the current display from "." + # (which might not exist if the master is tk-less) + if {[catch {set display [winfo screen .]}]} { + if {[info exists ::env(DISPLAY)]} { + set display $::env(DISPLAY) + } else { + Log $slave "no winfo screen . nor env(DISPLAY)" WARNING + set display ":0.0" + } + } + } if {![::tcl::OptProcArgGiven "-use"]} { # create a decorated toplevel - ::tcl::Lassign [tkTopLevel $slave] w use; + ::tcl::Lassign [tkTopLevel $slave $display] w use; # set our delete hook (slave arg is added by interpDelete) Set [DeleteHookName $slave] [list tkDelete {} $w]; + } else { + # Let's be nice and also accept tk window names instead of ids + if {[string match ".*" $use]} { + set windowName $use + set use [winfo id $windowName] + set nDisplay [winfo screen $windowName] + } else { + # Check for a better -display value + # (works only for multi screens on single host, but not + # cross hosts, for that a tk window name would be better + # but embeding is also usefull for non tk names) + if {![catch {winfo pathname $use} name]} { + set nDisplay [winfo screen $name] + } else { + # Can't have a better one + set nDisplay $display + } + } + if {[string compare $nDisplay $display]} { + if {$displayGiven} { + error "conflicting -display $display and -use\ + $use -> $nDisplay" + } else { + set display $nDisplay + } + } } - tkInterpInit $slave; - ::interp eval $slave [list set argv [list "-use" $use]]; - ::interp eval $slave [list set argc 2]; + + # Prepares the slave for tk with those parameters + + tkInterpInit $slave [list "-use" $use "-display" $display] + load {} Tk $slave - # Remove env(DISPLAY) if it's in there (if it has been set by - # tkInterpInit) - ::interp eval $slave {catch {unset env(DISPLAY)}} + return $slave } +proc ::safe::TkInit {interpPath} { + variable tkInit + if {[info exists tkInit($interpPath)]} { + set value $tkInit($interpPath) + Log $interpPath "TkInit called, returning \"$value\"" NOTICE + return $value + } else { + Log $interpPath "TkInit called for interp with clearance:\ + preventing Tk init" ERROR + error "not allowed" + } +} + +proc ::safe::allowTk {interpPath argv} { + variable tkInit + set tkInit($interpPath) $argv +} + proc ::safe::tkDelete {W window slave} { # we are going to be called for each widget... skip untill it's # top level @@ -99,11 +155,11 @@ proc ::safe::loadTk {} {} } } -proc ::safe::tkTopLevel {slave} { +proc ::safe::tkTopLevel {slave display} { variable tkSafeId; incr tkSafeId; set w ".safe$tkSafeId"; - if {[catch {toplevel $w -class SafeTk} msg]} { + if {[catch {toplevel $w -screen $display -class SafeTk} msg]} { return -code error "Unable to create toplevel for\ safe slave \"$slave\" ($msg)"; } diff --git a/library/scale.tcl b/library/scale.tcl index 8e96176..3da1201 100644 --- a/library/scale.tcl +++ b/library/scale.tcl @@ -3,7 +3,7 @@ # This file defines the default bindings for Tk scale widgets and provides # procedures that help in implementing the bindings. # -# SCCS: @(#) scale.tcl 1.12 96/04/16 11:42:25 +# SCCS: @(#) scale.tcl 1.13 97/12/03 15:29:03 # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994-1995 Sun Microsystems, Inc. @@ -19,7 +19,7 @@ # Standard Motif bindings: bind Scale <Enter> { - if $tk_strictMotif { + if {$tk_strictMotif} { set tkPriv(activeBg) [%W cget -activebackground] %W config -activebackground [%W cget -background] } @@ -29,7 +29,7 @@ bind Scale <Motion> { tkScaleActivate %W %x %y } bind Scale <Leave> { - if $tk_strictMotif { + if {$tk_strictMotif} { %W config -activebackground $tkPriv(activeBg) } if {[%W cget -state] == "active"} { @@ -137,8 +137,8 @@ proc tkScaleButtonDown {w x y} { set tkPriv(dragging) 1 set tkPriv(initValue) [$w get] set coords [$w coords] - set tkPriv(deltaX) [expr $x - [lindex $coords 0]] - set tkPriv(deltaY) [expr $y - [lindex $coords 1]] + set tkPriv(deltaX) [expr {$x - [lindex $coords 0]}] + set tkPriv(deltaY) [expr {$y - [lindex $coords 1]}] $w configure -sliderrelief sunken } } @@ -155,11 +155,11 @@ proc tkScaleButtonDown {w x y} { proc tkScaleDrag {w x y} { global tkPriv - if !$tkPriv(dragging) { + if {!$tkPriv(dragging)} { return } - $w set [$w get [expr $x - $tkPriv(deltaX)] \ - [expr $y - $tkPriv(deltaY)]] + $w set [$w get [expr {$x - $tkPriv(deltaX)}] \ + [expr {$y - $tkPriv(deltaY)}]] } # tkScaleEndDrag -- @@ -197,7 +197,7 @@ proc tkScaleIncrement {w dir big repeat} { if {$big == "big"} { set inc [$w cget -bigincrement] if {$inc == 0} { - set inc [expr abs([$w cget -to] - [$w cget -from])/10.0] + set inc [expr {abs([$w cget -to] - [$w cget -from])/10.0}] } if {$inc < [$w cget -resolution]} { set inc [$w cget -resolution] @@ -206,9 +206,9 @@ proc tkScaleIncrement {w dir big repeat} { set inc [$w cget -resolution] } if {([$w cget -from] > [$w cget -to]) ^ ($dir == "up")} { - set inc [expr -$inc] + set inc [expr {-$inc}] } - $w set [expr [$w get] + $inc] + $w set [expr {[$w get] + $inc}] if {$repeat == "again"} { set tkPriv(afterId) [after [$w cget -repeatinterval] \ diff --git a/library/scrlbar.tcl b/library/scrlbar.tcl index e2b04b7..9674951 100644 --- a/library/scrlbar.tcl +++ b/library/scrlbar.tcl @@ -3,7 +3,7 @@ # This file defines the default bindings for Tk scrollbar widgets. # It also provides procedures that help in implementing the bindings. # -# SCCS: @(#) scrlbar.tcl 1.26 96/11/30 17:19:16 +# SCCS: @(#) scrlbar.tcl 1.27 97/12/03 15:29:03 # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. @@ -20,7 +20,7 @@ if {($tcl_platform(platform) != "windows") && ($tcl_platform(platform) != "macintosh")} { bind Scrollbar <Enter> { - if $tk_strictMotif { + if {$tk_strictMotif} { set tkPriv(activeBg) [%W cget -activebackground] %W config -activebackground [%W cget -background] } @@ -231,8 +231,8 @@ proc tkScrollStartDrag {w x y} { if {$iv0 == 0} { set tkPriv(initPos) 0.0 } else { - set tkPriv(initPos) [expr (double([lindex $tkPriv(initValues) 2])) \ - / [lindex $tkPriv(initValues) 0]] + set tkPriv(initPos) [expr {(double([lindex $tkPriv(initValues) 2])) \ + / [lindex $tkPriv(initValues) 0]}] } } } @@ -253,19 +253,19 @@ proc tkScrollDrag {w x y} { if {$tkPriv(initPos) == ""} { return } - set delta [$w delta [expr $x - $tkPriv(pressX)] [expr $y - $tkPriv(pressY)]] - if [$w cget -jump] { + set delta [$w delta [expr {$x - $tkPriv(pressX)}] [expr {$y - $tkPriv(pressY)}]] + if {[$w cget -jump]} { if {[llength $tkPriv(initValues)] == 2} { - $w set [expr [lindex $tkPriv(initValues) 0] + $delta] \ - [expr [lindex $tkPriv(initValues) 1] + $delta] + $w set [expr {[lindex $tkPriv(initValues) 0] + $delta}] \ + [expr {[lindex $tkPriv(initValues) 1] + $delta}] } else { - set delta [expr round($delta * [lindex $tkPriv(initValues) 0])] + set delta [expr {round($delta * [lindex $tkPriv(initValues) 0])}] eval $w set [lreplace $tkPriv(initValues) 2 3 \ - [expr [lindex $tkPriv(initValues) 2] + $delta] \ - [expr [lindex $tkPriv(initValues) 3] + $delta]] + [expr {[lindex $tkPriv(initValues) 2] + $delta}] \ + [expr {[lindex $tkPriv(initValues) 3] + $delta}]] } } else { - tkScrollToPos $w [expr $tkPriv(initPos) + $delta] + tkScrollToPos $w [expr {$tkPriv(initPos) + $delta}] } } @@ -283,10 +283,10 @@ proc tkScrollEndDrag {w x y} { if {$tkPriv(initPos) == ""} { return } - if [$w cget -jump] { - set delta [$w delta [expr $x - $tkPriv(pressX)] \ - [expr $y - $tkPriv(pressY)]] - tkScrollToPos $w [expr $tkPriv(initPos) + $delta] + if {[$w cget -jump]} { + set delta [$w delta [expr {$x - $tkPriv(pressX)}] \ + [expr {$y - $tkPriv(pressY)}]] + tkScrollToPos $w [expr {$tkPriv(initPos) + $delta}] } set tkPriv(initPos) "" } @@ -375,9 +375,9 @@ proc tkScrollToPos {w pos} { proc tkScrollTopBottom {w x y} { global tkPriv set element [$w identify $x $y] - if [string match *1 $element] { + if {[string match *1 $element]} { tkScrollToPos $w 0 - } elseif [string match *2 $element] { + } elseif {[string match *2 $element]} { tkScrollToPos $w 1 } diff --git a/library/tclIndex b/library/tclIndex index e65708e..e2cf7f1 100644 --- a/library/tclIndex +++ b/library/tclIndex @@ -72,6 +72,7 @@ set auto_index(tkPostOverPoint) [list source [file join $dir menu.tcl]] set auto_index(tkSaveGrabInfo) [list source [file join $dir menu.tcl]] set auto_index(tkRestoreOldGrab) [list source [file join $dir menu.tcl]] set auto_index(tk_menuSetFocus) [list source [file join $dir menu.tcl]] +set auto_index(tkGenerateMenuSelect) [list source [file join $dir menu.tcl]] set auto_index(tk_popup) [list source [file join $dir menu.tcl]] set auto_index(tkScrollButtonDown) [list source [file join $dir scrlbar.tcl]] set auto_index(tkScrollButtonUp) [list source [file join $dir scrlbar.tcl]] @@ -172,6 +173,8 @@ set auto_index(tkFocusGroup_In) [list source [file join $dir comdlg.tcl]] set auto_index(tkFocusGroup_Out) [list source [file join $dir comdlg.tcl]] set auto_index(tkFDGetFileTypes) [list source [file join $dir comdlg.tcl]] set auto_index(::safe::loadTk) [list source [file join $dir safetk.tcl]] +set auto_index(::safe::TkInit) [list source [file join $dir safetk.tcl]] +set auto_index(::safe::allowTk) [list source [file join $dir safetk.tcl]] set auto_index(::safe::tkTopLevel) [list source [file join $dir safetk.tcl]] set auto_index(tkMessageBox) [list source [file join $dir msgbox.tcl]] set auto_index(tkIconList) [list source [file join $dir tkfbox.tcl]] diff --git a/library/tearoff.tcl b/library/tearoff.tcl index 7cbe8e7..2b318c6 100644 --- a/library/tearoff.tcl +++ b/library/tearoff.tcl @@ -2,7 +2,7 @@ # # This file contains procedures that implement tear-off menus. # -# SCCS: @(#) tearoff.tcl 1.20 97/08/21 14:49:27 +# SCCS: @(#) tearoff.tcl 1.22 98/01/16 15:21:49 # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. @@ -49,7 +49,7 @@ proc tkTearOffMenu {w {x 0} {y 0}} { } for {set i 1} 1 {incr i} { set menu $parent.tearoff$i - if ![winfo exists $menu] { + if {![winfo exists $menu]} { break } } @@ -134,12 +134,34 @@ proc tkMenuDup {src dst type} { # Duplicate the binding tags and bindings from the source menu. - regsub -all . $src {\\&} quotedSrc - regsub -all . $dst {\\&} quotedDst - regsub -all $quotedSrc [bindtags $src] $dst x + set tags [bindtags $src] + set srcLen [string length $src] + + # Copy tags to x, replacing each substring of src with dst. + + while {[set index [string first $src $tags]] != -1} { + append x [string range $tags 0 [expr $index - 1]] + append x $dst + set tags [string range $tags [expr $index + $srcLen] end] + } + append x $tags + bindtags $dst $x + foreach event [bind $src] { - regsub -all $quotedSrc [bind $src $event] $dst x + unset x + set script [bind $src $event] + set eventLen [string length $event] + + # Copy script to x, replacing each substring of event with dst. + + while {[set index [string first $event $script]] != -1} { + append x [string range $script 0 [expr $index - 1]] + append x $dst + set script [string range $script [expr $index + $eventLen] end] + } + append x $script + bind $dst $event $x } } diff --git a/library/text.tcl b/library/text.tcl index 891a9ed..d07544e 100644 --- a/library/text.tcl +++ b/library/text.tcl @@ -3,7 +3,7 @@ # This file defines the default bindings for Tk text widgets and provides # procedures that help in implementing the bindings. # -# SCCS: @(#) text.tcl 1.58 97/09/17 18:54:56 +# SCCS: @(#) text.tcl 1.59 97/12/03 15:29:05 # # Copyright (c) 1992-1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. @@ -216,7 +216,7 @@ bind Text <Delete> { bind Text <BackSpace> { if {[%W tag nextrange sel 1.0 end] != ""} { %W delete sel.first sel.last - } elseif [%W compare insert != 1.0] { + } elseif {[%W compare insert != 1.0]} { %W delete insert-1c %W see insert } @@ -278,33 +278,33 @@ if {$tcl_platform(platform) == "macintosh"} { # Additional emacs-like bindings: bind Text <Control-a> { - if !$tk_strictMotif { + if {!$tk_strictMotif} { tkTextSetCursor %W {insert linestart} } } bind Text <Control-b> { - if !$tk_strictMotif { + if {!$tk_strictMotif} { tkTextSetCursor %W insert-1c } } bind Text <Control-d> { - if !$tk_strictMotif { + if {!$tk_strictMotif} { %W delete insert } } bind Text <Control-e> { - if !$tk_strictMotif { + if {!$tk_strictMotif} { tkTextSetCursor %W {insert lineend} } } bind Text <Control-f> { - if !$tk_strictMotif { + if {!$tk_strictMotif} { tkTextSetCursor %W insert+1c } } bind Text <Control-k> { - if !$tk_strictMotif { - if [%W compare insert == {insert lineend}] { + if {!$tk_strictMotif} { + if {[%W compare insert == {insert lineend}]} { %W delete insert } else { %W delete insert {insert lineend} @@ -312,67 +312,67 @@ bind Text <Control-k> { } } bind Text <Control-n> { - if !$tk_strictMotif { + if {!$tk_strictMotif} { tkTextSetCursor %W [tkTextUpDownLine %W 1] } } bind Text <Control-o> { - if !$tk_strictMotif { + if {!$tk_strictMotif} { %W insert insert \n %W mark set insert insert-1c } } bind Text <Control-p> { - if !$tk_strictMotif { + if {!$tk_strictMotif} { tkTextSetCursor %W [tkTextUpDownLine %W -1] } } bind Text <Control-t> { - if !$tk_strictMotif { + if {!$tk_strictMotif} { tkTextTranspose %W } } if {$tcl_platform(platform) != "windows"} { bind Text <Control-v> { - if !$tk_strictMotif { + if {!$tk_strictMotif} { tkTextScrollPages %W 1 } } } bind Text <Meta-b> { - if !$tk_strictMotif { + if {!$tk_strictMotif} { tkTextSetCursor %W [tkTextPrevPos %W insert tcl_startOfPreviousWord] } } bind Text <Meta-d> { - if !$tk_strictMotif { + if {!$tk_strictMotif} { %W delete insert [tkTextNextWord %W insert] } } bind Text <Meta-f> { - if !$tk_strictMotif { + if {!$tk_strictMotif} { tkTextSetCursor %W [tkTextNextWord %W insert] } } bind Text <Meta-less> { - if !$tk_strictMotif { + if {!$tk_strictMotif} { tkTextSetCursor %W 1.0 } } bind Text <Meta-greater> { - if !$tk_strictMotif { + if {!$tk_strictMotif} { tkTextSetCursor %W end-1c } } bind Text <Meta-BackSpace> { - if !$tk_strictMotif { + if {!$tk_strictMotif} { %W delete [tkTextPrevPos %W insert tcl_startOfPreviousWord] insert } } bind Text <Meta-Delete> { - if !$tk_strictMotif { + if {!$tk_strictMotif} { %W delete [tkTextPrevPos %W insert tcl_startOfPreviousWord] insert } } @@ -420,15 +420,15 @@ bind Text <Shift-Option-Down> { # A few additional bindings of my own. bind Text <Control-h> { - if !$tk_strictMotif { - if [%W compare insert != 1.0] { + if {!$tk_strictMotif} { + if {[%W compare insert != 1.0]} { %W delete insert-1c %W see insert } } } bind Text <2> { - if !$tk_strictMotif { + if {!$tk_strictMotif} { %W scan mark %x %y set tkPriv(x) %x set tkPriv(y) %y @@ -436,11 +436,11 @@ bind Text <2> { } } bind Text <B2-Motion> { - if !$tk_strictMotif { + if {!$tk_strictMotif} { if {(%x != $tkPriv(x)) || (%y != $tkPriv(y))} { set tkPriv(mouseMoved) 1 } - if $tkPriv(mouseMoved) { + if {$tkPriv(mouseMoved)} { %W scan dragto %x %y } } @@ -460,7 +460,7 @@ set tkPriv(prevPos) {} proc tkTextClosestGap {w x y} { set pos [$w index @$x,$y] set bbox [$w bbox $pos] - if ![string compare $bbox ""] { + if {![string compare $bbox ""]} { return $pos } if {($x - [lindex $bbox 0]) < ([lindex $bbox 2]/2)} { @@ -506,7 +506,7 @@ proc tkTextSelectTo {w x y} { global tkPriv tcl_platform set cur [tkTextClosestGap $w $x $y] - if [catch {$w index anchor}] { + if {[catch {$w index anchor}]} { $w mark set anchor $cur } set anchor [$w index anchor] @@ -515,7 +515,7 @@ proc tkTextSelectTo {w x y} { } switch $tkPriv(selectMode) { char { - if [$w compare $cur < anchor] { + if {[$w compare $cur < anchor]} { set first $cur set last anchor } else { @@ -524,7 +524,7 @@ proc tkTextSelectTo {w x y} { } } word { - if [$w compare $cur < anchor] { + if {[$w compare $cur < anchor]} { set first [tkTextPrevPos $w "$cur + 1c" tcl_wordBreakBefore] set last [tkTextNextPos $w "anchor" tcl_wordBreakAfter] } else { @@ -533,7 +533,7 @@ proc tkTextSelectTo {w x y} { } } line { - if [$w compare $cur < anchor] { + if {[$w compare $cur < anchor]} { set first [$w index "$cur linestart"] set last [$w index "anchor - 1c lineend + 1c"] } else { @@ -568,11 +568,11 @@ proc tkTextKeyExtend {w index} { global tkPriv set cur [$w index $index] - if [catch {$w index anchor}] { + if {[catch {$w index anchor}]} { $w mark set anchor $cur } set anchor [$w index anchor] - if [$w compare $cur < anchor] { + if {[$w compare $cur < anchor]} { set first $cur set last anchor } else { @@ -640,7 +640,7 @@ proc tkTextAutoScan {w} { proc tkTextSetCursor {w pos} { global tkPriv - if [$w compare $pos == end] { + if {[$w compare $pos == end]} { set pos {end - 1 chars} } $w mark set insert $pos @@ -662,14 +662,14 @@ proc tkTextKeySelect {w new} { global tkPriv if {[$w tag nextrange sel 1.0 end] == ""} { - if [$w compare $new < insert] { + if {[$w compare $new < insert]} { $w tag add sel $new insert } else { $w tag add sel insert $new } $w mark set anchor insert } else { - if [$w compare $new < anchor] { + if {[$w compare $new < anchor]} { set first $new set last anchor } else { @@ -709,11 +709,11 @@ proc tkTextResetAnchor {w index} { set a [$w index $index] set b [$w index sel.first] set c [$w index sel.last] - if [$w compare $a < $b] { + if {[$w compare $a < $b]} { $w mark set anchor sel.last return } - if [$w compare $a > $c] { + if {[$w compare $a > $c]} { $w mark set anchor sel.first return } @@ -783,7 +783,7 @@ proc tkTextUpDownLine {w n} { if {[string compare $tkPriv(prevPos) $i] != 0} { set tkPriv(char) $char } - set new [$w index [expr $line + $n].$tkPriv(char)] + set new [$w index [expr {$line + $n}].$tkPriv(char)] if {[$w compare $new == end] || [$w compare $new == "insert linestart"]} { set new $i } @@ -805,8 +805,8 @@ proc tkTextPrevPara {w pos} { while 1 { if {(([$w get "$pos - 1 line"] == "\n") && ([$w get $pos] != "\n")) || ($pos == "1.0")} { - if [regexp -indices {^[ ]+(.)} [$w get $pos "$pos lineend"] \ - dummy index] { + if {[regexp -indices {^[ ]+(.)} [$w get $pos "$pos lineend"] \ + dummy index]} { set pos [$w index "$pos + [lindex $index 0] chars"] } if {[$w compare $pos != insert] || ($pos == "1.0")} { @@ -829,19 +829,19 @@ proc tkTextPrevPara {w pos} { proc tkTextNextPara {w start} { set pos [$w index "$start linestart + 1 line"] while {[$w get $pos] != "\n"} { - if [$w compare $pos == end] { + if {[$w compare $pos == end]} { return [$w index "end - 1c"] } set pos [$w index "$pos + 1 line"] } while {[$w get $pos] == "\n"} { set pos [$w index "$pos + 1 line"] - if [$w compare $pos == end] { + if {[$w compare $pos == end]} { return [$w index "end - 1c"] } } - if [regexp -indices {^[ ]+(.)} [$w get $pos "$pos lineend"] \ - dummy index] { + if {[regexp -indices {^[ ]+(.)} [$w get $pos "$pos lineend"] \ + dummy index]} { return [$w index "$pos + [lindex $index 0] chars"] } return $pos @@ -863,7 +863,7 @@ proc tkTextScrollPages {w count} { set bbox [$w bbox insert] $w yview scroll $count pages if {$bbox == ""} { - return [$w index @[expr [winfo height $w]/2],0] + return [$w index @[expr {[winfo height $w]/2}],0] } return [$w index @[lindex $bbox 0],[lindex $bbox 1]] } @@ -880,11 +880,11 @@ proc tkTextScrollPages {w count} { proc tkTextTranspose w { set pos insert - if [$w compare $pos != "$pos lineend"] { + if {[$w compare $pos != "$pos lineend"]} { set pos [$w index "$pos + 1 char"] } set new [$w get "$pos - 1 char"][$w get "$pos - 2 char"] - if [$w compare "$pos - 1 char" == 1.0] { + if {[$w compare "$pos - 1 char" == 1.0]} { return } $w delete "$pos - 2 char" $pos diff --git a/library/tk.tcl b/library/tk.tcl index 4ecbeaf..1a1fbd0 100644 --- a/library/tk.tcl +++ b/library/tk.tcl @@ -3,7 +3,7 @@ # Initialization script normally executed in the interpreter for each # Tk-based application. Arranges class bindings for widgets. # -# SCCS: @(#) tk.tcl 1.98 97/10/28 15:21:04 +# SCCS: @(#) tk.tcl 1.101 97/12/19 16:16:40 # # Copyright (c) 1992-1994 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. @@ -13,8 +13,8 @@ # Insist on running with compatible versions of Tcl and Tk. -package require -exact Tk 8.0 -package require -exact Tcl 8.0 +package require -exact Tk 8.1 +package require -exact Tcl 8.1 # Add Tk's directory to the end of the auto-load search path, if it # isn't already on the path: @@ -42,7 +42,7 @@ set tk_strictMotif 0 proc tkScreenChanged screen { set x [string last . $screen] if {$x > 0} { - set disp [string range $screen 0 [expr $x - 1]] + set disp [string range $screen 0 [expr {$x - 1}]] } else { set disp $screen } @@ -51,7 +51,7 @@ proc tkScreenChanged screen { global tkPriv global tcl_platform - if [info exists tkPriv] { + if {[info exists tkPriv]} { set tkPriv(screen) $screen return } @@ -101,7 +101,7 @@ tkScreenChanged [winfo screen .] proc tkEventMotifBindings {n1 dummy dummy} { upvar $n1 name - if $name { + if {$name} { set op delete } else { set op add @@ -113,6 +113,40 @@ proc tkEventMotifBindings {n1 dummy dummy} { } #---------------------------------------------------------------------- +# Define common dialogs on platforms where they are not implemented +# using compiled code. +#---------------------------------------------------------------------- + +if {[info commands tk_chooseColor] == ""} { + proc tk_chooseColor {args} { + return [eval tkColorDialog $args] + } +} +if {[info commands tk_getOpenFile] == ""} { + proc tk_getOpenFile {args} { + if {$::tk_strictMotif} { + return [eval tkMotifFDialog open $args] + } else { + return [eval tkFDialog open $args] + } + } +} +if {[info commands tk_getSaveFile] == ""} { + proc tk_getSaveFile {args} { + if {$::tk_strictMotif} { + return [eval tkMotifFDialog save $args] + } else { + return [eval tkFDialog save $args] + } + } +} +if {[info commands tk_messageBox] == ""} { + proc tk_messageBox {args} { + return [eval tkMessageBox $args] + } +} + +#---------------------------------------------------------------------- # Define the set of common virtual events. #---------------------------------------------------------------------- diff --git a/library/tkfbox.tcl b/library/tkfbox.tcl index d81a5a2..8e2bd73 100644 --- a/library/tkfbox.tcl +++ b/library/tkfbox.tcl @@ -11,9 +11,9 @@ # files by clicking on the file icons or by entering a filename # in the "Filename:" entry. # -# SCCS: @(#) tkfbox.tcl 1.13 97/10/01 14:51:01 +# SCCS: @(#) tkfbox.tcl 1.22 98/01/26 19:42:37 # -# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# Copyright (c) 1994-1998 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -95,10 +95,10 @@ proc tkIconList_Create {w} { bind $data(canvas) <1> "tkIconList_Btn1 $w %x %y" bind $data(canvas) <B1-Motion> "tkIconList_Motion1 $w %x %y" - bind $data(canvas) <Double-1> "tkIconList_Double1 $w %x %y" - bind $data(canvas) <ButtonRelease-1> "tkCancelRepeat" bind $data(canvas) <B1-Leave> "tkIconList_Leave1 $w %x %y" bind $data(canvas) <B1-Enter> "tkCancelRepeat" + bind $data(canvas) <ButtonRelease-1> "tkCancelRepeat" + bind $data(canvas) <Double-ButtonRelease-1> "tkIconList_Double1 $w %x %y" bind $data(canvas) <Up> "tkIconList_UpDown $w -1" bind $data(canvas) <Down> "tkIconList_UpDown $w 1" @@ -133,7 +133,7 @@ proc tkIconList_AutoScan {w} { set x $tkPriv(x) set y $tkPriv(y) - if $data(noScroll) { + if {$data(noScroll)} { return } if {$x >= [winfo width $data(canvas)]} { @@ -188,8 +188,8 @@ proc tkIconList_Add {w image text} { set rTag [$data(canvas) create rect 0 0 0 0 -fill "" -outline ""] set b [$data(canvas) bbox $iTag] - set iW [expr [lindex $b 2]-[lindex $b 0]] - set iH [expr [lindex $b 3]-[lindex $b 1]] + set iW [expr {[lindex $b 2]-[lindex $b 0]}] + set iH [expr {[lindex $b 3]-[lindex $b 1]}] if {$data(maxIW) < $iW} { set data(maxIW) $iW } @@ -198,8 +198,8 @@ proc tkIconList_Add {w image text} { } set b [$data(canvas) bbox $tTag] - set tW [expr [lindex $b 2]-[lindex $b 0]] - set tH [expr [lindex $b 3]-[lindex $b 1]] + set tW [expr {[lindex $b 2]-[lindex $b 0]}] + set tH [expr {[lindex $b 3]-[lindex $b 1]}] if {$data(maxTW) < $tW} { set data(maxTW) $tW } @@ -218,7 +218,7 @@ proc tkIconList_Add {w image text} { proc tkIconList_Arrange {w} { upvar #0 $w data - if ![info exists data(list)] { + if {![info exists data(list)]} { if {[info exists data(canvas)] && [winfo exists $data(canvas)]} { set data(noScroll) 1 $data(sbar) config -command "" @@ -228,26 +228,26 @@ proc tkIconList_Arrange {w} { set W [winfo width $data(canvas)] set H [winfo height $data(canvas)] - set pad [expr [$data(canvas) cget -highlightthickness] + \ - [$data(canvas) cget -bd]] + set pad [expr {[$data(canvas) cget -highlightthickness] + \ + [$data(canvas) cget -bd]}] if {$pad < 2} { set pad 2 } - incr W -[expr $pad*2] - incr H -[expr $pad*2] + incr W -[expr {$pad*2}] + incr H -[expr {$pad*2}] - set dx [expr $data(maxIW) + $data(maxTW) + 8] + set dx [expr {$data(maxIW) + $data(maxTW) + 8}] if {$data(maxTH) > $data(maxIH)} { set dy $data(maxTH) } else { set dy $data(maxIH) } incr dy 2 - set shift [expr $data(maxIW) + 4] + set shift [expr {$data(maxIW) + 4}] - set x [expr $pad * 2] - set y [expr $pad * 1] + set x [expr {$pad * 2}] + set y [expr {$pad * 1}] ; # Why * 1 ? set usedColumn 0 foreach sublist $data(list) { set usedColumn 1 @@ -259,24 +259,24 @@ proc tkIconList_Arrange {w} { set tW [lindex $sublist 5] set tH [lindex $sublist 6] - set i_dy [expr ($dy - $iH)/2] - set t_dy [expr ($dy - $tH)/2] + set i_dy [expr {($dy - $iH)/2}] + set t_dy [expr {($dy - $tH)/2}] - $data(canvas) coords $iTag $x [expr $y + $i_dy] - $data(canvas) coords $tTag [expr $x + $shift] [expr $y + $t_dy] - $data(canvas) coords $tTag [expr $x + $shift] [expr $y + $t_dy] - $data(canvas) coords $rTag $x $y [expr $x+$dx] [expr $y+$dy] + $data(canvas) coords $iTag $x [expr {$y + $i_dy}] + $data(canvas) coords $tTag [expr {$x + $shift}] [expr {$y + $t_dy}] + $data(canvas) coords $tTag [expr {$x + $shift}] [expr {$y + $t_dy}] + $data(canvas) coords $rTag $x $y [expr {$x+$dx}] [expr {$y+$dy}] incr y $dy - if {[expr $y + $dy] > $H} { - set y [expr $pad * 1] + if {($y + $dy) > $H} { + set y [expr {$pad * 1}] ; # *1 ? incr x $dx set usedColumn 0 } } if {$usedColumn} { - set sW [expr $x + $dx] + set sW [expr {$x + $dx}] } else { set sW $x } @@ -292,7 +292,7 @@ proc tkIconList_Arrange {w} { set data(noScroll) 0 } - set data(itemsPerColumn) [expr ($H-$pad)/$dy] + set data(itemsPerColumn) [expr {($H-$pad)/$dy}] if {$data(itemsPerColumn) < 1} { set data(itemsPerColumn) 1 } @@ -321,47 +321,47 @@ proc tkIconList_See {w rTag} { upvar #0 $w data upvar #0 $w:itemList itemList - if $data(noScroll) { + if {$data(noScroll)} { return } set sRegion [$data(canvas) cget -scrollregion] - if ![string compare $sRegion {}] { + if {![string compare $sRegion {}]} { return } - if ![info exists itemList($rTag)] { + if {![info exists itemList($rTag)]} { return } set bbox [$data(canvas) bbox $rTag] - set pad [expr [$data(canvas) cget -highlightthickness] + \ - [$data(canvas) cget -bd]] + set pad [expr {[$data(canvas) cget -highlightthickness] + \ + [$data(canvas) cget -bd]}] set x1 [lindex $bbox 0] set x2 [lindex $bbox 2] - incr x1 -[expr $pad * 2] - incr x2 -[expr $pad * 1] + incr x1 -[expr {$pad * 2}] + incr x2 -[expr {$pad * 1}] ; # *1 ? - set cW [expr [winfo width $data(canvas)] - $pad*2] + set cW [expr {[winfo width $data(canvas)] - $pad*2}] - set scrollW [expr [lindex $sRegion 2]-[lindex $sRegion 0]+1] - set dispX [expr int([lindex [$data(canvas) xview] 0]*$scrollW)] + set scrollW [expr {[lindex $sRegion 2]-[lindex $sRegion 0]+1}] + set dispX [expr {int([lindex [$data(canvas) xview] 0]*$scrollW)}] set oldDispX $dispX # check if out of the right edge # - if {[expr $x2 - $dispX] >= $cW} { - set dispX [expr $x2 - $cW] + if {($x2 - $dispX) >= $cW} { + set dispX [expr {$x2 - $cW}] } # check if out of the left edge # - if {[expr $x1 - $dispX] < 0} { + if {($x1 - $dispX) < 0} { set dispX $x1 } if {$oldDispX != $dispX} { - set fraction [expr double($dispX)/double($scrollW)] + set fraction [expr {double($dispX)/double($scrollW)}] $data(canvas) xview moveto $fraction } } @@ -377,7 +377,7 @@ proc tkIconList_Select {w rTag {callBrowse 1}} { upvar #0 $w data upvar #0 $w:itemList itemList - if ![info exists itemList($rTag)] { + if {![info exists itemList($rTag)]} { return } set iTag [lindex $itemList($rTag) 0] @@ -385,7 +385,7 @@ proc tkIconList_Select {w rTag {callBrowse 1}} { set text [lindex $itemList($rTag) 2] set serial [lindex $itemList($rTag) 3] - if ![info exists data(rect)] { + if {![info exists data(rect)]} { set data(rect) [$data(canvas) create rect 0 0 0 0 \ -fill #a0a0ff -outline #a0a0ff] } @@ -397,7 +397,7 @@ proc tkIconList_Select {w rTag {callBrowse 1}} { set data(selected) $text if {$callBrowse} { - if [string compare $data(-browsecmd) ""] { + if {[string compare $data(-browsecmd) ""]} { eval $data(-browsecmd) [list $text] } } @@ -406,11 +406,11 @@ proc tkIconList_Select {w rTag {callBrowse 1}} { proc tkIconList_Unselect {w} { upvar #0 $w data - if [info exists data(rect)] { + if {[info exists data(rect)]} { $data(canvas) delete $data(rect) unset data(rect) } - if [info exists data(selected)] { + if {[info exists data(selected)]} { unset data(selected) } set data(curItem) {} @@ -421,7 +421,7 @@ proc tkIconList_Unselect {w} { proc tkIconList_Get {w} { upvar #0 $w data - if [info exists data(selected)] { + if {[info exists data(selected)]} { return $data(selected) } else { return "" @@ -469,7 +469,7 @@ proc tkIconList_Leave1 {w x y} { proc tkIconList_FocusIn {w} { upvar #0 $w data - if ![info exists data(list)] { + if {![info exists data(list)]} { return } @@ -490,7 +490,7 @@ proc tkIconList_FocusIn {w} { proc tkIconList_UpDown {w amount} { upvar #0 $w data - if ![info exists data(list)] { + if {![info exists data(list)]} { return } @@ -498,13 +498,13 @@ proc tkIconList_UpDown {w amount} { set rTag [lindex [lindex $data(list) 0] 2] } else { set oldRTag [lindex [lindex $data(list) $data(curItem)] 2] - set rTag [lindex [lindex $data(list) [expr $data(curItem)+$amount]] 2] - if ![string compare $rTag ""] { + set rTag [lindex [lindex $data(list) [expr {$data(curItem)+$amount}]] 2] + if {![string compare $rTag ""]} { set rTag $oldRTag } } - if [string compare $rTag ""] { + if {[string compare $rTag ""]} { tkIconList_Select $w $rTag tkIconList_See $w $rTag } @@ -521,21 +521,21 @@ proc tkIconList_UpDown {w amount} { proc tkIconList_LeftRight {w amount} { upvar #0 $w data - if ![info exists data(list)] { + if {![info exists data(list)]} { return } if {$data(curItem) == {}} { set rTag [lindex [lindex $data(list) 0] 2] } else { set oldRTag [lindex [lindex $data(list) $data(curItem)] 2] - set newItem [expr $data(curItem)+($amount*$data(itemsPerColumn))] + set newItem [expr {$data(curItem)+($amount*$data(itemsPerColumn))}] set rTag [lindex [lindex $data(list) $newItem] 2] - if ![string compare $rTag ""] { + if {![string compare $rTag ""]} { set rTag $oldRTag } } - if [string compare $rTag ""] { + if {[string compare $rTag ""]} { tkIconList_Select $w $rTag tkIconList_See $w $rTag } @@ -565,7 +565,7 @@ proc tkIconList_Goto {w text} { upvar #0 $w:textList textList global tkPriv - if ![info exists data(list)] { + if {![info exists data(list)]} { return } @@ -583,7 +583,7 @@ proc tkIconList_Goto {w text} { set theIndex -1 set less 0 set len [string length $text] - set len0 [expr $len-1] + set len0 [expr {$len-1}] set i $start # Search forward until we find a filename whose prefix is an exact match @@ -628,23 +628,22 @@ proc tkIconList_Reset {w} { # the tk_strictMotif flag is set to false. This procedure shouldn't # be called directly. Call tk_getOpenFile or tk_getSaveFile instead. # -proc tkFDialog {args} { - global tkPriv - set w __tk_filedialog - upvar #0 $w data +# Arguments: +# type "open" or "save" +# args Options parsed by the procedure. +# - if ![string compare [lindex [info level 0] 0] tk_getOpenFile] { - set type open - } else { - set type save - } +proc tkFDialog {type args} { + global tkPriv + set dataName __tk_filedialog + upvar #0 $dataName data - tkFDialog_Config $w $type $args + tkFDialog_Config $dataName $type $args if {![string compare $data(-parent) .]} { - set w .$w + set w .$dataName } else { - set w $data(-parent).$w + set w $data(-parent).$dataName } # (re)create the dialog box if necessary @@ -657,7 +656,9 @@ proc tkFDialog {args} { } wm transient $w $data(-parent) - # 5. Initialize the file types menu + trace variable data(selectPath) w "tkFDialog_SetPath $w" + + # Initialize the file types menu # if {$data(-filetypes) != {}} { $data(typeMenu) delete 0 end @@ -678,21 +679,21 @@ proc tkFDialog {args} { tkFDialog_UpdateWhenIdle $w - # 6. Withdraw the window, then update all the geometry information + # Withdraw the window, then update all the geometry information # so we know how big it wants to be, then center the window in the # display and de-iconify it. wm withdraw $w update idletasks - set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \ - - [winfo vrootx [winfo parent $w]]] - set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \ - - [winfo vrooty [winfo parent $w]]] + set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \ + - [winfo vrootx [winfo parent $w]]}] + set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 \ + - [winfo vrooty [winfo parent $w]]}] wm geom $w [winfo reqwidth $w]x[winfo reqheight $w]+$x+$y wm deiconify $w wm title $w $data(-title) - # 7. Set a grab and claim the focus too. + # Set a grab and claim the focus too. set oldFocus [focus] set oldGrab [grab current $w] @@ -707,7 +708,7 @@ proc tkFDialog {args} { $data(ent) select to end $data(ent) icursor end - # 8. Wait for the user to respond, then restore the focus and + # Wait for the user to respond, then restore the focus and # return the index of the selected button. Restore the focus # before deleting the window, since otherwise the window manager # may take the focus away so we can't redirect it. Finally, @@ -724,6 +725,7 @@ proc tkFDialog {args} { grab $oldGrab } } + return $tkPriv(selectFilePath) } @@ -731,11 +733,19 @@ proc tkFDialog {args} { # # Configures the TK filedialog according to the argument list # -proc tkFDialog_Config {w type argList} { - upvar #0 $w data +proc tkFDialog_Config {dataName type argList} { + upvar #0 $dataName data set data(type) $type + # 0: Delete all variable that were set on data(selectPath) the + # last time the file dialog is used. The traces may cause troubles + # if the dialog is now used with a different -parent option. + + foreach trace [trace vinfo data(selectPath)] { + trace vdelete data(selectPath) [lindex $trace 0] [lindex $trace 1] + } + # 1: the configuration specs # set specs { @@ -749,7 +759,7 @@ proc tkFDialog_Config {w type argList} { # 2: default values depending on the type of the dialog # - if ![info exists data(selectPath)] { + if {![info exists data(selectPath)]} { # first time the dialog has been popped up set data(selectPath) [pwd] set data(selectFile) "" @@ -757,10 +767,10 @@ proc tkFDialog_Config {w type argList} { # 3: parse the arguments # - tclParseConfigSpec $w $specs "" $argList + tclParseConfigSpec $dataName $specs "" $argList - if ![string compare $data(-title) ""] { - if ![string compare $type "open"] { + if {![string compare $data(-title) ""]} { + if {![string compare $type "open"]} { set data(-title) "Open" } else { set data(-title) "Save As" @@ -770,9 +780,9 @@ proc tkFDialog_Config {w type argList} { # 4: set the default directory and selection according to the -initial # settings # - if [string compare $data(-initialdir) ""] { - if [file isdirectory $data(-initialdir)] { - set data(selectPath) [glob $data(-initialdir)] + if {[string compare $data(-initialdir) ""]} { + if {[file isdirectory $data(-initialdir)]} { + set data(selectPath) [lindex [glob $data(-initialdir)] 0] } else { error "\"$data(-initialdir)\" is not a valid directory" } @@ -783,7 +793,7 @@ proc tkFDialog_Config {w type argList} { # set data(-filetypes) [tkFDGetFileTypes $data(-filetypes)] - if ![winfo exists $data(-parent)] { + if {![winfo exists $data(-parent)]} { error "bad window path name \"$data(-parent)\"" } } @@ -802,7 +812,7 @@ proc tkFDialog_Create {w} { set data(dirMenuBtn) $f1.menu set data(dirMenu) [tk_optionMenu $f1.menu [format %s(selectPath) $dataName] ""] set data(upBtn) [button $f1.up] - if ![info exists tkPriv(updirImage)] { + if {![info exists tkPriv(updirImage)]} { set tkPriv(updirImage) [image create bitmap -data { #define updir_width 28 #define updir_height 16 @@ -896,8 +906,6 @@ static char updir_bits[] = { $data(okBtn) config -command "tkFDialog_OkCmd $w" $data(cancelBtn) config -command "tkFDialog_CancelCmd $w" - trace variable data(selectPath) w "tkFDialog_SetPath $w" - bind $w <Alt-d> "focus $data(dirMenuBtn)" bind $w <Alt-t> [format { if {"[%s cget -state]" == "normal"} { @@ -929,7 +937,7 @@ static char updir_bits[] = { proc tkFDialog_UpdateWhenIdle {w} { upvar #0 [winfo name $w] data - if [info exists data(updateId)] { + if {[info exists data(updateId)]} { return } else { set data(updateId) [after idle tkFDialog_Update $w] @@ -955,8 +963,7 @@ proc tkFDialog_Update {w} { catch {unset data(updateId)} } - set TRANSPARENT_GIF_COLOR [$w cget -bg] - if ![info exists tkPriv(folderImage)] { + if {![info exists tkPriv(folderImage)]} { set tkPriv(folderImage) [image create photo -data { R0lGODlhEAAMAKEAAAD//wAAAPD/gAAAACH5BAEAAAAALAAAAAAQAAwAAAIghINhyycvVFsB QtmS3rjaH1Hg141WaT5ouprt2HHcUgAAOw==}] @@ -968,9 +975,9 @@ rSASvJTGhnhcV3EJlo3kh53ltF5nAhQAOw==}] set file $tkPriv(fileImage) set appPWD [pwd] - if [catch { + if {[catch { cd $data(selectPath) - }] { + }]} { # We cannot change directory to $data(selectPath). $data(selectPath) # should have been checked before tkFDialog_Update is called, so # we normally won't come to here. Anyways, give an error and abort @@ -996,14 +1003,14 @@ rSASvJTGhnhcV3EJlo3kh53ltF5nAhQAOw==}] # Make the dir list # foreach f [lsort -dictionary [glob -nocomplain .* *]] { - if ![string compare $f .] { + if {![string compare $f .]} { continue } - if ![string compare $f ..] { + if {![string compare $f ..]} { continue } - if [file isdir ./$f] { - if ![info exists hasDoneDir($f)] { + if {[file isdir ./$f]} { + if {![info exists hasDoneDir($f)]} { tkIconList_Add $data(icons) $folder $f set hasDoneDir($f) 1 } @@ -1011,7 +1018,7 @@ rSASvJTGhnhcV3EJlo3kh53ltF5nAhQAOw==}] } # Make the file list # - if ![string compare $data(filter) *] { + if {![string compare $data(filter) *]} { set files [lsort -dictionary \ [glob -nocomplain .* *]] } else { @@ -1021,8 +1028,8 @@ rSASvJTGhnhcV3EJlo3kh53ltF5nAhQAOw==}] set top 0 foreach f $files { - if ![file isdir ./$f] { - if ![info exists hasDoneFile($f)] { + if {![file isdir ./$f]} { + if {![info exists hasDoneFile($f)]} { tkIconList_Add $data(icons) $file $f set hasDoneFile($f) 1 } @@ -1132,24 +1139,21 @@ proc tkFDialogResolveFile {context text defaultext} { set path "$path$defaultext" } - if [catch {file exists $path}] { - return [list ERROR $path ""] - } - if [catch {if [file exists $path] {}}] { - # This "if" block can be safely removed if the following code returns - # an error. It currently (7/22/97) doesn't + if {[catch {file exists $path}]} { + # This "if" block can be safely removed if the following code + # stop generating errors. # # file exists ~nonsuchuser # return [list ERROR $path ""] } - if [file exists $path] { - if [file isdirectory $path] { - if [catch { + if {[file exists $path]} { + if {[file isdirectory $path]} { + if {[catch { cd $path - }] { + }]} { return [list CHDIR $path ""] } set directory [pwd] @@ -1157,9 +1161,9 @@ proc tkFDialogResolveFile {context text defaultext} { set flag OK cd $appPWD } else { - if [catch { + if {[catch { cd [file dirname $path] - }] { + }]} { return [list CHDIR [file dirname $path] ""] } set directory [pwd] @@ -1169,15 +1173,15 @@ proc tkFDialogResolveFile {context text defaultext} { } } else { set dirname [file dirname $path] - if [file exists $dirname] { - if [catch { + if {[file exists $dirname]} { + if {[catch { cd $dirname - }] { + }]} { return [list CHDIR $dirname ""] } set directory [pwd] set file [file tail $path] - if [regexp {[*]|[?]} $file] { + if {[regexp {[*]|[?]} $file]} { set flag PATTERN } else { set flag FILE @@ -1201,7 +1205,7 @@ proc tkFDialogResolveFile {context text defaultext} { proc tkFDialog_EntFocusIn {w} { upvar #0 [winfo name $w] data - if [string compare [$data(ent) get] ""] { + if {[string compare [$data(ent) get] ""]} { $data(ent) selection from 0 $data(ent) selection to end $data(ent) icursor end @@ -1211,7 +1215,7 @@ proc tkFDialog_EntFocusIn {w} { tkIconList_Unselect $data(icons) - if ![string compare $data(type) open] { + if {![string compare $data(type) open]} { $data(okBtn) config -text "Open" } else { $data(okBtn) config -text "Save" @@ -1239,7 +1243,7 @@ proc tkFDialog_ActivateEnt {w} { case $flag { OK { - if ![string compare $file ""] { + if {![string compare $file ""]} { # user has entered an existing (sub)directory set data(selectPath) $path $data(ent) delete 0 end @@ -1254,7 +1258,7 @@ proc tkFDialog_ActivateEnt {w} { set data(filter) $file } FILE { - if ![string compare $data(type) open] { + if {![string compare $data(type) open]} { tk_messageBox -icon warning -type ok -parent $data(-parent) \ -message "File \"[file join $path $file]\" does not exist." $data(ent) select from 0 @@ -1297,7 +1301,7 @@ proc tkFDialog_ActivateEnt {w} { proc tkFDialog_InvokeBtn {w key} { upvar #0 [winfo name $w] data - if ![string compare [$data(okBtn) cget -text] $key] { + if {![string compare [$data(okBtn) cget -text] $key]} { tkButtonInvoke $data(okBtn) } } @@ -1307,7 +1311,7 @@ proc tkFDialog_InvokeBtn {w key} { proc tkFDialog_UpDirCmd {w} { upvar #0 [winfo name $w] data - if [string compare $data(selectPath) "/"] { + if {[string compare $data(selectPath) "/"]} { set data(selectPath) [file dirname $data(selectPath)] } } @@ -1331,9 +1335,9 @@ proc tkFDialog_OkCmd {w} { upvar #0 [winfo name $w] data set text [tkIconList_Get $data(icons)] - if [string compare $text ""] { + if {[string compare $text ""]} { set file [tkFDialog_JoinFile $data(selectPath) $text] - if [file isdirectory $file] { + if {[file isdirectory $file]} { tkFDialog_ListInvoke $w $text return } @@ -1362,11 +1366,11 @@ proc tkFDialog_ListBrowse {w text} { } set file [tkFDialog_JoinFile $data(selectPath) $text] - if ![file isdirectory $file] { + if {![file isdirectory $file]} { $data(ent) delete 0 end $data(ent) insert 0 $text - if ![string compare $data(type) open] { + if {![string compare $data(type) open]} { $data(okBtn) config -text "Open" } else { $data(okBtn) config -text "Save" @@ -1388,9 +1392,9 @@ proc tkFDialog_ListInvoke {w text} { set file [tkFDialog_JoinFile $data(selectPath) $text] - if [file isdirectory $file] { + if {[file isdirectory $file]} { set appPWD [pwd] - if [catch {cd $file}] { + if {[catch {cd $file}]} { tk_messageBox -type ok -parent $data(-parent) -message \ "Cannot change to the directory \"$file\".\nPermission denied."\ -icon warning @@ -1416,7 +1420,7 @@ proc tkFDialog_Done {w {selectFilePath ""}} { upvar #0 [winfo name $w] data global tkPriv - if ![string compare $selectFilePath ""] { + if {![string compare $selectFilePath ""]} { set selectFilePath [tkFDialog_JoinFile $data(selectPath) \ $data(selectFile)] set tkPriv(selectFile) $data(selectFile) @@ -1425,11 +1429,13 @@ proc tkFDialog_Done {w {selectFilePath ""}} { if {[file exists $selectFilePath] && ![string compare $data(type) save]} { - set reply [tk_messageBox -icon warning -type yesno -parent $data(-parent) \ - -message "File \"$selectFilePath\" already exists.\nDo you want to overwrite it?"] - if ![string compare $reply "no"] { - return - } + set reply [tk_messageBox -icon warning -type yesno\ + -parent $data(-parent) -message "File\ + \"$selectFilePath\" already exists.\nDo\ + you want to overwrite it?"] + if {![string compare $reply "no"]} { + return + } } } set tkPriv(selectFilePath) $selectFilePath diff --git a/library/xmfbox.tcl b/library/xmfbox.tcl index 52f8b33..3d3f014 100644 --- a/library/xmfbox.tcl +++ b/library/xmfbox.tcl @@ -4,59 +4,112 @@ # Unix platform. This implementation is used only if the # "tk_strictMotif" flag is set. # -# SCCS: @(#) xmfbox.tcl 1.6 97/10/01 15:06:07 -# # 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. # - +# SCCS: @(#) xmfbox.tcl 1.11 97/12/23 14:11:40 +# # tkMotifFDialog -- # # Implements a file dialog similar to the standard Motif file # selection box. # -# Return value: +# Arguments: +# type "open" or "save" +# args Options parsed by the procedure. # +# Results: # A list of two members. The first member is the absolute # pathname of the selected file or "" if user hits cancel. The # second member is the name of the selected file type, or "" # which stands for "default file type" -# -proc tkMotifFDialog {args} { + +proc tkMotifFDialog {type args} { global tkPriv - set w __tk_filedialog - upvar #0 $w data + set dataName __tk_filedialog + upvar #0 $dataName data - if ![string compare [lindex [info level 0] 0] tk_getOpenFile] { - set type open - } else { - set type save + set w [tkMotifFDialog_Create $dataName $type $args] + + # Set a grab and claim the focus too. + + set oldFocus [focus] + set oldGrab [grab current $w] + if {$oldGrab != ""} { + set grabStatus [grab status $oldGrab] } + grab $w + focus $data(sEnt) + $data(sEnt) select from 0 + $data(sEnt) select to end + + # Wait for the user to respond, then restore the focus and + # return the index of the selected button. Restore the focus + # before deleting the window, since otherwise the window manager + # may take the focus away so we can't redirect it. Finally, + # restore any grab that was in effect. + + tkwait variable tkPriv(selectFilePath) + catch {focus $oldFocus} + grab release $w + wm withdraw $w + if {$oldGrab != ""} { + if {$grabStatus == "global"} { + grab -global $oldGrab + } else { + grab $oldGrab + } + } + return $tkPriv(selectFilePath) +} + +# tkMotifFDialog_Create -- +# +# Creates the Motif file dialog (if it doesn't exist yet) and +# initialize the internal data structure associated with the +# dialog. +# +# This procedure is used by tkMotifFDialog to create the +# dialog. It's also used by the test suite to test the Motif +# file dialog implementation. User code shouldn't call this +# procedure directly. +# +# Arguments: +# dataName Name of the global "data" array for the file dialog. +# type "Save" or "Open" +# argList Options parsed by the procedure. +# +# Results: +# Pathname of the file dialog. + +proc tkMotifFDialog_Create {dataName type argList} { + global tkPriv + upvar #0 $dataName data - tkMotifFDialog_Config $w $type $args + tkMotifFDialog_Config $dataName $type $argList if {![string compare $data(-parent) .]} { - set w .$w + set w .$dataName } else { - set w $data(-parent).$w + set w $data(-parent).$dataName } # (re)create the dialog box if necessary # if {![winfo exists $w]} { - tkMotifFDialog_Create $w + tkMotifFDialog_BuildUI $w } elseif {[string compare [winfo class $w] TkMotifFDialog]} { destroy $w - tkMotifFDialog_Create $w + tkMotifFDialog_BuildUI $w } wm transient $w $data(-parent) tkMotifFDialog_Update $w - # 5. Withdraw the window, then update all the geometry information + # Withdraw the window, then update all the geometry information # so we know how big it wants to be, then center the window in the # display and de-iconify it. @@ -70,40 +123,23 @@ proc tkMotifFDialog {args} { wm deiconify $w wm title $w $data(-title) - # 6. Set a grab and claim the focus too. - - set oldFocus [focus] - set oldGrab [grab current $w] - if {$oldGrab != ""} { - set grabStatus [grab status $oldGrab] - } - grab $w - focus $data(sEnt) - $data(sEnt) select from 0 - $data(sEnt) select to end - - # 7. Wait for the user to respond, then restore the focus and - # return the index of the selected button. Restore the focus - # before deleting the window, since otherwise the window manager - # may take the focus away so we can't redirect it. Finally, - # restore any grab that was in effect. - - tkwait variable tkPriv(selectFilePath) - catch {focus $oldFocus} - grab release $w - wm withdraw $w - if {$oldGrab != ""} { - if {$grabStatus == "global"} { - grab -global $oldGrab - } else { - grab $oldGrab - } - } - return $tkPriv(selectFilePath) + return $w } -proc tkMotifFDialog_Config {w type argList} { - upvar #0 $w data +# tkMotifFDialog_Config -- +# +# Iterates over the optional arguments to determine the option +# values for the Motif file dialog; gives default values to +# unspecified options. +# +# Arguments: +# dataName The name of the global variable in which +# data for the file dialog is stored. +# type "Save" or "Open" +# argList Options parsed by the procedure. + +proc tkMotifFDialog_Config {dataName type argList} { + upvar #0 $dataName data set data(type) $type @@ -120,7 +156,7 @@ proc tkMotifFDialog_Config {w type argList} { # 2: default values depending on the type of the dialog # - if ![info exists data(selectPath)] { + if {![info exists data(selectPath)]} { # first time the dialog has been popped up set data(selectPath) [pwd] set data(selectFile) "" @@ -128,10 +164,10 @@ proc tkMotifFDialog_Config {w type argList} { # 3: parse the arguments # - tclParseConfigSpec $w $specs "" $argList + tclParseConfigSpec $dataName $specs "" $argList - if ![string compare $data(-title) ""] { - if ![string compare $type "open"] { + if {![string compare $data(-title) ""]} { + if {![string compare $type "open"]} { set data(-title) "Open" } else { set data(-title) "Save As" @@ -141,8 +177,8 @@ proc tkMotifFDialog_Config {w type argList} { # 4: set the default directory and selection according to the -initial # settings # - if [string compare $data(-initialdir) ""] { - if [file isdirectory $data(-initialdir)] { + if {[string compare $data(-initialdir) ""]} { + if {[file isdirectory $data(-initialdir)]} { set data(selectPath) [glob $data(-initialdir)] } else { error "\"$data(-initialdir)\" is not a valid directory" @@ -156,19 +192,29 @@ proc tkMotifFDialog_Config {w type argList} { # set data(-filetypes) [tkFDGetFileTypes $data(-filetypes)] - if ![info exists data(filter)] { + if {![info exists data(filter)]} { set data(filter) * } - if ![winfo exists $data(-parent)] { + if {![winfo exists $data(-parent)]} { error "bad window path name \"$data(-parent)\"" } } -proc tkMotifFDialog_Create {w} { +# tkMotifFDialog_BuildUI -- +# +# Builds the UI components of the Motif file dialog. +# +# Arguments: +# w Pathname of the dialog to build. +# +# Results: +# None. + +proc tkMotifFDialog_BuildUI {w} { set dataName [lindex [split $w .] end] upvar #0 $dataName data - # 1: Create the dialog ... + # Create the dialog toplevel and internal frames. # toplevel $w -class TkMotifFDialog set top [frame $w.top -relief raised -bd 1] @@ -246,7 +292,22 @@ proc tkMotifFDialog_Create {w} { wm protocol $w WM_DELETE_WINDOW "tkMotifFDialog_CancelCmd $w" } -proc tkMotifFDialog_MakeSList {w f label under cmd} { +# tkMotifFDialog_MakeSList -- +# +# Create a scrolled-listbox and set the keyboard accelerator +# bindings so that the list selection follows what the user +# types. +# +# Arguments: +# w Pathname of the dialog box. +# f Frame widget inside which to create the scrolled +# listbox. This frame widget already exists. +# label The string to display on top of the listbox. +# under Sets the -under option of the label. +# cmdPrefix Specifies procedures to call when the listbox is +# browsed or activated. + +proc tkMotifFDialog_MakeSList {w f label under cmdPrefix} { label $f.lab -text $label -under $under -anchor w listbox $f.l -width 12 -height 5 -selectmode browse -exportselection 0\ -xscrollcommand "$f.h set" \ @@ -268,13 +329,14 @@ proc tkMotifFDialog_MakeSList {w f label under cmd} { # bindings for the listboxes # set list $f.l - bind $list <Up> "tkMotifFDialog_Browse$cmd $w" - bind $list <Down> "tkMotifFDialog_Browse$cmd $w" - bind $list <space> "tkMotifFDialog_Browse$cmd $w" - bind $list <1> "tkMotifFDialog_Browse$cmd $w" - bind $list <B1-Motion> "tkMotifFDialog_Browse$cmd $w" - bind $list <Double-1> "tkMotifFDialog_Activate$cmd $w" - bind $list <Return> "tkMotifFDialog_Browse$cmd $w; tkMotifFDialog_Activate$cmd $w" + bind $list <Up> "tkMotifFDialog_Browse$cmdPrefix $w" + bind $list <Down> "tkMotifFDialog_Browse$cmdPrefix $w" + bind $list <space> "tkMotifFDialog_Browse$cmdPrefix $w" + bind $list <1> "tkMotifFDialog_Browse$cmdPrefix $w" + bind $list <B1-Motion> "tkMotifFDialog_Browse$cmdPrefix $w" + bind $list <Double-ButtonRelease-1> "tkMotifFDialog_Activate$cmdPrefix $w" + bind $list <Return> "tkMotifFDialog_Browse$cmdPrefix $w; \ + tkMotifFDialog_Activate$cmdPrefix $w" bindtags $list "Listbox $list [winfo toplevel $list] all" tkListBoxKeyAccel_Set $list @@ -282,15 +344,177 @@ proc tkMotifFDialog_MakeSList {w f label under cmd} { return $f.l } +# tkMotifFDialog_InterpFilter -- +# +# Interpret the string in the filter entry into two components: +# the directory and the pattern. If the string is a relative +# pathname, give a warning to the user and restore the pattern +# to original. +# +# Arguments: +# w pathname of the dialog box. +# +# Results: +# A list of two elements. The first element is the directory +# specified # by the filter. The second element is the filter +# pattern itself. + +proc tkMotifFDialog_InterpFilter {w} { + upvar #0 [winfo name $w] data + + set text [string trim [$data(fEnt) get]] + + # Perform tilde substitution + # + set badTilde 0 + if {[string compare [string index $text 0] ~] == 0} { + set list [file split $text] + set tilde [lindex $list 0] + if [catch {set tilde [glob $tilde]}] { + set badTilde 1 + } else { + set text [eval file join [concat $tilde [lrange $list 1 end]]] + } + } + + # If the string is a relative pathname, combine it + # with the current selectPath. + + set relative 0 + if {[file pathtype $text] == "relative"} { + set relative 1 + } elseif {$badTilde} { + set relative 1 + } + + if {$relative} { + tk_messageBox -icon warning -type ok \ + -message "\"$text\" must be an absolute pathname" + + $data(fEnt) delete 0 end + $data(fEnt) insert 0 [tkFDialog_JoinFile $data(selectPath) \ + $data(filter)] + + return [list $data(selectPath) $data(filter)] + } + + set resolved [tkFDialog_JoinFile [file dirname $text] [file tail $text]] + + if [file isdirectory $resolved] { + set dir $resolved + set fil $data(filter) + } else { + set dir [file dirname $resolved] + set fil [file tail $resolved] + } + + return [list $dir $fil] +} + +# tkMotifFDialog_Update +# +# Load the files and synchronize the "filter" and "selection" fields +# boxes. +# +# Arguments: +# w pathname of the dialog box. +# +# Results: +# None. + +proc tkMotifFDialog_Update {w} { + upvar #0 [winfo name $w] data + + $data(fEnt) delete 0 end + $data(fEnt) insert 0 [tkFDialog_JoinFile $data(selectPath) $data(filter)] + $data(sEnt) delete 0 end + $data(sEnt) insert 0 [tkFDialog_JoinFile $data(selectPath) \ + $data(selectFile)] + + tkMotifFDialog_LoadFiles $w +} + +# tkMotifFDialog_LoadFiles -- +# +# Loads the files and directories into the two listboxes according +# to the filter setting. +# +# Arguments: +# w pathname of the dialog box. +# +# Results: +# None. + +proc tkMotifFDialog_LoadFiles {w} { + upvar #0 [winfo name $w] data + + $data(dList) delete 0 end + $data(fList) delete 0 end + + set appPWD [pwd] + if [catch { + cd $data(selectPath) + }] { + cd $appPWD + + $data(dList) insert end ".." + return + } + + # Make the dir list + # + foreach f [lsort -dictionary [glob -nocomplain .* *]] { + if [file isdir ./$f] { + $data(dList) insert end $f + } + } + # Make the file list + # + if ![string compare $data(filter) *] { + set files [lsort -dictionary [glob -nocomplain .* *]] + } else { + set files [lsort -dictionary \ + [glob -nocomplain $data(filter)]] + } + + set top 0 + foreach f $files { + if ![file isdir ./$f] { + regsub {^[.]/} $f "" f + $data(fList) insert end $f + if [string match .* $f] { + incr top + } + } + } + + # The user probably doesn't want to see the . files. We adjust the view + # so that the listbox displays all the non-dot files + $data(fList) yview $top + + cd $appPWD +} + +# tkMotifFDialog_BrowseFList -- +# +# This procedure is called when the directory list is browsed +# (clicked-over) by the user. +# +# Arguments: +# w The pathname of the dialog box. +# +# Results: +# None. + proc tkMotifFDialog_BrowseDList {w} { upvar #0 [winfo name $w] data focus $data(dList) - if ![string compare [$data(dList) curselection] ""] { + if {![string compare [$data(dList) curselection] ""]} { return } set subdir [$data(dList) get [$data(dList) curselection]] - if ![string compare $subdir ""] { + if {![string compare $subdir ""]} { return } @@ -301,14 +525,15 @@ proc tkMotifFDialog_BrowseDList {w} { case $subdir { . { - set newSpec [file join $data(selectPath) $data(filter)] + set newSpec [tkFDialog_JoinFile $data(selectPath) $data(filter)] } .. { - set newSpec [file join [file dirname $data(selectPath)] \ + set newSpec [tkFDialog_JoinFile [file dirname $data(selectPath)] \ $data(filter)] } default { - set newSpec [file join $data(selectPath) $subdir $data(filter)] + set newSpec [tkFDialog_JoinFile [tkFDialog_JoinFile \ + $data(selectPath) $subdir] $data(filter)] } } @@ -316,14 +541,25 @@ proc tkMotifFDialog_BrowseDList {w} { $data(fEnt) insert 0 $newSpec } +# tkMotifFDialog_ActivateDList -- +# +# This procedure is called when the directory list is activated +# (double-clicked) by the user. +# +# Arguments: +# w The pathname of the dialog box. +# +# Results: +# None. + proc tkMotifFDialog_ActivateDList {w} { upvar #0 [winfo name $w] data - if ![string compare [$data(dList) curselection] ""] { + if {![string compare [$data(dList) curselection] ""]} { return } set subdir [$data(dList) get [$data(dList) curselection]] - if ![string compare $subdir ""] { + if {![string compare $subdir ""]} { return } @@ -337,14 +573,14 @@ proc tkMotifFDialog_ActivateDList {w} { set newDir [file dirname $data(selectPath)] } default { - set newDir [file join $data(selectPath) $subdir] + set newDir [tkFDialog_JoinFile $data(selectPath) $subdir] } } set data(selectPath) $newDir tkMotifFDialog_Update $w - if [string compare $subdir ..] { + if {[string compare $subdir ..]} { $data(dList) selection set 0 $data(dList) activate 0 } else { @@ -353,43 +589,78 @@ proc tkMotifFDialog_ActivateDList {w} { } } +# tkMotifFDialog_BrowseFList -- +# +# This procedure is called when the file list is browsed +# (clicked-over) by the user. +# +# Arguments: +# w The pathname of the dialog box. +# +# Results: +# None. + proc tkMotifFDialog_BrowseFList {w} { upvar #0 [winfo name $w] data focus $data(fList) - if ![string compare [$data(fList) curselection] ""] { + if {![string compare [$data(fList) curselection] ""]} { return } set data(selectFile) [$data(fList) get [$data(fList) curselection]] - if ![string compare $data(selectFile) ""] { + if {![string compare $data(selectFile) ""]} { return } $data(dList) selection clear 0 end $data(fEnt) delete 0 end - $data(fEnt) insert 0 [file join $data(selectPath) $data(filter)] + $data(fEnt) insert 0 [tkFDialog_JoinFile $data(selectPath) $data(filter)] $data(fEnt) xview end $data(sEnt) delete 0 end - $data(sEnt) insert 0 [file join $data(selectPath) $data(selectFile)] + $data(sEnt) insert 0 [tkFDialog_JoinFile $data(selectPath) \ + $data(selectFile)] $data(sEnt) xview end } +# tkMotifFDialog_ActivateFList -- +# +# This procedure is called when the file list is activated +# (double-clicked) by the user. +# +# Arguments: +# w The pathname of the dialog box. +# +# Results: +# None. + proc tkMotifFDialog_ActivateFList {w} { upvar #0 [winfo name $w] data - if ![string compare [$data(fList) curselection] ""] { + if {![string compare [$data(fList) curselection] ""]} { return } set data(selectFile) [$data(fList) get [$data(fList) curselection]] - if ![string compare $data(selectFile) ""] { + if {![string compare $data(selectFile) ""]} { return } else { tkMotifFDialog_ActivateSEnt $w } } +# tkMotifFDialog_ActivateFEnt -- +# +# This procedure is called when the user presses Return inside +# the "filter" entry. It updates the dialog according to the +# text inside the filter entry. +# +# Arguments: +# w The pathname of the dialog box. +# +# Results: +# None. + proc tkMotifFDialog_ActivateFEnt {w} { upvar #0 [winfo name $w] data @@ -400,34 +671,18 @@ proc tkMotifFDialog_ActivateFEnt {w} { tkMotifFDialog_Update $w } -proc tkMotifFDialog_InterpFilter {w} { - upvar #0 [winfo name $w] data - - set text [string trim [$data(fEnt) get]] - # Perform tilde substitution - # - if ![string compare [string index $text 0] ~] { - set list [file split $text] - set tilde [lindex $list 0] - catch { - set tilde [glob $tilde] - } - set text [eval file join [concat $tilde [lrange $list 1 end]]] - } - - set resolved [file join [file dirname $text] [file tail $text]] - - if [file isdirectory $resolved] { - set dir $resolved - set fil $data(filter) - } else { - set dir [file dirname $resolved] - set fil [file tail $resolved] - } - - return [list $dir $fil] -} - +# tkMotifFDialog_ActivateSEnt -- +# +# This procedure is called when the user presses Return inside +# the "selection" entry. It sets the tkPriv(selectFilePath) global +# variable so that the vwait loop in tkMotifFDialog will be +# terminated. +# +# Arguments: +# w The pathname of the dialog box. +# +# Results: +# None. proc tkMotifFDialog_ActivateSEnt {w} { global tkPriv @@ -437,7 +692,6 @@ proc tkMotifFDialog_ActivateSEnt {w} { set selectFile [file tail $selectFilePath] set selectPath [file dirname $selectFilePath] - if {![string compare $selectFilePath ""]} { tkMotifFDialog_FilterCmd $w return @@ -450,32 +704,32 @@ proc tkMotifFDialog_ActivateSEnt {w} { return } - if [string compare [file pathtype $selectFilePath] "absolute"] { + if {[string compare [file pathtype $selectFilePath] "absolute"]} { tk_messageBox -icon warning -type ok \ -message "\"$selectFilePath\" must be an absolute pathname" return } - if ![file exists $selectPath] { + if {![file exists $selectPath]} { tk_messageBox -icon warning -type ok \ -message "Directory \"$selectPath\" does not exist." return } - if ![file exists $selectFilePath] { - if ![string compare $data(type) open] { + if {![file exists $selectFilePath]} { + if {![string compare $data(type) open]} { tk_messageBox -icon warning -type ok \ -message "File \"$selectFilePath\" does not exist." return } } else { - if ![string compare $data(type) save] { + if {![string compare $data(type) save]} { set message [format %s%s \ "File \"$selectFilePath\" already exists.\n\n" \ "Replace existing file?"] set answer [tk_messageBox -icon warning -type yesno \ -message $message] - if ![string compare $answer "no"] { + if {![string compare $answer "no"]} { return } } @@ -507,75 +761,6 @@ proc tkMotifFDialog_CancelCmd {w} { set tkPriv(selectPath) "" } -# tkMotifFDialog_Update -# -# Load the files and synchronize the "filter" and "selection" fields -# boxes. -# -# popup: -# If this is true, then update the selection field according to the -# "-selection" flag -# -proc tkMotifFDialog_Update {w} { - upvar #0 [winfo name $w] data - - $data(fEnt) delete 0 end - $data(fEnt) insert 0 [file join $data(selectPath) $data(filter)] - $data(sEnt) delete 0 end - $data(sEnt) insert 0 [file join $data(selectPath) $data(selectFile)] - - tkMotifFDialog_LoadFiles $w -} - -proc tkMotifFDialog_LoadFiles {w} { - upvar #0 [winfo name $w] data - - $data(dList) delete 0 end - $data(fList) delete 0 end - - set appPWD [pwd] - if [catch { - cd $data(selectPath) - }] { - cd $appPWD - - $data(dList) insert end ".." - return - } - - # Make the dir list - # - foreach f [lsort -command tclSortNoCase [glob -nocomplain .* *]] { - if [file isdir $f] { - $data(dList) insert end $f - } - } - # Make the file list - # - if ![string compare $data(filter) *] { - set files [lsort -command tclSortNoCase [glob -nocomplain .* *]] - } else { - set files [lsort -command tclSortNoCase \ - [glob -nocomplain $data(filter)]] - } - - set top 0 - foreach f $files { - if ![file isdir $f] { - $data(fList) insert end $f - if [string match .* $f] { - incr top - } - } - } - - # The user probably doesn't want to see the . files. We adjust the view - # so that the listbox displays all the non-dot files - $data(fList) yview $top - - cd $appPWD -} - proc tkListBoxKeyAccel_Set {w} { bind Listbox <Any-KeyPress> "" bind $w <Destroy> "tkListBoxKeyAccel_Unset $w" @@ -590,6 +775,20 @@ proc tkListBoxKeyAccel_Unset {w} { catch {unset tkPriv(lbAccel,$w,afterId)} } +# tkListBoxKeyAccel_Key-- +# +# This procedure maintains a list of recently entered keystrokes +# over a listbox widget. It arranges an idle event to move the +# selection of the listbox to the entry that begins with the +# keystrokes. +# +# Arguments: +# w The pathname of the listbox. +# key The key which the user just pressed. +# +# Results: +# None. + proc tkListBoxKeyAccel_Key {w key} { global tkPriv diff --git a/mac/MW_TkHeader.pch b/mac/MW_TkHeader.pch index 7b7e2a4..a049f62 100644 --- a/mac/MW_TkHeader.pch +++ b/mac/MW_TkHeader.pch @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) MW_TkHeader.pch 1.26 97/11/20 19:37:29 + * SCCS: @(#) MW_TkHeader.pch 1.29 98/02/18 16:23:13 */ /* @@ -31,42 +31,13 @@ #pragma precompile_target "MW_TkHeader68K" #endif -/* - * Macintosh Tcl must be compiled with certain compiler options to - * ensure that it will work correctly. The following pragmas are - * used to ensure that those options are set correctly. An error - * will occur at compile time if they are not set correctly. - */ +#include "tclMacCommonDefines.h" -#if !__option(enumsalwaysint) -#error Tcl requires the Metrowerks setting "Enums always ints". -#endif - -#if !defined(__POWERPC__) -#if !__option(far_data) -#error Tcl requires the Metrowerks setting "Far data". -#endif -#endif - -#if !defined(__POWERPC__) -#if !__option(fourbyteints) -#error Tcl requires the Metrowerks setting "4 byte ints". -#endif -#endif - -#if !defined(__POWERPC__) -#if !__option(IEEEdoubles) -#error Tcl requires the Metrowerks setting "8 byte doubles". -#endif +#ifdef TCL_DEBUG +#define TK_TEST #endif /* - * The define is used most everywhere to tell Tk (or any Tk - * extensions) that we are compiling for the Macintosh platform. - */ -#define MAC_TCL - -/* * The following defines are for the Xlib.h file to force * it to generate prototypes in the way we need it. This is * defined here in case X.h & company are ever included before @@ -77,47 +48,6 @@ #define NeedWidePrototypes 0 /* - * The following defines control the behavior of the Macintosh - * Universial Headers. - */ - -#define SystemSevenOrLater 1 -#define STRICT_CONTROLS 0 -#define STRICT_WINDOWS 0 - -/* - * The appearance manager has not yet been shiped by Apple (10/29/97). - * It's currently in beta testing which is why we were able to write - * some code that depends on it. If you have access to the appearance - * manager you can define the symbol HAVE_APPEARANCE below to compile - * the code that uses the new appearance manager. - */ - -/* #define HAVE_APPEARANCE 1 */ - -/* - * Define the following symbol if you want - * comprehensive debugging turned on. - */ - -/* #define TCL_DEBUG */ - -#ifdef TCL_DEBUG -# define TCL_MEM_DEBUG -# define TK_TEST -# define TCL_TEST -#endif - -/* - * Apple's Universal Headers 2.0 & 3.0 change alot of names and constants. - * We will switch to the new names as soon as we can be reasonably sure the - * number of people with older versions of CodeWarrior, who will then not be - * able to build Tcl/Tk, is negligible. - */ - -#define OLDROUTINENAMES 1 - -/* * Place any includes below that will are needed by the majority of the * and is OK to be in any file in the system. */ @@ -1,10 +1,11 @@ -Tk 8.0 for Macintosh +Tk 8.1 for Macintosh -by Ray Johnson +by Ray Johnson and Jim Ingham Sun Microsystems Laboratories rjohnson@eng.sun.com +jim.ingham@sun.com -SCCS: @(#) README 1.30 97/11/20 22:06:57 +SCCS: @(#) README 1.33 98/02/18 11:23:12 1. Introduction --------------- @@ -18,50 +19,12 @@ directory. 2. What's new? ------------- -Native Look & Feel!!! We now try really hard to support the -Macintosh Look & Feel with Tcl/Tk 8.0. We aren't finished but -it look pretty good. Let me know what are the most "un-mac like" -problems and I'll fix them as quickly as I can. - -The button, checkbutton, radiobutton, and scrollbar widgets actually -use the Mac toolbox controls. This means that they will track the -look&feel if you use extension that change the appearance of -applications (like Aaron.) We also use "system" colors so the default -backgrounds etc. will also change colors. We plan to support this -feature - so let me know if something doesn't work quite right. -Unfortunantly, we are not able to change the colors of buttons under -MacOS 8. We are working on a solution to this. -In the meantime, if you really must have colored buttons, turn off the -"System-wide platinum appearance" option in the Appearance Control Panel, -and you will get the System 7, colorable, buttons back. - -We also now support native menus! By using the new -menu option -on toplevels you can have a menubar that is cross platform. You -can also place Tk menus in the Apple and Help menus! Check out -the documentation for more details. Syd Polk <icepick@eng.sun.com> is -the author of the new menu code. Feel free to contact him if you -have questions or comments about the menu mechanism. - -The "tk_messageBox" command on the Macintosh is now much more -mac-like. I'll probably still need to adjust this more - but it -looks a hell of alot better than it did before. - -I've also added a command that allows you to get more native window -styles. However, we have yet to decide on a cross platform solution -to the problem of varying window styles. None the less, I thought -it would be use full to add the capability in an unsupported means -to tide you over until a better solution is available. The command -is called "unsupported1". It can be used in the following way: - - toplevel .foo; unsupported1 style .foo zoomDocProc - -The above command will create a document window with a zoom box. -Type "unsupported1 style . ???" to get a list of the supported -styles. The command works like "wm overrideredirect" - you must -make the call before the window is mapped. - -As always - report the bugs you find - including asthetic ones -in the look & feel of widgets. +All the widgets will now display internationalized text! + +The widget configuration package has been changed to support the new object +model introduced with the 8.0 compiler. For now the old configuration +package is retained, and in fact, only the menu and button widgets use +the new package. 3. Mac specific features ------------------------ @@ -94,8 +57,8 @@ pointers to where you can find more information about the feature. Mac version of Tk allows you to use several Mac specific icons. See the GetBitmap.3 man page for a complete list. -* The send command does not yet work on the Macintosh. We hope to - have it available in Tk 8.1. +* The send command works among interpreters in the same application. We hope to + have the complete implementation available in Tk 8.1. * The -use and -container options almost work. The focus bugs that were in Tk8.0 final have been fixed. But there are still some @@ -109,7 +72,7 @@ Macintosh Tk is distributed in three different forms. This should make it easier to only download what you need. The packages are as follows: -mactk8.0.sea.hqx +mactk8.1.sea.hqx This distribution is a "binary" only release. It contains an installer program that will install a 68k, PowerPC, or Fat @@ -117,13 +80,13 @@ mactk8.0.sea.hqx the Tcl & Tk libraries in the Extensions folder inside your System Folder. (No "INIT"'s or Control Pannels are installed.) -mactcltk-full-8.0.sea.hqx +mactcltk-full-8.1.sea.hqx This release contains the full release of Tcl and Tk for the Macintosh plus the More Files package on which Macintosh Tcl and Tk rely. -mactk-source-8.0.sea.hqx +mactk-source-8.1.sea.hqx This release contains the complete source to Tk for the Macintosh In addition, Metrowerks CodeWarrior libraries and project files @@ -172,44 +135,36 @@ available (see below). In order to compile Macintosh Tk you must have the following items: - CodeWarrior Pro 1 or higher (CodeWarrior release 9 or higher can work - and we have project files, but we are depricating support) - Mac Tcl 8.0 (source) + CodeWarrior Pro 2 or higher + Mac Tcl 8.1 (source) (which requires More Files 1.4.2 or 1.4.3) - Mac Tk 8.0 (source) + Mac Tk 8.1 (source) The project files included with the Mac Tcl source should work fine. The only thing you may need to update are the access paths. -As with Tcl, there is something in the initial release of the CW Pro 2 -linker that rendersthe CFM68K version of Wish very unstable. I am -working with Metrowerks to resolve the issue. +As with Tcl, you need to upgrade to the 2.0.1 version of the C +compilers or later to build the CFM68K version of Tcl/Tk. Special notes: * Check out the file bugs.doc for information about known bugs. * We are starting to support the new Appearance Manager that shipped - with MacOS 8. At this point, the only feature that we are using is - the API to Iconify windows (so that wm iconify will work). However, - as of the release of Tk8.0p1, the SDK from Apple is still in Beta, so - we cannot ship it. So support for the Appearance Manager is turned off - in the source version of Tk8.0p1. - If you want to build Tk, and want to get the Appearance Manager features, - then need to do the following: - 1) get the SDK from Apple - 2) Uncomment the #define HAVE_APPEARANCE line in tk8.0:mac:MW_TkHeader.pch - 3) Add the Appearance.lib to tk8.0:mac:TkShells.¼, and put the include - directory of the SDK on your path in this project, and TkLibraries.¼. + with MacOS 8. wm iconify uses it, and the coloring of the + backgrounds of radiobuttons & checkbuttons now works under + Appearance. Tk correctly checks the Gestalt for Appearance, so you + do not have to install it on your target machines. However, you do + have to have the header and stub files to build it. These come with + CWPro 2, and are also available now from Apple. + 7. About Dialog --------------- -There is now a way to replace the default dialog box for the Wish -application. If you create the tcl procedure "tkAboutDialog" it will -be called instead of creating the default dialog box. Your procedure -is then responsible for displaying a window, removing it, etc. This -interface is experimental and may change in the future - tell me what -you think of it. +The prefered method for replacing the about dialog is to replace the +main menubar of the application, using the -menu option for the "." +window. Then add a cascade called .mainMenu.apple to your mainMenu, +and you can put an about item in here WITH YOUR OWN LABEL! 8. Apple Events --------------- diff --git a/mac/bugs.doc b/mac/bugs.doc index e522d8c..5e5a3e8 100644 --- a/mac/bugs.doc +++ b/mac/bugs.doc @@ -4,7 +4,7 @@ by Ray Johnson Sun Microsystems Laboratories rjohnson@eng.sun.com -SCCS: @(#) bugs.doc 1.10 97/11/03 17:16:00 +SCCS: @(#) bugs.doc 1.11 98/02/18 13:24:41 We are now very close to passing the test suite for Tk. We are very interested in finding remaining bugs that still linger. Please let us @@ -26,7 +26,11 @@ Known bugs: container, so you can watch that instead. All the focus bugs in Tk8.0 have been fixed, however. -* The send command is not yet implemented. +* The send command is only implemented within the same app. + +* You cannot color buttons, and the indicators for radiobuttons and + checkbuttons under Appearance. They will always use the current + Theme color. But, then, you are not supposed to... * Drawing is not really correct. This shows up mostly in the canvas when line widths are greater than one. Unfortunantly, this will not diff --git a/mac/tkMac.h b/mac/tkMac.h index ce41c81..87c005a 100644 --- a/mac/tkMac.h +++ b/mac/tkMac.h @@ -8,13 +8,15 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkMacInt.h 1.58 97/05/06 16:45:18 + * SCCS: %Z% %M% %I% %E% %U% */ #ifndef _TKMAC #define _TKMAC #include <Windows.h> +#include <QDOffscreen.h> +#include "tkInt.h" /* * "export" is a MetroWerks specific pragma. It flags the linker that @@ -32,21 +34,46 @@ EXTERN QDGlobalsPtr tcl_macQdPtr; +/* + * Structures and function types for handling Netscape-type in process + * embedding where Tk does not control the top-level + */ +typedef int (Tk_MacEmbedRegisterWinProc) (int winID, Tk_Window window); +typedef GWorldPtr (Tk_MacEmbedGetGrafPortProc) (Tk_Window window); +typedef int (Tk_MacEmbedMakeContainerExistProc) (Tk_Window window); +typedef void (Tk_MacEmbedGetClipProc) (Tk_Window window, RgnHandle rgn); +typedef void (Tk_MacEmbedGetOffsetInParentProc) (Tk_Window window, Point *ulCorner); + /* - * The following functions are needed to create a shell, and so they must be exported - * from the Tk library. However, these are not the final form of these interfaces, so - * they are not currently supported as public interfaces. + * Mac Specific functions that are available to extension writers. */ + +EXTERN void Tk_MacSetEmbedHandler _ANSI_ARGS_(( + Tk_MacEmbedRegisterWinProc *registerWinProcPtr, + Tk_MacEmbedGetGrafPortProc *getPortProcPtr, + Tk_MacEmbedMakeContainerExistProc *containerExistProcPtr, + Tk_MacEmbedGetClipProc *getClipProc, + Tk_MacEmbedGetOffsetInParentProc *getOffsetProc)); + +EXTERN void Tk_MacTurnOffMenus _ANSI_ARGS_ (()); +EXTERN void Tk_MacTkOwnsCursor _ANSI_ARGS_ ((int tkOwnsIt)); + /* * These functions are currently in tkMacInt.h. They are just copied over here * so they can be exported. */ EXTERN void TkMacInitMenus _ANSI_ARGS_((Tcl_Interp *interp)); -EXTERN void TkMacInitAppleEvents _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN void TkMacInitAppleEvents _ANSI_ARGS_((Tcl_Interp *interp)); + +EXTERN int TkMacConvertEvent _ANSI_ARGS_((EventRecord *eventPtr)); +EXTERN int TkMacConvertTkEvent _ANSI_ARGS_((EventRecord *eventPtr, + Window window)); +EXTERN void TkGenWMConfigureEvent _ANSI_ARGS_((Tk_Window tkwin, + int x, int y, int width, int height, int flags)); +EXTERN void TkMacInvalClipRgns _ANSI_ARGS_((TkWindow *winPtr)); -EXTERN int TkMacConvertEvent _ANSI_ARGS_((EventRecord *eventPtr)); #pragma export reset diff --git a/mac/tkMacAppInit.c b/mac/tkMacAppInit.c index ebc2c18..226127f 100644 --- a/mac/tkMacAppInit.c +++ b/mac/tkMacAppInit.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkMacAppInit.c 1.35 97/07/28 11:18:55 + * SCCS: @(#) tkMacAppInit.c 1.36 97/11/07 21:20:46 */ #include <Gestalt.h> @@ -108,7 +108,7 @@ main( * * Results: * Returns a standard Tcl completion code, and leaves an error - * message in interp->result if an error occurs. + * message in the interp's result if an error occurs. * * Side effects: * Depends on the startup script. @@ -307,7 +307,7 @@ SetupMainInterp( return TCL_OK; error: - panic(interp->result); + panic(Tcl_GetStringResult(interp)); return TCL_ERROR; } diff --git a/mac/tkMacBitmap.c b/mac/tkMacBitmap.c index fd08193..6571d43 100644 --- a/mac/tkMacBitmap.c +++ b/mac/tkMacBitmap.c @@ -3,12 +3,12 @@ * * This file handles the implementation of native bitmaps. * - * Copyright (c) 1996 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkMacBitmap.c 1.4 96/12/13 11:13:16 + * SCCS: @(#) tkMacBitmap.c 1.7 98/01/22 17:00:58 */ #include "tkPort.h" @@ -82,7 +82,7 @@ static BuiltInIcon builtInIcons[] = { * * Results: * A standard Tcl result. If an error occurs then TCL_ERROR is - * returned and a message is left in interp->result. + * returned and a message is left in the interp's result. * * Side effects: * "Name" is entered into the bitmap table and may be used from @@ -128,7 +128,7 @@ TkpDefineNativeBitmaps() * * Results: * A standard Tcl result. If an error occurs then TCL_ERROR is - * returned and a message is left in interp->result. + * returned and a message is left in the interp's result. * * Side effects: * "Name" is entered into the bitmap table and may be used from @@ -188,7 +188,7 @@ TkpCreateNativeBitmap( * * Results: * A standard Tcl result. If an error occurs then TCL_ERROR is - * returned and a message is left in interp->result. + * returned and a message is left in the interp's result. * * Side effects: * "Name" is entered into the bitmap table and may be used from @@ -210,19 +210,28 @@ TkpGetNativeAppBitmap( GWorldPtr destPort; Rect destRect; Handle resource; - int type; + int type, destWrote; + Str255 nativeName; + + /* + * macRoman is the encoding that the resource fork uses. + */ + + Tcl_UtfToExternal(NULL, Tcl_GetEncoding(NULL, "macRoman"), name, + strlen(name), 0, NULL, + (char *) &nativeName[1], + 255, NULL, &destWrote, NULL); /* Internalize native */ + nativeName[0] = destWrote; - c2pstr(name); - resource = GetNamedResource('cicn', (StringPtr) name); + resource = GetNamedResource('cicn', nativeName); if (resource != NULL) { type = TYPE3; } else { - resource = GetNamedResource('ICON', (StringPtr) name); + resource = GetNamedResource('ICON', nativeName); if (resource != NULL) { type = TYPE2; } } - p2cstr((StringPtr) name); if (resource == NULL) { return NULL; diff --git a/mac/tkMacButton.c b/mac/tkMacButton.c index 767baff..287c2ef 100644 --- a/mac/tkMacButton.c +++ b/mac/tkMacButton.c @@ -2,20 +2,21 @@ * tkMacButton.c -- * * This file implements the Macintosh specific portion of the - * button widgets. + * 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. * - * SCCS: @(#) tkMacButton.c 1.18 97/11/20 18:27:21 + * SCCS: @(#) tkMacButton.c 1.20 98/02/18 10:48:42 */ #include "tkButton.h" #include "tkMacInt.h" #include <Controls.h> #include <LowMem.h> +#include <Appearance.h> /* * Some defines used to control what type of control is drawn. @@ -43,18 +44,36 @@ static CCTabHandle radioTabHandle; static PixMapHandle oldPixPtr; /* + * These functions are used when Appearance is present. + * By embedding all our controls in a userPane control, + * we can color the background of the text in radiobuttons + * and checkbuttons. Thanks to Peter Gontier of Apple DTS + * for help on this one. + */ + +static ControlRef userPaneHandle; +static RGBColor gUserPaneBackground = { ~0, ~0, ~0}; +static pascal OSErr SetUserPaneDrawProc(ControlRef control, + ControlUserPaneDrawProcPtr upp); +static pascal OSErr SetUserPaneSetUpSpecialBackgroundProc(ControlRef control, + ControlUserPaneBackgroundProcPtr upp); +static pascal void UserPaneDraw(ControlRef control, ControlPartCode cpc); +static pascal void UserPaneBackgroundProc(ControlHandle, + ControlBackgroundPtr info); + +/* * Forward declarations for procedures defined later in this file: */ -static int UpdateControlColors _ANSI_ARGS_((TkButton *butPtr, - ControlRef controlHandle, CCTabHandle ccTabHandle, - RGBColor *saveColorPtr)); -static void DrawBufferedControl _ANSI_ARGS_((TkButton *butPtr, - GWorldPtr destPort)); -static void ChangeBackgroundWindowColor _ANSI_ARGS_(( - WindowRef macintoshWindow, RGBColor rgbColor, - RGBColor *oldColor)); -static void ButtonExitProc _ANSI_ARGS_((ClientData clientData)); +static int UpdateControlColors _ANSI_ARGS_((TkButton *butPtr, + ControlRef controlHandle, CCTabHandle ccTabHandle, + RGBColor *saveColorPtr)); +static void DrawBufferedControl _ANSI_ARGS_((TkButton *butPtr, + GWorldPtr destPort)); +static void ChangeBackgroundWindowColor _ANSI_ARGS_(( + WindowRef macintoshWindow, RGBColor rgbColor, + RGBColor *oldColor)); +static void ButtonExitProc _ANSI_ARGS_((ClientData clientData)); /* * The class procedure table for the button widgets. @@ -137,15 +156,16 @@ TkpDisplayButton( } border = butPtr->normalBorder; - if ((butPtr->state == tkDisabledUid) && (butPtr->disabledFg != NULL)) { + if ((butPtr->state == STATE_DISABLED) && (butPtr->disabledFg != NULL)) { gc = butPtr->disabledGC; - } else if ((butPtr->type == TYPE_BUTTON) && (butPtr->state == tkActiveUid)) { + } else if ((butPtr->type == TYPE_BUTTON) + && (butPtr->state == STATE_ACTIVE)) { gc = butPtr->activeTextGC; border = butPtr->activeBorder; } else { gc = butPtr->normalTextGC; } - if ((butPtr->flags & SELECTED) && (butPtr->state != tkActiveUid) + if ((butPtr->flags & SELECTED) && (butPtr->state != STATE_ACTIVE) && (butPtr->selectBorder != NULL) && !butPtr->indicatorOn) { border = butPtr->selectBorder; } @@ -173,9 +193,18 @@ TkpDisplayButton( pixmap = Tk_GetPixmap(butPtr->display, Tk_WindowId(tkwin), Tk_Width(tkwin), Tk_Height(tkwin), Tk_Depth(tkwin)); - Tk_Fill3DRectangle(tkwin, pixmap, butPtr->normalBorder, 0, 0, - Tk_Width(tkwin), Tk_Height(tkwin), 0, TK_RELIEF_FLAT); - + /* + * See the comment in UpdateControlColors as to why we use the + * highlightbackground for the border of Macintosh buttons. + */ + + if (butPtr->type == TYPE_BUTTON) { + Tk_Fill3DRectangle(tkwin, pixmap, butPtr->highlightBorder, 0, 0, + Tk_Width(tkwin), Tk_Height(tkwin), 0, TK_RELIEF_FLAT); + } else { + Tk_Fill3DRectangle(tkwin, pixmap, butPtr->normalBorder, 0, 0, + Tk_Width(tkwin), Tk_Height(tkwin), 0, TK_RELIEF_FLAT); + } if (butPtr->type == TYPE_LABEL) { drawType = DRAW_LABEL; @@ -274,7 +303,7 @@ TkpDisplayButton( * must temporarily modify the GC. */ - if ((butPtr->state == tkDisabledUid) + if ((butPtr->state == STATE_DISABLED) && ((butPtr->disabledFg == NULL) || (butPtr->image != NULL))) { if ((butPtr->flags & SELECTED) && !butPtr->indicatorOn && (butPtr->selectBorder != NULL)) { @@ -361,7 +390,7 @@ TkpComputeButtonGeometry( * highlight width as there is also one pixel of spacing. */ - if (butPtr->defaultState != tkDisabledUid) { + if (butPtr->defaultState != DEFAULT_DISABLED) { butPtr->inset += butPtr->highlightWidth; } butPtr->indicatorSpace = 0; @@ -388,8 +417,8 @@ TkpComputeButtonGeometry( } else { Tk_FreeTextLayout(butPtr->textLayout); butPtr->textLayout = Tk_ComputeTextLayout(butPtr->tkfont, - butPtr->text, -1, butPtr->wrapLength, butPtr->justify, 0, - &butPtr->textWidth, &butPtr->textHeight); + Tcl_GetString(butPtr->textPtr), -1, butPtr->wrapLength, + butPtr->justify, 0, &butPtr->textWidth, &butPtr->textHeight); width = butPtr->textWidth; height = butPtr->textHeight; @@ -491,36 +520,74 @@ DrawBufferedControl( /* * Create a dummy window that we can draw to. We will - * actually replace this windows bitmap with a the one + * actually replace this window's bitmap with the one * we want to draw to at a later time. This window and * the data structures attached to it are only deallocated * on exit of the application. */ - - windowRef = NewCWindow(NULL, &geometry, "\pempty", false, + + windowRef = NewCWindow(NULL, &geometry, "\pempty", false, zoomDocProc, (WindowRef) -1, true, 0); if (windowRef == NULL) { panic("Can't allocate buffer window."); } - + /* * Now add the three standard controls to hidden window. We * only create one of each and reuse them for every widget in * Tk. + * Under Appearance, we have to embed the controls in a UserPane + * control, so that we can color the background text in + * radiobuttons and checkbuttons. */ SetPort(windowRef); - buttonHandle = NewControl(windowRef, &geometry, "\p", - false, 1, 0, 1, pushButProc, (SInt32) 0); - checkHandle = NewControl(windowRef, &geometry, "\p", - false, 1, 0, 1, checkBoxProc, (SInt32) 0); - radioHandle = NewControl(windowRef, &geometry, "\p", - false, 1, 0, 1, radioButProc, (SInt32) 0); - ((CWindowPeek) windowRef)->visible = true; - - buttonTabHandle = (CCTabHandle) NewHandle(sizeof(CtlCTab)); - checkTabHandle = (CCTabHandle) NewHandle(sizeof(CtlCTab)); - radioTabHandle = (CCTabHandle) NewHandle(sizeof(CtlCTab)); + + if (TkMacHaveAppearance()) { + + OSErr err; + ControlRef dontCare; + + /* Adding UserPaneBackgroundProcs to the root control does + * not seem to work, so we have to add another UserPane to + * the root control. + */ + + err = CreateRootControl(windowRef, &dontCare); + if (err != noErr) { + panic("Can't create root control in DrawBufferedControl"); + } + + userPaneHandle = NewControl(windowRef, &geometry, "\p", + true, kControlSupportsEmbedding|kControlHasSpecialBackground, + 0, 1, kControlUserPaneProc, (SInt32) 5); + SetUserPaneSetUpSpecialBackgroundProc(userPaneHandle, + UserPaneBackgroundProc); + SetUserPaneDrawProc(userPaneHandle, UserPaneDraw); + + buttonHandle = NewControl(windowRef, &geometry, "\p", + false, 1, 0, 1, kControlPushButtonProc, (SInt32) 6); + EmbedControl(buttonHandle, userPaneHandle); + checkHandle = NewControl(windowRef, &geometry, "\p", + false, 1, 0, 1, kControlCheckBoxProc, (SInt32) 7); + EmbedControl(checkHandle, userPaneHandle); + radioHandle = NewControl(windowRef, &geometry, "\p", + false, 1, 0, 1, kControlRadioButtonProc, (SInt32) 8); + EmbedControl(radioHandle, userPaneHandle); + ((CWindowPeek) windowRef)->visible = true; + } else { + buttonHandle = NewControl(windowRef, &geometry, "\p", + false, 1, 0, 1, pushButProc, (SInt32) 0); + checkHandle = NewControl(windowRef, &geometry, "\p", + false, 1, 0, 1, checkBoxProc, (SInt32) 0); + radioHandle = NewControl(windowRef, &geometry, "\p", + false, 1, 0, 1, radioButProc, (SInt32) 0); + ((CWindowPeek) windowRef)->visible = true; + + buttonTabHandle = (CCTabHandle) NewHandle(sizeof(CtlCTab)); + checkTabHandle = (CCTabHandle) NewHandle(sizeof(CtlCTab)); + radioTabHandle = (CCTabHandle) NewHandle(sizeof(CtlCTab)); + } /* * Remove our window from the window list. This way our @@ -556,10 +623,29 @@ DrawBufferedControl( } /* + * Now swap in the passed in GWorld for the portBits of our fake + * window. We also adjust various fields in the WindowRecord to make + * the system think this is a normal window. + * Note, we can use DrawControlInCurrentPort under Appearance, so we don't + * need to swap pixmaps. + */ + + if (!TkMacHaveAppearance()) { + ((CWindowPeek) windowRef)->port.portPixMap = destPort->portPixMap; + } + + ((CWindowPeek) windowRef)->port.portRect = destPort->portRect; + RectRgn(((CWindowPeek) windowRef)->port.visRgn, &destPort->portRect); + RectRgn(((CWindowPeek) windowRef)->strucRgn, &destPort->portRect); + RectRgn(((CWindowPeek) windowRef)->updateRgn, &destPort->portRect); + RectRgn(((CWindowPeek) windowRef)->contRgn, &destPort->portRect); + PortChanged(windowRef); + + /* * Set up control in hidden window to match what we need - * to draw in the buffered window. + * to draw in the buffered window. */ - + switch (butPtr->type) { case TYPE_BUTTON: controlHandle = buttonHandle; @@ -574,21 +660,38 @@ DrawBufferedControl( ccTabHandle = checkTabHandle; break; } + (**controlHandle).contrlRect.left = butPtr->inset; (**controlHandle).contrlRect.top = butPtr->inset; (**controlHandle).contrlRect.right = Tk_Width(butPtr->tkwin) - butPtr->inset; (**controlHandle).contrlRect.bottom = Tk_Height(butPtr->tkwin) - butPtr->inset; - if ((**controlHandle).contrlVis != 255) { - (**controlHandle).contrlVis = 255; - } + + /* + * Setting the control visibility by hand does not + * seem to work under Appearance. + */ + + if (TkMacHaveAppearance()) { + SetControlVisibility(controlHandle, true, false); + (**userPaneHandle).contrlRect.left = 0; + (**userPaneHandle).contrlRect.top = 0; + (**userPaneHandle).contrlRect.right = Tk_Width(butPtr->tkwin); + (**userPaneHandle).contrlRect.bottom = Tk_Height(butPtr->tkwin); + } else { + (**controlHandle).contrlVis = 255; + } + + + if (butPtr->flags & SELECTED) { (**controlHandle).contrlValue = 1; } else { (**controlHandle).contrlValue = 0; } - if (butPtr->state == tkActiveUid) { + + if (butPtr->state == STATE_ACTIVE) { switch (butPtr->type) { case TYPE_BUTTON: (**controlHandle).contrlHilite = kControlButtonPart; @@ -600,27 +703,13 @@ DrawBufferedControl( (**controlHandle).contrlHilite = kControlCheckBoxPart; break; } - } else if (butPtr->state == tkDisabledUid) { + } else if (butPtr->state == STATE_DISABLED) { (**controlHandle).contrlHilite = kControlInactivePart; } else { (**controlHandle).contrlHilite = kControlNoPart; } /* - * Now swap in the passed in GWorld for the portBits of our fake - * window. We also adjust various fields in the WindowRecord to make - * the system think this is a normal window. - */ - - ((CWindowPeek) windowRef)->port.portPixMap = destPort->portPixMap; - ((CWindowPeek) windowRef)->port.portRect = destPort->portRect; - RectRgn(((CWindowPeek) windowRef)->port.visRgn, &destPort->portRect); - RectRgn(((CWindowPeek) windowRef)->strucRgn, &destPort->portRect); - RectRgn(((CWindowPeek) windowRef)->updateRgn, &destPort->portRect); - RectRgn(((CWindowPeek) windowRef)->contRgn, &destPort->portRect); - PortChanged(windowRef); - - /* * Before we draw the control we must add the hidden window back to the * main window list. Otherwise, radiobuttons and checkbuttons will draw * incorrectly. I don't really know why - but clearly the control draw @@ -635,14 +724,41 @@ DrawBufferedControl( * to muck with the colors for the port & window to draw the control * with the proper Tk colors. If we need to we also draw a default * ring for buttons. + * Under Appearance, we draw the control directly into destPort, and + * just set the default control data. */ - SetPort(windowRef); + if (TkMacHaveAppearance()) { + SetPort((GrafPort *) destPort); + } else { + SetPort(windowRef); + } + windowColorChanged = UpdateControlColors(butPtr, controlHandle, ccTabHandle, &saveBackColor); - Draw1Control(controlHandle); - if ((butPtr->type == TYPE_BUTTON) && - (butPtr->defaultState == tkActiveUid)) { + + if ((butPtr->type == TYPE_BUTTON) && TkMacHaveAppearance()) { + Boolean isDefault; + + if (butPtr->defaultState == DEFAULT_ACTIVE) { + isDefault = true; + } else { + isDefault = false; + } + SetControlData(controlHandle, kControlNoPart, + kControlPushButtonDefaultTag, + sizeof(isDefault), (Ptr) &isDefault); + } + + if (TkMacHaveAppearance()) { + DrawControlInCurrentPort(userPaneHandle); + } else { + Draw1Control(controlHandle); + } + + if (!TkMacHaveAppearance() && + (butPtr->type == TYPE_BUTTON) && + (butPtr->defaultState == DEFAULT_ACTIVE)) { Rect box = (**controlHandle).contrlRect; RGBColor rgbColor; @@ -652,21 +768,139 @@ DrawBufferedControl( InsetRect(&box, -butPtr->highlightWidth, -butPtr->highlightWidth); FrameRoundRect(&box, 16, 16); } + if (windowColorChanged) { RGBColor dummyColor; ChangeBackgroundWindowColor(windowRef, saveBackColor, &dummyColor); } /* - * Clean up: remove the hidden window from the main window list. + * Clean up: remove the hidden window from the main window list, and + * hide the control we drew. */ + if (TkMacHaveAppearance()) { + SetControlVisibility(controlHandle, false, false); + } else { + (**controlHandle).contrlVis = 0; + } LMSetWindowList((WindowRef) ((CWindowPeek) windowRef)->nextWindow); } /* *-------------------------------------------------------------- * + * SetUserPaneDrawProc -- + * + * Utility function to add a UserPaneDrawProc + * to a userPane control. From MoreControls code + * from Apple DTS. + * + * Results: + * MacOS system error. + * + * Side effects: + * The user pane gets a new UserPaneDrawProc. + * + *-------------------------------------------------------------- + */ +pascal OSErr SetUserPaneDrawProc ( + ControlRef control, + ControlUserPaneDrawProcPtr upp) +{ + ControlUserPaneDrawUPP myControlUserPaneDrawUPP; + myControlUserPaneDrawUPP = NewControlUserPaneDrawProc(upp); + return SetControlData (control, + kControlNoPart, kControlUserPaneDrawProcTag, + sizeof(myControlUserPaneDrawUPP), + (Ptr) &myControlUserPaneDrawUPP); +} + +/* + *-------------------------------------------------------------- + * + * SetUserPaneSetUpSpecialBackgroundProc -- + * + * Utility function to add a UserPaneBackgroundProc + * to a userPane control + * + * Results: + * MacOS system error. + * + * Side effects: + * The user pane gets a new UserPaneBackgroundProc. + * + *-------------------------------------------------------------- + */ +pascal OSErr +SetUserPaneSetUpSpecialBackgroundProc( + ControlRef control, + ControlUserPaneBackgroundProcPtr upp) +{ + ControlUserPaneBackgroundUPP myControlUserPaneBackgroundUPP; + myControlUserPaneBackgroundUPP = NewControlUserPaneBackgroundProc(upp); + return SetControlData (control, kControlNoPart, + kControlUserPaneBackgroundProcTag, + sizeof(myControlUserPaneBackgroundUPP), + (Ptr) &myControlUserPaneBackgroundUPP); +} + +/* + *-------------------------------------------------------------- + * + * UserPaneDraw -- + * + * This function draws the background of the user pane that will + * lie under checkboxes and radiobuttons. + * + * Results: + * None. + * + * Side effects: + * The user pane gets updated to the current color. + * + *-------------------------------------------------------------- + */ +pascal void +UserPaneDraw( + ControlRef control, + ControlPartCode cpc) +{ + Rect contrlRect = (**control).contrlRect; + RGBBackColor (&gUserPaneBackground); + EraseRect (&contrlRect); +} + +/* + *-------------------------------------------------------------- + * + * UserPaneBackgroundProc -- + * + * This function sets up the background of the user pane that will + * lie under checkboxes and radiobuttons. + * + * Results: + * None. + * + * Side effects: + * The user pane background gets set to the current color. + * + *-------------------------------------------------------------- + */ + +pascal void +UserPaneBackgroundProc( + ControlHandle, + ControlBackgroundPtr info) +{ + if (info->colorDevice) { + RGBBackColor (&gUserPaneBackground); + } +} + +/* + *-------------------------------------------------------------- + * * UpdateControlColors -- * * This function will review the colors used to display @@ -674,6 +908,9 @@ DrawBufferedControl( * used we create a custom palette for the button, populate * with the colors for the button and install the palette. * + * Under Appearance, we just set the pointer that will be + * used by the UserPaneDrawProc. + * * Results: * None. * @@ -692,33 +929,50 @@ UpdateControlColors( { XColor *xcolor; - xcolor = Tk_3DBorderColor(butPtr->normalBorder); - - (**ccTabHandle).ccSeed = 0; - (**ccTabHandle).ccRider = 0; - (**ccTabHandle).ctSize = 3; - (**ccTabHandle).ctTable[0].value = cBodyColor; - TkSetMacColor(xcolor->pixel, - &(**ccTabHandle).ctTable[0].rgb); - (**ccTabHandle).ctTable[1].value = cTextColor; - TkSetMacColor(butPtr->normalFg->pixel, - &(**ccTabHandle).ctTable[1].rgb); - (**ccTabHandle).ctTable[2].value = cFrameColor; - TkSetMacColor(butPtr->highlightColorPtr->pixel, - &(**ccTabHandle).ctTable[2].rgb); - SetControlColor(controlHandle, ccTabHandle); - - if (((xcolor->pixel >> 24) != CONTROL_BODY_PIXEL) && - ((butPtr->type == TYPE_CHECK_BUTTON) || - (butPtr->type == TYPE_RADIO_BUTTON))) { - RGBColor newColor; + /* + * Under Appearance we cannot change the background of the + * button itself. However, the color we are setting is the color + * of the containing userPane. This will be the color that peeks + * around the rounded corners of the button. + * We make this the highlightbackground rather than the background, + * because if you color the background of a frame containing a + * button, you usually also color the highlightbackground as well, + * or you will get a thin grey ring around the button. + */ + + if (TkMacHaveAppearance() && (butPtr->type == TYPE_BUTTON)) { + xcolor = Tk_3DBorderColor(butPtr->highlightBorder); + } else { + xcolor = Tk_3DBorderColor(butPtr->normalBorder); + } + if (TkMacHaveAppearance()) { + TkSetMacColor(xcolor->pixel, &gUserPaneBackground); + } else { + (**ccTabHandle).ccSeed = 0; + (**ccTabHandle).ccRider = 0; + (**ccTabHandle).ctSize = 3; + (**ccTabHandle).ctTable[0].value = cBodyColor; + TkSetMacColor(xcolor->pixel, + &(**ccTabHandle).ctTable[0].rgb); + (**ccTabHandle).ctTable[1].value = cTextColor; + TkSetMacColor(butPtr->normalFg->pixel, + &(**ccTabHandle).ctTable[1].rgb); + (**ccTabHandle).ctTable[2].value = cFrameColor; + TkSetMacColor(butPtr->highlightColorPtr->pixel, + &(**ccTabHandle).ctTable[2].rgb); + SetControlColor(controlHandle, ccTabHandle); + if (((xcolor->pixel >> 24) != CONTROL_BODY_PIXEL) && + ((butPtr->type == TYPE_CHECK_BUTTON) || + (butPtr->type == TYPE_RADIO_BUTTON))) { + RGBColor newColor; - TkSetMacColor(xcolor->pixel, &newColor); - ChangeBackgroundWindowColor((**controlHandle).contrlOwner, - newColor, saveColorPtr); - return true; + TkSetMacColor(xcolor->pixel, &newColor); + ChangeBackgroundWindowColor((**controlHandle).contrlOwner, + newColor, saveColorPtr); + return true; + } } - + return false; } diff --git a/mac/tkMacClipboard.c b/mac/tkMacClipboard.c index 0c06f1d..1ae497c 100644 --- a/mac/tkMacClipboard.c +++ b/mac/tkMacClipboard.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkMacClipboard.c 1.18 97/05/01 15:41:17 + * SCCS: @(#) tkMacClipboard.c 1.19 97/11/07 21:21:42 */ #include "tkInt.h" @@ -32,7 +32,7 @@ * 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 interp->result. + * then an error message is left in the interp's result. * * Side effects: * None. diff --git a/mac/tkMacConfig.c b/mac/tkMacConfig.c new file mode 100644 index 0000000..83da6cf --- /dev/null +++ b/mac/tkMacConfig.c @@ -0,0 +1,45 @@ +/* + * tkMacConfig.c -- + * + * This module implements the Macintosh 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. + * + * SCCS: @(#) tkMacConfig.c 1.3 97/10/08 10:07:55 + */ + +#include "tk.h" +#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. */ + char *dbName, /* The option database name. */ + char *className) /* The name of the option class. */ +{ + return NULL; +} diff --git a/mac/tkMacCursor.c b/mac/tkMacCursor.c index f221189..3f34434 100644 --- a/mac/tkMacCursor.c +++ b/mac/tkMacCursor.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkMacCursor.c 1.20 97/09/17 19:33:13 + * SCCS: @(#) tkMacCursor.c 1.24 98/01/22 17:00:29 */ #include "tkPort.h" @@ -64,9 +64,16 @@ static struct CursorName { static TkMacCursor * gCurrentCursor = NULL; /* A pointer to the current * cursor. */ -static int gResizeOverride = false; /* A boolean indicating wether +static int gResizeOverride = false; /* A boolean indicating whether * we should use the resize * cursor during installations. */ +static int gTkOwnsCursor = true; /* A boolean indicating whether + Tk owns the cursor. If not (for + instance, in the case where a Tk + window is embedded in another app's + window, and the cursor is out of + the tk window, we will not attempt + to adjust the cursor */ /* * Declarations of procedures local to this file @@ -102,13 +109,23 @@ FindCursorByName( { Handle resource; Str255 curName; + int destWrote, inCurLen; - curName[0] = strlen(string); - if (curName[0] > 255) { + inCurLen = strlen(string); + if (inCurLen > 255) { return; } - - strcpy((char *) curName + 1, string); + + /* + * macRoman is the encoding that the resource fork uses. + */ + + Tcl_UtfToExternal(NULL, Tcl_GetEncoding(NULL, "macRoman"), string, + inCurLen, 0, NULL, + (char *) &curName[1], + 255, NULL, &destWrote, NULL); /* Internalize native */ + curName[0] = destWrote; + resource = GetNamedResource('crsr', curName); if (resource != NULL) { @@ -245,7 +262,7 @@ TkCreateCursorFromData( /* *---------------------------------------------------------------------- * - * TkFreeCursor -- + * TkpFreeCursor -- * * This procedure is called to release a cursor allocated by * TkGetCursorByName. @@ -260,7 +277,7 @@ TkCreateCursorFromData( */ void -TkFreeCursor( +TkpFreeCursor( TkCursor *cursorPtr) { TkMacCursor *macCursorPtr = (TkMacCursor *) cursorPtr; @@ -277,8 +294,6 @@ TkFreeCursor( if (macCursorPtr == gCurrentCursor) { gCurrentCursor = NULL; } - - ckfree((char *) macCursorPtr); } /* @@ -348,6 +363,9 @@ void TkpSetCursor( TkpCursor cursor) { + if (!gTkOwnsCursor) { + return; + } if (cursor == None) { gCurrentCursor = NULL; } else { @@ -358,3 +376,25 @@ TkpSetCursor( TkMacInstallCursor(gResizeOverride); } } + +/* + *---------------------------------------------------------------------- + * + * Tk_MacTkOwnsCursor -- + * + * Sets whether Tk has the right to adjust the cursor. + * + * Results: + * None. + * + * Side effects: + * May keep Tk from changing the cursor. + * + *---------------------------------------------------------------------- + */ + +void Tk_MacTkOwnsCursor( + int tkOwnsIt) +{ + gTkOwnsCursor = tkOwnsIt; +} diff --git a/mac/tkMacDefault.h b/mac/tkMacDefault.h index 372d89b..da574fd 100644 --- a/mac/tkMacDefault.h +++ b/mac/tkMacDefault.h @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkMacDefault.h 1.48 97/10/09 17:45:04 + * SCCS: @(#) tkMacDefault.h 1.49 98/01/08 13:18:41 */ #ifndef _TKMACDEFAULT @@ -61,7 +61,8 @@ #define DEF_CHKRAD_FG DEF_BUTTON_FG #define DEF_BUTTON_FONT "system" #define DEF_BUTTON_HEIGHT "0" -#define DEF_BUTTON_HIGHLIGHT_BG NORMAL_BG +#define DEF_BUTTON_HIGHLIGHT_BG_COLOR DEF_BUTTON_BG_COLOR +#define DEF_BUTTON_HIGHLIGHT_BG_MONO DEF_BUTTON_BG_MONO #define DEF_BUTTON_HIGHLIGHT "systemButtonFrame" #define DEF_LABEL_HIGHLIGHT_WIDTH "0" #define DEF_BUTTON_HIGHLIGHT_WIDTH "4" diff --git a/mac/tkMacDialog.c b/mac/tkMacDialog.c index 43d11a5..e1031d9 100644 --- a/mac/tkMacDialog.c +++ b/mac/tkMacDialog.c @@ -3,13 +3,12 @@ * * Contains the Mac implementation of the common dialog boxes. * - * Copyright (c) 1996 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkMacDialog.c 1.12 96/12/03 11:15:12 - * + * SCCS: @(#) tkMacDialog.c 1.20 97/11/07 21:23:36 */ #include <Gestalt.h> @@ -26,6 +25,13 @@ #include "tclMacInt.h" #include "tkFileFilter.h" +#ifndef StrLength +#define StrLength(s) (*((unsigned char *) (s))) +#endif +#ifndef StrBody +#define StrBody(s) ((char *) (s) + 1) +#endif + /* * The following are ID's for resources that are defined in tkMacResource.r */ @@ -45,38 +51,27 @@ * information about the file dialog and the file filters. */ typedef struct _OpenFileData { - Tcl_Interp * interp; - char * initialFile; /* default file to appear in the - * save dialog */ - char * defExt; /* default extension (not used on the - * Mac) */ FileFilterList fl; /* List of file filters. */ SInt16 curType; /* The filetype currently being - * listed */ - int isOpen; /* True if this is an Open dialog, - * false if it is a Save dialog. */ - MenuHandle menu; /* Handle of the menu in the popup*/ - short dialogId; /* resource ID of the dialog */ - int popupId; /* resource ID of the popup */ - short popupItem; /* item number of the popup in the - * dialog */ + * listed. */ + short popupItem; /* Item number of the popup in the + * dialog. */ int usePopup; /* True if we show the popup menu (this * is an open operation and the - * -filetypes option is set) - */ + * -filetypes option is set). */ } OpenFileData; static pascal Boolean FileFilterProc _ANSI_ARGS_((CInfoPBPtr pb, void *myData)); -static int GetFileName _ANSI_ARGS_ (( - ClientData clientData, Tcl_Interp *interp, - int argc, char **argv, int isOpen )); +static int GetFileName _ANSI_ARGS_ ((ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[], int isOpen)); static Boolean MatchOneType _ANSI_ARGS_((CInfoPBPtr pb, - OpenFileData * myDataPtr, FileFilter * filterPtr)); + OpenFileData *myofdPtr, FileFilter *filterPtr)); static pascal short OpenHookProc _ANSI_ARGS_((short item, - DialogPtr theDialog, OpenFileData * myDataPtr)); + DialogPtr theDialog, OpenFileData * myofdPtr)); static int ParseFileDlgArgs _ANSI_ARGS_ ((Tcl_Interp * interp, - OpenFileData * myDataPtr, int argc, char ** argv, + OpenFileData * myofdPtr, int argc, char ** argv, int isOpen)); /* @@ -92,68 +87,7 @@ static DlgHookYDUPP saveHook = NULL; /* *---------------------------------------------------------------------- * - * EvalArgv -- - * - * Invokes the Tcl procedure with the arguments. argv[0] is set by - * the caller of this function. It may be different than cmdName. - * The TCL command will see argv[0], not cmdName, as its name if it - * invokes [lindex [info level 0] 0] - * - * Results: - * TCL_ERROR if the command does not exist and cannot be autoloaded. - * Otherwise, return the result of the evaluation of the command. - * - * Side effects: - * The command may be autoloaded. - * - *---------------------------------------------------------------------- - */ - -static int -EvalArgv( - Tcl_Interp *interp, /* Current interpreter. */ - char * cmdName, /* Name of the TCL command to call */ - int argc, /* Number of arguments. */ - char **argv) /* Argument strings. */ -{ - Tcl_CmdInfo cmdInfo; - - if (!Tcl_GetCommandInfo(interp, cmdName, &cmdInfo)) { - char * cmdArgv[2]; - - /* - * This comand is not in the interpreter yet -- looks like we - * have to auto-load it - */ - if (!Tcl_GetCommandInfo(interp, "auto_load", &cmdInfo)) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "cannot execute command \"auto_load\"", - NULL); - return TCL_ERROR; - } - - cmdArgv[0] = "auto_load"; - cmdArgv[1] = cmdName; - - if ((*cmdInfo.proc)(cmdInfo.clientData, interp, 2, cmdArgv)!= TCL_OK){ - return TCL_ERROR; - } - - if (!Tcl_GetCommandInfo(interp, cmdName, &cmdInfo)) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "cannot auto-load command \"", - cmdName, "\"",NULL); - return TCL_ERROR; - } - } - - return (*cmdInfo.proc)(cmdInfo.clientData, interp, argc, argv); -} - -/* - *---------------------------------------------------------------------- - * - * Tk_ChooseColorCmd -- + * Tk_ChooseColorObjCmd -- * * This procedure implements the color dialog box for the Mac * platform. See the user documentation for details on what it @@ -169,23 +103,86 @@ EvalArgv( */ int -Tk_ChooseColorCmd( +Tk_ChooseColorObjCmd( ClientData clientData, /* Main window associated with interpreter. */ Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv) /* Argument strings. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ { - Tk_Window parent = Tk_MainWindow(interp); - char * colorStr = NULL; - XColor * colorPtr = NULL; - char * title = "Choose a color:"; - int i, version; - long response = 0; - OSErr err = noErr; - char buff[40]; - static RGBColor in; + Tk_Window parent; + char *title; + int i, picked, srcRead, dstWrote; + long response; + OSErr err; static inited = 0; - + static RGBColor in; + static char *optionStrings[] = { + "-initialcolor", "-parent", "-title", NULL + }; + enum options { + COLOR_INITIAL, COLOR_PARENT, COLOR_TITLE + }; + + if (inited == 0) { + /* + * 'in' stores the last color picked. The next time the color dialog + * pops up, the last color will remain in the dialog. + */ + + in.red = 0xffff; + in.green = 0xffff; + in.blue = 0xffff; + inited = 1; + } + + parent = (Tk_Window) clientData; + title = "Choose a color:"; + picked = 0; + + for (i = 1; i < objc; i += 2) { + int index; + char *option, *value; + + if (Tcl_GetIndexFromObj(interp, objv[i], optionStrings, "option", + TCL_EXACT, &index) != TCL_OK) { + return TCL_ERROR; + } + if (i + 1 == objc) { + option = Tcl_GetStringFromObj(objv[i], NULL); + Tcl_AppendResult(interp, "value for \"", option, "\" missing", + (char *) NULL); + return TCL_ERROR; + } + value = Tcl_GetStringFromObj(objv[i + 1], NULL); + + switch ((enum options) index) { + case COLOR_INITIAL: { + XColor *colorPtr; + + colorPtr = Tk_GetColor(interp, parent, value); + if (colorPtr == NULL) { + return TCL_ERROR; + } + in.red = colorPtr->red; + in.green = colorPtr->green; + in.blue = colorPtr->blue; + Tk_FreeColor(colorPtr); + break; + } + case COLOR_PARENT: { + parent = Tk_NameToWindow(interp, value, parent); + if (parent == NULL) { + return TCL_ERROR; + } + break; + } + case COLOR_TITLE: { + title = value; + break; + } + } + } + /* * Use the gestalt manager to determine how to bring * up the color picker. If versin 2.0 isn't available @@ -194,92 +191,12 @@ Tk_ChooseColorCmd( */ err = Gestalt(gestaltColorPicker, &response); - if ((err == noErr) || (response == 0x0200L)) { - version = 2; - } else { - version = 1; - } - - for (i=1; i<argc; i+=2) { - int v = i+1; - int len = strlen(argv[i]); - - if (strncmp(argv[i], "-initialcolor", len)==0) { - if (v==argc) {goto arg_missing;} - - colorStr = argv[v]; - } else if (strncmp(argv[i], "-parent", len)==0) { - if (v==argc) {goto arg_missing;} - - parent=Tk_NameToWindow(interp, argv[v], Tk_MainWindow(interp)); - if (parent == NULL) { - return TCL_ERROR; - } - } else if (strncmp(argv[i], "-title", len)==0) { - if (v==argc) {goto arg_missing;} - - title = argv[v]; - } else { - Tcl_AppendResult(interp, "unknown option \"", - argv[i], "\", must be -initialcolor, -parent or -title", - NULL); - return TCL_ERROR; - } - } - - if (colorStr) { - colorPtr = Tk_GetColor(interp, parent, colorStr); - if (colorPtr == NULL) { - return TCL_ERROR; - } - } - - if (!inited) { - inited = 1; - in.red = 0xffff; - in.green = 0xffff; - in.blue = 0xffff; - } - if (colorPtr) { - in.red = colorPtr->red; - in.green = colorPtr->green; - in.blue = colorPtr->blue; - } - - if (version == 1) { - /* - * Use version 1.0 of the color picker - */ - - RGBColor out; - Str255 prompt; - Point point = {-1, -1}; - - prompt[0] = strlen(title); - strncpy((char*) prompt+1, title, 255); - - if (GetColor(point, prompt, &in, &out)) { - /* - * user selected a color - */ - sprintf(buff, "#%02x%02x%02x", out.red >> 8, out.green >> 8, - out.blue >> 8); - Tcl_SetResult(interp, buff, TCL_VOLATILE); + if ((err == noErr) && (response == 0x0200L)) { + ColorPickerInfo cpinfo; - /* - * Save it for the next time - */ - in.red = out.red; - in.green = out.green; - in.blue = out.blue; - } else { - Tcl_ResetResult(interp); - } - } else { /* * Version 2.0 of the color picker is available. Let's use it */ - ColorPickerInfo cpinfo; cpinfo.theColor.profile = 0L; cpinfo.theColor.color.rgb.red = in.red; @@ -292,41 +209,50 @@ Tk_ChooseColorCmd( cpinfo.eventProc = NULL; cpinfo.colorProc = NULL; cpinfo.colorProcData = NULL; + + Tcl_UtfToExternal(NULL, NULL, title, -1, 0, NULL, + StrBody(cpinfo.prompt), 255, &srcRead, &dstWrote, NULL); + StrLength(cpinfo.prompt) = (unsigned char) dstWrote; + + if ((PickColor(&cpinfo) == noErr) && (cpinfo.newColorChosen != 0)) { + in.red = cpinfo.theColor.color.rgb.red; + in.green = cpinfo.theColor.color.rgb.green; + in.blue = cpinfo.theColor.color.rgb.blue; + picked = 1; + } + } else { + RGBColor out; + Str255 prompt; + Point point = {-1, -1}; + + /* + * Use version 1.0 of the color picker + */ + + Tcl_UtfToExternal(NULL, NULL, title, -1, 0, NULL, StrBody(prompt), + 255, &srcRead, &dstWrote, NULL); + StrLength(prompt) = (unsigned char) dstWrote; - cpinfo.prompt[0] = strlen(title); - strncpy((char*)cpinfo.prompt+1, title, 255); - - if ((PickColor(&cpinfo) == noErr) && cpinfo.newColorChosen) { - sprintf(buff, "#%02x%02x%02x", - cpinfo.theColor.color.rgb.red >> 8, - cpinfo.theColor.color.rgb.green >> 8, - cpinfo.theColor.color.rgb.blue >> 8); - Tcl_SetResult(interp, buff, TCL_VOLATILE); - - in.blue = cpinfo.theColor.color.rgb.red; - in.green = cpinfo.theColor.color.rgb.green; - in.blue = cpinfo.theColor.color.rgb.blue; - } else { - Tcl_ResetResult(interp); + if (GetColor(point, prompt, &in, &out)) { + in = out; + picked = 1; } - } + } + + if (picked != 0) { + char result[32]; - if (colorPtr) { - Tk_FreeColor(colorPtr); + sprintf(result, "#%02x%02x%02x", in.red >> 8, in.green >> 8, + in.blue >> 8); + Tcl_AppendResult(interp, result, NULL); } - return TCL_OK; - - arg_missing: - Tcl_AppendResult(interp, "value for \"", argv[argc-1], "\" missing", - NULL); - return TCL_ERROR; } /* *---------------------------------------------------------------------- * - * Tk_GetOpenFileCmd -- + * Tk_GetOpenFileObjCmd -- * * This procedure implements the "open file" dialog box for the * Mac platform. See the user documentation for details on what @@ -341,19 +267,19 @@ Tk_ChooseColorCmd( */ int -Tk_GetOpenFileCmd( +Tk_GetOpenFileObjCmd( ClientData clientData, /* Main window associated with interpreter. */ Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv) /* Argument strings. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ { - return GetFileName(clientData, interp, argc, argv, OPEN_FILE); + return GetFileName(clientData, interp, objc, objv, OPEN_FILE); } /* *---------------------------------------------------------------------- * - * Tk_GetSaveFileCmd -- + * Tk_GetSaveFileObjCmd -- * * Same as Tk_GetOpenFileCmd but opens a "save file" dialog box * instead @@ -367,13 +293,13 @@ Tk_GetOpenFileCmd( */ int -Tk_GetSaveFileCmd( +Tk_GetSaveFileObjCmd( ClientData clientData, /* Main window associated with interpreter. */ Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv) /* Argument strings. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ { - return GetFileName(clientData, interp, argc, argv, SAVE_FILE); + return GetFileName(clientData, interp, objc, objv, SAVE_FILE); } /* @@ -389,8 +315,8 @@ Tk_GetSaveFileCmd( * * Side effects: * If the user selects a file, the native pathname of the file - * is returned in interp->result. Otherwise an empty string - * is returned in interp->result. + * is returned in the interp's result. Otherwise an empty string + * is returned in the interp's result. * *---------------------------------------------------------------------- */ @@ -399,32 +325,124 @@ static int GetFileName( ClientData clientData, /* Main window associated with interpreter. */ Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv, /* Argument strings. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[], /* Argument objects. */ int isOpen) /* true if we should call GetOpenFileName(), * false if we should call GetSaveFileName() */ { - int code = TCL_OK; - int i; - OpenFileData myData, *myDataPtr; + int i, result; + OpenFileData ofd; StandardFileReply reply; Point mypoint; - Str255 str; - - myDataPtr = &myData; + MenuHandle menu; + Str255 initialFile; + char *choice[6]; + Tk_Window parent; + static char *optionStrings[] = { + "-defaultextension", "-filetypes", "-initialdir", "-initialfile", + "-parent", "-title", NULL + }; + enum options { + FILE_DEFAULT, FILE_TYPES, FILE_INITDIR, FILE_INITFILE, + FILE_PARENT, FILE_TITLE + }; if (openFilter == NULL) { openFilter = NewFileFilterYDProc(FileFilterProc); openHook = NewDlgHookYDProc(OpenHookProc); saveHook = NewDlgHookYDProc(OpenHookProc); } + + result = TCL_ERROR; + parent = (Tk_Window) clientData; + memset(choice, 0, sizeof(choice)); - /* - * 1. Parse the arguments. - */ - if (ParseFileDlgArgs(interp, myDataPtr, argc, argv, isOpen) - != TCL_OK) { - return TCL_ERROR; + for (i = 1; i < objc; i += 2) { + int index; + char *string; + + if (Tcl_GetIndexFromObj(interp, objv[i], optionStrings, "option", + TCL_EXACT, &index) != TCL_OK) { + return TCL_ERROR; + } + if (i + 1 == objc) { + string = Tcl_GetStringFromObj(objv[i], NULL); + Tcl_AppendResult(interp, "value for \"", string, "\" missing", + (char *) NULL); + return TCL_ERROR; + } + choice[index] = Tcl_GetStringFromObj(objv[i + 1], NULL); + } + + StrLength(initialFile) = 0; + menu = NULL; + + TkInitFileFilters(&ofd.fl); + ofd.curType = 0; + ofd.popupItem = OPEN_POPUP_ITEM; + ofd.usePopup = isOpen; + + if (choice[FILE_TYPES] != NULL) { + if (TkGetFileFilters(interp, &ofd.fl, choice[FILE_TYPES], 0) != TCL_OK) { + goto end; + } + } + if (choice[FILE_INITDIR] != NULL) { + FSSpec dirSpec; + Tcl_DString ds; + long dirID; + OSErr err; + Boolean isDirectory; + char *string; + Str255 dir; + int srcRead, dstWrote; + + string = choice[FILE_INITDIR]; + if (Tcl_TranslateFileName(interp, string, &ds) == NULL) { + goto end; + } + Tcl_UtfToExternal(NULL, NULL, Tcl_DStringValue(&ds), + Tcl_DStringLength(&ds), 0, NULL, StrBody(dir), 255, + &srcRead, &dstWrote, NULL); + StrLength(dir) = (unsigned char) dstWrote; + Tcl_DStringFree(&ds); + + err = FSpLocationFromPath(StrLength(dir), StrBody(dir), &dirSpec); + if (err != noErr) { + Tcl_AppendResult(interp, "bad directory \"", string, "\"", NULL); + goto end; + } + err = FSpGetDirectoryID(&dirSpec, &dirID, &isDirectory); + if ((err != noErr) || !isDirectory) { + Tcl_AppendResult(interp, "bad directory \"", string, "\"", NULL); + goto end; + } + /* + * Make sure you negate -dirSpec.vRefNum because the + * standard file package wants it that way ! + */ + + LMSetSFSaveDisk(-dirSpec.vRefNum); + LMSetCurDirStore(dirID); + } + if (choice[FILE_INITFILE] != NULL) { + Tcl_DString ds; + int srcRead, dstWrote; + + if (Tcl_TranslateFileName(interp, choice[FILE_INITFILE], &ds) == NULL) { + goto end; + } + Tcl_UtfToExternal(NULL, NULL, Tcl_DStringValue(&ds), + Tcl_DStringLength(&ds), 0, NULL, + StrBody(initialFile), 255, &srcRead, &dstWrote, NULL); + StrLength(initialFile) = (unsigned char) dstWrote; + Tcl_DStringFree(&ds); + } + if (choice[FILE_PARENT] != NULL) { + parent = Tk_NameToWindow(interp, choice[FILE_PARENT], parent); + if (parent == NULL) { + return TCL_ERROR; + } } /* @@ -436,237 +454,89 @@ GetFileName( * left overs from previous invocation of this command */ - if (myDataPtr->usePopup) { - FileFilter * filterPtr; - - for (i=CountMItems(myDataPtr->menu); i>0; i--) { + if (ofd.usePopup) { + FileFilter *filterPtr; + + menu = GetMenu(OPEN_MENU); + for (i = CountMItems(menu); i > 0; i--) { /* * The item indices are one based. Also, if we delete from * the beginning, the items may be re-numbered. So we * delete from the end */ - DeleteMenuItem(myDataPtr->menu, i); + + DeleteMenuItem(menu, i); } - if (myDataPtr->fl.filters) { - for (filterPtr=myDataPtr->fl.filters; filterPtr; - filterPtr=filterPtr->next) { - strncpy((char*)str+1, filterPtr->name, 254); - str[0] = strlen(filterPtr->name); - AppendMenu(myDataPtr->menu, (ConstStr255Param) str); - } + filterPtr = ofd.fl.filters; + if (filterPtr == NULL) { + ofd.usePopup = 0; } else { - myDataPtr->usePopup = 0; + for ( ; filterPtr != NULL; filterPtr = filterPtr->next) { + Str255 str; + + StrLength(str) = (unsigned char) strlen(filterPtr->name); + strcpy(StrBody(str), filterPtr->name); + AppendMenu(menu, str); + } } } /* * 3. Call the toolbox file dialog function. */ + SetPt(&mypoint, -1, -1); TkpSetCursor(NULL); - - if (myDataPtr->isOpen) { - if (myDataPtr->usePopup) { - CustomGetFile(openFilter, (short) -1, NULL, &reply, - myDataPtr->dialogId, - mypoint, openHook, NULL, NULL, NULL, (void*)myDataPtr); + if (isOpen) { + if (ofd.usePopup) { + CustomGetFile(openFilter, (short) -1, NULL, &reply, OPEN_BOX, + mypoint, openHook, NULL, NULL, NULL, (void*) &ofd); } else { StandardGetFile(NULL, -1, NULL, &reply); } } else { - Str255 prompt, def; - - strcpy((char*)prompt+1, "Save as"); - prompt[0] = strlen("Save as"); - if (myDataPtr->initialFile) { - strncpy((char*)def+1, myDataPtr->initialFile, 254); - def[0] = strlen(myDataPtr->initialFile); - } else { - def[0] = 0; - } - if (myDataPtr->usePopup) { + static Str255 prompt = "\pSave as"; + + if (ofd.usePopup) { /* * Currently this never gets called because we don't use * popup for the save dialog. */ - CustomPutFile(prompt, def, &reply, myDataPtr->dialogId, mypoint, - saveHook, NULL, NULL, NULL, myDataPtr); + CustomPutFile(prompt, initialFile, &reply, OPEN_BOX, + mypoint, saveHook, NULL, NULL, NULL, (void *) &ofd); } else { - StandardPutFile(prompt, def, &reply); + StandardPutFile(prompt, initialFile, &reply); } } - Tcl_ResetResult(interp); if (reply.sfGood) { int length; - Handle pathHandle = NULL; - char * pathName = NULL; + Handle pathHandle; + pathHandle = NULL; FSpPathFromLocation(&reply.sfFile, &length, &pathHandle); - if (pathHandle != NULL) { + Tcl_DString ds; + HLock(pathHandle); - pathName = (char *) ckalloc((unsigned) (length + 1)); - strcpy(pathName, *pathHandle); + Tcl_ExternalToUtfDString(NULL, (char *) *pathHandle, -1, &ds); + Tcl_AppendResult(interp, Tcl_DStringValue(&ds), NULL); + Tcl_DStringFree(&ds); HUnlock(pathHandle); DisposeHandle(pathHandle); - - /* - * Return the full pathname of the selected file - */ - - Tcl_SetResult(interp, pathName, TCL_DYNAMIC); } } - - done: - TkFreeFileFilters(&myDataPtr->fl); - return code; -} - -/* - *---------------------------------------------------------------------- - * - * ParseFileDlgArgs -- - * - * Parses the arguments passed to tk_getOpenFile and tk_getSaveFile. - * - * Results: - * A standard TCL return value. - * - * Side effects: - * The OpenFileData structure is initialized and modified according - * to the arguments. - * - *---------------------------------------------------------------------- - */ - -static int -ParseFileDlgArgs( - Tcl_Interp * interp, /* Current interpreter. */ - OpenFileData * myDataPtr, /* Information about the file dialog */ - int argc, /* Number of arguments */ - char ** argv, /* Argument strings */ - int isOpen) /* TRUE if this is an "open" dialog */ -{ - int i; - - myDataPtr->interp = interp; - myDataPtr->initialFile = NULL; - myDataPtr->curType = 0; - - TkInitFileFilters(&myDataPtr->fl); - if (isOpen) { - myDataPtr->isOpen = 1; - myDataPtr->usePopup = 1; - myDataPtr->menu = GetMenu(OPEN_MENU); - myDataPtr->dialogId = OPEN_BOX; - myDataPtr->popupId = OPEN_POPUP; - myDataPtr->popupItem = OPEN_POPUP_ITEM; - if (myDataPtr->menu == NULL) { - Debugger(); - } - } else { - myDataPtr->isOpen = 0; - myDataPtr->usePopup = 0; - } - - for (i=1; i<argc; i+=2) { - int v = i+1; - int len = strlen(argv[i]); - - if (strncmp(argv[i], "-defaultextension", len)==0) { - if (v==argc) {goto arg_missing;} + result = TCL_OK; - myDataPtr->defExt = argv[v]; - } - else if (strncmp(argv[i], "-filetypes", len)==0) { - if (v==argc) {goto arg_missing;} - - if (TkGetFileFilters(interp, &myDataPtr->fl,argv[v],0) != TCL_OK) { - return TCL_ERROR; - } - } - else if (strncmp(argv[i], "-initialdir", len)==0) { - FSSpec dirSpec; - char * dirName; - Tcl_DString dstring; - long dirID; - OSErr err; - Boolean isDirectory; - - if (v==argc) {goto arg_missing;} - - if (Tcl_TranslateFileName(interp, argv[v], &dstring) == NULL) { - return TCL_ERROR; - } - dirName = dstring.string; - if (FSpLocationFromPath(strlen(dirName), dirName, &dirSpec) != - noErr) { - Tcl_AppendResult(interp, "bad directory \"", argv[v], - "\"", NULL); - return TCL_ERROR; - } - err = FSpGetDirectoryID(&dirSpec, &dirID, &isDirectory); - if ((err != noErr) || !isDirectory) { - Tcl_AppendResult(interp, "bad directory \"", argv[v], - "\"", NULL); - return TCL_ERROR; - } - /* - * Make sure you negate -dirSpec.vRefNum because the standard file - * package wants it that way ! - */ - LMSetSFSaveDisk(-dirSpec.vRefNum); - LMSetCurDirStore(dirID); - Tcl_DStringFree(&dstring); - } - else if (strncmp(argv[i], "-initialfile", len)==0) { - if (v==argc) {goto arg_missing;} - - myDataPtr->initialFile = argv[v]; - } - else if (strncmp(argv[i], "-parent", len)==0) { - /* - * Ignored on the Mac, but make sure that it's a valid window - * pathname - */ - Tk_Window parent; - - if (v==argc) {goto arg_missing;} - - parent=Tk_NameToWindow(interp, argv[v], Tk_MainWindow(interp)); - if (parent == NULL) { - return TCL_ERROR; - } - } - else if (strncmp(argv[i], "-title", len)==0) { - if (v==argc) {goto arg_missing;} - - /* - * This option is ignored on the Mac because the Mac file - * dialog do not support titles. - */ - } - else { - Tcl_AppendResult(interp, "unknown option \"", - argv[i], "\", must be -defaultextension, ", - "-filetypes, -initialdir, -initialfile, -parent or -title", - NULL); - return TCL_ERROR; - } + end: + TkFreeFileFilters(&ofd.fl); + if (menu != NULL) { + DisposeMenu(menu); } - - return TCL_OK; - - arg_missing: - Tcl_AppendResult(interp, "value for \"", argv[argc-1], "\" missing", - NULL); - return TCL_ERROR; + return result; } - /* *---------------------------------------------------------------------- * @@ -689,7 +559,7 @@ static pascal short OpenHookProc( short item, /* Event description. */ DialogPtr theDialog, /* The dialog where the event occurs. */ - OpenFileData * myDataPtr) /* Information about the file dialog. */ + OpenFileData *ofdPtr) /* Information about the file dialog. */ { short ignore; Rect rect; @@ -698,29 +568,29 @@ OpenHookProc( switch (item) { case sfHookFirstCall: - if (myDataPtr->usePopup) { + if (ofdPtr->usePopup) { /* * Set the popup list to display the selected type. */ - GetDialogItem(theDialog, myDataPtr->popupItem, - &ignore, &handle, &rect); - SetControlValue((ControlRef) handle, myDataPtr->curType + 1); + GetDialogItem(theDialog, ofdPtr->popupItem, &ignore, &handle, + &rect); + SetControlValue((ControlRef) handle, ofdPtr->curType + 1); } return sfHookNullEvent; case OPEN_POPUP_ITEM: - if (myDataPtr->usePopup) { - GetDialogItem(theDialog, myDataPtr->popupItem, + if (ofdPtr->usePopup) { + GetDialogItem(theDialog, ofdPtr->popupItem, &ignore, &handle, &rect); newType = GetCtlValue((ControlRef) handle) - 1; - if (myDataPtr->curType != newType) { - if (newType<0 || newType>myDataPtr->fl.numFilters) { + if (ofdPtr->curType != newType) { + if (newType<0 || newType>ofdPtr->fl.numFilters) { /* * Sanity check. Looks like the user selected an * non-existent menu item?? Don't do anything. */ } else { - myDataPtr->curType = newType; + ofdPtr->curType = newType; } return sfHookRebuildList; } @@ -755,10 +625,10 @@ FileFilterProc( void *myData) /* Client data for this file dialog */ { int i; - OpenFileData * myDataPtr = (OpenFileData*)myData; + OpenFileData * ofdPtr = (OpenFileData*)myData; FileFilter * filterPtr; - if (myDataPtr->fl.numFilters == 0) { + if (ofdPtr->fl.numFilters == 0) { /* * No types have been specified. List all files by default */ @@ -772,13 +642,13 @@ FileFilterProc( return MATCHED; } - if (myDataPtr->usePopup) { - i = myDataPtr->curType; - for (filterPtr=myDataPtr->fl.filters; filterPtr && i>0; i--) { + if (ofdPtr->usePopup) { + i = ofdPtr->curType; + for (filterPtr=ofdPtr->fl.filters; filterPtr && i>0; i--) { filterPtr = filterPtr->next; } if (filterPtr) { - return MatchOneType(pb, myDataPtr, filterPtr); + return MatchOneType(pb, ofdPtr, filterPtr); } else { return UNMATCHED; } @@ -788,9 +658,9 @@ FileFilterProc( * considered matched if it matches any of the file filters. */ - for (filterPtr=myDataPtr->fl.filters; filterPtr; + for (filterPtr=ofdPtr->fl.filters; filterPtr; filterPtr=filterPtr->next) { - if (MatchOneType(pb, myDataPtr, filterPtr) == MATCHED) { + if (MatchOneType(pb, ofdPtr, filterPtr) == MATCHED) { return MATCHED; } } @@ -818,7 +688,7 @@ FileFilterProc( static Boolean MatchOneType( CInfoPBPtr pb, /* Information about the file */ - OpenFileData * myDataPtr, /* Information about this file dialog */ + OpenFileData * ofdPtr, /* Information about this file dialog */ FileFilter * filterPtr) /* Match the file described by pb against * this filter */ { @@ -909,31 +779,33 @@ MatchOneType( return UNMATCHED; } - /* *---------------------------------------------------------------------- * - * Tk_MessageBoxCmd -- + * Tk_ChooseDirectoryObjCmd -- * - * This procedure implements the MessageBox window for the - * Mac platform. See the user documentation for details on what - * it does. + * This procedure implements the "tk_chooseDirectory" dialog box + * for the Windows platform. See the user documentation for details + * on what it does. * * Results: - * A standard Tcl result. + * See user documentation. * * Side effects: - * See user documentation. + * A modal dialog window is created. Tcl_SetServiceMode() is + * called to allow background events to be processed * *---------------------------------------------------------------------- */ int -Tk_MessageBoxCmd( - ClientData clientData, /* Main window associated with interpreter. */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv) /* Argument strings. */ +Tk_ChooseDirectoryObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Main window associated with interpreter. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - return EvalArgv(interp, "tkMessageBox", argc, argv); + return TCL_ERROR; } + + diff --git a/mac/tkMacEmbed.c b/mac/tkMacEmbed.c index 7a73b54..21e4803 100644 --- a/mac/tkMacEmbed.c +++ b/mac/tkMacEmbed.c @@ -8,12 +8,12 @@ * Currently only Toplevel embedding within the same Tk application is * allowed on the Macintosh. * - * Copyright (c) 1996-97 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkMacEmbed.c 1.6 97/10/31 17:20:22 + * SCCS: @(#) tkMacEmbed.c 1.8 97/12/03 18:56:10 */ #include "tkInt.h" @@ -53,6 +53,11 @@ typedef struct Container { static Container *firstContainerPtr = NULL; /* First in list of all containers * managed by this process. */ +/* + * Globals defined in this file + */ + +TkMacEmbedHandler *gMacEmbedHandler = NULL; /* * Prototypes for static procedures defined in this file: @@ -74,9 +79,41 @@ static void EmbedStructureProc _ANSI_ARGS_((ClientData clientData, XEvent *eventPtr)); static void EmbedWindowDeleted _ANSI_ARGS_((TkWindow *winPtr)); -/* WARNING - HACK */ -static void GenerateFocusEvents _ANSI_ARGS_((TkWindow *sourcePtr, - TkWindow *destPtr)); + +/* + *---------------------------------------------------------------------- + * + * Tk_MacSetEmbedHandler -- + * + * Registers a handler for an in process form of embedding, like + * Netscape plugins, where Tk is loaded into the process, but does + * not control the main window + * + * Results: + * None + * + * Side effects: + * The embed handler is set. + * + *---------------------------------------------------------------------- + */ +void +Tk_MacSetEmbedHandler( + Tk_MacEmbedRegisterWinProc *registerWinProc, + Tk_MacEmbedGetGrafPortProc *getPortProc, + Tk_MacEmbedMakeContainerExistProc *containerExistProc, + Tk_MacEmbedGetClipProc *getClipProc, + Tk_MacEmbedGetOffsetInParentProc *getOffsetProc) +{ + if (gMacEmbedHandler == NULL) { + gMacEmbedHandler = (TkMacEmbedHandler *) ckalloc(sizeof(TkMacEmbedHandler)); + } + gMacEmbedHandler->registerWinProc = registerWinProc; + gMacEmbedHandler->getPortProc = getPortProc; + gMacEmbedHandler->containerExistProc = containerExistProc; + gMacEmbedHandler->getClipProc = getClipProc; + gMacEmbedHandler->getOffsetProc = getOffsetProc; +} /* @@ -180,7 +217,7 @@ TkpMakeWindow( * 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 interp->result if + * is TCL_ERROR and an error message is left in the interp's result if * interp is non-NULL. * * Side effects: @@ -240,18 +277,6 @@ TkpUseWindow( } } - /* - * We should not get to this code until we start to allow - * embedding in other applications. - */ - - if (containerPtr == NULL) { - Tcl_AppendResult(interp, "The window ID ", string, - " does not correspond to a valid Tk Window.", - (char *) NULL); - return TCL_ERROR; - } - /* * Make the embedded window. */ @@ -264,13 +289,27 @@ TkpUseWindow( macWin->winPtr = winPtr; winPtr->privatePtr = macWin; + + /* + * The portPtr will be NULL for a Tk in Tk embedded window. + * It is none of our business what it is for a Tk not in Tk embedded window, + * but we will initialize it to NULL, and let the registerWinProc + * set it. In any case, you must always use TkMacGetDrawablePort + * to get the portPtr. It will correctly find the container's port. + */ + + macWin->portPtr = (GWorldPtr) NULL; + macWin->clipRgn = NewRgn(); macWin->aboveClipRgn = NewRgn(); macWin->referenceCount = 0; macWin->flags = TK_CLIP_INVALID; - + macWin->toplevel = macWin; + macWin->toplevel->referenceCount++; + winPtr->flags |= TK_EMBEDDED; + /* * Make a copy of the TK_EMBEDDED flag, since sometimes * we need this to get the port after the TkWindow structure @@ -279,33 +318,67 @@ TkpUseWindow( macWin->flags |= TK_EMBEDDED; - /* - * The portPtr will be NULL for an embedded window. - * Always use TkMacGetDrawablePort to get the portPtr. - * It will correctly find the container's port. + /* + * Now check whether it is embedded in another Tk widget. If not (the first + * case below) we see if there is an in-process embedding handler registered, + * and if so, let that fill in the rest of the macWin. */ - - macWin->portPtr = (GWorldPtr) NULL; - - macWin->toplevel = macWin; - macWin->xOff = parent->winPtr->privatePtr->xOff + - parent->winPtr->changes.border_width + - winPtr->changes.x; - macWin->yOff = parent->winPtr->privatePtr->yOff + - parent->winPtr->changes.border_width + - winPtr->changes.y; - macWin->toplevel->referenceCount++; + if (containerPtr == NULL) { + /* + * If someone has registered an in process embedding handler, then + * see if it can handle this window... + */ + + if (gMacEmbedHandler == NULL || + gMacEmbedHandler->registerWinProc(result, (Tk_Window) winPtr) != TCL_OK) { + Tcl_AppendResult(interp, "The window ID ", string, + " does not correspond to a valid Tk Window.", + (char *) NULL); + return TCL_ERROR; + } else { + containerPtr = (Container *) ckalloc(sizeof(Container)); + + containerPtr->parentPtr = NULL; + containerPtr->embedded = (Window) macWin; + containerPtr->embeddedPtr = macWin->winPtr; + containerPtr->nextPtr = firstContainerPtr; + firstContainerPtr = containerPtr; + + } + } else { + + /* + * The window is embedded in another Tk window. + */ + + macWin->xOff = parent->winPtr->privatePtr->xOff + + parent->winPtr->changes.border_width + + winPtr->changes.x; + macWin->yOff = parent->winPtr->privatePtr->yOff + + parent->winPtr->changes.border_width + + winPtr->changes.y; - /* - * Finish filling up the container structure with the embedded window's - * information. - */ + + /* + * Finish filling up the container structure with the embedded window's + * information. + */ - containerPtr->embedded = (Window) macWin; - containerPtr->embeddedPtr = macWin->winPtr; + containerPtr->embedded = (Window) macWin; + containerPtr->embeddedPtr = macWin->winPtr; - /* + /* + * Create an event handler to clean up the Container structure when + * tkwin is eventually deleted. + */ + + Tk_CreateEventHandler(tkwin, StructureNotifyMask, EmbeddedEventProc, + (ClientData) winPtr); + + } + + /* * TODO: need general solution for visibility events. */ @@ -318,15 +391,19 @@ TkpUseWindow( event.xvisibility.state = VisibilityUnobscured; Tk_QueueWindowEvent(&event, TCL_QUEUE_TAIL); - /* - * Create an event handler to clean up the Container structure when - * tkwin is eventually deleted. + + /* + * TODO: need general solution for visibility events. */ - - Tk_CreateEventHandler(tkwin, StructureNotifyMask, EmbeddedEventProc, - (ClientData) winPtr); - + event.xany.serial = Tk_Display(winPtr)->request; + event.xany.send_event = False; + event.xany.display = Tk_Display(winPtr); + + event.xvisibility.type = VisibilityNotify; + event.xvisibility.window = (Window) macWin;; + event.xvisibility.state = VisibilityUnobscured; + Tk_QueueWindowEvent(&event, TCL_QUEUE_TAIL); return TCL_OK; } @@ -884,11 +961,10 @@ EmbedActivateProc(clientData, eventPtr) Container *containerPtr = (Container *) clientData; if (containerPtr->embeddedPtr != NULL) { - - if (eventPtr->type == ActivateNotify) { - TkGenerateActivateEvents(containerPtr->embeddedPtr, 1); + if (eventPtr->type == ActivateNotify) { + TkGenerateActivateEvents(containerPtr->embeddedPtr,1); } else if (eventPtr->type == DeactivateNotify) { - TkGenerateActivateEvents(containerPtr->embeddedPtr, 0); + TkGenerateActivateEvents(containerPtr->embeddedPtr,0); } } } @@ -923,14 +999,14 @@ EmbedFocusProc(clientData, eventPtr) XEvent event; if (containerPtr->embeddedPtr != NULL) { - display = Tk_Display(containerPtr->parentPtr); + display = Tk_Display(containerPtr->parentPtr); event.xfocus.serial = LastKnownRequestProcessed(display); event.xfocus.send_event = false; event.xfocus.display = display; event.xfocus.mode = NotifyNormal; event.xfocus.window = containerPtr->embedded; - if (eventPtr->type == FocusIn) { + 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. @@ -951,7 +1027,7 @@ EmbedFocusProc(clientData, eventPtr) } Tk_QueueWindowEvent(&event, TCL_QUEUE_MARK); - } + } } /* diff --git a/mac/tkMacFont.c b/mac/tkMacFont.c index 8619880..616034e 100644 --- a/mac/tkMacFont.c +++ b/mac/tkMacFont.c @@ -10,36 +10,389 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS:@(#) tkMacFont.c 1.52 97/11/20 18:29:51 + * SCCS: @(#) tkMacFont.c 1.54 97/11/26 10:51:12 */ #include <Windows.h> #include <Strings.h> #include <Fonts.h> +#include <Script.h> #include <Resources.h> +#include <TextUtils.h> #include "tkMacInt.h" #include "tkFont.h" -#include "tkPort.h" /* - * The following structure represents the Macintosh's' implementation of a - * font. + * For doing things with Mac strings and Fixed numbers. This probably should move + * the mac header file. */ +#ifndef StrLength +#define StrLength(s) (*((unsigned char *) (s))) +#endif +#ifndef StrBody +#define StrBody(s) ((char *) (s) + 1) +#endif +#define pstrcmp(s1, s2) RelString((s1), (s2), 1, 1) +#define pstrcasecmp(s1, s2) RelString((s1), (s2), 0, 1) + +#ifndef Fixed2Int +#define Fixed2Int(f) ((f) >> 16) +#define Int2Fixed(i) ((i) << 16) +#endif + +/* + * The preferred font encodings. + */ + +static CONST char *encodingList[] = { + "macRoman", "macJapan", NULL +}; + +/* + * The following structures are used to map the script/language codes of a + * font to the name that should be passed to Tcl_GetTextEncoding() to obtain + * the encoding for that font. The set of numeric constants is fixed and + * defined by Apple. + */ + +static TkStateMap scriptMap[] = { + {smRoman, "macRoman"}, + {smJapanese, "macJapan"}, + {smTradChinese, "macChinese"}, + {smKorean, "macKorean"}, + {smArabic, "macArabic"}, + {smHebrew, "macHebrew"}, + {smGreek, "macGreek"}, + {smCyrillic, "macCyrillic"}, + {smRSymbol, "macRSymbol"}, + {smDevanagari, "macDevanagari"}, + {smGurmukhi, "macGurmukhi"}, + {smGujarati, "macGujarati"}, + {smOriya, "macOriya"}, + {smBengali, "macBengali"}, + {smTamil, "macTamil"}, + {smTelugu, "macTelugu"}, + {smKannada, "macKannada"}, + {smMalayalam, "macMalayalam"}, + {smSinhalese, "macSinhalese"}, + {smBurmese, "macBurmese"}, + {smKhmer, "macKhmer"}, + {smThai, "macThailand"}, + {smLaotian, "macLaos"}, + {smGeorgian, "macGeorgia"}, + {smArmenian, "macArmenia"}, + {smSimpChinese, "macSimpChinese"}, + {smTibetan, "macTIbet"}, + {smMongolian, "macMongolia"}, + {smGeez, "macEthiopia"}, + {smEastEurRoman, "macCentEuro"}, + {smVietnamese, "macVietnam"}, + {smExtArabic, "macSindhi"}, + {NULL, NULL} +}; + +static TkStateMap romanMap[] = { + {langCroatian, "macCroatian"}, + {langSlovenian, "macCroatian"}, + {langIcelandic, "macIceland"}, + {langRomanian, "macRomania"}, + {langTurkish, "macTurkish"}, + {langGreek, "macGreek"}, + {NULL, NULL} +}; + +static TkStateMap cyrillicMap[] = { + {langUkrainian, "macUkraine"}, + {langBulgarian, "macBulgaria"}, + {NULL, 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 Macintosh, a "font family" is uniquely identified by its face number. + */ + + +#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. + */ + + short faceNum; /* Unique face number key for this FontFamily. */ + + /* + * Derived properties. + */ + + Tcl_Encoding encoding; /* Encoding for this font family. */ + int isSymbolFont; /* Non-zero if this is a symbol family. */ + int isMultiByteFont; /* Non-zero if this is a multi-byte family. */ + char typeTable[256]; /* Table that identfies all lead bytes for a + * multi-byte family, used when measuring chars. + * If a byte is a lead byte, the value at the + * corresponding position in the typeTable is 1, + * otherwise 0. If this is a single-byte font, + * all entries are 0. */ + 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 added. 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. */ + FontFamily *familyPtr; /* The FontFamily for this SubFont. */ +} SubFont; + +/* + * The following structure represents Macintosh's implementation of a font + * object. + */ + +#define SUBFONT_SPACE 3 + typedef struct MacFont { TkFont font; /* Stuff used by generic font package. Must * be first in structure. */ - short family; - short size; - short style; + 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. */ + + short size; /* Font size in pixels, constructed from + * font attributes. */ + short style; /* Style bits, constructed from font + * attributes. */ } MacFont; +/* + * The following structure is used to map between the UTF-8 name for a font and + * the name that the Macintosh uses to refer to the font, in order to determine + * if a font exists. The Macintosh names for fonts are stored in the encoding + * of the font itself. + */ + +typedef struct FontNameMap { + Tk_Uid utfName; /* The name of the font in UTF-8. */ + StringPtr nativeName; /* The name of the font in the font's encoding. */ + short faceNum; /* Unique face number for this font. */ +} FontNameMap; + +/* + * 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. + */ + +static FontFamily *fontFamilyList = NULL; + +/* + * Information cached about the system at startup time. + */ + +static FontNameMap *gFontNameMap = NULL; static GWorldPtr gWorld = NULL; -static TkFont * AllocMacFont _ANSI_ARGS_((TkFont *tkfont, - Tk_Window tkwin, int family, int size, int style)); +/* + * Procedures used only in this file. + */ + +static FontFamily * AllocFontFamily(CONST MacFont *fontPtr, int family); +static SubFont * CanUseFallback(MacFont *fontPtr, + CONST char *fallbackName, int ch); +static SubFont * CanUseFallbackWithAliases(MacFont *fontPtr, + char *faceName, int ch, Tcl_DString *nameTriedPtr); +static SubFont * FindSubFontForChar(MacFont *fontPtr, int ch); +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 *familyPtr); +static void InitFont(Tk_Window tkwin, int family, int size, + int style, MacFont *fontPtr); +static void InitSubFont(CONST MacFont *fontPtr, int family, + SubFont *subFontPtr); +static void MultiFontDrawText(MacFont *fontPtr, + CONST char *source, int numBytes, int x, int y); +static void ReleaseFont(MacFont *fontPtr); +static void ReleaseSubFont(SubFont *subFontPtr); +static int SeenName(CONST char *name, Tcl_DString *dsPtr); + +static char * BreakLine(FontFamily *familyPtr, int flags, + CONST char *source, int numBytes, int *widthPtr); +static int GetFamilyNum(CONST char *faceName, short *familyPtr); +static int GetFamilyOrAliasNum(CONST char *faceName, + short *familyPtr); +static Tcl_Encoding GetFontEncoding(int faceNum, int allowSymbol, + int *isSymbolPtr); +static Tk_Uid GetUtfFaceName(StringPtr faceNameStr); + + +/* + *------------------------------------------------------------------------- + * + * TkpFontPkgInit -- + * + * This procedure is called when an application is created. It + * initializes all the structures that are used by the + * platform-dependant code on a per application basis. + * + * Results: + * None. + * + * Side effects: + * See comments below. + * + *------------------------------------------------------------------------- + */ +void +TkpFontPkgInit(mainPtr) + TkMainInfo *mainPtr; /* The application being created. */ +{ + MenuHandle fontMenu; + FontNameMap *tmpFontNameMap, *newFontNameMap, *mapPtr; + int i, j, numFonts, fontMapOffset, isSymbol; + Str255 nativeName; + Tcl_DString ds; + Tcl_Encoding encoding; + Tcl_Encoding *encodings; + + if (gWorld == NULL) { + /* + * Do the following one time only. + */ + + Rect rect = {0, 0, 1, 1}; + + SetFractEnable(0); + + /* + * Used for saving and restoring state while drawing and measuring. + */ + + if (NewGWorld(&gWorld, 0, &rect, NULL, NULL, 0) != noErr) { + panic("TkpFontPkgInit: NewGWorld failed"); + } + + /* + * The name of each font is stored in the encoding of that font. + * How would we translate a name from UTF-8 into the native encoding + * of the font unless we knew the encoding of that font? We can't. + * So, precompute the UTF-8 and native names of all fonts on the + * system. The when the user asks for font by its UTF-8 name, we + * lookup the name in that table and really ask for the font by its + * native name. Any unknown UTF-8 names will be mapped to the system + * font. + */ + + fontMenu = NewMenu('FT', "\px"); + AddResMenu(fontMenu, 'FONT'); + + numFonts = CountMItems(fontMenu); + tmpFontNameMap = (FontNameMap *) ckalloc(sizeof(FontNameMap) * numFonts); + encodings = (Tcl_Encoding *) ckalloc(sizeof(Tcl_Encoding) * numFonts); + + mapPtr = tmpFontNameMap; + for (i = 0; i < numFonts; i++) { + GetMenuItemText(fontMenu, i + 1, nativeName); + GetFNum(nativeName, &mapPtr->faceNum); + encodings[i] = GetFontEncoding(mapPtr->faceNum, 0, &isSymbol); + Tcl_ExternalToUtfDString(encodings[i], StrBody(nativeName), + StrLength(nativeName), &ds); + mapPtr->utfName = Tk_GetUid(Tcl_DStringValue(&ds)); + mapPtr->nativeName = (StringPtr) ckalloc(StrLength(nativeName) + 1); + memcpy(mapPtr->nativeName, nativeName, StrLength(nativeName) + 1); + Tcl_DStringFree(&ds); + mapPtr++; + } + DisposeMenu(fontMenu); + + /* + * Reorder FontNameMap so fonts with the preferred encodings are at + * the front of the list. The relative order of fonts that all have + * the same encoding is preserved. Fonts with unknown encodings get + * stuck at the end. + */ + + newFontNameMap = (FontNameMap *) ckalloc(sizeof(FontNameMap) * (numFonts + 1)); + fontMapOffset = 0; + for (i = 0; encodingList[i] != NULL; i++) { + encoding = Tcl_GetEncoding(NULL, encodingList[i]); + if (encoding == NULL) { + continue; + } + for (j = 0; j < numFonts; j++) { + if (encodings[j] == encoding) { + newFontNameMap[fontMapOffset] = tmpFontNameMap[j]; + fontMapOffset++; + Tcl_FreeEncoding(encodings[j]); + tmpFontNameMap[j].utfName = NULL; + } + } + Tcl_FreeEncoding(encoding); + } + for (i = 0; i < numFonts; i++) { + if (tmpFontNameMap[i].utfName != NULL) { + newFontNameMap[fontMapOffset] = tmpFontNameMap[i]; + fontMapOffset++; + Tcl_FreeEncoding(encodings[i]); + } + } + if (fontMapOffset != numFonts) { + panic("TkpFontPkgInit: unexpected number of fonts"); + } + + mapPtr = &newFontNameMap[numFonts]; + mapPtr->utfName = NULL; + mapPtr->nativeName = NULL; + mapPtr->faceNum = 0; + + ckfree((char *) tmpFontNameMap); + ckfree((char *) encodings); + + gFontNameMap = newFontNameMap; + } +} /* *--------------------------------------------------------------------------- @@ -73,6 +426,7 @@ TkpGetNativeFont( CONST char *name) /* Platform-specific font name. */ { short family; + MacFont *fontPtr; if (strcmp(name, "system") == 0) { family = GetSysFont(); @@ -81,8 +435,11 @@ TkpGetNativeFont( } else { return NULL; } - - return AllocMacFont(NULL, tkwin, family, 0, 0); + + fontPtr = (MacFont *) ckalloc(sizeof(MacFont)); + InitFont(tkwin, family, 0, 0, fontPtr); + + return (TkFont *) fontPtr; } /* @@ -122,41 +479,47 @@ TkpGetFontFromAttributes( * 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. */ + CONST TkFontAttributes *faPtr) + /* Set of attributes to match. */ { - char buf[257]; - size_t len; - short family, size, style; - - if (faPtr->family == NULL) { - family = 0; - } else { - CONST char *familyName; - - familyName = faPtr->family; - if (strcasecmp(familyName, "Times New Roman") == 0) { - familyName = "Times"; - } else if (strcasecmp(familyName, "Courier New") == 0) { - familyName = "Courier"; - } else if (strcasecmp(familyName, "Arial") == 0) { - familyName = "Helvetica"; - } - - len = strlen(familyName); - if (len > 255) { - len = 255; + short faceNum, style; + int i, j; + char *faceName, *fallback; + char ***fallbacks; + MacFont *fontPtr; + + /* + * Algorithm to get the closest font to the one requested. + * + * try fontname + * try all aliases for fontname + * foreach fallback for fontname + * try the fallback + * try all aliases for the fallback + */ + + faceNum = 0; + faceName = faPtr->family; + if (faceName != NULL) { + if (GetFamilyOrAliasNum(faceName, &faceNum) != 0) { + goto found; + } + fallbacks = TkFontGetFallbacks(); + for (i = 0; fallbacks[i] != NULL; i++) { + for (j = 0; (fallback = fallbacks[i][j]) != NULL; j++) { + if (strcasecmp(faceName, fallback) == 0) { + for (j = 0; (fallback = fallbacks[i][j]) != NULL; j++) { + if (GetFamilyOrAliasNum(fallback, &faceNum)) { + goto found; + } + } + } + break; + } } - buf[0] = (char) len; - memcpy(buf + 1, familyName, len); - buf[len + 1] = '\0'; - GetFNum((StringPtr) buf, &family); } - - size = faPtr->pointsize; - if (size <= 0) { - size = GetDefFontSize(); - } - + + found: style = 0; if (faPtr->weight != TK_FW_NORMAL) { style |= bold; @@ -167,8 +530,15 @@ TkpGetFontFromAttributes( if (faPtr->underline) { style |= underline; } - - return AllocMacFont(tkFontPtr, tkwin, family, size, style); + if (tkFontPtr == NULL) { + fontPtr = (MacFont *) ckalloc(sizeof(MacFont)); + } else { + fontPtr = (MacFont *) tkFontPtr; + ReleaseFont(fontPtr); + } + InitFont(tkwin, faceNum, faPtr->size, style, fontPtr); + + return (TkFont *) fontPtr; } /* @@ -194,7 +564,10 @@ void TkpDeleteFont( TkFont *tkFontPtr) /* Token of font to be deleted. */ { - ckfree((char *) tkFontPtr); + MacFont *fontPtr; + + fontPtr = (MacFont *) tkFontPtr; + ReleaseFont(fontPtr); } /* @@ -206,7 +579,7 @@ TkpDeleteFont( * on the display of the given window. * * Results: - * interp->result is modified to hold a list of all the available + * Modifies interp's result object to hold a list of all the available * font families. * * Side effects: @@ -220,76 +593,54 @@ TkpGetFontFamilies( Tcl_Interp *interp, /* Interp to hold result. */ Tk_Window tkwin) /* For display to query. */ { - MenuHandle fontMenu; - int i; - char itemText[257]; - - fontMenu = NewMenu(1, "\px"); - AddResMenu(fontMenu, 'FONT'); - - for (i = 1; i < CountMItems(fontMenu); i++) { - /* - * Each item is a pascal string. Convert it to C and append. - */ - GetMenuItemText(fontMenu, i, (unsigned char *) itemText); - itemText[itemText[0] + 1] = '\0'; - Tcl_AppendElement(interp, &itemText[1]); + FontNameMap *mapPtr; + Tcl_Obj *resultPtr, *strPtr; + + resultPtr = Tcl_GetObjResult(interp); + for (mapPtr = gFontNameMap; mapPtr->utfName != NULL; mapPtr++) { + strPtr = Tcl_NewStringObj(mapPtr->utfName, -1); + Tcl_ListObjAppendElement(NULL, resultPtr, strPtr); } - DisposeMenu(fontMenu); } - /* - *--------------------------------------------------------------------------- + *------------------------------------------------------------------------- * - * TkMacIsCharacterMissing -- + * TkpGetSubFonts -- * - * Given a tkFont and a character determines whether the character has - * a glyph defined in the font or not. Note that this is potentially - * not compatible with Mac OS 8 as it looks at the font handle - * structure directly. Looks into the character array of the font - * handle to determine whether the glyph is defined or not. + * A function used by the testing package for querying the actual + * screen fonts that make up a font object. * * Results: - * Returns a 1 if the character is missing, a 0 if it is not. + * 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. * - *--------------------------------------------------------------------------- + *------------------------------------------------------------------------- */ - -int -TkMacIsCharacterMissing( - Tk_Font tkfont, /* The font we are looking in. */ - unsigned int searchChar) /* The character we are looking for. */ + +void +TkpGetSubFonts(interp, tkfont) + Tcl_Interp *interp; /* Interp to hold result. */ + Tk_Font tkfont; /* Font object to query. */ { - MacFont *fontPtr = (MacFont *) tkfont; - FMInput fm; - FontRec **fontRecHandle; - - fm.family = fontPtr->family; - fm.size = fontPtr->size; - fm.face = fontPtr->style; - fm.needBits = 0; - fm.device = 0; - fm.numer.h = fm.numer.v = fm.denom.h = fm.denom.v = 1; + int i; + Tcl_Obj *resultPtr, *strPtr; + MacFont *fontPtr; + FontFamily *familyPtr; + Str255 nativeName; - /* - * This element of the FMOutput structure was changed between the 2.0 & 3.0 - * versions of the Universal Headers. - */ - -#if !defined(UNIVERSAL_INTERFACES_VERSION) || (UNIVERSAL_INTERFACES_VERSION < 0x0300) - fontRecHandle = (FontRec **) FMSwapFont(&fm)->fontResult; -#else - fontRecHandle = (FontRec **) FMSwapFont(&fm)->fontHandle; -#endif - return *(short *) ((long) &(*fontRecHandle)->owTLoc - + ((long)((*fontRecHandle)->owTLoc + searchChar - - (*fontRecHandle)->firstChar) * sizeof(short))) == -1; + resultPtr = Tcl_GetObjResult(interp); + fontPtr = (MacFont *) tkfont; + for (i = 0; i < fontPtr->numSubFonts; i++) { + familyPtr = fontPtr->subFontArray[i].familyPtr; + GetFontName(familyPtr->faceNum, nativeName); + strPtr = Tcl_NewStringObj(GetUtfFaceName(nativeName), -1); + Tcl_ListObjAppendElement(NULL, resultPtr, strPtr); + } } - /* *--------------------------------------------------------------------------- @@ -316,14 +667,14 @@ TkMacIsCharacterMissing( int Tk_MeasureChars( Tk_Font tkfont, /* Font in which characters will be drawn. */ - CONST char *source, /* Characters to be displayed. Need not be + CONST char *source, /* UTF-8 string to be displayed. Need not be * '\0' terminated. */ - int numChars, /* Maximum number of characters to consider + int numBytes, /* Maximum number of bytes to consider * from source string. */ - int maxLength, /* If > 0, maxLength specifies the longest + 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 + * x-position. If < 0, then line length is * unbounded and the flags argument is * ignored. */ int flags, /* Various flag bits OR-ed together: @@ -336,134 +687,270 @@ Tk_MeasureChars( int *lengthPtr) /* Filled with x-location just after the * terminating character. */ { - short staticWidths[128]; - short *widths; - CONST char *p, *term; - int curX, termX, curIdx, sawNonSpace; MacFont *fontPtr; + FontFamily *lastFamilyPtr; CGrafPtr saveWorld; GDHandle saveDevice; + int curX, curByte; - if (numChars == 0) { - *lengthPtr = 0; - return 0; - } - - if (gWorld == NULL) { - Rect rect = {0, 0, 1, 1}; + /* + * According to "Inside Macintosh: Text", the Macintosh may + * automatically substitute + * ligatures or context-sensitive presentation forms when + * measuring/displaying text within a font run. We cannot safely + * measure individual characters and add up the widths w/o errors. + * However, if we convert a range of text from UTF-8 to, say, + * Shift-JIS, and get the offset into the Shift-JIS string as to + * where a word or line break would occur, then can we map that + * number back to UTF-8? + */ + + fontPtr = (MacFont *) tkfont; - if (NewGWorld(&gWorld, 0, &rect, NULL, NULL, 0) != noErr) { - panic("NewGWorld failed in Tk_MeasureChars"); - } - } GetGWorld(&saveWorld, &saveDevice); SetGWorld(gWorld, NULL); - - fontPtr = (MacFont *) tkfont; - TextFont(fontPtr->family); + TextSize(fontPtr->size); TextFace(fontPtr->style); - if (maxLength <= 0) { - *lengthPtr = TextWidth(source, 0, numChars); - SetGWorld(saveWorld, saveDevice); - return numChars; - } - - if (numChars > maxLength) { - /* - * Assume that all chars are at least 1 pixel wide, so there's no - * need to measure more characters than there are pixels. This - * assumption could be refined to an iterative approach that would - * use that as a starting point and try more chars if necessary (if - * there actually were some zero-width chars). - */ - - numChars = maxLength; - } - if (numChars > SHRT_MAX) { - /* - * If they are trying to measure more than 32767 chars at one time, - * it would require several separate measurements. - */ - - numChars = SHRT_MAX; - } - - widths = staticWidths; - if (numChars >= sizeof(staticWidths) / sizeof(staticWidths[0])) { - widths = (short *) ckalloc((numChars + 1) * sizeof(short)); - } + lastFamilyPtr = fontPtr->subFontArray[0].familyPtr; - MeasureText((short) numChars, source, widths); - - if (widths[numChars] <= maxLength) { - curX = widths[numChars]; - curIdx = numChars; + if (numBytes == 0) { + curX = 0; + curByte = 0; + } else if (maxLength < 0) { + CONST char *p, *end, *next; + Tcl_UniChar ch; + FontFamily *thisFamilyPtr; + 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); + thisFamilyPtr = FindSubFontForChar(fontPtr, ch)->familyPtr; + if (thisFamilyPtr != lastFamilyPtr) { + TextFont(lastFamilyPtr->faceNum); + Tcl_UtfToExternalDString(lastFamilyPtr->encoding, source, + p - source, &runString); + curX += TextWidth(Tcl_DStringValue(&runString), 0, + Tcl_DStringLength(&runString)); + Tcl_DStringFree(&runString); + lastFamilyPtr = thisFamilyPtr; + source = p; + } + p = next; + } + TextFont(lastFamilyPtr->faceNum); + Tcl_UtfToExternalDString(lastFamilyPtr->encoding, source, p - source, + &runString); + curX += TextWidth(Tcl_DStringValue(&runString), 0, + Tcl_DStringLength(&runString)); + Tcl_DStringFree(&runString); + curByte = numBytes; } else { - p = term = source; - curX = termX = 0; - - sawNonSpace = !isspace(UCHAR(*p)); - for (curIdx = 1; ; curIdx++) { - if (isspace(UCHAR(*p))) { - if (sawNonSpace) { - term = p; - termX = widths[curIdx - 1]; - sawNonSpace = 0; - } - } else { - sawNonSpace = 1; - } - if (widths[curIdx] > maxLength) { - curIdx--; - curX = widths[curIdx]; - break; + CONST char *p, *end, *next, *sourceOrig; + int widthLeft; + FontFamily *thisFamilyPtr; + Tcl_UniChar ch; + char *rest; + + /* + * How many chars will fit in the space allotted? + */ + + if (maxLength > 32767) { + maxLength = 32767; + } + + widthLeft = maxLength; + sourceOrig = source; + end = source + numBytes; + for (p = source; p < end; p = next) { + next = p + Tcl_UtfToUniChar(p, &ch); + thisFamilyPtr = FindSubFontForChar(fontPtr, ch)->familyPtr; + if (thisFamilyPtr != lastFamilyPtr) { + if (p > source) { + rest = BreakLine(lastFamilyPtr, flags, source, + p - source, &widthLeft); + flags &= ~TK_AT_LEAST_ONE; + if (rest != NULL) { + p = source; + break; + } + } + lastFamilyPtr = thisFamilyPtr; + source = p; } - p++; } - if (flags & TK_PARTIAL_OK) { - curIdx++; - curX = widths[curIdx]; + + if (p > source) { + rest = BreakLine(lastFamilyPtr, flags, source, p - source, + &widthLeft); } - if ((curIdx == 0) && (flags & TK_AT_LEAST_ONE)) { - /* - * The space was too small to hold even one character. Since at - * least one character must always fit on a line, return the width - * of the first character. - */ - - curX = TextWidth(source, 0, 1); - curIdx = 1; - } else if (flags & TK_WHOLE_WORDS) { - /* - * Break at last word that fits on the line. - */ - - if ((flags & TK_AT_LEAST_ONE) && (term == source)) { - /* - * The space was too small to hold an entire word. This - * is the only word on the line, so just return the part of th - * word that fit. - */ - - ; - } else { - curIdx = term - source; - curX = termX; - } - } + + if (rest == NULL) { + curByte = numBytes; + } else { + curByte = rest - sourceOrig; + } + curX = maxLength - widthLeft; } - if (widths != staticWidths) { - ckfree((char *) widths); - } + SetGWorld(saveWorld, saveDevice); *lengthPtr = curX; + return curByte; +} + +/* + *--------------------------------------------------------------------------- + * + * BreakLine -- + * + * Determine where the given line of text should be broken so that it + * fits in the specified range. Before calling this function, the + * font values and graphics port must be set. + * + * Results: + * The return value is NULL if the specified range is larger that the + * space the text needs, and *widthLeftPtr is filled with how much + * space is left in the range after measuring the whole text buffer. + * Otherwise, the return value is a pointer into the text buffer that + * indicates where the line should be broken (up to, but not including + * that character), and *widthLeftPtr is filled with how much space is + * left in the range after measuring up to that character. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +static char * +BreakLine( + FontFamily *familyPtr, /* FontFamily that describes the font values + * that are already selected into the graphics + * port. */ + 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. */ + 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 *widthLeftPtr) /* On input, specifies size of range into + * which characters from source buffer should + * be fit. On output, filled with how much + * space is left after fitting as many + * characters as possible into the range. + * Result may be negative if TK_AT_LEAST_ONE + * was specified in the flags argument. */ +{ + Fixed pixelWidth, widthLeft; + StyledLineBreakCode breakCode; + Tcl_DString runString; + long textOffset; + Boolean leadingEdge; + Point point; + int charOffset, thisCharWasDoubleByte; + char *p, *end, *typeTable; - SetGWorld(saveWorld, saveDevice); + TextFont(familyPtr->faceNum); + Tcl_UtfToExternalDString(familyPtr->encoding, source, numBytes, + &runString); + pixelWidth = Int2Fixed(*widthLeftPtr) + 1; + if (flags & TK_WHOLE_WORDS) { + textOffset = (flags & TK_AT_LEAST_ONE); + widthLeft = pixelWidth; + breakCode = StyledLineBreak(Tcl_DStringValue(&runString), + Tcl_DStringLength(&runString), 0, Tcl_DStringLength(&runString), + 0, &widthLeft, &textOffset); + if (breakCode != smBreakOverflow) { + /* + * StyledLineBreak includes all the space characters at the end of + * line that we want to suppress. + */ + + textOffset = VisibleLength(Tcl_DStringValue(&runString), textOffset); + goto getoffset; + } + } else { + point.v = 1; + point.h = 1; + textOffset = PixelToChar(Tcl_DStringValue(&runString), + Tcl_DStringLength(&runString), 0, pixelWidth, &leadingEdge, + &widthLeft, smOnlyStyleRun, point, point); + if (Fixed2Int(widthLeft) < 0) { + goto getoffset; + } + } + *widthLeftPtr = Fixed2Int(widthLeft); + Tcl_DStringFree(&runString); + return NULL; + + /* + * The conversion routine that converts UTF-8 to the target encoding + * must map one UTF-8 character to exactly one encoding-specific + * character, so that the following algorithm works: + * + * 1. Get byte offset of where line should be broken. + * 2. Get char offset corresponding to that byte offset. + * 3. Map that char offset to byte offset in UTF-8 string. + */ + + getoffset: + thisCharWasDoubleByte = 0; + if (familyPtr->isMultiByteFont == 0) { + charOffset = textOffset; + } else { + charOffset = 0; + typeTable = familyPtr->typeTable; + + p = Tcl_DStringValue(&runString); + end = p + textOffset; + thisCharWasDoubleByte = typeTable[*((unsigned char *) p)]; + for ( ; p < end; p++) { + thisCharWasDoubleByte = typeTable[*((unsigned char *) p)]; + p += thisCharWasDoubleByte; + charOffset++; + } + } - return curIdx; + if ((flags & TK_WHOLE_WORDS) == 0) { + if ((flags & TK_PARTIAL_OK) && (leadingEdge != 0)) { + textOffset += thisCharWasDoubleByte; + textOffset++; + charOffset++; + } else if (((flags & TK_PARTIAL_OK) == 0) && (leadingEdge == 0)) { + textOffset -= thisCharWasDoubleByte; + textOffset--; + charOffset--; + } + } + if ((textOffset == 0) && (Tcl_DStringLength(&runString) > 0) + && (flags & TK_AT_LEAST_ONE)) { + p = Tcl_DStringValue(&runString); + textOffset += familyPtr->typeTable[*((unsigned char *) p)]; + textOffset++; + charOffset++; + } + *widthLeftPtr = Fixed2Int(pixelWidth) + - TextWidth(Tcl_DStringValue(&runString), 0, textOffset); + Tcl_DStringFree(&runString); + return Tcl_UtfAtIndex(source, charOffset); } /* @@ -489,14 +976,14 @@ Tk_DrawChars( 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, /* Characters to be displayed. Need not be + 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 numChars, /* Number of characters in string. */ + int numBytes, /* Number of bytes in string. */ int x, int y) /* Coordinates at which to place origin of * string when drawing. */ { @@ -538,19 +1025,12 @@ Tk_DrawChars( bufferPort = TkMacGetDrawablePort(pixmap); SetGWorld(bufferPort, NULL); - TextFont(fontPtr->family); - TextSize(fontPtr->size); - TextFace(fontPtr->style); - if (TkSetMacColor(gc->foreground, &macColor) == true) { RGBForeColor(&macColor); } - ShowPen(); - MoveTo((short) 0, (short) 0); FillRect(&stippleMap->bounds, &tcl_macQdPtr->white); - MoveTo((short) x, (short) y); - DrawText(source, 0, (short) numChars); + MultiFontDrawText(fontPtr, source, numBytes, 0, 0); SetGWorld(destPort, NULL); CopyDeepMask(&((GrafPtr) bufferPort)->portBits, stippleMap, @@ -565,18 +1045,13 @@ Tk_DrawChars( Tk_FreePixmap(display, pixmap); ckfree(stippleMap->baseAddr); ckfree((char *)stippleMap); - } else { - TextFont(fontPtr->family); - TextSize(fontPtr->size); - TextFace(fontPtr->style); - + } else { if (TkSetMacColor(gc->foreground, &macColor) == true) { RGBForeColor(&macColor); } - ShowPen(); - MoveTo((short) (macWin->xOff + x), (short) (macWin->yOff + y)); - DrawText(source, 0, (short) numChars); + MultiFontDrawText(fontPtr, source, numBytes, macWin->xOff + x, + macWin->yOff + y); } TextFont(txFont); @@ -587,92 +1062,1057 @@ Tk_DrawChars( } /* + *------------------------------------------------------------------------- + * + * MultiFontDrawText -- + * + * Helper function for Tk_DrawChars. Draws characters, using the + * various screen fonts in fontPtr to draw multilingual characters. + * Note: No bidirectional support. + * + * Results: + * None. + * + * Side effects: + * Information gets drawn on the screen. + * Contents of fontPtr may be modified if more subfonts were loaded + * in order to draw all the multilingual characters in the given + * string. + * + *------------------------------------------------------------------------- + */ + +static void +MultiFontDrawText( + MacFont *fontPtr, /* Contains set of fonts to use when drawing + * following string. */ + CONST char *source, /* Potentially multilingual UTF-8 string. */ + int numBytes, /* Length of string in bytes. */ + int x, int y) /* Coordinates at which to place origin * + * of string when drawing. */ +{ + FontFamily *lastFamilyPtr, *thisFamilyPtr; + Tcl_DString runString; + CONST char *p, *end, *next; + Tcl_UniChar ch; + + TextSize(fontPtr->size); + TextFace(fontPtr->style); + + lastFamilyPtr = fontPtr->subFontArray[0].familyPtr; + + end = source + numBytes; + for (p = source; p < end; ) { + next = p + Tcl_UtfToUniChar(p, &ch); + thisFamilyPtr = FindSubFontForChar(fontPtr, ch)->familyPtr; + if (thisFamilyPtr != lastFamilyPtr) { + if (p > source) { + TextFont(lastFamilyPtr->faceNum); + Tcl_UtfToExternalDString(lastFamilyPtr->encoding, source, + p - source, &runString); + MoveTo((short) x, (short) y); + DrawText(Tcl_DStringValue(&runString), 0, + Tcl_DStringLength(&runString)); + x += TextWidth(Tcl_DStringValue(&runString), 0, + Tcl_DStringLength(&runString)); + Tcl_DStringFree(&runString); + source = p; + } + lastFamilyPtr = thisFamilyPtr; + } + p = next; + } + if (p > source) { + TextFont(thisFamilyPtr->faceNum); + Tcl_UtfToExternalDString(lastFamilyPtr->encoding, source, + p - source, &runString); + MoveTo((short) x, (short) y); + DrawText(Tcl_DStringValue(&runString), 0, + Tcl_DStringLength(&runString)); + Tcl_DStringFree(&runString); + } +} + +/* *--------------------------------------------------------------------------- * - * AllocMacFont -- + * TkMacIsCharacterMissing -- * - * Helper for TkpGetNativeFont() and TkpGetFontFromAttributes(). - * Allocates and intializes the memory for a new TkFont that - * wraps the platform-specific data. + * Given a tkFont and a character determines whether the character has + * a glyph defined in the font or not. Note that this is potentially + * not compatible with Mac OS 8 as it looks at the font handle + * structure directly. Looks into the character array of the font + * handle to determine whether the glyph is defined or not. * * Results: - * Returns pointer to newly constructed TkFont. + * Returns a 1 if the character is missing, a 0 if it is not. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +int +TkMacIsCharacterMissing( + Tk_Font tkfont, /* The font we are looking in. */ + unsigned int searchChar) /* The character we are looking for. */ +{ + MacFont *fontPtr = (MacFont *) tkfont; + FMInput fm; + FontRec **fontRecHandle; + + fm.family = fontPtr->subFontArray[0].familyPtr->faceNum; + fm.size = fontPtr->size; + fm.face = fontPtr->style; + fm.needBits = 0; + fm.device = 0; + fm.numer.h = fm.numer.v = fm.denom.h = fm.denom.v = 1; + +#if !defined(UNIVERSAL_INTERFACES_VERSION) || (UNIVERSAL_INTERFACES_VERSION < 0x0300) + fontRecHandle = (FontRec **) FMSwapFont(&fm)->fontResult; +#else + fontRecHandle = (FontRec **) FMSwapFont(&fm)->fontHandle; +#endif + return *(short *) ((long) &(*fontRecHandle)->owTLoc + + ((long)((*fontRecHandle)->owTLoc + searchChar + - (*fontRecHandle)->firstChar) * sizeof(short))) == -1; +} + +/* + *--------------------------------------------------------------------------- + * + * InitFont -- + * + * Helper for TkpGetNativeFont() and TkpGetFontFromAttributes(). + * Initializes the memory for a MacFont 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 MacFont structure. + * * Side effects: * Memory allocated. * *--------------------------------------------------------------------------- */ -static TkFont * -AllocMacFont( - 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. */ +static void +InitFont( Tk_Window tkwin, /* For display where font will be used. */ - int family, /* Macintosh font family. */ + int faceNum, /* Macintosh font number. */ int size, /* Point size for Macintosh font. */ - int style) /* Macintosh style bits. */ + int style, /* Macintosh style bits. */ + MacFont *fontPtr) /* Filled with information constructed from + * the above arguments. */ { - char buf[257]; + Str255 nativeName; FontInfo fi; - MacFont *fontPtr; TkFontAttributes *faPtr; TkFontMetrics *fmPtr; CGrafPtr saveWorld; GDHandle saveDevice; + short pixels; - if (gWorld == NULL) { - Rect rect = {0, 0, 1, 1}; - - if (NewGWorld(&gWorld, 0, &rect, NULL, NULL, 0) != noErr) { - panic("NewGWorld failed in AllocMacFont"); - } + if (size == 0) { + size = -GetDefFontSize(); } + pixels = (short) TkFontGetPixels(tkwin, size); + GetGWorld(&saveWorld, &saveDevice); SetGWorld(gWorld, NULL); + TextFont(faceNum); + TextSize(pixels); + TextFace(style); - if (tkFontPtr == NULL) { - fontPtr = (MacFont *) ckalloc(sizeof(MacFont)); - } else { - fontPtr = (MacFont *) tkFontPtr; - } + GetFontInfo(&fi); + GetFontName(faceNum, nativeName); fontPtr->font.fid = (Font) fontPtr; - faPtr = &fontPtr->font.fa; - GetFontName(family, (StringPtr) buf); - buf[UCHAR(buf[0]) + 1] = '\0'; - faPtr->family = Tk_GetUid(buf + 1); - faPtr->pointsize = size; + faPtr = &fontPtr->font.fa; + faPtr->family = GetUtfFaceName(nativeName); + faPtr->size = TkFontGetPoints(tkwin, size); faPtr->weight = (style & bold) ? TK_FW_BOLD : TK_FW_NORMAL; faPtr->slant = (style & italic) ? TK_FS_ITALIC : TK_FS_ROMAN; faPtr->underline = ((style & underline) != 0); faPtr->overstrike = 0; - fmPtr = &fontPtr->font.fm; - TextFont(family); - TextSize(size); - TextFace(style); - GetFontInfo(&fi); + fmPtr = &fontPtr->font.fm; fmPtr->ascent = fi.ascent; fmPtr->descent = fi.descent; fmPtr->maxWidth = fi.widMax; fmPtr->fixed = (CharWidth('i') == CharWidth('w')); - - fontPtr->family = (short) family; - fontPtr->size = (short) size; + + fontPtr->size = pixels; fontPtr->style = (short) style; + + fontPtr->numSubFonts = 1; + fontPtr->subFontArray = fontPtr->staticSubFonts; + InitSubFont(fontPtr, faceNum, &fontPtr->subFontArray[0]); SetGWorld(saveWorld, saveDevice); +} + +/* + *------------------------------------------------------------------------- + * + * ReleaseFont -- + * + * Called to release the Macintosh-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( + MacFont *fontPtr) /* The font to delete. */ +{ + int i; - return (TkFont *) fontPtr; + for (i = 0; i < fontPtr->numSubFonts; i++) { + ReleaseSubFont(&fontPtr->subFontArray[i]); + } + if (fontPtr->subFontArray != fontPtr->staticSubFonts) { + ckfree((char *) 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( + CONST MacFont *fontPtr, /* Font object in which the SubFont will be + * used. */ + int faceNum, /* The font number. */ + SubFont *subFontPtr) /* Filled with SubFont constructed from + * above attributes. */ +{ + subFontPtr->familyPtr = AllocFontFamily(fontPtr, faceNum); + 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( + SubFont *subFontPtr) /* The SubFont to delete. */ +{ + FreeFontFamily(subFontPtr->familyPtr); +} + +/* + *------------------------------------------------------------------------- + * + * AllocFontFamily -- + * + * Find the FontFamily structure associated with the given font + * family. The information should be stored by the caller in a + * SubFont and used when determining if that SubFont supports a + * character. + * + * 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. + * + *------------------------------------------------------------------------- + */ + +static FontFamily * +AllocFontFamily( + CONST MacFont *fontPtr, /* Font object in which the FontFamily will + * be used. */ + int faceNum) /* The font number. */ +{ + FontFamily *familyPtr; + int i; + + familyPtr = fontFamilyList; + for (; familyPtr != NULL; familyPtr = familyPtr->nextPtr) { + if (familyPtr->faceNum == faceNum) { + familyPtr->refCount++; + return familyPtr; + } + } + + familyPtr = (FontFamily *) ckalloc(sizeof(FontFamily)); + memset(familyPtr, 0, sizeof(FontFamily)); + familyPtr->nextPtr = fontFamilyList; + fontFamilyList = familyPtr; + + /* + * Set key for this FontFamily. + */ + + familyPtr->faceNum = faceNum; + + /* + * 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; + familyPtr->encoding = GetFontEncoding(faceNum, 1, &familyPtr->isSymbolFont); + familyPtr->isMultiByteFont = 0; + FillParseTable(familyPtr->typeTable, FontToScript(faceNum)); + for (i = 0; i < 256; i++) { + if (familyPtr->typeTable[i] != 0) { + familyPtr->isMultiByteFont = 1; + break; + } + } + return familyPtr; +} + +/* + *------------------------------------------------------------------------- + * + * FreeFontFamily -- + * + * Called to free a 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; + 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((char *) familyPtr->fontMap[i]); + } + } + + /* + * Delete from list. + */ + + for (familyPtrPtr = &fontFamilyList; ; ) { + if (*familyPtrPtr == familyPtr) { + *familyPtrPtr = familyPtr->nextPtr; + break; + } + familyPtrPtr = &(*familyPtrPtr)->nextPtr; + } + + ckfree((char *) familyPtr); } + +/* + *------------------------------------------------------------------------- + * + * FindSubFontForChar -- + * + * Determine which physical 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. + * + *------------------------------------------------------------------------- + */ + +static SubFont * +FindSubFontForChar( + MacFont *fontPtr, /* The font object with which the character + * will be displayed. */ + int ch) /* The Unicode character to be displayed. */ +{ + int i, j, k; + char *fallbackName; + char **aliases; + SubFont *subFontPtr; + FontNameMap *mapPtr; + Tcl_DString faceNames; + char ***fontFallbacks; + char **anyFallbacks; + + 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]; + } + } + /* + * 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(&faceNames); + + aliases = TkFontGetAliasList(fontPtr->font.fa.family); + + subFontPtr = NULL; + fontFallbacks = TkFontGetFallbacks(); + for (i = 0; fontFallbacks[i] != NULL; i++) { + for (j = 0; fontFallbacks[i][j] != NULL; j++) { + fallbackName = fontFallbacks[i][j]; + if (strcasecmp(fallbackName, fontPtr->font.fa.family) == 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(aliases[k], fallbackName) == 0) { + goto tryfallbacks; + } + } + } + } + continue; + + /* + * ...then see if we can use one of the fallbacks, or an + * alias for one of the fallbacks. + */ + + tryfallbacks: + for (j = 0; fontFallbacks[i][j] != NULL; j++) { + fallbackName = fontFallbacks[i][j]; + subFontPtr = CanUseFallbackWithAliases(fontPtr, fallbackName, + ch, &faceNames); + if (subFontPtr != NULL) { + goto end; + } + } + } + + /* + * See if we can use something from the global fallback list. + */ + + anyFallbacks = TkFontGetGlobalClass(); + for (i = 0; anyFallbacks[i] != NULL; i++) { + fallbackName = anyFallbacks[i]; + subFontPtr = CanUseFallbackWithAliases(fontPtr, fallbackName, ch, + &faceNames); + if (subFontPtr != NULL) { + goto end; + } + } + + /* + * Try all face names available in the whole system until we + * find one that can be used. + */ + + for (mapPtr = gFontNameMap; mapPtr->utfName != NULL; mapPtr++) { + fallbackName = mapPtr->utfName; + if (SeenName(fallbackName, &faceNames) == 0) { + subFontPtr = CanUseFallback(fontPtr, fallbackName, ch); + if (subFontPtr != NULL) { + goto end; + } + } + } + + end: + Tcl_DStringFree(&faceNames); + + if (subFontPtr == NULL) { + /* + * No font can display this character. We will use the base font + * and have it display the "unknown" character. + */ + + subFontPtr = &fontPtr->subFontArray[0]; + 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 HFONT can (1) or cannot (0) display the + * characters on the page. + * + * Results: + * None. + * + * Side effects: + * Mempry 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. */ +{ + FMInput fm; + FontRec *fontRecPtr; + short *widths; + int i, end, bitOffset, isMultiByteFont; + char src[TCL_UTF_MAX]; + unsigned char buf[16]; + int srcRead, dstWrote; + Tcl_Encoding encoding; + + subFontPtr->fontMap[row] = (char *) ckalloc(FONTMAP_BITSPERPAGE / 8); + memset(subFontPtr->fontMap[row], 0, FONTMAP_BITSPERPAGE / 8); + + encoding = subFontPtr->familyPtr->encoding; + + fm.family = subFontPtr->familyPtr->faceNum; + fm.size = 12; + fm.face = 0; + fm.needBits = 0; + fm.device = 0; + fm.numer.h = 1; + fm.numer.v = 1; + fm.denom.h = 1; + fm.denom.v = 1; + +#if !defined(UNIVERSAL_INTERFACES_VERSION) || (UNIVERSAL_INTERFACES_VERSION < 0x0300) + fontRecPtr = *((FontRec **) FMSwapFont(&fm)->fontResult); +#else + fontRecPtr = *((FontRec **) FMSwapFont(&fm)->fontHandle); +#endif + widths = (short *) ((long) &fontRecPtr->owTLoc + + ((long) (fontRecPtr->owTLoc - fontRecPtr->firstChar) + * sizeof(short))); + isMultiByteFont = subFontPtr->familyPtr->isMultiByteFont; + + end = (row + 1) << FONTMAP_SHIFT; + for (i = row << FONTMAP_SHIFT; i < end; i++) { + if (Tcl_UtfToExternal(NULL, encoding, src, Tcl_UniCharToUtf(i, src), + TCL_ENCODING_STOPONERROR, NULL, (char *) buf, sizeof(buf), + &srcRead, &dstWrote, NULL) == TCL_OK) { + + if (((isMultiByteFont != 0) && (buf[0] > 31)) + || (widths[buf[0]] != -1)) { + if ((buf[0] == 0x11) && (widths[0x12] == -1)) { + continue; + } + + /* + * Mac's char existence metrics are only for one-byte + * characters. If we have a double-byte char, just + * assume that the font supports that char if the font's + * encoding supports that char. + */ + + 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. + * + *--------------------------------------------------------------------------- + */ + +static SubFont * +CanUseFallbackWithAliases( + MacFont *fontPtr, /* The font object that will own the new + * screen font. */ + 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 *subFontPtr; + char **aliases; + int i; + + if (SeenName(faceName, nameTriedPtr) == 0) { + subFontPtr = CanUseFallback(fontPtr, faceName, ch); + 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); + 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, (char *) name, (int) (strlen(name) + 1)); + return 0; +} + +/* + *------------------------------------------------------------------------- + * + * CanUseFallback -- + * + * If the specified physical screen font has not already been loaded + * into the font object, determine if the specified physical 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 + * font name. NULL is returned if the font object already holds + * a reference to the specified physical font or if the specified + * physical font cannot display the given character. + * + * Side effects: + * The font object's subFontArray is updated to contain a reference + * to the newly allocated SubFont. + * + *------------------------------------------------------------------------- + */ + +static SubFont * +CanUseFallback( + MacFont *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. */ +{ + int i; + SubFont subFont; + short faceNum; + + if (GetFamilyNum(faceName, &faceNum) == 0) { + return NULL; + } + + /* + * Skip all fonts we've already used. + */ + + for (i = 0; i < fontPtr->numSubFonts; i++) { + if (faceNum == fontPtr->subFontArray[i].familyPtr->faceNum) { + return NULL; + } + } + + /* + * Load this font and see if it has the desired character. + */ + + InitSubFont(fontPtr, faceNum, &subFont); + if (((ch < 256) && (subFont.familyPtr->isSymbolFont)) + || (FontMapLookup(&subFont, ch) == 0)) { + ReleaseSubFont(&subFont); + return NULL; + } + + if (fontPtr->numSubFonts >= SUBFONT_SPACE) { + SubFont *newPtr; + + newPtr = (SubFont *) ckalloc(sizeof(SubFont) + * (fontPtr->numSubFonts + 1)); + memcpy((char *) newPtr, fontPtr->subFontArray, + fontPtr->numSubFonts * sizeof(SubFont)); + if (fontPtr->subFontArray != fontPtr->staticSubFonts) { + ckfree((char *) fontPtr->subFontArray); + } + fontPtr->subFontArray = newPtr; + } + fontPtr->subFontArray[fontPtr->numSubFonts] = subFont; + fontPtr->numSubFonts++; + return &fontPtr->subFontArray[fontPtr->numSubFonts - 1]; +} + +/* + *------------------------------------------------------------------------- + * + * GetFamilyNum -- + * + * Determines if any physical screen font exists on the system with + * the given family name. If the family exists, then it should be + * possible to construct some physical screen font with that family + * name. + * + * Results: + * The return value is 0 if the specified font family does not exist, + * non-zero otherwise. *faceNumPtr is filled with the unique face + * number that identifies the screen font, or 0 if the font family + * did not exist. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +GetFamilyNum( + CONST char *faceName, /* UTF-8 name of font family to query. */ + short *faceNumPtr) /* Filled with font number for above family. */ +{ + FontNameMap *mapPtr; + + if (faceName != NULL) { + for (mapPtr = gFontNameMap; mapPtr->utfName != NULL; mapPtr++) { + if (strcasecmp(faceName, mapPtr->utfName) == 0) { + *faceNumPtr = mapPtr->faceNum; + return 1; + } + } + } + *faceNumPtr = 0; + return 0; +} + +static int +GetFamilyOrAliasNum( + CONST char *faceName, /* UTF-8 name of font family to query. */ + short *faceNumPtr) /* Filled with font number for above family. */ +{ + char **aliases; + int i; + + if (GetFamilyNum(faceName, faceNumPtr) != 0) { + return 1; + } + aliases = TkFontGetAliasList(faceName); + if (aliases != NULL) { + for (i = 0; aliases[i] != NULL; i++) { + if (GetFamilyNum(aliases[i], faceNumPtr) != 0) { + return 1; + } + } + } + return 0; +} + +/* + *------------------------------------------------------------------------- + * + * GetUtfFaceName -- + * + * Given the native name for a Macintosh font (in which the name of + * the font is in the encoding of the font itself), return the UTF-8 + * name that corresponds to that font. The specified font name must + * refer to a font that actually exists on the machine. + * + * This function is used to obtain the UTF-8 name when querying the + * properties of a Macintosh font object. + * + * Results: + * The return value is a pointer to the UTF-8 of the specified font. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------ + */ + +static Tk_Uid +GetUtfFaceName( + StringPtr nativeName) /* Pascal name for font in native encoding. */ +{ + FontNameMap *mapPtr; + + for (mapPtr = gFontNameMap; mapPtr->utfName != NULL; mapPtr++) { + if (pstrcmp(nativeName, mapPtr->nativeName) == 0) { + return mapPtr->utfName; + } + } + panic("GetUtfFaceName: unexpected nativeName"); + return NULL; +} + +/* + *------------------------------------------------------------------------ + * + * GetFontEncoding -- + * + * Return a string that can be passed to Tcl_GetTextEncoding() and + * used to convert bytes from UTF-8 into the encoding of the + * specified font. + * + * The desired encoding to use to convert the name of a symbolic + * font into UTF-8 is macRoman, while the desired encoding to use + * to convert bytes in a symbolic font to UTF-8 is the corresponding + * symbolic encoding. Due to this dual interpretatation of symbolic + * fonts, the caller can specify what type of encoding to return + * should the specified font be symbolic. + * + * Results: + * The return value is a string that specifies the font's encoding. + * If the font's encoding could not be identified, NULL is returned. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------ + */ + +static Tcl_Encoding +GetFontEncoding( + int faceNum, /* Macintosh font number. */ + int allowSymbol, /* If non-zero, then the encoding string + * for symbol fonts will be the corresponding + * symbol encoding. Otherwise, the encoding + * string for symbol fonts will be + * "macRoman". */ + int *isSymbolPtr) /* Filled with non-zero if this font is a + * symbol font, 0 otherwise. */ +{ + Str255 faceName; + int script, lang; + char *name; + + if (allowSymbol != 0) { + GetFontName(faceNum, faceName); + if (pstrcasecmp(faceName, "\psymbol") == 0) { + *isSymbolPtr = 1; + return Tcl_GetEncoding(NULL, "symbol"); + } + if (pstrcasecmp(faceName, "\pzapf dingbats") == 0) { + *isSymbolPtr = 1; + return Tcl_GetEncoding(NULL, "macDingbats"); + } + } + + *isSymbolPtr = 0; + + script = FontToScript(faceNum); + lang = GetScriptVariable(script, smScriptLang); + name = NULL; + if (script == smRoman) { + name = TkFindStateString(romanMap, lang); + } else if (script == smCyrillic) { + name = TkFindStateString(cyrillicMap, lang); + } + if (name == NULL) { + name = TkFindStateString(scriptMap, script); + } + return Tcl_GetEncoding(NULL, name); +} diff --git a/mac/tkMacHLEvents.c b/mac/tkMacHLEvents.c index 39f7836..bbf56fb 100644 --- a/mac/tkMacHLEvents.c +++ b/mac/tkMacHLEvents.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkMacHLEvents.c 1.21 97/09/17 17:19:00 + * SCCS: @(#) tkMacHLEvents.c 1.22 97/11/07 21:20:50 */ #include "tcl.h" @@ -361,10 +361,12 @@ ScriptHandler( if (tclErr >= 0) { if (tclErr == TCL_OK) { AEPutParamPtr(reply, keyDirectObject, typeChar, - interp->result, strlen(interp->result)); + Tcl_GetStringResult(interp), + strlen(Tcl_GetStringResult(interp))); } else { AEPutParamPtr(reply, keyErrorString, typeChar, - interp->result, strlen(interp->result)); + Tcl_GetStringResult(interp), + strlen(Tcl_GetStringResult(interp))); AEPutParamPtr(reply, keyErrorNumber, typeInteger, (Ptr) &tclErr, sizeof(int)); } diff --git a/mac/tkMacInit.c b/mac/tkMacInit.c index bb1f8b3..11f730a 100644 --- a/mac/tkMacInit.c +++ b/mac/tkMacInit.c @@ -4,7 +4,7 @@ * This file contains Mac-specific interpreter initialization * functions. * - * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * 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. @@ -41,7 +41,7 @@ QDGlobalsPtr tcl_macQdPtr = NULL; * * Results: * A standard Tcl completion code (TCL_OK or TCL_ERROR). Also - * leaves information in interp->result. + * leaves information in the interp's result. * * Side effects: * Sets "tk_library" Tcl variable, runs initialization scripts diff --git a/mac/tkMacInt.h b/mac/tkMacInt.h index fcb8174..7cbb21e 100644 --- a/mac/tkMacInt.h +++ b/mac/tkMacInt.h @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkMacInt.h 1.67 97/11/20 18:30:38 + * SCCS:@(#) tkMacInt.h 1.69 98/02/18 10:50:53 */ #ifndef _TKMACINT @@ -73,6 +73,24 @@ typedef struct TkMacWindowList { */ /* + * This structure is for handling Netscape-type in process + * embedding where Tk does not control the top-level. It contains + * various functions that are needed by Mac specific routines, like + * TkMacGetDrawablePort. The definitions of the function types + * are in tclMac.h. + */ + +typedef struct { + Tk_MacEmbedRegisterWinProc *registerWinProc; + Tk_MacEmbedGetGrafPortProc *getPortProc; + Tk_MacEmbedMakeContainerExistProc *containerExistProc; + Tk_MacEmbedGetClipProc *getClipProc; + Tk_MacEmbedGetOffsetInParentProc *getOffsetProc; +} TkMacEmbedHandler; + +extern TkMacEmbedHandler *gMacEmbedHandler; + +/* * Defines used for TkMacInvalidateWindow */ @@ -233,6 +251,7 @@ extern int TkMacGrowToplevel _ANSI_ARGS_((WindowRef whichWindow, Point start)); extern void TkMacHandleMenuSelect _ANSI_ARGS_((long mResult, int optionKeyPressed)); +extern int TkMacHaveAppearance _ANSI_ARGS_((void)); extern void TkMacInitAppleEvents _ANSI_ARGS_((Tcl_Interp *interp)); extern void TkMacInitMenus _ANSI_ARGS_((Tcl_Interp *interp)); extern void TkMacInvalidateWindow _ANSI_ARGS_((MacDrawable *macWin, int flag)); diff --git a/mac/tkMacKeyboard.c b/mac/tkMacKeyboard.c index a1dfad8..3c10b58 100644 --- a/mac/tkMacKeyboard.c +++ b/mac/tkMacKeyboard.c @@ -3,12 +3,12 @@ * * Routines to support keyboard events on the Macintosh. * - * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkMacKeyboard.c 1.14 96/08/15 15:34:00 + * SCCS: @(#) tkMacKeyboard.c 1.16 98/01/16 10:42:35 */ #include "tkInt.h" @@ -137,7 +137,7 @@ XKeycodeToKeysym( int index) { register Tcl_HashEntry *hPtr; - register char c; + int c; char virtualKey; int newKeycode; unsigned long dummy, newChar; @@ -146,8 +146,11 @@ XKeycodeToKeysym( InitKeyMaps(); } - c = keycode & charCodeMask; - virtualKey = (keycode & keyCodeMask) >> 8; + virtualKey = (char) (keycode >> 16); + c = (keycode) & 0xffff; + if (c > 255) { + return NoSymbol; + } /* * When determining what keysym to produce we firt check to see if @@ -161,8 +164,6 @@ XKeycodeToKeysym( return (KeySym) Tcl_GetHashValue(hPtr); } } - - hPtr = Tcl_FindHashEntry(&keycodeTable, (char *) virtualKey); if (hPtr != NULL) { return (KeySym) Tcl_GetHashValue(hPtr); @@ -190,60 +191,63 @@ XKeycodeToKeysym( /* *---------------------------------------------------------------------- * - * XLookupString -- + * TkpGetString -- * * Retrieve the string equivalent for the given keyboard event. * * Results: - * Returns the number of characters stored in buffer_return. + * Returns the UTF string. * * Side effects: - * Retrieves the characters stored in the event and inserts them - * into buffer_return. + * None. * *---------------------------------------------------------------------- */ -int -XLookupString( - XKeyEvent* event_struct, - char* buffer_return, - int bytes_buffer, - KeySym* keysym_return, - XComposeStatus* status_in_out) +char * +TkpGetString( + TkWindow *winPtr, /* Window where event occurred: needed to + * get input context. */ + XEvent *eventPtr, /* X keyboard event. */ + Tcl_DString *dsPtr) /* Uninitialized or empty string to hold + * result. */ { register Tcl_HashEntry *hPtr; char string[3]; char virtualKey; - char c; + int c, len; if (!initialized) { InitKeyMaps(); } - - c = event_struct->keycode & charCodeMask; - string[0] = c; - string[1] = '\0'; + + Tcl_DStringInit(dsPtr); + + virtualKey = (char) (eventPtr->xkey.keycode >> 16); + c = (eventPtr->xkey.keycode) & 0xffff; + + if (c < 256) { + string[0] = (char) c; + len = 1; + } else { + string[0] = (char) (c >> 8); + string[1] = (char) c; + len = 2; + } /* * Just return NULL if the character is a function key or another * non-printing key. */ if (c == 0x10) { - string[0] = '\0'; + len = 0; } else { - virtualKey = (event_struct->keycode & keyCodeMask) >> 8; hPtr = Tcl_FindHashEntry(&keycodeTable, (char *) virtualKey); if (hPtr != NULL) { - string[0] = '\0'; + len = 0; } } - - if (buffer_return != NULL) { - strncpy(buffer_return, string, bytes_buffer); - } - - return strlen(string); + return Tcl_ExternalToUtfDString(NULL, string, len, dsPtr); } /* @@ -377,7 +381,7 @@ XKeysymToKeycode( virtualKeyCode = 0x24; keysym = '\r'; } - keycode = keysym + ((virtualKeyCode << 8) & keyCodeMask); + keycode = keysym + (virtualKeyCode <<16); } return keycode; diff --git a/mac/tkMacLibrary.r b/mac/tkMacLibrary.r index c86954a..1d9c041 100644 --- a/mac/tkMacLibrary.r +++ b/mac/tkMacLibrary.r @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkMacLibrary.r 1.9 97/11/20 18:31:20 + * SCCS: @(#) tkMacLibrary.r 1.10 98/02/10 10:37:21 */ /* @@ -118,8 +118,6 @@ read 'TEXT' (TK_LIBRARY_RESOURCES+16, "msgbox", purgeable, preload) "::library:msgbox.tcl"; read 'TEXT' (TK_LIBRARY_RESOURCES+17, "comdlg", purgeable, preload) "::library:comdlg.tcl"; -read 'TEXT' (TK_LIBRARY_RESOURCES+18, "prolog", purgeable, preload) - "::library:prolog.ps"; /* * The following two resources define the default "About Box" for Mac Tk. diff --git a/mac/tkMacMenu.c b/mac/tkMacMenu.c index 33bb82b..a44636c 100644 --- a/mac/tkMacMenu.c +++ b/mac/tkMacMenu.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkMacMenu.c 1.107 97/11/20 18:33:09 + * SCCS: @(#) tkMacMenu.c 1.111 98/01/21 22:04:59 */ #include <Menus.h> @@ -18,11 +18,11 @@ #include <string.h> #include <ToolUtils.h> #include <Balloons.h> -#undef Status -#include <Devices.h> #include "tkMenu.h" #include "tkMacInt.h" -#include "tkMenuButton.h" +#include "tkMenubutton.h" +#undef Status +#include <Devices.h> typedef struct MacMenu { MenuHandle menuHdl; /* The Menu Manager data structure. */ @@ -46,7 +46,7 @@ typedef struct MacMenu { * The following are constants relating to the SICNs used for drawing the MDEF. */ -#define SICN_RESOURCE_NUMBER 128 +#define SICN_RESOURCE_NUMBER 128 #define SICN_HEIGHT 16 #define SICN_ROWS 2 @@ -139,6 +139,8 @@ typedef struct TopLevelMenubarList { #define MENUBAR_REDRAW_PENDING 1 +static int gNoTkMenus = 0; /* This is used by Tk_MacTurnOffMenus as the + * flag that Tk is not to draw any menus. */ RgnHandle tkMenuCascadeRgn = NULL; /* The region to clip drawing to when the * MDEF is up. */ @@ -166,6 +168,9 @@ static char *currentMenuBarName; * DString. */ static Tk_Window currentMenuBarOwner; /* Which window owns the current menu bar. */ +static char elipsisString[TCL_UTF_MAX + 1]; + /* The UTF representation of the elipsis (ƒ) + * character. */ static int helpItemCount; /* The number of items in the help menu. * -1 means that the help menu is * unavailable. This does not include @@ -182,7 +187,8 @@ static MacDrawable macMDEFDrawable; static MDEFScrollFlag = 0; /* Used so that popups don't scroll too soon. */ static int menuBarFlags; /* Used for whether the menu bar needs * redrawing or not. */ -static TkMenuDefUPP menuDefProc;/* The routine descriptor to the MDEF proc. +static TkMenuDefUPP menuDefProc = NULL ; + /* The routine descriptor to the MDEF proc. * The MDEF is needed to draw menus with * non-standard attributes and to support * tearoff menus. */ @@ -240,6 +246,8 @@ static void DrawTearoffEntry _ANSI_ARGS_((TkMenu *menuPtr, Tk_Font tkfont, CONST Tk_FontMetrics *fmPtr, int x, int y, int width, int height)); static void FixMDEF _ANSI_ARGS_((void)); +static void GetEntryText _ANSI_ARGS_((TkMenuEntry *mePtr, + Tcl_DString *dStringPtr)); static void GetMenuAccelGeometry _ANSI_ARGS_((TkMenu *menuPtr, TkMenuEntry *mePtr, Tk_Font tkfont, CONST Tk_FontMetrics *fmPtr, int *modWidthPtr, @@ -284,6 +292,8 @@ static void RecursivelyInsertMenu _ANSI_ARGS_(( static void SetDefaultMenubar _ANSI_ARGS_((void)); static int SetMenuCascade _ANSI_ARGS_((TkMenu *menuPtr)); static void SetMenuIndicator _ANSI_ARGS_((TkMenuEntry *mePtr)); +static void SetMenuTitle _ANSI_ARGS_((MenuHandle menuHdl, + Tcl_Obj *titlePtr)); /* @@ -308,7 +318,7 @@ static void SetMenuIndicator _ANSI_ARGS_((TkMenuEntry *mePtr)); int TkMacUseMenuID( - short macID) /* The id to take out of the table */ + short macID) /* The id to take out of the table */ { Tcl_HashEntry *commandEntryPtr; int newEntry; @@ -419,6 +429,7 @@ GetNewID( *menuIDPtr = returnID; return TCL_OK; } else { + Tcl_ResetResult(interp); Tcl_AppendResult(interp, "No more menus can be allocated.", (char *) NULL); return TCL_ERROR; @@ -655,7 +666,8 @@ TkpDestroyMenuEntry( * * Given a menu entry, gives back the text that should go in it. * Separators should be done by the caller, as they have to be - * handled specially. + * handled specially. This is primarily used to do a substitution + * between "..." and "ƒ". * * Results: * itemText points to the new text for the item. @@ -669,36 +681,41 @@ TkpDestroyMenuEntry( static void GetEntryText( TkMenuEntry *mePtr, /* A pointer to the menu entry. */ - Str255 itemText) /* The pascal string containing the text */ + Tcl_DString *dStringPtr) /* The DString to put the text into. This + * will be initialized by this routine. */ { + Tcl_DStringInit(dStringPtr); if (mePtr->type == TEAROFF_ENTRY) { - strcpy((char *)itemText, (const char *)"\p(Tear-off)"); - } else if (mePtr->imageString != NULL) { - strcpy((char *)itemText, (const char *)"\p(Image)"); - } else if (mePtr->bitmap != None) { - strcpy((char *)itemText, (const char *)"\p(Pixmap)"); - } else if (mePtr->label == NULL || mePtr->labelLength == 0) { + Tcl_DStringAppend(dStringPtr, "(Tear-off)", -1); + } else if (mePtr->imagePtr != NULL) { + Tcl_DStringAppend(dStringPtr, "(Image)", -1); + } else if (mePtr->bitmapPtr != NULL) { + Tcl_DStringAppend(dStringPtr, "(Pixmap)", -1); + } else if (mePtr->labelPtr == NULL || mePtr->labelLength == 0) { /* * The Mac menu manager does not like null strings. */ - strcpy((char *)itemText, (const char *)"\p "); + Tcl_DStringAppend(dStringPtr, " ", -1); } else { - char *text = mePtr->label; + int length; + char *text = Tcl_GetStringFromObj(mePtr->labelPtr, &length); + char *dStringText; int i; - itemText[0] = 0; - for (i = 1; (*text != '\0') && (i <= 230); i++, text++) { + for (i = 0; i < length; text++, i++) { if ((*text == '.') && (*(text + 1) != '\0') && (*(text + 1) == '.') && (*(text + 2) != '\0') && (*(text + 2) == '.')) { - itemText[i] = 'É'; - text += 2; - } else { - itemText[i] = *text; + Tcl_DStringAppend(dStringPtr, elipsisString, -1); + i += strlen(elipsisString) - 1; + } else { + Tcl_DStringSetLength(dStringPtr, + Tcl_DStringLength(dStringPtr) + 1); + dStringText = Tcl_DStringValue(dStringPtr); + dStringText[i] = *text; } - itemText[0] += 1; } } } @@ -715,10 +732,10 @@ GetEntryText( * We try the following special mac characters. If none of them * are present, just use the check mark. * '' - Check mark character - * '¥' - Bullet character + * '´' - Bullet character * '' - Filled diamond * '×' - Hollow diamond - * 'Ñ' = Long dash ("em dash") + * '„' = Long dash ("em dash") * '-' = short dash (minus, "en dash"); * * Results: @@ -736,19 +753,22 @@ FindMarkCharacter( * for. */ { char markChar; - Tk_Font tkfont = (mePtr->tkfont == NULL) ? mePtr->menuPtr->tkfont - : mePtr->tkfont; + Tk_Font tkfont; + + tkfont = Tk_GetFontFromObj(mePtr->menuPtr->tkwin, + (mePtr->fontPtr == NULL) ? mePtr->menuPtr->fontPtr + : mePtr->fontPtr); if (!TkMacIsCharacterMissing(tkfont, '')) { markChar = ''; - } else if (!TkMacIsCharacterMissing(tkfont, '¥')) { - markChar = '¥'; + } else if (!TkMacIsCharacterMissing(tkfont, '´')) { + markChar = '´'; } else if (!TkMacIsCharacterMissing(tkfont, '')) { markChar = ''; } else if (!TkMacIsCharacterMissing(tkfont, '×')) { markChar = '×'; - } else if (!TkMacIsCharacterMissing(tkfont, 'Ñ')) { - markChar = 'Ñ'; + } else if (!TkMacIsCharacterMissing(tkfont, '„')) { + markChar = '„'; } else if (!TkMacIsCharacterMissing(tkfont, '-')) { markChar = '-'; } else { @@ -781,6 +801,7 @@ SetMenuIndicator( TkMenu *menuPtr = mePtr->menuPtr; MenuHandle macMenuHdl = ((MacMenu *) menuPtr->platformData)->menuHdl; char markChar; + int indicatorOn; /* * There can be no indicators on menus that are not checkbuttons @@ -795,14 +816,14 @@ SetMenuIndicator( if (mePtr->type == CASCADE_ENTRY) { return; } - - if (((mePtr->type == RADIO_BUTTON_ENTRY) - || (mePtr->type == CHECK_BUTTON_ENTRY)) - && (mePtr->indicatorOn) - && (mePtr->entryFlags & ENTRY_SELECTED)) { - markChar = FindMarkCharacter(mePtr); - } else { - markChar = 0; + + markChar = 0; + if ((mePtr->type == RADIO_BUTTON_ENTRY) + || (mePtr->type == CHECK_BUTTON_ENTRY)) { + Tcl_GetBooleanFromObj(NULL, mePtr->indicatorOnPtr, &indicatorOn); + if (indicatorOn && (mePtr->entryFlags & ENTRY_SELECTED)) { + markChar = FindMarkCharacter(mePtr); + } } SetItemMark(macMenuHdl, mePtr->index + 1, markChar); } @@ -829,10 +850,12 @@ SetMenuIndicator( static void SetMenuTitle( MenuHandle menuHdl, /* The menu we are setting the title of. */ - char *title) /* The C string to set the title to. */ + Tcl_Obj *titlePtr) /* The C string to set the title to. */ { int oldLength, newLength, oldHandleSize, dataLength; Ptr menuDataPtr; + char *title = (titlePtr == NULL) ? "" + : Tcl_GetStringFromObj(titlePtr, NULL); menuDataPtr = (Ptr) (*menuHdl)->menuData; @@ -869,7 +892,7 @@ SetMenuTitle( * * Results: * Returns standard TCL result. If TCL_ERROR is returned, then - * interp->result contains an error message. + * the interp's result contains an error message. * * Side effects: * Configuration information get set for mePtr; old resources @@ -909,7 +932,7 @@ TkpConfigureMenuEntry( } if (menuPtr->menuType == MENUBAR) { - SetMenuTitle(childMenuHdl, mePtr->label); + SetMenuTitle(childMenuHdl, mePtr->labelPtr); } } } @@ -925,7 +948,9 @@ TkpConfigureMenuEntry( if (0 == mePtr->accelLength) { ((EntryGeometry *)mePtr->platformEntryData)->accelTextStart = -1; } else { - char *accelString = mePtr->accel; + char *accelString = (mePtr->accelPtr == NULL) ? "" + : Tcl_GetStringFromObj(mePtr->accelPtr, NULL); + char *accel = accelString; mePtr->entryFlags |= ~ENTRY_ACCEL_MASK; while (1) { @@ -971,7 +996,7 @@ TkpConfigureMenuEntry( } ((EntryGeometry *)mePtr->platformEntryData)->accelTextStart - = ((long) accelString - (long) mePtr->accel); + = ((long) accelString - (long) accel); } if (!(menuPtr->menuFlags & MENU_RECONFIGURE_PENDING)) { @@ -1018,11 +1043,17 @@ ReconfigureIndividualMenu( TkMenuEntry *mePtr; Str255 itemText; int parentDisabled = 0; + int state; for (mePtr = menuPtr->menuRefPtr->parentEntryPtr; mePtr != NULL; mePtr = mePtr->nextCascadePtr) { - if (strcmp(Tk_PathName(menuPtr->tkwin), mePtr->name) == 0) { - if (mePtr->state == tkDisabledUid) { + char *name = (mePtr->namePtr == NULL) ? "" + : Tcl_GetStringFromObj(mePtr->namePtr, NULL); + + if (strcmp(Tk_PathName(menuPtr->tkwin), name) == 0) { + Tcl_GetIndexFromObj(NULL, mePtr->statePtr, tkMenuStateStrings, + NULL, 0, &state); + if (state == ENTRY_DISABLED) { parentDisabled = 1; } break; @@ -1051,15 +1082,27 @@ ReconfigureIndividualMenu( if (mePtr->type == SEPARATOR_ENTRY) { AppendMenu(macMenuHdl, SEPARATOR_TEXT); } else { - GetEntryText(mePtr, itemText); + Tcl_DString itemTextDString; + int destWrote; + + GetEntryText(mePtr, &itemTextDString); + Tcl_UtfToExternal(NULL, NULL, Tcl_DStringValue(&itemTextDString), + Tcl_DStringLength(&itemTextDString), 0, NULL, + (char *) &itemText[1], + 231, NULL, &destWrote, NULL); + itemText[0] = destWrote; + AppendMenu(macMenuHdl, "\px"); SetMenuItemText(macMenuHdl, base + index, itemText); + Tcl_DStringFree(&itemTextDString); /* * Set enabling and disabling correctly. */ - if (parentDisabled || (mePtr->state == tkDisabledUid)) { + Tcl_GetIndexFromObj(NULL, mePtr->statePtr, tkMenuStateStrings, + NULL, 0, &state); + if (parentDisabled || (state == ENTRY_DISABLED)) { DisableItem(macMenuHdl, base + index); } else { EnableItem(macMenuHdl, base + index); @@ -1072,9 +1115,13 @@ ReconfigureIndividualMenu( SetItemMark(macMenuHdl, base + index, 0); if ((mePtr->type == CHECK_BUTTON_ENTRY) || (mePtr->type == RADIO_BUTTON_ENTRY)) { + int indicatorOn; + + Tcl_GetBooleanFromObj(NULL, mePtr->indicatorOnPtr, + &indicatorOn); CheckItem(macMenuHdl, base + index, (mePtr->entryFlags - & ENTRY_SELECTED) && (mePtr->indicatorOn)); - if ((mePtr->indicatorOn) + & ENTRY_SELECTED) && (indicatorOn)); + if ((indicatorOn) && (mePtr->entryFlags & ENTRY_SELECTED)) { SetItemMark(macMenuHdl, base + index, FindMarkCharacter(mePtr)); @@ -1116,9 +1163,9 @@ ReconfigureIndividualMenu( if ((mePtr->type != CASCADE_ENTRY) && (ENTRY_COMMAND_ACCEL == (mePtr->entryFlags & ENTRY_ACCEL_MASK))) { - SetItemCmd(macMenuHdl, index, mePtr - ->accel[((EntryGeometry *)mePtr->platformEntryData) - ->accelTextStart]); + char *accel = Tcl_GetStringFromObj(mePtr->accelPtr, NULL); + SetItemCmd(macMenuHdl, index, accel[((EntryGeometry *) + mePtr->platformEntryData)->accelTextStart]); } } } @@ -1396,6 +1443,31 @@ TkpMenuNewEntry( *---------------------------------------------------------------------- * * + * Tk_MacTurnOffMenus -- + * + * Turns off all the menu drawing code. This is more than just disabling + * the "menu" command, this means that Tk will NEVER touch the menubar. + * It is needed in the Plugin, where Tk does not own the menubar. + * + * Results: + * None. + * + * Side effects: + * A flag is set which will disable all menu drawing. + * + *---------------------------------------------------------------------- + */ + +EXTERN void +Tk_MacTurnOffMenus() +{ + gNoTkMenus = 1; +} + +/* + *---------------------------------------------------------------------- + * + * * DrawMenuBarWhenIdle -- * * Update the menu bar next time there is an idle event. @@ -1419,6 +1491,14 @@ DrawMenuBarWhenIdle( Tcl_HashEntry *hashEntryPtr; /* + * If we have been turned off, exit. + */ + + if (gNoTkMenus) { + return; + } + + /* * We need to clear the apple and help menus of any extra items. */ @@ -1527,9 +1607,14 @@ DrawMenuBarWhenIdle( if (menuBarPtr == NULL) { SetDefaultMenubar(); - } else { - if (menuBarPtr->tearOff != menuPtr->tearOff) { - if (menuBarPtr->tearOff) { + } else { + int menuBarTearoff, menuTearoff; + + Tcl_GetBooleanFromObj(NULL, menuBarPtr->tearoffPtr, + &menuBarTearoff); + Tcl_GetBooleanFromObj(NULL, menuPtr->tearoffPtr, &menuTearoff); + if (menuBarTearoff != menuTearoff) { + if (menuBarTearoff) { appleIndex = (-1 == appleIndex) ? appleIndex : appleIndex + 1; helpIndex = (-1 == helpIndex) ? helpIndex @@ -1577,7 +1662,12 @@ DrawMenuBarWhenIdle( for (i = 0; i < menuBarPtr->numEntries; i++) { if (i == appleIndex) { - if (menuBarPtr->entries[i]->state == tkDisabledUid) { + int state; + + Tcl_GetIndexFromObj(NULL, + menuBarPtr->entries[i]->statePtr, + tkMenuStateStrings, NULL, 0, &state); + if (state == ENTRY_DISABLED) { DisableItem(((MacMenu *) menuBarPtr->entries[i] ->childMenuRefPtr->menuPtr ->platformData)->menuHdl, @@ -1613,6 +1703,8 @@ DrawMenuBarWhenIdle( if ((menuBarPtr->entries[i]->childMenuRefPtr != NULL) && menuBarPtr->entries[i]->childMenuRefPtr ->menuPtr != NULL) { + int state; + cascadeMenuPtr = menuBarPtr->entries[i] ->childMenuRefPtr->menuPtr; macMenuHdl = ((MacMenu *) cascadeMenuPtr @@ -1620,7 +1712,10 @@ DrawMenuBarWhenIdle( DeleteMenu((*macMenuHdl)->menuID); InsertMenu(macMenuHdl, 0); RecursivelyInsertMenu(cascadeMenuPtr); - if (menuBarPtr->entries[i]->state == tkDisabledUid) { + Tcl_GetIndexFromObj(NULL, + menuBarPtr->entries[i]->statePtr, + tkMenuStateStrings, NULL, 0, &state); + if (state == ENTRY_DISABLED) { DisableItem(((MacMenu *) menuBarPtr->entries[i] ->childMenuRefPtr->menuPtr ->platformData)->menuHdl, @@ -1675,7 +1770,8 @@ RecursivelyInsertMenu( && (menuPtr->entries[i]->childMenuRefPtr->menuPtr != NULL)) { cascadeMenuPtr = menuPtr->entries[i]->childMenuRefPtr->menuPtr; - macMenuHdl = ((MacMenu *) cascadeMenuPtr->platformData)->menuHdl; + macMenuHdl = + ((MacMenu *) cascadeMenuPtr->platformData)->menuHdl; InsertMenu(macMenuHdl, -1); RecursivelyInsertMenu(cascadeMenuPtr); } @@ -1716,7 +1812,8 @@ RecursivelyDeleteMenu( && (menuPtr->entries[i]->childMenuRefPtr->menuPtr != NULL)) { cascadeMenuPtr = menuPtr->entries[i]->childMenuRefPtr->menuPtr; - macMenuHdl = ((MacMenu *) cascadeMenuPtr->platformData)->menuHdl; + macMenuHdl = + ((MacMenu *) cascadeMenuPtr->platformData)->menuHdl; DeleteMenu((*macMenuHdl)->menuID); RecursivelyInsertMenu(cascadeMenuPtr); } @@ -1826,7 +1923,8 @@ TkpSetMainMenubar( } } if (listPtr != NULL) { - menuName = Tk_PathName(listPtr->menuPtr->masterMenuPtr->tkwin); + menuName = Tk_PathName(listPtr->menuPtr->masterMenuPtr + ->tkwin); break; } } @@ -2028,15 +2126,15 @@ GetMenuAccelGeometry ( } else if (0 == mePtr->accelLength) { *textWidthPtr = 0; } else { + char *accel = (mePtr->accelPtr == NULL) ? "" + : Tcl_GetStringFromObj(mePtr->accelPtr, NULL); if (NULL == GetResource('SICN', SICN_RESOURCE_NUMBER)) { - *textWidthPtr = Tk_TextWidth(tkfont, mePtr->accel, - mePtr->accelLength); + *textWidthPtr = Tk_TextWidth(tkfont, accel, mePtr->accelLength); } else { int emWidth = Tk_TextWidth(tkfont, "W", 1) + 1; if ((mePtr->entryFlags & ENTRY_ACCEL_MASK) == 0) { - int width = Tk_TextWidth(tkfont, mePtr->accel, - mePtr->accelLength); + int width = Tk_TextWidth(tkfont, accel, mePtr->accelLength); *textWidthPtr = emWidth; if (width < emWidth) { *modWidthPtr = 0; @@ -2061,7 +2159,7 @@ GetMenuAccelGeometry ( if (1 == (mePtr->accelLength - length)) { *textWidthPtr = emWidth; } else { - *textWidthPtr += Tk_TextWidth(tkfont, mePtr->accel + *textWidthPtr += Tk_TextWidth(tkfont, accel + length, mePtr->accelLength - length); } } @@ -2163,21 +2261,31 @@ DrawMenuEntryIndicator( int width, /* width of entry */ int height) /* height of entry */ { - if (((mePtr->type == CHECK_BUTTON_ENTRY) || - (mePtr->type == RADIO_BUTTON_ENTRY)) - && (mePtr->indicatorOn) - && (mePtr->entryFlags & ENTRY_SELECTED)) { - int baseline; - short markShort; - char markChar; + if ((mePtr->type == CHECK_BUTTON_ENTRY) || + (mePtr->type == RADIO_BUTTON_ENTRY)) { + int indicatorOn; + + Tcl_GetBooleanFromObj(NULL, mePtr->indicatorOnPtr, &indicatorOn); + + if ((indicatorOn) + && (mePtr->entryFlags & ENTRY_SELECTED)) { + int baseline; + short markShort; - baseline = y + (height + fmPtr->ascent - fmPtr->descent) / 2; - GetItemMark(((MacMenu *) menuPtr->platformData)->menuHdl, - mePtr->index + 1, &markShort); - if (markShort != 0) { - markChar = (char) markShort; - Tk_DrawChars(menuPtr->display, d, gc, tkfont, &markChar, 1, - x + 2, baseline); + baseline = y + (height + fmPtr->ascent - fmPtr->descent) / 2; + GetItemMark(((MacMenu *) menuPtr->platformData)->menuHdl, + mePtr->index + 1, &markShort); + if (markShort != 0) { + char markChar; + char markCharUTF[TCL_UTF_MAX + 1]; + int dstWrote; + + markChar = (char) markShort; + Tcl_ExternalToUtf(NULL, NULL, &markChar, 1, 0, NULL, + markCharUTF, TCL_UTF_MAX + 1, NULL, &dstWrote, NULL); + Tk_DrawChars(menuPtr->display, d, gc, tkfont, markCharUTF, + dstWrote, x + 2, baseline); + } } } } @@ -2289,6 +2397,10 @@ DrawMenuEntryAccelerator( int height, /* The height of the entry */ int drawArrow) /* Whether or not to draw cascade arrow */ { + int activeBorderWidth; + + Tk_GetPixelsFromObj(NULL, menuPtr->tkwin, menuPtr->activeBorderWidthPtr, + &activeBorderWidth); if (mePtr->type == CASCADE_ENTRY) { if (0 == DrawSICN(SICN_RESOURCE_NUMBER, CASCADE_ARROW, d, gc, x + width - SICN_HEIGHT, (y + (height / 2)) @@ -2297,7 +2409,7 @@ DrawMenuEntryAccelerator( Tk_Window tkwin = menuPtr->tkwin; if (mePtr->type == CASCADE_ENTRY) { - points[0].x = width - menuPtr->activeBorderWidth + points[0].x = width - activeBorderWidth - MAC_MARGIN_WIDTH - CASCADE_ARROW_WIDTH; points[0].y = y + (height - CASCADE_ARROW_HEIGHT)/2; points[1].x = points[0].x; @@ -2311,11 +2423,14 @@ DrawMenuEntryAccelerator( } else if (mePtr->accelLength != 0) { int leftEdge = x + width; int baseline = y + (height + fmPtr->ascent - fmPtr->descent) / 2; + char *accel; + + accel = Tcl_GetStringFromObj(mePtr->accelPtr, NULL); if (NULL == GetResource('SICN', SICN_RESOURCE_NUMBER)) { leftEdge -= ((EntryGeometry *) mePtr->platformEntryData) ->accelTextWidth; - Tk_DrawChars(menuPtr->display, d, gc, tkfont, mePtr->accel, + Tk_DrawChars(menuPtr->display, d, gc, tkfont, accel, mePtr->accelLength, leftEdge, baseline); } else { EntryGeometry *geometryPtr = @@ -2327,7 +2442,7 @@ DrawMenuEntryAccelerator( leftEdge -= geometryPtr->modifierWidth; } - Tk_DrawChars(menuPtr->display, d, gc, tkfont, mePtr->accel + Tk_DrawChars(menuPtr->display, d, gc, tkfont, accel + geometryPtr->accelTextStart, length, leftEdge, baseline); if (mePtr->entryFlags & ENTRY_COMMAND_ACCEL) { @@ -2403,10 +2518,8 @@ DrawMenuSeparator( TkMacSetUpGraphicsPort(mePtr->disabledGC != None ? mePtr->disabledGC : menuPtr->disabledGC); - MoveTo(x, y + (height / 2)); Line(width, 0); - SetGWorld(saveWorld, saveDevice); } @@ -2447,7 +2560,7 @@ MenuDefProc( TkMenuEntry *parentEntryPtr; Tcl_HashEntry *commandEntryPtr; GrafPtr windowMgrPort; - Tk_Font tkfont; + Tk_Font tkfont, menuFont; Tk_FontMetrics fontMetrics, entryMetrics; Tk_FontMetrics *fmPtr; TkMenuEntry *mePtr; @@ -2562,7 +2675,8 @@ MenuDefProc( * that are lower than the bottom. */ - Tk_GetFontMetrics(menuPtr->tkfont, &fontMetrics); + menuFont = Tk_GetFontFromObj(menuPtr->tkwin, menuPtr->fontPtr); + Tk_GetFontMetrics(menuFont, &fontMetrics); for (i = 0; i < menuPtr->numEntries; i++) { mePtr = menuPtr->entries[i]; if (globalsPtr->menuTop + mePtr->y + mePtr->height @@ -2573,11 +2687,11 @@ MenuDefProc( continue; } ClipRect(&menuClipRect); - if (mePtr->tkfont == NULL) { + if (mePtr->fontPtr == NULL) { fmPtr = &fontMetrics; - tkfont = menuPtr->tkfont; + tkfont = menuFont; } else { - tkfont = mePtr->tkfont; + tkfont = Tk_GetFontFromObj(menuPtr->tkwin, mePtr->fontPtr); Tk_GetFontMetrics(tkfont, &entryMetrics); fmPtr = &entryMetrics; } @@ -2598,7 +2712,7 @@ MenuDefProc( break; case mChooseMsg: { - int hasTopScroll, hasBottomScroll; + int hasTopScroll, hasBottomScroll, tearoff; enum { DONT_SCROLL, DOWN_SCROLL, UP_SCROLL } scrollDirection; @@ -2640,8 +2754,12 @@ MenuDefProc( itemRect.bottom = itemRect.top + menuPtr->entries[i]->height; if (PtInRect(hitPt, &itemRect)) { + int state; + + Tcl_GetIndexFromObj(NULL, mePtr->statePtr, + tkMenuStateStrings, NULL, 0, &state); if ((mePtr->type == SEPARATOR_ENTRY) - || (mePtr->state == tkDisabledUid)) { + || (state == ENTRY_DISABLED)) { newItem = -1; } else { TkMenuEntry *cascadeEntryPtr; @@ -2652,10 +2770,17 @@ MenuDefProc( cascadeEntryPtr != NULL; cascadeEntryPtr = cascadeEntryPtr->nextCascadePtr) { - if (strcmp(cascadeEntryPtr->name, - Tk_PathName(menuPtr->tkwin)) == 0) { - if (cascadeEntryPtr->state - == tkDisabledUid) { + char *name; + + name = Tcl_GetStringFromObj( + cascadeEntryPtr->namePtr, NULL); + if (strcmp(name, Tk_PathName(menuPtr->tkwin)) + == 0) { + Tcl_GetIndexFromObj(NULL, + cascadeEntryPtr->statePtr, + tkMenuStateStrings, NULL, 0, + &state); + if (state == ENTRY_DISABLED) { parentDisabled = 1; } break; @@ -2707,9 +2832,17 @@ MenuDefProc( ClipRect(&menuClipRect); if (oldItem != newItem) { + int state; + if (oldItem >= 0) { mePtr = menuPtr->entries[oldItem]; - tkfont = mePtr->tkfont ? mePtr->tkfont : menuPtr->tkfont; + if (mePtr->fontPtr == NULL) { + tkfont = Tk_GetFontFromObj(menuPtr->tkwin, + menuPtr->fontPtr); + } else { + tkfont = Tk_GetFontFromObj(menuPtr->tkwin, + mePtr->fontPtr); + } Tk_GetFontMetrics(tkfont, &fontMetrics); TkpDrawMenuEntry(mePtr, (Drawable) &macMDEFDrawable, tkfont, &fontMetrics, @@ -2723,10 +2856,18 @@ MenuDefProc( int oldActiveItem = menuPtr->active; mePtr = menuPtr->entries[newItem]; - if (mePtr->state != tkDisabledUid) { + Tcl_GetIndexFromObj(NULL, mePtr->statePtr, + tkMenuStateStrings, NULL, 0, &state); + if (state != ENTRY_DISABLED) { TkActivateMenuEntry(menuPtr, newItem); } - tkfont = mePtr->tkfont ? mePtr->tkfont : menuPtr->tkfont; + if (mePtr->fontPtr == NULL) { + tkfont = Tk_GetFontFromObj(menuPtr->tkwin, + menuPtr->fontPtr); + } else { + tkfont = Tk_GetFontFromObj(menuPtr->tkwin, + mePtr->fontPtr); + } Tk_GetFontMetrics(tkfont, &fontMetrics); TkpDrawMenuEntry(mePtr, (Drawable) &macMDEFDrawable, tkfont, &fontMetrics, @@ -2742,7 +2883,9 @@ MenuDefProc( MenuSelectEvent(menuPtr); Tcl_ServiceAll(); tkUseMenuCascadeRgn = 0; - if (mePtr->state != tkDisabledUid) { + Tcl_GetIndexFromObj(NULL, mePtr->statePtr, + tkMenuStateStrings, NULL, 0, &state); + if (state != ENTRY_DISABLED) { TkActivateMenuEntry(menuPtr, -1); } *whichItem = newItem + 1; @@ -2755,7 +2898,8 @@ MenuDefProc( - globalsPtr->menuBottom) { scrollAmt = menuRectPtr->bottom - globalsPtr->menuBottom; } - if (!hasTopScroll && ((globalsPtr->menuTop + scrollAmt) < menuRectPtr->top)) { + if (!hasTopScroll && ((globalsPtr->menuTop + scrollAmt) + < menuRectPtr->top)) { SetRect(&updateRect, menuRectPtr->left, globalsPtr->menuTop, menuRectPtr->right, globalsPtr->menuTop + SICN_HEIGHT); @@ -2787,6 +2931,7 @@ MenuDefProc( } } if (scrollDirection != DONT_SCROLL) { + Tk_Font menuFont; RgnHandle updateRgn = NewRgn(); ScrollRect(&menuClipRect, 0, scrollAmt, updateRgn); updateRect = (*updateRgn)->rgnBBox; @@ -2801,7 +2946,8 @@ MenuDefProc( } ClipRect(&updateRect); EraseRect(&updateRect); - Tk_GetFontMetrics(menuPtr->tkfont, &fontMetrics); + menuFont = Tk_GetFontFromObj(menuPtr->tkwin, menuPtr->fontPtr); + Tk_GetFontMetrics(menuFont, &fontMetrics); for (i = 0; i < menuPtr->numEntries; i++) { mePtr = menuPtr->entries[i]; if (globalsPtr->menuTop + mePtr->y + mePtr->height @@ -2811,11 +2957,12 @@ MenuDefProc( > updateRect.bottom) { continue; } - if (mePtr->tkfont == NULL) { + if (mePtr->fontPtr == NULL) { fmPtr = &fontMetrics; - tkfont = menuPtr->tkfont; + tkfont = menuFont; } else { - tkfont = mePtr->tkfont; + tkfont = Tk_GetFontFromObj(menuPtr->tkwin, + mePtr->fontPtr); Tk_GetFontMetrics(tkfont, &entryMetrics); fmPtr = &entryMetrics; } @@ -2844,18 +2991,24 @@ MenuDefProc( menuRefPtr = TkFindMenuReferences(menuPtr->interp, Tk_PathName(menuPtr->tkwin)); if ((menuRefPtr != NULL) && (menuRefPtr->parentEntryPtr != NULL)) { + char *name; for (parentEntryPtr = menuRefPtr->parentEntryPtr; - strcmp(parentEntryPtr->name, - Tk_PathName(menuPtr->tkwin)) == 0; - parentEntryPtr = parentEntryPtr->nextCascadePtr) { + parentEntryPtr != NULL + ; parentEntryPtr = parentEntryPtr->nextCascadePtr) { + name = Tcl_GetStringFromObj(parentEntryPtr->namePtr, + NULL); + if (strcmp(name, Tk_PathName(menuPtr->tkwin)) != 0) { + break; + } } if (parentEntryPtr != NULL) { TkActivateMenuEntry(parentEntryPtr->menuPtr, - parentEntryPtr->index); + parentEntryPtr->index); } } - if (menuPtr->tearOff) { + Tcl_GetBooleanFromObj(NULL, menuPtr->tearoffPtr, &tearoff); + if (tearoff) { scratchRect = *menuRectPtr; if (tearoffStruct.menuPtr == NULL) { scratchRect.top -= 10; @@ -2982,7 +3135,7 @@ TkMacHandleTearoffMenu(void) { if (tearoffStruct.menuPtr != NULL) { Tcl_DString tearoffCmdStr; - char intString[20]; + char intString[TCL_INTEGER_SPACE]; short windowPart; WindowRef whichWindow; @@ -3092,8 +3245,10 @@ DrawTearoffEntry( { XPoint points[2]; int margin, segmentWidth, maxX; + Tk_3DBorder border; - if ((menuPtr->menuType != MASTER_MENU) || (GetResource('MDEF', 591) != NULL)) { + if ((menuPtr->menuType != MASTER_MENU) + || (GetResource('MDEF', 591) != NULL)) { return; } @@ -3103,13 +3258,14 @@ DrawTearoffEntry( 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, menuPtr->border, points, 2, 1, + Tk_Draw3DPolygon(menuPtr->tkwin, d, border, points, 2, 1, TK_RELIEF_RAISED); points[0].x += 2*segmentWidth; } @@ -3228,13 +3384,15 @@ TkpDrawMenuEntry( int padY = (menuPtr->menuType == MENUBAR) ? 3 : 0; int adjustedY = y + padY; int adjustedHeight = height - 2 * padY; + int state; /* * Choose the gc for drawing the foreground part of the entry. */ - if ((mePtr->state == tkActiveUid) - && !strictMotif) { + Tcl_GetIndexFromObj(NULL, mePtr->statePtr, tkMenuStateStrings, NULL, + 0, &state); + if ((state == ENTRY_ACTIVE) && !strictMotif) { gc = mePtr->activeGC; if (gc == NULL) { gc = menuPtr->activeGC; @@ -3246,17 +3404,23 @@ TkpDrawMenuEntry( for (cascadeEntryPtr = menuPtr->menuRefPtr->parentEntryPtr; cascadeEntryPtr != NULL; cascadeEntryPtr = cascadeEntryPtr->nextCascadePtr) { - if (strcmp(cascadeEntryPtr->name, - Tk_PathName(menuPtr->tkwin)) == 0) { - if (cascadeEntryPtr->state == tkDisabledUid) { + char *name = (cascadeEntryPtr->namePtr == NULL) ? "" + : Tcl_GetStringFromObj(cascadeEntryPtr->namePtr, NULL); + + if (strcmp(name, Tk_PathName(menuPtr->tkwin)) == 0) { + int cascadeState; + + Tcl_GetIndexFromObj(NULL, cascadeEntryPtr->statePtr, + tkMenuStateStrings, NULL, 0, &cascadeState); + if (cascadeState == ENTRY_DISABLED) { parentDisabled = 1; } break; } } - if (((parentDisabled || (mePtr->state == tkDisabledUid))) - && (menuPtr->disabledFg != NULL)) { + if (((parentDisabled || (state == ENTRY_DISABLED))) + && (menuPtr->disabledFgPtr != NULL)) { gc = mePtr->disabledGC; if (gc == NULL) { gc = menuPtr->disabledGC; @@ -3272,24 +3436,22 @@ TkpDrawMenuEntry( if (indicatorGC == NULL) { indicatorGC = menuPtr->indicatorGC; } - - bgBorder = mePtr->border; - if (bgBorder == NULL) { - bgBorder = menuPtr->border; - } + + bgBorder = Tk_Get3DBorderFromObj(menuPtr->tkwin, + (mePtr->borderPtr == NULL) + ? menuPtr->borderPtr : mePtr->borderPtr); if (strictMotif) { activeBorder = bgBorder; } else { - activeBorder = mePtr->activeBorder; - if (activeBorder == NULL) { - activeBorder = menuPtr->activeBorder; - } + activeBorder = Tk_Get3DBorderFromObj(menuPtr->tkwin, + (mePtr->activeBorderPtr == NULL) + ? menuPtr->activeBorderPtr : mePtr->activeBorderPtr); } - if (mePtr->tkfont == NULL) { + if (mePtr->fontPtr == NULL) { fmPtr = menuMetricsPtr; } else { - tkfont = mePtr->tkfont; + tkfont = Tk_GetFontFromObj(menuPtr->tkwin, mePtr->fontPtr); Tk_GetFontMetrics(tkfont, &entryMetrics); fmPtr = &entryMetrics; } @@ -3310,11 +3472,14 @@ TkpDrawMenuEntry( DrawTearoffEntry(menuPtr, mePtr, d, gc, tkfont, fmPtr, x, adjustedY, width, adjustedHeight); } else { + int hideMargin; + 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) { + Tcl_GetBooleanFromObj(NULL, mePtr->hideMarginPtr, &hideMargin); + if (!hideMargin) { DrawMenuEntryIndicator(menuPtr, mePtr, d, gc, indicatorGC, tkfont, fmPtr, x, adjustedY, width, adjustedHeight); } @@ -3344,13 +3509,13 @@ void TkpComputeStandardMenuGeometry( TkMenu *menuPtr) /* Structure describing menu. */ { - Tk_Font tkfont; + Tk_Font tkfont, menuFont; Tk_FontMetrics menuMetrics, entryMetrics, *fmPtr; int x, y, height, modifierWidth, labelWidth, indicatorSpace; int windowWidth, windowHeight, accelWidth, maxAccelTextWidth; int i, j, lastColumnBreak, maxModifierWidth, maxWidth, nonAccelMargin; int maxNonAccelMargin, maxEntryWithAccelWidth, maxEntryWithoutAccelWidth; - int entryWidth, maxIndicatorSpace; + int entryWidth, maxIndicatorSpace, borderWidth, activeBorderWidth; TkMenuEntry *mePtr, *columnEntryPtr; EntryGeometry *geometryPtr; @@ -3358,7 +3523,11 @@ TkpComputeStandardMenuGeometry( return; } - x = y = menuPtr->borderWidth; + Tk_GetPixelsFromObj(NULL, menuPtr->tkwin, menuPtr->borderWidthPtr, + &borderWidth); + Tk_GetPixelsFromObj(NULL, menuPtr->tkwin, menuPtr->activeBorderWidthPtr, + &activeBorderWidth); + x = y = borderWidth; indicatorSpace = labelWidth = accelWidth = maxAccelTextWidth = 0; windowHeight = windowWidth = maxWidth = lastColumnBreak = 0; maxModifierWidth = nonAccelMargin = maxNonAccelMargin = 0; @@ -3376,20 +3545,24 @@ TkpComputeStandardMenuGeometry( * give all of the geometry/drawing the entry's font and metrics. */ - Tk_GetFontMetrics(menuPtr->tkfont, &menuMetrics); + menuFont = Tk_GetFontFromObj(menuPtr->tkwin, menuPtr->fontPtr); + Tk_GetFontMetrics(menuFont, &menuMetrics); for (i = 0; i < menuPtr->numEntries; i++) { + int columnBreak; + mePtr = menuPtr->entries[i]; - tkfont = mePtr->tkfont; - if (tkfont == NULL) { - tkfont = menuPtr->tkfont; - fmPtr = &menuMetrics; + 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) { + Tcl_GetBooleanFromObj(NULL, mePtr->columnBreakPtr, &columnBreak); + if ((i > 0) && columnBreak) { if (maxIndicatorSpace != 0) { maxIndicatorSpace += 2; } @@ -3400,7 +3573,7 @@ TkpComputeStandardMenuGeometry( columnEntryPtr->indicatorSpace = maxIndicatorSpace; columnEntryPtr->width = maxIndicatorSpace + maxWidth - + 2 * menuPtr->activeBorderWidth; + + 2 * activeBorderWidth; geometryPtr->accelTextWidth = maxAccelTextWidth; geometryPtr->modifierWidth = maxModifierWidth; columnEntryPtr->x = x; @@ -3415,13 +3588,13 @@ TkpComputeStandardMenuGeometry( geometryPtr->nonAccelMargin = 0; } } - x += maxIndicatorSpace + maxWidth + 2 * menuPtr->borderWidth; + x += maxIndicatorSpace + maxWidth + 2 * borderWidth; windowWidth = x; maxWidth = maxIndicatorSpace = maxAccelTextWidth = 0; maxModifierWidth = maxNonAccelMargin = maxEntryWithAccelWidth = 0; maxEntryWithoutAccelWidth = 0; lastColumnBreak = i; - y = menuPtr->borderWidth; + y = borderWidth; } if (mePtr->type == SEPARATOR_ENTRY) { @@ -3433,6 +3606,9 @@ TkpComputeStandardMenuGeometry( fmPtr, &entryWidth, &height); mePtr->height = height; } else { + int hideMargin; + + Tcl_GetBooleanFromObj(NULL, mePtr->hideMarginPtr, &hideMargin); /* * For each entry, compute the height required by that @@ -3453,7 +3629,7 @@ TkpComputeStandardMenuGeometry( &modifierWidth, &accelWidth, &height); nonAccelMargin = 0; } else if (mePtr->accelLength == 0) { - nonAccelMargin = mePtr->hideMargin ? 0 + nonAccelMargin = hideMargin ? 0 : Tk_TextWidth(tkfont, "m", 1); accelWidth = modifierWidth = 0; } else { @@ -3466,7 +3642,7 @@ TkpComputeStandardMenuGeometry( nonAccelMargin = 0; } - if (!(mePtr->hideMargin)) { + if (!(hideMargin)) { GetMenuIndicatorGeometry(menuPtr, mePtr, tkfont, fmPtr, &indicatorSpace, &height); if (height > mePtr->height) { @@ -3506,10 +3682,10 @@ TkpComputeStandardMenuGeometry( } } - mePtr->height += 2 * menuPtr->activeBorderWidth; + mePtr->height += 2 * activeBorderWidth; } mePtr->y = y; - y += menuPtr->entries[i]->height + menuPtr->borderWidth; + y += menuPtr->entries[i]->height + borderWidth; if (y > windowHeight) { windowHeight = y; } @@ -3521,7 +3697,7 @@ TkpComputeStandardMenuGeometry( columnEntryPtr->indicatorSpace = maxIndicatorSpace; columnEntryPtr->width = maxIndicatorSpace + maxWidth - + 2 * menuPtr->activeBorderWidth; + + 2 * activeBorderWidth; geometryPtr->accelTextWidth = maxAccelTextWidth; geometryPtr->modifierWidth = maxModifierWidth; columnEntryPtr->x = x; @@ -3537,8 +3713,8 @@ TkpComputeStandardMenuGeometry( } } windowWidth = x + maxIndicatorSpace + maxWidth - + 2 * menuPtr->activeBorderWidth + menuPtr->borderWidth; - windowHeight += menuPtr->borderWidth; + + 2 * activeBorderWidth + borderWidth; + windowHeight += borderWidth; /* * The X server doesn't like zero dimensions, so round up to at least @@ -3589,6 +3765,7 @@ DrawMenuEntryLabel( int indicatorSpace = mePtr->indicatorSpace; int leftEdge = x + indicatorSpace; int imageHeight, imageWidth; + int state; /* * Draw label or bitmap or image for entry. @@ -3607,30 +3784,31 @@ DrawMenuEntryLabel( imageHeight, d, leftEdge, (int) (y + (mePtr->height - imageHeight)/2)); } - } else if (mePtr->bitmap != None) { + } else if (mePtr->bitmapPtr != NULL) { int width, height; - + Pixmap bitmap = Tk_GetBitmapFromObj(menuPtr->tkwin, mePtr->bitmapPtr); Tk_SizeOfBitmap(menuPtr->display, - mePtr->bitmap, &width, &height); - XCopyPlane(menuPtr->display, - mePtr->bitmap, d, - gc, 0, 0, (unsigned) width, (unsigned) height, leftEdge, + bitmap, &width, &height); + XCopyPlane(menuPtr->display, bitmap, d, gc, 0, 0, + (unsigned) width, (unsigned) height, leftEdge, (int) (y + (mePtr->height - height)/2), 1); } else { if (mePtr->labelLength > 0) { - Str255 itemText; + Tcl_DString itemTextDString; - GetEntryText(mePtr, itemText); + GetEntryText(mePtr, &itemTextDString); Tk_DrawChars(menuPtr->display, d, gc, - tkfont, (char *) itemText + 1, itemText[0], + tkfont, Tcl_DStringValue(&itemTextDString), + Tcl_DStringLength(&itemTextDString), leftEdge, baseline); -/* TkpDrawMenuUnderline(menuPtr, mePtr, d, gc, tkfont, fmPtr, x, y, - width, height);*/ + Tcl_DStringFree(&itemTextDString); } } - if (mePtr->state == tkDisabledUid) { - if (menuPtr->disabledFg == NULL) { + Tcl_GetIndexFromObj(NULL, mePtr->statePtr, tkMenuStateStrings, NULL, + 0, &state); + if (state == ENTRY_DISABLED) { + if (menuPtr->disabledFgPtr == NULL) { XFillRectangle(menuPtr->display, d, menuPtr->disabledGC, x, y, (unsigned) width, (unsigned) height); } else if ((mePtr->image != NULL) @@ -3672,7 +3850,11 @@ DrawMenuEntryBackground( int width, /* width of rectangle to draw */ int height) /* height of rectangle to draw */ { - if (mePtr->state == tkActiveUid) { + int state; + + Tcl_GetIndexFromObj(NULL, mePtr->statePtr, tkMenuStateStrings, NULL, + 0, &state); + if (state == ENTRY_ACTIVE) { bgBorder = activeBorder; } Tk_Fill3DRectangle(menuPtr->tkwin, d, bgBorder, @@ -3710,17 +3892,20 @@ GetMenuLabelGeometry( if (mePtr->image != NULL) { Tk_SizeOfImage(mePtr->image, widthPtr, heightPtr); - } else if (mePtr->bitmap != (Pixmap) NULL) { - Tk_SizeOfBitmap(menuPtr->display, mePtr->bitmap, widthPtr, heightPtr); + } else if (mePtr->bitmapPtr != NULL) { + Pixmap bitmap = Tk_GetBitmapFromObj(menuPtr->tkwin, mePtr->bitmapPtr); + Tk_SizeOfBitmap(menuPtr->display, bitmap, widthPtr, heightPtr); } else { *heightPtr = fmPtr->linespace; - if (mePtr->label != NULL) { - Str255 itemText; + if (mePtr->labelPtr != NULL) { + Tcl_DString itemTextDString; - GetEntryText(mePtr, itemText); - *widthPtr = Tk_TextWidth(tkfont, (char *) itemText + 1, - itemText[0]); + GetEntryText(mePtr, &itemTextDString); + *widthPtr = Tk_TextWidth(tkfont, + Tcl_DStringValue(&itemTextDString), + Tcl_DStringLength(&itemTextDString)); + Tcl_DStringFree(&itemTextDString); } else { *widthPtr = 0; } @@ -3882,7 +4067,8 @@ TkMacClearMenubarActive(void) { if ((menuBarRefPtr != NULL) && (menuBarRefPtr->menuPtr != NULL)) { TkMenu *menuPtr; - for (menuPtr = menuBarRefPtr->menuPtr->masterMenuPtr; menuPtr != NULL; + for (menuPtr = menuBarRefPtr->menuPtr->masterMenuPtr; + menuPtr != NULL; menuPtr = menuPtr->nextInstancePtr) { if (menuPtr->menuType == MENUBAR) { RecursivelyClearActiveMenu(menuPtr); @@ -3957,9 +4143,12 @@ FixMDEF(void) if ((MDEFHandle != NULL) && (SICNHandle != NULL)) { MoveHHi(MDEFHandle); HLock(MDEFHandle); - menuDefProc = TkNewMenuDefProc(MenuDefProc); + if ( menuDefProc == NULL) { + menuDefProc = TkNewMenuDefProc(MenuDefProc); + } memmove((void *) (((long) (*MDEFHandle)) + 0x24), &menuDefProc, 4); } + #endif } @@ -3974,7 +4163,7 @@ FixMDEF(void) * None. * * Side effects: - * Allcates a hash table. + * Allocates a hash table. * *---------------------------------------------------------------------- */ @@ -3991,4 +4180,9 @@ TkpMenuInit(void) currentMenuBarInterp = NULL; currentMenuBarName = NULL; windowListPtr = NULL; + FixMDEF(); + + + Tcl_ExternalToUtf(NULL, NULL, "É", -1, 0, NULL, elipsisString, + TCL_UTF_MAX + 1, NULL, NULL, NULL); } diff --git a/mac/tkMacPort.h b/mac/tkMacPort.h index 733e745..e05b7ba 100644 --- a/mac/tkMacPort.h +++ b/mac/tkMacPort.h @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkMacPort.h 1.52 97/07/28 11:18:59 + * SCCS: @(#) tkMacPort.h 1.53 98/01/08 14:59:32 */ #ifndef _TKMACPORT @@ -90,11 +90,12 @@ extern int strncasecmp _ANSI_ARGS_((CONST char *s1, #define XVisualIDFromVisual(visual) (visual->visualid) /* - * The following functions are not used on the Mac, so we stub it out. + * The following functions are not used on the Mac, so we stub them out. */ #define TkFreeWindowId(dispPtr,w) #define TkInitXId(dispPtr) +#define TkpButtonSetDefaults(specPtr) {} #define TkpCmapStressed(tkwin,colormap) (0) #define TkpFreeColor(tkColPtr) #define TkSetPixmapColormap(p,c) {} diff --git a/mac/tkMacProjects.sit.hqx b/mac/tkMacProjects.sit.hqx new file mode 100644 index 0000000..97ae8be --- /dev/null +++ b/mac/tkMacProjects.sit.hqx @@ -0,0 +1,800 @@ +(This file must be converted with BinHex 4.0) +:#d&bBfKTGQ8ZFfPd!&0*9%46593K!*!%PA%!N!4%'e0*9#%!!`!!PA&b6'&e!RX +!N!-@EhX!$3P8Dep04%9',VQ(b!4BE$J!20%U!*!$J!#3"!4J125YX`#3&!mM!*! +%rj!%68e3FN0A588"!,$B'6'a%)MK!*!'Fhm!N!B1R3!!h98!N!DCC`i!AFIem[- +jj3lP(TkERCDheq5$M%@jqk4QRbHR$MBGj(%*IhTQ-Xr1YlekmI16E#R[#$r##2m +)Pr!NQp$)2R,E5l)*2r*l32N4IQjMC*00f*E`k`JRYmrB%dEfQ3dBi8H1EBpXbEk +-2q'%E8CBY`*IApGRRAPb+[25)V62c3Kr`Lpb@r,Ef!9!0M$qp1eYi&29)#(%4)K +84%JiJa#eQ"#c"f`XNLc"NiPGEI-hHU24J"T92&'edqr6%lD#&*NNNAMF8-EM%JU +UjV)RbXD0K&`9a`p-**)pbDQ'[6je"*@C&*%XkA'j1r%HP!3i3j%(IjRV#PRQ8VQ +BSQ&5$IqcZ-k,XH1keI#($+Hb!IkCA2GGq%rQZXh`cq+kTq'IcA8[`$q(krE!I`S +25bimm)qk#hKm8,F-([PFGc8mcZDkCRJ8F"h'iabZZ`-H8lRZQr#BaR8rK-GdVRX +#(M1ilRI`Q-Per`q2@8`RBhaRFahDc1%k#mmAe&A"iebZZajcQ1ZLm*Kh)%[44J( +lfhQ+[HdMQC8m@b@b@&j$HNal3'HDdi2fp9h0c[++bT++YS#Z4K2U5M@X*j31l`h +H4)8eM$aHcHF0+RBe&!N%r8R2h!i+FcJ3EYH5GXbr8V&DMhU6C[DBTUXKj@VrQK[ +9D&[5cZEcq690mAMeMU44@5`3E0Z2i2+P9d-8f[c,rH%"Qr+!jY8dIkLe2cTS@"- +)G`fDl!qZ[GLqH2&EX@9QEiE@AZN%%-P)Hqa["J4Y$JB%$3F$JLDHLXTpq[hCjl( +EY"#N4pJI6"M9qYHq&E0kEl6GVbYeIPdI#&SPH&'FhNL%@KRC5DeU!PS5DA@YiSl +SJ9"JE4mSTpIRVP1FIS!f'!0D+fUmiIDBYpfrcmSGdb1aI9@PA2@*@ULE@%+3!*) +Je8++KG3++495&U4L5+Q3!%SKK6)S'e)FT(j)DC!![L"Y3D+"P!@T$G)rj#4)YC! +!BL'e3NU&9!ST&0*!T%q-0L&+AK)XD`-4F8f5VUcf+!lE#K[qmjaq2DVHk)pfD3U +YV(AcDj9&NVAh3FQkUV6"VG4@GC!!"8SG[XS@cPY'*0H2#6R[PrRc(+4GDA!65fm +AXDc+bVq)@19eVh'#EpSUEpc%8rY+S+-P9I+k9hVPkkUrYHK2Q1Q5Jf3l+e`0N!$ +VV8JU`1DfZ[VDmd&rYmHMYS*q8ffJV3EHMh[pZKrH6i-pN!"8mQaPd)[qrPc[p+$ +pbj'SIa@mhlM"(p@)p(C-SB3%D29"FNl-RE4Dh%m$e8fVc'j858Z`!5,4jS"N)88 ++NEj)GCmKRiAAHZk[&(32Fjd$LY`2H&,9Jqi4ERFY&,TbVJZ$$QbTlLD&j(C`(@4 ++(Y0*L([U6kK1TVTAZBq[3C%VP+pcl-L*F%kPViRi*hGLRU,'Y-+TjI3ckKaR32- +TGAS8L9L@[I&cLNCeNi'4"j[48e+684&Z$`DdMV2l!5JZEmJr!-Q-qE82j!#(cbQ +fN!"m,d6YE,1mERGqP`6eZR#44pli#'Q"A#U2UK'-0HDrDc0jfEBRrKFPmpi'd'f +SfAP1KQ[2c09JmjYYH`QjB$keM&@p-)PFieC8NMpI*91A&*1CFh[Q04%*rM,m64I +0d%P,HF(-I%NZ*GhY1GZPI+QUZfV,MZk@SVQhS#GU@GUHBjfaUqVj8QUCDhKI-'2 +AlFprjBm2&C'k@afhKKpVFYIX*#f)1PpC8+SX)C8Nka[G-8Ge25NX@d)FeQ82I[Z +"bZ*-kl,lHZk[I'MRLLhPC&BTF45ELV0FQq2Pa34H,[IrNCa&$P,T!)rYjSKdAdr +06R1Q+fEEmmBHM1f#G4MERphTLLR0mkZf2p2E%j4GfhTl9(KG-V1hCj9jkeEAe[U +U,ci9Ip@ec49cV5!%-L[c+J[*JAmZCYMXap!#0HGfZ+iImR%2@N,HQ#&r-U1N),r +J'DY8Ch18KPp$Mr(G95m3ki9KN[QC)2P#I$HmbZ*lFllH#Sh59C-@G"&cbi80lZ, +XiQ@YUY(iBXfjV!C2Y3@,33$l@X-L`3HX$CZ&K0a-@iTpVdb!)P1'C`CDGaCk+a( +Ad$4KLQ"aLB-!XD,9Sd6i9K#-HJ"2%c!&X4`r3'i*r+"%p`@A@Li@YK8'Saj!rm" +-Hm-5$Lpafm5d%RfM&[l`bS!Ar9(,b861-IV%85hUqeF8d1h(VJm+aN*f8j@C0%J +ET-Rb6F+$4-UQ53*rQ-#SmR[ES(pUB4h*Y*MSG"K,0Q-SDb!ra6r5h+cThUMJBBk +&G[&S!4f`5T68$&CU2mPf'Q@a3kL0B8(4M'"hP[9SMp@*j)!SqXc$i3"l%)I60%Z +R&dF1"`4R6jb0+h%!Pr9h6Z#NI@0J'haQ&bU3!$%Cb[6bA3NrD'K+qMP8S4!2pdA +McDQ3!'NJRJPA2,U5-@*j3'!5+B0cbRGFA!9Lmq$8LJ36%IM(DC+Q,3+%M*B3H5+ ++(YC(%F%3YDN,lHlbLSA+`R*E[3fHRQTlr8,45JV3XMG!mXa8GeE[+jZZM-HrqUc +iT8B)A35j%8j8d[G$qHZI)f6Tli9Zp5!Pf&*P!p``Pre[#!PZM'c%A&kc[-RA&@M +$)F2'1SqGmC4DYjY08KU`PpFfX%B#k$+@4p9B4-%p%A*PG8d&NRRqPPY%$UPKY!5 +-k1KGd'e&#iX2qklZ1NX`d%T+"VV40B&@T6S88D1kJVX!R*l'IR@C0aK8eE"5j3p +'L,04BBX%U+0''+#R'a03#a2m"%Erqef,QJ8R*,$662XUm%FqMIX2N!"Eiki%h*1 +!8qI[GPcIPp2-59`3&9'+I0326qBX#PB))rp`!iCKMeeSBqlQ3Pj98#lMP3A&cUX +15Lh(JS)l%)aP5,JDbeL'Y*CA)T3[`ppBKL4HN94(p+@pYRMmH`m)@r*#$#-$(G( +H[i@ZMmI[Z&RS9Jp5FTTeraf-N!"riEiEf!&$U4lScGEHhrkKqjbqABA)m0MqV,j +PC-*9'4Zk%k')%'k($K@CC1Fc-YLh#(*3CV2jdp1#ic5f5!5lK`)!(%jR69RD6pm +m$%6fN!!2@!Bh6J'1i@LdXmeYCq*D@eFlK2"p(2896I@@eJlLdl3@BYUfRK6-C9[ +Q8!UHh)(2JBNJSaJmkVQA[U1hB4H"i4ME9T%B*KV1$J2(iX@L!"a(![*2(%G@2Cl +#-3VN*!lrDJ(!lNQ+Bf`E4cSH1$*!FBa&)cNhPJSX``'VFJ8"1(bMN8h(&3IR$4` +MPHJNMV'H'8l5(FYAMA5-e'QfD*I33QfBlUr66AEh1)p"(iQj[U(BYUQqf+Fe#2Q +(''$($H,31S+ieA08qUB9K`Z)TXF%!6K3,*!!**r%&AZjR('RfUrL$mBp2$Ik!H0 +1i4!'-'jhQB0@d"%C(+8p+))2jRjib[FpjMk1i`4c(mGaJVNIaA'FZDGaL"HBqe! +m2Q,ZUF#qcpc61%i`pb%B(c,h0!k"!(2hYj2$G4U"d+h("jRlhE41#cmBph$LIm# +i4rF-#!)BGf-JI1NPbZUPP`malUch'"2J'+d-lc+QF4`RQ-j4(-HC6KV(Zj9m#-H +(P6b0BkcS!3l)qk2-r0-+Nm#"DcN15epRih#Q!3keYA-%KlZeFac(C1FliaaF-Te +11ajp)3#3!'19%bk5`)`qLL0iK(-#$Tb,6jiC-93CfZKqIa&!A-p8KJ3R2liMmbL +1G!8Hbl0%IZLMDAC-XYQT&DNDNdZlQ$Hr(JE@Qf,*"k5I*5HkQ%)!(2DJTK%S-9" +!KR%!Cm#iNT&q1qdq#J(L3EZ'3J!F4YG`"-I*VQ'((JU5l4k'Sh',I'h*HRN$k![ +bHZAUja5bBIY@d'q3!+qjSKGF`Ld@mei&IEIXI6&(GTMT,3m8"akF3&,aQ-JchUd +*4!lR+hCV8Pd@KJ2hC4!mlZ*-hY0ZM4!JAfQh4JL!!i@9-fMHr#HZ&!HNadJhD`+ +(5`hMe48TNCa1M`"JeKahrSr2Vmm4[de3M-MEA'Lr#'iR+#+4dDQ&G&`&"C-BCd5 +F0)R4GlR4)5FCiJRQ,UKJTN+!bLP@U&36NPj$)3$Tk3KFpP#-L)#J&b0Hh80aXKG +c#)L3!'#IaDM`I4DM)YlDCj%H"#06a42-hHkqXb[YajKi'4%k85B%`1(SM+kb`2q +6Z#*M%Tad!1KNfZRm5%kQRFjALL-N!"Ja&3J`,cVK0LB6F9dCL)`cV`NFiJRQKF) +RjIiE9iVM`%EZMh%)!1S3a6&fYGi%$Zi$cb%ma10b6M%Q3*(bFBSaMH+BB#MTbLR +mB#LMq5&NB"E$mF#*c92-BM5Z%iaJ)Zp46M##dAK3(-FVm"%Fl$JQ-G!K6!*Q-8% +rhda#F$EN2M[T1r$["VY"8T`"rJMD`Cf6!cMQ`k-)l!,ll"EFNX4RHM&TGa%F3Q[ +JklFV!Rm'[Ril21HA@1RYPhQ"Hp#!fcA"`m(X@[(@6(ir4FCIiB3($lA,hI&c$"# +cQr*jH#aPrLl$Zc$jA48QZ1f56'(qGZ+0Zrc'#Y-em*M+r-Q2JSlI@c%&Hf5cQEp +06b*JEJGh5@8bh(NA[`3'r!k,D6[40l0VY)+1hf3aE4FmCM+l*EM@QppR-Heee$& +m@fi&(Er9BMVLc'AqfR##MGpY-4fZ)j8i[T)e'!KQ0`2[h5aKGUCISfpZei#q'Ek +pZ!Q#(lSl!jSAdV2-Ac2HPm'2hTeeC6)2[*Jcr!$H@AM$'SY6AXFES12(m-l#[(Q +#iA[T0Y$a`hKR`m@RdR6QldXB2hiNEb(@M3HCh3V`B4c-1qG5H0!c*%PH,Gi)b)r +R24I`bcaq2m8Bmd0kVC!!Cj1ihF1[B'iaZmXK&bqpRH&BLGd-IQ"[)4iAV)4d$HY +F(i1Ima3m2#'GcLcdf4@Lhmb3!"l%'Y&[GalQ#[M$12ECcB0BbS8K[Af`cTeh"GJ +Y#88dm0G[Gri[i&(UUB%VD[2Z`KV%MrqerLKCAr[p>B2#,B#qQ2(cDKH"lXqJF +DF(`iZY[+mU!H,ilM&fiY!Ka5!E@EmRhX'['$JZGJ[Eq%fEAp#R6mZ1"1U(rQc3b +I"A18(K(m2`!!$3e8DdaTBR*KFQPPFbkjE$J!20%U!*!$J!#3"!4J125d13#3%4B +!!%kJ!*!%rj!%68e3FN0A588"!,$B"&#a%)MH!*!&!P"2!*!'2`d!!*5m!*!'8,8 +'q)klAkmMI''hf-4m`YH&hd)iECq%VqaDH)36YMY1&TN,cGjEU%`AHV+&Zr"&#GY +iDRK16kC[(*qdcrdGLq`MYeh)2X)AY[!LYr![mb5l)mIc)X[aA2KJ-F+AQC&p,[a ++ZmKQNB@6@ikl#5Il1V,`Uq00b#DF,$bbBSAAGF!kkmNYG*YH!`+`MbcN1GPN1E) +M#aNXj$ECVFZYXlbXXdPqCTlFcXZFTH9(Qq6C)0V,G60lb`Cf$MVGfRPTRA@3!0r +#VIF)h+8(#H6`0[6Ehl@lpX@$qb&Iq+),KrUP!mJA)9QZjh"$#GcNi1ekXZ%QN!" +XH"k"4jE)NZdZXN6i!S!&F1,6p5a1CrLMRmm*jHG[Jr`@IQ3Km!L(YjmZ!*cJ$cM +cFZ"AilJH"-&*3C!!@arNIhThN!"rc9Z#B1f(ZI2jA$l(dAcemAadBCJNY6JTP*0 +i6e40HhFG+9qUA`Za$f'r(33[2K`%2p$eGh`fi'"@b5a3kP[acRd*kVKb5-"VmaE ++TX0L[(bmd'p`6fF1FYkE1j4ERArpBqpL-Z+Fb3@G6[ILRh9bqR$0FNHqRldQ#&l +6dDqZa)29,bc&cE!D(hq[E,!q@*2lmrc"hVRM3H2"&IR6FSqF0"TXi"Pq13JHh"' +FGV4@+hH@*iUY*,UNY[mE9F%TRVeNi920NbH,"EqF2D`p84&aRPb&j!(-8hY@lZ# +Vk,Vec@3@5!FcJA9KHDQDDm9AmI0`I23Fmah'2QC2HH,a1M29j(6S)(QVXI'P#hG +APVC(iAb8R,rTClpCFp)hP$Q3!'rNccVT2B-Q&282mk"qqDZR,hDLJXGf!#G)%h! +*$"i9@IrdZUl,SA(NJT2@9*E1S9FXUGIQrVXS0YMR$LLb8LiGPH-Qq'MQLFGEH[r +hqQMQa6*0d!bFqh)(me@DR0pTE8EUZm`LmDh'UMkX[phGeU+qHl"Tmcf1cCM[&p9 +Ga2I9V!ZB6kd%9,@ElrIdF*)bqH60G`@(+[04Jq2-Gk$rk[&P$YAQqqXF*TM[(h# +BD$l@$T2-pami6$EILacdAN)p,fpmLIQ@FCKU[ZdFTTQ[PF0dmlf2`kAQqaN1-mc +h+eB[q2ijKjRQqmmF,RHqT'TMP[RQF*KY[R8FDXc('r2qq1M[a-(h)3jAQZqA1&a +P[PrR-0Gmri,$222p9`jA1ep+G6AII0braRce("DBldi1#mhh-)G&j[YT$S[0p`b +(*HEl"JI90l521UCfD!AdL'[0ajXZ0ap[A'XqqXF+ml&FZmjmIih$5[2p23kVc2G +&kcrirK@(kmhh"acUR#qM2V,'I,ce@[0YjN$Zq'lMX0jmY%RTljP$(25mT(c8eNE +cICR$*[2p,JIU"GmIFb![@KajEc%IpEr9I,c[0[2YiR#MqHLA$HEl!!Ik$,k2Fj! +!3ERL9JilcIFl("V04je*MmkU4j-A2RT0NrQSQAHCMpbS0A`-9FhQHj6$([2pE3j +lcIIh1H`chpFiY*L2Ypp[[MrLF,2cjG4ck9Iik#1hQ)rDZp9mj%$GiEZI`qhQ8d[ +8f'lc8A0hQ)qmk8AirLd('3CcRq2!kS14JCjqa(cdV+2QScl[-KpjhfdqCS9Mj[Y +E(1MRq06-%pYM2RSRYBR[[h#J,c'5-,IFDclklhhQ)eFCHr0khj2QSkr`c[LSV92 +QHjC$QrPqQi2-l[P2Fq"pe&HPQRl3I-`-Cma(,j'aVNUeqKlcNF0lcIFh1FKm@U8 +CL"k1l`81MjL2@H3Rc-HF6ap3hcM0-$+9Me2rIFamp!lQ(Abmlr[04jqQGq(l*!I +Q2RaIiI#%qIie"fSF(l2)Ah@qmCS92fJqqZ92QSrjJEc`d9YrbRc8&V-22YlJ`qB +MIqBqI"rP3!r(aacf0mc(h2QNqCJlU4&m[mq"2S#21[L)me9VRU4Qm6%M-I[JBaj +JeX0(lp1l+1@M,r`Gmr(Z[!-qlRr-I*rQ3'r(pimir*cjk1XrEllra1([QSrCp"2 +10d&plKI-aic(6)f2qBIj#"rpJ"V%4frkP2QS+rSU2Q)pC6lHJ$I"pdd1p(amp0I +210p%cHHI04qck1I-4eqRYq#M[cjY2RSS[43I2B)j%4re3$hLSrpphRb!*r$MSrm +alkK[NRB0cjQ21INIQSqHp'[QBiEjJ[R)QpN3(hhY5qDMKTQ,mI&'[$Nqm[i0mre +($XahkTZX[1PGq-LE[S'2pfBH`8F[r-IQ)qrRc8FIqNhc8F0I0ar[dJ0lF0Ym&Ed +Grp[I`GhY0-`1TiBe)($8K$1mR@@hZ,&FCXD2-hGKf6rXYalN02MLJkfQ49'ST8d +#Qm5QX#aa+V"6XAPX$MX"@idGMjf"[4`l'mYF3[p6F*p+-Y&V1rc-cHTkl15E2V2 +QQNlRZPQ(lT!!*6`EZX@kVM2`prIH-lNrqTJ6iR-lY-"#'AF"3TV+YNFEr**jka@ +PAX!fk+aENmHDY)d2r-I1A!!0qP-aUbI$[H&B2@bhShCa6fLl'[ml-&%ZP#kmb1h +@D&IU8Ea0D[GlaeDASQ3K+NbI`'EdIiA*3-1D0NpYfe9GUXd,80Jb5pd%MC%pdeN +e6f8ICc-Pq"q*dRVmV3Ti'"1,V6VE$cCkp'ED1&Yh0K"XcGQ@Xd9QSmpQLZl1YSr +*QNdI'`-f08cAE2MBmV$YCV214Te01KYd0ZGXQc`X$"XJYTFH*S%DiaAC9V#PB$[ +"9S)0"YX-YK*X)pK#X!eKfm'%cf61"S,0!aX(TR1f$@`Cf#k`9@#E`"D"l3(61GX +#YJ4X6pMfXFeKJm*@MfdKfd!f6P3CRB&Y)T-r@cbUQkdGfcUfG'cRf-UaM@-,arD +0V4YE#ECX6(KX(GQXX9&M5m,QJ#dlfh@fkQc6fD+bd@3EaKDGl6QE+$D2E,ICqV- +eCA2"aT302pY5*NGk)p-B'hifl@`0fDbc2@%Vc!DGIX#'J`d5Qh-3#'cTfI+!0'" +Mc"DDl60EClE@E+[C1V0YTK1beDD$X`PM8mG@PSQ2M5bEF,DaE%(Ba,)jBi214TS +0#YXE0XpXVGJdXbeRbm)fL3dcQhSfp-bSE16C,V2*BM2)4T!!65#E0MD)E!,C!,, +jB`2*KT(0RlIeBp[(PSm0$KXqYN*Xp0MNXD&MFmH'LNdG'cSfFf`XfFUab@%,*pX +hjm&(0lfcH+"Q1f4hcFFdYRhdjdGPUdY4QX6lSQ5TAG!39c0laNcK&EQ00efIfhM +*jTh6KCRYLm'2&fCefM4bqJ9"EJGpriUlejiq'5`8GMVNK%a6MhD'3IaGErVR1F5 +'3VbMUqDImlB-%Re%-h#F'6EcXYaGffr,AIGUKq,kD$BE-iH`NhZl(m8k'pBX6dj +8J[CL&`dAblGE6"8dZMA-FRAEmqfSN!![If6ajCSBCqBQJe0+icYfmMD(+Q'L#IH +*fFV-QILI,*GM6C62cG6Q03eq,Ba56AB[F*q*m9YEkk(LIEG5dKicpMQ"$pAjaEe +4dQDh8,NPLCAjR&@'[1&,eE+YJXEpT2CN@`'$D6LEE3,q*(Zc4F+JaV-03E`BV#m +%Z3c2&$p(dfcFi8M1DMU-1fc"@8fYHF-Pk1R5`afkCVi%dl["IcTJeUY64XDQYib +2&%DfM&C'16C0M&8-,1P+qG5qEJ4"2[39-3cl[i,TrMrj&*cGH'Z0Nh!,I+"0fMI +-Eh`1#,4*`'c!Gfj(cBied88RGhmT)Jc%6a-KZZqUQEh8A[XPlJTc#TK0p("@T*j +SVhC(6A@prMNLJ$%&bTX#qBDTE3[++S&9A!+8(fP(YD&31#(9KRZ!5Z2lG@'cIJZ +Hid+!hlce*VPJeGV+dUELZ@0E5f)hD9ZXrbHpbCjUIHUr`JkqFF(C6fcL&*Je2"M +Ba!%-c"6%D(5JL3#(G%[c8%%&dK(J34UXl&d!(r3m)@Hr`"SS!#%0V934iP`%!+- +[DN53!,T`1C%F&Jh(riDiV6b'+iRTPP[h5Dq3!$0J2kqa!#ccD(d!RhNE"`"NAN- +&N!$PdIS!"20@2!$r2&SIJ(%HV3q!1!rJ"c",D(dd!%YSI65J6fKp0($2)c-#N!! +RY$kaZl%#C)L*6N*SI@+LX4"DRjMS5$aD(pj)D(hLZL1d2TT15'KpiJ,C#De2A'! +cSI@*#q3QY$ja!4Z&eLFZB+$3qX3&pT2&@9cJ2D(eL3Z)*V3qFEfad2V%"HJ3@Tq +i3)C#ka2AJ#+d2R%"%iA@*blJQY$ka%9()V3qF9&A#+e2r(i1dVVLUJ0Ca-8rbd& +SIH+2@Le6jY5Ud2SN9"0#kj23H`QY6d,hKGBR)D#Jd2SN"1i6@Tq%)"K#kj03h3Z +YMkC'%PUIK1T$D(d5!MJ+V8p#S$bKp8N)G#Hd2JRe!+(e5@K'%eUIK)#C3ZZ6%*! +!8'Kp%U)F%PUIa(dFK0BR)5S(SI9*r$-(Q@i6AqBJY$j*eB(3qL69Di6@*kRD&MK +b8R8SY$j*eBR3qL6eMN,VNe4Z3ZZ6e2!UY$j*J4Q&eLFT3+E3qL3&+*8K0bP`U0$ +k*!9L&&UIT%#-3ZZ6&!K4D(ddcC23qL3&C"9DRk6!VN,VSbQIK0BRUCS3@TrN!ab +%eNG633QY6r)4$N,VNe+r&&UIP2UXd2UNe"Z%eLHPRL+d2LR9[0$kT&4A3ZZ6dMX ++V8p+XB6@4i&p#V3q+I8'SI9*#3!Vfib8hPjSI9)#CJUY6dVJ5k(e5@Qk&eUIP%C +fSI9*#A3Ui+,8acJ)V8rUlf`H`FGm),3q+G%f#De2@V1(d2UN03m)V8pDI9CSIG+ +UHi&NTY8,K0BRV4U6e8"Dlb@d2ZNZ-"JIS&qKp8N,`#Ud2QR0"d,VNaEd5@KpdS) +b#Df2TVX5@TrdA4aN1j2@$#5d2QP4aJLY6rVc()6@*k1j6QKp-TUA"$+488d,V8p +'r9jSI6,UZ8,VNe%r&9UIM2U8d2TNe#1%eLHMfK0DRicH@QKp-XT(D(db1JZY6dE +pAQKp-PVG#+e24U"XSIA*L*C&D(dbUPfKpFNmb%&SI6,Uj8,V8k(j8'Kp+P5l3ZY +6SGS9@Kp0[b@d2K@D(i6@Td)p8@Kp+P6E3ZY6S6F9@Tq+,MJB(h1Ed2T8U2F)V8q +&!1C#ke1K199SI5SdR`QY6iAkVY$kk$&CD(ddACF!Ll1Dpi6@*kXj5QKpXTT$K0B +RUei[Y$kDaNYSIE,U4d,VNe@G#ke29M8QY$jC[DA3qQ59Mp$kC09[K0BR+c#j`1H +bQLH%eLFVqLfKpFQ+DNeSIE+D,iA@*kH(&9UIR2U0d2VN0"X,VBqQ"K0DRjcU8QK +p0%fBd2VN0#m*VBqQ$"0DRjaQ!+(ebDQr#Ue26Me4D(ebkN&#kj06R3ZY6dke**3 +U1H8XY$kj1cN)V8rZEcN)V8p1ml63qZ5qb%&SICa!hrJq#q[rCK&fJp!"[8j3%P( +G[NaY@b*cCDRaFFi$5+q2m5`$5+qIH`B*p[-RN!"JcJ`H*&8ZKl&(X%HaGf([aKl +$YQ,IMEd(Hbrf2Z`*,,6[!,3!DU8GEbl&TdNCFeL)N!$b@!MpaQ((BkZa%l'6X*1 +a8l#AB+GLTf%[apCJVm$1`9k*[3Sl&cX2Hc9f2[BDl!,X3Z`Ll',X%Za5l$,XYGM +Pf&VXGGL9f&ABeGMVXAAB0GLef(ABpGJ0f"Z`'l'EX2ABcGJYf+hBEGJEX3hBlGJ +Gf*hB4Za0f&hB*ZblX,ZacGJpf,hBIGJ@l(lXcGJ$f&Z`Yf*[`pk12BLp!hZRE!% +#CCTELDqRm1PSVm`&P100dcY'5q2&m9ffd@[rcR-PU`HrXcSp@`#f8M09Dbj&Am' +(Z%qrPCZ@IUHb0&@E5m,%YT@ZP8r0*B*-F,apDK5p&j[!+Tkkf#TX'X[f[3+EaEC +LFpK+E"jEK4f((BqYaNl%3RJ+qHJ8l#ABUGKTf0RB'Z`9f$RB+l&ABHGLjf'[aXl +(AS0GJ&f)AB4GM&f#ABTGKVd@Zabl!RXGGL9f&ABepRTX(AB0GLef(ABpGJ2f"Za +'l#CX2ABcGJYf+hBEpNCX!hBlGJGf*lB4Ha0f&lB*qblXEQ`cGJpf,hBIYJ@l(hX +cpJ$f&ZbYf0Z`Yf-2BZr!(X)HaKl"(XAHKEdEH`clEZaa,+!0c6(TRCpCHmAIGcU +I-T!!Krpj5$E(i1H"QYN+'8Kc@h(!GG6rZ4"``iBpda28)9PEU(!aP33E,b"22i" +Ab`8IAUf#Ti5h9QGfCMkm@PeiE`D[,MapLHM4)iS%RdFE"d-+GK6-U%G##9i2I"U +i(`mEkNci(#[69,$GD8ULDYaSeHUeD,jJrBe@9e0C#RB9aZ*')fi'fk*QP05b1aE +D[k49A3c5*B*YUU@0X&@XQ[H"0)fEA@ppA)q6R[1"T$h`(UqejZ)`QHpHf&`,kr& +#chXUh0IeEBfEDGGhip6ihULCYV[qKQDYGhG(G0PM'69'cH@M[N12[3dh#QQSVQU +6hadYe2U"QUY*IDlhEXe4XjGJmr,F[PTc2YlAbk-PFcFZp-+e0,UHrE2TmT`#294 +99@M2%II+$be8G@TYK!Z4(!qNYAS@Y[$bHjZerHHj[(%e9m1k)TeHXNXENi@pcR% +kGKP[iLA%8DK2@jceBA2[D++dMHp1pi5i0RA$i@aSZ+V!TaEL*QQF6A(pXVl6Mli +RfZqH$1IHlN2LT$D-Xe6kpBejLejS&[9amj+DjAfLfBlYV@d$fG*-%jIqPL6ThU% +a50NFYY,H@UY(f0-d,1dq&6CF,Y['h2&Sh)#4dD5b,A,KYbAKR$PDh4Xe@'ALZEY +A(mUhE@*Vep98,[9Faq)dlMS,0E#ceNlRi[h@$eTlr8A9KGqTLJkr"jDEep&fZrX +HZeTTYe8eKG8PjcJH9YhYTVM@l,lpEZ3+lGSEZVI`'iMUELIUpER3"@Q1kS64VN) +KipK855)A$qrQ@YY9!%kr0V6h[[R)26(HaM"a6i*c6qK+'PqK&qa*V0!,CE+[ePk +f9c,G9,P1YUU$XF9iQaIaamEhYq)N"D[4PJECMCSU+SeUcLSN86YH6UT41f"`8I` +U06$K%&eGE9YZ+@M-jG0+L*BSA-V`(ZT`U'h0R@b@42YE39UYijIXJfQQVCKBGbr +l[@MLEY`b[K@I*H946l+kZ0'4a65S51qLD(R4M6YQ*`TM4FA"h4LQf82VjpLph%a +VG$"pXF@m1(A[E+T9!DcJVKX)ED%Q'KTCPDJVX9,j`U2Z6@'p(XG0TVrM,9+U'GX +`G[EC,P",S4bfk42DZcXk%*6(Yai06C,HDpSNe48r%A&+)RL9hGKZ",['TVIfXY( +hr14`Uq3+jG%i1e@`YbEIc906fC@1LP#Ar-,aqS@Ulb8Ib1TB"ffBhVQV&d-phEf +dkTJMULNdPDfeT*d@CU1&"K0&l#FG`Nd+dB5U@IqUfZj0mkrSj9em$"1LF,9BU1D +U&(q4,dMG+"56HI[LE99#IV2DXm4SIL6U6qq&i9hh16m36kTk$jI81qM8JNIF'Kj +p4Zre6ISmKRQCpXF)VJI086p"+ETL0[,,8,GZVihA(Aec&K1PLqU#[ULErH&kpfQ +#l(64PLmARdUZf'$baS@JrU+!lRc3pHQfT0TcIU(VS5lXI4ei5f-ZkQd$l05kDfl +2iejeeXX6$a5V,KfIliABf'T&B4)fh3"J(Uh%*U9,XRa$"bP8JSPJhITkmHjIm&+ +jb$kA%`qjhY-#mpBmcX)!EB$IPYrChQ[rfqqfaqk,eCjIej[f[8(4$ZIApAB$Ec[ +`IPde-2!'IIIlB[5phi9D((fMU"ik-KUS*lG!$aKpleGV9hM)6hr8k&X8$rRTHap +qM)Imp0h[cPpmjm(64GMK@Z-Krk'NZ1m6D6J*2R"4F2Yi*3iI$Ra$3+6!6F'9!aJ ++K"5F-[$3`$N$Ca1m5[!J`5X%p`m)+QJZi+%"*`8R&"`fF$I"E35)LSB&Ya%i+IL +Mi(Z#N`NH*##1P!*9!mm42%0`3-'M",q4*jD#pNS6KPV$NbJ%$a4m4h"-`DF$"JX +1+$LEi"2bq,CSUl3jH)iS3cLHi0J#q3hI%EaDF*A!F`@2%Ka&F"-"*S0VL,B)$aH +F5F$F2+iMH(NmS4T`f8%K!XqB*hkMA44(83a(Rl!06p!'A%r`#X%("jm9R(ZHQ!a +2M!E8+2!V`3B"VaYmER#h`H8'$a(m8h#fHEJd4J"@)r!6J8pM2H,Kdq![mM"URS! +5D#(J+S)2#@kNSSL5SL!5i+ZH+")ie1!FK01*%B44"Niiq0pB%M"k`)-%,a+m4ee +L1M`4(I#i`68&KaYmE(#f`G8'4aXM$jaXF,%a9X&$#1mG('a`Q6&D`G8%Ga0F6R# +NJG@$d`XU'ALGi",cK)1i&,i#rBEDBcTEk6F#T*16jA2'd@qi%$iAKGK3Tm2Hbhe +4U`@j$"iCYG2YDjbG'&qA3@E[Lp)#!'!&IIhc49%$H&$#+PbS8"!lelk-i9FH2-q +B+"Aii-%,@(GDr-U$'qr*m#X36,Y,m#YT`[[`d'k%U(Y!R-6&cc*iSPj1(8qD'Q1 +21l)3+@lNhLU1-V&,I4`J&kGm(+!6E6i1-))(qR%ma38[a3&HF'BP6Q`3"rM"Hh` +q`")HASQ6(X3"Z[#KVqIM1G3Yi!dIpR'!1$cTi`"pH+SITfI*SH)!MAMfkh9QifM +DD6p156q,d*rV1%!BR[0j!h0iAK5[qUf#GbbSd4%9I&pHHHr#)kKE3#db+qrBdH, +8p6rM'fQ&c[Nij8pN0la0[9E8"9L%XJ%cDiHB!@rcB'KGZ[mm[ArY-$*2Ialc%6" +"p`%mX&eRhJ!dd02!ekk0VkL*VdrIAK&baij%T%ii+ck82`8G4a9R1Y8'b((aESk +$6ffiK%T1FG#e(SLJ#6282aHq-Hd"*[mp8G+S0F2d1qRV-RE5S%Iqldl8UkMr0dZ +j''JX(669Eb8`cD0mVmE1aek$AB"GL&f%ABaGJPf+ABDp&VXF@iYGJEd1Za+l#VX +DHcff$VX'ZaDl$VXHZ`&l!hBMGK1f(VXCZ`@l&EX0Hb1f!EXGQmCQX"AB,$D&6@, +[`4kAG5dS(bMaJYD*BeE4!0D8DZhUXDZ+NQrhQ+K"i4dlGHcb3j[1ckM*&'9Sjdd +"G(GFP(6E(m&`a[@Q+VGE`U4CDbk)kkaiHmYm,BfI#!QCC[Q+T[2T69pUB-[q0!Q +Ib+pqZ3h2CJf%SfILC2k*faZVd!kf3AThH['*UjZ@DrAjImX*3VDHiZ'QSPa%XY5 +pFemY"DY9SH0Lcq-DFVlHdM+AHbY,#1c+YD,JqMe2amhqTl-irik,LK'`keC2Y@T +@399bpdAeBeF9Ff(I5i2M84#bjLK0[rE8F)I@P-*@+lYE!QB((6+i@Zk3!-(PBSI +XZ#QPd((4Hr6JTR5ji*,ZFZA(+RI5lYZ&HJpZPcTN6`e)0`XZYhI)i(DT3`CA5ad +bZ&VXN!!G0dYYTZ0kGfd91f6jrB)1fA@jYf+N3jCVaAE)MT[p6fFlC-G&1Q6RVCj +U,AE)i'UT3`CAfcYNZGGdGNK0UpM9(mh&lZjSVREd4[pHU36mDm&65qVGhDjdYeb +jjQkTQjSVYTHD#jhG-(M[8Ymb9hXkSEREf3I0aFiZD#jfp%$rAQFEm5ph9P"(pj- +AkqTpaD[Gp92UHe)9,h8preli@#pe22qDhqrXRDjUl1KejQ*RTc-AHrUFG)&5Pr- +UAGr5Y-2"e0J`8a!RmlfXNG[(6GdpP"b!Nl$*GYlF9cTfbh$K'"8"AAflP'VRf#D +TGYj8U3DhqP)e&G#CU1f(T66Y[8+5jNj(LJ(VlNZ0XRbpe#[,Gp[,Yh`pU1$bj9+ +V,GmYGY[1Uk8HeRPIfPMR6DpVYCG!d(QlEaHDErYYdhr,YdUP@ljEV0kZUlf2j"9 +hqGT)IEF2CMhAqjkh1%YdAKdS46Y4G0jNU1Lke[2iTG'LI,FdAC6[PZIHmZhLk0Y +jYHIaLJ0`A`rYETjpAE1RAAEhbDi''AE'cTEBe3YlQf"[pbZh[HjqepASZMYFHfZ +,HPTI-q[VBPhY+qaER3fV[90eYDMZhY6GP(Ul89FEkZ`rABeRB)!,TlH"d5fDfm+ +KV@pL'acAHQHe[N'YIdVV(p%kjl0`11ZEc-+aV'XQ1cH3!!e-B`1M@0mF0ML%p8j +JAH0Ahq`9$PlKe0@j9YNC0KH@NDM3HAGcA&hCPJD41qi@)jGUX"#cH+XBlD@UYHm +6h1aiRDkSl6H,89rld,@9cR"YS*%QCc4XG3Y1qSHcMBm0!*TJdG&"kS#MjE2p!1i +m04mFbU5PY!f$Q`m8La6pi!'NbEMFTJ6E$c+Z(cb%J!p(A$qSF2fJ$V%SLQM%fEC +Am[U"fLp1H,`Ih"X1CpXafRi`8BVQ"E$3l03CeCNH,CGDBr$kJ5)X5EPqi'Y8D8l +$jMb+X86GN!!#V+,eU!k4@bkcrQ$RJpbrp`0pdV,9kXV,Fh98Uc8dUrAPq@Jif"K +Kqd(&mre!6C91XQB3p)2XirXNC((GQ3jI@bRCIM$*qN%M&2q!L0X+jaCI96a[f&T +(X2fJQRQaDZfcfQ*Q1*h+2rkJJ99kcPl5*rSAH65@TNc%I259PGGeIdTfJ)LE(mZ +MCFc%drriAAI2cUaNq(SHHmCh9BTcLd'ehAiib$hbjZ$8b6lS1AY$jLX*h2-k`lH +[c86[appj@'QB2)CiHdZ5pRSrNmG#%q2rPhQFHj!!lqGa6ZVCDhN-*R)a$j6i,6f +`fGAVddF@1erDR*Gr#YVfUbjlAkBdF"Bmf0PYQ9"mGIFEf*2j$@mSj"ikR"&BkMb +'G*J1[`GdecU2Fq949LrBrkiRBD*`"15KK(AqrhG&XS#Aad!RZTM(N!#b$T8(&6[ +ik6cDJXAMI9Td)HT'l9eYlp1)4MbAUBP48T,Bq4e"(qC`(X-I$k+&!$S"mKK99e( +@apMpYD%`e!f3!!II%SVNKqm+CET-h*'BE[I(a+eHYLI''a0hP)FcB1,Hp616cdQ +j+L[$l2iF(j0lq+T[61iMHCbIh%Ib1$qj[jc(Uj2lF"l$NcZI61la"qlG1!4JFZp +pMlFQpqKKAjrFKr-i2lRhT[(Qj$kFKd0JFMqkm,pelrbBZ"9e9%q-0bEZ-!mq4m$ +%VCMGDRqL-#"Y+hqjEdp-+Sr"cR"KBKV*irbNmh)HVdik`hPFk15pHEcCbBIc''T +k+Jr0k$IF)E5Je[l2EL6k+d6PF@*1S[r#6`PH(FNM9hT'iPff9"U6,Jm(`2G+ae1 +NGP6LbhNFIhT@9(NFK`22Ck6VVHJMQ3)N&m#lMXd-K9Rk99AM,qFah$Q(kUa3(kG +2P0NVApi4j88pCRbfIIa-mmVFN@ZHh%*eIIi@kMZ[kfdIR3"je0IElB!@SaT)Q)I +UpEaVl2LHA'm0R3$[SEGp6S!m['hI3"iAYhh(dNBpZ,cXmRML(Qjr1(FrrUQAEXa +GI98Vq0(FM@pBIrR"h2@RU*NSC6,96HkIcGfBh*+lqPEL54l[9K9&lc&DCl*PD@d +p9DqX@(3MkXm$YE%aLE)GUhZpCA%#e+[HXMJ"mZ!cl5cfhAI9HDMbL(f[2Qk+Qdq +V2BZA5Z8K!*)M%G`a2(V%eJfI3$l86lrYUGf8qE`D'rMd$1-%b'2lRZ55)[D(lmT +8kUl!,!jmAE03qqI23MqZ$hm@qR'pMQkF4pE0kY1cd&MrS!-IU,@H3q#-[UYlBR2 +0*c29Mpj9jc'N!hSdMf')9qbP`pm`AJ2Ia8R(VB6a'[XF5aL[Nkd6dqR`Zel!LSe +1lJ@Xf0MR!-'+p6D3!$HaBQ'RGJ9JaD`qK*iJ&F-R*RG(a@6U"1LFES910IU0L(" +fIqad(#j-131IJf!Ai`CLbKRl(%Y-14Gh-6f*Z!Kf-HGL#121i1IHBY`CK[r(eJk +V`2qIRq$F'c`#&bD[hMcHQVbL"hPpmKV1`cR"Mh"amZT*a#h!Xf$b1(ULcNK#FC+ +DSD!rMKYJ)Y"j1#9i(`46KNbGRK'PkRNNUXSLL[%D%R8`Mp%Gh2"-l[a!IJl@Kj- +"q4Qqaa[)cm&h(GdeM0BphhR%jZ"lk$aH4@`1jU&iF9%,@Y(6U#`1llUR'GT)BSk +Gl12!mC6cFG"3@ZRMS,-dlq1JaE6+ad(AdMJI"dfRihdFG*p@qcKS3jhJik!IGD+ +2JmE856i11P3RqcKS9*hLik!,H+U2JhEJD6i1qS+RqcKS%,l8ad'6m!`I"lh#PrN +iD"UHkH1JFAK1,ij4U0m9KlPQELm1D[CliU#4H*k2JilLUhdFY"E2ph(3Bhb0Mi0 +Qi`8q$VU1&rSiD$pHj11J$hQaMi1'j#8q$MU6PrSil+D@q6MS9El@ad(6mR)I"ph +,Y6i1fTKAq$L`S&cRik!"HD@2J`lR96i1@TeAqcKSHDlcFGJTVI&ad!5peXG"0r3 +k(`GYdHYp(!3'E2"ad#KpJiq$MZQ02JjDTcIj11LKV[Ga8-klfFGKhE,&ad&lp9B +I"`cI0Kq(IGb02JiB[!BI"qQmfhdFpNSlI"`dCHrdFH#hDr4ad+CpNiq$IZeG2Jl +)iLBI"icRZh`FY(,[pR(3dphXik#jHiq2`i*lViq$!ZKp2Jlk[PYm($5!lrGa8"0 +pXiq$P[!$2Jjk`fraFG"RIUZ2JiEcfh`FG+$IlZ1J&IfJMi1Hp$Ym($5RhqRMS%[ +pN!#2JeEc`ci1HXk2q$LXGirk1+cBlr*af0THfBZ$'(JEacT34R#9M`1`rh)I"jD +Y@6i1h!kcI4a!$M8q6L[(+h`F8#GIm((!MAc4a`(eq1Xq$T@C@BP6$(L#ifriI&k +*icF'9ihfIAGb(!85#R"#jAR&QeY9N!!!*a6&#A"#84a`3Mlq*iS$6XM(%d9a!Ta +3&#I!#89a!Ta3&#I!#89a!Ta3&#I!#89a!Ta3&#I!#89a!Ta3&#I!#89a!Ta3&#I +!#89a!Ta3&#I!#89a!Ta3&#I!#89aCR2dm6p4(("#2[iRLJ01b-Ir4((!#IRiRbJ +11#%Ira2&!5INihqL11#%I2a2&!HFN!#2riRLJ"2bm6p4(("#2[iRLJ01b-Ir4(( +!#IRiRbJ11#%Ira2&!5INihqL11#%I2a2&!HFN!#2riRLJ"2bm6p4(("#2[iRLJ0 +1b-Ir4((!#IRiRbM1#SiqrLH+!dl)arp%FF!*qILI+!ii)4rr%m8"*q6MHU)ii)4 +m2'!8"jb3!)rrLH+!%r*a4e'F!#F8a3P`3P'F!#F8a3P`3P'F!#F8a3P`3P'F!#F +8a3P`3P'F!#F8a3P`3P%FF%)qrLH+!dl)ar9%F3+F8"3(R*!!Mrq*iS!6m[%r84a +`3Mlq*iS$6XM(rd4a`!Rjq*mS$MJK(rm6a3%Rj10rSMMJK(cm6a3(R*!!Mrq*iS! +6m[%r84a`3Mlq*iS$6XM(rd4a`!Rjq*mS$MJK(rm6a3%Rj10rSMMJK(cm6a3(R*! +!Mrq*iS!6m[%r84a`3Mlq*iS$6XM(rd4a`!Rjq*mS$MJK(rm6a3%Rj10rSMMJK(c +m6a3(PTB4r)q+!djS"2qMiS!6'X(rU$MJK%E`2bS11+%4r)q+!djS"2qMiS!6'X( +rU$MJK%E`2bS11+%4r)q+!hA+#2j(a3%Re)Ir+FDKJNG`24ILq)hKR4i#rJH85cS +XaQL3!(rlfm"RZ),M"hH*CQhX)jq#FfrZ8'jer[A(AY8*N!"PpiIQlErm%L#P`!5 +j!$lH`SfRfGdPTm(DD$4hZ(@#PrU"D,KhcfPfGmKTqRI2DAEh02@qFel3l2i$MHC +Z0-hZfD&cQYec3qFdZdmB3UIChI!&!P2QE$k$`RhNrGphlF@GcUpH1@5Y136IhFB +R@H`,Mp-AEZpdlKJ#S$A)kI8GJi`8AY"LArM0pkppiiFlRB1(KVVeK9pK@'LI&lj ++ArKQTr-*Tf(DcIE4"I)cdp0LB#YmZ@dc1l[DLI)[,LH4PT0U*A8%A6iDi%6JV40 +6ir56Xi0BL4HbZ+kTL)9qQPe[Y[-H1qqemb0fhQIR&M[[Yr20GRlBcJIXI)ZGElA +cEADqhFi(lAb(R3rCqE#GMpMjU*h[X[2GGMifH-lNbEX-QD'F&4EJT*h[Yr-T1lI +CqE5G(l$cJi1%8QZf145TUC(0&U,5cRNl9pPjR*h(flRDcK2X20(1Nq`mfFj6l(b +*RDIDfD[*kADqe-icl(bCR@IDqA)lcl,cE$[Af2N+1mqaFj1GVl6c9ADHDqGjGVl +Dc[2YI)fG&pKjSCdAfAQaRCIBHDQGPpRj@MX[Yh1YR9IBq6SlVl6cShCqc-kVl,c +DcYIEZFl1DqbmeXlVl,cHcK[XI)1G0pTjNjhVlHc9qaBlElAc0M[ID1F'1fmIY)l +-$mdZ5UE8iAJq+Ta93'$9LH@NQXQXdTe*$Ie*1kIXV-YARAAjUR2DcVVFe6Na5+m +LRh8NhG69eBV"eH`29UVe!L`UB&48kQd1kdKrP'KHAr!5[h332EIDS9YDXkI+@S5 +FRA9R8QIGfG6Ckf`k-h@qamlhfIhm),2+dbk-`U9-4*8k(&*k#3ZM'kBkcch8V+B +ej%5eYJX)cQjY-X'd0J[4rM3*fm9UiCAL"IBN+M%*`II1M+aLD`jfpLK`Tm-a"1F +jh%9`PF0$$XFir1(XDC%6"IFh[0j`GX2($@FNI*!!F$h#i`K()hc&F&2#1`NA0cc +EF'JVPFkaPf"RB#r$cX5LV@F@&ZjXH,(K[)E2'UjUH+MKQ)Br'QjSH*rKG)D['5j +QH*EK-SC(Q6H'VaJZB[6)`$8-Mc!F`I$r`Zd,Ebp!!rKfiFL&6aF1A,LQi+k&PaE +1@IKNiBU&"aD19rKEi@D&Ga919IK5i8+&ja318rK*U9Gi4H%-K3q854-H6lJSiCQ +%3a*p')i!jBj[ISRJe,A2bRfF-Ea,lH2KTr45Ap6El9C5qlMd`'CAVdmI@HamDA0 +HrLRh-@qpjhfCe,"CJ''bfm6U'Z2Z0l!Rma[H8-JpG$MEE$U@e$i1+9j6HBb)AK1 +9MXH1pfP4kDJEYAHe[8qlYe3kbX3GLDCfIdcF$L$0e)k&bGd0T*PkB(,RNmNprX# +p'iF!61lZ(mh8$S(*A@QG(UYl"iM@k9kPPQpURHjAI1N)Q,L(KE(QKPASBR91k&P +e6qJqG3,S0G8GaLQKMc4AHP*eYIQbTG+B-#F1J1q9MPI[+[(P2)ir25ZU2&$!#Ci +3*'AliaBU@X'8(!([1MBc&'ETSCRmBKl$RA1ScJVeFISj5DXMAei+33Gkc2KXqrL +CjT@j)pFmZBAUq[`Ye(GHepXq1J(bd%THMB65-!p42KSl[LIA@d-R`([SECm6)!p +[fcH3!-I&ECp@"2YBfHAaa$hFrR$ZI[a6,pfBZrUU9R"clXBhlEVmB1lk8p4-&1* +Z`KAF2jZlFImYZDY[*9j4%@cd(U0e*PZ@eYC6pFU+46HLrMbd)PJNVil9[Gkb1!( +U9@pCR!"jm*Pf&[[ZZqSm9(R%[PFI0mA0&3RiAX$'8[QCVGR,(d$+iG%MYQli"2, +K06A#Jc&H8b-m''2lRZ55)[D(lmT8kMK4+1pD8%FmQ)Z634eaH2m0GF5$-G`6QfZ +qmbU,4r)jVl,iA!d03EaL,ahqK[%Dq#j11QiPM0IBjeM#H&e8"0q6b!@Xf1MNAX# ++MAd1%+aBE`0j%bX@GQTA!&E-61k08E+`XK5Y'$iaZ6XU*P-R31Gd+h5Ud@qB+-F +"XY0aZ$$P$(`1JPf-'iJTCqac,$(PA0c&p#6L)YM&R)XKM$Z$RhZ,F@FBrKpE1k` +#rhpqJR0[m!KFQ,akmhKVmSSHj2A*DcJ2j`3r`XA*UbF4Y`$2JXP$Xk#'(dNSh3p +Q+1L2i`DB#(3H6JRH"m'8EBkV+b0+eI0)9*9&&1-e*1TJ(U-lZ1'Ch2Q"r"bX$bF +$mM0mMcH3!*q$lcUkDaLYHllcL-h"pp"j[)VB2*G(JX&!D4$4[r2PQc)b0VePI+3 +`XQ@d-XUaD@+X)U*PKmS(%lCMjS19A"erTUGH05&hi5Yd6&(Cm*8A10NQ*i*9Mm9 +jE"!(K['6ckTK9A&J)Eqr(kId,-8i-*@ImR&J-frcF@!lYkUp`cJ`SP[9hQ%F@01 +YDZm`$XcU9V9h'!IfGD[D1i`$3lY9l4h'BILeUVh$1$#p@pAHB4cBi+eUlc!1M2& +@YAFB"eCjUpSlM!1c[&AY(FD"IGkUpJlM`&"[9AZ(F@#aYkUp`cJ`h9[9hQ%Ff2# +YDZm`$Scj9V9h'!G@ID[D1i`$mlj9l4h'JChIU[B1im$JEe9lKh(BFPM9hQ%FP!" +BeGjK(03#@2AFB4`8"9Kehf%F9!GBeGjK(*3*@$AHB4c8#eJehQ%F"QqVaMZ-J`S +#UmBlM)05!U['1ib$QJ+VaMZ-`kEDU[%1ik$+`+Va$Z1JfX#Um3lMS#E"U[%1ik! +!BBH2!bH59HdGaN&0JPAM(FC"FB*9pah'3C@#9HdGaN'jJPAY(FC"hB*9l4h'B40 +Y9AZ(F9$*B&9lKh&3dQ"9HiGa80YJ9AZ(F9$NB&9lKh&3l@"9HiGa829J9AZ(F9! +!B99lKh&3#'&9HiGa8"&K9AZ(F9M5@YAHB4c85&M9hQ%FN!#r9V9h')FY[PAY(FB +"Z@Y9HiGa8%GK9AZ(FGK'@pAHB4a89PM9hQ%F@$'YDZm`$QSYV'V[-!k+,UaUlc! +1F"+VqMk-JrU,#Km(K4KC(`F9'6NI"m8GP6i1UMcb2Jl+2UTm(04rM20a8!JbhXG +"48LeMi25N!!*2Ji+2#Ek1+MdQ16MS14MXSm$q''+M`-fDDU2!kCKQSq$ESMT2Jk +d&jIk1($3cI"aB$kjc-F"!M66a`%&pG0q$`d3k)b2JlbG6r6L**q-Fi,M8rdi24! +"&3FNLUrL2IRNA[YqMVk+pbJ1'#*IaAX8"ab0Vq)pLJ1dcPIa(X8"1qLVH)rL2-M +49r%Ha6R$m9NI"qM3VrEMq++Ge&I%$k$mqMPIM`pcp0A$"hNAicc#d9F2(m9jP+1 +[(Mk+!hc59`mIaH&0I9A`8Cc(1AjjT8m9LN3j2[$01)A#FqDT3AGB[*p43BikS5` +,0&%Tkja63HjUD`0GrF"CThVE1DH5hPQ[JPcY&bF1Pe0"V[V"K+qT)#mSrR1RY3E +E$mB2R92&RKiZTiTGpB2-F$P9l+SIr%!P[300&E[U"pRKFUVB96qS(LkRLPheJdU +a()jSbh'HIUVcIE+bP!P#GV88J"-1dkkr42#Lrc2fD$G$djAcl@ZFR4KI0p&-Sk3 +CTBAarDdkR%P[-"mdX*mQV0T6Rf09F*GpQ3eVPLFR+X'qU8`4[aB1FfBRbU$JB&U +$`U#klIPp%dIb&ppjm!cTVCUCQ`a1+Bh[f!NAak&+Q!JTq-4XCHC-r%q@bl&f&-r +0e1D&,2TD'+AU+Lp`RkR`@e[VSH*pY`*%4jhrX*9%iSCiF5pXX8Vi4Z@@*'BbLTq +aDM"JTfUC2M5djX4@lFQdLIeLG[&XTJ2X6l)h@b6ZmVMdUm9ba@"p)FMpA1CE,'e +3m5XXRKSXicHE6fNGb[qZTBMq)#@l)mlR*1Y`lY2[RCR%j))'Ud5'`8PRZMmGq4U +XA('DHV3qADHFTKkY3pJeTk%Q09a13ifD$h,Id9$M11X(fH&b'QUd$R6AR#B[dI6 +RLY28SrA,&c68p2-"1dqrNkhUm&J0099VRad'(9lFm)IElBH$h#0[$NkGl*15CQr +)I&fmP2%Mem,eTFiI2k`dA%cFm2he#M'P9l!GpIUGIVfkNlMKA3+FlXH1pfRKG1q +YHpZReAjh*1'Kclh&$5q6Hb69CmE`0k8qMS80J"Y)UFr3"N#V%(-(E!$F2dTpKMB +!+Sq4*8""BFpBh6Y!&2EdkJ0i8f&2[mi!4m$%25c()MHX3Sf&Fd*&KAY#EB363#@ +%lM"1#981ZG)cf,jXU63'SlF,i(ZPip@l5R`jMq02ciSU$h3A`'a`%N'JlBpEU1J +M'CHi#q"GafD'`L`p0*0Ic'1iF`l9@D%q6MmRT',NbcmVLA"mYRhm622+h*&V[M( +GGRl&kED`IA3#j+(eBaMK$Q%HRN+kJAflhKSk!Gj$ErZF!(Piflk"2#jZql31MCf +(A"j2S!-JmD,m,[a6,pfBAhIa2F(0qH,&ZkEq0&miI)53!0-KX2TRh2p+[MMcD(l +Gj9Nq[Jk0k$e'kdbf,+fYTqU9&8Zd(6&jD"dD#+dBUhZpCA%#e+[HXMJ"mZ!6(4S +rHPHGKbU2J5h8D"l['([8@#U5pH"c!iRD1VLlRBBRTMN(`SG!XAIZ#"V&P1B(aY" +iT9S(IGE3V+@eX&il%'e0`S9'e2c@A-8%&[ZI#8bRE[,I%b@0@M0-[jfqHX2N9bq +Pdb9NE6KG+M["'P+0TITh[Ra64XDQYib2&%DfM&C'16C0M&9'KUf8`(eB@2dDX%V +9DN`BCj!!T)hBQl#lX+bY8F5k'pZ-4I(UAZ`qE!Yf2rCQl!(X,GKEXHblMQ#"-X- +C"!Tp'jEP*V[[$*BC!a9d15cU@r2B+Lb+AFGMUl%X4LGL*f%RUf59[33l&BZD9m8 +R&RX*GJB@4DmcXCGMCf&RBpPJAS'GJld5Ha9f,RBHPP*(PH`ef!9BN!!2Ll#,X8Z +`5l(`96%Y,-I@BPGJP5VBQ,ETUl#VXGGM%8Ha"VX@Z`kl(VX"b`*d)aBd,&YV8+K +EX'a%%eJQ&2CrDHcYf0ZX,P%Xbl+5pA3VPMdr@hL@c'$%6Q$C20,$hqlM+['(XIG +K6f,[ajl#YQ&2Bar!2SJpJhd[pK(XSpLcf-H`Mf1EXAZ`Hl(lX#hBrGLEX3H`Yf" +[aGk'[4el%(X(pK$f-2B)pLMf,ZcGf'2B*Q`P0SqY`Sl$MXG@BbGJ*f)RB5GMTf! +[`8l&6X01aek+RB'p$$X6HcPf&RBfYJCl"AB1pNVX9GLjf(RBUl(cXGGJ&f!ABKG +K&f1AB*GLPf'[a5l(eQ*AB+r$VX5Z`Ul'ASqY`kl"VX@Z`kl(EX$HJ0f)hB5Yafl +'EX&Za@l$hSKY`'l(SJi`Jkh!CV%TE"*l$eEeJFIS(91#4MXpYZ[2ISEb1FZp-L" +KqJ1%jaiphhjapEEjh+22f'rRJfV(*VrN2rE[,IYJ2lrL[6[Sj9jqaAYT+HkYc06 +k9Vlf!reqPIiEp@0cEjrk)2f3!(Yrh)ZAqa"[i%ha'F9pdX@l@Re@pZDCYfYf-I& +qjpHYPj,1LqV2jYlrZ-pQ$Y+KGipcpclp6cD(F*eFPlRmjQVZ%*A8&CSV6(k9NjT +lQ&FB0G5-NbklHl29Vl@#B"AfhfK1-IPprJDEDmLErMr$a@[42-5XSlk2m,icMVK +lLhr,jKrL-3YNA"lIqi,040aMYTVZl[h"ApUFa,frdUqchCV(H%2Z2DlBjYiHc6V +-8lbVQXhL,Vr+efSfBXDLI*L"kPaqrel[apa&(Y4CPBYh4$-GXaMMQ(U2q(hZAS0 +Q(HBciU'3!0M83H9@jFI-aVf[pH[l'Fe)c('Nb9cc[,[hUHjXarMfHI+Ek[*Se"c +%[%GUc'92ZA[[8`dc!e*rc%P,A"iIHk20KBb![d92-1qAq`2e*fC&4M49caPlebH +[YIP4I8r6,eGeij%c-b@Mip-FcME5Y[UVREfqqbqmbIa'QM%Sf([V2SRlTaTTA61 +E[CHk8M@UiY&hlEhNErIVq0($0XGbli9H[mapp+-ffh,[$r[a&UM@QAHjplrkr9+ +MPjL"'A@Ik2Hch,YX,ZBp8,GXqPrZphl*CQAZIDFIljMQBHCRkZaRHrfemTAD(6" +6%drh-(2[(Xf`XP,C6hreqZ86HJYQErS0G5&pB[*[fMc1[IIhqf@6HJ-cZUU8#EI +hqq9kp84",+CZl2A,bZrA$%!I)ir2pITPj6VP`(c22AURp+&[kmfBq8RKhrAljIZ +e&f%23$PmXpm[PdN90,9!qf,H0rfbFS[kQ@`ATfJ1N!#qFN)c'R-@crj`VerQhV( +ApJVNFDCI"rImXHdDD+HmJGF2[QVl"mV`Gh[pXR,c&fdR3EQTpr,kj9RYEGK68$j +SY*CqZI*qeDlN63m`rE*bKpk-I3CAIUhA,bX[rkcHf0`lc0Ylr6,h'eaJlk&5V[[ +AIVrmR(SB-aUPara6Bre5CMbq2kA(UrR9p%YlEb[c3r`+kjIfhV5h$[UP[4GA(r( +QaCp8`j9ll+0N[Qa5hE16i4kp6H*p6lXBDTCle,6dbmAADc#3!$Q5Z8,khe(9)M- +1pqLT-LqZek`P$#1*GrIMR9)2*8Ieh80rN[kAZehi@%(&*65$HR-52[CNe)hUFi@ +kXC[XqjQR+dkfZV(hTRa+05GeBqpGSTfG9cIq[IMCe'jf[T%Z(*[MYlf60eR8D,@ +*Cqr&ck1qdd&jUTh5cjL9fI@4(r1'l!q+H6cd*q54)Qp`G[jm%pp%(JR92IGX(Hr +3([*CZfIIEpT(qRhd$QBX[9rN(VeUZE[h@jSCC(H@rCL'!A2[SqS0l0@S*qD%3eC +Rc00D&ELkpk&qILpS4K@3!1$#rIhmlYFZ8i#CDHV$bqqh03X*PRHKCQA*lq[DX3M +QEj(QI-RM3Gd4HUH%GRZ5arFdSaTZeIJb14AkSSm062c8AB1kmHr&,Y"1aCY(lEh +TQXqmZVGjV#12q"h@*fbm$HrSpFZU9fYrm$kE9jKG6,qXqM(0$FaPkQ[9c'(kCGA +eQTmqB(QSZTIq9e93$6'6mKl%0Zqpib,Y,$lLlTh9fH5p)e8YdMrTPjrSjEhMGXe +rq*RrU$Q6pijcp@DrB(P3"bE[(Hr9h'q8RXI1%CbmYG%qe[pLNhS2ljkYJbAD@e6 +5cqM[0YjmpA%cMpCHS,di-ijkM`rq%DZ%rqEZrEjf**pdpcl&h#Pc8ZeYQRFrjHj +pPRHDlGkepY1hFH1AV+p3rfDqV2fJCKeQ%1BfpZaQIUepcbhi2ZhZcG2F*RPm8$X +DqJr[4&mcmf[YEXdBc-Ad)6Arb2bkiSFechh@kS1jaFb[Y9ri1$lQCI+QKmRlEA` +)RbKHIbqpAqEA&5r6hS9p#2'!hNUm*YAm,eYq[pIVIl9YeHicVJlqk9rdjU(DGrd +D0ibkpYL2X1q42V(L61d$m&1Ap%M6AfXl$fY@-2I@k2h-(Q*&3EhN9bdH2F$X)@V +r3EXmDSelc)KQhUTpVfU)1BYlp$#TTqqTMYAmUr06mlV-f5YHVPQ@2X0BSHCHQE0 +Vhhi(&llSlUh6r'cQl0U1pNPIXMl02'RQl0Srdda!6*A#+@T)jZcD6fU@9[f%lpe +[iI+Nl&lf&l4cC#HJV[a,DMheKfk1c'Ph3lp9hm2X-b4HEN*lXUqiH0pNIT*ifAG +U9Q1(S,kIS2kmr"l3VN6YGBRh,I,fmUY9$f92`[[4$dcrUlVSVr!C03MaqjQ(Tpc +NlYfNHBXC@Ghllr3BkArj4a@2Q8,GqjpICNq`am@E*Z`)FcTelqp[mQr9[TDG%RN +cPj[qPdqe3a%H[V@D%f3ZfDPpMc#JV98I02d[IkYfVQ"C90l9l"ZNre9YeHi'I!Y +TXYXcr5rrFHhik1h--IIhqPRq1RCi3Yq3!$LARBVd[rc[r`ShY&Tm&Bpq)r'qT"Q +!Q9'&1Nfp5Te9M@VAmh@A4bhcU04C988pk*rBHc#[QckA[qVcq)6"mD$b0(dZrbE +Y'i4KEB2H`25jUPr82NcB%EDV$jSqPrpV+Gd([m-pY3H9ZXPr3Rf)I09lV0,q`25 +jUY@U#A!qkYjUjJhTFeARDer&$Pap*jRMTFp9EGG-b*c#1r%HTXrP$bT[-%)UMqZ +e$j!!q[K6p6PU2rEr!*!$$3T8De0SC@aXFbkjb!4BE$J!20%U!*!$J!#3"!4J124 +[r`#3%!mM!*!)rj!%68e3FN0A588"!,$B&&Qa%)MG!*!&!c0$!*!'4Q%!!0TK!*! +'VGB'!'[F1XTYj4hPbl&&)iXGiH[#-lh)CUh-le0ZYkLHIFUL-Yh8Lp2fNFA@MDI +i!0DALFq,iEm'r,TBNAeNmFK#0Q(E"VhR,DBGiEFF@r6)F[cV*0ZHl(-jAZq4K@F +ZcaFH@F`)Gr&kKr'&PaQ2m"6Sm%V2'T3aXLR[,9PN*3[Cj$RCC,c*FE,*EYeNYFr +XNZXeX%N1E*!!j@9XXbr@kI&EI(CHRpIDj@CHJlb-EMD3!$pYB*GfREIVP"98qcM +NLqFYAPiQh0!AlN&R$MV6jIRLj8[fp4Q('fli[TIC#hFqI)8$ff4jMd!Hh!H-"A$ +L,jqHek6cQRJEXZh&pK@ra50`i)#l$B"#J%j(2S"RqlkVP$T&UF3'GFTCPkP6RKd +UpBYh`cildC@!UcheIPP2@d(Jq%%U(rKlY4dYqcT56VV9#iR2SM[N1K9G-dhXI5F +-H#DV9"`SrAracTiNqVLm3d#eUBAm5kbdhhbmdCp[5QF[HYqBZ$Ta@YH94kTXXV' +h6%)G2VcNq,A$#4j-Xmf9ma0[8HV5`rc%4@-(cXNMk8X$%LbKpXFTK6HR622j9DC +crVVl2(ADdh+qCpRqi`A,UJeUEH)[ZUjD[[G@e&2cLAFR[YVe1E8*CALh8PrBVCj +a"#R,Tr,CG#23&@IKZfh"$3b4'cRCk[PrpF&@ZQ3fRUNiN!!0"Y1adF2-JX!aZYL +baFJr"IpR5Vjc9[+e+)@MG&K8VX$#CCb8DRaZZP5F(G0@@3FA$Pc@KS65Z'4qY31 +%Secq2AQmH-2REpSZE#1Fm[!j$-0qAfKR1"b`jqE%hBRE6cPP"AZq34"-H)1XDRH +Cd)4qE'V1CpTe5(8*#)E0N8I82%Dk(IVrI+ql*ATE#qF-k1dRk!'a2(66m*Q&rf+ +69',pXE`J"8T6fK,rP[Mm+C89c-hM&QH'9)Cc$A&%EHZA5LVR0[a,a%CRCm6f6r! +h(%r13c%+f204r-[%pQRmr@lmlc(#fI6KF"9LZaUA5m6@L)Y5)ipj9iU0[+[%pNC +F*SMY39`QLZeIi6**E&r!CE)d%M@U&YZPZ*!!1lERi$*9E"Y`-6+5f2EJ-PeX,jB +H`IBkA)L2l4GaQ5Qf4k3EXIe(BUP#-[dc4fcie)LY$THjBQ["CClBpZ)bAf`rM-X +#XIdd,TH*lGGa@5LfIi2,j@,l,#k+&UQ(FEP#N!#!fPdTYQYaHDEBAS$,9@)MlfH +*ME`ALHeRF"(F-$EkHl(BrLdZ5m6fAh&CDQ`Pl'ek'4YeTlq`,FGPQGJf#FjJkm5 +&QQ$l4lJ3"pXEF+N9're0[f!6264aXGMq-blA'eZ'Z2-$BU1[RLXfr*mRYYBPR"B +Ep9iK0[*H+ECrLSYbVFclF'N3'hLf5QarM-YUXAdCPcA'9NVFZ8&Xp-aDXH'c6Q` +lF&'GSA34PjcBIK`AF!rE1h"4M#lp5m&KE1"SXpJHaBAq"A,"5V!,'lJ!RQ#MMY3 +FfeCF0SU0RU-(XGf$bfDa8IXYB[X9A'i5fqrJ3RaXr`@AEFCQi2eQXB'cfm8'6Yd +L0RUq6@cdc![&4Jld!VD$Z1`8fcr!CCIBU-eZXB'll@,lH9aZ&GZ(K*YJ!j0Z&p[ +RF1N3ferL!Tj$3q!Ep$ifX"[0(4[BYepXi!)pJSfH8GTEcRT4+fb(F,P$E#r("6X +fkL5k[E'p'4IPM1A%X#0LqbeFlK6E*h'j5fcJU'SrimM(`!GXp0D,a!BZ+k-F4pb +KAl$4Krp3E2MrN!$BAS-,r!AE1h&49MlZ$PcZ&YYRF(Q*f-!9m&"1"I%-,S!0M[& +5XB'$p#BfX10PBU2hk!9Xe2S9B[[(Z2b)f1MGHmAfch("&aZFk6jMZi4Fl8I&"[p +jTGM!lPH*M9kmAfcd`!0LSrpq6'brM-ZVaIClZ0!,f1!0i+fFmH5PVa8Ef%PmE'# +R8G,%"PDpAQcdf%q+$Hi,6m(fIPb`BrYpA1#Rf1#li+UF5[,2Ra)EH!1R``C2J'G +K!pIH*$Ekm*q*$Ar`""[mlbeL)pHhLZd[F(QEX9@4hrkXf1"J2bFfm1cYBJ1Ek%G +Xp!qm!pZlF!%VX2eVA,"MSfp%2q"-B0rmJYMJPR"KE2#FpiJ062mPXB%lla8EI3) +HBS0MdDIBi"R`$QaI`Z9AM@dL16RF%aZFN!#Bf1!`la-EZ%N2BU2Rk4&Xe23$B[Y +YA$iS0Pk+`"hN6++@mE$Bi1&J)cCijSI&"Xl"aE#"qlmK0R$Y0m9'Mi,Yf-JCI-- +'pT!!1cEidlm`YXNN81J'f-#jIbNfq$"m%aYm$dd$'j`%rSZ0[1P0E'!"1J!fkJi +2`[B(Z0"6f,k)bqmD@cAV68f`S8PmA'cNr3QaN6IBJJfq"%r""Vk6&cC`kP0LSkr +q8'c%qL1a`EhJbh+QX0j`@'cNrHr%"NH(Jf#$arb*f1!aD"VB`&Ni(6D`ir0LSdr +q[GLi$li!FXmFkF6+JP0[Z$T9R%eY`0-(eBUqG6CR`l("I"lkaB48AP$eUI-mR-$ +BUjc+'5IFJ1-#N!#)jC3Z[d[jfp0@#L-V[KcUe2!-ErM&aiRh,fT&8lJ5`8Q!hNF +r[C)#Vr`A(RrPBSi)QA2`Ri,r,2c"la&e1S8)Trh6L($D[`34K[frrhM'9-LmQ2# +I,q92mY3%kjhL$5C0VUM3U-qScUK)U09d$5S*hB6bLA+"#S`DLAS$Qd+jJIQ!CM! +Ue!SD$4D')N"q+0#`A"4Re&TI,8GT4UAbRaE4X#M+X%pB*f`6PJPlKCh#-Q'AX%V +B,H`99JQ,JMh"QQ"*X#CB*@`5&JPlK$A#&Q'*X%0B)8`B*3B&"Z8&a3AQL9+$BS$ +5!YY'k8(*3@'"iD'ZS+UJTX$b3#J8&*36Q"`+!!S*bJL+#%S)l"PP#&D*kS(D!E0 +&S8BY3IP#989Y3-&'L8D"4RN'`9!GBHbS1+JdX&"8-*3V&$"B+bS%kMTX'j8DC35 +&%M8DpS[k$1+!ELJ0U-kSf+MfU-US!`!-+JFU,ZSYULd+,bS1ULeU,H`CG3i9#4@ +3!aQe$ED-dSD#KVS$BdCK3h&%J8E44FP&`8@j4De"j8!jK5@M3U$3SR5MF-1B8-9 +3F9!k8'e3De#"8(P3De"T8'G3L9#"8'GJfbJc+$+`D4Jh+J`-#p8&Y3@9"A8&939 +9!88$RSHUK0+(ZSUULMU!DS8+LjU+N!05J9U,5SHkL4+%HSJUJ(+)`SYUL$+!SS" +#M$+-dSV#LX+#SSU5#Up#"8D"4P9%18@43bP!F9DPfA&``"2k@49Cdr[d1Me!VF! +rkNC0`AYU4Th!*HS'6S%YB$pB36q$'q!(@!+1JV(J+aJ&4S!,B!ei!Lk!#H!"r3r +QJXGJ-2e'2i&AB$2m!Ai#"S0ci#IF!a`#8q!8p"QF!b`&2q%am"!i$2e)Mp+[F"* +i$MJ$jS)jp"ki#"l4Jf!A'!3QJEpJ0GK+li2CB#bm"R`'3q%6B$Gi#`l5ih!Um"2 +F"2r!C$!BVJ0qJr[d2Y`+I!B2`"Ii%0J#[i+$`C(!DR!DA!![i3"J,hJ,$`#6`5Y +`#B`"`m!Z-!h1!RD"4A!`q"Pm!A`#Dq!hi$4i$SH$Dm!0i@M`(rJK("#Z#*F"Zq' +#F$f`%Db%1m%CiA4`#hd*FqVilkYF-qI[hNRQMl`F2U0!N!"K$CYAr[)ZFI"eFZ! +P"m)VK$B,JQjHYVe1"F54XZY(c2h0jLjN`9Yk1MD3!(9&("li'mH,r1HX2(m0Uq2 +q1@i(l5jSibHHKAj(mV2hi*Ai031c0aMaYh9@66YK649YGa0di*`c%eL"Sd09@!` +MA9paf+"$[aRBX"bHc9RfB+14pC`SEF2FUN0M%,r!eV+[D38D*NRY@8KiNH[-U1) +X6$I'*SQe[K"E9Z`ZC%HY$9ZF632Pmc0T"T!!Y#A!i4VZBUjCpMD1*XrkCK$k3CJ +1M(R,FEYI,E%IE0LYBNZqqrh)9p2DBV8lMj5F3JPpm![PQc6NSV*[Uk`AkD"LfAU +P3)RFG'Dbk891AFIPSC`eQI45q(VIpB1mBmrUB,PiMF-MSkK-9ke9Q1C!fhkpiEL +1,UF-PHQ+@l-'REE2XDh)mEfP0QfTSE9fVj3Z*%#,'REFcX[6[HQ`jV+8J8P5L5V +91#h@S$"KVP+IS19VcNZKJfXiH#Eab+1"ZNFF**QDE,hK"a'#hUKbqHNMjT@@krU +qKa,[Dk!!0CP0QHFrh`6DR-TES@fjXA@$[N,P4dD2K)ibPHk+-iAf"GQS8E2"+[m +9B9hYb8b-,UGNr2)CBSibl+TG!153!2UD*T3@5Z3+iqMV!)rDP[!)[jEXa05H&R5 +C5##!Ep9'Le`+cGJ$Gh&kBIL'mI%M,Rl+KfFc[KIkVL"Z!!f,EJ-!4&EJd0U2UHe +()!p5%$[kS%e%XEI%B)HR0!0"$D4)rNARqY%Fbf,meF82Y[H'T@U3!'5H$CJFBdq +r,0E6cbq2C6E*(YFSFpqcTf!f8'$@0!)FML$!qPja[&Xe4lme)a#eVKCaJ`alHk+ +[9$@&''N&D2-m5b!X*LIL(&-dJd`4([[ekN1a`lDl3XjfZFFXkfIf`KLe8p$5VE1 +PQ+d!)mC#!eQA3f%!V0Q,LZh69UK63dh(,DY4*`LM9%&AkpU,e(Bc0D(1*06ZZNX +3T!fhbfeeR&6BiRUH&aAFrA,kf4KiXCD3!0-@STUQk'ldI!J6`HmF%YX"$Y3HfS( +6L&Mef#%2Fe%8[me$(j13!+"*RjIIml'RB4p&&aZ*aT8L#GK)2I*'beMST6#!C4* +"#%1E+(XB`P$ZI@kU%)(Rl5+GPrB2f,VPTqeH%r`[ER3*)S2'@TS0XU8mf#mj"[D +#E$dH*NJhqNCQialjjL&56B+ml9CJHBCdYpB#d0`ZQTbq4eiZM-bci6@QIGh*e"A +q[2(BdK(JRHHjikfm!rfE&hlGVaF(hrX9iTip5Ea-XG1c($#Dqq6eQBRKNI@TpF1 +$a8&FQl1CSJbJFD8FH@Xd1JhUh)R3GFXhjf6phh`#im$EDB2JES($fqR("hUG2!k +)Yp24E,6`a86HTL9f"d`rFp@miaTjKI@hllaXCbIf*$k@q!L)RabGIZBbHdJPbNB +dem,Sb6dR2lH#Kk)mcU6lh3!6,%DU%l)dQ)$lJcha$Ud+rb6q@IbVm6H$Q18r(Ip +,mCq*rbcmCq-r"rmDr1IM[a$rbq2*%p+a%lreBQ'`BhPHQq+%&f&AcS@12IGNXr1 +QPa4hhl6rSIf(pYqrrhrf2b5``[YNreQI2db$jk6d2p"M"h!mmIa2iP6ZXZDXM'Z +&)4lel,&NpPMqE-hQm6*PUjN9jdpcp-''ppaqVVclp[ejjq`c)pjXqp-HHI2Y6h[ +NcEV2B[fhc4cr$6D(pqMqr!VHbqZd4r1HADFpQMIJ1Zh4c(R`P6lQ$1Ld4c1h3UF +pQMN*1Zda`5P81Zh46*2dTce58jhfD#C,kV4(Mfr"GGUMalIT1Zh4ihYjRIESm6f +q6R[dq+jITcekI21Ydaip[Yr@r[HSVZLd4ip[rRADSmGhr$VYdH--"Thfk('QJNj +lp$K[3kFpHTb0SG-H2GC9TcekR#USdal0j%UGpTKNI99X5r+ZV$R*YrJ+QNR1&0" +TMdR@6kFp*PNrRICSe#'GpTMNHhqGpTMNqhDGpTMN(!kGpTMNl!LGpTMN[!LGpTM +N$"+GpTMNc"#GpTMN2!QGpTMm6ecdMAZ5GG9TMbRLK8jl6,%2GGTMLMA5DBmTaY9 +TMbRfT8jl62&p[Njl62'p[Njl62'G[b*fLM-5G0TMLV-aG0TMLVa"TcfQ120%PB3 +8Ce(SY-F8Th6TY-F8X9bR2DD*GcVY-8emd@Q2DIDf6RY-XjGdfQ1DYG0TMqQPH5( +BQ1'Jdal0j%fGpTKHQ[H!M4N-1Zdac6N21ZdacANT1ZdacENI1ZdacGNG1ZdacEN +[1Zh461V8DBpTcS$4DBpTiSe1HdbcaMVYd8c`e'Q2*F3qRICB3Pc3DBmPV,Y1Hbc +KE!5G`9&#l0GTMb@FYD$6(NXiUd+R2CC`TSXqhbRK,"+GpPM#Q6BklE'%mfYdfQ- +*qe+R2CC`LTP1HbcKJfHGpTJKPZLda`baAUFpCSLc1Zda3ac8DBmCBT01Hm`34h6 +DBiBpUM*IKVA@DBmCjU26(M0,XdQ`-EY#TceQ@'pPiKR1H0"TMfDLU%jlc,"IGGT +MK[0jp#P$KR0lG,C)KM0iG0TMKR0D9-R0r"FZ1ZfaP0a-Tcf@NVISY-G5mKDGpPM ++HUX+@8T-e'Q2TF3)RICBbTl4DBqPj'FklG&-)p9TMk@F+D26(NXj%dDR2CDbCMV +YXC4cAA6DBbPa4DFpCXNjGGTMPRa2TceQL5Xkl6&,(U26(V2N$cVY-8[me@Q2@H+ +86R[-XKGefQ1@ID,6(V2-AkFpCPNrRIDBj9`KRIDB*3r3DBpCeP+R26S6$LJ&Ji# +pfSRQPQA6'EiU!)Z&!F2+BG'J-D`CKJ`$KK(l%kGF"-G&qmj&F,!XTi1U6NhmZ"1 +#,Z"K5ATiI1FHHpBTFhH2c3@mBbM-RQ2Q(!HQX#0pK5-Fe&ecd$VA$9iqb(pP6NH +"2kq$f6"&LE5QF-jNk[a%lmd(%lf9(9-6UFQaQMSh9H"YjIUc,i(B*mVFh$YlcYk +PUUNTSl`%hEJ5%p6US4E@Jm(AJj8h32&T`25k"NcDDm"mp99339D"`Dr#*,A98+a +@Bh,H'LK@Da$M"Ya[J0*a!pM`@LK$Dm&mef,'m6US11ZJ!+c$P,CeQ,Th)bM&MBL +A3p2R`'acQ0#@JemM9)R'jSQDLN!NUYPke+3CE,mCDNXcTZ8eh`q"51Va!UKc,m$ +-e3e3dcCJ5-`'q,9!Z@N"Hfi&Vfb&DY-+0Yb++B!ES4"Ya&5qMCMmYJRjE`,,hJ5 +9B$2bfJa9Bc-Qq@d"cpb#QQh"j,iYb1XQe1XQU!3h34@i#IjESBaYKC+b&DVD0UL +#fk!)E2XmK#*4VQk'%R%c&-,Yk+(Yi!$E`HDhBaVG,DM$,9#'EN%2Y%'eE)1Ld)C +FASKFASKTKMZJDZk!BV)$YGca$BK&SZ,YK#U`%kVL,UL(Zj!!ebj-SpZ0'Zm'Qpm +0KDXGr,JGDQXle+&f-2jfc,'q&HVEVHM[@a(h0[6!E9!PES2kHYYA)"`*"lmGrGi +"P1e!EhE!E`q8P$fSbaj-4pb,[YU,h2CLQZ)qe'mI&0"pk+Api"rlSIlXac6"6[$ +`6LKCRCLZG`!mrJ"8[!03X!qJrJHKAKa%[3pLHYj"B-!Gi1jhS2IZJ$,("+K$k+P +$8)J223J"5HV3"I@L#e-D$m2[-2$J#(VT#05Y)e$)MU"Ali5LHbG8[$[4VhGLUZ4 +G`++ld#phS9q13R%m#KAY+2$R'*63BqL2Br"l%@+m#1VXXpFfGf@,U[j-8H0NhY$ +qXp#[!0ee`)bkXDjkXY%erI$"FcRhEfCLPcSp0l*l#QV!cU)98'qlTe#FI#lX$q6 +c2V@l"bHG-VA-KbdG8DIl+2c4ZMmjkPU-prPLMU`[m3!Il-VpUh-FD1-PeJi(2[L +-GmiD8HiiD5G@3)aZQ0iEkr0f![Ea@(Y(-diN0R*M#5pq9q#PeBD85X4kU#MkSZ9 +j4SFk6VhA-j1SMe1$04221@KHVTVAGa(l("SX4BLNH61LdD+CCbbRJaKZH+ZCILN +1Q9-P-AqNCI#H",hDD(2LB%)Jk"Pa$`Ia30!dZD#k'lAG$fh'E%U%'8[*SE-EcFr +2"G!aSU%km1i[b-HIc"RNBfSM%B*LRDf041,4Kh%d8bl&B6C$bjeA(rQLL8208Nl +qE0!Jkh0&%j`bdl%Bhf''9,9rmhf2qr6%%qVF,%HBP6k"FVdGPpP,GApc*K9Jr(r +2[N`fQ,`0iMQ3!0%2+*Yj@HDV#6`Y-dr+I!IHP*QhC#@5!)qNc$-*2`+[b-cV-H2 +JUTeY3ejrRi)$BMU$3(YfHAETi(&%c&AilM5$D*jAF@i2RY5q#[mNrY2aRi(rTIM +2a(m@rV2aRi[r22`Ai(mCHdAqeIMcH2M-S)F4IkRR92aRi(mTrM2aVm&r([lcm9m +!J[HYpCpF+XH"m-`ZH'hR$YMP+Y)Skf34[jUF%h+5DZLjfI%Q-jLGc("R%I*Mhk- +$&mC6PGGSle&(9Ik,ITTU6rjff2&JQZSX5`0f1Pie21DmUZa%r['!Uhh-ESdpc'1 +k`FbemUX@SX!kRPYp-icmHZSb[6M["qAMcLYX6,RY`TMQ`lAMRQD5l%"#[)JBD"J +F'jb3!"4Lrm`h'b"m5&(d'bLU(53pf%h@Gl#CG!*`Gi-dXrhlDSEMF-h`lUmCIM+ +hZXpTS$[0j'YTXNjpG%EZhZfBX(fL`$cjDZF-hm24Sa9HMAJe1FbT0Dl4F29Z$)` +pHc!`pSd`X1LS$9$dmf[GRAm2"[Bl"fdE1bX'aMi'!f12'!-(+Uq3!"Al&M!`GSi +a-2D--6$fM$#`k"MM5G'l[jdL$1`ZA$F'p[N10T0LB(H$K"KBG"bZ@BL"46m`X0G +TS$XM$)`pB`b-23XBf!d0-3D'Brbl)6"bl%(!b$8#`)+I&VrJjTFj6Vd(rITmJhk +0I"Al)KF$IC&$M(cpp9DFLP`,Z"IjaV!A1FDS&cP'S&I`Lr'Mi0cA34(La4AV"Va +Hei(q8EL,Zb*%Zi,I8,&#V#Zi!A9&RrjZM)!ZFSaa,R)X`&b-!M(+)59f`j[ak-% +eia-"@Z#JT3hXI[eXAMhB&6N&6@HF&+f-cF#8XF6i&&G+SF6i&"$*1-93C$aL$$) +H%IJ%$R%M"ej4Q51FX3AS"TM3Tl[)#LQfN!!KPJ31[EQ(k"(BJBfm-Hk1##L-4i` +3aU-!$EEPBNc`QmaijCc`Z2D`GM)edF"U""eA2+)`Q(i9RHmJ9,KHadfjBdlf-D` +9"rY)A*aQ,f(A0(XG*FhBU6I0#!hM,)[F5*-XqNQ1N8p[LUDViYcbJ+C*j4dN'f2 +X6D0RMB8Le"AmBp3V1"Fk[q$I$3)&laJq#mi4N[ElaX$@(d!aVYr94lKL,h5MlU" +l!-"&Gi[&"EHiC3[18IF1q*iXPGrP"Eq[0hb"3Ch`(bTc4$2kIFmdCNJqqPhK)30 +q*lSJCLF&jjLS&*alf'M"25+QrEiRDKM4eF+q%d@N,3D)SEESAF$DBS"ZX#fkafK +Ep)lJGX!jEZZ"#0S6!ll$6G%0Z5Im!c$UpIFAkHMaLe'hk"h"lU$c8-&mi#dkpL* +[-83"HNm''#jh",i$cQIE0)6I!9r`Gp$aC$[%#&cdML%iA#@ML)@4E`b$N@-"!52 +IE[#,2'2FLa`Mb#[ia@e8F0B1+VMj24,AZ4[HHPf$9SpG,DK&,M'H4BkpX"0j&a# +RchHJ!K(1&2b'HL0%Pi)E`&,dkHZA'%iLaq%h+!D3!(1@9feD9IfSDi0[Ie[Vlij +EG)hL&X@D)'c"-iUD9f1#F)&,&'H!fJFKqlfMk)-%*3Jri"l&MjUX1h648`P6dHp +N+P'DVTIchCHV,S4CJ[qR*QNLf0rA*(K(2&L6i(LBEH#22!hR'1J,hP0c$03K2mG +!3hE2-A#BcFV34BBRi$m4rdRi6m&r+[l6m*q"rdcmCq%r'rmjCX0PYN"*R)&r*Ij +9q*IM2`lrLNHHC-YIjkXl!3iMMe0QdUm!dZ61F*0mi#&I`j&V*XD$ZUVfG1$B(GZ +!)F3$q,IJ`9&XjH4bB`NK(T3D2+M$CPkb!C@cM5IiH#$k`B4MH,$IkXc''8-mQ-L +GDqY@*S+,00pCYS+PE3#2EBqAckXEFVa1CN!4iN(C$r(!h!l8klkh2GqF`C+(09R +2GTYP(AB%JiN3$mUIa!0jC1BN!i0Z2"KRm-!m*p6PrHTN[8bAQT!!i11"M,9,I`X +2JT8Lh@Q)%1*"b6&pN4e8Gd5Geb6'N!![6K)mD23$cGIhADQqp*EdjNjVL"$L3GA +bpR869VD[de%'jikEiRedIZ%r@qB-GpF`pHeH`XC,b%C3iX9Q4Z1@il$Y@[lF[4+ +(bHd9bh&54q0%qE$$519b(,Bb(Sc$jNG9l6KXKc5K(BFG5kjlV$kKJHf6RYq1`p$ +SPHdiE+e8reLIK3DfBXUfil$p8QNl$LZ*V'V&'Cbk,1k-I,kYR3plUGcHMX-ZBah +Y1+`PdY#ZMpN(2amRlV0JmVQi-j+kE$A[+"p@'(RPDMj4((CDHqeUR1#Y[ELcqFM +V6XE*!e,`eZh-FGM'F6jY"CAHX@9E[dV1QrP+E601&+TN"NX*(pC$6P5h'LSCk(e +0"`YkYf#X8b*Cpm1Si&5(RDS6UH3`eQdqj#m@-+0*I'A$iM8kZY`*QjDVNYQTR&A +0&k)!L8Qk9B'ZBUEQS8@)&`Ge%#fUlZ,XG$hV98l8G,IU,ZY'9-Y(JHU'FVG[NJ0 +kXQR-eYU&GF%6hCGDRZreEGQXILQGU9QHdN1@29X0r+CAaYLmhIjm[+PiBPfk10[ +!-#lV`bE)+a%p[@2cYQdU#9pF'hGEG4e(DX[jFaSV5dZPE8$6(eHV*-B0lG0CEa* +hUE0-%*%k5!5U)h9QjT2@1DdA'LkV,9X[(h$G3C[,Kd[&GkQHp%Kp"M(VDpUHM6f +b@"Hj,@FjRRTfZP5bI3p,*4dZ93+rA[,d[1Yif)VDVr0ciTSYMqZ"EGQfAT9%VGX +$aT'CBP+9[6ZeAdFE(F2LbjlUE[MZBX'DdkSl@QbJH,IkUR[+FrBeGABBRA6BahX +*Q92PClK-VA&e*9*V&LFUP6MEfMKEmC0XPm6p8@pjFhN!J1lr[,q-kZq[jQYB+(e +eS0P$8Z1eG3aQN[PE"ef,[8iYTL%f@kl,M+G$l-'G9X$1N!$D90&aVkD6GP`9))5 +'h,fd1RC3S@[LHR"E4XcUp#1RXMLX)m[K'Rbk&96Rf0h#2"*GhJZa+N5i&96Rb#& +Z"A8C&3ehb9C3qANYQH9j,Hkjq4bZ0KMSai0dalPj,6h[jpcemeUFpZr[api,mjc +Fpr0DJZe4`m8YR+XR@[[$dG)!lVMY8GebUhf+1-#JUeYEJjVLf8c")#RaBN$8LT- +$SL31!k+fYq-`)'VEmPbbEL5+mRB2a'&&rPA,!h91$0KbAm54X`-ePTA)Kmj1M+J +EpSr6NR@Sl3LmX'YN6j*J&pR%Zl#hZJ`5ijhlpdm5da2-C!i(`+%@5CAX15PXc6$ +EM(l[X#6jLJD'dMJ"mQM-M3qGM#-21@UbGEi%T,+$-@4X#QYPZ`$bf*`ClJa3e`f +&bG8-RmLMG@42-6e68hBBhUm5$lj+*AHejMjQhaRE9PUZkrYHDNblbc1[[%2Aa%Z +YHQqpPfRB2'3$pY1RF6TPYR-DkJirMfFq[e0!(QF,mUdmcSlkqRBHCa+jN!#(6'a ++E,TLKqRAGafU(IlDMLlD*hm#XbL2h43(QJdkNGeCTNPm2iEr`Dj0,dXP[RK[c$T +0(Z'XRrpG$mC2QMc1YJGjk&*8`i@eHFJU@Bk!2(Cp[l)MGBA"qRQF4U),HCc6rb8 +2fF2UE!b64jHU2Bl6GXZV4!c8[QX"TlGN*TlJ-F4Br3-QXpZhipf4RMS8j&!Br)! +e2*C(9mhPr+Xc4lEP'Z9RA9'c3d!HR%9SNUIUbP"HCGc$LmLl2aMhd"MM*aRhF"l +1!-DpIQJA*kQG1Bhjk5IUiIKJlUH'6[m[jMkDaq2-I652ajRler0iM,Q2j2&YjZj +pqZ1p(3#BqiPkI*Hj$aIf#HBqNXIMc2e%'YpKlL0jR'2ZSl6Gck0,9rqrljdIM&X +fb"Z-m56M(XU$i`KJh$,9mqVqe-SkNMfRl%H-5I)iJ`cIC%bMH6c1G,kHaf0-Cb5 +2Eb,jL6bqJq3MHC`$2FR$l+ijJK#,-(I`Y(qS5*cU%-RM`-cHar0B2l2hL6c+FMp +iAjc0j6+B)qX#10p!2&PYN8lmHKllrTFV5KlXUj!!hd[a4%I[MLIBZJ$UqM4R#,M +d18jq)Bm4j$cACd&rb&cXljpaCRA&BB`C(kZ2ErF1*!kpj6XU92r*Ue#IHHQbqZJ +%b+2H$8-&L"%!'FT$X*kk*KlAbBeUk!5SKe(lR!"jq'VIk6`ZU(fh4h9A[3)28mR +M(NbIpJiNlS0pbVlHa*[Id&"A*'kmk6@[Z#Tam(5#LFbHV[6JIcaairAV%QrqXhK +DYFPM$lYSZ"lRqda9PSl'prS9PF8!dDNmQ$DIi&$qTr[HU#a1J(ie+SX6)!q1KE2 +%6qTUmT!!pNMmY$qDI)pcaBH2Pm[P1`$-Zf$pqa(UN6Lcmm6,KrU*ecialF$[XG2 +(F"JR3"lVpJD902j2e49@kUjiXhMkp(1K`XPcSHre4ji,IDpIh3'+Xqq-(#,c +9D6ca!ZGmAGd6bM9(1GA&ZTSmcZf"F6k2N5GHLHGdIR[MGITFB$TZT6GH6ar(dKZ +[Jih[Xp14ZMS+hSSpI4`JEm91!-KhhSUG@T(+$I"@,0`5Hc")DHF*jZkSB+C1!14 +d+b$9q6-k!G,pSHNiA#EPR$i1!Lh'$63TjqRM@*U8Fd','8c%4D$&R)fK%hI1(2I +@a*f4jrqb!*5Mi[hri`c1[6&(i*[-kd3Hhf9H``9jJRQ0j1'FQ)p`JAN0*Z)@Q,0 +Jmj!!9F*1(C+3!&RlPK5FLZ-'B!3Q$kI%h!Gp8pEJfkX8TH,*PkL5aA#-Elp%2C2 +(H3eZK*-l2ejqRZN2*m2,ck&k22RbmdaGcfX0jrZHmrL,c62e-(NmpQ,c6"ibdIF +EZfY+((EAR,)kSMRBA92LX,[QT08i86jX(cLeR6IlY%eEc5Ha%SIj`02EHE-*h-c +91#8VFFEMQYq&FlJql,LChm&c1!i`Qpr"FcJ1Zf[q`'0e$2Z@h6@Ifil$D1MRYH1 +`iqESETd5Kp(ISlYe5KbfV"[GV92LX,[Qk'kGiXAZQU1lG8SF0VSEhDe6iV$MjZK +ZR4+(%HElf[9KK2Q2VSj%[hXP$L2(4hIe&#ri6rA*A6dPcMaFlf[AF6kZ*hIkM1) +X`2AN6Tp4R)@iRYcTXf3P$T2a6qld'F6*!q&B#f%(6l0RCk-94Y!Hd`X0(aYiXKR +QLJSFc)k9c8-6$Hd0MaB@29XPXE)QVa4c6KdEH-UQQHbYfD!V@!1c[KQ%f(NcQhI +p+)Yp-X@hH@J-m9CcqdX624dk(RDR2+5MCZ$TFK'EBFSqPFX(6Y3d[D1r$eYQ5RV +09K$U`D!kaeL,ZB9Ql3#fiT3Y0A0B'A-YeY!mLMJ*Yj5(d0`HB+p,'EkjclGR5a8 +[9$eeDb(RPjf+Si0TTac98*GkhkXie@DJKjT4K%Ua)@BEem[F%3i(eV`eiqU-l`G +PE-!Td9FZ4Yb&Xm[&1TYQ)p$kh$Kf#@hh9(F@)IG09Vei2defc,4VG,E1MXaT$pY +X5Qe0[4CcMmdPII'YPKYd,ZhVikff0kiTZfl@$X#[a5PMMdhkVm'Xp#RYNp0H&98 +cAEN+kE+C$K@@ABAUXA!S@5kpL0NX(lJ)G@L*9rr8(6GeqdmU`1DD5r[kicTJ@h) +4Ue%lX"9lP0Te19Gjf0icN@4qM4B@(9f6(9AV#YQ*U6fS`T&'85r))U1*j(J1Hh* ++TTXJh#H5NpM"V3%lQlBkf'5dSP6#HU*Yh2UcSdb%N!#Y6J9K@1kd$5dP+*2&jU! +(XT'ZUfidr'E6CfcrZDU-YpFKSZJ1U0QC'AmKVQ-9Hd#+)FUk*(l%a8kQH*MY2a0 +&fF(c`'pH*m`MdH@r6S"1Gr!mm-UEiadmli5,Xf3(6h3BqD1UC2![a6q,IaRqjIK +IJ[pir#[aVm*r)[k6m*q-IcAq8r#IL[m-r#r&IbEq0IM2`hmqrJ[`AbLD"SHpQUN +@QKfl+G[Y)YMedZiVM,k"ESSQ#Y0$bd3(C-pQZJ'0%Id3,3qG$Jh1AA$)Nhc4fra +D8"IU46G5Zd,GU#depZZ&pNIpU$8epq['9UI8$Sf1ENCEFfFFHS"Dqre,[HN*kKh +eJpmcp!6p3"rirF[GCA$ml!aR,Cr+Cp-%h)k&EdF,P$CR!8Dj#XljR6`FAT-'('- +lHI$-bDQeNmHh*`3i!(Eb-(R)2R'M#CmlB`f(h6kqYCA2'"YLYiqA*'kmCF1*h6l +HHZI2LN'lIC`i@3`!6TRTcc+bD4)R"GGYVfT2"ikpr5QSFASG4N,VPJUT'!pFE6$ +3M`FPKKmFKE,JFN1&%!mb"JrU-19hHEU[BaY[p2&!p)1*ar"J[p@C68-)m@!#0MR +`YTZ(T5h0"MALZM&Xb#'EBEM8J-((!e&Tdpr#!hQ'F-J+(0e"$4#JaH*!!hhD +Q*E+mXK@8m8S%9$Lf29FB6f@f$cPH*c0d#2PLq3raJ*Z`L,TmFmCel&6@XpeQZA- +BJ`Ma)2XN(XMXhIfqej%-%N)m+$ZQ,ql#Z18G8HFeL6(%JbV"JdBrd0c9U5[9Ppk +5hYaT$4+MNhN+MFibFTkHVGN2"U6GFAAcL3EfVj$MKhUbDiq$B)SY"#%kG,E) +@Qkd!0X5E4jQ6(AX6V`0E*Icj!l(0HmH"H#Fk"p0-Ze2pbN!0[f&lqrAeVAjeG@f +40G6h!eYNpH1dZhk,,*H#!Z!'fM$JR!*3h*IP+3A!,E9&eY0p2kCPf#,VhHIG"EB +kc'll6X4Z!rA4#C!!4lK&eP!H!pXbpDKL4M9d!Y6$U(e1J$b#,E*1jA&"l62cFh0 +AYlE)NNGL@f#A,E+5CliNYPGqH2cfVY5pKf"LLka(i2r"VNe2Fl[1I%@m994qIZj +`2Flh@EK&eP!H!eYNpH34ET&eX4j'CA%#p+Y4@C`!HA"dIZl&ZTSml"CC&r-B-rC +XN58E'%`ddk9VLV1T$CR4(0kDA2%Mr0LF$FI-'i$+KrEFrK33kANH6Q$FQ,JkF9V +APFFLC1-EFq*0NlX!6M,qFh[X(%6b-lrMR9*U2lFTkVf*Chmd%XpdaI@8a$aMd1- +P[18ie(eD+djh0Q%F%,hqXAc#[#IKZUS9Cl$q%UFDedQVH8Ij6-9eHMZ1$1*)A0U +1-ahA&HdiPa)6rQHpDGR5GTaCZ0l@MM-Eep[EFHEJfY'1!q@j["eR,UlhY2Yf(Ui +0l6McFAheUI(QD"+cZmr33r`i#h'pEl8q86kAieV@MJ22q2(9rSlbIJDZVh`-p`U +(G(@G+9G[(&MQMT2LJJ[Q)&'Y'lamN!$rbT@9CXbiRjCc*P2R*hT[2TMSVHbBQNK +0MYA8ZDN#Eb[ARhf*5Zbq$66ZNCkcGkPUN!2#0+Dp(G4H*ZrB8623+MRPZEipQhF +@0'E0966LA@MDA0[hjY5jT9)j+TAk,bb9'PB31CCEXS,!@LaK5jV$3G11r'"d$NP +9TBHD8H4l)h2DLr)"e+#UG('f90#ZYL2(pc,eXZUjh!QEPMZ-Y-9M4h#LTVApI@V +0MVl0[&flq5,FP[G[98N,'p`X,3@P4Y!)N!"Y0Ve64k1lQhK,Y'KN(h*UMP6hJP1 +hUKS[6E*CciPf"PC&GEZf'pMDG982!M)K6qBaG8CCVq+V068SiT*IEAprR$'hjId +AUQ3kbccUI6mSKfTGdDp@A3hKZ$e6XlbUMQYE8CbP4kXr''K,*G%M"p!dlD@kYF$ +U5%&A,NE)VLSr0)l1fX$!+m*&ceCVE+[aSMMVUq1XZ5h[hkE@3+dlV*)9*`LMR$q +Rme'JNUKCUej!ZAEV"C8-jjh)VZR`A0DUSK*S24aBmaEbPLVYFNZMMPIHEG9ef," +XIEQ&q-e$`qLr`lV!c#X+1LT%j3`,f+@'5b8EI9fV&fcGB$ZZRXaXf6CMKHKmDH` +1VhU*[E&[LefcJP)8@%i8AQ+rB'0I2pALA4DkAXc2CDdlI,64%6G5238lF"V4'&E +YN5Q%'r0je90ZeZZ,3qLMpQ$H+8FeB%+$%cCFDc&MHA-XED,EmQ`JbB&!GA[0HT% +EA8P(,0hFUpC-!MN5kp*ld!@0IYQT1$V)@Bd'5T0BJdEE%RG43QeDfpb9,DV'ZiA +,HkUVm3%-BJ2SVX-ialUaVXDlVZkDI[MJmqk"bmc%,R9kEQ6h&25`R88Vi2#!H`V +&bHI#rN!qlr2C`S166TQ2M4qfd$abrbMm88dq1HTDM2Ij)PlYb[f,M5!HU[M91D` +Q*T5RI$M``@HmFpDXD1jT4jf"DeYXfa1V9fq+(Br(LY+AijTG4DENVBeYLp5'P%U +m-,Bp5fh&lH856f4)leDaVF1i`AG+LUhN8e*[,el*-G9DbG&e`khF*bGFZ8m@BR, +-VGcRVd!dGZ*BZFpImGC*Yh+I(3IUCPfjEl-6rR3*%ZI(FALZh1I@'3!X#hIpQ9Q +KC&eVmPcfRE&YB!@A6em6VmcL[I9HTZ&Q@VP[U&m(9Zi,q[8cVAjeGDhF0p6h!b[ +hpH1dZhlP2TH#!Z!+@VR[M!*3A#lU+3A!0E9bhm@q(p-bV0chGZp!iY"E[XYZqdl +%EJ2ed3Q3!%HiFYp3(J1VaI@SBNBeG!,8`kKp6S!mJTAl6Z9a3HdVVYbAI2V4PIX +qdlATMYHF@,R[SBf2VY`hA)rcI4DZh$H8am$+I6ejK#[hADb(89QF!2eU9"BR3"i +FA6EJBPe0(REP[SYjM"Pl9Zk6PahbC`d['EHZ*af2B,rbPQGHmb#UqTDRS-ApG5C +L5l[-F9aB#PciJP,2ZlHM'bl-aYCl*FGaSIEQVlcl'9cT`ZPfNL#4"9cB$9bSa0U +1l+ISEMYE!3VS$"%ZE#-ZI1h`'cX![!9aHTd$%"Ib#ePDA%MFdM0hpZ($ph9f`i9 +l34C1i-,a&h4bJ`@cXL`EBCVl,r5mjTl$KcqclC%JHD,TGMY64V2M)k#A+Gj&PTU +6K90+pX`eEaeBG01mL[)9+hCTh($%S3Areb$N&DFQc0k`[(LkAb+`q5ZlcjT&CPq +'[eQrNF9P1Dr!rdH@FY(YCdh@2%GCFb4*jYT5Qm""9RC-[!NKjbpPcA5&9beP66T +brqXUKZ&Y&F8iM`R+RBe`HkUSSI09P-$La*ZF[kTLP,@TSKMR,T99cZ!bYQk%`ak +8U9LXcU#Je@E[*&IE[S[q#IHJ6(@'fcNRa!-8+1%(4r&feZ@'#L%HP(5Ffj28he[ +0(EFRkD5IH6$f**hFb@j2dP2E9cK26reS$Z$hjS*6ElLkq-6B5"I*FAMZ5FTB!DI +1RU5,cGj,'mV,!E*MmDL&JEfTr[b"f1Dpim"e[$ZCpL3GkYH"28Q$IRepUepGAAZ +5$[Ap`*kNr6MYVYq6e+@J!,L#pL3pS`!80m*l5J&`6He*HV([al3-Hj+qqlbl`&D +(f@hILGKYS$ik!I))pb3GbQ0J(m`H9FbSKNk!HKLec`Q3!%H`*qQT2#kSIF8p5H@ +4@,3RUCc+$jrBNc6M2VSRkA!pc[GCZ#IT8"i$Hj,fj"(Z5AUa(NCPF3,dUe&CR!" +jF(4$P)Ye0ARB28N[jM&Ql0Q60,mGU4i[RPVVqMPYT6#b[XrQ(!M(LrH*fh%5)e` +`"kDaE[$b3IiV9cE6-&-E@XkC6*fIk,hjB++hXQ0U)M8j9P2RTJUmV9arpL8UXIX +f,(lf5-rCZe3e0F@9eB,GccULZYA)@@%%9TYHD2LK5KCYYc4BJ80p[Db5qD'*K[D +'4`Z,RUf5"4har8[1U6X48UK+&fG,`lVLH$V6$%)r80ejeiqbYZr"YhPS$2&@Clf ++(dG2KilAVj+"MTU"Tm[&aBC@DhB-$*bSDAT(Iem[DV'hP,H#8!m'e6R'@Mb!@qh +!CTAdp2biVN4CVk`A%#IKP[+3!$$DJcP080RRfl1PLKHURVUeN!$cbdl&dF'd8ij +UU%Zple@FDM233mdS3U@QXBVePMGRKF1"0@r0Z$VMqd%j90f)[R)aJM55$9eV6ZF +M9,Jq0qkJAcT9GaBKpde@2E81'FJ,*%RX6Ke%aGQ41He&F@e0[4C[a@e*AhbVhB, +EdViqhQTlijV@aM89[aDRV08kpPp$)3SFViVfb@Q[LUUCVPb&G0NhJJV,"KVeIM2 +1FZP&c'Ej`%@S3iXGq+ilB`@$GZ6iAMi!VD)#em4C,ihVJ'h*4Da'lF"@P4af`SC +V,Bji8E#SNXb[dBVXfXlXU&TAb%j-l8%9MM5+HL'##,6EReI*mGa1(5(66C!!K'5 +`L@a@e'"&ZZM8Y8U@5P8GP5,dGNHC#,%c4TJfA0[38S)bf5D5@"[TZZT'`fmfIEB +2VEbUM&Gp)D+XM#-RZQGQr)@iMPAX!5Q'D$D5q"%h8Yhd@"eS[!CXhE5fZ5YE92X +q(Xr6!H#5q`jKGJj!GafQFY@0GHflje$Ap--(cqZ(bmc%,R9kEQ6h&1DelbaD!Gq +!hP-S6MiApJIbHCrUdi166TP[aKkfG)38%hI"(pVjb9(ABVc2&r(i5ZjIE!6aE+b +[S[ZlX-e[qA$JJmpijkaCN8l5MMU$T-[BpULcF(e6l(KF23Hh,mFeZiVlEAPVBpX +LY5'P%Y`R,j'i3'h&c5b(*r&%-["Z&CXXHMIZMbA&9[a,XGfGP2bTeHi-,h3lN!$ +$8V-2Rh2Qb2*q%mef$6A&fG5'X(C"Sf'IIc6%jQ`iCYijSTDP2KXM4#*rH`H%fRL +AiUJY#4%A$$)ij(SjNpGR*SC(eUI@$`m@"h&YcQD+kcZV0%"qHq8m9(#4c3p,V,6 +II)TIJ$J@klbVp[!ja0-R4,#%QNTFR6LYkmVMPA-#C"QIFB+3!"A3$R3rXFHR'[E +TS5kJiiM33r2E@CUY-#XTKTRjR1dKAMi8hbbJ#cC1[pJmQf&[4TP5bRL%QSNIBfZ +!Ua3L26bqFimpkj3K`1bC,Z!Yi(J$0EC+j92jE*VL4mI#BrA8URBcHPQ[N`4Ld$+ +&0q)&SC*25J!(%A2QGl`PeaGcDF$H@j!!X$NX+bVAVUlPQJe@31+![Lmq'5GIef" +[`E%Z3KaHiXMHBh*,3@"fc1eJbKY&Ypb1PA*&S((,m3121j!!Q@R96YFGb14GeJE +YDL[8UD'QilBQ[VY6MNYZ"l,-cd)YQ`XiSHH#-l2'qABD#pQ4-l-HjP9hkLJeXY" +`XCApNqq+ed,p)DbS3'II,,[,6NDQ4aqklfVM)&-)$hhQrU26S`ppmVTiHM34h#E +6Sdherqii)DC(ZfQ16)mHQEJE6G5eIl"L5bI+kG'P(*0V4p$+hrdc5jUTYrjaTFf +9GS4-LAD$5"8$4r3,LMSkL$VI%Q0QK!(66mCa1Tbc'`9BIPC$RGP`YIcJl'6Rqm( +CJJGMe)6"f5YF0e@)V-La1`%X8HrS1)l'`GPM6C&aXU0Vc%cZ8,V'c2kIY'Xq$fI +%1M3Q$cI11M4pbdcq[c`F!$KNmR!$V'IMJKi)l[iDr[TAQjqkj8E&ZQJ@KMB6FX1 +KRf0TK$2@h1&bdK'9R2Y6cbP$lH'*Z@&-9fUFIM'(+,*rMa0Z+FL'dI&L"i#P),m +AhJ9f&[If%NFF-(d`PNG3dq!XjC-6%dFjA'ERj*54LL4!HYS*1EBd1jSG(i(8j-Q +p@Zj6j$jIlP2P2N2Z-q9qk8T5*8r(QJRlrFL(,5RqTA,2VX4*pK4YGe0a&X0LG`C +@i'J1d5aR)+QERf#0f$0LpqpcH*F0#8eKj(i&lc,RFClFjdUFk5X*ThS+Lf'NkdF +6(Lm*qK9D)2FbZIX&Z86ZPC,`G%R8G)VX$6PEr+XNlL5j6jEl4)NlGk8JQCqIeKE +VhhQX#9)5dq3Xpi9b[h`PG[Qk54hkcF$@BHSmE0ba0jAabpb'`a4-%M@G)d&04mM +G&%lZTP"bRb9h[f#Q%D53!+EPCI9-8`5acf'fccpPI1e,AFHVTUc8(-Ud)r'#jec +YH+&6eLRV$0Z[ebf[R&Tbk%aC3@!YGL)M&%k')a$,Si"-Dah)RS8S1jIM)(a2@ik +61E,BTcMNic!KZIkaI-+m*q'kkZ3DNP!!ZGkmQRH8ca4FYlIM6-Fefkl2$&a,fh( +BN!$hYRBF9[kl[4eR&UiGl6LcFEfm(3H'F8qlcaJKhG#1-aIA9jf+1#DQGl62JVe +6iBTb[9rL62THR!@ihVGDabM[bh!YDmGCL1XV@h'kFDT`A06V@EEG$*UCU)I4m4F +ajCMDAd'rRZRpdkrKBVRLT``db(3T,Xq!AmFa[`9l*3r*,rACPYre,`EG1flbLra +Q)EmNr55rb+q8r+BmhUkkI1BC60MkCIq959UrEAYJ8b+9i3CZ0PlC4cPYAiP*'AR +e!bEH9Dq(6EIN,82HL9dQhXFr"jY3'dlkCEJX0hk2EQ*LeLq*[NQFBIcHaC(R1U` +qLhSRHNeq9e,"dJGXf9Cqj42[C-,@l`E`pj+mm9[`TkbCpKqeR'cbqaAflcM*qrf +ic$$aERirE"A'l`Ir#Rhm-H1hp#ZXMFEEcCVC2,k5KBhHSDlN1Xhir3@jGkAi2G, +UXmhF*KYp!ErIBfcVGp0[`$E"q%e"rhSQ[h+,+q&10(iPa)dkNpqIX(lS$q4"[eD +BH"h[BifYhcc`A1m6aUrTGq#!$N%mfGYEqk$m-ZD(lN"qp+hfpi0[JSdYZVQ#Bam +fIQpR$DBC[aV8f(Z@b@2$"`PNeQmaqr9YaZpP[mEHd[`qJSYCG$GafY[r$MCd"cP +,IJmpCHYApS&IKB1Z&YU-2Xp)A9rl(`3bkrF4k!EA5Vch%c2&cTP'r$KHMd,@+#6 +AVd'-c([U8Ec85HMhJka,Fceb+85(IL8EfD-5$pb0r%+mI#Ne"+0m5QjX&flaXZ` +IQ*1ZXT!!qTG@['II$4XaJ6Ab8lbmJre+A[MpHJ[2aRmHY[Q50pLMH2P,(f'ZkJI +Z@,`XVh0rC[3&kK(LjE0r'cEd"2a#[$ai)f`k!Im0m2IamPiZ6I--L3HZ+%j-q`a +X9iJIbjmSAQjm$faA'VqIRQ[KCIf,i+#,jb4C$m@cUC5RU6re`fEaX[aCA16M@H* +hI3Z(2NIHX%MmhY,#bjF6Rq!1FUiqf-,,CAr2fLXrJ#GB[#c2rKD"4ZY(A44A$K2 +li9PbVN@G&#r,V[Yc*UCjX(k6pX%Gj"M2%Ep0+hJ!Cj!!,G)jcb('@l`X(b92ZXE +i,IY8#bpI#Xa,E$0qYH`RaF[Vf8[,K6r4IaB[bi[Xq9VMer#UCE`XIc9l46FMI!L +V6rKi14kj*Lif0,)#fkaI@c4er8AL+$%T(EbL4[!b&-ZqJKS)Ml4iQIIcZVq1fqf +#Pf'mF[D2MjHKAj,pURhmb$f`JHhiIEc&,cGbjBERLYqMVAL2[JifAAXK4GkSH,R +d!GMS+IaHfm+c2@q%EBA`DITImI*$V*@Z6eA1Zq,P`QYKdp8q8PpZi@8p1(4#PTY +*NeGSIRH4Ck`bIC!!!YG8[#al2hQ2VTaKpT&AR-J4)pB),k(r,9k@hFUkbVldj0% +!RZ2MjEh-$5j*(ra8#bqRIBded$cbH&Rfk8r$TNZ8CEPTKZ,3&-E@*ALQ[ED&Pmp +i1fb0aQme0V6hmA,0'q$3C2cQXQm8,rFcYrA56p49F@AaRj!!-eQr6H#C2VmFph) +iQ'hU*4ipVAd`(GLFQ*6mIUC9TmRXh4E"[rr8`XY1jUc2N4T49mA,XRrF$iH0aUr +Z[eYikEf9KE"qmiNIbLprlC@`E6Cq@m"aIEcFIi!1Y[pZ4YiqAQiRaX"Ca'mRq*b +2Pjqk(KjJ![@$"rYiQ4GP[@XrKMaH*ALCpdYX"qiQKJ8[3lpTM12MCHMRNAGTIa` +K4Qm62r*AI[P1iKbF'Mmd!ifhP0abZrLabElLj@6@i"E"&ELTkM([S`CJYZ8A@J3 +2X(KC[S-jkHBLFfpUiHAL6m+Qfk)NZBD)aFZb$pi#Qkk*Y1c0,EbF4@h$,L,L[30 +jqRMjQm35p"2S$hfV1(%hZB(ZkVD!2&2amK2NE(B$(Zm2J6f6EcEaMU2R%V+1A3R +a9r(X!@SBZQI,!Z+lmX[DIE#TMMEhYPEIc#6f`drT!h"@mA)EHDHZ)V-9I-[(bqX +q#JI9lkkP$U*kc+28X(6KU#A%&m@9&QS"UZXGicDVLTHl@!0`JAMdJrE"SPI$TQZ +H,#2H+"rk0@)V033@i,+Uahb-2D`kihC`G*pI,LC1k0)T0a2I&5qVUBATQL2ANFm +T[pc&2Y"PHMi)A2Eam[lli##mR[jl(h*9[#cl!$K%BYli2B`qmI(b5`r"3pFB[iD +kL)qAiHEX$b-2EdQ2#IfQNEX),KUm$2hQ84Icm6,[jcd)lMAqTRT82DCh*VY4Mq6 +'HL0%[0![G3EiA2+Ur(JBUG2H4FkU$p$QhS',kUaK21mdiTVNGj!!I44ZKej1hH@ +$iKIbhATLj0[%,m6ekql#j5Va#qZkM$USlDH*Gc#HlK0c2AR!8Z2h9Q+SlNCI3Pd +X(IY05K$6L3r040[EDI`-lX,&b!mHS2RGrpH`JHhJ!Ia*mrX)X4jZ4Al`4T[Ia(R +@9Gqih2+0jI`Q9VR`bYf50reYmjZdPEDA',qlU-0TITpP$m(&b!pFe[V0Bmd%9dd +mY!UYhdcbaCFD[bELMZEh#'YkMr%l5RjZmj[d"ZSZB#EjJDPD[rp!$N(pL8FHQPm +VYC9A5(krM-XEkZ%M1YpkmY,hLPqq[j0VUCRpK[L&rIeKkU62&ja6MCX)%m$4!ek +Bpr01TalRid6H,r&XpV12Fk(IGR,ak`8A3lmQpT[P56GqLM`-AJ"d5ee99mKY)Jq +ierKGKMj4r-lG4Xa$(a#rCb+'iRHZrk[`Z-rNPb('@0k6ZjYB#AH@XjPF`I+U'ap +Llk*T8)ph,219h"rp,@a`"$PEb)dXVmTGc*Va4N$ki29FTNEcDk,qJ4BKjpA%"XZ +VFNmMrk#'p!'iU2A,8FY!!j6kl56[XE`UGq@(iB(Q56`d')hh@q6-j%9BY&L,(lR +,U(QJ48JHZk(j+8r0lDA'"*qPjF42F5AhIZ,I6aLrea!E,+lFq#AU8ZLVp$GiErP +dlMh8*0#D`!Rd#-ZRFkpLVk-"iTIRIcGqm@(Bd$5S(cA3IVUFfZJE6ChfN!!2@Ik +AZ`"[&"*[%lrIAHCrZ8&L*Aa+r2CqBCRrjHlq%'aS34,U*kR,@2kA1qm'f0"R*0i +qp*[b[pa1BZfEK+I#kk`1NEZ6IB`fJNYHImVY)Kk6#b8#Ak`1NHZPGS!H++H0I0l +U",QcL(9[0AQ2)lrem6A%ZHR%Y5V`-hKaRMmP3q"LL4*me6FN"[r39G%[`GHmAq* +Af!Fq(ihm`"dIGd-rHa4hmhlHYH`VLl[9HpLVF"E*qbMUNGPKr!j6ZraCirG$`&r +&hHUA8q[RVBVir6"`CdBYpT[mGGB%IL'RP$c2iQ+eaGj$Kj&iRHacLl[9Yl*R`&Y +`#2b`r9Gp2I8cp'IkMhkeZ&Yp"h9PY$[b%(kJZ&[Gi"X$q*Vi(D!@ER'h@K22i"6 +8qk&P(+hqGElE3&-LRQL6LV[9ee)VHBraZi2BVr&qKhM'ZaMmrR!CGkZrr$IN@0E +[MAM,SVKEr5&U13m+r`!R,1j@Rdrp'liQm3laABh&hHSm-C3h#2L"(aChU`m3iq' +$q0'(&RHVCmJjU5Gqj'PaYlVr%l$a&J1rhfleNdIZbTXJm61pCA'hqQh-PAi4[cI +M(BlLERAkRq$"1`laH`XjU-AGkYqP,S*@6(jSi4ChU`r`$BaG)LRj"qJEaGh*hb! +@`6[Nh%$X+4Im#r&T#hRR$X(,%2rHJI`#A-`[r*5mPARlZ*Mh5ea-AZ(MBKM[2G5 +*I&`X,JkPZ"M'kb+f@9aXqMJeUBFP$qNjaFA'KiQ,F%raqe9`%FA&TR2iaJ9Z)Ri +I31pHDZ)eh8AYM(G$Y!$pCh'Vk8kqHB$l5,bh%9FX,MDGahKS(G3MrikND5-a'fj +)2$LZaF@QAfD0H&-MIMm,6Uqif,5'ZB)$i[GcI20KFE(T$2)`X!Xrp%@Yhh6L*Hq +mm*2BLSY0,k'@J'BSIMp22,$a'Vp%A3HHL"r[4LbH06j)[%6Ea!pHD['XkII*AF! +dr2#hH0Ddb2F"i#eqk%m@cjSX[[8#Ur&$kp8qH)Kp`aXCr0$r,*iehXmh#Z#$q2d +"hUFTRM9G4Yi[["+r6m@kKI9l,ppXS$AK4adYRM@pPpS5lc[`%ma62'[D5*hJ%kD +2Mj,6qlJ9iNS6ZC62md*Fq@1mir&q,XkMiTrj4Z,hMGqRS@HRhf[m$T-EJ1(LpeR +8dBqhL'q``'6aqpbrYq+Y*lHRAm6[6i%0IV`0j'EJLIKp!6c(MrGMe(6rb2Mp'Gr +RDE`h%-qSTrMp0qKVIV`rT6EmDH2hPp#Fr(K',k%Qi[FPk-eq202#q)VI9m"aJhV +`pSQh(Z,h2r"16q0GmJ[N@V`2%Th*!blim6l%0f#I-hj*jQ2j9X@YY%Rpm8[KhBE +bVBVA%r0jfb9q@I")[aiI)+Fh@ZMr"`"'`J!!: diff --git a/mac/tkMacResource.r b/mac/tkMacResource.r index 23a2000..76bd528 100644 --- a/mac/tkMacResource.r +++ b/mac/tkMacResource.r @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkMacResource.r 1.35 97/11/03 17:16:34 + * SCCS: @(#) tkMacResource.r 1.38 98/02/10 10:38:07 */ /* @@ -73,12 +73,7 @@ resource 'vers' (2) { * will load the TEXT resource named "Init". */ -read 'TEXT' (0, "Init", purgeable, preload) - ":::tcl" TCL_VERSION ":library:init.tcl"; -read 'TEXT' (1, "History", purgeable, preload) - ":::tcl" TCL_VERSION ":library:history.tcl"; -read 'TEXT' (2, "Word", purgeable,preload) - ":::tcl" TCL_VERSION ":library:word.tcl"; +#include "tclMacTclCode.r" read 'TEXT' (10, "tk", purgeable, preload) "::library:tk.tcl"; read 'TEXT' (11, "button", purgeable, preload) "::library:button.tcl"; @@ -97,7 +92,6 @@ read 'TEXT' (23, "tkerror", purgeable, preload) "::library:bgerror.tcl"; read 'TEXT' (24, "Console", purgeable, preload) "::library:console.tcl"; read 'TEXT' (25, "msgbox", purgeable, preload) "::library:msgbox.tcl"; read 'TEXT' (26, "comdlg", purgeable, preload) "::library:comdlg.tcl"; -read 'TEXT' (27, "prolog", purgeable, preload) "::library:prolog.ps"; /* @@ -130,18 +124,20 @@ resource 'STR#' (128, "Tcl Environment Variables") { */ resource 'DLOG' (128, "Default About Box", purgeable) { - {85, 107, 243, 406}, dBoxProc, visible, goAway, 0, + {85, 107, 260, 412}, dBoxProc, visible, goAway, 0, 128, "", centerMainScreen }; resource 'DITL' (128, "About Box", purgeable) { { - {128, 128, 148, 186}, Button {enabled, "Ok"}, - { 14, 108, 117, 310}, StaticText {disabled, + {143, 147, 167, 201}, Button {enabled, "Ok"}, + { 14, 108, 137, 314}, StaticText {disabled, "Wish - Windowing Shell" "\n" "based on Tcl " - TCL_PATCH_LEVEL " & Tk " TK_PATCH_LEVEL "\n\n" "Ray Johnson" "\n" - "Sun Microsystems Labs" "\n" "ray.johnson@eng.sun.com"}, - { 11, 24, 111, 92}, Picture {enabled, 128} + TCL_PATCH_LEVEL " & Tk " TK_PATCH_LEVEL "\n\n" + "Ray Johnson & Jim Ingham" "\n" + "Sun Microsystems Labs" "\n" "ray.johnson@eng.sun.com" + "\n" "jim.ingham@eng.sun.com"}, + { 19, 24, 119, 92}, Picture {enabled, 128} } }; diff --git a/mac/tkMacSend.c b/mac/tkMacSend.c index 85065ac..dc4e8fd 100644 --- a/mac/tkMacSend.c +++ b/mac/tkMacSend.c @@ -6,18 +6,41 @@ * to interpreter. This current implementation for the Mac * has most functionality stubed out. * + * The current plan, which we have not had time to implement, is + * for the first Wish app to create a gestalt of type 'WIsH'. + * This gestalt will point to a table, in system memory, of + * Tk apps. Each Tk app, when it starts up, will register their + * name, and process ID, in this table. This will allow us to + * implement "tk appname". + * + * Then the send command will look up the process id of the target + * app in this table, and send an AppleEvent to that process. The + * AppleEvent handler is much like the do script handler, except that + * you have to specify the name of the tk app as well, since there may + * be many interps in one wish app, and you need to send it to the + * right one. + * + * Implementing this has been on our list of things to do, but what + * with the demise of Tcl at Sun, and the lack of resources at + * Scriptics it may not get done for awhile. So this sketch is + * offered for the brave to attempt if they need the functionality... + * * Copyright (c) 1989-1994 The Regents of the University of California. - * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * Copyright (c) 1994-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkMacSend.c 1.7 96/12/03 11:48:27 + * SCCS: @(#) tkMacSend.c 1.9 98/02/18 11:01:26 */ +#include <Gestalt.h> #include "tkPort.h" #include "tkInt.h" +EXTERN int Tk_SendObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); + /* * The following structure is used to keep track of the * interpreters registered by this process. @@ -27,17 +50,12 @@ typedef struct RegisteredInterp { char *name; /* Interpreter's name (malloc-ed). */ Tcl_Interp *interp; /* Interpreter associated with * name. */ - TkWindow *winPtr; /* Main window for the application. */ struct RegisteredInterp *nextPtr; /* Next in list of names associated * with interps in this process. * NULL means end of list. */ } RegisteredInterp; -static RegisteredInterp *registry = NULL; -/* List of all interpreters - * registered by this process. */ - /* * A registry of all interpreters for a display is kept in a * property "InterpRegistry" on the root window of the display. @@ -61,54 +79,19 @@ typedef struct NameRegistry { * 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. See format - * above; this is *not* terminated by the - * first null character. Dynamically - * allocated. */ + 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. - */ +static initialized = false; /* A flag to denote if we have initialized yet. */ -typedef struct PendingCommand { - int serial; /* Serial number expected in - * result. */ - TkDisplay *dispPtr; /* Display being used for communication. */ - char *target; /* Name of interpreter command is - * being sent to. */ - Window commWindow; /* Target's communication window. */ - Tk_TimerToken timeout; /* Token for timer handler used to check - * up on target during long sends. */ - 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; - -static PendingCommand *pendingCommands = NULL; -/* List of all commands currently - * being waited for. */ +static RegisteredInterp *interpListPtr = NULL; +/* List of all interpreters + * registered by this process. */ /* * The information below is used for communication between processes @@ -206,9 +189,6 @@ int tkSendSerial = 0; static int AppendErrorProc _ANSI_ARGS_((ClientData clientData, XErrorEvent *errorPtr)); -static void AppendPropCarefully _ANSI_ARGS_((Display *display, - Window window, Atom property, char *value, - int length, PendingCommand *pendingPtr)); static void DeleteProc _ANSI_ARGS_((ClientData clientData)); static void RegAddName _ANSI_ARGS_((NameRegistry *regPtr, char *name, Window commWindow)); @@ -221,8 +201,7 @@ static NameRegistry * RegOpen _ANSI_ARGS_((Tcl_Interp *interp, TkWindow *winPtr, int lock)); static void SendEventProc _ANSI_ARGS_((ClientData clientData, XEvent *eventPtr)); -static int SendInit _ANSI_ARGS_((Tcl_Interp *interp, - TkWindow *winPtr)); +static int SendInit _ANSI_ARGS_((Tcl_Interp *interp)); static Bool SendRestrictProc _ANSI_ARGS_((Display *display, XEvent *eventPtr, char *arg)); static int ServerSecure _ANSI_ARGS_((TkDisplay *dispPtr)); @@ -265,13 +244,103 @@ Tk_SetAppName( * "send" commands. Must be globally * unique. */ { - return name; + TkWindow *winPtr = (TkWindow *) tkwin; + Tcl_Interp *interp = winPtr->mainPtr->interp; + int i, suffix, offset, result; + int createCommand = 0; + RegisteredInterp *riPtr, *prevPtr; + char *actualName; + Tcl_DString dString; + Tcl_Obj *resultObjPtr, *interpNamePtr; + char *interpName; + + if (!initialized) { + SendInit(interp); + } + + /* + * See if the application is already registered; if so, remove its + * current name from the registry. The deletion of the command + * will take care of disposing of this entry. + */ + + for (riPtr = interpListPtr, prevPtr = NULL; riPtr != NULL; + prevPtr = riPtr, riPtr = riPtr->nextPtr) { + if (riPtr->interp == interp) { + if (prevPtr == NULL) { + interpListPtr = interpListPtr->nextPtr; + } else { + prevPtr->nextPtr = riPtr->nextPtr; + } + 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; + suffix = 1; + offset = 0; + Tcl_DStringInit(&dString); + + TkGetInterpNames(interp, tkwin); + resultObjPtr = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(resultObjPtr); + for (i = 0; ; ) { + result = Tcl_ListObjIndex(NULL, resultObjPtr, i, &interpNamePtr); + if (interpNamePtr == NULL) { + break; + } + interpName = Tcl_GetStringFromObj(interpNamePtr, NULL); + if (strcmp(actualName, interpName) == 0) { + if (suffix == 1) { + Tcl_DStringAppend(&dString, name, -1); + Tcl_DStringAppend(&dString, " #", 2); + offset = Tcl_DStringLength(&dString); + Tcl_DStringSetLength(&dString, offset + 10); + actualName = Tcl_DStringValue(&dString); + } + suffix++; + sprintf(actualName + offset, "%d", suffix); + i = 0; + } else { + i++; + } + } + + Tcl_DecrRefCount(resultObjPtr); + Tcl_ResetResult(interp); + + /* + * We have found a unique name. Now add it to the registry. + */ + + riPtr = (RegisteredInterp *) ckalloc(sizeof(RegisteredInterp)); + riPtr->interp = interp; + riPtr->name = ckalloc(strlen(actualName) + 1); + riPtr->nextPtr = interpListPtr; + interpListPtr = riPtr; + strcpy(riPtr->name, actualName); + + Tcl_CreateObjCommand(interp, "send", Tk_SendObjCmd, + (ClientData) riPtr, NULL /* TODO: DeleteProc */); + if (Tcl_IsSafe(interp)) { + Tcl_HideCommand(interp, "send", "send"); + } + Tcl_DStringFree(&dString); + + return riPtr->name; } /* *-------------------------------------------------------------- * - * Tk_SendCmd -- + * Tk_SendObjCmd -- * * This procedure is invoked to process the "send" Tcl command. * See the user documentation for details on what it does. @@ -286,15 +355,127 @@ Tk_SetAppName( */ int -Tk_SendCmd( - ClientData clientData, /* Information about sender (only - * dispPtr field is used). */ - Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - char **argv) /* Argument strings. */ +Tk_SendObjCmd( + ClientData clientData, /* Used only for deletion */ + Tcl_Interp *interp, /* The interp we are sending from */ + int objc, /* Number of arguments */ + Tcl_Obj *CONST objv[]) /* The arguments */ { - Tcl_SetResult(interp, "Send not yet implemented", TCL_STATIC); - return TCL_ERROR; + static char *sendOptions[] = {"-async", "-displayof", "-", (char *) NULL}; + char *stringRep, *destName; + int async = 0; + int i, index, firstArg; + RegisteredInterp *riPtr; + Tcl_Obj *resultPtr, *listObjPtr; + int result; + + for (i = 1; i < (objc - 1); ) { + stringRep = Tcl_GetStringFromObj(objv[i], NULL); + if (stringRep[0] == '-') { + if (Tcl_GetIndexFromObj(interp, objv[i], sendOptions, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + if (index == 0) { + async = 1; + i++; + } else if (index == 1) { + i += 2; + } else { + i++; + } + } else { + break; + } + } + + if (objc < (i + 2)) { + Tcl_WrongNumArgs(interp, 1, objv, + "?options? interpName arg ?arg ...?"); + return TCL_ERROR; + } + + destName = Tcl_GetStringFromObj(objv[i], NULL); + firstArg = i + 1; + + resultPtr = Tcl_GetObjResult(interp); + + /* + * See if the target interpreter is local. If so, execute + * the command directly without going through the DDE 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 = interpListPtr; (riPtr != NULL) + && (strcmp(destName, riPtr->name)); riPtr = riPtr->nextPtr) { + /* + * Empty loop body. + */ + + } + + if (riPtr != NULL) { + /* + * This command is to a local interp. No need to go through + * the server. + */ + + Tcl_Interp *localInterp; + + Tcl_Preserve((ClientData) riPtr); + localInterp = riPtr->interp; + Tcl_Preserve((ClientData) localInterp); + if (firstArg == (objc - 1)) { + /* + * This might be one of those cases where the new + * parser is faster. + */ + + result = Tcl_EvalObj(localInterp, objv[firstArg], TCL_EVAL_DIRECT); + } else { + listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + for (i = firstArg; i < objc; i++) { + Tcl_ListObjAppendList(interp, listObjPtr, objv[i]); + } + Tcl_IncrRefCount(listObjPtr); + result = Tcl_EvalObj(localInterp, listObjPtr, TCL_EVAL_DIRECT); + Tcl_DecrRefCount(listObjPtr); + } + 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", (char *) NULL, TCL_GLOBAL_ONLY)); + /* errorObjPtr = Tcl_GetObjVar2(localInterp, "errorCode", NULL, + TCL_GLOBAL_ONLY); + Tcl_SetObjErrorCode(interp, errorObjPtr); */ + } + Tcl_SetObjResult(interp, Tcl_GetObjResult(localInterp)); + } + Tcl_Release((ClientData) riPtr); + Tcl_Release((ClientData) localInterp); + } else { + /* + * This is a non-local request. Send the script to the server and poll + * it for a result. TODO!!! + */ + } + +done: + return result; } /* @@ -324,8 +505,19 @@ TkGetInterpNames( Tk_Window tkwin) /* Window whose display is to be used * for the lookup. */ { - Tcl_SetResult(interp, "Send not yet implemented", TCL_STATIC); - return TCL_ERROR; + Tcl_Obj *listObjPtr; + RegisteredInterp *riPtr; + + listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + riPtr = interpListPtr; + while (riPtr != NULL) { + Tcl_ListObjAppendElement(interp, listObjPtr, + Tcl_NewStringObj(riPtr->name, -1)); + riPtr = riPtr->nextPtr; + } + + Tcl_SetObjResult(interp, listObjPtr); + return TCL_OK; } /* @@ -348,11 +540,9 @@ TkGetInterpNames( static int SendInit( - Tcl_Interp *interp, /* Interpreter to use for error reporting + Tcl_Interp *interp) /* Interpreter to use for error reporting * (no errors are ever returned, but the * interpreter is needed anyway). */ - TkWindow *winPtr) /* Window that identifies the display to - * initialize. */ { return TCL_OK; } diff --git a/mac/tkMacShLib.exp b/mac/tkMacShLib.exp index 0c28a4c..04e397a 100644 --- a/mac/tkMacShLib.exp +++ b/mac/tkMacShLib.exp @@ -83,9 +83,7 @@ TkGetInterpNames TkGetMenuHashTable TkGetMenuIndex TkGetMiterPoints -TkGetNativeProlog TkGetPointerCoords -TkGetProlog TkGetServerInfo TkGetTransientMaster TkGrabDeadWindow diff --git a/mac/tkMacSubwindows.c b/mac/tkMacSubwindows.c index 65c1a7e..562a977 100644 --- a/mac/tkMacSubwindows.c +++ b/mac/tkMacSubwindows.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkMacSubwindows.c 1.81 97/10/29 11:46:54 + * SCCS: @(#) tkMacSubwindows.c 1.84 98/02/19 14:56:28 */ #include "tkInt.h" @@ -288,67 +288,76 @@ XResizeWindow( display->request++; SetPort((GrafPtr) destPort); - if (Tk_IsTopLevel(macWin->winPtr) && !Tk_IsEmbedded(macWin->winPtr)) { - /* - * NOTE: we are not adding the new space to the update - * region. It is currently assumed that Tk will need - * to completely redraw anway. - */ - SizeWindow((WindowRef) destPort, - (short) width, (short) height, false); - TkMacInvalidateWindow(macWin, TK_WINDOW_ONLY); - TkMacInvalClipRgns(macWin->winPtr); - } else { - /* TODO: update all xOff & yOffs */ - int deltaX, deltaY, parentBorderwidth; - MacDrawable *macParent = macWin->winPtr->parentPtr->privatePtr; - - /* - * Find the Parent window - - * For an embedded window this will be its container. - */ - - if (Tk_IsEmbedded(macWin->winPtr)) { + if (Tk_IsTopLevel(macWin->winPtr)) { + if (!Tk_IsEmbedded(macWin->winPtr)) { + /* + * NOTE: we are not adding the new space to the update + * region. It is currently assumed that Tk will need + * to completely redraw anway. + */ + SizeWindow((WindowRef) destPort, + (short) width, (short) height, false); + TkMacInvalidateWindow(macWin, TK_WINDOW_ONLY); + TkMacInvalClipRgns(macWin->winPtr); + } else { + int deltaX, deltaY; + + /* + * Find the Parent window - + * For an embedded window this will be its container. + */ TkWindow *contWinPtr; contWinPtr = TkpGetOtherWindow(macWin->winPtr); - if (contWinPtr == NULL) { - panic("XMoveResizeWindow could not find container"); - } - macParent = contWinPtr->privatePtr; - /* - * NOTE: Here we should handle out of process embedding. - */ - - } else { - macParent = macWin->winPtr->parentPtr->privatePtr; - if (macParent == NULL) { - return; /* TODO: Probably should be a panic */ + if (contWinPtr != NULL) { + MacDrawable *macParent = contWinPtr->privatePtr; + + TkMacInvalClipRgns(macParent->winPtr); + TkMacInvalidateWindow(macWin, TK_PARENT_WINDOW); + + deltaX = macParent->xOff + + macWin->winPtr->changes.x - macWin->xOff; + deltaY = macParent->yOff + + macWin->winPtr->changes.y - macWin->yOff; + + UpdateOffsets(macWin->winPtr, deltaX, deltaY); + } else { + /* + * This is the case where we are embedded in + * another app. At this point, we are assuming that + * the changes.x,y is not maintained, if you need + * the info get it from Tk_GetRootCoords, + * and that the toplevel sits at 0,0 when it is drawn. + */ + + TkMacInvalidateWindow(macWin, TK_PARENT_WINDOW); + UpdateOffsets(macWin->winPtr, 0, 0); } + + } + } else { + /* TODO: update all xOff & yOffs */ + int deltaX, deltaY, parentBorderwidth; + MacDrawable *macParent = macWin->winPtr->parentPtr->privatePtr; + + if (macParent == NULL) { + return; /* TODO: Probably should be a panic */ } - TkMacInvalClipRgns(macParent->winPtr); + TkMacInvalClipRgns(macParent->winPtr); TkMacInvalidateWindow(macWin, TK_PARENT_WINDOW); deltaX = - macWin->xOff; deltaY = - macWin->yOff; - /* - * If macWin->winPtr is an embedded window, don't offset by its - * parent's borderwidth... - */ - - if (!Tk_IsEmbedded(macWin->winPtr)) { - parentBorderwidth = macWin->winPtr->parentPtr->changes.border_width; - } else { - parentBorderwidth = 0; - } + parentBorderwidth = macWin->winPtr->parentPtr->changes.border_width; + deltaX += macParent->xOff + parentBorderwidth + macWin->winPtr->changes.x; deltaY += macParent->yOff + parentBorderwidth + macWin->winPtr->changes.y; - + UpdateOffsets(macWin->winPtr, deltaX, deltaY); } } @@ -744,6 +753,9 @@ TkMacUpdateClipRgn( TkMacUpdateClipRgn(contWinPtr); SectRgn(rgn, contWinPtr->privatePtr->aboveClipRgn, rgn); + } else if (gMacEmbedHandler != NULL) { + gMacEmbedHandler->getClipProc((Tk_Window) winPtr, tmpRgn); + SectRgn(rgn, tmpRgn, rgn); } /* @@ -883,6 +895,7 @@ TkMacGetDrawablePort( Drawable drawable) { MacDrawable *macWin = (MacDrawable *) drawable; + GWorldPtr resultPort = NULL; if (macWin == NULL) { return NULL; @@ -917,18 +930,27 @@ TkMacGetDrawablePort( contWinPtr = TkpGetOtherWindow(macWin->toplevel->winPtr); if (contWinPtr != NULL) { - return TkMacGetDrawablePort((Drawable) contWinPtr->privatePtr); + resultPort = TkMacGetDrawablePort( + (Drawable) contWinPtr->privatePtr); + } else if (gMacEmbedHandler != NULL) { + resultPort = gMacEmbedHandler->getPortProc( + (Tk_Window) macWin->winPtr); + if (resultPort == NULL) { + panic("Embed Handler couldn't find port"); + return NULL; + } } else { - panic("TkMacGetDrawablePort couldn't find container"); - return NULL; - } + panic("TkMacGetDrawablePort couldn't find container"); + return NULL; - /* - * NOTE: Here we should handle out of process embedding. - */ + /* + * NOTE: Here we should handle out of process embedding. + */ + } + } - + return resultPort; } /* diff --git a/mac/tkMacTest.c b/mac/tkMacTest.c index 46a7bb1..b1b9db0 100644 --- a/mac/tkMacTest.c +++ b/mac/tkMacTest.c @@ -9,10 +9,11 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkMacTest.c 1.2 96/12/15 14:34:00 + * SCCS: @(#) tkMacTest.c 1.3 97/09/23 16:25:54 */ #include <Types.h> +#include <tcl.h> /* * Forward declarations of procedures defined later in this file: diff --git a/mac/tkMacWindowMgr.c b/mac/tkMacWindowMgr.c index 7c8206c..e04abd6 100644 --- a/mac/tkMacWindowMgr.c +++ b/mac/tkMacWindowMgr.c @@ -3,12 +3,12 @@ * * Implements common window manager functions for the Macintosh. * - * Copyright (c) 1995-1997 Sun Microsystems, Inc. + * Copyright (c) 1995-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkMacWindowMgr.c 1.59 97/11/20 18:56:39 + * SCCS: @(#) tkMacWindowMgr.c 1.62 98/01/16 10:42:51 */ #include <Events.h> @@ -63,13 +63,14 @@ static int GenerateActivateEvents _ANSI_ARGS_((EventRecord *eventPtr, static int GenerateFocusEvent _ANSI_ARGS_((EventRecord *eventPtr, Window window)); static int GenerateKeyEvent _ANSI_ARGS_((EventRecord *eventPtr, - Window window)); + Window window, UInt32 savedCode)); static int GenerateUpdateEvent _ANSI_ARGS_((EventRecord *eventPtr, Window window)); static void GenerateUpdates _ANSI_ARGS_((RgnHandle updateRgn, TkWindow *winPtr)); static int GeneratePollingEvents _ANSI_ARGS_((void)); -static int GeneratePollingEvents2 _ANSI_ARGS_((Window window)); +static int GeneratePollingEvents2 _ANSI_ARGS_((Window window, + int adjustCursor)); static OSErr TellWindowDefProcToCalcRegions _ANSI_ARGS_((WindowRef wRef)); static int WindowManagerMouse _ANSI_ARGS_((EventRecord *theEvent, Window window)); @@ -678,12 +679,18 @@ GenerateFocusEvent( static int GenerateKeyEvent( EventRecord *eventPtr, /* Incoming Mac event */ - Window window) /* Root X window for event. */ + Window window, /* Root X window for event. */ + UInt32 savedKeyCode) /* If non-zero, this is a lead byte which + * should be combined with the character + * in this event to form one multi-byte + * character. */ { Point where; Tk_Window tkwin; XEvent event; - + unsigned char byte; + char buf[16]; + /* * The focus must be in the FrontWindow on the Macintosh. * We then query Tk to determine the exact Tk window @@ -695,6 +702,17 @@ GenerateKeyEvent( if (tkwin == NULL) { return false; } + byte = (unsigned char) (eventPtr->message & charCodeMask); + if ((savedKeyCode == 0) && + (Tcl_ExternalToUtf(NULL, NULL, (char *) &byte, 1, 0, NULL, + buf, sizeof(buf), NULL, NULL, NULL) != TCL_OK)) { + /* + * This event specifies a lead byte. Wait for the second byte + * to come in before sending the XEvent. + */ + + return false; + } where.v = eventPtr->where.v; where.h = eventPtr->where.h; @@ -709,7 +727,10 @@ GenerateKeyEvent( GlobalToLocal(&where); Tk_TopCoordsToWindow(tkwin, where.h, where.v, &event.xkey.x, &event.xkey.y); - event.xkey.keycode = eventPtr->message; + + event.xkey.keycode = byte | + ((savedKeyCode & charCodeMask) << 8) | + ((eventPtr->message & keyCodeMask) << 8); event.xany.serial = Tk_Display(tkwin)->request; event.xkey.window = Tk_WindowId(tkwin); @@ -810,7 +831,7 @@ GeneratePollingEvents() } Tk_UpdatePointer(tkwin, whereGlobal.h, whereGlobal.v, TkMacButtonKeyState()); - + /* * Finally, we make sure the proper cursor is installed. The installation * is polled to 1) make our resize hack work, and 2) make sure we have the @@ -849,7 +870,8 @@ GeneratePollingEvents() static int GeneratePollingEvents2( - Window window) + Window window, + int adjustCursor) { Tk_Window tkwin, rootwin; WindowRef whichwindow, frontWin; @@ -889,6 +911,7 @@ GeneratePollingEvents2( } } + /* * The following call will generate the appropiate X events and * adjust any state that Tk must remember. @@ -899,15 +922,17 @@ GeneratePollingEvents2( } Tk_UpdatePointer(tkwin, whereGlobal.h, whereGlobal.v, TkMacButtonKeyState()); - + /* * Finally, we make sure the proper cursor is installed. The installation * is polled to 1) make our resize hack work, and 2) make sure we have the * proper cursor even if someone else changed the cursor out from under * us. */ - TkMacInstallCursor(0); - + + if (adjustCursor) { + TkMacInstallCursor(0); + } return true; } @@ -1105,6 +1130,7 @@ TkMacConvertEvent( WindowRef whichWindow; Window window; int eventFound = false; + static UInt32 savedKeyCode; switch (eventPtr->what) { case nullEvent: @@ -1148,11 +1174,28 @@ TkMacConvertEvent( break; } } + /* fall through */ + case keyUp: whichWindow = FrontWindow(); + if (whichWindow == NULL) { + /* + * This happens if we get a key event before Tk has had a + * chance to actually create and realize ".", if they type + * when "." is withdrawn(!), or between the time "." is + * destroyed and the app exits. + */ + + return false; + } window = TkMacGetXWindow(whichWindow); - eventFound |= GenerateKeyEvent(eventPtr, window); + if (GenerateKeyEvent(eventPtr, window, savedKeyCode) == 0) { + savedKeyCode = eventPtr->message; + return false; + } + eventFound = true; break; + case activateEvt: window = TkMacGetXWindow((WindowRef) eventPtr->message); eventFound |= GenerateActivateEvents(eventPtr, window); @@ -1205,6 +1248,7 @@ TkMacConvertEvent( break; } + savedKeyCode = 0; return eventFound; } @@ -1214,7 +1258,7 @@ TkMacConvertEvent( * TkMacConvertTkEvent -- * * This function converts a Macintosh event into zero or more - * Tcl events. + * Tcl events. It is intended for use in Netscape-style embedding. * * Results: * Returns 1 if event added to Tcl queue, 0 otherwse. @@ -1232,15 +1276,36 @@ TkMacConvertTkEvent( { int eventFound = false; Point where; + static UInt32 savedKeyCode; + + /* + * By default, assume it is legal for us to set the cursor + */ + + Tk_MacTkOwnsCursor(1); switch (eventPtr->what) { case nullEvent: + /* + * We get NULL events only when the cursor is NOT over + * the plugin. Otherwise we get updateCursor events. + * We will not generate polling events or move the cursor + * in this case. + */ + + eventFound = false; + break; case adjustCursorEvent: - if (GeneratePollingEvents2(window)) { + if (GeneratePollingEvents2(window, 1)) { eventFound = true; } break; case updateEvt: + /* + * It is possibly not legal for us to set the cursor + */ + + Tk_MacTkOwnsCursor(0); if (GenerateUpdateEvent(eventPtr, window)) { eventFound = true; } @@ -1267,10 +1332,24 @@ TkMacConvertTkEvent( break; } } + /* fall through. */ + case keyUp: - eventFound |= GenerateKeyEvent(eventPtr, window); + if (GenerateKeyEvent(eventPtr, window, savedKeyCode) == 0) { + savedKeyCode = eventPtr->message; + return false; + } + eventFound = true; break; + case activateEvt: + /* + * It is probably not legal for us to set the cursor + * here, since we don't know where the mouse is in the + * window that is being activated. + */ + + Tk_MacTkOwnsCursor(0); eventFound |= GenerateActivateEvents(eventPtr, window); eventFound |= GenerateFocusEvent(eventPtr, window); break; @@ -1291,10 +1370,18 @@ TkMacConvertTkEvent( * Do clipboard conversion. */ switch ((eventPtr->message & osEvtMessageMask) >> 24) { + /* + * It is possibly not legal for us to set the cursor. + * Netscape sends us these events all the time... + */ + + Tk_MacTkOwnsCursor(0); + case mouseMovedMessage: - if (GeneratePollingEvents2(window)) { + /* if (GeneratePollingEvents2(window, 0)) { eventFound = true; - } + } NEXT LINE IS TEMPORARY */ + eventFound = false; break; case suspendResumeMessage: if (!(eventPtr->message & resumeFlag)) { @@ -1318,7 +1405,7 @@ TkMacConvertTkEvent( } break; } - + savedKeyCode = 0; return eventFound; } @@ -1516,7 +1603,6 @@ TellWindowDefProcToCalcRegions( * Assuming there are no errors we now call the window definition * procedure to tell it to calculate the regions for the window. */ - if (err == noErr) { (void) CallWindowDefProc((UniversalProcPtr) *wdef, GetWVariant(wRef), wRef, wCalcRgns, 0); diff --git a/mac/tkMacWm.c b/mac/tkMacWm.c index 56c4b8a..4cd7920 100644 --- a/mac/tkMacWm.c +++ b/mac/tkMacWm.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkMacWm.c 1.72 97/10/29 13:27:30 + * SCCS: @(#) tkMacWm.c 1.77 98/02/18 11:03:54 */ #include <Gestalt.h> @@ -19,6 +19,7 @@ #include <Windows.h> #include <ToolUtils.h> +#include <tclMac.h> #include "tkPort.h" #include "tkInt.h" #include "tkMacInt.h" @@ -26,14 +27,12 @@ #include "tkScrollbar.h" /* - * If HAVE_APPEARANCE is defined in MW_TkHeader.pch then we must have the - * Appearance manager header & library. If so we can use these new API's to - * have the iconify code do the right thing. + * We now require the Appearance headers. They come with CodeWarrior Pro, + * and are on the SDK CD. However, we do not require the Appearance + * extension */ - -#ifdef HAVE_APPEARANCE -# include <Appearance.h> -#endif + +#include <Appearance.h> /* * A data structure of the following type holds information for @@ -313,7 +312,6 @@ void MacMoveWindow(WindowRef window, int x, int y); * Forward declarations for procedures defined in this file: */ -static int HaveAppearance _ANSI_ARGS_((void)); static void InitialWindowBounds _ANSI_ARGS_((TkWindow *winPtr, Rect *geometry)); static int ParseGeometry _ANSI_ARGS_((Tcl_Interp *interp, @@ -532,7 +530,7 @@ TkWmMapWindow( */ XMapWindow(winPtr->display, winPtr->window); - + /* * Now that the window is visable we can determine the offset * from the window's content orgin to the window's decorative @@ -711,7 +709,7 @@ Tk_WmCmd( return TCL_ERROR; } if (argc == 2) { - interp->result = (wmTracing) ? "on" : "off"; + Tcl_SetResult(interp, ((wmTracing) ? "on" : "off"), TCL_STATIC); return TCL_OK; } return Tcl_GetBoolean(interp, argv[2], &wmTracing); @@ -741,9 +739,12 @@ Tk_WmCmd( } if (argc == 3) { if (wmPtr->sizeHintsFlags & PAspect) { - sprintf(interp->result, "%d %d %d %d", wmPtr->minAspect.x, + char buf[TCL_INTEGER_SPACE * 4]; + + sprintf(buf, "%d %d %d %d", wmPtr->minAspect.x, wmPtr->minAspect.y, wmPtr->maxAspect.x, wmPtr->maxAspect.y); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } return TCL_OK; } @@ -758,7 +759,8 @@ Tk_WmCmd( } if ((numer1 <= 0) || (denom1 <= 0) || (numer2 <= 0) || (denom2 <= 0)) { - interp->result = "aspect number can't be <= 0"; + Tcl_SetResult(interp, "aspect number can't be <= 0", + TCL_STATIC); return TCL_ERROR; } wmPtr->minAspect.x = numer1; @@ -779,7 +781,7 @@ Tk_WmCmd( } if (argc == 3) { if (wmPtr->clientMachine != NULL) { - interp->result = wmPtr->clientMachine; + Tcl_SetResult(interp, wmPtr->clientMachine, TCL_STATIC); } return TCL_OK; } @@ -877,8 +879,9 @@ Tk_WmCmd( } if (argc == 3) { if (wmPtr->cmdArgv != NULL) { - interp->result = Tcl_Merge(wmPtr->cmdArgc, wmPtr->cmdArgv); - interp->freeProc = (Tcl_FreeProc *) free; + Tcl_SetResult(interp, + Tcl_Merge(wmPtr->cmdArgc, wmPtr->cmdArgv), + TCL_DYNAMIC); } return TCL_OK; } @@ -928,7 +931,8 @@ Tk_WmCmd( return TCL_ERROR; } if (argc == 3) { - interp->result = wmPtr->hints.input ? "passive" : "active"; + Tcl_SetResult(interp, (wmPtr->hints.input ? "passive" : "active"), + TCL_STATIC); return TCL_OK; } c = argv[3][0]; @@ -945,6 +949,7 @@ Tk_WmCmd( } else if ((c == 'f') && (strncmp(argv[1], "frame", length) == 0) && (length >= 2)) { Window window; + char buf[TCL_INTEGER_SPACE]; if (argc != 3) { Tcl_AppendResult(interp, "wrong # arguments: must be \"", @@ -955,7 +960,8 @@ Tk_WmCmd( if (window == None) { window = Tk_WindowId((Tk_Window) winPtr); } - sprintf(interp->result, "0x%x", (unsigned int) window); + sprintf(buf, "0x%x", (unsigned int) window); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } else if ((c == 'g') && (strncmp(argv[1], "geometry", length) == 0) && (length >= 2)) { char xSign, ySign; @@ -968,6 +974,8 @@ Tk_WmCmd( return TCL_ERROR; } if (argc == 3) { + char buf[16 + TCL_INTEGER_SPACE * 4]; + xSign = (wmPtr->flags & WM_NEGATIVE_X) ? '-' : '+'; ySign = (wmPtr->flags & WM_NEGATIVE_Y) ? '-' : '+'; if (wmPtr->gridWin != NULL) { @@ -979,8 +987,9 @@ Tk_WmCmd( width = winPtr->changes.width; height = winPtr->changes.height; } - sprintf(interp->result, "%dx%d%c%d%c%d", width, height, - xSign, wmPtr->x, ySign, wmPtr->y); + sprintf(buf, "%dx%d%c%d%c%d", width, height, xSign, wmPtr->x, + ySign, wmPtr->y); + Tcl_SetResult(interp, buf, TCL_VOLATILE); return TCL_OK; } if (*argv[3] == '\0') { @@ -1001,9 +1010,12 @@ Tk_WmCmd( } if (argc == 3) { if (wmPtr->sizeHintsFlags & PBaseSize) { - sprintf(interp->result, "%d %d %d %d", wmPtr->reqGridWidth, + char buf[TCL_INTEGER_SPACE * 4]; + + sprintf(buf, "%d %d %d %d", wmPtr->reqGridWidth, wmPtr->reqGridHeight, wmPtr->widthInc, wmPtr->heightInc); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } return TCL_OK; } @@ -1030,19 +1042,19 @@ Tk_WmCmd( return TCL_ERROR; } if (reqWidth < 0) { - interp->result = "baseWidth can't be < 0"; + Tcl_SetResult(interp, "baseWidth can't be < 0", TCL_STATIC); return TCL_ERROR; } if (reqHeight < 0) { - interp->result = "baseHeight can't be < 0"; + Tcl_SetResult(interp, "baseHeight can't be < 0", TCL_STATIC); return TCL_ERROR; } if (widthInc < 0) { - interp->result = "widthInc can't be < 0"; + Tcl_SetResult(interp, "widthInc can't be < 0", TCL_STATIC); return TCL_ERROR; } if (heightInc < 0) { - interp->result = "heightInc can't be < 0"; + Tcl_SetResult(interp, "heightInc can't be < 0", TCL_STATIC); return TCL_ERROR; } Tk_SetGrid((Tk_Window) winPtr, reqWidth, reqHeight, widthInc, @@ -1062,7 +1074,7 @@ Tk_WmCmd( } if (argc == 3) { if (wmPtr->hints.flags & WindowGroupHint) { - interp->result = wmPtr->leaderName; + Tcl_SetResult(interp, wmPtr->leaderName, TCL_STATIC); } return TCL_OK; } @@ -1095,8 +1107,9 @@ Tk_WmCmd( } if (argc == 3) { if (wmPtr->hints.flags & IconPixmapHint) { - interp->result = Tk_NameOfBitmap(winPtr->display, - wmPtr->hints.icon_pixmap); + Tcl_SetResult(interp, + Tk_NameOfBitmap(winPtr->display, wmPtr->hints.icon_pixmap), + TCL_STATIC); } return TCL_OK; } @@ -1155,8 +1168,9 @@ Tk_WmCmd( } if (argc == 3) { if (wmPtr->hints.flags & IconMaskHint) { - interp->result = Tk_NameOfBitmap(winPtr->display, - wmPtr->hints.icon_mask); + Tcl_SetResult(interp, + Tk_NameOfBitmap(winPtr->display, wmPtr->hints.icon_mask), + TCL_STATIC); } return TCL_OK; } @@ -1181,7 +1195,9 @@ Tk_WmCmd( return TCL_ERROR; } if (argc == 3) { - interp->result = (wmPtr->iconName != NULL) ? wmPtr->iconName : ""; + Tcl_SetResult(interp, + ((wmPtr->iconName != NULL) ? wmPtr->iconName : ""), + TCL_STATIC); return TCL_OK; } else { wmPtr->iconName = Tk_GetUid(argv[3]); @@ -1201,8 +1217,11 @@ Tk_WmCmd( } if (argc == 3) { if (wmPtr->hints.flags & IconPositionHint) { - sprintf(interp->result, "%d %d", wmPtr->hints.icon_x, + char buf[TCL_INTEGER_SPACE * 2]; + + sprintf(buf, "%d %d", wmPtr->hints.icon_x, wmPtr->hints.icon_y); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } return TCL_OK; } @@ -1230,7 +1249,7 @@ Tk_WmCmd( } if (argc == 3) { if (wmPtr->icon != NULL) { - interp->result = Tk_PathName(wmPtr->icon); + Tcl_SetResult(interp, Tk_PathName(wmPtr->icon), TCL_STATIC); } return TCL_OK; } @@ -1284,8 +1303,10 @@ Tk_WmCmd( return TCL_ERROR; } if (argc == 3) { - sprintf(interp->result, "%d %d", wmPtr->maxWidth, - wmPtr->maxHeight); + char buf[TCL_INTEGER_SPACE * 2]; + + sprintf(buf, "%d %d", wmPtr->maxWidth, wmPtr->maxHeight); + Tcl_SetResult(interp, buf, TCL_VOLATILE); return TCL_OK; } if ((Tcl_GetInt(interp, argv[3], &width) != TCL_OK) @@ -1305,8 +1326,10 @@ Tk_WmCmd( return TCL_ERROR; } if (argc == 3) { - sprintf(interp->result, "%d %d", wmPtr->minWidth, - wmPtr->minHeight); + char buf[TCL_INTEGER_SPACE * 2]; + + sprintf(buf, "%d %d", wmPtr->minWidth, wmPtr->minHeight); + Tcl_SetResult(interp, buf, TCL_VOLATILE); return TCL_OK; } if ((Tcl_GetInt(interp, argv[3], &width) != TCL_OK) @@ -1330,9 +1353,9 @@ Tk_WmCmd( } if (argc == 3) { if (Tk_Attributes((Tk_Window) winPtr)->override_redirect) { - interp->result = "1"; + Tcl_SetResult(interp, "1", TCL_STATIC); } else { - interp->result = "0"; + Tcl_SetResult(interp, "0", TCL_STATIC); } return TCL_OK; } @@ -1353,9 +1376,9 @@ Tk_WmCmd( } if (argc == 3) { if (wmPtr->sizeHintsFlags & USPosition) { - interp->result = "user"; + Tcl_SetResult(interp, "user", TCL_STATIC); } else if (wmPtr->sizeHintsFlags & PPosition) { - interp->result = "program"; + Tcl_SetResult(interp, "program", TCL_STATIC); } return TCL_OK; } @@ -1410,7 +1433,7 @@ Tk_WmCmd( for (protPtr = wmPtr->protPtr; protPtr != NULL; protPtr = protPtr->nextPtr) { if (protPtr->protocol == protocol) { - interp->result = protPtr->command; + Tcl_SetResult(interp, protPtr->command, TCL_STATIC); return TCL_OK; } } @@ -1454,9 +1477,12 @@ Tk_WmCmd( return TCL_ERROR; } if (argc == 3) { - sprintf(interp->result, "%d %d", + char buf[TCL_INTEGER_SPACE * 2]; + + sprintf(buf, "%d %d", (wmPtr->flags & WM_WIDTH_NOT_RESIZABLE) ? 0 : 1, (wmPtr->flags & WM_HEIGHT_NOT_RESIZABLE) ? 0 : 1); + Tcl_SetResult(interp, buf, TCL_VOLATILE); return TCL_OK; } if ((Tcl_GetBoolean(interp, argv[3], &width) != TCL_OK) @@ -1489,9 +1515,9 @@ Tk_WmCmd( } if (argc == 3) { if (wmPtr->sizeHintsFlags & USSize) { - interp->result = "user"; + Tcl_SetResult(interp, "user", TCL_STATIC); } else if (wmPtr->sizeHintsFlags & PSize) { - interp->result = "program"; + Tcl_SetResult(interp, "program", TCL_STATIC); } return TCL_OK; } @@ -1523,20 +1549,20 @@ Tk_WmCmd( return TCL_ERROR; } if (wmPtr->iconFor != NULL) { - interp->result = "icon"; + Tcl_SetResult(interp, "icon", TCL_STATIC); } else { switch (wmPtr->hints.initial_state) { case NormalState: - interp->result = "normal"; + Tcl_SetResult(interp, "normal", TCL_STATIC); break; case IconicState: - interp->result = "iconic"; + Tcl_SetResult(interp, "iconic", TCL_STATIC); break; case WithdrawnState: - interp->result = "withdrawn"; + Tcl_SetResult(interp, "withdrawn", TCL_STATIC); break; case ZoomState: - interp->result = "zoomed"; + Tcl_SetResult(interp, "zoomed", TCL_STATIC); break; } } @@ -1548,8 +1574,9 @@ Tk_WmCmd( return TCL_ERROR; } if (argc == 3) { - interp->result = (wmPtr->titleUid != NULL) ? wmPtr->titleUid - : winPtr->nameUid; + Tcl_SetResult(interp, + ((wmPtr->titleUid != NULL) ? wmPtr->titleUid : winPtr->nameUid), + TCL_STATIC); return TCL_OK; } else { wmPtr->titleUid = Tk_GetUid(argv[3]); @@ -1568,7 +1595,7 @@ Tk_WmCmd( } if (argc == 3) { if (wmPtr->master != None) { - interp->result = wmPtr->masterWindowName; + Tcl_SetResult(interp, wmPtr->masterWindowName, TCL_STATIC); } return TCL_OK; } @@ -2148,7 +2175,7 @@ UpdateSizeHints( * * Results: * A standard Tcl return value, plus an error message in - * interp->result if an error occurs. + * the interp's result if an error occurs. * * Side effects: * The size and/or location of winPtr may change. @@ -2333,12 +2360,26 @@ Tk_GetRootCoords( y += winPtr->changes.y + winPtr->changes.border_width; } else { + Point theOffset; - /* - * NOTE: Here we should handle - * out of process embedding. - */ - + if (gMacEmbedHandler->getOffsetProc != NULL) { + /* + * We do not require that the changes.x & changes.y for + * a non-Tk master window be kept up to date. So we + * first subtract off the possibly bogus values that have + * been added on at the top of this pass through the loop, + * and then call out to the getOffsetProc to give us + * the correct offset. + */ + + x -= winPtr->changes.x + winPtr->changes.border_width; + y -= winPtr->changes.y + winPtr->changes.border_width; + + gMacEmbedHandler->getOffsetProc((Tk_Window) winPtr, &theOffset); + + x += theOffset.h; + y += theOffset.v; + } break; } } @@ -3318,15 +3359,19 @@ TkSetWMName( { Str255 pTitle; GWorldPtr macWin; + int destWrote; if (Tk_IsEmbedded(winPtr)) { return; } + Tcl_UtfToExternal(NULL, NULL, titleUid, + strlen(titleUid), 0, NULL, + (char *) &pTitle[1], + 255, NULL, &destWrote, NULL); /* Internalize native */ + pTitle[0] = destWrote; - macWin = TkMacGetDrawablePort(winPtr->window); - - strcpy((char *) pTitle + 1, titleUid); - pTitle[0] = strlen(titleUid); + macWin = TkMacGetDrawablePort(winPtr->window); + SetWTitle((WindowPtr) macWin, pTitle); } @@ -3685,42 +3730,42 @@ TkUnsupported1Cmd( switch (wmPtr->style) { case noGrowDocProc: case documentProc: - interp->result = "documentProc"; + Tcl_SetResult(interp, "documentProc", TCL_STATIC); break; case dBoxProc: - interp->result = "dBoxProc"; + Tcl_SetResult(interp, "dBoxProc", TCL_STATIC); break; case plainDBox: - interp->result = "plainDBox"; + Tcl_SetResult(interp, "plainDBox", TCL_STATIC); break; case altDBoxProc: - interp->result = "altDBoxProc"; + Tcl_SetResult(interp, "altDBoxProc", TCL_STATIC); break; case movableDBoxProc: - interp->result = "movableDBoxProc"; + Tcl_SetResult(interp, "movableDBoxProc", TCL_STATIC); break; case zoomDocProc: case zoomNoGrow: - interp->result = "zoomDocProc"; + Tcl_SetResult(interp, "zoomDocProc", TCL_STATIC); break; case rDocProc: - interp->result = "rDocProc"; + Tcl_SetResult(interp, "rDocProc", TCL_STATIC); break; case floatProc: case floatGrowProc: - interp->result = "floatProc"; + Tcl_SetResult(interp, "floatProc", TCL_STATIC); break; case floatZoomProc: case floatZoomGrowProc: - interp->result = "floatZoomProc"; + Tcl_SetResult(interp, "floatZoomProc", TCL_STATIC); break; case floatSideProc: case floatSideGrowProc: - interp->result = "floatSideProc"; + Tcl_SetResult(interp, "floatSideProc", TCL_STATIC); break; case floatSideZoomProc: case floatSideZoomGrowProc: - interp->result = "floatSideZoomProc"; + Tcl_SetResult(interp, "floatSideZoomProc", TCL_STATIC); break; default: panic("invalid style"); @@ -3861,6 +3906,13 @@ TkMacMakeRealWindowExist( TkMacMakeRealWindowExist(contWinPtr->privatePtr->toplevel->winPtr); macWin->flags |= TK_HOST_EXISTS; return; + } else if (gMacEmbedHandler != NULL) { + if (gMacEmbedHandler->containerExistProc != NULL) { + if (gMacEmbedHandler->containerExistProc((Tk_Window) winPtr) != TCL_OK) { + panic("ContainerExistProc could not make container"); + } + } + return; } else { panic("TkMacMakeRealWindowExist could not find container"); } @@ -4148,8 +4200,7 @@ TkpWmSetState(winPtr, state) Tk_UnmapWindow((Tk_Window) winPtr); } else if (state == IconicState) { Tk_UnmapWindow((Tk_Window) winPtr); -#ifdef HAVE_APPEARANCE - if (HaveAppearance()) { + if (TkMacHaveAppearance()) { /* * The window always gets unmapped. However, if we can show the * icon version of the window (collapsed) we make the window visable @@ -4163,14 +4214,11 @@ TkpWmSetState(winPtr, state) CollapseWindow((WindowPtr) macWin, true); } } -#endif } else if (state == NormalState) { Tk_MapWindow((Tk_Window) winPtr); -#ifdef HAVE_APPEARANCE - if (HaveAppearance()) { + if (TkMacHaveAppearance()) { CollapseWindow((WindowPtr) macWin, false); } -#endif } else if (state == ZoomState) { /* TODO: need to support zoomed windows */ } @@ -4178,7 +4226,7 @@ TkpWmSetState(winPtr, state) /* *---------------------------------------------------------------------- * - * HaveAppearance -- + * TkMacHaveAppearance -- * * Determine if the appearance manager is available on this Mac. * We cache the result so future calls are fast. @@ -4192,22 +4240,20 @@ TkpWmSetState(winPtr, state) *---------------------------------------------------------------------- */ -static int -HaveAppearance() +int +TkMacHaveAppearance() { static initialized = false; - static int haveAppearance = false; + static int TkMacHaveAppearance = false; long response = 0; OSErr err = noErr; -#ifdef HAVE_APPEARANCE if (!initialized) { err = Gestalt(gestaltAppearanceAttr, &response); if (err == noErr) { - haveAppearance = true; + TkMacHaveAppearance = true; } } -#endif - return haveAppearance; + return TkMacHaveAppearance; } diff --git a/mac/tkMacXStubs.c b/mac/tkMacXStubs.c index f1042c2..4f52e41 100644 --- a/mac/tkMacXStubs.c +++ b/mac/tkMacXStubs.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkMacXStubs.c 1.87 97/11/20 18:35:29 + * SCCS: @(#) tkMacXStubs.c 1.89 97/11/26 13:10:52 */ #include "tkInt.h" @@ -46,7 +46,7 @@ */ static TkDisplay *gMacDisplay = NULL; /* Macintosh display. */ -static char *macScreenName = "Macintosh:0"; +static char *macScreenName = ":0"; /* Default name of macintosh display. */ /* @@ -541,7 +541,8 @@ TkGetServerInfo( Tk_Window tkwin) /* Token for window; this selects a * particular display and server. */ { - char buffer[50], buffer2[50]; + char buffer[8 + TCL_INTEGER_SPACE * 2]; + char buffer2[TCL_INTEGER_SPACE]; sprintf(buffer, "X%dR%d ", ProtocolVersion(Tk_Display(tkwin)), ProtocolRevision(Tk_Display(tkwin))); @@ -2,20 +2,21 @@ # tests. Execute it by invoking "source all" when running tclTest # in this directory. # -# SCCS: @(#) all 1.23 97/08/06 18:50:18 +# SCCS: @(#) all 1.28 97/12/23 15:00:50 +# These tests are not done because they cause the new configuration package +# to crash. + +set exclude {} switch $tcl_platform(platform) { "windows" { # Tests that cause tk to crash under windows. - set crash {} + set crash { safe.test } # Tests that fail under windows. - set fail { grid.test } - if {! [info exist exclude] } { - set exclude [string tolower "$crash $fail"] - } + set exclude [string tolower [concat $exclude $crash $fail]] } "macintosh" { set x [pwd] @@ -29,10 +30,16 @@ switch $tcl_platform(platform) { # Tests that fail under mac. set fail {bind.test entry.test send.test textDisp.test} - set exclude [string tolower "$crash $fail"] + set exclude [string tolower [concat $exclude $crash $fail]] } "unix" { - set exclude "" + # Tests that cause tk to crash under unix. + set crash {} + + # Tests that fail under unix. + set fail {} + + set exclude [concat $exclude $crash $fail] } } diff --git a/tests/bind.test b/tests/bind.test index 18de465..5faaedf 100644 --- a/tests/bind.test +++ b/tests/bind.test @@ -8,7 +8,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) bind.test 1.39 97/07/01 18:01:05 +# SCCS: @(#) bind.test 1.43 98/01/13 17:20:56 if {[string compare test [info procs test]] != 0} { source defs @@ -247,7 +247,7 @@ test bind-6.2 {Tk_DeleteBindTable procedure: pending bindings deleted later} { set x } {a1 bye.all2 bye.a1 b1 bye.c1} -test bind-7.1 {Tk_CreateBinding procedure: error} { +test bind-7.1 {Tk_CreateBinding procedure: bad binding} { catch {destroy .b.c} canvas .b.c list [catch {.b.c bind foo <} msg] $msg @@ -1463,8 +1463,11 @@ test bind-16.35 {ExpandPercents procedure} {nonPortable} { event gen .b.f <Key-space> event gen .b.f <Key-dollar> -state 1 event gen .b.f <Key-braceleft> -state 1 + event gen .b.f <Key-Multi_key> + event gen .b.f <Key-e> + event gen .b.f <Key-apostrophe> set x -} "a A { } {\r} {{}} {{}} { } {\$} \\\{" +} "a A { } {\r} {{}} {{}} { } {\$} \\\{ {{}} {{}} \u00e9" test bind-16.36 {ExpandPercents procedure} { setup bind .b.f <Configure> {set x "%B"} @@ -1532,10 +1535,10 @@ test bind-16.43 {ExpandPercents procedure} { test bind-17.1 {event command} { list [catch {event} msg] $msg -} {1 {wrong # args: should be "event option ?arg1?"}} +} {1 {wrong # args: should be "event option ?arg?"}} test bind-17.2 {event command} { - list [catch {event {}} msg] $msg -} {1 {bad option "": should be add, delete, generate, info}} + list [catch {event xyz} msg] $msg +} {1 {bad option "xyz": must be add, delete, generate, or info}} test bind-17.3 {event command: add} { list [catch {event add} msg] $msg } {1 {wrong # args: should be "event add virtual sequence ?sequence ...?"}} @@ -1604,8 +1607,7 @@ test bind-17.16 {event command: generate} { } {1 {bad event type or keysym "xyz"}} test bind-17.17 {event command} { list [catch {event foo} msg] $msg -} {1 {bad option "foo": should be add, delete, generate, info}} - +} {1 {bad option "foo": must be add, delete, generate, or info}} test bind-18.1 {CreateVirtualEvent procedure: GetVirtualEventUid} { list [catch {event add asd <Ctrl-v>} msg] $msg @@ -1964,73 +1966,73 @@ test bind-22.16 {HandleEventGenerate} { } {foo 99 100 101 102} test bind-22.17 {HandleEventGenerate} { list [catch {event gen . <Button> -when xyz} msg] $msg -} {1 {bad position "xyz": should be now, head, mark, tail}} -set i 14 +} {1 {bad -when value "xyz": must be now, head, mark, or tail}} +set i 18 foreach check { {<Configure> %a {-above .xyz} {{1 {bad window path name ".xyz"}}}} {<Configure> %a {-above .b} {[winfo id .b]}} - {<Configure> %a {-above xyz} {{1 {expected integer but got "xyz"}}}} + {<Configure> %a {-above xyz} {{1 {bad window name/identifier "xyz"}}}} {<Configure> %a {-above [winfo id .b]} {[winfo id .b]}} - {<Key> %b {-above .} {{1 {bad option to <Key> event: "-above"}}}} + {<Key> %b {-above .} {{1 {<Key> event doesn't accept "-above" option}}}} {<Configure> %B {-borderwidth xyz} {{1 {bad screen distance "xyz"}}}} {<Configure> %B {-borderwidth 2i} {[winfo pixels .b.f 2i]}} - {<Key> %k {-borderwidth 2i} {{1 {bad option to <Key> event: "-borderwidth"}}}} + {<Key> %k {-borderwidth 2i} {{1 {<Key> event doesn't accept "-borderwidth" option}}}} {<Button> %b {-button xyz} {{1 {expected integer but got "xyz"}}}} {<Button> %b {-button 1} 1} - {<Key> %k {-button 1} {{1 {bad option to <Key> event: "-button"}}}} + {<Key> %k {-button 1} {{1 {<Key> event doesn't accept "-button" option}}}} {<Expose> %c {-count xyz} {{1 {expected integer but got "xyz"}}}} {<Expose> %c {-count 20} 20} - {<Key> %b {-count 20} {{1 {bad option to <Key> event: "-count"}}}} + {<Key> %b {-count 20} {{1 {<Key> event doesn't accept "-count" option}}}} - {<Enter> %d {-detail xyz} {{1 {bad -detail value "xyz": must be NotifyAncestor, NotifyVirtual, NotifyInferior, NotifyNonlinear, NotifyNonlinearVirtual, NotifyPointer, NotifyPointerRoot, NotifyDetailNone}}}} + {<Enter> %d {-detail xyz} {{1 {bad -detail value "xyz": must be NotifyAncestor, NotifyVirtual, NotifyInferior, NotifyNonlinear, NotifyNonlinearVirtual, NotifyPointer, NotifyPointerRoot, or NotifyDetailNone}}}} {<FocusIn> %d {-detail NotifyVirtual} {{}}} {<Enter> %d {-detail NotifyVirtual} NotifyVirtual} - {<Key> %k {-detail NotifyVirtual} {{1 {bad option to <Key> event: "-detail"}}}} + {<Key> %k {-detail NotifyVirtual} {{1 {<Key> event doesn't accept "-detail" option}}}} {<Enter> %f {-focus xyz} {{1 {expected boolean value but got "xyz"}}}} {<Enter> %f {-focus 1} 1} - {<Key> %k {-focus 1} {{1 {bad option to <Key> event: "-focus"}}}} + {<Key> %k {-focus 1} {{1 {<Key> event doesn't accept "-focus" option}}}} {<Expose> %h {-height xyz} {{1 {bad screen distance "xyz"}}}} {<Expose> %h {-height 2i} {[winfo pixels .b.f 2i]}} {<Configure> %h {-height 2i} {[winfo pixels .b.f 2i]}} - {<Key> %k {-height 2i} {{1 {bad option to <Key> event: "-height"}}}} + {<Key> %k {-height 2i} {{1 {<Key> event doesn't accept "-height" option}}}} {<Key> %k {-keycode xyz} {{1 {expected integer but got "xyz"}}}} {<Key> %k {-keycode 20} 20} - {<Button> %b {-keycode 20} {{1 {bad option to <Button> event: "-keycode"}}}} + {<Button> %b {-keycode 20} {{1 {<Button> event doesn't accept "-keycode" option}}}} {<Key> %K {-keysym xyz} {{1 {unknown keysym "xyz"}}}} {<Key> %K {-keysym a} a} - {<Button> %b {-keysym a} {{1 {bad option to <Button> event: "-keysym"}}}} + {<Button> %b {-keysym a} {{1 {<Button> event doesn't accept "-keysym" option}}}} - {<Enter> %m {-mode xyz} {{1 {bad -mode value "xyz": must be NotifyNormal, NotifyGrab, NotifyUngrab, NotifyWhileGrabbed}}}} + {<Enter> %m {-mode xyz} {{1 {bad -mode value "xyz": must be NotifyNormal, NotifyGrab, NotifyUngrab, or NotifyWhileGrabbed}}}} {<Enter> %m {-mode NotifyNormal} NotifyNormal} {<FocusIn> %m {-mode NotifyNormal} {{}}} - {<Key> %k {-mode NotifyNormal} {{1 {bad option to <Key> event: "-mode"}}}} + {<Key> %k {-mode NotifyNormal} {{1 {<Key> event doesn't accept "-mode" option}}}} {<Map> %o {-override xyz} {{1 {expected boolean value but got "xyz"}}}} {<Map> %o {-override 1} 1} {<Reparent> %o {-override 1} 1} {<Configure> %o {-override 1} 1} - {<Key> %k {-override 1} {{1 {bad option to <Key> event: "-override"}}}} + {<Key> %k {-override 1} {{1 {<Key> event doesn't accept "-override" option}}}} - {<Circulate> %p {-place xyz} {{1 {bad -place value "xyz": must be PlaceOnTop, PlaceOnBottom}}}} + {<Circulate> %p {-place xyz} {{1 {bad -place value "xyz": must be PlaceOnTop, or PlaceOnBottom}}}} {<Circulate> %p {-place PlaceOnTop} PlaceOnTop} - {<Key> %k {-place PlaceOnTop} {{1 {bad option to <Key> event: "-place"}}}} + {<Key> %k {-place PlaceOnTop} {{1 {<Key> event doesn't accept "-place" option}}}} {<Key> %R {-root .xyz} {{1 {bad window path name ".xyz"}}}} {<Key> %R {-root .b} {[winfo id .b]}} - {<Key> %R {-root xyz} {{1 {expected integer but got "xyz"}}}} + {<Key> %R {-root xyz} {{1 {bad window name/identifier "xyz"}}}} {<Key> %R {-root [winfo id .b]} {[winfo id .b]}} {<Button> %R {-root .b} {[winfo id .b]}} {<Motion> %R {-root .b} {[winfo id .b]}} {<<Paste>> %R {-root .b} {[winfo id .b]}} {<Enter> %R {-root .b} {[winfo id .b]}} - {<Configure> %R {-root .b} {{1 {bad option to <Configure> event: "-root"}}}} + {<Configure> %R {-root .b} {{1 {<Configure> event doesn't accept "-root" option}}}} {<Key> %X {-rootx xyz} {{1 {bad screen distance "xyz"}}}} {<Key> %X {-rootx 2i} {[winfo pixels .b.f 2i]}} @@ -2038,7 +2040,7 @@ foreach check { {<Motion> %X {-rootx 2i} {[winfo pixels .b.f 2i]}} {<<Paste>> %X {-rootx 2i} {[winfo pixels .b.f 2i]}} {<Enter> %X {-rootx 2i} {[winfo pixels .b.f 2i]}} - {<Configure> %X {-rootx 2i} {{1 {bad option to <Configure> event: "-rootx"}}}} + {<Configure> %X {-rootx 2i} {{1 {<Configure> event doesn't accept "-rootx" option}}}} {<Key> %Y {-rooty xyz} {{1 {bad screen distance "xyz"}}}} {<Key> %Y {-rooty 2i} {[winfo pixels .b.f 2i]}} @@ -2046,7 +2048,7 @@ foreach check { {<Motion> %Y {-rooty 2i} {[winfo pixels .b.f 2i]}} {<<Paste>> %Y {-rooty 2i} {[winfo pixels .b.f 2i]}} {<Enter> %Y {-rooty 2i} {[winfo pixels .b.f 2i]}} - {<Configure> %Y {-rooty 2i} {{1 {bad option to <Configure> event: "-rooty"}}}} + {<Configure> %Y {-rooty 2i} {{1 {<Configure> event doesn't accept "-rooty" option}}}} {<Key> %E {-sendevent xyz} {{1 {expected boolean value but got "xyz"}}}} {<Key> %E {-sendevent 1} 1} @@ -2062,19 +2064,19 @@ foreach check { {<Motion> %s {-state 1} 1} {<<Paste>> %s {-state 1} 1} {<Enter> %s {-state 1} 1} - {<Visibility> %s {-state xyz} {{1 {bad -state value "xyz": must be VisibilityUnobscured, VisibilityPartiallyObscured, VisibilityFullyObscured}}}} + {<Visibility> %s {-state xyz} {{1 {bad -state value "xyz": must be VisibilityUnobscured, VisibilityPartiallyObscured, or VisibilityFullyObscured}}}} {<Visibility> %s {-state VisibilityUnobscured} VisibilityUnobscured} - {<Configure> %s {-state xyz} {{1 {bad option to <Configure> event: "-state"}}}} + {<Configure> %s {-state xyz} {{1 {<Configure> event doesn't accept "-state" option}}}} {<Key> %S {-subwindow .xyz} {{1 {bad window path name ".xyz"}}}} {<Key> %S {-subwindow .b} {[winfo id .b]}} - {<Key> %S {-subwindow xyz} {{1 {expected integer but got "xyz"}}}} + {<Key> %S {-subwindow xyz} {{1 {bad window name/identifier "xyz"}}}} {<Key> %S {-subwindow [winfo id .b]} {[winfo id .b]}} {<Button> %S {-subwindow .b} {[winfo id .b]}} {<Motion> %S {-subwindow .b} {[winfo id .b]}} {<<Paste>> %S {-subwindow .b} {[winfo id .b]}} {<Enter> %S {-subwindow .b} {[winfo id .b]}} - {<Configure> %S {-subwindow .b} {{1 {bad option to <Configure> event: "-subwindow"}}}} + {<Configure> %S {-subwindow .b} {{1 {<Configure> event doesn't accept "-subwindow" option}}}} {<Key> %t {-time xyz} {{1 {expected integer but got "xyz"}}}} {<Key> %t {-time 100} 100} @@ -2083,16 +2085,16 @@ foreach check { {<<Paste>> %t {-time 100} 100} {<Enter> %t {-time 100} 100} {<Property> %t {-time 100} 100} - {<Configure> %t {-time 100} {{1 {bad option to <Configure> event: "-time"}}}} + {<Configure> %t {-time 100} {{1 {<Configure> event doesn't accept "-time" option}}}} {<Expose> %w {-width xyz} {{1 {bad screen distance "xyz"}}}} {<Expose> %w {-width 2i} {[winfo pixels .b.f 2i]}} {<Configure> %w {-width 2i} {[winfo pixels .b.f 2i]}} - {<Key> %k {-width 2i} {{1 {bad option to <Key> event: "-width"}}}} + {<Key> %k {-width 2i} {{1 {<Key> event doesn't accept "-width" option}}}} {<Unmap> %W {-window .xyz} {{1 {bad window path name ".xyz"}}}} {<Unmap> %W {-window .b.f} .b.f} - {<Unmap> %W {-window xyz} {{1 {expected integer but got "xyz"}}}} + {<Unmap> %W {-window xyz} {{1 {bad window name/identifier "xyz"}}}} {<Unmap> %W {-window [winfo id .b.f]} .b.f} {<Unmap> %W {-window .b.f} .b.f} {<Map> %W {-window .b.f} .b.f} @@ -2100,7 +2102,7 @@ foreach check { {<Configure> %W {-window .b.f} .b.f} {<Gravity> %W {-window .b.f} .b.f} {<Circulate> %W {-window .b.f} .b.f} - {<Key> %W {-window .b.f} {{1 {bad option to <Key> event: "-window"}}}} + {<Key> %W {-window .b.f} {{1 {<Key> event doesn't accept "-window" option}}}} {<Key> %x {-x xyz} {{1 {bad screen distance "xyz"}}}} {<Key> %x {-x 2i} {[winfo pixels .b.f 2i]}} @@ -2112,7 +2114,7 @@ foreach check { {<Configure> %x {-x 2i} {[winfo pixels .b.f 2i]}} {<Gravity> %x {-x 2i} {[winfo pixels .b.f 2i]}} {<Reparent> %x {-x 2i} {[winfo pixels .b.f 2i]}} - {<Map> %x {-x 2i} {{1 {bad option to <Map> event: "-x"}}}} + {<Map> %x {-x 2i} {{1 {<Map> event doesn't accept "-x" option}}}} {<Key> %y {-y xyz} {{1 {bad screen distance "xyz"}}}} {<Key> %y {-y 2i} {[winfo pixels .b.f 2i]}} @@ -2124,9 +2126,9 @@ foreach check { {<Configure> %y {-y 2i} {[winfo pixels .b.f 2i]}} {<Gravity> %y {-y 2i} {[winfo pixels .b.f 2i]}} {<Reparent> %y {-y 2i} {[winfo pixels .b.f 2i]}} - {<Map> %y {-y 2i} {{1 {bad option to <Map> event: "-y"}}}} + {<Map> %y {-y 2i} {{1 {<Map> event doesn't accept "-y" option}}}} - {<Key> %k {-xyz 1} {{1 {bad option to <Key> event: "-xyz"}}}} + {<Key> %k {-xyz 1} {{1 {bad option "-xyz": must be -when, -above, -borderwidth, -button, -count, -detail, -focus, -height, -keycode, -keysym, -mode, -override, -place, -root, -rootx, -rooty, -sendevent, -serial, -state, -subwindow, -time, -width, -window, -x, or -y}}}} } { set event [lindex $check 0] test bind-22.$i "HandleEventGenerate: options $event [lindex $check 2]" { @@ -2237,7 +2239,17 @@ test bind-24.12 {FindSequence procedure: not new sequence, don't create} { bind .b.f <Control-Button-2> "foo" bind .b.f <Button-2> } {} - +test bind-24.13 {FindSequence procedure: no binding} { + catch {destroy .b.f} + frame .b.f -class Test -width 150 -height 100 + list [catch {bind .b.f <a>} msg] $msg +} {0 {}} +test bind-24.14 {FindSequence procedure: no binding} { + catch {destroy .b.f} + canvas .b.f + set i [.b.f create rect 10 10 100 100] + list [catch {.b.f bind $i <a>} msg] $msg +} {0 {}} test bind-25.1 {ParseEventDescription procedure} { list [catch {bind .b \x7 test} msg] $msg diff --git a/tests/bitmap.test b/tests/bitmap.test new file mode 100644 index 0000000..9fa98a3 --- /dev/null +++ b/tests/bitmap.test @@ -0,0 +1,99 @@ +# This file is a Tcl script to test out the procedures in the file +# tkBitmap.c. It is organized in the standard white-box fashion for +# Tcl tests. +# +# Copyright (c) 1998 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) bitmap.test 1.1 97/12/24 15:17:34 + +if {[info procs test] != "test"} { + source defs +} + +if {[info commands testbitmap] != "testbitmap"} { + puts "testbitmap command not available; skipping tests" + return +} + +eval destroy [winfo children .] +wm geometry . {} +raise . + +test bitmap-1.1 {Tk_AllocBitmapFromObj - converting internal reps} { + set x gray25 + lindex $x 0 + destroy .b1 + button .b1 -bitmap $x + lindex $x 0 + testbitmap gray25 +} {{1 0}} +test bitmap-1.2 {Tk_AllocBitmapFromObj - discard stale bitmap} { + set x gray25 + destroy .b1 .b2 + button .b1 -bitmap $x + destroy .b1 + set result {} + lappend result [testbitmap gray25] + button .b2 -bitmap $x + lappend result [testbitmap gray25] +} {{} {{1 1}}} +test bitmap-1.3 {Tk_AllocBitmapFromObj - reuse existing bitmap} { + set x gray25 + destroy .b1 .b2 + button .b1 -bitmap $x + set result {} + lappend result [testbitmap gray25] + button .b2 -bitmap $x + pack .b1 .b2 -side top + lappend result [testbitmap gray25] +} {{1 1}} {{2 1}} + +test bitmap-2.1 {Tk_GetBitmap procedure} { + destroy .b1 + list [catch {button .b1 -bitmap bad_name} msg] $msg +} {1 {bitmap "bad_name" not defined}} +test bitmap-2.2 {Tk_GetBitmap procedure} { + destroy .b1 + list [catch {button .b1 -bitmap @xyzzy} msg] $msg +} {1 {error reading bitmap file "xyzzy"}} + +test bitmap-3.1 {Tk_FreeBitmapFromObj - reference counts} { + set x questhead + destroy .b1 .b2 .b3 + button .b1 -bitmap $x + button .b3 -bitmap $x + button .b2 -bitmap $x + set result {} + lappend result [testbitmap questhead] + destroy .b1 + lappend result [testbitmap questhead] + destroy .b2 + lappend result [testbitmap questhead] + destroy .b3 + lappend result [testbitmap questhead] +} {{{3 1}} {{2 1}} {{1 1}} {}} + +test bitmap-4.1 {FreeBitmapObjProc} { + destroy .b + set x [format questhead] + button .b -bitmap $x + set y [format questhead] + .b configure -bitmap $y + set z [format questhead] + .b configure -bitmap $z + set result {} + lappend result [testbitmap questhead] + set x red + lappend result [testbitmap questhead] + set z 32 + lappend result [testbitmap questhead] + destroy .b + lappend result [testbitmap questhead] + set y bogus + set result +} {{{1 3}} {{1 2}} {{1 1}} {}} + +destroy .t diff --git a/tests/border.test b/tests/border.test new file mode 100644 index 0000000..d990ae0 --- /dev/null +++ b/tests/border.test @@ -0,0 +1,176 @@ +# This file is a Tcl script to test out the procedures in the file +# tkBorder.c. It is organized in the standard fashion for Tcl tests. +# +# Copyright (c) 1998 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) border.test 1.2 97/12/24 16:17:03 + +if {[info procs test] != "test"} { + source defs +} + +if {[info commands testborder] != "testborder"} { + puts "testborder command not available; skipping tests" + return +} + +eval destroy [winfo children .] +wm geometry . {} +raise . + +# Create a top-level with its own colormap (so we can test under +# controlled conditions), then check to make sure that the visual +# is color-mapped with 256 borders. If not, just skip this whole +# test file. + +if [catch {toplevel .t -visual {pseudocolor 8} -colormap new}] { + return +} +wm geom .t +0+0 +if {[winfo depth .t] != 8} { + destroy .t + return +} + +test border-1.1 {Tk_AllocBorderFromObj - converting internal reps} { + set x orange + lindex $x 0 + destroy .b1 + button .b1 -bg $x -text .b1 + lindex $x 0 + testborder orange +} {{1 0}} +test border-1.3 {Tk_AllocBorderFromObj - discard stale border} { + set x orange + destroy .b1 .b2 + button .b1 -bg $x -text First + destroy .b1 + set result {} + lappend result [testborder orange] + button .b2 -bg $x -text Second + lappend result [testborder orange] +} {{} {{1 1}}} +test border-1.2 {Tk_AllocBorderFromObj - reuse existing border} { + set x orange + destroy .b1 .b2 + button .b1 -bg $x -text First + set result {} + lappend result [testborder orange] + button .b2 -bg $x -text Second + pack .b1 .b2 -side top + lappend result [testborder orange] +} {{{1 1}} {{2 1}}} +test border-1.4 {Tk_AllocBorderFromObj - try other borders in list} { + set x purple + destroy .b1 .b2 .t.b + button .b1 -bg $x -text First + pack .b1 -side top + set result {} + lappend result [testborder purple] + button .t.b -bg $x -text Second + pack .t.b -side top + lappend result [testborder purple] + button .b2 -bg $x -text Third + pack .b2 -side top + lappend result [testborder purple] +} {{{1 1}} {{1 1} {1 0}} {{1 0} {2 1}}} + +test border-3.1 {Tk_Free3DBorder - reference counts} { + set x purple + destroy .b1 .b2 .t.b + button .b1 -bg $x -text First + pack .b1 -side top + button .t.b -bg $x -text Second + pack .t.b -side top + button .b2 -bg $x -text Third + pack .b2 -side top + set result {} + lappend result [testborder purple] + destroy .b1 + lappend result [testborder purple] + destroy .b2 + lappend result [testborder purple] + destroy .t.b + lappend result [testborder purple] +} {{{1 0} {2 1}} {{1 0} {1 1}} {{1 0}} {}} +test border-3.4 {Tk_Free3DBorder - unlinking from list} { + 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 -bg $x -text .b1 + button .t.b1 -bg $x -text .t.b1 + button .t.b2 -bg $x -text .t.b2 + button .t2.b1 -bg $x -text .t2.b1 + button .t2.b2 -bg $x -text .t2.b2 + button .t2.b3 -bg $x -text .t2.b3 + button .t3.b1 -bg $x -text .t3.b1 + button .t3.b2 -bg $x -text .t3.b2 + button .t3.b3 -bg $x -text .t3.b3 + button .t3.b4 -bg $x -text .t3.b4 + set result {} + lappend result [testborder purple] + destroy .t2 + lappend result [testborder purple] + destroy .b + lappend result [testborder purple] + destroy .t3 + lappend result [testborder purple] + destroy .t + lappend result [testborder purple] +} {{{4 1} {3 0} {2 0} {1 0}} {{4 1} {2 0} {1 0}} {{4 1} {2 0}} {{2 0}} {}} + +test border-4.1 {FreeBorderObjProc} { + destroy .b + set x [format purple] + button .b -bg $x -text .b1 + set y [format purple] + .b configure -bg $y + set z [format purple] + .b configure -bg $z + set result {} + lappend result [testborder purple] + set x red + lappend result [testborder purple] + set z 32 + lappend result [testborder purple] + destroy .b + lappend result [testborder purple] + set y bogus + set result +} {{{1 3}} {{1 2}} {{1 1}} {}} + +catch {destroy .b} +button .b +test get-2.1 {Tk_GetReliefFromObj} { + .b configure -relief flat + .b cget -relief +} {flat} +test get-2.2 {Tk_GetReliefFromObj} { + .b configure -relief groove + .b cget -relief +} {groove} +test get-2.3 {Tk_GetReliefFromObj} { + .b configure -relief raised + .b cget -relief +} {raised} +test get-2.3 {Tk_GetReliefFromObj} { + .b configure -relief ridge + .b cget -relief +} {ridge} +test get-2.3 {Tk_GetReliefFromObj} { + .b configure -relief solid + .b cget -relief +} {solid} +test get-2.3 {Tk_GetReliefFromObj} { + .b configure -relief sunken + .b cget -relief +} {sunken} +test get-2.4 {Tk_GetReliefFromObj - error} { + list [catch {.b configure -relief upanddown} msg] $msg +} {1 {bad relief "upanddown": must be flat, groove, raised, ridge, solid, or sunken}} + +destroy .t diff --git a/tests/button.test b/tests/button.test index 2c6d082..e72929b 100644 --- a/tests/button.test +++ b/tests/button.test @@ -8,7 +8,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) button.test 1.39 97/07/31 10:19:02 +# SCCS: @(#) button.test 1.41 97/12/24 16:10:22 if {[lsearch [image types] test] < 0} { puts "This application hasn't been compiled with the \"test\"" @@ -51,255 +51,217 @@ update set i 1 foreach test { {-activebackground #012345 #012345 non-existent - {unknown color name "non-existent"}} + {unknown color name "non-existent"} {0 1 1 1}} {-activeforeground #ff0000 #ff0000 non-existent - {unknown color name "non-existent"}} - {-anchor nw nw bogus {bad anchor position "bogus": must be n, ne, e, se, s, sw, w, nw, or center}} + {unknown color name "non-existent"} {0 1 1 1}} + {-anchor nw nw bogus {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center} {1 1 1 1}} {-background #ff0000 #ff0000 non-existent - {unknown color name "non-existent"}} - {-bg #ff0000 #ff0000 non-existent {unknown color name "non-existent"}} - {-bd 4 4 badValue {bad screen distance "badValue"}} - {-bitmap questhead questhead badValue {bitmap "badValue" not defined}} - {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} - {-command "set x" {set x} {} {}} - {-cursor arrow arrow badValue {bad cursor spec "badValue"}} - {-disabledforeground #00ff00 #00ff00 xyzzy {unknown color name "xyzzy"}} - {-fg #110022 #110022 bogus {unknown color name "bogus"}} - {-font {Helvetica 12} {Helvetica 12} {} {font "" doesn't exist}} - {-foreground #110022 #110022 bogus {unknown color name "bogus"}} - {-height 18 18 20.0 {expected integer but got "20.0"}} - {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}} - {-highlightcolor #110022 #110022 bogus {unknown color name "bogus"}} - {-highlightthickness 18 18 badValue {bad screen distance "badValue"}} - {-image image1 image1 bogus {image "bogus" doesn't exist}} - {-indicatoron yes 1 no_way {expected boolean value but got "no_way"}} - {-justify right right bogus {bad justification "bogus": must be left, right, or center}} - {-offvalue lousy lousy {} {}} - {-offvalue fantastic fantastic {} {}} - {-padx 12 12 420x {bad screen distance "420x"}} - {-pady 12 12 420x {bad screen distance "420x"}} - {-relief groove groove 1.5 {bad relief type "1.5": must be flat, groove, raised, ridge, solid, or sunken}} - {-selectcolor #110022 #110022 bogus {unknown color name "bogus"}} - {-selectimage image1 image1 bogus {image "bogus" doesn't exist}} - {-state normal normal bogus {bad state value "bogus": must be normal, active, or disabled}} - {-takefocus "any string" "any string" {} {}} - {-text "Sample text" {Sample text} {} {}} - {-textvariable i i {} {}} - {-underline 5 5 3p {expected integer but got "3p"}} - {-width 402 402 3p {expected integer but got "3p"}} - {-wraplength 100 100 6x {bad screen distance "6x"}} + {unknown color name "non-existent"} {1 1 1 1}} + {-bd 4 4 badValue {bad screen distance "badValue"} {1 1 1 1}} + {-bg #ff0000 #ff0000 non-existent {unknown color name "non-existent"} + {1 1 1 1}} + {-bitmap questhead questhead badValue {bitmap "badValue" not defined} + {1 1 1 1}} + {-borderwidth 1.3 1.3 badValue {bad screen distance "badValue"} {1 1 1 1}} + {-command "set x" {set x} {} {} {0 1 1 1}} + {-cursor arrow arrow badValue {bad cursor spec "badValue"} {1 1 1 1}} + {-default active active huh? + {bad default "huh?": must be active, disabled, or normal} + {0 1 0 0}} + {-disabledforeground #00ff00 #00ff00 xyzzy {unknown color name "xyzzy"} + {0 1 1 1}} + {-fg #110022 #110022 bogus {unknown color name "bogus"} {1 1 1 1}} + {-font {Helvetica 12} {Helvetica 12} {} {font "" doesn't exist} {1 1 1 1}} + {-foreground #110022 #110022 bogus {unknown color name "bogus"} {1 1 1 1}} + {-height 18 18 20.0 {expected integer but got "20.0"} {1 1 1 1}} + {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"} + {1 1 1 1}} + {-highlightcolor #110022 #110022 bogus {unknown color name "bogus"} + {1 1 1 1}} + {-highlightthickness 6m 6m badValue {bad screen distance "badValue"} + {1 1 1 1}} + {-image image1 image1 bogus {image "bogus" doesn't exist} {1 1 1 1}} + {-indicatoron yes 1 no_way {expected boolean value but got "no_way"} + {0 0 1 1}} + {-justify right right bogus {bad justification "bogus": must be left, right, or center} {1 1 1 1}} + {-offvalue lousy lousy {} {} {0 0 1 0}} + {-offvalue fantastic fantastic {} {} {0 0 1 0}} + {-padx 12m 12m 420x {bad screen distance "420x"} {1 1 1 1}} + {-pady 12m 12m 420x {bad screen distance "420x"} {1 1 1 1}} + {-relief groove groove 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken} {1 1 1 1}} + {-selectcolor #110022 #110022 bogus {unknown color name "bogus"} {0 0 1 1}} + {-selectimage image1 image1 bogus {image "bogus" doesn't exist} {0 0 1 1}} + {-state normal normal bogus {bad state "bogus": must be active, disabled, or normal} {0 1 1 1}} + {-takefocus "any string" "any string" {} {} {1 1 1 1}} + {-text "Sample text" {Sample text} {} {} {1 1 1 1}} + {-textvariable i i {} {} {1 1 1 1}} + {-underline 5 5 3p {expected integer but got "3p"} {1 1 1 1}} + {-value anyString anyString {} {} {0 0 0 1}} + {-width 402 402 3p {expected integer but got "3p"} {1 1 1 1}} + {-wraplength 100 100 6x {bad screen distance "6x"} {1 1 1 1}} } { set name [lindex $test 0] - test button-1.$i {configuration options} { - .c configure $name [lindex $test 1] - lindex [.c configure $name] 4 - } [lindex $test 2] - incr i - if {[lindex $test 3] != ""} { - test button-1.$i {configuration options} { - list [catch {.c configure $name [lindex $test 3]} msg] $msg - } [list 1 [lindex $test 4]] + set classes [lindex $test 5] + foreach w {.l .b .c .r} hasOption [lindex $test 5] { + if $hasOption { + test button-1.$i {configuration options} { + $w configure $name [lindex $test 1] + lindex [$w configure $name] 4 + } [lindex $test 2] + incr i + if {[lindex $test 3] != ""} { + test button-1.$i {configuration options} { + list [catch {$w configure $name [lindex $test 3]} msg] $msg + } [list 1 [lindex $test 4]] + } + $w configure $name [lindex [$w configure $name] 3] + } else { + test button-1.$i {configuration options} { + list [catch {$w configure $name [lindex $test 1]} msg] $msg + } "1 {unknown option \"$name\"}" + } } - .c configure $name [lindex [.c configure $name] 3] incr i } test button-1.$i {configuration options} { .c configure -selectcolor {} } {} incr i -# the following tests only work on buttons, not checkbuttons -test button-1.$i {configuration options} { - .b configure -default active - lindex [.b configure -default] 4 -} active -incr i -test button-1.$i {configuration options} { - .b configure -default normal - lindex [.b configure -default] 4 -} normal -incr i -test button-1.$i {configuration options} { - .b configure -default disabled - lindex [.b configure -default] 4 -} disabled -incr i -test button-1.$i {configuration options} { - .b configure -default active - lindex [.b configure -default] 3 -} disabled -incr i -test button-1.$i {configuration options} { - list [catch {.b configure -default no_way} msg] $msg -} {1 {bad -default value "no_way": must be normal, active, or disabled}} -set i 1 -foreach check { - {-activebackground 1 0 0 0} - {-activeforeground 1 0 0 0} - {-anchor 0 0 0 0} - {-background 0 0 0 0} - {-bd 0 0 0 0} - {-bg 0 0 0 0} - {-bitmap 0 0 0 0} - {-borderwidth 0 0 0 0} - {-command 1 0 0 0} - {-cursor 0 0 0 0} - {-default 1 0 1 1} - {-disabledforeground 1 0 0 0} - {-fg 0 0 0 0} - {-font 0 0 0 0} - {-foreground 0 0 0 0} - {-height 0 0 0 0} - {-image 0 0 0 0} - {-indicatoron 1 1 0 0} - {-offvalue 1 1 0 1} - {-onvalue 1 1 0 1} - {-padx 0 0 0 0} - {-pady 0 0 0 0} - {-relief 0 0 0 0} - {-selectcolor 1 1 0 0} - {-selectimage 1 1 0 0} - {-state 1 0 0 0} - {-text 0 0 0 0} - {-textvariable 0 0 0 0} - {-value 1 1 1 0} - {-variable 1 1 0 0} - {-width 0 0 0 0} +test button-3.1 {ButtonCreate - not enough cd ../unix } { - test button-2.$i {label-specific options} " - catch {.l configure [lindex $check 0]} - " [lindex $check 1] - incr i - test button-2.$i {button-specific options} " - catch {.b configure [lindex $check 0]} - " [lindex $check 2] - incr i - test button-2.$i {checkbutton-specific options} " - catch {.c configure [lindex $check 0]} - " [lindex $check 3] - incr i - test button-2.$i {radiobutton-specific options} " - catch {.r configure [lindex $check 0]} - " [lindex $check 4] - incr i -} - -test button-3.1 {ButtonCreate procedure} { list [catch {button} msg] $msg } {1 {wrong # args: should be "button pathName ?options?"}} -test button-3.2 {ButtonCreate procedure} { +test button-3.2 {ButtonCreate procedure - setting label class} { catch {destroy .x} label .x winfo class .x } {Label} -test button-3.3 {ButtonCreate procedure} { +test button-3.3 {ButtonCreate - setting button class} { catch {destroy .x} button .x winfo class .x } {Button} -test button-3.4 {ButtonCreate procedure} { +test button-3.4 {ButtonCreate - setting checkbutton class} { catch {destroy .x} checkbutton .x winfo class .x } {Checkbutton} -test button-3.5 {ButtonCreate procedure} { +test button-3.5 {ButtonCreate - setting radiobutton class} { catch {destroy .x} radiobutton .x winfo class .x } {Radiobutton} rename button gorp -test button-3.6 {ButtonCreate procedure} { +test button-3.6 {ButtonCreate - setting class} { catch {destroy .x} gorp .x winfo class .x } {Button} rename gorp button -test button-3.7 {ButtonCreate procedure} { +test button-3.7 {ButtonCreate - bad window name} { list [catch {button foo} msg] $msg } {1 {bad window path name "foo"}} -test button-3.8 {ButtonCreate procedure} { +test button-3.8 {ButtonCreate procedure - error in default option value} { + catch {destroy .funny} + option add *funny.background bogus + list [catch {button .funny} msg] $msg $errorInfo +} {1 {unknown color name "bogus"} {unknown color name "bogus" + (database entry for "-background" in widget ".funny") + invoked from within +"button .funny"}} +test button-3.9 {ButtonCreate procedure - option error} { catch {destroy .x} list [catch {button .x -gorp foo} msg] $msg [winfo exists .x] } {1 {unknown option "-gorp"} 0} +test button-3.10 {ButtonCreate procedure - return value} { + catch {destroy .abcd} + set x [button .abcd] + destroy .abc + set x +} {.abcd} -test button-4.1 {ButtonWidgetCmd procedure} { +test button-4.1 {ButtonWidgetCmd - too few arguments} { list [catch {.b} msg] $msg } {1 {wrong # args: should be ".b option ?arg arg ...?"}} -test button-4.2 {ButtonWidgetCmd procedure, "cget" option} { +test button-4.2 {ButtonWidgetCmd - bad option name} { list [catch {.b c} msg] $msg -} {1 {bad option "c": must be cget, configure, flash, or invoke}} -test button-4.3 {ButtonWidgetCmd procedure, "cget" option} { +} {1 {ambiguous option "c": must be cget, configure, flash, or invoke}} +test button-4.3 {ButtonWidgetCmd - bad option name} { + list [catch {.b bogus} msg] $msg +} {1 {bad option "bogus": must be cget, configure, flash, or invoke}} +test button-4.4 {ButtonWidgetCmd procedure, "cget" option} { list [catch {.b cget a b} msg] $msg } {1 {wrong # args: should be ".b cget option"}} -test button-4.4 {ButtonWidgetCmd procedure, "cget" option} { +test button-4.5 {ButtonWidgetCmd procedure, "cget" option} { list [catch {.b cget -gorp} msg] $msg } {1 {unknown option "-gorp"}} -test button-4.5 {ButtonWidgetCmd procedure, "cget" option} { +test button-4.6 {ButtonWidgetCmd procedure, "cget" option} { .b configure -highlightthickness 3 .b cget -highlightthickness } {3} -test button-4.6 {ButtonWidgetCmd procedure, "cget" option} { +test button-4.7 {ButtonWidgetCmd procedure, "cget" option} { list [catch {.l cget -disabledforeground} msg] $msg } {1 {unknown option "-disabledforeground"}} -test button-4.7 {ButtonWidgetCmd procedure, "cget" option} { +test button-4.8 {ButtonWidgetCmd procedure, "cget" option} { catch {.b cget -disabledforeground} } {0} -test button-4.8 {ButtonWidgetCmd procedure, "cget" option} { +test button-4.9 {ButtonWidgetCmd procedure, "cget" option} { list [catch {.b cget -variable} msg] $msg } {1 {unknown option "-variable"}} -test button-4.9 {ButtonWidgetCmd procedure, "cget" option} { +test button-4.10 {ButtonWidgetCmd procedure, "cget" option} { catch {.c cget -variable} } {0} -test button-4.10 {ButtonWidgetCmd procedure, "cget" option} { +test button-4.11 {ButtonWidgetCmd procedure, "cget" option} { list [catch {.c cget -value} msg] $msg } {1 {unknown option "-value"}} -test button-4.11 {ButtonWidgetCmd procedure, "cget" option} { +test button-4.12 {ButtonWidgetCmd procedure, "cget" option} { catch {.r cget -value} } {0} -test button-4.12 {ButtonWidgetCmd procedure, "cget" option} { +test button-4.13 {ButtonWidgetCmd procedure, "cget" option} { list [catch {.r cget -onvalue} msg] $msg } {1 {unknown option "-onvalue"}} -test button-4.13 {ButtonWidgetCmd procedure, "configure" option} { +test button-4.14 {ButtonWidgetCmd procedure, "configure" option} { llength [.c configure] } {36} -test button-4.14 {ButtonWidgetCmd procedure, "configure" option} { +test button-4.15 {ButtonWidgetCmd procedure, "configure" option} { list [catch {.b configure -gorp} msg] $msg } {1 {unknown option "-gorp"}} -test button-4.15 {ButtonWidgetCmd procedure, "configure" option} { +test button-4.16 {ButtonWidgetCmd procedure, "configure" option} { list [catch {.b co -bg #ffffff -fg} msg] $msg } {1 {value for "-fg" missing}} -test button-4.16 {ButtonWidgetCmd procedure, "configure" option} { +test button-4.17 {ButtonWidgetCmd procedure, "configure" option} { .b configure -fg #123456 .b configure -bg #654321 lindex [.b configure -fg] 4 } {#123456} .c configure -variable value -onvalue 1 -offvalue 0 .r configure -variable value2 -value red -test button-4.17 {ButtonWidgetCmd procedure, "deselect" option} { +test button-4.18 {ButtonWidgetCmd procedure, "deselect" option} { list [catch {.c deselect foo} msg] $msg } {1 {wrong # args: should be ".c deselect"}} -test button-4.18 {ButtonWidgetCmd procedure, "deselect" option} { +test button-4.19 {ButtonWidgetCmd procedure, "deselect" option} { list [catch {.l deselect} msg] $msg } {1 {bad option "deselect": must be cget or configure}} -test button-4.19 {ButtonWidgetCmd procedure, "deselect" option} { +test button-4.20 {ButtonWidgetCmd procedure, "deselect" option} { list [catch {.b deselect} msg] $msg } {1 {bad option "deselect": must be cget, configure, flash, or invoke}} -test button-4.20 {ButtonWidgetCmd procedure, "deselect" option} { +test button-4.21 {ButtonWidgetCmd procedure, "deselect" option} { set value 1 .c d set value } {0} -test button-4.21 {ButtonWidgetCmd procedure, "deselect" option} { +test button-4.22 {ButtonWidgetCmd procedure, "deselect" option} { set value2 green .r deselect set value2 } {green} -test button-4.22 {ButtonWidgetCmd procedure, "deselect" option} { +test button-4.23 {ButtonWidgetCmd procedure, "deselect" option} { set value2 red .r deselect set value2 } {} -test button-4.23 {ButtonWidgetCmd procedure, "deselect" option} { +test button-4.24 {ButtonWidgetCmd procedure, "deselect" option} { set value 1 trace variable value w bogusTrace set result [list [catch {.c deselect} msg] $msg $errorInfo $value] @@ -308,7 +270,7 @@ test button-4.23 {ButtonWidgetCmd procedure, "deselect" option} { } {1 {can't set "value": trace aborted} {can't set "value": trace aborted while executing ".c deselect"} 0} -test button-4.24 {ButtonWidgetCmd procedure, "deselect" option} { +test button-4.25 {ButtonWidgetCmd procedure, "deselect" option} { set value2 red trace variable value2 w bogusTrace set result [list [catch {.r deselect} msg] $msg $errorInfo $value2] @@ -317,40 +279,40 @@ test button-4.24 {ButtonWidgetCmd procedure, "deselect" option} { } {1 {can't set "value2": trace aborted} {can't set "value2": trace aborted while executing ".r deselect"} {}} -test button-4.25 {ButtonWidgetCmd procedure, "flash" option} { +test button-4.26 {ButtonWidgetCmd procedure, "flash" option} { list [catch {.b flash foo} msg] $msg } {1 {wrong # args: should be ".b flash"}} -test button-4.26 {ButtonWidgetCmd procedure, "flash" option} { +test button-4.27 {ButtonWidgetCmd procedure, "flash" option} { list [catch {.l flash} msg] $msg } {1 {bad option "flash": must be cget or configure}} -test button-4.27 {ButtonWidgetCmd procedure, "flash" option} { +test button-4.28 {ButtonWidgetCmd procedure, "flash" option} { list [catch {.b flash} msg] $msg } {0 {}} -test button-4.28 {ButtonWidgetCmd procedure, "flash" option} { +test button-4.29 {ButtonWidgetCmd procedure, "flash" option} { list [catch {.c flash} msg] $msg } {0 {}} -test button-4.29 {ButtonWidgetCmd procedure, "flash" option} { +test button-4.30 {ButtonWidgetCmd procedure, "flash" option} { list [catch {.r f} msg] $msg } {0 {}} -test button-4.30 {ButtonWidgetCmd procedure, "invoke" option} { +test button-4.31 {ButtonWidgetCmd procedure, "invoke" option} { list [catch {.b invoke foo} msg] $msg } {1 {wrong # args: should be ".b invoke"}} -test button-4.31 {ButtonWidgetCmd procedure, "invoke" option} { +test button-4.32 {ButtonWidgetCmd procedure, "invoke" option} { list [catch {.l invoke} msg] $msg } {1 {bad option "invoke": must be cget or configure}} -test button-4.32 {ButtonWidgetCmd procedure, "invoke" option} { +test button-4.33 {ButtonWidgetCmd procedure, "invoke" option} { .b configure -command {set x invoked} set x "not invoked" .b invoke set x } {invoked} -test button-4.33 {ButtonWidgetCmd procedure, "invoke" option} { +test button-4.34 {ButtonWidgetCmd procedure, "invoke" option} { .b configure -command {set x invoked} -state disabled set x "not invoked" .b invoke set x } {not invoked} -test button-4.34 {ButtonWidgetCmd procedure, "invoke" option} { +test button-4.35 {ButtonWidgetCmd procedure, "invoke" option} { set value bogus .c configure -command {set x invoked} -variable value -onvalue 1 \ -offvalue 0 @@ -358,35 +320,35 @@ test button-4.34 {ButtonWidgetCmd procedure, "invoke" option} { .c invoke list $x $value } {invoked 1} -test button-4.35 {ButtonWidgetCmd procedure, "invoke" option} { +test button-4.36 {ButtonWidgetCmd procedure, "invoke" option} { set value2 green .r configure -command {set x invoked} -variable value2 -value red set x "not invoked" .r i list $x $value2 } {invoked red} -test button-4.36 {ButtonWidgetCmd procedure, "select" option} { +test button-4.37 {ButtonWidgetCmd procedure, "select" option} { list [catch {.l select} msg] $msg } {1 {bad option "select": must be cget or configure}} -test button-4.37 {ButtonWidgetCmd procedure, "select" option} { +test button-4.38 {ButtonWidgetCmd procedure, "select" option} { list [catch {.b select} msg] $msg } {1 {bad option "select": must be cget, configure, flash, or invoke}} -test button-4.38 {ButtonWidgetCmd procedure, "select" option} { +test button-4.39 {ButtonWidgetCmd procedure, "select" option} { list [catch {.c select foo} msg] $msg } {1 {wrong # args: should be ".c select"}} -test button-4.39 {ButtonWidgetCmd procedure, "select" option} { +test button-4.40 {ButtonWidgetCmd procedure, "select" option} { set value bogus .c configure -command {} -variable value -onvalue lovely -offvalue 0 .c s set value } {lovely} -test button-4.40 {ButtonWidgetCmd procedure, "select" option} { +test button-4.41 {ButtonWidgetCmd procedure, "select" option} { set value2 green .r configure -command {} -variable value2 -value red .r select set value2 } {red} -test button-4.41 {ButtonWidgetCmd procedure, "select" option} { +test button-4.42 {ButtonWidgetCmd procedure, "select" option} { set value2 yellow trace variable value2 w bogusTrace set result [list [catch {.r select} msg] $msg $errorInfo $value2] @@ -395,19 +357,19 @@ test button-4.41 {ButtonWidgetCmd procedure, "select" option} { } {1 {can't set "value2": trace aborted} {can't set "value2": trace aborted while executing ".r select"} red} -test button-4.42 {ButtonWidgetCmd procedure, "toggle" option} { +test button-4.43 {ButtonWidgetCmd procedure, "toggle" option} { list [catch {.l toggle} msg] $msg } {1 {bad option "toggle": must be cget or configure}} -test button-4.43 {ButtonWidgetCmd procedure, "toggle" option} { +test button-4.44 {ButtonWidgetCmd procedure, "toggle" option} { list [catch {.b toggle} msg] $msg } {1 {bad option "toggle": must be cget, configure, flash, or invoke}} -test button-4.44 {ButtonWidgetCmd procedure, "toggle" option} { +test button-4.45 {ButtonWidgetCmd procedure, "toggle" option} { list [catch {.r toggle} msg] $msg } {1 {bad option "toggle": must be cget, configure, deselect, flash, invoke, or select}} -test button-4.45 {ButtonWidgetCmd procedure, "toggle" option} { +test button-4.46 {ButtonWidgetCmd procedure, "toggle" option} { list [catch {.c toggle foo} msg] $msg } {1 {wrong # args: should be ".c toggle"}} -test button-4.46 {ButtonWidgetCmd procedure, "toggle" option} { +test button-4.47 {ButtonWidgetCmd procedure, "toggle" option} { set value bogus .c configure -command {} -variable value -onvalue sunshine -offvalue rain .c toggle @@ -417,7 +379,7 @@ test button-4.46 {ButtonWidgetCmd procedure, "toggle" option} { .c toggle lappend result $value } {sunshine rain sunshine} -test button-4.47 {ButtonWidgetCmd procedure, "toggle" option} { +test button-4.48 {ButtonWidgetCmd procedure, "toggle" option} { .c configure -onvalue xyz -offvalue abc set value xyz trace variable value w bogusTrace @@ -427,7 +389,7 @@ test button-4.47 {ButtonWidgetCmd procedure, "toggle" option} { } {1 {can't set "value": trace aborted} {can't set "value": trace aborted while executing ".c toggle"} abc} -test button-4.48 {ButtonWidgetCmd procedure, "toggle" option} { +test button-4.49 {ButtonWidgetCmd procedure, "toggle" option} { .c configure -onvalue xyz -offvalue abc set value abc trace variable value w bogusTrace @@ -437,9 +399,6 @@ test button-4.48 {ButtonWidgetCmd procedure, "toggle" option} { } {1 {can't set "value": trace aborted} {can't set "value": trace aborted while executing ".c toggle"} xyz} -test button-4.49 {ButtonWidgetCmd procedure} { - list [catch {.c bad_option} msg] $msg -} {1 {bad option "bad_option": must be cget, configure, deselect, flash, invoke, select, or toggle}} test button-4.50 {ButtonWidgetCmd procedure, "toggle" option} { catch {unset value}; set value(1) 1; set result [list [catch {.c toggle} msg] $msg $errorInfo] @@ -462,7 +421,14 @@ test button-5.1 {DestroyButton procedure} { eval destroy [winfo children .] } {} -test button-6.1 {ConfigureButton procedure} { +test button-6.1 {ConfigureButton - textvariable trace} { + catch {destroy .b1} + button .b1 -bd 4 -bg green + catch {.b1 configure -bd 7 -bg green -fg bogus} + list [catch {.b1 configure -bd 7 -bg red -fg bogus} msg] \ + $msg [.b1 cget -bd] [.b1 cget -bg] +} {1 {unknown color name "bogus"} 4 green} +test button-6.2 {ConfigureButton - textvariable trace} { catch {destroy .b1} set x From-x set y From-y @@ -471,7 +437,7 @@ test button-6.1 {ConfigureButton procedure} { set x New lindex [.b1 configure -text] 4 } {From-y} -test button-6.2 {ConfigureButton procedure} { +test button-6.2 {ConfigureButton - variable traces} { catch {destroy .b1} catch {unset x} checkbutton .b1 -variable x @@ -482,7 +448,7 @@ test button-6.2 {ConfigureButton procedure} { .b1 toggle set y } {1} -test button-6.3 {ConfigureButton procedure} { +test button-6.3 {ConfigureButton - image handling} { catch {destroy .b1} eval image delete [image names] image create test image1 @@ -492,18 +458,12 @@ test button-6.3 {ConfigureButton procedure} { .b1 configure -image image2 image names } {image2} -test button-6.4 {ConfigureButton procedure} { - catch {destroy .b1} - button .b1 -text "Test" -state disabled - list [catch {.b1 configure -state bogus} msg] $msg \ - [lindex [.b1 configure -state] 4] -} {1 {bad state value "bogus": must be normal, active, or disabled} normal} -test button-6.5 {ConfigureButton procedure} { +test button-6.5 {ConfigureButton - default value for variable} { catch {destroy .b1} checkbutton .b1 .b1 cget -variable } {b1} -test button-6.6 {ConfigureButton procedure} { +test button-6.6 {ConfigureButton - setting selected state from variable} { catch {destroy .b1} set x 0 set y Shiny @@ -512,19 +472,19 @@ test button-6.6 {ConfigureButton procedure} { .b1 toggle set y } 0 -test button-6.7 {ConfigureButton procedure} { +test button-6.7 {ConfigureButton - setting selected state from variable} { catch {destroy .b1} catch {unset x} checkbutton .b1 -variable x -offvalue Bogus set x } Bogus -test button-6.8 {ConfigureButton procedure} { +test button-6.8 {ConfigureButton - setting selected state from variable} { catch {destroy .b1} catch {unset x} radiobutton .b1 -variable x set x } {} -test button-6.9 {ConfigureButton procedure} { +test button-6.9 {ConfigureButton - error in setting variable} { catch {destroy .b1} catch {unset x} trace variable x w bogusTrace @@ -532,23 +492,23 @@ test button-6.9 {ConfigureButton procedure} { trace vdelete x w bogusTrace set result } {1 {can't set "x": trace aborted}} -test button-6.10 {ConfigureButton procedure} { +test button-6.10 {ConfigureButton - bad image name} { catch {destroy .b1} list [catch {button .b1 -image bogus} msg] $msg } {1 {image "bogus" doesn't exist}} -test button-6.11 {ConfigureButton procedure} { +test button-6.11 {ConfigureButton - setting variable from current text value} { catch {destroy .b1} catch {unset x} button .b1 -textvariable x -text "Button 1" set x } {Button 1} -test button-6.12 {ConfigureButton procedure} { +test button-6.12 {ConfigureButton - using current value of variable} { catch {destroy .b1} set x Override button .b1 -textvariable x -text "Button 1" set x } {Override} -test button-6.13 {ConfigureButton procedure} { +test button-6.13 {ConfigureButton - variable handling} { catch {destroy .b1} catch {unset x} trace variable x w bogusTrace @@ -557,7 +517,7 @@ test button-6.13 {ConfigureButton procedure} { trace vdelete x w bogusTrace set result } {1 {can't set "x": trace aborted} foo} -test button-6.14 {ConfigureButton procedure} { +test button-6.14 {ConfigureButton - -width option} { catch {destroy .b1} button .b1 -text "Button 1" list [catch {.b1 configure -width 1i} msg] $msg $errorInfo @@ -565,7 +525,7 @@ test button-6.14 {ConfigureButton procedure} { (processing -width option) invoked from within ".b1 configure -width 1i"}} -test button-6.15 {ConfigureButton procedure} { +test button-6.15 {ConfigureButton - -height option} { catch {destroy .b1} button .b1 -text "Button 1" list [catch {.b1 configure -height 0.5c} msg] $msg $errorInfo @@ -573,7 +533,7 @@ test button-6.15 {ConfigureButton procedure} { (processing -height option) invoked from within ".b1 configure -height 0.5c"}} -test button-6.16 {ConfigureButton procedure} { +test button-6.16 {ConfigureButton - -width option} { catch {destroy .b1} button .b1 -bitmap questhead list [catch {.b1 configure -width abc} msg] $msg $errorInfo @@ -581,7 +541,7 @@ test button-6.16 {ConfigureButton procedure} { (processing -width option) invoked from within ".b1 configure -width abc"}} -test button-6.17 {ConfigureButton procedure} { +test button-6.17 {ConfigureButton - -height option} { catch {destroy .b1} eval image delete [image names] image create test image1 @@ -591,7 +551,7 @@ test button-6.17 {ConfigureButton procedure} { (processing -height option) invoked from within ".b1 configure -height 0.5x"}} -test button-6.18 {ConfigureButton procedure} {nonPortable fonts} { +test button-6.18 {ConfigureButton - computing geometry} {nonPortable fonts} { catch {destroy .b1} button .b1 -text "Sample text" -width 10 -height 2 pack .b1 @@ -599,7 +559,7 @@ test button-6.18 {ConfigureButton procedure} {nonPortable fonts} { .b1 configure -bitmap questhead lappend result [winfo reqwidth .b1] [winfo reqheight .b1] } {102 46 20 12} -test button-6.19 {ConfigureButton procedure} { +test button-6.19 {ConfigureButton - computing geometry} { catch {destroy .b1} button .b1 -text "Button 1" set old [winfo reqwidth .b1] @@ -819,4 +779,3 @@ test button-13.1 {button widget vs hidden commands} { eval destroy [winfo children .] option clear - diff --git a/tests/canvText.test b/tests/canvText.test index b121c25..c09182f 100644 --- a/tests/canvText.test +++ b/tests/canvText.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) canvText.test 1.8 97/06/24 13:34:16 +# SCCS: @(#) canvText.test 1.9 97/07/07 11:39:35 if {"[info procs test]" != "test"} { source defs @@ -199,7 +199,7 @@ test canvText-6.1 {ComputeTextBbox procedure} {fonts} { focus .c .c focus test .c itemconfig test -text "abcd\nefghi\njklmnopq" -test canvText-7.1 {DisplayText procedure: stippling} { +test canvText-7.0 {DisplayText procedure: stippling} { .c itemconfig test -stipple gray50 update .c itemconfig test -stipple {} diff --git a/tests/canvas.test b/tests/canvas.test index 786a29a..e9eca28 100644 --- a/tests/canvas.test +++ b/tests/canvas.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) canvas.test 1.10 97/07/31 10:22:48 +# SCCS: @(#) canvas.test 1.11 97/12/16 16:20:53 if {[info procs test] != "test"} { source defs @@ -74,7 +74,16 @@ canvas .c -width 60 -height 40 -scrollregion {0 0 200 150} -bd 0 \ -highlightthickness 0 pack .c update -test canvas-2.1 {CanvasWidgetCmd, xview option} { + +test canvas-2.1 {CanvasWidgetCmd, bind option} { + set i [.c create rect 10 10 100 100] + list [catch {.c bind $i <a>} msg] $msg +} {0 {}} +test canvas-2.2 {CanvasWidgetCmd, bind option} { + set i [.c create rect 10 10 100 100] + list [catch {.c bind $i <} msg] $msg +} {1 {no event type or button # or keysym}} +test canvas-2.3 {CanvasWidgetCmd, xview option} { .c configure -xscrollincrement 40 -yscrollincrement 5 .c xview moveto 0 update @@ -83,7 +92,7 @@ test canvas-2.1 {CanvasWidgetCmd, xview option} { update lappend x [.c xview] } {{0 0.3} {0.4 0.7}} -test canvas-2.2 {CanvasWidgetCmd, xview option} {nonPortable} { +test canvas-2.4 {CanvasWidgetCmd, xview option} {nonPortable} { # This test gives slightly different results on platforms such # as NetBSD. I don't know why... .c configure -xscrollincrement 0 -yscrollincrement 5 diff --git a/tests/clrpick.test b/tests/clrpick.test index d267224..7584bac 100644 --- a/tests/clrpick.test +++ b/tests/clrpick.test @@ -6,7 +6,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# @(#) clrpick.test 1.9 97/10/21 11:29:53 +# @(#) clrpick.test 1.10 97/10/29 10:33:44 # if {[string compare test [info procs test]] == 1} { @@ -15,9 +15,9 @@ if {[string compare test [info procs test]] == 1} { test clrpick-1.1 {tk_chooseColor command} { list [catch {tk_chooseColor -foo} msg] $msg -} {1 {unknown option "-foo", must be -initialcolor, -parent or -title}} +} {1 {bad option "-foo": must be -initialcolor, -parent, or -title}} -catch {tk_chooseColor -foo} msg +catch {tk_chooseColor -foo 1} msg regsub -all , $msg "" options regsub \"-foo\" $options "" options @@ -31,7 +31,7 @@ foreach option $options { test clrpick-1.3 {tk_chooseColor command} { list [catch {tk_chooseColor -foo bar} msg] $msg -} {1 {unknown option "-foo", must be -initialcolor, -parent or -title}} +} {1 {bad option "-foo": must be -initialcolor, -parent, or -title}} test clrpick-1.4 {tk_chooseColor command} { list [catch {tk_chooseColor -initialcolor} msg] $msg diff --git a/tests/color.test b/tests/color.test index 030efa0..23a41c9 100644 --- a/tests/color.test +++ b/tests/color.test @@ -1,17 +1,22 @@ # 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 Sun Microsystems, Inc. +# Copyright (c) 1995-1998 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) color.test 1.5 96/02/16 10:56:05 +# SCCS: @(#) color.test 1.7 98/01/12 13:23:09 if {[info procs test] != "test"} { source defs } +if {[info commands testcolor] != "testcolor"} { + puts "testcolor command not available; skipping tests" + return +} + eval destroy [winfo children .] wm geometry . {} raise . @@ -125,21 +130,63 @@ if [colorsFree .t.c] { } destroy .t.c .t.c2 -test color-1.1 {Tk_GetColor procedure} { +test color-1.1 {Tk_AllocColorFromObj - converting internal reps} { + 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} { + 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} { + 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} { + 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-2.1 {Tk_GetColor procedure} { c255 [winfo rgb .t red] } {255 0 0} -test color-1.2 {Tk_GetColor procedure} { +test color-2.2 {Tk_GetColor procedure} { list [catch {winfo rgb .t noname} msg] $msg } {1 {unknown color name "noname"}} - -test color-1.3 {Tk_GetColor procedure} { +test color-2.3 {Tk_GetColor procedure} { c255 [winfo rgb .t #123456] } {18 52 86} -test color-1.4 {Tk_GetColor procedure} { +test color-2.4 {Tk_GetColor procedure} { list [catch {winfo rgb .t #xyz} msg] $msg } {1 {invalid color name "#xyz"}} -test color-2.1 {Tk_FreeColor procedure, reference counting} { +test color-3.1 {Tk_FreeColor procedure, reference counting} { eval destroy [winfo child .t] mkColors .t.c 40 6 0 240 240 0 -6 0 0 0 -40 pack .t.c @@ -153,7 +200,7 @@ test color-2.1 {Tk_FreeColor procedure, reference counting} { .t.c2 delete $last lappend result [colorsFree .t] } {0 1} -test color-2.2 {Tk_FreeColor procedure, flushing stressed cmap information} { +test color-3.2 {Tk_FreeColor procedure, flushing stressed cmap information} { eval destroy [winfo child .t] mkColors .t.c 40 6 0 240 240 0 -6 0 0 0 -40 pack .t.c @@ -163,5 +210,69 @@ test color-2.2 {Tk_FreeColor procedure, flushing stressed cmap information} { update closest .t 241 241 1 } {240 240 0} +test color-3.3 {Tk_FreeColorFromObj - reference counts} { + 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} { + 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} { + 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 diff --git a/tests/config.test b/tests/config.test new file mode 100644 index 0000000..96a01e6 --- /dev/null +++ b/tests/config.test @@ -0,0 +1,823 @@ +# This file is a Tcl script to test the procedures in tkConfig.c, +# which comprise the new new option configuration system. It is +# organized in the standard "white-box" fashion for Tcl tests. +# +# 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. +# +# SCCS: @(#) config.test 1.21 98/01/09 16:47:32 + +if {[info command testobjconfig] != "testobjconfig"} { + puts "This application hasn't been compiled with the \"testobjconfig\"" + puts "command, so I can't run this test. Are you sure you're using" + puts "tktest instead of wish?" + return +} + +if {[info procs test] != "test"} { + source defs +} + +proc killTables {} { + # Note: it's important to delete chain2 before chain1, because + # chain2 depends on chain1. If chain1 is deleted first, the + # delete of chain2 will crash. + + foreach t {alltypes chain2 chain1 configerror internal new notenoughparams + twowindows} { + while {[testobjconfig info $t] != ""} { + testobjconfig delete $t + } + } +} + +foreach i [winfo children .] { + destroy $i +} +killTables +wm geometry . {} +raise . + +test config-1.1 {Tk_CreateOptionTable - reference counts} { + eval destroy [winfo children .] + killTables + set x {} + testobjconfig alltypes .a + lappend x [testobjconfig info alltypes] + testobjconfig alltypes .b + lappend x [testobjconfig info alltypes] + eval destroy [winfo children .] + set x +} {{1 15 -boolean} {2 15 -boolean}} +test config-1.2 {Tk_CreateOptionTable - synonym initialization} { + eval destroy [winfo children .] + testobjconfig alltypes .a -synonym green + .a cget -color +} {green} +test config-1.3 {Tk_CreateOptionTable - option database initialization} { + eval destroy [winfo children .] + option clear + testobjconfig alltypes .a + option add *b.string different + testobjconfig alltypes .b + list [.a cget -string] [.b cget -string] +} {foo different} +test config-1.4 {Tk_CreateOptionTable - option database initialization} { + eval destroy [winfo children .] + option clear + testobjconfig alltypes .a + option add *b.String bar + testobjconfig alltypes .b + list [.a cget -string] [.b cget -string] +} {foo bar} +test config-1.5 {Tk_CreateOptionTable - default initialization} { + eval destroy [winfo children .] + testobjconfig alltypes .a + .a cget -relief +} {raised} +test config-1.6 {Tk_CreateOptionTable - chained tables} { + eval destroy [winfo children .] + killTables + testobjconfig chain1 .a + testobjconfig chain2 .b + testobjconfig info chain2 +} {1 4 -three 2 2 -one} +test config-1.7 {Tk_CreateOptionTable - chained tables} { + eval destroy [winfo children .] + killTables + testobjconfig chain2 .b + testobjconfig chain1 .a + testobjconfig info chain2 +} {1 4 -three 2 2 -one} +test config-1.8 {Tk_CreateOptionTable - chained tables} { + eval destroy [winfo children .] + testobjconfig chain1 .a + testobjconfig chain2 .b + list [catch {.a cget -four} msg] $msg [.a cget -one] \ + [.b cget -four] [.b cget -one] +} {1 {unknown option "-four"} one four one} + +test config-2.1 {Tk_DeleteOptionTable - reference counts} { + eval destroy [winfo children .] + killTables + testobjconfig chain1 .a + testobjconfig chain2 .b + testobjconfig chain2 .c + eval destroy [winfo children .] + set x {} + testobjconfig delete chain2 + lappend x [testobjconfig info chain2] [testobjconfig info chain1] + testobjconfig delete chain2 + lappend x [testobjconfig info chain2] [testobjconfig info chain1] +} {{1 4 -three 2 2 -one} {2 2 -one} {} {1 2 -one}} + +# No tests for DestroyOptionHashTable; couldn't figure out how to test. + +test config-3.1 {Tk_InitOptions - priority of chained tables} { + eval destroy [winfo children .] + testobjconfig chain1 .a + testobjconfig chain2 .b + list [.a cget -two] [.b cget -two] +} {two {two and a half}} +test config-3.2 {Tk_InitOptions - initialize from database} { + eval destroy [winfo children .] + option clear + option add *a.color blue + testobjconfig alltypes .a + list [.a cget -color] +} {blue} +test config-3.3 {Tk_InitOptions - initialize from database} { + eval destroy [winfo children .] + option clear + option add *a.justify bogus + testobjconfig alltypes .a + list [.a cget -justify] +} {left} +test config-3.4 {Tk_InitOptions - initialize from widget class} { + eval destroy [winfo children .] + testobjconfig alltypes .a + list [.a cget -color] +} {red} +test config-3.5 {Tk_InitOptions - no initial value} { + eval destroy [winfo children .] + testobjconfig alltypes .a + .a cget -anchor +} {} +test config-3.6 {Tk_InitOptions - bad initial value} { + eval destroy [winfo children .] + option clear + option add *a.color non-existent + list [catch {testobjconfig alltypes .a} msg] $msg $errorInfo +} {1 {unknown color name "non-existent"} {unknown color name "non-existent" + (database entry for "-color" in widget ".a") + invoked from within +"testobjconfig alltypes .a"}} +option clear +test config-3.7 {Tk_InitOptions - bad initial value} { + eval destroy [winfo children .] + list [catch {testobjconfig configerror} msg] $msg $errorInfo +} {1 {expected integer but got "bogus"} {expected integer but got "bogus" + (default value for "-int") + invoked from within +"testobjconfig configerror"}} +option clear + +test config-4.1 {DoObjConfig - boolean} { + catch {rename .foo {}} + list [catch {testobjconfig alltypes .foo -boolean 0} msg] $msg [catch {.foo cget -boolean} result] $result [catch {rename .foo {}}] +} {0 .foo 0 0 0} +test config-4.2 {DoObjConfig - boolean} { + catch {rename .foo {}} + list [catch {testobjconfig alltypes .foo -boolean 1} msg] $msg [catch {.foo cget -boolean} result] $result [catch {rename .foo {}}] +} {0 .foo 0 1 0} +test config-4.3 {DoObjConfig - invalid boolean} { + catch {rename .foo {}} + list [catch {testobjconfig alltypes .foo -boolean {}} msg] $msg +} {1 {expected boolean value but got ""}} +test config-4.4 {DoObjConfig - boolean internal value} { + catch {rename .foo {}} + testobjconfig internal .foo -boolean 0 + .foo cget -boolean +} {0} +test config-4.5 {DoObjConfig - integer} { + catch {rename .foo {}} + list [catch {testobjconfig alltypes .foo -integer 3} msg] $msg [catch {.foo cget -integer} result] $result [catch {rename .foo {}}] +} {0 .foo 0 3 0} +test config-4.6 {DoObjConfig - invalid integer} { + catch {rename .foo {}} + list [catch {testobjconfig alltypes .foo -integer bar} msg] $msg +} {1 {expected integer but got "bar"}} +test config-4.7 {DoObjConfig - integer internal value} { + catch {rename .foo {}} + testobjconfig internal .foo -integer 421 + .foo cget -integer +} {421} +test config-4.8 {DoObjConfig - double} { + catch {rename .foo {}} + list [catch {testobjconfig alltypes .foo -double 3.14} msg] $msg [catch {.foo cget -double} result] $result [catch {rename .foo {}}] +} {0 .foo 0 3.14 0} +test config-4.9 {DoObjConfig - invalid double} { + catch {rename .foo {}} + list [catch {testobjconfig alltypes .foo -double bar} msg] $msg +} {1 {expected floating-point number but got "bar"}} +test config-4.10 {DoObjConfig - double internal value} { + catch {rename .foo {}} + testobjconfig internal .foo -double 62.75 + .foo cget -double +} {62.75} +test config-4.11 {DoObjConfig - string} { + catch {destroy .foo} + list [catch {testobjconfig alltypes .foo -string test} msg] $msg [catch {.foo cget -string} result] $result [destroy .foo] +} {0 .foo 0 test {}} +test config-4.12 {DoObjConfig - null string} { + catch {destroy .foo} + list [catch {testobjconfig alltypes .foo -string {}} msg] $msg [catch {.foo cget -string} result] $result [destroy .foo] +} {0 .foo 0 {} {}} +test config-4.13 {DoObjConfig - string internal value} { + catch {rename .foo {}} + testobjconfig internal .foo -string "this is a test" + .foo cget -string +} {this is a test} +test config-4.14 {DoObjConfig - string table} { + catch {destroy .foo} + list [catch {testobjconfig alltypes .foo -stringtable two} msg] $msg [catch {.foo cget -stringtable} result] $result [destroy .foo] +} {0 .foo 0 two {}} +test config-4.15 {DoObjConfig - invalid string table} { + catch {destroy .foo} + list [catch {testobjconfig alltypes .foo -stringtable foo} msg] $msg +} {1 {bad stringtable "foo": must be one, two, three, or four}} +test config-4.16 {DoObjConfig - new string table} { + catch {destroy .foo} + testobjconfig alltypes .foo -stringtable two + list [catch {.foo configure -stringtable three} msg] $msg [catch {.foo cget -stringtable} result] $result [destroy .foo] +} {0 16 0 three {}} +test config-4.17 {DoObjConfig - stringtable internal value} { + catch {rename .foo {}} + testobjconfig internal .foo -stringtable "four" + .foo cget -stringtable +} {four} +test config-4.18 {DoObjConfig - color} { + catch {rename .foo {}} + list [catch {testobjconfig alltypes .foo -color blue} msg] $msg [catch {.foo cget -color} result] $result [destroy .foo] +} {0 .foo 0 blue {}} +test config-4.19 {DoObjConfig - invalid color} { + catch {destroy .foo} + list [catch {testobjconfig alltypes .foo -color xxx} msg] $msg +} {1 {unknown color name "xxx"}} +test config-4.20 {DoObjConfig - color internal value} { + catch {rename .foo {}} + testobjconfig internal .foo -color purple + .foo cget -color +} {purple} +test config-4.21 {DoObjConfig - null color} { + catch {rename .foo {}} + list [catch {testobjconfig alltypes .foo -color {}} msg] $msg [catch {.foo cget -color} result] $result [destroy .foo] +} {0 .foo 0 {} {}} +test config-4.22 {DoObjConfig - getting rid of old color} { + catch {destroy .foo} + testobjconfig alltypes .foo -color #333333 + list [catch {.foo configure -color #444444} msg] $msg [catch {.foo cget -color} result] $result [destroy .foo] +} {0 32 0 #444444 {}} +test config-4.23 {DoObjConfig - font} { + catch {rename .foo {}} + list [catch {testobjconfig alltypes .foo -font {Helvetica 72}} msg] $msg [catch {.foo cget -font} result] $result [destroy .foo] +} {0 .foo 0 {Helvetica 72} {}} +test config-4.24 {DoObjConfig - new font} { + catch {rename .foo {}} + testobjconfig alltypes .foo -font {Courier 12} + list [catch {.foo configure -font {Helvetica 72}} msg] $msg [catch {.foo cget -font} result] $result [destroy .foo] +} {0 64 0 {Helvetica 72} {}} +test config-4.25 {DoObjConfig - invalid font} { + catch {rename .foo {}} + list [catch {testobjconfig alltypes .foo -font {Helvetica 12 foo}} msg] $msg +} {1 {unknown font style "foo"}} +test config-4.26 {DoObjConfig - null font} { + catch {rename .foo {}} + list [catch {testobjconfig alltypes .foo -font {}} msg] $msg [catch {.foo cget -font} result] $result [destroy .foo] +} {0 .foo 0 {} {}} +test config-4.27 {DoObjConfig - font internal value} { + catch {rename .foo {}} + testobjconfig internal .foo -font {Times 16} + .foo cget -font +} {Times 16} +test config-4.28 {DoObjConfig - bitmap} { + catch {destroy .foo} + list [catch {testobjconfig alltypes .foo -bitmap gray75} msg] $msg [catch {.foo cget -bitmap} result] $result [destroy .foo] +} {0 .foo 0 gray75 {}} +test config-4.29 {DoObjConfig - new bitmap} { + catch {destroy .foo} + testobjconfig alltypes .foo -bitmap gray75 + list [catch {.foo configure -bitmap gray50} msg] $msg [catch {.foo cget -bitmap} result] $result [destroy .foo] +} {0 128 0 gray50 {}} +test config-4.30 {DoObjConfig - invalid bitmap} { + catch {destroy .foo} + list [catch {testobjconfig alltypes .foo -bitmap foo} msg] $msg +} {1 {bitmap "foo" not defined}} +test config-4.31 {DoObjConfig - null bitmap} { + catch {destroy .foo} + list [catch {testobjconfig alltypes .foo -bitmap {}} msg] $msg [catch {.foo cget -bitmap} result] $result [destroy .foo] +} {0 .foo 0 {} {}} +test config-4.32 {DoObjConfig - bitmap internal value} { + catch {rename .foo {}} + testobjconfig internal .foo -bitmap gray25 + .foo cget -bitmap +} {gray25} +test config-4.33 {DoObjConfig - border} { + catch {rename .foo {}} + list [catch {testobjconfig alltypes .foo -border green} msg] $msg [catch {.foo cget -border} result] $result [destroy .foo] +} {0 .foo 0 green {}} +test config-4.34 {DoObjConfig - invalid border} { + catch {destroy .foo} + list [catch {testobjconfig alltypes .foo -border xxx} msg] $msg +} {1 {unknown color name "xxx"}} +test config-4.35 {DoObjConfig - null border} { + catch {rename .foo {}} + list [catch {testobjconfig alltypes .foo -border {}} msg] $msg [catch {.foo cget -border} result] $result [destroy .foo] +} {0 .foo 0 {} {}} +test config-4.36 {DoObjConfig - border internal value} { + catch {rename .foo {}} + testobjconfig internal .foo -border #123456 + .foo cget -border +} {#123456} +test config-4.37 {DoObjConfig - getting rid of old border} { + catch {destroy .foo} + testobjconfig alltypes .foo -border #333333 + list [catch {.foo configure -border #444444} msg] $msg [catch {.foo cget -border} result] $result [destroy .foo] +} {0 256 0 #444444 {}} +test config-4.38 {DoObjConfig - relief} { + catch {destroy .foo} + list [catch {testobjconfig alltypes .foo -relief flat} msg] $msg [catch {.foo cget -relief} result] $result [destroy .foo] +} {0 .foo 0 flat {}} +test config-4.39 {DoObjConfig - invalid relief} { + catch {destroy .foo} + list [catch {testobjconfig alltypes .foo -relief foo} msg] $msg +} {1 {bad relief "foo": must be flat, groove, raised, ridge, solid, or sunken}} +test config-4.40 {DoObjConfig - new relief} { + catch {destroy .foo} + testobjconfig alltypes .foo -relief raised + list [catch {.foo configure -relief flat} msg] $msg [catch {.foo cget -relief} result] $result [destroy .foo] +} {0 512 0 flat {}} +test config-4.41 {DoObjConfig - relief internal value} { + catch {rename .foo {}} + testobjconfig internal .foo -relief ridge + .foo cget -relief +} {ridge} +test config-4.42 {DoObjConfig - cursor} { + catch {destroy .foo} + list [catch {testobjconfig alltypes .foo -cursor arrow} msg] $msg [catch {.foo cget -cursor} result] $result [destroy .foo] +} {0 .foo 0 arrow {}} +test config-4.43 {DoObjConfig - invalid cursor} { + catch {destroy .foo} + list [catch {testobjconfig alltypes .foo -cursor foo} msg] $msg +} {1 {bad cursor spec "foo"}} +test config-4.44 {DoObjConfig - null cursor} { + catch {destroy .foo} + list [catch {testobjconfig alltypes .foo -cursor {}} msg] $msg [catch {.foo cget -cursor} result] $result [destroy .foo] +} {0 .foo 0 {} {}} +test config-4.45 {DoObjConfig - new cursor} { + catch {destroy .foo} + testobjconfig alltypes .foo -cursor xterm + list [catch {.foo configure -cursor arrow} msg] $msg [catch {.foo cget -cursor} result] $result [destroy .foo] +} {0 1024 0 arrow {}} +test config-4.46 {DoObjConfig - cursor internal value} { + catch {rename .foo {}} + testobjconfig internal .foo -cursor watch + .foo cget -cursor +} {watch} +test config-4.47 {DoObjConfig - justify} { + catch {destroy .foo} + list [catch {testobjconfig alltypes .foo -justify center} msg] $msg [catch {.foo cget -justify} result] $result [destroy .foo] +} {0 .foo 0 center {}} +test config-4.48 {DoObjConfig - invalid justify} { + catch {destroy .foo} + list [catch {testobjconfig alltypes .foo -justify foo} msg] $msg +} {1 {bad justification "foo": must be left, right, or center}} +test config-4.49 {DoObjConfig - new justify} { + catch {destroy .foo} + testobjconfig alltypes .foo -justify left + list [catch {.foo configure -justify right} msg] $msg [catch {.foo cget -justify} result] $result [destroy .foo] +} {0 2048 0 right {}} +test config-4.50 {DoObjConfig - justify internal value} { + catch {rename .foo {}} + testobjconfig internal .foo -justify center + .foo cget -justify +} {center} +test config-4.51 {DoObjConfig - anchor} { + catch {destroy .foo} + list [catch {testobjconfig alltypes .foo -anchor center} msg] $msg [catch {.foo cget -anchor} result] $result [destroy .foo] +} {0 .foo 0 center {}} +test config-4.52 {DoObjConfig - invalid anchor} { + catch {destroy .foo} + list [catch {testobjconfig alltypes .foo -anchor foo} msg] $msg +} {1 {bad anchor "foo": must be n, ne, e, se, s, sw, w, nw, or center}} +test config-4.53 {DoObjConfig - new anchor} { + catch {destroy .foo} + testobjconfig alltypes .foo -anchor e + list [catch {.foo configure -anchor n} msg] $msg [catch {.foo cget -anchor} result] $result [destroy .foo] +} {0 4096 0 n {}} +test config-4.54 {DoObjConfig - anchor internal value} { + catch {rename .foo {}} + testobjconfig internal .foo -anchor sw + .foo cget -anchor +} {sw} +test config-4.55 {DoObjConfig - pixel} { + catch {destroy .foo} + list [catch {testobjconfig alltypes .foo -pixel 42} msg] $msg [catch {.foo cget -pixel} result] $result [destroy .foo] +} {0 .foo 0 42 {}} +test config-4.56 {DoObjConfig - invalid pixel} { + catch {destroy .foo} + list [catch {testobjconfig alltypes .foo -pixel foo} msg] $msg +} {1 {bad screen distance "foo"}} +test config-4.57 {DoObjConfig - new pixel} { + catch {destroy .foo} + testobjconfig alltypes .foo -pixel 42m + list [catch {.foo configure -pixel 3c} msg] $msg [catch {.foo cget -pixel} result] $result [destroy .foo] +} {0 8192 0 3c {}} +test config-4.58 {DoObjConfig - pixel internal value} { + catch {rename .foo {}} + testobjconfig internal .foo -pixel [winfo screenmmwidth .]m + .foo cget -pixel +} [winfo screenwidth .] +test config-4.59 {DoObjConfig - window} { + catch {destroy .foo} + catch {destroy .bar} + toplevel .bar + list [catch {testobjconfig twowindows .foo -window .bar} msg] $msg [catch {.foo cget -window} result] $result [destroy .foo] [destroy .bar] +} {0 .foo 0 .bar {} {}} +test config-4.60 {DoObjConfig - invalid window} { + catch {destroy .foo} + toplevel .bar + list [catch {testobjconfig twowindows .foo -window foo} msg] $msg [destroy .bar] +} {1 {bad window path name "foo"} {}} +test config-4.61 {DoObjConfig - null window} { + catch {destroy .foo} + catch {destroy .bar} + toplevel .bar + list [catch {testobjconfig twowindows .foo -window {}} msg] $msg [catch {.foo cget -window} result] $result [destroy .foo] +} {0 .foo 0 {} {}} +test config-4.62 {DoObjConfig - new window} { + catch {destroy .foo} + catch {destroy .bar} + catch {destroy .blamph} + toplevel .bar + toplevel .blamph + testobjconfig twowindows .foo -window .bar + list [catch {.foo configure -window .blamph} msg] $msg [catch {.foo cget -window} result] $result [destroy .foo] [destroy .bar] [destroy .blamph] +} {0 0 0 .blamph {} {} {}} +test config-4.63 {DoObjConfig - window internal value} { + catch {rename .foo {}} + testobjconfig internal .foo -window . + .foo cget -window +} {.} +test config-4.64 {DoObjConfig - releasing old values} { + # This test doesn't generate a useful value to check; if an + # error occurs, it will be detected only by memory checking software + # such as Purify or Tcl's built-in checker. + + catch {rename .foo {}} + testobjconfig alltypes .foo -string {Test string} -color yellow \ + -font {Courier 18} -bitmap questhead -border green -cursor cross + .foo configure -string {new string} -color brown \ + -font {Times 8} -bitmap gray75 -border pink -cursor watch + concat {} +} {} +test config-4.65 {DoObjConfig - releasing old values} { + # This test doesn't generate a useful value to check; if an + # error occurs, it will be detected only by memory checking software + # such as Purify or Tcl's built-in checker. + + catch {rename .foo {}} + testobjconfig internal .foo -string {Test string} -color yellow \ + -font {Courier 18} -bitmap questhead -border green -cursor cross + .foo configure -string {new string} -color brown \ + -font {Times 8} -bitmap gray75 -border pink -cursor watch + concat {} +} {} + +test config-5.1 {ObjectIsEmpty - object is already string} { + catch {destroy .foo} + testobjconfig alltypes .foo -color [format ""] + .foo cget -color +} {} +test config-5.2 {ObjectIsEmpty - object is already string} { + catch {destroy .foo} + list [catch {testobjconfig alltypes .foo -color [format " "]} msg] $msg +} {1 {unknown color name " "}} +test config-5.3 {ObjectIsEmpty - must convert back to string} { + catch {destroy .foo} + testobjconfig alltypes .foo -color [list] + .foo cget -color +} {} + +eval destroy [winfo children .] +testobjconfig chain2 .a +testobjconfig alltypes .b +test config-6.1 {GetOptionFromObj - cached answer} { + list [.a cget -three] [.a cget -three] +} {three three} +test config-6.2 {GetOptionFromObj - exact match} { + .a cget -one +} {one} +test config-6.3 {GetOptionFromObj - abbreviation} { + .a cget -fo +} {four} +test config-6.4 {GetOptionFromObj - ambiguous abbreviation} { + list [catch {.a cget -on} msg] $msg +} {1 {unknown option "-on"}} +test config-6.5 {GetOptionFromObj - duplicate options in different tables} { + .a cget -tw +} {two and a half} +test config-6.6 {GetOptionFromObj - synonym} { + .b cget -synonym +} {red} + +eval destroy [winfo children .] +testobjconfig alltypes .a +test config-7.1 {Tk_SetOptions - basics} { + .a configure -color green -rel sunken + list [.a cget -color] [.a cget -relief] +} {green sunken} +test config-7.2 {Tk_SetOptions - bogus option name} { + list [catch {.a configure -bogus} msg] $msg +} {1 {unknown option "-bogus"}} +test config-7.3 {Tk_SetOptions - synonym} { + .a configure -synonym blue + .a cget -color +} {blue} +test config-7.4 {Tk_SetOptions - missing value} { + list [catch {.a configure -color green -relief} msg] $msg [.a cget -color] +} {1 {value for "-relief" missing} green} +test config-7.5 {Tk_SetOptions - saving old values} { + .a configure -color red -int 7 -relief raised -double 3.14159 + list [catch {.a csave -color green -int 432 -relief sunken \ + -double 2.0 -color bogus} msg] $msg [.a cget -color] \ + [.a cget -int] [.a cget -relief] [.a cget -double] +} {1 {unknown color name "bogus"} red 7 raised 3.14159} +test config-7.6 {Tk_SetOptions - error in DoObjConfig call} { + list [catch {.a configure -color bogus} msg] $msg $errorInfo +} {1 {unknown color name "bogus"} {unknown color name "bogus" + (processing "-color" option) + invoked from within +".a configure -color bogus"}} +test config-7.7 {Tk_SetOptions - synonym name in error message} { + list [catch {.a configure -synonym bogus} msg] $msg $errorInfo +} {1 {unknown color name "bogus"} {unknown color name "bogus" + (processing "-synonym" option) + invoked from within +".a configure -synonym bogus"}} +test config-7.8 {Tk_SetOptions - returning mask} { + format %x [.a configure -color red -int 7 -relief raised -double 3.14159] +} {226} + +test config-8.1 {Tk_RestoreSavedOptions - restore in proper order} { + eval destroy [winfo children .] + testobjconfig alltypes .a + list [catch {.a csave -color green -color black -color blue \ + -color #ffff00 -color #ff00ff -color bogus} msg] $msg \ + [.a cget -color] +} {1 {unknown color name "bogus"} red} +test config-8.2 {Tk_RestoreSavedOptions - freeing object memory} { + eval destroy [winfo children .] + testobjconfig alltypes .a + .a csave -color green -color black -color blue -color #ffff00 \ + -color #ff00ff +} {32} +test config-8.3 {Tk_RestoreSavedOptions - boolean internal form} { + eval destroy [winfo children .] + testobjconfig internal .a + list [catch {.a csave -boolean 0 -color bogus}] [.a cget -boolean] +} {1 1} +test config-8.4 {Tk_RestoreSavedOptions - integer internal form} { + eval destroy [winfo children .] + testobjconfig internal .a + list [catch {.a csave -integer 24 -color bogus}] [.a cget -integer] +} {1 148962237} +test config-8.5 {Tk_RestoreSavedOptions - double internal form} { + eval destroy [winfo children .] + testobjconfig internal .a + list [catch {.a csave -double 62.4 -color bogus}] [.a cget -double] +} {1 3.14159} +test config-8.6 {Tk_RestoreSavedOptions - string internal form} { + eval destroy [winfo children .] + testobjconfig internal .a + list [catch {.a csave -string "A long string" -color bogus}] \ + [.a cget -string] +} {1 foo} +test config-8.7 {Tk_RestoreSavedOptions - string table internal form} { + eval destroy [winfo children .] + testobjconfig internal .a + list [catch {.a csave -stringtable three -color bogus}] \ + [.a cget -stringtable] +} {1 one} +test config-8.8 {Tk_RestoreSavedOptions - color internal form} { + eval destroy [winfo children .] + testobjconfig internal .a + list [catch {.a csave -color green -color bogus}] [.a cget -color] +} {1 red} +test config-8.9 {Tk_RestoreSavedOptions - font internal form} { + eval destroy [winfo children .] + testobjconfig internal .a + list [catch {.a csave -font {Times 12} -color bogus}] [.a cget -font] +} {1 {Helvetica 12}} +test config-8.10 {Tk_RestoreSavedOptions - bitmap internal form} { + eval destroy [winfo children .] + testobjconfig internal .a + list [catch {.a csave -bitmap questhead -color bogus}] [.a cget -bitmap] +} {1 gray50} +test config-8.11 {Tk_RestoreSavedOptions - border internal form} { + eval destroy [winfo children .] + testobjconfig internal .a + list [catch {.a csave -border brown -color bogus}] [.a cget -border] +} {1 blue} +test config-8.12 {Tk_RestoreSavedOptions - relief internal form} { + eval destroy [winfo children .] + testobjconfig internal .a + list [catch {.a csave -relief sunken -color bogus}] [.a cget -relief] +} {1 raised} +test config-8.13 {Tk_RestoreSavedOptions - cursor internal form} { + eval destroy [winfo children .] + testobjconfig internal .a + list [catch {.a csave -cursor watch -color bogus}] [.a cget -cursor] +} {1 xterm} +test config-8.14 {Tk_RestoreSavedOptions - justify internal form} { + eval destroy [winfo children .] + testobjconfig internal .a + list [catch {.a csave -justify right -color bogus}] [.a cget -justify] +} {1 left} +test config-8.15 {Tk_RestoreSavedOptions - anchor internal form} { + eval destroy [winfo children .] + testobjconfig internal .a + list [catch {.a csave -anchor center -color bogus}] [.a cget -anchor] +} {1 n} +test config-8.16 {Tk_RestoreSavedOptions - window internal form} { + eval destroy [winfo children .] + testobjconfig internal .a -window .a + list [catch {.a csave -window .a -color bogus}] [.a cget -window] +} {1 .a} + +# Most of the tests below will cause memory leakage if there is a +# problem. This may not be evident unless the tests are run in +# conjunction with a memory usage analyzer such as Purify. + +test config-9.1 {Tk_FreeConfigOptions/FreeResources - string internal form} { + catch {destroy .foo} + testobjconfig internal .foo + .foo configure -string "two words" + destroy .foo +} {} +test config-9.2 {Tk_FreeConfigOptions/FreeResources - color internal form} { + catch {destroy .foo} + testobjconfig internal .foo + .foo configure -color yellow + destroy .foo +} {} +test config-9.3 {Tk_FreeConfigOptions/FreeResources - color} { + catch {destroy .foo} + testobjconfig alltypes .foo + .foo configure -color [format blue] + destroy .foo +} {} +test config-9.4 {Tk_FreeConfigOptions/FreeResources - font internal form} { + catch {destroy .foo} + testobjconfig internal .foo + .foo configure -font {Courier 20} + destroy .foo +} {} +test config-9.5 {Tk_FreeConfigOptions/FreeResources - font} { + catch {destroy .foo} + testobjconfig alltypes .foo + .foo configure -font [format {Courier 24}] + destroy .foo +} {} +test config-9.6 {Tk_FreeConfigOptions/FreeResources - bitmap internal form} { + catch {destroy .foo} + testobjconfig internal .foo + .foo configure -bitmap gray75 + destroy .foo +} {} +test config-9.7 {Tk_FreeConfigOptions/FreeResources - bitmap} { + catch {destroy .foo} + testobjconfig alltypes .foo + .foo configure -bitmap [format gray75] + destroy .foo +} {} +test config-9.8 {Tk_FreeConfigOptions/FreeResources - border internal form} { + catch {destroy .foo} + testobjconfig internal .foo + .foo configure -border orange + destroy .foo +} {} +test config-9.9 {Tk_FreeConfigOptions/FreeResources - border} { + catch {destroy .foo} + testobjconfig alltypes .foo + .foo configure -border [format blue] + destroy .foo +} {} +test config-9.10 {Tk_FreeConfigOptions/FreeResources - cursor internal form} { + catch {destroy .foo} + testobjconfig internal .foo + .foo configure -cursor cross + destroy .foo +} {} +test config-9.11 {Tk_FreeConfigOptions/FreeResources - cursor} { + catch {destroy .foo} + testobjconfig alltypes .foo + .foo configure -cursor [format watch] + destroy .foo +} {} +test config-9.12 {Tk_FreeConfigOptions/FreeResources - not special} { + catch {destroy .foo} + testobjconfig alltypes .foo + .foo configure -integer [format 27] + destroy .foo +} {} + +test config-10.1 {Tk_GetOptionInfo - one item} { + catch {destroy .foo} + testobjconfig alltypes .foo + .foo configure -relief groove + .foo configure -relief +} {-relief relief Relief raised groove} +test config-10.2 {Tk_GetOptionInfo - one item, synonym} { + catch {destroy .foo} + testobjconfig alltypes .foo + .foo configure -color black + .foo configure -synonym +} {-color color Color red black} +test config-10.3 {Tk_GetOptionInfo - all items} { + catch {destroy .foo} + testobjconfig alltypes .foo -font {Helvetica 18} -integer 13563 + .foo configure +} {{-boolean boolean Boolean 1 1} {-integer integer Integer 7 13563} {-double double Double 3.14159 3.14159} {-string string String foo foo} {-stringtable StringTable stringTable one one} {-color color Color red red} {-font font Font {Helvetica 12} {Helvetica 18}} {-bitmap bitmap Bitmap gray50 gray50} {-border border Border blue blue} {-relief relief Relief raised raised} {-cursor cursor Cursor xterm xterm} {-justify {} {} left left} {-anchor anchor Anchor {} {}} {-pixel pixel Pixel 1 1} {-synonym -color}} +test config-10.4 {Tk_GetOptionInfo - chaining through tables} { + catch {destroy .foo} + testobjconfig chain2 .foo -one asdf -three xyzzy + .foo configure +} {{-three three Three three xyzzy} {-four four Four four four} {-two two Two {two and a half} {two and a half}} {-oneAgain oneAgain OneAgain {one again} {one again}} {-one one One one asdf} {-two two Two two {two and a half}}} + +eval destroy [winfo children .] +testobjconfig alltypes .a +test config-11.1 {GetConfigList - synonym} { + lindex [.a configure] end +} {-synonym -color} +test config-11.2 {GetConfigList - null database names} { + .a configure -justify +} {-justify {} {} left left} +test config-11.3 {GetConfigList - null default and current value} { + .a configure -anchor +} {-anchor anchor Anchor {} {}} + +eval destroy [winfo children .] +testobjconfig internal .a +test config-12.1 {GetObjectForOption - boolean} { + .a configure -boolean 0 + .a cget -boolean +} {0} +test config-12.2 {GetObjectForOption - integer} { + .a configure -integer 1247 + .a cget -integer +} {1247} +test config-12.3 {GetObjectForOption - double} { + .a configure -double -88.82 + .a cget -double +} {-88.82} +test config-12.4 {GetObjectForOption - string} { + .a configure -string "test value" + .a cget -string +} {test value} +test config-12.5 {GetObjectForOption - stringTable} { + .a configure -stringtable "two" + .a cget -stringtable +} {two} +test config-12.6 {GetObjectForOption - color} { + .a configure -color "green" + .a cget -color +} {green} +test config-12.7 {GetObjectForOption - font} { + .a configure -font {Times 36} + .a cget -font +} {Times 36} +test config-12.8 {GetObjectForOption - bitmap} { + .a configure -bitmap "questhead" + .a cget -bitmap +} {questhead} +test config-12.9 {GetObjectForOption - border} { + .a configure -border #33217c + .a cget -border +} {#33217c} +test config-12.10 {GetObjectForOption - relief} { + .a configure -relief groove + .a cget -relief +} {groove} +test config-12.11 {GetObjectForOption - cursor} { + .a configure -cursor watch + .a cget -cursor +} {watch} +test config-12.12 {GetObjectForOption - justify} { + .a configure -justify right + .a cget -justify +} {right} +test config-12.13 {GetObjectForOption - anchor} { + .a configure -anchor e + .a cget -anchor +} {e} +test config-12.14 {GetObjectForOption - pixels} { + .a configure -pixel 193.2 + .a cget -pixel +} {193} +test config-12.15 {GetObjectForOption - window} { + .a configure -window .a + .a cget -window +} {.a} +test config-12.16 {GetObjectForOption - null values} { + .a configure -string {} -color {} -font {} -bitmap {} -border {} \ + -cursor {} -window {} + list [.a cget -string] [.a cget -color] [.a cget -font] \ + [.a cget -string] [.a cget -bitmap] [.a cget -border] \ + [.a cget -cursor] [.a cget -window] +} {{} {} {} {} {} {} {} {}} + +eval destroy [winfo children .] +killTables diff --git a/tests/cursor.test b/tests/cursor.test new file mode 100644 index 0000000..21259be --- /dev/null +++ b/tests/cursor.test @@ -0,0 +1,99 @@ +# 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. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) cursor.test 1.1 97/12/24 15:17:35 + +if {[info procs test] != "test"} { + source defs +} + +if {[info commands testcursor] != "testcursor"} { + puts "testcursor command not available; skipping tests" + return +} + +eval destroy [winfo children .] +wm geometry . {} +raise . + +test cursor-1.1 {Tk_AllocCursorFromObj - converting internal reps} { + set x watch + lindex $x 0 + destroy .b1 + button .b1 -cursor $x + lindex $x 0 + testcursor watch +} {{1 0}} +test cursor-1.2 {Tk_AllocCursorFromObj - discard stale cursor} { + set x watch + destroy .b1 .b2 + button .b1 -cursor $x + destroy .b1 + set result {} + lappend result [testcursor watch] + button .b2 -cursor $x + lappend result [testcursor watch] +} {{} {{1 1}}} +test cursor-1.3 {Tk_AllocCursorFromObj - reuse existing cursor} { + set x watch + destroy .b1 .b2 + button .b1 -cursor $x + set result {} + lappend result [testcursor watch] + button .b2 -cursor $x + pack .b1 .b2 -side top + lappend result [testcursor watch] +} {{1 1}} {{2 1}} + +test cursor-2.1 {Tk_GetCursor procedure} { + destroy .b1 + list [catch {button .b1 -cursor bad_name} msg] $msg +} {1 {bad cursor spec "bad_name"}} +test cursor-2.2 {Tk_GetCursor procedure} { + destroy .b1 + list [catch {button .b1 -cursor @xyzzy} msg] $msg +} {1 {bad cursor spec "@xyzzy"}} + +test cursor-3.1 {Tk_FreeCursorFromObj - reference counts} { + set x arrow + destroy .b1 .b2 .b3 + button .b1 -cursor $x + button .b3 -cursor $x + button .b2 -cursor $x + set result {} + lappend result [testcursor arrow] + destroy .b1 + lappend result [testcursor arrow] + destroy .b2 + lappend result [testcursor arrow] + destroy .b3 + lappend result [testcursor arrow] +} {{{3 1}} {{2 1}} {{1 1}} {}} + +test cursor-4.1 {FreeCursorObjProc} { + destroy .b + set x [format arrow] + button .b -cursor $x + set y [format arrow] + .b configure -cursor $y + set z [format arrow] + .b configure -cursor $z + set result {} + lappend result [testcursor arrow] + set x red + lappend result [testcursor arrow] + set z 32 + lappend result [testcursor arrow] + destroy .b + lappend result [testcursor arrow] + set y bogus + set result +} {{{1 3}} {{1 2}} {{1 1}} {}} + +destroy .t @@ -8,7 +8,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) defs 1.39 97/08/06 15:32:02 +# SCCS: @(#) defs 1.43 98/01/13 17:21:10 if ![info exists VERBOSE] { set VERBOSE 0 @@ -41,6 +41,10 @@ wm title . tktest # where the configuration is well known. The presence # of the file "doAllTests" in this directory indicates # that it is safe to run non-portable tests. +# knownBug - The test is known to fail and the bug is not yet +# fixed. The test will be run only if the file +# "doBuggyTests" exists (intended for Tcl dev. group +# internal use only). # fonts - 1 means that this platform uses fonts with # well-know geometries, so it is safe to run # tests that depend on particular font sizes. @@ -60,6 +64,7 @@ set testConfig(macOrPc) [expr $testConfig(macOnly) || $testConfig(pcOnly)] set testConfig(macOrUnix) [expr $testConfig(macOnly) || $testConfig(unixOnly)] set testConfig(nonPortable) [expr [file exists doAllTests] || [file exists DOALLT~1]] +set testConfig(knownBug) [expr [file exists doBuggyTests] || [file exists doBuggyT]] set testConfig(nt) [expr {$tcl_platform(os) == "Windows NT"}] set testConfig(95) [expr {$tcl_platform(os) == "Windows 95"}] @@ -88,7 +93,8 @@ entry .e -width 0 -font {Helvetica -12} -bd 1 if {([winfo reqwidth .e] != 37) || ([winfo reqheight .e] != 20)} { set testConfig(fonts) 0 } -destroy .e .t +destroy .e +catch {destroy .t} text .t -width 80 -height 20 -font {Times -14} -bd 1 pack .t .t insert end "This is\na dot." @@ -365,3 +371,21 @@ proc makeFile {contents name} { proc removeFile {name} { file delete -- $name } + +# +# Construct a string that consists of the requested sequence of bytes, +# as opposed to a string of properly formed UTF-8 characters. +# This allows the tester to +# 1. Create denormalized or improperly formed strings to pass to C procedures +# that are supposed to accept strings with embedded NULL bytes. +# 2. Confirm that a string result has a certain pattern of bytes, for instance +# to confirm that "\xe0\0" in a Tcl script is stored internally in +# UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80". +# +# Generally, it's a bad idea to examine the bytes in a Tcl string or to +# construct improperly formed strings in this manner, because it involves +# exposing that Tcl uses UTF-8 internally. + +proc bytestring {string} { + testencoding toutf $string identity +} diff --git a/tests/entry.test b/tests/entry.test index 950d278..6250bbb 100644 --- a/tests/entry.test +++ b/tests/entry.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) entry.test 1.49 97/11/07 09:34:31 +# SCCS: @(#) entry.test 1.51 98/01/21 00:22:38 if {[lsearch [image types] test] < 0} { puts "This application hasn't been compiled with the \"test\"" @@ -51,6 +51,7 @@ option add *Entry.font {Helvetica -12} entry .e -bd 2 -relief sunken pack .e update + set i 1 foreach test { {-background #ff0000 #ff0000 non-existent @@ -86,13 +87,13 @@ foreach test { {-xscrollcommand {Some command} {Some command} {} {}} } { set name [lindex $test 0] - test entry-1.1 {configuration options} { + test entry-1.$i {configuration options} { .e configure $name [lindex $test 1] list [lindex [.e configure $name] 4] [.e cget $name] } [list [lindex $test 2] [lindex $test 2]] incr i if {[lindex $test 3] != ""} { - test entry-1.2 {configuration options} { + test entry-1.$i {configuration options} { list [catch {.e configure $name [lindex $test 3]} msg] $msg } [list 1 [lindex $test 4]] } @@ -128,6 +129,7 @@ update set cx [font measure $fixed a] set cy [font metrics $fixed -linespace] +set ux [font measure $fixed \u4e4e] test entry-3.1 {EntryWidgetCmd procedure} { list [catch {.e} msg] $msg @@ -145,66 +147,106 @@ test entry-3.5 {EntryWidgetCmd procedure, "bbox" widget command} { .e delete 0 end .e bbox 0 } [list 5 5 0 $cy] -test entry-3.6 {EntryWidgetCmd procedure, "bbox" widget command} {fonts} { +test entry-3.6 {EntryWidgetCmd procedure, "bbox" widget command} { + # Tcl_UtfAtIndex(): no utf chars + + .e delete 0 end + .e insert 0 "abc" + list [.e bbox 3] [.e bbox end] +} [list "[expr 5+2*$cx] 5 $cx $cy" "[expr 5+2*$cx] 5 $cx $cy"] +test entry-3.7 {EntryWidgetCmd procedure, "bbox" widget command} { + # Tcl_UtfAtIndex(): utf at end + .e delete 0 end + .e insert 0 "ab\u4e4e" + .e bbox end +} "[expr 5+2*$cx] 5 $ux $cy" +test entry-3.8 {EntryWidgetCmd procedure, "bbox" widget command} { + # Tcl_UtfAtIndex(): utf before index + .e delete 0 end + .e insert 0 "ab\u4e4ec" + .e bbox 3 +} "[expr 5+2*$cx+$ux] 5 $cx $cy" +test entry-3.9 {EntryWidgetCmd procedure, "bbox" widget command} { + # Tcl_UtfAtIndex(): no chars .e delete 0 end - .e insert 0 "abcdefghijklmnop" - list [.e bbox 0] [.e bbox 1] [.e bbox end] -} [list "5 5 $cx $cy" "[expr 5+$cx] 5 $cx $cy" "[expr 5+15*$cx] 5 $cx $cy"] -test entry-3.7 {EntryWidgetCmd procedure, "cget" widget command} { + .e bbox end +} "5 5 0 $cy" +test entry-3.10 {EntryWidgetCmd procedure, "bbox" widget command} { + .e delete 0 end + .e insert 0 "abcdefghij\u4e4eklmnop" + list [.e bbox 0] [.e bbox 1] [.e bbox 10] [.e bbox end] +} [list "5 5 $cx $cy" "[expr 5+$cx] 5 $cx $cy" "[expr 5+10*$cx] 5 $ux $cy" "[expr 5+$ux+15*$cx] 5 $cx $cy"] +test entry-3.11 {EntryWidgetCmd procedure, "cget" widget command} { list [catch {.e cget} msg] $msg } {1 {wrong # args: should be ".e cget option"}} -test entry-3.8 {EntryWidgetCmd procedure, "cget" widget command} { +test entry-3.12 {EntryWidgetCmd procedure, "cget" widget command} { list [catch {.e cget a b} msg] $msg } {1 {wrong # args: should be ".e cget option"}} -test entry-3.9 {EntryWidgetCmd procedure, "cget" widget command} { +test entry-3.13 {EntryWidgetCmd procedure, "cget" widget command} { list [catch {.e cget -gorp} msg] $msg } {1 {unknown option "-gorp"}} -test entry-3.10 {EntryWidgetCmd procedure, "cget" widget command} { +test entry-3.14 {EntryWidgetCmd procedure, "cget" widget command} { .e configure -bd 4 .e cget -bd } {4} -test entry-3.11 {EntryWidgetCmd procedure, "configure" widget command} { +test entry-3.15 {EntryWidgetCmd procedure, "configure" widget command} { llength [.e configure] } {28} -test entry-3.12 {EntryWidgetCmd procedure, "configure" widget command} { +test entry-3.16 {EntryWidgetCmd procedure, "configure" widget command} { list [catch {.e configure -foo} msg] $msg } {1 {unknown option "-foo"}} -test entry-3.13 {EntryWidgetCmd procedure, "configure" widget command} { +test entry-3.17 {EntryWidgetCmd procedure, "configure" widget command} { .e configure -bd 4 .e configure -bg #ffffff lindex [.e configure -bd] 4 } {4} -test entry-3.14 {EntryWidgetCmd procedure, "delete" widget command} { +test entry-3.18 {EntryWidgetCmd procedure, "delete" widget command} { list [catch {.e delete} msg] $msg } {1 {wrong # args: should be ".e delete firstIndex ?lastIndex?"}} -test entry-3.15 {EntryWidgetCmd procedure, "delete" widget command} { +test entry-3.19 {EntryWidgetCmd procedure, "delete" widget command} { list [catch {.e delete a b c} msg] $msg } {1 {wrong # args: should be ".e delete firstIndex ?lastIndex?"}} -test entry-3.16 {EntryWidgetCmd procedure, "delete" widget command} { +test entry-3.20 {EntryWidgetCmd procedure, "delete" widget command} { list [catch {.e delete foo} msg] $msg } {1 {bad entry index "foo"}} -test entry-3.17 {EntryWidgetCmd procedure, "delete" widget command} { +test entry-3.21 {EntryWidgetCmd procedure, "delete" widget command} { list [catch {.e delete 0 bar} msg] $msg } {1 {bad entry index "bar"}} -test entry-3.18 {EntryWidgetCmd procedure, "delete" widget command} { +test entry-3.22 {EntryWidgetCmd procedure, "delete" widget command} { .e delete 0 end .e insert end "01234567890" .e delete 2 4 .e get } {014567890} -test entry-3.19 {EntryWidgetCmd procedure, "delete" widget command} { +test entry-3.23 {EntryWidgetCmd procedure, "delete" widget command} { .e delete 0 end .e insert end "01234567890" .e delete 6 .e get } {0123457890} -test entry-3.20 {EntryWidgetCmd procedure, "delete" widget command} { +test entry-3.24 {EntryWidgetCmd procedure, "delete" widget command} { + # UTF + set x {} + .e delete 0 end + .e insert end "01234\u4e4e67890" + .e delete 6 + lappend x [.e get] + .e delete 0 end + .e insert end "012345\u4e4e7890" + .e delete 6 + lappend x [.e get] + .e delete 0 end + .e insert end "0123456\u4e4e890" + .e delete 6 + lappend x [.e get] +} [list "01234\u4e4e7890" "0123457890" "012345\u4e4e890"] +test entry-3.25 {EntryWidgetCmd procedure, "delete" widget command} { .e delete 0 end .e insert end "01234567890" .e delete 6 5 .e get } {01234567890} -test entry-3.21 {EntryWidgetCmd procedure, "delete" widget command} { +test entry-3.26 {EntryWidgetCmd procedure, "delete" widget command} { .e delete 0 end .e insert end "01234567890" .e configure -state disabled @@ -212,49 +254,55 @@ test entry-3.21 {EntryWidgetCmd procedure, "delete" widget command} { .e configure -state normal .e get } {01234567890} -test entry-3.22 {EntryWidgetCmd procedure, "get" widget command} { +test entry-3.27 {EntryWidgetCmd procedure, "get" widget command} { list [catch {.e get foo} msg] $msg } {1 {wrong # args: should be ".e get"}} -test entry-3.23 {EntryWidgetCmd procedure, "icursor" widget command} { +test entry-3.28 {EntryWidgetCmd procedure, "icursor" widget command} { list [catch {.e icursor} msg] $msg } {1 {wrong # args: should be ".e icursor pos"}} -test entry-3.24 {EntryWidgetCmd procedure, "icursor" widget command} { +test entry-3.29 {EntryWidgetCmd procedure, "icursor" widget command} { list [catch {.e icursor foo} msg] $msg } {1 {bad entry index "foo"}} -test entry-3.25 {EntryWidgetCmd procedure, "icursor" widget command} { +test entry-3.30 {EntryWidgetCmd procedure, "icursor" widget command} { .e delete 0 end .e insert end "01234567890" .e icursor 4 .e index insert } {4} -test entry-3.26 {EntryWidgetCmd procedure, "index" widget command} { +test entry-3.31 {EntryWidgetCmd procedure, "index" widget command} { list [catch {.e in} msg] $msg } {1 {bad option "in": must be bbox, cget, configure, delete, get, icursor, index, insert, scan, selection, or xview}} -test entry-3.27 {EntryWidgetCmd procedure, "index" widget command} { +test entry-3.32 {EntryWidgetCmd procedure, "index" widget command} { list [catch {.e index} msg] $msg } {1 {wrong # args: should be ".e index string"}} -test entry-3.28 {EntryWidgetCmd procedure, "index" widget command} { +test entry-3.33 {EntryWidgetCmd procedure, "index" widget command} { list [catch {.e index foo} msg] $msg } {1 {bad entry index "foo"}} -test entry-3.29 {EntryWidgetCmd procedure, "index" widget command} { +test entry-3.34 {EntryWidgetCmd procedure, "index" widget command} { list [catch {.e index 0} msg] $msg } {0 0} -test entry-3.30 {EntryWidgetCmd procedure, "insert" widget command} { +test entry-3.35 {EntryWidgetCmd procedure, "index" widget command} { + # UTF + .e delete 0 end + .e insert 0 abc\u4e4e\u0153def + list [.e index 3] [.e index 4] [.e index end] +} {3 4 8} +test entry-3.36 {EntryWidgetCmd procedure, "insert" widget command} { list [catch {.e insert a} msg] $msg } {1 {wrong # args: should be ".e insert index text"}} -test entry-3.31 {EntryWidgetCmd procedure, "insert" widget command} { +test entry-3.37 {EntryWidgetCmd procedure, "insert" widget command} { list [catch {.e insert a b c} msg] $msg } {1 {wrong # args: should be ".e insert index text"}} -test entry-3.32 {EntryWidgetCmd procedure, "insert" widget command} { +test entry-3.38 {EntryWidgetCmd procedure, "insert" widget command} { list [catch {.e insert foo Text} msg] $msg } {1 {bad entry index "foo"}} -test entry-3.33 {EntryWidgetCmd procedure, "insert" widget command} { +test entry-3.39 {EntryWidgetCmd procedure, "insert" widget command} { .e delete 0 end .e insert end "01234567890" .e insert 3 xxx .e get } {012xxx34567890} -test entry-3.34 {EntryWidgetCmd procedure, "insert" widget command} { +test entry-3.40 {EntryWidgetCmd procedure, "insert" widget command} { .e delete 0 end .e insert end "01234567890" .e configure -state disabled @@ -262,24 +310,24 @@ test entry-3.34 {EntryWidgetCmd procedure, "insert" widget command} { .e configure -state normal .e get } {01234567890} -test entry-3.35 {EntryWidgetCmd procedure, "insert" widget command} { +test entry-3.41 {EntryWidgetCmd procedure, "insert" widget command} { list [catch {.e insert a b c} msg] $msg } {1 {wrong # args: should be ".e insert index text"}} -test entry-3.36 {EntryWidgetCmd procedure, "scan" widget command} { +test entry-3.42 {EntryWidgetCmd procedure, "scan" widget command} { list [catch {.e scan a} msg] $msg } {1 {wrong # args: should be ".e scan mark|dragto x"}} -test entry-3.37 {EntryWidgetCmd procedure, "scan" widget command} { +test entry-3.43 {EntryWidgetCmd procedure, "scan" widget command} { list [catch {.e scan a b c} msg] $msg } {1 {wrong # args: should be ".e scan mark|dragto x"}} -test entry-3.38 {EntryWidgetCmd procedure, "scan" widget command} { +test entry-3.44 {EntryWidgetCmd procedure, "scan" widget command} { list [catch {.e scan foobar 20} msg] $msg } {1 {bad scan option "foobar": must be mark or dragto}} -test entry-3.39 {EntryWidgetCmd procedure, "scan" widget command} { +test entry-3.45 {EntryWidgetCmd procedure, "scan" widget command} { list [catch {.e scan mark 20.1} msg] $msg } {1 {expected integer but got "20.1"}} # This test is non-portable because character sizes vary. -test entry-3.40 {EntryWidgetCmd procedure, "scan" widget command} {fonts} { +test entry-3.46 {EntryWidgetCmd procedure, "scan" widget command} {fonts} { .e delete 0 end update .e insert end "This is quite a long string, in fact a " @@ -288,16 +336,16 @@ test entry-3.40 {EntryWidgetCmd procedure, "scan" widget command} {fonts} { .e scan dragto 28 .e index @0 } {2} -test entry-3.41 {EntryWidgetCmd procedure, "select" widget command} { +test entry-3.47 {EntryWidgetCmd procedure, "select" widget command} { list [catch {.e select} msg] $msg } {1 {wrong # args: should be ".e select option ?index?"}} -test entry-3.42 {EntryWidgetCmd procedure, "select" widget command} { +test entry-3.48 {EntryWidgetCmd procedure, "select" widget command} { list [catch {.e select foo} msg] $msg } {1 {bad selection option "foo": must be adjust, clear, from, present, range, or to}} -test entry-3.43 {EntryWidgetCmd procedure, "select clear" widget command} { +test entry-3.49 {EntryWidgetCmd procedure, "select clear" widget command} { list [catch {.e select clear gorp} msg] $msg } {1 {wrong # args: should be ".e selection clear"}} -test entry-3.44 {EntryWidgetCmd procedure, "select clear" widget command} { +test entry-3.50 {EntryWidgetCmd procedure, "select clear" widget command} { .e delete 0 end .e insert end "0123456789" .e select from 1 @@ -306,17 +354,17 @@ test entry-3.44 {EntryWidgetCmd procedure, "select clear" widget command} { .e select clear list [catch {selection get} msg] $msg [selection own] } {1 {PRIMARY selection doesn't exist or form "STRING" not defined} .e} -test entry-3.45 {EntryWidgetCmd procedure, "selection present" widget command} { +test entry-3.51 {EntryWidgetCmd procedure, "selection present" widget command} { list [catch {.e selection present foo} msg] $msg } {1 {wrong # args: should be ".e selection present"}} -test entry-3.46 {EntryWidgetCmd procedure, "selection present" widget command} { +test entry-3.52 {EntryWidgetCmd procedure, "selection present" widget command} { .e delete 0 end .e insert end 0123456789 .e select from 3 .e select to 6 .e selection present } {1} -test entry-3.47 {EntryWidgetCmd procedure, "selection present" widget command} { +test entry-3.53 {EntryWidgetCmd procedure, "selection present" widget command} { .e delete 0 end .e insert end 0123456789 .e select from 3 @@ -325,7 +373,7 @@ test entry-3.47 {EntryWidgetCmd procedure, "selection present" widget command} { .e selection present } {1} .e configure -exportselection true -test entry-3.48 {EntryWidgetCmd procedure, "selection present" widget command} { +test entry-3.54 {EntryWidgetCmd procedure, "selection present" widget command} { .e delete 0 end .e insert end 0123456789 .e select from 3 @@ -333,13 +381,13 @@ test entry-3.48 {EntryWidgetCmd procedure, "selection present" widget command} { .e delete 0 end .e selection present } {0} -test entry-3.49 {EntryWidgetCmd procedure, "selection adjust" widget command} { +test entry-3.55 {EntryWidgetCmd procedure, "selection adjust" widget command} { list [catch {.e select adjust x} msg] $msg } {1 {bad entry index "x"}} -test entry-3.50 {EntryWidgetCmd procedure, "selection adjust" widget command} { +test entry-3.56 {EntryWidgetCmd procedure, "selection adjust" widget command} { list [catch {.e select adjust 2 3} msg] $msg } {1 {wrong # args: should be ".e selection adjust index"}} -test entry-3.51 {EntryWidgetCmd procedure, "selection adjust" widget command} { +test entry-3.57 {EntryWidgetCmd procedure, "selection adjust" widget command} { .e delete 0 end .e insert end "0123456789" .e select from 1 @@ -348,7 +396,7 @@ test entry-3.51 {EntryWidgetCmd procedure, "selection adjust" widget command} { .e select adjust 4 selection get } {123} -test entry-3.52 {EntryWidgetCmd procedure, "selection adjust" widget command} { +test entry-3.58 {EntryWidgetCmd procedure, "selection adjust" widget command} { .e delete 0 end .e insert end "0123456789" .e select from 1 @@ -357,16 +405,16 @@ test entry-3.52 {EntryWidgetCmd procedure, "selection adjust" widget command} { .e select adjust 2 selection get } {234} -test entry-3.53 {EntryWidgetCmd procedure, "selection from" widget command} { +test entry-3.59 {EntryWidgetCmd procedure, "selection from" widget command} { list [catch {.e select from 2 3} msg] $msg } {1 {wrong # args: should be ".e selection from index"}} -test entry-3.54 {EntryWidgetCmd procedure, "selection range" widget command} { +test entry-3.60 {EntryWidgetCmd procedure, "selection range" widget command} { list [catch {.e select range 2} msg] $msg } {1 {wrong # args: should be ".e selection range start end"}} -test entry-3.55 {EntryWidgetCmd procedure, "selection range" widget command} { +test entry-3.61 {EntryWidgetCmd procedure, "selection range" widget command} { list [catch {.e selection range 2 3 4} msg] $msg } {1 {wrong # args: should be ".e selection range start end"}} -test entry-3.56 {EntryWidgetCmd procedure, "selection range" widget command} { +test entry-3.62 {EntryWidgetCmd procedure, "selection range" widget command} { .e delete 0 end .e insert end 0123456789 .e select from 1 @@ -374,7 +422,7 @@ test entry-3.56 {EntryWidgetCmd procedure, "selection range" widget command} { .e select range 4 4 list [catch {.e index sel.first} msg] $msg } {1 {selection isn't in entry}} -test entry-3.57 {EntryWidgetCmd procedure, "selection range" widget command} { +test entry-3.63 {EntryWidgetCmd procedure, "selection range" widget command} { .e delete 0 end .e insert end 0123456789 .e select from 3 @@ -385,78 +433,92 @@ test entry-3.57 {EntryWidgetCmd procedure, "selection range" widget command} { .e delete 0 end .e insert end "This is quite a long text string, so long that it " .e insert end "runs off the end of the window quite a bit." -test entry-3.58 {EntryWidgetCmd procedure, "selection to" widget command} { +test entry-3.64 {EntryWidgetCmd procedure, "selection to" widget command} { list [catch {.e select to 2 3} msg] $msg } {1 {wrong # args: should be ".e selection to index"}} -test entry-3.59 {EntryWidgetCmd procedure, "xview" widget command} { +test entry-3.65 {EntryWidgetCmd procedure, "xview" widget command} { .e xview 5 .e xview } {0.0537634 0.268817} -test entry-3.60 {EntryWidgetCmd procedure, "xview" widget command} { +test entry-3.66 {EntryWidgetCmd procedure, "xview" widget command} { list [catch {.e xview gorp} msg] $msg } {1 {bad entry index "gorp"}} -test entry-3.61 {EntryWidgetCmd procedure, "xview" widget command} { +test entry-3.67 {EntryWidgetCmd procedure, "xview" widget command} { .e xview 0 .e icursor 10 .e xview insert .e xview } {0.107527 0.322581} -test entry-3.62 {EntryWidgetCmd procedure, "xview" widget command} { +test entry-3.68 {EntryWidgetCmd procedure, "xview" widget command} { list [catch {.e xview moveto foo bar} msg] $msg } {1 {wrong # args: should be ".e xview moveto fraction"}} -test entry-3.63 {EntryWidgetCmd procedure, "xview" widget command} { +test entry-3.69 {EntryWidgetCmd procedure, "xview" widget command} { list [catch {.e xview moveto foo} msg] $msg } {1 {expected floating-point number but got "foo"}} -test entry-3.64 {EntryWidgetCmd procedure, "xview" widget command} { +test entry-3.70 {EntryWidgetCmd procedure, "xview" widget command} { .e xview moveto 0.5 .e xview } {0.505376 0.72043} -test entry-3.65 {EntryWidgetCmd procedure, "xview" widget command} { +test entry-3.71 {EntryWidgetCmd procedure, "xview" widget command} { list [catch {.e xview scroll 24} msg] $msg } {1 {wrong # args: should be ".e xview scroll number units|pages"}} -test entry-3.66 {EntryWidgetCmd procedure, "xview" widget command} { +test entry-3.72 {EntryWidgetCmd procedure, "xview" widget command} { list [catch {.e xview scroll gorp units} msg] $msg } {1 {expected integer but got "gorp"}} -test entry-3.67 {EntryWidgetCmd procedure, "xview" widget command} { +test entry-3.73 {EntryWidgetCmd procedure, "xview" widget command} { .e xview moveto 0 .e xview scroll 1 pages .e xview } {0.193548 0.408602} -test entry-3.68 {EntryWidgetCmd procedure, "xview" widget command} { +test entry-3.74 {EntryWidgetCmd procedure, "xview" widget command} { .e xview moveto .9 update .e xview scroll -2 p .e xview } {0.397849 0.612903} -test entry-3.69 {EntryWidgetCmd procedure, "xview" widget command} { +test entry-3.75 {EntryWidgetCmd procedure, "xview" widget command} { .e xview 30 update .e xview scroll 2 units .e index @0 } {32} -test entry-3.70 {EntryWidgetCmd procedure, "xview" widget command} { +test entry-3.76 {EntryWidgetCmd procedure, "xview" widget command} { .e xview 30 update .e xview scroll -1 units .e index @0 } {29} -test entry-3.71 {EntryWidgetCmd procedure, "xview" widget command} { +test entry-3.77 {EntryWidgetCmd procedure, "xview" widget command} { list [catch {.e xview scroll 23 foobars} msg] $msg } {1 {bad argument "foobars": must be units or pages}} -test entry-3.72 {EntryWidgetCmd procedure, "xview" widget command} { +test entry-3.78 {EntryWidgetCmd procedure, "xview" widget command} { list [catch {.e xview eat 23 hamburgers} msg] $msg } {1 {unknown option "eat": must be moveto or scroll}} -test entry-3.73 {EntryWidgetCmd procedure, "xview" widget command} { +test entry-3.79 {EntryWidgetCmd procedure, "xview" widget command} { .e xview 0 update .e xview -4 .e index @0 } {0} -test entry-3.74 {EntryWidgetCmd procedure, "xview" widget command} { +test entry-3.80 {EntryWidgetCmd procedure, "xview" widget command} { .e xview 300 .e index @0 } {73} -test entry-3.75 {EntryWidgetCmd procedure} { +.e insert 10 \u4e4e +test entry-3.81 {EntryWidgetCmd procedure, "xview" widget command} { + # UTF + # If Tcl_NumUtfChars wasn't used, wrong answer would be: + # {0.106383 0.319149} {0.117021 0.351064} {0.117021 0.351064} + + set x {} + .e xview moveto .1 + lappend x [.e xview] + .e xview moveto .11 + lappend x [.e xview] + .e xview moveto .12 + lappend x [.e xview] +} {{0.0957447 0.308511} {0.106383 0.319149} {0.117021 0.351064}} +test entry-3.82 {EntryWidgetCmd procedure} { list [catch {.e gorp} msg] $msg } {1 {bad option "gorp": must be bbox, cget, configure, delete, get, icursor, index, insert, scan, selection, or xview}} @@ -662,7 +724,7 @@ test entry-6.9 {EntryComputeGeometry procedure} {fonts} { update list [winfo reqwidth .e] [winfo reqheight .e] } {25 39} -test entry-6.10 {EntryComputeGeometry procedure} {fonts} { +test entry-6.10 {EntryComputeGeometry procedure} {unix && fonts} { catch {destroy .e} entry .e -bd 1 -relief raised -width 0 -show . .e insert 0 12345 @@ -674,6 +736,21 @@ test entry-6.10 {EntryComputeGeometry procedure} {fonts} { .e configure -show "" lappend x [winfo reqwidth .e] } {23 53 43} +test entry-6.11 {EntryComputeGeometry procedure} {pc} { + catch {destroy .e} + entry .e -bd 1 -relief raised -width 0 -show . -font {helvetica 12} + .e insert 0 12345 + pack .e + update + set x [winfo reqwidth .e] + .e configure -show X + lappend x [winfo reqwidth .e] + .e configure -show "" + lappend x [winfo reqwidth .e] +} [list \ + [expr 8+5*[font measure {helvetica 12} .]] \ + [expr 8+5*[font measure {helvetica 12} X]] \ + [expr 8+[font measure {helvetica 12} 12345]]] catch {destroy .e} entry .e -width 10 -font $fixed -textvariable contents -xscrollcommand scroll @@ -1089,52 +1166,62 @@ test entry-13.9 {GetEntryIndex procedure} { list [.e index sel.first] [.e index sel.last] } {1 6} selection clear .e -test entry-13.10 {GetEntryIndex procedure} {pc} { - .e index sel.first -} {1} -test entry-13.11 {GetEntryIndex procedure} {!pc} { +test entry-13.10 {GetEntryIndex procedure} {unix} { + # On unix, when selection is cleared, entry widget's internal + # selection range is reset. + list [catch {.e index sel.first} msg] $msg } {1 {selection isn't in entry}} -test entry-13.12 {GetEntryIndex procedure} {pc} { - list [catch {.e index sbogus} msg] $msg -} {1 {bad entry index "sbogus"}} -test entry-13.13 {GetEntryIndex procedure} {!pc} { +test entry-13.11 {GetEntryIndex procedure} {!unix} { + # On mac and pc, when selection is cleared, entry widget remembers + # last selected range. When selection ownership is restored to + # entry, the old range will be rehighlighted. + + list [catch {selection get}] [.e index sel.first] +} {1 1} +test entry-13.12 {GetEntryIndex procedure} {unix} { list [catch {.e index sbogus} msg] $msg } {1 {selection isn't in entry}} -test entry-13.14 {GetEntryIndex procedure} { +test entry-13.13 {GetEntryIndex procedure} {!unix} { + list [catch {.e index sbogus} msg] $msg +} {1 {bad entry index "sbogus"}} +test entry-13.14 {GetEntryIndex procedure} {!unix} { + list [catch {selection get}] [catch {.e index sbogus}] +} {1 1} +test entry-13.15 {GetEntryIndex procedure} { list [catch {.e index @xyz} msg] $msg } {1 {bad entry index "@xyz"}} -test entry-13.15 {GetEntryIndex procedure} {fonts} { +test entry-13.16 {GetEntryIndex procedure} {fonts} { .e index @4 } {4} -test entry-13.16 {GetEntryIndex procedure} {fonts} { +test entry-13.17 {GetEntryIndex procedure} {fonts} { .e index @11 } {4} -test entry-13.17 {GetEntryIndex procedure} {fonts} { +test entry-13.18 {GetEntryIndex procedure} {fonts} { .e index @12 } {5} -test entry-13.18 {GetEntryIndex procedure} {fonts} { +test entry-13.19 {GetEntryIndex procedure} {fonts} { .e index @[expr [winfo width .e] - 6] } {8} -test entry-13.19 {GetEntryIndex procedure} {fonts} { +test entry-13.20 {GetEntryIndex procedure} {fonts} { .e index @[expr [winfo width .e] - 5] } {9} -test entry-13.20 {GetEntryIndex procedure} { +test entry-13.21 {GetEntryIndex procedure} { .e index @1000 } {9} -test entry-13.21 {GetEntryIndex procedure} { +test entry-13.22 {GetEntryIndex procedure} { list [catch {.e index 1xyz} msg] $msg } {1 {bad entry index "1xyz"}} -test entry-13.22 {GetEntryIndex procedure} { +test entry-13.23 {GetEntryIndex procedure} { .e index -10 } {0} -test entry-13.23 {GetEntryIndex procedure} { +test entry-13.24 {GetEntryIndex procedure} { .e index 12 } {12} -test entry-13.24 {GetEntryIndex procedure} { +test entry-13.25 {GetEntryIndex procedure} { .e index 49 } {21} -test entry-13.25 {GetEntryIndex procedure} {fonts} { +test entry-13.26 {GetEntryIndex procedure} {fonts} { catch {destroy .e} entry .e -show . .e insert 0 XXXYZZY @@ -1199,14 +1286,20 @@ test entry-16.1 {EntryVisibleRange procedure} {fonts} { .e insert 0 ............................. .e xview } {0 0.827586} -test entry-16.2 {EntryVisibleRange procedure} {fonts} { +test entry-15.2 {EntryVisibleRange procedure} {unix && fonts} { .e configure -show X .e delete 0 end .e insert 0 ............................. .e xview } {0 0.275862} +test entry-15.3 {EntryVisibleRange procedure} {pc} { + .e configure -show . + .e delete 0 end + .e insert 0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXX + .e xview +} {0 0.827586} .e configure -show "" -test entry-16.3 {EntryVisibleRange procedure} { +test entry-15.4 {EntryVisibleRange procedure} { .e delete 0 end .e xview } {0 1} diff --git a/tests/filebox.test b/tests/filebox.test index 6bae6c5..1956c09 100644 --- a/tests/filebox.test +++ b/tests/filebox.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) filebox.test 1.5 97/10/10 11:03:21 +# SCCS: @(#) filebox.test 1.7 97/10/20 14:49:37 # set tk_strictMotif_old $tk_strictMotif @@ -92,7 +92,7 @@ if {$tcl_platform(platform) == "unix"} { set modes 1 } -set unknownOptionsMsg {1 {unknown option "-foo", must be -defaultextension, -filetypes, -initialdir, -initialfile, -parent or -title}} +set unknownOptionsMsg {1 {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -parent, or -title}} foreach mode $modes { @@ -110,11 +110,11 @@ foreach mode $modes { # foreach command "tk_getOpenFile tk_getSaveFile" { - test filebox-1.1 "$command command" { list [catch {$command -foo} msg] $msg } $unknownOptionsMsg + catch {$command -foo 1} msg regsub -all , $msg "" options regsub \"-foo\" $options "" options @@ -171,7 +171,6 @@ foreach mode $modes { $command -title "Press Cancel ($verylongstring)" -parent $parent } "" - if {$command == "tk_getSaveFile"} { set fileName "12x 455" set fileDir [pwd] diff --git a/tests/font.test b/tests/font.test index a526470..30aa3f5 100644 --- a/tests/font.test +++ b/tests/font.test @@ -1,18 +1,23 @@ # This file is a Tcl script to test out Tk's "font" command # plus the procedures in tkFont.c. It is organized in the -# standard fashion for Tcl tests. +# standard white-box fashion for Tcl tests. # -# Copyright (c) 1996 Sun Microsystems, Inc. +# Copyright (c) 1996-1998 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) font.test 1.22 97/10/10 14:34:54 +# SCCS: @(#) font.test 1.29 98/01/16 10:47:57 if {[string compare test [info procs test]] != 0} { source defs } +if {[info commands testfont] != "testfont"} { + puts "testfont command not available; skipping tests" + return +} + catch {destroy .b} toplevel .b wm geom .b +0+0 @@ -20,7 +25,7 @@ update idletasks proc setup {} { catch {destroy .b.f} - catch {font delete xyz} + catch {eval font delete [font names]} label .b.f pack .b.f update @@ -56,243 +61,357 @@ case $tcl_platform(platform) { } set times [font actual {times 0} -family] -test font-1.1 {font command: general} { +test font-1.1 {TkFontPkgInit} { + catch {interp delete foo} + interp create foo + foo eval { + load {} Tk + wm geometry . +0+0 + update + } + interp delete foo +} {} + +test font-2.1 {TkFontPkgFree} { + catch {interp delete foo} + interp create foo + set x {} + + # Makes sure that named font was visible only to child interp. + + foo eval { + load {} Tk + wm geometry . +0+0 + button .b -font {times 16} -text "hi" + pack .b + font create wiggles -family courier -underline 1 + update + } + lappend x [catch {font configure wiggles} msg; set msg] + + # Tests cancelling the idle handler for TheWorldHasChanged, + # because app goes away before idle serviced. + + foo eval { + .b config -font wiggles + font config wiggles -size 24 + destroy . + } + lappend x [foo eval {catch {font families} msg; set msg}] + + interp delete foo + set x +} {{named font "wiggles" doesn't exist} {can't invoke "font" command: application has been destroyed}} + + +test font-3.1 {font command: general} { list [catch {font} msg] $msg } {1 {wrong # args: should be "font option ?arg?"}} -test font-1.2 {font command: actual: arguments} { +test font-3.2 {font command: general} { + list [catch {font xyz} msg] $msg +} {1 {bad option "xyz": must be actual, configure, create, delete, families, measure, metrics, or names}} + +test font-4.1 {font command: actual: arguments} { + # (skip < 0) list [catch {font actual xyz -displayof} msg] $msg } {1 {value for "-displayof" missing}} -test font-1.3 {font command: actual: arguments} { +test font-4.2 {font command: actual: arguments} { + # (objc < 3) list [catch {font actual} msg] $msg } {1 {wrong # args: should be "font actual font ?-displayof window? ?option?"}} -test font-1.4 {font command: actual: arguments} { +test font-4.3 {font command: actual: arguments} { + # (objc - skip > 4) when skip == 0 list [catch {font actual xyz abc def} msg] $msg } {1 {wrong # args: should be "font actual font ?-displayof window? ?option?"}} -test font-1.5 {font command: actual: arguments} { - list [catch {font actual {}} msg] $msg -} {1 {font "" doesn't exist}} -test font-1.6 {font command: actual: displayof specified, so skip to next} { +test font-4.4 {font command: actual: displayof specified, so skip to next} { catch {font actual xyz -displayof . -size} } {0} -test font-1.7 {font command: actual: displayof specified, so skip to next} { +test font-4.5 {font command: actual: displayof specified, so skip to next} { lindex [font actual xyz -displayof .] 0 } {-family} -test font-1.8 {font command: actual} {unix || mac} { +test font-4.6 {font command: actual: arguments} { + # (objc - skip > 4) when skip == 2 + list [catch {font actual xyz -displayof . abc def} msg] $msg +} {1 {wrong # args: should be "font actual font ?-displayof window? ?option?"}} +test font-4.7 {font command: actual: arguments} { + # (tkfont == NULL) + list [catch {font actual "\{xyz"} msg] $msg +} [list 1 "font \"{xyz\" doesn't exist"] +test font-4.8 {font command: actual: all attributes} { + # not (objc > 3) so objPtr = NULL + lindex [font actual {-family times}] 0 +} {-family} +test font-4.9 {font command: actual} {unix || mac} { + # (objc > 3) so objPtr = objv[3 + skip] string tolower [font actual {-family times} -family] } {times} -test font-1.9 {font command: actual} {pcOnly} { +test font-4.10 {font command: actual} {pcOnly} { + # (objc > 3) so objPtr = objv[3 + skip] font actual {-family times} -family } {Times New Roman} -test font-1.10 {font command: actual} { - lindex [font actual {-family times}] 0 -} {-family} -test font-1.11 {font command: bad option} { +test font-4.11 {font command: bad option} { list [catch {font actual xyz -style} msg] $msg } {1 {bad option "-style": must be -family, -size, -weight, -slant, -underline, or -overstrike}} -test font-2.1 {font command: configure} { +test font-5.1 {font command: configure} { + # (objc < 3) list [catch {font configure} msg] $msg } {1 {wrong # args: should be "font configure fontname ?options?"}} -test font-2.2 {font command: configure: non-existent font} { +test font-5.2 {font command: configure: non-existent font} { + # (namedHashPtr == NULL) list [catch {font configure xyz} msg] $msg } {1 {named font "xyz" doesn't exist}} -test font-2.3 {font command: configure: "deleted" font} { +test font-5.3 {font command: configure: "deleted" font} { + # (nfPtr->deletePending != 0) setup font create xyz .b.f configure -font xyz font delete xyz list [catch {font configure xyz} msg] $msg } {1 {named font "xyz" doesn't exist}} -test font-2.4 {font command: configure: get all options} { +test font-5.4 {font command: configure: get all options} { + # (objc == 3) so objPtr = NULL setup font create xyz -family xyz lindex [font configure xyz] 1 } xyz -test font-2.5 {font command: configure: get one option} { +test font-5.5 {font command: configure: get one option} { + # (objc == 4) so objPtr = objv[3] setup font create xyz -family xyz font configure xyz -family } xyz -test font-2.6 {font command: configure: update existing font} { +test font-5.6 {font command: configure: update existing font} { + # else result = ConfigAttributesObj() setup font create xyz font configure xyz -family xyz update font configure xyz -family } xyz -test font-2.7 {font command: configure: bad option} { +test font-5.7 {font command: configure: bad option} { setup font create xyz list [catch {font configure xyz -style} msg] $msg } {1 {bad option "-style": must be -family, -size, -weight, -slant, -underline, or -overstrike}} -test font-3.1 {font command: create: make up name} { - font delete [font create] - font delete [font create -family xyz] -} {} -test font-3.2 {font command: create: already exists} { +test font-6.1 {font command: create: make up name} { + # (objc < 3) so name = NULL setup - font create xyz - list [catch {font create xyz} msg] $msg -} {1 {font "xyz" already exists}} -test font-3.3 {font command: create: error recreating "deleted" font} { + font create + font names +} {font1} +test font-6.2 {font command: create: name specified} { + # not (objc < 3) setup font create xyz - .b.f configure -font xyz - font delete xyz - list [catch {font create xyz -xyz times} msg] $msg -} {1 {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}} -test font-3.4 {font command: create: recreate "deleted" font} { + font names +} {xyz} +test font-6.3 {font command: create: name not really specified} { + # (name[0] == '-') so name = NULL setup - font create xyz - .b.f configure -font xyz - font delete xyz - font actual xyz - font create xyz -family times - update - font configure xyz -family -} {times} -test font-3.5 {font command: create: bad option creating new font} { + font create -family xyz + font names +} {font1} +test font-6.4 {font command: create: generate name} { + # (name == NULL) + setup + font create -family one + font create -family two + font create -family three + font delete font2 + font create -family four + font configure font2 -family +} {four} +test font-6.5 {font command: create: bad option creating new font} { + # name was specified so skip = 3 setup list [catch {font create xyz -xyz times} msg] $msg } {1 {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}} -test font-3.6 {font command: create: totally new font} { +test font-6.6 {font command: create: bad option creating new font} { + # name was not specified so skip = 2 setup - font create xyz -family xyz - font configure xyz -family -} {xyz} + list [catch {font create -xyz times} msg] $msg +} {1 {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}} +test font-6.7 {font command: create: already exists} { + # (CreateNamedFont() != TCL_OK) + setup + font create xyz + list [catch {font create xyz} msg] $msg +} {1 {named font "xyz" already exists}} -test font-4.1 {font command: delete: arguments} { +test font-7.1 {font command: delete: arguments} { + # (objc < 3) list [catch {font delete} msg] $msg } {1 {wrong # args: should be "font delete fontname ?fontname ...?"}} -test font-4.2 {font command: delete: loop test} { +test font-7.2 {font command: delete: loop test} { + # for (i = 2; i < objc; i++) + setup + set x {} + font create a -underline 1 + font create b -underline 1 + font create c -underline 1 + font create d -underline 1 + font create e -underline 1 + lappend x [lsort [font names]] + font delete a e c b + lappend x [lsort [font names]] +} {{a b c d e} d} +test font-7.3 {font command: delete: loop test} { + # (namedHashPtr == NULL) in middle of loop + setup + set x {} font create a -underline 1 font create b -underline 1 font create c -underline 1 - font delete a b c - list [font actual a -underline] [font actual b -underline] [font actual c -underline] -} {0 0 0} -test font-4.3 {font command: delete: non-existent} { + font create d -underline 1 + font create e -underline 1 + lappend x [lsort [font names]] + catch {font delete a d q c e b} + lappend x [lsort [font names]] +} {{a b c d e} {b c e}} +test font-7.4 {font command: delete: non-existent} { + # (namedHashPtr == NULL) setup list [catch {font delete xyz} msg] $msg } {1 {named font "xyz" doesn't exist}} -test font-4.4 {font command: delete: mark for later deletion} { +test font-7.5 {font command: delete: mark for later deletion} { + # (nfPtr->refCount != 0) setup font create xyz .b.f configure -font xyz font delete xyz font actual xyz - list [catch {font configure xyz} msg] $msg -} {1 {named font "xyz" doesn't exist}} -test font-4.5 {font command: delete: actually delete} { + list [catch {font configure xyz} msg] $msg [.b.f cget -font] +} {1 {named font "xyz" doesn't exist} xyz} +test font-7.6 {font command: delete: actually delete} { + # not (nfPtr->refCount != 0) setup font create xyz -underline 1 font delete xyz - font actual xyz -underline -} {0} + catch {font config xyz} +} {1} +setup -test font-5.1 {font command: families: arguments} { +test font-8.1 {font command: families: arguments} { + # (skip < 0) list [catch {font families -displayof} msg] $msg } {1 {value for "-displayof" missing}} -test font-5.2 {font command: families: arguments} { +test font-8.2 {font command: families: arguments} { + # (objc - skip != 2) when skip == 0 list [catch {font families xyz} msg] $msg } {1 {wrong # args: should be "font families ?-displayof window?"}} -test font-5.3 {font command: families} { - font families - set x {} -} {} +test font-8.3 {font command: families: arguments} { + # (objc - skip != 2) when skip == 2 + list [catch {font families -displayof . xyz} msg] $msg +} {1 {wrong # args: should be "font families ?-displayof window?"}} +test font-8.4 {font command: families} { + # TkpGetFontFamilies() + regexp -nocase times [font families] +} {1} -test font-6.1 {font command: measure: arguments} { +test font-9.1 {font command: measure: arguments} { + # (skip < 0) list [catch {font measure xyz -displayof} msg] $msg } {1 {value for "-displayof" missing}} -test font-6.2 {font command: measure: arguments} { +test font-9.2 {font command: measure: arguments} { + # (objc - skip != 4) list [catch {font measure} msg] $msg } {1 {wrong # args: should be "font measure font ?-displayof window? text"}} -test font-6.3 {font command: measure: arguments} { +test font-9.3 {font command: measure: arguments} { + # (objc - skip != 4) list [catch {font measure xyz abc def} msg] $msg } {1 {wrong # args: should be "font measure font ?-displayof window? text"}} -test font-6.4 {font command: measure: arguments} { - list [catch {font measure {} abc} msg] $msg -} {1 {font "" doesn't exist}} -test font-6.5 {font command: measure} { +test font-9.4 {font command: measure: arguments} { + # (tkfont == NULL) + list [catch {font measure "\{xyz" abc} msg] $msg +} [list 1 "font \"{xyz\" doesn't exist"] +test font-9.5 {font command: measure} { + # Tk_TextWidth() expr [font measure $fixed "abcdefg"]==[font measure $fixed "a"]*7 } {1} -test font-7.1 {font command: metrics: arguments} { +test font-10.1 {font command: metrics: arguments} { + list [catch {font metrics xyz -displayof} msg] $msg +} {1 {value for "-displayof" missing}} +test font-10.2 {font command: metrics: arguments} { + # (skip < 0) list [catch {font metrics xyz -displayof} msg] $msg } {1 {value for "-displayof" missing}} -test font-7.2 {font command: metrics: arguments} { +test font-10.3 {font command: metrics: arguments} { + # (objc < 3) list [catch {font metrics} msg] $msg } {1 {wrong # args: should be "font metrics font ?-displayof window? ?option?"}} -test font-7.3 {font command: metrics: get all metrics} { +test font-10.4 {font command: metrics: arguments} { + # (objc - skip) > 4) when skip == 0 + list [catch {font metrics xyz abc def} msg] $msg +} {1 {wrong # args: should be "font metrics font ?-displayof window? ?option?"}} +test font-10.5 {font command: metrics: arguments} { + # (objc - skip) > 4) when skip == 2 + list [catch {font metrics xyz -displayof . abc} msg] $msg +} {1 {bad metric "abc": must be -ascent, -descent, -linespace, or -fixed}} +test font-10.6 {font command: metrics: bad font} { + # (tkfont == NULL) + list [catch {font metrics "\{xyz"} msg] $msg +} [list 1 "font \"{xyz\" doesn't exist"] +test font-10.7 {font command: metrics: get all metrics} { + # (objc == 3) catch {unset a} array set a [font metrics {-family xyz}] set x [lsort [array names a]] unset a set x } {-ascent -descent -fixed -linespace} -test font-7.4 {font command: metrics: get ascent} { - catch {expr [font metrics $fixed -ascent]} -} {0} -test font-7.5 {font command: metrics: get descent} { - catch {expr [font metrics {-family xyz} -descent]} -} {0} -test font-7.6 {font command: metrics: get linespace} { - catch {expr [font metrics {-family fixed} -linespace]} -} {0} -test font-7.7 {font command: metrics: get fixed} { - catch {expr [font metrics {-family fixed} -fixed]} -} {0} -test font-7.8 {font command: metrics: get ascent} { - catch {expr [font metrics {-family xyz} -ascent]} -} {0} -test font-7.9 {font command: metrics: get descent} { - catch {expr [font metrics {-family xyz} -descent]} -} {0} -test font-7.10 {font command: metrics: get linespace} { - catch {expr [font metrics {-family fixed} -linespace]} -} {0} -test font-7.11 {font command: metrics: get fixed} { - catch {expr [font metrics {-family fixed} -fixed]} -} {0} -test font-7.12 {font command: metrics: bad metric} { - list [catch {font metrics {-family fixed} -xyz} msg] $msg +test font-10.8 {font command: metrics: bad metric} { + # (Tcl_GetIndexFromObj() != TCL_OK) + list [catch {font metrics $fixed -xyz} msg] $msg } {1 {bad metric "-xyz": must be -ascent, -descent, -linespace, or -fixed}} +test font-10.9 {font command: metrics: get individual metrics} { + font metrics $fixed -ascent + font metrics $fixed -descent + font metrics $fixed -linespace + font metrics $fixed -fixed +} {1} -test font-8.1 {font command: names: arguments} { +test font-11.1 {font command: names: arguments} { + # (objc != 2) list [catch {font names xyz} msg] $msg } {1 {wrong # args: should be "font names"}} -test font-8.2 {font command: names} { +test font-11.2 {font command: names: loop test: no passes} { + setup + font names +} {} +test font-11.3 {font command: names: loop test: one pass} { + setup + font create + font names +} {font1} +test font-11.4 {font command: names: loop test: multiple passes} { setup font create xyz font create abc - set x [lsort [font names]] - font delete abc - font delete xyz - set x -} {abc xyz} -test font-8.3 {font command: names} { + font create def + lsort [font names] +} {abc def xyz} +test font-11.5 {font command: names: skip deletePending fonts} { + # (nfPtr->deletePending == 0) setup + set x {} font create xyz font create abc - set x [lsort [font names]] + lappend x [lsort [font names]] .b.f config -font xyz font delete xyz lappend x [font names] - font delete abc - set x -} {abc xyz abc} +} {{abc xyz} abc} -test font-9.1 {font command: unknown option} { - list [catch {font xyz} msg] $msg -} {1 {bad option "xyz": must be actual, configure, create, delete, families, measure, metrics, or names}} - -test font-10.1 {UpdateDependantFonts procedure: no users} { +test font-12.1 {UpdateDependantFonts procedure: no users} { + # (nfPtr->refCount == 0) setup font create xyz font configure xyz -family times } {} -test font-10.2 {UpdateDependantFonts procedure: pings the widgets} { +test font-12.2 {UpdateDependantFonts procedure: pings the widgets} { setup font create xyz -family times -size 20 .b.f config -font xyz -text "abcd" -padx 0 -bd 0 -highlightthickness 0 @@ -306,56 +425,155 @@ test font-10.2 {UpdateDependantFonts procedure: pings the widgets} { expr {$a1==$b1 && $a2==$b2} } {1} -test font-11.1 {Tk_GetFont procedure: bump ref count} { +test font-13.1 {CreateNamedFont: new named font} { + # not (new == 0) + setup + set x {} + lappend x [font names] + font create xyz + lappend x [font names] +} {{} xyz} +test font-13.2 {CreateNamedFont: named font already exists} { + # (new == 0) + setup + font create xyz + list [catch {font create xyz} msg] $msg +} {1 {named font "xyz" already exists}} +test font-13.3 {CreateNamedFont: named font already exists} { + # (nfPtr->deletePending == 0) + setup + font create xyz + list [catch {font create xyz} msg] $msg +} {1 {named font "xyz" already exists}} +test font-13.4 {CreateNamedFont: recreate "deleted" font} { + # not (nfPtr->deletePending == 0) + setup + font create xyz -family times + .b.f configure -font xyz + font delete xyz + font create xyz -family courier + font configure xyz -family +} {courier} + +test font-14.1 {Tk_GetFont procedure} { +} {} + +test font-15.1 {Tk_AllocFontFromObj - converting internal reps} { + set x {Times 16} + lindex $x 0 + destroy .b1 .b2 + button .b1 -font $x + lindex $x 0 + testfont counts {Times 16} +} {{1 0}} +test font-15.2 {Tk_AllocFontFromObj - discard stale font} { + set x {Times 16} + destroy .b1 .b2 + button .b1 -font $x + destroy .b1 + set result {} + lappend result [testfont counts {Times 16}] + button .b2 -font $x + lappend result [testfont counts {Times 16}] +} {{} {{1 1}}} +test font-15.3 {Tk_AllocFontFromObj - reuse existing font} { + set x {Times 16} + destroy .b1 .b2 + button .b1 -font $x + set result {} + lappend result [testfont counts {Times 16}] + button .b2 -font $x + pack .b1 .b2 -side top + lappend result [testfont counts {Times 16}] +} {{{1 1}} {{2 1}}} +test font-15.4 {Tk_AllocFontFromObj procedure: bump ref count} { + # (new == 0) setup .b.f config -font {-family fixed} lindex [font actual {-family fixed}] 0 } {-family} -test font-11.2 {Tk_GetFont procedure: bump ref count of named font, too} { +test font-15.5 {Tk_AllocFontFromObj procedure: get named font} { + # (namedHashPtr != NULL) setup - font create xyz - .b.f config -font xyz - lindex [font actual xyz] 0 -} {-family} -test font-11.3 {Tk_GetFont procedure: get named font} { + font create xyz + .b.f config -font xyz +} {} +test font-15.6 {Tk_AllocFontFromObj procedure: not a named font} { + # not (namedHashPtr != NULL) setup - font create xyz - .b.f config -font xyz + .b.f config -font {times 20} } {} -test font-11.4 {Tk_GetFont procedure: get native font} {unixOnly} { +test font-15.7 {Tk_AllocFontFromObj procedure: get native font} {unixOnly} { + # not (fontPtr == NULL) setup .b.f config -font fixed } {} -test font-11.5 {Tk_GetFont procedure: get native font} {pcOnly} { +test font-15.8 {Tk_AllocFontFromObj procedure: get native font} {pcOnly} { + # not (fontPtr == NULL) setup .b.f config -font oemfixed } {} -test font-11.6 {Tk_GetFont procedure: get native font} {macOnly} { +test font-15.9 {Tk_AllocFontFromObj procedure: get native font} {macOnly} { + # not (fontPtr == NULL) setup .b.f config -font application } {} -test font-11.7 {Tk_GetFont procedure: get attribute font} { +test font-15.10 {Tk_AllocFontFromObj procedure: get attribute font} { + # (fontPtr == NULL) list [catch {.b.f config -font {xxx yyy zzz}} msg] $msg } {1 {expected integer but got "yyy"}} -test font-11.8 {Tk_GetFont procedure: get attribute font} { +test font-15.11 {Tk_AllocFontFromObj procedure: no match} { + # (ParseFontNameObj() != TCL_OK) + list [catch {font actual "\{xyz"} msg] $msg +} [list 1 "font \"{xyz\" doesn't exist"] +test font-15.12 {Tk_AllocFontFromObj procedure: get attribute font} { + # not (ParseFontNameObj() != TCL_OK) lindex [font actual {plan 9}] 0 } {-family} -test font-11.9 {Tk_GetFont procedure: no match} { - list [catch {font actual {}} msg] $msg -} {1 {font "" doesn't exist}} +test font-15.13 {Tk_AllocFontFromObj procedure: setup tab width} { + # Tk_MeasureChars(fontPtr, "0", ...) + label .l -bd 0 -padx 0 -highlightthickness 0 -font $fixed -text "a\tb" + update + set x [winfo reqwidth .l] + destroy .l + set x +} [expr [font measure $fixed "0"]*9] +test font-15.14 {Tk_AllocFontFromObj procedure: underline position} { + # (fontPtr->underlineHeight == 0) because size was < 10 + setup + .b.f config -text "underline" -font "times -8 underline" + update +} {} -test font-12.1 {Tk_NameOfFont procedure} { +test font-16.1 {Tk_NameOfFont procedure} { setup - .b.f config -font {-family fixed} + .b.f config -font -family\ fixed .b.f cget -font } {-family fixed} -test font-13.1 {Tk_FreeFont procedure: one ref} { +test font-17.1 {Tk_FreeFontFromObj - reference counts} { + set x {Courier 12} + destroy .b1 .b2 .b3 + button .b1 -font $x + button .b3 -font $x + button .b2 -font $x + set result {} + lappend result [testfont counts {Courier 12}] + destroy .b1 + lappend result [testfont counts {Courier 12}] + destroy .b2 + lappend result [testfont counts {Courier 12}] + destroy .b3 + lappend result [testfont counts {Courier 12}] +} {{{3 1}} {{2 1}} {{1 1}} {}} +test font-17.2 {Tk_FreeFont procedure: one ref} { + # (fontPtr->refCount == 0) setup .b.f config -font {-family fixed} destroy .b.f } {} -test font-13.2 {Tk_FreeFont procedure: multiple ref} { +test font-17.3 {Tk_FreeFont procedure: multiple ref} { + # not (fontPtr->refCount == 0) setup .b.f config -font {-family fixed} button .b.b -font {-family fixed} @@ -364,14 +582,16 @@ test font-13.2 {Tk_FreeFont procedure: multiple ref} { destroy .b.b set x } {-family fixed} -test font-13.3 {Tk_FreeFont procedure: named font} { +test font-17.4 {Tk_FreeFont procedure: named font} { + # (fontPtr->namedHashPtr != NULL) setup font create xyz .b.f config -font xyz destroy .b.f font names } {xyz} -test font-13.4 {Tk_FreeFont procedure: named font} { +test font-17.5 {Tk_FreeFont procedure: named font} { + # not (fontPtr->refCount == 0) setup font create xyz -underline 1 .b.f config -font xyz @@ -380,9 +600,9 @@ test font-13.4 {Tk_FreeFont procedure: named font} { destroy .b.f list [font actual xyz -underline] $x } {0 1} -test font-13.5 {Tk_FreeFont procedure: named font not deleted yet} { +test font-17.6 {Tk_FreeFont procedure: named font not deleted yet} { setup - font create xyz + font create xyz .b.f config -font xyz button .b.b -font xyz font delete xyz @@ -391,12 +611,32 @@ test font-13.5 {Tk_FreeFont procedure: named font not deleted yet} { list [lindex [font actual xyz] 0] [lindex $x 0] } {-family -family} -test font-14.1 {Tk_FontId} { +test font-18.1 {FreeFontObjProc} { + destroy .b1 + set x [format {Courier 12}] + button .b1 -font $x + set y [format {Courier 12}] + .b1 configure -font $y + set z [format {Courier 12}] + .b1 configure -font $z + set result {} + lappend result [testfont counts {Courier 12}] + set x red + lappend result [testfont counts {Courier 12}] + set z 32 + lappend result [testfont counts {Courier 12}] + destroy .b1 + lappend result [testfont counts {Courier 12}] + set y bogus + set result +} {{{1 3}} {{1 2}} {{1 1}} {}} + +test font-19.1 {Tk_FontId} { .b.f config -font "times 20" update } {} -test font-15.1 {Tk_FontMetrics procedure} { +test font-20.1 {Tk_GetFontMetrics procedure} { button .b.w1 -text abc entry .b.w2 -text abcd update @@ -414,7 +654,7 @@ proc psfontname {name} { set start [string first "gsave" $post] return [string range $post [expr $start+7] end] } -test font-16.1 {Tk_PostscriptFontName procedure: native} {unixOnly} { +test font-21.1 {Tk_PostscriptFontName procedure: native} {unixOnly} { set x [font actual {{itc avant garde} 10} -family] if {[string match *avant*garde $x]} { psfontname "{itc avant garde} 10" @@ -422,25 +662,25 @@ test font-16.1 {Tk_PostscriptFontName procedure: native} {unixOnly} { set x {AvantGarde-Book} } } {AvantGarde-Book} -test font-16.2 {Tk_PostscriptFontName procedure: native} {pcOnly} { +test font-21.2 {Tk_PostscriptFontName procedure: native} {pcOnly} { psfontname "arial 10" } {Helvetica} -test font-16.3 {Tk_PostscriptFontName procedure: native} {pcOnly} { +test font-21.3 {Tk_PostscriptFontName procedure: native} {pcOnly} { psfontname "{times new roman} 10" } {Times-Roman} -test font-16.4 {Tk_PostscriptFontName procedure: native} {pcOnly} { +test font-21.4 {Tk_PostscriptFontName procedure: native} {pcOnly} { psfontname "{courier new} 10" } {Courier} -test font-16.5 {Tk_PostscriptFontName procedure: native} {macOnly} { +test font-21.5 {Tk_PostscriptFontName procedure: native} {macOnly} { psfontname "geneva 10" } {Helvetica} -test font-16.6 {Tk_PostscriptFontName procedure: native} {macOnly} { +test font-21.6 {Tk_PostscriptFontName procedure: native} {macOnly} { psfontname "{new york} 10" } {Times-Roman} -test font-16.7 {Tk_PostscriptFontName procedure: native} {macOnly} { +test font-21.7 {Tk_PostscriptFontName procedure: native} {macOnly} { psfontname "monaco 10" } {Courier} -test font-16.8 {Tk_PostscriptFontName procedure: spaces} {unixOnly} { +test font-21.8 {Tk_PostscriptFontName procedure: spaces} {unixOnly} { set x [font actual {{lucida bright} 10} -family] if {[string match lucida*bright $x]} { psfontname "{lucida bright} 10" @@ -448,7 +688,7 @@ test font-16.8 {Tk_PostscriptFontName procedure: spaces} {unixOnly} { set x {LucidaBright} } } {LucidaBright} -test font-16.9 {Tk_PostscriptFontName procedure: spaces} {unixOnly} { +test font-21.9 {Tk_PostscriptFontName procedure: spaces} {unixOnly} { psfontname "{new century schoolbook} 10" } {NewCenturySchlbk-Roman} set i 10 @@ -464,7 +704,7 @@ foreach p { {"zapfchancery" ZapfChancery-MediumItalic ZapfChancery-MediumItalic ZapfChancery-MediumItalic ZapfChancery-MediumItalic} {"zapfdingbats" ZapfDingbats ZapfDingbats ZapfDingbats ZapfDingbats} } { - test font-16.$i {Tk_PostscriptFontName procedure: exhaustive} {unixOnly} { + test font-21.$i {Tk_PostscriptFontName procedure: exhaustive} {unixOnly} { set family [lindex $p 0] set x {} set i 1 @@ -490,7 +730,7 @@ foreach p { {"symbol" Symbol Symbol-Bold Symbol-Italic Symbol-BoldItalic} {"times new roman" Times-Roman Times-Bold Times-Italic Times-BoldItalic} } { - test font-16.$i {Tk_PostscriptFontName procedure: exhaustive} {pcOnly} { + test font-21.$i {Tk_PostscriptFontName procedure: exhaustive} {pcOnly} { set family [lindex $p 0] set x {} foreach slant {roman italic} { @@ -511,7 +751,7 @@ foreach p { {"symbol" Symbol Symbol-Bold Symbol-Italic Symbol-BoldItalic} {"times" Times-Roman Times-Bold Times-Italic Times-BoldItalic} } { - test font-16.$i {Tk_PostscriptFontName procedure: exhaustive} {macOnly} { + test font-21.$i {Tk_PostscriptFontName procedure: exhaustive} {macOnly} { set family [lindex $p 0] set x {} foreach slant {roman italic} { @@ -524,7 +764,11 @@ foreach p { } [lrange $p 1 end] } -test font-17.1 {Tk_UnderlineChars procedure} { +test font-22.1 {Tk_TextWidth procedure} { + font measure [.b.l cget -font] "000" +} [expr $ax*3] + +test font-23.1 {Tk_UnderlineChars procedure} { text .b.t .b.t insert 1.0 abc\tdefg .b.t tag config sel -underline 1 @@ -533,39 +777,39 @@ test font-17.1 {Tk_UnderlineChars procedure} { } {} setup -test font-18.1 {Tk_ComputeTextLayout: empty string} { +test font-24.1 {Tk_ComputeTextLayout: empty string} { .b.l config -text "" } {} -test font-18.2 {Tk_ComputeTextLayout: simple string} { +test font-24.2 {Tk_ComputeTextLayout: simple string} { .b.l config -text "000" getsize } "[expr $ax*3] $ay" -test font-18.3 {Tk_ComputeTextLayout: find special chars} { +test font-24.3 {Tk_ComputeTextLayout: find special chars} { .b.l config -text "000\n000" getsize } "[expr $ax*3] [expr $ay*2]" -test font-18.4 {Tk_ComputeTextLayout: calls Tk_MeasureChars} { +test font-24.4 {Tk_ComputeTextLayout: calls Tk_MeasureChars} { .b.l config -text "000\n000" getsize } "[expr $ax*3] [expr $ay*2]" -test font-18.5 {Tk_ComputeTextLayout: break line} { +test font-24.5 {Tk_ComputeTextLayout: break line} { .b.l config -text "000\t00000" -wrap [expr 9*$ax] set x [getsize] .b.l config -wrap 0 set x } "[expr 8*$ax] [expr 2*$ay]" -test font-18.6 {Tk_ComputeTextLayout: normal ended on special char} { +test font-24.6 {Tk_ComputeTextLayout: normal ended on special char} { .b.l config -text "000\n000" } {} -test font-18.7 {Tk_ComputeTextLayout: special char was \n} { +test font-24.7 {Tk_ComputeTextLayout: special char was \n} { .b.l config -text "000\n0000" getsize } "[expr $ax*4] [expr $ay*2]" -test font-18.8 {Tk_ComputeTextLayout: special char was \t} { +test font-24.8 {Tk_ComputeTextLayout: special char was \t} { .b.l config -text "000\t00" getsize } "[expr $ax*10] $ay" -test font-18.9 {Tk_ComputeTextLayout: tab didn't cause break} { +test font-24.9 {Tk_ComputeTextLayout: tab didn't cause break} { set x {} .b.l config -text "000\t000" lappend x [getsize] @@ -574,7 +818,7 @@ test font-18.9 {Tk_ComputeTextLayout: tab didn't cause break} { .b.l config -wrap 0 set x } "{[expr $ax*11] $ay} {[expr $ax*11] $ay}" -test font-18.10 {Tk_ComputeTextLayout: tab caused break} { +test font-24.10 {Tk_ComputeTextLayout: tab caused break} { set x {} .b.l config -text "000\t" lappend x [getsize] @@ -583,7 +827,7 @@ test font-18.10 {Tk_ComputeTextLayout: tab caused break} { .b.l config -wrap 0 set x } "{[expr $ax*3] $ay} {[expr $ax*3] [expr $ay*2]}" -test font-18.11 {Tk_ComputeTextLayout: absorb spaces at eol} { +test font-24.11 {Tk_ComputeTextLayout: absorb spaces at eol} { set x {} .b.l config -text "000 000" -wrap [expr $ax*5] lappend x [getsize] @@ -592,7 +836,7 @@ test font-18.11 {Tk_ComputeTextLayout: absorb spaces at eol} { .b.l config -wrap 0 set x } "{[expr $ax*3] [expr $ay*2]} {[expr $ax*3] $ay}" -test font-18.12 {Tk_ComputeTextLayout: append non-printing spaces to chunk} { +test font-24.12 {Tk_ComputeTextLayout: append non-printing spaces to chunk} { set x {} .b.l config -text "000 0000" -wrap [expr $ax*5] lappend x [getsize] @@ -601,14 +845,14 @@ test font-18.12 {Tk_ComputeTextLayout: append non-printing spaces to chunk} { .b.l config -wrap 0 set x } "{[expr $ax*4] [expr $ay*2]} {[expr $ax*10] [expr $ay*2]}" -test font-18.13 {Tk_ComputeTextLayout: many lines -> realloc line array} { +test font-24.13 {Tk_ComputeTextLayout: many lines -> realloc line array} { .b.l config -text "\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n" getsize } "1 [expr $ay*129]" -test font-18.14 {Tk_ComputeTextLayout: text ended with \n} { +test font-24.14 {Tk_ComputeTextLayout: text ended with \n} { list [.b.l config -text "0000"; getsize] [.b.l config -text "0000\n"; getsize] } "{[expr $ax*4] $ay} {[expr $ax*4] [expr $ay*2]}" -test font-18.15 {Tk_ComputeTextLayout: justification} { +test font-24.15 {Tk_ComputeTextLayout: justification} { csetup "000\n00000" set x {} .b.c itemconfig text -just left @@ -621,52 +865,52 @@ test font-18.15 {Tk_ComputeTextLayout: justification} { set x } {2 1 0} -test font-19.1 {Tk_FreeTextLayout procedure} { +test font-25.1 {Tk_FreeTextLayout procedure} { setup .b.f config -text foo .b.f config -text boo } {} -test font-20.1 {Tk_DrawTextLayout procedure: auto-detect last char} { +test font-26.1 {Tk_DrawTextLayout procedure: auto-detect last char} { .b.f config -text foo } {} -test font-20.2 {Tk_DrawTextLayout procedure: multiple chunks} { +test font-26.2 {Tk_DrawTextLayout procedure: multiple chunks} { csetup "000\t00\n000" } {} -test font-20.3 {Tk_DrawTextLayout: draw subset of chunk: numDisplay <= 0} { +test font-26.3 {Tk_DrawTextLayout: draw subset of chunk: numDisplay <= 0} { csetup "000\t00" .b.c select from text 3 .b.c select to text 5 } {} -test font-20.4 {Tk_DrawTextLayout: draw subset of chunk: firstChar <= 0} { +test font-26.4 {Tk_DrawTextLayout: draw subset of chunk: firstChar <= 0} { .b.c select from text 3 .b.c select to text 5 } {} -test font-20.5 {Tk_DrawTextLayout: draw subset of chunk: firstChar > 0} { +test font-26.5 {Tk_DrawTextLayout: draw subset of chunk: firstChar > 0} { .b.c select from text 2 .b.c select to text 2 } {} -test font-20.6 {Tk_DrawTextLayout: draw subset of chunk: lastChar < numChars} { +test font-26.6 {Tk_DrawTextLayout: draw subset of chunk: lastChar < numChars} { .b.c select from text 4 .b.c select to text 4 } {} -test font-21.1 {Tk_UnderlineTextLayout procedure: no underline chosen} { +test font-27.1 {Tk_UnderlineTextLayout procedure: no underline chosen} { .b.f config -text "foo" -under -1 } {} -test font-21.2 {Tk_UnderlineTextLayout procedure: underline not visible} { +test font-27.2 {Tk_UnderlineTextLayout procedure: underline not visible} { .b.f config -text "000 00000" -wrap [expr $ax*7] -under 10 } {} -test font-21.3 {Tk_UnderlineTextLayout procedure: underline is visible} { +test font-27.3 {Tk_UnderlineTextLayout procedure: underline is visible} { .b.f config -text "000 00000" -wrap [expr $ax*7] -under 5 .b.f config -wrap -1 -under -1 } {} -test font-22.1 {Tk_PointToChar procedure: above all lines} { +test font-28.1 {Tk_PointToChar procedure: above all lines} { csetup "000" .b.c index text @-1,0 } {0} -test font-22.2 {Tk_PointToChar procedure: no chars} { +test font-28.2 {Tk_PointToChar procedure: no chars} { # After fixing the following bug: # # In canvas text item, it was impossible to click to position the @@ -678,103 +922,103 @@ test font-22.2 {Tk_PointToChar procedure: no chars} { csetup "" .b.c index text @100,100 } {0} -test font-22.3 {Tk_PointToChar procedure: loop test} { +test font-28.3 {Tk_PointToChar procedure: loop test} { csetup "000\n000\n000\n000" .b.c index text @10000,0 } {3} -test font-22.4 {Tk_PointToChar procedure: intersect line} { +test font-28.4 {Tk_PointToChar procedure: intersect line} { csetup "000\n000\n000" .b.c index text @0,$ay } {4} -test font-22.5 {Tk_PointToChar procedure: to the left of all chunks} { +test font-28.5 {Tk_PointToChar procedure: to the left of all chunks} { .b.c index text @-100,$ay } {4} -test font-22.6 {Tk_PointToChar procedure: past any possible chunk} { +test font-28.6 {Tk_PointToChar procedure: past any possible chunk} { .b.c index text @100000,$ay } {7} -test font-22.7 {Tk_PointToChar procedure: which chunk on this line} { +test font-28.7 {Tk_PointToChar procedure: which chunk on this line} { csetup "000\n000\t000\t000\n000" .b.c index text @[expr $ax*2],$ay } {6} -test font-22.8 {Tk_PointToChar procedure: which chunk on this line} { +test font-28.8 {Tk_PointToChar procedure: which chunk on this line} { csetup "000\n000\t000\t000\n000" .b.c index text @[expr $ax*10],$ay } {10} -test font-22.9 {Tk_PointToChar procedure: in special chunk} { +test font-28.9 {Tk_PointToChar procedure: in special chunk} { csetup "000\n000\t000\t000\n000" .b.c index text @[expr $ax*6],$ay } {7} -test font-22.10 {Tk_PointToChar procedure: past all chars in chunk} { +test font-28.10 {Tk_PointToChar procedure: past all chars in chunk} { csetup "000 0000000" .b.c itemconfig text -width [expr $ax*5] set x [.b.c index text @[expr $ax*5],0] .b.c itemconfig text -width 0 set x } {3} -test font-22.11 {Tk_PointToChar procedure: below all chunks} { +test font-28.11 {Tk_PointToChar procedure: below all chunks} { csetup "000 0000000" .b.c index text @0,1000000 } {11} -test font-23.1 {Tk_CharBBox procedure: index < 0} { +test font-29.1 {Tk_CharBBox procedure: index < 0} { .b.f config -text "000" -underline -1 } {} -test font-23.2 {Tk_CharBBox procedure: loop} { +test font-29.2 {Tk_CharBBox procedure: loop} { .b.f config -text "000\t000\t000\t000" -underline 9 } {} -test font-23.3 {Tk_CharBBox procedure: special char} { +test font-29.3 {Tk_CharBBox procedure: special char} { .b.f config -text "000\t000\t000" -underline 7 } {} -test font-23.4 {Tk_CharBBox procedure: normal char} { +test font-29.4 {Tk_CharBBox procedure: normal char} { .b.f config -text "000" -underline 1 } {} -test font-23.5 {Tk_CharBBox procedure: right edge of bbox truncated} { +test font-29.5 {Tk_CharBBox procedure: right edge of bbox truncated} { .b.f config -text "0 0000" -wrap [expr $ax*4] -under 2 .b.f config -wrap 0 } {} -test font-23.6 {Tk_CharBBox procedure: bbox pegged to right edge} { +test font-29.6 {Tk_CharBBox procedure: bbox pegged to right edge} { .b.f config -text "0 0000" -wrap [expr $ax*4] -under 3 .b.f config -wrap 0 } {} .b.c bind all <Enter> {lappend x [.b.c index current @%x,%y]} -test font-24.1 {Tk_TextLayoutToPoint procedure: loop once} { +test font-30.1 {Tk_DistanceToTextLayout procedure: loop once} { csetup "000\n000\n000" set x {} event generate .b.c <Leave> event generate .b.c <Enter> -x 0 -y 0 set x } {0} -test font-24.2 {Tk_TextLayoutToPoint procedure: loop multiple} { +test font-30.2 {Tk_DistanceToTextLayout procedure: loop multiple} { csetup "000\n000\n000" set x {} event generate .b.c <Leave> event generate .b.c <Enter> -x $ax -y $ay set x } {5} -test font-24.3 {Tk_TextLayoutToPoint procedure: loop to end} { +test font-30.3 {Tk_DistanceToTextLayout procedure: loop to end} { csetup "000\n0\n000" set x {} event generate .b.c <Leave> event generate .b.c <Enter> -x [expr $ax*2] -y $ay set x } {} -test font-24.4 {Tk_TextLayoutToPoint procedure: hit a special char (tab)} { +test font-30.4 {Tk_DistanceToTextLayout procedure: hit a special char (tab)} { csetup "000\t000\n000" set x {} event generate .b.c <Leave> event generate .b.c <Enter> -x [expr $ax*6] -y 0 set x } {3} -test font-24.5 {Tk_TextLayoutToPoint procedure: ignore newline} { +test font-30.5 {Tk_DistanceToTextLayout procedure: ignore newline} { csetup "000\n0\n000" set x {} event generate .b.c <Leave> event generate .b.c <Enter> -x [expr $ax*2] -y $ay set x } {} -test font-24.6 {Tk_TextLayoutToPoint procedure: ignore spaces at eol} { +test font-30.6 {Tk_DistanceToTextLayout procedure: ignore spaces at eol} { csetup "000\n000 000000000" .b.c itemconfig text -width [expr $ax*10] set x {} @@ -784,42 +1028,42 @@ test font-24.6 {Tk_TextLayoutToPoint procedure: ignore spaces at eol} { set x } {} .b.c itemconfig text -justify center -test font-24.7 {Tk_TextLayoutToPoint procedure: on left side} { +test font-30.7 {Tk_DistanceToTextLayout procedure: on left side} { csetup "0\n000" set x {} event generate .b.c <Leave> event generate .b.c <Enter> -x 0 -y 0 set x } {} -test font-24.8 {Tk_TextLayoutToPoint procedure: on right side} { +test font-30.8 {Tk_DistanceToTextLayout procedure: on right side} { csetup "0\n000" set x {} event generate .b.c <Leave> event generate .b.c <Enter> -x [expr $ax*2] -y 0 set x } {} -test font-24.9 {Tk_TextLayoutToPoint procedure: inside line} { +test font-30.9 {Tk_DistanceToTextLayout procedure: inside line} { csetup "0\n000" set x {} event generate .b.c <Leave> event generate .b.c <Enter> -x $ax -y 0 set x } {0} -test font-24.10 {Tk_TextLayoutToPoint procedure: above line} { +test font-30.10 {Tk_DistanceToTextLayout procedure: above line} { csetup "0\n000" set x {} event generate .b.c <Leave> event generate .b.c <Enter> -x 0 -y 0 set x } {} -test font-24.11 {Tk_TextLayoutToPoint procedure: below line} { +test font-30.11 {Tk_DistanceToTextLayout procedure: below line} { csetup "000\n0" set x {} event generate .b.c <Leave> event generate .b.c <Enter> -x 0 -y $ay set x } {} -test font-24.12 {Tk_TextLayoutToPoint procedure: in line} { +test font-30.12 {Tk_DistanceToTextLayout procedure: in line} { csetup "0\n000" set x {} event generate .b.c <Leave> @@ -827,7 +1071,7 @@ test font-24.12 {Tk_TextLayoutToPoint procedure: in line} { set x } {3} .b.c itemconfig text -justify left -test font-24.13 {Tk_TextLayoutToPoint procedure: exact hit} { +test font-30.13 {Tk_DistanceToTextLayout procedure: exact hit} { csetup "000" set x {} event generate .b.c <Leave> @@ -835,27 +1079,27 @@ test font-24.13 {Tk_TextLayoutToPoint procedure: exact hit} { set x } {1} -test font-25.1 {Tk_TextLayoutToArea procedure: loop once} { +test font-31.1 {Tk_IntersectTextLayout procedure: loop once} { csetup "000\n000\n000" .b.c find overlapping 0 0 0 0 } [.b.c find withtag text] -test font-25.2 {Tk_TextLayoutToArea procedure: loop multiple} { +test font-31.2 {Tk_IntersectTextLayout procedure: loop multiple} { csetup "000\t000\t000" .b.c find overlapping [expr $ax*10] 0 [expr $ax*10] 0 } [.b.c find withtag text] -test font-25.3 {Tk_TextLayoutToArea procedure: loop to end} { +test font-31.3 {Tk_IntersectTextLayout procedure: loop to end} { csetup "0\n000" .b.c find overlapping [expr $ax*2] 0 [expr $ax*2] 0 } {} -test font-25.4 {Tk_TextLayoutToArea procedure: hit a special char (tab)} { +test font-31.4 {Tk_IntersectTextLayout procedure: hit a special char (tab)} { csetup "000\t000" .b.c find overlapping [expr $ax*6] 0 [expr $ax*6] 0 } [.b.c find withtag text] -test font-25.5 {Tk_TextLayoutToArea procedure: ignore newlines} { +test font-31.5 {Tk_IntersectTextLayout procedure: ignore newlines} { csetup "000\n0\n000" .b.c find overlapping $ax $ay $ax $ay } {} -test font-25.6 {Tk_TextLayoutToArea procedure: ignore spaces at eol} { +test font-31.6 {Tk_IntersectTextLayout procedure: ignore spaces at eol} { csetup "000\n000 000000000" .b.c itemconfig text -width [expr $ax*10] set x [.b.c find overlapping [expr $ax*5] $ay [expr $ax*5] $ay] @@ -863,7 +1107,7 @@ test font-25.6 {Tk_TextLayoutToArea procedure: ignore spaces at eol} { set x } {} -test font-26.1 {Tk_TextLayoutToPostscript: ensure buffer doesn't overflow} { +test font-32.1 {Tk_TextLayoutToPostscript: ensure buffer doesn't overflow} { # If there were a whole bunch of returns or tabs in a row, then the # temporary buffer could overflow and write on the stack. @@ -910,29 +1154,19 @@ test font-26.1 {Tk_TextLayoutToPostscript: ensure buffer doesn't overflow} { (end) } -test font-27.1 {Tk_TextWidth procedure} { - font measure [.b.l cget -font] "000" -} [expr $ax*3] - -test font-28.1 {SetupFontMetrics procedure} { - setup - .b.f config -font $fixed +test font-33.1 {Tk_TextWidth procedure} { } {} -test font-29.1 {TkInitFontAttributes procedure} { +test font-33.2 {ConfigAttributesObj procedure: arguments} { + # (Tcl_GetIndexFromObj() != TCL_OK) setup - font create xyz - font config xyz -} {-family {} -size 0 -weight normal -slant roman -underline 0 -overstrike 0} - -test font-30.1 {ConfigAttributes procedure: arguments} { + list [catch {font create xyz -xyz} msg] $msg +} {1 {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}} +test font-34.1 {ConfigAttributesObj procedure: arguments} { + # (objc & 1) setup list [catch {font create xyz -family} msg] $msg -} {1 {missing value for "-family" option}} -test font-30.2 {ConfigAttributes procedure: arguments} { - setup - list [catch {font create xyz -xyz xyz} msg] $msg -} {1 {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}} +} {1 {value for "-family" option missing}} set i 3 foreach p { {family xyz times} @@ -943,7 +1177,7 @@ foreach p { {overstrike 0 1} } { set opt [lindex $p 0] - test font-30.$i "ConfigAttributes procedure: $opt" { + test font-34.$i "ConfigAttributesObj procedure: $opt" { setup set x {} font create xyz -$opt [lindex $p 1] @@ -955,27 +1189,37 @@ foreach p { } foreach p { {size xyz {1 {expected integer but got "xyz"}}} - {weight xyz {1 {bad -weight value "xyz": must be normal, bold}}} - {slant xyz {1 {bad -slant value "xyz": must be roman, italic}}} + {weight xyz {1 {bad -weight value "xyz": must be normal, or bold}}} + {slant xyz {1 {bad -slant value "xyz": must be roman, or italic}}} {underline xyz {1 {expected boolean value but got "xyz"}}} {overstrike xyz {1 {expected boolean value but got "xyz"}}} } { - test font-30.$i "ConfigAttributes procedure: [lindex $p 0]" { + test font-34.$i "ConfigAttributesObj procedure: [lindex $p 0]" { setup list [catch {font create xyz -[lindex $p 0] [lindex $p 1]} msg] $msg } [lindex $p 2] incr i } -test font-31.1 {GetAttributeInfo procedure: error} { - list [catch {font actual xyz -style} msg] $msg -} {1 {bad option "-style": must be -family, -size, -weight, -slant, -underline, or -overstrike}} -test font-31.2 {GetAttributeInfo procedure: all attributes} { +test font-35.1 {GetAttributeInfoObj procedure: one attribute} { + # (objPtr != NULL) + setup + font create xyz -family xyz + font config xyz -family +} {xyz} +test font-36.1 {GetAttributeInfoObj procedure: unknown attribute} { + # (Tcl_GetIndexFromObj() != TCL_OK) + setup + font create xyz + list [catch {font config xyz -xyz} msg] $msg +} {1 {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}} +test font-37.1 {GetAttributeInfoObj procedure: all attributes} { + # not (objPtr != NULL) setup font create xyz -family xyz font config xyz } {-family xyz -size 0 -weight normal -slant roman -underline 0 -overstrike 0} -set i 3 +set i 4 foreach p { {family xyz xyz} {size 20 20} @@ -993,100 +1237,137 @@ foreach p { } # In tests below, one field is set to "xyz" so that font name doesn't -# look like a native X font, so that ParseFontName or TkParseXLFD will +# look like a native X font, so that ParseFontNameObj or TkParseXLFD will # be called. setup -test font-32.1 {ParseFontName procedure: begins with -} { +test font-38.1 {ParseFontNameObj procedure: begins with -} { lindex [font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-*] 1 } $times -test font-32.2 {ParseFontName procedure: begins with -*} { +test font-38.2 {ParseFontNameObj procedure: begins with -*} { lindex [font actual -*-times-xyz-*-*-*-*-*-*-*-*-*-*-*] 1 } $times -test font-32.3 {ParseFontName procedure: begins with -, doesn't look like list} { +test font-38.3 {ParseFontNameObj procedure: begins with -, doesn't look like list} { lindex [font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-*] 1 } $times -test font-32.4 {ParseFontName procedure: begins with -, looks like list} { +test font-38.4 {ParseFontNameObj procedure: begins with -, looks like list} { lindex [font actual {-family times}] 1 } $times -test font-32.5 {ParseFontName procedure: begins with *} { +test font-38.5 {ParseFontNameObj procedure: begins with *} { lindex [font actual *-times-xyz-*-*-*-*-*-*-*-*-*-*-*] 1 } $times -test font-32.6 {ParseFontName procedure: begins with *} { +test font-38.6 {ParseFontNameObj procedure: begins with *} { font actual *-times-xyz -family } $times -test font-32.7 {ParseFontName procedure: arguments} { - list [catch {font actual {}} msg] $msg +test font-38.7 {ParseFontNameObj procedure: arguments} { + list [catch {font actual "\{xyz"} msg] $msg +} [list 1 "font \"{xyz\" doesn't exist"] +test font-38.8 {ParseFontNameObj procedure: arguments} { + list [catch {font actual ""} msg] $msg } {1 {font "" doesn't exist}} -test font-32.8 {ParseFontName procedure: arguments} { +test font-38.9 {ParseFontNameObj procedure: arguments} { list [catch {font actual {times 20 xyz xyz}} msg] $msg } {1 {unknown font style "xyz"}} -test font-32.9 {ParseFontName procedure: arguments} { +test font-38.10 {ParseFontNameObj procedure: arguments} { list [catch {font actual {times xyz xyz}} msg] $msg } {1 {expected integer but got "xyz"}} -test font-32.10 {ParseFontName procedure: stylelist loop} {macOnly} { +test font-38.11 {ParseFontNameObj procedure: stylelist loop} {macOnly} { lrange [font actual {times 12 bold italic overstrike underline}] 4 end } {-weight bold -slant italic -underline 1 -overstrike 0} -test font-32.11 {ParseFontName procedure: stylelist loop} {unixOrPc} { +test font-38.12 {ParseFontNameObj procedure: stylelist loop} {unixOrPc} { lrange [font actual {times 12 bold italic overstrike underline}] 4 end } {-weight bold -slant italic -underline 1 -overstrike 1} -test font-32.12 {ParseFontName procedure: stylelist error} { +test font-38.13 {ParseFontNameObj procedure: stylelist error} { list [catch {font actual {times 12 bold xyz}} msg] $msg } {1 {unknown font style "xyz"}} -test font-33.1 {TkParseXLFD procedure: initial dash} { +test font-39.1 {NewChunk procedure: test realloc} { + .b.f config -text "xxx\nxxx\txxx\nxxx\t\t\t" +} {} + +test font-40.1 {TkFontParseXLFD procedure: initial dash} { font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-* -family } $times -test font-33.2 {TkParseXLFD procedure: no initial dash} { +test font-40.2 {TkFontParseXLFD procedure: no initial dash} { font actual *-times-*-*-*-*-*-*-*-*-*-*-*-xyz -family } $times -test font-33.3 {TkParseXLFD procedure: not enough fields} { +test font-40.3 {TkFontParseXLFD procedure: not enough fields} { font actual -xyz-times-*-*-* -family } $times -test font-33.4 {TkParseXLFD procedure: all fields unspecified} { +test font-40.4 {TkFontParseXLFD procedure: all fields unspecified} { lindex [font actual -xyz-*-*-*-*-*-*-*-*-*-*-*-*-*] 0 } {-family} -test font-33.5 {TkParseXLFD procedure: all fields specified} { +test font-40.5 {TkFontParseXLFD procedure: all fields specified} { lindex [font actual -foundry-times-weight-slant-setwidth-addstyle-10-10-10-10-spacing-avgwidth-registry-encoding] 1 } $times -test font-33.6 {TkParseXLFD procedure: arguments} { +test font-41.1 {TkParseXLFD procedure: arguments} { # XLFD with bad pointsize: fallback to some system font. font actual -*-*-*-*-*-*-xyz-*-*-*-*-*-*-* set x {} } {} -test font-33.7 {TkParseXLFD procedure: arguments} { +test font-42.1 {TkFontParseXLFD procedure: arguments} { # XLFD with bad pixelsize: fallback to some system font. font actual -*-*-*-*-*-*-*-xyz-*-*-*-*-*-* set x {} } {} -test font-33.8 {TkParseXLFD procedure: pixelsize specified} { +test font-42.2 {TkFontParseXLFD procedure: pixelsize specified} { font metrics -xyz-times-*-*-*-*-12-*-*-*-*-*-*-* -linespace set x {} } {} -test font-33.9 {TkParseXLFD procedure: weird pixelsize specified} { +test font-42.3 {TkFontParseXLFD procedure: weird pixelsize specified} { font metrics {-xyz-times-*-*-*-*-[ 12.0 0 12.0 0]-*-*-*-*-*-*-*} -linespace set x {} } {} -test font-33.10 {TkParseXLFD procedure: pointsize specified} { +test font-42.4 {TkFontParseXLFD procedure: pointsize specified} { font metrics -xyz-times-*-*-*-*-*-120-*-*-*-*-*-* -linespace set x {} } {} -test font-33.11 {TkParseXLFD procedure: weird pointsize specified} { +test font-42.5 {TkFontParseXLFD procedure: weird pointsize specified} { font metrics {-xyz-times-*-*-*-*-*-[ 12.0 0 12.0 0]-*-*-*-*-*-*} -linespace set x {} } {} -test font-34.1 {FieldSpecified procedure: specified vs. non-specified} { +test font-43.1 {FieldSpecified procedure: specified vs. non-specified} { font actual -xyz--*-*-*-*-*-*-*-*-*-*-*-* font actual -xyz-*-*-*-*-*-*-*-*-*-*-*-*-* font actual -xyz-?-*-*-*-*-*-*-*-*-*-*-*-* lindex [font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-*] 1 } $times -test font-35.1 {NewChunk procedure: test realloc} { - .b.f config -text "xxx\nxxx\txxx\nxxx\t\t\t" -} {} +set oldscale [tk scaling] +tk scaling 0.5 +test font-44.1 {TkFontGetPixels: size < 0} { + font actual {times -12} -size +} {24} +test font-44.2 {TkFontGetPixels: size >= 0} { + font actual {times 12} -size +} {12} + +test font-45.1 {TkFontGetPoints: size >= 0} { + font actual {times 12} -size +} {12} +test font-45.2 {TkFontGetPoints: size < 0} { + font actual {times -12} -size +} {24} + +tk scaling $oldscale + +test font-46.1 {TkFontGetAliasList: no match} { + font actual {snarky 10} -family +} [font actual {-size 10} -family] +test font-46.2 {TkFontGetAliasList: match} {macOnly} { + # Result could be either "Times" or "New York" + font actual {{times new roman} 10} -family +} [font actual {times 10} -family] +test font-46.3 {TkFontGetAliasList: match} {pcOnly} { + font actual {times 10} -family +} {Times New Roman} +test font-46.4 {TkFontGetAliasList: match} {unixOnly} { + font actual {{times new roman} 10} -family +} [font actual {times 10} -family] + +setup destroy .b return diff --git a/tests/get.test b/tests/get.test new file mode 100644 index 0000000..9c57128 --- /dev/null +++ b/tests/get.test @@ -0,0 +1,81 @@ +# 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. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) get.test 1.1 97/12/24 16:16:50 + +if {[info procs test] != "test"} { + source defs +} + +eval destroy [winfo children .] +wm geometry . {} +raise . + +button .b +test get-1.1 {Tk_GetAnchorFromObj} { + .b configure -anchor n + .b cget -anchor +} {n} +test get-1.2 {Tk_GetAnchorFromObj} { + .b configure -anchor ne + .b cget -anchor +} {ne} +test get-1.3 {Tk_GetAnchorFromObj} { + .b configure -anchor e + .b cget -anchor +} {e} +test get-1.4 {Tk_GetAnchorFromObj} { + .b configure -anchor se + .b cget -anchor +} {se} +test get-1.5 {Tk_GetAnchorFromObj} { + .b configure -anchor s + .b cget -anchor +} {s} +test get-1.6 {Tk_GetAnchorFromObj} { + .b configure -anchor sw + .b cget -anchor +} {sw} +test get-1.7 {Tk_GetAnchorFromObj} { + .b configure -anchor w + .b cget -anchor +} {w} +test get-1.8 {Tk_GetAnchorFromObj} { + .b configure -anchor nw + .b cget -anchor +} {nw} +test get-1.9 {Tk_GetAnchorFromObj} { + .b configure -anchor n + .b cget -anchor +} {n} +test get-1.10 {Tk_GetAnchorFromObj} { + .b configure -anchor center + .b cget -anchor +} {center} +test get-1.11 {Tk_GetAnchorFromObj - error} { + list [catch {.b configure -anchor unknown} msg] $msg +} {1 {bad anchor "unknown": must be n, ne, e, se, s, sw, w, nw, or center}} + +catch {destroy .b} +button .b +test get-2.1 {Tk_GetJustifyFromObj} { + .b configure -justify left + .b cget -justify +} {left} +test get-2.2 {Tk_GetJustifyFromObj} { + .b configure -justify right + .b cget -justify +} {right} +test get-2.3 {Tk_GetJustifyFromObj} { + .b configure -justify center + .b cget -justify +} {center} +test get-2.4 {Tk_GetJustifyFromObj - error} { + list [catch {.b configure -justify stupid} msg] $msg +} {1 {bad justification "stupid": must be left, right, or center}} diff --git a/tests/macFont.test b/tests/macFont.test index aa342a6..bafbb8e 100644 --- a/tests/macFont.test +++ b/tests/macFont.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) macFont.test 1.5 97/05/05 14:21:05 +# SCCS: @(#) macFont.test 1.8 97/12/24 15:26:20 if {$tcl_platform(platform)!="macintosh"} { return @@ -25,10 +25,11 @@ catch {destroy .b} toplevel .b update idletasks -set courier {Courier 10} +set courier {Courier 12} set cx [font measure $courier 0] -label .b.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left -text "0" -font "Monaco 9" +set fixed {Monaco 12} +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 @@ -43,125 +44,226 @@ proc getsize {} { return "[winfo reqwidth .b.l] [winfo reqheight .b.l]" } -test macfont-1.1 {TkpGetNativeFont procedure: not native} { +set testConfig(gothic) 0 +set gothic {gothic 12} +set mx [font measure $gothic \u4e4e] +if {[font actual $gothic -family] != [font actual system -family]} { + set testConfig(gothic) 1 +} + +test macFont-1.1 {TkpFontPkgInit} { +} {} + +test macfont-2.1 {TkpGetNativeFont: not native} { list [catch {font measure {} xyz} msg] $msg } {1 {font "" doesn't exist}} -test macfont-1.2 {TkpGetNativeFont procedure: native} { +test macFont-2.2 {TkpGetNativeFont: native} { font measure system "0" font measure application "0" set x {} } {} -test macfont-2.1 {TkpGetFontFromAttributes procedure: no family} { +test macFont-3.1 {TkpGetFontFromAttributes: no family} { font actual {-underline 1} -family } [font actual system -family] -test macfont-2.2 {TkpGetFontFromAttributes procedure: long family name} { +test macFont-3.2 {TkpGetFontFromAttributes: long family name} { set x "12345678901234567890123456789012345678901234567890" set x "$x$x$x$x$x$x" font actual "-family $x" -family } [font actual system -family] -test macfont-2.3 {TkpGetFontFromAttributes procedure: family} { +test macFont-3.3 {TkpGetFontFromAttributes: family} { font actual {-family Courier} -family } {Courier} -test macfont-2.4 {TkpGetFontFromAttributes procedure: Times fonts} { +test macFont-3.4 {TkpGetFontFromAttributes: Times fonts} { set x {} lappend x [font actual {-family "Times"} -family] lappend x [font actual {-family "Times New Roman"} -family] } {Times Times} -test macfont-2.5 {TkpGetFontFromAttributes procedure: Courier fonts} { +test macFont-3.5 {TkpGetFontFromAttributes: Courier fonts} { set x {} lappend x [font actual {-family "Courier"} -family] lappend x [font actual {-family "Courier New"} -family] } {Courier Courier} -test macfont-2.6 {TkpGetFontFromAttributes procedure: Helvetica fonts} { +test macFont-3.6 {TkpGetFontFromAttributes: Helvetica fonts} { set x {} lappend x [font actual {-family "Geneva"} -family] lappend x [font actual {-family "Helvetica"} -family] lappend x [font actual {-family "Arial"} -family] } {Geneva Helvetica Helvetica} -test macfont-2.7 {TkpGetFontFromAttributes procedure: styles} { +test macFont-3.7 {TkpGetFontFromAttributes: try aliases} { + font actual {arial 10} -family +} {Helvetica} +test macFont-3.8 {TkpGetFontFromAttributes: try fallbacks} { + font actual {{ms sans serif} 10} -family +} {Chicago} +test macFont-3.9 {TkpGetFontFromAttributes: styles} { font actual {-weight normal} -weight } {normal} -test macfont-2.8 {TkpGetFontFromAttributes procedure: styles} { +test macFont-3.10 {TkpGetFontFromAttributes: styles} { font actual {-weight bold} -weight } {bold} -test macfont-2.9 {TkpGetFontFromAttributes procedure: styles} { +test macFont-3.11 {TkpGetFontFromAttributes: styles} { font actual {-slant roman} -slant } {roman} -test macfont-2.10 {TkpGetFontFromAttributes procedure: styles} { +test macFont-3.12 {TkpGetFontFromAttributes: styles} { font actual {-slant italic} -slant } {italic} -test macfont-2.11 {TkpGetFontFromAttributes procedure: styles} { +test macFont-3.13 {TkpGetFontFromAttributes: styles} { font actual {-underline false} -underline } {0} -test macfont-2.12 {TkpGetFontFromAttributes procedure: styles} { +test macFont-3.14 {TkpGetFontFromAttributes: styles} { font actual {-underline true} -underline } {1} -test macfont-2.13 {TkpGetFontFromAttributes procedure: styles} { +test macFont-3.15 {TkpGetFontFromAttributes: styles} { font actual {-overstrike false} -overstrike } {0} -test macfont-2.14 {TkpGetFontFromAttributes procedure: styles} { +test macFont-3.16 {TkpGetFontFromAttributes: styles} { font actual {-overstrike true} -overstrike } {0} -test macfont-3.1 {TkpDeleteFont procedure} { +test macFont-4.1 {TkpDeleteFont} { font actual {-family xyz} set x {} } {} -test macfont-4.1 {TkpGetFontFamilies procedure} { - font families - set x {} -} {} +test macFont-5.1 {TkpGetFontFamilies} { + expr {[lsearch [font families] Geneva] > 0} +} {1} -test macfont-5.1 {Tk_MeasureChars procedure: unbounded right margin} { +test macFont-6.1 {TkpGetSubFonts} {gothic} { + .b.l config -text "abc\u4e4e" + update + set x [testfont subfonts $fixed] +} "Monaco [font actual $gothic -family]" + +test macFont-7.1 {Tk_MeasureChars: unbounded right margin} { .b.l config -wrap 0 -text "000000" getsize } "[expr $ax*6] $ay" -test macfont-5.2 {Tk_MeasureChars procedure: static width buffer exceeded} { +test macFont-7.2 {Tk_MeasureChars: static width buffer exceeded} { .b.l config -wrap 100000 -text "0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000" getsize } "[expr $ax*256] $ay" -test macfont-5.3 {Tk_MeasureChars procedure: all chars did fit} { +test macFont-7.3 {Tk_MeasureChars: all chars did fit} { .b.l config -wrap [expr $ax*10] -text "00000000" getsize } "[expr $ax*8] $ay" -test macfont-5.4 {Tk_MeasureChars procedure: not all chars fit} { +test macFont-7.4 {Tk_MeasureChars: not all chars fit} { .b.l config -wrap [expr $ax*6] -text "00000000" getsize } "[expr $ax*6] [expr $ay*2]" -test macfont-5.5 {Tk_MeasureChars procedure: already saw space in line} { +test macFont-7.5 {Tk_MeasureChars: already saw space in line} { .b.l config -wrap [expr $ax*12] -text "000000 0000000" getsize } "[expr $ax*7] [expr $ay*2]" -test macfont-5.6 {Tk_MeasureChars procedure: internal spaces significant} { +test macFont-7.6 {Tk_MeasureChars: internal spaces significant} { .b.l config -wrap [expr $ax*12] -text "000 00 00000" getsize } "[expr $ax*7] [expr $ay*2]" -test macfont-5.7 {Tk_MeasureChars procedure: include last partial char} { +test macFont-7.7 {Tk_MeasureChars: include last partial char} { .b.c dchars $t 0 end .b.c insert $t 0 "0000" .b.c index $t @[expr int($ax*2.5)],1 } {2} -test macfont-5.8 {Tk_MeasureChars procedure: at least one char on line} { +test macFont-7.8 {Tk_MeasureChars: at least one char on line} { .b.l config -text "000000" -wrap 1 getsize } "$ax [expr $ay*6]" -test macfont-5.9 {Tk_MeasureChars procedure: whole words} { +test macFont-7.9 {Tk_MeasureChars: whole words} { .b.l config -wrap [expr $ax*8] -text "000000 0000" getsize } "[expr $ax*6] [expr $ay*2]" -test macfont-5.10 {Tk_MeasureChars procedure: make first part of word fit} { +test macFont-7.10 {Tk_MeasureChars: make first part of word fit} { .b.l config -wrap [expr $ax*12] -text "0000000000000000" getsize } "[expr $ax*12] [expr $ay*2]" +test macFont-7.11 {Tk_MeasureChars: numBytes == 0} { + font measure system {} +} {0} +test macFont-7.12 {Tk_MeasureChars: maxLength < 0} { + font measure $courier abcd +} "[expr $cx*4]" +test macFont-7.13 {Tk_MeasureChars: loop on each char} { + font measure $courier abcd +} "[expr $cx*4]" +test macFont-7.14 {Tk_MeasureChars: p == end} { + font measure $courier abcd +} "[expr $cx*4]" +test macFont-7.15 {Tk_MeasureChars: p > end} { + font measure $courier abc\xc2 +} "[expr $cx*4]" +test macFont-7.16 {Tk_MeasureChars: thisFamilyPtr != lastFamilyPtr} {gothic} { + font measure $courier abc\u4e4edef +} [expr $cx*6+$mx] +test macFont-7.17 {Tk_MeasureChars: measure no chars (in loop)} {gothic} { + font measure $courier \u4e4edef +} [expr $mx+$cx*3] +test macFont-7.18 {Tk_MeasureChars: final measure} {gothic} { + font measure $courier \u4e4edef +} [expr $mx+$cx*3] +test macFont-7.19 {Tk_MeasureChars: final measure (no chars)} {gothic} { + font measure $courier \u4e4e +} [expr $mx] +test macFont-7.20 {Tk_MeasureChars: maxLength >= 0} { + .b.l config -wrap [expr $ax*8] -text "000" + getsize +} "[expr $ax*3] $ay" +test macFont-7.21 {Tk_MeasureChars: loop on each char} { + .b.l config -wrap [expr $ax*8] -text "000" + getsize +} "[expr $ax*3] $ay" +test macFont-7.22 {Tk_MeasureChars: p == end} { + .b.l config -wrap [expr $ax*8] -text "000" + getsize +} "[expr $ax*3] $ay" +test macFont-7.23 {Tk_MeasureChars: p > end} { + .b.l config -wrap [expr $ax*8] -text "00\xc2" + getsize +} "[expr $ax*3] $ay" +test macFont-7.24 {Tk_MeasureChars: thisFamilyPtr != lastFamilyPtr} {gothic} { + .b.l config -wrap [expr $ax*8] -text "00\u4e4e00" + getsize +} "[expr $ax*4+$mx] $ay" +test macFont-7.25 {Tk_MeasureChars: measure no chars (in loop)} {gothic} { + .b.l config -wrap [expr $ax*8] -text "\u4e4e00" + getsize +} "[expr $mx+$ax*2] $ay" +test macFont-7.26 {Tk_MeasureChars: rest == NULL} {gothic} { + .b.l config -wrap [expr $ax*20] -text "000000\u4e4e\u4e4e00" + getsize +} "[expr $ax*8+$mx*2] $ay" +test macFont-7.27 {Tk_MeasureChars: rest != NULL in first segment} {gothic} { + .b.l config -wrap [expr $ax*5] -text "000000\u4e4e\u4e4f00" + getsize +} "[expr $ax*5] [expr $ay*3]" +test macFont-7.28 {Tk_MeasureChars: rest != NULL in next segment} {gothic} { + # even some of the "0"s would fit after \u4e4d, they should all wrap to next line. + .b.l config -wrap [expr $ax*8] -text "\u4e4d\u4e4d000000\u4e4e\u4e4f00" + getsize +} "[expr $ax*6+$mx] [expr $ay*3]" +test macFont-7.29 {Tk_MeasureChars: final measure} {gothic} { + .b.l config -wrap [expr $ax*8] -text "\u4e4e00" + getsize +} "[expr $mx+$ax*2] $ay" +test macFont-7.30 {Tk_MeasureChars: final measure (no chars)} {gothic} { + .b.l config -wrap [expr $ax*8] -text "\u4e4e" + getsize +} "$mx $ay" +test macFont-7.31 {Tk_MeasureChars: rest == NULL} { + .b.l config -wrap [expr $ax*1000] -text 0000 + getsize +} "[expr $ax*4] $ay" +test macFont-7.32 {Tk_MeasureChars: rest != NULL} { + .b.l config -wrap [expr $ax*6] -text "00000000" + getsize +} "[expr $ax*6] [expr $ay*2]" -test macfont-6.1 {Tk_DrawChars procedure} { +test macFont-8.1 {Tk_DrawChars procedure} { .b.l config -text "a" update } {} -test macfont-7.1 {AllocMacFont procedure: use old font} { +test macFont-9.1 {AllocMacFont: use old font} { font create xyz button .c -font xyz font configure xyz -family times @@ -169,13 +271,13 @@ test macfont-7.1 {AllocMacFont procedure: use old font} { destroy .c font delete xyz } {} -test macfont-7.2 {AllocMacFont procedure: extract info from style} { +test macFont-9.2 {AllocMacFont: extract info from style} { font actual {Monaco 9 bold italic underline overstrike} } {-family Monaco -size 9 -weight bold -slant italic -underline 1 -overstrike 0} -test macfont-7.3 {AllocMacFont procedure: extract text metrics} { +test macFont-9.3 {AllocMacFont: extract text metrics} { font metric {Geneva 10} -fixed } {0} -test macfont-7.4 {AllocMacFont procedure: extract text metrics} { +test macFont-9.4 {AllocMacFont: extract text metrics} { font metric "Monaco 9" -fixed } {1} diff --git a/tests/menu.test b/tests/menu.test index 3f54a8d..50a5b27 100644 --- a/tests/menu.test +++ b/tests/menu.test @@ -6,7 +6,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) menu.test 1.43 97/10/28 13:51:13 +# SCCS: @(#) menu.test 1.47 98/02/04 11:08:25 if {[lsearch [image types] test] < 0} { puts "This application hasn't been compiled with the \"test\" image" @@ -164,16 +164,16 @@ test menu-1.14 {Tk_MenuCmd procedure} { catch {destroy .m1} menu .m1 set i 1 -foreach test { +foreach configTest { {-activebackground #012345 #012345 non-existent {unknown color name "non-existent"}} - {-activeborderwidth 1.3 1 badValue {bad screen distance "badValue"}} + {-activeborderwidth 1.3 1.3 badValue {bad screen distance "badValue"}} {-activeforeground #ff0000 #ff0000 non-existent {unknown color name "non-existent"}} {-background #ff0000 #ff0000 non-existent {unknown color name "non-existent"}} {-bg #110022 #110022 bogus {unknown color name "bogus"}} - {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} + {-borderwidth 1.3 1.3 badValue {bad screen distance "badValue"}} {-cursor arrow arrow badValue {bad cursor spec "badValue"}} {-disabledforeground #00ff00 #00ff00 xyzzy {unknown color name "xyzzy"}} {-fg #110022 #110022 bogus {unknown color name "bogus"}} @@ -182,23 +182,27 @@ foreach test { {font "" doesn't exist}} {-foreground #110022 #110022 bogus {unknown color name "bogus"}} {-postcommand "any old string" "any old string" {} {}} - {-relief groove groove 1.5 {bad relief type "1.5": must be flat, groove, raised, ridge, solid, or sunken}} + {-relief groove groove 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}} {-selectcolor #110022 #110022 bogus {unknown color name "bogus"}} {-takefocus "any string" "any string" {} {}} {-tearoff 0 0} {-tearoff 1 1} {-tearoffcommand "any old string" "any old string" {} {}} } { - set name [lindex $test 0] - test menu-2.$i {configuration options} { - .m1 configure $name [lindex $test 1] + set name [lindex $configTest 0] + set value [lindex $configTest 1] + set result [lindex $configTest 2] + test menu-2.$i [list configuration options $name $value $result] { + .m1 configure $name $value lindex [.m1 configure $name] 4 - } [lindex $test 2] + } $result incr i - if {[lindex $test 3] != ""} { - test menu-2.$i {configuration options} { - list [catch {.m1 configure $name [lindex $test 3]} msg] $msg - } [list 1 [lindex $test 4]] + if {[lindex $configTest 3] != ""} { + set value [lindex $configTest 3] + set result [lindex $configTest 4] + test menu-2.$i [list configuration options $name $value $result] { + list [catch {.m1 configure $name $value} msg] $msg + } [list 1 $result] } .m1 configure $name [lindex [.m1 configure $name] 3] incr i @@ -221,7 +225,7 @@ menu .m2 .m1 add radiobutton -label "radiobutton" -variable radio image create photo image1 -file [file join $tk_library demos images earth.gif] -foreach test { +foreach configTest { {-activebackground {{#012345 {{unknown option "-activebackground"} #012345 #012345 @@ -240,7 +244,7 @@ foreach test { } {-activeforeground {{#ff0000 - {{unknown option "-activeforeground"} + {{unknown option "-activeforeground"} #ff0000 #ff0000 {unknown option "-activeforeground"} #ff0000 #ff0000 } } @@ -256,7 +260,7 @@ foreach test { } {-accelerator {{"Ctrl+S" - {{unknown option "-accelerator"} + {{unknown option "-accelerator"} "Ctrl+S" "Ctrl+S" {unknown option "-accelerator"} "Ctrl+S" "Ctrl+S" } @@ -279,8 +283,8 @@ foreach test { } {-bitmap {{questhead - {{unknown option "-bitmap"} questhead questhead - {unknown option "-bitmap"} questhead questhead + {{unknown option "-bitmap"} questhead questhead + {unknown option "-bitmap"} questhead questhead } } {badValue @@ -295,22 +299,23 @@ foreach test { } {-columnbreak {{1 - {{unknown option "-columnbreak"} 1 1 {unknown option "-columnbreak"} 1 1} + {{unknown option "-columnbreak"} 1 1 + {unknown option "-columnbreak"} 1 1} }} } {-command {{beep - {{unknown option "-command"} beep beep - {unknown option "-command"} beep beep + {{unknown option "-command"} beep beep + {unknown option "-command"} beep beep } }} } {-font {{-Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* - {{unknown option "-font"} + {{unknown option "-font"} -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* - {unknown option "-font"} + {unknown option "-font"} -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* } @@ -327,8 +332,8 @@ foreach test { } {-foreground {{#110022 - {{unknown option "-foreground"} #110022 #110022 - {unknown option "-foreground"} #110022 #110022 + {{unknown option "-foreground"} #110022 #110022 + {unknown option "-foreground"} #110022 #110022 } } {non-existent @@ -343,8 +348,8 @@ foreach test { } {-image {{image1 - {{unknown option "-image"} image1 image1 - {unknown option "-image"} image1 image1 + {{unknown option "-image"} image1 image1 + {unknown option "-image"} image1 image1 } } {bogus @@ -368,58 +373,58 @@ foreach test { } {-indicatoron {{1 - {{unknown option "-indicatoron"} - {unknown option "-indicatoron"} - {unknown option "-indicatoron"} - {unknown option "-indicatoron"} 1 1 + {{unknown option "-indicatoron"} + {unknown option "-indicatoron"} + {unknown option "-indicatoron"} + {unknown option "-indicatoron"} 1 1 } }} } {-label {{test - {{unknown option "-label"} test test - {unknown option "-label"} test test + {{unknown option "-label"} test test + {unknown option "-label"} test test } }} } {-menu {{.m2 - {{unknown option "-menu"} - {unknown option "-menu"} .m2 - {unknown option "-menu"} - {unknown option "-menu"} - {unknown option "-menu"} + {{unknown option "-menu"} + {unknown option "-menu"} .m2 + {unknown option "-menu"} + {unknown option "-menu"} + {unknown option "-menu"} } }} } {-offvalue {{off - {{unknown option "-offvalue"} - {unknown option "-offvalue"} + {{unknown option "-offvalue"} + {unknown option "-offvalue"} + {unknown option "-offvalue"} {unknown option "-offvalue"} - {unknown option "-offvalue"} off - {unknown option "-offvalue"} + {unknown option "-offvalue"} } }} } {-onvalue {{on - {{unknown option "-onvalue"} - {unknown option "-onvalue"} - {unknown option "-onvalue"} - {unknown option "-onvalue"} + {{unknown option "-onvalue"} + {unknown option "-onvalue"} + {unknown option "-onvalue"} + {unknown option "-onvalue"} on - {unknown option "-onvalue"} + {unknown option "-onvalue"} } }} } {-selectcolor {{#110022 - {{unknown option "-selectcolor"} - {unknown option "-selectcolor"} - {unknown option "-selectcolor"} - {unknown option "-selectcolor"} + {{unknown option "-selectcolor"} + {unknown option "-selectcolor"} + {unknown option "-selectcolor"} + {unknown option "-selectcolor"} #110022 #110022 } @@ -463,8 +468,7 @@ foreach test { } {-state {{normal - {normal normal normal - {unknown option "-state"} normal normal + {normal normal normal {unknown option "-state"} normal normal } }} } @@ -506,13 +510,13 @@ foreach test { }} } } { - set name [lindex $test 0] - foreach attempt [lindex $test 1] { + set name [lindex $configTest 0] + foreach attempt [lindex $configTest 1] { set value [lindex $attempt 0] set options [lindex $attempt 1] foreach item {0 1 2 3 4 5} { catch {unset msg} - test menu-2.$i [list entry configuration options $name $item $value] { + test menu-2.$i [list entry configuration options $name $item $value [.m1 type $item]] { set result [catch {.m1 entryconfigure $item $name $value} msg] if {$result == 1} { set msg @@ -551,21 +555,21 @@ test menu-3.4 {MenuWidgetCmd procedure, "activate" option} { menu .m1 list [catch {.m1 activate "foo"} msg] $msg [destroy .m1] } {1 {bad menu entry index "foo"} {}} -test menu-3.5 {MenuWidgetCmd procedure, "activate" option} { +test menu-3.5 {MenuWidgetCmd procedure, "activate" option} { catch {destroy .m1} menu .m1 .m1 add command -label "test" .m1 add separator list [catch {.m1 activate 2} msg] $msg [destroy .m1] } {0 {} {}} -test menu-3.6 {MenuWidgetCmd procedure, "activate" option} { +test menu-3.6 {MenuWidgetCmd procedure, "activate" option} { catch {destroy .m1} menu .m1 .m1 add command -label "test" .m1 entryconfigure 1 -state disabled list [catch {.m1 activate 1} msg] $msg [destroy .m1] } {0 {} {}} -test menu-3.7 {MenuWidgetCmd procedure, "activate" option} { +test menu-3.7 {MenuWidgetCmd procedure, "activate" option} { catch {destroy .m1} menu .m1 .m1 add command -label "test" @@ -913,19 +917,27 @@ test menu-3.67 {MenuWidgetCmd procedure, bad option} { list [catch {.m1 foo} msg] $msg [destroy .m1] } {1 {bad option "foo": must be activate, add, cget, clone, configure, delete, entrycget, entryconfigure, index, insert, invoke, post, postcascade, type, unpost, or yposition} {}} -test menu-4.1 {TkInvokeMenu} { +test menu-4.1 {TkInvokeMenu: disabled} { + catch {destroy .m1} + catch {unset foo} + menu .m1 + .m1 add checkbutton -label "test" -variable foo -onvalue on -offvalue off \ + -state disabled + list [catch {.m1 invoke 1} msg] [destroy .m1] $foo +} {0 {} off} +test menu-4.2 {TkInvokeMenu: tearoff} { catch {destroy .m1} menu .m1 list [catch {.m1 invoke 0} msg] [destroy .m1] } {0 {}} -test menu-4.2 {TkInvokeMenu} { +test menu-4.3 {TkInvokeMenu: checkbutton -on} { catch {destroy .m1} catch {unset foo} menu .m1 .m1 add checkbutton -label "test" -variable foo -onvalue on -offvalue off list [catch {.m1 invoke 1} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1] } {0 {} 0 on 0 {} {}} -test menu-4.3 {TkInvokeMenu} { +test menu-4.4 {TkInvokeMenu: checkbutton -off} { catch {destroy .m1} catch {unset foo} menu .m1 @@ -933,7 +945,14 @@ test menu-4.3 {TkInvokeMenu} { .m1 invoke 1 list [catch {.m1 invoke 1} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1] } {0 {} 0 off 0 {} {}} -test menu-4.4 {TkInvokeMenu} { +test menu-4.5 {TkInvokeMenu: checkbutton array element} { + catch {destroy .m1} + catch {unset foo} + menu .m1 + .m1 add checkbutton -label "test" -variable foo(1) -onvalue on + list [catch {.m1 invoke 1} msg] $msg [catch {set foo(1)} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1] +} {0 {} 0 on 0 {} {}} +test menu-4.6 {TkInvokeMenu: radiobutton} { catch {destroy .m1} catch {unset foo} menu .m1 @@ -942,7 +961,7 @@ test menu-4.4 {TkInvokeMenu} { .m1 add radiobutton -label "3" -variable foo -value three list [catch {.m1 invoke 1} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1] } {0 {} 0 one 0 {} {}} -test menu-4.5 {TkInvokeMenu} { +test menu-4.7 {TkInvokeMenu: radiobutton} { catch {destroy .m1} catch {unset foo} menu .m1 @@ -951,7 +970,7 @@ test menu-4.5 {TkInvokeMenu} { .m1 add radiobutton -label "3" -variable foo -value three list [catch {.m1 invoke 2} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1] } {0 {} 0 two 0 {} {}} -test menu-4.6 {TkInvokeMenu} { +test menu-4.8 {TkInvokeMenu: radiobutton} { catch {destroy .m1} catch {unset foo} menu .m1 @@ -960,20 +979,29 @@ test menu-4.6 {TkInvokeMenu} { .m1 add radiobutton -label "3" -variable foo -value three list [catch {.m1 invoke 3} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1] } {0 {} 0 three 0 {} {}} -test menu-4.7 {TkInvokeMenu} { +test menu-4.9 {TkInvokeMenu: radiobutton array element} { + catch {destroy .m1} + catch {unset foo} + menu .m1 + .m1 add radiobutton -label "1" -variable foo(2) -value one + .m1 add radiobutton -label "2" -variable foo(2) -value two + .m1 add radiobutton -label "3" -variable foo(2) -value three + list [catch {.m1 invoke 3} msg] $msg [catch {set foo(2)} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1] +} {0 {} 0 three 0 {} {}} +test menu-4.10 {TkInvokeMenu} { catch {destroy .m1} catch {unset menu_test} menu .m1 .m1 add command -label "test" -command "set menu_test menu-4.8" list [catch {.m1 invoke 1} msg] $msg [catch {set menu_test} msg2] $msg2 [catch {unset menu_test} msg3] $msg3 [destroy .m1] } {0 menu-4.8 0 menu-4.8 0 {} {}} -test menu-4.8 {TkInvokeMenu} { +test menu-4.11 {TkInvokeMenu} { catch {destroy .m1} menu .m1 .m1 add cascade -label "test" -menu .m1.m2 list [catch {.m1 invoke 1} msg] $msg [destroy .m1] } {0 {} {}} -test menu-4.9 {TkInvokeMenu} { +test menu-4.12 {TkInvokeMenu} { catch {destroy .m1} menu .m1 .m1 add command -label "test" -command ".m1 delete 1" @@ -1431,44 +1459,60 @@ test menu-9.9 {ConfigureMenu} { list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test menu-10.1 {ConfigureMenuEntry} { +test menu-10.1 {PostProcessEntry: array variable} { + catch {destroy .m1} + catch {unset foo} + menu .m1 + set foo(1) on + .m1 add checkbutton -variable foo(1) -onvalue on -offvalue off -label "Nonsense" + list [catch {set foo(1)} msg] $msg [destroy .m1] +} {0 on {}} +test menu-10.2 {PostProcessEntry: array variable} { + catch {destroy .m1} + catch {unset foo} + menu .m1 + .m1 add checkbutton -variable foo(1) -onvalue on -offvalue off -label "Nonsense" + list [catch {set foo(1)} msg] $msg [destroy .m1] +} {0 off {}} + +test menu-11.1 {ConfigureMenuEntry} { catch {destroy .m1} catch {unset foo} menu .m1 .m1 add checkbutton -variable foo -onvalue on -offvalue off -label "Nonsense" list [catch {.m1 entryconfigure 1 -variable bar} msg] $msg [.m1 entrycget 1 -variable] [destroy .m1] } {0 {} bar {}} -test menu-10.2 {ConfigureMenuEntry} { +test menu-11.2 {ConfigureMenuEntry} { catch {destroy .m1} menu .m1 .m1 add command -label "test" list [catch {.m1 entryconfigure 1 -label ""} msg] $msg [.m1 entrycget 1 -label] [destroy .m1] } {0 {} {} {}} -test menu-10.3 {ConfigureMenuEntry} { +test menu-11.3 {ConfigureMenuEntry} { catch {destroy .m1} menu .m1 .m1 add command list [catch {.m1 entryconfigure 1 -label "test"} cmd] $cmd [.m1 entrycget 1 -label] [destroy .m1] } {0 {} test {}} -test menu-10.4 {ConfigureMenuEntry} { +test menu-11.4 {ConfigureMenuEntry} { catch {destroy .m1} menu .m1 .m1 add command list [catch {.m1 entryconfigure 1 -accel "S"} msg] $msg [.m1 entrycget 1 -accel] [destroy .m1] } {0 {} S {}} -test menu-10.5 {ConfigureMenuEntry} { +test menu-11.5 {ConfigureMenuEntry} { catch {destroy .m1} menu .m1 .m1 add command list [catch {.m1 entryconfigure 1 -label "test"} msg] $msg [.m1 entrycget 1 -label] [destroy .m1] } {0 {} test {}} -test menu-10.6 {ConfigureMenuEntry} { +test menu-11.6 {ConfigureMenuEntry} { catch {destroy .m1} menu .m1 .m1 add command list [catch {.m1 entryconfigure 1 -label "test"} msg] $msg [destroy .m1] } {0 {} {}} -test menu-10.7 {ConfigureMenuEntry} { +test menu-11.7 {ConfigureMenuEntry} { catch {destroy .m1} catch {destroy .m2} menu .m2 @@ -1476,31 +1520,31 @@ test menu-10.7 {ConfigureMenuEntry} { .m1 add cascade list [catch {.m1 entryconfigure 1 -label "test" -menu .m2} msg] $msg [destroy .m1 .m2] } {0 {} {}} -test menu-10.8 {ConfigureMenuEntry} { +test menu-11.8 {ConfigureMenuEntry} { catch {destroy .m1} menu .m1 .m1 add cascade list [catch {.m1 entryconfigure 1 -label "test" -menu .m2} msg] $msg [destroy .m1] } {0 {} {}} -test menu-10.9 {ConfigureMenuEntry} { +test menu-11.9 {ConfigureMenuEntry} { catch {destroy .m1} menu .m1 .m1 add cascade -menu .m3 list [catch {.m1 entryconfigure 1 -label "test" -menu .m2} msg] $msg [destroy .m1] } {0 {} {}} -test menu-10.10 {ConfigureMenuEntry} { +test menu-11.10 {ConfigureMenuEntry} { catch {destroy .m1} menu .m1 .m1 add cascade list [catch {.m1 entryconfigure 1 -label "test" -menu .m2} msg] $msg [destroy .m1] } {0 {} {}} -test menu-10.11 {ConfigureMenuEntry} { +test menu-11.11 {ConfigureMenuEntry} { catch {destroy .m1} menu .m1 .m1 add cascade -menu .m2 list [catch {.m1 entryconfigure 1 -label "test" -menu .m2} msg] $msg [destroy .m1] } {0 {} {}} -test menu-10.12 {ConfigureMenuEntry} { +test menu-11.12 {ConfigureMenuEntry} { catch {destroy .m1} catch {destroy .m2} catch {destroy .m3} @@ -1517,7 +1561,7 @@ test menu-10.12 {ConfigureMenuEntry} { .m5 add cascade list [catch {.m5 entryconfigure 1 -label "test" -menu .m1} msg] $msg [destroy .m1 .m2 .m3 .m4 .m5] } {0 {} {}} -test menu-10.13 {ConfigureMenuEntry} { +test menu-11.13 {ConfigureMenuEntry} { catch {destroy .m1} catch {destroy .m2} catch {destroy .m3} @@ -1531,29 +1575,29 @@ test menu-10.13 {ConfigureMenuEntry} { .m4 add cascade -menu .m1 list [catch {.m3 entryconfigure 1 -label "test" -menu .m1} msg] $msg [destroy .m1 .m2 .m3 .m4] } {0 {} {}} -test menu-10.14 {ConfigureMenuEntry} { +test menu-11.14 {ConfigureMenuEntry} { catch {destroy .m1} menu .m1 .m1 add checkbutton list [catch {.m1 entryconfigure 1 -variable "test"} msg] $msg [.m1 entrycget 1 -variable] [destroy .m1] } {0 {} test {}} -test menu-10.15 {ConfigureMenuEntry} { +test menu-11.15 {ConfigureMenuEntry} { catch {destroy .m1} menu .m1 list [catch {.m1 add checkbutton -label "test"} msg] $msg [.m1 entrycget 1 -variable] [destroy .m1] } {0 {} test {}} -test menu-10.16 {ConfigureMenuEntry} { +test menu-11.16 {ConfigureMenuEntry} { catch {destroy .m1} menu .m1 list [catch {.m1 add radiobutton -label "test"} msg] $msg [destroy .m1] } {0 {} {}} -test menu-10.17 {ConfigureMenuEntry} { +test menu-11.17 {ConfigureMenuEntry} { catch {destroy .m1} menu .m1 .m1 add checkbutton list [catch {.m1 entryconfigure 1 -onvalue "test"} msg] $msg [.m1 entrycget 1 -onvalue] [destroy .m1] } {0 {} test {}} -test menu-10.18 {ConfigureMenuEntry} { +test menu-11.18 {ConfigureMenuEntry} { catch {destroy .m1} catch {image delete image1} menu .m1 @@ -1561,7 +1605,7 @@ test menu-10.18 {ConfigureMenuEntry} { image create test image1 list [catch {.m1 entryconfigure 1 -image image1} msg] $msg [destroy .m1] [image delete image1] } {0 {} {} {}} -test menu-10.19 {ConfigureMenuEntry} { +test menu-11.19 {ConfigureMenuEntry} { catch {destroy .m1} catch {image delete image1} catch {image delete image2} @@ -1571,7 +1615,7 @@ test menu-10.19 {ConfigureMenuEntry} { .m1 add command -image image1 list [catch {.m1 entryconfigure 1 -image image2} msg] $msg [destroy .m1] [image delete image1] [image delete image2] } {0 {} {} {} {}} -test menu-10.20 {ConfigureMenuEntry} { +test menu-11.20 {ConfigureMenuEntry} { catch {destroy .m1} catch {image delete image1} catch {image delete image2} @@ -1581,7 +1625,7 @@ test menu-10.20 {ConfigureMenuEntry} { .m1 add checkbutton -image image1 list [catch {.m1 entryconfigure 1 -selectimage image2} msg] $msg [destroy .m1] [image delete image1] [image delete image2] } {0 {} {} {} {}} -test menu-10.21 {ConfigureMenuEntry} { +test menu-11.21 {ConfigureMenuEntry} { catch {destroy .m1} catch {image delete image1} catch {image delete image2} @@ -1594,7 +1638,7 @@ test menu-10.21 {ConfigureMenuEntry} { list [catch {.m1 entryconfigure 1 -selectimage image3} msg] $msg [destroy .m1] [image delete image1] [image delete image2] [image delete image3] } {0 {} {} {} {} {}} -test menu-11.1 {ConfigureMenuCloneEntries} { +test menu-12.1 {ConfigureMenuCloneEntries} { catch {destroy .m1} catch {destroy .m2} catch {destroy .m3} @@ -1606,7 +1650,7 @@ test menu-11.1 {ConfigureMenuCloneEntries} { .m1 add command -label "test2" list [list [catch {.m1 entryconfigure 1 -gork "foo"} msg] $msg] [destroy .m1] } {{1 {unknown option "-gork"}} {}} -test menu-11.2 {ConfigureMenuCloneEntries} { +test menu-12.2 {ConfigureMenuCloneEntries} { catch {destroy .m1} catch {destroy .m2} catch {destroy .m3} @@ -1618,7 +1662,7 @@ test menu-11.2 {ConfigureMenuCloneEntries} { menu .m4 list [catch {.m1 entryconfigure 1 -menu .m4} msg] $msg [destroy .m1] [destroy .m3] [destroy .m4] } {0 {} {} {} {}} -test menu-11.3 {ConfigureMenuCloneEntries} { +test menu-12.3 {ConfigureMenuCloneEntries} { catch {destroy .m1} catch {destroy .m2} menu .m1 @@ -1627,7 +1671,7 @@ test menu-11.3 {ConfigureMenuCloneEntries} { list [catch {.m1 entryconfigure dummy -menu .m3} msg] $msg [destroy .m1] } {0 {} {}} -test menu-12.1 {TkGetMenuIndex} { +test menu-13.1 {TkGetMenuIndex} { catch {destroy .m1} menu .m1 .m1 add command -label "active" @@ -1636,7 +1680,7 @@ test menu-12.1 {TkGetMenuIndex} { .m1 activate 2 list [catch {.m1 entrycget active -label} msg] $msg [destroy .m1] } {0 test2 {}} -test menu-12.2 {TkGetMenuIndex} { +test menu-13.2 {TkGetMenuIndex} { catch {destroy .m1} menu .m1 .m1 add command -label "last" @@ -1645,7 +1689,7 @@ test menu-12.2 {TkGetMenuIndex} { .m1 activate 2 list [catch {.m1 entrycget last -label} msg] $msg [destroy .m1] } {0 test3 {}} -test menu-12.3 {TkGetMenuIndex} { +test menu-13.3 {TkGetMenuIndex} { catch {destroy .m1} menu .m1 .m1 add command -label "last" @@ -1654,19 +1698,19 @@ test menu-12.3 {TkGetMenuIndex} { .m1 activate 2 list [catch {.m1 entrycget end -label} msg] $msg [destroy .m1] } {0 test3 {}} -test menu-12.4 {TkGetMenuIndex} { +test menu-13.4 {TkGetMenuIndex} { catch {destroy .m1} menu .m1 .m1 add command -label "test" list [catch {.m1 insert last command -label "test2"} msg] $msg [.m1 entrycget last -label] [destroy .m1] } {0 {} test2 {}} -test menu-12.5 {TkGetMenuIndex} { +test menu-13.5 {TkGetMenuIndex} { catch {destroy .m1} menu .m1 .m1 add command -label "test" list [catch {.m1 insert end command -label "test2"} msg] $msg [.m1 entrycget end -label] [destroy .m1] } {0 {} test2 {}} -test menu-12.6 {TkGetMenuIndex} { +test menu-13.6 {TkGetMenuIndex} { catch {destroy .m1} menu .m1 .m1 add command -label "active" @@ -1676,7 +1720,7 @@ test menu-12.6 {TkGetMenuIndex} { list [catch {.m1 entrycget none -label} msg] $msg [destroy .m1] } {0 {} {}} #test menu-13.7 - Need to add @test here. -test menu-12.7 {TkGetMenuIndex} { +test menu-13.7 {TkGetMenuIndex} { catch {destroy .m1} menu .m1 .m1 add command -label "active" @@ -1684,32 +1728,32 @@ test menu-12.7 {TkGetMenuIndex} { .m1 add command -label "test3" list [catch {.m1 entrycget 1 -label} msg] $msg [destroy .m1] } {0 active {}} -test menu-12.8 {TkGetMenuIndex} { +test menu-13.8 {TkGetMenuIndex} { catch {destroy .m1} menu .m1 .m1 add command -label "active" list [catch {.m1 entrycget -1 -label} msg] $msg [destroy .m1] } {1 {bad menu entry index "-1"} {}} -test menu-12.9 {TkGetMenuIndex} { +test menu-13.9 {TkGetMenuIndex} { catch {destroy .m1} menu .m1 .m1 add command -label "test" .m1 add command -label "test2" list [catch {.m1 entrycget 999 -label} msg] $msg [destroy .m1] } {0 test2 {}} -test menu-12.10 {TkGetMenuIndex} { +test menu-13.10 {TkGetMenuIndex} { catch {destroy .m1} menu .m1 .m1 insert 999 command -label "test" list [catch {.m1 entrycget 1 -label} msg] $msg [destroy .m1] } {0 test {}} -test menu-12.11 {TkGetMenuIndex} { +test menu-13.11 {TkGetMenuIndex} { catch {destroy .m1} menu .m1 .m1 add command -label "1test" list [catch {.m1 entrycget 1test -label} msg] $msg [destroy .m1] } {0 1test {}} -test menu-12.12 {TkGetMenuIndex} { +test menu-13.12 {TkGetMenuIndex} { catch {destroy .m1} menu .m1 .m1 add command -label "test" @@ -1718,101 +1762,101 @@ test menu-12.12 {TkGetMenuIndex} { list [catch {.m1 entrycget test2 -command} msg] $msg [destroy .m1] } {0 beep {}} -test menu-13.1 {MenuCmdDeletedProc} { +test menu-14.1 {MenuCmdDeletedProc} { catch {destroy .m1} menu .m1 list [catch {destroy .m1} msg] $msg } {0 {}} -test menu-13.2 {MenuCmdDeletedProc} { +test menu-14.2 {MenuCmdDeletedProc} { catch {destroy .m1} menu .m1 .m1 clone .m2 list [catch {destroy .m1} msg] $msg } {0 {}} -test menu-14.1 {MenuNewEntry} { +test menu-15.1 {MenuNewEntry} { catch {destroy .m1} menu .m1 list [catch {.m1 add command -label "test"} msg] $msg [destroy .m1] } {0 {} {}} -test menu-14.2 {MenuNewEntry} { +test menu-15.2 {MenuNewEntry} { catch {destroy .m1} menu .m1 .m1 add command -label "test" .m1 add command -label "test3" list [catch {.m1 insert 2 command -label "test2"} msg] $msg [destroy .m1] } {0 {} {}} -test menu-14.3 {MenuNewEntry} { +test menu-15.3 {MenuNewEntry} { catch {destroy .m1} menu .m1 .m1 add command -label "test" list [catch {.m1 add command -label "test2"} msg] $msg [destroy .m1] } {0 {} {}} -test menu-14.4 {MenuNewEntry} { +test menu-15.4 {MenuNewEntry} { catch {destroy .m1} menu .m1 list [catch {.m1 add command -label "test"} msg] $msg [destroy .m1] } {0 {} {}} -test menu-15.1 {MenuAddOrInsert} { +test menu-16.1 {MenuAddOrInsert} { catch {destroy .m1} menu .m1 list [catch {.m1 insert foo command -label "test"} msg] $msg [destroy .m1] } {1 {bad menu entry index "foo"} {}} -test menu-15.2 {MenuAddOrInsert} { +test menu-16.2 {MenuAddOrInsert} { catch {destroy .m1} menu .m1 .m1 add command -label "test" list [catch {.m1 insert test command -label "foo"} msg] $msg [destroy .m1] } {0 {} {}} -test menu-15.3 {MenuAddOrInsert} { +test menu-16.3 {MenuAddOrInsert} { catch {destroy .m1} menu .m1 list [catch {.m1 insert -1 command -label "test"} msg] $msg [destroy .m1] } {1 {bad menu entry index "-1"} {}} -test menu-15.4 {MenuAddOrInsert} { +test menu-16.4 {MenuAddOrInsert} { catch {destroy .m1} menu .m1 .m1 add command -label "test" .m1 insert 0 command -label "test2" list [catch {.m1 entrycget 1 -label} msg] $msg [destroy .m1] } {0 test2 {}} -test menu-15.5 {MenuAddOrInsert} { +test menu-16.5 {MenuAddOrInsert} { catch {destroy .m1} menu .m1 list [catch {.m1 add cascade} msg] $msg [destroy .m1] } {0 {} {}} -test menu-15.6 {MenuAddOrInsert} { +test menu-16.6 {MenuAddOrInsert} { catch {destroy .m1} menu .m1 list [catch {.m1 add checkbutton} msg] $msg [destroy .m1] } {0 {} {}} -test menu-15.7 {MenuAddOrInsert} { +test menu-16.7 {MenuAddOrInsert} { catch {destroy .m1} menu .m1 list [catch {.m1 add command} msg] $msg [destroy .m1] } {0 {} {}} -test menu-15.8 {MenuAddOrInsert} { +test menu-16.8 {MenuAddOrInsert} { catch {destroy .m1} menu .m1 list [catch {.m1 add radiobutton} msg] $msg [destroy .m1] } {0 {} {}} -test menu-15.9 {MenuAddOrInsert} { +test menu-16.9 {MenuAddOrInsert} { catch {destroy .m1} menu .m1 list [catch {.m1 add separator} msg] $msg [destroy .m1] } {0 {} {}} -test menu-15.10 {MenuAddOrInsert} { +test menu-16.10 {MenuAddOrInsert} { catch {destroy .m1} menu .m1 list [catch {.m1 add blork} msg] $msg [destroy .m1] } {1 {bad menu entry type "blork": must be cascade, checkbutton, command, radiobutton, or separator} {}} -test menu-15.11 {MenuAddOrInsert} { +test menu-16.11 {MenuAddOrInsert} { catch {destroy .m1} menu .m1 list [catch {.m1 add command} msg] $msg [destroy .m1] } {0 {} {}} -test menu-15.12 {MenuAddOrInsert} { +test menu-16.12 {MenuAddOrInsert} { catch {destroy .m1} catch {destroy .m2} catch {destroy .m3} @@ -1821,7 +1865,7 @@ test menu-15.12 {MenuAddOrInsert} { .m2 clone .m3 list [catch {.m2 add command -label "test"} msg1] $msg1 [catch {.m1 entrycget 1 -label} msg2] $msg2 [catch {.m3 entrycget 1 -label} msg3] $msg3 [destroy .m1] } {0 {} 0 test 0 test {}} -test menu-15.13 {MenuAddOrInsert} { +test menu-16.13 {MenuAddOrInsert} { catch {destroy .m1} catch {destroy .m2} catch {destroy .m3} @@ -1830,12 +1874,12 @@ test menu-15.13 {MenuAddOrInsert} { .m2 clone .m3 list [catch {.m3 add command -label "test"} msg1] $msg1 [catch {.m1 entrycget 1 -label} msg2] $msg2 [catch {.m2 entrycget 1 -label} msg3] $msg3 [destroy .m1] } {0 {} 0 test 0 test {}} -test menu-15.14 {MenuAddOrInsert} { +test menu-16.14 {MenuAddOrInsert} { catch {destroy .m1} menu .m1 list [catch {.m1 add command -blork} msg] $msg [destroy .m1] } {1 {unknown option "-blork"} {}} -test menu-15.15 {MenuAddOrInsert} { +test menu-16.15 {MenuAddOrInsert} { catch {destroy .m1} catch {destroy .container} menu .m1 @@ -1844,7 +1888,7 @@ test menu-15.15 {MenuAddOrInsert} { . configure -menu .container list [catch {.container add cascade -label "File" -menu .m1} msg] $msg [. configure -menu ""] [destroy .container .m1] } {0 {} {} {}} -test menu-15.16 {MenuAddOrInsert} { +test menu-16.16 {MenuAddOrInsert} { catch {destroy .m1} catch {destroy .m2} menu .m1 @@ -1852,7 +1896,7 @@ test menu-15.16 {MenuAddOrInsert} { set tearoff [tkTearOffMenu .m2] list [catch {.m2 add cascade -menu .m1} msg] $msg [$tearoff unpost] [catch {destroy .m1} msg2] $msg2 [catch {destroy .m2} msg3] $msg3 } {0 {} {} 0 {} 0 {}} -test menu-15.17 {MenuAddOrInsert} { +test menu-16.17 {MenuAddOrInsert} { catch {destroy .m1} catch {destroy .container} menu .m1 @@ -1861,7 +1905,7 @@ test menu-15.17 {MenuAddOrInsert} { set tearoff [tkTearOffMenu .container] list [catch {.container add cascade -label "File" -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1 .container] } {0 {} {} {}} -test menu-15.18 {MenuAddOrInsert} { +test menu-16.18 {MenuAddOrInsert} { catch {destroy .m1} catch {destroy .container} menu .m1 @@ -1870,7 +1914,7 @@ test menu-15.18 {MenuAddOrInsert} { . configure -menu .container list [catch {.container add cascade -label "File" -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1 .container] } {0 {} {} {}} -test menu-15.19 {MenuAddOrInsert - Insert a cascade deep into the tree} { +test menu-16.19 {MenuAddOrInsert - Insert a cascade deep into the tree} { catch {destroy .menubar} menu .menubar menu .menubar.test -tearoff 0 @@ -1884,7 +1928,7 @@ test menu-15.19 {MenuAddOrInsert - Insert a cascade deep into the tree} { [. configure -menu ""] [destroy .menubar] } {0 .#menubar.#menubar#test.#menubar#test#cascade {} {}} -test menu-16.1 {MenuVarProc} { +test menu-17.1 {MenuVarProc} { catch {destroy .m1} catch {unset foo} menu .m1 @@ -1892,45 +1936,45 @@ test menu-16.1 {MenuVarProc} { list [catch {.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye} msg] $msg [catch {unset foo} msg2] $msg2 [destroy .m1] } {0 {} 0 {} {}} # menu-17.2 - Don't know how to generate the flags in the if -test menu-16.2 {MenuVarProc} { +test menu-17.2 {MenuVarProc} { catch {destroy .m1} catch {unset foo} menu .m1 list [catch {.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye} msg] $msg [set foo ""] [destroy .m1] } {0 {} {} {}} -test menu-16.3 {MenuVarProc} { +test menu-17.3 {MenuVarProc} { catch {destroy .m1} catch {unset foo} menu .m1 set foo "hello" list [catch {.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye} msg] $msg [set foo "hello"] [destroy .m1] [catch {unset foo} msg2] $msg2 } {0 {} hello {} 0 {}} -test menu-16.4 {MenuVarProc} { +test menu-17.4 {MenuVarProc} { catch {destroy .m1} menu .m1 set foo "goodbye" list [catch {.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye} msg] $msg [set foo "hello"] [destroy .m1] [catch {unset foo} msg2] $msg2 } {0 {} hello {} 0 {}} -test menu-16.5 {MenuVarProc} { +test menu-17.5 {MenuVarProc} { catch {destroy .m1} menu .m1 set foo "hello" list [catch {.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye} msg] $msg [set foo "goodbye"] [destroy .m1] [catch {unset foo} msg2] $msg2 } {0 {} goodbye {} 0 {}} -test menu-17.1 {TkActivateMenuEntry} { +test menu-18.1 {TkActivateMenuEntry} { catch {destroy .m1} menu .m1 .m1 add command -label "test" list [catch {.m1 activate 1} msg] $msg [destroy .m1] } {0 {} {}} -test menu-17.2 {TkActivateMenuEntry} { +test menu-18.2 {TkActivateMenuEntry} { catch {destroy .m1} menu .m1 .m1 add command -label "test" list [catch {.m1 activate 0} msg] $msg [destroy .m1] } {0 {} {}} -test menu-17.3 {TkActivateMenuEntry} { +test menu-18.3 {TkActivateMenuEntry} { catch {destroy .m1} menu .m1 .m1 add command -label "test" @@ -1938,7 +1982,7 @@ test menu-17.3 {TkActivateMenuEntry} { .m1 activate 1 list [catch {.m1 activate 2} msg] $msg [destroy .m1] } {0 {} {}} -test menu-17.4 {TkActivateMenuEntry} { +test menu-18.4 {TkActivateMenuEntry} { catch {destroy .m1} menu .m1 .m1 add command -label "test" @@ -1947,56 +1991,56 @@ test menu-17.4 {TkActivateMenuEntry} { list [catch {.m1 activate 1} msg] $msg [destroy .m1] } {0 {} {}} -test menu-18.1 {TkPostCommand} {menuInteractive} { +test menu-19.1 {TkPostCommand} {menuInteractive} { catch {destroy .m1} menu .m1 -postcommand "set menu_test menu-19.1" .m1 add command -label "menu-19.1 - hit Escape" list [catch {.m1 post 40 40} msg] $msg [.m1 unpost] [set menu_test] [destroy .m1] } {0 menu-19.1 {} menu-19.1 {}} -test menu-18.2 {TkPostCommand} {menuInteractive} { +test menu-19.2 {TkPostCommand} {menuInteractive} { catch {destroy .m1} menu .m1 .m1 add command -label "menu-19.2 - hit Escape" list [catch {.m1 post 40 40} msg] $msg [.m1 unpost] [destroy .m1] } {0 {} {} {}} -test menu-19.1 {CloneMenu} { +test menu-20.1 {CloneMenu} { catch {destroy .m1} catch {destroy .m2} menu .m1 list [catch {.m1 clone .m2} msg1] $msg1 [destroy .m1] } {0 {} {}} -test menu-19.2 {CloneMenu} { +test menu-20.2 {CloneMenu} { catch {destroy .m1} catch {destroy .m2} menu .m1 list [catch {.m1 clone .m2 normal} msg1] $msg1 [destroy .m1] } {0 {} {}} -test menu-19.3 {CloneMenu} { +test menu-20.3 {CloneMenu} { catch {destroy .m1} catch {destroy .m2} menu .m1 list [catch {.m1 clone .m2 tearoff} msg1] $msg1 [destroy .m1] } {0 {} {}} -test menu-19.4 {CloneMenu} { +test menu-20.4 {CloneMenu} { catch {destroy .m1} catch {destroy .m2} menu .m1 list [catch {.m1 clone .m2 menubar} msg1] $msg1 [destroy .m1] } {0 {} {}} -test menu-19.5 {CloneMenu} { +test menu-20.5 {CloneMenu} { catch {destroy .m1} catch {destroy .m2} menu .m1 list [catch {.m1 clone .m2 foo} msg1] $msg1 [destroy .m1] -} {1 {bad menu type - must be normal, tearoff, or menubar} {}} -test menu-19.6 {CloneMenu - hooking up bookeeping ptrs} { +} {1 {bad menu type "foo": must be normal, tearoff, or menubar} {}} +test menu-20.6 {CloneMenu - hooking up bookeeping ptrs} { catch {destroy .m1} catch {destroy .m2} menu .m1 list [catch {.m1 clone .m2} msg] $msg [destroy .m1] } {0 {} {}} - test menu-19.7 {CloneMenu - hooking up bookeeping ptrs - multiple children} { + test menu-20.7 {CloneMenu - hooking up bookeeping ptrs - multiple children} { catch {destroy .m1} catch {destroy .m2} catch {destroy .m3} @@ -2004,14 +2048,14 @@ test menu-19.6 {CloneMenu - hooking up bookeeping ptrs} { .m1 clone .m2 list [catch {.m1 clone .m3} msg] $msg [destroy .m1] } {0 {} {}} - test menu-19.8 {CloneMenu - cascade entries} { + test menu-20.8 {CloneMenu - cascade entries} { catch {destroy .m1} catch {destroy .foo} menu .m1 .m1 add cascade -menu .m2 list [catch {.m1 clone .foo} msg] $msg [destroy .m1] } {0 {} {}} - test menu-19.9 {CloneMenu - cascades entries} { + test menu-20.9 {CloneMenu - cascades entries} { catch {destroy .m1} catch {destroy .m2} catch {destroy .foo} @@ -2020,13 +2064,13 @@ test menu-19.6 {CloneMenu - hooking up bookeeping ptrs} { menu .m2 list [catch {.m1 clone .foo} msg] $msg [destroy .m1 .m2] } {0 {} {}} -test menu-19.10 {CloneMenu - tearoff fields} { +test menu-20.10 {CloneMenu - tearoff fields} { catch {destroy .m1} catch {destroy .m2} menu .m1 list [catch {.m1 clone .m2 normal} msg1] $msg1 [catch {.m2 cget -tearoff} msg2] $msg2 [destroy .m1] } {0 {} 0 1 {}} -test menu-19.11 {CloneMenu} { +test menu-20.11 {CloneMenu} { catch {destroy .m1} catch {destroy .m2} menu .m1 @@ -2034,26 +2078,26 @@ test menu-19.11 {CloneMenu} { list [catch {.m1 clone .m2} msg] $msg [destroy .m1 .m2] } {1 {window name "m2" already exists in parent} {}} -test menu-20.1 {MenuDoYPosition} { +test menu-21.1 {MenuDoYPosition} { catch {destroy .m1} menu .m1 list [catch {.m1 yposition glorp} msg] $msg [destroy .m1] } {1 {bad menu entry index "glorp"} {}} -test menu-20.2 {MenuDoYPosition} { +test menu-21.2 {MenuDoYPosition} { catch {destroy .m1} menu .m1 .m1 add command -label "Test" list [catch {.m1 yposition 1}] [destroy .m1] } {0 {}} -test menu-21.1 {GetIndexFromCoords} { +test menu-22.1 {GetIndexFromCoords} { catch {destroy .m1} menu .m1 .m1 add command -label "test" .m1 configure -tearoff 0 list [catch {.m1 index @5} msg] $msg [destroy .m1] } {0 0 {}} -test menu-21.2 {GetIndexFromCoords} { +test menu-22.2 {GetIndexFromCoords} { catch {destroy .m1} menu .m1 .m1 add command -label "test" @@ -2061,13 +2105,13 @@ test menu-21.2 {GetIndexFromCoords} { list [catch {.m1 index @5,5} msg] $msg [destroy .m1] } {0 0 {}} -test menu-22.1 {RecursivelyDeleteMenu} { +test menu-23.1 {RecursivelyDeleteMenu} { catch {destroy .m1} menu .m1 . configure -menu .m1 list [catch {. configure -menu ""} msg] $msg [destroy .m1] } {0 {} {}} -test menu-22.2 {RecursivelyDeleteMenu} { +test menu-23.2 {RecursivelyDeleteMenu} { catch {destroy .m1} catch {destroy .m2} menu .m2 @@ -2078,40 +2122,40 @@ test menu-22.2 {RecursivelyDeleteMenu} { list [catch {. configure -menu ""} msg] $msg [destroy .m1 .m2] } {0 {} {}} -test menu-23.1 {TkNewMenuName} { +test menu-24.1 {TkNewMenuName} { catch {destroy .m1} menu .m1 list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test menu-23.2 {TkNewMenuName} { +test menu-24.2 {TkNewMenuName} { catch {destroy .m1} catch {destroy .m1\#0} menu .m1 menu .m1\#0 list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test menu-23.3 {TkNewMenuName} { +test menu-24.3 {TkNewMenuName} { catch {destroy .#m} menu .#m rename .#m hideme list [catch {. configure -menu [menu .m]} $msg] [. configure -menu ""] [destroy .#m] [destroy .m] [destroy hideme] } {0 {} {} {} {}} -test menu-24.1 {TkSetWindowMenuBar} { +test menu-25.1 {TkSetWindowMenuBar} { . configure -menu "" list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] } {0 {} {}} -test menu-24.2 {TkSetWindowMenuBar} { +test menu-25.2 {TkSetWindowMenuBar} { . configure -menu "" list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] } {0 {} {}} -test menu-24.3 {TkSetWindowMenuBar} { +test menu-25.3 {TkSetWindowMenuBar} { . configure -menu "" catch {destroy .m1} menu .m1 list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test menu-24.4 {TkSetWindowMenuBar} { +test menu-25.4 {TkSetWindowMenuBar} { catch {destroy .m1} catch {destroy .m2} . configure -menu "" @@ -2120,7 +2164,7 @@ test menu-24.4 {TkSetWindowMenuBar} { menu .m2 list [catch {. configure -menu .m2} msg] $msg [. configure -menu ""] [destroy .m1 .m2] } {0 {} {} {}} -test menu-24.5 {TkSetWindowMenuBar} { +test menu-25.5 {TkSetWindowMenuBar} { catch {destroy .m1} catch {destroy .m2} catch {destroy .m3} @@ -2131,7 +2175,7 @@ test menu-24.5 {TkSetWindowMenuBar} { menu .m3 list [catch {. configure -menu .m3} msg] $msg [. configure -menu ""] [destroy .m1 .m3] } {0 {} {} {}} -test menu-24.6 {TkSetWindowMenuBar} { +test menu-25.6 {TkSetWindowMenuBar} { catch {destroy .m1} catch {destroy .m2} catch {destroy .m3} @@ -2142,7 +2186,7 @@ test menu-24.6 {TkSetWindowMenuBar} { menu .m3 list [catch {. configure -menu .m3} msg] $msg [. configure -menu ""] [destroy .m1 .m3] } {0 {} {} {}} -test menu-24.7 {TkSetWindowMenuBar} { +test menu-25.7 {TkSetWindowMenuBar} { catch {destroy .m1} catch {destroy .m2} . configure -menu "" @@ -2153,7 +2197,7 @@ test menu-24.7 {TkSetWindowMenuBar} { .t2 configure -menu .m1 list [catch {.t2 configure -menu .m2} msg] $msg [. configure -menu ""] [destroy .t2 .m1 .m2] } {0 {} {} {}} -test menu-24.8 {TkSetWindowMenuBar} { +test menu-25.8 {TkSetWindowMenuBar} { catch {destroy .m1} catch {destroy .m2} catch {destroy .t2} @@ -2166,7 +2210,7 @@ test menu-24.8 {TkSetWindowMenuBar} { .t2 configure -menu .m1 list [catch {. configure -menu .m2} msg] $msg [. configure -menu ""] [destroy .t2 .m1 .m2] } {0 {} {} {}} -test menu-24.9 {TkSetWindowMenuBar} { +test menu-25.9 {TkSetWindowMenuBar} { catch {destroy .m1} catch {destroy .m2} catch {destroy .t2} @@ -2181,7 +2225,7 @@ test menu-24.9 {TkSetWindowMenuBar} { wm geometry .t3 +0+0 list [catch {.t3 configure -menu .m2} msg] $msg [. configure -menu ""] [destroy .t2 .t3 .m1 .m2] } {0 {} {} {}} -test menu-24.10 {TkSetWindowMenuBar} { +test menu-25.10 {TkSetWindowMenuBar} { catch {destroy .m1} catch {destroy .m2} catch {destroy .t2} @@ -2196,7 +2240,7 @@ test menu-24.10 {TkSetWindowMenuBar} { wm geometry .t3 +0+0 list [catch {.t2 configure -menu .m2} msg] $msg [. configure -menu ""] [destroy .t2 .t3 .m1 .m2] } {0 {} {} {}} -test menu-24.11 {TkSetWindowMenuBar} { +test menu-25.11 {TkSetWindowMenuBar} { catch {destroy .m1} catch {destroy .m2} catch {destroy .t2} @@ -2211,27 +2255,27 @@ test menu-24.11 {TkSetWindowMenuBar} { wm geometry .t3 +0+0 list [catch {. configure -menu .m2} msg] $msg [. configure -menu ""] [destroy .t2 .t3 .m1 .m2] } {0 {} {} {}} -test menu-24.12 {TkSetWindowMenuBar} { +test menu-25.12 {TkSetWindowMenuBar} { catch {destroy .m1} . configure -menu "" menu .m1 list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test menu-24.13 {TkSetWindowMenuBar} { +test menu-25.13 {TkSetWindowMenuBar} { . configure -menu "" list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] } {0 {} {}} -test menu-24.14 {TkSetWindowMenuBar} { +test menu-25.14 {TkSetWindowMenuBar} { catch {destroy .m1} . configure -menu "" menu .m1 list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test menu-24.15 {TkSetWindowMenuBar} { +test menu-25.15 {TkSetWindowMenuBar} { . configure -menu "" list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] } {0 {} {}} -test menu-24.16 {TkSetWindowMenuBar} { +test menu-25.16 {TkSetWindowMenuBar} { catch {destroy .m1} . configure -menu "" menu .m1 @@ -2239,7 +2283,7 @@ test menu-24.16 {TkSetWindowMenuBar} { list [catch {toplevel .t2 -menu m1} msg] $msg [. configure -menu ""] [destroy .t2 .m1] } {0 .t2 {} {}} -test menu-25.1 {DestroyMenuHashTable} { +test menu-26.1 {DestroyMenuHashTable} { catch {interp destroy testinterp} interp create testinterp load {} Tk testinterp @@ -2247,18 +2291,18 @@ test menu-25.1 {DestroyMenuHashTable} { list [catch {interp delete testinterp} msg] $msg } {0 {}} -test menu-26.1 {GetMenuHashTable} { +test menu-27.1 {GetMenuHashTable} { catch {interp destroy testinterp} interp create testinterp load {} tk testinterp list [catch {interp eval testinterp {menu .m1}} msg] $msg [interp delete testinterp] } {0 .m1 {}} -test menu-27.1 {TkCreateMenuReferences - not there before} { +test menu-28.1 {TkCreateMenuReferences - not there before} { catch {destroy .m1} list [catch {menu .m1} msg] $msg [destroy .m1] } {0 .m1 {}} -test menu-27.2 {TkCreateMenuReferences - there already} { +test menu-28.2 {TkCreateMenuReferences - there already} { catch {destroy .m1} catch {destroy .m2} menu .m1 @@ -2266,14 +2310,14 @@ test menu-27.2 {TkCreateMenuReferences - there already} { list [catch {menu .m2} msg] $msg [destroy .m1 .m2] } {0 .m2 {}} -test menu-28.1 {TkFindMenuReferences - not there} { +test menu-29.1 {TkFindMenuReferences - not there} { catch {destroy .m1} . configure -menu "" menu .m1 .m1 add cascade -menu .m2 list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1] } {0 {} {} {}} -test menu-29.1 {TkFindMenuReferences - there already} { +test menu-30.1 {TkFindMenuReferences - there already} { catch {destroy .m1} catch {destroy .m2} . configure -menu "" @@ -2283,23 +2327,23 @@ test menu-29.1 {TkFindMenuReferences - there already} { list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1 .m2] } {0 {} {} {}} -test menu-30.1 {TkFreeMenuReferences - menuPtr} { +test menu-31.1 {TkFreeMenuReferences - menuPtr} { catch {destroy .m1} menu .m1 list [catch {destroy .m1} msg] $msg } {0 {}} -test menu-30.2 {TkFreeMenuReferences - cascadePtr} { +test menu-31.2 {TkFreeMenuReferences - cascadePtr} { catch {destroy .m1} . configure -menu "" menu .m1 .m1 add cascade -menu .m2 list [catch {.m1 entryconfigure 1 -menu .m3} msg] $msg [destroy .m1] } {0 {} {}} -test menu-30.3 {TkFreeMenuReferences - topLevelListPtr} { +test menu-31.3 {TkFreeMenuReferences - topLevelListPtr} { . configure -menu .m1 list [catch {. configure -menu ""} msg] $msg } {0 {}} -test menu-30.4 {TkFreeMenuReferences - not empty} { +test menu-31.4 {TkFreeMenuReferences - not empty} { catch {destroy .m1} catch {destroy .m2} menu .m1 @@ -2309,7 +2353,7 @@ test menu-30.4 {TkFreeMenuReferences - not empty} { list [catch {.m2 entryconfigure 1 -menu ".foo"} msg] $msg [destroy .m1 .m2] } {0 {} {}} -test menu-31.1 {DeleteMenuCloneEntries} { +test menu-32.1 {DeleteMenuCloneEntries} { catch {destroy .m1} catch {destroy .m2} menu .m1 @@ -2317,7 +2361,7 @@ test menu-31.1 {DeleteMenuCloneEntries} { .m1 clone .m2 list [catch {.m1 delete 1} msg] $msg [destroy .m1] } {0 {} {}} -test menu-31.2 {DeleteMenuCloneEntries} { +test menu-32.2 {DeleteMenuCloneEntries} { catch {destroy .m1} catch {destroy .m2} menu .m1 @@ -2328,7 +2372,7 @@ test menu-31.2 {DeleteMenuCloneEntries} { .m1 clone .m2 list [catch {.m1 delete 2 3} msg] $msg [destroy .m1] } {0 {} {}} -test menu-31.3 {DeleteMenuCloneEntries} { +test menu-32.3 {DeleteMenuCloneEntries} { catch {destroy .m1} catch {destroy .m2} menu .m1 -tearoff 0 @@ -2340,7 +2384,7 @@ test menu-31.3 {DeleteMenuCloneEntries} { .m2 configure -tearoff 1 list [catch {.m1 delete 1 2} msg] $msg [destroy .m1] } {0 {} {}} -test menu-31.4 {DeleteMenuCloneEntries} { +test menu-32.4 {DeleteMenuCloneEntries} { catch {destroy .m1} catch {destroy .m2} menu .m1 @@ -2352,7 +2396,7 @@ test menu-31.4 {DeleteMenuCloneEntries} { .m2 configure -tearoff 0 list [catch {.m1 delete 2 3} msg] $msg [destroy .m1] } {0 {} {}} -test menu-31.5 {DeleteMenuCloneEntries} { +test menu-32.5 {DeleteMenuCloneEntries} { catch {destroy .m1} catch {destroy .m2} menu .m1 @@ -2362,17 +2406,23 @@ test menu-31.5 {DeleteMenuCloneEntries} { .m1 activate one list [catch {.m1 delete one} msg] $msg [destroy .m1] } {0 {} {}} -test menu-31.6 {DeleteMenuCloneEntries - reentrancy - crashes tk8.0} { +test menu-32.6 {DeleteMenuCloneEntries - reentrancy - crashes tk8.0} { catch {destroy .m1} menu .m1 .m1 add command -label test -command ".m1 delete test ; .m1 add command -label test -command \".m1 delete test\"; .m1 delete test" list [catch {.m1 invoke test} msg] $msg [destroy .m1] } {0 {} {}} +test menu-32.7 {DeleteMenuCloneEntries - one entry} { + catch {destroy .m1} + menu .m1 -tearoff 0 + .m1 add command -label Hello + list [catch {.m1 delete Hello} msg] $msg [destroy .m1] +} {0 {} {}} set l [interp hidden] eval destroy [winfo children .] -test menu-32.1 {menu vs command hiding} { +test menu-33.1 {menu vs command hiding} { catch {destroy .m} menu .m interp hide {} .m diff --git a/tests/menuDraw.test b/tests/menuDraw.test index 291d2a2..212eacf 100644 --- a/tests/menuDraw.test +++ b/tests/menuDraw.test @@ -6,7 +6,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) menuDraw.test 1.11 97/06/24 13:50:34 +# SCCS: @(#) menuDraw.test 1.15 97/12/23 08:58:07 if {[lsearch [image types] test] < 0} { puts "This application hasn't been compiled with the \"test\" image" @@ -118,7 +118,7 @@ test menuDraw-6.6 {TkMenuConfigureEntryDrawOptions - bad state} { menu .m1 .m1 add command -label "foo" list [catch {.m1 entryconfigure 1 -state foo} msg] $msg [destroy .m1] -} {1 {bad state value "foo": must be normal, active, or disabled} {}} +} {1 {bad state "foo": must be active, normal, or disabled} {}} test menuDraw-6.7 {TkMenuConfigureEntryDrawOptions - tkfont specified} { catch {destroy .m1} menu .m1 diff --git a/tests/msgbox.test b/tests/msgbox.test index c23ddaf..b41ad70 100644 --- a/tests/msgbox.test +++ b/tests/msgbox.test @@ -6,7 +6,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) msgbox.test 1.7 97/07/31 10:05:25 +# SCCS: @(#) msgbox.test 1.10 97/10/21 09:54:32 # if {[string compare test [info procs test]] == 1} { @@ -15,10 +15,10 @@ if {[string compare test [info procs test]] == 1} { test msgbox-1.1 {tk_messageBox command} { list [catch {tk_messageBox -foo} msg] $msg -} {1 {unknown option "-foo", must be -default, -icon, -message, -parent, -title or -type}} +} {1 {bad option "-foo": must be -default, -icon, -message, -parent, -title, or -type}} test msgbox-1.2 {tk_messageBox command} { list [catch {tk_messageBox -foo bar} msg] $msg -} {1 {unknown option "-foo", must be -default, -icon, -message, -parent, -title or -type}} +} {1 {bad option "-foo": must be -default, -icon, -message, -parent, -title, or -type}} catch {tk_messageBox -foo bar} msg regsub -all , $msg "" options @@ -38,23 +38,23 @@ test msgbox-1.4 {tk_messageBox command} { test msgbox-1.5 {tk_messageBox command} { list [catch {tk_messageBox -type foo} msg] $msg -} {1 {invalid message box type "foo", must be abortretryignore, ok, okcancel, retrycancel, yesno or yesnocancel}} +} {1 {bad -type value "foo": must be abortretryignore, ok, okcancel, retrycancel, yesno, or yesnocancel}} test msgbox-1.6 {tk_messageBox command} { list [catch {tk_messageBox -default 1.1} msg] $msg -} {1 {invalid default button "1.1"}} +} {1 {bad -default value "1.1": must be abort, retry, ignore, ok, cancel, no, or yes}} test msgbox-1.7 {tk_messageBox command} { list [catch {tk_messageBox -default foo} msg] $msg -} {1 {invalid default button "foo"}} +} {1 {bad -default value "foo": must be abort, retry, ignore, ok, cancel, no, or yes}} test msgbox-1.8 {tk_messageBox command} { list [catch {tk_messageBox -type yesno -default 3} msg] $msg -} {1 {invalid default button "3"}} +} {1 {bad -default value "3": must be abort, retry, ignore, ok, cancel, no, or yes}} test msgbox-1.9 {tk_messageBox command} { list [catch {tk_messageBox -icon foo} msg] $msg -} {1 {invalid icon "foo", must be error, info, question or warning}} +} {1 {bad -icon value "foo": must be error, info, question, or warning}} test msgbox-1.10 {tk_messageBox command} { list [catch {tk_messageBox -parent foo.bar} msg] $msg diff --git a/tests/obj.test b/tests/obj.test new file mode 100644 index 0000000..1e3c524 --- /dev/null +++ b/tests/obj.test @@ -0,0 +1,37 @@ +# This file is a Tcl script to test new object types in Tk. +# It is organized in the standard fashion for Tcl tests. +# +# 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. +# +# SCCS: @(#) obj.test 1.2 97/11/17 11:20:18 + +if {[info procs test] != "test"} { + source defs +} + +foreach i [winfo children .] { + destroy $i +} +wm geometry . {} +raise . + +test obj-1.1 {TkGetPixelsFromObj} { +} {} + +test obj-2.1 {FreePixelInternalRep} { +} {} + +test obj-3.1 {DupPixelInternalRep} { +} {} + +test obj-4.1 {SetPixelFromAny} { +} {} + + + +eval destroy [winfo children .] + + diff --git a/tests/safe.test b/tests/safe.test index 65aed36..51ee212 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) safe.test 1.15 97/08/13 16:05:17 +# SCCS: @(#) safe.test 1.20 98/02/19 15:12:48 if {[info procs test] != "test"} { source defs @@ -20,11 +20,11 @@ foreach i [winfo children .] { # The set of hidden commands is platform dependent: if {"$tcl_platform(platform)" == "macintosh"} { - set hidden_cmds {beep bell cd clipboard echo exit fconfigure file glob grab load ls menu open pwd selection socket source tk tk_chooseColor tk_getOpenFile tk_getSaveFile tk_messageBox toplevel wm} + set hidden_cmds {beep bell cd clipboard echo exit fconfigure file glob grab load ls menu open pwd selection send socket source tk tk_chooseColor tk_chooseDirectory tk_getOpenFile tk_getSaveFile toplevel wm} } elseif {"$tcl_platform(platform)" == "windows"} { set hidden_cmds {bell cd clipboard exec exit fconfigure file glob grab load menu open pwd selection socket source tk tk_chooseColor tk_getOpenFile tk_getSaveFile tk_messageBox toplevel wm} } else { - set hidden_cmds {bell cd clipboard exec exit fconfigure file glob grab load menu open pwd selection send socket source tk tk_chooseColor tk_getOpenFile tk_getSaveFile tk_messageBox toplevel wm} + set hidden_cmds {bell cd clipboard exec exit fconfigure file glob grab load menu open pwd selection send socket source tk toplevel wm} } test safe-1.1 {Safe Tk loading into an interpreter} { @@ -119,4 +119,58 @@ test safe-4.2 {testing loadTk -use} { destroy $w } {} +test safe-5.1 {loading Tk in safe interps without master's clearance} { + set i [safe::interpCreate] + catch {interp eval $i {load {} Tk}} msg + safe::interpDelete $i + set msg +} {not allowed to start Tk by master's safe::TkInit} + +test safe-5.2 {multi-level Tk loading with clearance} { + # No error shall occur in that test and no window + # shall remain at the end. + set i [safe::interpCreate] + set j [list $i x] + set j [safe::interpCreate $j] + safe::loadTk $j + interp eval $j { + button .b -text Ok -command {destroy .} + pack .b +# tkwait window . ; # for interactive testing/debugging + } + safe::interpDelete $j + safe::interpDelete $i +} {} + +test safe-6.1 {loadTk -use windowPath} { + set w .safeTkFrame + catch {destroy $w} + frame $w -container 1; + pack .safeTkFrame + set i [safe::loadTk [safe::interpCreate] -use $w] + interp eval $i {button .b -text "hello world!"; pack .b} + safe::interpDelete $i + destroy $w +} {} + +test safe-6.2 {loadTk -use windowPath, conflicting -display} { + set w .safeTkFrame + catch {destroy $w} + frame $w -container 1; + pack .safeTkFrame + set i [safe::interpCreate] + catch {safe::loadTk $i -use $w -display :23.56} msg + safe::interpDelete $i + destroy $w + string range $msg 0 36 +} {conflicting -display :23.56 and -use } + + +test safe-7.1 {canvas printing} { + set i [safe::loadTk [safe::interpCreate]] + set r [catch {interp eval $i {canvas .c; .c postscript}}] + safe::interpDelete $i + set r +} 0 + unset hidden_cmds diff --git a/tests/scale.test b/tests/scale.test index 405a529..e265493 100644 --- a/tests/scale.test +++ b/tests/scale.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) scale.test 1.28 97/07/31 10:20:43 +# SCCS: @(#) scale.test 1.29 98/01/02 17:43:57 if {[info procs test] != "test"} { source defs @@ -329,8 +329,8 @@ test scale-6.6 {ComputeFormat procedure} {nonPortable} { test scale-6.7 {ComputeFormat procedure} { .s configure -from 1000000000 -to 10000000000 -resolution 1000000000 .s set 4930000000 - .s get -} {5.0e+09} + expr {[.s get] == 5.0e+09} +} {1} test scale-6.8 {ComputeFormat procedure} { .s configure -from .1 -to 1 -resolution .1 .s set .6 @@ -359,8 +359,8 @@ test scale-6.12 {ComputeFormat procedure} { test scale-6.13 {ComputeFormat procedure} { .s configure -from .000001 -to .00001 -resolution .000001 .s set .000006 - .s get -} {6.0e-06} + expr {[.s get] == 6.0e-06} +} {1} test scale-6.14 {ComputeFormat procedure} { .s configure -to .00001 -from .0001 -resolution .00001 .s set .00006 @@ -369,13 +369,13 @@ test scale-6.14 {ComputeFormat procedure} { test scale-6.15 {ComputeFormat procedure} { .s configure -to .000001 -from .00001 -resolution .000001 .s set .000006 - .s get -} {6.0e-06} + expr {[.s get] == 6.0e-06} +} {1} test scale-6.16 {ComputeFormat procedure} { .s configure -from .00001 -to .0001 -resolution .00001 -digits 1 .s set .00006 - .s get -} {6e-05} + expr {[.s get] == 6e-05} +} {1} test scale-6.17 {ComputeFormat procedure} { .s configure -from 10000000 -to 100000000 -resolution 10000000 -digits 3 .s set 49300000 diff --git a/tests/textDisp.test b/tests/textDisp.test index c14f785..1641b9b 100644 --- a/tests/textDisp.test +++ b/tests/textDisp.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) textDisp.test 1.55 97/07/24 15:15:43 +# SCCS: @(#) textDisp.test 1.56 97/08/14 13:41:51 if {[string compare test [info procs test]] == 1} { source defs diff --git a/tests/textIndex.test b/tests/textIndex.test index df30951..6b08d69 100644 --- a/tests/textIndex.test +++ b/tests/textIndex.test @@ -7,17 +7,13 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) textIndex.test 1.9 96/06/24 16:46:55 +# SCCS: @(#) textIndex.test 1.11 98/01/12 15:33:59 if {[string compare test [info procs test]] == 1} then \ {source defs} catch {destroy .t} -if [catch {text .t -font {Courier 12} -width 20 -height 10}] { - puts "The font needed by these tests isn't available, so I'm" - puts "going to skip the tests." - return -} +text .t -font {Courier -12} -width 20 -height 10 pack append . .t {top expand fill} update .t debug on @@ -35,73 +31,179 @@ wm deiconify . abcdefghijklm 12345 Line 4 -bOy GIrl .#@? x_yz +b\u4e4fy GIrl .#@? x_yz !@#$% Line 7" -test textIndex-1.1 {TkTextMakeIndex} { +image create photo textimage -width 10 -height 10 +textimage put red -to 0 0 9 9 + +test textIndex-1.1 {TkTextMakeByteIndex} { + # (lineIndex < 0) + testtext .t byteindex -1 3 +} {1.0 0} +test textIndex-1.2 {TkTextMakeByteIndex} { + # (lineIndex < 0), because lineIndex == strtol(argv[2]) - 1 + testtext .t byteindex 0 3 +} {1.0 0} +test textIndex-1.3 {TkTextMakeByteIndex} { + # not (lineIndex < 0) + testtext .t byteindex 1 3 +} {1.3 3} +test textIndex-1.4 {TkTextMakeByteIndex} { + # (byteIndex < 0) + testtext .t byteindex 3 -1 +} {3.0 0} +test textIndex-1.5 {TkTextMakeByteIndex} { + # not (byteIndex < 0) + testtext .t byteindex 3 3 +} {3.3 3} +test textIndex-1.6 {TkTextMakeByteIndex} { + # (indexPtr->linePtr == NULL) + testtext .t byteindex 9 2 +} {8.0 0} +test textIndex-1.7 {TkTextMakeByteIndex} { + # not (indexPtr->linePtr == NULL) + testtext .t byteindex 7 2 +} {7.2 2} +test textIndex-1.8 {TkTextMakeByteIndex: shortcut for 0} { + # (byteIndex == 0) + testtext .t byteindex 1 0 +} {1.0 0} +test textIndex-1.9 {TkTextMakeByteIndex: shortcut for 0} { + # not (byteIndex == 0) + testtext .t byteindex 3 80 +} {3.5 5} +test textIndex-1.10 {TkTextMakeByteIndex: verify index is in range} { + # for (segPtr = indexPtr->linePtr->segPtr; ; segPtr = segPtr->nextPtr) + # one segment + + testtext .t byteindex 3 5 +} {3.5 5} +test textIndex-1.11 {TkTextMakeByteIndex: verify index is in range} { + # for (segPtr = indexPtr->linePtr->segPtr; ; segPtr = segPtr->nextPtr) + # index += segPtr->size + # Multiple segments, make sure add segment size to index. + + .t mark set foo 3.2 + set x [testtext .t byteindex 3 7] + .t mark unset foo + set x +} {3.5 5} +test textIndex-1.12 {TkTextMakeByteIndex: verify index is in range} { + # (segPtr == NULL) + testtext .t byteindex 3 7 +} {3.5 5} +test textIndex-1.13 {TkTextMakeByteIndex: verify index is in range} { + # not (segPtr == NULL) + testtext .t byteindex 3 4 +} {3.4 4} +test textIndex-1.14 {TkTextMakeByteIndex: verify index is in range} { + # (index + segPtr->size > byteIndex) + # in this segment. + + testtext .t byteindex 3 4 +} {3.4 4} +test textIndex-1.15 {TkTextMakeByteIndex: verify index is in range} { + # (index + segPtr->size > byteIndex), index != 0 + # in this segment. + + .t mark set foo 3.2 + set x [testtext .t byteindex 3 4] + .t mark unset foo + set x +} {3.4 4} +test textIndex-1.16 {TkTextMakeByteIndex: UTF-8 characters} { + testtext .t byteindex 5 100 +} {5.18 20} +test textIndex-1.17 {TkTextMakeByteIndex: prevent splitting UTF-8 character} { + # ((byteIndex > index) && (segPtr->typePtr == &tkTextCharType)) + # Wrong answer would be \xb9 (the 2nd byte of UTF rep of 0x4e4f). + + set x [testtext .t byteindex 5 2] + list $x [.t get insert] +} {{5.2 4} y} +test textIndex-1.18 {TkTextMakeByteIndex: prevent splitting UTF-8 character} { + # ((byteIndex > index) && (segPtr->typePtr == &tkTextCharType)) + testtext .t byteindex 5 1 + .t get insert +} "\u4e4f" + +test textIndex-2.1 {TkTextMakeCharIndex} { + # (lineIndex < 0) .t index -1.3 } 1.0 -test textIndex-1.2 {TkTextMakeIndex} { +test textIndex-2.2 {TkTextMakeCharIndex} { + # (lineIndex < 0), because lineIndex == strtol(argv[2]) - 1 .t index 0.3 } 1.0 -test textIndex-1.3 {TkTextMakeIndex} { +test textIndex-2.3 {TkTextMakeCharIndex} { + # not (lineIndex < 0) .t index 1.3 } 1.3 -test textIndex-1.4 {TkTextMakeIndex} { +test textIndex-2.4 {TkTextMakeCharIndex} { + # (charIndex < 0) .t index 3.-1 } 3.0 -test textIndex-1.5 {TkTextMakeIndex} { +test textIndex-2.5 {TkTextMakeCharIndex} { + # (charIndex < 0) .t index 3.3 } 3.3 -test textIndex-1.6 {TkTextMakeIndex} { +test textIndex-2.6 {TkTextMakeCharIndex} { + # (indexPtr->linePtr == NULL) + .t index 9.2 +} 8.0 +test textIndex-2.7 {TkTextMakeCharIndex} { + # not (indexPtr->linePtr == NULL) + .t index 7.2 +} 7.2 +test textIndex-2.8 {TkTextMakeCharIndex: verify index is in range} { + # for (segPtr = indexPtr->linePtr->segPtr; ; segPtr = segPtr->nextPtr) + # one segment + .t index 3.5 } 3.5 -test textIndex-1.7 {TkTextMakeIndex} { - .t index 3.6 +test textIndex-2.9 {TkTextMakeCharIndex: verify index is in range} { + # for (segPtr = indexPtr->linePtr->segPtr; ; segPtr = segPtr->nextPtr) + # Multiple segments, make sure add segment size to index. + + .t mark set foo 3.2 + set x [.t index 3.7] + .t mark unset foo + set x } 3.5 -test textIndex-1.8 {TkTextMakeIndex} { +test textIndex-2.10 {TkTextMakeCharIndex: verify index is in range} { + # (segPtr == NULL) .t index 3.7 } 3.5 -test textIndex-1.9 {TkTextMakeIndex} { - .t index 7.2 -} 7.2 -test textIndex-1.10 {TkTextMakeIndex} { - .t index 8.0 -} 8.0 -test textIndex-1.11 {TkTextMakeIndex} { - .t index 8.1 -} 8.0 -test textIndex-1.12 {TkTextMakeIndex} { - .t index 9.0 -} 8.0 +test textIndex-2.11 {TkTextMakeCharIndex: verify index is in range} { + # not (segPtr == NULL) + .t index 3.4 +} 3.4 +test textIndex-2.12 {TkTextMakeCharIndex: verify index is in range} { + # (segPtr->typePtr == &tkTextCharType) + # Wrong answer would be \xb9 (the 2nd byte of UTF rep of 0x4e4f). + + .t mark set insert 5.2 + .t get insert +} y +test textIndex-2.13 {TkTextMakeCharIndex: verify index is in range} { + # not (segPtr->typePtr == &tkTextCharType) + + .t image create 5.2 -image textimage + .t mark set insert 5.5 + set x [.t get insert] + .t delete 5.2 + set x +} "G" +test textIndex-2.14 {TkTextMakeCharIndex: verify index is in range} { + # (charIndex < segPtr->size) -.t tag add x 2.3 2.6 -test textIndex-2.1 {TkTextIndexToSeg} { - .t get 2.0 -} a -test textIndex-2.2 {TkTextIndexToSeg} { - .t get 2.2 -} c -test textIndex-2.3 {TkTextIndexToSeg} { - .t get 2.3 -} d -test textIndex-2.4 {TkTextIndexToSeg} { - .t get 2.6 -} g -test textIndex-2.5 {TkTextIndexToSeg} { - .t get 2.7 -} h -test textIndex-2.6 {TkTextIndexToSeg} { - .t get 2.12 -} m -test textIndex-2.7 {TkTextIndexToSeg} { - .t get 2.13 -} \n -test textIndex-2.8 {TkTextIndexToSeg} { - .t get 2.14 -} \n -.t tag delete x + .t image create 5.0 -image textimage + set x [.t index 5.0] + .t delete 5.0 + set x +} 5.0 .t mark set foo 3.2 .t tag add x 2.8 2.11 @@ -242,8 +344,8 @@ test textIndex-10.4 {ForwBack} { list [catch {.t index {2.3 - 3ch}} msg] $msg } {0 2.0} test textIndex-10.5 {ForwBack} { - list [catch {.t index {2.3 + 3 lines}} msg] $msg -} {0 5.3} + list [catch {.t index {1.3 + 3 lines}} msg] $msg +} {0 4.3} test textIndex-10.6 {ForwBack} { list [catch {.t index {2.3 -1l}} msg] $msg } {0 1.3} @@ -253,97 +355,291 @@ test textIndex-10.7 {ForwBack} { test textIndex-10.8 {ForwBack} { list [catch {.t index {2.3 - 4 lines}} msg] $msg } {0 1.3} +test textIndex-10.9 {ForwBack} { + .t mark set insert 2.0 + list [catch {.t index {insert -0 chars}} msg] $msg +} {0 2.0} +test textIndex-10.10 {ForwBack} { + .t mark set insert 2.end + list [catch {.t index {insert +0 chars}} msg] $msg +} {0 2.13} -test textIndex-11.1 {TkTextIndexForwChars} { +test textIndex-11.1 {TkTextIndexForwBytes} { + testtext .t forwbytes 2.3 -7 +} {1.3 3} +test textIndex-11.2 {TkTextIndexForwBytes} { + testtext .t forwbytes 2.3 5 +} {2.8 8} +test textIndex-11.3 {TkTextIndexForwBytes} { + testtext .t forwbytes 2.3 10 +} {2.13 13} +test textIndex-11.4 {TkTextIndexForwBytes} { + testtext .t forwbytes 2.3 11 +} {3.0 0} +test textIndex-11.5 {TkTextIndexForwBytes} { + testtext .t forwbytes 2.3 57 +} {7.6 6} +test textIndex-11.6 {TkTextIndexForwBytes} { + testtext .t forwbytes 2.3 58 +} {8.0 0} +test textIndex-11.7 {TkTextIndexForwBytes} { + testtext .t forwbytes 2.3 59 +} {8.0 0} + +test textIndex-12.1 {TkTextIndexForwChars} { + # (charCount < 0) .t index {2.3 + -7 chars} } 1.3 -test textIndex-11.2 {TkTextIndexForwChars} { +test textIndex-12.2 {TkTextIndexForwChars} { + # not (charCount < 0) .t index {2.3 + 5 chars} } 2.8 -test textIndex-11.3 {TkTextIndexForwChars} { +test textIndex-12.3 {TkTextIndexForwChars: find index} { + # for ( ; segPtr != NULL; segPtr = segPtr->nextPtr) + # one loop + .t index {2.3 + 9 chars} +} 2.12 +test textIndex-12.4 {TkTextIndexForwChars: find index} { + # for ( ; segPtr != NULL; segPtr = segPtr->nextPtr) + # multiple loops + .t mark set foo 2.5 + set x [.t index {2.3 + 9 chars}] + .t mark unset foo + set x +} 2.12 +test textIndex-12.5 {TkTextIndexForwChars: find index} { + # for ( ; segPtr != NULL; segPtr = segPtr->nextPtr) + # border condition: last char + .t index {2.3 + 10 chars} } 2.13 -test textIndex-11.4 {TkTextIndexForwChars} { +test textIndex-12.6 {TkTextIndexForwChars: find index} { + # for ( ; segPtr != NULL; segPtr = segPtr->nextPtr) + # border condition: segPtr == NULL -> beginning of next line + .t index {2.3 + 11 chars} } 3.0 -test textIndex-11.5 {TkTextIndexForwChars} { - .t index {2.3 + 55 chars} -} 7.6 -test textIndex-11.6 {TkTextIndexForwChars} { +test textIndex-12.7 {TkTextIndexForwChars: find index} { + # (segPtr->typePtr == &tkTextCharType) + .t index {2.3 + 2 chars} +} 2.5 +test textIndex-12.8 {TkTextIndexForwChars: find index} { + # (charCount == 0) + # No more chars, so we found byte offset. + + .t index {2.3 + 2 chars} +} 2.5 +test textIndex-12.9 {TkTextIndexForwChars: find index} { + # not (segPtr->typePtr == &tkTextCharType) + + .t image create 2.4 -image textimage + set x [.t get {2.3 + 3 chars}] + .t delete 2.4 + set x +} "f" +test textIndex-12.10 {TkTextIndexForwChars: find index} { + # dstPtr->byteIndex += segPtr->size - byteOffset + # When moving to next segment, account for bytes in last segment. + # Wrong answer would be 2.4 + + .t mark set foo 2.4 + set x [.t index {2.3 + 5 chars}] + .t mark unset foo + set x +} 2.8 +test textIndex-12.11 {TkTextIndexForwChars: go to next line} { + # (linePtr == NULL) + .t index {7.6 + 3 chars} +} 8.0 +test textIndex-12.12 {TkTextIndexForwChars: go to next line} { + # Reset byteIndex to 0 now that we are on a new line. + # Wrong answer would be 2.9 + .t index {1.3 + 6 chars} +} 2.2 +test textIndex-12.13 {TkTextIndexForwChars} { + # right to end .t index {2.3 + 56 chars} } 8.0 -test textIndex-11.7 {TkTextIndexForwChars} { +test textIndex-12.14 {TkTextIndexForwChars} { + # try to go past end .t index {2.3 + 57 chars} } 8.0 -test textIndex-12.1 {TkTextIndexBackChars} { +test textIndex-13.1 {TkTextIndexBackBytes} { + testtext .t backbytes 3.2 -10 +} {4.6 6} +test textIndex-12.2 {TkTextIndexBackBytes} { + testtext .t backbytes 3.2 2 +} {3.0 0} +test textIndex-12.3 {TkTextIndexBackBytes} { + testtext .t backbytes 3.2 3 +} {2.13 13} +test textIndex-12.4 {TkTextIndexBackBytes} { + testtext .t backbytes 3.2 22 +} {1.1 1} +test textIndex-12.5 {TkTextIndexBackBytes} { + testtext .t backbytes 3.2 23 +} {1.0 0} +test textIndex-12.6 {TkTextIndexBackBytes} { + testtext .t backbytes 3.2 24 +} {1.0 0} + +test textIndex-14.1 {TkTextIndexBackChars} { + # (charCount < 0) .t index {3.2 - -10 chars} } 4.6 -test textIndex-12.2 {TkTextIndexBackChars} { +test textIndex-14.2 {TkTextIndexBackChars} { + # not (charCount < 0) .t index {3.2 - 2 chars} } 3.0 -test textIndex-12.3 {TkTextIndexBackChars} { +test textIndex-14.3 {TkTextIndexBackChars: find starting segment} { + # for (segPtr = dstPtr->linePtr->segPtr; ; segPtr = segPtr->nextPtr) + # single loop + .t index {3.2 - 3 chars} } 2.13 -test textIndex-12.4 {TkTextIndexBackChars} { +test textIndex-14.4 {TkTextIndexBackChars: find starting segment} { + # for (segPtr = dstPtr->linePtr->segPtr; ; segPtr = segPtr->nextPtr) + # multiple loop + + .t mark set foo1 2.5 + .t mark set foo2 2.7 + .t mark set foo3 2.10 + set x [.t index {2.9 - 1 chars}] + .t mark unset foo1 foo2 foo3 + set x +} 2.8 +test textIndex-14.5 {TkTextIndexBackChars: find starting seg and offset} { + # for (segPtr = dstPtr->linePtr->segPtr; ; segPtr = segPtr->nextPtr) + # Make sure segSize was decremented. Wrong answer would be 2.10 + + .t mark set foo 2.2 + set x [.t index {2.9 - 1 char}] + .t mark unset foo + set x +} 2.8 +test textIndex-14.6 {TkTextIndexBackChars: back over characters} { + # (segPtr->typePtr == &tkTextCharType) + .t index {3.2 - 22 chars} } 1.1 -test textIndex-12.5 {TkTextIndexBackChars} { - .t index {3.2 - 23 chars} -} 1.0 -test textIndex-12.6 {TkTextIndexBackChars} { - .t index {3.2 - 24 chars} +test textIndex-14.7 {TkTextIndexBackChars: loop backwards over chars} { + # (charCount == 0) + # No more chars, so we found byte offset. + + .t index {3.4 - 2 chars} +} 3.2 +test textIndex-14.8 {TkTextIndexBackChars: loop backwards over chars} { + # (p == start) + # Still more chars, but we reached beginning of segment + + .t image create 5.6 -image textimage + set x [.t index {5.8 - 3 chars}] + .t delete 5.6 + set x +} 5.5 +test textIndex-14.9 {TkTextIndexBackChars: back over image} { + # not (segPtr->typePtr == &tkTextCharType) + + .t image create 5.6 -image textimage + set x [.t get {5.8 - 4 chars}] + .t delete 5.6 + set x +} "G" +test textIndex-14.10 {TkTextIndexBackChars: move to previous segment} { + # (segPtr != oldPtr) + # More segments to go + + .t mark set foo 3.4 + set x [.t index {3.5 - 2 chars}] + .t mark unset foo + set x +} 3.3 +test textIndex-14.11 {TkTextIndexBackChars: move to previous segment} { + # not (segPtr != oldPtr) + # At beginning of line. + + .t mark set foo 3.4 + set x [.t index {3.5 - 10 chars}] + .t mark unset foo + set x +} 2.9 +test textIndex-14.12 {TkTextIndexBackChars: move to previous line} { + # (lineIndex == 0) + .t index {1.5 - 10 chars} } 1.0 +test textIndex-14.13 {TkTextIndexBackChars: move to previous line} { + # not (lineIndex == 0) + .t index {2.5 - 10 chars} +} 1.2 +test textIndex-14.14 {TkTextIndexBackChars: move to previous line} { + # for (segPtr = oldPtr; segPtr != NULL; segPtr = segPtr->nextPtr) + # Set byteIndex to end of previous line so we can subtract more + # bytes from it. Otherwise we get an TkTextIndex with a negative + # byteIndex. + + .t index {2.5 - 6 chars} +} 1.6 +test textIndex-14.15 {TkTextIndexBackChars: UTF} { + .t get {5.3 - 1 chars} +} y +test textIndex-14.16 {TkTextIndexBackChars: UTF} { + .t get {5.3 - 2 chars} +} \u4e4f +test textIndex-14.17 {TkTextIndexBackChars: UTF} { + .t get {5.3 - 3 chars} +} b proc getword index { .t get [.t index "$index wordstart"] [.t index "$index wordend"] } -test textIndex-13.1 {StartEnd} { +test textIndex-15.1 {StartEnd} { list [catch {.t index {2.3 lineend}} msg] $msg } {0 2.13} -test textIndex-13.2 {StartEnd} { +test textIndex-15.2 {StartEnd} { list [catch {.t index {2.3 linee}} msg] $msg } {0 2.13} -test textIndex-13.3 {StartEnd} { +test textIndex-15.3 {StartEnd} { list [catch {.t index {2.3 line}} msg] $msg } {1 {bad text index "2.3 line"}} -test textIndex-13.4 {StartEnd} { +test textIndex-15.4 {StartEnd} { list [catch {.t index {2.3 linestart}} msg] $msg } {0 2.0} -test textIndex-13.5 {StartEnd} { +test textIndex-15.5 {StartEnd} { list [catch {.t index {2.3 lines}} msg] $msg } {0 2.0} -test textIndex-13.6 {StartEnd} { +test textIndex-15.6 {StartEnd} { getword 5.3 } { } -test textIndex-13.7 {StartEnd} { +test textIndex-15.7 {StartEnd} { getword 5.4 } GIrl -test textIndex-13.8 {StartEnd} { +test textIndex-15.8 {StartEnd} { getword 5.7 } GIrl -test textIndex-13.9 {StartEnd} { +test textIndex-15.9 {StartEnd} { getword 5.8 } { } -test textIndex-13.10 {StartEnd} { +test textIndex-15.10 {StartEnd} { getword 5.14 } x_yz -test textIndex-13.11 {StartEnd} { +test textIndex-15.11 {StartEnd} { getword 6.2 } # -test textIndex-13.12 {StartEnd} { +test textIndex-15.12 {StartEnd} { getword 3.4 } 12345 .t tag add x 2.8 2.11 -test textIndex-13.13 {StartEnd} { +test textIndex-15.13 {StartEnd} { list [catch {.t index {2.2 worde}} msg] $msg } {0 2.13} -test textIndex-13.14 {StartEnd} { +test textIndex-15.14 {StartEnd} { list [catch {.t index {2.12 words}} msg] $msg } {0 2.0} -test textIndex-13.15 {StartEnd} { +test textIndex-15.15 {StartEnd} { list [catch {.t index {2.12 word}} msg] $msg } {1 {bad text index "2.12 word"}} +rename textimage {} catch {destroy .t} concat diff --git a/tests/textMark.test b/tests/textMark.test index 39a0961..058665e 100644 --- a/tests/textMark.test +++ b/tests/textMark.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) textMark.test 1.8 97/10/20 11:13:00 +# SCCS: @(#) textMark.test 1.9 98/01/12 12:45:56 if {[string compare test [info procs test]] == 1} then \ {source defs} diff --git a/tests/textTag.test b/tests/textTag.test index ae0d33a..4cc6fd4 100644 --- a/tests/textTag.test +++ b/tests/textTag.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) textTag.test 1.30 97/11/06 16:57:02 +# SCCS: @(#) textTag.test 1.31 97/12/16 16:20:48 if {[string compare test [info procs test]] == 1} then \ {source defs} @@ -183,7 +183,14 @@ test textTag-3.7 {TkTextTagCmd - "bind" option} { .t tag bind x <Enter> } {script1 script2} - +test textTag-3.7 {TkTextTagCmd - "bind" option} { + .t tag delete x + list [catch {.t tag bind x <Enter>} msg] $msg +} {0 {}} +test textTag-3.8 {TkTextTagCmd - "bind" option} { + .t tag delete x + list [catch {.t tag bind x <} msg] $msg +} {1 {no event type or button # or keysym}} test textTag-4.1 {TkTextTagCmd - "cget" option} { list [catch {.t tag cget a} msg] $msg diff --git a/tests/tk.test b/tests/tk.test index 94cec66..79d0c7a 100644 --- a/tests/tk.test +++ b/tests/tk.test @@ -6,7 +6,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) tk.test 1.3 97/05/20 15:17:44 +# SCCS: @(#) tk.test 1.4 97/12/23 08:58:39 if {[info commands test] == ""} { source defs @@ -17,7 +17,7 @@ test tk-1.1 {tk command: general} { } {1 {wrong # args: should be "tk option ?arg?"}} test tk-1.2 {tk command: general} { list [catch {tk xyz} msg] $msg -} {1 {bad option "xyz": must be appname, or scaling}} +} {1 {bad option "xyz": must be appname or scaling}} set appname [tk appname] test tk-2.1 {tk command: appname} { diff --git a/tests/unixFont.test b/tests/unixFont.test index edcce42..25255d3 100644 --- a/tests/unixFont.test +++ b/tests/unixFont.test @@ -13,7 +13,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) unixFont.test 1.7 97/06/24 13:34:24 +# SCCS: @(#) unixFont.test 1.9 97/10/13 11:11:25 if {$tcl_platform(platform)!="unix"} { return @@ -233,12 +233,12 @@ test unixfont-8.3 {AllocFont procedure: can't parse info from name} { } {0} test unixfont-8.4 {AllocFont procedure: classify characters} { set x 0 - incr x [font measure $courier "\001"] ;# 4 + 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*11] +} [expr $cx*13] test unixfont-8.5 {AllocFont procedure: setup widths of normal chars} { font metrics $courier -fixed } {1} @@ -281,7 +281,7 @@ test unixfont-9.1 {GetControlCharSubst procedure: 2 chars subst} { } {0 1 1 2} test unixfont-9.2 {GetControlCharSubst procedure: 4 chars subst} { .b.c dchars $t 0 end - .b.c insert $t 0 "0\1770" + .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] diff --git a/tests/unixMenu.test b/tests/unixMenu.test index dfcf252..679e9e0 100644 --- a/tests/unixMenu.test +++ b/tests/unixMenu.test @@ -8,7 +8,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) unixMenu.test 1.9 97/06/24 13:52:38 +# SCCS: @(#) unixMenu.test 1.10 97/10/13 13:10:04 if {$tcl_platform(platform) != "unix"} { return @@ -332,8 +332,8 @@ test unixMenu-18.1 {GetTearoffEntryGeometry} { .mb.m add command -label test pack .mb raise . - list [catch {tkMbPost .mb} msg] $msg [destroy .mb] -} {0 {} {}} + list [catch {tkMbPost .mb} msg] $msg [tkMenuUnpost .mb.m] [destroy .mb] +} {0 {} {} {}} # Don't know how to reproduce the case where the tkwin has been deleted. test unixMenu-19.1 {TkpComputeMenubarGeometry - zero entries} { @@ -848,8 +848,8 @@ test unixMenu-25.5 {TkpComputeStandardMenuGeometry - tearoff entry} {unixOnly} { .mb.m add command -label test pack .mb catch {tkMbPost .mb} - list [update] [destroy .mb] -} {{} {}} + list [update] [tkMenuUnpost .mb.m] [destroy .mb] +} {{} {} {}} test unixMenu-25.6 {TkpComputeStandardMenuGeometry - standard label geometry} { catch {destroy .m1} menu .m1 diff --git a/tests/send.test b/tests/unixSend.test index 7addb73..5626f06 100644 --- a/tests/send.test +++ b/tests/unixSend.test @@ -8,14 +8,13 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) send.test 1.26 96/12/09 17:26:42 +# SCCS: @(#) unixSend.test 1.28 97/10/21 10:05:26 if {$tcl_platform(platform) == "macintosh"} { puts "send is not available on the Mac - skipping tests" return } -if {$tcl_platform(platform) == "window"} { - puts "send is not available under Windows - skipping tests" +if {$tcl_platform(platform) == "windows"} { return } if {[auto_execok xhost] == ""} { @@ -81,19 +80,19 @@ catch {send t_s_1 destroy .} catch {send t_s_2 destroy .} if $gotTestCmds { - test send-1.1 {RegOpen procedure, bogus property} { + test unixSend-1.1 {RegOpen procedure, bogus property} { testsend bogus set result [winfo interps] tk appname tktest list $result [winfo interps] } {{} tktest} - test send-1.2 {RegOpen procedure, bogus property} { + test unixSend-1.2 {RegOpen procedure, bogus property} { testsend prop root InterpRegistry {} set result [winfo interps] tk appname tktest list $result [winfo interps] } {{} tktest} - test send-1.3 {RegOpen procedure, bogus property} { + test unixSend-1.3 {RegOpen procedure, bogus property} { testsend prop root InterpRegistry abcdefg tk appname tktest set x [testsend prop root InterpRegistry] @@ -102,52 +101,52 @@ if $gotTestCmds { frame .f -width 1 -height 1 set id [string range [winfo id .f] 2 end] - test send-2.1 {RegFindName procedure} { + test unixSend-2.1 {RegFindName procedure} { testsend prop root InterpRegistry {} list [catch {send foo bar} msg] $msg } {1 {no application named "foo"}} - test send-2.2 {RegFindName procedure} { + test unixSend-2.2 {RegFindName procedure} { testsend prop root InterpRegistry " abc\n def\nghi\n\n$id foo\n" tk appname foo } {foo #2} - test send-2.3 {RegFindName procedure} { + test unixSend-2.3 {RegFindName procedure} { testsend prop root InterpRegistry "gyz foo\n" tk appname foo } {foo} - test send-2.4 {RegFindName procedure} { + test unixSend-2.4 {RegFindName procedure} { testsend prop root InterpRegistry "${id}z foo\n" tk appname foo } {foo} - test send-3.1 {RegDeleteName procedure} { + test unixSend-3.1 {RegDeleteName procedure} { tk appname tktest testsend prop root InterpRegistry "012345 gorp\n12345 foo\n12345 tktest" tk appname x set x [testsend prop root InterpRegistry] string range $x [string first " " $x] end } " x\n012345 gorp\n12345 foo\n" - test send-3.2 {RegDeleteName procedure} { + test unixSend-3.2 {RegDeleteName procedure} { tk appname tktest testsend prop root InterpRegistry "012345 gorp\n12345 tktest\n23456 tktest" tk appname x set x [testsend prop root InterpRegistry] string range $x [string first " " $x] end } " x\n012345 gorp\n23456 tktest\n" - test send-3.3 {RegDeleteName procedure} { + test unixSend-3.3 {RegDeleteName procedure} { tk appname tktest testsend prop root InterpRegistry "012345 tktest\n12345 bar\n23456 tktest" tk appname x set x [testsend prop root InterpRegistry] string range $x [string first " " $x] end } " x\n12345 bar\n23456 tktest\n" - test send-3.4 {RegDeleteName procedure} { + test unixSend-3.4 {RegDeleteName procedure} { tk appname tktest testsend prop root InterpRegistry "foo" tk appname x set x [testsend prop root InterpRegistry] string range $x [string first " " $x] end } " x\nfoo\n" - test send-3.5 {RegDeleteName procedure} { + test unixSend-3.5 {RegDeleteName procedure} { tk appname tktest testsend prop root InterpRegistry "" tk appname x @@ -155,12 +154,12 @@ if $gotTestCmds { string range $x [string first " " $x] end } " x\n" - test send-4.1 {RegAddName procedure} { + test unixSend-4.1 {RegAddName procedure} { testsend prop root InterpRegistry "" tk appname bar testsend prop root InterpRegistry } "$commId bar\n" - test send-4.2 {RegAddName procedure} { + test unixSend-4.2 {RegAddName procedure} { testsend prop root InterpRegistry "abc def" tk appname bar tk appname foo @@ -169,19 +168,19 @@ if $gotTestCmds { # Previous checks should already cover the Regclose procedure. - test send-5.1 {ValidateName procedure} { + test unixSend-5.1 {ValidateName procedure} { testsend prop root InterpRegistry "123 abc\n" winfo interps } {} - test send-5.2 {ValidateName procedure} { + test unixSend-5.2 {ValidateName procedure} { testsend prop root InterpRegistry "$id Hi there" winfo interps } {{Hi there}} - test send-5.3 {ValidateName procedure} { + test unixSend-5.3 {ValidateName procedure} { testsend prop root InterpRegistry "$id Bogus" list [catch {send Bogus set a 44} msg] $msg } {1 {target application died or uses a Tk version before 4.0}} - test send-5.4 {ValidateName procedure} { + test unixSend-5.4 {ValidateName procedure} { tk appname test testsend prop root InterpRegistry "$commId Bogus\n$commId test\n" winfo interps @@ -196,16 +195,16 @@ set x [split [exec xhost] \n] foreach i [lrange $x 1 end] { exec xhost - $i } -test send-6.1 {ServerSecure procedure} {nonPortable} { +test unixSend-6.1 {ServerSecure procedure} {nonPortable} { set a 44 list [dobg [list send [tk appname] set a 55]] $a } {55 55} -test send-6.2 {ServerSecure procedure} {nonPortable} { +test unixSend-6.2 {ServerSecure procedure} {nonPortable} { set a 22 exec xhost [exec hostname] list [catch {dobg [list send [tk appname] set a 33]} msg] $a $msg } {0 22 {X server insecure (must use xauth-style authorization); command ignored}} -test send-6.3 {ServerSecure procedure} {nonPortable} { +test unixSend-6.3 {ServerSecure procedure} {nonPortable} { set a abc exec xhost - [exec hostname] list [dobg [list send [tk appname] set a new]] $a @@ -213,28 +212,28 @@ test send-6.3 {ServerSecure procedure} {nonPortable} { cleanupbg if $gotTestCmds { - test send-7.1 {Tk_SetAppName procedure} { + test unixSend-7.1 {Tk_SetAppName procedure} { testsend prop root InterpRegistry "" tk appname newName list [tk appname oldName] [testsend prop root InterpRegistry] } "oldName {$commId oldName\n}" - test send-7.2 {Tk_SetAppName procedure, name not in use} { + test unixSend-7.2 {Tk_SetAppName procedure, name not in use} { testsend prop root InterpRegistry "" list [tk appname gorp] [testsend prop root InterpRegistry] } "gorp {$commId gorp\n}" - test send-7.3 {Tk_SetAppName procedure, name in use by us} { + test unixSend-7.3 {Tk_SetAppName procedure, name in use by us} { tk appname name1 testsend prop root InterpRegistry "$commId name2\n" list [tk appname name2] [testsend prop root InterpRegistry] } "name2 {$commId name2\n}" - test send-7.4 {Tk_SetAppName procedure, name in use} { + test unixSend-7.4 {Tk_SetAppName procedure, name in use} { tk appname name1 testsend prop root InterpRegistry "$id foo\n$id foo #2\n$id foo #3\n" list [tk appname foo] [testsend prop root InterpRegistry] } "{foo #4} {$commId foo #4\n$id foo\n$id foo #2\n$id foo #3\n}" } -test send-8.1 {Tk_SendCmd procedure, options} { +test unixSend-8.1 {Tk_SendCmd procedure, options} { setupbg set app [dobg {tk appname}] set a 66 @@ -246,7 +245,7 @@ test send-8.1 {Tk_SendCmd procedure, options} { lappend result $a } {66 77} if [info exists env(TK_ALT_DISPLAY)] { - test send-8.2 {Tk_SendCmd procedure, options} { + test unixSend-8.2 {Tk_SendCmd procedure, options} { setupbg -display $env(TK_ALT_DISPLAY) tk appname xyzgorp set a homeDisplay @@ -261,29 +260,29 @@ if [info exists env(TK_ALT_DISPLAY)] { set result } {altDisplay homeDisplay} } -test send-8.3 {Tk_SendCmd procedure, options} { +test unixSend-8.3 {Tk_SendCmd procedure, options} { list [catch {send -- -async foo bar baz} msg] $msg } {1 {no application named "-async"}} -test send-8.4 {Tk_SendCmd procedure, options} { +test unixSend-8.4 {Tk_SendCmd procedure, options} { list [catch {send -gorp foo bar baz} msg] $msg } {1 {bad option "-gorp": must be -async, -displayof, or --}} -test send-8.5 {Tk_SendCmd procedure, options} { +test unixSend-8.5 {Tk_SendCmd procedure, options} { list [catch {send -async foo} msg] $msg } {1 {wrong # args: should be "send ?options? interpName arg ?arg ...?"}} -test send-8.6 {Tk_SendCmd procedure, options} { +test unixSend-8.6 {Tk_SendCmd procedure, options} { list [catch {send foo} msg] $msg } {1 {wrong # args: should be "send ?options? interpName arg ?arg ...?"}} -test send-8.7 {Tk_SendCmd procedure, local execution} { +test unixSend-8.7 {Tk_SendCmd procedure, local execution} { set a initial send [tk appname] {set a new} set a } {new} -test send-8.8 {Tk_SendCmd procedure, local execution} { +test unixSend-8.8 {Tk_SendCmd procedure, local execution} { set a initial send [tk appname] set a new set a } {new} -test send-8.9 {Tk_SendCmd procedure, local execution} { +test unixSend-8.9 {Tk_SendCmd procedure, local execution} { set a initial string tolower [list [catch {send [tk appname] open bad_file} msg] \ $msg $errorInfo $errorCode] @@ -292,41 +291,43 @@ test send-8.9 {Tk_SendCmd procedure, local execution} { "open bad_file" invoked from within "send [tk appname] open bad_file"} {posix enoent {no such file or directory}}} -test send-8.10 {Tk_SendCmd procedure, no such interpreter} { +test unixSend-8.10 {Tk_SendCmd procedure, no such interpreter} { list [catch {send bogus_name bogus_command} msg] $msg } {1 {no application named "bogus_name"}} if $gotTestCmds { newApp "" t_s_1 Test t_s_1 eval wm withdraw . - test send-8.11 {Tk_SendCmd procedure, local execution, different interp} { + test unixSend-8.11 {Tk_SendCmd procedure, local execution, different interp} { set a us send t_s_1 set a them list $a [send t_s_1 set a] } {us them} - test send-8.12 {Tk_SendCmd procedure, local execution, different interp} { + test unixSend-8.12 {Tk_SendCmd procedure, local execution, different interp} { set a us send t_s_1 {set a them} list $a [send t_s_1 {set a}] } {us them} - test send-8.13 {Tk_SendCmd procedure, local execution, different interp} { + test unixSend-8.13 {Tk_SendCmd procedure, local execution, different interp} { set a us send t_s_1 {set a them} list $a [send t_s_1 {set a}] } {us them} - test send-8.14 {Tk_SendCmd procedure, local interp killed by send} { + test unixSend-8.14 {Tk_SendCmd procedure, local interp killed by send} { newApp "" t_s_2 Test list [catch {send t_s_2 {destroy .; concat result}} msg] $msg } {0 result} interp delete t_s_2 - test send-8.15 {Tk_SendCmd procedure, local interp, error info} { + test unixSend-8.15 {Tk_SendCmd procedure, local interp, error info} { catch {error foo} list [catch {send t_s_1 {if 1 {open bogus_file_name}}} msg] $msg $errorInfo $errorCode } {1 {couldn't open "bogus_file_name": no such file or directory} {couldn't open "bogus_file_name": no such file or directory while executing "open bogus_file_name" invoked from within +"if 1 {open bogus_file_name}" + invoked from within "send t_s_1 {if 1 {open bogus_file_name}}"} {POSIX ENOENT {no such file or directory}}} - test send-8.16 {Tk_SendCmd procedure, bogusCommWindow} { + test unixSend-8.16 {Tk_SendCmd procedure, bogusCommWindow} { testsend prop root InterpRegistry "10234 bogus\n" set result [list [catch {send bogus bogus command} msg] $msg] winfo interps @@ -335,7 +336,7 @@ if $gotTestCmds { } {1 {no application named "bogus"}} interp delete t_s_1 } -test send-8.17 {Tk_SendCmd procedure, deferring events} {nonPortable} { +test unixSend-8.17 {Tk_SendCmd procedure, deferring events} {nonPortable} { # Non-portable because some window managers ignore "raise" # requests so can't guarantee that new app's window won't # obscure .f, thereby masking the Expose event. @@ -355,7 +356,7 @@ test send-8.17 {Tk_SendCmd procedure, deferring events} {nonPortable} { cleanupbg lappend result $a } {{no event yet} {no event yet} exposed} -test send-8.18 {Tk_SendCmd procedure, error in remote app} { +test unixSend-8.18 {Tk_SendCmd procedure, error in remote app} { setupbg set app [dobg {tk appname}] set result [string tolower [list [catch {send $app open bad_name} msg] \ @@ -367,7 +368,7 @@ test send-8.18 {Tk_SendCmd procedure, error in remote app} { "open bad_name" invoked from within "send $app open bad_name"} {posix enoent {no such file or directory}}} -test send-8.19 {Tk_SendCmd, using modal timeouts} { +test unixSend-8.19 {Tk_SendCmd, using modal timeouts} { setupbg set app [dobg {tk appname}] set x no @@ -385,29 +386,29 @@ catch {destroy .f} frame .f set id [string range [winfo id .f] 2 end] if $gotTestCmds { - test send-9.1 {Tk_GetInterpNames procedure} { + test unixSend-9.1 {Tk_GetInterpNames procedure} { testsend prop root InterpRegistry \ "$commId tktest\nfoo bar\n$commId tktest\n$id frame .f\n\n\n" list [winfo interps] [testsend prop root InterpRegistry] } "{tktest tktest {frame .f}} {$commId tktest\n$commId tktest\n$id frame .f }" - test send-9.2 {Tk_GetInterpNames procedure} { + test unixSend-9.2 {Tk_GetInterpNames procedure} { testsend prop root InterpRegistry \ "$commId tktest\nfoobar\n$commId gorp\n" list [winfo interps] [testsend prop root InterpRegistry] } "tktest {$commId tktest\n}" - test send-9.3 {Tk_GetInterpNames procedure} { + test unixSend-9.3 {Tk_GetInterpNames procedure} { testsend prop root InterpRegistry {} list [winfo interps] [testsend prop root InterpRegistry] } {{} {}} testsend prop root InterpRegistry "$commId tktest\n$id dummy\n" - test send-10.1 {SendEventProc procedure, bogus comm property} { + test unixSend-10.1 {SendEventProc procedure, bogus comm property} { testsend prop comm Comm {abc def} testsend prop comm Comm {} update } {} - test send-10.2 {SendEventProc procedure, simultaneous messages} { + test unixSend-10.2 {SendEventProc procedure, simultaneous messages} { testsend prop comm Comm \ "c\n-n tktest\n-s set a 44\nc\n-n tktest\n-s set b 45\n" set a null @@ -415,7 +416,7 @@ if $gotTestCmds { update list $a $b } {44 45} - test send-10.3 {SendEventProc procedure, simultaneous messages} { + test unixSend-10.3 {SendEventProc procedure, simultaneous messages} { testsend prop comm Comm \ "c\n-n tktest\n-s set a newA\nr\n-s [testsend serial]\n-r 12345\nc\n-n tktest\n-s set b newB\n" set a null @@ -423,21 +424,21 @@ if $gotTestCmds { set x [send dummy bogus] list $x $a $b } {12345 newA newB} - test send-10.4 {SendEventProc procedure, leading nulls, bogus commands} { + test unixSend-10.4 {SendEventProc procedure, leading nulls, bogus commands} { testsend prop comm Comm \ "\n\nx\n-bogus\n\nc\n-n tktest\n-s set a 44\n" set a null update set a } {44} - test send-10.5 {SendEventProc procedure, extraneous command options} { + test unixSend-10.5 {SendEventProc procedure, extraneous command options} { testsend prop comm Comm \ "c\n-n tktest\n-x miscellanous\n-y who knows?\n-s set a new\n" set a null update set a } {new} - test send-10.6 {SendEventProc procedure, unknown interpreter} { + test unixSend-10.6 {SendEventProc procedure, unknown interpreter} { testsend prop [winfo id .f] Comm {} testsend prop comm Comm \ "c\n-n unknown\n-r $id 44\n-s set a new\n" @@ -445,7 +446,7 @@ if $gotTestCmds { update list [testsend prop [winfo id .f] Comm] $a } "{\nr\n-s 44\n-r receiver never heard of interpreter \"unknown\"\n-c 1\n} null" - test send-10.7 {SendEventProc procedure, error in script} { + test unixSend-10.7 {SendEventProc procedure, error in script} { testsend prop [winfo id .f] Comm {} testsend prop comm Comm \ "c\n-n tktest\n-r $id 62\n-s foreach i {1 2 3} {error {test error} {Initial errorInfo} {test code}}\n" @@ -462,7 +463,7 @@ r -e test code -c 1 } - test send-10.8 {SendEventProc procedure, exceptional return} { + test unixSend-10.8 {SendEventProc procedure, exceptional return} { testsend prop [winfo id .f] Comm {} testsend prop comm Comm \ "c\n-n tktest\n-r $id 62\n-s break\n" @@ -474,7 +475,7 @@ r -r -c 3 } - test send-10.9 {SendEventProc procedure, empty return} { + test unixSend-10.9 {SendEventProc procedure, empty return} { testsend prop [winfo id .f] Comm {} testsend prop comm Comm \ "c\n-n tktest\n-r $id 62\n-s concat\n" @@ -485,64 +486,64 @@ r -s 62 -r } - test send-10.10 {SendEventProc procedure, asynchronous calls} { + test unixSend-10.10 {SendEventProc procedure, asynchronous calls} { testsend prop [winfo id .f] Comm {} testsend prop comm Comm \ "c\n-n tktest\n-s foreach i {1 2 3} {error {test error} {Initial errorInfo} {test code}}\n" update testsend prop [winfo id .f] Comm } {} - test send-10.11 {SendEventProc procedure, exceptional return} { + test unixSend-10.11 {SendEventProc procedure, exceptional return} { testsend prop [winfo id .f] Comm {} testsend prop comm Comm \ "c\n-n tktest\n-s break\n" update testsend prop [winfo id .f] Comm } {} - test send-10.12 {SendEventProc procedure, empty return} { + test unixSend-10.12 {SendEventProc procedure, empty return} { testsend prop [winfo id .f] Comm {} testsend prop comm Comm \ "c\n-n tktest\n-s concat\n" update testsend prop [winfo id .f] Comm } {} - test send-10.13 {SendEventProc procedure, return processing} { + test unixSend-10.13 {SendEventProc procedure, return processing} { testsend prop comm Comm \ "r\n-c 1\n-e test1\n-i test2\n-r test3\n-s [testsend serial]\n" list [catch {send dummy foo} msg] $msg $errorInfo $errorCode } {1 test3 {test2 invoked from within "send dummy foo"} test1} - test send-10.14 {SendEventProc procedure, extraneous return options} { + test unixSend-10.14 {SendEventProc procedure, extraneous return options} { testsend prop comm Comm \ "r\n-x test1\n-y test2\n-r result\n-s [testsend serial]\n" list [catch {send dummy foo} msg] $msg } {0 result} - test send-10.15 {SendEventProc procedure, serial number} { + test unixSend-10.15 {SendEventProc procedure, serial number} { testsend prop comm Comm \ "r\n-r response\n" list [catch {send dummy foo} msg] $msg } {1 {target application died or uses a Tk version before 4.0}} - test send-10.16 {SendEventProc procedure, serial number} { + test unixSend-10.16 {SendEventProc procedure, serial number} { testsend prop comm Comm \ "r\n-r response\n\n-s 0" list [catch {send dummy foo} msg] $msg } {1 {target application died or uses a Tk version before 4.0}} - test send-10.17 {SendEventProc procedure, errorCode and errorInfo} { + test unixSend-10.17 {SendEventProc procedure, errorCode and errorInfo} { testsend prop comm Comm \ "r\n-i test1\n-e test2\n-c 4\n-s [testsend serial]\n" set errorCode oldErrorCode set errorInfo oldErrorInfo list [catch {send dummy foo} msg] $msg $errorInfo $errorCode } {4 {} oldErrorInfo oldErrorCode} - test send-10.18 {SendEventProc procedure, send kills application} { + test unixSend-10.18 {SendEventProc procedure, send kills application} { setupbg dobg {tk appname t_s_3} set x [list [catch {send t_s_3 destroy .} msg] $msg] cleanupbg set x } {0 {}} - test send-10.19 {SendEventProc procedure, send exits} { + test unixSend-10.19 {SendEventProc procedure, send exits} { setupbg dobg {tk appname t_s_3} set x [list [catch {send t_s_3 exit} msg] $msg] @@ -550,11 +551,11 @@ r set x } {1 {target application died}} - test send-11.1 {AppendPropCarefully and AppendErrorProc procedures} { + test unixSend-11.1 {AppendPropCarefully and AppendErrorProc procedures} { testsend prop root InterpRegistry "0x21447 dummy\n" list [catch {send dummy foo} msg] $msg } {1 {no application named "dummy"}} - test send-11.2 {AppendPropCarefully and AppendErrorProc procedures} { + test unixSend-11.2 {AppendPropCarefully and AppendErrorProc procedures} { testsend prop comm Comm "c\n-r0x123 44\n-n tktest\n-s concat a b c\n" update } {} @@ -566,13 +567,13 @@ catch {destroy .f} frame .f set id [string range [winfo id .f] 2 end] if $gotTestCmds { - test send-12.1 {TimeoutProc procedure} { + test unixSend-12.1 {TimeoutProc procedure} { testsend prop root InterpRegistry "$id dummy\n" list [catch {send dummy foo} msg] $msg } {1 {target application died or uses a Tk version before 4.0}} testsend prop root InterpRegistry "" } -test send-12.2 {TimeoutProc procedure} { +test unixSend-12.2 {TimeoutProc procedure} { winfo interps tk appname tktest update @@ -591,14 +592,14 @@ test send-12.2 {TimeoutProc procedure} { winfo interps tk appname tktest -test send-13.1 {DeleteProc procedure} { +test unixSend-13.1 {DeleteProc procedure} { setupbg set app [dobg {rename send {}; tk appname}] set result [list [catch {send $app foo} msg] $msg [winfo interps]] cleanupbg set result } {1 {no application named "tktest #2"} tktest} -test send-13.2 {DeleteProc procedure} { +test unixSend-13.2 {DeleteProc procedure} { winfo interps tk appname tktest rename send {} @@ -609,7 +610,7 @@ test send-13.2 {DeleteProc procedure} { } {{} {} foo send} if [info exists env(TK_ALT_DISPLAY)] { - test send-14.1 {SendRestrictProc procedure, sends crossing from different displays} { + test unixSend-14.1 {SendRestrictProc procedure, sends crossing from different displays} { setupbg -display $env(TK_ALT_DISPLAY) set result [dobg " toplevel .t -screen [winfo screen .] @@ -632,7 +633,7 @@ if [info exists env(TK_ALT_DISPLAY)] { if $gotTestCmds { testsend prop root InterpRegister $registry tk appname tktest - test send-15.1 {UpdateCommWindow procedure} { + test unixSend-15.1 {UpdateCommWindow procedure} { set x [list [testsend prop comm TK_APPLICATION]] newApp "" t_s_1 Test send t_s_1 wm withdraw . diff --git a/tests/unixWm.test b/tests/unixWm.test index b165826..1845390 100644 --- a/tests/unixWm.test +++ b/tests/unixWm.test @@ -8,7 +8,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) unixWm.test 1.46 97/10/27 16:15:36 +# SCCS: @(#) unixWm.test 1.47 98/01/20 14:20:10 if {$tcl_platform(platform) != "unix"} { return @@ -2285,6 +2285,37 @@ test unixWm-57.2 {MenubarReqProc procedure} {unixOnly} { lappend result [expr [winfo rootx .t] - $x] [expr [winfo rooty .t] - $y] } {0 20 0 1} +test unixWm-58.1 {UpdateCommand procedure, DString gets reallocated} {unixOnly} { + catch {destroy .t} + toplevel .t -width 100 -height 50 + wm geom .t +0+0 + wm command .t "argumentNumber0 argumentNumber1 argumentNumber2 argumentNumber0 argumentNumber3 argumentNumber4 argumentNumber5 argumentNumber6 argumentNumber0 argumentNumber7 argumentNumber8 argumentNumber9 argumentNumber10 argumentNumber0 argumentNumber11 argumentNumber12 argumentNumber13 argumentNumber14 argumentNumber15 argumentNumber16 argumentNumber17 argumentNumber18" + update + testprop [testwrapper .t] WM_COMMAND +} {argumentNumber0 +argumentNumber1 +argumentNumber2 +argumentNumber0 +argumentNumber3 +argumentNumber4 +argumentNumber5 +argumentNumber6 +argumentNumber0 +argumentNumber7 +argumentNumber8 +argumentNumber9 +argumentNumber10 +argumentNumber0 +argumentNumber11 +argumentNumber12 +argumentNumber13 +argumentNumber14 +argumentNumber15 +argumentNumber16 +argumentNumber17 +argumentNumber18 +} + # Test exit processing and cleanup: test unixWm-58.1 {exit processing} { diff --git a/tests/winDialog.test b/tests/winDialog.test new file mode 100644 index 0000000..34a6dae --- /dev/null +++ b/tests/winDialog.test @@ -0,0 +1,316 @@ +# 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. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) winDialog.test 1.4 97/08/06 18:19:56 + +if {$tcl_platform(os) != "Windows NT"} { + return +} + +if {[info procs test] != "test"} { + source defs +} + +set testConfig(interactive) [info exists INTERACTIVE] + +testwinevent debug 1 + +eval destroy [winfo children .] +wm geometry . {} +raise . + +proc start {arg} { + set ::tk_dialog 0 + + after 1 "$arg" +} + +proc then {cmd} { + set ::command $cmd + set ::dialogresult {} + + afterbody + vwait ::dialogresult + return $::dialogresult +} + +proc afterbody {} { + if {$::tk_dialog == 0} { + after 100 {afterbody} + return + } + uplevel #0 {set dialogresult [eval $command]} +} + +proc Click {button} { + testwinevent $::tk_dialog $button WM_LBUTTONDOWN 1 0x000a000b + testwinevent $::tk_dialog $button WM_LBUTTONUP 0 0x000a000b +} + +proc GetText {button} { + return [testwinevent $::tk_dialog $button WM_GETTEXT] +} + +proc SetText {button text} { + return [testwinevent $::tk_dialog $button WM_SETTEXT $text] +} + +test winDialog-1.1 {Tk_ChooseColorObjCmd} { +} {} + +test winDialog-2.1 {ColorDlgHookProc} { +} {} + +test winDialog-3.1 {Tk_GetOpenFileObjCmd} { + start {tk_getOpenFile} + then { + set x [GetText 2] + Click 2 + } + set x +} {Cancel} + +test winDialog-4.1 {Tk_GetSaveFileObjCmd} { + start {tk_getSaveFile} + then { + set x [GetText 2] + Click 2 + } + set x +} {Cancel} + +test winDialog-5.1 {GetFileName: no arguments} { + start {tk_getOpenFile -title Open} + then { + Click cancel + } +} {0} +test winDialog-5.2 {GetFileName: one argument} { + list [catch {tk_getOpenFile -foo} msg] $msg +} {1 {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -parent, or -title}} +test winDialog-5.4 {GetFileName: many arguments} { + start {tk_getOpenFile -initialdir c:/ -parent . -title test -initialfile foo} + then { + Click cancel + } +} {0} +test winDialog-5.5 {GetFileName: Tcl_GetIndexFromObj() != TCL_OK} { + list [catch {tk_getOpenFile -foo bar -abc} msg] $msg +} {1 {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -parent, or -title}} +test winDialog-5.6 {GetFileName: Tcl_GetIndexFromObj() == TCL_OK} { + start {tk_getOpenFile -title bar} + then { + Click cancel + } +} {0} +test winDialog-5.7 {GetFileName: valid option, but missing value} { + list [catch {tk_getOpenFile -initialdir bar -title} msg] $msg +} {1 {value for "-title" missing}} +test winDialog-5.8 {GetFileName: extension begins with .} { +# if (string[0] == '.') { +# string++; +# } + + start {set x [tk_getSaveFile -defaultextension .foo -title Save]} + then { + SetText 0x480 bar + Click 1 + } + set x +} [file join [pwd] bar.foo] +test winDialog-5.9 {GetFileName: extension doesn't begin with .} { + start {set x [tk_getSaveFile -defaultextension foo -title Save]} + then { + SetText 0x480 bar + Click 1 + } + set x +} [file join [pwd] bar.foo] +test winDialog-5.10 {GetFileName: file types} { +# case FILE_TYPES: + + start {tk_getSaveFile -filetypes {{"foo files" .foo FOOF}} -title Foo} + then { + set x [GetText 0x470] + Click cancel + } + set x +} {foo files (*.foo)} +test winDialog-5.11 {GetFileName: file types: MakeFilter() fails} { +# if (MakeFilter(interp, string, &utfFilterString) != TCL_OK) + + list [catch {tk_getSaveFile -filetypes {{"foo" .foo FOO}}} msg] $msg +} {1 {bad Macintosh file type "FOO"}} +test winDialog-5.12 {GetFileName: initial directory} { +# case FILE_INITDIR: + + start {set x [tk_getSaveFile -initialdir c:/ -initialfile "12x 455" -title Foo]} + then { + Click 1 + } + set x +} {C:/12x 455} +test winDialog-5.13 {GetFileName: initial directory: Tcl_TranslateFilename()} { +# if (Tcl_TranslateFileName(interp, string, &ds) == NULL) + + list [catch {tk_getOpenFile -initialdir ~12x/455} msg] $msg +} {1 {user "12x" doesn't exist}} +test winDialog-5.14 {GetFileName: initial file} { +# case FILE_INITFILE: + + start {set x [tk_getSaveFile -initialfile "12x 456" -title Foo]} + then { + Click 1 + } + set x +} [file join [pwd] "12x 456"] +test winDialog-5.15 {GetFileName: initial file: Tcl_TranslateFileName()} { +# if (Tcl_TranslateFileName(interp, string, &ds) == NULL) + list [catch {tk_getOpenFile -initialfile ~12x/455} msg] $msg +} {1 {user "12x" doesn't exist}} +set a aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa +append a $a +append a $a +append a $a +append a $a +test winDialog-5.16 {GetFileName: initial file: long name} { + start {set x [tk_getSaveFile -initialfile $a -title Long]} + then { + Click 1 + } + set x +} [string range [file join [pwd] $a] 0 257] +test winDialog-5.17 {GetFileName: parent} { +# case FILE_PARENT: + + toplevel .t + set x 0 + start {tk_getOpenFile -parent .t -title Parent; set x 1} + then { + destroy .t + } + set x +} {1} +test winDialog-5.18 {GetFileName: title} { +# case FILE_TITLE: + + start {tk_getOpenFile -title Narf} + then { + Click 2 + } +} {0} +test winDialog-5.19 {GetFileName: no filter specified} { +# if (ofn.lpstrFilter == NULL) + + start {tk_getOpenFile -title Filter} + then { + set x [GetText 0x470] + Click 2 + } + set x +} {All Files (*.*)} +test winDialog-5.20 {GetFileName: parent HWND doesn't yet exist} { +# if (Tk_WindowId(parent) == None) + + toplevel .t + start {tk_getOpenFile -parent .t -title Open} + then { + destroy .t + } +} {} +test winDialog-5.21 {GetFileName: parent HWND already exists} { + toplevel .t + update + start {tk_getOpenFile -parent .t -title Open} + then { + destroy .t + } +} {} +test winDialog-5.22 {GetFileName: call GetOpenFileName} { +# winCode = GetOpenFileName(&ofn); + + start {tk_getOpenFile -title Open} + then { + set x [GetText 1] + Click 2 + } + set x +} {&Open} +test winDialog-5.22 {GetFileName: call GetSaveFileName} { +# winCode = GetSaveFileName(&ofn); + + start {tk_getSaveFile -title Save} + then { + set x [GetText 1] + Click 2 + } + set x +} {&Save} +test winDialog-5.22 {GetFileName: convert \ to /} { + start {set x [tk_getSaveFile -title Back]} + then { + SetText 0x480 "c:\\12x 457" + Click 1 + } + set x +} {c:/12x 457} + +test winDialog-8.1 {OFNHookProc} { +} {} + +test winDialog-6.1 {MakeFilter} { +} {} + +test winDialog-5.1 {Tk_ChooseDirectoryObjCmd: no arguments} { + start {tk_chooseDirectory} + then { + Click cancel + } +} {0} +test winDialog-5.2 {Tk_ChooseDirectoryObjCmd: one argument} { + list [catch {tk_chooseDirectory -foo} msg] $msg +} {1 {bad option "-foo": must be -initialdir, -mustexist, -parent, or -title}} +test winDialog-5.4 {Tk_ChooseDirectoryObjCmd: many arguments} { + start {tk_chooseDirectory -initialdir c:/ -mustexist 1 -parent . -title test} + then { + Click cancel + } +} {0} +test winDialog-5.5 {Tk_ChooseDirectoryObjCmd: Tcl_GetIndexFromObj() != TCL_OK} { + list [catch {tk_chooseDirectory -foo bar -abc} msg] $msg +} {1 {bad option "-foo": must be -initialdir, -mustexist, -parent, or -title}} +test winDialog-5.6 {Tk_ChooseDirectoryObjCmd: Tcl_GetIndexFromObj() == TCL_OK} { + start {tk_chooseDirectory -title bar} + then { + Click cancel + } +} {0} +test winDialog-5.7 {Tk_ChooseDirectoryObjCmd: valid option, but missing value} { + list [catch {tk_chooseDirectory -initialdir bar -title} msg] $msg +} {1 {value for "-title" missing}} +test winDialog-5.12 {Tk_ChooseDirectoryObjCmd: initial directory} { +# case DIR_INITIAL: + + start {set x [tk_chooseDirectory -initialdir c:/ -title Foo]} + then { + Click 1 + } + string tolower [set x] +} {c:/} +test winDialog-5.13 {Tk_ChooseDirectoryObjCmd: initial directory: Tcl_TranslateFilename()} { +# if (Tcl_TranslateFileName(interp, string, +# &utfDirString) == NULL) + + list [catch {tk_chooseDirectory -initialdir ~12x/455} msg] $msg +} {1 {user "12x" doesn't exist}} + +test winDialog-7.1 {Tk_MessageBoxObjCmd} { +} {} + +testwinevent debug 0 diff --git a/tests/winMenu.test b/tests/winMenu.test index ceeced6..7a3a9a9 100644 --- a/tests/winMenu.test +++ b/tests/winMenu.test @@ -8,7 +8,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) winMenu.test 1.19 97/07/02 11:29:57 +# SCCS: @(#) winMenu.test 1.20 98/01/26 19:43:03 if {$tcl_platform(platform) != "windows"} { return @@ -374,32 +374,47 @@ test winMenu-11.2 {TkWinHandleMenuEvent - WM_COMMAND} {menuInteractive} { .m1 add checkbutton -variable foo -label "winMenu-11.2: Please select this menu item." list [.m1 post 40 40] [update] [set foo] [unset foo] [destroy .m1] } {{} {} 1 {} {}} +test winMenu-11.3 {TkWinHandleMenuEvent - WM_COMMAND} {menuInteractive} { + catch {destroy .m1} + catch {unset foo} + proc bgerror {args} { + global foo errorInfo + set foo [list $args $errorInfo] + } + menu .m1 + .m1 add command -command {error 1} -label "winMenu-11.2: Please select this menu item." + list [.m1 post 40 40] [update] [set foo] [unset foo] [destroy .m1] +} {{} {} {1 {1 + while executing +"error 1" + (menu invoke)}} {} {}} + # Can't test WM_MENUCHAR -test winMenu-11.3 {TkWinHandleMenuEvent - WM_MEASUREITEM} {menuInteractive} { +test winMenu-11.4 {TkWinHandleMenuEvent - WM_MEASUREITEM} {menuInteractive} { catch {destroy .m1} menu .m1 .m1 add command -label "winMenu-11.3: Hit ESCAPE." list [.m1 post 40 40] [destroy .m1] } {{} {}} -test winMenu-11.4 {TkWinHandleMenuEvent - WM_MEASUREITEM} {menuInteractive} { +test winMenu-11.5 {TkWinHandleMenuEvent - WM_MEASUREITEM} {menuInteractive} { catch {destroy .m1} menu .m1 .m1 add checkbutton -label "winMenu-11.4: Hit ESCAPE" -hidemargin 1 list [.m1 post 40 40] [destroy .m1] } {{} {}} -test winMenu-11.5 {TkWinHandleMenuEvent - WM_DRAWITEM} {menuInteractive} { +test winMenu-11.6 {TkWinHandleMenuEvent - WM_DRAWITEM} {menuInteractive} { catch {destroy .m1} menu .m1 .m1 add command -label "winMenu-11.5: Hit ESCAPE." list [.m1 post 40 40] [destroy .m1] } {{} {}} -test winMenu-11.6 {TkWinHandleMenuEvent - WM_DRAWITEM - item disabled} {menuInteractive} { +test winMenu-11.7 {TkWinHandleMenuEvent - WM_DRAWITEM - item disabled} {menuInteractive} { catch {destroy .m1} menu .m1 .m1 add command -label "winMenu-11.6: Hit ESCAPE." -state disabled list [.m1 post 40 40] [destroy .m1] } {{} {}} -test winMenu-11.7 {TkWinHandleMenuEvent - WM_INITMENU - not pending} {menuInteractive} { +test winMenu-11.8 {TkWinHandleMenuEvent - WM_INITMENU - not pending} {menuInteractive} { catch {destroy .m1} menu .m1 -tearoff 0 .m1 add command -label "winMenu-11.7: Hit ESCAPE" diff --git a/tests/winSend.test b/tests/winSend.test new file mode 100644 index 0000000..a4fab43 --- /dev/null +++ b/tests/winSend.test @@ -0,0 +1,415 @@ +# 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. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) winSend.test 1.3 98/02/11 18:05:48 + +if {$tcl_platform(platform) != "windows"} { + return +} + +if {[info procs test] != "test"} { + source defs +} + +foreach i [winfo children .] { + destroy $i +} +wm geometry . {} +raise . + +set currentInterps [winfo interps] + +if {[catch {exec tktest &}] == 1} { + puts "Could not run winSend.test because another instance of tktest could not be loaded." + return; +} + +# 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} +} + +# 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. +if {[catch {send $interp {console hide; update}}] == 1} { + puts "Could not send to child interpreter $interp" + return +} + +# 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} { + 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} { + 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} { + newApp testApp + list [testApp eval tk appname testApp] [interp delete testApp] +} {testApp {}} +test winSend-1.4 {Tk_SetAppName - unique name - one conflict} { + 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} { + 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} { + 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} { + list [catch {send tktest} msg] $msg +} {1 {wrong # args: should be "send ?options? interpName arg ?arg ...?"}} +test winSend-2.1 {Tk_SendObjCmd: arguments} { + list [catch {send -bogus tktest} msg] $msg +} {1 {bad option "-bogus": must be -async, -displayof, or --}} +test winSend-2.1 {Tk_SendObjCmd: arguments} { + list [catch {send -async bogus foo} msg] $msg +} {1 {no registered server named "bogus"}} +test winSend-2.1 {Tk_SendObjCmd: arguments} { + list [catch {send -displayof . bogus foo} msg] $msg +} {1 {no registered server named "bogus"}} +test winSend-2.1 {Tk_SendObjCmd: arguments} { + list [catch {send -- -bogus foo} msg] $msg +} {1 {no registered server named "-bogus"}} +test winSend-2.2 {Tk_SendObjCmd - sending to ourselves} { + list [send [tk appname] {set foo a}] +} {a} +test winSend-2.3 {Tk_SendObjCmd - sending to ourselves in a different interpreter} { + 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} { + 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} { + 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} { + 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} { + 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} { + set origLength [llength $currentInterps] + set newLength [llength [winfo interps]] + expr {($newLength - 2) == $origLength} +} {1} + +test winSend-4.1 {DeleteProc - changing name of app} { + newApp a + list [a eval tk appname foo] [interp delete a] +} {foo {}} +test winSend-4.2 {DeleteProc - normal} { + newApp a + list [interp delete a] +} {{}} + +test winSend-5.1 {ExecuteRemoteObject - no error} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + newApp testApp + list [interp delete testApp] +} {{}} + +test winSend-8.1 {SendDdeConnect} { + 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} { + list [catch {dde execute Tk foo {set foo hello}} msg] $msg +} {1 {dde command failed}} + +test winSend-10.1 {Tk_DDEObjCmd - wrong num args} { + list [catch {dde} msg] $msg +} {1 {wrong # args: should be "dde ?-async? serviceName topicName value"}} +test winSend-10.2 {Tk_DDEObjCmd - unknown subcommand} { + 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} { + 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} { + 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} { + 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} { + 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} { + list [catch {dde services} msg] $msg +} {1 {wrong # args: should be "dde services serviceName topicName"}} +test winSend-10.8 {Tk_DDEObjCmd - null service name} { + list [catch {dde services {} {tktest #2}}] +} {0} +test winSend-10.9 {Tk_DDEObjCmd - null topic name} { + list [catch {dde services {Tk} {}}] +} {0} +test winSend-10.10 {Tk_DDEObjCmd - execute - nothing to execute} { + 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} { + list [catch {dde execute Tk foo {set foo hello}} msg] $msg +} {1 {dde command failed}} +test winSend-10.12 {Tk_DDEObjCmd - execute - async} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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 + } + } +} + diff --git a/tests/winfo.test b/tests/winfo.test index 5d7292f..4b9b60f 100644 --- a/tests/winfo.test +++ b/tests/winfo.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# SCCS: @(#) winfo.test 1.19 97/05/16 08:49:01 +# SCCS: @(#) winfo.test 1.20 97/05/26 13:24:39 if {[info procs test] != "test"} { source defs @@ -311,7 +311,7 @@ proc MakeEmbed {} { pack .emb.b -expand yes -fill both update } -test winfo-13.1 {root coordinates of embedded toplevel} {macOrUnix} { +test winfo-13.1 {root coordinates of embedded toplevel} {winCrash} { MakeEmbed set z [expr [winfo rootx .emb] == [winfo rootx .con] && \ [winfo rooty .emb] == [winfo rooty .con]] @@ -319,8 +319,8 @@ test winfo-13.1 {root coordinates of embedded toplevel} {macOrUnix} { destroy .con set z } {1} -test winfo-13.2 {destroying embedded toplevel} {macOrUnix} { - catch {destroy .emb} +test winfo-13.2 {destroying embedded toplevel} {winCrash} { + destroy .emb update expr [winfo exists .emb.b] || [winfo exists .con] } 0 @@ -329,7 +329,7 @@ foreach i [winfo children .] { destroy $i } -test winfo-13.3 {destroying container window} {macOrUnix} { +test winfo-13.3 {destroying container window} {winCrash} { MakeEmbed destroy .con update @@ -343,7 +343,7 @@ foreach i [winfo children .] { destroy $i } -test winfo-13.4 {[winfo containing] with embedded windows} {macOrUnix} { +test winfo-13.4 {[winfo containing] with embedded windows} {winCrash} { MakeEmbed button .b pack .b -expand yes -fill both diff --git a/tests/xmfbox.test b/tests/xmfbox.test new file mode 100644 index 0000000..d6b54ee --- /dev/null +++ b/tests/xmfbox.test @@ -0,0 +1,146 @@ +# xmfbox.test -- +# +# This file is a Tcl script to test the file dialog that's used +# when the tk_strictMotif flag is set. Because the file dialog +# runs in a modal loop, the only way to test it sufficiently is +# to call the internal Tcl procedures in xmfbox.tcl directly. +# +# 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. +# +# SCCS: @(#) xmfbox.test 1.3 98/01/07 16:44:17 + +if {[string compare test [info procs test]] == 1} { + source defs +} + +if {$tcl_platform(platform) != "unix"} { + # This test is needed only on Unix platforms. Windows and Mac + # have their own Native file dialogs. + return +} + +set testPWD [pwd] +eval destroy [winfo children .] +catch {unset foo} + +catch {unset data foo} + +proc cleanup {} { + global testPWD + + set err0 [catch { + cd $testPWD + } msg0] + + set err1 [catch { + if [file exists ./~nosuchuser1] { + file delete ./~nosuchuser1 + } + } msg1] + + set err2 [catch { + if [file exists ./~nosuchuser2] { + file delete ./~nosuchuser2 + } + } msg2] + + set err3 [catch { + if [file exists ./~nosuchuser3] { + file delete ./~nosuchuser3 + } + } msg3] + + set err4 [catch { + if [file exists ./~nosuchuser4] { + file delete ./~nosuchuser4 + } + } msg4] + + if {$err0 || $err1 || $err2 || $err3 || $err4} { + error [list $msg0 $msg1 $msg2 $msg3 $msg4] + } + catch {unset foo} + catch {destroy .foo} +} + +test xmfbox-1.1 {tkMotifFDialog_Create, -parent switch} { + catch {unset foo} + set x [tkMotifFDialog_Create foo open {-parent .}] + catch {destroy $x} + set x +} .foo + +test xmfbox-1.2 {tkMotifFDialog_Create, -parent switch} { + catch {unset foo} + toplevel .bar + set x [tkMotifFDialog_Create foo open {-parent .bar}] + catch {destroy $x} + catch {destroy .bar} + set x +} .bar.foo + +test xmfbox-2.1 {tkMotifFDialog_InterpFilter, ~ in dir names} { + cleanup + file mkdir ./~nosuchuser1 + set x [tkMotifFDialog_Create foo open {}] + $foo(fEnt) delete 0 end + $foo(fEnt) insert 0 [pwd]/~nosuchuser1 + set kk [tkMotifFDialog_InterpFilter $x] +} [list $testPWD/~nosuchuser1 *] + +test xmfbox-2.2 {tkMotifFDialog_InterpFilter, ~ in file names} { + cleanup + close [open ./~nosuchuser1 {CREAT TRUNC WRONLY}] + set x [tkMotifFDialog_Create foo open {}] + $foo(fEnt) delete 0 end + $foo(fEnt) insert 0 [pwd]/~nosuchuser1 + set kk [tkMotifFDialog_InterpFilter $x] +} [list $testPWD ./~nosuchuser1] + +test xmfbox-2.3 {tkMotifFDialog_Update, ~ in file names} { + cleanup + close [open ./~nosuchuser1 {CREAT TRUNC WRONLY}] + set x [tkMotifFDialog_Create foo open {}] + $foo(fEnt) delete 0 end + $foo(fEnt) insert 0 [pwd]/~nosuchuser1 + tkMotifFDialog_InterpFilter $x + tkMotifFDialog_Update $x + $foo(fList) get end +} ~nosuchuser1 + +test xmfbox-2.4 {tkMotifFDialog_LoadFile, ~ in file names} { + cleanup + close [open ./~nosuchuser1 {CREAT TRUNC WRONLY}] + set x [tkMotifFDialog_Create foo open {}] + set i [lsearch [$foo(fList) get 0 end] ~nosuchuser1] + expr {$i >= 0} +} 1 + +test xmfbox-2.5 {tkMotifFDialog_BrowseFList, ~ in file names} { + cleanup + close [open ./~nosuchuser1 {CREAT TRUNC WRONLY}] + set x [tkMotifFDialog_Create foo open {}] + set i [lsearch [$foo(fList) get 0 end] ~nosuchuser1] + $foo(fList) selection clear 0 end + $foo(fList) selection set $i + tkMotifFDialog_BrowseFList $x + $foo(sEnt) get +} $testPWD/~nosuchuser1 + +test xmfbox-2.5 {tkMotifFDialog_ActivateFList, ~ in file names} { + cleanup + close [open ./~nosuchuser1 {CREAT TRUNC WRONLY}] + set x [tkMotifFDialog_Create foo open {}] + set i [lsearch [$foo(fList) get 0 end] ~nosuchuser1] + $foo(fList) selection clear 0 end + $foo(fList) selection set $i + tkMotifFDialog_BrowseFList $x + tkMotifFDialog_ActivateFList $x + list $foo(selectPath) $foo(selectFile) $tkPriv(selectFilePath) +} [list $testPWD ~nosuchuser1 $testPWD/~nosuchuser1] + +cleanup +return diff --git a/unix/Makefile.in b/unix/Makefile.in index 51b9723..cff8c7d 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -5,7 +5,7 @@ # "autoconf" program (constructs like "@foo@" will get replaced in the # actual Makefile. # -# SCCS: @(#) Makefile.in 1.146 97/11/05 11:10:45 +# SCCS: @(#) Makefile.in 1.154 98/02/10 10:24:55 # Current Tk version; used in various names. @@ -76,6 +76,7 @@ MANN_INSTALL_DIR = $(MAN_INSTALL_DIR)/mann # 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 +TCL_UNIX_DIR = @TCL_SRC_DIR@/unix # The directory containing the Tcl library archive file appropriate # for this version of Tk: @@ -125,6 +126,12 @@ MEM_DEBUG_FLAGS = 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 = /bin/sh @@ -186,7 +193,7 @@ TOOL_DIR = @TCL_SRC_DIR@/tools CC = @CC@ CC_SWITCHES = ${CFLAGS} ${TK_SHLIB_CFLAGS} -I${UNIX_DIR} -I${GENERIC_DIR} \ -I${BMAP_DIR} -I${TCL_GENERIC_DIR} ${X11_INCLUDES} ${AC_FLAGS} ${PROTO_FLAGS} \ -${SECURITY_FLAGS} ${MEM_DEBUG_FLAGS} ${KEYSYM_FLAGS} +${SECURITY_FLAGS} ${MEM_DEBUG_FLAGS} ${KEYSYM_FLAGS} ${NO_DEPRECATED_FLAGS} DEPEND_SWITCHES = ${CFLAGS} -I${UNIX_DIR} -I${GENERIC_DIR} \ -I${BMAP_DIR} \ @@ -196,7 +203,8 @@ ${KEYSYM_FLAGS} WISH_OBJS = tkAppInit.o -TKTEST_OBJS = tkTestInit.o tkTest.o tkSquare.o +TCLTEST_OBJS = ${TCL_BIN_DIR}/tclTest.o ${TCL_BIN_DIR}/tclUnixTest.o +TKTEST_OBJS = $(TCLTEST_OBJS) tkTestInit.o tkTest.o tkSquare.o WIDGOBJS = tkButton.o tkEntry.o tkFrame.o tkListbox.o \ tkMenu.o tkMenubutton.o tkMenuDraw.o tkMessage.o tkScale.o \ @@ -211,16 +219,16 @@ IMAGEOBJS = tkImage.o tkImgBmap.o tkImgGIF.o tkImgPPM.o tkImgPhoto.o TEXTOBJS = tkText.o tkTextBTree.o tkTextDisp.o tkTextImage.o tkTextIndex.o \ tkTextMark.o tkTextTag.o tkTextWind.o -UNIXOBJS = tkUnix.o tkUnix3d.o tkUnixButton.o tkUnixColor.o tkUnixCursor.o \ - tkUnixDialog.o tkUnixDraw.o \ - tkUnixEmbed.o tkUnixEvent.o tkUnixFocus.o tkUnixFont.o tkUnixInit.o \ - tkUnixMenu.o tkUnixMenubu.o tkUnixScale.o tkUnixScrlbr.o \ - tkUnixSelect.o tkUnixSend.o tkUnixWm.o tkUnixXId.o +UNIXOBJS = tkUnix.o tkUnix3d.o tkUnixButton.o tkUnixColor.o tkUnixConfig.o \ + tkUnixCursor.o tkUnixDraw.o tkUnixEmbed.o tkUnixEvent.o \ + tkUnixFocus.o tkUnixFont.o tkUnixInit.o tkUnixKey.o tkUnixMenu.o \ + tkUnixMenubu.o tkUnixScale.o tkUnixScrlbr.o tkUnixSelect.o \ + tkUnixSend.o tkUnixWm.o tkUnixXId.o OBJS = tk3d.o tkArgv.o tkAtom.o tkBind.o tkBitmap.o tkClipboard.o tkCmds.o \ tkColor.o tkConfig.o tkCursor.o tkError.o tkEvent.o \ tkFocus.o tkFont.o tkGet.o tkGC.o tkGeometry.o tkGrab.o tkGrid.o \ - tkMain.o tkOption.o tkPack.o tkPlace.o \ + tkMain.o tkObj.o tkOldConfig.o tkOption.o tkPack.o tkPlace.o \ tkSelect.o tkUtil.o tkVisual.o tkWindow.o \ $(UNIXOBJS) $(WIDGOBJS) $(CANVOBJS) $(IMAGEOBJS) $(TEXTOBJS) @@ -239,7 +247,7 @@ SRCS = \ $(GENERIC_DIR)/tkPack.c $(GENERIC_DIR)/tkPlace.c \ $(GENERIC_DIR)/tkSelect.c $(GENERIC_DIR)/tkUtil.c \ $(GENERIC_DIR)/tkVisual.c $(GENERIC_DIR)/tkWindow.c \ - $(GENERIC_DIR)/tkButton.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 \ @@ -259,15 +267,18 @@ SRCS = \ $(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)/tkSquare.c $(GENERIC_DIR)/tkTest.c \ $(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)/tkUnixDialog.c $(UNIX_DIR)/tkUnixDraw.c \ + $(UNIX_DIR)/tkUnixDraw.c \ $(UNIX_DIR)/tkUnixEmbed.c $(UNIX_DIR)/tkUnixEvent.c \ $(UNIX_DIR)/tkUnixFocus.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 \ @@ -320,8 +331,10 @@ xttest: test.o tkTest.o tkSquare.o $(TK_LIB_FILE) test: tktest LD_LIBRARY_PATH=`pwd`:${TCL_BIN_DIR}:${LD_LIBRARY_PATH}; \ export LD_LIBRARY_PATH; \ + SHLIB_PATH=`pwd`:${TCL_BIN_DIR}:${SHLIB_PATH}; \ + export SHLIB_PATH; \ TCL_LIBRARY=@TCL_SRC_DIR@/library; export TCL_LIBRARY; \ - TK_LIBRARY=$(TOP_DIR)/library; export TK_LIBRARY; \ + TK_LIBRARY=@TK_SRC_DIR@/library; export TK_LIBRARY; \ ( echo cd $(TOP_DIR)/tests\; source all\; exit ) \ | ./tktest -geometry +0+0 @@ -330,8 +343,10 @@ test: tktest runtest: LD_LIBRARY_PATH=`pwd`:${TCL_BIN_DIR}:${LD_LIBRARY_PATH}; \ export LD_LIBRARY_PATH; \ + SHLIB_PATH=`pwd`:${TCL_BIN_DIR}:${SHLIB_PATH}; \ + export SHLIB_PATH; \ TCL_LIBRARY=@TCL_SRC_DIR@/library; export TCL_LIBRARY; \ - TK_LIBRARY=$(TOP_DIR)/library; export TK_LIBRARY; \ + TK_LIBRARY=@TK_SRC_DIR@/library; export TK_LIBRARY; \ ./tktest install: install-binaries install-libraries install-demos install-man @@ -372,7 +387,7 @@ install-libraries: done; @echo "Installing tk.h" @$(INSTALL_DATA) $(GENERIC_DIR)/tk.h $(INCLUDE_INSTALL_DIR)/tk.h - for i in $(SRC_DIR)/library/*.tcl $(SRC_DIR)/library/tclIndex $(SRC_DIR)/library/prolog.ps $(UNIX_DIR)/tkAppInit.c; \ + for i in $(SRC_DIR)/library/*.tcl $(SRC_DIR)/library/tclIndex $(UNIX_DIR)/tkAppInit.c; \ do \ echo "Installing $$i"; \ $(INSTALL_DATA) $$i $(SCRIPT_INSTALL_DIR); \ @@ -548,6 +563,12 @@ tkGrid.o: $(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 @@ -692,12 +713,12 @@ tkUnixButton.o: $(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 -tkUnixDialog.o: $(UNIX_DIR)/tkUnixDialog.c - $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tkUnixDialog.c - tkUnixDraw.o: $(UNIX_DIR)/tkUnixDraw.c $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tkUnixDraw.c @@ -717,6 +738,9 @@ tkUnixInit.o: $(UNIX_DIR)/tkUnixInit.c $(GENERIC_DIR)/tkInitScript.h 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 @@ -796,7 +820,8 @@ dist: $(UNIX_DIR)/configure fi; \ done;) mkdir $(DISTDIR)/generic - cp -p $(GENERIC_DIR)/*.c $(GENERIC_DIR)/*.h $(DISTDIR)/generic + cp -p $(GENERIC_DIR)/*.c $(GENERIC_DIR)/*.h $(GENERIC_DIR)/prolog.ps \ + $(DISTDIR)/generic cp -p $(GENERIC_DIR)/README $(DISTDIR)/generic cp -p $(TOP_DIR)/changes $(TOP_DIR)/README $(TOP_DIR)/license.terms \ $(DISTDIR) @@ -835,7 +860,7 @@ dist: $(UNIX_DIR)/configure 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 $(TOP_DIR)/library/prolog.ps \ + $(TOP_DIR)/library/tclIndex \ $(DISTDIR)/library mkdir $(DISTDIR)/library/images @(cd $(TOP_DIR); for i in library/images/* ; do \ @@ -878,10 +903,10 @@ dist: $(UNIX_DIR)/configure # alldist: dist - rm -f /proj/tcl/dist/$(DISTNAME).tar.Z \ - /proj/tcl/dist/$(DISTNAME).tar.gz \ - /proj/tcl/dist/$(ZIPNAME) - cd /proj/tcl/dist; tar cf $(DISTNAME).tar $(DISTNAME); \ + rm -f $(DISTDIR)/../$(DISTNAME).tar.Z \ + $(DISTDIR)/../$(DISTNAME).tar.gz \ + $(DISTDIR)/../$(ZIPNAME) + cd $(DISTDIR)/..; tar cf $(DISTNAME).tar $(DISTNAME); \ gzip -9 -c $(DISTNAME).tar > $(DISTNAME).tar.gz; \ compress $(DISTNAME).tar; zip -r8 $(ZIPNAME) $(DISTNAME) diff --git a/unix/README b/unix/README index bb06d21..ae07ad5 100644 --- a/unix/README +++ b/unix/README @@ -10,14 +10,14 @@ 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 a Macintosh, see the README file in the directory ../mac. -SCCS: @(#) README 1.24 97/08/13 17:31:19 +SCCS: @(#) README 1.26 98/02/18 18:04:01 How To Compile And Install Tk: ------------------------------ -(a) Make sure that the Tcl 8.0 release is present in the directory - ../../tcl8.0 (or else use the "--with-tcl" switch described below). - This release of Tk will only work with Tcl 8.0. Also, be sure that +(a) Make sure that the Tcl 8.1 release is present in the directory + ../../tcl8.1a2 (or else use the "--with-tcl" switch described below). + This release of Tk will only work with Tcl 8.1. Also, be sure that you have configured Tcl before you configure Tk. (b) Check for patches as described in ../README. @@ -78,15 +78,15 @@ How To Compile And Install Tk: TCL_LIBRARY environment variable as well (see the Tcl README file for information on this). Note that installed versions of wish, libtk.a, libtk.so, and the Tk library have a version number in their - names, such as "wish8.0" or "libtk8.0.so"; to use the installed + names, such as "wish8.1" or "libtk8.1.so"; to use the installed versions, either specify the version number or create a symbolic - link (e.g. from "wish" to "wish8.0"). + link (e.g. from "wish" to "wish8.1"). If you have trouble compiling Tk, read through the file "porting.notes". It contains information that people have provided about changes they had to make to compile Tcl in various environments. Or, check out the following Web URL: - http://www.sunlabs.com/cgi-bin/tcl/info.8.0 + http://www.sunlabs.com/cgi-bin/tcl/info.8.1 This is an on-line database of porting information. We make no guarantees that this information is accurate, complete, or up-to-date, but you may find it useful. If you get Tk running on a new configuration and had to diff --git a/unix/configure.in b/unix/configure.in index 7f3c15f..57c3e13 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -2,12 +2,12 @@ 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(../generic/tk.h) -# SCCS: @(#) configure.in 1.90 97/11/20 12:45:45 +# SCCS: @(#) configure.in 1.97 98/02/19 14:17:04 -TK_VERSION=8.0 +TK_VERSION=8.1 TK_MAJOR_VERSION=8 -TK_MINOR_VERSION=0 -TK_PATCH_LEVEL="p2" +TK_MINOR_VERSION=1 +TK_PATCH_LEVEL=a2 VERSION=${TK_VERSION} if test "${prefix}" = "NONE"; then @@ -18,6 +18,10 @@ if test "${exec_prefix}" = "NONE"; then fi TK_SRC_DIR=`cd $srcdir/..; pwd` +# Most of the checks here are duplicated from Tcl's configure.in +# and should not be redone but rather simply used from the definitions +# found in tclConfig.sh + AC_PROG_RANLIB AC_ARG_ENABLE(gcc, [ --enable-gcc allow use of gcc if available], [tk_ok=$enableval], [tkl_ok=no]) @@ -35,8 +39,8 @@ AC_HAVE_HEADERS(unistd.h limits.h) # not, assume that its top-level directory is a sibling of ours. #-------------------------------------------------------------------- -AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl 8.0 binaries from DIR], - TCL_BIN_DIR=$withval, TCL_BIN_DIR=`cd ../../tcl8.0/unix; pwd`) +AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl 8.1 binaries from DIR], + TCL_BIN_DIR=$withval, TCL_BIN_DIR=`cd ../../tcl8.1a2/unix; pwd`) if test ! -d $TCL_BIN_DIR; then AC_MSG_ERROR(Tcl directory $TCL_BIN_DIR doesn't exist) fi @@ -66,7 +70,7 @@ LIB_RUNTIME_DIR='${LIB_RUNTIME_DIR}' # search path to reflect this. if test "$TCL_EXEC_PREFIX" != "$exec_prefix"; then - LIB_RUNTIME_DIR="${LIB_RUNTIME_DIR}:${TCL_EXEC_PREFIX}" + LIB_RUNTIME_DIR="${LIB_RUNTIME_DIR}:${TCL_EXEC_PREFIX}/lib" fi #-------------------------------------------------------------------- @@ -299,13 +303,6 @@ AC_CHECK_FUNC(sin, , MATH_LIBS="-lm") AC_CHECK_LIB(ieee, main, [MATH_LIBS="-lieee $MATH_LIBS"]) #-------------------------------------------------------------------- -# If this system doesn't have a memmove procedure, use memcpy -# instead. -#-------------------------------------------------------------------- - -AC_CHECK_FUNC(memmove, , [AC_DEFINE(memmove, memcpy)]) - -#-------------------------------------------------------------------- # Figure out whether "char" is unsigned. If so, set a # #define for __CHAR_UNSIGNED__. #-------------------------------------------------------------------- diff --git a/unix/mkLinks b/unix/mkLinks index d817703..5b326b6 100644 --- a/unix/mkLinks +++ b/unix/mkLinks @@ -43,6 +43,26 @@ if test -r 3DBorder.3; then rm -f Tk_3DVerticalBevel.3 ln 3DBorder.3 Tk_3DVerticalBevel.3 fi +if test -r 3DBorder.3; then + rm -f Tk_Alloc3DBorderFromObj.3 + ln 3DBorder.3 Tk_Alloc3DBorderFromObj.3 +fi +if test -r GetBitmap.3; then + rm -f Tk_AllocBitmapFromObj.3 + ln GetBitmap.3 Tk_AllocBitmapFromObj.3 +fi +if test -r GetColor.3; then + rm -f Tk_AllocColorFromObj.3 + ln GetColor.3 Tk_AllocColorFromObj.3 +fi +if test -r GetCursor.3; then + rm -f Tk_AllocCursorFromObj.3 + ln GetCursor.3 Tk_AllocCursorFromObj.3 +fi +if test -r GetFont.3; then + rm -f Tk_AllocFontFromObj.3 + ln GetFont.3 Tk_AllocFontFromObj.3 +fi if test -r WindowId.3; then rm -f Tk_Attributes.3 ln WindowId.3 Tk_Attributes.3 @@ -191,6 +211,10 @@ if test -r CrtItemType.3; then rm -f Tk_CreateItemType.3 ln CrtItemType.3 Tk_CreateItemType.3 fi +if test -r SetOptions.3; then + rm -f Tk_CreateOptionTable.3 + ln SetOptions.3 Tk_CreateOptionTable.3 +fi if test -r CrtPhImgFmt.3; then rm -f Tk_CreatePhotoImageFormat.3 ln CrtPhImgFmt.3 Tk_CreatePhotoImageFormat.3 @@ -243,6 +267,10 @@ if test -r DeleteImg.3; then rm -f Tk_DeleteImage.3 ln DeleteImg.3 Tk_DeleteImage.3 fi +if test -r SetOptions.3; then + rm -f Tk_DeleteOptionTable.3 + ln SetOptions.3 Tk_DeleteOptionTable.3 +fi if test -r CrtSelHdlr.3; then rm -f Tk_DeleteSelHandler.3 ln CrtSelHdlr.3 Tk_DeleteSelHandler.3 @@ -311,26 +339,50 @@ if test -r 3DBorder.3; then rm -f Tk_Free3DBorder.3 ln 3DBorder.3 Tk_Free3DBorder.3 fi +if test -r 3DBorder.3; then + rm -f Tk_Free3DBorderFromObj.3 + ln 3DBorder.3 Tk_Free3DBorderFromObj.3 +fi if test -r GetBitmap.3; then rm -f Tk_FreeBitmap.3 ln GetBitmap.3 Tk_FreeBitmap.3 fi +if test -r GetBitmap.3; then + rm -f Tk_FreeBitmapFromObj.3 + ln GetBitmap.3 Tk_FreeBitmapFromObj.3 +fi if test -r GetColor.3; then rm -f Tk_FreeColor.3 ln GetColor.3 Tk_FreeColor.3 fi +if test -r GetColor.3; then + rm -f Tk_FreeColorFromObj.3 + ln GetColor.3 Tk_FreeColorFromObj.3 +fi if test -r GetClrmap.3; then rm -f Tk_FreeColormap.3 ln GetClrmap.3 Tk_FreeColormap.3 fi +if test -r SetOptions.3; then + rm -f Tk_FreeConfigOptions.3 + ln SetOptions.3 Tk_FreeConfigOptions.3 +fi if test -r GetCursor.3; then rm -f Tk_FreeCursor.3 ln GetCursor.3 Tk_FreeCursor.3 fi +if test -r GetCursor.3; then + rm -f Tk_FreeCursorFromObj.3 + ln GetCursor.3 Tk_FreeCursorFromObj.3 +fi if test -r GetFont.3; then rm -f Tk_FreeFont.3 ln GetFont.3 Tk_FreeFont.3 fi +if test -r GetFont.3; then + rm -f Tk_FreeFontFromObj.3 + ln GetFont.3 Tk_FreeFontFromObj.3 +fi if test -r GetGC.3; then rm -f Tk_FreeGC.3 ln GetGC.3 Tk_FreeGC.3 @@ -347,6 +399,10 @@ if test -r GetPixmap.3; then rm -f Tk_FreePixmap.3 ln GetPixmap.3 Tk_FreePixmap.3 fi +if test -r SetOptions.3; then + rm -f Tk_FreeSavedOptions.3 + ln SetOptions.3 Tk_FreeSavedOptions.3 +fi if test -r TextLayout.3; then rm -f Tk_FreeTextLayout.3 ln TextLayout.3 Tk_FreeTextLayout.3 @@ -363,6 +419,10 @@ if test -r 3DBorder.3; then rm -f Tk_Get3DBorder.3 ln 3DBorder.3 Tk_Get3DBorder.3 fi +if test -r 3DBorder.3; then + rm -f Tk_Get3DBorderFromObj.3 + ln 3DBorder.3 Tk_Get3DBorderFromObj.3 +fi if test -r BindTable.3; then rm -f Tk_GetAllBindings.3 ln BindTable.3 Tk_GetAllBindings.3 @@ -371,6 +431,10 @@ if test -r GetAnchor.3; then rm -f Tk_GetAnchor.3 ln GetAnchor.3 Tk_GetAnchor.3 fi +if test -r GetAnchor.3; then + rm -f Tk_GetAnchorFromObj.3 + ln GetAnchor.3 Tk_GetAnchorFromObj.3 +fi if test -r InternAtom.3; then rm -f Tk_GetAtomName.3 ln InternAtom.3 Tk_GetAtomName.3 @@ -387,6 +451,10 @@ if test -r GetBitmap.3; then rm -f Tk_GetBitmapFromData.3 ln GetBitmap.3 Tk_GetBitmapFromData.3 fi +if test -r GetBitmap.3; then + rm -f Tk_GetBitmapFromObj.3 + ln GetBitmap.3 Tk_GetBitmapFromObj.3 +fi if test -r GetCapStyl.3; then rm -f Tk_GetCapStyle.3 ln GetCapStyl.3 Tk_GetCapStyle.3 @@ -399,6 +467,10 @@ if test -r GetColor.3; then rm -f Tk_GetColorByValue.3 ln GetColor.3 Tk_GetColorByValue.3 fi +if test -r GetColor.3; then + rm -f Tk_GetColorFromObj.3 + ln GetColor.3 Tk_GetColorFromObj.3 +fi if test -r GetClrmap.3; then rm -f Tk_GetColormap.3 ln GetClrmap.3 Tk_GetColormap.3 @@ -411,10 +483,18 @@ if test -r GetCursor.3; then rm -f Tk_GetCursorFromData.3 ln GetCursor.3 Tk_GetCursorFromData.3 fi +if test -r GetCursor.3; then + rm -f Tk_GetCursorFromObj.3 + ln GetCursor.3 Tk_GetCursorFromObj.3 +fi if test -r GetFont.3; then rm -f Tk_GetFont.3 ln GetFont.3 Tk_GetFont.3 fi +if test -r GetFont.3; then + rm -f Tk_GetFontFromObj.3 + ln GetFont.3 Tk_GetFontFromObj.3 +fi if test -r GetGC.3; then rm -f Tk_GetGC.3 ln GetGC.3 Tk_GetGC.3 @@ -439,14 +519,34 @@ if test -r GetJustify.3; then rm -f Tk_GetJustify.3 ln GetJustify.3 Tk_GetJustify.3 fi +if test -r GetJustify.3; then + rm -f Tk_GetJustifyFromObj.3 + ln GetJustify.3 Tk_GetJustifyFromObj.3 +fi +if test -r GetPixels.3; then + rm -f Tk_GetMMFromObj.3 + ln GetPixels.3 Tk_GetMMFromObj.3 +fi if test -r GetOption.3; then rm -f Tk_GetOption.3 ln GetOption.3 Tk_GetOption.3 fi +if test -r SetOptions.3; then + rm -f Tk_GetOptionInfo.3 + ln SetOptions.3 Tk_GetOptionInfo.3 +fi +if test -r SetOptions.3; then + rm -f Tk_GetOptionValue.3 + ln SetOptions.3 Tk_GetOptionValue.3 +fi if test -r GetPixels.3; then rm -f Tk_GetPixels.3 ln GetPixels.3 Tk_GetPixels.3 fi +if test -r GetPixels.3; then + rm -f Tk_GetPixelsFromObj.3 + ln GetPixels.3 Tk_GetPixelsFromObj.3 +fi if test -r GetPixmap.3; then rm -f Tk_GetPixmap.3 ln GetPixmap.3 Tk_GetPixmap.3 @@ -455,6 +555,10 @@ if test -r GetRelief.3; then rm -f Tk_GetRelief.3 ln GetRelief.3 Tk_GetRelief.3 fi +if test -r GetRelief.3; then + rm -f Tk_GetReliefFromObj.3 + ln GetRelief.3 Tk_GetReliefFromObj.3 +fi if test -r GetRootCrd.3; then rm -f Tk_GetRootCoords.3 ln GetRootCrd.3 Tk_GetRootCoords.3 @@ -499,6 +603,10 @@ if test -r ImgChanged.3; then rm -f Tk_ImageChanged.3 ln ImgChanged.3 Tk_ImageChanged.3 fi +if test -r SetOptions.3; then + rm -f Tk_InitOptions.3 + ln SetOptions.3 Tk_InitOptions.3 +fi if test -r InternAtom.3; then rm -f Tk_InternAtom.3 ln InternAtom.3 Tk_InternAtom.3 @@ -611,9 +719,9 @@ if test -r Name.3; then rm -f Tk_NameToWindow.3 ln Name.3 Tk_NameToWindow.3 fi -if test -r ConfigWidg.3; then +if test -r SetOptions.3; then rm -f Tk_Offset.3 - ln ConfigWidg.3 Tk_Offset.3 + ln SetOptions.3 Tk_Offset.3 fi if test -r OwnSelect.3; then rm -f Tk_OwnSelection.3 @@ -691,6 +799,10 @@ if test -r Restack.3; then rm -f Tk_RestackWindow.3 ln Restack.3 Tk_RestackWindow.3 fi +if test -r SetOptions.3; then + rm -f Tk_RestoreSavedOptions.3 + ln SetOptions.3 Tk_RestoreSavedOptions.3 +fi if test -r RestrictEv.3; then rm -f Tk_RestrictEvents.3 ln RestrictEv.3 Tk_RestrictEvents.3 @@ -723,6 +835,10 @@ if test -r GeomReq.3; then rm -f Tk_SetInternalBorder.3 ln GeomReq.3 Tk_SetInternalBorder.3 fi +if test -r SetOptions.3; then + rm -f Tk_SetOptions.3 + ln SetOptions.3 Tk_SetOptions.3 +fi if test -r ConfigWind.3; then rm -f Tk_SetWindowBackground.3 ln ConfigWind.3 Tk_SetWindowBackground.3 diff --git a/unix/tkAppInit.c b/unix/tkAppInit.c index 6b6b2e2..fdd9afd 100644 --- a/unix/tkAppInit.c +++ b/unix/tkAppInit.c @@ -5,15 +5,16 @@ * use in wish and similar Tk-based applications. * * Copyright (c) 1993 The Regents of the University of California. - * Copyright (c) 1994 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkAppInit.c 1.22 96/05/29 09:47:08 + * SCCS: @(#) tkAppInit.c 1.24 98/01/13 17:21:40 */ #include "tk.h" +#include "locale.h" /* * The following variable is a special hack that is needed in order for @@ -24,6 +25,7 @@ extern int matherr(); int *tclDummyMathPtr = (int *) matherr; #ifdef TK_TEST +EXTERN int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN int Tktest_Init _ANSI_ARGS_((Tcl_Interp *interp)); #endif /* TK_TEST */ @@ -64,7 +66,7 @@ main(argc, argv) * * Results: * Returns a standard Tcl completion code, and leaves an error - * message in interp->result if an error occurs. + * message in the interp's result if an error occurs. * * Side effects: * Depends on the startup script. @@ -84,6 +86,11 @@ Tcl_AppInit(interp) } Tcl_StaticPackage(interp, "Tk", Tk_Init, Tk_SafeInit); #ifdef TK_TEST + if (Tcltest_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } + Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init, + (Tcl_PackageInitProc *) NULL); if (Tktest_Init(interp) == TCL_ERROR) { return TCL_ERROR; } diff --git a/unix/tkUnix.c b/unix/tkUnix.c index ca6fa07..25b1997 100644 --- a/unix/tkUnix.c +++ b/unix/tkUnix.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkUnix.c 1.5 97/01/07 11:41:39 + * SCCS: @(#) tkUnix.c 1.6 97/11/07 21:24:29 */ #include <tkInt.h> @@ -40,7 +40,8 @@ TkGetServerInfo(interp, tkwin) Tk_Window tkwin; /* Token for window; this selects a * particular display and server. */ { - char buffer[50], buffer2[50]; + char buffer[8 + TCL_INTEGER_SPACE * 2]; + char buffer2[TCL_INTEGER_SPACE]; sprintf(buffer, "X%dR%d ", ProtocolVersion(Tk_Display(tkwin)), ProtocolRevision(Tk_Display(tkwin))); diff --git a/unix/tkUnixButton.c b/unix/tkUnixButton.c index 8c74dcb..fcb3d38 100644 --- a/unix/tkUnixButton.c +++ b/unix/tkUnixButton.c @@ -4,12 +4,12 @@ * This file implements the Unix specific portion of the button * widgets. * - * Copyright (c) 1996 by Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkUnixButton.c 1.4 97/06/06 11:21:40 + * SCCS: @(#) tkUnixButton.c 1.6 97/12/22 10:44:42 */ #include "tkButton.h" @@ -85,12 +85,11 @@ TkpDisplayButton(clientData) int x = 0; /* Initialization only needed to stop * compiler warning. */ int y, relief; - register Tk_Window tkwin = butPtr->tkwin; + Tk_Window tkwin = butPtr->tkwin; int width, height; - int offset; /* 0 means this is a label widget. 1 means - * it is a flavor of button, so we offset - * the text to make the button appear to - * move up and down as the relief changes. */ + 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. */ butPtr->flags &= ~REDRAW_PENDING; if ((butPtr->tkwin == NULL) || !Tk_IsMapped(tkwin)) { @@ -98,16 +97,16 @@ TkpDisplayButton(clientData) } border = butPtr->normalBorder; - if ((butPtr->state == tkDisabledUid) && (butPtr->disabledFg != NULL)) { + if ((butPtr->state == STATE_DISABLED) && (butPtr->disabledFg != NULL)) { gc = butPtr->disabledGC; - } else if ((butPtr->state == tkActiveUid) + } 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->state != tkActiveUid) + if ((butPtr->flags & SELECTED) && (butPtr->state != STATE_ACTIVE) && (butPtr->selectBorder != NULL) && !butPtr->indicatorOn) { border = butPtr->selectBorder; } @@ -141,7 +140,7 @@ TkpDisplayButton(clientData) * Display image or bitmap or text for button. */ - if (butPtr->image != None) { + if (butPtr->image != NULL) { Tk_SizeOfImage(butPtr->image, &width, &height); imageOrBitmap: @@ -213,7 +212,7 @@ TkpDisplayButton(clientData) y -= dim/2; if (dim > 2*butPtr->borderWidth) { Tk_Draw3DRectangle(tkwin, pixmap, border, x, y, dim, dim, - butPtr->borderWidth, + butPtr->borderWidth, (butPtr->flags & SELECTED) ? TK_RELIEF_SUNKEN : TK_RELIEF_RAISED); x += butPtr->borderWidth; @@ -222,7 +221,7 @@ TkpDisplayButton(clientData) if (butPtr->flags & SELECTED) { GC gc; - gc = Tk_3DBorderGC(tkwin,(butPtr->selectBorder != NULL) + gc = Tk_3DBorderGC(tkwin, (butPtr->selectBorder != NULL) ? butPtr->selectBorder : butPtr->normalBorder, TK_3D_FLAT_GC); XFillRectangle(butPtr->display, pixmap, gc, x, y, @@ -269,7 +268,7 @@ TkpDisplayButton(clientData) * must temporarily modify the GC. */ - if ((butPtr->state == tkDisabledUid) + if ((butPtr->state == STATE_DISABLED) && ((butPtr->disabledFg == NULL) || (butPtr->image != NULL))) { if ((butPtr->flags & SELECTED) && !butPtr->indicatorOn && (butPtr->selectBorder != NULL)) { @@ -297,7 +296,8 @@ TkpDisplayButton(clientData) if (relief != TK_RELIEF_FLAT) { int inset = butPtr->highlightWidth; - if (butPtr->defaultState == tkActiveUid) { + + 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 @@ -319,15 +319,14 @@ TkpDisplayButton(clientData) Tk_Height(tkwin) - 2*inset, 2, TK_RELIEF_FLAT); inset += 2; - } else if (butPtr->defaultState == tkNormalUid) { + } 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); + 0, Tk_Width(tkwin), Tk_Height(tkwin), 5, TK_RELIEF_FLAT); inset += 5; } @@ -339,7 +338,7 @@ TkpDisplayButton(clientData) Tk_Width(tkwin) - 2*inset, Tk_Height(tkwin) - 2*inset, butPtr->borderWidth, relief); } - if (butPtr->highlightWidth != 0) { + if (butPtr->highlightWidth > 0) { GC gc; if (butPtr->flags & GOT_FOCUS) { @@ -354,7 +353,7 @@ TkpDisplayButton(clientData) * padding space left for a default ring. */ - if (butPtr->defaultState == tkNormalUid) { + if (butPtr->defaultState == DEFAULT_NORMAL) { TkDrawInsetFocusHighlight(tkwin, gc, butPtr->highlightWidth, pixmap, 5); } else { @@ -396,18 +395,19 @@ TkpComputeButtonGeometry(butPtr) register TkButton *butPtr; /* Button whose geometry may have changed. */ { int width, height, avgWidth; + int length; + char *text; Tk_FontMetrics fm; - if (butPtr->highlightWidth < 0) { - butPtr->highlightWidth = 0; - } + text = Tcl_GetStringFromObj(butPtr->textPtr, &length); + butPtr->inset = butPtr->highlightWidth + butPtr->borderWidth; /* * Leave room for the default ring if needed. */ - if (butPtr->defaultState != tkDisabledUid) { + if (butPtr->defaultState != DEFAULT_DISABLED) { butPtr->inset += 5; } butPtr->indicatorSpace = 0; @@ -434,7 +434,7 @@ TkpComputeButtonGeometry(butPtr) } else { Tk_FreeTextLayout(butPtr->textLayout); butPtr->textLayout = Tk_ComputeTextLayout(butPtr->tkfont, - butPtr->text, -1, butPtr->wrapLength, butPtr->justify, 0, + text, length, butPtr->wrapLength, butPtr->justify, 0, &butPtr->textWidth, &butPtr->textHeight); width = butPtr->textWidth; diff --git a/unix/tkUnixConfig.c b/unix/tkUnixConfig.c new file mode 100644 index 0000000..4333cdf --- /dev/null +++ b/unix/tkUnixConfig.c @@ -0,0 +1,45 @@ +/* + * 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. + * + * SCCS: @(#) tkUnixConfig.c 1.3 97/10/09 10:57:51 + */ + +#include "tk.h" +#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(tkwin, dbName, className) + Tk_Window tkwin; /* A window to use. */ + char *dbName; /* The option database name. */ + char *className; /* The name of the option class. */ +{ + return NULL; +} diff --git a/unix/tkUnixCursor.c b/unix/tkUnixCursor.c index da75ac6..46000df 100644 --- a/unix/tkUnixCursor.c +++ b/unix/tkUnixCursor.c @@ -3,12 +3,12 @@ * * This file contains X specific cursor manipulation routines. * - * Copyright (c) 1995 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkUnixCursor.c 1.4 96/10/08 09:33:08 + * SCCS: @(#) tkUnixCursor.c 1.7 98/02/04 13:56:12 */ #include "tkPort.h" @@ -218,7 +218,7 @@ TkGetCursorByName(interp, tkwin, string) if (dispPtr->cursorFont == None) { dispPtr->cursorFont = XLoadFont(display, CURSORFONT); if (dispPtr->cursorFont == None) { - interp->result = "couldn't load cursor font"; + Tcl_SetResult(interp, "couldn't load cursor font", TCL_STATIC); goto cleanup; } } @@ -282,8 +282,9 @@ TkGetCursorByName(interp, tkwin, string) goto cleanup; } if ((maskWidth != width) && (maskHeight != height)) { - interp->result = - "source and mask bitmaps have different sizes"; + Tcl_SetResult(interp, + "source and mask bitmaps have different sizes", + TCL_STATIC); goto cleanup; } if (XParseColor(display, Tk_Colormap(tkwin), argv[2], @@ -323,6 +324,9 @@ TkGetCursorByName(interp, tkwin, string) badString: + if (argv) { + ckfree((char *) argv); + } Tcl_AppendResult(interp, "bad cursor spec \"", string, "\"", (char *) NULL); return NULL; @@ -382,7 +386,7 @@ TkCreateCursorFromData(tkwin, source, mask, width, height, xHot, yHot, /* *---------------------------------------------------------------------- * - * TkFreeCursor -- + * TkpFreeCursor -- * * This procedure is called to release a cursor allocated by * TkGetCursorByName. @@ -397,11 +401,10 @@ TkCreateCursorFromData(tkwin, source, mask, width, height, xHot, yHot, */ void -TkFreeCursor(cursorPtr) +TkpFreeCursor(cursorPtr) TkCursor *cursorPtr; { TkUnixCursor *unixCursorPtr = (TkUnixCursor *) cursorPtr; XFreeCursor(unixCursorPtr->display, (Cursor) unixCursorPtr->info.cursor); Tk_FreeXId(unixCursorPtr->display, (XID) unixCursorPtr->info.cursor); - ckfree((char *) unixCursorPtr); } diff --git a/unix/tkUnixDefault.h b/unix/tkUnixDefault.h index f895d63..b1b35f5 100644 --- a/unix/tkUnixDefault.h +++ b/unix/tkUnixDefault.h @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkUnixDefault.h 1.105 97/10/09 17:45:10 + * SCCS: @(#) tkUnixDefault.h 1.106 97/12/13 15:47:22 */ #ifndef _TKUNIXDEFAULT @@ -59,7 +59,8 @@ #define DEF_CHKRAD_FG DEF_BUTTON_FG #define DEF_BUTTON_FONT "Helvetica -12 bold" #define DEF_BUTTON_HEIGHT "0" -#define DEF_BUTTON_HIGHLIGHT_BG NORMAL_BG +#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" diff --git a/unix/tkUnixDialog.c b/unix/tkUnixDialog.c deleted file mode 100644 index b8a1ab0..0000000 --- a/unix/tkUnixDialog.c +++ /dev/null @@ -1,207 +0,0 @@ -/* - * 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. - * - * SCCS: @(#) tkUnixDialog.c 1.5 96/08/28 21:21:01 - * - */ - -#include "tkPort.h" -#include "tkInt.h" -#include "tkUnixInt.h" - -/* - *---------------------------------------------------------------------- - * - * EvalArgv -- - * - * Invokes the Tcl procedure with the arguments. argv[0] is set by - * the caller of this function. It may be different than cmdName. - * The TCL command will see argv[0], not cmdName, as its name if it - * invokes [lindex [info level 0] 0] - * - * Results: - * TCL_ERROR if the command does not exist and cannot be autoloaded. - * Otherwise, return the result of the evaluation of the command. - * - * Side effects: - * The command may be autoloaded. - * - *---------------------------------------------------------------------- - */ - -static int EvalArgv(interp, cmdName, argc, argv) - Tcl_Interp *interp; /* Current interpreter. */ - char * cmdName; /* Name of the TCL command to call */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - Tcl_CmdInfo cmdInfo; - - if (!Tcl_GetCommandInfo(interp, cmdName, &cmdInfo)) { - char * cmdArgv[2]; - - /* - * This comand is not in the interpreter yet -- looks like we - * have to auto-load it - */ - if (!Tcl_GetCommandInfo(interp, "auto_load", &cmdInfo)) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "cannot execute command \"auto_load\"", - NULL); - return TCL_ERROR; - } - - cmdArgv[0] = "auto_load"; - cmdArgv[1] = cmdName; - - if ((*cmdInfo.proc)(cmdInfo.clientData, interp, 2, cmdArgv)!= TCL_OK){ - return TCL_ERROR; - } - - if (!Tcl_GetCommandInfo(interp, cmdName, &cmdInfo)) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "cannot auto-load command \"", - cmdName, "\"",NULL); - return TCL_ERROR; - } - } - - return (*cmdInfo.proc)(cmdInfo.clientData, interp, argc, argv); -} - -/* - *---------------------------------------------------------------------- - * - * Tk_ChooseColorCmd -- - * - * 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_ChooseColorCmd(clientData, interp, argc, argv) - ClientData clientData; /* Main window associated with interpreter. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - return EvalArgv(interp, "tkColorDialog", argc, argv); -} - -/* - *---------------------------------------------------------------------- - * - * 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_GetOpenFileCmd(clientData, interp, argc, argv) - ClientData clientData; /* Main window associated with interpreter. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - Tk_Window tkwin = (Tk_Window)clientData; - - if (Tk_StrictMotif(tkwin)) { - return EvalArgv(interp, "tkMotifFDialog", argc, argv); - } else { - return EvalArgv(interp, "tkFDialog", argc, argv); - } -} - -/* - *---------------------------------------------------------------------- - * - * 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_GetSaveFileCmd(clientData, interp, argc, argv) - ClientData clientData; /* Main window associated with interpreter. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - Tk_Window tkwin = (Tk_Window)clientData; - - if (Tk_StrictMotif(tkwin)) { - return EvalArgv(interp, "tkMotifFDialog", argc, argv); - } else { - return EvalArgv(interp, "tkFDialog", argc, argv); - } -} - -/* - *---------------------------------------------------------------------- - * - * 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, interp, argc, argv) - ClientData clientData; /* Main window associated with interpreter. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ - return EvalArgv(interp, "tkMessageBox", argc, argv); -} - diff --git a/unix/tkUnixEmbed.c b/unix/tkUnixEmbed.c index fd20a34..6136905 100644 --- a/unix/tkUnixEmbed.c +++ b/unix/tkUnixEmbed.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkUnixEmbed.c 1.22 97/08/13 11:15:51 + * SCCS: @(#) tkUnixEmbed.c 1.23 97/11/07 21:24:52 */ #include "tkInt.h" @@ -83,7 +83,7 @@ static void EmbedWindowDeleted _ANSI_ARGS_((TkWindow *winPtr)); * 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 interp->result if + * is TCL_ERROR and an error message is left in the interp's result if * interp is non-NULL. * * Side effects: diff --git a/unix/tkUnixEvent.c b/unix/tkUnixEvent.c index ace4cc3..6fc30bb 100644 --- a/unix/tkUnixEvent.c +++ b/unix/tkUnixEvent.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkUnixEvent.c 1.17 97/09/11 12:51:04 + * SCCS: @(#) tkUnixEvent.c 1.18 97/10/28 18:47:15 */ #include "tkInt.h" @@ -34,6 +34,8 @@ static void DisplayFileProc _ANSI_ARGS_((ClientData clientData, int flags)); static void DisplaySetupProc _ANSI_ARGS_((ClientData clientData, int flags)); +static void TransferXEventsToTcl _ANSI_ARGS_((Display *display)); + /* *---------------------------------------------------------------------- @@ -196,7 +198,7 @@ DisplaySetupProc(clientData, flags) */ XFlush(dispPtr->display); - if (XQLength(dispPtr->display) > 0) { + if (QLength(dispPtr->display) > 0) { Tcl_SetMaxBlockTime(&blockTime); } } @@ -205,6 +207,43 @@ DisplaySetupProc(clientData, flags) /* *---------------------------------------------------------------------- * + * 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 *display; +{ + int numFound; + XEvent event; + + numFound = QLength(display); + + /* + * Transfer events from the X event queue to the Tk event queue. + */ + + while (numFound > 0) { + XNextEvent(display, &event); + Tk_QueueWindowEvent(&event, TCL_QUEUE_TAIL); + numFound--; + } +} + +/* + *---------------------------------------------------------------------- + * * DisplayCheckProc -- * * This procedure checks for events sitting in the X event @@ -225,8 +264,6 @@ DisplayCheckProc(clientData, flags) int flags; { TkDisplay *dispPtr; - XEvent event; - int numFound; if (!(flags & TCL_WINDOW_EVENTS)) { return; @@ -235,19 +272,11 @@ DisplayCheckProc(clientData, flags) for (dispPtr = tkDisplayList; dispPtr != NULL; dispPtr = dispPtr->nextPtr) { XFlush(dispPtr->display); - numFound = XQLength(dispPtr->display); - - /* - * Transfer events from the X event queue to the Tk event queue. - */ - - while (numFound > 0) { - XNextEvent(dispPtr->display, &event); - Tk_QueueWindowEvent(&event, TCL_QUEUE_TAIL); - numFound--; - } + TransferXEventsToTcl(dispPtr->display); } } + + /* *---------------------------------------------------------------------- @@ -273,7 +302,6 @@ DisplayFileProc(clientData, flags) { TkDisplay *dispPtr = (TkDisplay *) clientData; Display *display = dispPtr->display; - XEvent event; int numFound; XFlush(display); @@ -311,15 +339,7 @@ DisplayFileProc(clientData, flags) (void) signal(SIGPIPE, oldHandler); } - /* - * Transfer events from the X event queue to the Tk event queue. - */ - - while (numFound > 0) { - XNextEvent(display, &event); - Tk_QueueWindowEvent(&event, TCL_QUEUE_TAIL); - numFound--; - } + TransferXEventsToTcl(display); } /* @@ -397,7 +417,7 @@ TkUnixDoOneXEvent(timePtr) for (dispPtr = tkDisplayList; dispPtr != NULL; dispPtr = dispPtr->nextPtr) { XFlush(dispPtr->display); - if (XQLength(dispPtr->display) > 0) { + if (QLength(dispPtr->display) > 0) { blockTime.tv_sec = 0; blockTime.tv_usec = 0; } @@ -430,7 +450,7 @@ TkUnixDoOneXEvent(timePtr) fd = ConnectionNumber(dispPtr->display); index = fd/(NBBY*sizeof(fd_mask)); bit = 1 << (fd%(NBBY*sizeof(fd_mask))); - if ((readMask[index] & bit) || (XQLength(dispPtr->display) > 0)) { + if ((readMask[index] & bit) || (QLength(dispPtr->display) > 0)) { DisplayFileProc((ClientData)dispPtr, TCL_READABLE); } } @@ -480,19 +500,11 @@ void TkpSync(display) Display *display; /* Display to sync. */ { - int numFound = 0; - XEvent event; - XSync(display, False); /* * Transfer events from the X event queue to the Tk event queue. */ + TransferXEventsToTcl(display); - numFound = XQLength(display); - while (numFound > 0) { - XNextEvent(display, &event); - Tk_QueueWindowEvent(&event, TCL_QUEUE_TAIL); - numFound--; - } } diff --git a/unix/tkUnixFont.c b/unix/tkUnixFont.c index d25f157..2a76e4d 100644 --- a/unix/tkUnixFont.c +++ b/unix/tkUnixFont.c @@ -4,96 +4,387 @@ * Contains the Unix implementation of the platform-independant * font package interface. * - * Copyright (c) 1996 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkUnixFont.c 1.16 97/10/23 12:47:53 + * SCCS: @(#) tkUnixFont.c 1.22 98/02/18 17:09:20 */ -#include "tkPort.h" -#include "tkInt.h" #include "tkUnixInt.h" - #include "tkFont.h" -#ifndef ABS -#define ABS(n) (((n) < 0) ? -(n) : (n)) -#endif +/* + * The preferred font encodings. + */ + +static CONST char *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. + * 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. */ - Display *display; /* The display to which font belongs. */ - XFontStruct *fontStructPtr; /* X information about font. */ - char types[256]; /* Array giving types of all characters in - * the font, used when displaying control - * characters. See below for definition. */ - int widths[256]; /* Array giving widths of all possible - * characters in the font. */ + 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 for simulating a native - * underlined font). */ + * underline bar (used when drawing underlined + * font) (pixels). */ int barHeight; /* Height of underline or overstrike bar - * (used for simulating a native underlined or - * strikeout font). */ + * (used when drawing underlined or strikeout + * font) (pixels). */ } UnixFont; /* - * Possible values for entries in the "types" field in a UnixFont structure, - * which classifies the types of all characters in the given font. This - * information is used when measuring and displaying characters. - * - * NORMAL: Standard character. - * REPLACE: This character doesn't print: instead of - * displaying character, display a replacement - * sequence like "\n" (for those characters where - * ANSI C defines such a sequence) or a sequence - * of the form "\xdd" where dd is the hex equivalent - * of the character. - * SKIP: Don't display anything for this character. This - * is only used where the font doesn't contain - * all the characters needed to generate - * replacement sequences. - */ + * 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 { + char *realName; /* The real name of the encoding to load if + * the provided name matched the pattern. */ + char *aliasPattern; /* Pattern for encoding name, of the form + * that is acceptable to Tcl_StringMatch. */ +} EncodingAlias; -#define NORMAL 0 -#define REPLACE 1 -#define SKIP 2 +/* + * Just some utility structures used for passing around values in helper + * procedures. + */ + +typedef struct FontAttributes { + TkFontAttributes fa; + TkXLFDAttributes xa; +} FontAttributes; /* - * Characters used when displaying control sequences. + * 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. */ -static char hexChars[] = "0123456789abcdefxtnvr\\"; +static FontFamily *fontFamilyList = NULL; /* - * The following table maps some control characters to sequences like '\n' - * rather than '\x10'. A zero entry in the table means no such mapping - * exists, and the table only maps characters less than 0x10. + * FontFamily used to handle control character expansions. The encoding + * of this FontFamily converts UTF-8 to backslashed escape sequences. */ + +static FontFamily controlFamily; -static char mapChars[] = { - 0, 0, 0, 0, 0, 0, 0, - 'a', 'b', 't', 'n', 'v', 'f', 'r', - 0 +/* + * 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", "gb2312*"}, + {"big5", "big5*"}, + {"cns11643-1", "cns11643*-1"}, + {"cns11643-1", "cns11643*.1-0"}, + {"cns11643-2", "cns11643*-2"}, + {"cns11643-2", "cns11643*.2-0"}, + {"jis0201", "jisx0202*"}, + {"jis0208", "jisc6226*"}, + {"jis0208", "jisx0208*"}, + {"jis0212", "jisx0212*"}, + {"tis620", "tis620*"}, + {"ksc5601", "ksc5601*"}, + {"dingbats", "*dingbats"}, + {NULL, NULL} }; +/* + * Procedures used only in this file. + */ -static UnixFont * AllocFont _ANSI_ARGS_((TkFont *tkFontPtr, - Tk_Window tkwin, XFontStruct *fontStructPtr, - CONST char *fontName)); -static void DrawChars _ANSI_ARGS_((Display *display, - Drawable drawable, GC gc, UnixFont *fontPtr, - CONST char *source, int numChars, int x, - int y)); -static int GetControlCharSubst _ANSI_ARGS_((int c, char buf[4])); +static FontFamily * AllocFontFamily _ANSI_ARGS_((Display *display, + XFontStruct *fontStructPtr, int base)); +static SubFont * CanUseFallback _ANSI_ARGS_((UnixFont *fontPtr, + char *fallbackName, int ch)); +static SubFont * CanUseFallbackWithAliases _ANSI_ARGS_(( + UnixFont *fontPtr, char *fallbackName, + int ch, Tcl_DString *nameTriedPtr)); +static int ControlUtfProc _ANSI_ARGS_((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 _ANSI_ARGS_((Tk_Window tkwin, + CONST TkFontAttributes *faPtr, + CONST TkXLFDAttributes *xaPtr)); +static SubFont * FindSubFontForChar _ANSI_ARGS_((UnixFont *fontPtr, + int ch)); +static void FontMapInsert _ANSI_ARGS_((SubFont *subFontPtr, + int ch)); +static void FontMapLoadPage _ANSI_ARGS_((SubFont *subFontPtr, + int row)); +static int FontMapLookup _ANSI_ARGS_((SubFont *subFontPtr, + int ch)); +static void FreeFontFamily _ANSI_ARGS_((FontFamily *afPtr)); +static CONST char * GetEncodingAlias _ANSI_ARGS_((CONST char *name)); +static int GetFontAttributes _ANSI_ARGS_((Display *display, + XFontStruct *fontStructPtr, FontAttributes *faPtr)); +static XFontStruct * GetScreenFont _ANSI_ARGS_((Display *display, + FontAttributes *wantPtr, char **nameList, + int bestIdx[], unsigned int bestScore[])); +static XFontStruct * GetSystemFont _ANSI_ARGS_((Display *display)); +static int IdentifySymbolEncodings _ANSI_ARGS_(( + FontAttributes *faPtr)); +static void InitFont _ANSI_ARGS_((Tk_Window tkwin, + XFontStruct *fontStructPtr, UnixFont *fontPtr)); +static void InitSubFont _ANSI_ARGS_((Display *display, + XFontStruct *fontStructPtr, int base, + SubFont *subFontPtr)); +static char ** ListFonts _ANSI_ARGS_((Display *display, + CONST char *faceName, int *numNamesPtr)); +static char ** ListFontOrAlias _ANSI_ARGS_((Display *display, + CONST char *faceName, int *numNamesPtr)); +static unsigned int RankAttributes _ANSI_ARGS_((FontAttributes *wantPtr, + FontAttributes *gotPtr)); +static void ReleaseFont _ANSI_ARGS_((UnixFont *fontPtr)); +static void ReleaseSubFont _ANSI_ARGS_((Display *display, + SubFont *subFontPtr)); +static int SeenName _ANSI_ARGS_((CONST char *name, + Tcl_DString *dsPtr)); + + +/* + *------------------------------------------------------------------------- + * + * TkpFontPkgInit -- + * + * This procedure 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(mainPtr) + TkMainInfo *mainPtr; /* The application being created. */ +{ + Tcl_EncodingType type; + SubFont dummy; + int i; + + if (controlFamily.encoding == NULL) { + type.encodingName = "X11ControlChars"; + type.toUtfProc = ControlUtfProc; + type.fromUtfProc = ControlUtfProc; + type.freeProc = NULL; + type.clientData = NULL; + type.nullSize = 0; + + controlFamily.refCount = 2; + controlFamily.encoding = Tcl_CreateEncoding(&type); + controlFamily.isTwoByteFont = 0; + + dummy.familyPtr = &controlFamily; + dummy.fontMap = controlFamily.fontMap; + for (i = 0x00; i < 0x20; i++) { + FontMapInsert(&dummy, i); + FontMapInsert(&dummy, i + 0x80); + } + } +} + +/* + *------------------------------------------------------------------------- + * + * 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, src, srcLen, flags, statePtr, dst, dstLen, + srcReadPtr, dstWrotePtr, dstCharsPtr) + 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 - srcEnd; + *dstWrotePtr = dst - dstStart; + *dstCharsPtr = dst - dstStart; + return result; +} /* *--------------------------------------------------------------------------- @@ -116,24 +407,52 @@ static int GetControlCharSubst _ANSI_ARGS_((int c, char buf[4])); * the contents of the generic TkFont before calling TkpDeleteFont(). * * Side effects: - * None. + * Memory allocated. * *--------------------------------------------------------------------------- */ - + TkFont * TkpGetNativeFont(tkwin, name) Tk_Window tkwin; /* For display where font will be used. */ CONST char *name; /* Platform-specific font name. */ { + UnixFont *fontPtr; XFontStruct *fontStructPtr; + FontAttributes fa; fontStructPtr = XLoadQueryFont(Tk_Display(tkwin), name); if (fontStructPtr == NULL) { - return 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 = (UnixFont *) ckalloc(sizeof(UnixFont)); + InitFont(tkwin, fontStructPtr, fontPtr); - return (TkFont *) AllocFont(NULL, tkwin, fontStructPtr, name); + return (TkFont *) fontPtr; } /* @@ -160,7 +479,7 @@ TkpGetNativeFont(tkwin, name) * the contents of the generic TkFont before calling TkpDeleteFont(). * * Side effects: - * None. + * Memory allocated. * *--------------------------------------------------------------------------- */ @@ -173,249 +492,29 @@ TkpGetFontFromAttributes(tkFontPtr, tkwin, faPtr) * 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. */ + CONST TkFontAttributes *faPtr; + /* Set of attributes to match. */ { - int numNames, score, i, scaleable, pixelsize, xaPixelsize; - int bestIdx, bestScore, bestScaleableIdx, bestScaleableScore; - TkXLFDAttributes xa; - char buf[256]; UnixFont *fontPtr; - char **nameList; + TkXLFDAttributes xa; XFontStruct *fontStructPtr; - CONST char *fmt, *family; - double d; - family = faPtr->family; - if (family == NULL) { - family = "*"; - } + TkInitXLFDAttributes(&xa); + fontStructPtr = CreateClosestFont(tkwin, faPtr, &xa); - pixelsize = -faPtr->pointsize; - if (pixelsize < 0) { - d = -pixelsize * 25.4 / 72; - d *= WidthOfScreen(Tk_Screen(tkwin)); - d /= WidthMMOfScreen(Tk_Screen(tkwin)); - d += 0.5; - pixelsize = (int) d; - } - - /* - * Replace the standard Windows and Mac family names with the names that - * X likes. - */ - - if ((strcasecmp("Times New Roman", family) == 0) - || (strcasecmp("New York", family) == 0)) { - family = "Times"; - } else if ((strcasecmp("Courier New", family) == 0) - || (strcasecmp("Monaco", family) == 0)) { - family = "Courier"; - } else if ((strcasecmp("Arial", family) == 0) - || (strcasecmp("Geneva", family) == 0)) { - family = "Helvetica"; - } - - /* - * First try for the Q&D exact match. - */ - -#if 0 - sprintf(buf, "-*-%.200s-%s-%c-normal-*-*-%d-*-*-*-*-iso8859-1", family, - ((faPtr->weight > TK_FW_NORMAL) ? "bold" : "medium"), - ((faPtr->slant == TK_FS_ROMAN) ? 'r' : - (faPtr->slant == TK_FS_ITALIC) ? 'i' : 'o'), - faPtr->pointsize * 10); - fontStructPtr = XLoadQueryFont(Tk_Display(tkwin), buf); -#else - fontStructPtr = NULL; -#endif - - if (fontStructPtr != NULL) { - goto end; - } - /* - * Couldn't find exact match. Now fall back to other available - * physical fonts. - */ - - fmt = "-*-%.240s-*-*-*-*-*-*-*-*-*-*-*-*"; - sprintf(buf, fmt, family); - nameList = XListFonts(Tk_Display(tkwin), buf, 10000, &numNames); - if (numNames == 0) { - /* - * Try getting some system font. - */ - - sprintf(buf, fmt, "fixed"); - nameList = XListFonts(Tk_Display(tkwin), buf, 10000, &numNames); - if (numNames == 0) { - getsystem: - fontStructPtr = XLoadQueryFont(Tk_Display(tkwin), "fixed"); - if (fontStructPtr == NULL) { - fontStructPtr = XLoadQueryFont(Tk_Display(tkwin), "*"); - if (fontStructPtr == NULL) { - panic("TkpGetFontFromAttributes: cannot get any font"); - } - } - goto end; - } - } - - /* - * Inspect each of the XLFDs and pick the one that most closely - * matches the desired attributes. - */ - - bestIdx = 0; - bestScore = INT_MAX; - bestScaleableIdx = 0; - bestScaleableScore = INT_MAX; - - for (i = 0; i < numNames; i++) { - score = 0; - scaleable = 0; - if (TkParseXLFD(nameList[i], &xa) != TCL_OK) { - continue; - } - xaPixelsize = -xa.fa.pointsize; - - /* - * Since most people used to use -adobe-* in their XLFDs, - * preserve the preference for "adobe" foundry. Otherwise - * some applications looks may change slightly if another foundry - * is chosen. - */ - - if (strcasecmp(xa.foundry, "adobe") != 0) { - score += 3000; - } - if (xa.fa.pointsize == 0) { - /* - * A scaleable font is almost always acceptable, but the - * corresponding bitmapped font would be better. - */ - - score += 10; - scaleable = 1; - } else { - /* - * A font that is too small is better than one that is too - * big. - */ - - if (xaPixelsize > pixelsize) { - score += (xaPixelsize - pixelsize) * 120; - } else { - score += (pixelsize - xaPixelsize) * 100; - } - } - - score += ABS(xa.fa.weight - faPtr->weight) * 30; - score += ABS(xa.fa.slant - faPtr->slant) * 25; - if (xa.slant == TK_FS_OBLIQUE) { - /* - * Italic fonts are preferred over oblique. */ - - score += 4; - } - - if (xa.setwidth != TK_SW_NORMAL) { - /* - * The normal setwidth is highly preferred. - */ - score += 2000; - } - if (xa.charset == TK_CS_OTHER) { - /* - * The standard character set is highly preferred over - * foreign languages charsets (because we don't support - * other languages yet). - */ - score += 11000; - } - if ((xa.charset == TK_CS_NORMAL) && (xa.encoding != 1)) { - /* - * The '1' encoding for the characters above 0x7f is highly - * preferred over the other encodings. - */ - score += 8000; - } - - if (scaleable) { - if (score < bestScaleableScore) { - bestScaleableIdx = i; - bestScaleableScore = score; - } - } else { - if (score < bestScore) { - bestIdx = i; - bestScore = score; - } - } - if (score == 0) { - break; - } - } - - /* - * Now we know which is the closest matching scaleable font and the - * closest matching bitmapped font. If the scaleable font was a - * better match, try getting the scaleable font; however, if the - * scalable font was not actually available in the desired - * pointsize, fall back to the closest bitmapped font. - */ - - fontStructPtr = NULL; - if (bestScaleableScore < bestScore) { - char *str, *rest; - - /* - * Fill in the desired pointsize info for this font. - */ - - tryscale: - str = nameList[bestScaleableIdx]; - for (i = 0; i < XLFD_PIXEL_SIZE - 1; i++) { - str = strchr(str + 1, '-'); - } - rest = str; - for (i = XLFD_PIXEL_SIZE - 1; i < XLFD_REGISTRY; i++) { - rest = strchr(rest + 1, '-'); - } - *str = '\0'; - sprintf(buf, "%.240s-*-%d-*-*-*-*-*%s", nameList[bestScaleableIdx], - pixelsize, rest); - *str = '-'; - fontStructPtr = XLoadQueryFont(Tk_Display(tkwin), buf); - bestScaleableScore = INT_MAX; - } - if (fontStructPtr == NULL) { - strcpy(buf, nameList[bestIdx]); - fontStructPtr = XLoadQueryFont(Tk_Display(tkwin), buf); - 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 (bestScaleableScore < INT_MAX) { - goto tryscale; - } else { - XFreeFontNames(nameList); - goto getsystem; - } - } + fontPtr = (UnixFont *) tkFontPtr; + if (fontPtr == NULL) { + fontPtr = (UnixFont *) ckalloc(sizeof(UnixFont)); + } else { + ReleaseFont(fontPtr); } - XFreeFontNames(nameList); + InitFont(tkwin, fontStructPtr, fontPtr); - end: - fontPtr = AllocFont(tkFontPtr, tkwin, fontStructPtr, buf); - fontPtr->font.fa.underline = faPtr->underline; + fontPtr->font.fa.underline = faPtr->underline; fontPtr->font.fa.overstrike = faPtr->overstrike; return (TkFont *) fontPtr; } - /* *--------------------------------------------------------------------------- @@ -443,9 +542,7 @@ TkpDeleteFont(tkFontPtr) UnixFont *fontPtr; fontPtr = (UnixFont *) tkFontPtr; - - XFreeFont(fontPtr->display, fontPtr->fontStructPtr); - ckfree((char *) fontPtr); + ReleaseFont(fontPtr); } /* @@ -457,7 +554,7 @@ TkpDeleteFont(tkFontPtr) * on the display of the given window. * * Results: - * interp->result is modified to hold a list of all the available + * Modifies interp's result object to hold a list of all the available * font families. * * Side effects: @@ -465,52 +562,80 @@ TkpDeleteFont(tkFontPtr) * *--------------------------------------------------------------------------- */ - + void TkpGetFontFamilies(interp, tkwin) - Tcl_Interp *interp; - Tk_Window tkwin; + Tcl_Interp *interp; /* Interp to hold result. */ + Tk_Window tkwin; /* For display to query. */ { int i, new, numNames; - char *family, *end, *p; + char *family; Tcl_HashTable familyTable; Tcl_HashEntry *hPtr; Tcl_HashSearch search; char **nameList; + Tcl_Obj *resultPtr, *strPtr; - Tcl_InitHashTable(&familyTable, TCL_STRING_KEYS); + resultPtr = Tcl_GetObjResult(interp); - nameList = XListFonts(Tk_Display(tkwin), "*", 10000, &numNames); + Tcl_InitHashTable(&familyTable, TCL_STRING_KEYS); + nameList = ListFonts(Tk_Display(tkwin), "*", &numNames); for (i = 0; i < numNames; i++) { - if (nameList[i][0] != '-') { - continue; - } - family = strchr(nameList[i] + 1, '-'); - if (family == NULL) { - continue; - } - family++; - end = strchr(family, '-'); - if (end == NULL) { - continue; - } - *end = '\0'; - for (p = family; *p != '\0'; p++) { - if (isupper(UCHAR(*p))) { - *p = tolower(UCHAR(*p)); - } - } + family = strchr(nameList[i] + 1, '-') + 1; + strchr(family, '-')[0] = '\0'; Tcl_CreateHashEntry(&familyTable, family, &new); } + XFreeFontNames(nameList); hPtr = Tcl_FirstHashEntry(&familyTable, &search); while (hPtr != NULL) { - Tcl_AppendElement(interp, Tcl_GetHashKey(&familyTable, hPtr)); + strPtr = Tcl_NewStringObj(Tcl_GetHashKey(&familyTable, hPtr), -1); + Tcl_ListObjAppendElement(NULL, resultPtr, strPtr); hPtr = Tcl_NextHashEntry(&search); } Tcl_DeleteHashTable(&familyTable); - XFreeFontNames(nameList); +} + +/* + *------------------------------------------------------------------------- + * + * 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(interp, tkfont) + Tcl_Interp *interp; + Tk_Font tkfont; +{ + int i; + Tcl_Obj *objv[3]; + Tcl_Obj *resultPtr, *listPtr; + UnixFont *fontPtr; + FontFamily *familyPtr; + + resultPtr = Tcl_GetObjResult(interp); + 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); + } } /* @@ -534,18 +659,19 @@ TkpGetFontFamilies(interp, tkwin) * *--------------------------------------------------------------------------- */ + int -Tk_MeasureChars(tkfont, source, numChars, maxLength, flags, lengthPtr) +Tk_MeasureChars(tkfont, source, numBytes, maxLength, flags, lengthPtr) Tk_Font tkfont; /* Font in which characters will be drawn. */ - CONST char *source; /* Characters to be displayed. Need not be + CONST char *source; /* UTF-8 string to be displayed. Need not be * '\0' terminated. */ - int numChars; /* Maximum number of characters to consider + int numBytes; /* Maximum number of bytes to consider * from source string. */ - 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 + 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 @@ -558,99 +684,179 @@ Tk_MeasureChars(tkfont, source, numChars, maxLength, flags, lengthPtr) * terminating character. */ { UnixFont *fontPtr; - CONST char *p; /* Current character. */ - CONST char *term; /* Pointer to most recent character that - * may legally be a terminating character. */ - int termX; /* X-position just after term. */ - int curX; /* X-position corresponding to p. */ - int newX; /* X-position corresponding to p+1. */ - int c, sawNonSpace; + SubFont *lastSubFontPtr; + int curX, curByte; - fontPtr = (UnixFont *) tkfont; + /* + * 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. + */ - if (numChars == 0) { - *lengthPtr = 0; - return 0; - } + fontPtr = (UnixFont *) tkfont; - if (maxLength <= 0) { - maxLength = INT_MAX; - } + lastSubFontPtr = &fontPtr->subFontArray[0]; - newX = curX = termX = 0; - p = term = source; - sawNonSpace = !isspace(UCHAR(*p)); + 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; - /* - * Scan the input string one character at a time, calculating width. - */ + /* + * 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. + */ - for (c = UCHAR(*p); ; ) { - newX += fontPtr->widths[c]; - if (newX > maxLength) { - break; + curX = 0; + end = source + numBytes; + for (p = source; p < end; ) { + next = p + Tcl_UtfToUniChar(p, &ch); + thisSubFontPtr = FindSubFontForChar(fontPtr, ch); + 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; } - curX = newX; - numChars--; - p++; - if (numChars == 0) { - term = p; - termX = curX; - break; + 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; + char buf[16]; + + /* + * How many chars will fit in the space allotted? + * This first version may be inefficient because it measures + * every character individually. + */ - c = UCHAR(*p); - if (isspace(c)) { - if (sawNonSpace) { - term = p; + 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); + familyPtr = lastSubFontPtr->familyPtr; + Tcl_UtfToExternal(NULL, familyPtr->encoding, p, next - p, + 0, NULL, buf, sizeof(buf), NULL, &dstWrote, NULL); + if (familyPtr->isTwoByteFont) { + newX += XTextWidth16(lastSubFontPtr->fontStructPtr, + (XChar2b *) buf, dstWrote >> 1); + } else { + newX += XTextWidth(lastSubFontPtr->fontStructPtr, buf, + dstWrote); + } + } + if (newX > maxLength) { + break; + } + curX = newX; + p = next; + if (p >= end) { + term = end; termX = curX; - sawNonSpace = 0; + break; } - } 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. - */ + next += Tcl_UtfToUniChar(next, &ch); + if ((ch < 256) && isspace(ch)) { + if (sawNonSpace) { + term = p; + termX = curX; + sawNonSpace = 0; + } + } else { + sawNonSpace = 1; + } + } - if ((flags & TK_PARTIAL_OK) && (numChars > 0) && (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. + * P points to the first character that doesn't fit in the desired + * span. Use the flags to figure out what to return. */ - numChars--; - curX = newX; - p++; - } - if ((flags & TK_AT_LEAST_ONE) && (term == source) && (numChars > 0)) { - term = p; - termX = curX; - if (term == source) { - term++; - termX = newX; + 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); } - } else if ((numChars == 0) || !(flags & TK_WHOLE_WORDS)) { - term = p; - termX = curX; + 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 = termX; - return term-source; + *lengthPtr = curX; + return curByte; } /* *--------------------------------------------------------------------------- * - * Tk_DrawChars, DrawChars -- + * Tk_DrawChars -- * * Draw a string of characters on the screen. Tk_DrawChars() - * expands control characters that occur in the string to \X or - * \xXX sequences. DrawChars() just draws the strings. + * expands control characters that occur in the string to + * \xNN sequences. * * Results: * None. @@ -662,236 +868,357 @@ Tk_MeasureChars(tkfont, source, numChars, maxLength, flags, lengthPtr) */ void -Tk_DrawChars(display, drawable, gc, tkfont, source, numChars, x, y) +Tk_DrawChars(display, drawable, gc, tkfont, source, numBytes, x, y) 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; /* Characters to be displayed. Need not be + 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 numChars; /* Number of characters in string. */ + int numBytes; /* Number of bytes in string. */ int x, y; /* Coordinates at which to place origin of * string when drawing. */ { UnixFont *fontPtr; - CONST char *p; - int i, type; - char buf[4]; + SubFont *thisSubFontPtr, *lastSubFontPtr; + Tcl_DString runString; + CONST char *p, *end, *next; + int xStart, needWidth; + Tcl_UniChar ch; + FontFamily *familyPtr; fontPtr = (UnixFont *) tkfont; - - p = source; - for (i = 0; i < numChars; i++) { - type = fontPtr->types[UCHAR(*p)]; - if (type != NORMAL) { - DrawChars(display, drawable, gc, fontPtr, source, p - source, x, y); - x += XTextWidth(fontPtr->fontStructPtr, source, p - source); - if (type == REPLACE) { - DrawChars(display, drawable, gc, fontPtr, buf, - GetControlCharSubst(UCHAR(*p), buf), x, y); - x += fontPtr->widths[UCHAR(*p)]; + lastSubFontPtr = &fontPtr->subFontArray[0]; + + xStart = x; + + end = source + numBytes; + for (p = source; p < end; ) { + next = p + Tcl_UtfToUniChar(p, &ch); + thisSubFontPtr = FindSubFontForChar(fontPtr, ch); + if (thisSubFontPtr != lastSubFontPtr) { + if (p > source) { + 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); + + 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)); + x += XTextWidth(lastSubFontPtr->fontStructPtr, + Tcl_DStringValue(&runString), + Tcl_DStringLength(&runString)); + } + Tcl_DStringFree(&runString); } - source = p + 1; + lastSubFontPtr = thisSubFontPtr; + source = p; + XSetFont(display, gc, lastSubFontPtr->fontStructPtr->fid); } - p++; + p = next; } - DrawChars(display, drawable, gc, fontPtr, source, p - source, x, y); -} + needWidth = fontPtr->font.fa.underline + fontPtr->font.fa.overstrike; + if (p > source) { + 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) >> 1); + if (needWidth) { + x += XTextWidth16(lastSubFontPtr->fontStructPtr, + (XChar2b *) Tcl_DStringValue(&runString), + Tcl_DStringLength(&runString) >> 1); + } + } else { + XDrawString(display, drawable, gc, x, y, + Tcl_DStringValue(&runString), + Tcl_DStringLength(&runString)); + if (needWidth) { + x += XTextWidth(lastSubFontPtr->fontStructPtr, + Tcl_DStringValue(&runString), + Tcl_DStringLength(&runString)); + } + } + Tcl_DStringFree(&runString); + } -static void -DrawChars(display, drawable, gc, fontPtr, source, numChars, x, y) - Display *display; /* Display on which to draw. */ - Drawable drawable; /* Window or pixmap in which to draw. */ - GC gc; /* Graphics context for drawing characters. */ - UnixFont *fontPtr; /* Font in which characters will be drawn; - * must be the same as font used in GC. */ - CONST char *source; /* Characters 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 numChars; /* Number of characters in string. */ - int x, y; /* Coordinates at which to place origin of - * string when drawing. */ -{ - XDrawString(display, drawable, gc, x, y, source, numChars); + if (lastSubFontPtr != &fontPtr->subFontArray[0]) { + XSetFont(display, gc, fontPtr->subFontArray[0].fontStructPtr->fid); + } if (fontPtr->font.fa.underline != 0) { - XFillRectangle(display, drawable, gc, x, + XFillRectangle(display, drawable, gc, xStart, y + fontPtr->underlinePos, - (unsigned) XTextWidth(fontPtr->fontStructPtr, source, numChars), - (unsigned) fontPtr->barHeight); + (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, x, y, - (unsigned) XTextWidth(fontPtr->fontStructPtr, source, numChars), - (unsigned) fontPtr->barHeight); + XFillRectangle(display, drawable, gc, xStart, y, + (unsigned) (x - xStart), (unsigned) fontPtr->barHeight); } } /* - *--------------------------------------------------------------------------- + *------------------------------------------------------------------------- * - * AllocFont -- + * CreateClosestFont -- * * Helper for TkpGetNativeFont() and TkpGetFontFromAttributes(). - * Allocates and intializes the memory for a new TkFont that - * wraps the platform-specific data. + * 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: - * Returns pointer to newly constructed TkFont. - * - * 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(). + * 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: - * Memory allocated. + * None. * - *--------------------------------------------------------------------------- - */ + *------------------------------------------------------------------------- + */ -static UnixFont * -AllocFont(tkFontPtr, tkwin, fontStructPtr, fontName) - 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. */ +static XFontStruct * +CreateClosestFont(tkwin, faPtr, xaPtr) Tk_Window tkwin; /* For display where font will be used. */ - XFontStruct *fontStructPtr; /* X information about font. */ - CONST char *fontName; /* The string passed to XLoadQueryFont() to - * construct the fontStructPtr. */ + CONST TkFontAttributes *faPtr; + /* Set of generic attributes to match. */ + CONST TkXLFDAttributes *xaPtr; + /* Set of X-specific attributes to match. */ { - UnixFont *fontPtr; - unsigned long value; - int i, width, firstChar, lastChar, n, replaceOK; - char *name, *p; - char buf[4]; - TkXLFDAttributes xa; - double d; - - if (tkFontPtr != NULL) { - fontPtr = (UnixFont *) tkFontPtr; - XFreeFont(fontPtr->display, fontPtr->fontStructPtr); - } else { - fontPtr = (UnixFont *) ckalloc(sizeof(UnixFont)); + FontAttributes want; + char **nameList; + int numNames, nameIdx; + Display *display; + XFontStruct *fontStructPtr; + int bestIdx[2]; + unsigned int 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 = Tk_GetUid("iso8859-1"); /* locale. */ } + display = Tk_Display(tkwin); + /* - * Encapsulate the generic stuff in the TkFont. + * 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 */ - fontPtr->font.fid = fontStructPtr->fid; - - if (XGetFontProperty(fontStructPtr, XA_FONT, &value) && (value != 0)) { - name = Tk_GetAtomName(tkwin, (Atom) value); - TkInitFontAttributes(&xa.fa); - if (TkParseXLFD(name, &xa) == TCL_OK) { - goto ok; + nameList = ListFontOrAlias(display, want.fa.family, &numNames); + if (numNames == 0) { + char ***fontFallbacks; + int i, j; + 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); } } - TkInitFontAttributes(&xa.fa); - if (TkParseXLFD(fontName, &xa) != TCL_OK) { - TkInitFontAttributes(&fontPtr->font.fa); - fontPtr->font.fa.family = Tk_GetUid(fontName); - } else { - ok: - fontPtr->font.fa = xa.fa; + found: + bestIdx[0] = -1; + bestIdx[1] = -1; + bestScore[0] = (unsigned int) -1; + bestScore[1] = (unsigned int) -1; + for (nameIdx = 0; nameIdx < numNames; nameIdx++) { + FontAttributes got; + int scalable; + unsigned int 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; + } } - if (fontPtr->font.fa.pointsize < 0) { - d = -fontPtr->font.fa.pointsize * 72 / 25.4; - d *= WidthMMOfScreen(Tk_Screen(tkwin)); - d /= WidthOfScreen(Tk_Screen(tkwin)); - d += 0.5; - fontPtr->font.fa.pointsize = (int) d; + fontStructPtr = GetScreenFont(display, &want, nameList, bestIdx, bestScore); + XFreeFontNames(nameList); + + if (fontStructPtr == NULL) { + return GetSystemFont(display); } - - fontPtr->font.fm.ascent = fontStructPtr->ascent; - fontPtr->font.fm.descent = fontStructPtr->descent; - fontPtr->font.fm.maxWidth = fontStructPtr->max_bounds.width; - fontPtr->font.fm.fixed = 1; - fontPtr->display = Tk_Display(tkwin); - fontPtr->fontStructPtr = fontStructPtr; + 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(tkwin, fontStructPtr, fontPtr) + 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. */ +{ + 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; /* - * Classify the characters. + * Get all font attributes and metrics. */ - - firstChar = fontStructPtr->min_char_or_byte2; - lastChar = fontStructPtr->max_char_or_byte2; - for (i = 0; i < 256; i++) { - if ((i == 0177) || (i < firstChar) || (i > lastChar)) { - fontPtr->types[i] = REPLACE; - } else { - fontPtr->types[i] = NORMAL; + + 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; + } + } } } - /* - * Compute the widths for all the normal characters. Any other - * characters are given an initial width of 0. Also, this determines - * if this is a fixed or variable width font, by comparing the widths - * of all the normal characters. - */ - - width = 0; + 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'); + controlPtr = &fontPtr->controlSubFont; + controlPtr->fontStructPtr = subFontPtr->fontStructPtr; + controlPtr->familyPtr = &controlFamily; + controlPtr->fontMap = controlFamily.fontMap; + + pageMap = fontPtr->subFontArray[0].fontMap[0]; for (i = 0; i < 256; i++) { - if (fontPtr->types[i] != NORMAL) { + if ((minHi > 0) || (i < minLo) || (i > maxLo) || + (((pageMap[i >> 3] >> (i & 7)) & 1) == 0)) { n = 0; } else if (fontStructPtr->per_char == NULL) { n = fontStructPtr->max_bounds.width; } else { - n = fontStructPtr->per_char[i - firstChar].width; + n = fontStructPtr->per_char[i - minLo].width; } fontPtr->widths[i] = n; - if (n != 0) { - if (width == 0) { - width = n; - } else if (width != n) { - fontPtr->font.fm.fixed = 0; - } - } - } - - /* - * Compute the widths of the characters that should be replaced with - * control character expansions. If the appropriate chars are not - * available in this font, then control character expansions will not - * be used; control chars will be invisible & zero-width. - */ - - replaceOK = 1; - for (p = hexChars; *p != '\0'; p++) { - if ((UCHAR(*p) < firstChar) || (UCHAR(*p) > lastChar)) { - replaceOK = 0; - break; - } - } - for (i = 0; i < 256; i++) { - if (fontPtr->types[i] == REPLACE) { - if (replaceOK) { - n = GetControlCharSubst(i, buf); - for ( ; --n >= 0; ) { - fontPtr->widths[i] += fontPtr->widths[UCHAR(buf[n])]; - } - } else { - fontPtr->types[i] = SKIP; - } - } } + if (XGetFontProperty(fontStructPtr, XA_UNDERLINE_POSITION, &value)) { fontPtr->underlinePos = value; @@ -905,9 +1232,6 @@ AllocFont(tkFontPtr, tkwin, fontStructPtr, fontName) } fontPtr->barHeight = 0; if (XGetFontProperty(fontStructPtr, XA_UNDERLINE_THICKNESS, &value)) { - /* - * Sometimes this is 0 even though it shouldn't be. - */ fontPtr->barHeight = value; } if (fontPtr->barHeight == 0) { @@ -936,23 +1260,620 @@ AllocFont(tkFontPtr, tkwin, fontStructPtr, fontName) 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(fontPtr) + UnixFont *fontPtr; /* The font to delete. */ +{ + int i; - return fontPtr; + for (i = 0; i < fontPtr->numSubFonts; i++) { + ReleaseSubFont(fontPtr->display, &fontPtr->subFontArray[i]); + } + if (fontPtr->subFontArray != fontPtr->staticSubFonts) { + ckfree((char *) 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, fontStructPtr, base, subFontPtr) + 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, subFontPtr) + Display *display; /* Display which owns screen font. */ + SubFont *subFontPtr; /* The SubFont to delete. */ +{ + XFreeFont(display, subFontPtr->fontStructPtr); + FreeFontFamily(subFontPtr->familyPtr); +} + +/* + *------------------------------------------------------------------------- * - * GetControlCharSubst -- + * AllocFontFamily -- * - * When displaying text in a widget, a backslashed escape sequence - * is substituted for control characters that occur in the text. - * Given a control character, fill in a buffer with the replacement - * string that should be displayed. + * 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: - * The return value is the length of the substitute string. buf is - * filled with the substitute string; it is not '\0' terminated. + * 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, fontStructPtr, base) + 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; + + GetFontAttributes(display, fontStructPtr, &fa); + encoding = Tcl_GetEncoding(NULL, GetEncodingAlias(fa.xa.charset)); + + familyPtr = 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 = (FontFamily *) ckalloc(sizeof(FontFamily)); + memset(familyPtr, 0, sizeof(FontFamily)); + familyPtr->nextPtr = fontFamilyList; + 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; + familyPtr->isTwoByteFont = (fontStructPtr->min_byte1 > 0); + 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(familyPtr) + FontFamily *familyPtr; /* The FontFamily to delete. */ +{ + FontFamily **familyPtrPtr; + 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 = &fontFamilyList; ; ) { + if (*familyPtrPtr == familyPtr) { + *familyPtrPtr = familyPtr->nextPtr; + break; + } + familyPtrPtr = &(*familyPtrPtr)->nextPtr; + } + + ckfree((char *) 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. + * + *------------------------------------------------------------------------- + */ + +static SubFont * +FindSubFontForChar(fontPtr, ch) + UnixFont *fontPtr; /* The font object with which the character + * will be displayed. */ + int ch; /* The Unicode character to be displayed. */ +{ + int i, j, k, numNames; + char *faceName, *fallback; + char **aliases, **nameList, **anyFallbacks; + char ***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); + 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); + 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); + 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); + 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(subFontPtr, ch) + 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(subFontPtr, ch) + 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: + * Mempry allocated. + * + *------------------------------------------------------------------------- + */ +static void +FontMapLoadPage(subFontPtr, row) + SubFont *subFontPtr; /* Contains font mapping cache to be + * updated. */ + int row; /* Index of the page to be loaded into + * the cache. */ +{ + char src[TCL_UTF_MAX], buf[16]; + int minHi, maxHi, minLo, maxLo, scale; + int i, end, bitOffset, isTwoByteFont, n; + Tcl_Encoding encoding; + XFontStruct *fontStructPtr; + XCharStruct *widths; + + subFontPtr->fontMap[row] = (char *) ckalloc(FONTMAP_BITSPERPAGE / 8); + memset(subFontPtr->fontMap[row], 0, FONTMAP_BITSPERPAGE / 8); + + if (subFontPtr->familyPtr == &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; + + if (isTwoByteFont == 0) { + if (minLo < 32) { + minLo = 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 < minLo) || (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. + * + *--------------------------------------------------------------------------- + */ + +static SubFont * +CanUseFallbackWithAliases(fontPtr, faceName, ch, nameTriedPtr) + UnixFont *fontPtr; /* The font object that will own the new + * screen font. */ + 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 *subFontPtr; + char **aliases; + int i; + + if (SeenName(faceName, nameTriedPtr) == 0) { + subFontPtr = CanUseFallback(fontPtr, faceName, ch); + 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); + 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. @@ -961,19 +1882,662 @@ AllocFont(tkFontPtr, tkwin, fontStructPtr, fontName) */ static int -GetControlCharSubst(c, buf) - int c; /* The control character to be replaced. */ - char buf[4]; /* Buffer that gets replacement string. It - * only needs to be 4 characters long. */ +SeenName(name, dsPtr) + 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, (char *) 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. + * + *------------------------------------------------------------------------- + */ + +static SubFont * +CanUseFallback(fontPtr, faceName, ch) + UnixFont *fontPtr; /* The font object that will own the new + * screen font. */ + char *faceName; /* Desired face name for new screen font. */ + int ch; /* The Unicode character that the new + * screen font must be able to display. */ { - buf[0] = '\\'; - if ((c < sizeof(mapChars)) && (mapChars[c] != 0)) { - buf[1] = mapChars[c]; - return 2; + int i, nameIdx, numNames, srcLen; + Tk_Uid hateFoundry; + int bestIdx[2]; + CONST char *charset, *hateCharset; + unsigned int bestScore[2]; + char **nameList, **nameListOrig; + FontAttributes want, got; + char src[TCL_UTF_MAX]; + Display *display; + SubFont subFont; + XFontStruct *fontStructPtr; + Tcl_DString dsEncodings; + int numEncodings; + 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 int) -1; + bestScore[1] = (unsigned int) -1; + for (nameIdx = 0; nameIdx < numNames; nameIdx++) { + Tcl_Encoding encoding; + char dst[16]; + int scalable, srcRead, dstWrote; + unsigned int 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 = (char **) 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((char *) 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((char *) nameList); + } + XFreeFontNames(nameListOrig); + + if (fontPtr->numSubFonts >= SUBFONT_SPACE) { + SubFont *newPtr; + + newPtr = (SubFont *) ckalloc(sizeof(SubFont) * (fontPtr->numSubFonts + 1)); + memcpy((char *) newPtr, fontPtr->subFontArray, + fontPtr->numSubFonts * sizeof(SubFont)); + if (fontPtr->subFontArray != fontPtr->staticSubFonts) { + ckfree((char *) 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 int +RankAttributes(wantPtr, gotPtr) + FontAttributes *wantPtr; /* The desired attributes. */ + FontAttributes *gotPtr; /* The attributes we have to live with. */ +{ + unsigned int 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, wantPtr, nameList, bestIdx, bestScore) + 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 int 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; + char 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; /* Display for new XFontStruct. */ +{ + XFontStruct *fontStructPtr; + + fontStructPtr = XLoadQueryFont(display, "fixed"); + if (fontStructPtr == NULL) { + fontStructPtr = XLoadQueryFont(display, "*"); + if (fontStructPtr == NULL) { + 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, fontStructPtr, faPtr) + 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 *p, *name; + + if ((XGetFontProperty(fontStructPtr, XA_FONT, &value) != False) && + (value != 0)) { + name = XGetAtomName(display, (Atom) value); + for (p = name; *p != '\0'; p++) { + if (isupper(UCHAR(*p))) { /* INTL: native text */ + *p = tolower(UCHAR(*p)); /* INTL: native text */ + } + } + 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 { - buf[1] = 'x'; - buf[2] = hexChars[(c >> 4) & 0xf]; - buf[3] = hexChars[c & 0xf]; - return 4; + TkInitFontAttributes(&faPtr->fa); + TkInitXLFDAttributes(&faPtr->xa); + 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, faceName, numNamesPtr) + 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, faceName, numNamesPtr) + 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, **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(faPtr) + FontAttributes *faPtr; +{ + int i, j; + char **aliases, **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(name) + CONST char *name; /* The name to look up. */ +{ + EncodingAlias *aliasPtr; + + for (aliasPtr = encodingAliases; aliasPtr->aliasPattern != NULL; ) { + if (Tcl_StringMatch((char *) name, aliasPtr->aliasPattern)) { + return aliasPtr->realName; + } + aliasPtr++; + } + return name; +} + + diff --git a/unix/tkUnixInit.c b/unix/tkUnixInit.c index acfd8de..c90eb16 100644 --- a/unix/tkUnixInit.c +++ b/unix/tkUnixInit.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkUnixInit.c 1.24 97/07/24 14:46:09 + * SCCS: @(#) tkUnixInit.c 1.26 98/01/02 17:45:36 */ #include "tkInt.h" @@ -39,7 +39,7 @@ static char defaultLibraryDir[200] = TK_LIBRARY; * * Results: * Returns a standard Tcl result. Leaves an error message or result - * in interp->result. + * in the interp's result. * * Side effects: * Sets "tk_library" Tcl variable, runs "tk.tcl" script. @@ -122,9 +122,9 @@ TkpDisplayWarning(msg, title) { Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR); if (errChannel) { - Tcl_Write(errChannel, title, -1); - Tcl_Write(errChannel, ": ", 2); - Tcl_Write(errChannel, msg, -1); - Tcl_Write(errChannel, "\n", 1); + Tcl_WriteChars(errChannel, title, -1); + Tcl_WriteChars(errChannel, ": ", 2); + Tcl_WriteChars(errChannel, msg, -1); + Tcl_WriteChars(errChannel, "\n", 1); } } diff --git a/unix/tkUnixInt.h b/unix/tkUnixInt.h index 41bbb66..bef2f38 100644 --- a/unix/tkUnixInt.h +++ b/unix/tkUnixInt.h @@ -10,12 +10,16 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkUnixInt.h 1.9 97/05/08 11:20:12 + * SCCS: @(#) tkUnixInt.h 1.10 97/05/15 14:47:03 */ #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. diff --git a/unix/tkUnixKey.c b/unix/tkUnixKey.c new file mode 100644 index 0000000..6df12fc --- /dev/null +++ b/unix/tkUnixKey.c @@ -0,0 +1,90 @@ +/* + * 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. + * + * SCCS: @(#) tkUnixKey.c 1.3 98/01/13 17:34:38 + */ + +#include "tkInt.h" + + +/* + *---------------------------------------------------------------------- + * + * 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. + * + *---------------------------------------------------------------------- + */ + +char * +TkpGetString(winPtr, eventPtr, dsPtr) + TkWindow *winPtr; /* Window where event occurred: needed to + * get input context. */ + XEvent *eventPtr; /* X keyboard event. */ + Tcl_DString *dsPtr; /* Uninitialized or empty string to hold + * result. */ +{ + int len; + Tcl_DString buf; + Status status; + + /* + * Overallocate the dstring to the maximum stack amount. + */ + + Tcl_DStringInit(&buf); + Tcl_DStringSetLength(&buf, TCL_DSTRING_STATIC_SIZE-1); + +#ifdef TK_USE_INPUT_METHODS + if ((winPtr->inputContext != NULL) + && (eventPtr->type == KeyPress)) { + len = XmbLookupString(winPtr->inputContext, &eventPtr->xkey, + Tcl_DStringValue(&buf), Tcl_DStringLength(&buf), + (KeySym *) NULL, &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, (KeySym *) NULL, &status); + } + if ((status != XLookupChars) + && (status != XLookupBoth)) { + len = 0; + } + } else { + len = XLookupString(&eventPtr->xkey, Tcl_DStringValue(&buf), + Tcl_DStringLength(&buf), (KeySym *) NULL, + (XComposeStatus *) NULL); + } +#else /* TK_USE_INPUT_METHODS */ + len = XLookupString(&eventPtr->xkey, Tcl_DStringValue(&buf), + Tcl_DStringLength(&buf), (KeySym *) NULL, + (XComposeStatus *) NULL); +#endif /* TK_USE_INPUT_METHODS */ + Tcl_DStringSetLength(&buf, len); + + Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&buf), len, dsPtr); + Tcl_DStringFree(&buf); + + return Tcl_DStringValue(dsPtr); +} diff --git a/unix/tkUnixMenu.c b/unix/tkUnixMenu.c index 3179a31..20d7196 100644 --- a/unix/tkUnixMenu.c +++ b/unix/tkUnixMenu.c @@ -3,12 +3,12 @@ * * This module implements the UNIX platform-specific features of menus. * - * Copyright (c) 1996-1997 by Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkUnixMenu.c 1.76 97/11/05 09:08:22 + * SCCS: @(#) tkUnixMenu.c 1.80 98/01/20 16:39:28 */ #include "tkPort.h" @@ -178,7 +178,7 @@ TkpDestroyMenuEntry(mEntryPtr) * * Results: * Returns standard TCL result. If TCL_ERROR is returned, then - * interp->result contains an error message. + * the interp's result contains an error message. * * Side effects: * Configuration information get set for mePtr; old resources @@ -198,11 +198,11 @@ TkpConfigureMenuEntry(mePtr) * see if the child menu is a help menu. */ - if ((mePtr->type == CASCADE_ENTRY) && (mePtr->name != NULL)) { + if ((mePtr->type == CASCADE_ENTRY) && (mePtr->namePtr != NULL)) { TkMenuReferences *menuRefPtr; - menuRefPtr = TkFindMenuReferences(mePtr->menuPtr->interp, - mePtr->name); + menuRefPtr = TkFindMenuReferencesObj(mePtr->menuPtr->interp, + mePtr->namePtr); if ((menuRefPtr != NULL) && (menuRefPtr->menuPtr != NULL)) { SetHelpMenu(menuRefPtr->menuPtr); } @@ -321,32 +321,51 @@ GetMenuIndicatorGeometry(menuPtr, mePtr, tkfont, fmPtr, widthPtr, heightPtr) int *widthPtr; /* The resulting width */ int *heightPtr; /* The resulting height */ { - if (!mePtr->hideMargin && mePtr->indicatorOn && - ((mePtr->type == CHECK_BUTTON_ENTRY) - || (mePtr->type == RADIO_BUTTON_ENTRY))) { - if ((mePtr->image != NULL) || (mePtr->bitmap != None)) { - *widthPtr = (14 * mePtr->height) / 10; - *heightPtr = mePtr->height; - if (mePtr->type == CHECK_BUTTON_ENTRY) { - mePtr->platformEntryData = - (TkMenuPlatformEntryData) ((65 * mePtr->height) / 100); + if ((mePtr->type == CHECK_BUTTON_ENTRY) + || (mePtr->type == RADIO_BUTTON_ENTRY)) { + int hideMargin; + int indicatorOn; + + Tcl_GetBooleanFromObj(NULL, mePtr->hideMarginPtr, &hideMargin); + Tcl_GetBooleanFromObj(NULL, mePtr->indicatorOnPtr, &indicatorOn); + if (!hideMargin && 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) ((65 * mePtr->height) + / 100); + } else { + mePtr->platformEntryData = + (TkMenuPlatformEntryData) ((75 * mePtr->height) + / 100); + } } else { - mePtr->platformEntryData = - (TkMenuPlatformEntryData) ((75 * mePtr->height) / 100); - } - } else { - *widthPtr = *heightPtr = mePtr->height; - if (mePtr->type == CHECK_BUTTON_ENTRY) { - mePtr->platformEntryData = (TkMenuPlatformEntryData) + *widthPtr = *heightPtr = mePtr->height; + if (mePtr->type == CHECK_BUTTON_ENTRY) { + mePtr->platformEntryData = (TkMenuPlatformEntryData) ((80 * mePtr->height) / 100); - } else { - mePtr->platformEntryData = (TkMenuPlatformEntryData) + } else { + mePtr->platformEntryData = (TkMenuPlatformEntryData) mePtr->height; + } } + } else { + int borderWidth; + + Tk_GetPixelsFromObj(NULL, menuPtr->tkwin, + menuPtr->borderWidthPtr, &borderWidth); + *heightPtr = 0; + *widthPtr = borderWidth; } } else { + int borderWidth; + + Tk_GetPixelsFromObj(NULL, menuPtr->tkwin, menuPtr->borderWidthPtr, + &borderWidth); *heightPtr = 0; - *widthPtr = menuPtr->borderWidth; + *widthPtr = borderWidth; } } @@ -379,8 +398,11 @@ GetMenuAccelGeometry(menuPtr, mePtr, tkfont, fmPtr, widthPtr, heightPtr) *heightPtr = fmPtr->linespace; if (mePtr->type == CASCADE_ENTRY) { *widthPtr = 2 * CASCADE_ARROW_WIDTH; - } else if ((menuPtr->menuType != MENUBAR) && (mePtr->accel != NULL)) { - *widthPtr = Tk_TextWidth(tkfont, mePtr->accel, mePtr->accelLength); + } else if ((menuPtr->menuType != MENUBAR) + && (mePtr->accelPtr != NULL)) { + char *accel = Tcl_GetStringFromObj(mePtr->accelPtr, NULL); + + *widthPtr = Tk_TextWidth(tkfont, accel, mePtr->accelLength); } else { *widthPtr = 0; } @@ -416,8 +438,14 @@ DrawMenuEntryBackground(menuPtr, mePtr, d, activeBorder, bgBorder, x, y, int width; /* Width of entry rect */ int height; /* Height of entry rect */ { - if (mePtr->state == tkActiveUid) { + int state; + + Tcl_GetIndexFromObj(NULL, mePtr->statePtr, tkMenuStateStrings, + NULL, 0, &state); + if (state == ENTRY_ACTIVE) { int relief; + int activeBorderWidth; + bgBorder = activeBorder; if ((menuPtr->menuType == MENUBAR) @@ -427,9 +455,11 @@ DrawMenuEntryBackground(menuPtr, mePtr, d, activeBorder, bgBorder, x, y, } else { relief = TK_RELIEF_RAISED; } - + + Tk_GetPixelsFromObj(NULL, menuPtr->tkwin, + menuPtr->activeBorderWidthPtr, &activeBorderWidth); Tk_Fill3DRectangle(menuPtr->tkwin, d, bgBorder, x, y, width, height, - menuPtr->activeBorderWidth, relief); + activeBorderWidth, relief); } else { Tk_Fill3DRectangle(menuPtr->tkwin, d, bgBorder, x, y, width, height, 0, TK_RELIEF_FLAT); @@ -470,6 +500,7 @@ DrawMenuEntryAccelerator(menuPtr, mePtr, d, gc, tkfont, fmPtr, activeBorder, int drawArrow; /* Whether or not to draw arrow. */ { XPoint points[3]; + int borderWidth, activeBorderWidth; /* * Draw accelerator or cascade arrow. @@ -479,9 +510,13 @@ DrawMenuEntryAccelerator(menuPtr, mePtr, d, gc, tkfont, fmPtr, activeBorder, 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 - menuPtr->borderWidth - - menuPtr->activeBorderWidth - CASCADE_ARROW_WIDTH; + 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; @@ -491,13 +526,15 @@ DrawMenuEntryAccelerator(menuPtr, mePtr, d, gc, tkfont, fmPtr, activeBorder, DECORATION_BORDER_WIDTH, (menuPtr->postedCascade == mePtr) ? TK_RELIEF_SUNKEN : TK_RELIEF_RAISED); - } else if (mePtr->accel != NULL) { - int left = x + mePtr->labelWidth + menuPtr->activeBorderWidth + } else if (mePtr->accelPtr != NULL) { + char *accel = Tcl_GetStringFromObj(mePtr->accelPtr, NULL); + int left = x + mePtr->labelWidth + activeBorderWidth + mePtr->indicatorSpace; + if (menuPtr->menuType == MENUBAR) { left += 5; } - Tk_DrawChars(menuPtr->display, d, gc, tkfont, mePtr->accel, + Tk_DrawChars(menuPtr->display, d, gc, tkfont, accel, mePtr->accelLength, left, (y + (height + fmPtr->ascent - fmPtr->descent) / 2)); } @@ -540,57 +577,75 @@ DrawMenuEntryIndicator(menuPtr, mePtr, d, gc, indicatorGC, tkfont, fmPtr, * Draw check-button indicator. */ - if ((mePtr->type == CHECK_BUTTON_ENTRY) - && mePtr->indicatorOn) { - int dim, top, left; + if (mePtr->type == CHECK_BUTTON_ENTRY) { + int indicatorOn; + + Tcl_GetBooleanFromObj(NULL, mePtr->indicatorOnPtr, &indicatorOn); + + if (indicatorOn) { + int dim, top, left; + int activeBorderWidth; + Tk_3DBorder border; - dim = (int) mePtr->platformEntryData; - left = x + menuPtr->activeBorderWidth - + (mePtr->indicatorSpace - dim)/2; - if (menuPtr->menuType == MENUBAR) { - left += 5; + dim = (int) mePtr->platformEntryData; + Tk_GetPixelsFromObj(NULL, menuPtr->tkwin, + menuPtr->activeBorderWidthPtr, &activeBorderWidth); + left = x + activeBorderWidth + (mePtr->indicatorSpace - dim)/2; + if (menuPtr->menuType == MENUBAR) { + left += 5; + } + top = y + (height - dim)/2; + border = Tk_Get3DBorderFromObj(menuPtr->tkwin, + menuPtr->borderPtr); + Tk_Fill3DRectangle(menuPtr->tkwin, d, border, left, top, dim, + dim, DECORATION_BORDER_WIDTH, TK_RELIEF_SUNKEN); + left += DECORATION_BORDER_WIDTH; + top += DECORATION_BORDER_WIDTH; + dim -= 2*DECORATION_BORDER_WIDTH; + if ((dim > 0) && (mePtr->entryFlags + & ENTRY_SELECTED)) { + XFillRectangle(menuPtr->display, d, indicatorGC, left, top, + (unsigned int) dim, (unsigned int) dim); + } } - top = y + (height - dim)/2; - Tk_Fill3DRectangle(menuPtr->tkwin, d, menuPtr->border, left, top, dim, - dim, DECORATION_BORDER_WIDTH, TK_RELIEF_SUNKEN); - left += DECORATION_BORDER_WIDTH; - top += DECORATION_BORDER_WIDTH; - dim -= 2*DECORATION_BORDER_WIDTH; - if ((dim > 0) && (mePtr->entryFlags - & ENTRY_SELECTED)) { - XFillRectangle(menuPtr->display, d, indicatorGC, left, top, - (unsigned int) dim, (unsigned int) dim); - } } /* * Draw radio-button indicator. */ - if ((mePtr->type == RADIO_BUTTON_ENTRY) - && mePtr->indicatorOn) { - XPoint points[4]; - int radius; - - radius = ((int) mePtr->platformEntryData)/2; - points[0].x = x + (mePtr->indicatorSpace - - (int) mePtr->platformEntryData)/2; - points[0].y = y + (height)/2; - points[1].x = points[0].x + radius; - points[1].y = points[0].y + radius; - points[2].x = points[1].x + radius; - points[2].y = points[0].y; - points[3].x = points[1].x; - points[3].y = points[0].y - radius; - if (mePtr->entryFlags & ENTRY_SELECTED) { - XFillPolygon(menuPtr->display, d, indicatorGC, points, 4, Convex, - CoordModeOrigin); - } else { - Tk_Fill3DPolygon(menuPtr->tkwin, d, menuPtr->border, points, 4, - DECORATION_BORDER_WIDTH, TK_RELIEF_FLAT); - } - Tk_Draw3DPolygon(menuPtr->tkwin, d, menuPtr->border, points, 4, - DECORATION_BORDER_WIDTH, TK_RELIEF_SUNKEN); + if (mePtr->type == RADIO_BUTTON_ENTRY) { + int indicatorOn; + + Tcl_GetBooleanFromObj(NULL, mePtr->indicatorOnPtr, &indicatorOn); + + if (indicatorOn) { + XPoint points[4]; + int radius; + Tk_3DBorder border; + + border = Tk_Get3DBorderFromObj(menuPtr->tkwin, + menuPtr->borderPtr); + radius = ((int) mePtr->platformEntryData)/2; + points[0].x = x + (mePtr->indicatorSpace + - (int) mePtr->platformEntryData)/2; + points[0].y = y + (height)/2; + points[1].x = points[0].x + radius; + points[1].y = points[0].y + radius; + points[2].x = points[1].x + radius; + points[2].y = points[0].y; + points[3].x = points[1].x; + points[3].y = points[0].y - radius; + if (mePtr->entryFlags & ENTRY_SELECTED) { + XFillPolygon(menuPtr->display, d, indicatorGC, points, 4, + Convex, CoordModeOrigin); + } else { + Tk_Fill3DPolygon(menuPtr->tkwin, d, border, points, 4, + DECORATION_BORDER_WIDTH, TK_RELIEF_FLAT); + } + Tk_Draw3DPolygon(menuPtr->tkwin, d, border, points, 4, + DECORATION_BORDER_WIDTH, TK_RELIEF_SUNKEN); + } } } @@ -626,6 +681,7 @@ DrawMenuSeparator(menuPtr, mePtr, d, gc, tkfont, fmPtr, x, y, width, height) { XPoint points[2]; int margin; + Tk_3DBorder border; if (menuPtr->menuType == MENUBAR) { return; @@ -636,7 +692,8 @@ DrawMenuSeparator(menuPtr, mePtr, d, gc, tkfont, fmPtr, x, y, width, height) points[0].y = y + height/2; points[1].x = width - 1; points[1].y = points[0].y; - Tk_Draw3DPolygon(menuPtr->tkwin, d, menuPtr->border, points, 2, 1, + border = Tk_Get3DBorderFromObj(menuPtr->tkwin, menuPtr->borderPtr); + Tk_Draw3DPolygon(menuPtr->tkwin, d, border, points, 2, 1, TK_RELIEF_RAISED); } @@ -658,30 +715,28 @@ DrawMenuSeparator(menuPtr, mePtr, d, gc, tkfont, fmPtr, x, y, width, height) */ static void -DrawMenuEntryLabel( - menuPtr, /* The menu we are drawing */ - mePtr, /* The entry we are drawing */ - d, /* What we are drawing into */ - gc, /* The gc we are drawing into */ - tkfont, /* The precalculated font */ - fmPtr, /* The precalculated font metrics */ - x, /* left edge */ - y, /* right edge */ - width, /* width of entry */ - height) /* height of entry */ - TkMenu *menuPtr; - TkMenuEntry *mePtr; - Drawable d; - GC gc; - Tk_Font tkfont; - CONST Tk_FontMetrics *fmPtr; - int x, y, width, height; +DrawMenuEntryLabel(menuPtr, mePtr, d, gc, tkfont, fmPtr, x, y, width, height) + 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 baseline; int indicatorSpace = mePtr->indicatorSpace; - int leftEdge = x + indicatorSpace + menuPtr->activeBorderWidth; + int activeBorderWidth; + int leftEdge; int imageHeight, imageWidth; + int state; + Tk_GetPixelsFromObj(NULL, menuPtr->tkwin, menuPtr->activeBorderWidthPtr, + &activeBorderWidth); + leftEdge = x + indicatorSpace + activeBorderWidth; if (menuPtr->menuType == MENUBAR) { leftEdge += 5; } @@ -703,27 +758,27 @@ DrawMenuEntryLabel( imageHeight, d, leftEdge, (int) (y + (mePtr->height - imageHeight)/2)); } - } else if (mePtr->bitmap != None) { + } else if (mePtr->bitmapPtr != None) { int width, height; - - Tk_SizeOfBitmap(menuPtr->display, - mePtr->bitmap, &width, &height); - XCopyPlane(menuPtr->display, - mePtr->bitmap, d, - gc, 0, 0, (unsigned) width, (unsigned) height, leftEdge, + Pixmap bitmap = Tk_GetBitmapFromObj(menuPtr->tkwin, mePtr->bitmapPtr); + Tk_SizeOfBitmap(menuPtr->display,bitmap, &width, &height); + XCopyPlane(menuPtr->display, bitmap, d, gc, 0, 0, (unsigned) width, + (unsigned) height, leftEdge, (int) (y + (mePtr->height - height)/2), 1); } else { if (mePtr->labelLength > 0) { - Tk_DrawChars(menuPtr->display, d, gc, - tkfont, mePtr->label, mePtr->labelLength, - leftEdge, baseline); + char *label = Tcl_GetStringFromObj(mePtr->labelPtr, NULL); + Tk_DrawChars(menuPtr->display, d, gc, tkfont, label, + mePtr->labelLength, leftEdge, baseline); DrawMenuUnderline(menuPtr, mePtr, d, gc, tkfont, fmPtr, x, y, width, height); } } - if (mePtr->state == tkDisabledUid) { - if (menuPtr->disabledFg == NULL) { + Tcl_GetIndexFromObj(NULL, mePtr->statePtr, tkMenuStateStrings, NULL, + 0, &state); + if (state == ENTRY_DISABLED) { + if (menuPtr->disabledFgPtr == NULL) { XFillRectangle(menuPtr->display, d, menuPtr->disabledGC, x, y, (unsigned) width, (unsigned) height); } else if ((mePtr->image != NULL) @@ -768,13 +823,20 @@ DrawMenuUnderline(menuPtr, mePtr, d, gc, tkfont, fmPtr, x, y, width, height) int height; { int indicatorSpace = mePtr->indicatorSpace; + if (mePtr->underline >= 0) { - int leftEdge = x + indicatorSpace + menuPtr->activeBorderWidth; + int activeBorderWidth; + int leftEdge; + char *label = Tcl_GetStringFromObj(mePtr->labelPtr, NULL); + + Tk_GetPixelsFromObj(NULL, menuPtr->tkwin, + menuPtr->activeBorderWidthPtr, &activeBorderWidth); + leftEdge = x + indicatorSpace + activeBorderWidth; if (menuPtr->menuType == MENUBAR) { leftEdge += 5; } - Tk_UnderlineChars(menuPtr->display, d, gc, tkfont, mePtr->label, + Tk_UnderlineChars(menuPtr->display, d, gc, tkfont, label, leftEdge, y + (height + fmPtr->ascent - fmPtr->descent) / 2, mePtr->underline, mePtr->underline + 1); } @@ -903,21 +965,32 @@ TkpComputeMenubarGeometry(menuPtr) int helpMenuIndex = -1; TkMenuEntry *mePtr; int lastEntry; + Tk_Font menuFont; + int borderWidth; + int activeBorderWidth; 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; - x = y = menuPtr->borderWidth; + Tk_GetPixelsFromObj(NULL, menuPtr->tkwin, menuPtr->borderWidthPtr, + &borderWidth); + x = y = borderWidth; lastRowBreak = 0; currentRowWidth = 0; @@ -929,21 +1002,22 @@ TkpComputeMenubarGeometry(menuPtr) * 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. */ - - Tk_GetFontMetrics(menuPtr->tkfont, &menuMetrics); + + 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; - tkfont = mePtr->tkfont; - if (tkfont == NULL) { - tkfont = menuPtr->tkfont; - fmPtr = &menuMetrics; - } else { + 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 @@ -956,24 +1030,21 @@ TkpComputeMenubarGeometry(menuPtr) || (mePtr->type == TEAROFF_ENTRY)) { mePtr->height = mePtr->width = 0; } else { - - GetMenuLabelGeometry(mePtr, tkfont, fmPtr, - &width, &height); - mePtr->height = height + 2 * menuPtr->activeBorderWidth + 10; + GetMenuLabelGeometry(mePtr, tkfont, fmPtr, &width, &height); + mePtr->height = height + 2 * activeBorderWidth + 10; mePtr->width = width; - - GetMenuIndicatorGeometry(menuPtr, mePtr, - tkfont, fmPtr, &width, &height); + + GetMenuIndicatorGeometry(menuPtr, mePtr, tkfont, fmPtr, + &width, &height); mePtr->indicatorSpace = width; if (width > 0) { mePtr->width += width; } - mePtr->width += 2 * menuPtr->activeBorderWidth + 10; + mePtr->width += 2 * activeBorderWidth + 10; } if (mePtr->entryFlags & ENTRY_HELP_MENU) { helpMenuIndex = i; - } else if (x + mePtr->width + menuPtr->borderWidth - > maxWindowWidth) { + } else if (x + mePtr->width + borderWidth > maxWindowWidth) { if (i == lastRowBreak) { mePtr->y = y; @@ -982,7 +1053,7 @@ TkpComputeMenubarGeometry(menuPtr) y += mePtr->height; currentRowHeight = 0; } else { - x = menuPtr->borderWidth; + x = borderWidth; for (j = lastRowBreak; j < i; j++) { menuPtr->entries[j]->y = y + currentRowHeight - menuPtr->entries[j]->height; @@ -996,7 +1067,7 @@ TkpComputeMenubarGeometry(menuPtr) if (x > maxWidth) { maxWidth = x; } - x = menuPtr->borderWidth; + x = borderWidth; } else { x += mePtr->width; if (mePtr->height > currentRowHeight) { @@ -1010,11 +1081,10 @@ TkpComputeMenubarGeometry(menuPtr) lastEntry--; } if ((lastEntry >= 0) && (x + menuPtr->entries[lastEntry]->width - + menuPtr->borderWidth > maxWidth)) { - maxWidth = x + menuPtr->entries[lastEntry]->width - + menuPtr->borderWidth; + + borderWidth > maxWidth)) { + maxWidth = x + menuPtr->entries[lastEntry]->width + borderWidth; } - x = menuPtr->borderWidth; + x = borderWidth; for (j = lastRowBreak; j < menuPtr->numEntries; j++) { if (j == helpMenuIndex) { continue; @@ -1028,17 +1098,17 @@ TkpComputeMenubarGeometry(menuPtr) if (helpMenuIndex != -1) { mePtr = menuPtr->entries[helpMenuIndex]; - if (x + mePtr->width + menuPtr->borderWidth > maxWindowWidth) { + if (x + mePtr->width + borderWidth > maxWindowWidth) { y += currentRowHeight; currentRowHeight = mePtr->height; - x = menuPtr->borderWidth; + x = borderWidth; } else if (mePtr->height > currentRowHeight) { currentRowHeight = mePtr->height; } - mePtr->x = maxWindowWidth - menuPtr->borderWidth - mePtr->width; + mePtr->x = maxWindowWidth - borderWidth - mePtr->width; mePtr->y = y + currentRowHeight - mePtr->height; } - height = y + currentRowHeight + menuPtr->borderWidth; + height = y + currentRowHeight + borderWidth; } width = Tk_Width(menuPtr->tkwin); @@ -1089,6 +1159,7 @@ DrawTearoffEntry(menuPtr, mePtr, d, gc, tkfont, fmPtr, x, y, width, height) { XPoint points[2]; int margin, segmentWidth, maxX; + Tk_3DBorder border; if (menuPtr->menuType != MASTER_MENU) { return; @@ -1100,15 +1171,16 @@ DrawTearoffEntry(menuPtr, mePtr, d, gc, tkfont, fmPtr, x, y, width, height) 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, menuPtr->border, points, 2, 1, + Tk_Draw3DPolygon(menuPtr->tkwin, d, border, points, 2, 1, TK_RELIEF_RAISED); - points[0].x += 2*segmentWidth; + points[0].x += 2 * segmentWidth; } } @@ -1230,13 +1302,15 @@ TkpDrawMenuEntry(mePtr, d, tkfont, menuMetricsPtr, x, y, width, height, int padY = (menuPtr->menuType == MENUBAR) ? 3 : 0; int adjustedY = y + padY; int adjustedHeight = height - 2 * padY; + int state; /* * Choose the gc for drawing the foreground part of the entry. */ - if ((mePtr->state == tkActiveUid) - && !strictMotif) { + Tcl_GetIndexFromObj(NULL, mePtr->statePtr, tkMenuStateStrings, NULL, + 0, &state); + if ((state == ENTRY_ACTIVE) && !strictMotif) { gc = mePtr->activeGC; if (gc == NULL) { gc = menuPtr->activeGC; @@ -1248,17 +1322,25 @@ TkpDrawMenuEntry(mePtr, d, tkfont, menuMetricsPtr, x, y, width, height, for (cascadeEntryPtr = menuPtr->menuRefPtr->parentEntryPtr; cascadeEntryPtr != NULL; cascadeEntryPtr = cascadeEntryPtr->nextCascadePtr) { - if (strcmp(cascadeEntryPtr->name, - Tk_PathName(menuPtr->tkwin)) == 0) { - if (cascadeEntryPtr->state == tkDisabledUid) { - parentDisabled = 1; + if (cascadeEntryPtr->namePtr != NULL) { + char *name = Tcl_GetStringFromObj(cascadeEntryPtr->namePtr, + NULL); + + if (strcmp(name, Tk_PathName(menuPtr->tkwin)) == 0) { + int cascadeState; + + Tcl_GetIndexFromObj(NULL, cascadeEntryPtr->statePtr, + tkMenuStateStrings, NULL, 0, &cascadeState); + if (cascadeState == ENTRY_DISABLED) { + parentDisabled = 1; + } + break; } - break; } } - if (((parentDisabled || (mePtr->state == tkDisabledUid))) - && (menuPtr->disabledFg != NULL)) { + if (((parentDisabled || (state == ENTRY_DISABLED))) + && (menuPtr->disabledFgPtr != NULL)) { gc = mePtr->disabledGC; if (gc == NULL) { gc = menuPtr->disabledGC; @@ -1274,24 +1356,22 @@ TkpDrawMenuEntry(mePtr, d, tkfont, menuMetricsPtr, x, y, width, height, if (indicatorGC == NULL) { indicatorGC = menuPtr->indicatorGC; } - - bgBorder = mePtr->border; - if (bgBorder == NULL) { - bgBorder = menuPtr->border; - } + + bgBorder = Tk_Get3DBorderFromObj(menuPtr->tkwin, + (mePtr->borderPtr == NULL) + ? menuPtr->borderPtr : mePtr->borderPtr); if (strictMotif) { activeBorder = bgBorder; } else { - activeBorder = mePtr->activeBorder; - if (activeBorder == NULL) { - activeBorder = menuPtr->activeBorder; - } + activeBorder = Tk_Get3DBorderFromObj(menuPtr->tkwin, + (mePtr->activeBorderPtr == NULL) + ? menuPtr->activeBorderPtr : mePtr->activeBorderPtr); } - if (mePtr->tkfont == NULL) { + if (mePtr->fontPtr == NULL) { fmPtr = menuMetricsPtr; } else { - tkfont = mePtr->tkfont; + tkfont = Tk_GetFontFromObj(menuPtr->tkwin, mePtr->fontPtr); Tk_GetFontMetrics(tkfont, &entryMetrics); fmPtr = &entryMetrics; } @@ -1312,11 +1392,14 @@ TkpDrawMenuEntry(mePtr, d, tkfont, menuMetricsPtr, x, y, width, height, DrawTearoffEntry(menuPtr, mePtr, d, gc, tkfont, fmPtr, x, adjustedY, width, adjustedHeight); } else { + int hideMargin; + 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) { + Tcl_GetBooleanFromObj(NULL, mePtr->hideMarginPtr, &hideMargin); + if (!hideMargin) { DrawMenuEntryIndicator(menuPtr, mePtr, d, gc, indicatorGC, tkfont, fmPtr, x, adjustedY, width, adjustedHeight); } @@ -1354,13 +1437,16 @@ GetMenuLabelGeometry(mePtr, tkfont, fmPtr, widthPtr, heightPtr) if (mePtr->image != NULL) { Tk_SizeOfImage(mePtr->image, widthPtr, heightPtr); - } else if (mePtr->bitmap != (Pixmap) NULL) { - Tk_SizeOfBitmap(menuPtr->display, mePtr->bitmap, widthPtr, heightPtr); + } else if (mePtr->bitmapPtr != NULL) { + Pixmap bitmap = Tk_GetBitmapFromObj(menuPtr->tkwin, mePtr->bitmapPtr); + Tk_SizeOfBitmap(menuPtr->display, bitmap, widthPtr, heightPtr); } else { *heightPtr = fmPtr->linespace; - if (mePtr->label != NULL) { - *widthPtr = Tk_TextWidth(tkfont, mePtr->label, mePtr->labelLength); + if (mePtr->labelPtr != NULL) { + char *label = Tcl_GetStringFromObj(mePtr->labelPtr, NULL); + + *widthPtr = Tk_TextWidth(tkfont, label, mePtr->labelLength); } else { *widthPtr = 0; } @@ -1392,18 +1478,24 @@ TkpComputeStandardMenuGeometry( menuPtr) /* Structure describing menu. */ TkMenu *menuPtr; { - Tk_Font tkfont; + Tk_Font tkfont, menuFont; Tk_FontMetrics menuMetrics, entryMetrics, *fmPtr; int x, y, height, width, indicatorSpace, labelWidth, accelWidth; int windowWidth, windowHeight, accelSpace; int i, j, lastColumnBreak = 0; TkMenuEntry *mePtr; + int borderWidth, activeBorderWidth; + int columnBreak, hideMargin; if (menuPtr->tkwin == NULL) { return; } - x = y = menuPtr->borderWidth; + 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; @@ -1418,21 +1510,23 @@ TkpComputeStandardMenuGeometry( * give all of the geometry/drawing the entry's font and metrics. */ - Tk_GetFontMetrics(menuPtr->tkfont, &menuMetrics); - accelSpace = Tk_TextWidth(menuPtr->tkfont, "M", 1); + 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]; - tkfont = mePtr->tkfont; - if (tkfont == NULL) { - tkfont = menuPtr->tkfont; - fmPtr = &menuMetrics; - } else { - Tk_GetFontMetrics(tkfont, &entryMetrics); - fmPtr = &entryMetrics; - } - - if ((i > 0) && mePtr->columnBreak) { + if (mePtr->fontPtr == NULL) { + tkfont = menuFont; + fmPtr = &menuMetrics; + } else { + tkfont = Tk_GetFontFromObj(menuPtr->tkwin, mePtr->fontPtr); + Tk_GetFontMetrics(tkfont, &entryMetrics); + fmPtr = &entryMetrics; + } + + Tcl_GetBooleanFromObj(NULL, mePtr->columnBreakPtr, &columnBreak); + if ((i > 0) && columnBreak) { if (accelWidth != 0) { labelWidth += accelSpace; } @@ -1440,16 +1534,16 @@ TkpComputeStandardMenuGeometry( menuPtr->entries[j]->indicatorSpace = indicatorSpace; menuPtr->entries[j]->labelWidth = labelWidth; menuPtr->entries[j]->width = indicatorSpace + labelWidth - + accelWidth + 2 * menuPtr->activeBorderWidth; + + accelWidth + 2 * activeBorderWidth; menuPtr->entries[j]->x = x; menuPtr->entries[j]->entryFlags &= ~ENTRY_LAST_COLUMN; } x += indicatorSpace + labelWidth + accelWidth - + 2 * menuPtr->activeBorderWidth; + + 2 * activeBorderWidth; windowWidth = x; indicatorSpace = labelWidth = accelWidth = 0; lastColumnBreak = i; - y = menuPtr->borderWidth; + y = borderWidth; } if (mePtr->type == SEPARATOR_ENTRY) { @@ -1476,7 +1570,8 @@ TkpComputeStandardMenuGeometry( GetMenuLabelGeometry(mePtr, tkfont, fmPtr, &width, &height); mePtr->height = height; - if (!mePtr->hideMargin) { + Tcl_GetBooleanFromObj(NULL, mePtr->hideMarginPtr, &hideMargin); + if (!hideMargin) { width += MENU_MARGIN_WIDTH; } if (width > labelWidth) { @@ -1488,7 +1583,7 @@ TkpComputeStandardMenuGeometry( if (height > mePtr->height) { mePtr->height = height; } - if (!mePtr->hideMargin) { + if (hideMargin) { width += MENU_MARGIN_WIDTH; } if (width > accelWidth) { @@ -1500,15 +1595,14 @@ TkpComputeStandardMenuGeometry( if (height > mePtr->height) { mePtr->height = height; } - if (!mePtr->hideMargin) { + if (hideMargin) { width += MENU_MARGIN_WIDTH; } if (width > indicatorSpace) { indicatorSpace = width; } - mePtr->height += 2 * menuPtr->activeBorderWidth + - MENU_DIVIDER_HEIGHT; + mePtr->height += 2 * activeBorderWidth + MENU_DIVIDER_HEIGHT; } mePtr->y = y; y += mePtr->height; @@ -1524,15 +1618,15 @@ TkpComputeStandardMenuGeometry( menuPtr->entries[j]->indicatorSpace = indicatorSpace; menuPtr->entries[j]->labelWidth = labelWidth; menuPtr->entries[j]->width = indicatorSpace + labelWidth - + accelWidth + 2 * menuPtr->activeBorderWidth; + + accelWidth + 2 * activeBorderWidth; menuPtr->entries[j]->x = x; menuPtr->entries[j]->entryFlags |= ENTRY_LAST_COLUMN; } windowWidth = x + indicatorSpace + labelWidth + accelWidth - + 2 * menuPtr->activeBorderWidth + 2 * menuPtr->borderWidth; + + 2 * activeBorderWidth + 2 * borderWidth; - windowHeight += menuPtr->borderWidth; + windowHeight += borderWidth; /* * The X server doesn't like zero dimensions, so round up to at least diff --git a/unix/tkUnixPort.h b/unix/tkUnixPort.h index 146e60d..0bc3632 100644 --- a/unix/tkUnixPort.h +++ b/unix/tkUnixPort.h @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkUnixPort.h 1.38 97/05/17 16:48:19 + * SCCS: @(#) tkUnixPort.h 1.40 98/02/10 10:33:38 */ #ifndef _UNIXPORT @@ -158,12 +158,6 @@ extern int errno; srcy, width, height); /* - * The following Tk functions are implemented as macros under Windows. - */ - -#define TkGetNativeProlog(interp) TkGetProlog(interp) - -/* * Supply macros for seek offsets, if they're not already provided by * an include file. */ @@ -191,6 +185,7 @@ extern void panic _ANSI_ARGS_(TCL_VARARGS(char *, string)); * These functions do nothing under Unix, so we just eliminate calls to them. */ +#define TkpButtonSetDefaults(specPtr) {} #define TkpDestroyButton(butPtr) {} #define TkSelUpdateClipboard(a,b) {} #define TkSetPixmapColormap(p,c) {} diff --git a/unix/tkUnixSelect.c b/unix/tkUnixSelect.c index 404631e..ff355ea 100644 --- a/unix/tkUnixSelect.c +++ b/unix/tkUnixSelect.c @@ -4,12 +4,12 @@ * This file contains X specific routines for manipulating * selections. * - * Copyright (c) 1995 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkUnixSelect.c 1.5 96/03/29 14:14:31 + * SCCS: @(#) tkUnixSelect.c 1.6 97/11/07 21:24:34 */ #include "tkInt.h" @@ -98,7 +98,7 @@ static void SelTimeoutProc _ANSI_ARGS_((ClientData clientData)); * 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 interp->result. + * then an error message is left in the interp's result. * * Side effects: * None. @@ -422,9 +422,12 @@ TkSelEventProc(tkwin, eventPtr) if ((type == XA_STRING) || (type == dispPtr->textAtom) || (type == dispPtr->compoundTextAtom)) { if (format != 8) { - sprintf(retrPtr->interp->result, - "bad format for string selection: wanted \"8\", got \"%d\"", - format); + char buf[64 + TCL_INTEGER_SPACE]; + + sprintf(buf, + "bad format for string selection: wanted \"8\", got \"%d\"", + format); + Tcl_SetResult(retrPtr->interp, buf, TCL_VOLATILE); retrPtr->result = TCL_ERROR; return; } @@ -456,9 +459,12 @@ TkSelEventProc(tkwin, eventPtr) char *string; if (format != 32) { - sprintf(retrPtr->interp->result, - "bad format for selection: wanted \"32\", got \"%d\"", - format); + char buf[64 + TCL_INTEGER_SPACE]; + + sprintf(buf, + "bad format for selection: wanted \"32\", got \"%d\"", + format); + Tcl_SetResult(retrPtr->interp, buf, TCL_VOLATILE); retrPtr->result = TCL_ERROR; return; } @@ -891,10 +897,12 @@ SelRcvIncrProc(clientData, eventPtr) || (type == retrPtr->winPtr->dispPtr->textAtom) || (type == retrPtr->winPtr->dispPtr->compoundTextAtom)) { if (format != 8) { - Tcl_SetResult(retrPtr->interp, (char *) NULL, TCL_STATIC); - sprintf(retrPtr->interp->result, - "bad format for string selection: wanted \"8\", got \"%d\"", - format); + char buf[64 + TCL_INTEGER_SPACE]; + + sprintf(buf, + "bad format for string selection: wanted \"8\", got \"%d\"", + format); + Tcl_SetResult(retrPtr->interp, buf, TCL_VOLATILE); retrPtr->result = TCL_ERROR; goto done; } @@ -909,10 +917,12 @@ SelRcvIncrProc(clientData, eventPtr) char *string; if (format != 32) { - Tcl_SetResult(retrPtr->interp, (char *) NULL, TCL_STATIC); - sprintf(retrPtr->interp->result, - "bad format for selection: wanted \"32\", got \"%d\"", - format); + char buf[64 + TCL_INTEGER_SPACE]; + + sprintf(buf, + "bad format for selection: wanted \"32\", got \"%d\"", + format); + Tcl_SetResult(retrPtr->interp, buf, TCL_VOLATILE); retrPtr->result = TCL_ERROR; goto done; } diff --git a/unix/tkUnixSend.c b/unix/tkUnixSend.c index f07c59b..932c4b4 100644 --- a/unix/tkUnixSend.c +++ b/unix/tkUnixSend.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkUnixSend.c 1.74 97/11/04 17:12:18 + * SCCS: @(#) tkUnixSend.c 1.76 97/11/07 21:25:10 */ #include "tkPort.h" @@ -752,10 +752,6 @@ Tk_SetAppName(tkwin, name) Tcl_DString dString; int offset, i; -#ifdef __WIN32__ - return name; -#endif /* __WIN32__ */ - dispPtr = winPtr->dispPtr; interp = winPtr->mainPtr->interp; if (dispPtr->commTkwin == NULL) { @@ -898,7 +894,7 @@ Tk_SendCmd(clientData, interp, argc, argv) Window commWindow; PendingCommand pending; register RegisteredInterp *riPtr; - char *destName, buffer[30]; + char *destName; int result, c, async, i, firstArg; size_t length; Tk_RestrictProc *prevRestrictProc; @@ -990,6 +986,7 @@ Tk_SendCmd(clientData, interp, argc, argv) } if (interp != localInterp) { if (result == TCL_ERROR) { + Tcl_Obj *errorObjPtr; /* * An error occurred, so transfer error information from the @@ -1003,17 +1000,11 @@ Tk_SendCmd(clientData, interp, argc, argv) Tcl_ResetResult(interp); Tcl_AddErrorInfo(interp, Tcl_GetVar2(localInterp, "errorInfo", (char *) NULL, TCL_GLOBAL_ONLY)); - Tcl_SetVar2(interp, "errorCode", (char *) NULL, - Tcl_GetVar2(localInterp, "errorCode", (char *) NULL, - TCL_GLOBAL_ONLY), TCL_GLOBAL_ONLY); + errorObjPtr = Tcl_GetObjVar2(localInterp, "errorCode", NULL, + TCL_GLOBAL_ONLY); + Tcl_SetObjErrorCode(interp, errorObjPtr); } - if (localInterp->freeProc != TCL_STATIC) { - interp->result = localInterp->result; - interp->freeProc = localInterp->freeProc; - localInterp->freeProc = TCL_STATIC; - } else { - Tcl_SetResult(interp, localInterp->result, TCL_VOLATILE); - } + Tcl_SetObjResult(interp, Tcl_GetObjResult(localInterp)); Tcl_ResetResult(localInterp); } Tcl_Release((ClientData) riPtr); @@ -1044,6 +1035,8 @@ Tk_SendCmd(clientData, interp, argc, argv) 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 int) Tk_WindowId(dispPtr->commTkwin), tkSendSerial); @@ -1153,8 +1146,9 @@ Tk_SendCmd(clientData, interp, argc, argv) ckfree(pending.errorInfo); } if (pending.errorCode != NULL) { - Tcl_SetVar2(interp, "errorCode", (char *) NULL, pending.errorCode, - TCL_GLOBAL_ONLY); + Tcl_Obj *errorObjPtr; + errorObjPtr = Tcl_NewStringObj(pending.errorCode, -1); + Tcl_SetObjErrorCode(interp, errorObjPtr); ckfree(pending.errorCode); } Tcl_SetResult(interp, pending.result, TCL_DYNAMIC); @@ -1171,10 +1165,10 @@ Tk_SendCmd(clientData, interp, argc, argv) * of a particular window. * * Results: - * A standard Tcl return value. Interp->result will be set + * 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 interp->result will hold an error message. + * is returned and the interp's result will hold an error message. * * Side effects: * None. @@ -1498,7 +1492,8 @@ SendEventProc(clientData, eventPtr) */ if (commWindow != None) { - Tcl_DStringAppend(&reply, remoteInterp->result, -1); + Tcl_DStringAppend(&reply, Tcl_GetStringResult(remoteInterp), + -1); if (result == TCL_ERROR) { char *varValue; @@ -1529,7 +1524,7 @@ SendEventProc(clientData, eventPtr) returnResult: if (commWindow != None) { if (result != TCL_OK) { - char buffer[20]; + char buffer[TCL_INTEGER_SPACE]; sprintf(buffer, "%d", result); Tcl_DStringAppend(&reply, "\0-c ", 4); diff --git a/unix/tkUnixWm.c b/unix/tkUnixWm.c index 0c26c9b..33dcd78 100644 --- a/unix/tkUnixWm.c +++ b/unix/tkUnixWm.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkUnixWm.c 1.155 97/10/28 08:35:19 + * SCCS: @(#) tkUnixWm.c 1.158 98/01/20 14:19:48 */ #include "tkPort.h" @@ -336,6 +336,7 @@ static void ReparentEvent _ANSI_ARGS_((WmInfo *wmPtr, XReparentEvent *eventPtr)); static void TopLevelReqProc _ANSI_ARGS_((ClientData dummy, Tk_Window tkwin)); +static void UpdateCommand _ANSI_ARGS_((TkWindow *winPtr)); static void UpdateGeometryInfo _ANSI_ARGS_(( ClientData clientData)); static void UpdateHints _ANSI_ARGS_((TkWindow *winPtr)); @@ -479,6 +480,8 @@ TkWmMapWindow(winPtr) char *string; if (wmPtr->flags & WM_NEVER_MAPPED) { + Tcl_DString ds; + wmPtr->flags &= ~WM_NEVER_MAPPED; /* @@ -497,16 +500,22 @@ TkWmMapWindow(winPtr) */ string = (wmPtr->title != NULL) ? wmPtr->title : winPtr->nameUid; - if (XStringListToTextProperty(&string, 1, &textProp) != 0) { + Tcl_UtfToExternalDString(NULL, string, -1, &ds); + string = Tcl_DStringValue(&ds); + if (XStringListToTextProperty(&(Tcl_DStringValue(&ds)), 1, + &textProp) != 0) { XSetWMName(winPtr->display, wmPtr->wrapperPtr->window, &textProp); XFree((char *) textProp.value); } - + Tcl_DStringFree(&ds); + TkWmSetClass(winPtr); if (wmPtr->iconName != NULL) { + Tcl_UtfToExternalDString(NULL, wmPtr->iconName, -1, &ds); XSetIconName(winPtr->display, wmPtr->wrapperPtr->window, - wmPtr->iconName); + Tcl_DStringValue(&ds)); + Tcl_DStringFree(&ds); } if (wmPtr->master != None) { @@ -518,16 +527,17 @@ TkWmMapWindow(winPtr) UpdateHints(winPtr); UpdateWmProtocols(wmPtr); if (wmPtr->cmdArgv != NULL) { - XSetCommand(winPtr->display, wmPtr->wrapperPtr->window, - wmPtr->cmdArgv, wmPtr->cmdArgc); + UpdateCommand(winPtr); } if (wmPtr->clientMachine != NULL) { - if (XStringListToTextProperty(&wmPtr->clientMachine, 1, &textProp) - != 0) { + Tcl_UtfToExternalDString(NULL, wmPtr->clientMachine, -1, &ds); + if (XStringListToTextProperty(&(Tcl_DStringValue(&ds)), 1, + &textProp) != 0) { XSetWMClientMachine(winPtr->display, wmPtr->wrapperPtr->window, &textProp); XFree((char *) textProp.value); } + Tcl_DStringFree(&ds); } } if (wmPtr->hints.initial_state == WithdrawnState) { @@ -739,13 +749,18 @@ TkWmSetClass(winPtr) 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 = winPtr->nameUid; - classPtr->res_class = winPtr->classUid; + 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); } } @@ -797,7 +812,7 @@ Tk_WmCmd(clientData, interp, argc, argv) return TCL_ERROR; } if (argc == 2) { - interp->result = (wmTracing) ? "on" : "off"; + Tcl_SetResult(interp, ((wmTracing) ? "on" : "off"), TCL_STATIC); return TCL_OK; } return Tcl_GetBoolean(interp, argv[2], &wmTracing); @@ -827,9 +842,12 @@ Tk_WmCmd(clientData, interp, argc, argv) } if (argc == 3) { if (wmPtr->sizeHintsFlags & PAspect) { - sprintf(interp->result, "%d %d %d %d", wmPtr->minAspect.x, + char buf[TCL_INTEGER_SPACE * 4]; + + sprintf(buf, "%d %d %d %d", wmPtr->minAspect.x, wmPtr->minAspect.y, wmPtr->maxAspect.x, wmPtr->maxAspect.y); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } return TCL_OK; } @@ -844,7 +862,8 @@ Tk_WmCmd(clientData, interp, argc, argv) } if ((numer1 <= 0) || (denom1 <= 0) || (numer2 <= 0) || (denom2 <= 0)) { - interp->result = "aspect number can't be <= 0"; + Tcl_SetResult(interp, "aspect number can't be <= 0", + TCL_STATIC); return TCL_ERROR; } wmPtr->minAspect.x = numer1; @@ -865,7 +884,7 @@ Tk_WmCmd(clientData, interp, argc, argv) } if (argc == 3) { if (wmPtr->clientMachine != NULL) { - interp->result = wmPtr->clientMachine; + Tcl_SetResult(interp, wmPtr->clientMachine, TCL_STATIC); } return TCL_OK; } @@ -889,12 +908,16 @@ Tk_WmCmd(clientData, interp, argc, argv) strcpy(wmPtr->clientMachine, argv[3]); if (!(wmPtr->flags & WM_NEVER_MAPPED)) { XTextProperty textProp; - if (XStringListToTextProperty(&wmPtr->clientMachine, 1, &textProp) - != 0) { + Tcl_DString ds; + + Tcl_UtfToExternalDString(NULL, wmPtr->clientMachine, -1, &ds); + if (XStringListToTextProperty(&(Tcl_DStringValue(&ds)), 1, + &textProp) != 0) { XSetWMClientMachine(winPtr->display, wmPtr->wrapperPtr->window, &textProp); XFree((char *) textProp.value); } + Tcl_DStringFree(&ds); } } else if ((c == 'c') && (strncmp(argv[1], "colormapwindows", length) == 0) && (length >= 3)) { @@ -984,8 +1007,9 @@ Tk_WmCmd(clientData, interp, argc, argv) } if (argc == 3) { if (wmPtr->cmdArgv != NULL) { - interp->result = Tcl_Merge(wmPtr->cmdArgc, wmPtr->cmdArgv); - interp->freeProc = TCL_DYNAMIC; + Tcl_SetResult(interp, + Tcl_Merge(wmPtr->cmdArgc, wmPtr->cmdArgv), + TCL_DYNAMIC); } return TCL_OK; } @@ -1009,8 +1033,7 @@ Tk_WmCmd(clientData, interp, argc, argv) wmPtr->cmdArgc = cmdArgc; wmPtr->cmdArgv = cmdArgv; if (!(wmPtr->flags & WM_NEVER_MAPPED)) { - XSetCommand(winPtr->display, wmPtr->wrapperPtr->window, - cmdArgv, cmdArgc); + UpdateCommand(winPtr); } } else if ((c == 'd') && (strncmp(argv[1], "deiconify", length) == 0)) { if (argc != 3) { @@ -1040,7 +1063,8 @@ Tk_WmCmd(clientData, interp, argc, argv) return TCL_ERROR; } if (argc == 3) { - interp->result = wmPtr->hints.input ? "passive" : "active"; + Tcl_SetResult(interp, (wmPtr->hints.input ? "passive" : "active"), + TCL_STATIC); return TCL_OK; } c = argv[3][0]; @@ -1058,6 +1082,7 @@ Tk_WmCmd(clientData, interp, argc, argv) } else if ((c == 'f') && (strncmp(argv[1], "frame", length) == 0) && (length >= 2)) { Window window; + char buf[TCL_INTEGER_SPACE]; if (argc != 3) { Tcl_AppendResult(interp, "wrong # arguments: must be \"", @@ -1068,7 +1093,8 @@ Tk_WmCmd(clientData, interp, argc, argv) if (window == None) { window = Tk_WindowId((Tk_Window) winPtr); } - sprintf(interp->result, "0x%x", (unsigned int) window); + sprintf(buf, "0x%x", (unsigned int) window); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } else if ((c == 'g') && (strncmp(argv[1], "geometry", length) == 0) && (length >= 2)) { char xSign, ySign; @@ -1081,6 +1107,8 @@ Tk_WmCmd(clientData, interp, argc, argv) return TCL_ERROR; } if (argc == 3) { + char buf[16 + TCL_INTEGER_SPACE * 4]; + xSign = (wmPtr->flags & WM_NEGATIVE_X) ? '-' : '+'; ySign = (wmPtr->flags & WM_NEGATIVE_Y) ? '-' : '+'; if (wmPtr->gridWin != NULL) { @@ -1092,8 +1120,9 @@ Tk_WmCmd(clientData, interp, argc, argv) width = winPtr->changes.width; height = winPtr->changes.height; } - sprintf(interp->result, "%dx%d%c%d%c%d", width, height, - xSign, wmPtr->x, ySign, wmPtr->y); + sprintf(buf, "%dx%d%c%d%c%d", width, height, xSign, wmPtr->x, + ySign, wmPtr->y); + Tcl_SetResult(interp, buf, TCL_VOLATILE); return TCL_OK; } if (*argv[3] == '\0') { @@ -1114,9 +1143,12 @@ Tk_WmCmd(clientData, interp, argc, argv) } if (argc == 3) { if (wmPtr->sizeHintsFlags & PBaseSize) { - sprintf(interp->result, "%d %d %d %d", wmPtr->reqGridWidth, + char buf[TCL_INTEGER_SPACE * 4]; + + sprintf(buf, "%d %d %d %d", wmPtr->reqGridWidth, wmPtr->reqGridHeight, wmPtr->widthInc, wmPtr->heightInc); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } return TCL_OK; } @@ -1143,19 +1175,19 @@ Tk_WmCmd(clientData, interp, argc, argv) return TCL_ERROR; } if (reqWidth < 0) { - interp->result = "baseWidth can't be < 0"; + Tcl_SetResult(interp, "baseWidth can't be < 0", TCL_STATIC); return TCL_ERROR; } if (reqHeight < 0) { - interp->result = "baseHeight can't be < 0"; + Tcl_SetResult(interp, "baseHeight can't be < 0", TCL_STATIC); return TCL_ERROR; } if (widthInc < 0) { - interp->result = "widthInc can't be < 0"; + Tcl_SetResult(interp, "widthInc can't be < 0", TCL_STATIC); return TCL_ERROR; } if (heightInc < 0) { - interp->result = "heightInc can't be < 0"; + Tcl_SetResult(interp, "heightInc can't be < 0", TCL_STATIC); return TCL_ERROR; } Tk_SetGrid((Tk_Window) winPtr, reqWidth, reqHeight, widthInc, @@ -1176,7 +1208,7 @@ Tk_WmCmd(clientData, interp, argc, argv) } if (argc == 3) { if (wmPtr->hints.flags & WindowGroupHint) { - interp->result = wmPtr->leaderName; + Tcl_SetResult(interp, wmPtr->leaderName, TCL_STATIC); } return TCL_OK; } @@ -1221,8 +1253,9 @@ Tk_WmCmd(clientData, interp, argc, argv) } if (argc == 3) { if (wmPtr->hints.flags & IconPixmapHint) { - interp->result = Tk_NameOfBitmap(winPtr->display, - wmPtr->hints.icon_pixmap); + Tcl_SetResult(interp, + Tk_NameOfBitmap(winPtr->display, wmPtr->hints.icon_pixmap), + TCL_STATIC); } return TCL_OK; } @@ -1276,8 +1309,9 @@ Tk_WmCmd(clientData, interp, argc, argv) } else { if (XIconifyWindow(winPtr->display, wmPtr->wrapperPtr->window, winPtr->screenNum) == 0) { - interp->result = - "couldn't send iconify message to window manager"; + Tcl_SetResult(interp, + "couldn't send iconify message to window manager", + TCL_STATIC); return TCL_ERROR; } WaitForMapNotify(winPtr, 0); @@ -1294,8 +1328,9 @@ Tk_WmCmd(clientData, interp, argc, argv) } if (argc == 3) { if (wmPtr->hints.flags & IconMaskHint) { - interp->result = Tk_NameOfBitmap(winPtr->display, - wmPtr->hints.icon_mask); + Tcl_SetResult(interp, + Tk_NameOfBitmap(winPtr->display, wmPtr->hints.icon_mask), + TCL_STATIC); } return TCL_OK; } @@ -1321,14 +1356,20 @@ Tk_WmCmd(clientData, interp, argc, argv) return TCL_ERROR; } if (argc == 3) { - interp->result = (wmPtr->iconName != NULL) ? wmPtr->iconName : ""; + Tcl_SetResult(interp, + ((wmPtr->iconName != NULL) ? wmPtr->iconName : ""), + TCL_STATIC); return TCL_OK; } else { wmPtr->iconName = ckalloc((unsigned) (strlen(argv[3]) + 1)); strcpy(wmPtr->iconName, argv[3]); if (!(wmPtr->flags & WM_NEVER_MAPPED)) { + Tcl_DString ds; + + Tcl_UtfToExternalDString(NULL, wmPtr->iconName, -1, &ds); XSetIconName(winPtr->display, wmPtr->wrapperPtr->window, - wmPtr->iconName); + Tcl_DStringValue(&ds)); + Tcl_DStringFree(&ds); } } } else if ((c == 'i') && (strncmp(argv[1], "iconposition", length) == 0) @@ -1343,8 +1384,11 @@ Tk_WmCmd(clientData, interp, argc, argv) } if (argc == 3) { if (wmPtr->hints.flags & IconPositionHint) { - sprintf(interp->result, "%d %d", wmPtr->hints.icon_x, + char buf[TCL_INTEGER_SPACE * 2]; + + sprintf(buf, "%d %d", wmPtr->hints.icon_x, wmPtr->hints.icon_y); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } return TCL_OK; } @@ -1374,7 +1418,7 @@ Tk_WmCmd(clientData, interp, argc, argv) } if (argc == 3) { if (wmPtr->icon != NULL) { - interp->result = Tk_PathName(wmPtr->icon); + Tcl_SetResult(interp, Tk_PathName(wmPtr->icon), TCL_STATIC); } return TCL_OK; } @@ -1443,8 +1487,9 @@ Tk_WmCmd(clientData, interp, argc, argv) if (XWithdrawWindow(Tk_Display(tkwin2), Tk_WindowId(wmPtr2->wrapperPtr), Tk_ScreenNumber(tkwin2)) == 0) { - interp->result = - "couldn't send withdraw message to window manager"; + Tcl_SetResult(interp, + "couldn't send withdraw message to window manager", + TCL_STATIC); return TCL_ERROR; } WaitForMapNotify((TkWindow *) tkwin2, 0); @@ -1460,8 +1505,11 @@ Tk_WmCmd(clientData, interp, argc, argv) return TCL_ERROR; } if (argc == 3) { + char buf[TCL_INTEGER_SPACE * 2]; + GetMaxSize(wmPtr, &width, &height); - sprintf(interp->result, "%d %d", width, height); + sprintf(buf, "%d %d", width, height); + Tcl_SetResult(interp, buf, TCL_VOLATILE); return TCL_OK; } if ((Tcl_GetInt(interp, argv[3], &width) != TCL_OK) @@ -1481,8 +1529,10 @@ Tk_WmCmd(clientData, interp, argc, argv) return TCL_ERROR; } if (argc == 3) { - sprintf(interp->result, "%d %d", wmPtr->minWidth, - wmPtr->minHeight); + char buf[TCL_INTEGER_SPACE * 2]; + + sprintf(buf, "%d %d", wmPtr->minWidth, wmPtr->minHeight); + Tcl_SetResult(interp, buf, TCL_VOLATILE); return TCL_OK; } if ((Tcl_GetInt(interp, argv[3], &width) != TCL_OK) @@ -1506,9 +1556,9 @@ Tk_WmCmd(clientData, interp, argc, argv) } if (argc == 3) { if (Tk_Attributes((Tk_Window) winPtr)->override_redirect) { - interp->result = "1"; + Tcl_SetResult(interp, "1", TCL_STATIC); } else { - interp->result = "0"; + Tcl_SetResult(interp, "0", TCL_STATIC); } return TCL_OK; } @@ -1533,9 +1583,9 @@ Tk_WmCmd(clientData, interp, argc, argv) } if (argc == 3) { if (wmPtr->sizeHintsFlags & USPosition) { - interp->result = "user"; + Tcl_SetResult(interp, "user", TCL_STATIC); } else if (wmPtr->sizeHintsFlags & PPosition) { - interp->result = "program"; + Tcl_SetResult(interp, "program", TCL_STATIC); } return TCL_OK; } @@ -1589,7 +1639,7 @@ Tk_WmCmd(clientData, interp, argc, argv) for (protPtr = wmPtr->protPtr; protPtr != NULL; protPtr = protPtr->nextPtr) { if (protPtr->protocol == protocol) { - interp->result = protPtr->command; + Tcl_SetResult(interp, protPtr->command, TCL_STATIC); return TCL_OK; } } @@ -1636,9 +1686,12 @@ Tk_WmCmd(clientData, interp, argc, argv) return TCL_ERROR; } if (argc == 3) { - sprintf(interp->result, "%d %d", + char buf[TCL_INTEGER_SPACE * 2]; + + sprintf(buf, "%d %d", (wmPtr->flags & WM_WIDTH_NOT_RESIZABLE) ? 0 : 1, (wmPtr->flags & WM_HEIGHT_NOT_RESIZABLE) ? 0 : 1); + Tcl_SetResult(interp, buf, TCL_VOLATILE); return TCL_OK; } if ((Tcl_GetBoolean(interp, argv[3], &width) != TCL_OK) @@ -1667,9 +1720,9 @@ Tk_WmCmd(clientData, interp, argc, argv) } if (argc == 3) { if (wmPtr->sizeHintsFlags & USSize) { - interp->result = "user"; + Tcl_SetResult(interp, "user", TCL_STATIC); } else if (wmPtr->sizeHintsFlags & PSize) { - interp->result = "program"; + Tcl_SetResult(interp, "program", TCL_STATIC); } return TCL_OK; } @@ -1701,15 +1754,15 @@ Tk_WmCmd(clientData, interp, argc, argv) return TCL_ERROR; } if (wmPtr->iconFor != NULL) { - interp->result = "icon"; + Tcl_SetResult(interp, "icon", TCL_STATIC); } else if (wmPtr->withdrawn) { - interp->result = "withdrawn"; + Tcl_SetResult(interp, "withdrawn", TCL_STATIC); } else if (Tk_IsMapped((Tk_Window) winPtr) || ((wmPtr->flags & WM_NEVER_MAPPED) && (wmPtr->hints.initial_state == NormalState))) { - interp->result = "normal"; + Tcl_SetResult(interp, "normal", TCL_STATIC); } else { - interp->result = "iconic"; + Tcl_SetResult(interp, "iconic", TCL_STATIC); } } else if ((c == 't') && (strncmp(argv[1], "title", length) == 0) && (length >= 2)) { @@ -1719,21 +1772,25 @@ Tk_WmCmd(clientData, interp, argc, argv) return TCL_ERROR; } if (argc == 3) { - interp->result = (wmPtr->title != NULL) ? wmPtr->title - : winPtr->nameUid; + Tcl_SetResult(interp, + ((wmPtr->title != NULL) ? wmPtr->title : winPtr->nameUid), + TCL_STATIC); return TCL_OK; } else { wmPtr->title = ckalloc((unsigned) (strlen(argv[3]) + 1)); strcpy(wmPtr->title, argv[3]); if (!(wmPtr->flags & WM_NEVER_MAPPED)) { XTextProperty textProp; + Tcl_DString ds; - if (XStringListToTextProperty(&wmPtr->title, 1, + Tcl_UtfToExternalDString(NULL, wmPtr->title, -1, &ds); + if (XStringListToTextProperty(&(Tcl_DStringValue(&ds)), 1, &textProp) != 0) { XSetWMName(winPtr->display, wmPtr->wrapperPtr->window, &textProp); XFree((char *) textProp.value); } + Tcl_DStringFree(&ds); } } } else if ((c == 't') && (strncmp(argv[1], "transient", length) == 0) @@ -1748,7 +1805,7 @@ Tk_WmCmd(clientData, interp, argc, argv) } if (argc == 3) { if (wmPtr->master != None) { - interp->result = wmPtr->masterWindowName; + Tcl_SetResult(interp, wmPtr->masterWindowName, TCL_STATIC); } return TCL_OK; } @@ -1803,8 +1860,9 @@ Tk_WmCmd(clientData, interp, argc, argv) } if (XWithdrawWindow(winPtr->display, wmPtr->wrapperPtr->window, winPtr->screenNum) == 0) { - interp->result = - "couldn't send withdraw message to window manager"; + Tcl_SetResult(interp, + "couldn't send withdraw message to window manager", + TCL_STATIC); return TCL_ERROR; } WaitForMapNotify(winPtr, 0); @@ -3181,7 +3239,7 @@ UpdateHints(winPtr) * * Results: * A standard Tcl return value, plus an error message in - * interp->result if an error occurs. + * the interp's result if an error occurs. * * Side effects: * The size and/or location of winPtr may change. @@ -4811,3 +4869,63 @@ TkpGetWrapperWindow(winPtr) 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(winPtr) + 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 = (char **) ckalloc(sizeof(char *) * wmPtr->cmdArgc); + offsets = (int *) 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((char *) cmdArgv); + ckfree((char *) offsets); +} diff --git a/unix/tkUnixXId.c b/unix/tkUnixXId.c index f67c35c..2bcab2b 100644 --- a/unix/tkUnixXId.c +++ b/unix/tkUnixXId.c @@ -12,12 +12,12 @@ * George C. Kaplan and Michael Hoegeman. * * Copyright (c) 1993 The Regents of the University of California. - * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkUnixXId.c 1.22 97/06/25 13:16:47 + * SCCS: @(#) tkUnixXId.c 1.24 98/01/12 15:30:26 */ /* @@ -28,9 +28,8 @@ #define XLIB_ILLEGAL_ACCESS 1 -#include "tkInt.h" -#include "tkPort.h" #include "tkUnixInt.h" +#include "tkPort.h" /* * A structure of the following type is used to hold one or more @@ -1,10 +1,10 @@ -Tk 8.0p2 for Windows +Tk 8.1a2 for Windows by Scott Stanton Sun Microsystems Laboratories scott.stanton@eng.sun.com -SCCS: @(#) README 1.20 97/11/21 15:17:54 +SCCS: @(#) README 1.22 98/02/18 18:03:07 1. Introduction --------------- @@ -17,7 +17,7 @@ contains information specific to the Windows version of Tk. 2. Distribution notes --------------------- -Tk 8.0 for Windows is distributed in binary form in addition to the +Tk 8.1 for Windows is distributed in binary form in addition to the common source release. The binary distribution is a self-extracting archive with a built-in installation script. @@ -34,8 +34,8 @@ source distribution in order to build and use extensions. In order to compile Tk for Windows, you need the following items: - Tcl 8.0 Source Distribution (plus any patches) - Tk 8.0 Source Distribution (plus any patches) + Tcl 8.1 Source Distribution (plus any patches) + Tk 8.1 Source Distribution (plus any patches) The latest Win32 SDK header files @@ -58,24 +58,24 @@ find them. Tk looks in one of two places for the library files: 1) The environment variable "TK_LIBRARY". - 2) In the lib\tk8.0 directory under the Tcl installation directory + 2) In the lib\tk8.1 directory under the Tcl installation directory as specified in the registry: For Windows NT & 95: - HKEY_LOCAL_MACHINE\SOFTWARE\Sun\Tcl\8.0 + HKEY_LOCAL_MACHINE\SOFTWARE\Sun\Tcl\8.1 Value Name is "Root" For Win32s: - HKEY_CLASSES_ROOT\SOFTWARE\Sun\Tcl\8.0\ + HKEY_CLASSES_ROOT\SOFTWARE\Sun\Tcl\8.1\ 2) Relative to the directory containing the current .exe. - Tk will look for a directory "..\lib\tk8.0" relative to the + Tk will look for a directory "..\lib\tk8.1" relative to the directory containing the currently running .exe. -Note that in order to run wish80.exe, you must ensure that tcl80.dll, -tclpip80.dll (plus tcl1680.dll under Win32s), and tk80.dll are on your +Note that in order to run wish81.exe, you must ensure that tcl81.dll, +tclpip81.dll (plus tcl1681.dll under Win32s), and tk81.dll are on your path, in the system directory, or in the directory containing -wish80.exe. +wish81.exe. 4. Test suite ------------- @@ -103,12 +103,10 @@ Windows beta version of Tk: - Color management on some displays doesn't work properly resulting in Tk switching to monochrome mode. - Tk seems to fail to draw anything on some Matrox Millenium cards. -- Send and winfo interps are not currently supported - Printing does not work for images (e.g. GIF) on a canvas. - Tk_dialog appears in the upper left corner. This is a symptom of a larger problem with "wm geometry" when applied to unmapped or iconified windows. -- Some keys don't work on international keyboards. - Grabs do not affect native menus or the title bar. - PPM images are using the wrong translation mode for writing to files, resulting in CR/LF terminated PPM files. @@ -116,9 +114,6 @@ Windows beta version of Tk: also doesn't consistently track changes in the system colors. If you have comments or bug reports for the Windows version of Tk, -please direct them to: - -Scott Stanton -scott.stanton@eng.sun.com - -or post them to the newsgroup comp.lang.tcl. +please direct them to the comp.lang.tcl newsgroup or the wintcl +mailing list (see http://sunscript.sun.com/win/wintcl-list.html for +more information). diff --git a/win/makefile.bc b/win/makefile.bc index a77c0ed..f2bd900 100644 --- a/win/makefile.bc +++ b/win/makefile.bc @@ -1,11 +1,11 @@ # Borland C++ 4.5 makefile for Tk # -# Copyright (c) 1995-1996 by Sun Microsystems, Inc. +# Copyright (c) 1995-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. # -# SCCS: @(#) makefile.bc 1.73 97/11/05 16:12:27 +# SCCS: @(#) makefile.bc 1.75 98/02/18 18:32:57 # @@ -19,7 +19,7 @@ ROOT = .. TMPDIR = . TOOLS = c:\bc45 -TCLDIR = ..\..\tcl8.0 +TCLDIR = ..\..\tcl8.1a2 # uncomment the following line to compile with symbols #DEBUG=1 @@ -105,6 +105,7 @@ TKOBJS = \ $(TMPDIR)\tkWinButton.obj \ $(TMPDIR)\tkWinClipboard.obj \ $(TMPDIR)\tkWinColor.obj \ + $(TMPDIR)\tkWinConfig.obj \ $(TMPDIR)\tkWinCursor.obj \ $(TMPDIR)\tkWinDialog.obj \ $(TMPDIR)\tkWinDraw.obj \ @@ -119,6 +120,7 @@ TKOBJS = \ $(TMPDIR)\tkWinRegion.obj \ $(TMPDIR)\tkWinScrlbr.obj \ $(TMPDIR)\tkWinSend.obj \ + $(TMPDIR)\tkWinTest.obj \ $(TMPDIR)\tkWinWindow.obj \ $(TMPDIR)\tkWinWm.obj \ $(TMPDIR)\tkWinX.obj \ @@ -169,6 +171,8 @@ TKOBJS = \ $(TMPDIR)\tkMenubutton.obj \ $(TMPDIR)\tkMenuDraw.obj \ $(TMPDIR)\tkMessage.obj \ + $(TMPDIR)\tkObj.obj \ + $(TMPDIR)\tkOldConfig.obj \ $(TMPDIR)\tkOption.obj \ $(TMPDIR)\tkPack.obj \ $(TMPDIR)\tkPlace.obj \ @@ -190,11 +194,11 @@ TKOBJS = \ $(TMPDIR)\tkVisual.obj \ $(TMPDIR)\tkWindow.obj -TCLDLL = tcl80.dll -TCLLIB = tcl80.lib -TKDLL = tk80.dll -TKLIB = tk80.lib -WISH = wish80.exe +TCLDLL = tcl81.dll +TCLLIB = tcl81.lib +TKDLL = tk81.dll +TKLIB = tk81.lib +WISH = wish81.exe TKTEST = tktest.exe # diff --git a/win/makefile.vc b/win/makefile.vc index 7312db0..d1b2a34 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -3,8 +3,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# Copyright (c) 1995-1996 Sun Microsystems, Inc. -# SCCS: @(#) makefile.vc 1.64 97/10/27 17:27:20 +# Copyright (c) 1995-1997 Sun Microsystems, Inc. +# SCCS: @(#) makefile.vc 1.67 98/02/18 18:32:52 # Does not depend on the presence of any environment variables in # order to compile tcl; all needed information is derived from @@ -28,7 +28,7 @@ ROOT = .. TMPDIR = . TOOLS32 = c:\msdev -TCLDIR = ..\..\tcl8.0 +TCLDIR = ..\..\tcl8.1a2 # Set this to the appropriate value of /MACHINE: for your platform MACHINE = IX86 @@ -43,7 +43,7 @@ NODEBUG=1 # Do not modify below this line ###################################################################### -VERSION = 80 +VERSION = 81 TCLDLL = tcl$(VERSION).dll TCLLIB = tcl$(VERSION).lib @@ -85,6 +85,7 @@ TKOBJS = \ $(TMPDIR)\tkWinButton.obj \ $(TMPDIR)\tkWinClipboard.obj \ $(TMPDIR)\tkWinColor.obj \ + $(TMPDIR)\tkWinConfig.obj \ $(TMPDIR)\tkWinCursor.obj \ $(TMPDIR)\tkWinDialog.obj \ $(TMPDIR)\tkWinDraw.obj \ @@ -99,6 +100,7 @@ TKOBJS = \ $(TMPDIR)\tkWinRegion.obj \ $(TMPDIR)\tkWinScrlbr.obj \ $(TMPDIR)\tkWinSend.obj \ + $(TMPDIR)\tkWinTest.obj \ $(TMPDIR)\tkWinWindow.obj \ $(TMPDIR)\tkWinWm.obj \ $(TMPDIR)\tkWinX.obj \ @@ -149,6 +151,8 @@ TKOBJS = \ $(TMPDIR)\tkMenubutton.obj \ $(TMPDIR)\tkMenuDraw.obj \ $(TMPDIR)\tkMessage.obj \ + $(TMPDIR)\tkObj.obj \ + $(TMPDIR)\tkOldConfig.obj \ $(TMPDIR)\tkOption.obj \ $(TMPDIR)\tkPack.obj \ $(TMPDIR)\tkPlace.obj \ diff --git a/win/rc/tk.rc b/win/rc/tk.rc index 0d74ec3..b357dd9 100644 --- a/win/rc/tk.rc +++ b/win/rc/tk.rc @@ -1,8 +1,10 @@ -// SCCS: @(#) tk.rc 1.22 97/03/21 18:35:14 +// SCCS: @(#) tk.rc 1.23 97/07/24 13:55:02 // // Version // +#include <windows.h> + #define RESOURCE_INCLUDED #include <tk.h> @@ -37,6 +39,36 @@ BEGIN END END +#include <dlgs.h> +FILEOPENORD DIALOG DISCARDABLE 36, 24, 218, 138 +STYLE DS_MODALFRAME | DS_3DLOOK | WS_POPUP | WS_CAPTION | WS_SYSMENU +CAPTION "Choose Directory" +FONT 8, "Helv" +BEGIN + LTEXT "Directory &name:",-1,8,6,118,9 + EDITTEXT edt10,8,26,144,12, WS_TABSTOP | ES_AUTOHSCROLL + LISTBOX lst2,8,40,144,64,LBS_SORT | LBS_OWNERDRAWFIXED | + LBS_HASSTRINGS | LBS_NOINTEGRALHEIGHT | + LBS_DISABLENOSCROLL | WS_VSCROLL | WS_TABSTOP + LTEXT "Dri&ves:",stc4,8,106,92,9 + COMBOBOX cmb2,8,115,144,68,CBS_DROPDOWNLIST | CBS_OWNERDRAWFIXED | + CBS_AUTOHSCROLL | CBS_SORT | CBS_HASSTRINGS | WS_BORDER | + WS_VSCROLL | WS_TABSTOP + DEFPUSHBUTTON "OK",1,160,6,50,14,WS_GROUP + PUSHBUTTON "Cancel",2,160,24,50,14,WS_GROUP + PUSHBUTTON "&Help",psh15,160,42,50,14,WS_GROUP + CHECKBOX "&Read only",chx1,160,66,50,12,WS_GROUP + PUSHBUTTON "Net&work...",psh14,160,115,50,14,WS_GROUP + + LTEXT "a",stc3,9,143,114,15 + EDITTEXT edt1,7,158,135,20,NOT WS_TABSTOP + LISTBOX lst1,8,205,134,42,LBS_NOINTEGRALHEIGHT + COMBOBOX cmb1,8,253,135,21,CBS_DROPDOWNLIST | CBS_OWNERDRAWFIXED | + CBS_AUTOHSCROLL | CBS_SORT | CBS_HASSTRINGS | WS_BORDER | + WS_VSCROLL + +END + // // Icons // diff --git a/win/tkWin.h b/win/tkWin.h index c9d9360..2b10c46 100644 --- a/win/tkWin.h +++ b/win/tkWin.h @@ -4,12 +4,12 @@ * Declarations of public types and interfaces that are only * available under Windows. * - * Copyright (c) 1996 by Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkWin.h 1.6 96/08/15 13:19:41 + * SCCS: @(#) tkWin.h 1.10 97/08/29 15:21:40 */ #ifndef _TKWIN @@ -44,6 +44,9 @@ EXTERN Window Tk_AttachHWND _ANSI_ARGS_((Tk_Window tkwin, HWND hwnd)); +EXTERN int Tk_DdeObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); EXTERN HINSTANCE Tk_GetHINSTANCE _ANSI_ARGS_((void)); EXTERN HWND Tk_GetHWND _ANSI_ARGS_((Window window)); EXTERN Tk_Window Tk_HWNDToWindow _ANSI_ARGS_((HWND hwnd)); diff --git a/win/tkWin32Dll.c b/win/tkWin32Dll.c index 969e687..6f69a29 100644 --- a/win/tkWin32Dll.c +++ b/win/tkWin32Dll.c @@ -8,12 +8,13 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkWin32Dll.c 1.9 96/08/06 15:59:08 + * SCCS: @(#) tkWin32Dll.c 1.14 97/08/06 18:22:18 */ -#include "tkPort.h" #include "tkWinInt.h" +static int tkPlatformId; + /* * The following declaration is for the VC++ DLL entry point. */ @@ -70,6 +71,8 @@ DllMain(hInstance, reason, reserved) DWORD reason; LPVOID reserved; { + OSVERSIONINFO os; + /* * If we are attaching to the DLL from a new process, tell Tk about * the hInstance to use. If we are detaching then clean up any @@ -77,9 +80,40 @@ DllMain(hInstance, reason, reserved) */ if (reason == DLL_PROCESS_ATTACH) { + os.dwOSVersionInfoSize = sizeof(os); + GetVersionEx(&os); + tkPlatformId = os.dwPlatformId; + TkWinXInit(hInstance); } else if (reason == DLL_PROCESS_DETACH) { TkWinXCleanup(hInstance); } return(TRUE); } + +/* + *---------------------------------------------------------------------- + * + * TkWinGetPlatformId -- + * + * Determines whether running under NT, 95, or Win32s, to allow + * runtime conditional code. + * + * Results: + * The return value is one of: + * VER_PLATFORM_WIN32s Win32s on Windows 3.1. + * VER_PLATFORM_WIN32_WINDOWS Win32 on Windows 95. + * VER_PLATFORM_WIN32_NT Win32 on Windows NT + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TkWinGetPlatformId() +{ + return tkPlatformId; +} + diff --git a/win/tkWin3d.c b/win/tkWin3d.c index 3ee9907..16e7c0e 100644 --- a/win/tkWin3d.c +++ b/win/tkWin3d.c @@ -9,11 +9,11 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkWin3d.c 1.6 97/08/12 14:28:54 + * SCCS: @(#) tkWin3d.c 1.7 97/08/22 12:13:12 */ -#include <tk3d.h> -#include <tkWinInt.h> +#include "tkWinInt.h" +#include "tk3d.h" /* * This structure is used to keep track of the extra colors used by diff --git a/win/tkWinButton.c b/win/tkWinButton.c index 47a74e6..1aaa029 100644 --- a/win/tkWinButton.c +++ b/win/tkWinButton.c @@ -4,12 +4,12 @@ * This file implements the Windows specific portion of the button * widgets. * - * Copyright (c) 1996 by Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkWinButton.c 1.12 97/09/02 13:18:27 + * SCCS: @(#) tkWinButton.c 1.14 98/01/09 09:46:46 */ #define OEMRESOURCE @@ -65,12 +65,6 @@ enum { }; /* - * Set to non-zero if this module is initialized. - */ - -static int initialized = 0; - -/* * Variables for the cached information about the boxes bitmap. */ @@ -80,11 +74,12 @@ static LPSTR boxesBits = NULL; /* Pointer to bitmap data. */ static DWORD boxHeight = 0, boxWidth = 0; /* Size of each sub-image. */ /* - * This variable holds the default border width for a button in string - * form for use in a Tk_ConfigSpec. + * The following variable holds the default border width for a button + * in string form for use in Tk_OptionSpecs for the various button + * widget classes. */ -static char defWidth[8]; +static char defWidth[TCL_INTEGER_SPACE]; /* * Declarations for functions defined in this file. @@ -99,7 +94,6 @@ static DWORD ComputeStyle _ANSI_ARGS_((WinButton* butPtr)); static Window CreateProc _ANSI_ARGS_((Tk_Window tkwin, Window parent, ClientData instanceData)); static void InitBoxes _ANSI_ARGS_((void)); -static void UpdateButtonDefaults _ANSI_ARGS_((void)); /* * The class procedure table for the button widgets. @@ -177,33 +171,38 @@ InitBoxes() /* *---------------------------------------------------------------------- * - * UpdateButtonDefaults -- + * TkpButtonSetDefaults -- * - * This function retrieves the current system defaults for - * the button widgets. + * This procedure is invoked before option tables are created for + * buttons. It modifies some of the default values to match the + * current values defined for this platform. * * Results: - * None. + * Some of the default values in *specPtr are modified. * * Side effects: - * Updates the configuration defaults for buttons. + * Updates some of. * *---------------------------------------------------------------------- */ void -UpdateButtonDefaults() +TkpButtonSetDefaults(specPtr) + Tk_OptionSpec *specPtr; /* Points to an array of option specs, + * terminated by one with type + * TK_OPTION_END. */ { - Tk_ConfigSpec *specPtr; - int width = GetSystemMetrics(SM_CXEDGE); + int width; - if (width == 0) { - width = 1; + if (defWidth[0] == 0) { + width = GetSystemMetrics(SM_CXEDGE); + if (width == 0) { + width = 1; + } + sprintf(defWidth, "%d", width); } - sprintf(defWidth, "%d", width); - for (specPtr = tkpButtonConfigSpecs; specPtr->type != TK_CONFIG_END; - specPtr++) { - if (specPtr->offset == Tk_Offset(TkButton, borderWidth)) { + for ( ; specPtr->type != TK_OPTION_END; specPtr++) { + if (specPtr->internalOffset == Tk_Offset(TkButton, borderWidth)) { specPtr->defValue = defWidth; } } @@ -231,11 +230,6 @@ TkpCreateButton(tkwin) { WinButton *butPtr; - if (!initialized) { - UpdateButtonDefaults(); - initialized = 1; - } - butPtr = (WinButton *)ckalloc(sizeof(WinButton)); butPtr->hwnd = NULL; return (TkButton *) butPtr; @@ -361,16 +355,16 @@ TkpDisplayButton(clientData) } border = butPtr->normalBorder; - if ((butPtr->state == tkDisabledUid) && (butPtr->disabledFg != NULL)) { + if ((butPtr->state == STATE_DISABLED) && (butPtr->disabledFg != NULL)) { gc = butPtr->disabledGC; - } else if ((butPtr->state == tkActiveUid) + } 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->state != tkActiveUid) + if ((butPtr->flags & SELECTED) && (butPtr->state != STATE_ACTIVE) && (butPtr->selectBorder != NULL) && !butPtr->indicatorOn) { border = butPtr->selectBorder; } @@ -391,7 +385,7 @@ TkpDisplayButton(clientData) */ if (butPtr->type == TYPE_BUTTON) { - defaultWidth = ((butPtr->defaultState == tkActiveUid) + defaultWidth = ((butPtr->defaultState == DEFAULT_ACTIVE) ? butPtr->highlightWidth : 0); offset = 1; } else { @@ -507,7 +501,7 @@ TkpDisplayButton(clientData) y -= butPtr->indicatorDiameter / 2; xSrc = (butPtr->flags & SELECTED) ? boxWidth : 0; - if (butPtr->state == tkActiveUid) { + if (butPtr->state == STATE_ACTIVE) { xSrc += boxWidth*2; } ySrc = (butPtr->type == TYPE_RADIO_BUTTON) ? 0 : boxHeight; @@ -530,7 +524,7 @@ TkpDisplayButton(clientData) border, TK_3D_LIGHT2)); boxesPalette[PAL_BOTTOM_OUTER] = FlipColor(TkWinGetBorderPixels(tkwin, border, TK_3D_LIGHT_GC)); - if (butPtr->state == tkDisabledUid) { + if (butPtr->state == STATE_DISABLED) { boxesPalette[PAL_INTERIOR] = FlipColor(TkWinGetBorderPixels(tkwin, border, TK_3D_LIGHT2)); } else if (butPtr->selectBorder != NULL) { @@ -556,7 +550,7 @@ TkpDisplayButton(clientData) * must temporarily modify the GC. */ - if ((butPtr->state == tkDisabledUid) + if ((butPtr->state == STATE_DISABLED) && ((butPtr->disabledFg == NULL) || (butPtr->image != NULL))) { if ((butPtr->flags & SELECTED) && !butPtr->indicatorOn && (butPtr->selectBorder != NULL)) { @@ -666,8 +660,8 @@ TkpComputeButtonGeometry(butPtr) } else { Tk_FreeTextLayout(butPtr->textLayout); butPtr->textLayout = Tk_ComputeTextLayout(butPtr->tkfont, - butPtr->text, -1, butPtr->wrapLength, butPtr->justify, 0, - &butPtr->textWidth, &butPtr->textHeight); + Tcl_GetString(butPtr->textPtr), -1, butPtr->wrapLength, + butPtr->justify, 0, &butPtr->textWidth, &butPtr->textHeight); width = butPtr->textWidth; height = butPtr->textHeight; @@ -788,7 +782,7 @@ ButtonProc(hwnd, message, wParam, lParam) case BN_CLICKED: { int code; Tcl_Interp *interp = butPtr->info.interp; - if (butPtr->info.state != tkDisabledUid) { + if (butPtr->info.state != STATE_DISABLED) { Tcl_Preserve((ClientData)interp); code = TkInvokeButton((TkButton*)butPtr); if (code != TCL_OK && code != TCL_CONTINUE diff --git a/win/tkWinClipboard.c b/win/tkWinClipboard.c index 9d4237a..5d630d9 100644 --- a/win/tkWinClipboard.c +++ b/win/tkWinClipboard.c @@ -3,12 +3,12 @@ * * This file contains functions for managing the clipboard. * - * Copyright (c) 1995 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkWinClipboard.c 1.8 97/05/20 17:01:13 + * SCCS: @(#) tkWinClipboard.c 1.9 97/11/07 21:25:49 */ #include "tkWinInt.h" @@ -27,7 +27,7 @@ * 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 interp->result. + * then an error message is left in the interp's result. * * Side effects: * None. diff --git a/win/tkWinColor.c b/win/tkWinColor.c index 2cc3d09..db38a7d 100644 --- a/win/tkWinColor.c +++ b/win/tkWinColor.c @@ -9,11 +9,11 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkWinColor.c 1.20 97/10/27 16:39:23 + * SCCS: @(#) tkWinColor.c 1.21 97/10/29 10:37:34 */ -#include <tkColor.h> -#include <tkWinInt.h> +#include "tkWinInt.h" +#include "tkColor.h" /* * The following structure is used to keep track of each color that is diff --git a/win/tkWinConfig.c b/win/tkWinConfig.c new file mode 100644 index 0000000..feb77bd --- /dev/null +++ b/win/tkWinConfig.c @@ -0,0 +1,60 @@ +/* + * tkWinConfig.c -- + * + * This module implements the Windows 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. + * + * SCCS: @(#) tkWinConfig.c 1.4 98/01/21 00:23:32 + */ + +#include "tk.h" +#include "tkInt.h" +#include "tkWinInt.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. */ + char *dbName, /* The option database name. */ + char *className) /* The name of the option class. */ +{ + Tcl_Obj *valueObjPtr; + Tk_Uid classUid; + + if (tkwin == NULL) { + return NULL; + } + + valueObjPtr = NULL; + classUid = Tk_Class(tkwin); + + if (strcmp(classUid, "Menu") == 0) { + valueObjPtr = TkWinGetMenuSystemDefault(tkwin, dbName, className); + } + + return valueObjPtr; +} diff --git a/win/tkWinCursor.c b/win/tkWinCursor.c index bf81d8f..85010e6 100644 --- a/win/tkWinCursor.c +++ b/win/tkWinCursor.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkWinCursor.c 1.10 97/09/02 13:21:01 + * SCCS: @(#) tkWinCursor.c 1.11 97/11/12 17:50:45 */ #include "tkWinInt.h" @@ -152,7 +152,7 @@ TkCreateCursorFromData(tkwin, source, mask, width, height, xHot, yHot, /* *---------------------------------------------------------------------- * - * TkFreeCursor -- + * TkpFreeCursor -- * * This procedure is called to release a cursor allocated by * TkGetCursorByName. @@ -167,11 +167,10 @@ TkCreateCursorFromData(tkwin, source, mask, width, height, xHot, yHot, */ void -TkFreeCursor(cursorPtr) +TkpFreeCursor(cursorPtr) TkCursor *cursorPtr; { TkWinCursor *winCursorPtr = (TkWinCursor *) cursorPtr; - ckfree((char *) winCursorPtr); } /* diff --git a/win/tkWinDefault.h b/win/tkWinDefault.h index c82f3c8..ecd00d2 100644 --- a/win/tkWinDefault.h +++ b/win/tkWinDefault.h @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkWinDefault.h 1.34 97/10/09 17:45:20 + * SCCS: @(#) tkWinDefault.h 1.35 98/01/09 09:46:28 */ #ifndef _TKWINDEFAULT @@ -65,7 +65,8 @@ #define DEF_CHKRAD_FG TEXT_FG #define DEF_BUTTON_FONT CTL_FONT #define DEF_BUTTON_HEIGHT "0" -#define DEF_BUTTON_HIGHLIGHT_BG NORMAL_BG +#define DEF_BUTTON_HIGHLIGHT_BG_COLOR DEF_BUTTON_BG_COLOR +#define DEF_BUTTON_HIGHLIGHT_BG_MONO DEF_BUTTON_BG_MONO #define DEF_BUTTON_HIGHLIGHT HIGHLIGHT #define DEF_LABEL_HIGHLIGHT_WIDTH "0" #define DEF_BUTTON_HIGHLIGHT_WIDTH "1" diff --git a/win/tkWinDialog.c b/win/tkWinDialog.c index 7d01edb..11f2056 100644 --- a/win/tkWinDialog.c +++ b/win/tkWinDialog.c @@ -8,10 +8,10 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkWinDialog.c 1.10 97/10/21 11:29:18 + * SCCS: @(#) tkWinDialog.c 1.11 97/10/29 10:41:59 * */ - + #include "tkWinInt.h" #include "tkFileFilter.h" @@ -19,138 +19,140 @@ #include <dlgs.h> /* includes common dialog template defines */ #include <cderr.h> /* includes the common dialog error codes */ -#if ((TK_MAJOR_VERSION == 4) && (TK_MINOR_VERSION <= 2)) /* - * The following function is implemented on tk4.3 and after only + * The following variable flags whether we should output debugging + * infomation while displaying a builtin dialog. */ -#define Tk_GetHWND TkWinGetHWND -#endif -#define SAVE_FILE 0 -#define OPEN_FILE 1 +static int debugFlag = 0; +static Tcl_Interp *debugInterp = NULL; -/*---------------------------------------------------------------------- - * MsgTypeInfo -- - * - * This structure stores the type of available message box in an - * easy-to-process format. Used by th Tk_MessageBox() function - *---------------------------------------------------------------------- +/* + * The following variable holds a registered windows event used for + * communicating between the DirectoryChooser dialog and its hook proc. + */ + +static UINT WM_LBSELCHANGED = 0; + +/* + * The following structures are used by Tk_MessageBox() to parse + * arguments and return results. */ -typedef struct MsgTypeInfo { - char * name; - int type; - int numButtons; - char * btnNames[3]; -} MsgTypeInfo; - -#define NUM_TYPES 6 - -static MsgTypeInfo -msgTypeInfo[NUM_TYPES] = { - {"abortretryignore", MB_ABORTRETRYIGNORE, 3, {"abort", "retry", "ignore"}}, - {"ok", MB_OK, 1, {"ok" }}, - {"okcancel", MB_OKCANCEL, 2, {"ok", "cancel" }}, - {"retrycancel", MB_RETRYCANCEL, 2, {"retry", "cancel" }}, - {"yesno", MB_YESNO, 2, {"yes", "no" }}, - {"yesnocancel", MB_YESNOCANCEL, 3, {"yes", "no", "cancel"}} + +static const TkStateMap iconMap[] = { + {MB_ICONERROR, "error"}, + {MB_ICONINFORMATION, "info"}, + {MB_ICONQUESTION, "question"}, + {MB_ICONWARNING, "warning"}, + {-1, NULL} +}; + +static const TkStateMap typeMap[] = { + {MB_ABORTRETRYIGNORE, "abortretryignore"}, + {MB_OK, "ok"}, + {MB_OKCANCEL, "okcancel"}, + {MB_RETRYCANCEL, "retrycancel"}, + {MB_YESNO, "yesno"}, + {MB_YESNOCANCEL, "yesnocancel"}, + {-1, NULL} +}; + +static const TkStateMap buttonMap[] = { + {IDABORT, "abort"}, + {IDRETRY, "retry"}, + {IDIGNORE, "ignore"}, + {IDOK, "ok"}, + {IDCANCEL, "cancel"}, + {IDNO, "no"}, + {IDYES, "yes"}, + {-1, NULL} }; +static const int buttonFlagMap[] = { + MB_DEFBUTTON1, MB_DEFBUTTON2, MB_DEFBUTTON3, MB_DEFBUTTON4 +}; + +static const struct {int type; int btnIds[3];} allowedTypes[] = { + {MB_ABORTRETRYIGNORE, {IDABORT, IDRETRY, IDIGNORE}}, + {MB_OK, {IDOK, -1, -1 }}, + {MB_OKCANCEL, {IDOK, IDCANCEL, -1 }}, + {MB_RETRYCANCEL, {IDRETRY, IDCANCEL, -1 }}, + {MB_YESNO, {IDYES, IDNO, -1 }}, + {MB_YESNOCANCEL, {IDYES, IDNO, IDCANCEL}} +}; + +#define NUM_TYPES (sizeof(allowedTypes) / sizeof(allowedTypes[0])) + /* - * The following structure is used in the GetOpenFileName() and - * GetSaveFileName() calls. + * The following structure is used to pass information between the directory + * chooser procedure, Tk_ChooseDirectoryObjCmd(), and its dialog hook proc. */ -typedef struct _OpenFileData { - Tcl_Interp * interp; - TCHAR szFile[MAX_PATH+1]; -} OpenFileData; + +typedef struct ChooseDir { + Tcl_Interp *interp; /* Interp, used only if debug is turned on, + * for setting the "tk_dialog" variable. */ + int lastCtrl; /* Used by hook proc to keep track of last + * control that had input focus, so when OK + * is pressed we know whether to browse a + * new directory or return. */ + int lastIdx; /* Last item that was selected in directory + * browser listbox. */ + TCHAR path[MAX_PATH]; /* On return from choose directory dialog, + * holds the selected path. Cannot return + * selected path in ofnPtr->lpstrFile because + * the default dialog proc stores a '\0' in + * it, since, of course, no _file_ was + * selected. */ +} ChooseDir; /* - * The following structure is used in the ChooseColor() call. + * Definitions of procedures used only in this file. */ -typedef struct _ChooseColorData { - Tcl_Interp * interp; - char * title; /* Title of the color dialog */ -} ChooseColorData; - - -static int GetFileName _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv, - int isOpen)); -static UINT CALLBACK ColorDlgHookProc _ANSI_ARGS_((HWND hDlg, UINT uMsg, - WPARAM wParam, LPARAM lParam)); -static int MakeFilter _ANSI_ARGS_((Tcl_Interp *interp, - OPENFILENAME *ofnPtr, char * string)); -static int ParseFileDlgArgs _ANSI_ARGS_((Tcl_Interp * interp, - OPENFILENAME *ofnPtr, int argc, char ** argv, - int isOpen)); -static int ProcessCDError _ANSI_ARGS_((Tcl_Interp * interp, - DWORD dwErrorCode, HWND hWnd)); + +static UINT APIENTRY ChooseDirectoryHookProc(HWND hdlg, UINT uMsg, + WPARAM wParam, LPARAM lParam); +static UINT CALLBACK ColorDlgHookProc(HWND hDlg, UINT uMsg, WPARAM wParam, + LPARAM lParam); +static int GetFileName(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[], int isOpen); +static int MakeFilter(Tcl_Interp *interp, char *string, + Tcl_DString *dsPtr); +static UINT APIENTRY OFNHookProc(HWND hdlg, UINT uMsg, WPARAM wParam, + LPARAM lParam); +static void SetTkDialog(ClientData clientData); +static int TrySetDirectory(HWND hwnd, const TCHAR *dir); /* - *---------------------------------------------------------------------- + *------------------------------------------------------------------------- * - * EvalArgv -- + * TkWinDialogDebug -- * - * Invokes the Tcl procedure with the arguments. argv[0] is set by - * the caller of this function. It may be different than cmdName. - * The TCL command will see argv[0], not cmdName, as its name if it - * invokes [lindex [info level 0] 0] + * Function to turn on/off debugging support for common dialogs under + * windows. The variable "tk_debug" is set to the identifier of the + * dialog window when the modal dialog window pops up and it is safe to + * send messages to the dialog. * * Results: - * TCL_ERROR if the command does not exist and cannot be autoloaded. - * Otherwise, return the result of the evaluation of the command. + * None. * * Side effects: - * The command may be autoloaded. + * This variable only makes sense if just one dialog is up at a time. * - *---------------------------------------------------------------------- + *------------------------------------------------------------------------- */ -static int -EvalArgv(interp, cmdName, argc, argv) - Tcl_Interp *interp; /* Current interpreter. */ - char * cmdName; /* Name of the TCL command to call */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ +void +TkWinDialogDebug( + int debug) { - Tcl_CmdInfo cmdInfo; - - if (!Tcl_GetCommandInfo(interp, cmdName, &cmdInfo)) { - char * cmdArgv[2]; - - /* - * This comand is not in the interpreter yet -- looks like we - * have to auto-load it - */ - if (!Tcl_GetCommandInfo(interp, "auto_load", &cmdInfo)) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "cannot execute command \"auto_load\"", - NULL); - return TCL_ERROR; - } - - cmdArgv[0] = "auto_load"; - cmdArgv[1] = cmdName; - - if ((*cmdInfo.proc)(cmdInfo.clientData, interp, 2, cmdArgv)!= TCL_OK){ - return TCL_ERROR; - } - - if (!Tcl_GetCommandInfo(interp, cmdName, &cmdInfo)) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "cannot auto-load command \"", - cmdName, "\"",NULL); - return TCL_ERROR; - } - } - - return (*cmdInfo.proc)(cmdInfo.clientData, interp, argc, argv); + debugFlag = debug; } /* - *---------------------------------------------------------------------- + *------------------------------------------------------------------------- * - * Tk_ChooseColorCmd -- + * Tk_ChooseColorObjCmd -- * * This procedure implements the color dialog box for the Windows * platform. See the user documentation for details on what it @@ -164,106 +166,105 @@ EvalArgv(interp, cmdName, argc, argv) * This window is not destroyed and will be reused the next time the * application invokes the "tk_chooseColor" command. * - *---------------------------------------------------------------------- + *------------------------------------------------------------------------- */ int -Tk_ChooseColorCmd(clientData, interp, argc, argv) +Tk_ChooseColorObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Main window associated with interpreter. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - Tk_Window parent = Tk_MainWindow(interp); - ChooseColorData custData; - int oldMode; + Tk_Window tkwin, parent; + int i, oldMode, winCode; CHOOSECOLOR chooseColor; - char * colorStr = NULL; - int i; - int winCode, tclCode; - XColor * colorPtr = NULL; static inited = 0; - static long dwCustColors[16]; + static COLORREF dwCustColors[16]; static long oldColor; /* the color selected last time */ - - custData.title = NULL; - - if (!inited) { + static char *optionStrings[] = { + "-initialcolor", "-parent", "-title", NULL + }; + enum options { + COLOR_INITIAL, COLOR_PARENT, COLOR_TITLE + }; + + if (inited == 0) { /* * dwCustColors stores the custom color which the user can - * modify. We store these colors in a fixed array so that the next + * modify. We store these colors in a static array so that the next * time the color dialog pops up, the same set of custom colors * remain in the dialog. */ - for (i=0; i<16; i++) { - dwCustColors[i] = (RGB(255-i*10, i, i*10)) ; + for (i = 0; i < 16; i++) { + dwCustColors[i] = RGB(255-i * 10, i, i * 10); } - oldColor = RGB(0xa0,0xa0,0xa0); + oldColor = RGB(0xa0, 0xa0, 0xa0); inited = 1; } - /* - * 1. Parse the arguments - */ - - chooseColor.lStructSize = sizeof(CHOOSECOLOR) ; - chooseColor.hwndOwner = 0; /* filled in below */ - chooseColor.hInstance = 0; - chooseColor.rgbResult = oldColor; - chooseColor.lpCustColors = (LPDWORD) dwCustColors ; - chooseColor.Flags = CC_RGBINIT | CC_FULLOPEN | CC_ENABLEHOOK; - chooseColor.lCustData = (LPARAM)&custData; - chooseColor.lpfnHook = ColorDlgHookProc; - chooseColor.lpTemplateName = NULL; - - for (i=1; i<argc; i+=2) { - int v = i+1; - int len = strlen(argv[i]); - - if (strncmp(argv[i], "-initialcolor", len)==0) { - if (v==argc) {goto arg_missing;} - - colorStr = argv[v]; + tkwin = (Tk_Window) clientData; + + parent = tkwin; + chooseColor.lStructSize = sizeof(CHOOSECOLOR) ; + chooseColor.hwndOwner = 0; + chooseColor.hInstance = 0; + chooseColor.rgbResult = oldColor; + chooseColor.lpCustColors = dwCustColors ; + chooseColor.Flags = CC_RGBINIT | CC_FULLOPEN | CC_ENABLEHOOK; + chooseColor.lCustData = (LPARAM) NULL; + chooseColor.lpfnHook = ColorDlgHookProc; + chooseColor.lpTemplateName = (LPTSTR) interp; + + for (i = 1; i < objc; i += 2) { + int index; + char *string; + Tcl_Obj *optionPtr, *valuePtr; + + optionPtr = objv[i]; + valuePtr = objv[i + 1]; + + if (Tcl_GetIndexFromObj(interp, optionPtr, optionStrings, "option", + TCL_EXACT, &index) != TCL_OK) { + return TCL_ERROR; } - else if (strncmp(argv[i], "-parent", len)==0) { - if (v==argc) {goto arg_missing;} - - parent=Tk_NameToWindow(interp, argv[v], Tk_MainWindow(interp)); - if (parent == NULL) { - return TCL_ERROR; - } + if (i + 1 == objc) { + string = Tcl_GetStringFromObj(optionPtr, NULL); + Tcl_AppendResult(interp, "value for \"", string, "\" missing", + (char *) NULL); + return TCL_ERROR; } - else if (strncmp(argv[i], "-title", len)==0) { - if (v==argc) {goto arg_missing;} - custData.title = argv[v]; - } - else { - Tcl_AppendResult(interp, "unknown option \"", - argv[i], "\", must be -initialcolor, -parent or -title", - NULL); - return TCL_ERROR; + string = Tcl_GetStringFromObj(valuePtr, NULL); + switch ((enum options) index) { + case COLOR_INITIAL: { + XColor *colorPtr; + + colorPtr = Tk_GetColor(interp, tkwin, string); + if (colorPtr == NULL) { + return TCL_ERROR; + } + chooseColor.rgbResult = RGB(colorPtr->red / 0x100, + colorPtr->green / 0x100, colorPtr->blue / 0x100); + break; + } + case COLOR_PARENT: { + parent = Tk_NameToWindow(interp, string, tkwin); + if (parent == NULL) { + return TCL_ERROR; + } + break; + } + case COLOR_TITLE: { + chooseColor.lCustData = (LPARAM) string; + break; + } } } - if (Tk_WindowId(parent) == None) { - Tk_MakeWindowExist(parent); - } + Tk_MakeWindowExist(parent); chooseColor.hwndOwner = Tk_GetHWND(Tk_WindowId(parent)); - if (colorStr != NULL) { - colorPtr = Tk_GetColor(interp, Tk_MainWindow(interp), colorStr); - if (!colorPtr) { - return TCL_ERROR; - } - chooseColor.rgbResult = RGB((colorPtr->red/0x100), - (colorPtr->green/0x100), (colorPtr->blue/0x100)); - } - - /* - * 2. Popup the dialog - */ - oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL); winCode = ChooseColor(&chooseColor); (void) Tcl_SetServiceMode(oldMode); @@ -278,6 +279,7 @@ Tk_ChooseColorCmd(clientData, interp, argc, argv) /* * 3. Process the result of the dialog */ + if (winCode) { /* * User has selected a color @@ -285,75 +287,64 @@ Tk_ChooseColorCmd(clientData, interp, argc, argv) char result[100]; sprintf(result, "#%02x%02x%02x", - GetRValue(chooseColor.rgbResult), - GetGValue(chooseColor.rgbResult), - GetBValue(chooseColor.rgbResult)); + GetRValue(chooseColor.rgbResult), + GetGValue(chooseColor.rgbResult), + GetBValue(chooseColor.rgbResult)); Tcl_AppendResult(interp, result, NULL); - tclCode = TCL_OK; - oldColor = chooseColor.rgbResult; - } else { - /* - * User probably pressed Cancel, or an error occurred - */ - tclCode = ProcessCDError(interp, CommDlgExtendedError(), - chooseColor.hwndOwner); - } - - if (colorPtr) { - Tk_FreeColor(colorPtr); } - - return tclCode; - - arg_missing: - Tcl_AppendResult(interp, "value for \"", argv[argc-1], "\" missing", - NULL); - return TCL_ERROR; + return TCL_OK; } /* - *---------------------------------------------------------------------- + *------------------------------------------------------------------------- * * ColorDlgHookProc -- * - * Gets called during the execution of the color dialog. It processes - * the "interesting" messages that Windows send to the dialog. + * Provides special handling of messages for the Color common dialog + * box. Used to set the title when the dialog first appears. * * Results: - * TRUE if the message has been processed, FALSE otherwise. + * The return value is 0 if the default dialog box procedure should + * handle the message, non-zero otherwise. * * Side effects: - * Changes the title of the dialog window when it is popped up. + * Changes the title of the dialog window. * *---------------------------------------------------------------------- */ -static UINT -CALLBACK ColorDlgHookProc(hDlg, uMsg, wParam, lParam) - HWND hDlg; /* Handle to the color dialog */ - UINT uMsg; /* Type of message */ - WPARAM wParam; /* word param, interpretation depends on uMsg*/ - LPARAM lParam; /* long param, interpretation depends on uMsg*/ +static UINT CALLBACK +ColorDlgHookProc(hDlg, uMsg, wParam, lParam) + HWND hDlg; /* Handle to the color dialog. */ + UINT uMsg; /* Type of message. */ + WPARAM wParam; /* First message parameter. */ + LPARAM lParam; /* Second message parameter. */ { - CHOOSECOLOR * ccPtr; - ChooseColorData * pCustData; - switch (uMsg) { - case WM_INITDIALOG: - /* Save the pointer to CHOOSECOLOR so that we can use it later */ - SetWindowLong(hDlg, DWL_USER, lParam); - - /* Set the title string of the dialog */ - ccPtr = (CHOOSECOLOR*)lParam; - pCustData = (ChooseColorData*)(ccPtr->lCustData); - if (pCustData->title && *(pCustData->title)) { - SetWindowText(hDlg, (LPCSTR)pCustData->title); - } + case WM_INITDIALOG: { + const char *title; + CHOOSECOLOR *ccPtr; + Tcl_DString ds; - return TRUE; - } + /* + * Set the title string of the dialog. + */ + ccPtr = (CHOOSECOLOR *) lParam; + title = (const char *) ccPtr->lCustData; + if ((title != NULL) && (title[0] != '\0')) { + Tcl_UtfToExternalDString(NULL, title, -1, &ds); + SetWindowText(hDlg, (TCHAR *) Tcl_DStringValue(&ds)); + Tcl_DStringFree(&ds); + } + if (debugFlag) { + debugInterp = (Tcl_Interp *) ccPtr->lpTemplateName; + Tcl_DoWhenIdle(SetTkDialog, (ClientData) hDlg); + } + return TRUE; + } + } return FALSE; } @@ -371,21 +362,18 @@ CALLBACK ColorDlgHookProc(hDlg, uMsg, wParam, lParam) * * 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_GetOpenFileCmd(clientData, interp, argc, argv) +Tk_GetOpenFileObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Main window associated with interpreter. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - return GetFileName(clientData, interp, argc, argv, OPEN_FILE); + return GetFileName(clientData, interp, objc, objv, 1); } /* @@ -406,13 +394,13 @@ Tk_GetOpenFileCmd(clientData, interp, argc, argv) */ int -Tk_GetSaveFileCmd(clientData, interp, argc, argv) +Tk_GetSaveFileObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Main window associated with interpreter. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - return GetFileName(clientData, interp, argc, argv, SAVE_FILE); + return GetFileName(clientData, interp, objc, objv, 0); } /* @@ -432,41 +420,195 @@ Tk_GetSaveFileCmd(clientData, interp, argc, argv) */ static int -GetFileName(clientData, interp, argc, argv, isOpen) +GetFileName(clientData, interp, objc, objv, open) ClientData clientData; /* Main window associated with interpreter. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ - int isOpen; /* true if we should call GetOpenFileName(), - * false if we should call GetSaveFileName() */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ + int open; /* 1 to call GetOpenFileName(), 0 to + * call GetSaveFileName(). */ { - OPENFILENAME openFileName, *ofnPtr; - int tclCode, winCode, oldMode; - OpenFileData *custData; - char buffer[MAX_PATH+1]; - - ofnPtr = &openFileName; + OPENFILENAME ofn; + TCHAR file[MAX_PATH], savePath[MAX_PATH]; + int result, winCode, oldMode, i; + char *extension, *filter, *title; + Tk_Window tkwin; + Tcl_DString utfFilterString, utfDirString; + Tcl_DString extString, filterString, dirString, titleString; + static char *optionStrings[] = { + "-defaultextension", "-filetypes", "-initialdir", "-initialfile", + "-parent", "-title", NULL + }; + enum options { + FILE_DEFAULT, FILE_TYPES, FILE_INITDIR, FILE_INITFILE, + FILE_PARENT, FILE_TITLE + }; + + result = TCL_ERROR; + file[0] = '\0'; /* - * 1. Parse the arguments. + * Parse the arguments. */ - if (ParseFileDlgArgs(interp, ofnPtr, argc, argv, isOpen) != TCL_OK) { - return TCL_ERROR; + + extension = NULL; + filter = NULL; + Tcl_DStringInit(&utfFilterString); + Tcl_DStringInit(&utfDirString); + tkwin = (Tk_Window) clientData; + title = NULL; + + for (i = 1; i < objc; i += 2) { + int index; + char *string; + Tcl_Obj *optionPtr, *valuePtr; + + optionPtr = objv[i]; + valuePtr = objv[i + 1]; + + if (Tcl_GetIndexFromObj(interp, optionPtr, optionStrings, "option", + 0, &index) != TCL_OK) { + goto end; + } + if (i + 1 == objc) { + string = Tcl_GetStringFromObj(optionPtr, NULL); + Tcl_AppendResult(interp, "value for \"", string, "\" missing", + (char *) NULL); + goto end; + } + + string = Tcl_GetStringFromObj(valuePtr, NULL); + switch ((enum options) index) { + case FILE_DEFAULT: { + if (string[0] == '.') { + string++; + } + extension = string; + break; + } + case FILE_TYPES: { + Tcl_DStringFree(&utfFilterString); + if (MakeFilter(interp, string, &utfFilterString) != TCL_OK) { + goto end; + } + filter = Tcl_DStringValue(&utfFilterString); + break; + } + case FILE_INITDIR: { + Tcl_DStringFree(&utfDirString); + if (Tcl_TranslateFileName(interp, string, + &utfDirString) == NULL) { + goto end; + } + break; + } + case FILE_INITFILE: { + Tcl_DString ds; + + if (Tcl_TranslateFileName(interp, string, &ds) == NULL) { + goto end; + } + Tcl_UtfToExternal(NULL, NULL, Tcl_DStringValue(&ds), + Tcl_DStringLength(&ds), 0, NULL, (char *) file, + sizeof(file), NULL, NULL, NULL); + break; + } + case FILE_PARENT: { + tkwin = Tk_NameToWindow(interp, string, tkwin); + if (tkwin == NULL) { + goto end; + } + break; + } + case FILE_TITLE: { + title = string; + break; + } + } + } + + if (filter == NULL) { + if (MakeFilter(interp, "", &utfFilterString) != TCL_OK) { + goto end; + } + } + + Tk_MakeWindowExist(tkwin); + + ofn.lStructSize = sizeof(ofn); + ofn.hwndOwner = Tk_GetHWND(Tk_WindowId(tkwin)); + ofn.hInstance = (HINSTANCE) GetWindowLong(ofn.hwndOwner, + GWL_HINSTANCE); + ofn.lpstrFilter = NULL; + ofn.lpstrCustomFilter = NULL; + ofn.nMaxCustFilter = 0; + ofn.nFilterIndex = 0; + ofn.lpstrFile = (LPTSTR) file; + ofn.nMaxFile = MAX_PATH; + ofn.lpstrFileTitle = NULL; + ofn.nMaxFileTitle = 0; + ofn.lpstrInitialDir = NULL; + ofn.lpstrTitle = NULL; + ofn.Flags = OFN_HIDEREADONLY | OFN_PATHMUSTEXIST + | OFN_NOCHANGEDIR; + ofn.nFileOffset = 0; + ofn.nFileExtension = 0; + ofn.lpstrDefExt = NULL; + ofn.lpfnHook = OFNHookProc; + ofn.lCustData = (LPARAM) interp; + ofn.lpTemplateName = NULL; + + if (LOBYTE(LOWORD(GetVersion())) >= 4) { + /* + * Use the "explorer" style file selection box on platforms that + * support it (Win95 and NT4.0 both have a major version number + * of 4). + */ + + ofn.Flags |= OFN_EXPLORER; + } + + if (open != 0) { + ofn.Flags |= OFN_FILEMUSTEXIST; + } else { + ofn.Flags |= OFN_OVERWRITEPROMPT; + } + + if (debugFlag != 0) { + ofn.Flags |= OFN_ENABLEHOOK; + } + + if (extension != NULL) { + Tcl_UtfToExternalDString(NULL, extension, -1, &extString); + ofn.lpstrDefExt = (LPTSTR) Tcl_DStringValue(&extString); + } + Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(&utfFilterString), + Tcl_DStringLength(&utfFilterString), &filterString); + ofn.lpstrFilter = (LPTSTR) Tcl_DStringValue(&filterString); + + if (Tcl_DStringValue(&utfDirString)[0] != '\0') { + Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(&utfDirString), + Tcl_DStringLength(&utfDirString), &dirString); + ofn.lpstrInitialDir = (LPTSTR) Tcl_DStringValue(&dirString); + } + if (title != NULL) { + Tcl_UtfToExternalDString(NULL, title, -1, &titleString); + ofn.lpstrTitle = (LPTSTR) Tcl_DStringValue(&titleString); } - custData = (OpenFileData*) ofnPtr->lCustData; /* - * 2. Call the common dialog function. + * Popup the dialog. */ + + GetCurrentDirectory(MAX_PATH, savePath); oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL); - GetCurrentDirectory(MAX_PATH+1, buffer); - if (isOpen) { - winCode = GetOpenFileName(ofnPtr); + if (open != 0) { + winCode = GetOpenFileName(&ofn); } else { - winCode = GetSaveFileName(ofnPtr); + winCode = GetSaveFileName(&ofn); } - SetCurrentDirectory(buffer); - (void) Tcl_SetServiceMode(oldMode); + Tcl_SetServiceMode(oldMode); + SetCurrentDirectory(savePath); /* * Clear the interp result since anything may have happened during the @@ -475,18 +617,16 @@ GetFileName(clientData, interp, argc, argv, isOpen) Tcl_ResetResult(interp); - if (ofnPtr->lpstrInitialDir != NULL) { - ckfree((char*) ofnPtr->lpstrInitialDir); - } - /* - * 3. Process the results. + * Process the results. */ - if (winCode) { + + if (winCode != 0) { char *p; - Tcl_ResetResult(interp); + Tcl_DString ds; - for (p = custData->szFile; p && *p; p++) { + Tcl_ExternalToUtfDString(NULL, (char *) ofn.lpstrFile, -1, &ds); + for (p = Tcl_DStringValue(&ds); *p != '\0'; p++) { /* * Change the pathname to the Tcl "normalized" pathname, where * back slashes are used instead of forward slashes @@ -495,177 +635,78 @@ GetFileName(clientData, interp, argc, argv, isOpen) *p = '/'; } } - Tcl_AppendResult(interp, custData->szFile, NULL); - tclCode = TCL_OK; - } else { - tclCode = ProcessCDError(interp, CommDlgExtendedError(), - ofnPtr->hwndOwner); + Tcl_AppendResult(interp, Tcl_DStringValue(&ds), NULL); + Tcl_DStringFree(&ds); } - if (custData) { - ckfree((char*)custData); + if (ofn.lpstrTitle != NULL) { + Tcl_DStringFree(&titleString); + } + if (ofn.lpstrInitialDir != NULL) { + Tcl_DStringFree(&dirString); } - if (ofnPtr->lpstrFilter) { - ckfree((char*)ofnPtr->lpstrFilter); + Tcl_DStringFree(&filterString); + if (ofn.lpstrDefExt != NULL) { + Tcl_DStringFree(&extString); } + result = TCL_OK; - return tclCode; + end: + Tcl_DStringFree(&utfDirString); + Tcl_DStringFree(&utfFilterString); + + return result; } /* - *---------------------------------------------------------------------- + *------------------------------------------------------------------------- * - * ParseFileDlgArgs -- + * OFNHookProc -- * - * Parses the arguments passed to tk_getOpenFile and tk_getSaveFile. + * Hook procedure called only if debugging is turned on. Sets + * the "tk_dialog" variable when the dialog is ready to receive + * messages. * * Results: - * A standard TCL return value. + * Returns 0 to allow default processing of messages to occur. * * Side effects: - * The OPENFILENAME structure is initialized and modified according - * to the arguments. + * None. * - *---------------------------------------------------------------------- + *------------------------------------------------------------------------- */ -static int -ParseFileDlgArgs(interp, ofnPtr, argc, argv, isOpen) - Tcl_Interp * interp; /* Current interpreter. */ - OPENFILENAME *ofnPtr; /* Info about the file dialog */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ - int isOpen; /* true if we should call GetOpenFileName(), - * false if we should call GetSaveFileName() */ +static UINT APIENTRY +OFNHookProc( + HWND hdlg, // handle to child dialog window + UINT uMsg, // message identifier + WPARAM wParam, // message parameter + LPARAM lParam) // message parameter { - OpenFileData * custData; - int i; - Tk_Window parent = Tk_MainWindow(interp); - int doneFilter = 0; - int windowsMajorVersion; - Tcl_DString buffer; - - custData = (OpenFileData*)ckalloc(sizeof(OpenFileData)); - custData->interp = interp; - strcpy(custData->szFile, ""); - - /* Fill in the OPENFILENAME structure to */ - ofnPtr->lStructSize = sizeof(OPENFILENAME); - ofnPtr->hwndOwner = 0; /* filled in below */ - ofnPtr->lpstrFilter = NULL; - ofnPtr->lpstrCustomFilter = NULL; - ofnPtr->nMaxCustFilter = 0; - ofnPtr->nFilterIndex = 0; - ofnPtr->lpstrFile = custData->szFile; - ofnPtr->nMaxFile = sizeof(custData->szFile); - ofnPtr->lpstrFileTitle = NULL; - ofnPtr->nMaxFileTitle = 0; - ofnPtr->lpstrInitialDir = NULL; - ofnPtr->lpstrTitle = NULL; - ofnPtr->nFileOffset = 0; - ofnPtr->nFileExtension = 0; - ofnPtr->lpstrDefExt = NULL; - ofnPtr->lpfnHook = NULL; - ofnPtr->lCustData = (DWORD)custData; - ofnPtr->lpTemplateName = NULL; - ofnPtr->Flags = OFN_HIDEREADONLY | OFN_PATHMUSTEXIST; - - windowsMajorVersion = LOBYTE(LOWORD(GetVersion())); - if (windowsMajorVersion >= 4) { + OPENFILENAME *ofnPtr; + + if (uMsg == WM_INITDIALOG) { + SetWindowLong(hdlg, GWL_USERDATA, lParam); + } else if (uMsg == WM_WINDOWPOSCHANGED) { /* - * Use the "explorer" style file selection box on platforms that - * support it (Win95 and NT4.0, both have a major version number - * of 4) + * This message is delivered at the right time to both + * old-style and explorer-style hook procs to enable Tk + * to set the debug information. Unhooks itself so it + * won't set the debug information every time it gets a + * WM_WINDOWPOSCHANGED message. */ - ofnPtr->Flags |= OFN_EXPLORER; - } - - if (isOpen) { - ofnPtr->Flags |= OFN_FILEMUSTEXIST; - } else { - ofnPtr->Flags |= OFN_OVERWRITEPROMPT; - } - - for (i=1; i<argc; i+=2) { - int v = i+1; - int len = strlen(argv[i]); - - if (strncmp(argv[i], "-defaultextension", len)==0) { - if (v==argc) {goto arg_missing;} - - ofnPtr->lpstrDefExt = argv[v]; - if (ofnPtr->lpstrDefExt[0] == '.') { - /* Windows will insert the dot for us */ - ofnPtr->lpstrDefExt ++; + ofnPtr = (OPENFILENAME *) GetWindowLong(hdlg, GWL_USERDATA); + if (ofnPtr != NULL) { + if (ofnPtr->Flags & OFN_EXPLORER) { + hdlg = GetParent(hdlg); } + debugInterp = (Tcl_Interp *) ofnPtr->lCustData; + Tcl_DoWhenIdle(SetTkDialog, (ClientData) hdlg); + SetWindowLong(hdlg, GWL_USERDATA, (LPARAM) NULL); } - else if (strncmp(argv[i], "-filetypes", len)==0) { - if (v==argc) {goto arg_missing;} - - if (MakeFilter(interp, ofnPtr, argv[v]) != TCL_OK) { - return TCL_ERROR; - } - doneFilter = 1; - } - else if (strncmp(argv[i], "-initialdir", len)==0) { - if (v==argc) {goto arg_missing;} - - if (Tcl_TranslateFileName(interp, argv[v], &buffer) == NULL) { - return TCL_ERROR; - } - ofnPtr->lpstrInitialDir = ckalloc(Tcl_DStringLength(&buffer)+1); - strcpy((char*)ofnPtr->lpstrInitialDir, Tcl_DStringValue(&buffer)); - Tcl_DStringFree(&buffer); - } - else if (strncmp(argv[i], "-initialfile", len)==0) { - if (v==argc) {goto arg_missing;} - - if (Tcl_TranslateFileName(interp, argv[v], &buffer) == NULL) { - return TCL_ERROR; - } - strcpy(ofnPtr->lpstrFile, Tcl_DStringValue(&buffer)); - Tcl_DStringFree(&buffer); - } - else if (strncmp(argv[i], "-parent", len)==0) { - if (v==argc) {goto arg_missing;} - - parent=Tk_NameToWindow(interp, argv[v], Tk_MainWindow(interp)); - if (parent == NULL) { - return TCL_ERROR; - } - } - else if (strncmp(argv[i], "-title", len)==0) { - if (v==argc) {goto arg_missing;} - - ofnPtr->lpstrTitle = argv[v]; - } - else { - Tcl_AppendResult(interp, "unknown option \"", - argv[i], "\", must be -defaultextension, ", - "-filetypes, -initialdir, -initialfile, -parent or -title", - NULL); - return TCL_ERROR; - } - } - - if (!doneFilter) { - if (MakeFilter(interp, ofnPtr, "") != TCL_OK) { - return TCL_ERROR; - } - } - - if (Tk_WindowId(parent) == None) { - Tk_MakeWindowExist(parent); } - ofnPtr->hwndOwner = Tk_GetHWND(Tk_WindowId(parent)); - - return TCL_OK; - - arg_missing: - Tcl_AppendResult(interp, "value for \"", argv[argc-1], "\" missing", - NULL); - return TCL_ERROR; + return 0; } /* @@ -684,10 +725,11 @@ ParseFileDlgArgs(interp, ofnPtr, argc, argv, isOpen) * *---------------------------------------------------------------------- */ -static int MakeFilter(interp, ofnPtr, string) +static int +MakeFilter(interp, string, dsPtr) Tcl_Interp *interp; /* Current interpreter. */ - OPENFILENAME *ofnPtr; /* Info about the file dialog */ char *string; /* String value of the -filetypes option */ + Tcl_DString *dsPtr; /* Filled with windows filter string. */ { char *filterStr; char *p; @@ -702,7 +744,7 @@ static int MakeFilter(interp, ofnPtr, string) if (flist.filters == NULL) { /* - * Use "All Files (*.*) as the default filter is none is specified + * Use "All Files (*.*) as the default filter if none is specified */ char *defaultFilter = "All Files (*.*)"; @@ -790,10 +832,8 @@ static int MakeFilter(interp, ofnPtr, string) *p = '\0'; } - if (ofnPtr->lpstrFilter != NULL) { - ckfree((char*)ofnPtr->lpstrFilter); - } - ofnPtr->lpstrFilter = filterStr; + Tcl_DStringAppend(dsPtr, filterStr, p - filterStr); + ckfree((char *) filterStr); TkFreeFileFilters(&flist); return TCL_OK; @@ -802,249 +842,577 @@ static int MakeFilter(interp, ofnPtr, string) /* *---------------------------------------------------------------------- * - * Tk_MessageBoxCmd -- + * Tk_ChooseDirectoryObjCmd -- * - * This procedure implements the MessageBox window for the - * Windows platform. See the user documentation for details on what - * it does. + * This procedure implements the "tk_chooseDirectory" dialog box + * for the Windows 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. + * A modal dialog window is created. Tcl_SetServiceMode() is + * called to allow background events to be processed * *---------------------------------------------------------------------- */ int -Tk_MessageBoxCmd(clientData, interp, argc, argv) +Tk_ChooseDirectoryObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Main window associated with interpreter. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - int flags; - Tk_Window parent = Tk_MainWindow(interp); - HWND hWnd; - char *message = ""; - char *title = ""; - int icon = MB_ICONINFORMATION; - int type = MB_OK; - int i, j; - char *result; - int code, oldMode; - char *defaultBtn = NULL; - int defaultBtnIdx = -1; - - for (i=1; i<argc; i+=2) { - int v = i+1; - int len = strlen(argv[i]); - - if (strncmp(argv[i], "-default", len)==0) { - if (v==argc) {goto arg_missing;} - - defaultBtn = argv[v]; + OPENFILENAME ofn; + TCHAR path[MAX_PATH], savePath[MAX_PATH]; + ChooseDir cd; + int result, mustExist, code, mode, i; + Tk_Window tkwin; + char *utfTitle; + Tcl_DString utfDirString; + Tcl_DString titleString, dirString; + static char *optionStrings[] = { + "-initialdir", "-mustexist", "-parent", "-title", + NULL + }; + enum options { + DIR_INITIAL, DIR_EXIST, DIR_PARENT, FILE_TITLE + }; + + if (WM_LBSELCHANGED == 0) { + WM_LBSELCHANGED = RegisterWindowMessage(LBSELCHSTRING); + } + + result = TCL_ERROR; + path[0] = '\0'; + + Tcl_DStringInit(&utfDirString); + mustExist = 0; + tkwin = (Tk_Window) clientData; + utfTitle = NULL; + + for (i = 1; i < objc; i += 2) { + int index; + char *string; + Tcl_Obj *optionPtr, *valuePtr; + + optionPtr = objv[i]; + valuePtr = objv[i + 1]; + + if (Tcl_GetIndexFromObj(interp, optionPtr, optionStrings, "option", + 0, &index) != TCL_OK) { + goto cleanup; + } + if (i + 1 == objc) { + string = Tcl_GetStringFromObj(optionPtr, NULL); + Tcl_AppendResult(interp, "value for \"", string, "\" missing", + (char *) NULL); + goto cleanup; } - else if (strncmp(argv[i], "-icon", len)==0) { - if (v==argc) {goto arg_missing;} - if (strcmp(argv[v], "error") == 0) { - icon = MB_ICONERROR; + string = Tcl_GetStringFromObj(valuePtr, NULL); + switch ((enum options) index) { + case DIR_INITIAL: { + Tcl_DStringFree(&utfDirString); + if (Tcl_TranslateFileName(interp, string, + &utfDirString) == NULL) { + goto cleanup; + } + break; } - else if (strcmp(argv[v], "info") == 0) { - icon = MB_ICONINFORMATION; + case DIR_EXIST: { + if (Tcl_GetBooleanFromObj(interp, valuePtr, &mustExist) != TCL_OK) { + goto cleanup; + } + break; } - else if (strcmp(argv[v], "question") == 0) { - icon = MB_ICONQUESTION; + case DIR_PARENT: { + tkwin = Tk_NameToWindow(interp, string, tkwin); + if (tkwin == NULL) { + goto cleanup; + } + break; } - else if (strcmp(argv[v], "warning") == 0) { - icon = MB_ICONWARNING; + case FILE_TITLE: { + utfTitle = string; + break; } - else { - Tcl_AppendResult(interp, "invalid icon \"", argv[v], - "\", must be error, info, question or warning", NULL); - return TCL_ERROR; + } + } + + Tk_MakeWindowExist(tkwin); + + cd.interp = interp; + + ofn.lStructSize = sizeof(ofn); + ofn.hwndOwner = Tk_GetHWND(Tk_WindowId(tkwin)); + ofn.hInstance = (HINSTANCE) GetWindowLong(ofn.hwndOwner, + GWL_HINSTANCE); + ofn.lpstrFilter = NULL; + ofn.lpstrCustomFilter = NULL; + ofn.nMaxCustFilter = 0; + ofn.nFilterIndex = 0; + ofn.lpstrFile = NULL; //(TCHAR *) path; + ofn.nMaxFile = MAX_PATH; + ofn.lpstrFileTitle = NULL; + ofn.nMaxFileTitle = 0; + ofn.lpstrInitialDir = NULL; + ofn.lpstrTitle = NULL; + ofn.Flags = OFN_HIDEREADONLY + | OFN_ENABLEHOOK | OFN_ENABLETEMPLATE; + ofn.nFileOffset = 0; + ofn.nFileExtension = 0; + ofn.lpstrDefExt = NULL; + ofn.lCustData = (LPARAM) &cd; + ofn.lpfnHook = ChooseDirectoryHookProc; + ofn.lpTemplateName = MAKEINTRESOURCE(FILEOPENORD); + + if (Tcl_DStringValue(&utfDirString)[0] != '\0') { + Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(&utfDirString), + Tcl_DStringLength(&utfDirString), &dirString); + ofn.lpstrInitialDir = (LPTSTR) Tcl_DStringValue(&dirString); + } + if (mustExist) { + ofn.Flags |= OFN_PATHMUSTEXIST; + } + if (utfTitle != NULL) { + Tcl_UtfToExternalDString(NULL, utfTitle, -1, &titleString); + ofn.lpstrTitle = (LPTSTR) Tcl_DStringValue(&titleString); + } + + /* + * Display dialog. The choose directory dialog doesn't preserve the + * current directory, so it must be saved and restored here. + */ + + GetCurrentDirectory(MAX_PATH, savePath); + mode = Tcl_SetServiceMode(TCL_SERVICE_ALL); + code = GetOpenFileName(&ofn); + Tcl_SetServiceMode(mode); + SetCurrentDirectory(savePath); + + Tcl_ResetResult(interp); + if (code != 0) { + /* + * Change the pathname to the Tcl "normalized" pathname, where + * back slashes are used instead of forward slashes + */ + + char *p; + Tcl_DString ds; + + Tcl_ExternalToUtfDString(NULL, (char *) cd.path, -1, &ds); + for (p = Tcl_DStringValue(&ds); *p != '\0'; p++) { + if (*p == '\\') { + *p = '/'; } } - else if (strncmp(argv[i], "-message", len)==0) { - if (v==argc) {goto arg_missing;} + Tcl_AppendResult(interp, Tcl_DStringValue(&ds), NULL); + Tcl_DStringFree(&ds); + } + + if (ofn.lpstrTitle != NULL) { + Tcl_DStringFree(&titleString); + } + if (ofn.lpstrInitialDir != NULL) { + Tcl_DStringFree(&dirString); + } + result = TCL_OK; - message = argv[v]; + cleanup: + Tcl_DStringFree(&utfDirString); + + return result; +} + +/* + *---------------------------------------------------------------------- + * + * ChooseDirectoryHookProc -- + * + * Hook procedure called by the ChooseDirectory dialog to modify + * its default behavior. The ChooseDirectory dialog is really an + * OpenFile dialog with certain controls rearranged and certain + * behaviors changed. For instance, typing a name in the + * ChooseDirectory dialog selects a directory, rather than + * selecting a file. + * + * Results: + * Returns 0 to allow default processing of message, or 1 to + * tell default dialog procedure not to process the message. + * + * 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. + * + *---------------------------------------------------------------------- + */ + +static UINT APIENTRY +ChooseDirectoryHookProc( + HWND hwnd, + UINT message, + WPARAM wParam, + LPARAM lParam) +{ + OPENFILENAME *ofnPtr; + + /* + * GWL_USERDATA keeps track of ofnPtr. + */ + + ofnPtr = (OPENFILENAME *) GetWindowLong(hwnd, GWL_USERDATA); + + if (message == WM_INITDIALOG) { + ChooseDir *cdPtr; + + SetWindowLong(hwnd, GWL_USERDATA, lParam); + ofnPtr = (OPENFILENAME *) lParam; + cdPtr = (ChooseDir *) ofnPtr->lCustData; + cdPtr->lastCtrl = 0; + cdPtr->lastIdx = 1000; + cdPtr->path[0] = '\0'; + + if (ofnPtr->lpstrInitialDir == NULL) { + GetCurrentDirectory(MAX_PATH, cdPtr->path); + } else { + lstrcpy(cdPtr->path, ofnPtr->lpstrInitialDir); } - else if (strncmp(argv[i], "-parent", len)==0) { - if (v==argc) {goto arg_missing;} + SetDlgItemText(hwnd, edt10, cdPtr->path); + SendDlgItemMessage(hwnd, edt10, EM_SETSEL, 0, -1); + if (debugFlag) { + debugInterp = cdPtr->interp; + Tcl_DoWhenIdle(SetTkDialog, (ClientData) hwnd); + } + return 0; + } + if (ofnPtr == NULL) { + return 0; + } - parent=Tk_NameToWindow(interp, argv[v], Tk_MainWindow(interp)); - if (parent == NULL) { - return TCL_ERROR; + if (message == WM_LBSELCHANGED) { + /* + * Called when double-clicking on directory. + * If directory wasn't already open, browse that directory. + * If directory was already open, return selected directory. + */ + + ChooseDir *cdPtr; + int idCtrl, thisItem; + + idCtrl = (int) wParam; + thisItem = LOWORD(lParam); + cdPtr = (ChooseDir *) ofnPtr->lCustData; + + GetCurrentDirectory(MAX_PATH, cdPtr->path); + if (idCtrl == lst2) { + if ((cdPtr->lastIdx < 0) || (cdPtr->lastIdx == thisItem)) { + EndDialog(hwnd, IDOK); + return 1; } + cdPtr->lastIdx = thisItem; } - else if (strncmp(argv[i], "-title", len)==0) { - if (v==argc) {goto arg_missing;} + SetDlgItemText(hwnd, edt10, cdPtr->path); + SendDlgItemMessage(hwnd, edt10, EM_SETSEL, 0, -1); + } else if (message == WM_COMMAND) { + ChooseDir *cdPtr; + int idCtrl, notifyCode; + + idCtrl = LOWORD(wParam); + notifyCode = HIWORD(wParam); + cdPtr = (ChooseDir *) ofnPtr->lCustData; - title = argv[v]; + if ((idCtrl != IDOK) || (notifyCode != BN_CLICKED)) { + /* + * OK Button wasn't clicked. Do the default. + */ + + if ((idCtrl == lst2) || (idCtrl == edt10)) { + cdPtr->lastCtrl = idCtrl; + } + return 0; } - else if (strncmp(argv[i], "-type", len)==0) { - int found = 0; - if (v==argc) {goto arg_missing;} + /* + * Dialogs also get the message that OK was clicked when Enter + * is pressed in some other control. Find out what window + * we were really in when we got the supposed "OK", because the + * behavior is different. + */ + + if (cdPtr->lastCtrl == edt10) { + /* + * Hit Enter or clicked OK while typing a directory name in the + * edit control. + * If it's a new name, try to go to that directory. + * If the name hasn't changed since last time, return selected + * directory. + */ + + int changed; + TCHAR tmp[MAX_PATH]; + + if (GetDlgItemText(hwnd, edt10, tmp, MAX_PATH) == 0) { + return 0; + } + + changed = lstrcmp(cdPtr->path, tmp); + lstrcpy(cdPtr->path, tmp); + + if (SetCurrentDirectory(cdPtr->path) == 0) { + /* + * Non-existent directory. + */ - for (j=0; j<NUM_TYPES; j++) { - if (strcmp(argv[v], msgTypeInfo[j].name) == 0) { - type = msgTypeInfo[j].type; - found = 1; - break; + if (ofnPtr->Flags & OFN_PATHMUSTEXIST) { + /* + * Directory must exist. Complain, then rehighlight text. + */ + + wsprintf(tmp, _T("Cannot change directory to \"%.200s\"."), + cdPtr->path); + MessageBox(hwnd, tmp, NULL, MB_OK); + SendDlgItemMessage(hwnd, edt10, EM_SETSEL, 0, -1); + return 0; + } + if (changed) { + /* + * Directory was invalid, but we want to keep displaying + * this name. Don't update the listbox that displays the + * current directory heirarchy, or it'll erase the name. + */ + + SendDlgItemMessage(hwnd, edt10, EM_SETSEL, 0, -1); + return 0; } } - if (!found) { - Tcl_AppendResult(interp, "invalid message box type \"", - argv[v], "\", must be abortretryignore, ok, ", - "okcancel, retrycancel, yesno or yesnocancel", NULL); - return TCL_ERROR; + if (changed == 0) { + /* + * Name hasn't changed since the last time we hit return + * or double-clicked on a directory, so return this. + */ + + EndDialog(hwnd, IDOK); + return 1; + } + + cdPtr->lastCtrl = IDOK; + + /* + * The following is the magic code, determined by running + * Spy++ on some other directory chooser, that it takes to + * get this dialog to update the listbox to display the + * current directory. + */ + + SetDlgItemText(hwnd, edt1, cdPtr->path); + SendMessage(hwnd, WM_COMMAND, (WPARAM) MAKELONG(cmb2, 0x8003), + (LPARAM) GetDlgItem(hwnd, cmb2)); + return 0; + } else if (idCtrl == lst2) { + /* + * Enter key was pressed while in listbox. + * If it's a new directory, allow default behavior to open dir. + * If the directory hasn't changed, return selected directory. + */ + + int thisItem; + + thisItem = (int) SendDlgItemMessage(hwnd, lst2, LB_GETCURSEL, 0, 0); + if (cdPtr->lastIdx == thisItem) { + GetCurrentDirectory(MAX_PATH, cdPtr->path); + EndDialog(hwnd, IDOK); + return 1; } + } else if (idCtrl == IDOK) { + /* + * The OK button was clicked. Return the path currently specified + * in the listbox. + * + * The directory has not yet been changed to the one specified in + * the listbox. Returning 0 allows the default dialog proc to + * change the directory to the one specified in the listbox and + * then causes it to send a WM_LBSELCHANGED back to the hook proc. + * When we get that message, we will record the current directory + * and then quit. + */ + + cdPtr->lastIdx = -1; + } + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_MessageBoxObjCmd -- + * + * This procedure implements the MessageBox window for the + * Windows 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_MessageBoxObjCmd(clientData, interp, objc, objv) + 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, parent; + HWND hWnd; + char *message, *title; + int defaultBtn, icon, type; + int i, oldMode, flags, winCode; + Tcl_DString messageString, titleString; + static char *optionStrings[] = { + "-default", "-icon", "-message", "-parent", + "-title", "-type", NULL + }; + enum options { + MSG_DEFAULT, MSG_ICON, MSG_MESSAGE, MSG_PARENT, + MSG_TITLE, MSG_TYPE + }; + + tkwin = (Tk_Window) clientData; + + defaultBtn = -1; + icon = MB_ICONINFORMATION; + message = NULL; + parent = tkwin; + title = NULL; + type = MB_OK; + + for (i = 1; i < objc; i += 2) { + int index; + char *string; + Tcl_Obj *optionPtr, *valuePtr; + + optionPtr = objv[i]; + valuePtr = objv[i + 1]; + + if (Tcl_GetIndexFromObj(interp, optionPtr, optionStrings, "option", + TCL_EXACT, &index) != TCL_OK) { + return TCL_ERROR; } - else { - Tcl_AppendResult(interp, "unknown option \"", - argv[i], "\", must be -default, -icon, ", - "-message, -parent, -title or -type", NULL); + if (i + 1 == objc) { + string = Tcl_GetStringFromObj(optionPtr, NULL); + Tcl_AppendResult(interp, "value for \"", string, "\" missing", + (char *) NULL); + return TCL_ERROR; + } + + string = Tcl_GetStringFromObj(valuePtr, NULL); + switch ((enum options) index) { + case MSG_DEFAULT: + defaultBtn = TkFindStateNumObj(interp, optionPtr, buttonMap, + valuePtr); + if (defaultBtn < 0) { + return TCL_ERROR; + } + break; + + case MSG_ICON: + icon = TkFindStateNumObj(interp, optionPtr, iconMap, valuePtr); + if (icon < 0) { + return TCL_ERROR; + } + break; + + case MSG_MESSAGE: + message = string; + break; + + case MSG_PARENT: + parent = Tk_NameToWindow(interp, string, tkwin); + if (parent == NULL) { + return TCL_ERROR; + } + break; + + case MSG_TITLE: + title = string; + break; + + case MSG_TYPE: + type = TkFindStateNumObj(interp, optionPtr, typeMap, valuePtr); + if (type < 0) { return TCL_ERROR; + } + break; + } } - /* Make sure we have a valid hWnd to act as the parent of this message box - */ - if (Tk_WindowId(parent) == None) { - Tk_MakeWindowExist(parent); - } + Tk_MakeWindowExist(parent); hWnd = Tk_GetHWND(Tk_WindowId(parent)); - if (defaultBtn != NULL) { - for (i=0; i<NUM_TYPES; i++) { - if (type == msgTypeInfo[i].type) { - for (j=0; j<msgTypeInfo[i].numButtons; j++) { - if (strcmp(defaultBtn, msgTypeInfo[i].btnNames[j])==0) { - defaultBtnIdx = j; + flags = 0; + if (defaultBtn >= 0) { + int defaultBtnIdx; + + defaultBtnIdx = -1; + for (i = 0; i < NUM_TYPES; i++) { + if (type == allowedTypes[i].type) { + int j; + + for (j = 0; j < 3; j++) { + if (allowedTypes[i].btnIds[j] == defaultBtn) { + defaultBtnIdx = j; break; } } if (defaultBtnIdx < 0) { Tcl_AppendResult(interp, "invalid default button \"", - defaultBtn, "\"", NULL); + TkFindStateString(buttonMap, defaultBtn), + "\"", NULL); return TCL_ERROR; } break; } } - - switch (defaultBtnIdx) { - case 0: flags = MB_DEFBUTTON1; break; - case 1: flags = MB_DEFBUTTON2; break; - case 2: flags = MB_DEFBUTTON3; break; - case 3: flags = MB_DEFBUTTON4; break; - } - } else { - flags = 0; + flags = buttonFlagMap[defaultBtnIdx]; } - flags |= icon | type; + flags |= icon | type | MB_SYSTEMMODAL; + + Tcl_UtfToExternalDString(NULL, message, -1, &messageString); + Tcl_UtfToExternalDString(NULL, title, -1, &titleString); + oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL); - code = MessageBox(hWnd, message, title, flags|MB_SYSTEMMODAL); + winCode = MessageBox(hWnd, Tcl_DStringValue(&messageString), + Tcl_DStringValue(&titleString), flags); (void) Tcl_SetServiceMode(oldMode); - switch (code) { - case IDABORT: result = "abort"; break; - case IDCANCEL: result = "cancel"; break; - case IDIGNORE: result = "ignore"; break; - case IDNO: result = "no"; break; - case IDOK: result = "ok"; break; - case IDRETRY: result = "retry"; break; - case IDYES: result = "yes"; break; - default: result = ""; - } - - /* - * When we come to here interp->result may have been changed by some - * background scripts. Call Tcl_SetResult() to make sure that any stuff - * lingering in interp->result will not appear in the result of - * this command. - */ + Tcl_DStringFree(&messageString); + Tcl_DStringFree(&titleString); - Tcl_SetResult(interp, result, TCL_STATIC); + Tcl_SetResult(interp, TkFindStateString(buttonMap, winCode), TCL_STATIC); return TCL_OK; - - arg_missing: - Tcl_AppendResult(interp, "value for \"", argv[argc-1], "\" missing", - NULL); - return TCL_ERROR; } - -/* - *---------------------------------------------------------------------- - * - * ProcessCDError -- - * - * This procedure gets called if a Windows-specific error message - * has occurred during the execution of a common dialog or the - * user has pressed the CANCEL button. - * - * Results: - * If an error has indeed happened, returns a standard TCL result - * that reports the error code in string format. If the user has - * pressed the CANCEL button (dwErrorCode == 0), resets - * interp->result to the empty string. - * - * Side effects: - * interp->result is changed. - * - *---------------------------------------------------------------------- - */ -static int ProcessCDError(interp, dwErrorCode, hWnd) - Tcl_Interp * interp; /* Current interpreter. */ - DWORD dwErrorCode; /* The Windows-specific error code */ - HWND hWnd; /* window in which the error happened*/ -{ - char *string; - Tcl_ResetResult(interp); +static void +SetTkDialog(ClientData clientData) +{ + char buf[32]; + HWND hwnd; - switch(dwErrorCode) { - case 0: /* User has hit CANCEL */ - return TCL_OK; - - case CDERR_DIALOGFAILURE: string="CDERR_DIALOGFAILURE"; break; - case CDERR_STRUCTSIZE: string="CDERR_STRUCTSIZE"; break; - case CDERR_INITIALIZATION: string="CDERR_INITIALIZATION"; break; - case CDERR_NOTEMPLATE: string="CDERR_NOTEMPLATE"; break; - case CDERR_NOHINSTANCE: string="CDERR_NOHINSTANCE"; break; - case CDERR_LOADSTRFAILURE: string="CDERR_LOADSTRFAILURE"; break; - case CDERR_FINDRESFAILURE: string="CDERR_FINDRESFAILURE"; break; - case CDERR_LOADRESFAILURE: string="CDERR_LOADRESFAILURE"; break; - case CDERR_LOCKRESFAILURE: string="CDERR_LOCKRESFAILURE"; break; - case CDERR_MEMALLOCFAILURE: string="CDERR_MEMALLOCFAILURE"; break; - case CDERR_MEMLOCKFAILURE: string="CDERR_MEMLOCKFAILURE"; break; - case CDERR_NOHOOK: string="CDERR_NOHOOK"; break; - case PDERR_SETUPFAILURE: string="PDERR_SETUPFAILURE"; break; - case PDERR_PARSEFAILURE: string="PDERR_PARSEFAILURE"; break; - case PDERR_RETDEFFAILURE: string="PDERR_RETDEFFAILURE"; break; - case PDERR_LOADDRVFAILURE: string="PDERR_LOADDRVFAILURE"; break; - case PDERR_GETDEVMODEFAIL: string="PDERR_GETDEVMODEFAIL"; break; - case PDERR_INITFAILURE: string="PDERR_INITFAILURE"; break; - case PDERR_NODEVICES: string="PDERR_NODEVICES"; break; - case PDERR_NODEFAULTPRN: string="PDERR_NODEFAULTPRN"; break; - case PDERR_DNDMMISMATCH: string="PDERR_DNDMMISMATCH"; break; - case PDERR_CREATEICFAILURE: string="PDERR_CREATEICFAILURE"; break; - case PDERR_PRINTERNOTFOUND: string="PDERR_PRINTERNOTFOUND"; break; - case CFERR_NOFONTS: string="CFERR_NOFONTS"; break; - case FNERR_SUBCLASSFAILURE: string="FNERR_SUBCLASSFAILURE"; break; - case FNERR_INVALIDFILENAME: string="FNERR_INVALIDFILENAME"; break; - case FNERR_BUFFERTOOSMALL: string="FNERR_BUFFERTOOSMALL"; break; - - default: - string="unknown error"; - } + hwnd = (HWND) clientData; - Tcl_AppendResult(interp, "Win32 internal error: ", string, NULL); - return TCL_ERROR; + sprintf(buf, "0x%08x", hwnd); + Tcl_SetVar(debugInterp, "tk_dialog", buf, TCL_GLOBAL_ONLY); } diff --git a/win/tkWinEmbed.c b/win/tkWinEmbed.c index 0dc4036..1e66219 100644 --- a/win/tkWinEmbed.c +++ b/win/tkWinEmbed.c @@ -6,12 +6,12 @@ * one application can use as its main window an internal window from * another application). * - * Copyright (c) 1996 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkWinEmbed.c 1.20 97/11/05 17:47:09; + * SCCS: @(#) tkWinEmbed.c 1.21 97/11/07 21:59:08; */ #include "tkWinInt.h" @@ -126,7 +126,7 @@ TkpTestembedCmd(clientData, interp, argc, argv) * The return value is normally TCL_OK. If an error occurred (such as * if the argument does not identify a legal Windows window handle), * the return value is TCL_ERROR and an error message is left in the - * interp->result if interp is not NULL. + * the interp's result if interp is not NULL. * * Side effects: * None. @@ -159,7 +159,8 @@ TkpUseWindow(interp, tkwin, string) /* * Check if the window is a valid handle. If it is invalid, return - * TCL_ERROR and potentially leave an error message in interp->result. + * TCL_ERROR and potentially leave an error message in the interp's + * result. */ if (!IsWindow(hwnd)) { diff --git a/win/tkWinFont.c b/win/tkWinFont.c index c1d5161..d8e1647 100644 --- a/win/tkWinFont.c +++ b/win/tkWinFont.c @@ -10,28 +10,157 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkWinFont.c 1.20 97/05/14 15:45:30 + * SCCS: @(#) tkWinFont.c 1.29 98/02/04 15:55:35 */ #include "tkWinInt.h" #include "tkFont.h" /* - * The following structure represents Windows' implementation of a font. + * 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 Windows, a "font family" is uniquely identified by its face name. */ +#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 faceName; /* Face name key for this FontFamily. */ + + /* + * Derived properties. + */ + + Tcl_Encoding encoding; /* Encoding for this font family. */ + int isSymbolFont; /* Non-zero if this is a symbol font. */ + int isWideFont; /* 1 if this is a double-byte font, 0 + * otherwise. */ + BOOL (WINAPI *textOutProc)(HDC, int, int, TCHAR *, int); + /* The procedure to use to draw text after + * it has been converted from UTF-8 to the + * encoding of this font. */ + BOOL (WINAPI *getTextExtentPointProc)(HDC, TCHAR *, int, LPSIZE); + /* The procedure to use to measure text after + * it has been converted from UTF-8 to the + * encoding of this font. */ + + 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 added. 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. */ + + /* + * Cached Truetype font info. + */ + + int segCount; /* The length of the following arrays. */ + USHORT *startCount; /* Truetype information about the font, */ + USHORT *endCount; /* indicating which characters this font + * can display (malloced). The format of + * this information is (relatively) compact, + * but would take longer to search than + * indexing into the fontMap[][] table. */ +} 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. */ + HFONT hFont; /* 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 Windows' implementation of a font + * object. + */ + +#define SUBFONT_SPACE 3 +#define BASE_CHARS 128 + typedef struct WinFont { TkFont font; /* Stuff used by generic font package. Must * be first in structure. */ - HFONT hFont; /* Windows information about font. */ + 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. */ + HWND hwnd; /* Toplevel window of application that owns - * this font, used for getting HDC. */ - int widths[256]; /* Widths of first 256 chars in this font. */ + * this font, used for getting HDC for + * offscreen measurements. */ + int pixelSize; /* Original pixel size used when font was + * constructed. */ + int widths[BASE_CHARS]; /* Widths of first 128 chars in the base + * font, for handling common case. The base + * font is always used to draw characters + * between 0x0000 and 0x007f. */ } WinFont; /* - * The following structure is used as to map between the Tcl strings - * that represent the system fonts and the numbers used by Windows. + * The following structure is passed as the LPARAM when calling the font + * enumeration procedure to determine if a font can support the given + * character. + */ + +typedef struct CanUse { + HDC hdc; + WinFont *fontPtr; + Tcl_DString *nameTriedPtr; + int ch; + SubFont *subFontPtr; +} CanUse; + +/* + * 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. + */ + +static FontFamily *fontFamilyList = NULL; + +/* + * The following structure is used to map between the Tcl strings that + * represent the system fonts and the numbers used by Windows. */ static TkStateMap systemMap[] = { @@ -44,16 +173,95 @@ static TkStateMap systemMap[] = { {-1, NULL} }; -#define ABS(x) (((x) < 0) ? -(x) : (x)) +/* + * Information cached about the system at startup time. + */ + +static int platformId; +static Tcl_Encoding unicodeEncoding; +static Tcl_Encoding systemEncoding; + +/* + * Procedures used only in this file. + */ + +static FontFamily * AllocFontFamily(HDC hdc, HFONT hFont, int base); +static SubFont * CanUseFallback(HDC hdc, WinFont *fontPtr, + char *fallbackName, int ch); +static SubFont * CanUseFallbackWithAliases(HDC hdc, WinFont *fontPtr, + char *faceName, int ch, Tcl_DString *nameTriedPtr); +static int FamilyExists(HDC hdc, CONST char *faceName); +static char * FamilyOrAliasExists(HDC hdc, CONST char *faceName); +static SubFont * FindSubFontForChar(WinFont *fontPtr, int ch); +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 *familyPtr); +static HFONT GetScreenFont(CONST TkFontAttributes *faPtr, + CONST char *faceName, int pixelSize); +static void InitFont(Tk_Window tkwin, HFONT hFont, + int overstrike, WinFont *tkFontPtr); +static void InitSubFont(HDC hdc, HFONT hFont, int base, + SubFont *subFontPtr); +static int LoadFontRanges(HDC hdc, HFONT hFont, + USHORT **startCount, USHORT **endCount, + int *symbolPtr); +static void MultiFontTextOut(HDC hdc, WinFont *fontPtr, + CONST char *source, int numBytes, int x, int y); +static void ReleaseFont(WinFont *fontPtr); +static void ReleaseSubFont(SubFont *subFontPtr); +static int SeenName(CONST char *name, Tcl_DString *dsPtr); +static void SwapLong(PULONG p); +static void SwapShort(USHORT *p); +static int CALLBACK WinFontCanUseProc(ENUMLOGFONT *lfPtr, + NEWTEXTMETRIC *tmPtr, int fontType, + LPARAM lParam); +static int CALLBACK WinFontExistProc(ENUMLOGFONT *lfPtr, + NEWTEXTMETRIC *tmPtr, int fontType, + LPARAM lParam); +static int CALLBACK WinFontFamilyEnumProc(ENUMLOGFONT *lfPtr, + NEWTEXTMETRIC *tmPtr, int fontType, + LPARAM lParam); + +/* + *------------------------------------------------------------------------- + * + * TkpFontPkgInit -- + * + * This procedure is called when an application is created. It + * initializes all the structures that are used by the + * platform-dependant code on a per application basis. + * + * Results: + * None. + * + * Side effects: + * + * None. + * + *------------------------------------------------------------------------- + */ + +void +TkpFontPkgInit( + TkMainInfo *mainPtr) /* The application being created. */ +{ + OSVERSIONINFO os; -static TkFont * AllocFont _ANSI_ARGS_((TkFont *tkFontPtr, - Tk_Window tkwin, HFONT hFont)); -static char * GetProperty _ANSI_ARGS_((CONST TkFontAttributes *faPtr, - CONST char *option)); -static int CALLBACK WinFontFamilyEnumProc _ANSI_ARGS_((ENUMLOGFONT *elfPtr, - NEWTEXTMETRIC *ntmPtr, int fontType, - LPARAM lParam)); + os.dwOSVersionInfoSize = sizeof(os); + GetVersionEx(&os); + platformId = os.dwPlatformId; + unicodeEncoding = Tcl_GetEncoding(NULL, "unicode"); + if (platformId == VER_PLATFORM_WIN32_NT) { + /* + * If running NT, then we will be calling some Unicode functions + * explictly. So, even if the Tcl system encoding isn't Unicode, + * make sure we convert to/from the Unicode char set. + */ + systemEncoding = unicodeEncoding; + } +} /* *--------------------------------------------------------------------------- @@ -76,29 +284,29 @@ static int CALLBACK WinFontFamilyEnumProc _ANSI_ARGS_((ENUMLOGFONT *elfPtr, * the contents of the generic TkFont before calling TkpDeleteFont(). * * Side effects: - * None. + * Memory allocated. * *--------------------------------------------------------------------------- */ TkFont * -TkpGetNativeFont(tkwin, name) - Tk_Window tkwin; /* For display where font will be used. */ - CONST char *name; /* Platform-specific font name. */ +TkpGetNativeFont( + Tk_Window tkwin, /* For display where font will be used. */ + CONST char *name) /* Platform-specific font name. */ { int object; - HFONT hFont; - + WinFont *fontPtr; + object = TkFindStateNum(NULL, NULL, systemMap, name); if (object < 0) { return NULL; } - hFont = GetStockObject(object); - if (hFont == NULL) { - panic("TkpGetNativeFont: can't allocate stock font"); - } - return AllocFont(NULL, tkwin, hFont); + tkwin = (Tk_Window) ((TkWindow *) tkwin)->mainPtr->winPtr; + fontPtr = (WinFont *) ckalloc(sizeof(WinFont)); + InitFont(tkwin, GetStockObject(object), 0, fontPtr); + + return (TkFont *) fontPtr; } /* @@ -125,80 +333,86 @@ TkpGetNativeFont(tkwin, name) * the contents of the generic TkFont before calling TkpDeleteFont(). * * Side effects: - * None. + * Memory allocated. * *--------------------------------------------------------------------------- */ + TkFont * -TkpGetFontFromAttributes(tkFontPtr, tkwin, faPtr) - TkFont *tkFontPtr; /* If non-NULL, store the information in +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. */ + Tk_Window tkwin, /* For display where font will be used. */ + CONST TkFontAttributes *faPtr) + /* Set of attributes to match. */ { - LOGFONT lf; + int i, j; + HDC hdc; + HWND hwnd; HFONT hFont; Window window; - HWND hwnd; - HDC hdc; + WinFont *fontPtr; + char ***fontFallbacks; + char *faceName, *fallback, *actualName; - window = Tk_WindowId(((TkWindow *) tkwin)->mainPtr->winPtr); - hwnd = (window == None) ? NULL : TkWinGetHWND(window); - - hdc = GetDC(hwnd); - lf.lfHeight = -faPtr->pointsize; - if (lf.lfHeight < 0) { - lf.lfHeight = MulDiv(lf.lfHeight, - 254 * WidthOfScreen(Tk_Screen(tkwin)), - 720 * WidthMMOfScreen(Tk_Screen(tkwin))); - } - lf.lfWidth = 0; - lf.lfEscapement = 0; - lf.lfOrientation = 0; - lf.lfWeight = (faPtr->weight == TK_FW_NORMAL) ? FW_NORMAL : FW_BOLD; - lf.lfItalic = faPtr->slant; - lf.lfUnderline = faPtr->underline; - lf.lfStrikeOut = faPtr->overstrike; - lf.lfCharSet = DEFAULT_CHARSET; - lf.lfOutPrecision = OUT_DEFAULT_PRECIS; - lf.lfClipPrecision = CLIP_DEFAULT_PRECIS; - lf.lfQuality = DEFAULT_QUALITY; - lf.lfPitchAndFamily = DEFAULT_PITCH | FF_DONTCARE; - if (faPtr->family == NULL) { - lf.lfFaceName[0] = '\0'; - } else { - lstrcpyn(lf.lfFaceName, faPtr->family, sizeof(lf.lfFaceName)); - } - ReleaseDC(hwnd, hdc); + tkwin = (Tk_Window) ((TkWindow *) tkwin)->mainPtr->winPtr; + window = Tk_WindowId(tkwin); + hwnd = (window == None) ? NULL : TkWinGetHWND(window); + hdc = GetDC(hwnd); /* - * Replace the standard X and Mac family names with the names that - * Windows likes. + * Algorithm to get the closest font name to the one requested. + * + * try fontname + * try all aliases for fontname + * foreach fallback for fontname + * try the fallback + * try all aliases for the fallback */ - if ((stricmp(lf.lfFaceName, "Times") == 0) - || (stricmp(lf.lfFaceName, "New York") == 0)) { - strcpy(lf.lfFaceName, "Times New Roman"); - } else if ((stricmp(lf.lfFaceName, "Courier") == 0) - || (stricmp(lf.lfFaceName, "Monaco") == 0)) { - strcpy(lf.lfFaceName, "Courier New"); - } else if ((stricmp(lf.lfFaceName, "Helvetica") == 0) - || (stricmp(lf.lfFaceName, "Geneva") == 0)) { - strcpy(lf.lfFaceName, "Arial"); - } - - hFont = CreateFontIndirect(&lf); - if (hFont == NULL) { - hFont = GetStockObject(SYSTEM_FONT); - if (hFont == NULL) { - panic("TkpGetFontFromAttributes: cannot get system font"); + faceName = faPtr->family; + if (faceName != NULL) { + actualName = FamilyOrAliasExists(hdc, faceName); + if (actualName != NULL) { + faceName = actualName; + goto found; } + fontFallbacks = TkFontGetFallbacks(); + for (i = 0; fontFallbacks[i] != NULL; i++) { + for (j = 0; (fallback = fontFallbacks[i][j]) != NULL; j++) { + if (strcasecmp(faceName, fallback) == 0) { + break; + } + } + if (fallback != NULL) { + for (j = 0; (fallback = fontFallbacks[i][j]) != NULL; j++) { + actualName = FamilyOrAliasExists(hdc, fallback); + if (actualName != NULL) { + faceName = actualName; + goto found; + } + } + } + } + } + + found: + ReleaseDC(hwnd, hdc); + + hFont = GetScreenFont(faPtr, faceName, TkFontGetPixels(tkwin, faPtr->size)); + if (tkFontPtr == NULL) { + fontPtr = (WinFont *) ckalloc(sizeof(WinFont)); + } else { + fontPtr = (WinFont *) tkFontPtr; + ReleaseFont(fontPtr); } - return AllocFont(tkFontPtr, tkwin, hFont); + InitFont(tkwin, hFont, faPtr->overstrike, fontPtr); + + return (TkFont *) fontPtr; } /* @@ -221,26 +435,25 @@ TkpGetFontFromAttributes(tkFontPtr, tkwin, faPtr) */ void -TkpDeleteFont(tkFontPtr) - TkFont *tkFontPtr; /* Token of font to be deleted. */ +TkpDeleteFont( + TkFont *tkFontPtr) /* Token of font to be deleted. */ { WinFont *fontPtr; fontPtr = (WinFont *) tkFontPtr; - DeleteObject(fontPtr->hFont); - ckfree((char *) fontPtr); + ReleaseFont(fontPtr); } /* *--------------------------------------------------------------------------- * - * TkpGetFontFamilies, WinFontEnumFamilyProc -- + * TkpGetFontFamilies, WinFontFamilyEnumProc -- * * Return information about the font families that are available * on the display of the given window. * * Results: - * interp->result is modified to hold a list of all the available + * Modifies interp's result object to hold a list of all the available * font families. * * Side effects: @@ -250,40 +463,103 @@ TkpDeleteFont(tkFontPtr) */ void -TkpGetFontFamilies(interp, tkwin) - Tcl_Interp *interp; /* Interp to hold result. */ - Tk_Window tkwin; /* For display to query. */ +TkpGetFontFamilies( + Tcl_Interp *interp, /* Interp to hold result. */ + Tk_Window tkwin) /* For display to query. */ { - Window window; - HWND hwnd; HDC hdc; + HWND hwnd; + Window window; + + window = Tk_WindowId(tkwin); + hwnd = (window == None) ? NULL : TkWinGetHWND(window); + hdc = GetDC(hwnd); - window = Tk_WindowId(tkwin); - hwnd = (window == (Window) NULL) ? NULL : TkWinGetHWND(window); + /* + * On any version NT, there may fonts with international names. + * Use the NT-only Unicode version of EnumFontFamilies to get the + * font names. If we used the ANSI version on a non-internationalized + * version of NT, we would get font names with '?' replacing all + * the international characters. + * + * On a non-internationalized verson of 95, fonts with international + * names are not allowed, so the ANSI version of EnumFontFamilies will + * work. On an internationalized version of 95, there may be fonts with + * international names; the ANSI version will work, fetching the + * name in the system code page. Can't use the Unicode version of + * EnumFontFamilies because it only exists under NT. + */ - hdc = GetDC(hwnd); - EnumFontFamilies(hdc, NULL, (FONTENUMPROC) WinFontFamilyEnumProc, - (LPARAM) interp); + if (platformId == VER_PLATFORM_WIN32_NT) { + EnumFontFamiliesW(hdc, NULL, (FONTENUMPROCW) WinFontFamilyEnumProc, + (LPARAM) interp); + } else { + EnumFontFamiliesA(hdc, NULL, (FONTENUMPROCA) WinFontFamilyEnumProc, + (LPARAM) interp); + } ReleaseDC(hwnd, hdc); } -/* ARGSUSED */ - static int CALLBACK -WinFontFamilyEnumProc(elfPtr, ntmPtr, fontType, lParam) - ENUMLOGFONT *elfPtr; /* Logical-font data. */ - NEWTEXTMETRIC *ntmPtr; /* Physical-font data (not used). */ - int fontType; /* Type of font (not used). */ - LPARAM lParam; /* Interp to hold result. */ +WinFontFamilyEnumProc( + ENUMLOGFONT *lfPtr, /* Logical-font data. */ + NEWTEXTMETRIC *tmPtr, /* Physical-font data (not used). */ + int fontType, /* Type of font (not used). */ + LPARAM lParam) /* Result object to hold result. */ { + char *faceName; + Tcl_DString faceString; + Tcl_Obj *strPtr; Tcl_Interp *interp; interp = (Tcl_Interp *) lParam; - Tcl_AppendElement(interp, elfPtr->elfLogFont.lfFaceName); + faceName = lfPtr->elfLogFont.lfFaceName; + Tcl_ExternalToUtfDString(systemEncoding, faceName, -1, &faceString); + strPtr = Tcl_NewStringObj(Tcl_DStringValue(&faceString), + Tcl_DStringLength(&faceString)); + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), strPtr); + Tcl_DStringFree(&faceString); return 1; } /* + *------------------------------------------------------------------------- + * + * 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, /* Interp to hold result. */ + Tk_Font tkfont) /* Font object to query. */ +{ + int i; + WinFont *fontPtr; + FontFamily *familyPtr; + Tcl_Obj *resultPtr, *strPtr; + + resultPtr = Tcl_GetObjResult(interp); + fontPtr = (WinFont *) tkfont; + for (i = 0; i < fontPtr->numSubFonts; i++) { + familyPtr = fontPtr->subFontArray[i].familyPtr; + strPtr = Tcl_NewStringObj(familyPtr->faceName, -1); + Tcl_ListObjAppendElement(NULL, resultPtr, strPtr); + } +} + +/* *--------------------------------------------------------------------------- * * Tk_MeasureChars -- @@ -304,83 +580,154 @@ WinFontFamilyEnumProc(elfPtr, ntmPtr, fontType, lParam) * *--------------------------------------------------------------------------- */ + int -Tk_MeasureChars(tkfont, source, numChars, maxLength, flags, lengthPtr) - Tk_Font tkfont; /* Font in which characters will be drawn. */ - CONST char *source; /* Characters to be displayed. Need not be +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 numChars; /* Maximum number of characters to consider + int numBytes, /* Maximum number of bytes to consider * from source string. */ - 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 + 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: + 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 + int *lengthPtr) /* Filled with x-location just after the * terminating character. */ { - WinFont *fontPtr; HDC hdc; - HFONT hFont; - int curX, curIdx; + HFONT oldFont; + WinFont *fontPtr; + int curX, curByte; + SubFont *lastSubFontPtr; /* - * On the authority of the Gates Empire, Windows does not use kerning + * According to Microsoft tech support, Windows 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" + * of characters and add up the widths w/o any "off-by-one-pixel" * errors. */ fontPtr = (WinFont *) tkfont; hdc = GetDC(fontPtr->hwnd); - hFont = SelectObject(hdc, fontPtr->hFont); + lastSubFontPtr = &fontPtr->subFontArray[0]; + oldFont = SelectObject(hdc, lastSubFontPtr->hFont); - if (numChars == 0) { + if (numBytes == 0) { curX = 0; - curIdx = 0; - } else if (maxLength <= 0) { + curByte = 0; + } else if (maxLength < 0) { + Tcl_UniChar ch; SIZE size; + FontFamily *familyPtr; + Tcl_DString runString; + SubFont *thisSubFontPtr; + CONST char *p, *end, *next; - GetTextExtentPoint(hdc, source, numChars, &size); - curX = size.cx; - curIdx = numChars; + /* + * 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); + if (thisSubFontPtr != lastSubFontPtr) { + familyPtr = lastSubFontPtr->familyPtr; + Tcl_UtfToExternalDString(familyPtr->encoding, source, + p - source, &runString); + (*familyPtr->getTextExtentPointProc)(hdc, + Tcl_DStringValue(&runString), + Tcl_DStringLength(&runString) >> familyPtr->isWideFont, + &size); + curX += size.cx; + Tcl_DStringFree(&runString); + lastSubFontPtr = thisSubFontPtr; + source = p; + + SelectObject(hdc, lastSubFontPtr->hFont); + } + p = next; + } + familyPtr = lastSubFontPtr->familyPtr; + Tcl_UtfToExternalDString(familyPtr->encoding, source, p - source, + &runString); + (*familyPtr->getTextExtentPointProc)(hdc, Tcl_DStringValue(&runString), + Tcl_DStringLength(&runString) >> familyPtr->isWideFont, + &size); + curX += size.cx; + Tcl_DStringFree(&runString); + curByte = numBytes; } else { - int newX, termX, sawNonSpace; - CONST char *term, *end, *p; - int ch; + Tcl_UniChar ch; + SIZE size; + char buf[16]; + FontFamily *familyPtr; + SubFont *thisSubFontPtr; + CONST char *term, *end, *p, *next; + int newX, termX, sawNonSpace, srcRead, dstWrote; + + /* + * How many chars will fit in the space allotted? + * This first version may be inefficient because it measures + * every character individually. There is a function call that + * can measure multiple characters at once and return the + * offset of each of them, but it only works on NT, even though + * the documentation claims it works for 95. + */ - ch = UCHAR(*source); + next = source + Tcl_UtfToUniChar(source, &ch); newX = curX = termX = 0; term = source; - end = source + numChars; + end = source + numBytes; - sawNonSpace = !isspace(ch); + sawNonSpace = (ch > 255) || !isspace(ch); for (p = source; ; ) { - newX += fontPtr->widths[ch]; + if (ch < BASE_CHARS) { + newX += fontPtr->widths[ch]; + } else { + thisSubFontPtr = FindSubFontForChar(fontPtr, ch); + if (thisSubFontPtr != lastSubFontPtr) { + SelectObject(hdc, thisSubFontPtr->hFont); + lastSubFontPtr = thisSubFontPtr; + } + familyPtr = lastSubFontPtr->familyPtr; + Tcl_UtfToExternal(NULL, familyPtr->encoding, p, next - p, + 0, NULL, buf, sizeof(buf), &srcRead, &dstWrote, NULL); + (*familyPtr->getTextExtentPointProc)(hdc, buf, + dstWrote >> familyPtr->isWideFont, &size); + newX += size.cx; + } if (newX > maxLength) { break; } curX = newX; - p++; + p = next; if (p >= end) { term = end; termX = curX; break; } - ch = UCHAR(*p); - if (isspace(ch)) { + next += Tcl_UtfToUniChar(next, &ch); + if ((ch < 256) && isspace(ch)) { if (sawNonSpace) { term = p; termX = curX; @@ -404,13 +751,13 @@ Tk_MeasureChars(tkfont, source, numChars, maxLength, flags, lengthPtr) */ curX = newX; - p++; + p += Tcl_UtfToUniChar(p, &ch); } if ((flags & TK_AT_LEAST_ONE) && (term == source) && (p < end)) { term = p; termX = curX; if (term == source) { - term++; + term += Tcl_UtfToUniChar(term, &ch); termX = newX; } } else if ((p >= end) || !(flags & TK_WHOLE_WORDS)) { @@ -419,14 +766,14 @@ Tk_MeasureChars(tkfont, source, numChars, maxLength, flags, lengthPtr) } curX = termX; - curIdx = term - source; + curByte = term - source; } - SelectObject(hdc, hFont); + SelectObject(hdc, oldFont); ReleaseDC(fontPtr->hwnd, hdc); *lengthPtr = curX; - return curIdx; + return curByte; } /* @@ -446,27 +793,26 @@ Tk_MeasureChars(tkfont, source, numChars, maxLength, flags, lengthPtr) */ void -Tk_DrawChars(display, drawable, gc, tkfont, source, numChars, x, y) - 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; +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; /* Characters to be displayed. Need not be + 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 numChars; /* Number of characters in string. */ - int x, y; /* Coordinates at which to place origin of + int numBytes, /* Number of bytes in string. */ + int x, int y) /* Coordinates at which to place origin of * string when drawing. */ { HDC dc; - HFONT hFont; - TkWinDCState state; WinFont *fontPtr; + TkWinDCState state; fontPtr = (WinFont *) gc->font; display->request++; @@ -503,18 +849,16 @@ Tk_DrawChars(display, drawable, gc, tkfont, source, numChars, x, y) SetBrushOrgEx(dc, gc->ts_x_origin, gc->ts_y_origin, NULL); oldBrush = SelectObject(dc, stipple); - SetTextAlign(dcMem, TA_LEFT | TA_TOP); + SetTextAlign(dcMem, TA_LEFT | TA_BASELINE); SetTextColor(dcMem, gc->foreground); SetBkMode(dcMem, TRANSPARENT); SetBkColor(dcMem, RGB(0, 0, 0)); - hFont = SelectObject(dcMem, fontPtr->hFont); - /* * Compute the bounding box and create a compatible bitmap. */ - GetTextExtentPoint(dcMem, source, numChars, &size); + GetTextExtentPoint(dcMem, source, numBytes, &size); GetTextMetrics(dcMem, &tm); size.cx -= tm.tmOverhang; bitmap = CreateCompatibleBitmap(dc, size.cx, size.cy); @@ -529,11 +873,11 @@ Tk_DrawChars(display, drawable, gc, tkfont, source, numChars, x, y) */ PatBlt(dcMem, 0, 0, size.cx, size.cy, BLACKNESS); - TextOut(dcMem, 0, 0, source, numChars); + MultiFontTextOut(dc, fontPtr, source, numBytes, x, y); BitBlt(dc, x, y - tm.tmAscent, size.cx, size.cy, dcMem, 0, 0, 0xEA02E9); PatBlt(dcMem, 0, 0, size.cx, size.cy, WHITENESS); - TextOut(dcMem, 0, 0, source, numChars); + MultiFontTextOut(dc, fontPtr, source, numBytes, x, y); BitBlt(dc, x, y - tm.tmAscent, size.cx, size.cy, dcMem, 0, 0, 0x8A0E06); @@ -541,7 +885,6 @@ Tk_DrawChars(display, drawable, gc, tkfont, source, numChars, x, y) * Destroy the temporary bitmap and restore the device context. */ - SelectObject(dcMem, hFont); SelectObject(dcMem, oldBitmap); DeleteObject(bitmap); DeleteDC(dcMem); @@ -551,93 +894,1454 @@ Tk_DrawChars(display, drawable, gc, tkfont, source, numChars, x, y) SetTextAlign(dc, TA_LEFT | TA_BASELINE); SetTextColor(dc, gc->foreground); SetBkMode(dc, TRANSPARENT); - hFont = SelectObject(dc, fontPtr->hFont); - TextOut(dc, x, y, source, numChars); - SelectObject(dc, hFont); + MultiFontTextOut(dc, fontPtr, source, numBytes, x, y); } TkWinReleaseDrawableDC(drawable, dc, &state); } /* - *--------------------------------------------------------------------------- + *------------------------------------------------------------------------- * - * AllocFont -- + * MultiFontTextOut -- * - * Helper for TkpGetNativeFont() and TkpGetFontFromAttributes(). - * Allocates and intializes the memory for a new TkFont that - * wraps the platform-specific data. + * Helper function for Tk_DrawChars. Draws characters, using the + * various screen fonts in fontPtr to draw multilingual characters. + * Note: No bidirectional support. * * Results: - * Returns pointer to newly constructed TkFont. + * None. + * + * Side effects: + * Information gets drawn on the screen. + * Contents of fontPtr may be modified if more subfonts were loaded + * in order to draw all the multilingual characters in the given + * string. + * + *------------------------------------------------------------------------- + */ + +static void +MultiFontTextOut( + HDC hdc, /* HDC to draw into. */ + WinFont *fontPtr, /* Contains set of fonts to use when drawing + * following string. */ + CONST char *source, /* Potentially multilingual UTF-8 string. */ + int numBytes, /* Length of string in bytes. */ + int x, int y) /* Coordinates at which to place origin * + * of string when drawing. */ +{ + Tcl_UniChar ch; + SIZE size; + HFONT oldFont; + FontFamily *familyPtr; + Tcl_DString runString; + CONST char *p, *end, *next; + SubFont *lastSubFontPtr, *thisSubFontPtr; + + lastSubFontPtr = &fontPtr->subFontArray[0]; + oldFont = SelectObject(hdc, lastSubFontPtr->hFont); + + end = source + numBytes; + for (p = source; p < end; ) { + next = p + Tcl_UtfToUniChar(p, &ch); + thisSubFontPtr = FindSubFontForChar(fontPtr, ch); + if (thisSubFontPtr != lastSubFontPtr) { + if (p > source) { + familyPtr = lastSubFontPtr->familyPtr; + Tcl_UtfToExternalDString(familyPtr->encoding, source, + p - source, &runString); + (*familyPtr->textOutProc)(hdc, x, y, + Tcl_DStringValue(&runString), + Tcl_DStringLength(&runString) >> familyPtr->isWideFont); + (*familyPtr->getTextExtentPointProc)(hdc, + Tcl_DStringValue(&runString), + Tcl_DStringLength(&runString) >> familyPtr->isWideFont, + &size); + x += size.cx; + Tcl_DStringFree(&runString); + } + lastSubFontPtr = thisSubFontPtr; + source = p; + SelectObject(hdc, lastSubFontPtr->hFont); + } + p = next; + } + if (p > source) { + familyPtr = lastSubFontPtr->familyPtr; + Tcl_UtfToExternalDString(familyPtr->encoding, source, p - source, + &runString); + (*familyPtr->textOutProc)(hdc, x, y, Tcl_DStringValue(&runString), + Tcl_DStringLength(&runString) >> familyPtr->isWideFont); + Tcl_DStringFree(&runString); + } + SelectObject(hdc, oldFont); +} + +/* + *--------------------------------------------------------------------------- + * + * InitFont -- + * + * Helper for TkpGetNativeFont() and TkpGetFontFromAttributes(). + * Initializes the memory for a new WinFont 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 + * WinFont 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 TkFont * -AllocFont(tkFontPtr, tkwin, hFont) - 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. */ - HFONT hFont; /* Windows information about font. */ +static void +InitFont( + Tk_Window tkwin, /* Main window of interp in which font will + * be used, for getting HDC. */ + HFONT hFont, /* Windows token for font. */ + int overstrike, /* The overstrike attribute of logfont used + * to allocate this font. For some reason, + * the TEXTMETRICs may contain incorrect info + * in the tmStruckOut field. */ + WinFont *fontPtr) /* Filled with information constructed from + * the above arguments. */ { - HWND hwnd; - WinFont *fontPtr; HDC hdc; + HWND hwnd; + HFONT oldFont; TEXTMETRIC tm; Window window; - char buf[LF_FACESIZE]; + TkFontMetrics *fmPtr; + Tcl_Encoding encoding; + Tcl_DString faceString; TkFontAttributes *faPtr; + char buf[LF_FACESIZE * sizeof(WCHAR)]; + + window = Tk_WindowId(tkwin); + hwnd = (window == None) ? NULL : TkWinGetHWND(window); + hdc = GetDC(hwnd); + oldFont = SelectObject(hdc, hFont); + + GetTextMetrics(hdc, &tm); - if (tkFontPtr != NULL) { - fontPtr = (WinFont *) tkFontPtr; - DeleteObject(fontPtr->hFont); + /* + * On any version NT, there may fonts with international names. + * Use the NT-only Unicode version of GetTextFace to get the font's + * name. If we used the ANSI version on a non-internationalized + * version of NT, we would get a font name with '?' replacing all + * the international characters. + * + * On a non-internationalized verson of 95, fonts with international + * names are not allowed, so the ANSI version of GetTextFace will work. + * On an internationalized version of 95, there may be fonts with + * international names; the ANSI version will work, fetching the + * name in the international system code page. Can't use the Unicode + * version of GetTextFace because it only exists under NT. + */ + + if (platformId == VER_PLATFORM_WIN32_NT) { + GetTextFaceW(hdc, LF_FACESIZE, (WCHAR *) buf); } else { - fontPtr = (WinFont *) ckalloc(sizeof(WinFont)); + GetTextFaceA(hdc, LF_FACESIZE, (char *) buf); } - - window = Tk_WindowId(((TkWindow *) tkwin)->mainPtr->winPtr); - hwnd = (window == None) ? NULL : TkWinGetHWND(window); - - hdc = GetDC(hwnd); - hFont = SelectObject(hdc, hFont); - GetTextFace(hdc, sizeof(buf), buf); - GetTextMetrics(hdc, &tm); - GetCharWidth(hdc, 0, 255, fontPtr->widths); + Tcl_ExternalToUtfDString(systemEncoding, buf, -1, &faceString); fontPtr->font.fid = (Font) fontPtr; - faPtr = &fontPtr->font.fa; - faPtr->family = Tk_GetUid(buf); - faPtr->pointsize = MulDiv(tm.tmHeight - tm.tmInternalLeading, - 720 * WidthMMOfScreen(Tk_Screen(tkwin)), - 254 * WidthOfScreen(Tk_Screen(tkwin))); + faPtr = &fontPtr->font.fa; + faPtr->family = Tk_GetUid(Tcl_DStringValue(&faceString)); + faPtr->size = TkFontGetPoints(tkwin, -(tm.tmHeight - tm.tmInternalLeading)); faPtr->weight = (tm.tmWeight > FW_MEDIUM) ? TK_FW_BOLD : TK_FW_NORMAL; faPtr->slant = (tm.tmItalic != 0) ? TK_FS_ITALIC : TK_FS_ROMAN; faPtr->underline = (tm.tmUnderlined != 0) ? 1 : 0; - faPtr->overstrike = (tm.tmStruckOut != 0) ? 1 : 0; + faPtr->overstrike = overstrike; + + fmPtr = &fontPtr->font.fm; + fmPtr->ascent = tm.tmAscent; + fmPtr->descent = tm.tmDescent; + fmPtr->maxWidth = tm.tmMaxCharWidth; + fmPtr->fixed = !(tm.tmPitchAndFamily & TMPF_FIXED_PITCH); - fontPtr->font.fm.ascent = tm.tmAscent; - fontPtr->font.fm.descent = tm.tmDescent; - fontPtr->font.fm.maxWidth = tm.tmMaxCharWidth; - fontPtr->font.fm.fixed = !(tm.tmPitchAndFamily & TMPF_FIXED_PITCH); + fontPtr->hwnd = hwnd; + fontPtr->pixelSize = tm.tmHeight - tm.tmInternalLeading; - hFont = SelectObject(hdc, hFont); + fontPtr->numSubFonts = 1; + fontPtr->subFontArray = fontPtr->staticSubFonts; + InitSubFont(hdc, hFont, 1, &fontPtr->subFontArray[0]); + + encoding = fontPtr->subFontArray[0].familyPtr->encoding; + if (encoding == unicodeEncoding) { + GetCharWidthW(hdc, 0, BASE_CHARS - 1, fontPtr->widths); + } else { + GetCharWidthA(hdc, 0, BASE_CHARS - 1, fontPtr->widths); + } + Tcl_DStringFree(&faceString); + + SelectObject(hdc, oldFont); ReleaseDC(hwnd, hdc); +} + +/* + *------------------------------------------------------------------------- + * + * ReleaseFont -- + * + * Called to release the windows-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( + WinFont *fontPtr) /* The font to delete. */ +{ + int i; - fontPtr->hFont = hFont; - fontPtr->hwnd = hwnd; + for (i = 0; i < fontPtr->numSubFonts; i++) { + ReleaseSubFont(&fontPtr->subFontArray[i]); + } + if (fontPtr->subFontArray != fontPtr->staticSubFonts) { + ckfree((char *) 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. + * + *------------------------------------------------------------------------- + */ - return (TkFont *) fontPtr; +static void +InitSubFont( + HDC hdc, /* HDC in which font can be selected. */ + HFONT hFont, /* 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->hFont = hFont; + subFontPtr->familyPtr = AllocFontFamily(hdc, hFont, 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( + SubFont *subFontPtr) /* The SubFont to delete. */ +{ + DeleteObject(subFontPtr->hFont); + 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( + HDC hdc, /* HDC in which font can be selected. */ + HFONT hFont, /* 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. */ +{ + Tk_Uid faceName; + FontFamily *familyPtr; + Tcl_DString faceString; + Tcl_Encoding encoding; + char buf[LF_FACESIZE * sizeof(WCHAR)]; + + hFont = SelectObject(hdc, hFont); + if (platformId == VER_PLATFORM_WIN32_NT) { + GetTextFaceW(hdc, LF_FACESIZE, (WCHAR *) buf); + } else { + GetTextFaceA(hdc, LF_FACESIZE, (char *) buf); + } + Tcl_ExternalToUtfDString(systemEncoding, buf, -1, &faceString); + faceName = Tk_GetUid(Tcl_DStringValue(&faceString)); + Tcl_DStringFree(&faceString); + hFont = SelectObject(hdc, hFont); + + familyPtr = fontFamilyList; + for ( ; familyPtr != NULL; familyPtr = familyPtr->nextPtr) { + if (familyPtr->faceName == faceName) { + familyPtr->refCount++; + return familyPtr; + } + } + + familyPtr = (FontFamily *) ckalloc(sizeof(FontFamily)); + memset(familyPtr, 0, sizeof(FontFamily)); + familyPtr->nextPtr = fontFamilyList; + fontFamilyList = familyPtr; + + /* + * Set key for this FontFamily. + */ + + familyPtr->faceName = faceName; + + /* + * 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; + + familyPtr->segCount = LoadFontRanges(hdc, hFont, &familyPtr->startCount, + &familyPtr->endCount, &familyPtr->isSymbolFont); + + encoding = NULL; + if (familyPtr->isSymbolFont != 0) { + /* + * Symbol fonts are handled specially. For instance, Unicode 0393 + * (GREEK CAPITAL GAMMA) must be mapped to Symbol character 0047 + * (GREEK CAPITAL GAMMA), because the Symbol font doesn't have a + * GREEK CAPITAL GAMMA at location 0393. If Tk interpreted the + * Symbol font using the Unicode encoding, it would decide that + * the Symbol font has no GREEK CAPITAL GAMMA, because the Symbol + * encoding (of course) reports that character 0393 doesn't exist. + * + * With non-symbol Windows fonts, such as Times New Roman, if the + * font has a GREEK CAPITAL GAMMA, it will be found in the correct + * Unicode location (0393); the GREEK CAPITAL GAMMA will not be off + * hiding at some other location. + */ + + encoding = Tcl_GetEncoding(NULL, faceName); + } + + if (encoding == NULL) { + encoding = Tcl_GetEncoding(NULL, "unicode"); + familyPtr->textOutProc = + (BOOL (WINAPI *)(HDC, int, int, TCHAR *, int)) TextOutW; + familyPtr->getTextExtentPointProc = + (BOOL (WINAPI *)(HDC, TCHAR *, int, LPSIZE)) GetTextExtentPointW; + familyPtr->isWideFont = 1; + } else { + familyPtr->textOutProc = + (BOOL (WINAPI *)(HDC, int, int, TCHAR *, int)) TextOutA; + familyPtr->getTextExtentPointProc = + (BOOL (WINAPI *)(HDC, TCHAR *, int, LPSIZE)) GetTextExtentPointA; + familyPtr->isWideFont = 0; + } + + familyPtr->encoding = encoding; + + return familyPtr; } + +/* + *------------------------------------------------------------------------- + * + * FreeFontFamily -- + * + * Called to free a 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. */ +{ + int i; + FontFamily **familyPtrPtr; + + if (familyPtr == NULL) { + return; + } + familyPtr->refCount--; + if (familyPtr->refCount > 0) { + return; + } + for (i = 0; i < FONTMAP_PAGES; i++) { + if (familyPtr->fontMap[i] != NULL) { + ckfree(familyPtr->fontMap[i]); + } + } + if (familyPtr->startCount != NULL) { + ckfree((char *) familyPtr->startCount); + } + if (familyPtr->endCount != NULL) { + ckfree((char *) familyPtr->endCount); + } + if (familyPtr->encoding != unicodeEncoding) { + Tcl_FreeEncoding(familyPtr->encoding); + } + + /* + * Delete from list. + */ + + for (familyPtrPtr = &fontFamilyList; ; ) { + if (*familyPtrPtr == familyPtr) { + *familyPtrPtr = familyPtr->nextPtr; + break; + } + familyPtrPtr = &(*familyPtrPtr)->nextPtr; + } + + ckfree((char *) 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. + * + *------------------------------------------------------------------------- + */ +static SubFont * +FindSubFontForChar( + WinFont *fontPtr, /* The font object with which the character + * will be displayed. */ + int ch) /* The Unicode character to be displayed. */ +{ + HDC hdc; + int i, j, k; + CanUse canUse; + char **aliases, **anyFallbacks; + char ***fontFallbacks; + char *fallbackName; + SubFont *subFontPtr; + Tcl_DString ds; + + if (ch < BASE_CHARS) { + return &fontPtr->subFontArray[0]; + } + + for (i = 0; i < fontPtr->numSubFonts; i++) { + if (FontMapLookup(&fontPtr->subFontArray[i], ch)) { + return &fontPtr->subFontArray[i]; + } + } + + /* + * 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); + hdc = GetDC(fontPtr->hwnd); + + aliases = TkFontGetAliasList(fontPtr->font.fa.family); + + fontFallbacks = TkFontGetFallbacks(); + for (i = 0; fontFallbacks[i] != NULL; i++) { + for (j = 0; fontFallbacks[i][j] != NULL; j++) { + fallbackName = fontFallbacks[i][j]; + if (strcasecmp(fallbackName, fontPtr->font.fa.family) == 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(aliases[k], fallbackName) == 0) { + goto tryfallbacks; + } + } + } + } + continue; + + /* + * ...then see if we can use one of the fallbacks, or an + * alias for one of the fallbacks. + */ + + tryfallbacks: + for (j = 0; fontFallbacks[i][j] != NULL; j++) { + fallbackName = fontFallbacks[i][j]; + subFontPtr = CanUseFallbackWithAliases(hdc, fontPtr, fallbackName, + ch, &ds); + if (subFontPtr != NULL) { + goto end; + } + } + } + + /* + * See if we can use something from the global fallback list. + */ + + anyFallbacks = TkFontGetGlobalClass(); + for (i = 0; anyFallbacks[i] != NULL; i++) { + fallbackName = anyFallbacks[i]; + subFontPtr = CanUseFallbackWithAliases(hdc, fontPtr, fallbackName, + ch, &ds); + if (subFontPtr != NULL) { + goto end; + } + } + + /* + * Try all face names available in the whole system until we + * find one that can be used. + */ + + canUse.hdc = hdc; + canUse.fontPtr = fontPtr; + canUse.nameTriedPtr = &ds; + canUse.ch = ch; + canUse.subFontPtr = NULL; + if (platformId == VER_PLATFORM_WIN32_NT) { + EnumFontFamiliesW(hdc, NULL, (FONTENUMPROCW) WinFontCanUseProc, + (LPARAM) &canUse); + } else { + EnumFontFamiliesA(hdc, NULL, (FONTENUMPROCA) WinFontCanUseProc, + (LPARAM) &canUse); + } + subFontPtr = canUse.subFontPtr; + + end: + Tcl_DStringFree(&ds); + + if (subFontPtr == NULL) { + /* + * No font can display this character. We will use the base font + * and have it display the "unknown" character. + */ + + subFontPtr = &fontPtr->subFontArray[0]; + FontMapInsert(subFontPtr, ch); + } + ReleaseDC(fontPtr->hwnd, hdc); + return subFontPtr; +} + +static int CALLBACK +WinFontCanUseProc( + ENUMLOGFONT *lfPtr, /* Logical-font data. */ + NEWTEXTMETRIC *tmPtr, /* Physical-font data (not used). */ + int fontType, /* Type of font (not used). */ + LPARAM lParam) /* Result object to hold result. */ +{ + int ch; + HDC hdc; + WinFont *fontPtr; + CanUse *canUsePtr; + char *fallbackName; + SubFont *subFontPtr; + Tcl_DString faceString; + Tcl_DString *nameTriedPtr; + + canUsePtr = (CanUse *) lParam; + ch = canUsePtr->ch; + hdc = canUsePtr->hdc; + fontPtr = canUsePtr->fontPtr; + nameTriedPtr = canUsePtr->nameTriedPtr; + + fallbackName = lfPtr->elfLogFont.lfFaceName; + Tcl_ExternalToUtfDString(systemEncoding, fallbackName, -1, &faceString); + fallbackName = Tcl_DStringValue(&faceString); + + if (SeenName(fallbackName, nameTriedPtr) == 0) { + subFontPtr = CanUseFallback(hdc, fontPtr, fallbackName, ch); + if (subFontPtr != NULL) { + canUsePtr->subFontPtr = subFontPtr; + Tcl_DStringFree(&faceString); + return 0; + } + } + Tcl_DStringFree(&faceString); + return 1; +} + +/* + *------------------------------------------------------------------------- + * + * 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 HFONT can (1) or cannot (0) display the + * characters on the page. + * + * Results: + * None. + * + * Side effects: + * Mempry 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. */ +{ + FontFamily *familyPtr; + Tcl_Encoding encoding; + char src[TCL_UTF_MAX], buf[16]; + USHORT *startCount, *endCount; + int i, j, bitOffset, end, segCount; + + subFontPtr->fontMap[row] = (char *) ckalloc(FONTMAP_BITSPERPAGE / 8); + memset(subFontPtr->fontMap[row], 0, FONTMAP_BITSPERPAGE / 8); + + familyPtr = subFontPtr->familyPtr; + encoding = familyPtr->encoding; + + if (familyPtr->encoding == unicodeEncoding) { + /* + * Font is Unicode. Few fonts are going to have all characters, so + * examine the TrueType character existence metrics to determine + * what characters actually exist in this font. + */ + + segCount = familyPtr->segCount; + startCount = familyPtr->startCount; + endCount = familyPtr->endCount; + + j = 0; + end = (row + 1) << FONTMAP_SHIFT; + for (i = row << FONTMAP_SHIFT; i < end; i++) { + for ( ; j < segCount; j++) { + if (endCount[j] >= i) { + if (startCount[j] <= i) { + bitOffset = i & (FONTMAP_BITSPERPAGE - 1); + subFontPtr->fontMap[row][bitOffset >> 3] |= 1 << (bitOffset & 7); + } + break; + } + } + } + } else if (familyPtr->isSymbolFont) { + /* + * Assume that a symbol font with a known encoding has all the + * characters that its encoding claims it supports. + * + * The test for "encoding == unicodeEncoding" + * must occur before this case, to catch all symbol fonts (such + * as {Comic Sans MS} or Wingdings) for which we don't have + * encoding information; those symbol fonts are treated as if + * they were in the Unicode encoding and their symbolic + * character existence metrics are treated as if they were Unicode + * character existence metrics. This way, although we don't know + * the proper Unicode -> symbol font mapping, we can install the + * symbol font as the base font and access its glyphs. + */ + + end = (row + 1) << FONTMAP_SHIFT; + for (i = row << FONTMAP_SHIFT; i < end; i++) { + if (Tcl_UtfToExternal(NULL, encoding, src, + Tcl_UniCharToUtf(i, src), TCL_ENCODING_STOPONERROR, NULL, + buf, sizeof(buf), NULL, NULL, NULL) != TCL_OK) { + continue; + } + 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. + * + *--------------------------------------------------------------------------- + */ + +static SubFont * +CanUseFallbackWithAliases( + HDC hdc, /* HDC in which font can be selected. */ + WinFont *fontPtr, /* The font object that will own the new + * screen font. */ + 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. */ +{ + int i; + char **aliases; + SubFont *subFontPtr; + + if (SeenName(faceName, nameTriedPtr) == 0) { + subFontPtr = CanUseFallback(hdc, fontPtr, faceName, ch); + 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(hdc, fontPtr, aliases[i], ch); + 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, (char *) name, (int) (strlen(name) + 1)); + return 0; +} + +/* + *------------------------------------------------------------------------- + * + * CanUseFallback -- + * + * If the specified screen font has not already been loaded into + * the font object, determine if it 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 + * font name. NULL is returned if the font object already holds + * a reference to the specified physical font or if the specified + * physical font cannot display the given character. + * + * Side effects: + * The font object's subFontArray is updated to contain a reference + * to the newly allocated SubFont. + * + *------------------------------------------------------------------------- + */ + +static SubFont * +CanUseFallback( + HDC hdc, /* HDC in which font can be selected. */ + WinFont *fontPtr, /* The font object that will own the new + * screen font. */ + char *faceName, /* Desired face name for new screen font. */ + int ch) /* The Unicode character that the new + * screen font must be able to display. */ +{ + int i; + HFONT hFont; + SubFont subFont; + + if (FamilyExists(hdc, faceName) == 0) { + return NULL; + } + + /* + * Skip all fonts we've already used. + */ + + for (i = 0; i < fontPtr->numSubFonts; i++) { + if (faceName == fontPtr->subFontArray[i].familyPtr->faceName) { + return NULL; + } + } + + /* + * Load this font and see if it has the desired character. + */ + + hFont = GetScreenFont(&fontPtr->font.fa, faceName, fontPtr->pixelSize); + InitSubFont(hdc, hFont, 0, &subFont); + if (((ch < 256) && (subFont.familyPtr->isSymbolFont)) + || (FontMapLookup(&subFont, ch) == 0)) { + /* + * Don't use a symbol font as a fallback font for characters below + * 256. + */ + + ReleaseSubFont(&subFont); + return NULL; + } + + if (fontPtr->numSubFonts >= SUBFONT_SPACE) { + SubFont *newPtr; + + newPtr = (SubFont *) ckalloc(sizeof(SubFont) + * (fontPtr->numSubFonts + 1)); + memcpy((char *) newPtr, fontPtr->subFontArray, + fontPtr->numSubFonts * sizeof(SubFont)); + if (fontPtr->subFontArray != fontPtr->staticSubFonts) { + ckfree((char *) fontPtr->subFontArray); + } + fontPtr->subFontArray = newPtr; + } + fontPtr->subFontArray[fontPtr->numSubFonts] = subFont; + fontPtr->numSubFonts++; + return &fontPtr->subFontArray[fontPtr->numSubFonts - 1]; +} + +/* + *--------------------------------------------------------------------------- + * + * GetScreenFont -- + * + * Given the name and other attributes, construct an HFONT. + * This is where all the alias and fallback substitution bottoms + * out. + * + * Results: + * The screen font that corresponds to the attributes. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +static HFONT +GetScreenFont( + CONST TkFontAttributes *faPtr, + /* Desired font attributes for new HFONT. */ + CONST char *faceName, /* Overrides font family specified in font + * attributes. */ + int pixelSize) /* Overrides size specified in font + * attributes. */ +{ + Tcl_DString ds; + HFONT hFont; + LOGFONTW lf; + + lf.lfHeight = -pixelSize; + lf.lfWidth = 0; + lf.lfEscapement = 0; + lf.lfOrientation = 0; + lf.lfWeight = (faPtr->weight == TK_FW_NORMAL) ? FW_NORMAL : FW_BOLD; + lf.lfItalic = faPtr->slant; + lf.lfUnderline = faPtr->underline; + lf.lfStrikeOut = faPtr->overstrike; + lf.lfCharSet = DEFAULT_CHARSET; + lf.lfOutPrecision = OUT_TT_PRECIS; + lf.lfClipPrecision = CLIP_DEFAULT_PRECIS; + lf.lfQuality = DEFAULT_QUALITY; + lf.lfPitchAndFamily = DEFAULT_PITCH | FF_DONTCARE; + + Tcl_UtfToExternalDString(systemEncoding, faceName, -1, &ds); + + if (platformId == VER_PLATFORM_WIN32_NT) { + Tcl_UniChar *src, *dst; + src = (Tcl_UniChar *) Tcl_DStringValue(&ds); + dst = (Tcl_UniChar *) lf.lfFaceName; + while (*src != '\0') { + *dst++ = *src++; + } + *dst = '\0'; + hFont = CreateFontIndirectW(&lf); + } else { + strcpy((char *) lf.lfFaceName, Tcl_DStringValue(&ds)); + hFont = CreateFontIndirectA((LOGFONTA *) &lf); + } + Tcl_DStringFree(&ds); + return hFont; +} + +/* + *------------------------------------------------------------------------- + * + * FamilyExists, FamilyOrAliasExists, WinFontExistsProc -- + * + * Determines if any physical screen font exists on the system with + * the given family name. If the family exists, then it should be + * possible to construct some physical screen font with that family + * name. + * + * Results: + * The return value is 0 if the specified font family does not exist, + * non-zero otherwise. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +FamilyExists( + HDC hdc, /* HDC in which font family will be used. */ + CONST char *faceName) /* Font family to query. */ +{ + int result; + Tcl_DString faceString; + + /* + * Just immediately rule out the following fonts, because they look so + * ugly on windows. The caller's fallback mechanism will cause the + * corresponding appropriate TrueType fonts to be selected. + */ + + if (strcasecmp(faceName, "Courier") == 0) { + return 0; + } + if (strcasecmp(faceName, "Times") == 0) { + return 0; + } + if (strcasecmp(faceName, "Helvetica") == 0) { + return 0; + } + + Tcl_UtfToExternalDString(systemEncoding, faceName, -1, &faceString); + + /* + * If the family exists, WinFontExistProc() will be called and + * EnumFontFamilies() will return whatever WinFontExistProc() returns. + * If the family doesn't exist, EnumFontFamilies() will just return a + * non-zero value. + */ + + if (platformId == VER_PLATFORM_WIN32_NT) { + result = EnumFontFamiliesW(hdc, (WCHAR *) Tcl_DStringValue(&faceString), + (FONTENUMPROCW) WinFontExistProc, 0); + } else { + result = EnumFontFamiliesA(hdc, (char *) Tcl_DStringValue(&faceString), + (FONTENUMPROCA) WinFontExistProc, 0); + } + Tcl_DStringFree(&faceString); + return (result == 0); +} + +static char * +FamilyOrAliasExists( + HDC hdc, + CONST char *faceName) +{ + char **aliases; + int i; + + if (FamilyExists(hdc, faceName) != 0) { + return (char *) faceName; + } + aliases = TkFontGetAliasList(faceName); + if (aliases != NULL) { + for (i = 0; aliases[i] != NULL; i++) { + if (FamilyExists(hdc, aliases[i]) != 0) { + return aliases[i]; + } + } + } + return NULL; +} + +static int CALLBACK +WinFontExistProc( + ENUMLOGFONT *lfPtr, /* Logical-font data. */ + NEWTEXTMETRIC *tmPtr, /* Physical-font data (not used). */ + int fontType, /* Type of font (not used). */ + LPARAM lParam) /* EnumFontData to hold result. */ +{ + return 0; +} + +/* + * The following data structures are used when querying a TrueType font file + * to determine which characters the font supports. + */ + +#pragma pack(1) /* Structures are byte aligned in file. */ + +#define CMAPHEX 0x636d6170 /* Key for character map resource. */ + +typedef struct CMAPTABLE { + USHORT version; /* Table version number (0). */ + USHORT numTables; /* Number of encoding tables following. */ +} CMAPTABLE; + +typedef struct ENCODINGTABLE { + USHORT platform; /* Platform for which data is targeted. + * 3 means data is for Windows. */ + USHORT encoding; /* How characters in font are encoded. + * 1 means that the following subtable is + * keyed based on Unicode. */ + ULONG offset; /* Byte offset from beginning of CMAPTABLE + * to the subtable for this encoding. */ +} ENCODINGTABLE; + +typedef struct ANYTABLE { + USHORT format; /* Format number. */ + USHORT length; /* The actual length in bytes of this + * subtable. */ + USHORT version; /* Version number (starts at 0). */ +} ANYTABLE; + +typedef struct BYTETABLE { + USHORT format; /* Format number is set to 0. */ + USHORT length; /* The actual length in bytes of this + * subtable. */ + USHORT version; /* Version number (starts at 0). */ + BYTE glyphIdArray[256]; /* Array that maps up to 256 single-byte char + * codes to glyph indices. */ +} BYTETABLE; + +typedef struct SUBHEADER { + USHORT firstCode; /* First valid low byte for subHeader. */ + USHORT entryCount; /* Number valid low bytes for subHeader. */ + SHORT idDelta; /* Constant adder to get base glyph index. */ + USHORT idRangeOffset; /* Byte offset from here to appropriate + * glyphIndexArray. */ +} SUBHEADER; + +typedef struct HIBYTETABLE { + USHORT format; /* Format number is set to 2. */ + USHORT length; /* The actual length in bytes of this + * subtable. */ + USHORT version; /* Version number (starts at 0). */ + USHORT subHeaderKeys[256]; /* Maps high bytes to subHeaders: value is + * subHeader index * 8. */ +#if 0 + SUBHEADER subHeaders[]; /* Variable-length array of SUBHEADERs. */ + USHORT glyphIndexArray[]; /* Variable-length array containing subarrays + * used for mapping the low byte of 2-byte + * characters. */ +#endif +} HIBYTETABLE; + +typedef struct SEGMENTTABLE { + USHORT format; /* Format number is set to 4. */ + USHORT length; /* The actual length in bytes of this + * subtable. */ + USHORT version; /* Version number (starts at 0). */ + USHORT segCountX2; /* 2 x segCount. */ + USHORT searchRange; /* 2 x (2**floor(log2(segCount))). */ + USHORT entrySelector; /* log2(searchRange/2). */ + USHORT rangeShift; /* 2 x segCount - searchRange. */ +#if 0 + USHORT endCount[segCount] /* End characterCode for each segment. */ + USHORT reservedPad; /* Set to 0. */ + USHORT startCount[segCount];/* Start character code for each segment. */ + USHORT idDelta[segCount]; /* Delta for all character in segment. */ + USHORT idRangeOffset[segCount]; /* Offsets into glyphIdArray or 0. */ + USHORT glyphIdArray[] /* Glyph index array. */ +#endif +} SEGMENTTABLE; + +typedef struct TRIMMEDTABLE { + USHORT format; /* Format number is set to 6. */ + USHORT length; /* The actual length in bytes of this + * subtable. */ + USHORT version; /* Version number (starts at 0). */ + USHORT firstCode; /* First character code of subrange. */ + USHORT entryCount; /* Number of character codes in subrange. */ +#if 0 + USHORT glyphIdArray[]; /* Array of glyph index values for + character codes in the range. */ +#endif +} TRIMMEDTABLE; + +typedef union SUBTABLE { + ANYTABLE any; + BYTETABLE byte; + HIBYTETABLE hiByte; + SEGMENTTABLE segment; + TRIMMEDTABLE trimmed; +} SUBTABLE; + +#pragma pack() + +/* + *------------------------------------------------------------------------- + * + * LoadFontRanges -- + * + * Given an HFONT, get the information about the characters that + * this font can display. + * + * Results: + * If the font has no Unicode character information, the return value + * is 0 and *startCountPtr and *endCountPtr are filled with NULL. + * Otherwise, *startCountPtr and *endCountPtr are set to pointers to + * arrays of TrueType character existence information and the return + * value is the length of the arrays (the two arrays are always the + * same length as each other). + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +LoadFontRanges( + HDC hdc, /* HDC into which font can be selected. */ + HFONT hFont, /* HFONT to query. */ + USHORT **startCountPtr, /* Filled with malloced pointer to + * character range information. */ + USHORT **endCountPtr, /* Filled with malloced pointer to + * character range information. */ + int *symbolPtr) + { + int n, i, swapped, offset, cbData, segCount; + DWORD cmapKey; + USHORT *startCount, *endCount; + CMAPTABLE cmapTable; + ENCODINGTABLE encTable; + SUBTABLE subTable; + char *s; + + segCount = 0; + startCount = NULL; + endCount = NULL; + *symbolPtr = 0; + + hFont = SelectObject(hdc, hFont); + + i = 0; + s = (char *) &i; + *s = '\1'; + swapped = 0; + + if (i == 1) { + swapped = 1; + } + + cmapKey = CMAPHEX; + if (swapped) { + SwapLong(&cmapKey); + } + + n = GetFontData(hdc, cmapKey, 0, &cmapTable, sizeof(cmapTable)); + if (n != GDI_ERROR) { + if (swapped) { + SwapShort(&cmapTable.numTables); + } + for (i = 0; i < cmapTable.numTables; i++) { + offset = sizeof(cmapTable) + i * sizeof(encTable); + GetFontData(hdc, cmapKey, offset, &encTable, sizeof(encTable)); + if (swapped) { + SwapShort(&encTable.platform); + SwapShort(&encTable.encoding); + SwapLong(&encTable.offset); + } + if (encTable.platform != 3) { + /* + * Not Microsoft encoding. + */ + + continue; + } + if (encTable.encoding == 0) { + *symbolPtr = 1; + } else if (encTable.encoding != 1) { + continue; + } + + GetFontData(hdc, cmapKey, encTable.offset, &subTable, + sizeof(subTable)); + if (swapped) { + SwapShort(&subTable.any.format); + } + if (subTable.any.format == 4) { + if (swapped) { + SwapShort(&subTable.segment.segCountX2); + } + segCount = subTable.segment.segCountX2 / 2; + cbData = segCount * sizeof(USHORT); + + startCount = (USHORT *) ckalloc(cbData); + endCount = (USHORT *) ckalloc(cbData); + + offset = encTable.offset + sizeof(subTable.segment); + GetFontData(hdc, cmapKey, offset, endCount, cbData); + offset += cbData + sizeof(USHORT); + GetFontData(hdc, cmapKey, offset, startCount, cbData); + if (swapped) { + for (i = 0; i < segCount; i++) { + SwapShort(&endCount[i]); + SwapShort(&startCount[i]); + } + } + if (*symbolPtr != 0) { + /* + * Empirically determined: When a symbol font is + * loaded, the character existence metrics obtained + * from the system are mildly wrong. If the real range + * of the symbol font is from 0020 to 00FE, then the + * metrics are reported as F020 to F0FE. When we load + * a symbol font, we must fix the character existence + * metrics. + */ + + for (i = 0; i < segCount; i++) { + if ((startCount[i] & 0xff00) == 0xf000) { + startCount[i] &= 0xff; + } + if ((endCount[i] & 0xff00) == 0xf000) { + endCount[i] &= 0xff; + } + } + } + } + } + } + SelectObject(hdc, hFont); + + *startCountPtr = startCount; + *endCountPtr = endCount; + return segCount; +} + +/* + *------------------------------------------------------------------------- + * + * SwapShort, SwapLong -- + * + * Helper functions to convert the data loaded from TrueType font + * files to Intel byte ordering. + * + * Results: + * Bytes of input value are swapped and stored back in argument. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static void +SwapShort(PUSHORT p) +{ + *p = (SHORT)(HIBYTE(*p) + (LOBYTE(*p) << 8)); +} + +static void +SwapLong(PULONG p) +{ + ULONG temp; + + temp = (LONG) ((BYTE) *p); + temp <<= 8; + *p >>=8; + + temp += (LONG) ((BYTE) *p); + temp <<= 8; + *p >>=8; + + temp += (LONG) ((BYTE) *p); + temp <<= 8; + *p >>=8; + + temp += (LONG) ((BYTE) *p); + *p = temp; +} diff --git a/win/tkWinInit.c b/win/tkWinInit.c index 400f693..b311bae 100644 --- a/win/tkWinInit.c +++ b/win/tkWinInit.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkWinInit.c 1.29 97/07/24 14:46:35 + * SCCS: @(#) tkWinInit.c 1.30 97/11/07 21:25:45 */ #include "tkWinInt.h" @@ -31,7 +31,7 @@ * * Results: * A standard Tcl completion code (TCL_OK or TCL_ERROR). Also - * leaves information in interp->result. + * leaves information in the interp's result. * * Side effects: * Sets "tk_library" Tcl variable, runs "tk.tcl" script. diff --git a/win/tkWinInt.h b/win/tkWinInt.h index f3bca19..8198b6b 100644 --- a/win/tkWinInt.h +++ b/win/tkWinInt.h @@ -5,12 +5,12 @@ * Windows-specific parts of Tk, but aren't used by the rest of * Tk. * - * Copyright (c) 1995 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkWinInt.h 1.34 97/09/02 13:06:20 + * SCCS: @(#) tkWinInt.h 1.36 97/10/02 17:30:22 */ #ifndef _TKWININT @@ -28,6 +28,11 @@ #include "tkWin.h" #endif +#ifndef _TKPORT +#include "tkPort.h" +#endif + + /* * Define constants missing from older Win32 SDK header files. */ @@ -150,6 +155,7 @@ extern LRESULT CALLBACK TkWinChildProc _ANSI_ARGS_((HWND hwnd, UINT message, WPARAM wParam, LPARAM lParam)); extern void TkWinClipboardRender _ANSI_ARGS_((TkDisplay *dispPtr, UINT format)); +extern void TkWinDialogDebug _ANSI_ARGS_((int debug)); extern LRESULT TkWinEmbeddedEventProc _ANSI_ARGS_((HWND hwnd, UINT message, WPARAM wParam, LPARAM lParam)); extern void TkWinFillRect _ANSI_ARGS_((HDC dc, int x, int y, @@ -158,7 +164,10 @@ extern COLORREF TkWinGetBorderPixels _ANSI_ARGS_((Tk_Window tkwin, Tk_3DBorder border, int which)); extern HDC TkWinGetDrawableDC _ANSI_ARGS_((Display *display, Drawable d, TkWinDCState* state)); +extern Tcl_Obj * TkWinGetMenuSystemDefault _ANSI_ARGS_((Tk_Window tkwin, + char *dbName, char *className)); extern int TkWinGetModifierState _ANSI_ARGS_((void)); +extern int TkWinGetPlatformId(); extern HPALETTE TkWinGetSystemPalette _ANSI_ARGS_((void)); extern HWND TkWinGetWrapperWindow _ANSI_ARGS_((Tk_Window tkwin)); extern int TkWinHandleMenuEvent _ANSI_ARGS_((HWND *phwnd, @@ -190,5 +199,6 @@ extern void TkWinWmStoreEmbedAssociation _ANSI_ARGS_(( extern void TkWinXCleanup _ANSI_ARGS_((HINSTANCE hInstance)); extern void TkWinXInit _ANSI_ARGS_((HINSTANCE hInstance)); + #endif /* _TKWININT */ diff --git a/win/tkWinKey.c b/win/tkWinKey.c index 3589143..bc74c43 100644 --- a/win/tkWinKey.c +++ b/win/tkWinKey.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkWinKey.c 1.9 97/06/20 15:12:39 + * SCCS: @(#) tkWinKey.c 1.11 98/01/13 20:26:49 */ #include "tkWinInt.h" @@ -79,71 +79,59 @@ static Keys keymap[] = { /* *---------------------------------------------------------------------- * - * XLookupString -- + * TkpGetString -- * - * Retrieve the string equivalent for the given keyboard event. + * Retrieve the UTF string equivalent for the given keyboard event. * * Results: - * Returns the number of characters stored in buffer_return. + * Returns the UTF string. * * Side effects: - * Retrieves the characters stored in the event and inserts them - * into buffer_return. + * None. * *---------------------------------------------------------------------- */ -int -XLookupString(event_struct, buffer_return, bytes_buffer, keysym_return, - status_in_out) - XKeyEvent* event_struct; - char* buffer_return; - int bytes_buffer; - KeySym* keysym_return; - XComposeStatus* status_in_out; +char * +TkpGetString(winPtr, eventPtr, dsPtr) + TkWindow *winPtr; /* Window where event occurred: needed to + * get input context. */ + XEvent *eventPtr; /* X keyboard event. */ + Tcl_DString *dsPtr; /* Uninitialized or empty string to hold + * result. */ { - int i, limit; + int index; + KeySym keysym; + XKeyEvent* keyEv = &eventPtr->xkey; - if (event_struct->send_event != -1) { + Tcl_DStringInit(dsPtr); + if (eventPtr->xkey.send_event != -1) { /* * This is an event generated from generic code. It has no * nchars or trans_chars members. */ - int index; - KeySym keysym; - index = 0; - if (event_struct->state & ShiftMask) { + if (eventPtr->xkey.state & ShiftMask) { index |= 1; } - if (event_struct->state & Mod1Mask) { + if (eventPtr->xkey.state & Mod1Mask) { index |= 2; } - keysym = XKeycodeToKeysym(event_struct->display, - event_struct->keycode, index); + keysym = XKeycodeToKeysym(eventPtr->xkey.display, + eventPtr->xkey.keycode, index); if (((keysym != NoSymbol) && (keysym > 0) && (keysym < 256)) || (keysym == XK_Return) || (keysym == XK_Tab)) { - buffer_return[0] = (char) keysym; - return 1; + char buf[TCL_UTF_MAX]; + int len = Tcl_UniCharToUtf((Tcl_UniChar) keysym, buf); + Tcl_DStringAppend(dsPtr, buf, len); } - return 0; - } - if ((event_struct->nchars <= 0) || (buffer_return == NULL)) { - return 0; - } - limit = (event_struct->nchars < bytes_buffer) ? event_struct->nchars : - bytes_buffer; - - for (i = 0; i < limit; i++) { - buffer_return[i] = event_struct->trans_chars[i]; - } - - if (keysym_return != NULL) { - *keysym_return = NoSymbol; + } else if (eventPtr->xkey.nbytes > 0) { + Tcl_ExternalToUtfDString(NULL, eventPtr->xkey.trans_chars, + eventPtr->xkey.nbytes, dsPtr); } - return i; + return Tcl_DStringValue(dsPtr); } /* @@ -189,8 +177,8 @@ XKeycodeToKeysym(display, keycode, index) * for alphanumeric characters map onto Latin-1, we just return it. */ - if (result == 1 && buf[0] >= 0x20) { - return (KeySym) buf[0]; + if (result == 1 && UCHAR(buf[0]) >= 0x20) { + return (KeySym) UCHAR(buf[0]); } /* diff --git a/win/tkWinMenu.c b/win/tkWinMenu.c index 00e24b7..44f53fc 100644 --- a/win/tkWinMenu.c +++ b/win/tkWinMenu.c @@ -1,20 +1,21 @@ /* * tkWinMenu.c -- * - * This module implements the Mac-platform specific features of menus. + * This module implements the Windows-platform specific features of menus. * - * Copyright (c) 1996-1997 by Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkWinMenu.c 1.102 97/10/28 13:56:58 + * SCCS: @(#) tkWinMenu.c 1.110 98/01/26 19:43:53 */ #define OEMRESOURCE -#include <string.h> -#include "tkMenu.h" #include "tkWinInt.h" +#include "tkMenu.h" + +#include <string.h> /* * The class of the window for popup menus. @@ -74,7 +75,7 @@ static Tcl_HashTable winMenuTable; * The following are default menu value strings. */ -static char borderString[5]; /* The string indicating how big the border is */ +static int defaultBorderWidth; /* The windows default border width. */ static Tcl_DString menuFontDString; /* A buffer to store the default menu font * string. */ @@ -122,7 +123,7 @@ static void DrawWindowsSystemBitmap _ANSI_ARGS_(( GC gc, CONST RECT *rectPtr, int bitmapID, int alignFlags)); static void FreeID _ANSI_ARGS_((int commandID)); -static char * GetEntryText _ANSI_ARGS_((TkMenuEntry *mePtr)); +static TCHAR * GetEntryText _ANSI_ARGS_((TkMenuEntry *mePtr)); static void GetMenuAccelGeometry _ANSI_ARGS_((TkMenu *menuPtr, TkMenuEntry *mePtr, Tk_Font tkfont, CONST Tk_FontMetrics *fmPtr, int *widthPtr, @@ -154,6 +155,7 @@ static void ReconfigureWindowsMenu _ANSI_ARGS_(( ClientData clientData)); static void RecursivelyClearActiveMenu _ANSI_ARGS_(( TkMenu *menuPtr)); +static void SetDefaults _ANSI_ARGS_((int firstTime)); static LRESULT CALLBACK TkWinMenuProc _ANSI_ARGS_((HWND hwnd, UINT message, WPARAM wParam, LPARAM lParam)); @@ -315,6 +317,7 @@ TkpDestroyMenu(menuPtr) TkMenu *menuPtr; /* The common menu structure */ { HMENU winMenuHdl = (HMENU) menuPtr->platformData; + char *searchName; if (menuPtr->menuFlags & MENU_RECONFIGURE_PENDING) { Tcl_CancelIdleCall(ReconfigureWindowsMenu, (ClientData) menuPtr); @@ -330,7 +333,9 @@ TkpDestroyMenu(menuPtr) for (searchEntryPtr = menuPtr->menuRefPtr->parentEntryPtr; searchEntryPtr != NULL; searchEntryPtr = searchEntryPtr->nextCascadePtr) { - if (strcmp(searchEntryPtr->name, + searchName = Tcl_GetStringFromObj(searchEntryPtr->namePtr, + NULL); + if (strcmp(searchName, menuName) == 0) { Tk_Window parentTopLevelPtr = searchEntryPtr ->menuPtr->parentTopLevelPtr; @@ -410,18 +415,22 @@ GetEntryText(mePtr) if (mePtr->type == TEAROFF_ENTRY) { itemText = ckalloc(sizeof("(Tear-off)")); strcpy(itemText, "(Tear-off)"); - } else if (mePtr->imageString != NULL) { + } else if (mePtr->imagePtr != NULL) { itemText = ckalloc(sizeof("(Image)")); strcpy(itemText, "(Image)"); - } else if (mePtr->bitmap != None) { + } else if (mePtr->bitmapPtr != NULL) { itemText = ckalloc(sizeof("(Pixmap)")); strcpy(itemText, "(Pixmap)"); - } else if (mePtr->label == NULL || mePtr->labelLength == 0) { + } else if (mePtr->labelPtr == NULL || mePtr->labelLength == 0) { itemText = ckalloc(sizeof("( )")); strcpy(itemText, "( )"); } else { int size = mePtr->labelLength + 1; int i, j; + char *label = (mePtr->labelPtr == NULL) ? "" + : Tcl_GetStringFromObj(mePtr->labelPtr, NULL); + char *accel = (mePtr->accelPtr == NULL) ? "" + : Tcl_GetStringFromObj(mePtr->accelPtr, NULL); /* * We have to construct the string with an ampersand @@ -431,14 +440,14 @@ GetEntryText(mePtr) */ for (i = 0; i < mePtr->labelLength; i++) { - if (mePtr->label[i] == '&') { + if (label[i] == '&') { size++; } } if (mePtr->underline >= 0) { size++; - if (mePtr->label[mePtr->underline] == '&') { + if (label[mePtr->underline] == '&') { size++; } } @@ -448,7 +457,7 @@ GetEntryText(mePtr) } for (i = 0; i < mePtr->accelLength; i++) { - if (mePtr->accel[i] == '&') { + if (accel[i] == '&') { size++; } } @@ -459,13 +468,13 @@ GetEntryText(mePtr) itemText[0] = 0; } else { for (i = 0, j = 0; i < mePtr->labelLength; i++, j++) { - if (mePtr->label[i] == '&') { + if (label[i] == '&') { itemText[j++] = '&'; } if (i == mePtr->underline) { itemText[j++] = '&'; } - itemText[j] = mePtr->label[i]; + itemText[j] = label[i]; } itemText[j] = '\0'; } @@ -474,10 +483,10 @@ GetEntryText(mePtr) strcat(itemText, "\t"); for (i = 0, j = strlen(itemText); i < mePtr->accelLength; i++, j++) { - if (mePtr->accel[i] == '&') { + if (accel[i] == '&') { itemText[j++] = '&'; } - itemText[j] = mePtr->accel[i]; + itemText[j] = accel[i]; } itemText[j] = '\0'; } @@ -509,8 +518,8 @@ ReconfigureWindowsMenu( TkMenu *menuPtr = (TkMenu *) clientData; TkMenuEntry *mePtr; HMENU winMenuHdl = (HMENU) menuPtr->platformData; - char *itemText = NULL; - LPCTSTR lpNewItem; + TCHAR *itemText = NULL; + const TCHAR *lpNewItem; UINT flags; UINT itemID; int i, count, systemMenu = 0, base; @@ -552,6 +561,8 @@ ReconfigureWindowsMenu( if (mePtr->type == SEPARATOR_ENTRY) { flags |= MF_SEPARATOR; } else { + int columnBreak, state; + itemText = GetEntryText(mePtr); if ((menuPtr->menuType == MENUBAR) || (menuPtr->menuFlags & MENU_SYSTEM_MENU)) { @@ -565,7 +576,9 @@ ReconfigureWindowsMenu( * Set enabling and disabling correctly. */ - if (mePtr->state == tkDisabledUid) { + Tcl_GetIndexFromObj(NULL, mePtr->statePtr, tkMenuStateStrings, + NULL, 0, &state); + if (state == ENTRY_DISABLED) { flags |= MF_DISABLED; } @@ -579,7 +592,9 @@ ReconfigureWindowsMenu( flags |= MF_CHECKED; } - if (mePtr->columnBreak) { + Tcl_GetBooleanFromObj(NULL, mePtr->columnBreakPtr, + &columnBreak); + if (columnBreak) { flags |= MF_MENUBREAK; } @@ -603,10 +618,6 @@ ReconfigureWindowsMenu( char *systemMenuName = ckalloc(strlen( Tk_PathName(menuPtr->masterMenuPtr->tkwin)) + strlen(".system") + 1); - - strcpy(systemMenuName, - Tk_PathName(menuPtr->masterMenuPtr->tkwin)); - strcat(systemMenuName, ".system"); menuRefPtr = TkFindMenuReferences(menuPtr->interp, systemMenuName); if ((menuRefPtr != NULL) @@ -904,6 +915,7 @@ TkWinHandleMenuEvent(phwnd, pMessage, pwParam, plParam, plResult) if (mePtr != NULL) { TkMenuReferences *menuRefPtr; TkMenuEntry *parentEntryPtr; + int code; /* * We have to set the parent of this menu to be active @@ -914,28 +926,40 @@ TkWinHandleMenuEvent(phwnd, pMessage, pwParam, plParam, plResult) menuPtr = mePtr->menuPtr; menuRefPtr = TkFindMenuReferences(menuPtr->interp, Tk_PathName(menuPtr->tkwin)); - if ((menuRefPtr != NULL) && (menuRefPtr->parentEntryPtr - != NULL)) { - for (parentEntryPtr = menuRefPtr->parentEntryPtr; - strcmp(parentEntryPtr->name, - Tk_PathName(menuPtr->tkwin)) != 0; - parentEntryPtr = parentEntryPtr->nextCascadePtr) { - - /* - * Empty loop body. - */ + if ((menuRefPtr != NULL) + && (menuRefPtr->parentEntryPtr != NULL)) { + char *name; + int state; + for (parentEntryPtr = menuRefPtr->parentEntryPtr; + ; + parentEntryPtr = + parentEntryPtr->nextCascadePtr) { + name = Tcl_GetStringFromObj( + parentEntryPtr->namePtr, NULL); + if (strcmp(name, Tk_PathName(menuPtr->tkwin)) + == 0) { + break; + } } - if (parentEntryPtr->menuPtr - ->entries[parentEntryPtr->index]->state - != tkDisabledUid) { + Tcl_GetIndexFromObj(NULL, parentEntryPtr->menuPtr + ->entries[parentEntryPtr->index] + ->statePtr, tkMenuStateStrings, NULL, + 0, &state); + if (state != ENTRY_DISABLED) { TkActivateMenuEntry(parentEntryPtr->menuPtr, parentEntryPtr->index); } } - TkInvokeMenu(mePtr->menuPtr->interp, + code = TkInvokeMenu(mePtr->menuPtr->interp, menuPtr, mePtr->index); + if (code != TCL_OK && code != TCL_CONTINUE + && code != TCL_BREAK) { + Tcl_AddErrorInfo(mePtr->menuPtr->interp, + "\n (menu invoke)"); + Tcl_BackgroundError(mePtr->menuPtr->interp); + } } *plResult = 0; returnResult = 1; @@ -954,12 +978,19 @@ TkWinHandleMenuEvent(phwnd, pMessage, pwParam, plParam, plResult) *plResult = 0; menuPtr = (TkMenu *) Tcl_GetHashValue(hashEntryPtr); for (i = 0; i < menuPtr->numEntries; i++) { - int underline = menuPtr->entries[i]->underline; + int underline; + char *label; + + underline = menuPtr->entries[i]->underline; + if (menuPtr->entries[i]->labelPtr != NULL) { + label = Tcl_GetStringFromObj( + menuPtr->entries[i]->labelPtr, NULL); + } if ((-1 != underline) - && (NULL != menuPtr->entries[i]->label) + && (NULL != menuPtr->entries[i]->labelPtr) && (CharUpper((LPTSTR) menuChar) - == CharUpper((LPTSTR) (unsigned char) menuPtr - ->entries[i]->label[underline]))) { + == CharUpper((LPTSTR) (unsigned char) + label[underline]))) { *plResult = (2 << 16) | i; break; } @@ -973,16 +1004,25 @@ TkWinHandleMenuEvent(phwnd, pMessage, pwParam, plParam, plResult) LPMEASUREITEMSTRUCT itemPtr = (LPMEASUREITEMSTRUCT) *plParam; if (itemPtr != NULL) { + int hideMargin; + mePtr = (TkMenuEntry *) itemPtr->itemData; menuPtr = mePtr->menuPtr; TkRecomputeMenu(menuPtr); itemPtr->itemHeight = mePtr->height; itemPtr->itemWidth = mePtr->width; - if (mePtr->hideMargin) { - itemPtr->itemWidth += 2 - indicatorDimensions[0]; + Tcl_GetBooleanFromObj(NULL, mePtr->hideMarginPtr, + &hideMargin); + if (hideMargin) { + itemPtr->itemWidth += 2 - indicatorDimensions[1]; } else { - itemPtr->itemWidth += 2 * menuPtr->activeBorderWidth; + int activeBorderWidth; + + Tk_GetPixelsFromObj(menuPtr->interp, menuPtr->tkwin, + menuPtr->activeBorderWidthPtr, + &activeBorderWidth); + itemPtr->itemWidth += 2 * activeBorderWidth; } *plResult = 1; returnResult = 1; @@ -996,13 +1036,18 @@ TkWinHandleMenuEvent(phwnd, pMessage, pwParam, plParam, plResult) Tk_FontMetrics fontMetrics; if (itemPtr != NULL) { + int state; + Tk_Font tkfont; + mePtr = (TkMenuEntry *) itemPtr->itemData; menuPtr = mePtr->menuPtr; twdPtr = (TkWinDrawable *) ckalloc(sizeof(TkWinDrawable)); twdPtr->type = TWD_WINDC; twdPtr->winDC.hdc = itemPtr->hDC; - if (mePtr->state != tkDisabledUid) { + Tcl_GetIndexFromObj(NULL, mePtr->statePtr, + tkMenuStateStrings, NULL, 0, &state); + if (state != ENTRY_DISABLED) { if (itemPtr->itemState & ODS_SELECTED) { TkActivateMenuEntry(menuPtr, mePtr->index); } else { @@ -1010,8 +1055,9 @@ TkWinHandleMenuEvent(phwnd, pMessage, pwParam, plParam, plResult) } } - Tk_GetFontMetrics(menuPtr->tkfont, &fontMetrics); - TkpDrawMenuEntry(mePtr, (Drawable) twdPtr, menuPtr->tkfont, + tkfont = Tk_GetFontFromObj(menuPtr->tkwin, menuPtr->fontPtr); + Tk_GetFontMetrics(tkfont, &fontMetrics); + TkpDrawMenuEntry(mePtr, (Drawable) twdPtr, tkfont, &fontMetrics, itemPtr->rcItem.left, itemPtr->rcItem.top, itemPtr->rcItem.right - itemPtr->rcItem.left, itemPtr->rcItem.bottom @@ -1045,6 +1091,8 @@ TkWinHandleMenuEvent(phwnd, pMessage, pwParam, plParam, plResult) } if (menuPtr != NULL) { + int state; + mePtr = NULL; if (flags != 0xFFFF) { if (flags & MF_POPUP) { @@ -1053,15 +1101,22 @@ TkWinHandleMenuEvent(phwnd, pMessage, pwParam, plParam, plResult) hashEntryPtr = Tcl_FindHashEntry(&commandTable, (char *) LOWORD(*pwParam)); if (hashEntryPtr != NULL) { - mePtr = (TkMenuEntry *) Tcl_GetHashValue(hashEntryPtr); + mePtr = (TkMenuEntry *) + Tcl_GetHashValue(hashEntryPtr); } } } - if ((mePtr == NULL) || (mePtr->state == tkDisabledUid)) { + if (mePtr == NULL) { TkActivateMenuEntry(menuPtr, -1); } else { - TkActivateMenuEntry(menuPtr, mePtr->index); + Tcl_GetIndexFromObj(NULL, mePtr->statePtr, + tkMenuStateStrings, NULL, 0, &state); + if (state == ENTRY_DISABLED) { + TkActivateMenuEntry(menuPtr, -1); + } else { + TkActivateMenuEntry(menuPtr, mePtr->index); + } } MenuSelectEvent(menuPtr); Tcl_ServiceAll(); @@ -1210,11 +1265,18 @@ GetMenuIndicatorGeometry ( int *widthPtr, /* The resulting width */ int *heightPtr) /* The resulting height */ { + int hideMargin; + *heightPtr = indicatorDimensions[0]; - if (mePtr->hideMargin) { + Tcl_GetBooleanFromObj(NULL, mePtr->hideMarginPtr, &hideMargin); + if (hideMargin) { *widthPtr = 0; } else { - *widthPtr = indicatorDimensions[1] - menuPtr->borderWidth; + int borderWidth; + + Tk_GetPixelsFromObj(menuPtr->interp, menuPtr->tkwin, + menuPtr->borderWidthPtr, &borderWidth); + *widthPtr = indicatorDimensions[1] - borderWidth; } } @@ -1246,10 +1308,11 @@ GetMenuAccelGeometry ( *heightPtr = fmPtr->linespace; if (mePtr->type == CASCADE_ENTRY) { *widthPtr = 0; - } else if (mePtr->accel == NULL) { + } else if (mePtr->accelPtr == NULL) { *widthPtr = 0; } else { - *widthPtr = Tk_TextWidth(tkfont, mePtr->accel, mePtr->accelLength); + char *accel = Tcl_GetStringFromObj(mePtr->accelPtr, NULL); + *widthPtr = Tk_TextWidth(tkfont, accel, mePtr->accelLength); } } @@ -1339,7 +1402,7 @@ DrawWindowsSystemBitmap(display, drawable, gc, rectPtr, bitmapID, alignFlags) Display *display; /* The display we are drawing into */ Drawable drawable; /* The drawable we are working with */ GC gc; /* The GC to draw with */ - CONST RECT *rectPtr; /* The rectangle to draw into */ + CONST RECT *rectPtr; /* The rectangle to draw into */ int bitmapID; /* The windows id of the system * bitmap to draw. */ int alignFlags; /* How to align the bitmap inside the @@ -1425,47 +1488,59 @@ DrawMenuEntryIndicator(menuPtr, mePtr, d, gc, indicatorGC, tkfont, fmPtr, x, int width; int height; { - if ((mePtr->type == CHECK_BUTTON_ENTRY || - mePtr->type == RADIO_BUTTON_ENTRY) - && mePtr->indicatorOn - && mePtr->entryFlags & ENTRY_SELECTED) { - RECT rect; - GC whichGC; - - if (mePtr->state != tkNormalUid) { - whichGC = gc; - } else { - whichGC = indicatorGC; - } - - rect.top = y; - rect.bottom = y + mePtr->height; - rect.left = menuPtr->borderWidth + menuPtr->activeBorderWidth + x; - rect.right = mePtr->indicatorSpace + x; + if ((mePtr->type == CHECK_BUTTON_ENTRY) + || (mePtr->type == RADIO_BUTTON_ENTRY)) { + int indicatorOn; + + Tcl_GetBooleanFromObj(NULL, mePtr->indicatorOnPtr, &indicatorOn); + + if (indicatorOn && (mePtr->entryFlags & ENTRY_SELECTED)) { + RECT rect; + GC whichGC; + int state; + int borderWidth, activeBorderWidth; + Tcl_GetIndexFromObj(NULL, mePtr->statePtr, tkMenuStateStrings, + NULL, 0, &state); + if (state != ENTRY_NORMAL) { + whichGC = gc; + } else { + whichGC = indicatorGC; + } - if ((mePtr->state == tkDisabledUid) && (menuPtr->disabledFg != NULL) - && (versionInfo.dwMajorVersion >= 4)) { - RECT hilightRect; - COLORREF oldFgColor = whichGC->foreground; - - whichGC->foreground = GetSysColor(COLOR_3DHILIGHT); - hilightRect.top = rect.top + 1; - hilightRect.bottom = rect.bottom + 1; - hilightRect.left = rect.left + 1; - hilightRect.right = rect.right + 1; - DrawWindowsSystemBitmap(menuPtr->display, d, whichGC, - &hilightRect, OBM_CHECK, 0); - whichGC->foreground = oldFgColor; - } + rect.top = y; + rect.bottom = y + mePtr->height; + Tk_GetPixelsFromObj(menuPtr->interp, menuPtr->tkwin, + menuPtr->borderWidthPtr, &borderWidth); + Tk_GetPixelsFromObj(menuPtr->interp, menuPtr->tkwin, + menuPtr->activeBorderWidthPtr, &activeBorderWidth); + rect.left = borderWidth + activeBorderWidth + x; + rect.right = mePtr->indicatorSpace + x; + + if ((state == ENTRY_DISABLED) + && (menuPtr->disabledFgPtr != NULL) + && (versionInfo.dwMajorVersion >= 4)) { + RECT hilightRect; + COLORREF oldFgColor = whichGC->foreground; + + whichGC->foreground = GetSysColor(COLOR_3DHILIGHT); + hilightRect.top = rect.top + 1; + hilightRect.bottom = rect.bottom + 1; + hilightRect.left = rect.left + 1; + hilightRect.right = rect.right + 1; + DrawWindowsSystemBitmap(menuPtr->display, d, whichGC, + &hilightRect, OBM_CHECK, 0); + whichGC->foreground = oldFgColor; + } - DrawWindowsSystemBitmap(menuPtr->display, d, whichGC, &rect, - OBM_CHECK, 0); + DrawWindowsSystemBitmap(menuPtr->display, d, whichGC, &rect, + OBM_CHECK, 0); - if ((mePtr->state == tkDisabledUid) - && (menuPtr->disabledImageGC != None) - && (versionInfo.dwMajorVersion < 4)) { - XFillRectangle(menuPtr->display, d, menuPtr->disabledImageGC, - rect.left, rect.top, rect.right, rect.bottom); + if ((state == ENTRY_DISABLED) + && (menuPtr->disabledImageGC != None) + && (versionInfo.dwMajorVersion < 4)) { + XFillRectangle(menuPtr->display, d, menuPtr->disabledImageGC, + rect.left, rect.top, rect.right, rect.bottom); + } } } } @@ -1510,18 +1585,26 @@ DrawMenuEntryAccelerator(menuPtr, mePtr, d, gc, tkfont, fmPtr, { int baseline; int leftEdge = x + mePtr->indicatorSpace + mePtr->labelWidth; + int state; + char *accel; + + if (mePtr->accelPtr != NULL) { + accel = Tcl_GetStringFromObj(mePtr->accelPtr, NULL); + } baseline = y + (height + fmPtr->ascent - fmPtr->descent) / 2; - if ((mePtr->state == tkDisabledUid) && (menuPtr->disabledFg != NULL) - && ((mePtr->accel != NULL) + Tcl_GetIndexFromObj(NULL, mePtr->statePtr, tkMenuStateStrings, NULL, + 0, &state); + if ((state == ENTRY_DISABLED) && (menuPtr->disabledFgPtr != NULL) + && ((mePtr->accelPtr != NULL) || ((mePtr->type == CASCADE_ENTRY) && drawArrow))) { if (versionInfo.dwMajorVersion >= 4) { COLORREF oldFgColor = gc->foreground; gc->foreground = GetSysColor(COLOR_3DHILIGHT); - if (mePtr->accel != NULL) { - Tk_DrawChars(menuPtr->display, d, gc, tkfont, mePtr->accel, + if (mePtr->accelPtr != NULL) { + Tk_DrawChars(menuPtr->display, d, gc, tkfont, accel, mePtr->accelLength, leftEdge + 1, baseline + 1); } @@ -1539,12 +1622,12 @@ DrawMenuEntryAccelerator(menuPtr, mePtr, d, gc, tkfont, fmPtr, } } - if (mePtr->accel != NULL) { - Tk_DrawChars(menuPtr->display, d, gc, tkfont, mePtr->accel, + if (mePtr->accelPtr != NULL) { + Tk_DrawChars(menuPtr->display, d, gc, tkfont, accel, mePtr->accelLength, leftEdge, baseline); } - if ((mePtr->state == tkDisabledUid) + if ((state == ENTRY_DISABLED) && (menuPtr->disabledImageGC != None) && (versionInfo.dwMajorVersion < 4)) { XFillRectangle(menuPtr->display, d, menuPtr->disabledImageGC, @@ -1561,7 +1644,7 @@ DrawMenuEntryAccelerator(menuPtr, mePtr, d, gc, tkfont, fmPtr, rect.right = x + width - 1; DrawWindowsSystemBitmap(menuPtr->display, d, gc, &rect, OBM_MNARROW, ALIGN_BITMAP_RIGHT); - if ((mePtr->state == tkDisabledUid) + if ((state == ENTRY_DISABLED) && (menuPtr->disabledImageGC != None) && (versionInfo.dwMajorVersion < 4)) { XFillRectangle(menuPtr->display, d, menuPtr->disabledImageGC, @@ -1600,13 +1683,15 @@ DrawMenuSeparator(menuPtr, mePtr, d, gc, tkfont, fmPtr, x, y, width, height) int height; /* height of item */ { XPoint points[2]; + Tk_3DBorder border; points[0].x = x; points[0].y = y + height / 2; points[1].x = x + width - 1; points[1].y = points[0].y; - Tk_Draw3DPolygon(menuPtr->tkwin, d, - menuPtr->border, points, 2, 1, TK_RELIEF_RAISED); + border = Tk_Get3DBorderFromObj(menuPtr->tkwin, menuPtr->borderPtr); + Tk_Draw3DPolygon(menuPtr->tkwin, d, border, points, 2, 1, + TK_RELIEF_RAISED); } /* @@ -1640,8 +1725,10 @@ DrawMenuUnderline( int height) /* Height of entry */ { if (mePtr->underline >= 0) { + char *label = Tcl_GetStringFromObj(mePtr->labelPtr, NULL); + Tk_UnderlineChars(menuPtr->display, d, - gc, tkfont, mePtr->label, x + mePtr->indicatorSpace, + gc, tkfont, label, x + mePtr->indicatorSpace, y + (height + fmPtr->ascent - fmPtr->descent) / 2, mePtr->underline, mePtr->underline + 1); } @@ -1822,8 +1909,14 @@ DrawMenuEntryLabel( { int baseline; int indicatorSpace = mePtr->indicatorSpace; - int leftEdge = x + indicatorSpace + menuPtr->activeBorderWidth; + int activeBorderWidth; + int leftEdge; int imageHeight, imageWidth; + int state; + + Tk_GetPixelsFromObj(menuPtr->interp, menuPtr->tkwin, + menuPtr->activeBorderWidthPtr, &activeBorderWidth); + leftEdge = x + indicatorSpace + activeBorderWidth; /* * Draw label or bitmap or image for entry. @@ -1842,27 +1935,27 @@ DrawMenuEntryLabel( imageHeight, d, leftEdge, (int) (y + (mePtr->height - imageHeight)/2)); } - } else if (mePtr->bitmap != None) { + } else if (mePtr->bitmapPtr != NULL) { int width, height; - - Tk_SizeOfBitmap(menuPtr->display, - mePtr->bitmap, &width, &height); - XCopyPlane(menuPtr->display, - mePtr->bitmap, d, - gc, 0, 0, (unsigned) width, (unsigned) height, leftEdge, - (int) (y + (mePtr->height - height)/2), 1); + Pixmap bitmap = Tk_GetBitmapFromObj(menuPtr->tkwin, mePtr->bitmapPtr); + Tk_SizeOfBitmap(menuPtr->display, bitmap, &width, &height); + XCopyPlane(menuPtr->display, bitmap, d, gc, 0, 0, (unsigned) width, + (unsigned) height, leftEdge, + (int) (y + (mePtr->height - height)/2), 1); } else { if (mePtr->labelLength > 0) { - Tk_DrawChars(menuPtr->display, d, gc, - tkfont, mePtr->label, mePtr->labelLength, - leftEdge, baseline); + char *label = Tcl_GetStringFromObj(mePtr->labelPtr, NULL); + Tk_DrawChars(menuPtr->display, d, gc, tkfont, label, + mePtr->labelLength, leftEdge, baseline); DrawMenuUnderline(menuPtr, mePtr, d, gc, tkfont, fmPtr, x, y, width, height); } } - if (mePtr->state == tkDisabledUid) { - if (menuPtr->disabledFg == NULL) { + Tcl_GetIndexFromObj(NULL, mePtr->statePtr, tkMenuStateStrings, NULL, + 0, &state); + if (state == ENTRY_DISABLED) { + if (menuPtr->disabledFgPtr == NULL) { XFillRectangle(menuPtr->display, d, menuPtr->disabledGC, x, y, (unsigned) width, (unsigned) height); } else if ((mePtr->image != NULL) @@ -1933,6 +2026,7 @@ DrawTearoffEntry(menuPtr, mePtr, d, gc, tkfont, fmPtr, x, y, width, height) { XPoint points[2]; int segmentWidth, maxX; + Tk_3DBorder border; if (menuPtr->menuType != MASTER_MENU) { return; @@ -1943,13 +2037,14 @@ DrawTearoffEntry(menuPtr, mePtr, d, gc, tkfont, fmPtr, x, y, width, height) 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, menuPtr->border, points, 2, 1, + Tk_Draw3DPolygon(menuPtr->tkwin, d, border, points, 2, 1, TK_RELIEF_RAISED); points[0].x += 2*segmentWidth; } @@ -1964,7 +2059,7 @@ DrawTearoffEntry(menuPtr, mePtr, d, gc, tkfont, fmPtr, x, y, width, height) * * Results: * Returns standard TCL result. If TCL_ERROR is returned, then - * interp->result contains an error message. + * the interp's result contains an error message. * * Side effects: * Configuration information get set for mePtr; old resources @@ -2030,13 +2125,15 @@ TkpDrawMenuEntry(mePtr, d, tkfont, menuMetricsPtr, x, y, width, height, int padY = (menuPtr->menuType == MENUBAR) ? 3 : 0; int adjustedY = y + padY; int adjustedHeight = height - 2 * padY; + int state; /* * Choose the gc for drawing the foreground part of the entry. */ - if ((mePtr->state == tkActiveUid) - && !strictMotif) { + Tcl_GetIndexFromObj(NULL, mePtr->statePtr, tkMenuStateStrings, NULL, + 0, &state); + if ((state == ENTRY_ACTIVE) && !strictMotif) { gc = mePtr->activeGC; if (gc == NULL) { gc = menuPtr->activeGC; @@ -2044,21 +2141,22 @@ TkpDrawMenuEntry(mePtr, d, tkfont, menuMetricsPtr, x, y, width, height, } else { TkMenuEntry *cascadeEntryPtr; int parentDisabled = 0; + char *name; for (cascadeEntryPtr = menuPtr->menuRefPtr->parentEntryPtr; cascadeEntryPtr != NULL; cascadeEntryPtr = cascadeEntryPtr->nextCascadePtr) { - if (strcmp(cascadeEntryPtr->name, - Tk_PathName(menuPtr->tkwin)) == 0) { - if (cascadeEntryPtr->state == tkDisabledUid) { + name = Tcl_GetStringFromObj(cascadeEntryPtr->namePtr, NULL); + if (strcmp(name, Tk_PathName(menuPtr->tkwin)) == 0) { + if (state == ENTRY_DISABLED) { parentDisabled = 1; } break; } } - if (((parentDisabled || (mePtr->state == tkDisabledUid))) - && (menuPtr->disabledFg != NULL)) { + if (((parentDisabled || (state == ENTRY_DISABLED))) + && (menuPtr->disabledFgPtr != NULL)) { gc = mePtr->disabledGC; if (gc == NULL) { gc = menuPtr->disabledGC; @@ -2074,24 +2172,22 @@ TkpDrawMenuEntry(mePtr, d, tkfont, menuMetricsPtr, x, y, width, height, if (indicatorGC == NULL) { indicatorGC = menuPtr->indicatorGC; } - - bgBorder = mePtr->border; - if (bgBorder == NULL) { - bgBorder = menuPtr->border; - } + + bgBorder = Tk_Get3DBorderFromObj(menuPtr->tkwin, + (mePtr->borderPtr == NULL) ? menuPtr->borderPtr + : mePtr->borderPtr); if (strictMotif) { activeBorder = bgBorder; } else { - activeBorder = mePtr->activeBorder; - if (activeBorder == NULL) { - activeBorder = menuPtr->activeBorder; - } + activeBorder = Tk_Get3DBorderFromObj(menuPtr->tkwin, + (mePtr->activeBorderPtr == NULL) ? menuPtr->activeBorderPtr + : mePtr->activeBorderPtr); } - if (mePtr->tkfont == NULL) { + if (mePtr->fontPtr == NULL) { fmPtr = menuMetricsPtr; } else { - tkfont = mePtr->tkfont; + tkfont = Tk_GetFontFromObj(menuPtr->tkwin, mePtr->fontPtr); Tk_GetFontMetrics(tkfont, &entryMetrics); fmPtr = &entryMetrics; } @@ -2112,11 +2208,14 @@ TkpDrawMenuEntry(mePtr, d, tkfont, menuMetricsPtr, x, y, width, height, DrawTearoffEntry(menuPtr, mePtr, d, gc, tkfont, fmPtr, x, adjustedY, width, adjustedHeight); } else { + int hideMargin; + 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) { + Tcl_GetBooleanFromObj(NULL, mePtr->hideMarginPtr, &hideMargin); + if (!hideMargin) { DrawMenuEntryIndicator(menuPtr, mePtr, d, gc, indicatorGC, tkfont, fmPtr, x, adjustedY, width, adjustedHeight); } @@ -2154,13 +2253,16 @@ GetMenuLabelGeometry(mePtr, tkfont, fmPtr, widthPtr, heightPtr) if (mePtr->image != NULL) { Tk_SizeOfImage(mePtr->image, widthPtr, heightPtr); - } else if (mePtr->bitmap != (Pixmap) NULL) { - Tk_SizeOfBitmap(menuPtr->display, mePtr->bitmap, widthPtr, heightPtr); + } else if (mePtr->bitmapPtr != NULL) { + Pixmap bitmap = Tk_GetBitmapFromObj(menuPtr->tkwin, mePtr->bitmapPtr); + Tk_SizeOfBitmap(menuPtr->display, bitmap, widthPtr, heightPtr); } else { *heightPtr = fmPtr->linespace; - if (mePtr->label != NULL) { - *widthPtr = Tk_TextWidth(tkfont, mePtr->label, mePtr->labelLength); + if (mePtr->labelPtr != NULL) { + char *label = Tcl_GetStringFromObj(mePtr->labelPtr, NULL); + + *widthPtr = Tk_TextWidth(tkfont, label, mePtr->labelLength); } else { *widthPtr = 0; } @@ -2197,7 +2299,11 @@ DrawMenuEntryBackground( int width, /* width of rectangle to draw */ int height) /* height of rectangle to draw */ { - if (mePtr->state == tkActiveUid) { + int state; + + Tcl_GetIndexFromObj(NULL, mePtr->statePtr, tkMenuStateStrings, + NULL, 0, &state); + if (state == ENTRY_ACTIVE) { bgBorder = activeBorder; } Tk_Fill3DRectangle(menuPtr->tkwin, d, bgBorder, @@ -2227,17 +2333,21 @@ void TkpComputeStandardMenuGeometry( TkMenu *menuPtr) /* Structure describing menu. */ { - Tk_Font tkfont; + Tk_Font menuFont, tkfont; Tk_FontMetrics menuMetrics, entryMetrics, *fmPtr; int x, y, height, width, indicatorSpace, labelWidth, accelWidth; int windowWidth, windowHeight, accelSpace; int i, j, lastColumnBreak = 0; + int columnBreak; + int activeBorderWidth, borderWidth; if (menuPtr->tkwin == NULL) { return; } - x = y = menuPtr->borderWidth; + Tk_GetPixelsFromObj(menuPtr->interp, menuPtr->tkwin, + menuPtr->borderWidthPtr, &borderWidth); + x = y = borderWidth; indicatorSpace = labelWidth = accelWidth = 0; windowHeight = 0; @@ -2252,20 +2362,26 @@ TkpComputeStandardMenuGeometry( * give all of the geometry/drawing the entry's font and metrics. */ - Tk_GetFontMetrics(menuPtr->tkfont, &menuMetrics); - accelSpace = Tk_TextWidth(menuPtr->tkfont, "M", 1); + menuFont = Tk_GetFontFromObj(menuPtr->tkwin, menuPtr->fontPtr); + Tk_GetFontMetrics(menuFont, &menuMetrics); + accelSpace = Tk_TextWidth(menuFont, "M", 1); + Tk_GetPixelsFromObj(menuPtr->interp, menuPtr->tkwin, + menuPtr->activeBorderWidthPtr, &activeBorderWidth); for (i = 0; i < menuPtr->numEntries; i++) { - tkfont = menuPtr->entries[i]->tkfont; - if (tkfont == NULL) { - tkfont = menuPtr->tkfont; - fmPtr = &menuMetrics; - } else { + if (menuPtr->entries[i]->fontPtr == NULL) { + tkfont = menuFont; + fmPtr = &menuMetrics; + } else { + tkfont = Tk_GetFontFromObj(menuPtr->tkwin, + menuPtr->entries[i]->fontPtr); Tk_GetFontMetrics(tkfont, &entryMetrics); fmPtr = &entryMetrics; } - - if ((i > 0) && menuPtr->entries[i]->columnBreak) { + + Tcl_GetBooleanFromObj(NULL, menuPtr->entries[i]->columnBreakPtr, + &columnBreak); + if ((i > 0) && columnBreak) { if (accelWidth != 0) { labelWidth += accelSpace; } @@ -2273,15 +2389,15 @@ TkpComputeStandardMenuGeometry( menuPtr->entries[j]->indicatorSpace = indicatorSpace; menuPtr->entries[j]->labelWidth = labelWidth; menuPtr->entries[j]->width = indicatorSpace + labelWidth - + accelWidth + 2 * menuPtr->activeBorderWidth; + + accelWidth + 2 * activeBorderWidth; menuPtr->entries[j]->x = x; menuPtr->entries[j]->entryFlags &= ~ENTRY_LAST_COLUMN; } x += indicatorSpace + labelWidth + accelWidth - + 2 * menuPtr->borderWidth; + + 2 * borderWidth; indicatorSpace = labelWidth = accelWidth = 0; lastColumnBreak = i; - y = menuPtr->borderWidth; + y = borderWidth; } if (menuPtr->entries[i]->type == SEPARATOR_ENTRY) { @@ -2329,7 +2445,7 @@ TkpComputeStandardMenuGeometry( indicatorSpace = width; } - menuPtr->entries[i]->height += 2 * menuPtr->activeBorderWidth + 1; + menuPtr->entries[i]->height += 2 * activeBorderWidth + 1; } menuPtr->entries[i]->y = y; y += menuPtr->entries[i]->height; @@ -2345,16 +2461,15 @@ TkpComputeStandardMenuGeometry( menuPtr->entries[j]->indicatorSpace = indicatorSpace; menuPtr->entries[j]->labelWidth = labelWidth; menuPtr->entries[j]->width = indicatorSpace + labelWidth - + accelWidth + 2 * menuPtr->activeBorderWidth; + + accelWidth + 2 * activeBorderWidth; menuPtr->entries[j]->x = x; menuPtr->entries[j]->entryFlags |= ENTRY_LAST_COLUMN; } windowWidth = x + indicatorSpace + labelWidth + accelWidth + accelSpace - + 2 * menuPtr->activeBorderWidth - + 2 * menuPtr->borderWidth; + + 2 * activeBorderWidth + 2 * borderWidth; - windowHeight += menuPtr->borderWidth; + windowHeight += borderWidth; /* * The X server doesn't like zero dimensions, so round up to at least @@ -2487,7 +2602,45 @@ MenuExitHandler( /* *---------------------------------------------------------------------- * - * TkpMenuInit -- + * TkWinGetMenuSystemDefault -- + * + * Gets the Windows specific default value for a given X resource + * database name. + * + * Results: + * Returns a Tcl_Obj * with the default value. If there is no + * Windows-specific default for this attribute, returns NULL. + * This object has a ref count of 0. + * + * Side effects: + * Storage is allocated. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TkWinGetMenuSystemDefault( + Tk_Window tkwin, /* A window to use. */ + char *dbName, /* The option database name. */ + char *className) /* The name of the option class. */ +{ + Tcl_Obj *valuePtr = NULL; + + if ((strcmp(dbName, "activeBorderWidth") == 0) || + (strcmp(dbName, "borderWidth") == 0)) { + valuePtr = Tcl_NewIntObj(defaultBorderWidth); + } else if (strcmp(dbName, "font") == 0) { + valuePtr = Tcl_NewStringObj(Tcl_DStringValue(&menuFontDString), + -1); + } + + return valuePtr; +} + +/* + *---------------------------------------------------------------------- + * + * TkWinMenuSetDefaults -- * * Sets up the hash tables and the variables used by the menu package. * @@ -2502,37 +2655,20 @@ MenuExitHandler( */ void -TkpMenuInit() +SetDefaults( + int firstTime) /* Is this the first time this + * has been called? */ { - WNDCLASS wndClass; - char sizeString[4]; + char sizeString[TCL_INTEGER_SPACE]; char faceName[LF_FACESIZE]; HDC scratchDC; Tcl_DString boldItalicDString; int bold = 0; int italic = 0; - int i; TEXTMETRIC tm; + int pointSize; + HFONT menuFont; - Tcl_InitHashTable(&winMenuTable, TCL_ONE_WORD_KEYS); - Tcl_InitHashTable(&commandTable, TCL_ONE_WORD_KEYS); - - wndClass.style = CS_OWNDC; - wndClass.lpfnWndProc = TkWinMenuProc; - wndClass.cbClsExtra = 0; - wndClass.cbWndExtra = 0; - wndClass.hInstance = Tk_GetHINSTANCE(); - wndClass.hIcon = NULL; - wndClass.hCursor = NULL; - wndClass.hbrBackground = (HBRUSH)(COLOR_WINDOW + 1); - wndClass.lpszMenuName = NULL; - wndClass.lpszClassName = MENU_CLASS_NAME; - RegisterClass(&wndClass); - - menuHWND = CreateWindow(MENU_CLASS_NAME, "MenuWindow", WS_POPUP, - 0, 0, 10, 10, NULL, NULL, Tk_GetHINSTANCE(), NULL); - - Tcl_CreateExitHandler(MenuExitHandler, (ClientData) NULL); versionInfo.dwOSVersionInfoSize = sizeof(versionInfo); @@ -2551,74 +2687,59 @@ TkpMenuInit() * out of options via a break statement. */ - for (i = 0; ; i++) { - if (tkMenuConfigSpecs[i].type == TK_CONFIG_END) { - break; - } + defaultBorderWidth = GetSystemMetrics(SM_CXBORDER); + if (GetSystemMetrics(SM_CYBORDER) > defaultBorderWidth) { + defaultBorderWidth = GetSystemMetrics(SM_CYBORDER); + } - if ((strcmp(tkMenuConfigSpecs[i].dbName, - "activeBorderWidth") == 0) || - (strcmp(tkMenuConfigSpecs[i].dbName, "borderWidth") == 0)) { - int borderWidth; - borderWidth = GetSystemMetrics(SM_CXBORDER); - if (GetSystemMetrics(SM_CYBORDER) > borderWidth) { - borderWidth = GetSystemMetrics(SM_CYBORDER); - } - sprintf(borderString, "%d", borderWidth); - tkMenuConfigSpecs[i].defValue = borderString; - } else if ((strcmp(tkMenuConfigSpecs[i].dbName, "font") == 0)) { - int pointSize; - HFONT menuFont; - - scratchDC = CreateDC("DISPLAY", NULL, NULL, NULL); - Tcl_DStringInit(&menuFontDString); - - if (versionInfo.dwMajorVersion >= 4) { - NONCLIENTMETRICS ncMetrics; - - ncMetrics.cbSize = sizeof(ncMetrics); - SystemParametersInfo(SPI_GETNONCLIENTMETRICS, sizeof(ncMetrics), - &ncMetrics, 0); - menuFont = CreateFontIndirect(&ncMetrics.lfMenuFont); - } else { - menuFont = GetStockObject(SYSTEM_FONT); - } - SelectObject(scratchDC, menuFont); - GetTextMetrics(scratchDC, &tm); - GetTextFace(scratchDC, sizeof(menuFontDString), faceName); - pointSize = MulDiv(tm.tmHeight - tm.tmInternalLeading, - 72, GetDeviceCaps(scratchDC, LOGPIXELSY)); - if (tm.tmWeight >= 700) { - bold = 1; - } - if (tm.tmItalic) { - italic = 1; - } + scratchDC = CreateDC("DISPLAY", NULL, NULL, NULL); + if (!firstTime) { + Tcl_DStringFree(&menuFontDString); + } + Tcl_DStringInit(&menuFontDString); - SelectObject(scratchDC, GetStockObject(SYSTEM_FONT)); - DeleteDC(scratchDC); + if (versionInfo.dwMajorVersion >= 4) { + NONCLIENTMETRICS ncMetrics; - DeleteObject(menuFont); - - Tcl_DStringAppendElement(&menuFontDString, faceName); - sprintf(sizeString, "%d", pointSize); - Tcl_DStringAppendElement(&menuFontDString, sizeString); - - if (bold == 1 || italic == 1) { - Tcl_DStringInit(&boldItalicDString); - if (bold == 1) { - Tcl_DStringAppendElement(&boldItalicDString, "bold"); - } - if (italic == 1) { - Tcl_DStringAppendElement(&boldItalicDString, "italic"); - } - Tcl_DStringAppendElement(&menuFontDString, - Tcl_DStringValue(&boldItalicDString)); - } + ncMetrics.cbSize = sizeof(ncMetrics); + SystemParametersInfo(SPI_GETNONCLIENTMETRICS, sizeof(ncMetrics), + &ncMetrics, 0); + menuFont = CreateFontIndirect(&ncMetrics.lfMenuFont); + } else { + menuFont = GetStockObject(SYSTEM_FONT); + } + SelectObject(scratchDC, menuFont); + GetTextMetrics(scratchDC, &tm); + GetTextFace(scratchDC, sizeof(menuFontDString), faceName); + pointSize = MulDiv(tm.tmHeight - tm.tmInternalLeading, + 72, GetDeviceCaps(scratchDC, LOGPIXELSY)); + if (tm.tmWeight >= 700) { + bold = 1; + } + if (tm.tmItalic) { + italic = 1; + } - tkMenuConfigSpecs[i].defValue = Tcl_DStringValue(&menuFontDString); + SelectObject(scratchDC, GetStockObject(SYSTEM_FONT)); + DeleteDC(scratchDC); + + DeleteObject(menuFont); + + Tcl_DStringAppendElement(&menuFontDString, faceName); + sprintf(sizeString, "%d", pointSize); + Tcl_DStringAppendElement(&menuFontDString, sizeString); + + if (bold == 1 || italic == 1) { + Tcl_DStringInit(&boldItalicDString); + if (bold == 1) { + Tcl_DStringAppendElement(&boldItalicDString, "bold"); } + if (italic == 1) { + Tcl_DStringAppendElement(&boldItalicDString, "italic"); + } + Tcl_DStringAppendElement(&menuFontDString, + Tcl_DStringValue(&boldItalicDString)); } /* @@ -2642,5 +2763,47 @@ TkpMenuInit() indicatorDimensions[0] = HIWORD(dimensions); indicatorDimensions[1] = LOWORD(dimensions); } +} + +/* + *---------------------------------------------------------------------- + * + * TkpMenuInit -- + * + * Sets up the hash tables and the variables used by the menu package. + * + * Results: + * None. + * + * Side effects: + * lastMenuID gets initialized, and the parent hash and the command hash + * are allocated. + * + *---------------------------------------------------------------------- + */ + +void +TkpMenuInit() +{ + WNDCLASS wndClass; + Tcl_InitHashTable(&winMenuTable, TCL_ONE_WORD_KEYS); + Tcl_InitHashTable(&commandTable, TCL_ONE_WORD_KEYS); + wndClass.style = CS_OWNDC; + wndClass.lpfnWndProc = TkWinMenuProc; + wndClass.cbClsExtra = 0; + wndClass.cbWndExtra = 0; + wndClass.hInstance = Tk_GetHINSTANCE(); + wndClass.hIcon = NULL; + wndClass.hCursor = NULL; + wndClass.hbrBackground = (HBRUSH)(COLOR_WINDOW + 1); + wndClass.lpszMenuName = NULL; + wndClass.lpszClassName = MENU_CLASS_NAME; + RegisterClass(&wndClass); + + menuHWND = CreateWindow(MENU_CLASS_NAME, "MenuWindow", WS_POPUP, + 0, 0, 10, 10, NULL, NULL, Tk_GetHINSTANCE(), NULL); + + Tcl_CreateExitHandler(MenuExitHandler, (ClientData) NULL); + SetDefaults(1); } diff --git a/win/tkWinPort.h b/win/tkWinPort.h index 1f755a7..c2e9658 100644 --- a/win/tkWinPort.h +++ b/win/tkWinPort.h @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkWinPort.h 1.25 97/04/21 17:08:42 + * SCCS: @(#) tkWinPort.h 1.27 98/02/10 10:35:52 */ #ifndef _WINPORT @@ -33,6 +33,7 @@ #include <io.h> #include <sys/stat.h> #include <time.h> +#include <tchar.h> #ifdef _MSC_VER # define hypot _hypot @@ -89,7 +90,6 @@ * The following Tk functions are implemented as macros under Windows. */ -#define TkGetNativeProlog(interp) TkGetProlog(interp) #define TkpGetPixel(p) (((((p)->red >> 8) & 0xff) \ | ((p)->green & 0xff00) | (((p)->blue << 8) & 0xff0000)) | 0x20000000) diff --git a/win/tkWinScrlbr.c b/win/tkWinScrlbr.c index 6c1a664..613469f 100644 --- a/win/tkWinScrlbr.c +++ b/win/tkWinScrlbr.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkWinScrlbr.c 1.19 97/08/13 17:37:49 + * SCCS: @(#) tkWinScrlbr.c 1.20 97/11/07 21:25:53 */ #include "tkWinInt.h" @@ -62,7 +62,7 @@ static int vArrowWidth, vArrowHeight, vThumb; /* Vertical control metrics. */ * form for use in a Tk_ConfigSpec. */ -static char defWidth[8]; +static char defWidth[TCL_INTEGER_SPACE]; /* * Declarations for functions defined in this file. diff --git a/win/tkWinSend.c b/win/tkWinSend.c index 6d12ed4..120ccf9 100644 --- a/win/tkWinSend.c +++ b/win/tkWinSend.c @@ -10,11 +10,67 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkWinSend.c 1.4 97/06/10 09:39:50 + * SCCS: @(#) tkWinSend.c 1.15 98/02/19 17:04:54 */ -#include "tkPort.h" -#include "tkInt.h" +#include "tkWinInt.h" +#include <ddeml.h> + +/* + * The following structure is used to keep track of the interpreters + * registered by this process. + */ + +typedef struct RegisteredInterp { + struct RegisteredInterp *nextPtr; + /* The next interp this application knows + * about. */ + char *name; /* Interpreter's name (malloc-ed). */ + Tcl_Interp *interp; /* The interpreter attached to this name. */ +} RegisteredInterp; + +/* + * Used to keep track of conversations. + */ + +typedef struct Conversation { + struct Conversation *nextPtr; + /* The next conversation in the list. */ + RegisteredInterp *riPtr; /* The info we know about the conversation. */ + HCONV hConv; /* The DDE handle for this conversation. */ + Tcl_Obj *returnPackagePtr; /* The result package for this conversation. */ +} Conversation; + +/* + * Static variables used by the registration process. Most of these + * are allocated in RegOpen and freed in RegClose. + */ + +static Conversation *currentConversations; + /* A list of conversations currently + * being processed. */ +static DWORD ddeInstance = 0; /* The application instance handle given + * to us by DdeInitialize. */ +static RegisteredInterp *interpListPtr; + /* The list of interps that this particular + * application knows about. */ + +/* + * Forward declarations for procedures defined later in this file. + */ + +static void RemoveDdeServerExitProc _ANSI_ARGS_((ClientData clientData)); +static void DeleteProc _ANSI_ARGS_((ClientData clientData)); +static Tcl_Obj * ExecuteRemoteObject _ANSI_ARGS_(( + RegisteredInterp *riPtr, + Tcl_Obj *ddeObjectPtr)); +static int MakeDdeConnection _ANSI_ARGS_((Tcl_Interp *interp, + char *name, HCONV *ddeConvPtr)); +static HDDEDATA CALLBACK TkDdeServerProc _ANSI_ARGS_((UINT uType, + UINT uFmt, HCONV hConv, HSZ ddeTopic, + HSZ ddeItem, HDDEDATA hData, DWORD dwData1, + DWORD dwData2)); +static void SetDdeError _ANSI_ARGS_((Tcl_Interp *interp)); /* @@ -52,7 +108,360 @@ Tk_SetAppName(tkwin, name) * "send" commands. Must be globally * unique. */ { - return name; + TkWindow *winPtr = (TkWindow *) tkwin; + Tcl_Interp *interp = winPtr->mainPtr->interp; + int i, suffix, offset; + RegisteredInterp *riPtr, *prevPtr; + char *actualName; + Tcl_DString dString; + Tcl_Obj *resultObjPtr, *interpNamePtr; + char *interpName; + + /* + * Make sure that the DDE server is there. This is done only once, + * add an exit handler tear it down. + */ + + if (ddeInstance == 0) { + HSZ ddeService; + + if (DdeInitialize(&ddeInstance, TkDdeServerProc, + CBF_SKIP_REGISTRATIONS|CBF_SKIP_UNREGISTRATIONS + |CBF_FAIL_POKES, 0) + != DMLERR_NO_ERROR) { + DdeUninitialize(ddeInstance); + return NULL; + } + Tcl_CreateExitHandler(RemoveDdeServerExitProc, NULL); + ddeService = DdeCreateStringHandle(ddeInstance, "Tk", 0); + DdeNameService(ddeInstance, ddeService, 0L, DNS_REGISTER); + } + + /* + * See if the application is already registered; if so, remove its + * current name from the registry. The deletion of the command + * will take care of disposing of this entry. + */ + + for (riPtr = interpListPtr, prevPtr = NULL; riPtr != NULL; + prevPtr = riPtr, riPtr = riPtr->nextPtr) { + if (riPtr->interp == interp) { + if (prevPtr == NULL) { + interpListPtr = interpListPtr->nextPtr; + } else { + prevPtr->nextPtr = riPtr->nextPtr; + } + 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; + suffix = 1; + offset = 0; + Tcl_DStringInit(&dString); + + TkGetInterpNames(interp, tkwin); + resultObjPtr = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(resultObjPtr); + for (i = 0; ; ) { + (void) Tcl_ListObjIndex(NULL, resultObjPtr, i, &interpNamePtr); + if (interpNamePtr == NULL) { + break; + } + interpName = Tcl_GetString(interpNamePtr); + if (stricmp(actualName, interpName) == 0) { + if (suffix == 1) { + Tcl_DStringAppend(&dString, name, -1); + Tcl_DStringAppend(&dString, " #", 2); + offset = Tcl_DStringLength(&dString); + Tcl_DStringSetLength(&dString, offset + 10); + actualName = Tcl_DStringValue(&dString); + } + suffix++; + sprintf(actualName + offset, "%d", suffix); + i = 0; + } else { + i++; + } + } + + Tcl_DecrRefCount(resultObjPtr); + Tcl_ResetResult(interp); + + /* + * We have found a unique name. Now add it to the registry. + */ + + riPtr = (RegisteredInterp *) ckalloc(sizeof(RegisteredInterp)); + riPtr->interp = interp; + riPtr->name = ckalloc(strlen(actualName) + 1); + riPtr->nextPtr = interpListPtr; + interpListPtr = riPtr; + strcpy(riPtr->name, actualName); + + Tcl_CreateObjCommand(interp, "send", Tk_SendObjCmd, + (ClientData) riPtr, DeleteProc); + Tcl_CreateObjCommand(interp, "dde", Tk_DdeObjCmd, + (ClientData) NULL, NULL); + if (Tcl_IsSafe(interp)) { + Tcl_HideCommand(interp, "send", "send"); + Tcl_HideCommand(interp, "dde", "dde"); + } + Tcl_DStringFree(&dString); + + return riPtr->name; +} + +/* + *-------------------------------------------------------------- + * + * Tk_SendObjCmd -- + * + * This procedure 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, /* Used only for deletion */ + Tcl_Interp *interp, /* The interp we are sending from */ + int objc, /* Number of arguments */ + Tcl_Obj *CONST objv[]) /* The arguments */ +{ + char *string, *sendName; + int async, i, result, length; + RegisteredInterp *riPtr; + Tcl_Interp *sendInterp; + Tcl_Obj *objPtr; + static char *options[] = { + "-async", "-displayof", "--", (char *) NULL + }; + enum options { + SEND_ASYNC, SEND_DISPLAYOF, SEND_LAST + }; + + async = 0; + for (i = 1; i < objc; i++) { + int index; + + string = Tcl_GetString(objv[i]); + if (string[0] != '-') { + break; + } + if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", TCL_EXACT, + &index) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum options) index) { + case SEND_ASYNC: { + async = 1; + break; + } + case SEND_DISPLAYOF: { + /* + * Don't care about -displayof option. Skip the + * (ignored) window argument. + */ + + i++; + break; + } + case SEND_LAST: { + i++; + /* break 2; */ + goto endOfOptionLoop; + } + } + } + + endOfOptionLoop: + if (objc - i < 2) { + Tcl_WrongNumArgs(interp, 1, objv, + "?options? interpName arg ?arg ...?"); + return TCL_ERROR; + } + + sendName = Tcl_GetString(objv[i]); + objc -= i + 1; + ((Tcl_Obj **)objv) += i + 1; + + /* + * See if the target interpreter is local. If so, execute + * the command directly without going through the DDE server. + * Don't exchange objects between interps. The target interp could + * compile an object, producing a bytecode structure that refers to + * other objects owned by the target interp. If the target interp + * is then deleted, the bytecode structure would be referring to + * deallocated objects. + */ + + for (riPtr = interpListPtr; riPtr != NULL; riPtr = riPtr->nextPtr) { + if (stricmp(sendName, riPtr->name) == 0) { + break; + } + } + + if (riPtr != NULL) { + /* + * This command is to a local interp. No need to go through + * the server. + */ + + Tcl_Preserve((ClientData) riPtr); + sendInterp = riPtr->interp; + Tcl_Preserve((ClientData) sendInterp); + + /* + * Don't exchange objects between interps. The target interp would + * compile an object, producing a bytecode structure that refers to + * other objects owned by the target interp. If the target interp + * is then deleted, the bytecode structure would be referring to + * deallocated objects. + */ + + if (objc == 1) { + result = Tcl_EvalObj(sendInterp, objv[0], TCL_EVAL_GLOBAL); + } else { + objPtr = Tcl_ConcatObj(objc, objv); + Tcl_IncrRefCount(objPtr); + result = Tcl_EvalObj(sendInterp, objPtr, TCL_EVAL_GLOBAL); + Tcl_DecrRefCount(objPtr); + } + if (interp != sendInterp) { + if (result == TCL_ERROR) { + /* + * An error occurred, so transfer error information from the + * destination interpreter back to our interpreter. + */ + + Tcl_ResetResult(interp); + objPtr = Tcl_GetObjVar2(sendInterp, "errorInfo", NULL, + TCL_GLOBAL_ONLY); + string = Tcl_GetStringFromObj(objPtr, &length); + Tcl_AddObjErrorInfo(interp, string, length); + + objPtr = Tcl_GetObjVar2(sendInterp, "errorCode", NULL, + TCL_GLOBAL_ONLY); + Tcl_SetObjErrorCode(interp, objPtr); + } + Tcl_SetObjResult(interp, Tcl_GetObjResult(sendInterp)); + } + Tcl_Release((ClientData) riPtr); + Tcl_Release((ClientData) sendInterp); + } else { + /* + * This is a non-local request. Send the script to the server and poll + * it for a result. + */ + + HCONV hConv; + HDDEDATA ddeItem; + HDDEDATA ddeData; + DWORD ddeResult; + + if (MakeDdeConnection(interp, sendName, &hConv) != TCL_OK) { + return TCL_ERROR; + } + + objPtr = Tcl_ConcatObj(objc, objv); + string = Tcl_GetStringFromObj(objPtr, &length); + ddeItem = DdeCreateDataHandle(ddeInstance, string, length, 0, 0, + CF_TEXT, 0); + if (async) { + ddeData = DdeClientTransaction((LPBYTE) ddeItem, 0xFFFFFFFF, hConv, 0, + CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult); + DdeAbandonTransaction(ddeInstance, hConv, ddeResult); + } else { + ddeData = DdeClientTransaction((LPBYTE) ddeItem, 0xFFFFFFFF, hConv, 0, + CF_TEXT, XTYP_EXECUTE, 7200000, NULL); + if (ddeData != 0) { + HSZ ddeCookie; + + ddeCookie = DdeCreateStringHandle(ddeInstance, + "$TK$EXECUTE$RESULT", CP_WINANSI); + ddeData = DdeClientTransaction(NULL, 0, hConv, ddeCookie, + CF_TEXT, XTYP_REQUEST, 7200000, NULL); + DdeFreeStringHandle(ddeInstance, ddeCookie); + } + } + + DdeFreeDataHandle(ddeItem); + Tcl_DecrRefCount(objPtr); + + if (ddeData == 0) { + SetDdeError(interp); + DdeDisconnect(hConv); + return TCL_ERROR; + } + + if (async == 0) { + Tcl_Obj *resultPtr; + + /* + * The return handle has a two or four element list in it. The first + * element is the return code (TCL_OK, TCL_ERROR, etc.). The + * second is the result of the script. If the return code is TCL_ERROR, + * then the third element is the value of the variable "errorCode", + * and the fourth is the value of the variable "errorInfo". + */ + + length = DdeGetData(ddeData, NULL, 0, 0); + resultPtr = Tcl_NewObj(); + Tcl_SetObjLength(resultPtr, length); + string = Tcl_GetString(resultPtr); + DdeGetData(ddeData, string, length, 0); + DdeFreeDataHandle(ddeData); + DdeDisconnect(hConv); + + if (Tcl_ListObjIndex(NULL, resultPtr, 0, &objPtr) != TCL_OK) { + goto error; + } + if (Tcl_GetIntFromObj(NULL, objPtr, &result) != TCL_OK) { + goto error; + } + if (result == TCL_ERROR) { + Tcl_ResetResult(interp); + + if (Tcl_ListObjIndex(NULL, resultPtr, 3, &objPtr) != TCL_OK) { + goto error; + } + string = Tcl_GetStringFromObj(objPtr, &length); + Tcl_AddObjErrorInfo(interp, string, length); + + Tcl_ListObjIndex(NULL, resultPtr, 2, &objPtr); + Tcl_SetObjErrorCode(interp, objPtr); + } + if (Tcl_ListObjIndex(NULL, resultPtr, 1, &objPtr) != TCL_OK) { + goto error; + } + Tcl_SetObjResult(interp, objPtr); + Tcl_DecrRefCount(resultPtr); + return result; + + error: + Tcl_SetStringObj(Tcl_GetObjResult(interp), + "invalid data returned from server", -1); + Tcl_DecrRefCount(resultPtr); + return TCL_ERROR; + } + } + + return result; } /* @@ -65,10 +474,10 @@ Tk_SetAppName(tkwin, name) * of a particular window. * * Results: - * A standard Tcl return value. Interp->result will be set + * 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 interp->result will hold an error message. + * is returned and the interp's result will hold an error message. * * Side effects: * None. @@ -82,5 +491,766 @@ TkGetInterpNames(interp, tkwin) Tk_Window tkwin; /* Window whose display is to be used * for the lookup. */ { + Tcl_Obj *listObjPtr; + HCONVLIST hConvList; + HCONV hConv; + HSZ ddeService; + CONVINFO convInfo; + Tcl_DString dString; + char *topicName; + int len; + + convInfo.cb = sizeof(CONVINFO); + ddeService = DdeCreateStringHandle(ddeInstance, "Tk", CP_WINANSI); + hConvList = DdeConnectList(ddeInstance, ddeService, NULL, + 0, NULL); + hConv = 0; + + Tcl_DStringInit(&dString); + listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + while (hConv = DdeQueryNextServer(hConvList, hConv), hConv != 0) { + DdeQueryConvInfo(hConv, QID_SYNC, &convInfo); + len = DdeQueryString(ddeInstance, convInfo.hszTopic, + NULL, 0, CP_WINANSI); + Tcl_DStringSetLength(&dString, len); + topicName = Tcl_DStringValue(&dString); + DdeQueryString(ddeInstance, convInfo.hszTopic, topicName, + len + 1, CP_WINANSI); + Tcl_ListObjAppendElement(interp, listObjPtr, + Tcl_NewStringObj(topicName, len)); + } + + DdeDisconnectList(hConvList); + Tcl_SetObjResult(interp, listObjPtr); + Tcl_DStringFree(&dString); + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * DeleteProc -- + * + * This procedure 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 clientData; /* The interp we are deleting passed + * as ClientData. */ +{ + RegisteredInterp *riPtr = (RegisteredInterp *) clientData; + RegisteredInterp *searchPtr, *prevPtr; + + for (searchPtr = interpListPtr, prevPtr = NULL; + (searchPtr != NULL) && (searchPtr != riPtr); + prevPtr = searchPtr, searchPtr = searchPtr->nextPtr) { + /* + * Empty loop body. + */ + } + + Tcl_DeleteCommand(riPtr->interp, "dde"); + + if (searchPtr != NULL) { + if (prevPtr == NULL) { + interpListPtr = interpListPtr->nextPtr; + } else { + prevPtr->nextPtr = searchPtr->nextPtr; + } + } + ckfree(riPtr->name); + Tcl_EventuallyFree(clientData, TCL_DYNAMIC); +} + +/* + *-------------------------------------------------------------- + * + * ExecuteRemoteObject -- + * + * Takes the package delivered by DDE and executes it in + * the server's interpreter. + * + * Results: + * A list Tcl_Obj * that describes what happened. The first + * element is the numerical return code (TCL_ERROR, etc.). + * The second element is the result of the script. If the + * return result was TCL_ERROR, then the third element + * will be the value of the global "errorCode", and the + * fourth will be the value of the global "errorInfo". + * The return result will have a refCount of 0. + * + * Side effects: + * A Tcl script is run, which can cause all kinds of other + * things to happen. + * + *-------------------------------------------------------------- + */ + +static Tcl_Obj * +ExecuteRemoteObject( + RegisteredInterp *riPtr, /* Info about this server. */ + Tcl_Obj *ddeObjectPtr) /* The object to execute. */ +{ + Tcl_Obj *errorObjPtr; + Tcl_Obj *returnPackagePtr; + int result; + + result = Tcl_EvalObj(riPtr->interp, ddeObjectPtr, TCL_EVAL_GLOBAL); + returnPackagePtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + Tcl_ListObjAppendElement(NULL, returnPackagePtr, + Tcl_NewIntObj(result)); + Tcl_ListObjAppendElement(NULL, returnPackagePtr, + Tcl_GetObjResult(riPtr->interp)); + if (result == TCL_ERROR) { + errorObjPtr = Tcl_GetObjVar2(riPtr->interp, "errorCode", NULL, + TCL_GLOBAL_ONLY); + Tcl_ListObjAppendElement(NULL, returnPackagePtr, errorObjPtr); + errorObjPtr = Tcl_GetObjVar2(riPtr->interp, "errorInfo", NULL, + TCL_GLOBAL_ONLY); + Tcl_ListObjAppendElement(NULL, returnPackagePtr, errorObjPtr); + } + + return returnPackagePtr; +} + +/* + *-------------------------------------------------------------- + * + * TkDdeServerProc -- + * + * Handles all transactions for this server. Can handle + * execute, request, and connect protocols. Dde will + * call this routine when a client attempts to run a dde + * command using this server. + * + * Results: + * A DDE Handle with the result of the dde command. + * + * Side effects: + * Depending on which command is executed, arbitrary + * Tcl scripts can be run. + * + *-------------------------------------------------------------- + */ + +static HDDEDATA CALLBACK +TkDdeServerProc ( + UINT uType, /* The type of DDE transaction we + * are performing. */ + UINT uFmt, /* The format that data is sent or + * received. */ + HCONV hConv, /* The conversation associated with the + * current transaction. */ + HSZ ddeTopic, /* A string handle. Transaction-type + * dependent. */ + HSZ ddeItem, /* A string handle. Transaction-type + * dependent. */ + HDDEDATA hData, /* DDE data. Transaction-type dependent. */ + DWORD dwData1, /* Transaction-dependent data. */ + DWORD dwData2) /* Transaction-dependent data. */ +{ + Tcl_DString dString; + int len; + char *utilString; + Tcl_Obj *ddeObjectPtr; + HDDEDATA ddeReturn = NULL; + RegisteredInterp *riPtr; + Conversation *convPtr, *prevConvPtr; + + switch(uType) { + case XTYP_CONNECT: + + /* + * Dde is trying to initialize a conversation with us. Check + * and make sure we have a valid topic. + */ + + len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0); + Tcl_DStringInit(&dString); + Tcl_DStringSetLength(&dString, len); + utilString = Tcl_DStringValue(&dString); + DdeQueryString(ddeInstance, ddeTopic, utilString, len + 1, + CP_WINANSI); + + for (riPtr = interpListPtr; riPtr != NULL; + riPtr = riPtr->nextPtr) { + if (stricmp(utilString, riPtr->name) == 0) { + Tcl_DStringFree(&dString); + return (HDDEDATA) TRUE; + } + } + + Tcl_DStringFree(&dString); + return (HDDEDATA) FALSE; + + case XTYP_CONNECT_CONFIRM: + + /* + * Dde has decided that we can connect, so it gives us a + * conversation handle. We need to keep track of it + * so we know which execution result to return in an + * XTYP_REQUEST. + */ + + len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0); + Tcl_DStringInit(&dString); + Tcl_DStringSetLength(&dString, len); + utilString = Tcl_DStringValue(&dString); + DdeQueryString(ddeInstance, ddeTopic, utilString, len + 1, + CP_WINANSI); + for (riPtr = interpListPtr; riPtr != NULL; + riPtr = riPtr->nextPtr) { + if (stricmp(riPtr->name, utilString) == 0) { + convPtr = (Conversation *) ckalloc(sizeof(Conversation)); + convPtr->nextPtr = currentConversations; + convPtr->returnPackagePtr = NULL; + convPtr->hConv = hConv; + convPtr->riPtr = riPtr; + currentConversations = convPtr; + break; + } + } + Tcl_DStringFree(&dString); + return (HDDEDATA) TRUE; + + case XTYP_DISCONNECT: + + /* + * The client has disconnected from our server. Forget this + * conversation. + */ + + for (convPtr = currentConversations, prevConvPtr = NULL; + convPtr != NULL; + prevConvPtr = convPtr, convPtr = convPtr->nextPtr) { + if (hConv == convPtr->hConv) { + if (prevConvPtr == NULL) { + currentConversations = convPtr->nextPtr; + } else { + prevConvPtr->nextPtr = convPtr->nextPtr; + } + if (convPtr->returnPackagePtr != NULL) { + Tcl_DecrRefCount(convPtr->returnPackagePtr); + } + ckfree((char *) convPtr); + break; + } + } + return (HDDEDATA) TRUE; + + case XTYP_REQUEST: + + /* + * This could be either a request for a value of a Tcl variable, + * or it could be the send command requesting the results of the + * last execute. + */ + + if (uFmt != CF_TEXT) { + return (HDDEDATA) FALSE; + } + + ddeReturn = (HDDEDATA) FALSE; + for (convPtr = currentConversations; (convPtr != NULL) + && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) { + /* + * Empty loop body. + */ + } + + if (convPtr != NULL) { + char *returnString; + + len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, + CP_WINANSI); + Tcl_DStringInit(&dString); + Tcl_DStringSetLength(&dString, len); + utilString = Tcl_DStringValue(&dString); + DdeQueryString(ddeInstance, ddeItem, utilString, len + 1, + CP_WINANSI); + if (stricmp(utilString, "$TK$EXECUTE$RESULT") == 0) { + returnString = + Tcl_GetStringFromObj(convPtr->returnPackagePtr, &len); + ddeReturn = DdeCreateDataHandle(ddeInstance, + returnString, len, 0, ddeItem, CF_TEXT, + 0); + } else { + Tcl_Obj *variableObjPtr = Tcl_GetObjVar2( + convPtr->riPtr->interp, utilString, NULL, + TCL_GLOBAL_ONLY); + if (variableObjPtr != NULL) { + returnString = Tcl_GetStringFromObj(variableObjPtr, + &len); + ddeReturn = DdeCreateDataHandle(ddeInstance, + returnString, len, 0, ddeItem, CF_TEXT, 0); + } else { + ddeReturn = NULL; + } + } + Tcl_DStringFree(&dString); + } + return ddeReturn; + + case XTYP_EXECUTE: { + + /* + * Execute this script. The results will be saved into + * a list object which will be retreived later. See + * ExecuteRemoteObject. + */ + + Tcl_Obj *returnPackagePtr; + + for (convPtr = currentConversations; (convPtr != NULL) + && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) { + /* + * Empty loop body. + */ + + } + + if (convPtr == NULL) { + return (HDDEDATA) DDE_FNOTPROCESSED; + } + + utilString = (char *) DdeAccessData(hData, &len); + ddeObjectPtr = Tcl_NewStringObj(utilString, len); + Tcl_IncrRefCount(ddeObjectPtr); + DdeUnaccessData(hData); + if (convPtr->returnPackagePtr != NULL) { + Tcl_DecrRefCount(convPtr->returnPackagePtr); + } + convPtr->returnPackagePtr = NULL; + returnPackagePtr = + ExecuteRemoteObject(convPtr->riPtr, ddeObjectPtr); + for (convPtr = currentConversations; (convPtr != NULL) + && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) { + /* + * Empty loop body. + */ + + } + if (convPtr != NULL) { + Tcl_IncrRefCount(returnPackagePtr); + convPtr->returnPackagePtr = returnPackagePtr; + } + Tcl_DecrRefCount(ddeObjectPtr); + if (returnPackagePtr == NULL) { + return (HDDEDATA) DDE_FNOTPROCESSED; + } else { + return (HDDEDATA) DDE_FACK; + } + } + + case XTYP_WILDCONNECT: { + + /* + * Dde wants a list of services and topics that we support. + */ + + HSZPAIR *returnPtr; + int i; + int numItems; + + for (i = 0, riPtr = interpListPtr; riPtr != NULL; + i++, riPtr = riPtr->nextPtr) { + /* + * Empty loop body. + */ + + } + + numItems = i; + ddeReturn = DdeCreateDataHandle(ddeInstance, NULL, + (numItems + 1) * sizeof(HSZPAIR), 0, 0, 0, 0); + returnPtr = (HSZPAIR *) DdeAccessData(ddeReturn, &len); + for (i = 0, riPtr = interpListPtr; i < numItems; + i++, riPtr = riPtr->nextPtr) { + returnPtr[i].hszSvc = DdeCreateStringHandle(ddeInstance, + "Tk", CP_WINANSI); + returnPtr[i].hszTopic = DdeCreateStringHandle(ddeInstance, + riPtr->name, CP_WINANSI); + } + returnPtr[i].hszSvc = NULL; + returnPtr[i].hszTopic = NULL; + DdeUnaccessData(ddeReturn); + return ddeReturn; + } + + } + return NULL; +} + + +/* + *-------------------------------------------------------------- + * + * RemoveDdeServerExitProc -- + * + * Gets rid of our DDE server when we go away. + * + * Results: + * None. + * + * Side effects: + * The DDE server is deleted. + * + *-------------------------------------------------------------- + */ + +static void +RemoveDdeServerExitProc( + ClientData clientData) /* Not used in this handler. */ +{ + DdeNameService(ddeInstance, NULL, 0, DNS_UNREGISTER); + DdeUninitialize(ddeInstance); + ddeInstance = 0; +} + +/* + *-------------------------------------------------------------- + * + * MakeDdeConnection -- + * + * This procedure is a utility used to connect to a DDE + * server when given a server name and a topic name. + * + * Results: + * A standard Tcl result. + * + * + * Side effects: + * Passes back a conversation through ddeConvPtr + * + *-------------------------------------------------------------- + */ + +static int +MakeDdeConnection( + Tcl_Interp *interp, /* Used to report errors. */ + char *name, /* The connection to use. */ + HCONV *ddeConvPtr) +{ + HSZ ddeTopic, ddeService; + HCONV ddeConv; + + ddeService = DdeCreateStringHandle(ddeInstance, "Tk", 0); + ddeTopic = DdeCreateStringHandle(ddeInstance, name, 0); + + ddeConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); + DdeFreeStringHandle(ddeInstance, ddeService); + DdeFreeStringHandle(ddeInstance, ddeTopic); + + if (ddeConv == (HCONV) NULL) { + if (interp != NULL) { + Tcl_AppendResult(interp, "no registered server named \"", + name, "\"", (char *) NULL); + } + return TCL_ERROR; + } + + *ddeConvPtr = ddeConv; return TCL_OK; } + +/* + *-------------------------------------------------------------- + * + * SetDdeError -- + * + * Sets the interp result to a cogent error message + * describing the last DDE error. + * + * Results: + * None. + * + * + * Side effects: + * The interp's result object is changed. + * + *-------------------------------------------------------------- + */ + +static void +SetDdeError( + Tcl_Interp *interp) /* The interp to put the message in.*/ +{ + Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); + int err; + + err = DdeGetLastError(ddeInstance); + switch (err) { + case DMLERR_DATAACKTIMEOUT: + case DMLERR_EXECACKTIMEOUT: + case DMLERR_POKEACKTIMEOUT: + Tcl_SetStringObj(resultPtr, + "remote interpreter did not respond", -1); + break; + + case DMLERR_BUSY: + Tcl_SetStringObj(resultPtr, "remote server is busy", -1); + break; + + case DMLERR_NOTPROCESSED: + Tcl_SetStringObj(resultPtr, + "remote server cannot handle this command", -1); + break; + + default: + Tcl_SetStringObj(resultPtr, "dde command failed", -1); + } +} + +/* + *-------------------------------------------------------------- + * + * Tk_DdeObjCmd -- + * + * This procedure is invoked to process the "dde" 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_DdeObjCmd( + ClientData clientData, /* Used only for deletion */ + Tcl_Interp *interp, /* The interp we are sending from */ + int objc, /* Number of arguments */ + Tcl_Obj *CONST objv[]) /* The arguments */ +{ + enum { + DDE_EXECUTE, + DDE_REQUEST, + DDE_SERVICES + }; + + static char *ddeCommands[] = {"execute", "request", "services", + (char *) NULL}; + static char *ddeOptions[] = {"-async", (char *) NULL}; + int index, argIndex; + int async = 0; + int result = TCL_OK; + HSZ ddeService = NULL; + HSZ ddeTopic = NULL; + HSZ ddeItem = NULL; + HDDEDATA ddeData = NULL; + HCONV hConv; + char *serviceName, *topicName, *itemString, *dataString; + int firstArg, length, dataLength; + DWORD ddeResult; + HDDEDATA ddeReturn; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, + "?-async? serviceName topicName value"); + return TCL_ERROR; + } + + if (Tcl_GetIndexFromObj(interp, objv[1], ddeCommands, "command", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + + switch (index) { + case DDE_EXECUTE: + if ((objc < 5) || (objc > 6)) { + Tcl_WrongNumArgs(interp, 1, objv, + "execute ?-async? serviceName topicName value"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(NULL, objv[2], ddeOptions, "option", 0, + &argIndex) != TCL_OK) { + if (objc != 5) { + Tcl_WrongNumArgs(interp, 1, objv, + "execute ?-async? serviceName topicName value"); + return TCL_ERROR; + } + async = 0; + firstArg = 2; + } else { + if (objc != 6) { + Tcl_WrongNumArgs(interp, 1, objv, + "execute ?-async? serviceName topicName value"); + return TCL_ERROR; + } + async = 1; + firstArg = 3; + } + break; + case DDE_REQUEST: + if (objc != 5) { + Tcl_WrongNumArgs(interp, 1, objv, + "request serviceName topicName value"); + return TCL_ERROR; + } + firstArg = 2; + break; + case DDE_SERVICES: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, + "services serviceName topicName"); + return TCL_ERROR; + } + firstArg = 2; + break; + } + + serviceName = Tcl_GetStringFromObj(objv[firstArg], &length); + if (length == 0) { + serviceName = NULL; + } else { + ddeService = DdeCreateStringHandle(ddeInstance, serviceName, + CP_WINANSI); + } + topicName = Tcl_GetStringFromObj(objv[firstArg + 1], &length); + if (length == 0) { + topicName = NULL; + } else { + ddeTopic = DdeCreateStringHandle(ddeInstance, topicName, CP_WINANSI); + } + + switch (index) { + case DDE_EXECUTE: { + dataString = Tcl_GetStringFromObj(objv[firstArg + 2], &dataLength); + if (dataLength == 0) { + Tcl_SetStringObj(Tcl_GetObjResult(interp), + "cannot execute null data", -1); + result = TCL_ERROR; + break; + } + hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); + + if (hConv == NULL) { + SetDdeError(interp); + result = TCL_ERROR; + break; + } + + ddeData = DdeCreateDataHandle(ddeInstance, dataString, + dataLength, 0, 0, CF_TEXT, 0); + if (ddeData != NULL) { + if (async) { + DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, hConv, 0, + CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult); + DdeAbandonTransaction(ddeInstance, hConv, ddeResult); + } else { + ddeReturn = DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, + hConv, 0, CF_TEXT, XTYP_EXECUTE, 7200000, NULL); + if (ddeReturn == 0) { + SetDdeError(interp); + result = TCL_ERROR; + } + } + DdeFreeDataHandle(ddeData); + } else { + SetDdeError(interp); + result = TCL_ERROR; + } + DdeDisconnect(hConv); + break; + } + case DDE_REQUEST: { + itemString = Tcl_GetStringFromObj(objv[firstArg + 2], &length); + if (length == 0) { + Tcl_SetStringObj(Tcl_GetObjResult(interp), + "cannot request value of null data", -1); + return TCL_ERROR; + } + hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); + + if (hConv == NULL) { + SetDdeError(interp); + result = TCL_ERROR; + } else { + Tcl_Obj *returnObjPtr; + ddeItem = DdeCreateStringHandle(ddeInstance, itemString, + CP_WINANSI); + if (ddeItem != NULL) { + ddeData = DdeClientTransaction(NULL, 0, hConv, ddeItem, + CF_TEXT, XTYP_REQUEST, 5000, NULL); + if (ddeData == NULL) { + SetDdeError(interp); + result = TCL_ERROR; + } else { + dataString = DdeAccessData(ddeData, &dataLength); + returnObjPtr = Tcl_NewStringObj(dataString, dataLength); + DdeUnaccessData(ddeData); + DdeFreeDataHandle(ddeData); + Tcl_SetObjResult(interp, returnObjPtr); + } + } else { + SetDdeError(interp); + result = TCL_ERROR; + } + DdeDisconnect(hConv); + } + + break; + } + case DDE_SERVICES: { + HCONVLIST hConvList; + CONVINFO convInfo; + Tcl_Obj *convListObjPtr, *elementObjPtr; + Tcl_DString dString; + char *name; + + convInfo.cb = sizeof(CONVINFO); + hConvList = DdeConnectList(ddeInstance, ddeService, ddeTopic, + 0, NULL); + hConv = 0; + convListObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + Tcl_DStringInit(&dString); + + while (hConv = DdeQueryNextServer(hConvList, hConv), hConv != 0) { + elementObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + DdeQueryConvInfo(hConv, QID_SYNC, &convInfo); + length = DdeQueryString(ddeInstance, convInfo.hszSvcPartner, + NULL, 0, CP_WINANSI); + Tcl_DStringSetLength(&dString, length); + name = Tcl_DStringValue(&dString); + DdeQueryString(ddeInstance, convInfo.hszSvcPartner, name, + length + 1, CP_WINANSI); + Tcl_ListObjAppendElement(interp, elementObjPtr, + Tcl_NewStringObj(name, length)); + length = DdeQueryString(ddeInstance, convInfo.hszTopic, + NULL, 0, CP_WINANSI); + Tcl_DStringSetLength(&dString, length); + name = Tcl_DStringValue(&dString); + DdeQueryString(ddeInstance, convInfo.hszTopic, name, + length + 1, CP_WINANSI); + Tcl_ListObjAppendElement(interp, elementObjPtr, + Tcl_NewStringObj(name, length)); + Tcl_ListObjAppendElement(interp, convListObjPtr, elementObjPtr); + } + DdeDisconnectList(hConvList); + Tcl_SetObjResult(interp, convListObjPtr); + Tcl_DStringFree(&dString); + break; + } + } + if (ddeService != NULL) { + DdeFreeStringHandle(ddeInstance, ddeService); + } + if (ddeTopic != NULL) { + DdeFreeStringHandle(ddeInstance, ddeTopic); + } + + return result; +} diff --git a/win/tkWinTest.c b/win/tkWinTest.c new file mode 100644 index 0000000..3ca00d4 --- /dev/null +++ b/win/tkWinTest.c @@ -0,0 +1,230 @@ +/* + * tkWinTest.c -- + * + * Contains commands for platform specific tests for + * the Windows platform. + * + * 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. + * + * SCCS: @(#) tkWinTest.c 1.4 97/11/07 21:26:18 + */ + +#include "tkWinInt.h" + +HWND tkWinCurrentDialog; + +/* + * Forward declarations of procedures defined later in this file: + */ + +int TkplatformtestInit(Tcl_Interp *interp); +static int TestclipboardCmd(ClientData clientData, + Tcl_Interp *interp, int argc, char **argv); +static int TestwineventCmd(ClientData clientData, + Tcl_Interp *interp, int argc, char **argv); + + +/* + *---------------------------------------------------------------------- + * + * TkplatformtestInit -- + * + * Defines commands that test platform specific functionality for + * Unix platforms. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Defines new commands. + * + *---------------------------------------------------------------------- + */ + +int +TkplatformtestInit( + Tcl_Interp *interp) /* Interpreter to add commands to. */ +{ + /* + * Add commands for platform specific tests on MacOS here. + */ + + Tcl_CreateCommand(interp, "testclipboard", TestclipboardCmd, + (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testwinevent", TestwineventCmd, + (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestclipboardCmd -- + * + * This procedure implements the testclipboard command. It provides + * a way to determine the actual contents of the Windows clipboard. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestclipboardCmd(clientData, interp, argc, argv) + ClientData clientData; /* Main window for application. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + TkWindow *winPtr = (TkWindow *) clientData; + HGLOBAL handle; + char *data; + + if (OpenClipboard(NULL)) { + handle = GetClipboardData(CF_TEXT); + if (handle != NULL) { + data = GlobalLock(handle); + Tcl_AppendResult(interp, data, (char *) NULL); + GlobalUnlock(handle); + } + CloseClipboard(); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestwineventCmd -- + * + * This procedure implements the testwinevent command. It provides + * a way to send messages to windows dialogs. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestwineventCmd(clientData, interp, argc, argv) + ClientData clientData; /* Main window for application. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + HWND hwnd; + int id; + char *rest; + UINT message; + WPARAM wParam; + LPARAM lParam; + static TkStateMap messageMap[] = { + {WM_LBUTTONDOWN, "WM_LBUTTONDOWN"}, + {WM_LBUTTONUP, "WM_LBUTTONUP"}, + {WM_CHAR, "WM_CHAR"}, + {WM_GETTEXT, "WM_GETTEXT"}, + {WM_SETTEXT, "WM_SETTEXT"}, + {-1, NULL} + }; + + if ((argc == 3) && (strcmp(argv[1], "debug") == 0)) { + int i; + + if (Tcl_GetBoolean(interp, argv[2], &i) != TCL_OK) { + return TCL_ERROR; + } + TkWinDialogDebug(i); + return TCL_OK; + } + + if (argc < 4) { + return TCL_ERROR; + } + + hwnd = (HWND) strtol(argv[1], &rest, 0); + if (rest == argv[2]) { + hwnd = FindWindow(NULL, argv[1]); + if (hwnd == NULL) { + Tcl_SetResult(interp, "no such window", TCL_STATIC); + return TCL_ERROR; + } + } + UpdateWindow(hwnd); + + id = strtol(argv[2], &rest, 0); + if (rest == argv[2]) { + HWND child; + char buf[256]; + + child = GetWindow(hwnd, GW_CHILD); + while (child != NULL) { + SendMessage(child, WM_GETTEXT, (WPARAM) sizeof(buf), (LPARAM) buf); + if (strcasecmp(buf, argv[2]) == 0) { + id = GetDlgCtrlID(child); + break; + } + child = GetWindow(child, GW_HWNDNEXT); + } + if (child == NULL) { + return TCL_ERROR; + } + } + message = TkFindStateNum(NULL, NULL, messageMap, argv[3]); + if (message < 0) { + message = strtol(argv[3], NULL, 0); + } + wParam = 0; + lParam = 0; + + if (argc > 4) { + wParam = strtol(argv[4], NULL, 0); + } + if (argc > 5) { + lParam = strtol(argv[5], NULL, 0); + } + + switch (message) { + case WM_GETTEXT: { + Tcl_DString ds; + char buf[256]; + + GetDlgItemText(hwnd, id, buf, 256); + Tcl_ExternalToUtfDString(NULL, buf, -1, &ds); + Tcl_AppendResult(interp, Tcl_DStringValue(&ds), NULL); + Tcl_DStringFree(&ds); + break; + } + case WM_SETTEXT: { + Tcl_DString ds; + + Tcl_UtfToExternalDString(NULL, argv[4], -1, &ds); + SetDlgItemText(hwnd, id, Tcl_DStringValue(&ds)); + Tcl_DStringFree(&ds); + break; + } + default: { + char buf[TCL_INTEGER_SPACE]; + + sprintf(buf, "%d", + SendDlgItemMessage(hwnd, id, message, wParam, lParam)); + Tcl_SetResult(interp, buf, TCL_VOLATILE); + break; + } + } + return TCL_OK; +} + + + diff --git a/win/tkWinWindow.c b/win/tkWinWindow.c index 2b8eb41..ab723c4 100644 --- a/win/tkWinWindow.c +++ b/win/tkWinWindow.c @@ -4,12 +4,12 @@ * Xlib emulation routines for Windows related to creating, * displaying and destroying windows. * - * Copyright (c) 1995 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) tkWinWindow.c 1.23 97/07/01 18:14:13 + * SCCS: @(#) tkWinWindow.c 1.25 97/12/08 15:16:32 */ #include "tkWinInt.h" @@ -114,7 +114,12 @@ Tk_Window Tk_HWNDToWindow(hwnd) HWND hwnd; { - Tcl_HashEntry *entryPtr = Tcl_FindHashEntry(&windowTable, (char*)hwnd); + Tcl_HashEntry *entryPtr; + if (!initialized) { + Tcl_InitHashTable(&windowTable, TCL_ONE_WORD_KEYS); + initialized = 1; + } + entryPtr = Tcl_FindHashEntry(&windowTable, (char*)hwnd); if (entryPtr != NULL) { return (Tk_Window) Tcl_GetHashValue(entryPtr); } @@ -185,7 +190,7 @@ TkpPrintWindowId(buf, window) * The return value is normally TCL_OK; in this case *idPtr * will be set to the X Window id equivalent to string. If * string is improperly formed then TCL_ERROR is returned and - * an error message will be left in interp->result. If the + * an error message will be left in the interp's result. If the * number does not correspond to a Tk Window, then *idPtr will * be set to None. * diff --git a/win/tkWinWm.c b/win/tkWinWm.c index 6ec1a2a..c81e137 100644 --- a/win/tkWinWm.c +++ b/win/tkWinWm.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkWinWm.c 1.67 97/09/23 17:39:47 + * SCCS: @(#) tkWinWm.c 1.68 97/11/07 21:25:21 */ #include "tkWinInt.h" @@ -1096,7 +1096,7 @@ Tk_WmCmd(clientData, interp, argc, argv) return TCL_ERROR; } if (argc == 2) { - interp->result = (wmTracing) ? "on" : "off"; + Tcl_SetResult(interp, ((wmTracing) ? "on" : "off"), TCL_STATIC); return TCL_OK; } return Tcl_GetBoolean(interp, argv[2], &wmTracing); @@ -1126,9 +1126,12 @@ Tk_WmCmd(clientData, interp, argc, argv) } if (argc == 3) { if (wmPtr->sizeHintsFlags & PAspect) { - sprintf(interp->result, "%d %d %d %d", wmPtr->minAspect.x, + char buf[TCL_INTEGER_SPACE * 4]; + + sprintf(buf, "%d %d %d %d", wmPtr->minAspect.x, wmPtr->minAspect.y, wmPtr->maxAspect.x, wmPtr->maxAspect.y); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } return TCL_OK; } @@ -1143,7 +1146,8 @@ Tk_WmCmd(clientData, interp, argc, argv) } if ((numer1 <= 0) || (denom1 <= 0) || (numer2 <= 0) || (denom2 <= 0)) { - interp->result = "aspect number can't be <= 0"; + Tcl_SetResult(interp, "aspect number can't be <= 0", + TCL_STATIC); return TCL_ERROR; } wmPtr->minAspect.x = numer1; @@ -1163,7 +1167,7 @@ Tk_WmCmd(clientData, interp, argc, argv) } if (argc == 3) { if (wmPtr->clientMachine != NULL) { - interp->result = wmPtr->clientMachine; + Tcl_SetResult(interp, wmPtr->clientMachine, TCL_STATIC); } return TCL_OK; } @@ -1278,8 +1282,9 @@ Tk_WmCmd(clientData, interp, argc, argv) } if (argc == 3) { if (wmPtr->cmdArgv != NULL) { - interp->result = Tcl_Merge(wmPtr->cmdArgc, wmPtr->cmdArgv); - interp->freeProc = TCL_DYNAMIC; + Tcl_SetResult(interp, + Tcl_Merge(wmPtr->cmdArgc, wmPtr->cmdArgv), + TCL_DYNAMIC); } return TCL_OK; } @@ -1331,7 +1336,8 @@ Tk_WmCmd(clientData, interp, argc, argv) return TCL_ERROR; } if (argc == 3) { - interp->result = wmPtr->hints.input ? "passive" : "active"; + Tcl_SetResult(interp, (wmPtr->hints.input ? "passive" : "active"), + TCL_STATIC); return TCL_OK; } c = argv[3][0]; @@ -1348,6 +1354,7 @@ Tk_WmCmd(clientData, interp, argc, argv) } else if ((c == 'f') && (strncmp(argv[1], "frame", length) == 0) && (length >= 2)) { HWND hwnd; + char buf[TCL_INTEGER_SPACE]; if (argc != 3) { Tcl_AppendResult(interp, "wrong # arguments: must be \"", @@ -1358,7 +1365,8 @@ Tk_WmCmd(clientData, interp, argc, argv) if (hwnd == NULL) { hwnd = Tk_GetHWND(Tk_WindowId((Tk_Window) winPtr)); } - sprintf(interp->result, "0x%x", (unsigned int) hwnd); + sprintf(buf, "0x%x", (unsigned int) hwnd); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } else if ((c == 'g') && (strncmp(argv[1], "geometry", length) == 0) && (length >= 2)) { char xSign, ySign; @@ -1371,6 +1379,8 @@ Tk_WmCmd(clientData, interp, argc, argv) return TCL_ERROR; } if (argc == 3) { + char buf[16 + TCL_INTEGER_SPACE * 4]; + xSign = (wmPtr->flags & WM_NEGATIVE_X) ? '-' : '+'; ySign = (wmPtr->flags & WM_NEGATIVE_Y) ? '-' : '+'; if (wmPtr->gridWin != NULL) { @@ -1382,8 +1392,9 @@ Tk_WmCmd(clientData, interp, argc, argv) width = winPtr->changes.width; height = winPtr->changes.height; } - sprintf(interp->result, "%dx%d%c%d%c%d", width, height, - xSign, wmPtr->x, ySign, wmPtr->y); + sprintf(buf, "%dx%d%c%d%c%d", width, height, xSign, wmPtr->x, + ySign, wmPtr->y); + Tcl_SetResult(interp, buf, TCL_VOLATILE); return TCL_OK; } if (*argv[3] == '\0') { @@ -1404,9 +1415,12 @@ Tk_WmCmd(clientData, interp, argc, argv) } if (argc == 3) { if (wmPtr->sizeHintsFlags & PBaseSize) { - sprintf(interp->result, "%d %d %d %d", wmPtr->reqGridWidth, + char buf[TCL_INTEGER_SPACE * 4]; + + sprintf(buf, "%d %d %d %d", wmPtr->reqGridWidth, wmPtr->reqGridHeight, wmPtr->widthInc, wmPtr->heightInc); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } return TCL_OK; } @@ -1433,19 +1447,19 @@ Tk_WmCmd(clientData, interp, argc, argv) return TCL_ERROR; } if (reqWidth < 0) { - interp->result = "baseWidth can't be < 0"; + Tcl_SetResult(interp, "baseWidth can't be < 0", TCL_STATIC); return TCL_ERROR; } if (reqHeight < 0) { - interp->result = "baseHeight can't be < 0"; + Tcl_SetResult(interp, "baseHeight can't be < 0", TCL_STATIC); return TCL_ERROR; } if (widthInc < 0) { - interp->result = "widthInc can't be < 0"; + Tcl_SetResult(interp, "widthInc can't be < 0", TCL_STATIC); return TCL_ERROR; } if (heightInc < 0) { - interp->result = "heightInc can't be < 0"; + Tcl_SetResult(interp, "heightInc can't be < 0", TCL_STATIC); return TCL_ERROR; } Tk_SetGrid((Tk_Window) winPtr, reqWidth, reqHeight, widthInc, @@ -1464,7 +1478,7 @@ Tk_WmCmd(clientData, interp, argc, argv) } if (argc == 3) { if (wmPtr->hints.flags & WindowGroupHint) { - interp->result = wmPtr->leaderName; + Tcl_SetResult(interp, wmPtr->leaderName, TCL_STATIC); } return TCL_OK; } @@ -1497,8 +1511,9 @@ Tk_WmCmd(clientData, interp, argc, argv) } if (argc == 3) { if (wmPtr->hints.flags & IconPixmapHint) { - interp->result = Tk_NameOfBitmap(winPtr->display, - wmPtr->hints.icon_pixmap); + Tcl_SetResult(interp, + Tk_NameOfBitmap(winPtr->display, wmPtr->hints.icon_pixmap), + TCL_STATIC); } return TCL_OK; } @@ -1556,8 +1571,9 @@ Tk_WmCmd(clientData, interp, argc, argv) } if (argc == 3) { if (wmPtr->hints.flags & IconMaskHint) { - interp->result = Tk_NameOfBitmap(winPtr->display, - wmPtr->hints.icon_mask); + Tcl_SetResult(interp, + Tk_NameOfBitmap(winPtr->display, wmPtr->hints.icon_mask), + TCL_STATIC); } return TCL_OK; } @@ -1582,7 +1598,9 @@ Tk_WmCmd(clientData, interp, argc, argv) return TCL_ERROR; } if (argc == 3) { - interp->result = (wmPtr->iconName != NULL) ? wmPtr->iconName : ""; + Tcl_SetResult(interp, + ((wmPtr->iconName != NULL) ? wmPtr->iconName : ""), + TCL_STATIC); return TCL_OK; } else { wmPtr->iconName = Tk_GetUid(argv[3]); @@ -1602,8 +1620,11 @@ Tk_WmCmd(clientData, interp, argc, argv) } if (argc == 3) { if (wmPtr->hints.flags & IconPositionHint) { - sprintf(interp->result, "%d %d", wmPtr->hints.icon_x, + char buf[TCL_INTEGER_SPACE * 2]; + + sprintf(buf, "%d %d", wmPtr->hints.icon_x, wmPtr->hints.icon_y); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } return TCL_OK; } @@ -1632,7 +1653,7 @@ Tk_WmCmd(clientData, interp, argc, argv) } if (argc == 3) { if (wmPtr->icon != NULL) { - interp->result = Tk_PathName(wmPtr->icon); + Tcl_SetResult(interp, Tk_PathName(wmPtr->icon), TCL_STATIC); } return TCL_OK; } @@ -1699,8 +1720,9 @@ Tk_WmCmd(clientData, interp, argc, argv) if (!(wmPtr2->flags & WM_NEVER_MAPPED)) { if (XWithdrawWindow(Tk_Display(tkwin2), Tk_WindowId(tkwin2), Tk_ScreenNumber(tkwin2)) == 0) { - interp->result = - "couldn't send withdraw message to window manager"; + Tcl_SetResult(interp, + "couldn't send withdraw message to window manager", + TCL_STATIC); return TCL_ERROR; } } @@ -1715,8 +1737,11 @@ Tk_WmCmd(clientData, interp, argc, argv) return TCL_ERROR; } if (argc == 3) { + char buf[TCL_INTEGER_SPACE * 2]; + GetMaxSize(wmPtr, &width, &height); - sprintf(interp->result, "%d %d", width, height); + sprintf(buf, "%d %d", width, height); + Tcl_SetResult(interp, buf, TCL_VOLATILE); return TCL_OK; } if ((Tcl_GetInt(interp, argv[3], &width) != TCL_OK) @@ -1736,8 +1761,11 @@ Tk_WmCmd(clientData, interp, argc, argv) return TCL_ERROR; } if (argc == 3) { + char buf[TCL_INTEGER_SPACE * 2]; + GetMinSize(wmPtr, &width, &height); - sprintf(interp->result, "%d %d", width, height); + sprintf(buf, "%d %d", width, height); + Tcl_SetResult(interp, buf, TCL_VOLATILE); return TCL_OK; } if ((Tcl_GetInt(interp, argv[3], &width) != TCL_OK) @@ -1760,9 +1788,9 @@ Tk_WmCmd(clientData, interp, argc, argv) } if (argc == 3) { if (Tk_Attributes((Tk_Window) winPtr)->override_redirect) { - interp->result = "1"; + Tcl_SetResult(interp, "1", TCL_STATIC); } else { - interp->result = "0"; + Tcl_SetResult(interp, "0", TCL_STATIC); } return TCL_OK; } @@ -1786,9 +1814,9 @@ Tk_WmCmd(clientData, interp, argc, argv) } if (argc == 3) { if (wmPtr->sizeHintsFlags & USPosition) { - interp->result = "user"; + Tcl_SetResult(interp, "user", TCL_STATIC); } else if (wmPtr->sizeHintsFlags & PPosition) { - interp->result = "program"; + Tcl_SetResult(interp, "program", TCL_STATIC); } return TCL_OK; } @@ -1842,7 +1870,7 @@ Tk_WmCmd(clientData, interp, argc, argv) for (protPtr = wmPtr->protPtr; protPtr != NULL; protPtr = protPtr->nextPtr) { if (protPtr->protocol == protocol) { - interp->result = protPtr->command; + Tcl_SetResult(interp, protPtr->command, TCL_STATIC); return TCL_OK; } } @@ -1886,9 +1914,12 @@ Tk_WmCmd(clientData, interp, argc, argv) return TCL_ERROR; } if (argc == 3) { - sprintf(interp->result, "%d %d", + char buf[TCL_INTEGER_SPACE * 2]; + + sprintf(buf, "%d %d", (wmPtr->flags & WM_WIDTH_NOT_RESIZABLE) ? 0 : 1, (wmPtr->flags & WM_HEIGHT_NOT_RESIZABLE) ? 0 : 1); + Tcl_SetResult(interp, buf, TCL_VOLATILE); return TCL_OK; } if ((Tcl_GetBoolean(interp, argv[3], &width) != TCL_OK) @@ -1917,9 +1948,9 @@ Tk_WmCmd(clientData, interp, argc, argv) } if (argc == 3) { if (wmPtr->sizeHintsFlags & USSize) { - interp->result = "user"; + Tcl_SetResult(interp, "user", TCL_STATIC); } else if (wmPtr->sizeHintsFlags & PSize) { - interp->result = "program"; + Tcl_SetResult(interp, "program", TCL_STATIC); } return TCL_OK; } @@ -1950,20 +1981,20 @@ Tk_WmCmd(clientData, interp, argc, argv) return TCL_ERROR; } if (wmPtr->iconFor != NULL) { - interp->result = "icon"; + Tcl_SetResult(interp, "icon", TCL_STATIC); } else { switch (wmPtr->hints.initial_state) { case NormalState: - interp->result = "normal"; + Tcl_SetResult(interp, "normal", TCL_STATIC); break; case IconicState: - interp->result = "iconic"; + Tcl_SetResult(interp, "iconic", TCL_STATIC); break; case WithdrawnState: - interp->result = "withdrawn"; + Tcl_SetResult(interp, "withdrawn", TCL_STATIC); break; case ZoomState: - interp->result = "zoomed"; + Tcl_SetResult(interp, "zoomed", TCL_STATIC); break; } } @@ -1975,8 +2006,9 @@ Tk_WmCmd(clientData, interp, argc, argv) return TCL_ERROR; } if (argc == 3) { - interp->result = (wmPtr->titleUid != NULL) ? wmPtr->titleUid - : winPtr->nameUid; + Tcl_SetResult(interp, + ((wmPtr->titleUid != NULL) ? wmPtr->titleUid : winPtr->nameUid), + TCL_STATIC); return TCL_OK; } else { wmPtr->titleUid = Tk_GetUid(argv[3]); @@ -2576,7 +2608,7 @@ UpdateGeometryInfo(clientData) * * Results: * A standard Tcl return value, plus an error message in - * interp->result if an error occurs. + * the interp's result if an error occurs. * * Side effects: * The size and/or location of winPtr may change. diff --git a/win/tkWinX.c b/win/tkWinX.c index 0b00186..579eaf7 100644 --- a/win/tkWinX.c +++ b/win/tkWinX.c @@ -9,10 +9,9 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tkWinX.c 1.51 97/09/02 13:06:57 + * SCCS: @(#) tkWinX.c 1.55 98/01/21 00:23:17 */ -#include "tkInt.h" #include "tkWinInt.h" /* @@ -763,19 +762,61 @@ GenerateXEvent(hwnd, message, wParam, lParam) */ event.type = KeyRelease; event.xkey.keycode = wParam; - event.xkey.nchars = 0; + event.xkey.nbytes = 0; break; case WM_CHAR: /* * Synthesize both a KeyPress and a KeyRelease. + * Strings generated by Input Method Editor are handled + * in the following manner: + * 1. A series of WM_KEYDOWN & WM_KEYUP messages that + * cause GetTranslatedKey() to be called and return + * immediately because the WM_KEYDOWNs have no + * associated WM_CHAR messages -- the IME window is + * accumulating the characters and translating them + * itself. In the "bind" command, you get an event + * with a mystery keysym and %A == "" for each + * WM_KEYDOWN that actually was meant for the IME. + * 2. A WM_KEYDOWN corresponding to the "confirm typing" + * character. This causes GetTranslatedKey() to be + * called. + * 3. A WM_IME_NOTIFY message saying that the IME is + * done. A side effect of this message is that + * GetTranslatedKey() thinks this means that there + * are no WM_CHAR messages and returns immediately. + * In the "bind" command, you get an another event + * with a mystery keysym and %A == "". + * 4. A sequence of WM_CHAR messages that correspond to + * the characters in the IME window. A bunch of + * simulated KeyPress/KeyRelease events will be + * generated, one for each character. Adjacent + * WM_CHAR messages may actually specify the high + * and low bytes of a multi-byte character -- in that + * case the two WM_CHAR messages will be combined into + * one event. It is the event-consumer's + * responsibility to convert the string returned from + * XLookupString from system encoding to UTF-8. + * 5. And finally we get the WM_KEYUP for the "confirm + * typing" character. */ event.type = KeyPress; event.xany.send_event = -1; event.xkey.keycode = 0; - event.xkey.nchars = 1; + event.xkey.nbytes = 1; event.xkey.trans_chars[0] = (char) wParam; + + if (IsDBCSLeadByte((BYTE) wParam)) { + MSG msg; + + if ((PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE) != 0) + && (msg.message == WM_CHAR)) { + GetMessage(&msg, NULL, 0, 0); + event.xkey.nbytes = 2; + event.xkey.trans_chars[1] = (char) msg.wParam; + } + } Tk_QueueWindowEvent(&event, TCL_QUEUE_TAIL); event.type = KeyRelease; break; @@ -874,7 +915,7 @@ GetState(message, wParam, lParam) * given KeyPress event. * * Results: - * Sets the trans_chars and nchars member of the key event. + * Sets the trans_chars and nbytes member of the key event. * * Side effects: * Removes any WM_CHAR messages waiting on the top of the system @@ -888,18 +929,21 @@ GetTranslatedKey(xkey) XKeyEvent *xkey; { MSG msg; + char buf[XMaxTransChars]; - xkey->nchars = 0; + xkey->nbytes = 0; - while (xkey->nchars < XMaxTransChars + while ((xkey->nbytes < XMaxTransChars) && PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE)) { if (msg.message == WM_CHAR) { - xkey->trans_chars[xkey->nchars] = (char) msg.wParam; - xkey->nchars++; GetMessage(&msg, NULL, 0, 0); - if ((msg.message == WM_CHAR) && (msg.lParam & 0x20000000)) { + + if (msg.lParam & 0x20000000) { xkey->state = 0; } + buf[xkey->nbytes] = (char) msg.wParam; + xkey->trans_chars[xkey->nbytes] = (char) msg.wParam; + xkey->nbytes++; } else { break; } diff --git a/win/winMain.c b/win/winMain.c index f263339..691aa91 100644 --- a/win/winMain.c +++ b/win/winMain.c @@ -3,12 +3,12 @@ * * Main entry point for wish and other Tk-based applications. * - * Copyright (c) 1995 Sun Microsystems, Inc. + * 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. * - * SCCS: @(#) winMain.c 1.33 96/12/17 12:56:14 + * SCCS: @(#) winMain.c 1.37 98/01/20 22:47:06 */ #include <tk.h> @@ -37,6 +37,11 @@ static void WishPanic _ANSI_ARGS_(TCL_VARARGS(char *,format)); EXTERN int Tktest_Init(Tcl_Interp *interp); #endif /* TK_TEST */ +#ifdef TCL_TEST +EXTERN int TclObjTest_Init _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp)); +#endif /* TCL_TEST */ + /* *---------------------------------------------------------------------- @@ -62,9 +67,8 @@ WinMain(hInstance, hPrevInstance, lpszCmdLine, nCmdShow) LPSTR lpszCmdLine; int nCmdShow; { - char **argv, *p; + char **argv; int argc; - char buffer[MAX_PATH]; Tcl_SetPanicProc(WishPanic); @@ -74,7 +78,7 @@ WinMain(hInstance, hPrevInstance, lpszCmdLine, nCmdShow) */ setlocale(LC_ALL, "C"); - + setargv(&argc, &argv); /* * Increase the application queue size from default value of 8. @@ -83,6 +87,7 @@ WinMain(hInstance, hPrevInstance, lpszCmdLine, nCmdShow) * This is only needed for Windows 3.x, since NT dynamically expands * the queue. */ + SetMessageQueue(64); /* @@ -93,21 +98,6 @@ WinMain(hInstance, hPrevInstance, lpszCmdLine, nCmdShow) TkConsoleCreate(); - setargv(&argc, &argv); - - /* - * Replace argv[0] with full pathname of executable, and forward - * slashes substituted for backslashes. - */ - - GetModuleFileName(NULL, buffer, sizeof(buffer)); - argv[0] = buffer; - for (p = buffer; *p != '\0'; p++) { - if (*p == '\\') { - *p = '/'; - } - } - Tk_Main(argc, argv, Tcl_AppInit); return 1; } @@ -124,7 +114,7 @@ WinMain(hInstance, hPrevInstance, lpszCmdLine, nCmdShow) * * Results: * Returns a standard Tcl completion code, and leaves an error - * message in interp->result if an error occurs. + * message in the interp's result if an error occurs. * * Side effects: * Depends on the startup script. @@ -153,6 +143,17 @@ Tcl_AppInit(interp) goto error; } +#ifdef TCL_TEST + if (Tcltest_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } + Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init, + (Tcl_PackageInitProc *) NULL); + if (TclObjTest_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } +#endif /* TCL_TEST */ + #ifdef TK_TEST if (Tktest_Init(interp) == TCL_ERROR) { goto error; @@ -165,7 +166,7 @@ Tcl_AppInit(interp) return TCL_OK; error: - WishPanic(interp->result); + WishPanic(Tcl_GetStringResult(interp)); return TCL_ERROR; } @@ -241,7 +242,7 @@ setargv(argcPtr, argvPtr) char **argv; int argc, size, inquote, copy, slashes; - cmdLine = GetCommandLine(); + cmdLine = GetCommandLine(); /* INTL: BUG */ /* * Precompute an overly pessimistic guess at the number of arguments @@ -250,9 +251,9 @@ setargv(argcPtr, argvPtr) size = 2; for (p = cmdLine; *p != '\0'; p++) { - if (isspace(*p)) { + if ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */ size++; - while (isspace(*p)) { + while ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */ p++; } if (*p == '\0') { @@ -260,8 +261,8 @@ setargv(argcPtr, argvPtr) } } } - argSpace = (char *) ckalloc((unsigned) (size * sizeof(char *) - + strlen(cmdLine) + 1)); + argSpace = (char *) Tcl_Alloc( + (unsigned) (size * sizeof(char *) + strlen(cmdLine) + 1)); argv = (char **) argSpace; argSpace += size * sizeof(char *); size--; @@ -269,7 +270,7 @@ setargv(argcPtr, argvPtr) p = cmdLine; for (argc = 0; argc < size; argc++) { argv[argc] = arg = argSpace; - while (isspace(*p)) { + while ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */ p++; } if (*p == '\0') { @@ -303,7 +304,8 @@ setargv(argcPtr, argvPtr) slashes--; } - if ((*p == '\0') || (!inquote && isspace(*p))) { + if ((*p == '\0') + || (!inquote && ((*p == ' ') || (*p == '\t')))) { /* INTL: ISO space. */ break; } if (copy != 0) { @@ -320,4 +322,3 @@ setargv(argcPtr, argvPtr) *argcPtr = argc; *argvPtr = argv; } - diff --git a/xlib/X11/X.h b/xlib/X11/X.h index 55a3133..a7f6566 100644 --- a/xlib/X11/X.h +++ b/xlib/X11/X.h @@ -59,7 +59,11 @@ typedef unsigned long VisualID; typedef unsigned long Time; -typedef unsigned short KeyCode; +typedef unsigned long KeyCode; /* In order to use IME, the Macintosh needs + * to pack 3 bytes into the keyCode field in + * the XEvent. In the real X.h, a KeyCode is + * defined as a short, which wouldn't be big + * enough. */ /***************************************************************** * RESERVED RESOURCE AND CONSTANT DEFINITIONS diff --git a/xlib/X11/Xlib.h b/xlib/X11/Xlib.h index 397bb03..247255b 100644 --- a/xlib/X11/Xlib.h +++ b/xlib/X11/Xlib.h @@ -546,7 +546,7 @@ typedef struct { Bool same_screen; /* same screen flag */ char trans_chars[XMaxTransChars]; /* translated characters */ - int nchars; + int nbytes; } XKeyEvent; typedef XKeyEvent XKeyPressedEvent; typedef XKeyEvent XKeyReleasedEvent; |
