summaryrefslogtreecommitdiffstats
path: root/Doc/lib
Commit message (Expand)AuthorAgeFilesLines
* Partial patch from SF #452266, by Jason Petrone.Guido van Rossum2001-10-161-5/+4
* [ #403753 ] zlib decompress; uncontrollable memory usageJeremy Hylton2001-10-161-2/+16
* Fix a few usage and style-guide conformance issues.Fred Drake2001-10-161-10/+10
* Added information about setprofile() and settrace() hooks being thread-Fred Drake2001-10-161-2/+9
* Added notes to clarify that binascii.crc32(), zlib.crc32(), andFred Drake2001-10-152-3/+9
* Document that keyfile and certfile are now optional.Jeremy Hylton2001-10-111-1/+1
* Describe the HeaderParser class.Barry Warsaw2001-10-111-0/+11
* A copy-and-paste job forget the "paste" half.Tim Peters2001-10-091-1/+1
* Allow the profiler's calibration constant to be specified in the constructorTim Peters2001-10-091-52/+32
* Fix minor cut-and-paste typo.Barry Warsaw2001-10-091-1/+1
* Update the documentation for the isinstance() function to reflect recentFred Drake2001-10-091-221/+226
* Add documentation for the MIMEAudio class/module, contributed byBarry Warsaw2001-10-091-0/+26
* Improve the documentation for the os.P_* constants used with the os.spawn*()Fred Drake2001-10-091-9/+29
* Note that the values for Boolean options are case-insensitive.Fred Drake2001-10-091-2/+3
* Update the description of getboolean() to reflect the changes made byFred Drake2001-10-081-3/+5
* Remove code and docs for the OldProfile and HotProfile classes: codeTim Peters2001-10-071-170/+23
* Update the documentation to reflect the changes to ReferenceError.Fred Drake2001-10-062-1/+13
* A regexp example was rendered asTim Peters2001-10-051-1/+1
* Add chroot call. Implements feature #459267.Martin v. Löwis2001-10-041-0/+6
* Update a couple of old addresses that point to CNRI.Fred Drake2001-10-042-9/+11
* Make clear that tuple() accepts the same kind of arguments as list().Tim Peters2001-10-041-1/+3
* CVS patch [#466628] Doc changes for doctest patch (#466616), fromTim Peters2001-10-021-25/+2
* Fredrik tells me the truefalse parameter for boolean() is not part of theFred Drake2001-10-011-5/+3
* "boolean" --> "Boolean" (per the style guide).Fred Drake2001-10-014-5/+5
* Straighten out some markup.Fred Drake2001-10-011-3/+4
* Clarify comments about mailbox objects being iterable.Fred Drake2001-10-011-2/+3
* Docs for SF patch #462628Guido van Rossum2001-10-011-2/+8
* Patch #462122: add readline startup and pre_event hooks.Martin v. Löwis2001-09-301-0/+16
* Patch #462190, patch #464070: Support quoted printable in the binascii module.Martin v. Löwis2001-09-302-7/+33
* The execfile() docs imply it acts on locals same as exec. But in truthTim Peters2001-09-301-0/+7
* Correct docs for long(float).Tim Peters2001-09-301-2/+1
* Fix two typos in the text about compile(), and add two caveats fromGuido van Rossum2001-09-291-2/+9
* forgot to mark use of StringType and UnicodeType in the text.Skip Montanaro2001-09-291-2/+3
* added description of StringTypes objectSkip Montanaro2001-09-291-0/+5
* Minor markup improvement.Fred Drake2001-09-291-2/+2
* The list.sort() docs require a function that returns -1, 0 or +1. That'sTim Peters2001-09-291-1/+1
* Move XML-RPC-related docs to the "Internet Protocols" chapter.Fred Drake2001-09-281-1/+2
* Preliminary documentation for the SimpleXMLRPCServer module.Fred Drake2001-09-281-0/+69
* Use consistent version annotations instead of something ad hoc.Fred Drake2001-09-281-4/+7
* Added note about non-support of UNC paths on Windows.Fred Drake2001-09-282-1/+6
* State that encode() and encodestring() append a newline to the input dataFred Drake2001-09-281-2/+7
* Add entries for the email and compiler packages.Fred Drake2001-09-271-0/+10
* Markup adjustments.Fred Drake2001-09-271-4/+5
* Migrate the compiler documentation from the Tools/compiler/doc/ directory.Fred Drake2001-09-272-0/+589
* Fix some markup errors.Fred Drake2001-09-271-2/+2
* Markup adjustment: \[...\] is math markup and does not translate well whenFred Drake2001-09-271-6/+7
* Updates do email package documentation for markup, style, andBarry Warsaw2001-09-268-225/+161
* Start making some markup adjustments; Barry has indicated he will work onFred Drake2001-09-261-17/+17
* The email package documentation, currently organized the way I thinkBarry Warsaw2001-09-268-0/+1168
* Clarified some points about the interface to the mmap() function.Fred Drake2001-09-251-10/+11
eric/tkTextWind.c create mode 100644 generic/tkTrig.c create mode 100644 generic/tkUtil.c create mode 100644 generic/tkVisual.c create mode 100644 generic/tkWindow.c create mode 100644 library/bgerror.tcl create mode 100644 library/button.tcl create mode 100644 library/clrpick.tcl create mode 100644 library/comdlg.tcl create mode 100644 library/console.tcl create mode 100644 library/demos/README create mode 100644 library/demos/arrow.tcl create mode 100644 library/demos/bind.tcl create mode 100644 library/demos/bitmap.tcl create mode 100644 library/demos/browse create mode 100644 library/demos/button.tcl create mode 100644 library/demos/check.tcl create mode 100644 library/demos/clrpick.tcl create mode 100644 library/demos/colors.tcl create mode 100644 library/demos/cscroll.tcl create mode 100644 library/demos/ctext.tcl create mode 100644 library/demos/dialog1.tcl create mode 100644 library/demos/dialog2.tcl create mode 100644 library/demos/entry1.tcl create mode 100644 library/demos/entry2.tcl create mode 100644 library/demos/filebox.tcl create mode 100644 library/demos/floor.tcl create mode 100644 library/demos/form.tcl create mode 100644 library/demos/hello create mode 100644 library/demos/hscale.tcl create mode 100644 library/demos/icon.tcl create mode 100644 library/demos/image1.tcl create mode 100644 library/demos/image2.tcl create mode 100644 library/demos/images/earth.gif create mode 100644 library/demos/images/earthris.gif create mode 100644 library/demos/images/face.bmp create mode 100644 library/demos/images/flagdown.bmp create mode 100644 library/demos/images/flagup.bmp create mode 100644 library/demos/images/gray25.bmp create mode 100644 library/demos/images/letters.bmp create mode 100644 library/demos/images/noletter.bmp create mode 100644 library/demos/images/pattern.bmp create mode 100644 library/demos/images/tcllogo.gif create mode 100644 library/demos/images/teapot.ppm create mode 100644 library/demos/items.tcl create mode 100644 library/demos/ixset create mode 100644 library/demos/label.tcl create mode 100644 library/demos/menu.tcl create mode 100644 library/demos/menubu.tcl create mode 100644 library/demos/msgbox.tcl create mode 100644 library/demos/plot.tcl create mode 100644 library/demos/puzzle.tcl create mode 100644 library/demos/radio.tcl create mode 100644 library/demos/rmt create mode 100644 library/demos/rolodex create mode 100644 library/demos/ruler.tcl create mode 100644 library/demos/sayings.tcl create mode 100644 library/demos/search.tcl create mode 100644 library/demos/square create mode 100644 library/demos/states.tcl create mode 100644 library/demos/style.tcl create mode 100644 library/demos/tclIndex create mode 100644 library/demos/tcolor create mode 100644 library/demos/text.tcl create mode 100644 library/demos/timer create mode 100644 library/demos/twind.tcl create mode 100644 library/demos/vscale.tcl create mode 100644 library/demos/widget create mode 100644 library/dialog.tcl create mode 100644 library/entry.tcl create mode 100644 library/focus.tcl create mode 100644 library/images/README create mode 100644 library/images/logo100.gif create mode 100644 library/images/logo64.gif create mode 100644 library/images/logoLarge.gif create mode 100644 library/images/logoMed.gif create mode 100644 library/images/pwrdLogo100.gif create mode 100644 library/images/pwrdLogo150.gif create mode 100644 library/images/pwrdLogo175.gif create mode 100644 library/images/pwrdLogo200.gif create mode 100644 library/images/pwrdLogo75.gif create mode 100644 library/listbox.tcl create mode 100644 library/menu.tcl create mode 100644 library/msgbox.tcl create mode 100644 library/obsolete.tcl create mode 100644 library/optMenu.tcl create mode 100644 library/palette.tcl create mode 100644 library/prolog.ps create mode 100644 library/safetk.tcl create mode 100644 library/scale.tcl create mode 100644 library/scrlbar.tcl create mode 100644 library/tclIndex create mode 100644 library/tearoff.tcl create mode 100644 library/text.tcl create mode 100644 library/tk.tcl create mode 100644 library/tkfbox.tcl create mode 100644 library/xmfbox.tcl create mode 100644 mac/MW_TkHeader.pch create mode 100644 mac/README create mode 100644 mac/bugs.doc create mode 100644 mac/tclets.tcl create mode 100644 mac/tkMac.h create mode 100644 mac/tkMacAppInit.c create mode 100644 mac/tkMacApplication.r create mode 100644 mac/tkMacBitmap.c create mode 100644 mac/tkMacButton.c create mode 100644 mac/tkMacClipboard.c create mode 100644 mac/tkMacColor.c create mode 100644 mac/tkMacCursor.c create mode 100644 mac/tkMacCursors.r create mode 100644 mac/tkMacDefault.h create mode 100644 mac/tkMacDialog.c create mode 100644 mac/tkMacDraw.c create mode 100644 mac/tkMacEmbed.c create mode 100644 mac/tkMacFont.c create mode 100644 mac/tkMacHLEvents.c create mode 100644 mac/tkMacInit.c create mode 100644 mac/tkMacInt.h create mode 100644 mac/tkMacKeyboard.c create mode 100644 mac/tkMacLibrary.r create mode 100644 mac/tkMacMDEF.c create mode 100644 mac/tkMacMDEF.r create mode 100644 mac/tkMacMenu.c create mode 100644 mac/tkMacMenu.r create mode 100644 mac/tkMacMenubutton.c create mode 100644 mac/tkMacMenus.c create mode 100644 mac/tkMacPort.h create mode 100644 mac/tkMacProlog.c create mode 100644 mac/tkMacRegion.c create mode 100644 mac/tkMacResource.r create mode 100644 mac/tkMacScale.c create mode 100644 mac/tkMacScrlbr.c create mode 100644 mac/tkMacSend.c create mode 100644 mac/tkMacShLib.exp create mode 100644 mac/tkMacSubwindows.c create mode 100644 mac/tkMacTest.c create mode 100644 mac/tkMacWindowMgr.c create mode 100644 mac/tkMacWm.c create mode 100644 mac/tkMacXCursors.r create mode 100644 mac/tkMacXStubs.c create mode 100644 tests/README create mode 100644 tests/all create mode 100644 tests/arc.tcl create mode 100644 tests/bell.test create mode 100644 tests/bevel.tcl create mode 100644 tests/bgerror.test create mode 100644 tests/bind.test create mode 100644 tests/bugs.tcl create mode 100644 tests/butGeom.tcl create mode 100644 tests/butGeom2.tcl create mode 100644 tests/button.test create mode 100644 tests/canvImg.test create mode 100644 tests/canvPs.test create mode 100644 tests/canvPsArc.tcl create mode 100644 tests/canvPsBmap.tcl create mode 100644 tests/canvPsGrph.tcl create mode 100644 tests/canvPsText.tcl create mode 100644 tests/canvRect.test create mode 100644 tests/canvText.test create mode 100644 tests/canvWind.test create mode 100644 tests/canvas.test create mode 100644 tests/clipboard.test create mode 100644 tests/clrpick.test create mode 100644 tests/cmap.tcl create mode 100644 tests/cmds.test create mode 100644 tests/color.test create mode 100644 tests/defs create mode 100644 tests/entry.test create mode 100644 tests/event.test create mode 100644 tests/filebox.test create mode 100644 tests/focus.test create mode 100644 tests/focusTcl.test create mode 100644 tests/font.test create mode 100644 tests/frame.test create mode 100644 tests/geometry.test create mode 100644 tests/grid.test create mode 100644 tests/id.test create mode 100644 tests/image.test create mode 100644 tests/imgBmap.test create mode 100644 tests/imgPPM.test create mode 100644 tests/imgPhoto.test create mode 100644 tests/listbox.test create mode 100644 tests/macEmbed.test create mode 100644 tests/macFont.test create mode 100644 tests/macMenu.test create mode 100644 tests/macWinMenu.test create mode 100644 tests/macscrollbar.test create mode 100644 tests/main.test create mode 100644 tests/menu.test create mode 100644 tests/menuDraw.test create mode 100644 tests/menubut.test create mode 100644 tests/msgbox.test create mode 100644 tests/oldpack.test create mode 100644 tests/option.test create mode 100644 tests/pack.test create mode 100644 tests/place.test create mode 100644 tests/raise.test create mode 100644 tests/safe.test create mode 100644 tests/scale.test create mode 100644 tests/scrollbar.test create mode 100644 tests/select.test create mode 100644 tests/send.test create mode 100644 tests/text.test create mode 100644 tests/textBTree.test create mode 100644 tests/textDisp.test create mode 100644 tests/textImage.test create mode 100644 tests/textIndex.test create mode 100644 tests/textMark.test create mode 100644 tests/textTag.test create mode 100644 tests/textWind.test create mode 100644 tests/tk.test create mode 100644 tests/unixButton.test create mode 100644 tests/unixEmbed.test create mode 100644 tests/unixFont.test create mode 100644 tests/unixMenu.test create mode 100644 tests/unixWm.test create mode 100644 tests/util.test create mode 100644 tests/visual create mode 100644 tests/visual.test create mode 100644 tests/winButton.test create mode 100644 tests/winClipboard.test create mode 100644 tests/winFont.test create mode 100644 tests/winMenu.test create mode 100644 tests/winWm.test create mode 100644 tests/window.test create mode 100644 tests/winfo.test create mode 100644 unix/Makefile.in create mode 100644 unix/README create mode 100644 unix/configure.in create mode 100644 unix/install-sh create mode 100644 unix/mkLinks create mode 100644 unix/porting.notes create mode 100644 unix/porting.old create mode 100644 unix/tkAppInit.c create mode 100644 unix/tkConfig.sh.in create mode 100644 unix/tkUnix.c create mode 100644 unix/tkUnix3d.c create mode 100644 unix/tkUnixButton.c create mode 100644 unix/tkUnixColor.c create mode 100644 unix/tkUnixCursor.c create mode 100644 unix/tkUnixDefault.h create mode 100644 unix/tkUnixDialog.c create mode 100644 unix/tkUnixDraw.c create mode 100644 unix/tkUnixEmbed.c create mode 100644 unix/tkUnixEvent.c create mode 100644 unix/tkUnixFocus.c create mode 100644 unix/tkUnixFont.c create mode 100644 unix/tkUnixInit.c create mode 100644 unix/tkUnixInt.h create mode 100644 unix/tkUnixMenu.c create mode 100644 unix/tkUnixMenubu.c create mode 100644 unix/tkUnixPort.h create mode 100644 unix/tkUnixScale.c create mode 100644 unix/tkUnixScrlbr.c create mode 100644 unix/tkUnixSelect.c create mode 100644 unix/tkUnixSend.c create mode 100644 unix/tkUnixWm.c create mode 100644 unix/tkUnixXId.c create mode 100644 win/README create mode 100644 win/makefile.bc create mode 100644 win/makefile.vc create mode 100644 win/rc/buttons.bmp create mode 100644 win/rc/cursor00.cur create mode 100644 win/rc/cursor02.cur create mode 100644 win/rc/cursor04.cur create mode 100644 win/rc/cursor06.cur create mode 100644 win/rc/cursor08.cur create mode 100644 win/rc/cursor0a.cur create mode 100644 win/rc/cursor0c.cur create mode 100644 win/rc/cursor0e.cur create mode 100644 win/rc/cursor10.cur create mode 100644 win/rc/cursor12.cur create mode 100644 win/rc/cursor14.cur create mode 100644 win/rc/cursor16.cur create mode 100644 win/rc/cursor18.cur create mode 100644 win/rc/cursor1a.cur create mode 100644 win/rc/cursor1c.cur create mode 100644 win/rc/cursor1e.cur create mode 100644 win/rc/cursor20.cur create mode 100644 win/rc/cursor22.cur create mode 100644 win/rc/cursor24.cur create mode 100644 win/rc/cursor26.cur create mode 100644 win/rc/cursor28.cur create mode 100644 win/rc/cursor2a.cur create mode 100644 win/rc/cursor2c.cur create mode 100644 win/rc/cursor2e.cur create mode 100644 win/rc/cursor30.cur create mode 100644 win/rc/cursor32.cur create mode 100644 win/rc/cursor34.cur create mode 100644 win/rc/cursor36.cur create mode 100644 win/rc/cursor38.cur create mode 100644 win/rc/cursor3a.cur create mode 100644 win/rc/cursor3c.cur create mode 100644 win/rc/cursor3e.cur create mode 100644 win/rc/cursor40.cur create mode 100644 win/rc/cursor42.cur create mode 100644 win/rc/cursor44.cur create mode 100644 win/rc/cursor46.cur create mode 100644 win/rc/cursor48.cur create mode 100644 win/rc/cursor4a.cur create mode 100644 win/rc/cursor4c.cur create mode 100644 win/rc/cursor4e.cur create mode 100644 win/rc/cursor50.cur create mode 100644 win/rc/cursor52.cur create mode 100644 win/rc/cursor54.cur create mode 100644 win/rc/cursor56.cur create mode 100644 win/rc/cursor58.cur create mode 100644 win/rc/cursor5a.cur create mode 100644 win/rc/cursor5c.cur create mode 100644 win/rc/cursor5e.cur create mode 100644 win/rc/cursor60.cur create mode 100644 win/rc/cursor62.cur create mode 100644 win/rc/cursor64.cur create mode 100644 win/rc/cursor66.cur create mode 100644 win/rc/cursor68.cur create mode 100644 win/rc/cursor6a.cur create mode 100644 win/rc/cursor6c.cur create mode 100644 win/rc/cursor6e.cur create mode 100644 win/rc/cursor70.cur create mode 100644 win/rc/cursor72.cur create mode 100644 win/rc/cursor74.cur create mode 100644 win/rc/cursor76.cur create mode 100644 win/rc/cursor78.cur create mode 100644 win/rc/cursor7a.cur create mode 100644 win/rc/cursor7c.cur create mode 100644 win/rc/cursor7e.cur create mode 100644 win/rc/cursor80.cur create mode 100644 win/rc/cursor82.cur create mode 100644 win/rc/cursor84.cur create mode 100644 win/rc/cursor86.cur create mode 100644 win/rc/cursor88.cur create mode 100644 win/rc/cursor8a.cur create mode 100644 win/rc/cursor8c.cur create mode 100644 win/rc/cursor8e.cur create mode 100644 win/rc/cursor90.cur create mode 100644 win/rc/cursor92.cur create mode 100644 win/rc/cursor94.cur create mode 100644 win/rc/cursor96.cur create mode 100644 win/rc/cursor98.cur create mode 100644 win/rc/tk.ico create mode 100644 win/rc/tk.rc create mode 100644 win/rc/wish.ico create mode 100644 win/rc/wish.rc create mode 100644 win/stubs.c create mode 100644 win/tkWin.h create mode 100644 win/tkWin32Dll.c create mode 100644 win/tkWin3d.c create mode 100644 win/tkWinButton.c create mode 100644 win/tkWinClipboard.c create mode 100644 win/tkWinColor.c create mode 100644 win/tkWinCursor.c create mode 100644 win/tkWinDefault.h create mode 100644 win/tkWinDialog.c create mode 100644 win/tkWinDraw.c create mode 100644 win/tkWinEmbed.c create mode 100644 win/tkWinFont.c create mode 100644 win/tkWinImage.c create mode 100644 win/tkWinInit.c create mode 100644 win/tkWinInt.h create mode 100644 win/tkWinKey.c create mode 100644 win/tkWinMenu.c create mode 100644 win/tkWinPixmap.c create mode 100644 win/tkWinPointer.c create mode 100644 win/tkWinPort.h create mode 100644 win/tkWinRegion.c create mode 100644 win/tkWinScrlbr.c create mode 100644 win/tkWinSend.c create mode 100644 win/tkWinWindow.c create mode 100644 win/tkWinWm.c create mode 100644 win/tkWinX.c create mode 100644 win/winMain.c create mode 100644 xlib/X11/X.h create mode 100644 xlib/X11/Xatom.h create mode 100644 xlib/X11/Xfuncproto.h create mode 100644 xlib/X11/Xlib.h create mode 100644 xlib/X11/Xutil.h create mode 100644 xlib/X11/cursorfont.h create mode 100644 xlib/X11/keysym.h create mode 100644 xlib/X11/keysymdef.h create mode 100644 xlib/xbytes.h create mode 100644 xlib/xcolors.c create mode 100644 xlib/xdraw.c create mode 100644 xlib/xgc.c create mode 100644 xlib/ximage.c create mode 100644 xlib/xutil.c diff --git a/deleted_files/xlib/ximage.c b/deleted_files/xlib/ximage.c new file mode 100644 index 0000000..057e973 --- /dev/null +++ b/deleted_files/xlib/ximage.c @@ -0,0 +1,115 @@ +/* + * ximage.c -- + * + * X bitmap and image routines. + * + * Copyright (c) 1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) ximage.c 1.6 96/07/23 16:59:10 + */ + +#include "tkInt.h" + + +/* + *---------------------------------------------------------------------- + * + * XCreateBitmapFromData -- + * + * Construct a single plane pixmap from bitmap data. + * + * Results: + * Returns a new Pixmap. + * + * Side effects: + * Allocates a new bitmap and drawable. + * + *---------------------------------------------------------------------- + */ + +Pixmap +XCreateBitmapFromData(display, d, data, width, height) + Display* display; + Drawable d; + _Xconst char* data; + unsigned int width; + unsigned int height; +{ + XImage ximage; + GC gc; + Pixmap pix; + + pix = Tk_GetPixmap(display, d, width, height, 1); + gc = XCreateGC(display, pix, 0, NULL); + if (gc == NULL) { + return None; + } + ximage.height = height; + ximage.width = width; + ximage.depth = 1; + ximage.bits_per_pixel = 1; + ximage.xoffset = 0; + ximage.format = XYBitmap; + ximage.data = (char *)data; + ximage.byte_order = LSBFirst; + ximage.bitmap_unit = 8; + ximage.bitmap_bit_order = LSBFirst; + ximage.bitmap_pad = 8; + ximage.bytes_per_line = (width+7)/8; + + TkPutImage(NULL, 0, display, pix, gc, &ximage, 0, 0, 0, 0, width, height); + XFreeGC(display, gc); + return pix; +} + +/* + *---------------------------------------------------------------------- + * + * XReadBitmapFile -- + * + * Loads a bitmap image in X bitmap format into the specified + * drawable. + * + * Results: + * Sets the size, hotspot, and bitmap on success. + * + * Side effects: + * Creates a new bitmap from the file data. + * + *---------------------------------------------------------------------- + */ + +int +XReadBitmapFile(display, d, filename, width_return, height_return, + bitmap_return, x_hot_return, y_hot_return) + Display* display; + Drawable d; + _Xconst char* filename; + unsigned int* width_return; + unsigned int* height_return; + Pixmap* bitmap_return; + int* x_hot_return; + int* y_hot_return; +{ + Tcl_Interp *dummy; + char *data; + + dummy = Tcl_CreateInterp(); + + data = TkGetBitmapData(dummy, NULL, (char *) filename, + (int *) width_return, (int *) height_return, x_hot_return, + y_hot_return); + if (data == NULL) { + return BitmapFileInvalid; + } + + *bitmap_return = XCreateBitmapFromData(display, d, data, *width_return, + *height_return); + + Tcl_DeleteInterp(dummy); + ckfree(data); + return BitmapSuccess; +} diff --git a/generic/README b/generic/README new file mode 100644 index 0000000..572cc93 --- /dev/null +++ b/generic/README @@ -0,0 +1,5 @@ +This directory contains Tk source files that work on all the platforms +where Tk runs (e.g. UNIX, PCs, and Macintoshes). Platform-specific +sources are in the directories ../unix, ../win, and ../mac. + +SCCS ID: @(#) README 1.1 95/09/11 14:02:45 diff --git a/generic/default.h b/generic/default.h new file mode 100644 index 0000000..91a19f6 --- /dev/null +++ b/generic/default.h @@ -0,0 +1,29 @@ +/* + * default.h -- + * + * This file defines the defaults for all options for all of + * the Tk widgets. + * + * Copyright (c) 1991-1994 The Regents of the University of California. + * Copyright (c) 1994 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: @(#) default.h 1.4 96/02/07 17:33:39 + */ + +#ifndef _DEFAULT +#define _DEFAULT + +#if defined(__WIN32__) || defined(_WIN32) +# include "tkWinDefault.h" +#else +# if defined(MAC_TCL) +# include "tkMacDefault.h" +# else +# include "tkUnixDefault.h" +# endif +#endif + +#endif /* _DEFAULT */ diff --git a/generic/ks_names.h b/generic/ks_names.h new file mode 100644 index 0000000..3eee008 --- /dev/null +++ b/generic/ks_names.h @@ -0,0 +1,917 @@ +/* + * This file is generated from $(INCLUDESRC)/keysymdef.h. Do not edit. + */ +{ "BackSpace", 0xFF08 }, +{ "Tab", 0xFF09 }, +{ "Linefeed", 0xFF0A }, +{ "Clear", 0xFF0B }, +{ "Return", 0xFF0D }, +{ "Pause", 0xFF13 }, +{ "Escape", 0xFF1B }, +{ "Delete", 0xFFFF }, +{ "Multi_key", 0xFF20 }, +{ "Kanji", 0xFF21 }, +{ "Home", 0xFF50 }, +{ "Left", 0xFF51 }, +{ "Up", 0xFF52 }, +{ "Right", 0xFF53 }, +{ "Down", 0xFF54 }, +{ "Prior", 0xFF55 }, +{ "Next", 0xFF56 }, +{ "End", 0xFF57 }, +{ "Begin", 0xFF58 }, +{ "Select", 0xFF60 }, +{ "Print", 0xFF61 }, +{ "Execute", 0xFF62 }, +{ "Insert", 0xFF63 }, +{ "Undo", 0xFF65 }, +{ "Redo", 0xFF66 }, +{ "Menu", 0xFF67 }, +{ "Find", 0xFF68 }, +{ "Cancel", 0xFF69 }, +{ "Help", 0xFF6A }, +{ "Break", 0xFF6B }, +{ "Mode_switch", 0xFF7E }, +{ "script_switch", 0xFF7E }, +{ "Num_Lock", 0xFF7F }, +{ "KP_Space", 0xFF80 }, +{ "KP_Tab", 0xFF89 }, +{ "KP_Enter", 0xFF8D }, +{ "KP_F1", 0xFF91 }, +{ "KP_F2", 0xFF92 }, +{ "KP_F3", 0xFF93 }, +{ "KP_F4", 0xFF94 }, +{ "KP_Equal", 0xFFBD }, +{ "KP_Multiply", 0xFFAA }, +{ "KP_Add", 0xFFAB }, +{ "KP_Separator", 0xFFAC }, +{ "KP_Subtract", 0xFFAD }, +{ "KP_Decimal", 0xFFAE }, +{ "KP_Divide", 0xFFAF }, +{ "KP_0", 0xFFB0 }, +{ "KP_1", 0xFFB1 }, +{ "KP_2", 0xFFB2 }, +{ "KP_3", 0xFFB3 }, +{ "KP_4", 0xFFB4 }, +{ "KP_5", 0xFFB5 }, +{ "KP_6", 0xFFB6 }, +{ "KP_7", 0xFFB7 }, +{ "KP_8", 0xFFB8 }, +{ "KP_9", 0xFFB9 }, +{ "F1", 0xFFBE }, +{ "F2", 0xFFBF }, +{ "F3", 0xFFC0 }, +{ "F4", 0xFFC1 }, +{ "F5", 0xFFC2 }, +{ "F6", 0xFFC3 }, +{ "F7", 0xFFC4 }, +{ "F8", 0xFFC5 }, +{ "F9", 0xFFC6 }, +{ "F10", 0xFFC7 }, +{ "F11", 0xFFC8 }, +{ "L1", 0xFFC8 }, +{ "F12", 0xFFC9 }, +{ "L2", 0xFFC9 }, +{ "F13", 0xFFCA }, +{ "L3", 0xFFCA }, +{ "F14", 0xFFCB }, +{ "L4", 0xFFCB }, +{ "F15", 0xFFCC }, +{ "L5", 0xFFCC }, +{ "F16", 0xFFCD }, +{ "L6", 0xFFCD }, +{ "F17", 0xFFCE }, +{ "L7", 0xFFCE }, +{ "F18", 0xFFCF }, +{ "L8", 0xFFCF }, +{ "F19", 0xFFD0 }, +{ "L9", 0xFFD0 }, +{ "F20", 0xFFD1 }, +{ "L10", 0xFFD1 }, +{ "F21", 0xFFD2 }, +{ "R1", 0xFFD2 }, +{ "F22", 0xFFD3 }, +{ "R2", 0xFFD3 }, +{ "F23", 0xFFD4 }, +{ "R3", 0xFFD4 }, +{ "F24", 0xFFD5 }, +{ "R4", 0xFFD5 }, +{ "F25", 0xFFD6 }, +{ "R5", 0xFFD6 }, +{ "F26", 0xFFD7 }, +{ "R6", 0xFFD7 }, +{ "F27", 0xFFD8 }, +{ "R7", 0xFFD8 }, +{ "F28", 0xFFD9 }, +{ "R8", 0xFFD9 }, +{ "F29", 0xFFDA }, +{ "R9", 0xFFDA }, +{ "F30", 0xFFDB }, +{ "R10", 0xFFDB }, +{ "F31", 0xFFDC }, +{ "R11", 0xFFDC }, +{ "F32", 0xFFDD }, +{ "R12", 0xFFDD }, +{ "R13", 0xFFDE }, +{ "F33", 0xFFDE }, +{ "F34", 0xFFDF }, +{ "R14", 0xFFDF }, +{ "F35", 0xFFE0 }, +{ "R15", 0xFFE0 }, +{ "Shift_L", 0xFFE1 }, +{ "Shift_R", 0xFFE2 }, +{ "Control_L", 0xFFE3 }, +{ "Control_R", 0xFFE4 }, +{ "Caps_Lock", 0xFFE5 }, +{ "Shift_Lock", 0xFFE6 }, +{ "Meta_L", 0xFFE7 }, +{ "Meta_R", 0xFFE8 }, +{ "Alt_L", 0xFFE9 }, +{ "Alt_R", 0xFFEA }, +{ "Super_L", 0xFFEB }, +{ "Super_R", 0xFFEC }, +{ "Hyper_L", 0xFFED }, +{ "Hyper_R", 0xFFEE }, +{ "space", 0x020 }, +{ "exclam", 0x021 }, +{ "quotedbl", 0x022 }, +{ "numbersign", 0x023 }, +{ "dollar", 0x024 }, +{ "percent", 0x025 }, +{ "ampersand", 0x026 }, +{ "quoteright", 0x027 }, +{ "parenleft", 0x028 }, +{ "parenright", 0x029 }, +{ "asterisk", 0x02a }, +{ "plus", 0x02b }, +{ "comma", 0x02c }, +{ "minus", 0x02d }, +{ "period", 0x02e }, +{ "slash", 0x02f }, +{ "0", 0x030 }, +{ "1", 0x031 }, +{ "2", 0x032 }, +{ "3", 0x033 }, +{ "4", 0x034 }, +{ "5", 0x035 }, +{ "6", 0x036 }, +{ "7", 0x037 }, +{ "8", 0x038 }, +{ "9", 0x039 }, +{ "colon", 0x03a }, +{ "semicolon", 0x03b }, +{ "less", 0x03c }, +{ "equal", 0x03d }, +{ "greater", 0x03e }, +{ "question", 0x03f }, +{ "at", 0x040 }, +{ "A", 0x041 }, +{ "B", 0x042 }, +{ "C", 0x043 }, +{ "D", 0x044 }, +{ "E", 0x045 }, +{ "F", 0x046 }, +{ "G", 0x047 }, +{ "H", 0x048 }, +{ "I", 0x049 }, +{ "J", 0x04a }, +{ "K", 0x04b }, +{ "L", 0x04c }, +{ "M", 0x04d }, +{ "N", 0x04e }, +{ "O", 0x04f }, +{ "P", 0x050 }, +{ "Q", 0x051 }, +{ "R", 0x052 }, +{ "S", 0x053 }, +{ "T", 0x054 }, +{ "U", 0x055 }, +{ "V", 0x056 }, +{ "W", 0x057 }, +{ "X", 0x058 }, +{ "Y", 0x059 }, +{ "Z", 0x05a }, +{ "bracketleft", 0x05b }, +{ "backslash", 0x05c }, +{ "bracketright", 0x05d }, +{ "asciicircum", 0x05e }, +{ "underscore", 0x05f }, +{ "quoteleft", 0x060 }, +{ "a", 0x061 }, +{ "b", 0x062 }, +{ "c", 0x063 }, +{ "d", 0x064 }, +{ "e", 0x065 }, +{ "f", 0x066 }, +{ "g", 0x067 }, +{ "h", 0x068 }, +{ "i", 0x069 }, +{ "j", 0x06a }, +{ "k", 0x06b }, +{ "l", 0x06c }, +{ "m", 0x06d }, +{ "n", 0x06e }, +{ "o", 0x06f }, +{ "p", 0x070 }, +{ "q", 0x071 }, +{ "r", 0x072 }, +{ "s", 0x073 }, +{ "t", 0x074 }, +{ "u", 0x075 }, +{ "v", 0x076 }, +{ "w", 0x077 }, +{ "x", 0x078 }, +{ "y", 0x079 }, +{ "z", 0x07a }, +{ "braceleft", 0x07b }, +{ "bar", 0x07c }, +{ "braceright", 0x07d }, +{ "asciitilde", 0x07e }, +{ "nobreakspace", 0x0a0 }, +{ "exclamdown", 0x0a1 }, +{ "cent", 0x0a2 }, +{ "sterling", 0x0a3 }, +{ "currency", 0x0a4 }, +{ "yen", 0x0a5 }, +{ "brokenbar", 0x0a6 }, +{ "section", 0x0a7 }, +{ "diaeresis", 0x0a8 }, +{ "copyright", 0x0a9 }, +{ "ordfeminine", 0x0aa }, +{ "guillemotleft", 0x0ab }, +{ "notsign", 0x0ac }, +{ "hyphen", 0x0ad }, +{ "registered", 0x0ae }, +{ "macron", 0x0af }, +{ "degree", 0x0b0 }, +{ "plusminus", 0x0b1 }, +{ "twosuperior", 0x0b2 }, +{ "threesuperior", 0x0b3 }, +{ "acute", 0x0b4 }, +{ "mu", 0x0b5 }, +{ "paragraph", 0x0b6 }, +{ "periodcentered", 0x0b7 }, +{ "cedilla", 0x0b8 }, +{ "onesuperior", 0x0b9 }, +{ "masculine", 0x0ba }, +{ "guillemotright", 0x0bb }, +{ "onequarter", 0x0bc }, +{ "onehalf", 0x0bd }, +{ "threequarters", 0x0be }, +{ "questiondown", 0x0bf }, +{ "Agrave", 0x0c0 }, +{ "Aacute", 0x0c1 }, +{ "Acircumflex", 0x0c2 }, +{ "Atilde", 0x0c3 }, +{ "Adiaeresis", 0x0c4 }, +{ "Aring", 0x0c5 }, +{ "AE", 0x0c6 }, +{ "Ccedilla", 0x0c7 }, +{ "Egrave", 0x0c8 }, +{ "Eacute", 0x0c9 }, +{ "Ecircumflex", 0x0ca }, +{ "Ediaeresis", 0x0cb }, +{ "Igrave", 0x0cc }, +{ "Iacute", 0x0cd }, +{ "Icircumflex", 0x0ce }, +{ "Idiaeresis", 0x0cf }, +{ "Eth", 0x0d0 }, +{ "Ntilde", 0x0d1 }, +{ "Ograve", 0x0d2 }, +{ "Oacute", 0x0d3 }, +{ "Ocircumflex", 0x0d4 }, +{ "Otilde", 0x0d5 }, +{ "Odiaeresis", 0x0d6 }, +{ "multiply", 0x0d7 }, +{ "Ooblique", 0x0d8 }, +{ "Ugrave", 0x0d9 }, +{ "Uacute", 0x0da }, +{ "Ucircumflex", 0x0db }, +{ "Udiaeresis", 0x0dc }, +{ "Yacute", 0x0dd }, +{ "Thorn", 0x0de }, +{ "ssharp", 0x0df }, +{ "agrave", 0x0e0 }, +{ "aacute", 0x0e1 }, +{ "acircumflex", 0x0e2 }, +{ "atilde", 0x0e3 }, +{ "adiaeresis", 0x0e4 }, +{ "aring", 0x0e5 }, +{ "ae", 0x0e6 }, +{ "ccedilla", 0x0e7 }, +{ "egrave", 0x0e8 }, +{ "eacute", 0x0e9 }, +{ "ecircumflex", 0x0ea }, +{ "ediaeresis", 0x0eb }, +{ "igrave", 0x0ec }, +{ "iacute", 0x0ed }, +{ "icircumflex", 0x0ee }, +{ "idiaeresis", 0x0ef }, +{ "eth", 0x0f0 }, +{ "ntilde", 0x0f1 }, +{ "ograve", 0x0f2 }, +{ "oacute", 0x0f3 }, +{ "ocircumflex", 0x0f4 }, +{ "otilde", 0x0f5 }, +{ "odiaeresis", 0x0f6 }, +{ "division", 0x0f7 }, +{ "oslash", 0x0f8 }, +{ "ugrave", 0x0f9 }, +{ "uacute", 0x0fa }, +{ "ucircumflex", 0x0fb }, +{ "udiaeresis", 0x0fc }, +{ "yacute", 0x0fd }, +{ "thorn", 0x0fe }, +{ "ydiaeresis", 0x0ff }, +{ "Aogonek", 0x1a1 }, +{ "breve", 0x1a2 }, +{ "Lstroke", 0x1a3 }, +{ "Lcaron", 0x1a5 }, +{ "Sacute", 0x1a6 }, +{ "Scaron", 0x1a9 }, +{ "Scedilla", 0x1aa }, +{ "Tcaron", 0x1ab }, +{ "Zacute", 0x1ac }, +{ "Zcaron", 0x1ae }, +{ "Zabovedot", 0x1af }, +{ "aogonek", 0x1b1 }, +{ "ogonek", 0x1b2 }, +{ "lstroke", 0x1b3 }, +{ "lcaron", 0x1b5 }, +{ "sacute", 0x1b6 }, +{ "caron", 0x1b7 }, +{ "scaron", 0x1b9 }, +{ "scedilla", 0x1ba }, +{ "tcaron", 0x1bb }, +{ "zacute", 0x1bc }, +{ "doubleacute", 0x1bd }, +{ "zcaron", 0x1be }, +{ "zabovedot", 0x1bf }, +{ "Racute", 0x1c0 }, +{ "Abreve", 0x1c3 }, +{ "Cacute", 0x1c6 }, +{ "Ccaron", 0x1c8 }, +{ "Eogonek", 0x1ca }, +{ "Ecaron", 0x1cc }, +{ "Dcaron", 0x1cf }, +{ "Nacute", 0x1d1 }, +{ "Ncaron", 0x1d2 }, +{ "Odoubleacute", 0x1d5 }, +{ "Rcaron", 0x1d8 }, +{ "Uring", 0x1d9 }, +{ "Udoubleacute", 0x1db }, +{ "Tcedilla", 0x1de }, +{ "racute", 0x1e0 }, +{ "abreve", 0x1e3 }, +{ "cacute", 0x1e6 }, +{ "ccaron", 0x1e8 }, +{ "eogonek", 0x1ea }, +{ "ecaron", 0x1ec }, +{ "dcaron", 0x1ef }, +{ "nacute", 0x1f1 }, +{ "ncaron", 0x1f2 }, +{ "odoubleacute", 0x1f5 }, +{ "udoubleacute", 0x1fb }, +{ "rcaron", 0x1f8 }, +{ "uring", 0x1f9 }, +{ "tcedilla", 0x1fe }, +{ "abovedot", 0x1ff }, +{ "Hstroke", 0x2a1 }, +{ "Hcircumflex", 0x2a6 }, +{ "Iabovedot", 0x2a9 }, +{ "Gbreve", 0x2ab }, +{ "Jcircumflex", 0x2ac }, +{ "hstroke", 0x2b1 }, +{ "hcircumflex", 0x2b6 }, +{ "idotless", 0x2b9 }, +{ "gbreve", 0x2bb }, +{ "jcircumflex", 0x2bc }, +{ "Cabovedot", 0x2c5 }, +{ "Ccircumflex", 0x2c6 }, +{ "Gabovedot", 0x2d5 }, +{ "Gcircumflex", 0x2d8 }, +{ "Ubreve", 0x2dd }, +{ "Scircumflex", 0x2de }, +{ "cabovedot", 0x2e5 }, +{ "ccircumflex", 0x2e6 }, +{ "gabovedot", 0x2f5 }, +{ "gcircumflex", 0x2f8 }, +{ "ubreve", 0x2fd }, +{ "scircumflex", 0x2fe }, +{ "kappa", 0x3a2 }, +{ "Rcedilla", 0x3a3 }, +{ "Itilde", 0x3a5 }, +{ "Lcedilla", 0x3a6 }, +{ "Emacron", 0x3aa }, +{ "Gcedilla", 0x3ab }, +{ "Tslash", 0x3ac }, +{ "rcedilla", 0x3b3 }, +{ "itilde", 0x3b5 }, +{ "lcedilla", 0x3b6 }, +{ "emacron", 0x3ba }, +{ "gacute", 0x3bb }, +{ "tslash", 0x3bc }, +{ "ENG", 0x3bd }, +{ "eng", 0x3bf }, +{ "Amacron", 0x3c0 }, +{ "Iogonek", 0x3c7 }, +{ "Eabovedot", 0x3cc }, +{ "Imacron", 0x3cf }, +{ "Ncedilla", 0x3d1 }, +{ "Omacron", 0x3d2 }, +{ "Kcedilla", 0x3d3 }, +{ "Uogonek", 0x3d9 }, +{ "Utilde", 0x3dd }, +{ "Umacron", 0x3de }, +{ "amacron", 0x3e0 }, +{ "iogonek", 0x3e7 }, +{ "eabovedot", 0x3ec }, +{ "imacron", 0x3ef }, +{ "ncedilla", 0x3f1 }, +{ "omacron", 0x3f2 }, +{ "kcedilla", 0x3f3 }, +{ "uogonek", 0x3f9 }, +{ "utilde", 0x3fd }, +{ "umacron", 0x3fe }, +{ "overline", 0x47e }, +{ "kana_fullstop", 0x4a1 }, +{ "kana_openingbracket", 0x4a2 }, +{ "kana_closingbracket", 0x4a3 }, +{ "kana_comma", 0x4a4 }, +{ "kana_middledot", 0x4a5 }, +{ "kana_WO", 0x4a6 }, +{ "kana_a", 0x4a7 }, +{ "kana_i", 0x4a8 }, +{ "kana_u", 0x4a9 }, +{ "kana_e", 0x4aa }, +{ "kana_o", 0x4ab }, +{ "kana_ya", 0x4ac }, +{ "kana_yu", 0x4ad }, +{ "kana_yo", 0x4ae }, +{ "kana_tu", 0x4af }, +{ "prolongedsound", 0x4b0 }, +{ "kana_A", 0x4b1 }, +{ "kana_I", 0x4b2 }, +{ "kana_U", 0x4b3 }, +{ "kana_E", 0x4b4 }, +{ "kana_O", 0x4b5 }, +{ "kana_KA", 0x4b6 }, +{ "kana_KI", 0x4b7 }, +{ "kana_KU", 0x4b8 }, +{ "kana_KE", 0x4b9 }, +{ "kana_KO", 0x4ba }, +{ "kana_SA", 0x4bb }, +{ "kana_SHI", 0x4bc }, +{ "kana_SU", 0x4bd }, +{ "kana_SE", 0x4be }, +{ "kana_SO", 0x4bf }, +{ "kana_TA", 0x4c0 }, +{ "kana_TI", 0x4c1 }, +{ "kana_TU", 0x4c2 }, +{ "kana_TE", 0x4c3 }, +{ "kana_TO", 0x4c4 }, +{ "kana_NA", 0x4c5 }, +{ "kana_NI", 0x4c6 }, +{ "kana_NU", 0x4c7 }, +{ "kana_NE", 0x4c8 }, +{ "kana_NO", 0x4c9 }, +{ "kana_HA", 0x4ca }, +{ "kana_HI", 0x4cb }, +{ "kana_HU", 0x4cc }, +{ "kana_HE", 0x4cd }, +{ "kana_HO", 0x4ce }, +{ "kana_MA", 0x4cf }, +{ "kana_MI", 0x4d0 }, +{ "kana_MU", 0x4d1 }, +{ "kana_ME", 0x4d2 }, +{ "kana_MO", 0x4d3 }, +{ "kana_YA", 0x4d4 }, +{ "kana_YU", 0x4d5 }, +{ "kana_YO", 0x4d6 }, +{ "kana_RA", 0x4d7 }, +{ "kana_RI", 0x4d8 }, +{ "kana_RU", 0x4d9 }, +{ "kana_RE", 0x4da }, +{ "kana_RO", 0x4db }, +{ "kana_WA", 0x4dc }, +{ "kana_N", 0x4dd }, +{ "voicedsound", 0x4de }, +{ "semivoicedsound", 0x4df }, +{ "kana_switch", 0xFF7E }, +{ "Arabic_comma", 0x5ac }, +{ "Arabic_semicolon", 0x5bb }, +{ "Arabic_question_mark", 0x5bf }, +{ "Arabic_hamza", 0x5c1 }, +{ "Arabic_maddaonalef", 0x5c2 }, +{ "Arabic_hamzaonalef", 0x5c3 }, +{ "Arabic_hamzaonwaw", 0x5c4 }, +{ "Arabic_hamzaunderalef", 0x5c5 }, +{ "Arabic_hamzaonyeh", 0x5c6 }, +{ "Arabic_alef", 0x5c7 }, +{ "Arabic_beh", 0x5c8 }, +{ "Arabic_tehmarbuta", 0x5c9 }, +{ "Arabic_teh", 0x5ca }, +{ "Arabic_theh", 0x5cb }, +{ "Arabic_jeem", 0x5cc }, +{ "Arabic_hah", 0x5cd }, +{ "Arabic_khah", 0x5ce }, +{ "Arabic_dal", 0x5cf }, +{ "Arabic_thal", 0x5d0 }, +{ "Arabic_ra", 0x5d1 }, +{ "Arabic_zain", 0x5d2 }, +{ "Arabic_seen", 0x5d3 }, +{ "Arabic_sheen", 0x5d4 }, +{ "Arabic_sad", 0x5d5 }, +{ "Arabic_dad", 0x5d6 }, +{ "Arabic_tah", 0x5d7 }, +{ "Arabic_zah", 0x5d8 }, +{ "Arabic_ain", 0x5d9 }, +{ "Arabic_ghain", 0x5da }, +{ "Arabic_tatweel", 0x5e0 }, +{ "Arabic_feh", 0x5e1 }, +{ "Arabic_qaf", 0x5e2 }, +{ "Arabic_kaf", 0x5e3 }, +{ "Arabic_lam", 0x5e4 }, +{ "Arabic_meem", 0x5e5 }, +{ "Arabic_noon", 0x5e6 }, +{ "Arabic_heh", 0x5e7 }, +{ "Arabic_waw", 0x5e8 }, +{ "Arabic_alefmaksura", 0x5e9 }, +{ "Arabic_yeh", 0x5ea }, +{ "Arabic_fathatan", 0x5eb }, +{ "Arabic_dammatan", 0x5ec }, +{ "Arabic_kasratan", 0x5ed }, +{ "Arabic_fatha", 0x5ee }, +{ "Arabic_damma", 0x5ef }, +{ "Arabic_kasra", 0x5f0 }, +{ "Arabic_shadda", 0x5f1 }, +{ "Arabic_sukun", 0x5f2 }, +{ "Arabic_switch", 0xFF7E }, +{ "Serbian_dje", 0x6a1 }, +{ "Macedonia_gje", 0x6a2 }, +{ "Cyrillic_io", 0x6a3 }, +{ "Ukranian_je", 0x6a4 }, +{ "Macedonia_dse", 0x6a5 }, +{ "Ukranian_i", 0x6a6 }, +{ "Ukranian_yi", 0x6a7 }, +{ "Serbian_je", 0x6a8 }, +{ "Serbian_lje", 0x6a9 }, +{ "Serbian_nje", 0x6aa }, +{ "Serbian_tshe", 0x6ab }, +{ "Macedonia_kje", 0x6ac }, +{ "Byelorussian_shortu", 0x6ae }, +{ "Serbian_dze", 0x6af }, +{ "numerosign", 0x6b0 }, +{ "Serbian_DJE", 0x6b1 }, +{ "Macedonia_GJE", 0x6b2 }, +{ "Cyrillic_IO", 0x6b3 }, +{ "Ukranian_JE", 0x6b4 }, +{ "Macedonia_DSE", 0x6b5 }, +{ "Ukranian_I", 0x6b6 }, +{ "Ukranian_YI", 0x6b7 }, +{ "Serbian_JE", 0x6b8 }, +{ "Serbian_LJE", 0x6b9 }, +{ "Serbian_NJE", 0x6ba }, +{ "Serbian_TSHE", 0x6bb }, +{ "Macedonia_KJE", 0x6bc }, +{ "Byelorussian_SHORTU", 0x6be }, +{ "Serbian_DZE", 0x6bf }, +{ "Cyrillic_yu", 0x6c0 }, +{ "Cyrillic_a", 0x6c1 }, +{ "Cyrillic_be", 0x6c2 }, +{ "Cyrillic_tse", 0x6c3 }, +{ "Cyrillic_de", 0x6c4 }, +{ "Cyrillic_ie", 0x6c5 }, +{ "Cyrillic_ef", 0x6c6 }, +{ "Cyrillic_ghe", 0x6c7 }, +{ "Cyrillic_ha", 0x6c8 }, +{ "Cyrillic_i", 0x6c9 }, +{ "Cyrillic_shorti", 0x6ca }, +{ "Cyrillic_ka", 0x6cb }, +{ "Cyrillic_el", 0x6cc }, +{ "Cyrillic_em", 0x6cd }, +{ "Cyrillic_en", 0x6ce }, +{ "Cyrillic_o", 0x6cf }, +{ "Cyrillic_pe", 0x6d0 }, +{ "Cyrillic_ya", 0x6d1 }, +{ "Cyrillic_er", 0x6d2 }, +{ "Cyrillic_es", 0x6d3 }, +{ "Cyrillic_te", 0x6d4 }, +{ "Cyrillic_u", 0x6d5 }, +{ "Cyrillic_zhe", 0x6d6 }, +{ "Cyrillic_ve", 0x6d7 }, +{ "Cyrillic_softsign", 0x6d8 }, +{ "Cyrillic_yeru", 0x6d9 }, +{ "Cyrillic_ze", 0x6da }, +{ "Cyrillic_sha", 0x6db }, +{ "Cyrillic_e", 0x6dc }, +{ "Cyrillic_shcha", 0x6dd }, +{ "Cyrillic_che", 0x6de }, +{ "Cyrillic_hardsign", 0x6df }, +{ "Cyrillic_YU", 0x6e0 }, +{ "Cyrillic_A", 0x6e1 }, +{ "Cyrillic_BE", 0x6e2 }, +{ "Cyrillic_TSE", 0x6e3 }, +{ "Cyrillic_DE", 0x6e4 }, +{ "Cyrillic_IE", 0x6e5 }, +{ "Cyrillic_EF", 0x6e6 }, +{ "Cyrillic_GHE", 0x6e7 }, +{ "Cyrillic_HA", 0x6e8 }, +{ "Cyrillic_I", 0x6e9 }, +{ "Cyrillic_SHORTI", 0x6ea }, +{ "Cyrillic_KA", 0x6eb }, +{ "Cyrillic_EL", 0x6ec }, +{ "Cyrillic_EM", 0x6ed }, +{ "Cyrillic_EN", 0x6ee }, +{ "Cyrillic_O", 0x6ef }, +{ "Cyrillic_PE", 0x6f0 }, +{ "Cyrillic_YA", 0x6f1 }, +{ "Cyrillic_ER", 0x6f2 }, +{ "Cyrillic_ES", 0x6f3 }, +{ "Cyrillic_TE", 0x6f4 }, +{ "Cyrillic_U", 0x6f5 }, +{ "Cyrillic_ZHE", 0x6f6 }, +{ "Cyrillic_VE", 0x6f7 }, +{ "Cyrillic_SOFTSIGN", 0x6f8 }, +{ "Cyrillic_YERU", 0x6f9 }, +{ "Cyrillic_ZE", 0x6fa }, +{ "Cyrillic_SHA", 0x6fb }, +{ "Cyrillic_E", 0x6fc }, +{ "Cyrillic_SHCHA", 0x6fd }, +{ "Cyrillic_CHE", 0x6fe }, +{ "Cyrillic_HARDSIGN", 0x6ff }, +{ "Greek_ALPHAaccent", 0x7a1 }, +{ "Greek_EPSILONaccent", 0x7a2 }, +{ "Greek_ETAaccent", 0x7a3 }, +{ "Greek_IOTAaccent", 0x7a4 }, +{ "Greek_IOTAdiaeresis", 0x7a5 }, +{ "Greek_IOTAaccentdiaeresis", 0x7a6 }, +{ "Greek_OMICRONaccent", 0x7a7 }, +{ "Greek_UPSILONaccent", 0x7a8 }, +{ "Greek_UPSILONdieresis", 0x7a9 }, +{ "Greek_UPSILONaccentdieresis", 0x7aa }, +{ "Greek_OMEGAaccent", 0x7ab }, +{ "Greek_alphaaccent", 0x7b1 }, +{ "Greek_epsilonaccent", 0x7b2 }, +{ "Greek_etaaccent", 0x7b3 }, +{ "Greek_iotaaccent", 0x7b4 }, +{ "Greek_iotadieresis", 0x7b5 }, +{ "Greek_iotaaccentdieresis", 0x7b6 }, +{ "Greek_omicronaccent", 0x7b7 }, +{ "Greek_upsilonaccent", 0x7b8 }, +{ "Greek_upsilondieresis", 0x7b9 }, +{ "Greek_upsilonaccentdieresis", 0x7ba }, +{ "Greek_omegaaccent", 0x7bb }, +{ "Greek_ALPHA", 0x7c1 }, +{ "Greek_BETA", 0x7c2 }, +{ "Greek_GAMMA", 0x7c3 }, +{ "Greek_DELTA", 0x7c4 }, +{ "Greek_EPSILON", 0x7c5 }, +{ "Greek_ZETA", 0x7c6 }, +{ "Greek_ETA", 0x7c7 }, +{ "Greek_THETA", 0x7c8 }, +{ "Greek_IOTA", 0x7c9 }, +{ "Greek_KAPPA", 0x7ca }, +{ "Greek_LAMBDA", 0x7cb }, +{ "Greek_MU", 0x7cc }, +{ "Greek_NU", 0x7cd }, +{ "Greek_XI", 0x7ce }, +{ "Greek_OMICRON", 0x7cf }, +{ "Greek_PI", 0x7d0 }, +{ "Greek_RHO", 0x7d1 }, +{ "Greek_SIGMA", 0x7d2 }, +{ "Greek_TAU", 0x7d4 }, +{ "Greek_UPSILON", 0x7d5 }, +{ "Greek_PHI", 0x7d6 }, +{ "Greek_CHI", 0x7d7 }, +{ "Greek_PSI", 0x7d8 }, +{ "Greek_OMEGA", 0x7d9 }, +{ "Greek_alpha", 0x7e1 }, +{ "Greek_beta", 0x7e2 }, +{ "Greek_gamma", 0x7e3 }, +{ "Greek_delta", 0x7e4 }, +{ "Greek_epsilon", 0x7e5 }, +{ "Greek_zeta", 0x7e6 }, +{ "Greek_eta", 0x7e7 }, +{ "Greek_theta", 0x7e8 }, +{ "Greek_iota", 0x7e9 }, +{ "Greek_kappa", 0x7ea }, +{ "Greek_lambda", 0x7eb }, +{ "Greek_mu", 0x7ec }, +{ "Greek_nu", 0x7ed }, +{ "Greek_xi", 0x7ee }, +{ "Greek_omicron", 0x7ef }, +{ "Greek_pi", 0x7f0 }, +{ "Greek_rho", 0x7f1 }, +{ "Greek_sigma", 0x7f2 }, +{ "Greek_finalsmallsigma", 0x7f3 }, +{ "Greek_tau", 0x7f4 }, +{ "Greek_upsilon", 0x7f5 }, +{ "Greek_phi", 0x7f6 }, +{ "Greek_chi", 0x7f7 }, +{ "Greek_psi", 0x7f8 }, +{ "Greek_omega", 0x7f9 }, +{ "Greek_switch", 0xFF7E }, +{ "leftradical", 0x8a1 }, +{ "topleftradical", 0x8a2 }, +{ "horizconnector", 0x8a3 }, +{ "topintegral", 0x8a4 }, +{ "botintegral", 0x8a5 }, +{ "vertconnector", 0x8a6 }, +{ "topleftsqbracket", 0x8a7 }, +{ "botleftsqbracket", 0x8a8 }, +{ "toprightsqbracket", 0x8a9 }, +{ "botrightsqbracket", 0x8aa }, +{ "topleftparens", 0x8ab }, +{ "botleftparens", 0x8ac }, +{ "toprightparens", 0x8ad }, +{ "botrightparens", 0x8ae }, +{ "leftmiddlecurlybrace", 0x8af }, +{ "rightmiddlecurlybrace", 0x8b0 }, +{ "topleftsummation", 0x8b1 }, +{ "botleftsummation", 0x8b2 }, +{ "topvertsummationconnector", 0x8b3 }, +{ "botvertsummationconnector", 0x8b4 }, +{ "toprightsummation", 0x8b5 }, +{ "botrightsummation", 0x8b6 }, +{ "rightmiddlesummation", 0x8b7 }, +{ "lessthanequal", 0x8bc }, +{ "notequal", 0x8bd }, +{ "greaterthanequal", 0x8be }, +{ "integral", 0x8bf }, +{ "therefore", 0x8c0 }, +{ "variation", 0x8c1 }, +{ "infinity", 0x8c2 }, +{ "nabla", 0x8c5 }, +{ "approximate", 0x8c8 }, +{ "similarequal", 0x8c9 }, +{ "ifonlyif", 0x8cd }, +{ "implies", 0x8ce }, +{ "identical", 0x8cf }, +{ "radical", 0x8d6 }, +{ "includedin", 0x8da }, +{ "includes", 0x8db }, +{ "intersection", 0x8dc }, +{ "union", 0x8dd }, +{ "logicaland", 0x8de }, +{ "logicalor", 0x8df }, +{ "partialderivative", 0x8ef }, +{ "function", 0x8f6 }, +{ "leftarrow", 0x8fb }, +{ "uparrow", 0x8fc }, +{ "rightarrow", 0x8fd }, +{ "downarrow", 0x8fe }, +{ "blank", 0x9df }, +{ "soliddiamond", 0x9e0 }, +{ "checkerboard", 0x9e1 }, +{ "ht", 0x9e2 }, +{ "ff", 0x9e3 }, +{ "cr", 0x9e4 }, +{ "lf", 0x9e5 }, +{ "nl", 0x9e8 }, +{ "vt", 0x9e9 }, +{ "lowrightcorner", 0x9ea }, +{ "uprightcorner", 0x9eb }, +{ "upleftcorner", 0x9ec }, +{ "lowleftcorner", 0x9ed }, +{ "crossinglines", 0x9ee }, +{ "horizlinescan1", 0x9ef }, +{ "horizlinescan3", 0x9f0 }, +{ "horizlinescan5", 0x9f1 }, +{ "horizlinescan7", 0x9f2 }, +{ "horizlinescan9", 0x9f3 }, +{ "leftt", 0x9f4 }, +{ "rightt", 0x9f5 }, +{ "bott", 0x9f6 }, +{ "topt", 0x9f7 }, +{ "vertbar", 0x9f8 }, +{ "emspace", 0xaa1 }, +{ "enspace", 0xaa2 }, +{ "em3space", 0xaa3 }, +{ "em4space", 0xaa4 }, +{ "digitspace", 0xaa5 }, +{ "punctspace", 0xaa6 }, +{ "thinspace", 0xaa7 }, +{ "hairspace", 0xaa8 }, +{ "emdash", 0xaa9 }, +{ "endash", 0xaaa }, +{ "signifblank", 0xaac }, +{ "ellipsis", 0xaae }, +{ "doubbaselinedot", 0xaaf }, +{ "onethird", 0xab0 }, +{ "twothirds", 0xab1 }, +{ "onefifth", 0xab2 }, +{ "twofifths", 0xab3 }, +{ "threefifths", 0xab4 }, +{ "fourfifths", 0xab5 }, +{ "onesixth", 0xab6 }, +{ "fivesixths", 0xab7 }, +{ "careof", 0xab8 }, +{ "figdash", 0xabb }, +{ "leftanglebracket", 0xabc }, +{ "decimalpoint", 0xabd }, +{ "rightanglebracket", 0xabe }, +{ "marker", 0xabf }, +{ "oneeighth", 0xac3 }, +{ "threeeighths", 0xac4 }, +{ "fiveeighths", 0xac5 }, +{ "seveneighths", 0xac6 }, +{ "trademark", 0xac9 }, +{ "signaturemark", 0xaca }, +{ "trademarkincircle", 0xacb }, +{ "leftopentriangle", 0xacc }, +{ "rightopentriangle", 0xacd }, +{ "emopencircle", 0xace }, +{ "emopenrectangle", 0xacf }, +{ "leftsinglequotemark", 0xad0 }, +{ "rightsinglequotemark", 0xad1 }, +{ "leftdoublequotemark", 0xad2 }, +{ "rightdoublequotemark", 0xad3 }, +{ "prescription", 0xad4 }, +{ "minutes", 0xad6 }, +{ "seconds", 0xad7 }, +{ "latincross", 0xad9 }, +{ "hexagram", 0xada }, +{ "filledrectbullet", 0xadb }, +{ "filledlefttribullet", 0xadc }, +{ "filledrighttribullet", 0xadd }, +{ "emfilledcircle", 0xade }, +{ "emfilledrect", 0xadf }, +{ "enopencircbullet", 0xae0 }, +{ "enopensquarebullet", 0xae1 }, +{ "openrectbullet", 0xae2 }, +{ "opentribulletup", 0xae3 }, +{ "opentribulletdown", 0xae4 }, +{ "openstar", 0xae5 }, +{ "enfilledcircbullet", 0xae6 }, +{ "enfilledsqbullet", 0xae7 }, +{ "filledtribulletup", 0xae8 }, +{ "filledtribulletdown", 0xae9 }, +{ "leftpointer", 0xaea }, +{ "rightpointer", 0xaeb }, +{ "club", 0xaec }, +{ "diamond", 0xaed }, +{ "heart", 0xaee }, +{ "maltesecross", 0xaf0 }, +{ "dagger", 0xaf1 }, +{ "doubledagger", 0xaf2 }, +{ "checkmark", 0xaf3 }, +{ "ballotcross", 0xaf4 }, +{ "musicalsharp", 0xaf5 }, +{ "musicalflat", 0xaf6 }, +{ "malesymbol", 0xaf7 }, +{ "femalesymbol", 0xaf8 }, +{ "telephone", 0xaf9 }, +{ "telephonerecorder", 0xafa }, +{ "phonographcopyright", 0xafb }, +{ "caret", 0xafc }, +{ "singlelowquotemark", 0xafd }, +{ "doublelowquotemark", 0xafe }, +{ "cursor", 0xaff }, +{ "leftcaret", 0xba3 }, +{ "rightcaret", 0xba6 }, +{ "downcaret", 0xba8 }, +{ "upcaret", 0xba9 }, +{ "overbar", 0xbc0 }, +{ "downtack", 0xbc2 }, +{ "upshoe", 0xbc3 }, +{ "downstile", 0xbc4 }, +{ "underbar", 0xbc6 }, +{ "jot", 0xbca }, +{ "quad", 0xbcc }, +{ "uptack", 0xbce }, +{ "circle", 0xbcf }, +{ "upstile", 0xbd3 }, +{ "downshoe", 0xbd6 }, +{ "rightshoe", 0xbd8 }, +{ "leftshoe", 0xbda }, +{ "lefttack", 0xbdc }, +{ "righttack", 0xbfc }, +{ "hebrew_aleph", 0xce0 }, +{ "hebrew_beth", 0xce1 }, +{ "hebrew_gimmel", 0xce2 }, +{ "hebrew_daleth", 0xce3 }, +{ "hebrew_he", 0xce4 }, +{ "hebrew_waw", 0xce5 }, +{ "hebrew_zayin", 0xce6 }, +{ "hebrew_het", 0xce7 }, +{ "hebrew_teth", 0xce8 }, +{ "hebrew_yod", 0xce9 }, +{ "hebrew_finalkaph", 0xcea }, +{ "hebrew_kaph", 0xceb }, +{ "hebrew_lamed", 0xcec }, +{ "hebrew_finalmem", 0xced }, +{ "hebrew_mem", 0xcee }, +{ "hebrew_finalnun", 0xcef }, +{ "hebrew_nun", 0xcf0 }, +{ "hebrew_samekh", 0xcf1 }, +{ "hebrew_ayin", 0xcf2 }, +{ "hebrew_finalpe", 0xcf3 }, +{ "hebrew_pe", 0xcf4 }, +{ "hebrew_finalzadi", 0xcf5 }, +{ "hebrew_zadi", 0xcf6 }, +{ "hebrew_kuf", 0xcf7 }, +{ "hebrew_resh", 0xcf8 }, +{ "hebrew_shin", 0xcf9 }, +{ "hebrew_taf", 0xcfa }, +{ "Hebrew_switch", 0xFF7E }, diff --git a/generic/tk.h b/generic/tk.h new file mode 100644 index 0000000..3e470f0 --- /dev/null +++ b/generic/tk.h @@ -0,0 +1,1538 @@ +/* + * tk.h -- + * + * Declarations for Tk-related things that are visible + * outside of the Tk module itself. + * + * 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. + * + * 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 + */ + +#ifndef _TK +#define _TK + +/* + * When version numbers change here, you must also go into the following files + * and update the version numbers: + * + * unix/configure.in + * win/makefile.bc + * win/makefile.vc + * library/tk.tcl + * + * 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 + * "a", "b", or "p" in the patch level; for example, if the patch level + * is 4.3b2, TK_RELEASE_SERIAL is 2. It restarts at 1 whenever the + * release level is changed, except for the final release, which should + * be 0. + * + * You may also need to update some of these files when the numbers change + * for the version of Tcl that this release of Tk is compiled against. + */ + +#define TK_MAJOR_VERSION 8 +#define TK_MINOR_VERSION 0 +#define TK_RELEASE_LEVEL 2 +#define TK_RELEASE_SERIAL 2 + +#define TK_VERSION "8.0" +#define TK_PATCH_LEVEL "8.0p2" + +/* + * A special definition used to allow this header file to be included + * in resource files. + */ + +#ifndef RESOURCE_INCLUDED + +/* + * The following definitions set up the proper options for Macintosh + * compilers. We use this method because there is no autoconf equivalent. + */ + +#ifdef MAC_TCL +# ifndef REDO_KEYSYM_LOOKUP +# define REDO_KEYSYM_LOOKUP +# endif +#endif + +#ifndef _TCL +# include +#endif +#ifndef _XLIB_H +# ifdef MAC_TCL +# include +# include +# else +# include +# endif +#endif +#ifdef __STDC__ +# include +#endif + +/* + * Decide whether or not to use input methods. + */ + +#ifdef XNQueryInputStyle +#define TK_USE_INPUT_METHODS +#endif + +/* + * Dummy types that are used by clients: + */ + +typedef struct Tk_BindingTable_ *Tk_BindingTable; +typedef struct Tk_Canvas_ *Tk_Canvas; +typedef struct Tk_Cursor_ *Tk_Cursor; +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_TextLayout_ *Tk_TextLayout; +typedef struct Tk_Window_ *Tk_Window; +typedef struct Tk_3DBorder_ *Tk_3DBorder; + +/* + * Additional types exported to clients. + */ + +typedef char *Tk_Uid; + +/* + * 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 + +/* + * 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. + */ + +typedef int (Tk_OptionParseProc) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, Tk_Window tkwin, char *value, char *widgRec, + int offset)); +typedef char *(Tk_OptionPrintProc) _ANSI_ARGS_((ClientData clientData, + Tk_Window tkwin, char *widgRec, int offset, + Tcl_FreeProc **freeProcPtr)); + +typedef struct Tk_CustomOption { + Tk_OptionParseProc *parseProc; /* Procedure to call to parse an + * option and store it in converted + * form. */ + Tk_OptionPrintProc *printProc; /* Procedure to return a printable + * string describing an existing + * option. */ + ClientData clientData; /* Arbitrary one-word value used by + * option parser: passed to + * parseProc and printProc. */ +} Tk_CustomOption; + +/* + * Structure used to specify information for Tk_ConfigureWidget. Each + * structure gives complete information for one option, including + * how the option is specified on the command line, where it appears + * in the option database, etc. + */ + +typedef struct Tk_ConfigSpec { + int type; /* Type of option, such as TK_CONFIG_COLOR; + * see definitions below. Last option in + * table must have type TK_CONFIG_END. */ + char *argvName; /* Switch used to specify option in argv. + * NULL means this spec is part of a group. */ + 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 or database. */ + int offset; /* Where in widget record to store value; + * use Tk_Offset macro to generate values + * for this. */ + int specFlags; /* Any combination of the values defined + * below; other bits are used internally + * by tkConfig.c. */ + Tk_CustomOption *customPtr; /* If type is TK_CONFIG_CUSTOM then this is + * a pointer to info about how to parse and + * print the option. Otherwise it is + * irrelevant. */ +} Tk_ConfigSpec; + +/* + * Type values for Tk_ConfigSpec structures. See the user + * 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 + +/* + * Possible values for flags argument to Tk_ConfigureWidget: + */ + +#define TK_CONFIG_ARGV_ONLY 1 + +/* + * Possible flag values for Tk_ConfigInfo 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). + */ + +#define TK_CONFIG_COLOR_ONLY 1 +#define TK_CONFIG_MONO_ONLY 2 +#define TK_CONFIG_NULL_OK 4 +#define TK_CONFIG_DONT_SET_DEFAULT 8 +#define TK_CONFIG_OPTION_SPECIFIED 0x10 +#define TK_CONFIG_USER_BIT 0x100 + +/* + * Enumerated type for describing actions to be taken in response + * to a restrictProc established by Tk_RestrictEvents. + */ + +typedef enum { + TK_DEFER_EVENT, TK_PROCESS_EVENT, TK_DISCARD_EVENT +} Tk_RestrictAction; + +/* + * Priority levels to pass to Tk_AddOption: + */ + +#define TK_WIDGET_DEFAULT_PRIO 20 +#define TK_STARTUP_FILE_PRIO 40 +#define TK_USER_DEFAULT_PRIO 60 +#define TK_INTERACTIVE_PRIO 80 +#define TK_MAX_PRIO 100 + +/* + * 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 + +/* + * "Which" argument values for Tk_3DBorderGC: + */ + +#define TK_3D_FLAT_GC 1 +#define TK_3D_LIGHT_GC 2 +#define TK_3D_DARK_GC 3 + +/* + * Special EnterNotify/LeaveNotify "mode" for use in events + * generated by tkShare.c. Pick a high enough value that it's + * unlikely to conflict with existing values (like NotifyNormal) + * or any new values defined in the future. + */ + +#define TK_NOTIFY_SHARE 20 + +/* + * Enumerated type for describing a point by which to anchor something: + */ + +typedef enum { + TK_ANCHOR_N, TK_ANCHOR_NE, TK_ANCHOR_E, TK_ANCHOR_SE, + TK_ANCHOR_S, TK_ANCHOR_SW, TK_ANCHOR_W, TK_ANCHOR_NW, + TK_ANCHOR_CENTER +} Tk_Anchor; + +/* + * Enumerated type for describing a style of justification: + */ + +typedef enum { + TK_JUSTIFY_LEFT, TK_JUSTIFY_RIGHT, TK_JUSTIFY_CENTER +} Tk_Justify; + +/* + * The following structure is used by Tk_GetFontMetrics() to return + * information about the properties of a Tk_Font. + */ + +typedef struct Tk_FontMetrics { + int ascent; /* The amount in pixels that the tallest + * letter sticks up above the baseline, plus + * any extra blank space added by the designer + * of the font. */ + int descent; /* The largest amount in pixels that any + * letter sticks below the baseline, plus any + * extra blank space added by the designer of + * the font. */ + int linespace; /* The sum of the ascent and descent. How + * far apart two lines of text in the same + * font should be placed so that none of the + * characters in one line overlap any of the + * characters in the other line. */ +} Tk_FontMetrics; + +/* + * Flags passed to Tk_MeasureChars: + */ + +#define TK_WHOLE_WORDS 1 +#define TK_AT_LEAST_ONE 2 +#define TK_PARTIAL_OK 4 + +/* + * Flags passed to Tk_ComputeTextLayout: + */ + +#define TK_IGNORE_TABS 8 +#define TK_IGNORE_NEWLINES 16 + +/* + * Each geometry manager (the packer, the placer, etc.) is represented + * by a structure of the following form, which indicates procedures + * to invoke in the geometry manager to carry out certain functions. + */ + +typedef void (Tk_GeomRequestProc) _ANSI_ARGS_((ClientData clientData, + Tk_Window tkwin)); +typedef void (Tk_GeomLostSlaveProc) _ANSI_ARGS_((ClientData clientData, + Tk_Window tkwin)); + +typedef struct Tk_GeomMgr { + char *name; /* Name of the geometry manager (command + * used to invoke it, or name of widget + * class that allows embedded widgets). */ + Tk_GeomRequestProc *requestProc; + /* Procedure to invoke when a slave's + * requested geometry changes. */ + Tk_GeomLostSlaveProc *lostSlaveProc; + /* Procedure to invoke when a slave is + * taken away from one geometry manager + * by another. NULL means geometry manager + * doesn't care when slaves are lost. */ +} Tk_GeomMgr; + +/* + * Result values returned by Tk_GetScrollInfo: + */ + +#define TK_SCROLL_MOVETO 1 +#define TK_SCROLL_PAGES 2 +#define TK_SCROLL_UNITS 3 +#define TK_SCROLL_ERROR 4 + +/* + *--------------------------------------------------------------------------- + * + * Extensions to the X event set + * + *--------------------------------------------------------------------------- + */ +#define VirtualEvent (LASTEvent) +#define ActivateNotify (LASTEvent + 1) +#define DeactivateNotify (LASTEvent + 2) +#define TK_LASTEVENT (LASTEvent + 3) + +#define VirtualEventMask (1L << 30) +#define ActivateMask (1L << 29) +#define TK_LASTEVENT (LASTEvent + 3) + + +/* + * A virtual event shares most of its fields with the XKeyEvent and + * XButtonEvent structures. 99% of the time a virtual event will be + * an abstraction of a key or button event, so this structure provides + * the most information to the user. The only difference is the changing + * of the detail field for a virtual event so that it holds the name of the + * virtual event being triggered. + */ + +typedef struct { + int type; + unsigned long serial; /* # of last request processed by server */ + Bool send_event; /* True if this came from a SendEvent request */ + Display *display; /* Display the event was read from */ + Window event; /* Window on which event was requested. */ + Window root; /* root window that the event occured on */ + Window subwindow; /* child window */ + Time time; /* milliseconds */ + int x, y; /* pointer x, y coordinates in event window */ + int x_root, y_root; /* coordinates relative to root */ + unsigned int state; /* key or button mask */ + Tk_Uid name; /* Name of virtual event. */ + Bool same_screen; /* same screen flag */ +} XVirtualEvent; + +typedef struct { + int type; + unsigned long serial; /* # of last request processed by server */ + Bool send_event; /* True if this came from a SendEvent request */ + Display *display; /* Display the event was read from */ + Window window; /* Window in which event occurred. */ +} XActivateDeactivateEvent; +typedef XActivateDeactivateEvent XActivateEvent; +typedef XActivateDeactivateEvent XDeactivateEvent; + +/* + *-------------------------------------------------------------- + * + * Macros for querying Tk_Window structures. See the + * manual entries for documentation. + * + *-------------------------------------------------------------- + */ + +#define Tk_Display(tkwin) (((Tk_FakeWin *) (tkwin))->display) +#define Tk_ScreenNumber(tkwin) (((Tk_FakeWin *) (tkwin))->screenNum) +#define Tk_Screen(tkwin) (ScreenOfDisplay(Tk_Display(tkwin), \ + Tk_ScreenNumber(tkwin))) +#define Tk_Depth(tkwin) (((Tk_FakeWin *) (tkwin))->depth) +#define Tk_Visual(tkwin) (((Tk_FakeWin *) (tkwin))->visual) +#define Tk_WindowId(tkwin) (((Tk_FakeWin *) (tkwin))->window) +#define Tk_PathName(tkwin) (((Tk_FakeWin *) (tkwin))->pathName) +#define Tk_Name(tkwin) (((Tk_FakeWin *) (tkwin))->nameUid) +#define Tk_Class(tkwin) (((Tk_FakeWin *) (tkwin))->classUid) +#define Tk_X(tkwin) (((Tk_FakeWin *) (tkwin))->changes.x) +#define Tk_Y(tkwin) (((Tk_FakeWin *) (tkwin))->changes.y) +#define Tk_Width(tkwin) (((Tk_FakeWin *) (tkwin))->changes.width) +#define Tk_Height(tkwin) \ + (((Tk_FakeWin *) (tkwin))->changes.height) +#define Tk_Changes(tkwin) (&((Tk_FakeWin *) (tkwin))->changes) +#define Tk_Attributes(tkwin) (&((Tk_FakeWin *) (tkwin))->atts) +#define Tk_IsEmbedded(tkwin) \ + (((Tk_FakeWin *) (tkwin))->flags & TK_EMBEDDED) +#define Tk_IsContainer(tkwin) \ + (((Tk_FakeWin *) (tkwin))->flags & TK_CONTAINER) +#define Tk_IsMapped(tkwin) \ + (((Tk_FakeWin *) (tkwin))->flags & TK_MAPPED) +#define Tk_IsTopLevel(tkwin) \ + (((Tk_FakeWin *) (tkwin))->flags & TK_TOP_LEVEL) +#define Tk_ReqWidth(tkwin) (((Tk_FakeWin *) (tkwin))->reqWidth) +#define Tk_ReqHeight(tkwin) (((Tk_FakeWin *) (tkwin))->reqHeight) +#define Tk_InternalBorderWidth(tkwin) \ + (((Tk_FakeWin *) (tkwin))->internalBorderWidth) +#define Tk_Parent(tkwin) (((Tk_FakeWin *) (tkwin))->parentPtr) +#define Tk_Colormap(tkwin) (((Tk_FakeWin *) (tkwin))->atts.colormap) + +/* + * The structure below is needed by the macros above so that they can + * access the fields of a Tk_Window. The fields not needed by the macros + * are declared as "dummyX". The structure has its own type in order to + * prevent applications from accessing Tk_Window fields except using + * official macros. WARNING!! The structure definition must be kept + * consistent with the TkWindow structure in tkInt.h. If you change one, + * then change the other. See the declaration in tkInt.h for + * documentation on what the fields are used for internally. + */ + +typedef struct Tk_FakeWin { + Display *display; + char *dummy1; + int screenNum; + Visual *visual; + int depth; + Window window; + char *dummy2; + char *dummy3; + Tk_Window parentPtr; + char *dummy4; + char *dummy5; + char *pathName; + Tk_Uid nameUid; + Tk_Uid classUid; + XWindowChanges changes; + unsigned int dummy6; + XSetWindowAttributes atts; + unsigned long dummy7; + unsigned int flags; + char *dummy8; +#ifdef TK_USE_INPUT_METHODS + XIC dummy9; +#endif /* TK_USE_INPUT_METHODS */ + ClientData *dummy10; + int dummy11; + int dummy12; + char *dummy13; + char *dummy14; + ClientData dummy15; + int reqWidth, reqHeight; + int internalBorderWidth; + char *dummy16; + char *dummy17; + ClientData dummy18; + char *dummy19; +} Tk_FakeWin; + +/* + * Flag values for TkWindow (and Tk_FakeWin) structures are: + * + * TK_MAPPED: 1 means window is currently mapped, + * 0 means unmapped. + * TK_TOP_LEVEL: 1 means this is a top-level window (it + * was or will be created as a child of + * a root window). + * TK_ALREADY_DEAD: 1 means the window is in the process of + * being destroyed already. + * TK_NEED_CONFIG_NOTIFY: 1 means that the window has been reconfigured + * before it was made to exist. At the time of + * making it exist a ConfigureNotify event needs + * to be generated. + * TK_GRAB_FLAG: Used to manage grabs. See tkGrab.c for + * details. + * TK_CHECKED_IC: 1 means we've already tried to get an input + * context for this window; if the ic field + * is NULL it means that there isn't a context + * for the field. + * TK_DONT_DESTROY_WINDOW: 1 means that Tk_DestroyWindow should not + * invoke XDestroyWindow to destroy this widget's + * X window. The flag is set when the window + * has already been destroyed elsewhere (e.g. + * by another application) or when it will be + * destroyed later (e.g. by destroying its + * parent). + * TK_WM_COLORMAP_WINDOW: 1 means that this window has at some time + * appeared in the WM_COLORMAP_WINDOWS property + * for its toplevel, so we have to remove it + * from that property if the window is + * deleted and the toplevel isn't. + * TK_EMBEDDED: 1 means that this window (which must be a + * toplevel) is not a free-standing window but + * rather is embedded in some other application. + * TK_CONTAINER: 1 means that this window is a container, and + * that some other application (either in + * this process or elsewhere) may be + * embedding itself inside the window. + * TK_BOTH_HALVES: 1 means that this window is used for + * application embedding (either as + * container or embedded application), and + * both the containing and embedded halves + * are associated with windows in this + * particular process. + * TK_DEFER_MODAL: 1 means that this window has deferred a modal + * loop until all of the bindings for the current + * event have been invoked. + * TK_WRAPPER: 1 means that this window is the extra + * wrapper window created around a toplevel + * to hold the menubar under Unix. See + * tkUnixWm.c for more information. + * TK_REPARENTED: 1 means that this window has been reparented + * so that as far as the window system is + * concerned it isn't a child of its Tk + * parent. Initially this is used only for + * special Unix menubar windows. + */ + + +#define TK_MAPPED 1 +#define TK_TOP_LEVEL 2 +#define TK_ALREADY_DEAD 4 +#define TK_NEED_CONFIG_NOTIFY 8 +#define TK_GRAB_FLAG 0x10 +#define TK_CHECKED_IC 0x20 +#define TK_DONT_DESTROY_WINDOW 0x40 +#define TK_WM_COLORMAP_WINDOW 0x80 +#define TK_EMBEDDED 0x100 +#define TK_CONTAINER 0x200 +#define TK_BOTH_HALVES 0x400 +#define TK_DEFER_MODAL 0x800 +#define TK_WRAPPER 0x1000 +#define TK_REPARENTED 0x2000 + +/* + *-------------------------------------------------------------- + * + * Procedure prototypes and structures used for defining new canvas + * items: + * + *-------------------------------------------------------------- + */ + +/* + * For each item in a canvas widget there exists one record with + * the following structure. Each actual item is represented by + * a record with the following stuff at its beginning, plus additional + * type-specific stuff after that. + */ + +#define TK_TAG_SPACE 3 + +typedef struct Tk_Item { + int id; /* Unique identifier for this item + * (also serves as first tag for + * item). */ + struct Tk_Item *nextPtr; /* Next in display list of all + * items in this canvas. Later items + * in list are drawn on top of earlier + * ones. */ + Tk_Uid staticTagSpace[TK_TAG_SPACE];/* Built-in space for limited # of + * tags. */ + Tk_Uid *tagPtr; /* Pointer to array of tags. Usually + * points to staticTagSpace, but + * may point to malloc-ed space if + * there are lots of tags. */ + int tagSpace; /* Total amount of tag space available + * at tagPtr. */ + int numTags; /* Number of tag slots actually used + * at *tagPtr. */ + struct Tk_ItemType *typePtr; /* Table of procedures that implement + * this type of item. */ + int x1, y1, x2, y2; /* Bounding box for item, in integer + * canvas units. Set by item-specific + * code and guaranteed to contain every + * pixel drawn in item. Item area + * includes x1 and y1 but not x2 + * and y2. */ + + /* + *------------------------------------------------------------------ + * Starting here is additional type-specific stuff; see the + * declarations for individual types to see what is part of + * each type. The actual space below is determined by the + * "itemInfoSize" of the type's Tk_ItemType record. + *------------------------------------------------------------------ + */ +} Tk_Item; + +/* + * Records of the following type are used to describe a type of + * item (e.g. lines, circles, etc.) that can form part of a + * canvas widget. + */ + +typedef int Tk_ItemCreateProc _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int argc, + char **argv)); +typedef int Tk_ItemConfigureProc _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int argc, + char **argv, int flags)); +typedef int Tk_ItemCoordProc _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int argc, + char **argv)); +typedef void Tk_ItemDeleteProc _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, Display *display)); +typedef void Tk_ItemDisplayProc _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, Display *display, Drawable dst, + int x, int y, int width, int height)); +typedef double Tk_ItemPointProc _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double *pointPtr)); +typedef int Tk_ItemAreaProc _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double *rectPtr)); +typedef int Tk_ItemPostscriptProc _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int prepass)); +typedef void Tk_ItemScaleProc _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double originX, double originY, + double scaleX, double scaleY)); +typedef void Tk_ItemTranslateProc _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double deltaX, double deltaY)); +typedef int Tk_ItemIndexProc _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, char *indexString, + int *indexPtr)); +typedef void Tk_ItemCursorProc _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, int index)); +typedef int Tk_ItemSelectionProc _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, int offset, char *buffer, + int maxBytes)); +typedef void Tk_ItemInsertProc _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, int beforeThis, char *string)); +typedef void Tk_ItemDCharsProc _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, int first, int last)); + +typedef struct Tk_ItemType { + char *name; /* The name of this type of item, such + * as "line". */ + int itemSize; /* Total amount of space needed for + * item's record. */ + Tk_ItemCreateProc *createProc; /* Procedure to create a new item of + * this type. */ + Tk_ConfigSpec *configSpecs; /* Pointer to array of configuration + * specs for this type. Used for + * returning configuration info. */ + Tk_ItemConfigureProc *configProc; /* Procedure to call to change + * configuration options. */ + Tk_ItemCoordProc *coordProc; /* Procedure to call to get and set + * the item's coordinates. */ + Tk_ItemDeleteProc *deleteProc; /* Procedure to delete existing item of + * this type. */ + Tk_ItemDisplayProc *displayProc; /* Procedure to display items of + * this type. */ + int alwaysRedraw; /* Non-zero means displayProc should + * be called even when the item has + * been moved off-screen. */ + Tk_ItemPointProc *pointProc; /* Computes distance from item to + * a given point. */ + Tk_ItemAreaProc *areaProc; /* Computes whether item is inside, + * outside, or overlapping an area. */ + Tk_ItemPostscriptProc *postscriptProc; + /* Procedure to write a Postscript + * description for items of this + * type. */ + Tk_ItemScaleProc *scaleProc; /* Procedure to rescale items of + * this type. */ + Tk_ItemTranslateProc *translateProc;/* Procedure to translate items of + * this type. */ + Tk_ItemIndexProc *indexProc; /* Procedure to determine index of + * indicated character. NULL if + * item doesn't support indexing. */ + Tk_ItemCursorProc *icursorProc; /* Procedure to set insert cursor pos. + * to just before a given position. */ + Tk_ItemSelectionProc *selectionProc;/* Procedure to return selection (in + * STRING format) when it is in this + * item. */ + Tk_ItemInsertProc *insertProc; /* Procedure to insert something into + * an item. */ + Tk_ItemDCharsProc *dCharsProc; /* Procedure to delete characters + * from an item. */ + struct Tk_ItemType *nextPtr; /* Used to link types together into + * a list. */ +} Tk_ItemType; + +/* + * The following structure provides information about the selection and + * the insertion cursor. It is needed by only a few items, such as + * those that display text. It is shared by the generic canvas code + * and the item-specific code, but most of the fields should be written + * only by the canvas generic code. + */ + +typedef struct Tk_CanvasTextInfo { + Tk_3DBorder selBorder; /* Border and background for selected + * characters. Read-only to items.*/ + int selBorderWidth; /* Width of border around selection. + * Read-only to items. */ + XColor *selFgColorPtr; /* Foreground color for selected text. + * Read-only to items. */ + 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. */ + 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. */ + Tk_3DBorder insertBorder; /* Used to draw vertical bar for insertion + * cursor. Read-only to items. */ + int insertWidth; /* Total width of insertion cursor. Read-only + * to items. */ + int insertBorderWidth; /* Width of 3-D border around insert cursor. + * Read-only to items. */ + Tk_Item *focusItemPtr; /* Item that currently has the input focus, + * or NULL if no such item. Read-only to + * items. */ + int gotFocus; /* Non-zero means that the canvas widget has + * the input focus. Read-only to items.*/ + int cursorOn; /* Non-zero means that an insertion cursor + * should be displayed in focusItemPtr. + * Read-only to items.*/ +} Tk_CanvasTextInfo; + +/* + *-------------------------------------------------------------- + * + * Procedure prototypes and structures used for managing images: + * + *-------------------------------------------------------------- + */ + +typedef struct Tk_ImageType Tk_ImageType; +typedef int (Tk_ImageCreateProc) _ANSI_ARGS_((Tcl_Interp *interp, + char *name, int argc, char **argv, Tk_ImageType *typePtr, + Tk_ImageMaster master, ClientData *masterDataPtr)); +typedef ClientData (Tk_ImageGetProc) _ANSI_ARGS_((Tk_Window tkwin, + ClientData masterData)); +typedef void (Tk_ImageDisplayProc) _ANSI_ARGS_((ClientData instanceData, + Display *display, Drawable drawable, int imageX, int imageY, + int width, int height, int drawableX, int drawableY)); +typedef void (Tk_ImageFreeProc) _ANSI_ARGS_((ClientData instanceData, + Display *display)); +typedef void (Tk_ImageDeleteProc) _ANSI_ARGS_((ClientData masterData)); +typedef void (Tk_ImageChangedProc) _ANSI_ARGS_((ClientData clientData, + int x, int y, int width, int height, int imageWidth, + int imageHeight)); + +/* + * The following structure represents a particular type of image + * (bitmap, xpm image, etc.). It provides information common to + * all images of that type, such as the type name and a collection + * of procedures in the image manager that respond to various + * events. Each image manager is represented by one of these + * structures. + */ + +struct Tk_ImageType { + char *name; /* Name of image type. */ + Tk_ImageCreateProc *createProc; + /* Procedure to call to create a new image + * of this type. */ + Tk_ImageGetProc *getProc; /* Procedure to call the first time + * Tk_GetImage is called in a new way + * (new visual or screen). */ + Tk_ImageDisplayProc *displayProc; + /* Call to draw image, in response to + * Tk_RedrawImage calls. */ + Tk_ImageFreeProc *freeProc; /* Procedure to call whenever Tk_FreeImage + * is called to release an instance of an + * image. */ + Tk_ImageDeleteProc *deleteProc; + /* Procedure to call to delete image. It + * will not be called until after freeProc + * has been called for each instance of the + * image. */ + struct Tk_ImageType *nextPtr; + /* Next in list of all image types currently + * known. Filled in by Tk, not by image + * manager. */ +}; + +/* + *-------------------------------------------------------------- + * + * Additional definitions used to manage images of type "photo". + * + *-------------------------------------------------------------- + */ + +/* + * The following type is used to identify a particular photo image + * to be manipulated: + */ + +typedef void *Tk_PhotoHandle; + +/* + * The following structure describes a block of pixels in memory: + */ + +typedef struct Tk_PhotoImageBlock { + unsigned char *pixelPtr; /* Pointer to the first pixel. */ + int width; /* Width of block, in pixels. */ + int height; /* Height of block, in pixels. */ + int pitch; /* Address difference between corresponding + * pixels in successive lines. */ + int pixelSize; /* Address difference between successive + * pixels in the same line. */ + int offset[3]; /* Address differences between the red, green + * and blue components of the pixel and the + * pixel as a whole. */ +} Tk_PhotoImageBlock; + +/* + * Procedure prototypes and structures used in reading and + * writing photo images: + */ + +typedef struct Tk_PhotoImageFormat Tk_PhotoImageFormat; +typedef int (Tk_ImageFileMatchProc) _ANSI_ARGS_((Tcl_Channel chan, + char *fileName, char *formatString, int *widthPtr, int *heightPtr)); +typedef int (Tk_ImageStringMatchProc) _ANSI_ARGS_((char *string, + char *formatString, int *widthPtr, int *heightPtr)); +typedef int (Tk_ImageFileReadProc) _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Channel chan, char *fileName, char *formatString, + Tk_PhotoHandle imageHandle, int destX, int destY, + int width, int height, int srcX, int srcY)); +typedef int (Tk_ImageStringReadProc) _ANSI_ARGS_((Tcl_Interp *interp, + char *string, char *formatString, Tk_PhotoHandle imageHandle, + int destX, int destY, int width, int height, int srcX, int srcY)); +typedef int (Tk_ImageFileWriteProc) _ANSI_ARGS_((Tcl_Interp *interp, + char *fileName, char *formatString, Tk_PhotoImageBlock *blockPtr)); +typedef int (Tk_ImageStringWriteProc) _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_DString *dataPtr, char *formatString, + Tk_PhotoImageBlock *blockPtr)); + +/* + * The following structure represents a particular file format for + * storing images (e.g., PPM, GIF, JPEG, etc.). It provides information + * to allow image files of that format to be recognized and read into + * a photo image. + */ + +struct Tk_PhotoImageFormat { + char *name; /* Name of image file format */ + Tk_ImageFileMatchProc *fileMatchProc; + /* Procedure to call to determine whether + * an image file matches this format. */ + Tk_ImageStringMatchProc *stringMatchProc; + /* Procedure to call to determine whether + * the data in a string matches this format. */ + Tk_ImageFileReadProc *fileReadProc; + /* Procedure to call to read data from + * an image file into a photo image. */ + Tk_ImageStringReadProc *stringReadProc; + /* Procedure to call to read data from + * a string into a photo image. */ + Tk_ImageFileWriteProc *fileWriteProc; + /* Procedure to call to write data from + * a photo image to a file. */ + Tk_ImageStringWriteProc *stringWriteProc; + /* Procedure to call to obtain a string + * representation of the data in a photo + * image.*/ + struct Tk_PhotoImageFormat *nextPtr; + /* Next in list of all photo image formats + * currently known. Filled in by Tk, not + * by image format handler. */ +}; + +/* + *-------------------------------------------------------------- + * + * The definitions below provide backward compatibility for + * functions and types related to event handling that used to + * be in Tk but have moved to Tcl. + * + *-------------------------------------------------------------- + */ + +#define TK_READABLE TCL_READABLE +#define TK_WRITABLE TCL_WRITABLE +#define TK_EXCEPTION TCL_EXCEPTION + +#define TK_DONT_WAIT TCL_DONT_WAIT +#define TK_X_EVENTS TCL_WINDOW_EVENTS +#define TK_WINDOW_EVENTS TCL_WINDOW_EVENTS +#define TK_FILE_EVENTS TCL_FILE_EVENTS +#define TK_TIMER_EVENTS TCL_TIMER_EVENTS +#define TK_IDLE_EVENTS TCL_IDLE_EVENTS +#define TK_ALL_EVENTS TCL_ALL_EVENTS + +#define Tk_IdleProc Tcl_IdleProc +#define Tk_FileProc Tcl_FileProc +#define Tk_TimerProc Tcl_TimerProc +#define Tk_TimerToken Tcl_TimerToken + +#define Tk_BackgroundError Tcl_BackgroundError +#define Tk_CancelIdleCall Tcl_CancelIdleCall +#define Tk_CreateFileHandler Tcl_CreateFileHandler +#define Tk_CreateTimerHandler Tcl_CreateTimerHandler +#define Tk_DeleteFileHandler Tcl_DeleteFileHandler +#define Tk_DeleteTimerHandler Tcl_DeleteTimerHandler +#define Tk_DoOneEvent Tcl_DoOneEvent +#define Tk_DoWhenIdle Tcl_DoWhenIdle +#define Tk_Sleep Tcl_Sleep + +/* Additional stuff that has moved to Tcl: */ + +#define Tk_AfterCmd Tcl_AfterCmd +#define Tk_EventuallyFree Tcl_EventuallyFree +#define Tk_FreeProc Tcl_FreeProc +#define Tk_Preserve Tcl_Preserve +#define Tk_Release Tcl_Release + +/* + *-------------------------------------------------------------- + * + * Additional procedure types defined by Tk. + * + *-------------------------------------------------------------- + */ + +typedef int (Tk_ErrorProc) _ANSI_ARGS_((ClientData clientData, + XErrorEvent *errEventPtr)); +typedef void (Tk_EventProc) _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +typedef int (Tk_GenericProc) _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +typedef int (Tk_GetSelProc) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, char *portion)); +typedef void (Tk_LostSelProc) _ANSI_ARGS_((ClientData clientData)); +typedef Tk_RestrictAction (Tk_RestrictProc) _ANSI_ARGS_(( + ClientData clientData, XEvent *eventPtr)); +typedef int (Tk_SelectionProc) _ANSI_ARGS_((ClientData clientData, + int offset, char *buffer, int maxBytes)); + +/* + *-------------------------------------------------------------- + * + * Exported procedures and variables. + * + *-------------------------------------------------------------- + */ + +EXTERN XColor * Tk_3DBorderColor _ANSI_ARGS_((Tk_3DBorder border)); +EXTERN GC Tk_3DBorderGC _ANSI_ARGS_((Tk_Window tkwin, + Tk_3DBorder border, int which)); +EXTERN void Tk_3DHorizontalBevel _ANSI_ARGS_((Tk_Window tkwin, + Drawable drawable, Tk_3DBorder border, int x, + int y, int width, int height, int leftIn, + int rightIn, int topBevel, int relief)); +EXTERN void Tk_3DVerticalBevel _ANSI_ARGS_((Tk_Window tkwin, + Drawable drawable, Tk_3DBorder border, int x, + int y, int width, int height, int leftBevel, + int relief)); +EXTERN void Tk_AddOption _ANSI_ARGS_((Tk_Window tkwin, char *name, + char *value, int priority)); +EXTERN void Tk_BindEvent _ANSI_ARGS_((Tk_BindingTable bindingTable, + XEvent *eventPtr, Tk_Window tkwin, int numObjects, + ClientData *objectPtr)); +EXTERN void Tk_CanvasDrawableCoords _ANSI_ARGS_((Tk_Canvas canvas, + double x, double y, short *drawableXPtr, + short *drawableYPtr)); +EXTERN void Tk_CanvasEventuallyRedraw _ANSI_ARGS_(( + Tk_Canvas canvas, int x1, int y1, int x2, + int y2)); +EXTERN int Tk_CanvasGetCoord _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, char *string, + double *doublePtr)); +EXTERN Tk_CanvasTextInfo *Tk_CanvasGetTextInfo _ANSI_ARGS_((Tk_Canvas canvas)); +EXTERN int Tk_CanvasPsBitmap _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Pixmap bitmap, int x, int y, + int width, int height)); +EXTERN int Tk_CanvasPsColor _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, XColor *colorPtr)); +EXTERN int Tk_CanvasPsFont _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Font font)); +EXTERN void Tk_CanvasPsPath _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, double *coordPtr, int numPoints)); +EXTERN int Tk_CanvasPsStipple _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Pixmap bitmap)); +EXTERN double Tk_CanvasPsY _ANSI_ARGS_((Tk_Canvas canvas, double y)); +EXTERN void Tk_CanvasSetStippleOrigin _ANSI_ARGS_(( + Tk_Canvas canvas, GC gc)); +EXTERN int Tk_CanvasTagsParseProc _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp, + Tk_Window tkwin, char *value, char *widgRec, + int offset)); +EXTERN char * Tk_CanvasTagsPrintProc _ANSI_ARGS_(( + ClientData clientData, Tk_Window tkwin, + char *widgRec, int offset, + Tcl_FreeProc **freeProcPtr)); +EXTERN Tk_Window Tk_CanvasTkwin _ANSI_ARGS_((Tk_Canvas canvas)); +EXTERN void Tk_CanvasWindowCoords _ANSI_ARGS_((Tk_Canvas canvas, + double x, double y, short *screenXPtr, + short *screenYPtr)); +EXTERN void Tk_ChangeWindowAttributes _ANSI_ARGS_((Tk_Window tkwin, + unsigned long valueMask, + XSetWindowAttributes *attsPtr)); +EXTERN int Tk_CharBbox _ANSI_ARGS_((Tk_TextLayout layout, + int index, int *xPtr, int *yPtr, int *widthPtr, + int *heightPtr)); +EXTERN void Tk_ClearSelection _ANSI_ARGS_((Tk_Window tkwin, + Atom selection)); +EXTERN int Tk_ClipboardAppend _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, Atom target, Atom format, + char* buffer)); +EXTERN int Tk_ClipboardClear _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin)); +EXTERN int Tk_ConfigureInfo _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, Tk_ConfigSpec *specs, + char *widgRec, char *argvName, int flags)); +EXTERN int Tk_ConfigureValue _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, Tk_ConfigSpec *specs, + char *widgRec, char *argvName, int flags)); +EXTERN int Tk_ConfigureWidget _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, Tk_ConfigSpec *specs, + int argc, char **argv, char *widgRec, + int flags)); +EXTERN void Tk_ConfigureWindow _ANSI_ARGS_((Tk_Window tkwin, + unsigned int valueMask, XWindowChanges *valuePtr)); +EXTERN Tk_TextLayout Tk_ComputeTextLayout _ANSI_ARGS_((Tk_Font font, + CONST char *string, int numChars, int wrapLength, + Tk_Justify justify, int flags, int *widthPtr, + int *heightPtr)); +EXTERN Tk_Window Tk_CoordsToWindow _ANSI_ARGS_((int rootX, int rootY, + Tk_Window tkwin)); +EXTERN unsigned long Tk_CreateBinding _ANSI_ARGS_((Tcl_Interp *interp, + Tk_BindingTable bindingTable, ClientData object, + char *eventString, char *command, int append)); +EXTERN Tk_BindingTable Tk_CreateBindingTable _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN Tk_ErrorHandler Tk_CreateErrorHandler _ANSI_ARGS_((Display *display, + int errNum, int request, int minorCode, + Tk_ErrorProc *errorProc, ClientData clientData)); +EXTERN void Tk_CreateEventHandler _ANSI_ARGS_((Tk_Window token, + unsigned long mask, Tk_EventProc *proc, + ClientData clientData)); +EXTERN void Tk_CreateGenericHandler _ANSI_ARGS_(( + Tk_GenericProc *proc, ClientData clientData)); +EXTERN void Tk_CreateImageType _ANSI_ARGS_(( + Tk_ImageType *typePtr)); +EXTERN void Tk_CreateItemType _ANSI_ARGS_((Tk_ItemType *typePtr)); +EXTERN void Tk_CreatePhotoImageFormat _ANSI_ARGS_(( + Tk_PhotoImageFormat *formatPtr)); +EXTERN void Tk_CreateSelHandler _ANSI_ARGS_((Tk_Window tkwin, + Atom selection, Atom target, + Tk_SelectionProc *proc, ClientData clientData, + Atom format)); +EXTERN Tk_Window Tk_CreateWindow _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window parent, char *name, char *screenName)); +EXTERN Tk_Window Tk_CreateWindowFromPath _ANSI_ARGS_(( + Tcl_Interp *interp, Tk_Window tkwin, + char *pathName, char *screenName)); +EXTERN int Tk_DefineBitmap _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Uid name, char *source, int width, + int height)); +EXTERN void Tk_DefineCursor _ANSI_ARGS_((Tk_Window window, + Tk_Cursor cursor)); +EXTERN void Tk_DeleteAllBindings _ANSI_ARGS_(( + Tk_BindingTable bindingTable, ClientData object)); +EXTERN int Tk_DeleteBinding _ANSI_ARGS_((Tcl_Interp *interp, + Tk_BindingTable bindingTable, ClientData object, + char *eventString)); +EXTERN void Tk_DeleteBindingTable _ANSI_ARGS_(( + Tk_BindingTable bindingTable)); +EXTERN void Tk_DeleteErrorHandler _ANSI_ARGS_(( + Tk_ErrorHandler handler)); +EXTERN void Tk_DeleteEventHandler _ANSI_ARGS_((Tk_Window token, + unsigned long mask, Tk_EventProc *proc, + ClientData clientData)); +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_DeleteSelHandler _ANSI_ARGS_((Tk_Window tkwin, + Atom selection, Atom target)); +EXTERN void Tk_DestroyWindow _ANSI_ARGS_((Tk_Window tkwin)); +EXTERN char * Tk_DisplayName _ANSI_ARGS_((Tk_Window tkwin)); +EXTERN int Tk_DistanceToTextLayout _ANSI_ARGS_(( + Tk_TextLayout layout, int x, int y)); +EXTERN void Tk_Draw3DPolygon _ANSI_ARGS_((Tk_Window tkwin, + Drawable drawable, Tk_3DBorder border, + XPoint *pointPtr, int numPoints, int borderWidth, + int leftRelief)); +EXTERN void Tk_Draw3DRectangle _ANSI_ARGS_((Tk_Window tkwin, + Drawable drawable, Tk_3DBorder border, int x, + int y, int width, int height, int borderWidth, + int relief)); +EXTERN void Tk_DrawChars _ANSI_ARGS_((Display *display, + Drawable drawable, GC gc, Tk_Font tkfont, + CONST char *source, int numChars, int x, + int y)); +EXTERN void Tk_DrawFocusHighlight _ANSI_ARGS_((Tk_Window tkwin, + GC gc, int width, Drawable drawable)); +EXTERN void Tk_DrawTextLayout _ANSI_ARGS_((Display *display, + Drawable drawable, GC gc, Tk_TextLayout layout, + int x, int y, int firstChar, int lastChar)); +EXTERN void Tk_Fill3DPolygon _ANSI_ARGS_((Tk_Window tkwin, + Drawable drawable, Tk_3DBorder border, + XPoint *pointPtr, int numPoints, int borderWidth, + int leftRelief)); +EXTERN void Tk_Fill3DRectangle _ANSI_ARGS_((Tk_Window tkwin, + Drawable drawable, Tk_3DBorder border, int x, + int y, int width, int height, int borderWidth, + int relief)); +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_FreeBitmap _ANSI_ARGS_((Display *display, + Pixmap bitmap)); +EXTERN void Tk_FreeColor _ANSI_ARGS_((XColor *colorPtr)); +EXTERN void Tk_FreeColormap _ANSI_ARGS_((Display *display, + Colormap colormap)); +EXTERN void Tk_FreeCursor _ANSI_ARGS_((Display *display, + Tk_Cursor cursor)); +EXTERN void Tk_FreeFont _ANSI_ARGS_((Tk_Font)); +EXTERN void Tk_FreeGC _ANSI_ARGS_((Display *display, GC gc)); +EXTERN void Tk_FreeImage _ANSI_ARGS_((Tk_Image image)); +EXTERN void Tk_FreeOptions _ANSI_ARGS_((Tk_ConfigSpec *specs, + char *widgRec, Display *display, int needFlags)); +EXTERN void Tk_FreePixmap _ANSI_ARGS_((Display *display, + Pixmap pixmap)); +EXTERN void Tk_FreeTextLayout _ANSI_ARGS_(( + Tk_TextLayout textLayout)); +EXTERN void Tk_FreeXId _ANSI_ARGS_((Display *display, XID xid)); +EXTERN GC Tk_GCForColor _ANSI_ARGS_((XColor *colorPtr, + Drawable drawable)); +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)); +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 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)); +EXTERN Pixmap Tk_GetBitmapFromData _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, char *source, + int width, int height)); +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)); +EXTERN XColor * Tk_GetColorByValue _ANSI_ARGS_((Tk_Window tkwin, + XColor *colorPtr)); +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)); +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_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 void Tk_GetFontMetrics _ANSI_ARGS_((Tk_Font font, + Tk_FontMetrics *fmPtr)); +EXTERN GC Tk_GetGC _ANSI_ARGS_((Tk_Window tkwin, + unsigned long valueMask, XGCValues *valuePtr)); +EXTERN Tk_Image Tk_GetImage _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, char *name, + Tk_ImageChangedProc *changeProc, + ClientData clientData)); +EXTERN ClientData Tk_GetImageMasterData _ANSI_ARGS_ ((Tcl_Interp *interp, + char *name, Tk_ImageType **typePtrPtr)); +EXTERN Tk_ItemType * Tk_GetItemTypes _ANSI_ARGS_((void)); +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_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 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 void Tk_GetRootCoords _ANSI_ARGS_ ((Tk_Window tkwin, + int *xPtr, int *yPtr)); +EXTERN int Tk_GetScrollInfo _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv, double *dblPtr, + int *intPtr)); +EXTERN int Tk_GetScreenMM _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, char *string, double *doublePtr)); +EXTERN int Tk_GetSelection _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, Atom selection, Atom target, + Tk_GetSelProc *proc, ClientData clientData)); +EXTERN Tk_Uid Tk_GetUid _ANSI_ARGS_((CONST char *string)); +EXTERN Visual * Tk_GetVisual _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, char *string, int *depthPtr, + Colormap *colormapPtr)); +EXTERN void Tk_GetVRootGeometry _ANSI_ARGS_((Tk_Window tkwin, + int *xPtr, int *yPtr, int *widthPtr, + int *heightPtr)); +EXTERN int Tk_Grab _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, int grabGlobal)); +EXTERN void Tk_HandleEvent _ANSI_ARGS_((XEvent *eventPtr)); +EXTERN Tk_Window Tk_IdToWindow _ANSI_ARGS_((Display *display, + Window window)); +EXTERN void Tk_ImageChanged _ANSI_ARGS_(( + Tk_ImageMaster master, int x, int y, + int width, int height, int imageWidth, + int imageHeight)); +EXTERN int Tk_Init _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN Atom Tk_InternAtom _ANSI_ARGS_((Tk_Window tkwin, + char *name)); +EXTERN int Tk_IntersectTextLayout _ANSI_ARGS_(( + Tk_TextLayout layout, int x, int y, int width, + int height)); +EXTERN void Tk_Main _ANSI_ARGS_((int argc, char **argv, + Tcl_AppInitProc *appInitProc)); +EXTERN void Tk_MainLoop _ANSI_ARGS_((void)); +EXTERN void Tk_MaintainGeometry _ANSI_ARGS_((Tk_Window slave, + Tk_Window master, int x, int y, int width, + int height)); +EXTERN Tk_Window Tk_MainWindow _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN void Tk_MakeWindowExist _ANSI_ARGS_((Tk_Window tkwin)); +EXTERN void Tk_ManageGeometry _ANSI_ARGS_((Tk_Window tkwin, + Tk_GeomMgr *mgrPtr, ClientData clientData)); +EXTERN void Tk_MapWindow _ANSI_ARGS_((Tk_Window tkwin)); +EXTERN int Tk_MeasureChars _ANSI_ARGS_((Tk_Font tkfont, + CONST char *source, int maxChars, int maxPixels, + int flags, int *lengthPtr)); +EXTERN void Tk_MoveResizeWindow _ANSI_ARGS_((Tk_Window tkwin, + int x, int y, int width, int height)); +EXTERN void Tk_MoveWindow _ANSI_ARGS_((Tk_Window tkwin, int x, + int y)); +EXTERN void Tk_MoveToplevelWindow _ANSI_ARGS_((Tk_Window tkwin, + int x, int y)); +EXTERN char * Tk_NameOf3DBorder _ANSI_ARGS_((Tk_3DBorder border)); +EXTERN char * Tk_NameOfAnchor _ANSI_ARGS_((Tk_Anchor anchor)); +EXTERN char * Tk_NameOfBitmap _ANSI_ARGS_((Display *display, + Pixmap bitmap)); +EXTERN char * Tk_NameOfCapStyle _ANSI_ARGS_((int cap)); +EXTERN char * Tk_NameOfColor _ANSI_ARGS_((XColor *colorPtr)); +EXTERN char * Tk_NameOfCursor _ANSI_ARGS_((Display *display, + Tk_Cursor cursor)); +EXTERN char * Tk_NameOfFont _ANSI_ARGS_((Tk_Font font)); +EXTERN char * Tk_NameOfImage _ANSI_ARGS_(( + Tk_ImageMaster imageMaster)); +EXTERN char * Tk_NameOfJoinStyle _ANSI_ARGS_((int join)); +EXTERN char * Tk_NameOfJustify _ANSI_ARGS_((Tk_Justify justify)); +EXTERN char * Tk_NameOfRelief _ANSI_ARGS_((int relief)); +EXTERN Tk_Window Tk_NameToWindow _ANSI_ARGS_((Tcl_Interp *interp, + char *pathName, Tk_Window tkwin)); +EXTERN void Tk_OwnSelection _ANSI_ARGS_((Tk_Window tkwin, + Atom selection, Tk_LostSelProc *proc, + ClientData clientData)); +EXTERN int Tk_ParseArgv _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, int *argcPtr, char **argv, + Tk_ArgvInfo *argTable, int flags)); +EXTERN void Tk_PhotoPutBlock _ANSI_ARGS_((Tk_PhotoHandle handle, + Tk_PhotoImageBlock *blockPtr, int x, int y, + int width, int height)); +EXTERN void Tk_PhotoPutZoomedBlock _ANSI_ARGS_(( + Tk_PhotoHandle handle, + Tk_PhotoImageBlock *blockPtr, int x, int y, + int width, int height, int zoomX, int zoomY, + int subsampleX, int subsampleY)); +EXTERN int Tk_PhotoGetImage _ANSI_ARGS_((Tk_PhotoHandle handle, + Tk_PhotoImageBlock *blockPtr)); +EXTERN void Tk_PhotoBlank _ANSI_ARGS_((Tk_PhotoHandle handle)); +EXTERN void Tk_PhotoExpand _ANSI_ARGS_((Tk_PhotoHandle handle, + int width, int height )); +EXTERN void Tk_PhotoGetSize _ANSI_ARGS_((Tk_PhotoHandle handle, + int *widthPtr, int *heightPtr)); +EXTERN void Tk_PhotoSetSize _ANSI_ARGS_((Tk_PhotoHandle handle, + int width, int height)); +EXTERN int Tk_PointToChar _ANSI_ARGS_((Tk_TextLayout layout, + int x, int y)); +EXTERN int Tk_PostscriptFontName _ANSI_ARGS_((Tk_Font tkfont, + Tcl_DString *dsPtr)); +EXTERN void Tk_PreserveColormap _ANSI_ARGS_((Display *display, + Colormap colormap)); +EXTERN void Tk_QueueWindowEvent _ANSI_ARGS_((XEvent *eventPtr, + Tcl_QueuePosition position)); +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_ResizeWindow _ANSI_ARGS_((Tk_Window tkwin, + int width, int height)); +EXTERN int Tk_RestackWindow _ANSI_ARGS_((Tk_Window tkwin, + int aboveBelow, Tk_Window other)); +EXTERN Tk_RestrictProc *Tk_RestrictEvents _ANSI_ARGS_((Tk_RestrictProc *proc, + ClientData arg, ClientData *prevArgPtr)); +EXTERN int Tk_SafeInit _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN char * Tk_SetAppName _ANSI_ARGS_((Tk_Window tkwin, + char *name)); +EXTERN void Tk_SetBackgroundFromBorder _ANSI_ARGS_(( + Tk_Window tkwin, Tk_3DBorder border)); +EXTERN void Tk_SetClass _ANSI_ARGS_((Tk_Window tkwin, + char *className)); +EXTERN void Tk_SetGrid _ANSI_ARGS_((Tk_Window tkwin, + int reqWidth, int reqHeight, int gridWidth, + int gridHeight)); +EXTERN void Tk_SetInternalBorder _ANSI_ARGS_((Tk_Window tkwin, + int width)); +EXTERN void Tk_SetWindowBackground _ANSI_ARGS_((Tk_Window tkwin, + unsigned long pixel)); +EXTERN void Tk_SetWindowBackgroundPixmap _ANSI_ARGS_(( + Tk_Window tkwin, Pixmap pixmap)); +EXTERN void Tk_SetWindowBorder _ANSI_ARGS_((Tk_Window tkwin, + unsigned long pixel)); +EXTERN void Tk_SetWindowBorderWidth _ANSI_ARGS_((Tk_Window tkwin, + int width)); +EXTERN void Tk_SetWindowBorderPixmap _ANSI_ARGS_((Tk_Window tkwin, + Pixmap pixmap)); +EXTERN void Tk_SetWindowColormap _ANSI_ARGS_((Tk_Window tkwin, + Colormap colormap)); +EXTERN int Tk_SetWindowVisual _ANSI_ARGS_((Tk_Window tkwin, + Visual *visual, int depth, + Colormap colormap)); +EXTERN void Tk_SizeOfBitmap _ANSI_ARGS_((Display *display, + Pixmap bitmap, int *widthPtr, + int *heightPtr)); +EXTERN void Tk_SizeOfImage _ANSI_ARGS_((Tk_Image image, + int *widthPtr, int *heightPtr)); +EXTERN int Tk_StrictMotif _ANSI_ARGS_((Tk_Window tkwin)); +EXTERN void Tk_TextLayoutToPostscript _ANSI_ARGS_(( + Tcl_Interp *interp, Tk_TextLayout layout)); +EXTERN int Tk_TextWidth _ANSI_ARGS_((Tk_Font font, + CONST char *string, int numChars)); +EXTERN void Tk_UndefineCursor _ANSI_ARGS_((Tk_Window window)); +EXTERN void Tk_UnderlineChars _ANSI_ARGS_((Display *display, + Drawable drawable, GC gc, Tk_Font tkfont, + CONST char *source, int x, int y, int firstChar, + int lastChar)); +EXTERN void Tk_UnderlineTextLayout _ANSI_ARGS_(( + Display *display, Drawable drawable, GC gc, + Tk_TextLayout layout, int x, int y, + int underline)); +EXTERN void Tk_Ungrab _ANSI_ARGS_((Tk_Window tkwin)); +EXTERN void Tk_UnmaintainGeometry _ANSI_ARGS_((Tk_Window slave, + Tk_Window master)); +EXTERN void Tk_UnmapWindow _ANSI_ARGS_((Tk_Window tkwin)); +EXTERN void Tk_UnsetGrid _ANSI_ARGS_((Tk_Window tkwin)); +EXTERN void Tk_UpdatePointer _ANSI_ARGS_((Tk_Window tkwin, + int x, int y, int state)); + +/* + * Tcl commands exported by Tk: + */ + +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_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_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_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_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_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_FontObjCmd _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_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_MessageCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_OptionCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +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_RaiseCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_ScaleCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_ScrollbarCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +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_TextCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tk_TkObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +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_WinfoObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +EXTERN int Tk_WmCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); + +#endif /* RESOURCE_INCLUDED */ +#endif /* _TK */ diff --git a/generic/tk3d.c b/generic/tk3d.c new file mode 100644 index 0000000..53eec8b --- /dev/null +++ b/generic/tk3d.c @@ -0,0 +1,949 @@ +/* + * tk3d.c -- + * + * This module provides procedures to draw borders in + * the three-dimensional Motif style. + * + * 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: @(#) tk3d.c 1.60 97/01/13 17:23:10 + */ + +#include + +/* + * Hash table to map from a border's values (color, etc.) to a + * Border structure for those values. + */ + +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. */ + +/* + * Forward declarations for procedures defined in this file: + */ + +static void BorderInit _ANSI_ARGS_((void)); +static int Intersect _ANSI_ARGS_((XPoint *a1Ptr, XPoint *a2Ptr, + XPoint *b1Ptr, XPoint *b2Ptr, XPoint *iPtr)); +static void ShiftLine _ANSI_ARGS_((XPoint *p1Ptr, XPoint *p2Ptr, + int distance, XPoint *p3Ptr)); + +/* + *-------------------------------------------------------------- + * + * Tk_Get3DBorder -- + * + * 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. + * + * Side effects: + * Data structures, graphics contexts, etc. are allocated. + * It is the caller's responsibility to eventually call + * Tk_Free3DBorder to release the resources. + * + *-------------------------------------------------------------- + */ + +Tk_3DBorder +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 + * for window background. */ +{ + BorderKey key; + Tcl_HashEntry *hashPtr; + register TkBorder *borderPtr; + int new; + XGCValues gcValues; + + 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); + if (!new) { + borderPtr = (TkBorder *) Tcl_GetHashValue(hashPtr); + borderPtr->refCount++; + } else { + XColor *bgColorPtr; + + /* + * No satisfactory border exists yet. Initialize a new one. + */ + + bgColorPtr = Tk_GetColor(interp, tkwin, colorName); + if (bgColorPtr == NULL) { + 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 (Tk_3DBorder) borderPtr; +} + +/* + *-------------------------------------------------------------- + * + * Tk_Draw3DRectangle -- + * + * Draw a 3-D border at a given place in a given window. + * + * Results: + * None. + * + * Side effects: + * A 3-D border will be drawn in the indicated drawable. + * The outside edges of the border will be determined by x, + * y, width, and height. The inside edges of the border + * will be determined by the borderWidth argument. + * + *-------------------------------------------------------------- + */ + +void +Tk_Draw3DRectangle(tkwin, drawable, border, x, y, width, height, + borderWidth, relief) + Tk_Window tkwin; /* Window for which border was allocated. */ + Drawable drawable; /* X window or pixmap in which to draw. */ + Tk_3DBorder border; /* Token for border to draw. */ + int x, y, width, height; /* Outside area of region in + * which border will be drawn. */ + int borderWidth; /* Desired width for border, in + * pixels. */ + int relief; /* Type of relief: TK_RELIEF_RAISED, + * TK_RELIEF_SUNKEN, TK_RELIEF_GROOVE, etc. */ +{ + if (width < 2*borderWidth) { + borderWidth = width/2; + } + if (height < 2*borderWidth) { + borderWidth = height/2; + } + Tk_3DVerticalBevel(tkwin, drawable, border, x, y, borderWidth, height, + 1, relief); + Tk_3DVerticalBevel(tkwin, drawable, border, x+width-borderWidth, y, + borderWidth, height, 0, relief); + Tk_3DHorizontalBevel(tkwin, drawable, border, x, y, width, borderWidth, + 1, 1, 1, relief); + Tk_3DHorizontalBevel(tkwin, drawable, border, x, y+height-borderWidth, + width, borderWidth, 0, 0, 0, relief); +} + +/* + *-------------------------------------------------------------- + * + * Tk_NameOf3DBorder -- + * + * Given a border, return a textual string identifying the + * border's color. + * + * Results: + * The return value is the string that was used to create + * the border. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +char * +Tk_NameOf3DBorder(border) + Tk_3DBorder border; /* Token for border. */ +{ + TkBorder *borderPtr = (TkBorder *) border; + + return ((BorderKey *) borderPtr->hashPtr->key.words)->colorName; +} + +/* + *-------------------------------------------------------------------- + * + * Tk_3DBorderColor -- + * + * Given a 3D border, return the X color used for the "flat" + * surfaces. + * + * Results: + * Returns the color used drawing flat surfaces with the border. + * + * Side effects: + * None. + * + *-------------------------------------------------------------------- + */ +XColor * +Tk_3DBorderColor(border) + Tk_3DBorder border; /* Border whose color is wanted. */ +{ + return(((TkBorder *) border)->bgColorPtr); +} + +/* + *-------------------------------------------------------------------- + * + * Tk_3DBorderGC -- + * + * Given a 3D border, returns one of the graphics contexts used to + * draw the border. + * + * Results: + * Returns the graphics context given by the "which" argument. + * + * Side effects: + * None. + * + *-------------------------------------------------------------------- + */ +GC +Tk_3DBorderGC(tkwin, border, which) + Tk_Window tkwin; /* Window for which border was allocated. */ + Tk_3DBorder border; /* Border whose GC is wanted. */ + int which; /* Selects one of the border's 3 GC's: + * TK_3D_FLAT_GC, TK_3D_LIGHT_GC, or + * TK_3D_DARK_GC. */ +{ + TkBorder * borderPtr = (TkBorder *) border; + + if ((borderPtr->lightGC == None) && (which != TK_3D_FLAT_GC)) { + TkpGetShadows(borderPtr, tkwin); + } + if (which == TK_3D_FLAT_GC) { + return borderPtr->bgGC; + } else if (which == TK_3D_LIGHT_GC) { + return borderPtr->lightGC; + } else if (which == TK_3D_DARK_GC){ + return borderPtr->darkGC; + } + panic("bogus \"which\" value in Tk_3DBorderGC"); + + /* + * The code below will never be executed, but it's needed to + * keep compilers happy. + */ + + return (GC) None; +} + +/* + *-------------------------------------------------------------- + * + * Tk_Free3DBorder -- + * + * This procedure is called when a 3D border is no longer + * needed. It frees the resources associated with the + * border. After this call, the caller should never again + * use the "border" token. + * + * Results: + * None. + * + * Side effects: + * Resources are freed. + * + *-------------------------------------------------------------- + */ + +void +Tk_Free3DBorder(border) + Tk_3DBorder border; /* Token for border to be released. */ +{ + register TkBorder *borderPtr = (TkBorder *) border; + Display *display = DisplayOfScreen(borderPtr->screen); + + 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); + } + if (borderPtr->lightGC != None) { + Tk_FreeGC(display, borderPtr->lightGC); + } + Tcl_DeleteHashEntry(borderPtr->hashPtr); + ckfree((char *) borderPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tk_SetBackgroundFromBorder -- + * + * Change the background of a window to one appropriate for a given + * 3-D border. + * + * Results: + * None. + * + * Side effects: + * Tkwin's background gets modified. + * + *---------------------------------------------------------------------- + */ + +void +Tk_SetBackgroundFromBorder(tkwin, border) + Tk_Window tkwin; /* Window whose background is to be set. */ + Tk_3DBorder border; /* Token for border. */ +{ + register TkBorder *borderPtr = (TkBorder *) border; + + Tk_SetWindowBackground(tkwin, borderPtr->bgColorPtr->pixel); +} + +/* + *---------------------------------------------------------------------- + * + * Tk_GetRelief -- + * + * Parse a relief description and return the corresponding + * relief value, or an error. + * + * Results: + * A standard Tcl return value. If all goes well then + * *reliefPtr is filled in with one of the values + * TK_RELIEF_RAISED, TK_RELIEF_FLAT, or TK_RELIEF_SUNKEN. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tk_GetRelief(interp, name, reliefPtr) + Tcl_Interp *interp; /* For error messages. */ + char *name; /* Name of a relief type. */ + int *reliefPtr; /* Where to store converted relief. */ +{ + char c; + size_t length; + + c = name[0]; + length = strlen(name); + if ((c == 'f') && (strncmp(name, "flat", length) == 0)) { + *reliefPtr = TK_RELIEF_FLAT; + } else if ((c == 'g') && (strncmp(name, "groove", length) == 0) + && (length >= 2)) { + *reliefPtr = TK_RELIEF_GROOVE; + } else if ((c == 'r') && (strncmp(name, "raised", length) == 0) + && (length >= 2)) { + *reliefPtr = TK_RELIEF_RAISED; + } else if ((c == 'r') && (strncmp(name, "ridge", length) == 0)) { + *reliefPtr = TK_RELIEF_RIDGE; + } else if ((c == 's') && (strncmp(name, "solid", length) == 0)) { + *reliefPtr = TK_RELIEF_SOLID; + } else if ((c == 's') && (strncmp(name, "sunken", length) == 0)) { + *reliefPtr = TK_RELIEF_SUNKEN; + } else { + sprintf(interp->result, "bad relief type \"%.50s\": must be %s", + name, "flat, groove, raised, ridge, solid, or sunken"); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * Tk_NameOfRelief -- + * + * Given a relief value, produce a string describing that + * relief value. + * + * Results: + * The return value is a static string that is equivalent + * to relief. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +char * +Tk_NameOfRelief(relief) + int relief; /* One of TK_RELIEF_FLAT, TK_RELIEF_RAISED, + * or TK_RELIEF_SUNKEN. */ +{ + if (relief == TK_RELIEF_FLAT) { + return "flat"; + } else if (relief == TK_RELIEF_SUNKEN) { + return "sunken"; + } else if (relief == TK_RELIEF_RAISED) { + return "raised"; + } else if (relief == TK_RELIEF_GROOVE) { + return "groove"; + } else if (relief == TK_RELIEF_RIDGE) { + return "ridge"; + } else if (relief == TK_RELIEF_SOLID) { + return "solid"; + } else { + return "unknown relief"; + } +} + +/* + *-------------------------------------------------------------- + * + * Tk_Draw3DPolygon -- + * + * Draw a border with 3-D appearance around the edge of a + * given polygon. + * + * Results: + * None. + * + * Side effects: + * Information is drawn in "drawable" in the form of a + * 3-D border borderWidth units width wide on the left + * of the trajectory given by pointPtr and numPoints (or + * -borderWidth units wide on the right side, if borderWidth + * is negative). + * + *-------------------------------------------------------------- + */ + +void +Tk_Draw3DPolygon(tkwin, drawable, border, pointPtr, numPoints, + borderWidth, leftRelief) + Tk_Window tkwin; /* Window for which border was allocated. */ + Drawable drawable; /* X window or pixmap in which to draw. */ + Tk_3DBorder border; /* Token for border to draw. */ + XPoint *pointPtr; /* Array of points describing + * polygon. All points must be + * absolute (CoordModeOrigin). */ + int numPoints; /* Number of points at *pointPtr. */ + int borderWidth; /* Width of border, measured in + * pixels to the left of the polygon's + * trajectory. May be negative. */ + int leftRelief; /* TK_RELIEF_RAISED or + * TK_RELIEF_SUNKEN: indicates how + * stuff to left of trajectory looks + * relative to stuff on right. */ +{ + XPoint poly[4], b1, b2, newB1, newB2; + XPoint perp, c, shift1, shift2; /* Used for handling parallel lines. */ + register XPoint *p1Ptr, *p2Ptr; + TkBorder *borderPtr = (TkBorder *) border; + GC gc; + int i, lightOnLeft, dx, dy, parallel, pointsSeen; + Display *display = Tk_Display(tkwin); + + if (borderPtr->lightGC == None) { + TkpGetShadows(borderPtr, tkwin); + } + + /* + * Handle grooves and ridges with recursive calls. + */ + + if ((leftRelief == TK_RELIEF_GROOVE) || (leftRelief == TK_RELIEF_RIDGE)) { + int halfWidth; + + halfWidth = borderWidth/2; + Tk_Draw3DPolygon(tkwin, drawable, border, pointPtr, numPoints, + halfWidth, (leftRelief == TK_RELIEF_GROOVE) ? TK_RELIEF_RAISED + : TK_RELIEF_SUNKEN); + Tk_Draw3DPolygon(tkwin, drawable, border, pointPtr, numPoints, + -halfWidth, (leftRelief == TK_RELIEF_GROOVE) ? TK_RELIEF_SUNKEN + : TK_RELIEF_RAISED); + return; + } + + /* + * If the polygon is already closed, drop the last point from it + * (we'll close it automatically). + */ + + p1Ptr = &pointPtr[numPoints-1]; + p2Ptr = &pointPtr[0]; + if ((p1Ptr->x == p2Ptr->x) && (p1Ptr->y == p2Ptr->y)) { + numPoints--; + } + + /* + * The loop below is executed once for each vertex in the polgon. + * At the beginning of each iteration things look like this: + * + * poly[1] / + * * / + * | / + * b1 * poly[0] (pointPtr[i-1]) + * | | + * | | + * | | + * | | + * | | + * | | *p1Ptr *p2Ptr + * b2 *--------------------* + * | + * | + * x------------------------- + * + * The job of this iteration is to do the following: + * (a) Compute x (the border corner corresponding to + * pointPtr[i]) and put it in poly[2]. As part of + * this, compute a new b1 and b2 value for the next + * side of the polygon. + * (b) Put pointPtr[i] into poly[3]. + * (c) Draw the polygon given by poly[0..3]. + * (d) Advance poly[0], poly[1], b1, and b2 for the + * next side of the polygon. + */ + + /* + * The above situation doesn't first come into existence until + * two points have been processed; the first two points are + * used to "prime the pump", so some parts of the processing + * are ommitted for these points. The variable "pointsSeen" + * keeps track of the priming process; it has to be separate + * from i in order to be able to ignore duplicate points in the + * polygon. + */ + + pointsSeen = 0; + for (i = -2, p1Ptr = &pointPtr[numPoints-2], p2Ptr = p1Ptr+1; + i < numPoints; i++, p1Ptr = p2Ptr, p2Ptr++) { + if ((i == -1) || (i == numPoints-1)) { + p2Ptr = pointPtr; + } + if ((p2Ptr->x == p1Ptr->x) && (p2Ptr->y == p1Ptr->y)) { + /* + * Ignore duplicate points (they'd cause core dumps in + * ShiftLine calls below). + */ + continue; + } + ShiftLine(p1Ptr, p2Ptr, borderWidth, &newB1); + newB2.x = newB1.x + (p2Ptr->x - p1Ptr->x); + newB2.y = newB1.y + (p2Ptr->y - p1Ptr->y); + poly[3] = *p1Ptr; + parallel = 0; + if (pointsSeen >= 1) { + parallel = Intersect(&newB1, &newB2, &b1, &b2, &poly[2]); + + /* + * If two consecutive segments of the polygon are parallel, + * then things get more complex. Consider the following + * diagram: + * + * poly[1] + * *----b1-----------b2------a + * \ + * \ + * *---------*----------* b + * poly[0] *p2Ptr *p1Ptr / + * / + * --*--------*----c + * newB1 newB2 + * + * Instead of using x and *p1Ptr for poly[2] and poly[3], as + * in the original diagram, use a and b as above. Then instead + * of using x and *p1Ptr for the new poly[0] and poly[1], use + * b and c as above. + * + * Do the computation in three stages: + * 1. Compute a point "perp" such that the line p1Ptr-perp + * is perpendicular to p1Ptr-p2Ptr. + * 2. Compute the points a and c by intersecting the lines + * b1-b2 and newB1-newB2 with p1Ptr-perp. + * 3. Compute b by shifting p1Ptr-perp to the right and + * intersecting it with p1Ptr-p2Ptr. + */ + + if (parallel) { + perp.x = p1Ptr->x + (p2Ptr->y - p1Ptr->y); + perp.y = p1Ptr->y - (p2Ptr->x - p1Ptr->x); + (void) Intersect(p1Ptr, &perp, &b1, &b2, &poly[2]); + (void) Intersect(p1Ptr, &perp, &newB1, &newB2, &c); + ShiftLine(p1Ptr, &perp, borderWidth, &shift1); + shift2.x = shift1.x + (perp.x - p1Ptr->x); + shift2.y = shift1.y + (perp.y - p1Ptr->y); + (void) Intersect(p1Ptr, p2Ptr, &shift1, &shift2, &poly[3]); + } + } + if (pointsSeen >= 2) { + dx = poly[3].x - poly[0].x; + dy = poly[3].y - poly[0].y; + if (dx > 0) { + lightOnLeft = (dy <= dx); + } else { + lightOnLeft = (dy < dx); + } + if (lightOnLeft ^ (leftRelief == TK_RELIEF_RAISED)) { + gc = borderPtr->lightGC; + } else { + gc = borderPtr->darkGC; + } + XFillPolygon(display, drawable, gc, poly, 4, Convex, + CoordModeOrigin); + } + b1.x = newB1.x; + b1.y = newB1.y; + b2.x = newB2.x; + b2.y = newB2.y; + poly[0].x = poly[3].x; + poly[0].y = poly[3].y; + if (parallel) { + poly[1].x = c.x; + poly[1].y = c.y; + } else if (pointsSeen >= 1) { + poly[1].x = poly[2].x; + poly[1].y = poly[2].y; + } + pointsSeen++; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tk_Fill3DRectangle -- + * + * Fill a rectangular area, supplying a 3D border if desired. + * + * Results: + * None. + * + * Side effects: + * Information gets drawn on the screen. + * + *---------------------------------------------------------------------- + */ + +void +Tk_Fill3DRectangle(tkwin, drawable, border, x, y, width, + height, borderWidth, relief) + Tk_Window tkwin; /* Window for which border was allocated. */ + Drawable drawable; /* X window or pixmap in which to draw. */ + Tk_3DBorder border; /* Token for border to draw. */ + int x, y, width, height; /* Outside area of rectangular region. */ + int borderWidth; /* Desired width for border, in + * pixels. Border will be *inside* region. */ + int relief; /* Indicates 3D effect: TK_RELIEF_FLAT, + * TK_RELIEF_RAISED, or TK_RELIEF_SUNKEN. */ +{ + register TkBorder *borderPtr = (TkBorder *) border; + int doubleBorder; + + /* + * This code is slightly tricky because it only draws the background + * in areas not covered by the 3D border. This avoids flashing + * effects on the screen for the border region. + */ + + if (relief == TK_RELIEF_FLAT) { + borderWidth = 0; + } + doubleBorder = 2*borderWidth; + + if ((width > doubleBorder) && (height > doubleBorder)) { + XFillRectangle(Tk_Display(tkwin), drawable, borderPtr->bgGC, + x + borderWidth, y + borderWidth, + (unsigned int) (width - doubleBorder), + (unsigned int) (height - doubleBorder)); + } + if (borderWidth) { + Tk_Draw3DRectangle(tkwin, drawable, border, x, y, width, + height, borderWidth, relief); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tk_Fill3DPolygon -- + * + * Fill a polygonal area, supplying a 3D border if desired. + * + * Results: + * None. + * + * Side effects: + * Information gets drawn on the screen. + * + *---------------------------------------------------------------------- + */ + +void +Tk_Fill3DPolygon(tkwin, drawable, border, pointPtr, numPoints, + borderWidth, leftRelief) + Tk_Window tkwin; /* Window for which border was allocated. */ + Drawable drawable; /* X window or pixmap in which to draw. */ + Tk_3DBorder border; /* Token for border to draw. */ + XPoint *pointPtr; /* Array of points describing + * polygon. All points must be + * absolute (CoordModeOrigin). */ + int numPoints; /* Number of points at *pointPtr. */ + int borderWidth; /* Width of border, measured in + * pixels to the left of the polygon's + * trajectory. May be negative. */ + int leftRelief; /* Indicates 3D effect of left side of + * trajectory relative to right: + * TK_RELIEF_FLAT, TK_RELIEF_RAISED, + * or TK_RELIEF_SUNKEN. */ +{ + register TkBorder *borderPtr = (TkBorder *) border; + + XFillPolygon(Tk_Display(tkwin), drawable, borderPtr->bgGC, + pointPtr, numPoints, Complex, CoordModeOrigin); + if (leftRelief != TK_RELIEF_FLAT) { + Tk_Draw3DPolygon(tkwin, drawable, border, pointPtr, numPoints, + borderWidth, leftRelief); + } +} + +/* + *-------------------------------------------------------------- + * + * BorderInit -- + * + * Initialize the structures used for border management. + * + * Results: + * None. + * + * Side effects: + * Read the code. + * + *------------------------------------------------------------- + */ + +static void +BorderInit() +{ + initialized = 1; + Tcl_InitHashTable(&borderTable, sizeof(BorderKey)/sizeof(int)); +} + +/* + *-------------------------------------------------------------- + * + * ShiftLine -- + * + * Given two points on a line, compute a point on a + * new line that is parallel to the given line and + * a given distance away from it. + * + * Results: + * None. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static void +ShiftLine(p1Ptr, p2Ptr, distance, p3Ptr) + XPoint *p1Ptr; /* First point on line. */ + XPoint *p2Ptr; /* Second point on line. */ + int distance; /* New line is to be this many + * units to the left of original + * line, when looking from p1 to + * p2. May be negative. */ + XPoint *p3Ptr; /* Store coords of point on new + * line here. */ +{ + int dx, dy, dxNeg, dyNeg; + + /* + * The table below is used for a quick approximation in + * computing the new point. An index into the table + * is 128 times the slope of the original line (the slope + * must always be between 0 and 1). The value of the table + * entry is 128 times the amount to displace the new line + * in y for each unit of perpendicular distance. In other + * words, the table maps from the tangent of an angle to + * the inverse of its cosine. If the slope of the original + * line is greater than 1, then the displacement is done in + * x rather than in y. + */ + + static int shiftTable[129]; + + /* + * Initialize the table if this is the first time it is + * used. + */ + + if (shiftTable[0] == 0) { + int i; + double tangent, cosine; + + for (i = 0; i <= 128; i++) { + tangent = i/128.0; + cosine = 128/cos(atan(tangent)) + .5; + shiftTable[i] = (int) cosine; + } + } + + *p3Ptr = *p1Ptr; + dx = p2Ptr->x - p1Ptr->x; + dy = p2Ptr->y - p1Ptr->y; + if (dy < 0) { + dyNeg = 1; + dy = -dy; + } else { + dyNeg = 0; + } + if (dx < 0) { + dxNeg = 1; + dx = -dx; + } else { + dxNeg = 0; + } + if (dy <= dx) { + dy = ((distance * shiftTable[(dy<<7)/dx]) + 64) >> 7; + if (!dxNeg) { + dy = -dy; + } + p3Ptr->y += dy; + } else { + dx = ((distance * shiftTable[(dx<<7)/dy]) + 64) >> 7; + if (dyNeg) { + dx = -dx; + } + p3Ptr->x += dx; + } +} + +/* + *-------------------------------------------------------------- + * + * Intersect -- + * + * Find the intersection point between two lines. + * + * Results: + * Under normal conditions 0 is returned and the point + * at *iPtr is filled in with the intersection between + * the two lines. If the two lines are parallel, then + * -1 is returned and *iPtr isn't modified. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static int +Intersect(a1Ptr, a2Ptr, b1Ptr, b2Ptr, iPtr) + XPoint *a1Ptr; /* First point of first line. */ + XPoint *a2Ptr; /* Second point of first line. */ + XPoint *b1Ptr; /* First point of second line. */ + XPoint *b2Ptr; /* Second point of second line. */ + XPoint *iPtr; /* Filled in with intersection point. */ +{ + int dxadyb, dxbdya, dxadxb, dyadyb, p, q; + + /* + * The code below is just a straightforward manipulation of two + * equations of the form y = (x-x1)*(y2-y1)/(x2-x1) + y1 to solve + * for the x-coordinate of intersection, then the y-coordinate. + */ + + dxadyb = (a2Ptr->x - a1Ptr->x)*(b2Ptr->y - b1Ptr->y); + dxbdya = (b2Ptr->x - b1Ptr->x)*(a2Ptr->y - a1Ptr->y); + dxadxb = (a2Ptr->x - a1Ptr->x)*(b2Ptr->x - b1Ptr->x); + dyadyb = (a2Ptr->y - a1Ptr->y)*(b2Ptr->y - b1Ptr->y); + + if (dxadyb == dxbdya) { + return -1; + } + p = (a1Ptr->x*dxbdya - b1Ptr->x*dxadyb + (b1Ptr->y - a1Ptr->y)*dxadxb); + q = dxbdya - dxadyb; + if (q < 0) { + p = -p; + q = -q; + } + if (p < 0) { + iPtr->x = - ((-p + q/2)/q); + } else { + iPtr->x = (p + q/2)/q; + } + p = (a1Ptr->y*dxadyb - b1Ptr->y*dxbdya + (b1Ptr->x - a1Ptr->x)*dyadyb); + q = dxadyb - dxbdya; + if (q < 0) { + p = -p; + q = -q; + } + if (p < 0) { + iPtr->y = - ((-p + q/2)/q); + } else { + iPtr->y = (p + q/2)/q; + } + return 0; +} diff --git a/generic/tk3d.h b/generic/tk3d.h new file mode 100644 index 0000000..cd9ecd5 --- /dev/null +++ b/generic/tk3d.h @@ -0,0 +1,79 @@ +/* + * tk3d.h -- + * + * Declarations of types and functions shared by the 3d border + * module. + * + * Copyright (c) 1996 by Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tk3d.h 1.1 96/11/04 13:52:59 + */ + +#ifndef _TK3D +#define _TK3D + +#include + +/* + * 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 { + Screen *screen; /* Screen on which the border will be used. */ + Visual *visual; /* Visual for all windows and pixmaps using + * the border. */ + int depth; /* Number of bits per pixel of drawables where + * the border will be used. */ + Colormap colormap; /* Colormap out of which pixels are + * allocated. */ + int refCount; /* Number of different users of + * this border. */ + XColor *bgColorPtr; /* Background color (intensity + * between lightColorPtr and + * darkColorPtr). */ + XColor *darkColorPtr; /* Color for darker areas (must free when + * deleting structure). NULL means shadows + * haven't been allocated yet.*/ + XColor *lightColorPtr; /* Color used for lighter areas of border + * (must free this when deleting structure). + * NULL means shadows haven't been allocated + * yet. */ + Pixmap shadow; /* Stipple pattern to use for drawing + * shadows areas. Used for displays with + * <= 64 colors or where colormap has filled + * up. */ + GC bgGC; /* Used (if necessary) to draw areas in + * the background color. */ + GC darkGC; /* Used to draw darker parts of the + * border. None means the shadow colors + * haven't been allocated yet.*/ + GC lightGC; /* Used to draw lighter parts of + * the border. None means the shadow colors + * haven't been allocated yet. */ + Tcl_HashEntry *hashPtr; /* Entry in borderTable (needed in + * order to delete structure). */ +} TkBorder; + + +/* + * Maximum intensity for a color: + */ + +#define MAX_INTENSITY 65535 + +/* + * Declarations for platform specific interfaces used by this module. + */ + +EXTERN TkBorder * TkpGetBorder _ANSI_ARGS_((void)); +EXTERN void TkpGetShadows _ANSI_ARGS_((TkBorder *borderPtr, + Tk_Window tkwin)); +EXTERN void TkpFreeBorder _ANSI_ARGS_((TkBorder *borderPtr)); + +#endif /* _TK3D */ diff --git a/generic/tkArgv.c b/generic/tkArgv.c new file mode 100644 index 0000000..5842687 --- /dev/null +++ b/generic/tkArgv.c @@ -0,0 +1,433 @@ +/* + * tkArgv.c -- + * + * This file contains a procedure that handles table-based + * argv-argc parsing. + * + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994 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 + */ + +#include "tkPort.h" +#include "tk.h" + +/* + * Default table of argument descriptors. These are normally available + * in every application. + */ + +static Tk_ArgvInfo defaultTable[] = { + {"-help", TK_ARGV_HELP, (char *) NULL, (char *) NULL, + "Print summary of command-line options and abort"}, + {NULL, TK_ARGV_END, (char *) NULL, (char *) NULL, + (char *) NULL} +}; + +/* + * Forward declarations for procedures defined in this file: + */ + +static void PrintUsage _ANSI_ARGS_((Tcl_Interp *interp, + Tk_ArgvInfo *argTable, int flags)); + +/* + *---------------------------------------------------------------------- + * + * Tk_ParseArgv -- + * + * Process an argv array according to a table of expected + * command-line options. See the manual page for more details. + * + * Results: + * The return value is a standard Tcl return value. If an + * error occurs then an error message is left in interp->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 + * argument). + * + * Side effects: + * Variables may be modified, resources may be entered for tkwin, + * or procedures may be called. It all depends on the arguments + * and their entries in argTable. See the user documentation + * for details. + * + *---------------------------------------------------------------------- + */ + +int +Tk_ParseArgv(interp, tkwin, argcPtr, argv, argTable, flags) + Tcl_Interp *interp; /* Place to store error message. */ + Tk_Window tkwin; /* Window to use for setting Tk options. + * NULL means ignore Tk option specs. */ + int *argcPtr; /* Number of arguments in argv. Modified + * to hold # args left in argv at end. */ + char **argv; /* Array of arguments. Modified to hold + * those that couldn't be processed here. */ + Tk_ArgvInfo *argTable; /* Array of option descriptions */ + int flags; /* Or'ed combination of various flag bits, + * such as TK_ARGV_NO_DEFAULTS. */ +{ + register Tk_ArgvInfo *infoPtr; + /* Pointer to the current entry in the + * table of argument descriptions. */ + Tk_ArgvInfo *matchPtr; /* Descriptor that matches current argument. */ + char *curArg; /* Current argument */ + register char c; /* Second character of current arg (used for + * quick check for matching; use 2nd char. + * because first char. will almost always + * be '-'). */ + int srcIndex; /* Location from which to read next argument + * from argv. */ + int dstIndex; /* Index into argv to which next unused + * argument should be copied (never greater + * than srcIndex). */ + int argc; /* # arguments in argv still to process. */ + size_t length; /* Number of characters in current argument. */ + int i; + + if (flags & TK_ARGV_DONT_SKIP_FIRST_ARG) { + srcIndex = dstIndex = 0; + argc = *argcPtr; + } else { + srcIndex = dstIndex = 1; + argc = *argcPtr-1; + } + + while (argc > 0) { + curArg = argv[srcIndex]; + srcIndex++; + argc--; + length = strlen(curArg); + if (length > 0) { + c = curArg[1]; + } else { + c = 0; + } + + /* + * Loop throught the argument descriptors searching for one with + * the matching key string. If found, leave a pointer to it in + * matchPtr. + */ + + matchPtr = NULL; + for (i = 0; i < 2; i++) { + if (i == 0) { + infoPtr = argTable; + } else { + infoPtr = defaultTable; + } + for (; (infoPtr != NULL) && (infoPtr->type != TK_ARGV_END); + infoPtr++) { + if (infoPtr->key == NULL) { + continue; + } + if ((infoPtr->key[1] != c) + || (strncmp(infoPtr->key, curArg, length) != 0)) { + continue; + } + if ((tkwin == NULL) + && ((infoPtr->type == TK_ARGV_CONST_OPTION) + || (infoPtr->type == TK_ARGV_OPTION_VALUE) + || (infoPtr->type == TK_ARGV_OPTION_NAME_VALUE))) { + continue; + } + if (infoPtr->key[length] == 0) { + matchPtr = infoPtr; + goto gotMatch; + } + if (flags & TK_ARGV_NO_ABBREV) { + continue; + } + if (matchPtr != NULL) { + Tcl_AppendResult(interp, "ambiguous option \"", curArg, + "\"", (char *) NULL); + return TCL_ERROR; + } + matchPtr = infoPtr; + } + } + if (matchPtr == NULL) { + + /* + * Unrecognized argument. Just copy it down, unless the caller + * prefers an error to be registered. + */ + + if (flags & TK_ARGV_NO_LEFTOVERS) { + Tcl_AppendResult(interp, "unrecognized argument \"", + curArg, "\"", (char *) NULL); + return TCL_ERROR; + } + argv[dstIndex] = curArg; + dstIndex++; + continue; + } + + /* + * Take the appropriate action based on the option type + */ + + gotMatch: + infoPtr = matchPtr; + switch (infoPtr->type) { + case TK_ARGV_CONSTANT: + *((int *) infoPtr->dst) = (int) infoPtr->src; + break; + case TK_ARGV_INT: + if (argc == 0) { + goto missingArg; + } else { + char *endPtr; + + *((int *) infoPtr->dst) = + strtol(argv[srcIndex], &endPtr, 0); + if ((endPtr == argv[srcIndex]) || (*endPtr != 0)) { + Tcl_AppendResult(interp, "expected integer argument ", + "for \"", infoPtr->key, "\" but got \"", + argv[srcIndex], "\"", (char *) NULL); + return TCL_ERROR; + } + srcIndex++; + argc--; + } + break; + case TK_ARGV_STRING: + if (argc == 0) { + goto missingArg; + } else { + *((char **)infoPtr->dst) = argv[srcIndex]; + srcIndex++; + argc--; + } + break; + case TK_ARGV_UID: + if (argc == 0) { + goto missingArg; + } else { + *((Tk_Uid *)infoPtr->dst) = Tk_GetUid(argv[srcIndex]); + srcIndex++; + argc--; + } + break; + case TK_ARGV_REST: + *((int *) infoPtr->dst) = dstIndex; + goto argsDone; + case TK_ARGV_FLOAT: + if (argc == 0) { + goto missingArg; + } else { + char *endPtr; + + *((double *) infoPtr->dst) = + strtod(argv[srcIndex], &endPtr); + if ((endPtr == argv[srcIndex]) || (*endPtr != 0)) { + Tcl_AppendResult(interp, "expected floating-point ", + "argument for \"", infoPtr->key, + "\" but got \"", argv[srcIndex], "\"", + (char *) NULL); + return TCL_ERROR; + } + srcIndex++; + argc--; + } + break; + case TK_ARGV_FUNC: { + typedef int (ArgvFunc)_ANSI_ARGS_((char *, char *, char *)); + ArgvFunc *handlerProc; + + handlerProc = (ArgvFunc *) infoPtr->src; + if ((*handlerProc)(infoPtr->dst, infoPtr->key, + argv[srcIndex])) { + srcIndex += 1; + argc -= 1; + } + break; + } + case TK_ARGV_GENFUNC: { + typedef int (ArgvGenFunc)_ANSI_ARGS_((char *, Tcl_Interp *, + char *, int, char **)); + ArgvGenFunc *handlerProc; + + handlerProc = (ArgvGenFunc *) infoPtr->src; + argc = (*handlerProc)(infoPtr->dst, interp, infoPtr->key, + argc, argv+srcIndex); + if (argc < 0) { + return TCL_ERROR; + } + break; + } + case TK_ARGV_HELP: + PrintUsage (interp, argTable, flags); + return TCL_ERROR; + case TK_ARGV_CONST_OPTION: + Tk_AddOption(tkwin, infoPtr->dst, infoPtr->src, + TK_INTERACTIVE_PRIO); + break; + case TK_ARGV_OPTION_VALUE: + if (argc < 1) { + goto missingArg; + } + Tk_AddOption(tkwin, infoPtr->dst, argv[srcIndex], + TK_INTERACTIVE_PRIO); + srcIndex++; + argc--; + break; + case TK_ARGV_OPTION_NAME_VALUE: + if (argc < 2) { + Tcl_AppendResult(interp, "\"", curArg, + "\" option requires two following arguments", + (char *) NULL); + return TCL_ERROR; + } + Tk_AddOption(tkwin, argv[srcIndex], argv[srcIndex+1], + TK_INTERACTIVE_PRIO); + srcIndex += 2; + argc -= 2; + break; + default: + sprintf(interp->result, "bad argument type %d in Tk_ArgvInfo", + infoPtr->type); + return TCL_ERROR; + } + } + + /* + * If we broke out of the loop because of an OPT_REST argument, + * copy the remaining arguments down. + */ + + argsDone: + while (argc) { + argv[dstIndex] = argv[srcIndex]; + srcIndex++; + dstIndex++; + argc--; + } + argv[dstIndex] = (char *) NULL; + *argcPtr = dstIndex; + return TCL_OK; + + missingArg: + Tcl_AppendResult(interp, "\"", curArg, + "\" option requires an additional argument", (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * PrintUsage -- + * + * Generate a help string describing command-line options. + * + * Results: + * Interp->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. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +PrintUsage(interp, argTable, flags) + Tcl_Interp *interp; /* Place information in this interp's + * result area. */ + Tk_ArgvInfo *argTable; /* Array of command-specific argument + * descriptions. */ + int flags; /* If the TK_ARGV_NO_DEFAULTS bit is set + * in this word, then don't generate + * information for default options. */ +{ + register Tk_ArgvInfo *infoPtr; + int width, i, numSpaces; +#define NUM_SPACES 20 + static char spaces[] = " "; + char tmp[30]; + + /* + * First, compute the width of the widest option key, so that we + * can make everything line up. + */ + + width = 4; + for (i = 0; i < 2; i++) { + for (infoPtr = i ? defaultTable : argTable; + infoPtr->type != TK_ARGV_END; infoPtr++) { + int length; + if (infoPtr->key == NULL) { + continue; + } + length = strlen(infoPtr->key); + if (length > width) { + width = length; + } + } + } + + Tcl_AppendResult(interp, "Command-specific options:", (char *) NULL); + for (i = 0; ; i++) { + for (infoPtr = i ? defaultTable : argTable; + infoPtr->type != TK_ARGV_END; infoPtr++) { + if ((infoPtr->type == TK_ARGV_HELP) && (infoPtr->key == NULL)) { + Tcl_AppendResult(interp, "\n", infoPtr->help, (char *) NULL); + continue; + } + Tcl_AppendResult(interp, "\n ", infoPtr->key, ":", (char *) NULL); + numSpaces = width + 1 - strlen(infoPtr->key); + while (numSpaces > 0) { + if (numSpaces >= NUM_SPACES) { + Tcl_AppendResult(interp, spaces, (char *) NULL); + } else { + Tcl_AppendResult(interp, spaces+NUM_SPACES-numSpaces, + (char *) NULL); + } + numSpaces -= NUM_SPACES; + } + Tcl_AppendResult(interp, infoPtr->help, (char *) NULL); + switch (infoPtr->type) { + case TK_ARGV_INT: { + sprintf(tmp, "%d", *((int *) infoPtr->dst)); + Tcl_AppendResult(interp, "\n\t\tDefault value: ", + tmp, (char *) NULL); + break; + } + case TK_ARGV_FLOAT: { + sprintf(tmp, "%g", *((double *) infoPtr->dst)); + Tcl_AppendResult(interp, "\n\t\tDefault value: ", + tmp, (char *) NULL); + break; + } + case TK_ARGV_STRING: { + char *string; + + string = *((char **) infoPtr->dst); + if (string != NULL) { + Tcl_AppendResult(interp, "\n\t\tDefault value: \"", + string, "\"", (char *) NULL); + } + break; + } + default: { + break; + } + } + } + + if ((flags & TK_ARGV_NO_DEFAULTS) || (i > 0)) { + break; + } + Tcl_AppendResult(interp, "\nGeneric options for all commands:", + (char *) NULL); + } +} diff --git a/generic/tkAtom.c b/generic/tkAtom.c new file mode 100644 index 0000000..9d35f6b --- /dev/null +++ b/generic/tkAtom.c @@ -0,0 +1,217 @@ +/* + * tkAtom.c -- + * + * This file manages a cache of X Atoms in order to avoid + * interactions with the X server. It's much like the Xmu + * routines, except it has a cleaner interface (caller + * doesn't have to provide permanent storage for atom names, + * for example). + * + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994 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: @(#) tkAtom.c 1.13 96/02/15 18:51:34 + */ + +#include "tkPort.h" +#include "tkInt.h" + +/* + * The following are a list of the predefined atom strings. + * They should match those found in xatom.h + */ + +static char * atomNameArray[] = { + "PRIMARY", "SECONDARY", "ARC", + "ATOM", "BITMAP", "CARDINAL", + "COLORMAP", "CURSOR", "CUT_BUFFER0", + "CUT_BUFFER1", "CUT_BUFFER2", "CUT_BUFFER3", + "CUT_BUFFER4", "CUT_BUFFER5", "CUT_BUFFER6", + "CUT_BUFFER7", "DRAWABLE", "FONT", + "INTEGER", "PIXMAP", "POINT", + "RECTANGLE", "RESOURCE_MANAGER", "RGB_COLOR_MAP", + "RGB_BEST_MAP", "RGB_BLUE_MAP", "RGB_DEFAULT_MAP", + "RGB_GRAY_MAP", "RGB_GREEN_MAP", "RGB_RED_MAP", + "STRING", "VISUALID", "WINDOW", + "WM_COMMAND", "WM_HINTS", "WM_CLIENT_MACHINE", + "WM_ICON_NAME", "WM_ICON_SIZE", "WM_NAME", + "WM_NORMAL_HINTS", "WM_SIZE_HINTS", "WM_ZOOM_HINTS", + "MIN_SPACE", "NORM_SPACE", "MAX_SPACE", + "END_SPACE", "SUPERSCRIPT_X", "SUPERSCRIPT_Y", + "SUBSCRIPT_X", "SUBSCRIPT_Y", "UNDERLINE_POSITION", + "UNDERLINE_THICKNESS", "STRIKEOUT_ASCENT", "STRIKEOUT_DESCENT", + "ITALIC_ANGLE", "X_HEIGHT", "QUAD_WIDTH", + "WEIGHT", "POINT_SIZE", "RESOLUTION", + "COPYRIGHT", "NOTICE", "FONT_NAME", + "FAMILY_NAME", "FULL_NAME", "CAP_HEIGHT", + "WM_CLASS", "WM_TRANSIENT_FOR", + (char *) NULL +}; + +/* + * Forward references to procedures defined in this file: + */ + +static void AtomInit _ANSI_ARGS_((TkDisplay *dispPtr)); + +/* + *-------------------------------------------------------------- + * + * Tk_InternAtom -- + * + * Given a string, produce the equivalent X atom. This + * procedure is equivalent to XInternAtom, except that it + * keeps a local cache of atoms. Once a name is known, + * the server need not be contacted again for that name. + * + * Results: + * The return value is the Atom corresponding to name. + * + * Side effects: + * A new entry may be added to the local atom cache. + * + *-------------------------------------------------------------- + */ + +Atom +Tk_InternAtom(tkwin, name) + Tk_Window tkwin; /* Window token; map name to atom + * for this window's display. */ + char *name; /* Name to turn into atom. */ +{ + register TkDisplay *dispPtr; + register Tcl_HashEntry *hPtr; + int new; + + dispPtr = ((TkWindow *) tkwin)->dispPtr; + if (!dispPtr->atomInit) { + AtomInit(dispPtr); + } + + hPtr = Tcl_CreateHashEntry(&dispPtr->nameTable, name, &new); + if (new) { + Tcl_HashEntry *hPtr2; + Atom atom; + + atom = XInternAtom(dispPtr->display, name, False); + Tcl_SetHashValue(hPtr, atom); + hPtr2 = Tcl_CreateHashEntry(&dispPtr->atomTable, (char *) atom, + &new); + Tcl_SetHashValue(hPtr2, Tcl_GetHashKey(&dispPtr->nameTable, hPtr)); + } + return (Atom) Tcl_GetHashValue(hPtr); +} + +/* + *-------------------------------------------------------------- + * + * Tk_GetAtomName -- + * + * This procedure is equivalent to XGetAtomName except that + * it uses the local atom cache to avoid contacting the + * server. + * + * Results: + * The return value is a character string corresponding to + * the atom given by "atom". This string's storage space + * is static: it need not be freed by the caller, and should + * not be modified by the caller. If "atom" doesn't exist + * on tkwin's display, then the string "?bad atom?" is returned. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +char * +Tk_GetAtomName(tkwin, atom) + Tk_Window tkwin; /* Window token; map atom to name + * relative to this window's + * display. */ + Atom atom; /* Atom whose name is wanted. */ +{ + register TkDisplay *dispPtr; + register Tcl_HashEntry *hPtr; + + dispPtr = ((TkWindow *) tkwin)->dispPtr; + if (!dispPtr->atomInit) { + AtomInit(dispPtr); + } + + hPtr = Tcl_FindHashEntry(&dispPtr->atomTable, (char *) atom); + if (hPtr == NULL) { + char *name; + Tk_ErrorHandler handler; + int new, mustFree; + + handler= Tk_CreateErrorHandler(dispPtr->display, BadAtom, + -1, -1, (Tk_ErrorProc *) NULL, (ClientData) NULL); + name = XGetAtomName(dispPtr->display, atom); + mustFree = 1; + if (name == NULL) { + name = "?bad atom?"; + mustFree = 0; + } + Tk_DeleteErrorHandler(handler); + hPtr = Tcl_CreateHashEntry(&dispPtr->nameTable, (char *) name, + &new); + Tcl_SetHashValue(hPtr, atom); + if (mustFree) { + XFree(name); + } + name = Tcl_GetHashKey(&dispPtr->nameTable, hPtr); + hPtr = Tcl_CreateHashEntry(&dispPtr->atomTable, (char *) atom, + &new); + Tcl_SetHashValue(hPtr, name); + } + return (char *) Tcl_GetHashValue(hPtr); +} + +/* + *-------------------------------------------------------------- + * + * AtomInit -- + * + * Initialize atom-related information for a display. + * + * Results: + * None. + * + * Side effects: + * Tables get initialized, etc. etc.. + * + *-------------------------------------------------------------- + */ + +static void +AtomInit(dispPtr) + register TkDisplay *dispPtr; /* Display to initialize. */ +{ + Tcl_HashEntry *hPtr; + Atom atom; + + dispPtr->atomInit = 1; + Tcl_InitHashTable(&dispPtr->nameTable, TCL_STRING_KEYS); + Tcl_InitHashTable(&dispPtr->atomTable, TCL_ONE_WORD_KEYS); + + for (atom = 1; atom <= XA_LAST_PREDEFINED; atom++) { + hPtr = Tcl_FindHashEntry(&dispPtr->atomTable, (char *) atom); + if (hPtr == NULL) { + char *name; + int new; + + name = atomNameArray[atom - 1]; + hPtr = Tcl_CreateHashEntry(&dispPtr->nameTable, (char *) name, + &new); + Tcl_SetHashValue(hPtr, atom); + name = Tcl_GetHashKey(&dispPtr->nameTable, hPtr); + hPtr = Tcl_CreateHashEntry(&dispPtr->atomTable, (char *) atom, + &new); + Tcl_SetHashValue(hPtr, name); + } + } +} diff --git a/generic/tkBind.c b/generic/tkBind.c new file mode 100644 index 0000000..bb37b00 --- /dev/null +++ b/generic/tkBind.c @@ -0,0 +1,4533 @@ +/* + * tkBind.c -- + * + * This file provides procedures that associate Tcl commands + * 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. + * + * 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 + */ + +#include "tkPort.h" +#include "tkInt.h" + +/* + * File structure: + * + * Structure definitions and static variables. + * + * Init/Free this package. + * + * Tcl "bind" command (actually located in tkCmds.c). + * "bind" command implementation. + * "bind" implementation helpers. + * + * Tcl "event" command. + * "event" command implementation. + * "event" implementation helpers. + * + * Package-specific common helpers. + * + * Non-package-specific helpers. + */ + + +/* + * The following union is used to hold the detail information from an + * XEvent (including Tk's XVirtualEvent extension). + */ +typedef union { + KeySym keySym; /* KeySym that corresponds to xkey.keycode. */ + int button; /* Button that was pressed (xbutton.button). */ + Tk_Uid name; /* Tk_Uid of virtual event. */ + ClientData clientData; /* Used when type of Detail is unknown, and to + * ensure that all bytes of Detail are initialized + * when this structure is used in a hash key. */ +} Detail; + +/* + * The structure below represents a binding table. A binding table + * represents a domain in which event bindings may occur. It includes + * a space of objects relative to which events occur (usually windows, + * but not always), a history of recent events in the domain, and + * a set of mappings that associate particular Tcl commands with sequences + * of events in the domain. Multiple binding tables may exist at once, + * either because there are multiple applications open, or because there + * are multiple domains within an application with separate event + * bindings for each (for example, each canvas widget has a separate + * binding table for associating events with the items in the canvas). + * + * Note: it is probably a bad idea to reduce EVENT_BUFFER_SIZE much + * below 30. To see this, consider a triple mouse button click while + * the Shift key is down (and auto-repeating). There may be as many + * as 3 auto-repeat events after each mouse button press or release + * (see the first large comment block within Tk_BindEvent for more on + * this), for a total of 20 events to cover the three button presses + * and two intervening releases. If you reduce EVENT_BUFFER_SIZE too + * much, shift multi-clicks will be lost. + * + */ + +#define EVENT_BUFFER_SIZE 30 +typedef struct BindingTable { + XEvent eventRing[EVENT_BUFFER_SIZE];/* Circular queue of recent events + * (higher indices are for more recent + * events). */ + Detail detailRing[EVENT_BUFFER_SIZE];/* "Detail" information (keySym, + * button, Tk_Uid, or 0) for each + * entry in eventRing. */ + int curEvent; /* Index in eventRing of most recent + * event. Newer events have higher + * indices. */ + Tcl_HashTable patternTable; /* Used to map from an event to a + * list of patterns that may match that + * event. Keys are PatternTableKey + * structs, values are (PatSeq *). */ + Tcl_HashTable objectTable; /* Used to map from an object to a + * list of patterns associated with + * that object. Keys are ClientData, + * values are (PatSeq *). */ + Tcl_Interp *interp; /* Interpreter in which commands are + * executed. */ +} BindingTable; + +/* + * The following structure represents virtual event table. A virtual event + * table provides a way to map from platform-specific physical events such + * as button clicks or key presses to virtual events such as <>, + * <>, or <>. + * + * A virtual event is usually never part of the event stream, but instead is + * synthesized inline by matching low-level events. However, a virtual + * event may be generated by platform-specific code or by Tcl scripts. In + * that case, no lookup of the virtual event will need to be done using + * this table, because the virtual event is actually in the event stream. + */ + +typedef struct VirtualEventTable { + Tcl_HashTable patternTable; /* Used to map from a physical event to + * a list of patterns that may match that + * event. Keys are PatternTableKey + * structs, values are (PatSeq *). */ + Tcl_HashTable nameTable; /* Used to map a virtual event name to + * the array of physical events that can + * trigger it. Keys are the Tk_Uid names + * of the virtual events, values are + * PhysicalsOwned structs. */ +} VirtualEventTable; + +/* + * The following structure is used as a key in a patternTable for both + * binding tables and a virtual event tables. + * + * In a binding table, the object field corresponds to the binding tag + * for the widget whose bindings are being accessed. + * + * In a virtual event table, the object field is always NULL. Virtual + * events are a global definiton and are not tied to a particular + * binding tag. + * + * The same key is used for both types of pattern tables so that the + * helper functions that traverse and match patterns will work for both + * binding tables and virtual event tables. + */ +typedef struct PatternTableKey { + ClientData object; /* For binding table, identifies the binding + * tag of the object (or class of objects) + * relative to which the event occurred. + * For virtual event table, always NULL. */ + int type; /* Type of event (from X). */ + Detail detail; /* Additional information, such as keysym, + * button, Tk_Uid, or 0 if nothing + * additional. */ +} PatternTableKey; + +/* + * The following structure defines a pattern, which is matched against X + * events as part of the process of converting X events into Tcl commands. + */ + +typedef struct Pattern { + int eventType; /* Type of X event, e.g. ButtonPress. */ + int needMods; /* Mask of modifiers that must be + * present (0 means no modifiers are + * required). */ + Detail detail; /* Additional information that must + * match event. Normally this is 0, + * meaning no additional information + * must match. For KeyPress and + * KeyRelease events, a keySym may + * be specified to select a + * particular keystroke (0 means any + * keystrokes). For button events, + * specifies a particular button (0 + * means any buttons are OK). For virtual + * events, specifies the Tk_Uid of the + * virtual event name (never 0). */ +} Pattern; + +/* + * The following structure defines a pattern sequence, which consists of one + * or more patterns. In order to trigger, a pattern sequence must match + * the most recent X events (first pattern to most recent event, next + * pattern to next event, and so on). It is used as the hash value in a + * patternTable for both binding tables and virtual event tables. + * + * In a binding table, it is the sequence of physical events that make up + * a binding for an object. + * + * In a virtual event table, it is the sequence of physical events that + * define a virtual event. + * + * The same structure is used for both types of pattern tables so that the + * helper functions that traverse and match patterns will work for both + * binding tables and virtual event tables. + */ + +typedef struct PatSeq { + int numPats; /* Number of patterns in sequence (usually + * 1). */ + TkBindEvalProc *eventProc; /* The procedure that will be invoked on + * the clientData when this pattern sequence + * matches. */ + TkBindFreeProc *freeProc; /* The procedure that will be invoked to + * release the clientData when this pattern + * sequence is freed. */ + ClientData clientData; /* Arbitray data passed to eventProc and + * freeProc when sequence matches. */ + int flags; /* Miscellaneous flag values; see below for + * definitions. */ + int refCount; /* Number of times that this binding is in + * the midst of executing. If greater than 1, + * then a recursive invocation is happening. + * Only when this is zero can the binding + * actually be freed. */ + struct PatSeq *nextSeqPtr; /* Next in list of all pattern sequences + * that have the same initial pattern. NULL + * means end of list. */ + Tcl_HashEntry *hPtr; /* Pointer to hash table entry for the + * initial pattern. This is the head of the + * list of which nextSeqPtr forms a part. */ + struct VirtualOwners *voPtr;/* In a binding table, always NULL. In a + * virtual event table, identifies the array + * of virtual events that can be triggered by + * this event. */ + struct PatSeq *nextObjPtr; /* In a binding table, next in list of all + * pattern sequences for the same object (NULL + * for end of list). Needed to implement + * Tk_DeleteAllBindings. In a virtual event + * table, always NULL. */ + Pattern pats[1]; /* Array of "numPats" patterns. Only one + * element is declared here but in actuality + * enough space will be allocated for "numPats" + * patterns. To match, pats[0] must match + * event n, pats[1] must match event n-1, etc. + */ +} PatSeq; + +/* + * Flag values for PatSeq structures: + * + * PAT_NEARBY 1 means that all of the events matching + * this sequence must occur with nearby X + * and Y mouse coordinates and close in time. + * This is typically used to restrict multiple + * button presses. + * MARKED_DELETED 1 means that this binding has been marked as deleted + * and removed from the binding table, but its memory + * could not be released because it was already queued for + * execution. When the binding is actually about to be + * executed, this flag will be checked and the binding + * skipped if set. + */ + +#define PAT_NEARBY 0x1 +#define MARKED_DELETED 0x2 + +/* + * Constants that define how close together two events must be + * in milliseconds or pixels to meet the PAT_NEARBY constraint: + */ + +#define NEARBY_PIXELS 5 +#define NEARBY_MS 500 + + +/* + * The following structure keeps track of all the virtual events that are + * associated with a particular physical event. It is pointed to by the + * voPtr field in a PatSeq in the patternTable of a virtual event table. + */ + +typedef struct VirtualOwners { + int numOwners; /* Number of virtual events to trigger. */ + Tcl_HashEntry *owners[1]; /* Array of pointers to entries in + * nameTable. Enough space will + * actually be allocated for numOwners + * hash entries. */ +} VirtualOwners; + +/* + * The following structure is used in the nameTable of a virtual event + * table to associate a virtual event with all the physical events that can + * trigger it. + */ +typedef struct PhysicalsOwned { + int numOwned; /* Number of physical events owned. */ + PatSeq *patSeqs[1]; /* Array of pointers to physical event + * patterns. Enough space will actually + * be allocated to hold numOwned. */ +} PhysicalsOwned; + +/* + * One of the following structures exists for each interpreter. This + * structure keeps track of the current display and screen in the + * interpreter, so that a script can be invoked whenever the display/screen + * changes (the script does things like point tkPriv at a display-specific + * structure). + */ + +typedef struct { + TkDisplay *curDispPtr; /* Display for last binding command invoked + * in this application. */ + int curScreenIndex; /* Index of screen for last binding command. */ + int bindingDepth; /* Number of active instances of Tk_BindEvent + * in this application. */ +} ScreenInfo; + +/* + * The following structure is used to keep track of all the C bindings that + * are awaiting invocation and whether the window they refer to has been + * destroyed. If the window is destroyed, then all pending callbacks for + * that window will be cancelled. The Tcl bindings will still all be + * invoked, however. + */ + +typedef struct PendingBinding { + struct PendingBinding *nextPtr; + /* Next in chain of pending bindings, in + * case a recursive binding evaluation is in + * progress. */ + Tk_Window tkwin; /* The window that the following bindings + * depend upon. */ + int deleted; /* Set to non-zero by window cleanup code + * if tkwin is deleted. */ + PatSeq *matchArray[5]; /* Array of pending C bindings. The actual + * size of this depends on how many C bindings + * matched the event passed to Tk_BindEvent. + * THIS FIELD MUST BE THE LAST IN THE + * STRUCTURE. */ +} PendingBinding; + +/* + * The following structure keeps track of all the information local to + * the binding package on a per interpreter basis. + */ + +typedef struct BindInfo { + VirtualEventTable virtualEventTable; + /* The virtual events that exist in this + * interpreter. */ + ScreenInfo screenInfo; /* Keeps track of the current display and + * screen, so it can be restored after + * a binding has executed. */ + PendingBinding *pendingList;/* The list of pending C bindings, kept in + * case a C or Tcl binding causes the target + * window to be deleted. */ +} BindInfo; + +/* + * In X11R4 and earlier versions, XStringToKeysym is ridiculously + * slow. The data structure and hash table below, along with the + * code that uses them, implement a fast mapping from strings to + * keysyms. In X11R5 and later releases XStringToKeysym is plenty + * fast so this stuff isn't needed. The #define REDO_KEYSYM_LOOKUP + * is normally undefined, so that XStringToKeysym gets used. It + * can be set in the Makefile to enable the use of the hash table + * below. + */ + +#ifdef REDO_KEYSYM_LOOKUP +typedef struct { + char *name; /* Name of keysym. */ + KeySym value; /* Numeric identifier for keysym. */ +} KeySymInfo; +static KeySymInfo keyArray[] = { +#ifndef lint +#include "ks_names.h" +#endif + {(char *) NULL, 0} +}; +static Tcl_HashTable keySymTable; /* keyArray hashed by keysym value. */ +static Tcl_HashTable nameTable; /* keyArray hashed by keysym name. */ +#endif /* REDO_KEYSYM_LOOKUP */ + +/* + * Set to non-zero when the package-wide static variables have been + * initialized. + */ + +static int initialized = 0; + +/* + * A hash table is kept to map from the string names of event + * modifiers to information about those modifiers. The structure + * for storing this information, and the hash table built at + * initialization time, are defined below. + */ + +typedef struct { + char *name; /* Name of modifier. */ + int mask; /* Button/modifier mask value, * such as Button1Mask. */ + int flags; /* Various flags; see below for + * definitions. */ +} ModInfo; + +/* + * Flags for ModInfo structures: + * + * DOUBLE - Non-zero means duplicate this event, + * e.g. for double-clicks. + * TRIPLE - Non-zero means triplicate this event, + * e.g. for triple-clicks. + */ + +#define DOUBLE 1 +#define TRIPLE 2 + +/* + * The following special modifier mask bits are defined, to indicate + * logical modifiers such as Meta and Alt that may float among the + * actual modifier bits. + */ + +#define META_MASK (AnyModifier<<1) +#define ALT_MASK (AnyModifier<<2) + +static ModInfo modArray[] = { + {"Control", ControlMask, 0}, + {"Shift", ShiftMask, 0}, + {"Lock", LockMask, 0}, + {"Meta", META_MASK, 0}, + {"M", META_MASK, 0}, + {"Alt", ALT_MASK, 0}, + {"B1", Button1Mask, 0}, + {"Button1", Button1Mask, 0}, + {"B2", Button2Mask, 0}, + {"Button2", Button2Mask, 0}, + {"B3", Button3Mask, 0}, + {"Button3", Button3Mask, 0}, + {"B4", Button4Mask, 0}, + {"Button4", Button4Mask, 0}, + {"B5", Button5Mask, 0}, + {"Button5", Button5Mask, 0}, + {"Mod1", Mod1Mask, 0}, + {"M1", Mod1Mask, 0}, + {"Command", Mod1Mask, 0}, + {"Mod2", Mod2Mask, 0}, + {"M2", Mod2Mask, 0}, + {"Option", Mod2Mask, 0}, + {"Mod3", Mod3Mask, 0}, + {"M3", Mod3Mask, 0}, + {"Mod4", Mod4Mask, 0}, + {"M4", Mod4Mask, 0}, + {"Mod5", Mod5Mask, 0}, + {"M5", Mod5Mask, 0}, + {"Double", 0, DOUBLE}, + {"Triple", 0, TRIPLE}, + {"Any", 0, 0}, /* Ignored: historical relic. */ + {NULL, 0, 0} +}; +static Tcl_HashTable modTable; + +/* + * This module also keeps a hash table mapping from event names + * to information about those events. The structure, an array + * to use to initialize the hash table, and the hash table are + * all defined below. + */ + +typedef struct { + char *name; /* Name of event. */ + int type; /* Event type for X, such as + * ButtonPress. */ + int eventMask; /* Mask bits (for XSelectInput) + * for this event type. */ +} EventInfo; + +/* + * Note: some of the masks below are an OR-ed combination of + * several masks. This is necessary because X doesn't report + * up events unless you also ask for down events. Also, X + * doesn't report button state in motion events unless you've + * asked about button events. + */ + +static EventInfo eventArray[] = { + {"Key", KeyPress, KeyPressMask}, + {"KeyPress", KeyPress, KeyPressMask}, + {"KeyRelease", KeyRelease, KeyPressMask|KeyReleaseMask}, + {"Button", ButtonPress, ButtonPressMask}, + {"ButtonPress", ButtonPress, ButtonPressMask}, + {"ButtonRelease", ButtonRelease, + ButtonPressMask|ButtonReleaseMask}, + {"Motion", MotionNotify, + ButtonPressMask|PointerMotionMask}, + {"Enter", EnterNotify, EnterWindowMask}, + {"Leave", LeaveNotify, LeaveWindowMask}, + {"FocusIn", FocusIn, FocusChangeMask}, + {"FocusOut", FocusOut, FocusChangeMask}, + {"Expose", Expose, ExposureMask}, + {"Visibility", VisibilityNotify, VisibilityChangeMask}, + {"Destroy", DestroyNotify, StructureNotifyMask}, + {"Unmap", UnmapNotify, StructureNotifyMask}, + {"Map", MapNotify, StructureNotifyMask}, + {"Reparent", ReparentNotify, StructureNotifyMask}, + {"Configure", ConfigureNotify, StructureNotifyMask}, + {"Gravity", GravityNotify, StructureNotifyMask}, + {"Circulate", CirculateNotify, StructureNotifyMask}, + {"Property", PropertyNotify, PropertyChangeMask}, + {"Colormap", ColormapNotify, ColormapChangeMask}, + {"Activate", ActivateNotify, ActivateMask}, + {"Deactivate", DeactivateNotify, ActivateMask}, + {(char *) NULL, 0, 0} +}; +static Tcl_HashTable eventTable; + +/* + * The defines and table below are used to classify events into + * various groups. The reason for this is that logically identical + * fields (e.g. "state") appear at different places in different + * types of events. The classification masks can be used to figure + * out quickly where to extract information from events. + */ + +#define KEY 0x1 +#define BUTTON 0x2 +#define MOTION 0x4 +#define CROSSING 0x8 +#define FOCUS 0x10 +#define EXPOSE 0x20 +#define VISIBILITY 0x40 +#define CREATE 0x80 +#define DESTROY 0x100 +#define UNMAP 0x200 +#define MAP 0x400 +#define REPARENT 0x800 +#define CONFIG 0x1000 +#define GRAVITY 0x2000 +#define CIRC 0x4000 +#define PROP 0x8000 +#define COLORMAP 0x10000 +#define VIRTUAL 0x20000 +#define ACTIVATE 0x40000 + +#define KEY_BUTTON_MOTION_VIRTUAL (KEY|BUTTON|MOTION|VIRTUAL) + +static int flagArray[TK_LASTEVENT] = { + /* Not used */ 0, + /* Not used */ 0, + /* KeyPress */ KEY, + /* KeyRelease */ KEY, + /* ButtonPress */ BUTTON, + /* ButtonRelease */ BUTTON, + /* MotionNotify */ MOTION, + /* EnterNotify */ CROSSING, + /* LeaveNotify */ CROSSING, + /* FocusIn */ FOCUS, + /* FocusOut */ FOCUS, + /* KeymapNotify */ 0, + /* Expose */ EXPOSE, + /* GraphicsExpose */ EXPOSE, + /* NoExpose */ 0, + /* VisibilityNotify */ VISIBILITY, + /* CreateNotify */ CREATE, + /* DestroyNotify */ DESTROY, + /* UnmapNotify */ UNMAP, + /* MapNotify */ MAP, + /* MapRequest */ 0, + /* ReparentNotify */ REPARENT, + /* ConfigureNotify */ CONFIG, + /* ConfigureRequest */ 0, + /* GravityNotify */ GRAVITY, + /* ResizeRequest */ 0, + /* CirculateNotify */ CIRC, + /* CirculateRequest */ 0, + /* PropertyNotify */ PROP, + /* SelectionClear */ 0, + /* SelectionRequest */ 0, + /* SelectionNotify */ 0, + /* ColormapNotify */ COLORMAP, + /* ClientMessage */ 0, + /* MappingNotify */ 0, + /* VirtualEvent */ VIRTUAL, + /* Activate */ ACTIVATE, + /* Deactivate */ ACTIVATE +}; + +/* + * 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 + * when providing data from an XEvent to the user. + */ + +static TkStateMap notifyMode[] = { + {NotifyNormal, "NotifyNormal"}, + {NotifyGrab, "NotifyGrab"}, + {NotifyUngrab, "NotifyUngrab"}, + {NotifyWhileGrabbed, "NotifyWhileGrabbed"}, + {-1, NULL} +}; + +static TkStateMap notifyDetail[] = { + {NotifyAncestor, "NotifyAncestor"}, + {NotifyVirtual, "NotifyVirtual"}, + {NotifyInferior, "NotifyInferior"}, + {NotifyNonlinear, "NotifyNonlinear"}, + {NotifyNonlinearVirtual, "NotifyNonlinearVirtual"}, + {NotifyPointer, "NotifyPointer"}, + {NotifyPointerRoot, "NotifyPointerRoot"}, + {NotifyDetailNone, "NotifyDetailNone"}, + {-1, NULL} +}; + +static TkStateMap circPlace[] = { + {PlaceOnTop, "PlaceOnTop"}, + {PlaceOnBottom, "PlaceOnBottom"}, + {-1, NULL} +}; + +static TkStateMap visNotify[] = { + {VisibilityUnobscured, "VisibilityUnobscured"}, + {VisibilityPartiallyObscured, "VisibilityPartiallyObscured"}, + {VisibilityFullyObscured, "VisibilityFullyObscured"}, + {-1, NULL} +}; + +/* + * Prototypes for local procedures defined in this file: + */ + +static void ChangeScreen _ANSI_ARGS_((Tcl_Interp *interp, + char *dispName, int screenIndex)); +static int CreateVirtualEvent _ANSI_ARGS_((Tcl_Interp *interp, + VirtualEventTable *vetPtr, char *virtString, + char *eventString)); +static int DeleteVirtualEvent _ANSI_ARGS_((Tcl_Interp *interp, + VirtualEventTable *vetPtr, char *virtString, + char *eventString)); +static void DeleteVirtualEventTable _ANSI_ARGS_(( + VirtualEventTable *vetPtr)); +static void ExpandPercents _ANSI_ARGS_((TkWindow *winPtr, + char *before, XEvent *eventPtr, KeySym keySym, + Tcl_DString *dsPtr)); +static void FreeTclBinding _ANSI_ARGS_((ClientData clientData)); +static PatSeq * FindSequence _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_HashTable *patternTablePtr, ClientData object, + char *eventString, int create, int allowVirtual, + unsigned long *maskPtr)); +static void GetAllVirtualEvents _ANSI_ARGS_((Tcl_Interp *interp, + VirtualEventTable *vetPtr)); +static char * GetField _ANSI_ARGS_((char *p, char *copy, int size)); +static KeySym GetKeySym _ANSI_ARGS_((TkDisplay *dispPtr, + XEvent *eventPtr)); +static void GetPatternString _ANSI_ARGS_((PatSeq *psPtr, + Tcl_DString *dsPtr)); +static int GetVirtualEvent _ANSI_ARGS_((Tcl_Interp *interp, + VirtualEventTable *vetPtr, char *virtString)); +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)); +static void InitKeymapInfo _ANSI_ARGS_((TkDisplay *dispPtr)); +static void InitVirtualEventTable _ANSI_ARGS_(( + VirtualEventTable *vetPtr)); +static PatSeq * MatchPatterns _ANSI_ARGS_((TkDisplay *dispPtr, + BindingTable *bindPtr, PatSeq *psPtr, + PatSeq *bestPtr, ClientData *objectPtr, + PatSeq **sourcePtrPtr)); +static int ParseEventDescription _ANSI_ARGS_((Tcl_Interp *interp, + char **eventStringPtr, Pattern *patPtr, + unsigned long *eventMaskPtr)); + +/* + * The following define is used as a short circuit for the callback + * procedure to evaluate a TclBinding. The actual evaluation of the + * binding is handled inline, because special things have to be done + * with a Tcl binding before evaluation time. + */ + +#define EvalTclBinding ((TkBindEvalProc *) 1) + + +/* + *--------------------------------------------------------------------------- + * + * TkBindInit -- + * + * This procedure is called when an application is created. It + * initializes all the structures used by bindings and virtual + * events. It must be called before any other functions in this + * file are called. + * + * Results: + * None. + * + * Side effects: + * Memory allocated. + * + *--------------------------------------------------------------------------- + */ + +void +TkBindInit(mainPtr) + TkMainInfo *mainPtr; /* The newly created application. */ +{ + BindInfo *bindInfoPtr; + + if (sizeof(XEvent) < sizeof(XVirtualEvent)) { + panic("TkBindInit: virtual events can't be supported"); + } + + /* + * Initialize the static data structures used by the binding package. + * They are only initialized once, no matter how many interps are + * created. + */ + + if (!initialized) { + Tcl_HashEntry *hPtr; + ModInfo *modPtr; + EventInfo *eiPtr; + int dummy; + +#ifdef REDO_KEYSYM_LOOKUP + KeySymInfo *kPtr; + + Tcl_InitHashTable(&keySymTable, TCL_STRING_KEYS); + Tcl_InitHashTable(&nameTable, TCL_ONE_WORD_KEYS); + for (kPtr = keyArray; kPtr->name != NULL; kPtr++) { + hPtr = Tcl_CreateHashEntry(&keySymTable, kPtr->name, &dummy); + Tcl_SetHashValue(hPtr, kPtr->value); + hPtr = Tcl_CreateHashEntry(&nameTable, (char *) kPtr->value, + &dummy); + Tcl_SetHashValue(hPtr, kPtr->name); + } +#endif /* REDO_KEYSYM_LOOKUP */ + + Tcl_InitHashTable(&modTable, TCL_STRING_KEYS); + for (modPtr = modArray; modPtr->name != NULL; modPtr++) { + hPtr = Tcl_CreateHashEntry(&modTable, modPtr->name, &dummy); + Tcl_SetHashValue(hPtr, modPtr); + } + + Tcl_InitHashTable(&eventTable, TCL_STRING_KEYS); + for (eiPtr = eventArray; eiPtr->name != NULL; eiPtr++) { + hPtr = Tcl_CreateHashEntry(&eventTable, eiPtr->name, &dummy); + Tcl_SetHashValue(hPtr, eiPtr); + } + initialized = 1; + } + + mainPtr->bindingTable = Tk_CreateBindingTable(mainPtr->interp); + + bindInfoPtr = (BindInfo *) ckalloc(sizeof(BindInfo)); + InitVirtualEventTable(&bindInfoPtr->virtualEventTable); + bindInfoPtr->screenInfo.curDispPtr = NULL; + bindInfoPtr->screenInfo.curScreenIndex = -1; + bindInfoPtr->screenInfo.bindingDepth = 0; + bindInfoPtr->pendingList = NULL; + mainPtr->bindInfo = (TkBindInfo) bindInfoPtr; + + TkpInitializeMenuBindings(mainPtr->interp, mainPtr->bindingTable); +} + +/* + *--------------------------------------------------------------------------- + * + * TkBindFree -- + * + * This procedure is called when an application is deleted. It + * deletes all the structures used by bindings and virtual events. + * + * Results: + * None. + * + * Side effects: + * Memory freed. + * + *--------------------------------------------------------------------------- + */ + +void +TkBindFree(mainPtr) + TkMainInfo *mainPtr; /* The newly created application. */ +{ + BindInfo *bindInfoPtr; + + Tk_DeleteBindingTable(mainPtr->bindingTable); + mainPtr->bindingTable = NULL; + + bindInfoPtr = (BindInfo *) mainPtr->bindInfo; + DeleteVirtualEventTable(&bindInfoPtr->virtualEventTable); + mainPtr->bindInfo = NULL; +} + +/* + *-------------------------------------------------------------- + * + * Tk_CreateBindingTable -- + * + * Set up a new domain in which event bindings may be created. + * + * Results: + * The return value is a token for the new table, which must + * be passed to procedures like Tk_CreatBinding. + * + * Side effects: + * Memory is allocated for the new table. + * + *-------------------------------------------------------------- + */ + +Tk_BindingTable +Tk_CreateBindingTable(interp) + Tcl_Interp *interp; /* Interpreter to associate with the binding + * table: commands are executed in this + * interpreter. */ +{ + BindingTable *bindPtr; + int i; + + /* + * Create and initialize a new binding table. + */ + + bindPtr = (BindingTable *) ckalloc(sizeof(BindingTable)); + for (i = 0; i < EVENT_BUFFER_SIZE; i++) { + bindPtr->eventRing[i].type = -1; + } + bindPtr->curEvent = 0; + Tcl_InitHashTable(&bindPtr->patternTable, + sizeof(PatternTableKey)/sizeof(int)); + Tcl_InitHashTable(&bindPtr->objectTable, TCL_ONE_WORD_KEYS); + bindPtr->interp = interp; + return (Tk_BindingTable) bindPtr; +} + +/* + *-------------------------------------------------------------- + * + * Tk_DeleteBindingTable -- + * + * Destroy a binding table and free up all its memory. + * The caller should not use bindingTable again after + * this procedure returns. + * + * Results: + * None. + * + * Side effects: + * Memory is freed. + * + *-------------------------------------------------------------- + */ + +void +Tk_DeleteBindingTable(bindingTable) + Tk_BindingTable bindingTable; /* Token for the binding table to + * destroy. */ +{ + BindingTable *bindPtr = (BindingTable *) bindingTable; + PatSeq *psPtr, *nextPtr; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + + /* + * Find and delete all of the patterns associated with the binding + * table. + */ + + for (hPtr = Tcl_FirstHashEntry(&bindPtr->patternTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + for (psPtr = (PatSeq *) Tcl_GetHashValue(hPtr); + psPtr != NULL; psPtr = nextPtr) { + nextPtr = psPtr->nextSeqPtr; + psPtr->flags |= MARKED_DELETED; + if (psPtr->refCount == 0) { + if (psPtr->freeProc != NULL) { + (*psPtr->freeProc)(psPtr->clientData); + } + ckfree((char *) psPtr); + } + } + } + + /* + * Clean up the rest of the information associated with the + * binding table. + */ + + Tcl_DeleteHashTable(&bindPtr->patternTable); + Tcl_DeleteHashTable(&bindPtr->objectTable); + ckfree((char *) bindPtr); +} + +/* + *-------------------------------------------------------------- + * + * Tk_CreateBinding -- + * + * Add a binding to a binding table, so that future calls to + * Tk_BindEvent may execute the command in the binding. + * + * 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 + * 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 + * what events to select for in a window, for example. + * + * Side effects: + * An existing binding on the same event sequence may be + * replaced. + * The new binding may cause future calls to Tk_BindEvent to + * behave differently than they did previously. + * + *-------------------------------------------------------------- + */ + +unsigned long +Tk_CreateBinding(interp, bindingTable, object, eventString, command, append) + Tcl_Interp *interp; /* Used for error reporting. */ + Tk_BindingTable bindingTable; + /* Table in which to create binding. */ + ClientData object; /* Token for object with which binding is + * associated. */ + char *eventString; /* String describing event sequence that + * triggers binding. */ + char *command; /* Contains Tcl command to execute when + * binding triggers. */ + int append; /* 0 means replace any existing binding for + * eventString; 1 means append to that + * binding. If the existing binding is for a + * callback function and not a Tcl command + * string, the existing binding will always be + * replaced. */ +{ + BindingTable *bindPtr = (BindingTable *) bindingTable; + PatSeq *psPtr; + unsigned long eventMask; + char *new, *old; + + psPtr = FindSequence(interp, &bindPtr->patternTable, object, eventString, + 1, 1, &eventMask); + if (psPtr == NULL) { + return 0; + } + if (psPtr->eventProc == NULL) { + int new; + Tcl_HashEntry *hPtr; + + /* + * This pattern sequence was just created. + * Link the pattern into the list associated with the object, so + * that if the object goes away, these bindings will all + * automatically be deleted. + */ + + hPtr = Tcl_CreateHashEntry(&bindPtr->objectTable, (char *) object, + &new); + if (new) { + psPtr->nextObjPtr = NULL; + } else { + psPtr->nextObjPtr = (PatSeq *) Tcl_GetHashValue(hPtr); + } + Tcl_SetHashValue(hPtr, psPtr); + } else if (psPtr->eventProc != EvalTclBinding) { + /* + * Free existing procedural binding. + */ + + if (psPtr->freeProc != NULL) { + (*psPtr->freeProc)(psPtr->clientData); + } + psPtr->clientData = NULL; + append = 0; + } + + old = (char *) psPtr->clientData; + if ((append != 0) && (old != NULL)) { + int length; + + length = strlen(old) + strlen(command) + 2; + new = (char *) ckalloc((unsigned) length); + sprintf(new, "%s\n%s", old, command); + } else { + new = (char *) ckalloc((unsigned) strlen(command) + 1); + strcpy(new, command); + } + if (old != NULL) { + ckfree(old); + } + psPtr->eventProc = EvalTclBinding; + psPtr->freeProc = FreeTclBinding; + psPtr->clientData = (ClientData) new; + return eventMask; +} + +/* + *--------------------------------------------------------------------------- + * + * TkCreateBindingProcedure -- + * + * Add a C binding to a binding table, so that future calls to + * Tk_BindEvent may callback the procedure in the binding. + * + * 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 + * 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 + * what events to select for in a window, for example. + * + * Side effects: + * Any existing binding on the same event sequence will be + * replaced. + * + *--------------------------------------------------------------------------- + */ + +unsigned long +TkCreateBindingProcedure(interp, bindingTable, object, eventString, + eventProc, freeProc, clientData) + Tcl_Interp *interp; /* Used for error reporting. */ + Tk_BindingTable bindingTable; + /* Table in which to create binding. */ + ClientData object; /* Token for object with which binding is + * associated. */ + char *eventString; /* String describing event sequence that + * triggers binding. */ + TkBindEvalProc *eventProc; /* Procedure to invoke when binding + * triggers. Must not be NULL. */ + TkBindFreeProc *freeProc; /* Procedure to invoke when binding is + * freed. May be NULL for no procedure. */ + ClientData clientData; /* Arbitrary ClientData to pass to eventProc + * and freeProc. */ +{ + BindingTable *bindPtr = (BindingTable *) bindingTable; + PatSeq *psPtr; + unsigned long eventMask; + + psPtr = FindSequence(interp, &bindPtr->patternTable, object, eventString, + 1, 1, &eventMask); + if (psPtr == NULL) { + return 0; + } + if (psPtr->eventProc == NULL) { + int new; + Tcl_HashEntry *hPtr; + + /* + * This pattern sequence was just created. + * Link the pattern into the list associated with the object, so + * that if the object goes away, these bindings will all + * automatically be deleted. + */ + + hPtr = Tcl_CreateHashEntry(&bindPtr->objectTable, (char *) object, + &new); + if (new) { + psPtr->nextObjPtr = NULL; + } else { + psPtr->nextObjPtr = (PatSeq *) Tcl_GetHashValue(hPtr); + } + Tcl_SetHashValue(hPtr, psPtr); + } else { + + /* + * Free existing callback. + */ + + if (psPtr->freeProc != NULL) { + (*psPtr->freeProc)(psPtr->clientData); + } + } + + psPtr->eventProc = eventProc; + psPtr->freeProc = freeProc; + psPtr->clientData = clientData; + return eventMask; +} + +/* + *-------------------------------------------------------------- + * + * Tk_DeleteBinding -- + * + * Remove an event binding from a binding table. + * + * Results: + * The result is a standard Tcl return value. If an error + * occurs then interp->result will contain an error message. + * + * Side effects: + * The binding given by object and eventString is removed + * from bindingTable. + * + *-------------------------------------------------------------- + */ + +int +Tk_DeleteBinding(interp, bindingTable, object, eventString) + Tcl_Interp *interp; /* Used for error reporting. */ + Tk_BindingTable bindingTable; /* Table in which to delete binding. */ + ClientData object; /* Token for object with which binding + * is associated. */ + char *eventString; /* String describing event sequence + * that triggers binding. */ +{ + BindingTable *bindPtr = (BindingTable *) bindingTable; + PatSeq *psPtr, *prevPtr; + unsigned long eventMask; + Tcl_HashEntry *hPtr; + + psPtr = FindSequence(interp, &bindPtr->patternTable, object, eventString, + 0, 1, &eventMask); + if (psPtr == NULL) { + Tcl_ResetResult(interp); + return TCL_OK; + } + + /* + * Unlink the binding from the list for its object, then from the + * list for its pattern. + */ + + hPtr = Tcl_FindHashEntry(&bindPtr->objectTable, (char *) object); + if (hPtr == NULL) { + panic("Tk_DeleteBinding couldn't find object table entry"); + } + prevPtr = (PatSeq *) Tcl_GetHashValue(hPtr); + if (prevPtr == psPtr) { + Tcl_SetHashValue(hPtr, psPtr->nextObjPtr); + } else { + for ( ; ; prevPtr = prevPtr->nextObjPtr) { + if (prevPtr == NULL) { + panic("Tk_DeleteBinding couldn't find on object list"); + } + if (prevPtr->nextObjPtr == psPtr) { + prevPtr->nextObjPtr = psPtr->nextObjPtr; + break; + } + } + } + prevPtr = (PatSeq *) Tcl_GetHashValue(psPtr->hPtr); + if (prevPtr == psPtr) { + if (psPtr->nextSeqPtr == NULL) { + Tcl_DeleteHashEntry(psPtr->hPtr); + } else { + Tcl_SetHashValue(psPtr->hPtr, psPtr->nextSeqPtr); + } + } else { + for ( ; ; prevPtr = prevPtr->nextSeqPtr) { + if (prevPtr == NULL) { + panic("Tk_DeleteBinding couldn't find on hash chain"); + } + if (prevPtr->nextSeqPtr == psPtr) { + prevPtr->nextSeqPtr = psPtr->nextSeqPtr; + break; + } + } + } + + psPtr->flags |= MARKED_DELETED; + if (psPtr->refCount == 0) { + if (psPtr->freeProc != NULL) { + (*psPtr->freeProc)(psPtr->clientData); + } + ckfree((char *) psPtr); + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * Tk_GetBinding -- + * + * Return the command associated with a given event string. + * + * Results: + * The return value is a pointer to the command string + * associated with eventString for object in the domain + * 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 + * will persist until the binding is changed or deleted. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +char * +Tk_GetBinding(interp, bindingTable, object, eventString) + Tcl_Interp *interp; /* Interpreter for error reporting. */ + Tk_BindingTable bindingTable; /* Table in which to look for + * binding. */ + ClientData object; /* Token for object with which binding + * is associated. */ + char *eventString; /* String describing event sequence + * that triggers binding. */ +{ + BindingTable *bindPtr = (BindingTable *) bindingTable; + PatSeq *psPtr; + unsigned long eventMask; + + psPtr = FindSequence(interp, &bindPtr->patternTable, object, eventString, + 0, 1, &eventMask); + if (psPtr == NULL) { + return NULL; + } + if (psPtr->eventProc == EvalTclBinding) { + return (char *) psPtr->clientData; + } + return ""; +} + +/* + *-------------------------------------------------------------- + * + * Tk_GetAllBindings -- + * + * Return a list of event strings for all the bindings + * associated with a given object. + * + * Results: + * There is no return value. Interp->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. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +void +Tk_GetAllBindings(interp, bindingTable, object) + Tcl_Interp *interp; /* Interpreter returning result or + * error. */ + Tk_BindingTable bindingTable; /* Table in which to look for + * bindings. */ + ClientData object; /* Token for object. */ + +{ + BindingTable *bindPtr = (BindingTable *) bindingTable; + PatSeq *psPtr; + Tcl_HashEntry *hPtr; + Tcl_DString ds; + + hPtr = Tcl_FindHashEntry(&bindPtr->objectTable, (char *) object); + if (hPtr == NULL) { + return; + } + Tcl_DStringInit(&ds); + for (psPtr = (PatSeq *) Tcl_GetHashValue(hPtr); psPtr != NULL; + psPtr = psPtr->nextObjPtr) { + /* + * For each binding, output information about each of the + * patterns in its sequence. + */ + + Tcl_DStringSetLength(&ds, 0); + GetPatternString(psPtr, &ds); + Tcl_AppendElement(interp, Tcl_DStringValue(&ds)); + } + Tcl_DStringFree(&ds); +} + +/* + *-------------------------------------------------------------- + * + * Tk_DeleteAllBindings -- + * + * Remove all bindings associated with a given object in a + * given binding table. + * + * Results: + * All bindings associated with object are removed from + * bindingTable. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +void +Tk_DeleteAllBindings(bindingTable, object) + Tk_BindingTable bindingTable; /* Table in which to delete + * bindings. */ + ClientData object; /* Token for object. */ +{ + BindingTable *bindPtr = (BindingTable *) bindingTable; + PatSeq *psPtr, *prevPtr; + PatSeq *nextPtr; + Tcl_HashEntry *hPtr; + + hPtr = Tcl_FindHashEntry(&bindPtr->objectTable, (char *) object); + if (hPtr == NULL) { + return; + } + for (psPtr = (PatSeq *) Tcl_GetHashValue(hPtr); psPtr != NULL; + psPtr = nextPtr) { + nextPtr = psPtr->nextObjPtr; + + /* + * Be sure to remove each binding from its hash chain in the + * pattern table. If this is the last pattern in the chain, + * then delete the hash entry too. + */ + + prevPtr = (PatSeq *) Tcl_GetHashValue(psPtr->hPtr); + if (prevPtr == psPtr) { + if (psPtr->nextSeqPtr == NULL) { + Tcl_DeleteHashEntry(psPtr->hPtr); + } else { + Tcl_SetHashValue(psPtr->hPtr, psPtr->nextSeqPtr); + } + } else { + for ( ; ; prevPtr = prevPtr->nextSeqPtr) { + if (prevPtr == NULL) { + panic("Tk_DeleteAllBindings couldn't find on hash chain"); + } + if (prevPtr->nextSeqPtr == psPtr) { + prevPtr->nextSeqPtr = psPtr->nextSeqPtr; + break; + } + } + } + psPtr->flags |= MARKED_DELETED; + + if (psPtr->refCount == 0) { + if (psPtr->freeProc != NULL) { + (*psPtr->freeProc)(psPtr->clientData); + } + ckfree((char *) psPtr); + } + } + Tcl_DeleteHashEntry(hPtr); +} + +/* + *--------------------------------------------------------------------------- + * + * Tk_BindEvent -- + * + * This procedure is invoked to process an X event. The + * event is added to those recorded for the binding table. + * Then each of the objects at *objectPtr is checked in + * order to see if it has a binding that matches the recent + * events. If so, the most specific binding is invoked for + * each object. + * + * Results: + * None. + * + * Side effects: + * Depends on the command associated with the matching binding. + * + * All Tcl bindings scripts for each object are accumulated before + * the first binding is evaluated. If the action of a Tcl binding + * is to change or delete a binding, or delete the window associated + * with the binding, all the original Tcl binding scripts will still + * fire. Contrast this with C binding procedures. If a pending C + * binding (one that hasn't fired yet, but is queued to be fired for + * this window) is deleted, it will not be called, and if it is + * changed, then the new binding procedure will be called. If the + * window itself is deleted, no further C binding procedures will be + * called for this window. When both Tcl binding scripts and C binding + * procedures are interleaved, the above rules still apply. + * + *--------------------------------------------------------------------------- + */ + +void +Tk_BindEvent(bindingTable, eventPtr, tkwin, numObjects, objectPtr) + Tk_BindingTable bindingTable; /* Table in which to look for + * bindings. */ + XEvent *eventPtr; /* What actually happened. */ + Tk_Window tkwin; /* Window on display where event + * occurred (needed in order to + * locate display information). */ + int numObjects; /* Number of objects at *objectPtr. */ + ClientData *objectPtr; /* Array of one or more objects + * to check for a matching binding. */ +{ + BindingTable *bindPtr; + TkDisplay *dispPtr; + BindInfo *bindInfoPtr; + TkDisplay *oldDispPtr; + ScreenInfo *screenPtr; + XEvent *ringPtr; + PatSeq *vMatchDetailList, *vMatchNoDetailList; + int flags, oldScreen, i, deferModal; + unsigned int matchCount, matchSpace; + Tcl_Interp *interp; + Tcl_DString scripts, savedResult; + Detail detail; + char *p, *end; + PendingBinding *pendingPtr; + PendingBinding staticPending; + TkWindow *winPtr = (TkWindow *)tkwin; + PatternTableKey key; + + /* + * Ignore events on windows that don't have names: these are windows + * like wrapper windows that shouldn't be visible to the + * application. + */ + + if (winPtr->pathName == NULL) { + return; + } + + /* + * Ignore the event completely if it is an Enter, Leave, FocusIn, + * or FocusOut event with detail NotifyInferior. The reason for + * ignoring these events is that we don't want transitions between + * a window and its children to visible to bindings on the parent: + * this would cause problems for mega-widgets, since the internal + * structure of a mega-widget isn't supposed to be visible to + * people watching the parent. + */ + + if ((eventPtr->type == EnterNotify) || (eventPtr->type == LeaveNotify)) { + if (eventPtr->xcrossing.detail == NotifyInferior) { + return; + } + } + if ((eventPtr->type == FocusIn) || (eventPtr->type == FocusOut)) { + if (eventPtr->xfocus.detail == NotifyInferior) { + return; + } + } + + bindPtr = (BindingTable *) bindingTable; + dispPtr = ((TkWindow *) tkwin)->dispPtr; + bindInfoPtr = (BindInfo *) winPtr->mainPtr->bindInfo; + + /* + * Add the new event to the ring of saved events for the + * binding table. Two tricky points: + * + * 1. Combine consecutive MotionNotify events. Do this by putting + * the new event *on top* of the previous event. + * 2. If a modifier key is held down, it auto-repeats to generate + * continuous KeyPress and KeyRelease events. These can flush + * the event ring so that valuable information is lost (such + * as repeated button clicks). To handle this, check for the + * special case of a modifier KeyPress arriving when the previous + * two events are a KeyRelease and KeyPress of the same key. + * If this happens, mark the most recent event (the KeyRelease) + * invalid and put the new event on top of the event before that + * (the KeyPress). + */ + + if ((eventPtr->type == MotionNotify) + && (bindPtr->eventRing[bindPtr->curEvent].type == MotionNotify)) { + /* + * Don't advance the ring pointer. + */ + } else if (eventPtr->type == KeyPress) { + int i; + for (i = 0; ; i++) { + if (i >= dispPtr->numModKeyCodes) { + goto advanceRingPointer; + } + if (dispPtr->modKeyCodes[i] == eventPtr->xkey.keycode) { + break; + } + } + ringPtr = &bindPtr->eventRing[bindPtr->curEvent]; + if ((ringPtr->type != KeyRelease) + || (ringPtr->xkey.keycode != eventPtr->xkey.keycode)) { + goto advanceRingPointer; + } + if (bindPtr->curEvent <= 0) { + i = EVENT_BUFFER_SIZE - 1; + } else { + i = bindPtr->curEvent - 1; + } + ringPtr = &bindPtr->eventRing[i]; + if ((ringPtr->type != KeyPress) + || (ringPtr->xkey.keycode != eventPtr->xkey.keycode)) { + goto advanceRingPointer; + } + bindPtr->eventRing[bindPtr->curEvent].type = -1; + bindPtr->curEvent = i; + } else { + advanceRingPointer: + bindPtr->curEvent++; + if (bindPtr->curEvent >= EVENT_BUFFER_SIZE) { + bindPtr->curEvent = 0; + } + } + ringPtr = &bindPtr->eventRing[bindPtr->curEvent]; + memcpy((VOID *) ringPtr, (VOID *) eventPtr, sizeof(XEvent)); + detail.clientData = 0; + flags = flagArray[ringPtr->type]; + if (flags & KEY) { + detail.keySym = GetKeySym(dispPtr, ringPtr); + if (detail.keySym == NoSymbol) { + detail.keySym = 0; + } + } else if (flags & BUTTON) { + detail.button = ringPtr->xbutton.button; + } else if (flags & VIRTUAL) { + detail.name = ((XVirtualEvent *) ringPtr)->name; + } + bindPtr->detailRing[bindPtr->curEvent] = detail; + + /* + * Find out if there are any virtual events that correspond to this + * physical event (or sequence of physical events). + */ + + vMatchDetailList = NULL; + vMatchNoDetailList = NULL; + memset(&key, 0, sizeof(key)); + + if (ringPtr->type != VirtualEvent) { + Tcl_HashTable *veptPtr; + Tcl_HashEntry *hPtr; + + veptPtr = &bindInfoPtr->virtualEventTable.patternTable; + + key.object = NULL; + key.type = ringPtr->type; + key.detail = detail; + + hPtr = Tcl_FindHashEntry(veptPtr, (char *) &key); + if (hPtr != NULL) { + vMatchDetailList = (PatSeq *) Tcl_GetHashValue(hPtr); + } + + if (key.detail.clientData != 0) { + key.detail.clientData = 0; + hPtr = Tcl_FindHashEntry(veptPtr, (char *) &key); + if (hPtr != NULL) { + vMatchNoDetailList = (PatSeq *) Tcl_GetHashValue(hPtr); + } + } + } + + /* + * Loop over all the binding tags, finding the binding script or + * callback for each one. Append all of the binding scripts, with + * %-sequences expanded, to "scripts", with null characters separating + * the scripts for each object. Append all the callbacks to the array + * of pending callbacks. + */ + + pendingPtr = &staticPending; + matchCount = 0; + matchSpace = sizeof(staticPending.matchArray) / sizeof(PatSeq *); + Tcl_DStringInit(&scripts); + + for ( ; numObjects > 0; numObjects--, objectPtr++) { + PatSeq *matchPtr, *sourcePtr; + Tcl_HashEntry *hPtr; + + matchPtr = NULL; + sourcePtr = NULL; + + /* + * Match the new event against those recorded in the pattern table, + * saving the longest matching pattern. For events with details + * (button and key events), look for a binding for the specific + * key or button. First see if the event matches a physical event + * that the object is interested in, then look for a virtual event. + */ + + key.object = *objectPtr; + key.type = ringPtr->type; + key.detail = detail; + hPtr = Tcl_FindHashEntry(&bindPtr->patternTable, (char *) &key); + if (hPtr != NULL) { + matchPtr = MatchPatterns(dispPtr, bindPtr, + (PatSeq *) Tcl_GetHashValue(hPtr), matchPtr, NULL, + &sourcePtr); + } + + if (vMatchDetailList != NULL) { + matchPtr = MatchPatterns(dispPtr, bindPtr, vMatchDetailList, + matchPtr, objectPtr, &sourcePtr); + } + + /* + * If no match was found, look for a binding for all keys or buttons + * (detail of 0). Again, first match on a virtual event. + */ + + if ((detail.clientData != 0) && (matchPtr == NULL)) { + key.detail.clientData = 0; + hPtr = Tcl_FindHashEntry(&bindPtr->patternTable, (char *) &key); + if (hPtr != NULL) { + matchPtr = MatchPatterns(dispPtr, bindPtr, + (PatSeq *) Tcl_GetHashValue(hPtr), matchPtr, NULL, + &sourcePtr); + } + + if (vMatchNoDetailList != NULL) { + matchPtr = MatchPatterns(dispPtr, bindPtr, vMatchNoDetailList, + matchPtr, objectPtr, &sourcePtr); + } + + } + + if (matchPtr != NULL) { + if (sourcePtr->eventProc == NULL) { + panic("Tk_BindEvent: missing command"); + } + if (sourcePtr->eventProc == EvalTclBinding) { + ExpandPercents(winPtr, (char *) sourcePtr->clientData, + eventPtr, detail.keySym, &scripts); + } else { + if (matchCount >= matchSpace) { + PendingBinding *new; + unsigned int oldSize, newSize; + + oldSize = sizeof(staticPending) + - sizeof(staticPending.matchArray) + + matchSpace * sizeof(PatSeq*); + matchSpace *= 2; + newSize = sizeof(staticPending) + - sizeof(staticPending.matchArray) + + matchSpace * sizeof(PatSeq*); + new = (PendingBinding *) ckalloc(newSize); + memcpy((VOID *) new, (VOID *) pendingPtr, oldSize); + if (pendingPtr != &staticPending) { + ckfree((char *) pendingPtr); + } + pendingPtr = new; + } + sourcePtr->refCount++; + pendingPtr->matchArray[matchCount] = sourcePtr; + matchCount++; + } + /* + * A "" is added to the scripts string to separate the + * various scripts that should be invoked. + */ + + Tcl_DStringAppend(&scripts, "", 1); + } + } + if (Tcl_DStringLength(&scripts) == 0) { + return; + } + + /* + * Now go back through and evaluate the binding for each object, + * in order, dealing with "break" and "continue" exceptions + * appropriately. + * + * 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 + * 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, + * we save it in a dynamic string. + * 2. The binding's action can potentially delete the binding, + * so bindPtr may not point to anything valid once the action + * completes. Thus we have to save bindPtr->interp in a + * local variable in order to restore the result. + */ + + interp = bindPtr->interp; + Tcl_DStringInit(&savedResult); + + /* + * Save information about the current screen, then invoke a script + * if the screen has changed. + */ + + Tcl_DStringGetResult(interp, &savedResult); + screenPtr = &bindInfoPtr->screenInfo; + oldDispPtr = screenPtr->curDispPtr; + oldScreen = screenPtr->curScreenIndex; + if ((dispPtr != screenPtr->curDispPtr) + || (Tk_ScreenNumber(tkwin) != screenPtr->curScreenIndex)) { + screenPtr->curDispPtr = dispPtr; + screenPtr->curScreenIndex = Tk_ScreenNumber(tkwin); + ChangeScreen(interp, dispPtr->name, screenPtr->curScreenIndex); + } + + if (matchCount > 0) { + pendingPtr->nextPtr = bindInfoPtr->pendingList; + pendingPtr->tkwin = tkwin; + pendingPtr->deleted = 0; + bindInfoPtr->pendingList = pendingPtr; + } + + /* + * Save the current value of the TK_DEFER_MODAL flag so we can + * restore it at the end of the loop. Clear the flag so we can + * detect any recursive requests for a modal loop. + */ + + flags = winPtr->flags; + winPtr->flags &= ~TK_DEFER_MODAL; + + p = Tcl_DStringValue(&scripts); + end = p + Tcl_DStringLength(&scripts); + i = 0; + + while (p < end) { + int code; + + screenPtr->bindingDepth++; + Tcl_AllowExceptions(interp); + + if (*p == '\0') { + PatSeq *psPtr; + + psPtr = pendingPtr->matchArray[i]; + i++; + code = TCL_OK; + if ((pendingPtr->deleted == 0) + && ((psPtr->flags & MARKED_DELETED) == 0)) { + code = (*psPtr->eventProc)(psPtr->clientData, interp, eventPtr, + tkwin, detail.keySym); + } + psPtr->refCount--; + if ((psPtr->refCount == 0) && (psPtr->flags & MARKED_DELETED)) { + if (psPtr->freeProc != NULL) { + (*psPtr->freeProc)(psPtr->clientData); + } + ckfree((char *) psPtr); + } + } else { + code = Tcl_GlobalEval(interp, p); + p += strlen(p); + } + p++; + screenPtr->bindingDepth--; + if (code != TCL_OK) { + if (code == TCL_CONTINUE) { + /* + * Do nothing: just go on to the next command. + */ + } else if (code == TCL_BREAK) { + break; + } else { + Tcl_AddErrorInfo(interp, "\n (command bound to event)"); + Tcl_BackgroundError(interp); + break; + } + } + } + + if (matchCount > 0 && !pendingPtr->deleted) { + /* + * Restore the original modal flag value and invoke the modal loop + * if needed. + */ + + deferModal = winPtr->flags & TK_DEFER_MODAL; + winPtr->flags = (winPtr->flags & (unsigned int) ~TK_DEFER_MODAL) + | (flags & TK_DEFER_MODAL); + if (deferModal) { + (*winPtr->classProcsPtr->modalProc)(tkwin, eventPtr); + } + } + + if ((screenPtr->bindingDepth != 0) && + ((oldDispPtr != screenPtr->curDispPtr) + || (oldScreen != screenPtr->curScreenIndex))) { + + /* + * Some other binding script is currently executing, but its + * screen is no longer current. Change the current display + * back again. + */ + + screenPtr->curDispPtr = oldDispPtr; + screenPtr->curScreenIndex = oldScreen; + ChangeScreen(interp, oldDispPtr->name, oldScreen); + } + Tcl_DStringResult(interp, &savedResult); + Tcl_DStringFree(&scripts); + + if (matchCount > 0) { + PendingBinding **curPtrPtr; + + for (curPtrPtr = &bindInfoPtr->pendingList; ; ) { + if (*curPtrPtr == pendingPtr) { + *curPtrPtr = pendingPtr->nextPtr; + break; + } + curPtrPtr = &(*curPtrPtr)->nextPtr; + } + if (pendingPtr != &staticPending) { + ckfree((char *) pendingPtr); + } + } +} + +/* + *--------------------------------------------------------------------------- + * + * TkBindDeadWindow -- + * + * This procedure is invoked when it is determined that a window is + * dead. It cleans up bind-related information about the window + * + * Results: + * None. + * + * Side effects: + * Any pending C bindings for this window are cancelled. + * + *--------------------------------------------------------------------------- + */ + +void +TkBindDeadWindow(winPtr) + TkWindow *winPtr; /* The window that is being deleted. */ +{ + BindInfo *bindInfoPtr; + PendingBinding *curPtr; + + bindInfoPtr = (BindInfo *) winPtr->mainPtr->bindInfo; + curPtr = bindInfoPtr->pendingList; + while (curPtr != NULL) { + if (curPtr->tkwin == (Tk_Window) winPtr) { + curPtr->deleted = 1; + } + curPtr = curPtr->nextPtr; + } +} + +/* + *---------------------------------------------------------------------- + * + * MatchPatterns -- + * + * Given a list of pattern sequences and a list of recent events, + * return the pattern sequence that best matches the event list, + * if there is one. + * + * This procedure is used in two different ways. In the simplest + * use, "object" is NULL and psPtr is a list of pattern sequences, + * each of which corresponds to a binding. In this case, the + * procedure finds the pattern sequences that match the event list + * and returns the most specific of those, if there is more than one. + * + * In the second case, psPtr is a list of pattern sequences, each + * of which corresponds to a definition for a virtual binding. + * In order for one of these sequences to "match", it must match + * the events (as above) but in addition there must be a binding + * for its associated virtual event on the current object. The + * "object" argument indicates which object the binding must be for. + * + * Results: + * The return value is NULL if bestPtr is NULL and no pattern matches + * the recent events from bindPtr. Otherwise the return value is + * the most specific pattern sequence among bestPtr and all those + * at psPtr that match the event list and object. If a pattern + * sequence other than bestPtr is returned, then *bestCommandPtr + * is filled in with a pointer to the command from the best sequence. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +static PatSeq * +MatchPatterns(dispPtr, bindPtr, psPtr, bestPtr, objectPtr, sourcePtrPtr) + TkDisplay *dispPtr; /* Display from which the event came. */ + BindingTable *bindPtr; /* Information about binding table, such as + * ring of recent events. */ + PatSeq *psPtr; /* List of pattern sequences. */ + PatSeq *bestPtr; /* The best match seen so far, from a + * previous call to this procedure. NULL + * means no prior best match. */ + ClientData *objectPtr; /* If NULL, the sequences at psPtr + * correspond to "normal" bindings. If + * non-NULL, the sequences at psPtr correspond + * to virtual bindings; in order to match each + * sequence must correspond to a virtual + * binding for which a binding exists for + * object in bindPtr. */ + PatSeq **sourcePtrPtr; /* Filled with the pattern sequence that + * contains the eventProc and clientData + * associated with the best match. If this + * differs from the return value, it is the + * virtual event that most closely matched the + * return value (a physical event). Not + * modified unless a result other than bestPtr + * is returned. */ +{ + PatSeq *matchPtr, *bestSourcePtr, *sourcePtr; + + bestSourcePtr = *sourcePtrPtr; + + /* + * Iterate over all the pattern sequences. + */ + + for ( ; psPtr != NULL; psPtr = psPtr->nextSeqPtr) { + XEvent *eventPtr; + Pattern *patPtr; + Window window; + Detail *detailPtr; + int patCount, ringCount, flags, state; + int modMask; + + /* + * Iterate over all the patterns in a sequence to be + * sure that they all match. + */ + + eventPtr = &bindPtr->eventRing[bindPtr->curEvent]; + detailPtr = &bindPtr->detailRing[bindPtr->curEvent]; + window = eventPtr->xany.window; + patPtr = psPtr->pats; + patCount = psPtr->numPats; + ringCount = EVENT_BUFFER_SIZE; + while (patCount > 0) { + if (ringCount <= 0) { + goto nextSequence; + } + if (eventPtr->xany.type != patPtr->eventType) { + /* + * Most of the event types are considered superfluous + * in that they are ignored if they occur in the middle + * of a pattern sequence and have mismatching types. The + * only ones that cannot be ignored are ButtonPress and + * ButtonRelease events (if the next event in the pattern + * is a KeyPress or KeyRelease) and KeyPress and KeyRelease + * events (if the next pattern event is a ButtonPress or + * ButtonRelease). Here are some tricky cases to consider: + * 1. Double-Button or Double-Key events. + * 2. Double-ButtonRelease or Double-KeyRelease events. + * 3. The arrival of various events like Enter and Leave + * and FocusIn and GraphicsExpose between two button + * presses or key presses. + * 4. Modifier keys like Shift and Control shouldn't + * generate conflicts with button events. + */ + + if ((patPtr->eventType == KeyPress) + || (patPtr->eventType == KeyRelease)) { + if ((eventPtr->xany.type == ButtonPress) + || (eventPtr->xany.type == ButtonRelease)) { + goto nextSequence; + } + } else if ((patPtr->eventType == ButtonPress) + || (patPtr->eventType == ButtonRelease)) { + if ((eventPtr->xany.type == KeyPress) + || (eventPtr->xany.type == KeyRelease)) { + int i; + + /* + * Ignore key events if they are modifier keys. + */ + + for (i = 0; i < dispPtr->numModKeyCodes; i++) { + if (dispPtr->modKeyCodes[i] + == eventPtr->xkey.keycode) { + /* + * This key is a modifier key, so ignore it. + */ + goto nextEvent; + } + } + goto nextSequence; + } + } + goto nextEvent; + } + if (eventPtr->xany.window != window) { + goto nextSequence; + } + + /* + * Note: it's important for the keysym check to go before + * the modifier check, so we can ignore unwanted modifier + * keys before choking on the modifier check. + */ + + if ((patPtr->detail.clientData != 0) + && (patPtr->detail.clientData != detailPtr->clientData)) { + /* + * The detail appears not to match. However, if the event + * is a KeyPress for a modifier key then just ignore the + * event. Otherwise event sequences like "aD" never match + * because the shift key goes down between the "a" and the + * "D". + */ + + if (eventPtr->xany.type == KeyPress) { + int i; + + for (i = 0; i < dispPtr->numModKeyCodes; i++) { + if (dispPtr->modKeyCodes[i] == eventPtr->xkey.keycode) { + goto nextEvent; + } + } + } + goto nextSequence; + } + flags = flagArray[eventPtr->type]; + if (flags & (KEY_BUTTON_MOTION_VIRTUAL)) { + state = eventPtr->xkey.state; + } else if (flags & CROSSING) { + state = eventPtr->xcrossing.state; + } else { + state = 0; + } + if (patPtr->needMods != 0) { + modMask = patPtr->needMods; + if ((modMask & META_MASK) && (dispPtr->metaModMask != 0)) { + modMask = (modMask & ~META_MASK) | dispPtr->metaModMask; + } + if ((modMask & ALT_MASK) && (dispPtr->altModMask != 0)) { + modMask = (modMask & ~ALT_MASK) | dispPtr->altModMask; + } + if ((state & modMask) != modMask) { + goto nextSequence; + } + } + if (psPtr->flags & PAT_NEARBY) { + XEvent *firstPtr; + int timeDiff; + + firstPtr = &bindPtr->eventRing[bindPtr->curEvent]; + timeDiff = (Time) firstPtr->xkey.time - eventPtr->xkey.time; + if ((firstPtr->xkey.x_root + < (eventPtr->xkey.x_root - NEARBY_PIXELS)) + || (firstPtr->xkey.x_root + > (eventPtr->xkey.x_root + NEARBY_PIXELS)) + || (firstPtr->xkey.y_root + < (eventPtr->xkey.y_root - NEARBY_PIXELS)) + || (firstPtr->xkey.y_root + > (eventPtr->xkey.y_root + NEARBY_PIXELS)) + || (timeDiff > NEARBY_MS)) { + goto nextSequence; + } + } + patPtr++; + patCount--; + nextEvent: + if (eventPtr == bindPtr->eventRing) { + eventPtr = &bindPtr->eventRing[EVENT_BUFFER_SIZE-1]; + detailPtr = &bindPtr->detailRing[EVENT_BUFFER_SIZE-1]; + } else { + eventPtr--; + detailPtr--; + } + ringCount--; + } + + matchPtr = psPtr; + sourcePtr = psPtr; + + if (objectPtr != NULL) { + int iVirt; + VirtualOwners *voPtr; + PatternTableKey key; + + /* + * The sequence matches the physical constraints. + * Is this object interested in any of the virtual events + * that correspond to this sequence? + */ + + voPtr = psPtr->voPtr; + + memset(&key, 0, sizeof(key)); + key.object = *objectPtr; + key.type = VirtualEvent; + key.detail.clientData = 0; + + for (iVirt = 0; iVirt < voPtr->numOwners; iVirt++) { + Tcl_HashEntry *hPtr = voPtr->owners[iVirt]; + + key.detail.name = (Tk_Uid) Tcl_GetHashKey(hPtr->tablePtr, + hPtr); + hPtr = Tcl_FindHashEntry(&bindPtr->patternTable, + (char *) &key); + if (hPtr != NULL) { + + /* + * This tag is interested in this virtual event and its + * corresponding physical event is a good match with the + * virtual event's definition. + */ + + PatSeq *virtMatchPtr; + + virtMatchPtr = (PatSeq *) Tcl_GetHashValue(hPtr); + if ((virtMatchPtr->numPats != 1) + || (virtMatchPtr->nextSeqPtr != NULL)) { + panic("MatchPattern: badly constructed virtual event"); + } + sourcePtr = virtMatchPtr; + goto match; + } + } + + /* + * The physical event matches a virtual event's definition, but + * the tag isn't interested in it. + */ + goto nextSequence; + } + match: + + /* + * This sequence matches. If we've already got another match, + * pick whichever is most specific. Detail is most important, + * then needMods. + */ + + if (bestPtr != NULL) { + Pattern *patPtr2; + int i; + + if (matchPtr->numPats != bestPtr->numPats) { + if (bestPtr->numPats > matchPtr->numPats) { + goto nextSequence; + } else { + goto newBest; + } + } + for (i = 0, patPtr = matchPtr->pats, patPtr2 = bestPtr->pats; + i < matchPtr->numPats; i++, patPtr++, patPtr2++) { + if (patPtr->detail.clientData != patPtr2->detail.clientData) { + if (patPtr->detail.clientData == 0) { + goto nextSequence; + } else { + goto newBest; + } + } + if (patPtr->needMods != patPtr2->needMods) { + if ((patPtr->needMods & patPtr2->needMods) + == patPtr->needMods) { + goto nextSequence; + } else if ((patPtr->needMods & patPtr2->needMods) + == patPtr2->needMods) { + goto newBest; + } + } + } + /* + * Tie goes to current best pattern. + * + * (1) For virtual vs. virtual, the least recently defined + * virtual wins, because virtuals are examined in order of + * definition. This order is _not_ guaranteed in the + * documentation. + * + * (2) For virtual vs. physical, the physical wins because all + * the physicals are examined before the virtuals. This order + * is guaranteed in the documentation. + * + * (3) For physical vs. physical pattern, the most recently + * defined physical wins, because physicals are examined in + * reverse order of definition. This order is guaranteed in + * the documentation. + */ + + goto nextSequence; + } + newBest: + bestPtr = matchPtr; + bestSourcePtr = sourcePtr; + + nextSequence: continue; + } + + *sourcePtrPtr = bestSourcePtr; + return bestPtr; +} + +/* + *-------------------------------------------------------------- + * + * ExpandPercents -- + * + * Given a command and an event, produce a new command + * by replacing % constructs in the original command + * with information from the X event. + * + * Results: + * The new expanded command is appended to the dynamic string + * given by dsPtr. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static void +ExpandPercents(winPtr, before, eventPtr, keySym, dsPtr) + TkWindow *winPtr; /* Window where event occurred: needed to + * get input context. */ + char *before; /* Command containing percent expressions + * to be replaced. */ + XEvent *eventPtr; /* X event containing information to be + * used in % replacements. */ + KeySym keySym; /* KeySym: only relevant for KeyPress and + * KeyRelease events). */ + Tcl_DString *dsPtr; /* Dynamic string in which to append new + * command. */ +{ + int spaceNeeded, cvtFlags; /* Used to substitute string as proper Tcl + * list element. */ + int number, flags, length; +#define NUM_SIZE 40 + char *string; + char numStorage[NUM_SIZE+1]; + + if (eventPtr->type < TK_LASTEVENT) { + flags = flagArray[eventPtr->type]; + } else { + flags = 0; + } + while (1) { + /* + * Find everything up to the next % character and append it + * to the result string. + */ + + for (string = before; (*string != 0) && (*string != '%'); string++) { + /* Empty loop body. */ + } + if (string != before) { + Tcl_DStringAppend(dsPtr, before, string-before); + before = string; + } + if (*before == 0) { + break; + } + + /* + * There's a percent sequence here. Process it. + */ + + number = 0; + string = "??"; + switch (before[1]) { + case '#': + number = eventPtr->xany.serial; + goto doNumber; + case 'a': + TkpPrintWindowId(numStorage, eventPtr->xconfigure.above); + string = numStorage; + goto doString; + case 'b': + number = eventPtr->xbutton.button; + goto doNumber; + case 'c': + if (flags & EXPOSE) { + number = eventPtr->xexpose.count; + } + goto doNumber; + case 'd': + if (flags & (CROSSING|FOCUS)) { + if (flags & FOCUS) { + number = eventPtr->xfocus.detail; + } else { + number = eventPtr->xcrossing.detail; + } + string = TkFindStateString(notifyDetail, number); + } + goto doString; + case 'f': + number = eventPtr->xcrossing.focus; + goto doNumber; + case 'h': + if (flags & EXPOSE) { + number = eventPtr->xexpose.height; + } else if (flags & (CONFIG)) { + number = eventPtr->xconfigure.height; + } + goto doNumber; + case 'k': + number = eventPtr->xkey.keycode; + goto doNumber; + case 'm': + if (flags & CROSSING) { + number = eventPtr->xcrossing.mode; + } else if (flags & FOCUS) { + number = eventPtr->xfocus.mode; + } + string = TkFindStateString(notifyMode, number); + goto doString; + case 'o': + if (flags & CREATE) { + number = eventPtr->xcreatewindow.override_redirect; + } else if (flags & MAP) { + number = eventPtr->xmap.override_redirect; + } else if (flags & REPARENT) { + number = eventPtr->xreparent.override_redirect; + } else if (flags & CONFIG) { + number = eventPtr->xconfigure.override_redirect; + } + goto doNumber; + case 'p': + string = TkFindStateString(circPlace, eventPtr->xcirculate.place); + goto doString; + case 's': + if (flags & (KEY_BUTTON_MOTION_VIRTUAL)) { + number = eventPtr->xkey.state; + } else if (flags & CROSSING) { + number = eventPtr->xcrossing.state; + } else if (flags & VISIBILITY) { + string = TkFindStateString(visNotify, + eventPtr->xvisibility.state); + goto doString; + } + goto doNumber; + case 't': + if (flags & (KEY_BUTTON_MOTION_VIRTUAL)) { + number = (int) eventPtr->xkey.time; + } else if (flags & CROSSING) { + number = (int) eventPtr->xcrossing.time; + } else if (flags & PROP) { + number = (int) eventPtr->xproperty.time; + } + goto doNumber; + case 'v': + number = eventPtr->xconfigurerequest.value_mask; + goto doNumber; + case 'w': + if (flags & EXPOSE) { + number = eventPtr->xexpose.width; + } else if (flags & CONFIG) { + number = eventPtr->xconfigure.width; + } + goto doNumber; + case 'x': + if (flags & (KEY_BUTTON_MOTION_VIRTUAL)) { + number = eventPtr->xkey.x; + } else if (flags & CROSSING) { + number = eventPtr->xcrossing.x; + } else if (flags & EXPOSE) { + number = eventPtr->xexpose.x; + } else if (flags & (CREATE|CONFIG|GRAVITY)) { + number = eventPtr->xcreatewindow.x; + } else if (flags & REPARENT) { + number = eventPtr->xreparent.x; + } + goto doNumber; + case 'y': + if (flags & (KEY_BUTTON_MOTION_VIRTUAL)) { + number = eventPtr->xkey.y; + } else if (flags & EXPOSE) { + number = eventPtr->xexpose.y; + } else if (flags & (CREATE|CONFIG|GRAVITY)) { + number = eventPtr->xcreatewindow.y; + } else if (flags & REPARENT) { + number = eventPtr->xreparent.y; + } else if (flags & CROSSING) { + number = eventPtr->xcrossing.y; + + } + 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; + } + goto doString; + case 'B': + number = eventPtr->xcreatewindow.border_width; + goto doNumber; + case 'E': + number = (int) eventPtr->xany.send_event; + goto doNumber; + case 'K': + if (flags & KEY) { + char *name; + + name = TkKeysymToString(keySym); + if (name != NULL) { + string = name; + } + } + goto doString; + case 'N': + number = (int) keySym; + goto doNumber; + case 'R': + TkpPrintWindowId(numStorage, eventPtr->xkey.root); + string = numStorage; + goto doString; + case 'S': + TkpPrintWindowId(numStorage, eventPtr->xkey.subwindow); + string = numStorage; + goto doString; + case 'T': + number = eventPtr->type; + goto doNumber; + case 'W': { + Tk_Window tkwin; + + tkwin = Tk_IdToWindow(eventPtr->xany.display, + eventPtr->xany.window); + if (tkwin != NULL) { + string = Tk_PathName(tkwin); + } else { + string = "??"; + } + goto doString; + } + case 'X': { + Tk_Window tkwin; + int x, y; + int width, height; + + number = eventPtr->xkey.x_root; + tkwin = Tk_IdToWindow(eventPtr->xany.display, + eventPtr->xany.window); + if (tkwin != NULL) { + Tk_GetVRootGeometry(tkwin, &x, &y, &width, &height); + number -= x; + } + goto doNumber; + } + case 'Y': { + Tk_Window tkwin; + int x, y; + int width, height; + + number = eventPtr->xkey.y_root; + tkwin = Tk_IdToWindow(eventPtr->xany.display, + eventPtr->xany.window); + if (tkwin != NULL) { + Tk_GetVRootGeometry(tkwin, &x, &y, &width, &height); + number -= y; + } + goto doNumber; + } + default: + numStorage[0] = before[1]; + numStorage[1] = '\0'; + string = numStorage; + goto doString; + } + + doNumber: + sprintf(numStorage, "%d", number); + string = numStorage; + + doString: + spaceNeeded = Tcl_ScanElement(string, &cvtFlags); + length = Tcl_DStringLength(dsPtr); + Tcl_DStringSetLength(dsPtr, length + spaceNeeded); + spaceNeeded = Tcl_ConvertElement(string, + Tcl_DStringValue(dsPtr) + length, + cvtFlags | TCL_DONT_USE_BRACES); + Tcl_DStringSetLength(dsPtr, length + spaceNeeded); + before += 2; + } +} + +/* + *---------------------------------------------------------------------- + * + * ChangeScreen -- + * + * This procedure is invoked whenever the current screen changes + * in an application. It invokes a Tcl procedure named + * "tkScreenChanged", passing it the screen name as argument. + * tkScreenChanged does things like making the tkPriv variable + * point to an array for the current display. + * + * Results: + * None. + * + * Side effects: + * Depends on what tkScreenChanged does. If an error occurs + * them tkError will be invoked. + * + *---------------------------------------------------------------------- + */ + +static void +ChangeScreen(interp, dispName, screenIndex) + Tcl_Interp *interp; /* Interpreter in which to invoke + * command. */ + char *dispName; /* Name of new display. */ + int screenIndex; /* Index of new screen. */ +{ + Tcl_DString cmd; + int code; + char screen[30]; + + Tcl_DStringInit(&cmd); + Tcl_DStringAppend(&cmd, "tkScreenChanged ", 16); + Tcl_DStringAppend(&cmd, dispName, -1); + sprintf(screen, ".%d", screenIndex); + Tcl_DStringAppend(&cmd, screen, -1); + code = Tcl_GlobalEval(interp, Tcl_DStringValue(&cmd)); + if (code != TCL_OK) { + Tcl_AddErrorInfo(interp, + "\n (changing screen in event binding)"); + Tcl_BackgroundError(interp); + } +} + + +/* + *---------------------------------------------------------------------- + * + * Tk_EventCmd -- + * + * This procedure is invoked to process the "event" Tcl command. + * It is used to define and generate events. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tk_EventCmd(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. */ +{ + int i; + size_t length; + char *option; + 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; + } + + 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) { + return TCL_ERROR; + } + } + } 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) { + return TCL_ERROR; + } + } + } 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; + } + 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; + } + } else { + badopt: + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be add, delete, generate, info", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * InitVirtualEventTable -- + * + * Given storage for a virtual event table, set up the fields to + * prepare a new domain in which virtual events may be defined. + * + * Results: + * None. + * + * Side effects: + * *vetPtr is now initialized. + * + *--------------------------------------------------------------------------- + */ + +static void +InitVirtualEventTable(vetPtr) + VirtualEventTable *vetPtr; /* Pointer to virtual event table. Memory + * is supplied by the caller. */ +{ + Tcl_InitHashTable(&vetPtr->patternTable, + sizeof(PatternTableKey) / sizeof(int)); + Tcl_InitHashTable(&vetPtr->nameTable, TCL_ONE_WORD_KEYS); +} + +/* + *--------------------------------------------------------------------------- + * + * DeleteVirtualEventTable -- + * + * Delete the contents of a virtual event table. The caller is + * responsible for freeing any memory used by the table itself. + * + * Results: + * None. + * + * Side effects: + * Memory is freed. + * + *--------------------------------------------------------------------------- + */ + +static void +DeleteVirtualEventTable(vetPtr) + VirtualEventTable *vetPtr; /* The virtual event table to delete. */ +{ + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + PatSeq *psPtr, *nextPtr; + + hPtr = Tcl_FirstHashEntry(&vetPtr->patternTable, &search); + for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + psPtr = (PatSeq *) Tcl_GetHashValue(hPtr); + for ( ; psPtr != NULL; psPtr = nextPtr) { + nextPtr = psPtr->nextSeqPtr; + ckfree((char *) psPtr->voPtr); + ckfree((char *) psPtr); + } + } + Tcl_DeleteHashTable(&vetPtr->patternTable); + + hPtr = Tcl_FirstHashEntry(&vetPtr->nameTable, &search); + for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + ckfree((char *) Tcl_GetHashValue(hPtr)); + } + Tcl_DeleteHashTable(&vetPtr->nameTable); +} + +/* + *---------------------------------------------------------------------- + * + * CreateVirtualEvent -- + * + * Add a new definition for a virtual event. If the virtual event + * is already defined, the new definition augments those that + * already exist. + * + * 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. + * + * Side effects: + * The virtual event may cause future calls to Tk_BindEvent to + * behave differently than they did previously. + * + *---------------------------------------------------------------------- + */ + +static int +CreateVirtualEvent(interp, vetPtr, virtString, eventString) + Tcl_Interp *interp; /* Used for error reporting. */ + VirtualEventTable *vetPtr;/* Table in which to augment virtual event. */ + char *virtString; /* Name of new virtual event. */ + char *eventString; /* String describing physical event that + * triggers virtual event. */ +{ + PatSeq *psPtr; + int dummy; + Tcl_HashEntry *vhPtr; + unsigned long eventMask; + PhysicalsOwned *poPtr; + VirtualOwners *voPtr; + Tk_Uid virtUid; + + virtUid = GetVirtualEventUid(interp, virtString); + if (virtUid == NULL) { + return TCL_ERROR; + } + + /* + * Find/create physical event + */ + + psPtr = FindSequence(interp, &vetPtr->patternTable, NULL, eventString, + 1, 0, &eventMask); + if (psPtr == NULL) { + return TCL_ERROR; + } + + /* + * Find/create virtual event. + */ + + vhPtr = Tcl_CreateHashEntry(&vetPtr->nameTable, virtUid, &dummy); + + /* + * Make virtual event own the physical event. + */ + + poPtr = (PhysicalsOwned *) Tcl_GetHashValue(vhPtr); + if (poPtr == NULL) { + poPtr = (PhysicalsOwned *) ckalloc(sizeof(PhysicalsOwned)); + poPtr->numOwned = 0; + } else { + /* + * See if this virtual event is already defined for this physical + * event and just return if it is. + */ + + int i; + for (i = 0; i < poPtr->numOwned; i++) { + if (poPtr->patSeqs[i] == psPtr) { + return TCL_OK; + } + } + poPtr = (PhysicalsOwned *) ckrealloc((char *) poPtr, + sizeof(PhysicalsOwned) + poPtr->numOwned * sizeof(PatSeq *)); + } + Tcl_SetHashValue(vhPtr, (ClientData) poPtr); + poPtr->patSeqs[poPtr->numOwned] = psPtr; + poPtr->numOwned++; + + /* + * Make physical event so it can trigger the virtual event. + */ + + voPtr = psPtr->voPtr; + if (voPtr == NULL) { + voPtr = (VirtualOwners *) ckalloc(sizeof(VirtualOwners)); + voPtr->numOwners = 0; + } else { + voPtr = (VirtualOwners *) ckrealloc((char *) voPtr, + sizeof(VirtualOwners) + + voPtr->numOwners * sizeof(Tcl_HashEntry *)); + } + psPtr->voPtr = voPtr; + voPtr->owners[voPtr->numOwners] = vhPtr; + voPtr->numOwners++; + + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * DeleteVirtualEvent -- + * + * Remove the definition of a given virtual event. If the + * event string is NULL, all definitions of the virtual event + * will be removed. Otherwise, just the specified definition + * of the virtual event will be removed. + * + * Results: + * The result is a standard Tcl return value. If an error + * occurs then interp->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. + * + * Side effects: + * The virtual event given by virtString may be removed from the + * virtual event table. + * + *-------------------------------------------------------------- + */ + +static int +DeleteVirtualEvent(interp, vetPtr, virtString, eventString) + Tcl_Interp *interp; /* Used for error reporting. */ + VirtualEventTable *vetPtr;/* Table in which to delete event. */ + char *virtString; /* String describing event sequence that + * triggers binding. */ + char *eventString; /* The event sequence that should be deleted, + * or NULL to delete all event sequences for + * the entire virtual event. */ +{ + int iPhys; + Tk_Uid virtUid; + Tcl_HashEntry *vhPtr; + PhysicalsOwned *poPtr; + PatSeq *eventPSPtr; + + virtUid = GetVirtualEventUid(interp, virtString); + if (virtUid == NULL) { + return TCL_ERROR; + } + + vhPtr = Tcl_FindHashEntry(&vetPtr->nameTable, virtUid); + if (vhPtr == NULL) { + return TCL_OK; + } + poPtr = (PhysicalsOwned *) Tcl_GetHashValue(vhPtr); + + eventPSPtr = NULL; + if (eventString != NULL) { + unsigned long eventMask; + + /* + * Delete only the specific physical event associated with the + * virtual event. If the physical event doesn't already exist, or + * the virtual event doesn't own that physical event, return w/o + * doing anything. + */ + + eventPSPtr = FindSequence(interp, &vetPtr->patternTable, NULL, + eventString, 0, 0, &eventMask); + if (eventPSPtr == NULL) { + return (interp->result[0] != '\0') ? TCL_ERROR : TCL_OK; + } + } + + for (iPhys = poPtr->numOwned; --iPhys >= 0; ) { + PatSeq *psPtr = poPtr->patSeqs[iPhys]; + if ((eventPSPtr == NULL) || (psPtr == eventPSPtr)) { + int iVirt; + VirtualOwners *voPtr; + + /* + * Remove association between this physical event and the given + * virtual event that it triggers. + */ + + voPtr = psPtr->voPtr; + for (iVirt = 0; iVirt < voPtr->numOwners; iVirt++) { + if (voPtr->owners[iVirt] == vhPtr) { + break; + } + } + if (iVirt == voPtr->numOwners) { + panic("DeleteVirtualEvent: couldn't find owner"); + } + voPtr->numOwners--; + if (voPtr->numOwners == 0) { + /* + * Removed last reference to this physical event, so + * remove it from physical->virtual map. + */ + PatSeq *prevPtr = (PatSeq *) Tcl_GetHashValue(psPtr->hPtr); + if (prevPtr == psPtr) { + if (psPtr->nextSeqPtr == NULL) { + Tcl_DeleteHashEntry(psPtr->hPtr); + } else { + Tcl_SetHashValue(psPtr->hPtr, + psPtr->nextSeqPtr); + } + } else { + for ( ; ; prevPtr = prevPtr->nextSeqPtr) { + if (prevPtr == NULL) { + panic("Tk_DeleteVirtualEvent couldn't find on hash chain"); + } + if (prevPtr->nextSeqPtr == psPtr) { + prevPtr->nextSeqPtr = psPtr->nextSeqPtr; + break; + } + } + } + ckfree((char *) psPtr->voPtr); + ckfree((char *) psPtr); + } else { + /* + * This physical event still triggers some other virtual + * event(s). Consolidate the list of virtual owners for + * this physical event so it no longer triggers the + * given virtual event. + */ + voPtr->owners[iVirt] = voPtr->owners[voPtr->numOwners]; + } + + /* + * Now delete the virtual event's reference to the physical + * event. + */ + + poPtr->numOwned--; + if (eventPSPtr != NULL && poPtr->numOwned != 0) { + /* + * Just deleting this one physical event. Consolidate list + * of owned physical events and return. + */ + + poPtr->patSeqs[iPhys] = poPtr->patSeqs[poPtr->numOwned]; + return TCL_OK; + } + } + } + + if (poPtr->numOwned == 0) { + /* + * All the physical events for this virtual event were deleted, + * either because there was only one associated physical event or + * because the caller was deleting the entire virtual event. Now + * the virtual event itself should be deleted. + */ + + ckfree((char *) poPtr); + Tcl_DeleteHashEntry(vhPtr); + } + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * GetVirtualEvent -- + * + * Return the list of physical events that can invoke the + * given virtual event. + * + * Results: + * The return value is TCL_OK and interp->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 + * virtual event string is improperly formed, then TCL_ERROR is + * returned and an error message is left in interp->result. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +static int +GetVirtualEvent(interp, vetPtr, virtString) + Tcl_Interp *interp; /* Interpreter for reporting. */ + VirtualEventTable *vetPtr;/* Table in which to look for event. */ + char *virtString; /* String describing virtual event. */ +{ + Tcl_HashEntry *vhPtr; + Tcl_DString ds; + int iPhys; + PhysicalsOwned *poPtr; + Tk_Uid virtUid; + + virtUid = GetVirtualEventUid(interp, virtString); + if (virtUid == NULL) { + return TCL_ERROR; + } + + vhPtr = Tcl_FindHashEntry(&vetPtr->nameTable, virtUid); + if (vhPtr == NULL) { + return TCL_OK; + } + + Tcl_DStringInit(&ds); + + poPtr = (PhysicalsOwned *) Tcl_GetHashValue(vhPtr); + for (iPhys = 0; iPhys < poPtr->numOwned; iPhys++) { + Tcl_DStringSetLength(&ds, 0); + GetPatternString(poPtr->patSeqs[iPhys], &ds); + Tcl_AppendElement(interp, Tcl_DStringValue(&ds)); + } + Tcl_DStringFree(&ds); + + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * GetAllVirtualEvents -- + * + * Return a list that contains the names of all the virtual + * event defined. + * + * Results: + * There is no return value. Interp->result is modified to + * hold a Tcl list with one entry for each virtual event in + * nameTable. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static void +GetAllVirtualEvents(interp, vetPtr) + Tcl_Interp *interp; /* Interpreter returning result. */ + VirtualEventTable *vetPtr;/* Table containing events. */ +{ + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + Tcl_DString ds; + + Tcl_DStringInit(&ds); + + hPtr = Tcl_FirstHashEntry(&vetPtr->nameTable, &search); + for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + Tcl_DStringSetLength(&ds, 0); + Tcl_DStringAppend(&ds, "<<", 2); + Tcl_DStringAppend(&ds, Tcl_GetHashKey(hPtr->tablePtr, hPtr), -1); + Tcl_DStringAppend(&ds, ">>", 2); + Tcl_AppendElement(interp, Tcl_DStringValue(&ds)); + } + + Tcl_DStringFree(&ds); +} + +/* + *--------------------------------------------------------------------------- + * + * HandleEventGenerate -- + * + * Helper function for the "event generate" command. Generate and + * process an XEvent, constructed from information parsed from the + * event description string and its optional arguments. + * + * argv[0] contains name of the target window. + * argv[1] contains pattern string for one event (e.g, ). + * argv[2..argc-1] contains -field/option pairs for specifying + * additional detail in the generated event. + * + * Either virtual or physical events can be generated this way. + * The event description string must contain the specification + * for only one event. + * + * Results: + * None. + * + * Side effects: + * When constructing the event, + * event.xany.serial is filled with the current X serial number. + * event.xany.window is filled with the target window. + * event.xany.display is filled with the target window's display. + * Any other fields in eventPtr which are not specified by the pattern + * string or the optional arguments, are set to 0. + * + * The event may be handled sychronously or asynchronously, depending + * on the value specified by the optional "-when" option. The + * default setting is synchronous. + * + *--------------------------------------------------------------------------- + */ +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. */ +{ + Pattern pat; + Tk_Window tkwin; + char *p; + unsigned long eventMask; + int count, i, state, flags, synch; + Tcl_QueuePosition pos; + XEvent event; + + 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; + } + } + + p = argv[1]; + count = ParseEventDescription(interp, &p, &pat, &eventMask); + if (count == 0) { + return TCL_ERROR; + } + if (count != 1) { + interp->result = "Double or Triple modifier not allowed"; + 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); + return TCL_ERROR; + } + + memset((VOID *) &event, 0, sizeof(event)); + event.xany.type = pat.eventType; + event.xany.serial = NextRequest(Tk_Display(tkwin)); + event.xany.send_event = False; + event.xany.window = Tk_WindowId(tkwin); + event.xany.display = Tk_Display(tkwin); + + flags = flagArray[event.xany.type]; + 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; + } + } + } + } else if (flags & BUTTON) { + event.xbutton.button = pat.detail.button; + } else if (flags & VIRTUAL) { + ((XVirtualEvent *) &event)->name = pat.detail.name; + } + } + if (flags & (CREATE|DESTROY|UNMAP|MAP|REPARENT|CONFIG|GRAVITY|CIRC)) { + event.xcreatewindow.window = event.xany.window; + } + + /* + * Process the remaining arguments to fill in additional fields + * of the event. + */ + + synch = 1; + pos = TCL_QUEUE_TAIL; + for (i = 2; i < argc; i += 2) { + char *field, *value; + Tk_Window tkwin2; + int number; + KeySym keysym; + + 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; + synch = 0; + } else { + Tcl_AppendResult(interp, "bad position \"", value, + "\": should be now, head, mark, tail", (char *) NULL); + return TCL_ERROR; + } + } else if (strcmp(field, "-above") == 0) { + if (value[0] == '.') { + tkwin2 = Tk_NameToWindow(interp, value, main); + if (tkwin2 == NULL) { + 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 & (CREATE|CONFIG)) { + event.xcreatewindow.border_width = number; + } else { + goto badopt; + } + } else if (strcmp(field, "-button") == 0) { + if (Tcl_GetInt(interp, value, &number) != TCL_OK) { + return TCL_ERROR; + } + if (flags & BUTTON) { + event.xbutton.button = number; + } else { + goto badopt; + } + } else if (strcmp(field, "-count") == 0) { + if (Tcl_GetInt(interp, value, &number) != TCL_OK) { + return TCL_ERROR; + } + if (flags & EXPOSE) { + event.xexpose.count = number; + } else { + goto badopt; + } + } else if (strcmp(field, "-detail") == 0) { + number = TkFindStateNum(interp, field, notifyDetail, value); + if (number < 0) { + return TCL_ERROR; + } + if (flags & FOCUS) { + event.xfocus.detail = number; + } else if (flags & CROSSING) { + event.xcrossing.detail = number; + } else { + goto badopt; + } + } else if (strcmp(field, "-focus") == 0) { + if (Tcl_GetBoolean(interp, value, &number) != TCL_OK) { + return TCL_ERROR; + } + if (flags & CROSSING) { + event.xcrossing.focus = number; + } else { + goto badopt; + } + } else if (strcmp(field, "-height") == 0) { + if (Tk_GetPixels(interp, tkwin, value, &number) != TCL_OK) { + return TCL_ERROR; + } + if (flags & EXPOSE) { + event.xexpose.height = number; + } else if (flags & CONFIG) { + event.xconfigure.height = number; + } else { + goto badopt; + } + } else if (strcmp(field, "-keycode") == 0) { + if (Tcl_GetInt(interp, value, &number) != TCL_OK) { + return TCL_ERROR; + } + if (flags & KEY) { + event.xkey.keycode = number; + } else { + goto badopt; + } + } else if (strcmp(field, "-keysym") == 0) { + keysym = TkStringToKeysym(value); + if (keysym == NoSymbol) { + Tcl_AppendResult(interp, "unknown keysym \"", value, + "\"", (char *) NULL); + return TCL_ERROR; + } + /* + * 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. + */ + + 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; + } + if (state & 2) { + TkDisplay *dispPtr = ((TkWindow *) tkwin)->dispPtr; + event.xkey.state |= dispPtr->modeModMask; + } + 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; + } + } else if (strcmp(field, "-root") == 0) { + if (value[0] == '.') { + tkwin2 = Tk_NameToWindow(interp, value, main); + if (tkwin2 == NULL) { + 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; + } + if (flags & (KEY_BUTTON_MOTION_VIRTUAL|CROSSING)) { + event.xkey.y_root = number; + } else { + goto badopt; + } + } 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) { + return TCL_ERROR; + } + } else { + if (Tcl_GetBoolean(interp, value, &number) != TCL_OK) { + return TCL_ERROR; + } + } + 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) { + return TCL_ERROR; + } + if (flags & (KEY_BUTTON_MOTION_VIRTUAL)) { + event.xkey.state = number; + } else { + event.xcrossing.state = number; + } + } else if (flags & VISIBILITY) { + number = TkFindStateNum(interp, field, visNotify, value); + if (number < 0) { + 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; + } + 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; + } + } else if (strcmp(field, "-window") == 0) { + if (value[0] == '.') { + tkwin2 = Tk_NameToWindow(interp, value, main); + if (tkwin2 == NULL) { + 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; + } + } else if (strcmp(field, "-y") == 0) { + int rootX, rootY; + if (Tk_GetPixels(interp, tkwin, value, &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; + } + } else { + badopt: + Tcl_AppendResult(interp, "bad option to ", argv[1], + " event: \"", field, "\"", (char *) NULL); + return TCL_ERROR; + } + } + + if (synch != 0) { + Tk_HandleEvent(&event); + } else { + Tk_QueueWindowEvent(&event, pos); + } + Tcl_ResetResult(interp); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * GetVirtualEventUid -- + * + * Determine if the given string is in the proper format for a + * virtual event. + * + * 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 + * value is a Tk_Uid that represents the virtual event. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ +static Tk_Uid +GetVirtualEventUid(interp, virtString) + Tcl_Interp *interp; + char *virtString; +{ + Tk_Uid uid; + int length; + + length = strlen(virtString); + + if (length < 5 || virtString[0] != '<' || virtString[1] != '<' || + virtString[length - 2] != '>' || virtString[length - 1] != '>') { + Tcl_AppendResult(interp, "virtual event \"", virtString, + "\" is badly formed", (char *) NULL); + return NULL; + } + virtString[length - 2] = '\0'; + uid = Tk_GetUid(virtString + 2); + virtString[length - 2] = '>'; + + return uid; +} + + +/* + *---------------------------------------------------------------------- + * + * FindSequence -- + * + * Find the entry in the pattern table that corresponds to a + * particular pattern string, and return a pointer to that + * entry. + * + * Results: + * The return value is normally a pointer to the PatSeq + * 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. + * 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 + * on which the pattern sequence depends. + * + * Side effects: + * A new pattern sequence may be allocated. + * + *---------------------------------------------------------------------- + */ + +static PatSeq * +FindSequence(interp, patternTablePtr, object, eventString, create, + allowVirtual, maskPtr) + Tcl_Interp *interp; /* Interpreter to use for error + * reporting. */ + Tcl_HashTable *patternTablePtr; /* Table to use for lookup. */ + ClientData object; /* For binding table, token for object with + * which binding is associated. + * For virtual event table, NULL. */ + char *eventString; /* String description of pattern to + * match on. See user documentation + * for details. */ + int create; /* 0 means don't create the entry if + * it doesn't already exist. Non-zero + * means create. */ + int allowVirtual; /* 0 means that virtual events are not + * allowed in the sequence. Non-zero + * otherwise. */ + unsigned long *maskPtr; /* *maskPtr is filled in with the event + * types on which this pattern sequence + * depends. */ +{ + + Pattern pats[EVENT_BUFFER_SIZE]; + int numPats, virtualFound; + char *p; + Pattern *patPtr; + PatSeq *psPtr; + Tcl_HashEntry *hPtr; + int flags, count, new; + size_t sequenceSize; + unsigned long eventMask; + PatternTableKey key; + + /* + *------------------------------------------------------------- + * Step 1: parse the pattern string to produce an array + * of Patterns. The array is generated backwards, so + * that the lowest-indexed pattern corresponds to the last + * event that must occur. + *------------------------------------------------------------- + */ + + p = eventString; + flags = 0; + eventMask = 0; + virtualFound = 0; + + patPtr = &pats[EVENT_BUFFER_SIZE-1]; + for (numPats = 0; numPats < EVENT_BUFFER_SIZE; numPats++, patPtr--) { + while (isspace(UCHAR(*p))) { + p++; + } + if (*p == '\0') { + break; + } + + count = ParseEventDescription(interp, &p, patPtr, &eventMask); + if (count == 0) { + return NULL; + } + + if (eventMask & VirtualEventMask) { + if (allowVirtual == 0) { + interp->result = + "virtual event not allowed in definition of another virtual event"; + return NULL; + } + virtualFound = 1; + } + + /* + * Replicate events for DOUBLE and TRIPLE. + */ + + if ((count > 1) && (numPats < EVENT_BUFFER_SIZE-1)) { + flags |= PAT_NEARBY; + patPtr[-1] = patPtr[0]; + patPtr--; + numPats++; + if ((count == 3) && (numPats < EVENT_BUFFER_SIZE-1)) { + patPtr[-1] = patPtr[0]; + patPtr--; + numPats++; + } + } + } + + /* + *------------------------------------------------------------- + * Step 2: find the sequence in the binding table if it exists, + * and add a new sequence to the table if it doesn't. + *------------------------------------------------------------- + */ + + if (numPats == 0) { + interp->result = "no events specified in binding"; + return NULL; + } + if ((numPats > 1) && (virtualFound != 0)) { + interp->result = "virtual events may not be composed"; + return NULL; + } + + patPtr = &pats[EVENT_BUFFER_SIZE-numPats]; + memset(&key, 0, sizeof(key)); + key.object = object; + key.type = patPtr->eventType; + key.detail = patPtr->detail; + hPtr = Tcl_CreateHashEntry(patternTablePtr, (char *) &key, &new); + sequenceSize = numPats*sizeof(Pattern); + if (!new) { + for (psPtr = (PatSeq *) Tcl_GetHashValue(hPtr); psPtr != NULL; + psPtr = psPtr->nextSeqPtr) { + if ((numPats == psPtr->numPats) + && ((flags & PAT_NEARBY) == (psPtr->flags & PAT_NEARBY)) + && (memcmp((char *) patPtr, (char *) psPtr->pats, + sequenceSize) == 0)) { + goto done; + } + } + } + if (!create) { + if (new) { + Tcl_DeleteHashEntry(hPtr); + } + return NULL; + } + psPtr = (PatSeq *) ckalloc((unsigned) (sizeof(PatSeq) + + (numPats-1)*sizeof(Pattern))); + psPtr->numPats = numPats; + psPtr->eventProc = NULL; + psPtr->freeProc = NULL; + psPtr->clientData = NULL; + psPtr->flags = flags; + psPtr->refCount = 0; + psPtr->nextSeqPtr = (PatSeq *) Tcl_GetHashValue(hPtr); + psPtr->hPtr = hPtr; + psPtr->voPtr = NULL; + psPtr->nextObjPtr = NULL; + Tcl_SetHashValue(hPtr, psPtr); + + memcpy((VOID *) psPtr->pats, (VOID *) patPtr, sequenceSize); + + done: + *maskPtr = eventMask; + return psPtr; +} + +/* + *--------------------------------------------------------------------------- + * + * ParseEventDescription -- + * + * Fill Pattern buffer with information about event from + * event string. + * + * Results: + * Leaves error message in interp and returns 0 if there was an + * error due to a badly formed event string. Returns 1 if proper + * event was specified, 2 if Double modifier was used in event + * string, or 3 if Triple was used. + * + * Side effects: + * On exit, eventStringPtr points to rest of event string (after the + * closing '>', so that this procedure can be called repeatedly to + * parse all the events in the entire sequence. + * + *--------------------------------------------------------------------------- + */ + +static int +ParseEventDescription(interp, eventStringPtr, patPtr, + eventMaskPtr) + Tcl_Interp *interp; /* For error messages. */ + char **eventStringPtr; /* On input, holds a pointer to start of + * event string. On exit, gets pointer to + * rest of string after parsed event. */ + Pattern *patPtr; /* Filled with the pattern parsed from the + * event string. */ + unsigned long *eventMaskPtr;/* Filled with event mask of matched event. */ + +{ + char *p; + unsigned long eventMask; + int count, eventFlags; +#define FIELD_SIZE 48 + char field[FIELD_SIZE]; + Tcl_HashEntry *hPtr; + + p = *eventStringPtr; + + patPtr->eventType = -1; + patPtr->needMods = 0; + patPtr->detail.clientData = 0; + + eventMask = 0; + count = 1; + + /* + * Handle simple ASCII characters. + */ + + if (*p != '<') { + char string[2]; + + patPtr->eventType = KeyPress; + eventMask = KeyPressMask; + string[0] = *p; + string[1] = 0; + patPtr->detail.keySym = TkStringToKeysym(string); + if (patPtr->detail.keySym == NoSymbol) { + if (isprint(UCHAR(*p))) { + patPtr->detail.keySym = *p; + } else { + sprintf(interp->result, + "bad ASCII character 0x%x", (unsigned char) *p); + return 0; + } + } + p++; + goto end; + } + + /* + * A fancier event description. This can be either a virtual event + * or a physical event. + * + * A virtual event description consists of: + * + * 1. double open angle brackets. + * 2. virtual event name. + * 3. double close angle brackets. + * + * A physical event description consists of: + * + * 1. open angle bracket. + * 2. any number of modifiers, each followed by spaces + * or dashes. + * 3. an optional event name. + * 4. an option button or keysym name. Either this or + * item 3 *must* be present; if both are present + * then they are separated by spaces or dashes. + * 5. a close angle bracket. + */ + + p++; + if (*p == '<') { + /* + * This is a virtual event: soak up all the characters up to + * the next '>'. + */ + + char *field = p + 1; + p = strchr(field, '>'); + if (p == field) { + interp->result = "virtual event \"<<>>\" is badly formed"; + return 0; + } + if ((p == NULL) || (p[1] != '>')) { + interp->result = "missing \">\" in virtual binding"; + return 0; + } + *p = '\0'; + patPtr->eventType = VirtualEvent; + eventMask = VirtualEventMask; + patPtr->detail.name = Tk_GetUid(field); + *p = '>'; + + p += 2; + goto end; + } + + while (1) { + ModInfo *modPtr; + p = GetField(p, field, FIELD_SIZE); + if (*p == '>') { + /* + * This solves the problem of, e.g., being + * misinterpreted as Control + Meta + missing keysym + * instead of Control + KeyPress + M. + */ + break; + } + hPtr = Tcl_FindHashEntry(&modTable, field); + if (hPtr == NULL) { + break; + } + modPtr = (ModInfo *) Tcl_GetHashValue(hPtr); + patPtr->needMods |= modPtr->mask; + if (modPtr->flags & (DOUBLE|TRIPLE)) { + if (modPtr->flags & DOUBLE) { + count = 2; + } else { + count = 3; + } + } + while ((*p == '-') || isspace(UCHAR(*p))) { + p++; + } + } + + eventFlags = 0; + hPtr = Tcl_FindHashEntry(&eventTable, field); + if (hPtr != NULL) { + EventInfo *eiPtr; + eiPtr = (EventInfo *) Tcl_GetHashValue(hPtr); + + patPtr->eventType = eiPtr->type; + eventFlags = flagArray[eiPtr->type]; + eventMask = eiPtr->eventMask; + while ((*p == '-') || isspace(UCHAR(*p))) { + p++; + } + p = GetField(p, field, FIELD_SIZE); + } + if (*field != '\0') { + if ((*field >= '1') && (*field <= '5') && (field[1] == '\0')) { + if (eventFlags == 0) { + patPtr->eventType = ButtonPress; + eventMask = ButtonPressMask; + } else if (eventFlags & KEY) { + goto getKeysym; + } else if ((eventFlags & BUTTON) == 0) { + Tcl_AppendResult(interp, "specified button \"", field, + "\" for non-button event", (char *) NULL); + return 0; + } + patPtr->detail.button = (*field - '0'); + } else { + getKeysym: + patPtr->detail.keySym = TkStringToKeysym(field); + if (patPtr->detail.keySym == NoSymbol) { + Tcl_AppendResult(interp, "bad event type or keysym \"", + field, "\"", (char *) NULL); + return 0; + } + if (eventFlags == 0) { + patPtr->eventType = KeyPress; + eventMask = KeyPressMask; + } else if ((eventFlags & KEY) == 0) { + Tcl_AppendResult(interp, "specified keysym \"", field, + "\" for non-key event", (char *) NULL); + return 0; + } + } + } else if (eventFlags == 0) { + interp->result = "no event type or button # or keysym"; + return 0; + } + + while ((*p == '-') || isspace(UCHAR(*p))) { + p++; + } + if (*p != '>') { + while (*p != '\0') { + p++; + if (*p == '>') { + interp->result = "extra characters after detail in binding"; + return 0; + } + } + interp->result = "missing \">\" in binding"; + return 0; + } + p++; + +end: + *eventStringPtr = p; + *eventMaskPtr |= eventMask; + return count; +} + +/* + *---------------------------------------------------------------------- + * + * GetField -- + * + * Used to parse pattern descriptions. Copies up to + * size characters from p to copy, stopping at end of + * string, space, "-", ">", or whenever size is + * exceeded. + * + * Results: + * The return value is a pointer to the character just + * after the last one copied (usually "-" or space or + * ">", but could be anything if size was exceeded). + * Also places NULL-terminated string (up to size + * character, including NULL), at copy. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static char * +GetField(p, copy, size) + char *p; /* Pointer to part of pattern. */ + char *copy; /* Place to copy field. */ + int size; /* Maximum number of characters to + * copy. */ +{ + while ((*p != '\0') && !isspace(UCHAR(*p)) && (*p != '>') + && (*p != '-') && (size > 1)) { + *copy = *p; + p++; + copy++; + size--; + } + *copy = '\0'; + return p; +} + +/* + *--------------------------------------------------------------------------- + * + * GetPatternString -- + * + * Produce a string version of the given event, for displaying to + * the user. + * + * Results: + * The string is left in dsPtr. + * + * Side effects: + * It is the caller's responsibility to initialize the DString before + * and to free it after calling this procedure. + * + *--------------------------------------------------------------------------- + */ +static void +GetPatternString(psPtr, dsPtr) + PatSeq *psPtr; + Tcl_DString *dsPtr; +{ + Pattern *patPtr; + char c, buffer[10]; + int patsLeft, needMods; + ModInfo *modPtr; + EventInfo *eiPtr; + + /* + * The order of the patterns in the sequence is backwards from the order + * in which they must be output. + */ + + for (patsLeft = psPtr->numPats, patPtr = &psPtr->pats[psPtr->numPats - 1]; + patsLeft > 0; patsLeft--, patPtr--) { + + /* + * Check for simple case of an ASCII character. + */ + + if ((patPtr->eventType == KeyPress) + && ((psPtr->flags & PAT_NEARBY) == 0) + && (patPtr->needMods == 0) + && (patPtr->detail.keySym < 128) + && isprint(UCHAR(patPtr->detail.keySym)) + && (patPtr->detail.keySym != '<') + && (patPtr->detail.keySym != ' ')) { + + c = (char) patPtr->detail.keySym; + Tcl_DStringAppend(dsPtr, &c, 1); + continue; + } + + /* + * Check for virtual event. + */ + + if (patPtr->eventType == VirtualEvent) { + Tcl_DStringAppend(dsPtr, "<<", 2); + Tcl_DStringAppend(dsPtr, patPtr->detail.name, -1); + Tcl_DStringAppend(dsPtr, ">>", 2); + continue; + } + + /* + * It's a more general event specification. First check + * for "Double" or "Triple", then modifiers, then event type, + * then keysym or button detail. + */ + + Tcl_DStringAppend(dsPtr, "<", 1); + if ((psPtr->flags & PAT_NEARBY) && (patsLeft > 1) + && (memcmp((char *) patPtr, (char *) (patPtr-1), + sizeof(Pattern)) == 0)) { + patsLeft--; + patPtr--; + if ((patsLeft > 1) && (memcmp((char *) patPtr, + (char *) (patPtr-1), sizeof(Pattern)) == 0)) { + patsLeft--; + patPtr--; + Tcl_DStringAppend(dsPtr, "Triple-", 7); + } else { + Tcl_DStringAppend(dsPtr, "Double-", 7); + } + } + for (needMods = patPtr->needMods, modPtr = modArray; + needMods != 0; modPtr++) { + if (modPtr->mask & needMods) { + needMods &= ~modPtr->mask; + Tcl_DStringAppend(dsPtr, modPtr->name, -1); + Tcl_DStringAppend(dsPtr, "-", 1); + } + } + for (eiPtr = eventArray; eiPtr->name != NULL; eiPtr++) { + if (eiPtr->type == patPtr->eventType) { + Tcl_DStringAppend(dsPtr, eiPtr->name, -1); + if (patPtr->detail.clientData != 0) { + Tcl_DStringAppend(dsPtr, "-", 1); + } + break; + } + } + + if (patPtr->detail.clientData != 0) { + if ((patPtr->eventType == KeyPress) + || (patPtr->eventType == KeyRelease)) { + char *string; + + string = TkKeysymToString(patPtr->detail.keySym); + if (string != NULL) { + Tcl_DStringAppend(dsPtr, string, -1); + } + } else { + sprintf(buffer, "%d", patPtr->detail.button); + Tcl_DStringAppend(dsPtr, buffer, -1); + } + } + Tcl_DStringAppend(dsPtr, ">", 1); + } +} + +/* + *---------------------------------------------------------------------- + * + * GetKeySym -- + * + * Given an X KeyPress or KeyRelease event, map the + * keycode in the event into a KeySym. + * + * Results: + * The return value is the KeySym corresponding to + * eventPtr, or NoSymbol if no matching Keysym could be + * found. + * + * Side effects: + * In the first call for a given display, keycode-to- + * KeySym maps get loaded. + * + *---------------------------------------------------------------------- + */ + +static KeySym +GetKeySym(dispPtr, eventPtr) + TkDisplay *dispPtr; /* Display in which to + * map keycode. */ + XEvent *eventPtr; /* Description of X event. */ +{ + KeySym sym; + int index; + + /* + * Refresh the mapping information if it's stale + */ + + if (dispPtr->bindInfoStale) { + InitKeymapInfo(dispPtr); + } + + /* + * Figure out which of the four slots in the keymap vector to + * use for this key. Refer to Xlib documentation for more info + * on how this computation works. + */ + + index = 0; + if (eventPtr->xkey.state & dispPtr->modeModMask) { + index = 2; + } + if ((eventPtr->xkey.state & ShiftMask) + || ((dispPtr->lockUsage != LU_IGNORE) + && (eventPtr->xkey.state & LockMask))) { + index += 1; + } + sym = XKeycodeToKeysym(dispPtr->display, eventPtr->xkey.keycode, index); + + /* + * Special handling: if the key was shifted because of Lock, but + * lock is only caps lock, not shift lock, and the shifted keysym + * isn't upper-case alphabetic, then switch back to the unshifted + * keysym. + */ + + if ((index & 1) && !(eventPtr->xkey.state & ShiftMask) + && (dispPtr->lockUsage == LU_CAPS)) { + if (!(((sym >= XK_A) && (sym <= XK_Z)) + || ((sym >= XK_Agrave) && (sym <= XK_Odiaeresis)) + || ((sym >= XK_Ooblique) && (sym <= XK_Thorn)))) { + index &= ~1; + sym = XKeycodeToKeysym(dispPtr->display, eventPtr->xkey.keycode, + index); + } + } + + /* + * Another bit of special handling: if this is a shifted key and there + * is no keysym defined, then use the keysym for the unshifted key. + */ + + if ((index & 1) && (sym == NoSymbol)) { + sym = XKeycodeToKeysym(dispPtr->display, eventPtr->xkey.keycode, + index & ~1); + } + return sym; +} + +/* + *-------------------------------------------------------------- + * + * InitKeymapInfo -- + * + * This procedure is invoked to scan keymap information + * to recompute stuff that's important for binding, such + * as the modifier key (if any) that corresponds to "mode + * switch". + * + * Results: + * None. + * + * Side effects: + * Keymap-related information in dispPtr is updated. + * + *-------------------------------------------------------------- + */ + +static void +InitKeymapInfo(dispPtr) + TkDisplay *dispPtr; /* Display for which to recompute keymap + * information. */ +{ + XModifierKeymap *modMapPtr; + KeyCode *codePtr; + KeySym keysym; + int count, i, j, max, arraySize; +#define KEYCODE_ARRAY_SIZE 20 + + dispPtr->bindInfoStale = 0; + modMapPtr = XGetModifierMapping(dispPtr->display); + + /* + * Check the keycodes associated with the Lock modifier. If + * any of them is associated with the XK_Shift_Lock modifier, + * then Lock has to be interpreted as Shift Lock, not Caps Lock. + */ + + dispPtr->lockUsage = LU_IGNORE; + codePtr = modMapPtr->modifiermap + modMapPtr->max_keypermod*LockMapIndex; + for (count = modMapPtr->max_keypermod; count > 0; count--, codePtr++) { + if (*codePtr == 0) { + continue; + } + keysym = XKeycodeToKeysym(dispPtr->display, *codePtr, 0); + if (keysym == XK_Shift_Lock) { + dispPtr->lockUsage = LU_SHIFT; + break; + } + if (keysym == XK_Caps_Lock) { + dispPtr->lockUsage = LU_CAPS; + break; + } + } + + /* + * Look through the keycodes associated with modifiers to see if + * the the "mode switch", "meta", or "alt" keysyms are associated + * with any modifiers. If so, remember their modifier mask bits. + */ + + dispPtr->modeModMask = 0; + dispPtr->metaModMask = 0; + dispPtr->altModMask = 0; + codePtr = modMapPtr->modifiermap; + max = 8*modMapPtr->max_keypermod; + for (i = 0; i < max; i++, codePtr++) { + if (*codePtr == 0) { + continue; + } + keysym = XKeycodeToKeysym(dispPtr->display, *codePtr, 0); + if (keysym == XK_Mode_switch) { + dispPtr->modeModMask |= ShiftMask << (i/modMapPtr->max_keypermod); + } + if ((keysym == XK_Meta_L) || (keysym == XK_Meta_R)) { + dispPtr->metaModMask |= ShiftMask << (i/modMapPtr->max_keypermod); + } + if ((keysym == XK_Alt_L) || (keysym == XK_Alt_R)) { + dispPtr->altModMask |= ShiftMask << (i/modMapPtr->max_keypermod); + } + } + + /* + * Create an array of the keycodes for all modifier keys. + */ + + if (dispPtr->modKeyCodes != NULL) { + ckfree((char *) dispPtr->modKeyCodes); + } + dispPtr->numModKeyCodes = 0; + arraySize = KEYCODE_ARRAY_SIZE; + dispPtr->modKeyCodes = (KeyCode *) ckalloc((unsigned) + (KEYCODE_ARRAY_SIZE * sizeof(KeyCode))); + for (i = 0, codePtr = modMapPtr->modifiermap; i < max; i++, codePtr++) { + if (*codePtr == 0) { + continue; + } + + /* + * Make sure that the keycode isn't already in the array. + */ + + for (j = 0; j < dispPtr->numModKeyCodes; j++) { + if (dispPtr->modKeyCodes[j] == *codePtr) { + goto nextModCode; + } + } + if (dispPtr->numModKeyCodes >= arraySize) { + KeyCode *new; + + /* + * Ran out of space in the array; grow it. + */ + + arraySize *= 2; + new = (KeyCode *) ckalloc((unsigned) + (arraySize * sizeof(KeyCode))); + memcpy((VOID *) new, (VOID *) dispPtr->modKeyCodes, + (dispPtr->numModKeyCodes * sizeof(KeyCode))); + ckfree((char *) dispPtr->modKeyCodes); + dispPtr->modKeyCodes = new; + } + dispPtr->modKeyCodes[dispPtr->numModKeyCodes] = *codePtr; + dispPtr->numModKeyCodes++; + nextModCode: continue; + } + XFreeModifiermap(modMapPtr); +} + +/* + *--------------------------------------------------------------------------- + * + * EvalTclBinding -- + * + * The procedure that is invoked by Tk_BindEvent when a Tcl binding + * is fired. + * + * Results: + * A standard Tcl result code, the result of globally evaluating the + * percent-substitued binding string. + * + * Side effects: + * Normal side effects due to eval. + * + *--------------------------------------------------------------------------- + */ + +static void +FreeTclBinding(clientData) + ClientData clientData; +{ + ckfree((char *) clientData); +} + +/* + *---------------------------------------------------------------------- + * + * TkStringToKeysym -- + * + * This procedure finds the keysym associated with a given keysym + * name. + * + * Results: + * The return value is the keysym that corresponds to name, or + * NoSymbol if there is no such keysym. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +KeySym +TkStringToKeysym(name) + char *name; /* Name of a keysym. */ +{ +#ifdef REDO_KEYSYM_LOOKUP + Tcl_HashEntry *hPtr; + KeySym keysym; + + hPtr = Tcl_FindHashEntry(&keySymTable, name); + if (hPtr != NULL) { + return (KeySym) Tcl_GetHashValue(hPtr); + } + if (strlen(name) == 1) { + keysym = (KeySym) (unsigned char) name[0]; + if (TkKeysymToString(keysym) != NULL) { + return keysym; + } + } +#endif /* REDO_KEYSYM_LOOKUP */ + return XStringToKeysym(name); +} + +/* + *---------------------------------------------------------------------- + * + * TkKeysymToString -- + * + * This procedure finds the keysym name associated with a given + * keysym. + * + * Results: + * The return value is a pointer to a static string containing + * the name of the given keysym, or NULL if there is no known name. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +TkKeysymToString(keysym) + KeySym keysym; +{ +#ifdef REDO_KEYSYM_LOOKUP + Tcl_HashEntry *hPtr; + + hPtr = Tcl_FindHashEntry(&nameTable, (char *)keysym); + if (hPtr != NULL) { + return (char *) Tcl_GetHashValue(hPtr); + } +#endif /* REDO_KEYSYM_LOOKUP */ + return XKeysymToString(keysym); +} + +/* + *---------------------------------------------------------------------- + * + * TkCopyAndGlobalEval -- + * + * This procedure makes a copy of a script then calls Tcl_GlobalEval + * to evaluate it. It's used in situations where the execution of + * a command may cause the original command string to be reallocated. + * + * Results: + * Returns the result of evaluating script, including both a standard + * Tcl completion code and a string in interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TkCopyAndGlobalEval(interp, script) + Tcl_Interp *interp; /* Interpreter in which to evaluate + * script. */ + char *script; /* Script to evaluate. */ +{ + Tcl_DString buffer; + int code; + + Tcl_DStringInit(&buffer); + Tcl_DStringAppend(&buffer, script, -1); + code = Tcl_GlobalEval(interp, Tcl_DStringValue(&buffer)); + Tcl_DStringFree(&buffer); + return code; +} + + diff --git a/generic/tkBitmap.c b/generic/tkBitmap.c new file mode 100644 index 0000000..fe46b35 --- /dev/null +++ b/generic/tkBitmap.c @@ -0,0 +1,585 @@ +/* + * tkBitmap.c -- + * + * This file maintains a database of read-only bitmaps for the Tk + * toolkit. This allows bitmaps to be shared between widgets and + * 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. + * + * 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 + */ + +#include "tkPort.h" +#include "tkInt.h" + +/* + * The includes below are for pre-defined bitmaps. + * + * Platform-specific issue: Windows complains when the bitmaps are + * included, because an array of characters is being initialized with + * integers as elements. For lint purposes, the following pragmas + * temporarily turn off that warning message. + */ + +#if defined(__WIN32__) || defined(_WIN32) +#pragma warning (disable : 4305) +#endif + +#include "error.bmp" +#include "gray12.bmp" +#include "gray25.bmp" +#include "gray50.bmp" +#include "gray75.bmp" +#include "hourglass.bmp" +#include "info.bmp" +#include "questhead.bmp" +#include "question.bmp" +#include "warning.bmp" + +#if defined(__WIN32__) || defined(_WIN32) +#pragma warning (default : 4305) +#endif + +/* + * One of the following data structures exists for each bitmap that is + * currently in use. Each structure is indexed with both "idTable" and + * "nameTable". + */ + +typedef struct { + 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 + * (needed when deleting). */ +} 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: + */ + +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 to the TkBitmap structure + * for the bitmap. This table is used by Tk_FreeBitmap. + */ + +static Tcl_HashTable idTable; +typedef struct { + Display *display; /* Display for which bitmap was allocated. */ + Pixmap pixmap; /* X identifier for pixmap. */ +} IdKey; + +/* + * Hash table create 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. + */ + +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- + * generated name for the bitmap: + */ + +static Tcl_HashTable dataTable; +typedef struct { + char *source; /* Bitmap bits. */ + int width, height; /* Dimensions of bitmap. */ +} DataKey; + +static int initialized = 0; /* 0 means static structures haven't been + * initialized yet. */ + +/* + * Forward declarations for procedures defined in this file: + */ + +static void BitmapInit _ANSI_ARGS_((void)); + +/* + *---------------------------------------------------------------------- + * + * Tk_GetBitmap -- + * + * Given a string describing a bitmap, locate (or create if necessary) + * a bitmap that fits the description. + * + * 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 interp->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, so that the database can be cleaned up when bitmaps + * aren't needed anymore. + * + *---------------------------------------------------------------------- + */ + +Pixmap +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 + * for details on legal syntax. */ +{ + NameKey nameKey; + IdKey idKey; + Tcl_HashEntry *nameHashPtr, *idHashPtr, *predefHashPtr; + register TkBitmap *bitmapPtr; + TkPredefBitmap *predefPtr; + int new; + Pixmap bitmap; + int width, height; + int dummy2; + + if (!initialized) { + BitmapInit(); + } + + nameKey.name = string; + nameKey.screen = Tk_Screen(tkwin); + nameHashPtr = Tcl_CreateHashEntry(&nameTable, (char *) &nameKey, &new); + if (!new) { + bitmapPtr = (TkBitmap *) Tcl_GetHashValue(nameHashPtr); + bitmapPtr->refCount++; + return bitmapPtr->bitmap; + } + + /* + * No suitable bitmap exists. Create a new bitmap from the + * information contained in the string. If the string starts + * with "@" then the rest of the string is a file name containing + * the bitmap. Otherwise the string must refer to a bitmap + * defined by a call to Tk_DefineBitmap. + */ + + if (*string == '@') { + Tcl_DString buffer; + int result; + + if (Tcl_IsSafe(interp)) { + Tcl_AppendResult(interp, "can't specify bitmap with '@' in a", + " safe interpreter", (char *) NULL); + goto error; + } + + string = Tcl_TranslateFileName(interp, string + 1, &buffer); + if (string == NULL) { + goto error; + } + result = XReadBitmapFile(Tk_Display(tkwin), + RootWindowOfScreen(nameKey.screen), string, + (unsigned int *) &width, (unsigned int *) &height, + &bitmap, &dummy2, &dummy2); + if (result != BitmapSuccess) { + if (interp != NULL) { + Tcl_AppendResult(interp, "error reading bitmap file \"", string, + "\"", (char *) NULL); + } + Tcl_DStringFree(&buffer); + goto error; + } + Tcl_DStringFree(&buffer); + } else { + predefHashPtr = Tcl_FindHashEntry(&tkPredefBitmapTable, string); + if (predefHashPtr == NULL) { + /* + * The following platform specific call allows the user to + * define bitmaps that may only exist during run time. If + * it returns None nothing was found and we return the error. + */ + bitmap = TkpGetNativeAppBitmap(Tk_Display(tkwin), string, + &width, &height); + + if (bitmap == None) { + if (interp != NULL) { + Tcl_AppendResult(interp, "bitmap \"", string, + "\" not defined", (char *) NULL); + } + goto error; + } + } else { + predefPtr = (TkPredefBitmap *) Tcl_GetHashValue(predefHashPtr); + width = predefPtr->width; + height = predefPtr->height; + if (predefPtr->native) { + bitmap = TkpCreateNativeBitmap(Tk_Display(tkwin), + predefPtr->source); + if (bitmap == None) { + panic("native bitmap creation failed"); + } + } else { + bitmap = XCreateBitmapFromData(Tk_Display(tkwin), + RootWindowOfScreen(nameKey.screen), predefPtr->source, + (unsigned) width, (unsigned) height); + } + } + } + + /* + * Add information about this bitmap to our database. + */ + + bitmapPtr = (TkBitmap *) ckalloc(sizeof(TkBitmap)); + bitmapPtr->bitmap = bitmap; + bitmapPtr->width = width; + bitmapPtr->height = height; + bitmapPtr->display = Tk_Display(tkwin); + bitmapPtr->refCount = 1; + bitmapPtr->hashPtr = nameHashPtr; + idKey.display = bitmapPtr->display; + idKey.pixmap = bitmap; + idHashPtr = Tcl_CreateHashEntry(&idTable, (char *) &idKey, + &new); + if (!new) { + panic("bitmap already registered in Tk_GetBitmap"); + } + Tcl_SetHashValue(nameHashPtr, bitmapPtr); + Tcl_SetHashValue(idHashPtr, bitmapPtr); + return bitmapPtr->bitmap; + + error: + Tcl_DeleteHashEntry(nameHashPtr); + return None; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_DefineBitmap -- + * + * This procedure associates a textual name with a binary bitmap + * description, so that the name may be used to refer to the + * bitmap in future calls to Tk_GetBitmap. + * + * Results: + * A standard Tcl result. If an error occurs then TCL_ERROR is + * returned and a message is left in interp->result. + * + * Side effects: + * "Name" is entered into the bitmap table and may be used from + * here on to refer to the given bitmap. + * + *---------------------------------------------------------------------- + */ + +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 + * be defined as a bitmap. */ + char *source; /* Address of bits for bitmap. */ + int width; /* Width of bitmap. */ + int height; /* Height of bitmap. */ +{ + int new; + Tcl_HashEntry *predefHashPtr; + TkPredefBitmap *predefPtr; + + if (!initialized) { + BitmapInit(); + } + + predefHashPtr = Tcl_CreateHashEntry(&tkPredefBitmapTable, name, &new); + if (!new) { + Tcl_AppendResult(interp, "bitmap \"", name, + "\" is already defined", (char *) NULL); + return TCL_ERROR; + } + predefPtr = (TkPredefBitmap *) ckalloc(sizeof(TkPredefBitmap)); + predefPtr->source = source; + predefPtr->width = width; + predefPtr->height = height; + predefPtr->native = 0; + Tcl_SetHashValue(predefHashPtr, predefPtr); + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * Tk_NameOfBitmap -- + * + * Given a bitmap, return a textual string identifying the + * bitmap. + * + * Results: + * The return value is the string name associated with bitmap. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +Tk_Uid +Tk_NameOfBitmap(display, bitmap) + Display *display; /* Display for which bitmap was + * allocated. */ + Pixmap bitmap; /* Bitmap whose name is wanted. */ +{ + IdKey idKey; + Tcl_HashEntry *idHashPtr; + TkBitmap *bitmapPtr; + + if (!initialized) { + unknown: + panic("Tk_NameOfBitmap received unknown bitmap argument"); + } + + idKey.display = display; + idKey.pixmap = bitmap; + idHashPtr = Tcl_FindHashEntry(&idTable, (char *) &idKey); + if (idHashPtr == NULL) { + goto unknown; + } + bitmapPtr = (TkBitmap *) Tcl_GetHashValue(idHashPtr); + return ((NameKey *) bitmapPtr->hashPtr->key.words)->name; +} + +/* + *-------------------------------------------------------------- + * + * Tk_SizeOfBitmap -- + * + * Given a bitmap managed by this module, returns the width + * and height of the bitmap. + * + * Results: + * The words at *widthPtr and *heightPtr are filled in with + * the dimenstions of bitmap. + * + * Side effects: + * If bitmap isn't managed by this module then the procedure + * panics.. + * + *-------------------------------------------------------------- + */ + +void +Tk_SizeOfBitmap(display, bitmap, widthPtr, heightPtr) + Display *display; /* Display for which bitmap was + * allocated. */ + Pixmap bitmap; /* Bitmap whose size is wanted. */ + int *widthPtr; /* Store bitmap width here. */ + int *heightPtr; /* Store bitmap height here. */ +{ + IdKey idKey; + Tcl_HashEntry *idHashPtr; + TkBitmap *bitmapPtr; + + if (!initialized) { + unknownBitmap: + panic("Tk_SizeOfBitmap received unknown bitmap argument"); + } + + idKey.display = display; + idKey.pixmap = bitmap; + idHashPtr = Tcl_FindHashEntry(&idTable, (char *) &idKey); + if (idHashPtr == NULL) { + goto unknownBitmap; + } + bitmapPtr = (TkBitmap *) Tcl_GetHashValue(idHashPtr); + *widthPtr = bitmapPtr->width; + *heightPtr = bitmapPtr->height; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_FreeBitmap -- + * + * This procedure is called to release a bitmap allocated by + * Tk_GetBitmap or TkGetBitmapFromData. + * + * Results: + * None. + * + * Side effects: + * The reference count associated with bitmap is decremented, and + * it is officially deallocated if no-one is using it anymore. + * + *---------------------------------------------------------------------- + */ + +void +Tk_FreeBitmap(display, bitmap) + Display *display; /* Display for which bitmap was + * allocated. */ + Pixmap bitmap; /* Bitmap to be released. */ +{ + Tcl_HashEntry *idHashPtr; + register TkBitmap *bitmapPtr; + IdKey idKey; + + if (!initialized) { + panic("Tk_FreeBitmap called before Tk_GetBitmap"); + } + + idKey.display = display; + idKey.pixmap = bitmap; + idHashPtr = Tcl_FindHashEntry(&idTable, (char *) &idKey); + 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); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tk_GetBitmapFromData -- + * + * Given a description of the bits for a bitmap, make a bitmap that + * has the given properties. *** NOTE: this procedure is obsolete + * and really shouldn't be used anymore. *** + * + * Results: + * 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 + * 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, so that the database can be cleaned up when bitmaps + * aren't needed anymore. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +Pixmap +Tk_GetBitmapFromData(interp, tkwin, source, width, height) + Tcl_Interp *interp; /* Interpreter to use for error reporting. */ + Tk_Window tkwin; /* Window in which bitmap will be used. */ + char *source; /* Bitmap data for bitmap shape. */ + int width, height; /* Dimensions of bitmap. */ +{ + DataKey nameKey; + Tcl_HashEntry *dataHashPtr; + Tk_Uid name; + int new; + char string[20]; + static int autoNumber = 0; + + if (!initialized) { + BitmapInit(); + } + + nameKey.source = source; + nameKey.width = width; + nameKey.height = height; + dataHashPtr = Tcl_CreateHashEntry(&dataTable, (char *) &nameKey, &new); + if (!new) { + name = (Tk_Uid) Tcl_GetHashValue(dataHashPtr); + } else { + autoNumber++; + sprintf(string, "_tk%d", autoNumber); + name = Tk_GetUid(string); + Tcl_SetHashValue(dataHashPtr, name); + if (Tk_DefineBitmap(interp, name, source, width, height) != TCL_OK) { + Tcl_DeleteHashEntry(dataHashPtr); + return TCL_ERROR; + } + } + return Tk_GetBitmap(interp, tkwin, name); +} + +/* + *---------------------------------------------------------------------- + * + * BitmapInit -- + * + * Initialize the structures used for bitmap management. + * + * Results: + * None. + * + * Side effects: + * Read the code. + * + *---------------------------------------------------------------------- + */ + +static void +BitmapInit() +{ + Tcl_Interp *dummy; + + dummy = Tcl_CreateInterp(); + initialized = 1; + Tcl_InitHashTable(&nameTable, sizeof(NameKey)/sizeof(int)); + Tcl_InitHashTable(&dataTable, sizeof(DataKey)/sizeof(int)); + Tcl_InitHashTable(&tkPredefBitmapTable, TCL_ONE_WORD_KEYS); + + /* + * The call below is tricky: can't use sizeof(IdKey) because it + * gets padded with extra unpredictable bytes on some 64-bit + * machines. + */ + + Tcl_InitHashTable(&idTable, (sizeof(Display *) + sizeof(Pixmap)) + /sizeof(int)); + + Tk_DefineBitmap(dummy, Tk_GetUid("error"), (char *) error_bits, + error_width, error_height); + Tk_DefineBitmap(dummy, Tk_GetUid("gray75"), (char *) gray75_bits, + gray75_width, gray75_height); + Tk_DefineBitmap(dummy, Tk_GetUid("gray50"), (char *) gray50_bits, + gray50_width, gray50_height); + Tk_DefineBitmap(dummy, Tk_GetUid("gray25"), (char *) gray25_bits, + gray25_width, gray25_height); + Tk_DefineBitmap(dummy, Tk_GetUid("gray12"), (char *) gray12_bits, + gray12_width, gray12_height); + Tk_DefineBitmap(dummy, Tk_GetUid("hourglass"), (char *) hourglass_bits, + hourglass_width, hourglass_height); + Tk_DefineBitmap(dummy, Tk_GetUid("info"), (char *) info_bits, + info_width, info_height); + Tk_DefineBitmap(dummy, Tk_GetUid("questhead"), (char *) questhead_bits, + questhead_width, questhead_height); + Tk_DefineBitmap(dummy, Tk_GetUid("question"), (char *) question_bits, + question_width, question_height); + Tk_DefineBitmap(dummy, Tk_GetUid("warning"), (char *) warning_bits, + warning_width, warning_height); + + TkpDefineNativeBitmaps(); + + Tcl_DeleteInterp(dummy); +} diff --git a/generic/tkButton.c b/generic/tkButton.c new file mode 100644 index 0000000..c9c25c2 --- /dev/null +++ b/generic/tkButton.c @@ -0,0 +1,1347 @@ +/* + * tkButton.c -- + * + * This module implements a collection of button-like + * widgets for the Tk toolkit. The widgets implemented + * include labels, buttons, check buttons, and radio + * buttons. + * + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkButton.c 1.144 97/07/31 09:04:57 + */ + +#include "tkButton.h" +#include "default.h" + +/* + * Class names for buttons, indexed by one of the type values above. + */ + +static char *classNames[] = {"Label", "Button", "Checkbutton", "Radiobutton"}; + +/* + * The class procedure table for the button widget. + */ + +static int configFlags[] = {LABEL_MASK, BUTTON_MASK, + CHECK_BUTTON_MASK, RADIO_BUTTON_MASK}; + +/* + * Information used for parsing configuration specs: + */ + +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", + "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} +}; + +/* + * String to print out in error messages, identifying options for + * widget commands for different types of labels or buttons: + */ + +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" +}; + +/* + * Forward declarations for procedures defined later in this file: + */ + +static void ButtonCmdDeletedProc _ANSI_ARGS_(( + ClientData clientData)); +static int ButtonCreate _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv, + int type)); +static void ButtonEventProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +static void ButtonImageProc _ANSI_ARGS_((ClientData clientData, + int x, int y, int width, int height, + int imgWidth, int imgHeight)); +static void ButtonSelectImageProc _ANSI_ARGS_(( + ClientData clientData, int x, int y, int width, + int height, int imgWidth, int imgHeight)); +static char * ButtonTextVarProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, char *name1, char *name2, + int flags)); +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 ConfigureButton _ANSI_ARGS_((Tcl_Interp *interp, + TkButton *butPtr, int argc, char **argv, + int flags)); +static void DestroyButton _ANSI_ARGS_((TkButton *butPtr)); + + +/* + *-------------------------------------------------------------- + * + * Tk_ButtonCmd, Tk_CheckbuttonCmd, Tk_LabelCmd, Tk_RadiobuttonCmd -- + * + * These procedures are invoked to process the "button", "label", + * "radiobutton", and "checkbutton" Tcl commands. See the + * user documentation for details on what they do. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. These procedures are just wrappers; + * they call ButtonCreate to do all of the real work. + * + *-------------------------------------------------------------- + */ + +int +Tk_ButtonCmd(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 ButtonCreate(clientData, interp, argc, argv, TYPE_BUTTON); +} + +int +Tk_CheckbuttonCmd(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 ButtonCreate(clientData, interp, argc, argv, TYPE_CHECK_BUTTON); +} + +int +Tk_LabelCmd(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 ButtonCreate(clientData, interp, argc, argv, TYPE_LABEL); +} + +int +Tk_RadiobuttonCmd(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 ButtonCreate(clientData, interp, argc, argv, TYPE_RADIO_BUTTON); +} + +/* + *-------------------------------------------------------------- + * + * ButtonCreate -- + * + * This procedure does all the real work of implementing the + * "button", "label", "radiobutton", and "checkbutton" Tcl + * commands. See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +static int +ButtonCreate(clientData, interp, argc, argv, type) + ClientData clientData; /* Main window associated with + * interpreter. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ + 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; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " pathName ?options?\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * Create the new window. + */ + + new = Tk_CreateWindowFromPath(interp, tkwin, argv[1], (char *) NULL); + if (new == NULL) { + return TCL_ERROR; + } + + Tk_SetClass(new, classNames[type]); + butPtr = TkpCreateButton(new); + + TkSetClassProcs(new, &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->interp = interp; + butPtr->type = type; + butPtr->text = NULL; + butPtr->underline = -1; + butPtr->textVarName = NULL; + butPtr->bitmap = None; + butPtr->imageString = NULL; + butPtr->image = NULL; + butPtr->selectImageString = NULL; + butPtr->selectImage = NULL; + butPtr->state = tkNormalUid; + butPtr->normalBorder = NULL; + butPtr->activeBorder = NULL; + butPtr->borderWidth = 0; + butPtr->relief = TK_RELIEF_FLAT; + butPtr->highlightWidth = 0; + butPtr->highlightBorder = NULL; + butPtr->highlightColorPtr = NULL; + butPtr->inset = 0; + butPtr->tkfont = NULL; + butPtr->normalFg = NULL; + butPtr->activeFg = NULL; + butPtr->disabledFg = NULL; + butPtr->normalTextGC = None; + butPtr->activeTextGC = None; + butPtr->gray = None; + butPtr->disabledGC = None; + butPtr->copyGC = None; + butPtr->widthString = NULL; + butPtr->heightString = NULL; + butPtr->width = 0; + butPtr->height = 0; + butPtr->wrapLength = 0; + butPtr->padX = 0; + butPtr->padY = 0; + butPtr->anchor = TK_ANCHOR_CENTER; + butPtr->justify = TK_JUSTIFY_CENTER; + butPtr->textLayout = NULL; + butPtr->indicatorOn = 0; + butPtr->selectBorder = NULL; + butPtr->indicatorSpace = 0; + butPtr->indicatorDiameter = 0; + butPtr->defaultState = tkDisabledUid; + butPtr->selVarName = NULL; + butPtr->onValue = NULL; + butPtr->offValue = NULL; + butPtr->cursor = None; + butPtr->command = NULL; + butPtr->takeFocus = 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) { + Tk_DestroyWindow(butPtr->tkwin); + return TCL_ERROR; + } + + interp->result = Tk_PathName(butPtr->tkwin); + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * ButtonWidgetCmd -- + * + * This procedure is invoked to process the Tcl command + * that corresponds to a widget managed by this module. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +static int +ButtonWidgetCmd(clientData, interp, argc, argv) + ClientData clientData; /* Information about button widget. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + 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]); + return TCL_ERROR; + } + 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; + } + } 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); + } + } + } 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; + } + if (butPtr->state != tkDisabledUid) { + result = TkInvokeButton(butPtr); + } + } 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; + } + if (Tcl_SetVar(interp, butPtr->selVarName, butPtr->onValue, + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { + result = TCL_ERROR; + } + } 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; + } + if (butPtr->flags & SELECTED) { + if (Tcl_SetVar(interp, butPtr->selVarName, butPtr->offValue, + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { + result = TCL_ERROR; + } + } else { + if (Tcl_SetVar(interp, butPtr->selVarName, butPtr->onValue, + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { + result = TCL_ERROR; + } + } + } else { + sprintf(interp->result, + "bad option \"%.50s\": must be %s", argv[1], + optionStrings[butPtr->type]); + goto error; + } + Tcl_Release((ClientData) butPtr); + return result; + + error: + Tcl_Release((ClientData) butPtr); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * 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). + * + * Results: + * None. + * + * Side effects: + * Everything associated with the widget is freed up. + * + *---------------------------------------------------------------------- + */ + +static void +DestroyButton(butPtr) + TkButton *butPtr; /* Info about button widget. */ +{ + /* + * 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_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + ButtonTextVarProc, (ClientData) butPtr); + } + if (butPtr->image != NULL) { + Tk_FreeImage(butPtr->image); + } + if (butPtr->selectImage != NULL) { + Tk_FreeImage(butPtr->selectImage); + } + if (butPtr->normalTextGC != None) { + Tk_FreeGC(butPtr->display, butPtr->normalTextGC); + } + 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->copyGC != None) { + Tk_FreeGC(butPtr->display, butPtr->copyGC); + } + if (butPtr->selVarName != NULL) { + Tcl_UntraceVar(butPtr->interp, butPtr->selVarName, + 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); +} + +/* + *---------------------------------------------------------------------- + * + * 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. + * + * Results: + * The return value is a standard Tcl result. If TCL_ERROR is + * returned, then interp->result contains an error message. + * + * Side effects: + * Configuration information, such as text string, colors, font, + * etc. get set for butPtr; old resources get freed, if there + * were any. The button is redisplayed. + * + *---------------------------------------------------------------------- + */ + +static int +ConfigureButton(interp, butPtr, argc, argv, flags) + 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. */ +{ + Tk_Image image; + + /* + * Eliminate any existing trace on variables monitored by the button. + */ + + if (butPtr->textVarName != NULL) { + Tcl_UntraceVar(interp, butPtr->textVarName, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + ButtonTextVarProc, (ClientData) butPtr); + } + if (butPtr->selVarName != NULL) { + Tcl_UntraceVar(interp, butPtr->selVarName, + 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. + */ + + 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; + } + } + + 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 (butPtr->highlightWidth < 0) { + butPtr->highlightWidth = 0; + } + + if (butPtr->padX < 0) { + butPtr->padX = 0; + } + if (butPtr->padY < 0) { + butPtr->padY = 0; + } + + if (butPtr->type >= TYPE_CHECK_BUTTON) { + char *value; + + if (butPtr->selVarName == NULL) { + butPtr->selVarName = (char *) ckalloc((unsigned) + (strlen(Tk_Name(butPtr->tkwin)) + 1)); + strcpy(butPtr->selVarName, Tk_Name(butPtr->tkwin)); + } + + /* + * 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. + */ + + value = Tcl_GetVar(interp, butPtr->selVarName, TCL_GLOBAL_ONLY); + butPtr->flags &= ~SELECTED; + if (value != NULL) { + if (strcmp(value, butPtr->onValue) == 0) { + butPtr->flags |= SELECTED; + } + } 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; + } + } + 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; + } + } 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; + } + } 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; + } + } else { + if (butPtr->text != NULL) { + ckfree(butPtr->text); + } + butPtr->text = (char *) ckalloc((unsigned) (strlen(value) + 1)); + strcpy(butPtr->text, value); + } + Tcl_TraceVar(interp, butPtr->textVarName, + 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; + } + } + + TkButtonWorldChanged((ClientData) butPtr); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * TkButtonWorldChanged -- + * + * This procedure is called when the world has changed in some + * way and the widget needs to recompute all its graphics contexts + * and determine its new geometry. + * + * Results: + * None. + * + * Side effects: + * Button will be relayed out and redisplayed. + * + *--------------------------------------------------------------------------- + */ + +void +TkButtonWorldChanged(instanceData) + ClientData instanceData; /* Information about widget. */ +{ + XGCValues gcValues; + GC newGC; + unsigned long mask; + TkButton *butPtr; + + butPtr = (TkButton *) instanceData; + + /* + * Recompute GCs. + */ + + gcValues.font = Tk_FontId(butPtr->tkfont); + gcValues.foreground = butPtr->normalFg->pixel; + gcValues.background = Tk_3DBorderColor(butPtr->normalBorder)->pixel; + + /* + * Note: GraphicsExpose events are disabled in normalTextGC because it's + * used to copy stuff from an off-screen pixmap onto the screen (we know + * that there's no problem with obscured areas). + */ + + gcValues.graphics_exposures = False; + mask = GCForeground | GCBackground | GCFont | GCGraphicsExposures; + newGC = Tk_GetGC(butPtr->tkwin, mask, &gcValues); + if (butPtr->normalTextGC != None) { + Tk_FreeGC(butPtr->display, butPtr->normalTextGC); + } + 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; + newGC = Tk_GetGC(butPtr->tkwin, mask, &gcValues); + if (butPtr->activeTextGC != None) { + Tk_FreeGC(butPtr->display, butPtr->activeTextGC); + } + butPtr->activeTextGC = newGC; + } + + 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)) { + 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")); + } + if (butPtr->gray != None) { + gcValues.fill_style = FillStippled; + gcValues.stipple = butPtr->gray; + mask |= GCFillStyle | GCStipple; + } + } + newGC = Tk_GetGC(butPtr->tkwin, mask, &gcValues); + if (butPtr->disabledGC != None) { + Tk_FreeGC(butPtr->display, butPtr->disabledGC); + } + butPtr->disabledGC = newGC; + } + + if (butPtr->copyGC == None) { + butPtr->copyGC = Tk_GetGC(butPtr->tkwin, 0, &gcValues); + } + + TkpComputeButtonGeometry(butPtr); + + /* + * Lastly, arrange for the button to be redisplayed. + */ + + if (Tk_IsMapped(butPtr->tkwin) && !(butPtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(TkpDisplayButton, (ClientData) butPtr); + butPtr->flags |= REDRAW_PENDING; + } +} + +/* + *-------------------------------------------------------------- + * + * ButtonEventProc -- + * + * This procedure is invoked by the Tk dispatcher for various + * events on buttons. + * + * Results: + * None. + * + * Side effects: + * When the window gets deleted, internal structures get + * cleaned up. When it gets exposed, it is redisplayed. + * + *-------------------------------------------------------------- + */ + +static void +ButtonEventProc(clientData, eventPtr) + ClientData clientData; /* Information about window. */ + XEvent *eventPtr; /* Information about event. */ +{ + TkButton *butPtr = (TkButton *) clientData; + if ((eventPtr->type == Expose) && (eventPtr->xexpose.count == 0)) { + goto redraw; + } else if (eventPtr->type == ConfigureNotify) { + /* + * Must redraw after size changes, since layout could have changed + * and borders will need to be redrawn. + */ + + 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) { + butPtr->flags |= GOT_FOCUS; + if (butPtr->highlightWidth > 0) { + goto redraw; + } + } + } else if (eventPtr->type == FocusOut) { + if (eventPtr->xfocus.detail != NotifyInferior) { + butPtr->flags &= ~GOT_FOCUS; + if (butPtr->highlightWidth > 0) { + goto redraw; + } + } + } + return; + + redraw: + if ((butPtr->tkwin != NULL) && !(butPtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(TkpDisplayButton, (ClientData) butPtr); + butPtr->flags |= REDRAW_PENDING; + } +} + +/* + *---------------------------------------------------------------------- + * + * ButtonCmdDeletedProc -- + * + * 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 +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. + */ + + if (tkwin != NULL) { + butPtr->tkwin = NULL; + Tk_DestroyWindow(tkwin); + } +} + +/* + *---------------------------------------------------------------------- + * + * TkInvokeButton -- + * + * This procedure is called to carry out the actions associated + * with a button, such as invoking a Tcl command or setting a + * variable. This procedure is invoked, for example, when the + * button is invoked via the mouse. + * + * Results: + * A standard Tcl return value. Information is also left in + * interp->result. + * + * Side effects: + * Depends on the button and its associated command. + * + *---------------------------------------------------------------------- + */ + +int +TkInvokeButton(butPtr) + register TkButton *butPtr; /* Information about button. */ +{ + 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) { + return TCL_ERROR; + } + } else { + if (Tcl_SetVar(butPtr->interp, butPtr->selVarName, butPtr->onValue, + 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) { + return TCL_ERROR; + } + } + if ((butPtr->type != TYPE_LABEL) && (butPtr->command != NULL)) { + return TkCopyAndGlobalEval(butPtr->interp, butPtr->command); + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * ButtonVarProc -- + * + * This procedure is invoked when someone changes the + * state variable associated with a radio button. Depending + * on the new value of the button's variable, the button + * may be selected or deselected. + * + * Results: + * NULL is always returned. + * + * Side effects: + * The button may become selected or deselected. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static char * +ButtonVarProc(clientData, interp, name1, name2, flags) + ClientData clientData; /* Information about button. */ + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *name1; /* Name of variable. */ + char *name2; /* Second part of variable name. */ + int flags; /* Information about what happened. */ +{ + register TkButton *butPtr = (TkButton *) clientData; + char *value; + + /* + * If the variable is being unset, then just re-establish the + * trace unless the whole interpreter is going away. + */ + + if (flags & TCL_TRACE_UNSETS) { + butPtr->flags &= ~SELECTED; + if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) { + Tcl_TraceVar(interp, butPtr->selVarName, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + ButtonVarProc, clientData); + } + goto redisplay; + } + + /* + * Use the value of the variable to update the selected status of + * the button. + */ + + value = Tcl_GetVar(interp, butPtr->selVarName, TCL_GLOBAL_ONLY); + if (value == NULL) { + value = ""; + } + if (strcmp(value, butPtr->onValue) == 0) { + if (butPtr->flags & SELECTED) { + return (char *) NULL; + } + butPtr->flags |= SELECTED; + } else if (butPtr->flags & SELECTED) { + butPtr->flags &= ~SELECTED; + } else { + return (char *) NULL; + } + + redisplay: + if ((butPtr->tkwin != NULL) && Tk_IsMapped(butPtr->tkwin) + && !(butPtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(TkpDisplayButton, (ClientData) butPtr); + butPtr->flags |= REDRAW_PENDING; + } + return (char *) NULL; +} + +/* + *-------------------------------------------------------------- + * + * ButtonTextVarProc -- + * + * This procedure is invoked when someone changes the variable + * whose contents are to be displayed in a button. + * + * Results: + * NULL is always returned. + * + * Side effects: + * The text displayed in the button will change to match the + * variable. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static char * +ButtonTextVarProc(clientData, interp, name1, name2, flags) + ClientData clientData; /* Information about button. */ + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *name1; /* Not used. */ + char *name2; /* Not used. */ + int flags; /* Information about what happened. */ +{ + register TkButton *butPtr = (TkButton *) clientData; + char *value; + + /* + * If the variable is unset, then immediately recreate it unless + * the whole interpreter is going away. + */ + + if (flags & TCL_TRACE_UNSETS) { + if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) { + Tcl_SetVar(interp, butPtr->textVarName, butPtr->text, + TCL_GLOBAL_ONLY); + Tcl_TraceVar(interp, butPtr->textVarName, + 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); + } + butPtr->text = (char *) ckalloc((unsigned) (strlen(value) + 1)); + strcpy(butPtr->text, value); + TkpComputeButtonGeometry(butPtr); + + if ((butPtr->tkwin != NULL) && Tk_IsMapped(butPtr->tkwin) + && !(butPtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(TkpDisplayButton, (ClientData) butPtr); + butPtr->flags |= REDRAW_PENDING; + } + return (char *) NULL; +} + +/* + *---------------------------------------------------------------------- + * + * ButtonImageProc -- + * + * This procedure is invoked by the image code whenever the manager + * for an image does something that affects the size of contents + * of an image displayed in a button. + * + * Results: + * None. + * + * Side effects: + * Arranges for the button to get redisplayed. + * + *---------------------------------------------------------------------- + */ + +static void +ButtonImageProc(clientData, x, y, width, height, imgWidth, imgHeight) + ClientData clientData; /* Pointer to widget record. */ + int x, y; /* Upper left pixel (within image) + * that must be redisplayed. */ + int width, height; /* Dimensions of area to redisplay + * (may be <= 0). */ + int imgWidth, imgHeight; /* New dimensions of image. */ +{ + register TkButton *butPtr = (TkButton *) clientData; + + if (butPtr->tkwin != NULL) { + TkpComputeButtonGeometry(butPtr); + if (Tk_IsMapped(butPtr->tkwin) && !(butPtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(TkpDisplayButton, (ClientData) butPtr); + butPtr->flags |= REDRAW_PENDING; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * ButtonSelectImageProc -- + * + * This procedure is invoked by the image code whenever the manager + * for an image does something that affects the size of contents + * of the image displayed in a button when it is selected. + * + * Results: + * None. + * + * Side effects: + * May arrange for the button to get redisplayed. + * + *---------------------------------------------------------------------- + */ + +static void +ButtonSelectImageProc(clientData, x, y, width, height, imgWidth, imgHeight) + ClientData clientData; /* Pointer to widget record. */ + int x, y; /* Upper left pixel (within image) + * that must be redisplayed. */ + int width, height; /* Dimensions of area to redisplay + * (may be <= 0). */ + int imgWidth, imgHeight; /* New dimensions of image. */ +{ + register TkButton *butPtr = (TkButton *) clientData; + + /* + * Don't recompute geometry: it's controlled by the primary image. + */ + + if ((butPtr->flags & SELECTED) && (butPtr->tkwin != NULL) + && Tk_IsMapped(butPtr->tkwin) + && !(butPtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(TkpDisplayButton, (ClientData) butPtr); + butPtr->flags |= REDRAW_PENDING; + } +} diff --git a/generic/tkButton.h b/generic/tkButton.h new file mode 100644 index 0000000..0d5b928 --- /dev/null +++ b/generic/tkButton.h @@ -0,0 +1,241 @@ +/* + * tkButton.h -- + * + * Declarations of types and functions used to implement + * button-like widgets. + * + * Copyright (c) 1996 by Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkButton.h 1.5 97/06/06 11:19:24 + */ + +#ifndef _TKBUTTON +#define _TKBUTTON + +#ifndef _TKINT +#include "tkInt.h" +#endif + +/* + * A data structure of the following type is kept for each + * widget managed by this file: + */ + +typedef struct { + Tk_Window tkwin; /* Window that embodies the button. NULL + * means that the window has been destroyed. */ + Display *display; /* Display containing widget. Needed to + * 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. */ + + /* + * 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 + * 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 + * 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. + * <= 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 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 + * means use normalFg with a 50% stipple + * instead. */ + GC normalTextGC; /* GC for drawing text in normal mode. Also + * used to copy from off-screen pixmap onto + * 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. */ + 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 + * 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 + * 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 textWidth; /* Width needed to display text as requested, + * in pixels. */ + int textHeight; /* Height needed to display text as requested, + * in pixels. */ + Tk_TextLayout textLayout; /* Saved text layout information. */ + 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. */ + + /* + * 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. */ + + /* + * Miscellaneous information: + */ + + Tk_Cursor cursor; /* Current cursor for window, or None. */ + char *takeFocus; /* 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. */ + int flags; /* Various flags; see below for + * definitions. */ +} TkButton; + +/* + * Possible "type" values for buttons. These are the kinds of + * widgets supported by this file. The ordering of the type + * numbers is significant: greater means more features and is + * used in the code. + */ + +#define TYPE_LABEL 0 +#define TYPE_BUTTON 1 +#define TYPE_CHECK_BUTTON 2 +#define TYPE_RADIO_BUTTON 3 + +/* + * Flag bits for buttons: + * + * REDRAW_PENDING: Non-zero means a DoWhenIdle handler + * has already been queued to redraw + * this window. + * SELECTED: Non-zero means this button is selected, + * so special highlight should be drawn. + * GOT_FOCUS: Non-zero means this button currently + * has the input focus. + */ + +#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) + +/* + * 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. + */ + +EXTERN void TkButtonWorldChanged _ANSI_ARGS_(( + ClientData instanceData)); +EXTERN void TkpComputeButtonGeometry _ANSI_ARGS_(( + TkButton *butPtr)); +EXTERN TkButton * TkpCreateButton _ANSI_ARGS_((Tk_Window tkwin)); +#ifndef TkpDestroyButton +EXTERN void TkpDestroyButton _ANSI_ARGS_((TkButton *butPtr)); +#endif +#ifndef TkpDisplayButton +EXTERN void TkpDisplayButton _ANSI_ARGS_((ClientData clientData)); +#endif +EXTERN int TkInvokeButton _ANSI_ARGS_((TkButton *butPtr)); + +#endif /* _TKBUTTON */ diff --git a/generic/tkCanvArc.c b/generic/tkCanvArc.c new file mode 100644 index 0000000..26b62e7 --- /dev/null +++ b/generic/tkCanvArc.c @@ -0,0 +1,1716 @@ +/* + * tkCanvArc.c -- + * + * 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. + * + * 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 + */ + +#include +#include "tkPort.h" +#include "tkInt.h" + +/* + * The structure below defines the record for each arc item. + */ + +typedef struct ArcItem { + Tk_Item header; /* Generic stuff that's the same for all + * types. MUST BE FIRST IN STRUCTURE. */ + double bbox[4]; /* Coordinates (x1, y1, x2, y2) of bounding + * box for oval of which arc is a piece. */ + double start; /* Angle at which arc begins, in degrees + * between 0 and 360. */ + double extent; /* Extent of arc (angular distance from + * start to end of arc) in degrees between + * -360 and 360. */ + double *outlinePtr; /* Points to (x,y) coordinates for points + * that define one or two closed polygons + * representing the portion of the outline + * that isn't part of the arc (the V-shape + * for a pie slice or a line-like segment + * for a chord). Malloc'ed. */ + int numOutlinePoints; /* Number of points at outlinePtr. Zero + * means no space allocated. */ + int width; /* Width of outline (in pixels). */ + XColor *outlineColor; /* Color for outline. NULL means don't + * draw outline. */ + XColor *fillColor; /* Color for filling arc (used for drawing + * outline too when style is "arc"). NULL + * means don't fill arc. */ + Pixmap fillStipple; /* Stipple bitmap for filling item. */ + Pixmap outlineStipple; /* Stipple bitmap for outline. */ + Tk_Uid style; /* How to draw arc: arc, chord, or pieslice. */ + GC outlineGC; /* Graphics context for outline. */ + GC fillGC; /* Graphics context for filling item. */ + double center1[2]; /* Coordinates of center of arc outline at + * start (see ComputeArcOutline). */ + double center2[2]; /* Coordinates of center of arc outline at + * start+extent (see ComputeArcOutline). */ +} ArcItem; + +/* + * The definitions below define the sizes of the polygons used to + * display outline information for various styles of arcs: + */ + +#define CHORD_OUTLINE_PTS 7 +#define PIE_OUTLINE1_PTS 6 +#define PIE_OUTLINE2_PTS 7 + +/* + * Information used for parsing configuration specs: + */ + +static Tk_CustomOption tagsOption = {Tk_CanvasTagsParseProc, + Tk_CanvasTagsPrintProc, (ClientData) NULL +}; + +static Tk_ConfigSpec configSpecs[] = { + {TK_CONFIG_DOUBLE, "-extent", (char *) NULL, (char *) NULL, + "90", Tk_Offset(ArcItem, extent), TK_CONFIG_DONT_SET_DEFAULT}, + {TK_CONFIG_COLOR, "-fill", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(ArcItem, fillColor), TK_CONFIG_NULL_OK}, + {TK_CONFIG_COLOR, "-outline", (char *) NULL, (char *) NULL, + "black", Tk_Offset(ArcItem, outlineColor), TK_CONFIG_NULL_OK}, + {TK_CONFIG_BITMAP, "-outlinestipple", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(ArcItem, outlineStipple), TK_CONFIG_NULL_OK}, + {TK_CONFIG_DOUBLE, "-start", (char *) NULL, (char *) NULL, + "0", Tk_Offset(ArcItem, start), TK_CONFIG_DONT_SET_DEFAULT}, + {TK_CONFIG_BITMAP, "-stipple", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(ArcItem, fillStipple), TK_CONFIG_NULL_OK}, + {TK_CONFIG_UID, "-style", (char *) NULL, (char *) NULL, + "pieslice", Tk_Offset(ArcItem, style), TK_CONFIG_DONT_SET_DEFAULT}, + {TK_CONFIG_CUSTOM, "-tags", (char *) NULL, (char *) NULL, + (char *) NULL, 0, TK_CONFIG_NULL_OK, &tagsOption}, + {TK_CONFIG_PIXELS, "-width", (char *) NULL, (char *) NULL, + "1", Tk_Offset(ArcItem, width), TK_CONFIG_DONT_SET_DEFAULT}, + {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, 0} +}; + +/* + * Prototypes for procedures defined in this file: + */ + +static void ComputeArcBbox _ANSI_ARGS_((Tk_Canvas canvas, + ArcItem *arcPtr)); +static int ConfigureArc _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int argc, + char **argv, int flags)); +static int CreateArc _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, struct Tk_Item *itemPtr, + int argc, char **argv)); +static void DeleteArc _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, Display *display)); +static void DisplayArc _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, Display *display, Drawable dst, + int x, int y, int width, int height)); +static int ArcCoords _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int argc, + char **argv)); +static int ArcToArea _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double *rectPtr)); +static double ArcToPoint _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double *coordPtr)); +static int ArcToPostscript _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int prepass)); +static void ScaleArc _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double originX, double originY, + double scaleX, double scaleY)); +static void TranslateArc _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double deltaX, double deltaY)); +static int AngleInRange _ANSI_ARGS_((double x, double y, + double start, double extent)); +static void ComputeArcOutline _ANSI_ARGS_((ArcItem *arcPtr)); +static int HorizLineToArc _ANSI_ARGS_((double x1, double x2, + double y, double rx, double ry, + double start, double extent)); +static int VertLineToArc _ANSI_ARGS_((double x, double y1, + double y2, double rx, double ry, + double start, double extent)); + +/* + * The structures below defines the arc item types by means of procedures + * that can be invoked by generic item code. + */ + +Tk_ItemType tkArcType = { + "arc", /* name */ + sizeof(ArcItem), /* itemSize */ + CreateArc, /* createProc */ + configSpecs, /* configSpecs */ + ConfigureArc, /* configureProc */ + ArcCoords, /* coordProc */ + DeleteArc, /* deleteProc */ + DisplayArc, /* displayProc */ + 0, /* alwaysRedraw */ + ArcToPoint, /* pointProc */ + ArcToArea, /* areaProc */ + ArcToPostscript, /* postscriptProc */ + ScaleArc, /* scaleProc */ + TranslateArc, /* translateProc */ + (Tk_ItemIndexProc *) NULL, /* indexProc */ + (Tk_ItemCursorProc *) NULL, /* icursorProc */ + (Tk_ItemSelectionProc *) NULL, /* selectionProc */ + (Tk_ItemInsertProc *) NULL, /* insertProc */ + (Tk_ItemDCharsProc *) NULL, /* dTextProc */ + (Tk_ItemType *) NULL /* nextPtr */ +}; + +#ifndef PI +# define PI 3.14159265358979323846 +#endif + +/* + * The uid's below comprise the legal values for the "-style" + * option for arcs. + */ + +static Tk_Uid arcUid = NULL; +static Tk_Uid chordUid = NULL; +static Tk_Uid pieSliceUid = NULL; + +/* + *-------------------------------------------------------------- + * + * CreateArc -- + * + * This procedure is invoked to create a new arc item in + * a canvas. + * + * 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, so it can be safely freed by the + * caller. + * + * Side effects: + * A new arc item is created. + * + *-------------------------------------------------------------- + */ + +static int +CreateArc(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 arc. */ +{ + ArcItem *arcPtr = (ArcItem *) itemPtr; + + if (argc < 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + Tk_PathName(Tk_CanvasTkwin(canvas)), " create ", + itemPtr->typePtr->name, " x1 y1 x2 y2 ?options?\"", + (char *) NULL); + return TCL_ERROR; + } + + /* + * Carry out once-only initialization. + */ + + if (arcUid == NULL) { + arcUid = Tk_GetUid("arc"); + chordUid = Tk_GetUid("chord"); + pieSliceUid = Tk_GetUid("pieslice"); + } + + /* + * Carry out initialization that is needed in order to clean + * up after errors during the the remainder of this procedure. + */ + + arcPtr->start = 0; + arcPtr->extent = 90; + arcPtr->outlinePtr = NULL; + arcPtr->numOutlinePoints = 0; + arcPtr->width = 1; + arcPtr->outlineColor = NULL; + arcPtr->fillColor = NULL; + arcPtr->fillStipple = None; + arcPtr->outlineStipple = None; + arcPtr->style = pieSliceUid; + arcPtr->outlineGC = None; + arcPtr->fillGC = None; + + /* + * Process the arguments to fill in the item record. + */ + + if ((Tk_CanvasGetCoord(interp, canvas, argv[0], &arcPtr->bbox[0]) != TCL_OK) + || (Tk_CanvasGetCoord(interp, canvas, argv[1], + &arcPtr->bbox[1]) != TCL_OK) + || (Tk_CanvasGetCoord(interp, canvas, argv[2], + &arcPtr->bbox[2]) != TCL_OK) + || (Tk_CanvasGetCoord(interp, canvas, argv[3], + &arcPtr->bbox[3]) != TCL_OK)) { + return TCL_ERROR; + } + + if (ConfigureArc(interp, canvas, itemPtr, argc-4, argv+4, 0) != TCL_OK) { + DeleteArc(canvas, itemPtr, Tk_Display(Tk_CanvasTkwin(canvas))); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * ArcCoords -- + * + * This procedure is invoked to process the "coords" widget + * command on arcs. See the user documentation for details + * on what it does. + * + * Results: + * Returns TCL_OK or TCL_ERROR, and sets interp->result. + * + * Side effects: + * The coordinates for the given item may be changed. + * + *-------------------------------------------------------------- + */ + +static int +ArcCoords(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, ... */ +{ + ArcItem *arcPtr = (ArcItem *) itemPtr; + char c0[TCL_DOUBLE_SPACE], c1[TCL_DOUBLE_SPACE]; + char c2[TCL_DOUBLE_SPACE], c3[TCL_DOUBLE_SPACE]; + + if (argc == 0) { + Tcl_PrintDouble(interp, arcPtr->bbox[0], c0); + Tcl_PrintDouble(interp, arcPtr->bbox[1], c1); + Tcl_PrintDouble(interp, arcPtr->bbox[2], c2); + Tcl_PrintDouble(interp, arcPtr->bbox[3], c3); + Tcl_AppendResult(interp, c0, " ", c1, " ", c2, " ", c3, + (char *) NULL); + } else if (argc == 4) { + if ((Tk_CanvasGetCoord(interp, canvas, argv[0], + &arcPtr->bbox[0]) != TCL_OK) + || (Tk_CanvasGetCoord(interp, canvas, argv[1], + &arcPtr->bbox[1]) != TCL_OK) + || (Tk_CanvasGetCoord(interp, canvas, argv[2], + &arcPtr->bbox[2]) != TCL_OK) + || (Tk_CanvasGetCoord(interp, canvas, argv[3], + &arcPtr->bbox[3]) != TCL_OK)) { + return TCL_ERROR; + } + ComputeArcBbox(canvas, arcPtr); + } else { + sprintf(interp->result, + "wrong # coordinates: expected 0 or 4, got %d", + argc); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * ConfigureArc -- + * + * This procedure is invoked to configure various aspects + * of a arc item, such as its outline and fill colors. + * + * Results: + * A standard Tcl result code. If an error occurs, then + * an error message is left in interp->result. + * + * Side effects: + * Configuration information, such as colors and stipple + * patterns, may be set for itemPtr. + * + *-------------------------------------------------------------- + */ + +static int +ConfigureArc(interp, canvas, itemPtr, argc, argv, flags) + Tcl_Interp *interp; /* Used for error reporting. */ + Tk_Canvas canvas; /* Canvas containing itemPtr. */ + Tk_Item *itemPtr; /* Arc item to reconfigure. */ + int argc; /* Number of elements in argv. */ + char **argv; /* Arguments describing things to configure. */ + int flags; /* Flags to pass to Tk_ConfigureWidget. */ +{ + ArcItem *arcPtr = (ArcItem *) itemPtr; + XGCValues gcValues; + GC newGC; + unsigned long mask; + int i; + Tk_Window tkwin; + + tkwin = Tk_CanvasTkwin(canvas); + if (Tk_ConfigureWidget(interp, tkwin, configSpecs, argc, argv, + (char *) arcPtr, flags) != TCL_OK) { + return TCL_ERROR; + } + + /* + * A few of the options require additional processing, such as + * style and graphics contexts. + */ + + i = (int) (arcPtr->start/360.0); + arcPtr->start -= i*360.0; + if (arcPtr->start < 0) { + arcPtr->start += 360.0; + } + i = (int) (arcPtr->extent/360.0); + arcPtr->extent -= i*360.0; + + if ((arcPtr->style != arcUid) && (arcPtr->style != chordUid) + && (arcPtr->style != pieSliceUid)) { + Tcl_AppendResult(interp, "bad -style option \"", + arcPtr->style, "\": must be arc, chord, or pieslice", + (char *) NULL); + arcPtr->style = pieSliceUid; + return TCL_ERROR; + } + + if (arcPtr->width < 0) { + arcPtr->width = 1; + } + if (arcPtr->outlineColor == NULL) { + newGC = None; + } else { + gcValues.foreground = arcPtr->outlineColor->pixel; + gcValues.cap_style = CapButt; + gcValues.line_width = arcPtr->width; + mask = GCForeground|GCCapStyle|GCLineWidth; + if (arcPtr->outlineStipple != None) { + gcValues.stipple = arcPtr->outlineStipple; + gcValues.fill_style = FillStippled; + mask |= GCStipple|GCFillStyle; + } + newGC = Tk_GetGC(tkwin, mask, &gcValues); + } + if (arcPtr->outlineGC != None) { + Tk_FreeGC(Tk_Display(tkwin), arcPtr->outlineGC); + } + arcPtr->outlineGC = newGC; + + if ((arcPtr->fillColor == NULL) || (arcPtr->style == arcUid)) { + newGC = None; + } else { + gcValues.foreground = arcPtr->fillColor->pixel; + if (arcPtr->style == chordUid) { + gcValues.arc_mode = ArcChord; + } else { + gcValues.arc_mode = ArcPieSlice; + } + mask = GCForeground|GCArcMode; + if (arcPtr->fillStipple != None) { + gcValues.stipple = arcPtr->fillStipple; + gcValues.fill_style = FillStippled; + mask |= GCStipple|GCFillStyle; + } + newGC = Tk_GetGC(tkwin, mask, &gcValues); + } + if (arcPtr->fillGC != None) { + Tk_FreeGC(Tk_Display(tkwin), arcPtr->fillGC); + } + arcPtr->fillGC = newGC; + + ComputeArcBbox(canvas, arcPtr); + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * DeleteArc -- + * + * This procedure is called to clean up the data structure + * associated with a arc item. + * + * Results: + * None. + * + * Side effects: + * Resources associated with itemPtr are released. + * + *-------------------------------------------------------------- + */ + +static void +DeleteArc(canvas, itemPtr, display) + Tk_Canvas canvas; /* Info about overall canvas. */ + Tk_Item *itemPtr; /* Item that is being deleted. */ + Display *display; /* Display containing window for + * canvas. */ +{ + ArcItem *arcPtr = (ArcItem *) itemPtr; + + if (arcPtr->numOutlinePoints != 0) { + ckfree((char *) arcPtr->outlinePtr); + } + if (arcPtr->outlineColor != NULL) { + Tk_FreeColor(arcPtr->outlineColor); + } + if (arcPtr->fillColor != NULL) { + Tk_FreeColor(arcPtr->fillColor); + } + if (arcPtr->fillStipple != None) { + Tk_FreeBitmap(display, arcPtr->fillStipple); + } + if (arcPtr->outlineStipple != None) { + Tk_FreeBitmap(display, arcPtr->outlineStipple); + } + if (arcPtr->outlineGC != None) { + Tk_FreeGC(display, arcPtr->outlineGC); + } + if (arcPtr->fillGC != None) { + Tk_FreeGC(display, arcPtr->fillGC); + } +} + +/* + *-------------------------------------------------------------- + * + * ComputeArcBbox -- + * + * This procedure is invoked to compute the bounding box of + * all the pixels that may be drawn as part of an arc. + * + * Results: + * None. + * + * Side effects: + * The fields x1, y1, x2, and y2 are updated in the header + * for itemPtr. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +ComputeArcBbox(canvas, arcPtr) + Tk_Canvas canvas; /* Canvas that contains item. */ + ArcItem *arcPtr; /* Item whose bbox is to be + * recomputed. */ +{ + double tmp, center[2], point[2]; + + /* + * Make sure that the first coordinates are the lowest ones. + */ + + if (arcPtr->bbox[1] > arcPtr->bbox[3]) { + double tmp; + tmp = arcPtr->bbox[3]; + arcPtr->bbox[3] = arcPtr->bbox[1]; + arcPtr->bbox[1] = tmp; + } + if (arcPtr->bbox[0] > arcPtr->bbox[2]) { + double tmp; + tmp = arcPtr->bbox[2]; + arcPtr->bbox[2] = arcPtr->bbox[0]; + arcPtr->bbox[0] = tmp; + } + + ComputeArcOutline(arcPtr); + + /* + * To compute the bounding box, start with the the bbox formed + * by the two endpoints of the arc. Then add in the center of + * the arc's oval (if relevant) and the 3-o'clock, 6-o'clock, + * 9-o'clock, and 12-o'clock positions, if they are relevant. + */ + + arcPtr->header.x1 = arcPtr->header.x2 = (int) arcPtr->center1[0]; + arcPtr->header.y1 = arcPtr->header.y2 = (int) arcPtr->center1[1]; + TkIncludePoint((Tk_Item *) arcPtr, arcPtr->center2); + center[0] = (arcPtr->bbox[0] + arcPtr->bbox[2])/2; + center[1] = (arcPtr->bbox[1] + arcPtr->bbox[3])/2; + if (arcPtr->style != arcUid) { + TkIncludePoint((Tk_Item *) arcPtr, center); + } + + tmp = -arcPtr->start; + if (tmp < 0) { + tmp += 360.0; + } + if ((tmp < arcPtr->extent) || ((tmp-360) > arcPtr->extent)) { + point[0] = arcPtr->bbox[2]; + point[1] = center[1]; + TkIncludePoint((Tk_Item *) arcPtr, point); + } + tmp = 90.0 - arcPtr->start; + if (tmp < 0) { + tmp += 360.0; + } + if ((tmp < arcPtr->extent) || ((tmp-360) > arcPtr->extent)) { + point[0] = center[0]; + point[1] = arcPtr->bbox[1]; + TkIncludePoint((Tk_Item *) arcPtr, point); + } + tmp = 180.0 - arcPtr->start; + if (tmp < 0) { + tmp += 360.0; + } + if ((tmp < arcPtr->extent) || ((tmp-360) > arcPtr->extent)) { + point[0] = arcPtr->bbox[0]; + point[1] = center[1]; + TkIncludePoint((Tk_Item *) arcPtr, point); + } + tmp = 270.0 - arcPtr->start; + if (tmp < 0) { + tmp += 360.0; + } + if ((tmp < arcPtr->extent) || ((tmp-360) > arcPtr->extent)) { + point[0] = center[0]; + point[1] = arcPtr->bbox[3]; + TkIncludePoint((Tk_Item *) arcPtr, point); + } + + /* + * Lastly, expand by the width of the arc (if the arc's outline is + * being drawn) and add one extra pixel just for safety. + */ + + if (arcPtr->outlineColor == NULL) { + tmp = 1; + } else { + tmp = (arcPtr->width + 1)/2 + 1; + } + arcPtr->header.x1 -= (int) tmp; + arcPtr->header.y1 -= (int) tmp; + arcPtr->header.x2 += (int) tmp; + arcPtr->header.y2 += (int) tmp; +} + +/* + *-------------------------------------------------------------- + * + * DisplayArc -- + * + * This procedure is invoked to draw an arc item in a given + * drawable. + * + * Results: + * None. + * + * Side effects: + * ItemPtr is drawn in drawable using the transformation + * information in canvas. + * + *-------------------------------------------------------------- + */ + +static void +DisplayArc(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). */ +{ + ArcItem *arcPtr = (ArcItem *) itemPtr; + short x1, y1, x2, y2; + int start, extent; + + /* + * Compute the screen coordinates of the bounding box for the item, + * plus integer values for the angles. + */ + + Tk_CanvasDrawableCoords(canvas, arcPtr->bbox[0], arcPtr->bbox[1], + &x1, &y1); + Tk_CanvasDrawableCoords(canvas, arcPtr->bbox[2], arcPtr->bbox[3], + &x2, &y2); + if (x2 <= x1) { + x2 = x1+1; + } + if (y2 <= y1) { + y2 = y1+1; + } + start = (int) ((64*arcPtr->start) + 0.5); + extent = (int) ((64*arcPtr->extent) + 0.5); + + /* + * Display filled arc first (if wanted), then outline. If the extent + * is zero then don't invoke XFillArc or XDrawArc, since this causes + * some window servers to crash and should be a no-op anyway. + */ + + if ((arcPtr->fillGC != None) && (extent != 0)) { + if (arcPtr->fillStipple != None) { + Tk_CanvasSetStippleOrigin(canvas, arcPtr->fillGC); + } + XFillArc(display, drawable, arcPtr->fillGC, x1, y1, (unsigned) (x2-x1), + (unsigned) (y2-y1), start, extent); + if (arcPtr->fillStipple != None) { + XSetTSOrigin(display, arcPtr->fillGC, 0, 0); + } + } + if (arcPtr->outlineGC != None) { + if (arcPtr->outlineStipple != None) { + Tk_CanvasSetStippleOrigin(canvas, arcPtr->outlineGC); + } + if (extent != 0) { + XDrawArc(display, drawable, arcPtr->outlineGC, x1, y1, + (unsigned) (x2-x1), (unsigned) (y2-y1), start, extent); + } + + /* + * If the outline width is very thin, don't use polygons to draw + * the linear parts of the outline (this often results in nothing + * being displayed); just draw lines instead. + */ + + if (arcPtr->width <= 2) { + Tk_CanvasDrawableCoords(canvas, arcPtr->center1[0], + arcPtr->center1[1], &x1, &y1); + Tk_CanvasDrawableCoords(canvas, arcPtr->center2[0], + arcPtr->center2[1], &x2, &y2); + + if (arcPtr->style == chordUid) { + XDrawLine(display, drawable, arcPtr->outlineGC, + x1, y1, x2, y2); + } else if (arcPtr->style == pieSliceUid) { + short cx, cy; + + Tk_CanvasDrawableCoords(canvas, + (arcPtr->bbox[0] + arcPtr->bbox[2])/2.0, + (arcPtr->bbox[1] + arcPtr->bbox[3])/2.0, &cx, &cy); + XDrawLine(display, drawable, arcPtr->outlineGC, + cx, cy, x1, y1); + XDrawLine(display, drawable, arcPtr->outlineGC, + cx, cy, x2, y2); + } + } else { + if (arcPtr->style == chordUid) { + TkFillPolygon(canvas, arcPtr->outlinePtr, CHORD_OUTLINE_PTS, + display, drawable, arcPtr->outlineGC, None); + } else if (arcPtr->style == pieSliceUid) { + TkFillPolygon(canvas, arcPtr->outlinePtr, PIE_OUTLINE1_PTS, + display, drawable, arcPtr->outlineGC, None); + TkFillPolygon(canvas, arcPtr->outlinePtr + 2*PIE_OUTLINE1_PTS, + PIE_OUTLINE2_PTS, display, drawable, arcPtr->outlineGC, + None); + } + } + if (arcPtr->outlineStipple != None) { + XSetTSOrigin(display, arcPtr->outlineGC, 0, 0); + } + } +} + +/* + *-------------------------------------------------------------- + * + * ArcToPoint -- + * + * Computes the distance from a given point to a given + * arc, in canvas units. + * + * Results: + * The return value is 0 if the point whose x and y coordinates + * are coordPtr[0] and coordPtr[1] is inside the arc. If the + * point isn't inside the arc then the return value is the + * distance from the point to the arc. If itemPtr is filled, + * then anywhere in the interior is considered "inside"; if + * itemPtr isn't filled, then "inside" means only the area + * occupied by the outline. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static double +ArcToPoint(canvas, itemPtr, pointPtr) + Tk_Canvas canvas; /* Canvas containing item. */ + Tk_Item *itemPtr; /* Item to check against point. */ + double *pointPtr; /* Pointer to x and y coordinates. */ +{ + ArcItem *arcPtr = (ArcItem *) itemPtr; + double vertex[2], pointAngle, diff, dist, newDist; + double poly[8], polyDist, width, t1, t2; + int filled, angleInRange; + + /* + * See if the point is within the angular range of the arc. + * Remember, X angles are backwards from the way we'd normally + * think of them. Also, compensate for any eccentricity of + * the oval. + */ + + vertex[0] = (arcPtr->bbox[0] + arcPtr->bbox[2])/2.0; + vertex[1] = (arcPtr->bbox[1] + arcPtr->bbox[3])/2.0; + t1 = (pointPtr[1] - vertex[1])/(arcPtr->bbox[3] - arcPtr->bbox[1]); + t2 = (pointPtr[0] - vertex[0])/(arcPtr->bbox[2] - arcPtr->bbox[0]); + if ((t1 == 0.0) && (t2 == 0.0)) { + pointAngle = 0; + } else { + pointAngle = -atan2(t1, t2)*180/PI; + } + diff = pointAngle - arcPtr->start; + diff -= ((int) (diff/360.0) * 360.0); + if (diff < 0) { + diff += 360.0; + } + angleInRange = (diff <= arcPtr->extent) || + ((arcPtr->extent < 0) && ((diff - 360.0) >= arcPtr->extent)); + + /* + * Now perform different tests depending on what kind of arc + * we're dealing with. + */ + + if (arcPtr->style == arcUid) { + if (angleInRange) { + return TkOvalToPoint(arcPtr->bbox, (double) arcPtr->width, + 0, pointPtr); + } + dist = hypot(pointPtr[0] - arcPtr->center1[0], + pointPtr[1] - arcPtr->center1[1]); + newDist = hypot(pointPtr[0] - arcPtr->center2[0], + pointPtr[1] - arcPtr->center2[1]); + if (newDist < dist) { + return newDist; + } + return dist; + } + + if ((arcPtr->fillGC != None) || (arcPtr->outlineGC == None)) { + filled = 1; + } else { + filled = 0; + } + if (arcPtr->outlineGC == None) { + width = 0.0; + } else { + width = arcPtr->width; + } + + if (arcPtr->style == pieSliceUid) { + if (width > 1.0) { + dist = TkPolygonToPoint(arcPtr->outlinePtr, PIE_OUTLINE1_PTS, + pointPtr); + newDist = TkPolygonToPoint(arcPtr->outlinePtr + 2*PIE_OUTLINE1_PTS, + PIE_OUTLINE2_PTS, pointPtr); + } else { + dist = TkLineToPoint(vertex, arcPtr->center1, pointPtr); + newDist = TkLineToPoint(vertex, arcPtr->center2, pointPtr); + } + if (newDist < dist) { + dist = newDist; + } + if (angleInRange) { + newDist = TkOvalToPoint(arcPtr->bbox, width, filled, pointPtr); + if (newDist < dist) { + dist = newDist; + } + } + return dist; + } + + /* + * This is a chord-style arc. We have to deal specially with the + * triangular piece that represents the difference between a + * chord-style arc and a pie-slice arc (for small angles this piece + * is excluded here where it would be included for pie slices; + * for large angles the piece is included here but would be + * excluded for pie slices). + */ + + if (width > 1.0) { + dist = TkPolygonToPoint(arcPtr->outlinePtr, CHORD_OUTLINE_PTS, + pointPtr); + } else { + dist = TkLineToPoint(arcPtr->center1, arcPtr->center2, pointPtr); + } + poly[0] = poly[6] = vertex[0]; + poly[1] = poly[7] = vertex[1]; + poly[2] = arcPtr->center1[0]; + poly[3] = arcPtr->center1[1]; + poly[4] = arcPtr->center2[0]; + poly[5] = arcPtr->center2[1]; + polyDist = TkPolygonToPoint(poly, 4, pointPtr); + if (angleInRange) { + if ((arcPtr->extent < -180.0) || (arcPtr->extent > 180.0) + || (polyDist > 0.0)) { + newDist = TkOvalToPoint(arcPtr->bbox, width, filled, pointPtr); + if (newDist < dist) { + dist = newDist; + } + } + } else { + if ((arcPtr->extent < -180.0) || (arcPtr->extent > 180.0)) { + if (filled && (polyDist < dist)) { + dist = polyDist; + } + } + } + return dist; +} + +/* + *-------------------------------------------------------------- + * + * ArcToArea -- + * + * This procedure is called to determine whether an item + * lies entirely inside, entirely outside, or overlapping + * a given area. + * + * Results: + * -1 is returned if the item is entirely outside the area + * given by rectPtr, 0 if it overlaps, and 1 if it is entirely + * inside the given area. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +ArcToArea(canvas, itemPtr, rectPtr) + Tk_Canvas canvas; /* Canvas containing item. */ + Tk_Item *itemPtr; /* Item to check against arc. */ + double *rectPtr; /* Pointer to array of four coordinates + * (x1, y1, x2, y2) describing rectangular + * area. */ +{ + ArcItem *arcPtr = (ArcItem *) itemPtr; + double rx, ry; /* Radii for transformed oval: these define + * an oval centered at the origin. */ + double tRect[4]; /* Transformed version of x1, y1, x2, y2, + * for coord. system where arc is centered + * on the origin. */ + double center[2], width, angle, tmp; + double points[20], *pointPtr; + int numPoints, filled; + int inside; /* Non-zero means every test so far suggests + * that arc is inside rectangle. 0 means + * every test so far shows arc to be outside + * of rectangle. */ + int newInside; + + if ((arcPtr->fillGC != None) || (arcPtr->outlineGC == None)) { + filled = 1; + } else { + filled = 0; + } + if (arcPtr->outlineGC == None) { + width = 0.0; + } else { + width = arcPtr->width; + } + + /* + * Transform both the arc and the rectangle so that the arc's oval + * is centered on the origin. + */ + + center[0] = (arcPtr->bbox[0] + arcPtr->bbox[2])/2.0; + center[1] = (arcPtr->bbox[1] + arcPtr->bbox[3])/2.0; + tRect[0] = rectPtr[0] - center[0]; + tRect[1] = rectPtr[1] - center[1]; + tRect[2] = rectPtr[2] - center[0]; + tRect[3] = rectPtr[3] - center[1]; + rx = arcPtr->bbox[2] - center[0] + width/2.0; + ry = arcPtr->bbox[3] - center[1] + width/2.0; + + /* + * Find the extreme points of the arc and see whether these are all + * inside the rectangle (in which case we're done), partly in and + * partly out (in which case we're done), or all outside (in which + * case we have more work to do). The extreme points include the + * following, which are checked in order: + * + * 1. The outside points of the arc, corresponding to start and + * extent. + * 2. The center of the arc (but only in pie-slice mode). + * 3. The 12, 3, 6, and 9-o'clock positions (but only if the arc + * includes those angles). + */ + + pointPtr = points; + angle = -arcPtr->start*(PI/180.0); + pointPtr[0] = rx*cos(angle); + pointPtr[1] = ry*sin(angle); + angle += -arcPtr->extent*(PI/180.0); + pointPtr[2] = rx*cos(angle); + pointPtr[3] = ry*sin(angle); + numPoints = 2; + pointPtr += 4; + + if ((arcPtr->style == pieSliceUid) && (arcPtr->extent < 180.0)) { + pointPtr[0] = 0.0; + pointPtr[1] = 0.0; + numPoints++; + pointPtr += 2; + } + + tmp = -arcPtr->start; + if (tmp < 0) { + tmp += 360.0; + } + if ((tmp < arcPtr->extent) || ((tmp-360) > arcPtr->extent)) { + pointPtr[0] = rx; + pointPtr[1] = 0.0; + numPoints++; + pointPtr += 2; + } + tmp = 90.0 - arcPtr->start; + if (tmp < 0) { + tmp += 360.0; + } + if ((tmp < arcPtr->extent) || ((tmp-360) > arcPtr->extent)) { + pointPtr[0] = 0.0; + pointPtr[1] = -ry; + numPoints++; + pointPtr += 2; + } + tmp = 180.0 - arcPtr->start; + if (tmp < 0) { + tmp += 360.0; + } + if ((tmp < arcPtr->extent) || ((tmp-360) > arcPtr->extent)) { + pointPtr[0] = -rx; + pointPtr[1] = 0.0; + numPoints++; + pointPtr += 2; + } + tmp = 270.0 - arcPtr->start; + if (tmp < 0) { + tmp += 360.0; + } + if ((tmp < arcPtr->extent) || ((tmp-360) > arcPtr->extent)) { + pointPtr[0] = 0.0; + pointPtr[1] = ry; + numPoints++; + } + + /* + * Now that we've located the extreme points, loop through them all + * to see which are inside the rectangle. + */ + + inside = (points[0] > tRect[0]) && (points[0] < tRect[2]) + && (points[1] > tRect[1]) && (points[1] < tRect[3]); + for (pointPtr = points+2; numPoints > 1; pointPtr += 2, numPoints--) { + newInside = (pointPtr[0] > tRect[0]) && (pointPtr[0] < tRect[2]) + && (pointPtr[1] > tRect[1]) && (pointPtr[1] < tRect[3]); + if (newInside != inside) { + return 0; + } + } + + if (inside) { + return 1; + } + + /* + * So far, oval appears to be outside rectangle, but can't yet tell + * for sure. Next, test each of the four sides of the rectangle + * against the bounding region for the arc. If any intersections + * are found, then return "overlapping". First, test against the + * polygon(s) forming the sides of a chord or pie-slice. + */ + + if (arcPtr->style == pieSliceUid) { + if (width >= 1.0) { + if (TkPolygonToArea(arcPtr->outlinePtr, PIE_OUTLINE1_PTS, + rectPtr) != -1) { + return 0; + } + if (TkPolygonToArea(arcPtr->outlinePtr + 2*PIE_OUTLINE1_PTS, + PIE_OUTLINE2_PTS, rectPtr) != -1) { + return 0; + } + } else { + if ((TkLineToArea(center, arcPtr->center1, rectPtr) != -1) || + (TkLineToArea(center, arcPtr->center2, rectPtr) != -1)) { + return 0; + } + } + } else if (arcPtr->style == chordUid) { + if (width >= 1.0) { + if (TkPolygonToArea(arcPtr->outlinePtr, CHORD_OUTLINE_PTS, + rectPtr) != -1) { + return 0; + } + } else { + if (TkLineToArea(arcPtr->center1, arcPtr->center2, + rectPtr) != -1) { + return 0; + } + } + } + + /* + * Next check for overlap between each of the four sides and the + * outer perimiter of the arc. If the arc isn't filled, then also + * check the inner perimeter of the arc. + */ + + if (HorizLineToArc(tRect[0], tRect[2], tRect[1], rx, ry, arcPtr->start, + arcPtr->extent) + || HorizLineToArc(tRect[0], tRect[2], tRect[3], rx, ry, + arcPtr->start, arcPtr->extent) + || VertLineToArc(tRect[0], tRect[1], tRect[3], rx, ry, + arcPtr->start, arcPtr->extent) + || VertLineToArc(tRect[2], tRect[1], tRect[3], rx, ry, + arcPtr->start, arcPtr->extent)) { + return 0; + } + if ((width > 1.0) && !filled) { + rx -= width; + ry -= width; + if (HorizLineToArc(tRect[0], tRect[2], tRect[1], rx, ry, arcPtr->start, + arcPtr->extent) + || HorizLineToArc(tRect[0], tRect[2], tRect[3], rx, ry, + arcPtr->start, arcPtr->extent) + || VertLineToArc(tRect[0], tRect[1], tRect[3], rx, ry, + arcPtr->start, arcPtr->extent) + || VertLineToArc(tRect[2], tRect[1], tRect[3], rx, ry, + arcPtr->start, arcPtr->extent)) { + return 0; + } + } + + /* + * The arc still appears to be totally disjoint from the rectangle, + * but it's also possible that the rectangle is totally inside the arc. + * Do one last check, which is to check one point of the rectangle + * to see if it's inside the arc. If it is, we've got overlap. If + * it isn't, the arc's really outside the rectangle. + */ + + if (ArcToPoint(canvas, itemPtr, rectPtr) == 0.0) { + return 0; + } + return -1; +} + +/* + *-------------------------------------------------------------- + * + * ScaleArc -- + * + * This procedure is invoked to rescale an arc item. + * + * Results: + * None. + * + * Side effects: + * The arc referred to by itemPtr is rescaled so that the + * following transformation is applied to all point + * coordinates: + * x' = originX + scaleX*(x-originX) + * y' = originY + scaleY*(y-originY) + * + *-------------------------------------------------------------- + */ + +static void +ScaleArc(canvas, itemPtr, originX, originY, scaleX, scaleY) + Tk_Canvas canvas; /* Canvas containing arc. */ + Tk_Item *itemPtr; /* Arc 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. */ +{ + ArcItem *arcPtr = (ArcItem *) itemPtr; + + arcPtr->bbox[0] = originX + scaleX*(arcPtr->bbox[0] - originX); + arcPtr->bbox[1] = originY + scaleY*(arcPtr->bbox[1] - originY); + arcPtr->bbox[2] = originX + scaleX*(arcPtr->bbox[2] - originX); + arcPtr->bbox[3] = originY + scaleY*(arcPtr->bbox[3] - originY); + ComputeArcBbox(canvas, arcPtr); +} + +/* + *-------------------------------------------------------------- + * + * TranslateArc -- + * + * This procedure is called to move an arc by a given amount. + * + * Results: + * None. + * + * Side effects: + * The position of the arc is offset by (xDelta, yDelta), and + * the bounding box is updated in the generic part of the item + * structure. + * + *-------------------------------------------------------------- + */ + +static void +TranslateArc(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. */ +{ + ArcItem *arcPtr = (ArcItem *) itemPtr; + + arcPtr->bbox[0] += deltaX; + arcPtr->bbox[1] += deltaY; + arcPtr->bbox[2] += deltaX; + arcPtr->bbox[3] += deltaY; + ComputeArcBbox(canvas, arcPtr); +} + +/* + *-------------------------------------------------------------- + * + * ComputeArcOutline -- + * + * This procedure creates a polygon describing everything in + * the outline for an arc except what's in the curved part. + * For a "pie slice" arc this is a V-shaped chunk, and for + * a "chord" arc this is a linear chunk (with cutaway corners). + * For "arc" arcs, this stuff isn't relevant. + * + * Results: + * None. + * + * Side effects: + * The information at arcPtr->outlinePtr gets modified, and + * storage for arcPtr->outlinePtr may be allocated or freed. + * + *-------------------------------------------------------------- + */ + +static void +ComputeArcOutline(arcPtr) + ArcItem *arcPtr; /* Information about arc. */ +{ + double sin1, cos1, sin2, cos2, angle, halfWidth; + double boxWidth, boxHeight; + double vertex[2], corner1[2], corner2[2]; + double *outlinePtr; + + /* + * Make sure that the outlinePtr array is large enough to hold + * either a chord or pie-slice outline. + */ + + if (arcPtr->numOutlinePoints == 0) { + arcPtr->outlinePtr = (double *) ckalloc((unsigned) + (26 * sizeof(double))); + arcPtr->numOutlinePoints = 22; + } + outlinePtr = arcPtr->outlinePtr; + + /* + * First compute the two points that lie at the centers of + * the ends of the curved arc segment, which are marked with + * X's in the figure below: + * + * + * * * * + * * * + * * * * * + * * * * * + * * * * * + * X * * X + * + * The code is tricky because the arc can be ovular in shape. + * It computes the position for a unit circle, and then + * scales to fit the shape of the arc's bounding box. + * + * Also, watch out because angles go counter-clockwise like you + * might expect, but the y-coordinate system is inverted. To + * handle this, just negate the angles in all the computations. + */ + + boxWidth = arcPtr->bbox[2] - arcPtr->bbox[0]; + boxHeight = arcPtr->bbox[3] - arcPtr->bbox[1]; + angle = -arcPtr->start*PI/180.0; + sin1 = sin(angle); + cos1 = cos(angle); + angle -= arcPtr->extent*PI/180.0; + sin2 = sin(angle); + cos2 = cos(angle); + vertex[0] = (arcPtr->bbox[0] + arcPtr->bbox[2])/2.0; + vertex[1] = (arcPtr->bbox[1] + arcPtr->bbox[3])/2.0; + arcPtr->center1[0] = vertex[0] + cos1*boxWidth/2.0; + arcPtr->center1[1] = vertex[1] + sin1*boxHeight/2.0; + arcPtr->center2[0] = vertex[0] + cos2*boxWidth/2.0; + arcPtr->center2[1] = vertex[1] + sin2*boxHeight/2.0; + + /* + * Next compute the "outermost corners" of the arc, which are + * marked with X's in the figure below: + * + * * * * + * * * + * * * * * + * * * * * + * X * * X + * * * + * + * The code below is tricky because it has to handle eccentricity + * in the shape of the oval. The key in the code below is to + * realize that the slope of the line from arcPtr->center1 to corner1 + * is (boxWidth*sin1)/(boxHeight*cos1), and similarly for arcPtr->center2 + * and corner2. These formulas can be computed from the formula for + * the oval. + */ + + halfWidth = arcPtr->width/2.0; + if (((boxWidth*sin1) == 0.0) && ((boxHeight*cos1) == 0.0)) { + angle = 0.0; + } else { + angle = atan2(boxWidth*sin1, boxHeight*cos1); + } + corner1[0] = arcPtr->center1[0] + cos(angle)*halfWidth; + corner1[1] = arcPtr->center1[1] + sin(angle)*halfWidth; + if (((boxWidth*sin2) == 0.0) && ((boxHeight*cos2) == 0.0)) { + angle = 0.0; + } else { + angle = atan2(boxWidth*sin2, boxHeight*cos2); + } + corner2[0] = arcPtr->center2[0] + cos(angle)*halfWidth; + corner2[1] = arcPtr->center2[1] + sin(angle)*halfWidth; + + /* + * For a chord outline, generate a six-sided polygon with three + * points for each end of the chord. The first and third points + * for each end are butt points generated on either side of the + * center point. The second point is the corner point. + */ + + if (arcPtr->style == chordUid) { + outlinePtr[0] = outlinePtr[12] = corner1[0]; + outlinePtr[1] = outlinePtr[13] = corner1[1]; + TkGetButtPoints(arcPtr->center2, arcPtr->center1, + (double) arcPtr->width, 0, outlinePtr+10, outlinePtr+2); + outlinePtr[4] = arcPtr->center2[0] + outlinePtr[2] + - arcPtr->center1[0]; + outlinePtr[5] = arcPtr->center2[1] + outlinePtr[3] + - arcPtr->center1[1]; + outlinePtr[6] = corner2[0]; + outlinePtr[7] = corner2[1]; + outlinePtr[8] = arcPtr->center2[0] + outlinePtr[10] + - arcPtr->center1[0]; + outlinePtr[9] = arcPtr->center2[1] + outlinePtr[11] + - arcPtr->center1[1]; + } else if (arcPtr->style == pieSliceUid) { + /* + * For pie slices, generate two polygons, one for each side + * of the pie slice. The first arm has a shape like this, + * where the center of the oval is X, arcPtr->center1 is at Y, and + * corner1 is at Z: + * + * _____________________ + * | \ + * | \ + * X Y Z + * | / + * |_____________________/ + * + */ + + TkGetButtPoints(arcPtr->center1, vertex, (double) arcPtr->width, 0, + outlinePtr, outlinePtr+2); + outlinePtr[4] = arcPtr->center1[0] + outlinePtr[2] - vertex[0]; + outlinePtr[5] = arcPtr->center1[1] + outlinePtr[3] - vertex[1]; + outlinePtr[6] = corner1[0]; + outlinePtr[7] = corner1[1]; + outlinePtr[8] = arcPtr->center1[0] + outlinePtr[0] - vertex[0]; + outlinePtr[9] = arcPtr->center1[1] + outlinePtr[1] - vertex[1]; + outlinePtr[10] = outlinePtr[0]; + outlinePtr[11] = outlinePtr[1]; + + /* + * The second arm has a shape like this: + * + * + * ______________________ + * / \ + * / \ + * Z Y X / + * \ / + * \______________________/ + * + * Similar to above X is the center of the oval/circle, Y is + * arcPtr->center2, and Z is corner2. The extra jog out to the left + * of X is needed in or to produce a butted joint with the + * first arm; the corner to the right of X is one of the + * first two points of the first arm, depending on extent. + */ + + TkGetButtPoints(arcPtr->center2, vertex, (double) arcPtr->width, 0, + outlinePtr+12, outlinePtr+16); + if ((arcPtr->extent > 180) || + ((arcPtr->extent < 0) && (arcPtr->extent > -180))) { + outlinePtr[14] = outlinePtr[0]; + outlinePtr[15] = outlinePtr[1]; + } else { + outlinePtr[14] = outlinePtr[2]; + outlinePtr[15] = outlinePtr[3]; + } + outlinePtr[18] = arcPtr->center2[0] + outlinePtr[16] - vertex[0]; + outlinePtr[19] = arcPtr->center2[1] + outlinePtr[17] - vertex[1]; + outlinePtr[20] = corner2[0]; + outlinePtr[21] = corner2[1]; + outlinePtr[22] = arcPtr->center2[0] + outlinePtr[12] - vertex[0]; + outlinePtr[23] = arcPtr->center2[1] + outlinePtr[13] - vertex[1]; + outlinePtr[24] = outlinePtr[12]; + outlinePtr[25] = outlinePtr[13]; + } +} + +/* + *-------------------------------------------------------------- + * + * HorizLineToArc -- + * + * Determines whether a horizontal line segment intersects + * a given arc. + * + * Results: + * The return value is 1 if the given line intersects the + * infinitely-thin arc section defined by rx, ry, start, + * and extent, and 0 otherwise. Only the perimeter of the + * arc is checked: interior areas (e.g. pie-slice or chord) + * are not checked. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static int +HorizLineToArc(x1, x2, y, rx, ry, start, extent) + double x1, x2; /* X-coords of endpoints of line segment. + * X1 must be <= x2. */ + double y; /* Y-coordinate of line segment. */ + double rx, ry; /* These x- and y-radii define an oval + * centered at the origin. */ + double start, extent; /* Angles that define extent of arc, in + * the standard fashion for this module. */ +{ + double tmp; + double tx, ty; /* Coordinates of intersection point in + * transformed coordinate system. */ + double x; + + /* + * Compute the x-coordinate of one possible intersection point + * between the arc and the line. Use a transformed coordinate + * system where the oval is a unit circle centered at the origin. + * Then scale back to get actual x-coordinate. + */ + + ty = y/ry; + tmp = 1 - ty*ty; + if (tmp < 0) { + return 0; + } + tx = sqrt(tmp); + x = tx*rx; + + /* + * Test both intersection points. + */ + + if ((x >= x1) && (x <= x2) && AngleInRange(tx, ty, start, extent)) { + return 1; + } + if ((-x >= x1) && (-x <= x2) && AngleInRange(-tx, ty, start, extent)) { + return 1; + } + return 0; +} + +/* + *-------------------------------------------------------------- + * + * VertLineToArc -- + * + * Determines whether a vertical line segment intersects + * a given arc. + * + * Results: + * The return value is 1 if the given line intersects the + * infinitely-thin arc section defined by rx, ry, start, + * and extent, and 0 otherwise. Only the perimeter of the + * arc is checked: interior areas (e.g. pie-slice or chord) + * are not checked. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static int +VertLineToArc(x, y1, y2, rx, ry, start, extent) + double x; /* X-coordinate of line segment. */ + double y1, y2; /* Y-coords of endpoints of line segment. + * Y1 must be <= y2. */ + double rx, ry; /* These x- and y-radii define an oval + * centered at the origin. */ + double start, extent; /* Angles that define extent of arc, in + * the standard fashion for this module. */ +{ + double tmp; + double tx, ty; /* Coordinates of intersection point in + * transformed coordinate system. */ + double y; + + /* + * Compute the y-coordinate of one possible intersection point + * between the arc and the line. Use a transformed coordinate + * system where the oval is a unit circle centered at the origin. + * Then scale back to get actual y-coordinate. + */ + + tx = x/rx; + tmp = 1 - tx*tx; + if (tmp < 0) { + return 0; + } + ty = sqrt(tmp); + y = ty*ry; + + /* + * Test both intersection points. + */ + + if ((y > y1) && (y < y2) && AngleInRange(tx, ty, start, extent)) { + return 1; + } + if ((-y > y1) && (-y < y2) && AngleInRange(tx, -ty, start, extent)) { + return 1; + } + return 0; +} + +/* + *-------------------------------------------------------------- + * + * AngleInRange -- + * + * Determine whether the angle from the origin to a given + * point is within a given range. + * + * Results: + * The return value is 1 if the angle from (0,0) to (x,y) + * is in the range given by start and extent, where angles + * are interpreted in the standard way for ovals (meaning + * backwards from normal interpretation). Otherwise the + * return value is 0. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static int +AngleInRange(x, y, start, extent) + double x, y; /* Coordinate of point; angle measured + * from origin to here, relative to x-axis. */ + double start; /* First angle, degrees, >=0, <=360. */ + double extent; /* Size of arc in degrees >=-360, <=360. */ +{ + double diff; + + if ((x == 0.0) && (y == 0.0)) { + return 1; + } + diff = -atan2(y, x); + diff = diff*(180.0/PI) - start; + while (diff > 360.0) { + diff -= 360.0; + } + while (diff < 0.0) { + diff += 360.0; + } + if (extent >= 0) { + return diff <= extent; + } + return (diff-360.0) >= extent; +} + +/* + *-------------------------------------------------------------- + * + * ArcToPostscript -- + * + * This procedure is called to generate Postscript for + * arc items. + * + * 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. If no error occurs, then Postscript for the + * item is appended to the result. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static int +ArcToPostscript(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. */ +{ + ArcItem *arcPtr = (ArcItem *) itemPtr; + char buffer[400]; + double y1, y2, ang1, ang2; + + y1 = Tk_CanvasPsY(canvas, arcPtr->bbox[1]); + y2 = Tk_CanvasPsY(canvas, arcPtr->bbox[3]); + ang1 = arcPtr->start; + ang2 = ang1 + arcPtr->extent; + if (ang2 < ang1) { + ang1 = ang2; + ang2 = arcPtr->start; + } + + /* + * If the arc is filled, output Postscript for the interior region + * of the arc. + */ + + if (arcPtr->fillGC != None) { + sprintf(buffer, "matrix currentmatrix\n%.15g %.15g translate %.15g %.15g scale\n", + (arcPtr->bbox[0] + arcPtr->bbox[2])/2, (y1 + y2)/2, + (arcPtr->bbox[2] - arcPtr->bbox[0])/2, (y1 - y2)/2); + Tcl_AppendResult(interp, buffer, (char *) NULL); + if (arcPtr->style == chordUid) { + sprintf(buffer, "0 0 1 %.15g %.15g arc closepath\nsetmatrix\n", + ang1, ang2); + } else { + sprintf(buffer, + "0 0 moveto 0 0 1 %.15g %.15g arc closepath\nsetmatrix\n", + ang1, ang2); + } + Tcl_AppendResult(interp, buffer, (char *) NULL); + if (Tk_CanvasPsColor(interp, canvas, arcPtr->fillColor) != TCL_OK) { + return TCL_ERROR; + }; + if (arcPtr->fillStipple != None) { + Tcl_AppendResult(interp, "clip ", (char *) NULL); + if (Tk_CanvasPsStipple(interp, canvas, arcPtr->fillStipple) + != TCL_OK) { + return TCL_ERROR; + } + if (arcPtr->outlineGC != None) { + Tcl_AppendResult(interp, "grestore gsave\n", (char *) NULL); + } + } else { + Tcl_AppendResult(interp, "fill\n", (char *) NULL); + } + } + + /* + * If there's an outline for the arc, draw it. + */ + + if (arcPtr->outlineGC != None) { + sprintf(buffer, "matrix currentmatrix\n%.15g %.15g translate %.15g %.15g scale\n", + (arcPtr->bbox[0] + arcPtr->bbox[2])/2, (y1 + y2)/2, + (arcPtr->bbox[2] - arcPtr->bbox[0])/2, (y1 - y2)/2); + Tcl_AppendResult(interp, buffer, (char *) NULL); + sprintf(buffer, "0 0 1 %.15g %.15g arc\nsetmatrix\n", ang1, ang2); + Tcl_AppendResult(interp, buffer, (char *) NULL); + sprintf(buffer, "%d setlinewidth\n0 setlinecap\n", arcPtr->width); + Tcl_AppendResult(interp, buffer, (char *) NULL); + if (Tk_CanvasPsColor(interp, canvas, arcPtr->outlineColor) + != TCL_OK) { + return TCL_ERROR; + } + if (arcPtr->outlineStipple != None) { + Tcl_AppendResult(interp, "StrokeClip ", (char *) NULL); + if (Tk_CanvasPsStipple(interp, canvas, + arcPtr->outlineStipple) != TCL_OK) { + return TCL_ERROR; + } + } else { + Tcl_AppendResult(interp, "stroke\n", (char *) NULL); + } + if (arcPtr->style != arcUid) { + Tcl_AppendResult(interp, "grestore gsave\n", (char *) NULL); + if (arcPtr->style == chordUid) { + Tk_CanvasPsPath(interp, canvas, arcPtr->outlinePtr, + CHORD_OUTLINE_PTS); + } else { + Tk_CanvasPsPath(interp, canvas, arcPtr->outlinePtr, + PIE_OUTLINE1_PTS); + if (Tk_CanvasPsColor(interp, canvas, arcPtr->outlineColor) + != TCL_OK) { + return TCL_ERROR; + } + if (arcPtr->outlineStipple != None) { + Tcl_AppendResult(interp, "clip ", (char *) NULL); + if (Tk_CanvasPsStipple(interp, canvas, + arcPtr->outlineStipple) != TCL_OK) { + return TCL_ERROR; + } + } else { + Tcl_AppendResult(interp, "fill\n", (char *) NULL); + } + Tcl_AppendResult(interp, "grestore gsave\n", (char *) NULL); + Tk_CanvasPsPath(interp, canvas, + arcPtr->outlinePtr + 2*PIE_OUTLINE1_PTS, + PIE_OUTLINE2_PTS); + } + if (Tk_CanvasPsColor(interp, canvas, arcPtr->outlineColor) + != TCL_OK) { + return TCL_ERROR; + } + if (arcPtr->outlineStipple != None) { + Tcl_AppendResult(interp, "clip ", (char *) NULL); + if (Tk_CanvasPsStipple(interp, canvas, + arcPtr->outlineStipple) != TCL_OK) { + return TCL_ERROR; + } + } else { + Tcl_AppendResult(interp, "fill\n", (char *) NULL); + } + } + } + + return TCL_OK; +} diff --git a/generic/tkCanvBmap.c b/generic/tkCanvBmap.c new file mode 100644 index 0000000..fff0638 --- /dev/null +++ b/generic/tkCanvBmap.c @@ -0,0 +1,800 @@ +/* + * tkCanvBmap.c -- + * + * 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. + * + * 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 + */ + +#include +#include "tkInt.h" +#include "tkPort.h" +#include "tkCanvas.h" + +/* + * The structure below defines the record for each bitmap item. + */ + +typedef struct BitmapItem { + Tk_Item header; /* Generic stuff that's the same for all + * types. MUST BE FIRST IN STRUCTURE. */ + double x, y; /* Coordinates of positioning point for + * bitmap. */ + Tk_Anchor anchor; /* Where to anchor bitmap relative to + * (x,y). */ + Pixmap bitmap; /* Bitmap to display in window. */ + XColor *fgColor; /* Foreground color to use for bitmap. */ + XColor *bgColor; /* Background color to use for bitmap. */ + GC gc; /* Graphics context to use for drawing + * bitmap on screen. */ +} BitmapItem; + +/* + * Information used for parsing configuration specs: + */ + +static Tk_CustomOption tagsOption = {Tk_CanvasTagsParseProc, + Tk_CanvasTagsPrintProc, (ClientData) NULL +}; + +static Tk_ConfigSpec configSpecs[] = { + {TK_CONFIG_ANCHOR, "-anchor", (char *) NULL, (char *) NULL, + "center", Tk_Offset(BitmapItem, anchor), TK_CONFIG_DONT_SET_DEFAULT}, + {TK_CONFIG_COLOR, "-background", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(BitmapItem, bgColor), TK_CONFIG_NULL_OK}, + {TK_CONFIG_BITMAP, "-bitmap", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(BitmapItem, bitmap), TK_CONFIG_NULL_OK}, + {TK_CONFIG_COLOR, "-foreground", (char *) NULL, (char *) NULL, + "black", Tk_Offset(BitmapItem, fgColor), 0}, + {TK_CONFIG_CUSTOM, "-tags", (char *) NULL, (char *) NULL, + (char *) NULL, 0, TK_CONFIG_NULL_OK, &tagsOption}, + {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, 0} +}; + +/* + * Prototypes for procedures defined in this file: + */ + +static int BitmapCoords _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int argc, + char **argv)); +static int BitmapToArea _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double *rectPtr)); +static double BitmapToPoint _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double *coordPtr)); +static int BitmapToPostscript _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int prepass)); +static void ComputeBitmapBbox _ANSI_ARGS_((Tk_Canvas canvas, + BitmapItem *bmapPtr)); +static int ConfigureBitmap _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int argc, + char **argv, int flags)); +static int CreateBitmap _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, struct Tk_Item *itemPtr, + int argc, char **argv)); +static void DeleteBitmap _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, Display *display)); +static void DisplayBitmap _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, Display *display, Drawable dst, + int x, int y, int width, int height)); +static void ScaleBitmap _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double originX, double originY, + double scaleX, double scaleY)); +static void TranslateBitmap _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double deltaX, double deltaY)); + +/* + * The structures below defines the bitmap item type in terms of + * procedures that can be invoked by generic item code. + */ + +Tk_ItemType tkBitmapType = { + "bitmap", /* name */ + sizeof(BitmapItem), /* itemSize */ + CreateBitmap, /* createProc */ + configSpecs, /* configSpecs */ + ConfigureBitmap, /* configureProc */ + BitmapCoords, /* coordProc */ + DeleteBitmap, /* deleteProc */ + DisplayBitmap, /* displayProc */ + 0, /* alwaysRedraw */ + BitmapToPoint, /* pointProc */ + BitmapToArea, /* areaProc */ + BitmapToPostscript, /* postscriptProc */ + ScaleBitmap, /* scaleProc */ + TranslateBitmap, /* translateProc */ + (Tk_ItemIndexProc *) NULL, /* indexProc */ + (Tk_ItemCursorProc *) NULL, /* icursorProc */ + (Tk_ItemSelectionProc *) NULL, /* selectionProc */ + (Tk_ItemInsertProc *) NULL, /* insertProc */ + (Tk_ItemDCharsProc *) NULL, /* dTextProc */ + (Tk_ItemType *) NULL /* nextPtr */ +}; + +/* + *-------------------------------------------------------------- + * + * CreateBitmap -- + * + * This procedure is invoked to create a new bitmap + * item in a canvas. + * + * 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, + * so it can be safely freed by the caller. + * + * Side effects: + * A new bitmap item is created. + * + *-------------------------------------------------------------- + */ + +static int +CreateBitmap(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. */ +{ + BitmapItem *bmapPtr = (BitmapItem *) itemPtr; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + Tk_PathName(Tk_CanvasTkwin(canvas)), " create ", + itemPtr->typePtr->name, " x y ?options?\"", + (char *) NULL); + return TCL_ERROR; + } + + /* + * Initialize item's record. + */ + + bmapPtr->anchor = TK_ANCHOR_CENTER; + bmapPtr->bitmap = None; + bmapPtr->fgColor = NULL; + bmapPtr->bgColor = NULL; + bmapPtr->gc = None; + + /* + * Process the arguments to fill in the item record. + */ + + if ((Tk_CanvasGetCoord(interp, canvas, argv[0], &bmapPtr->x) != TCL_OK) + || (Tk_CanvasGetCoord(interp, canvas, argv[1], &bmapPtr->y) + != TCL_OK)) { + return TCL_ERROR; + } + + if (ConfigureBitmap(interp, canvas, itemPtr, argc-2, argv+2, 0) != TCL_OK) { + DeleteBitmap(canvas, itemPtr, Tk_Display(Tk_CanvasTkwin(canvas))); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * BitmapCoords -- + * + * This procedure is invoked to process the "coords" widget + * command on bitmap items. See the user documentation for + * details on what it does. + * + * Results: + * Returns TCL_OK or TCL_ERROR, and sets interp->result. + * + * Side effects: + * The coordinates for the given item may be changed. + * + *-------------------------------------------------------------- + */ + +static int +BitmapCoords(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, ... */ +{ + BitmapItem *bmapPtr = (BitmapItem *) itemPtr; + char x[TCL_DOUBLE_SPACE], y[TCL_DOUBLE_SPACE]; + + if (argc == 0) { + Tcl_PrintDouble(interp, bmapPtr->x, x); + Tcl_PrintDouble(interp, bmapPtr->y, y); + Tcl_AppendResult(interp, x, " ", y, (char *) NULL); + } else if (argc == 2) { + if ((Tk_CanvasGetCoord(interp, canvas, argv[0], &bmapPtr->x) != TCL_OK) + || (Tk_CanvasGetCoord(interp, canvas, argv[1], &bmapPtr->y) + != TCL_OK)) { + return TCL_ERROR; + } + ComputeBitmapBbox(canvas, bmapPtr); + } else { + sprintf(interp->result, + "wrong # coordinates: expected 0 or 2, got %d", argc); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * ConfigureBitmap -- + * + * This procedure is invoked to configure various aspects + * of a bitmap item, such as its anchor position. + * + * Results: + * A standard Tcl result code. If an error occurs, then + * an error message is left in interp->result. + * + * Side effects: + * Configuration information may be set for itemPtr. + * + *-------------------------------------------------------------- + */ + +static int +ConfigureBitmap(interp, canvas, itemPtr, argc, argv, flags) + Tcl_Interp *interp; /* Used for error reporting. */ + Tk_Canvas canvas; /* Canvas containing itemPtr. */ + Tk_Item *itemPtr; /* Bitmap item to reconfigure. */ + int argc; /* Number of elements in argv. */ + char **argv; /* Arguments describing things to configure. */ + int flags; /* Flags to pass to Tk_ConfigureWidget. */ +{ + BitmapItem *bmapPtr = (BitmapItem *) itemPtr; + XGCValues gcValues; + GC newGC; + Tk_Window tkwin; + unsigned long mask; + + tkwin = Tk_CanvasTkwin(canvas); + if (Tk_ConfigureWidget(interp, tkwin, configSpecs, argc, argv, + (char *) bmapPtr, flags) != TCL_OK) { + return TCL_ERROR; + } + + /* + * A few of the options require additional processing, such as those + * that determine the graphics context. + */ + + gcValues.foreground = bmapPtr->fgColor->pixel; + mask = GCForeground; + if (bmapPtr->bgColor != NULL) { + gcValues.background = bmapPtr->bgColor->pixel; + mask |= GCBackground; + } else { + gcValues.clip_mask = bmapPtr->bitmap; + mask |= GCClipMask; + } + newGC = Tk_GetGC(tkwin, mask, &gcValues); + if (bmapPtr->gc != None) { + Tk_FreeGC(Tk_Display(tkwin), bmapPtr->gc); + } + bmapPtr->gc = newGC; + + ComputeBitmapBbox(canvas, bmapPtr); + + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * DeleteBitmap -- + * + * This procedure is called to clean up the data structure + * associated with a bitmap item. + * + * Results: + * None. + * + * Side effects: + * Resources associated with itemPtr are released. + * + *-------------------------------------------------------------- + */ + +static void +DeleteBitmap(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. */ +{ + BitmapItem *bmapPtr = (BitmapItem *) itemPtr; + + if (bmapPtr->bitmap != None) { + Tk_FreeBitmap(display, bmapPtr->bitmap); + } + if (bmapPtr->fgColor != NULL) { + Tk_FreeColor(bmapPtr->fgColor); + } + if (bmapPtr->bgColor != NULL) { + Tk_FreeColor(bmapPtr->bgColor); + } + if (bmapPtr->gc != NULL) { + Tk_FreeGC(display, bmapPtr->gc); + } +} + +/* + *-------------------------------------------------------------- + * + * ComputeBitmapBbox -- + * + * This procedure is invoked to compute the bounding box of + * all the pixels that may be drawn as part of a bitmap item. + * This procedure is where the child bitmap's placement is + * computed. + * + * Results: + * None. + * + * Side effects: + * The fields x1, y1, x2, and y2 are updated in the header + * for itemPtr. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +ComputeBitmapBbox(canvas, bmapPtr) + Tk_Canvas canvas; /* Canvas that contains item. */ + BitmapItem *bmapPtr; /* Item whose bbox is to be + * recomputed. */ +{ + int width, height; + int x, y; + + x = (int) (bmapPtr->x + ((bmapPtr->x >= 0) ? 0.5 : - 0.5)); + y = (int) (bmapPtr->y + ((bmapPtr->y >= 0) ? 0.5 : - 0.5)); + + if (bmapPtr->bitmap == None) { + bmapPtr->header.x1 = bmapPtr->header.x2 = x; + bmapPtr->header.y1 = bmapPtr->header.y2 = y; + return; + } + + /* + * Compute location and size of bitmap, using anchor information. + */ + + Tk_SizeOfBitmap(Tk_Display(Tk_CanvasTkwin(canvas)), bmapPtr->bitmap, + &width, &height); + switch (bmapPtr->anchor) { + case TK_ANCHOR_N: + x -= width/2; + break; + case TK_ANCHOR_NE: + x -= width; + break; + case TK_ANCHOR_E: + x -= width; + y -= height/2; + break; + case TK_ANCHOR_SE: + x -= width; + y -= height; + break; + case TK_ANCHOR_S: + x -= width/2; + y -= height; + break; + case TK_ANCHOR_SW: + y -= height; + break; + case TK_ANCHOR_W: + y -= height/2; + break; + case TK_ANCHOR_NW: + break; + case TK_ANCHOR_CENTER: + x -= width/2; + y -= height/2; + break; + } + + /* + * Store the information in the item header. + */ + + bmapPtr->header.x1 = x; + bmapPtr->header.y1 = y; + bmapPtr->header.x2 = x + width; + bmapPtr->header.y2 = y + height; +} + +/* + *-------------------------------------------------------------- + * + * DisplayBitmap -- + * + * This procedure is invoked to draw a bitmap item in a given + * drawable. + * + * Results: + * None. + * + * Side effects: + * ItemPtr is drawn in drawable using the transformation + * information in canvas. + * + *-------------------------------------------------------------- + */ + +static void +DisplayBitmap(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). */ +{ + BitmapItem *bmapPtr = (BitmapItem *) itemPtr; + int bmapX, bmapY, bmapWidth, bmapHeight; + short drawableX, drawableY; + + /* + * If the area being displayed doesn't cover the whole bitmap, + * then only redisplay the part of the bitmap that needs + * redisplay. + */ + + if (bmapPtr->bitmap != None) { + if (x > bmapPtr->header.x1) { + bmapX = x - bmapPtr->header.x1; + bmapWidth = bmapPtr->header.x2 - x; + } else { + bmapX = 0; + if ((x+width) < bmapPtr->header.x2) { + bmapWidth = x + width - bmapPtr->header.x1; + } else { + bmapWidth = bmapPtr->header.x2 - bmapPtr->header.x1; + } + } + if (y > bmapPtr->header.y1) { + bmapY = y - bmapPtr->header.y1; + bmapHeight = bmapPtr->header.y2 - y; + } else { + bmapY = 0; + if ((y+height) < bmapPtr->header.y2) { + bmapHeight = y + height - bmapPtr->header.y1; + } else { + bmapHeight = bmapPtr->header.y2 - bmapPtr->header.y1; + } + } + Tk_CanvasDrawableCoords(canvas, + (double) (bmapPtr->header.x1 + bmapX), + (double) (bmapPtr->header.y1 + bmapY), + &drawableX, &drawableY); + + /* + * Must modify the mask origin within the graphics context + * to line up with the bitmap's origin (in order to make + * bitmaps with "-background {}" work right). + */ + + XSetClipOrigin(display, bmapPtr->gc, drawableX - bmapX, + drawableY - bmapY); + XCopyPlane(display, bmapPtr->bitmap, drawable, + bmapPtr->gc, bmapX, bmapY, (unsigned int) bmapWidth, + (unsigned int) bmapHeight, drawableX, drawableY, 1); + } +} + +/* + *-------------------------------------------------------------- + * + * BitmapToPoint -- + * + * Computes the distance from a given point to a given + * rectangle, in canvas units. + * + * Results: + * The return value is 0 if the point whose x and y coordinates + * are coordPtr[0] and coordPtr[1] is inside the bitmap. If the + * point isn't inside the bitmap then the return value is the + * distance from the point to the bitmap. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static double +BitmapToPoint(canvas, itemPtr, coordPtr) + Tk_Canvas canvas; /* Canvas containing item. */ + Tk_Item *itemPtr; /* Item to check against point. */ + double *coordPtr; /* Pointer to x and y coordinates. */ +{ + BitmapItem *bmapPtr = (BitmapItem *) itemPtr; + double x1, x2, y1, y2, xDiff, yDiff; + + x1 = bmapPtr->header.x1; + y1 = bmapPtr->header.y1; + x2 = bmapPtr->header.x2; + y2 = bmapPtr->header.y2; + + /* + * Point is outside rectangle. + */ + + if (coordPtr[0] < x1) { + xDiff = x1 - coordPtr[0]; + } else if (coordPtr[0] > x2) { + xDiff = coordPtr[0] - x2; + } else { + xDiff = 0; + } + + if (coordPtr[1] < y1) { + yDiff = y1 - coordPtr[1]; + } else if (coordPtr[1] > y2) { + yDiff = coordPtr[1] - y2; + } else { + yDiff = 0; + } + + return hypot(xDiff, yDiff); +} + +/* + *-------------------------------------------------------------- + * + * BitmapToArea -- + * + * This procedure is called to determine whether an item + * lies entirely inside, entirely outside, or overlapping + * a given rectangle. + * + * Results: + * -1 is returned if the item is entirely outside the area + * given by rectPtr, 0 if it overlaps, and 1 if it is entirely + * inside the given area. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +BitmapToArea(canvas, itemPtr, rectPtr) + Tk_Canvas canvas; /* Canvas containing item. */ + Tk_Item *itemPtr; /* Item to check against rectangle. */ + double *rectPtr; /* Pointer to array of four coordinates + * (x1, y1, x2, y2) describing rectangular + * area. */ +{ + BitmapItem *bmapPtr = (BitmapItem *) itemPtr; + + if ((rectPtr[2] <= bmapPtr->header.x1) + || (rectPtr[0] >= bmapPtr->header.x2) + || (rectPtr[3] <= bmapPtr->header.y1) + || (rectPtr[1] >= bmapPtr->header.y2)) { + return -1; + } + if ((rectPtr[0] <= bmapPtr->header.x1) + && (rectPtr[1] <= bmapPtr->header.y1) + && (rectPtr[2] >= bmapPtr->header.x2) + && (rectPtr[3] >= bmapPtr->header.y2)) { + return 1; + } + return 0; +} + +/* + *-------------------------------------------------------------- + * + * ScaleBitmap -- + * + * This procedure is invoked to rescale a bitmap item in a + * canvas. It is one of the standard item procedures for + * bitmap items, and is invoked by the generic canvas code. + * + * Results: + * None. + * + * Side effects: + * The item referred to by itemPtr is rescaled so that the + * following transformation is applied to all point coordinates: + * x' = originX + scaleX*(x-originX) + * y' = originY + scaleY*(y-originY) + * + *-------------------------------------------------------------- + */ + +static void +ScaleBitmap(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 item. */ + double scaleX; /* Amount to scale in X direction. */ + double scaleY; /* Amount to scale in Y direction. */ +{ + BitmapItem *bmapPtr = (BitmapItem *) itemPtr; + + bmapPtr->x = originX + scaleX*(bmapPtr->x - originX); + bmapPtr->y = originY + scaleY*(bmapPtr->y - originY); + ComputeBitmapBbox(canvas, bmapPtr); +} + +/* + *-------------------------------------------------------------- + * + * TranslateBitmap -- + * + * This procedure is called to move an item by a given amount. + * + * Results: + * None. + * + * Side effects: + * The position of the item is offset by (xDelta, yDelta), and + * the bounding box is updated in the generic part of the item + * structure. + * + *-------------------------------------------------------------- + */ + +static void +TranslateBitmap(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. */ +{ + BitmapItem *bmapPtr = (BitmapItem *) itemPtr; + + bmapPtr->x += deltaX; + bmapPtr->y += deltaY; + ComputeBitmapBbox(canvas, bmapPtr); +} + +/* + *-------------------------------------------------------------- + * + * BitmapToPostscript -- + * + * This procedure is called to generate Postscript for + * bitmap items. + * + * 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. + * If no error occurs, then Postscript for the item is appended + * to the result. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static int +BitmapToPostscript(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. */ +{ + BitmapItem *bmapPtr = (BitmapItem *) itemPtr; + double x, y; + int width, height, rowsAtOnce, rowsThisTime; + int curRow; + char buffer[200]; + + if (bmapPtr->bitmap == None) { + return TCL_OK; + } + + /* + * Compute the coordinates of the lower-left corner of the bitmap, + * taking into account the anchor position for the bitmp. + */ + + x = bmapPtr->x; + y = Tk_CanvasPsY(canvas, bmapPtr->y); + Tk_SizeOfBitmap(Tk_Display(Tk_CanvasTkwin(canvas)), bmapPtr->bitmap, + &width, &height); + switch (bmapPtr->anchor) { + case TK_ANCHOR_NW: y -= height; break; + case TK_ANCHOR_N: x -= width/2.0; y -= height; break; + case TK_ANCHOR_NE: x -= width; y -= height; break; + case TK_ANCHOR_E: x -= width; y -= height/2.0; break; + case TK_ANCHOR_SE: x -= width; break; + case TK_ANCHOR_S: x -= width/2.0; break; + case TK_ANCHOR_SW: break; + case TK_ANCHOR_W: y -= height/2.0; break; + case TK_ANCHOR_CENTER: x -= width/2.0; y -= height/2.0; break; + } + + /* + * Color the background, if there is one. + */ + + 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"); + Tcl_AppendResult(interp, buffer, (char *) NULL); + if (Tk_CanvasPsColor(interp, canvas, bmapPtr->bgColor) != TCL_OK) { + return TCL_ERROR; + } + Tcl_AppendResult(interp, "fill\n", (char *) NULL); + } + + /* + * Draw the bitmap, if there is a foreground color. If the bitmap + * is very large, then chop it up into multiple bitmaps, each + * consisting of one or more rows. This is needed because Postscript + * can't handle single strings longer than 64 KBytes long. + */ + + if (bmapPtr->fgColor != NULL) { + if (Tk_CanvasPsColor(interp, canvas, bmapPtr->fgColor) != TCL_OK) { + return TCL_ERROR; + } + if (width > 60000) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "can't generate Postscript", + " for bitmaps more than 60000 pixels wide", + (char *) NULL); + return TCL_ERROR; + } + rowsAtOnce = 60000/width; + if (rowsAtOnce < 1) { + rowsAtOnce = 1; + } + sprintf(buffer, "%.15g %.15g translate\n", x, y+height); + Tcl_AppendResult(interp, buffer, (char *) NULL); + for (curRow = 0; curRow < height; curRow += rowsAtOnce) { + rowsThisTime = rowsAtOnce; + if (rowsThisTime > (height - curRow)) { + rowsThisTime = height - curRow; + } + sprintf(buffer, "0 -%.15g translate\n%d %d true matrix {\n", + (double) rowsThisTime, width, rowsThisTime); + Tcl_AppendResult(interp, buffer, (char *) NULL); + if (Tk_CanvasPsBitmap(interp, canvas, bmapPtr->bitmap, + 0, curRow, width, rowsThisTime) != TCL_OK) { + return TCL_ERROR; + } + Tcl_AppendResult(interp, "\n} imagemask\n", (char *) NULL); + } + } + return TCL_OK; +} diff --git a/generic/tkCanvImg.c b/generic/tkCanvImg.c new file mode 100644 index 0000000..55169f7 --- /dev/null +++ b/generic/tkCanvImg.c @@ -0,0 +1,677 @@ +/* + * tkCanvImg.c -- + * + * 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. + * + * 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 + */ + +#include +#include "tkInt.h" +#include "tkPort.h" +#include "tkCanvas.h" + +/* + * The structure below defines the record for each image item. + */ + +typedef struct ImageItem { + Tk_Item header; /* Generic stuff that's the same for all + * types. MUST BE FIRST IN STRUCTURE. */ + Tk_Canvas canvas; /* Canvas containing the image. */ + double x, y; /* Coordinates of positioning point for + * image. */ + Tk_Anchor anchor; /* Where to anchor image relative to + * (x,y). */ + char *imageString; /* String describing -image option (malloc-ed). + * NULL means no image right now. */ + Tk_Image image; /* Image to display in window, or NULL if + * no image at present. */ +} ImageItem; + +/* + * Information used for parsing configuration specs: + */ + +static Tk_CustomOption tagsOption = {Tk_CanvasTagsParseProc, + Tk_CanvasTagsPrintProc, (ClientData) NULL +}; + +static Tk_ConfigSpec configSpecs[] = { + {TK_CONFIG_ANCHOR, "-anchor", (char *) NULL, (char *) NULL, + "center", Tk_Offset(ImageItem, anchor), TK_CONFIG_DONT_SET_DEFAULT}, + {TK_CONFIG_STRING, "-image", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(ImageItem, imageString), TK_CONFIG_NULL_OK}, + {TK_CONFIG_CUSTOM, "-tags", (char *) NULL, (char *) NULL, + (char *) NULL, 0, TK_CONFIG_NULL_OK, &tagsOption}, + {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, 0} +}; + +/* + * Prototypes for procedures defined in this file: + */ + +static void ImageChangedProc _ANSI_ARGS_((ClientData clientData, + int x, int y, int width, int height, int imgWidth, + int imgHeight)); +static int ImageCoords _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int argc, + char **argv)); +static int ImageToArea _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double *rectPtr)); +static double ImageToPoint _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double *coordPtr)); +static void ComputeImageBbox _ANSI_ARGS_((Tk_Canvas canvas, + ImageItem *imgPtr)); +static int ConfigureImage _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int argc, + char **argv, int flags)); +static int CreateImage _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, struct Tk_Item *itemPtr, + int argc, char **argv)); +static void DeleteImage _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, Display *display)); +static void DisplayImage _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, Display *display, Drawable dst, + int x, int y, int width, int height)); +static void ScaleImage _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double originX, double originY, + double scaleX, double scaleY)); +static void TranslateImage _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double deltaX, double deltaY)); + +/* + * The structures below defines the image item type in terms of + * procedures that can be invoked by generic item code. + */ + +Tk_ItemType tkImageType = { + "image", /* name */ + sizeof(ImageItem), /* itemSize */ + CreateImage, /* createProc */ + configSpecs, /* configSpecs */ + ConfigureImage, /* configureProc */ + ImageCoords, /* coordProc */ + DeleteImage, /* deleteProc */ + DisplayImage, /* displayProc */ + 0, /* alwaysRedraw */ + ImageToPoint, /* pointProc */ + ImageToArea, /* areaProc */ + (Tk_ItemPostscriptProc *) NULL, /* postscriptProc */ + ScaleImage, /* scaleProc */ + TranslateImage, /* translateProc */ + (Tk_ItemIndexProc *) NULL, /* indexProc */ + (Tk_ItemCursorProc *) NULL, /* icursorProc */ + (Tk_ItemSelectionProc *) NULL, /* selectionProc */ + (Tk_ItemInsertProc *) NULL, /* insertProc */ + (Tk_ItemDCharsProc *) NULL, /* dTextProc */ + (Tk_ItemType *) NULL /* nextPtr */ +}; + +/* + *-------------------------------------------------------------- + * + * CreateImage -- + * + * This procedure is invoked to create a new image + * item in a canvas. + * + * 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, + * so it can be safely freed by the caller. + * + * Side effects: + * A new image item is created. + * + *-------------------------------------------------------------- + */ + +static int +CreateImage(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. */ +{ + ImageItem *imgPtr = (ImageItem *) itemPtr; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + Tk_PathName(Tk_CanvasTkwin(canvas)), " create ", + itemPtr->typePtr->name, " x y ?options?\"", + (char *) NULL); + return TCL_ERROR; + } + + /* + * Initialize item's record. + */ + + imgPtr->canvas = canvas; + imgPtr->anchor = TK_ANCHOR_CENTER; + imgPtr->imageString = NULL; + imgPtr->image = NULL; + + /* + * Process the arguments to fill in the item record. + */ + + if ((Tk_CanvasGetCoord(interp, canvas, argv[0], &imgPtr->x) != TCL_OK) + || (Tk_CanvasGetCoord(interp, canvas, argv[1], &imgPtr->y) + != TCL_OK)) { + return TCL_ERROR; + } + + if (ConfigureImage(interp, canvas, itemPtr, argc-2, argv+2, 0) != TCL_OK) { + DeleteImage(canvas, itemPtr, Tk_Display(Tk_CanvasTkwin(canvas))); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * ImageCoords -- + * + * This procedure is invoked to process the "coords" widget + * command on image items. See the user documentation for + * details on what it does. + * + * Results: + * Returns TCL_OK or TCL_ERROR, and sets interp->result. + * + * Side effects: + * The coordinates for the given item may be changed. + * + *-------------------------------------------------------------- + */ + +static int +ImageCoords(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, ... */ +{ + ImageItem *imgPtr = (ImageItem *) itemPtr; + char x[TCL_DOUBLE_SPACE], y[TCL_DOUBLE_SPACE]; + + if (argc == 0) { + Tcl_PrintDouble(interp, imgPtr->x, x); + Tcl_PrintDouble(interp, imgPtr->y, y); + Tcl_AppendResult(interp, x, " ", y, (char *) NULL); + } else if (argc == 2) { + if ((Tk_CanvasGetCoord(interp, canvas, argv[0], &imgPtr->x) != TCL_OK) + || (Tk_CanvasGetCoord(interp, canvas, argv[1], + &imgPtr->y) != TCL_OK)) { + return TCL_ERROR; + } + ComputeImageBbox(canvas, imgPtr); + } else { + sprintf(interp->result, + "wrong # coordinates: expected 0 or 2, got %d", argc); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * ConfigureImage -- + * + * This procedure is invoked to configure various aspects + * of an image item, such as its anchor position. + * + * Results: + * A standard Tcl result code. If an error occurs, then + * an error message is left in interp->result. + * + * Side effects: + * Configuration information may be set for itemPtr. + * + *-------------------------------------------------------------- + */ + +static int +ConfigureImage(interp, canvas, itemPtr, argc, argv, flags) + Tcl_Interp *interp; /* Used for error reporting. */ + Tk_Canvas canvas; /* Canvas containing itemPtr. */ + Tk_Item *itemPtr; /* Image item to reconfigure. */ + int argc; /* Number of elements in argv. */ + char **argv; /* Arguments describing things to configure. */ + int flags; /* Flags to pass to Tk_ConfigureWidget. */ +{ + ImageItem *imgPtr = (ImageItem *) itemPtr; + Tk_Window tkwin; + Tk_Image image; + + tkwin = Tk_CanvasTkwin(canvas); + if (Tk_ConfigureWidget(interp, tkwin, configSpecs, argc, + argv, (char *) imgPtr, flags) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Create the image. Save the old image around and don't free it + * until after the new one is allocated. This keeps the reference + * count from going to zero so the image doesn't have to be recreated + * if it hasn't changed. + */ + + if (imgPtr->imageString != NULL) { + image = Tk_GetImage(interp, tkwin, imgPtr->imageString, + ImageChangedProc, (ClientData) imgPtr); + if (image == NULL) { + return TCL_ERROR; + } + } else { + image = NULL; + } + if (imgPtr->image != NULL) { + Tk_FreeImage(imgPtr->image); + } + imgPtr->image = image; + ComputeImageBbox(canvas, imgPtr); + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * DeleteImage -- + * + * This procedure is called to clean up the data structure + * associated with a image item. + * + * Results: + * None. + * + * Side effects: + * Resources associated with itemPtr are released. + * + *-------------------------------------------------------------- + */ + +static void +DeleteImage(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. */ +{ + ImageItem *imgPtr = (ImageItem *) itemPtr; + + if (imgPtr->imageString != NULL) { + ckfree(imgPtr->imageString); + } + if (imgPtr->image != NULL) { + Tk_FreeImage(imgPtr->image); + } +} + +/* + *-------------------------------------------------------------- + * + * ComputeImageBbox -- + * + * This procedure is invoked to compute the bounding box of + * all the pixels that may be drawn as part of a image item. + * This procedure is where the child image's placement is + * computed. + * + * Results: + * None. + * + * Side effects: + * The fields x1, y1, x2, and y2 are updated in the header + * for itemPtr. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +ComputeImageBbox(canvas, imgPtr) + Tk_Canvas canvas; /* Canvas that contains item. */ + ImageItem *imgPtr; /* Item whose bbox is to be + * recomputed. */ +{ + int width, height; + int x, y; + + x = (int) (imgPtr->x + ((imgPtr->x >= 0) ? 0.5 : - 0.5)); + y = (int) (imgPtr->y + ((imgPtr->y >= 0) ? 0.5 : - 0.5)); + + if (imgPtr->image == None) { + imgPtr->header.x1 = imgPtr->header.x2 = x; + imgPtr->header.y1 = imgPtr->header.y2 = y; + return; + } + + /* + * Compute location and size of image, using anchor information. + */ + + Tk_SizeOfImage(imgPtr->image, &width, &height); + switch (imgPtr->anchor) { + case TK_ANCHOR_N: + x -= width/2; + break; + case TK_ANCHOR_NE: + x -= width; + break; + case TK_ANCHOR_E: + x -= width; + y -= height/2; + break; + case TK_ANCHOR_SE: + x -= width; + y -= height; + break; + case TK_ANCHOR_S: + x -= width/2; + y -= height; + break; + case TK_ANCHOR_SW: + y -= height; + break; + case TK_ANCHOR_W: + y -= height/2; + break; + case TK_ANCHOR_NW: + break; + case TK_ANCHOR_CENTER: + x -= width/2; + y -= height/2; + break; + } + + /* + * Store the information in the item header. + */ + + imgPtr->header.x1 = x; + imgPtr->header.y1 = y; + imgPtr->header.x2 = x + width; + imgPtr->header.y2 = y + height; +} + +/* + *-------------------------------------------------------------- + * + * DisplayImage -- + * + * This procedure is invoked to draw a image item in a given + * drawable. + * + * Results: + * None. + * + * Side effects: + * ItemPtr is drawn in drawable using the transformation + * information in canvas. + * + *-------------------------------------------------------------- + */ + +static void +DisplayImage(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). */ +{ + ImageItem *imgPtr = (ImageItem *) itemPtr; + short drawableX, drawableY; + + if (imgPtr->image == NULL) { + return; + } + + /* + * Translate the coordinates to those of the image, then redisplay it. + */ + + Tk_CanvasDrawableCoords(canvas, (double) x, (double) y, + &drawableX, &drawableY); + Tk_RedrawImage(imgPtr->image, x - imgPtr->header.x1, y - imgPtr->header.y1, + width, height, drawable, drawableX, drawableY); +} + +/* + *-------------------------------------------------------------- + * + * ImageToPoint -- + * + * Computes the distance from a given point to a given + * rectangle, in canvas units. + * + * Results: + * The return value is 0 if the point whose x and y coordinates + * are coordPtr[0] and coordPtr[1] is inside the image. If the + * point isn't inside the image then the return value is the + * distance from the point to the image. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static double +ImageToPoint(canvas, itemPtr, coordPtr) + Tk_Canvas canvas; /* Canvas containing item. */ + Tk_Item *itemPtr; /* Item to check against point. */ + double *coordPtr; /* Pointer to x and y coordinates. */ +{ + ImageItem *imgPtr = (ImageItem *) itemPtr; + double x1, x2, y1, y2, xDiff, yDiff; + + x1 = imgPtr->header.x1; + y1 = imgPtr->header.y1; + x2 = imgPtr->header.x2; + y2 = imgPtr->header.y2; + + /* + * Point is outside rectangle. + */ + + if (coordPtr[0] < x1) { + xDiff = x1 - coordPtr[0]; + } else if (coordPtr[0] > x2) { + xDiff = coordPtr[0] - x2; + } else { + xDiff = 0; + } + + if (coordPtr[1] < y1) { + yDiff = y1 - coordPtr[1]; + } else if (coordPtr[1] > y2) { + yDiff = coordPtr[1] - y2; + } else { + yDiff = 0; + } + + return hypot(xDiff, yDiff); +} + +/* + *-------------------------------------------------------------- + * + * ImageToArea -- + * + * This procedure is called to determine whether an item + * lies entirely inside, entirely outside, or overlapping + * a given rectangle. + * + * Results: + * -1 is returned if the item is entirely outside the area + * given by rectPtr, 0 if it overlaps, and 1 if it is entirely + * inside the given area. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static int +ImageToArea(canvas, itemPtr, rectPtr) + Tk_Canvas canvas; /* Canvas containing item. */ + Tk_Item *itemPtr; /* Item to check against rectangle. */ + double *rectPtr; /* Pointer to array of four coordinates + * (x1, y1, x2, y2) describing rectangular + * area. */ +{ + ImageItem *imgPtr = (ImageItem *) itemPtr; + + if ((rectPtr[2] <= imgPtr->header.x1) + || (rectPtr[0] >= imgPtr->header.x2) + || (rectPtr[3] <= imgPtr->header.y1) + || (rectPtr[1] >= imgPtr->header.y2)) { + return -1; + } + if ((rectPtr[0] <= imgPtr->header.x1) + && (rectPtr[1] <= imgPtr->header.y1) + && (rectPtr[2] >= imgPtr->header.x2) + && (rectPtr[3] >= imgPtr->header.y2)) { + return 1; + } + return 0; +} + +/* + *-------------------------------------------------------------- + * + * ScaleImage -- + * + * This procedure is invoked to rescale an item. + * + * Results: + * None. + * + * Side effects: + * The item referred to by itemPtr is rescaled so that the + * following transformation is applied to all point coordinates: + * x' = originX + scaleX*(x-originX) + * y' = originY + scaleY*(y-originY) + * + *-------------------------------------------------------------- + */ + +static void +ScaleImage(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. */ +{ + ImageItem *imgPtr = (ImageItem *) itemPtr; + + imgPtr->x = originX + scaleX*(imgPtr->x - originX); + imgPtr->y = originY + scaleY*(imgPtr->y - originY); + ComputeImageBbox(canvas, imgPtr); +} + +/* + *-------------------------------------------------------------- + * + * TranslateImage -- + * + * This procedure is called to move an item by a given amount. + * + * Results: + * None. + * + * Side effects: + * The position of the item is offset by (xDelta, yDelta), and + * the bounding box is updated in the generic part of the item + * structure. + * + *-------------------------------------------------------------- + */ + +static void +TranslateImage(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. */ +{ + ImageItem *imgPtr = (ImageItem *) itemPtr; + + imgPtr->x += deltaX; + imgPtr->y += deltaY; + ComputeImageBbox(canvas, imgPtr); +} + +/* + *---------------------------------------------------------------------- + * + * ImageChangedProc -- + * + * This procedure is invoked by the image code whenever the manager + * for an image does something that affects the image's size or + * how it is displayed. + * + * Results: + * None. + * + * Side effects: + * Arranges for the canvas to get redisplayed. + * + *---------------------------------------------------------------------- + */ + +static void +ImageChangedProc(clientData, x, y, width, height, imgWidth, imgHeight) + ClientData clientData; /* Pointer to canvas item for image. */ + int x, y; /* Upper left pixel (within image) + * that must be redisplayed. */ + int width, height; /* Dimensions of area to redisplay + * (may be <= 0). */ + int imgWidth, imgHeight; /* New dimensions of image. */ +{ + ImageItem *imgPtr = (ImageItem *) clientData; + + /* + * If the image's size changed and it's not anchored at its + * northwest corner then just redisplay the entire area of the + * image. This is a bit over-conservative, but we need to do + * something because a size change also means a position change. + */ + + if (((imgPtr->header.x2 - imgPtr->header.x1) != imgWidth) + || ((imgPtr->header.y2 - imgPtr->header.y1) != imgHeight)) { + x = y = 0; + width = imgWidth; + height = imgHeight; + Tk_CanvasEventuallyRedraw(imgPtr->canvas, imgPtr->header.x1, + imgPtr->header.y1, imgPtr->header.x2, imgPtr->header.y2); + } + ComputeImageBbox(imgPtr->canvas, imgPtr); + Tk_CanvasEventuallyRedraw(imgPtr->canvas, imgPtr->header.x1 + x, + imgPtr->header.y1 + y, (int) (imgPtr->header.x1 + x + width), + (int) (imgPtr->header.y1 + y + height)); +} diff --git a/generic/tkCanvLine.c b/generic/tkCanvLine.c new file mode 100644 index 0000000..97cd1f5 --- /dev/null +++ b/generic/tkCanvLine.c @@ -0,0 +1,1623 @@ +/* + * tkCanvLine.c -- + * + * 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. + * + * 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 + */ + +#include +#include "tkInt.h" +#include "tkPort.h" + +/* + * The structure below defines the record for each line item. + */ + +typedef struct LineItem { + Tk_Item header; /* Generic stuff that's the same for all + * types. MUST BE FIRST IN STRUCTURE. */ + Tk_Canvas canvas; /* Canvas containing item. Needed for + * parsing arrow shapes. */ + int numPoints; /* Number of points in line (always >= 2). */ + double *coordPtr; /* Pointer to malloc-ed array containing + * x- and y-coords of all points in line. + * X-coords are even-valued indices, y-coords + * are corresponding odd-valued indices. If + * the line has arrowheads then the first + * and last points have been adjusted to refer + * to the necks of the arrowheads rather than + * their tips. The actual endpoints are + * stored in the *firstArrowPtr and + * *lastArrowPtr, if they exist. */ + int width; /* Width of line. */ + XColor *fg; /* Foreground color for line. */ + Pixmap fillStipple; /* Stipple bitmap for filling line. */ + int capStyle; /* Cap style for line. */ + int joinStyle; /* Join style for line. */ + GC gc; /* Graphics context for filling line. */ + GC arrowGC; /* Graphics context for drawing arrowheads. */ + Tk_Uid arrow; /* Indicates whether or not to draw arrowheads: + * "none", "first", "last", or "both". */ + float arrowShapeA; /* Distance from tip of arrowhead to center. */ + float arrowShapeB; /* Distance from tip of arrowhead to trailing + * point, measured along shaft. */ + float arrowShapeC; /* Distance of trailing points from outside + * edge of shaft. */ + double *firstArrowPtr; /* Points to array of PTS_IN_ARROW points + * describing polygon for arrowhead at first + * point in line. First point of arrowhead + * is tip. Malloc'ed. NULL means no arrowhead + * at first point. */ + double *lastArrowPtr; /* Points to polygon for arrowhead at last + * point in line (PTS_IN_ARROW points, first + * of which is tip). Malloc'ed. NULL means + * no arrowhead at last point. */ + int smooth; /* Non-zero means draw line smoothed (i.e. + * with Bezier splines). */ + int splineSteps; /* Number of steps in each spline segment. */ +} LineItem; + +/* + * Number of points in an arrowHead: + */ + +#define PTS_IN_ARROW 6 + +/* + * Prototypes for procedures defined in this file: + */ + +static int ArrowheadPostscript _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, LineItem *linePtr, + double *arrowPtr)); +static void ComputeLineBbox _ANSI_ARGS_((Tk_Canvas canvas, + LineItem *linePtr)); +static int ConfigureLine _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int argc, + char **argv, int flags)); +static int ConfigureArrows _ANSI_ARGS_((Tk_Canvas canvas, + LineItem *linePtr)); +static int CreateLine _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, struct Tk_Item *itemPtr, + int argc, char **argv)); +static void DeleteLine _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, Display *display)); +static void DisplayLine _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, Display *display, Drawable dst, + int x, int y, int width, int height)); +static int LineCoords _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, + int argc, char **argv)); +static int LineToArea _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double *rectPtr)); +static double LineToPoint _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double *coordPtr)); +static int LineToPostscript _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int prepass)); +static int ParseArrowShape _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, Tk_Window tkwin, char *value, + char *recordPtr, int offset)); +static char * PrintArrowShape _ANSI_ARGS_((ClientData clientData, + Tk_Window tkwin, char *recordPtr, int offset, + Tcl_FreeProc **freeProcPtr)); +static void ScaleLine _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double originX, double originY, + double scaleX, double scaleY)); +static void TranslateLine _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double deltaX, double deltaY)); + +/* + * Information used for parsing configuration specs. If you change any + * of the default strings, be sure to change the corresponding default + * values in CreateLine. + */ + +static Tk_CustomOption arrowShapeOption = {ParseArrowShape, + PrintArrowShape, (ClientData) NULL}; +static Tk_CustomOption tagsOption = {Tk_CanvasTagsParseProc, + Tk_CanvasTagsPrintProc, (ClientData) NULL +}; + +static Tk_ConfigSpec configSpecs[] = { + {TK_CONFIG_UID, "-arrow", (char *) NULL, (char *) NULL, + "none", Tk_Offset(LineItem, arrow), TK_CONFIG_DONT_SET_DEFAULT}, + {TK_CONFIG_CUSTOM, "-arrowshape", (char *) NULL, (char *) NULL, + "8 10 3", Tk_Offset(LineItem, arrowShapeA), + TK_CONFIG_DONT_SET_DEFAULT, &arrowShapeOption}, + {TK_CONFIG_CAP_STYLE, "-capstyle", (char *) NULL, (char *) NULL, + "butt", Tk_Offset(LineItem, capStyle), TK_CONFIG_DONT_SET_DEFAULT}, + {TK_CONFIG_COLOR, "-fill", (char *) NULL, (char *) NULL, + "black", Tk_Offset(LineItem, fg), TK_CONFIG_NULL_OK}, + {TK_CONFIG_JOIN_STYLE, "-joinstyle", (char *) NULL, (char *) NULL, + "round", Tk_Offset(LineItem, joinStyle), TK_CONFIG_DONT_SET_DEFAULT}, + {TK_CONFIG_BOOLEAN, "-smooth", (char *) NULL, (char *) NULL, + "0", Tk_Offset(LineItem, smooth), TK_CONFIG_DONT_SET_DEFAULT}, + {TK_CONFIG_INT, "-splinesteps", (char *) NULL, (char *) NULL, + "12", Tk_Offset(LineItem, splineSteps), TK_CONFIG_DONT_SET_DEFAULT}, + {TK_CONFIG_BITMAP, "-stipple", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(LineItem, fillStipple), TK_CONFIG_NULL_OK}, + {TK_CONFIG_CUSTOM, "-tags", (char *) NULL, (char *) NULL, + (char *) NULL, 0, TK_CONFIG_NULL_OK, &tagsOption}, + {TK_CONFIG_PIXELS, "-width", (char *) NULL, (char *) NULL, + "1", Tk_Offset(LineItem, width), TK_CONFIG_DONT_SET_DEFAULT}, + {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, 0} +}; + +/* + * The structures below defines the line item type by means + * of procedures that can be invoked by generic item code. + */ + +Tk_ItemType tkLineType = { + "line", /* name */ + sizeof(LineItem), /* itemSize */ + CreateLine, /* createProc */ + configSpecs, /* configSpecs */ + ConfigureLine, /* configureProc */ + LineCoords, /* coordProc */ + DeleteLine, /* deleteProc */ + DisplayLine, /* displayProc */ + 0, /* alwaysRedraw */ + LineToPoint, /* pointProc */ + LineToArea, /* areaProc */ + LineToPostscript, /* postscriptProc */ + ScaleLine, /* scaleProc */ + TranslateLine, /* translateProc */ + (Tk_ItemIndexProc *) NULL, /* indexProc */ + (Tk_ItemCursorProc *) NULL, /* icursorProc */ + (Tk_ItemSelectionProc *) NULL, /* selectionProc */ + (Tk_ItemInsertProc *) NULL, /* insertProc */ + (Tk_ItemDCharsProc *) NULL, /* dTextProc */ + (Tk_ItemType *) NULL /* nextPtr */ +}; + +/* + * The Tk_Uid's below refer to uids for the various arrow types: + */ + +static Tk_Uid noneUid = NULL; +static Tk_Uid firstUid = NULL; +static Tk_Uid lastUid = NULL; +static Tk_Uid bothUid = NULL; + +/* + * The definition below determines how large are static arrays + * used to hold spline points (splines larger than this have to + * have their arrays malloc-ed). + */ + +#define MAX_STATIC_POINTS 200 + +/* + *-------------------------------------------------------------- + * + * CreateLine -- + * + * This procedure is invoked to create a new line item in + * a canvas. + * + * 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, + * so it can be safely freed by the caller. + * + * Side effects: + * A new line item is created. + * + *-------------------------------------------------------------- + */ + +static int +CreateLine(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 line. */ +{ + LineItem *linePtr = (LineItem *) itemPtr; + int i; + + if (argc < 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + Tk_PathName(Tk_CanvasTkwin(canvas)), " create ", + itemPtr->typePtr->name, " x1 y1 x2 y2 ?x3 y3 ...? ?options?\"", + (char *) NULL); + return TCL_ERROR; + } + + /* + * Carry out initialization that is needed to set defaults and to + * allow proper cleanup after errors during the the remainder of + * this procedure. + */ + + linePtr->canvas = canvas; + linePtr->numPoints = 0; + linePtr->coordPtr = NULL; + linePtr->width = 1; + linePtr->fg = None; + linePtr->fillStipple = None; + linePtr->capStyle = CapButt; + linePtr->joinStyle = JoinRound; + linePtr->gc = None; + linePtr->arrowGC = None; + if (noneUid == NULL) { + noneUid = Tk_GetUid("none"); + firstUid = Tk_GetUid("first"); + lastUid = Tk_GetUid("last"); + bothUid = Tk_GetUid("both"); + } + linePtr->arrow = noneUid; + linePtr->arrowShapeA = (float)8.0; + linePtr->arrowShapeB = (float)10.0; + linePtr->arrowShapeC = (float)3.0; + linePtr->firstArrowPtr = NULL; + linePtr->lastArrowPtr = NULL; + linePtr->smooth = 0; + linePtr->splineSteps = 12; + + /* + * Count the number of points and then parse them into a point + * array. Leading arguments are assumed to be points if they + * start with a digit or a minus sign followed by a digit. + */ + + for (i = 4; i < (argc-1); i+=2) { + if ((!isdigit(UCHAR(argv[i][0]))) && + ((argv[i][0] != '-') + || ((argv[i][1] != '.') && !isdigit(UCHAR(argv[i][1]))))) { + break; + } + } + if (LineCoords(interp, canvas, itemPtr, i, argv) != TCL_OK) { + goto error; + } + if (ConfigureLine(interp, canvas, itemPtr, argc-i, argv+i, 0) == TCL_OK) { + return TCL_OK; + } + + error: + DeleteLine(canvas, itemPtr, Tk_Display(Tk_CanvasTkwin(canvas))); + return TCL_ERROR; +} + +/* + *-------------------------------------------------------------- + * + * LineCoords -- + * + * This procedure is invoked to process the "coords" widget + * command on lines. See the user documentation for details + * on what it does. + * + * Results: + * Returns TCL_OK or TCL_ERROR, and sets interp->result. + * + * Side effects: + * The coordinates for the given item may be changed. + * + *-------------------------------------------------------------- + */ + +static int +LineCoords(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, ... */ +{ + LineItem *linePtr = (LineItem *) itemPtr; + char buffer[TCL_DOUBLE_SPACE]; + int i, numPoints; + + if (argc == 0) { + double *coordPtr; + int numCoords; + + numCoords = 2*linePtr->numPoints; + if (linePtr->firstArrowPtr != NULL) { + coordPtr = linePtr->firstArrowPtr; + } else { + coordPtr = linePtr->coordPtr; + } + for (i = 0; i < numCoords; i++, coordPtr++) { + if (i == 2) { + coordPtr = linePtr->coordPtr+2; + } + if ((linePtr->lastArrowPtr != NULL) && (i == (numCoords-2))) { + coordPtr = linePtr->lastArrowPtr; + } + Tcl_PrintDouble(interp, *coordPtr, buffer); + Tcl_AppendElement(interp, buffer); + } + } else if (argc < 4) { + Tcl_AppendResult(interp, + "too few coordinates for line: must have at least 4", + (char *) NULL); + return TCL_ERROR; + } else if (argc & 1) { + Tcl_AppendResult(interp, + "odd number of coordinates specified for line", + (char *) NULL); + return TCL_ERROR; + } else { + numPoints = argc/2; + if (linePtr->numPoints != numPoints) { + if (linePtr->coordPtr != NULL) { + ckfree((char *) linePtr->coordPtr); + } + linePtr->coordPtr = (double *) ckalloc((unsigned) + (sizeof(double) * argc)); + linePtr->numPoints = numPoints; + } + for (i = argc-1; i >= 0; i--) { + if (Tk_CanvasGetCoord(interp, canvas, argv[i], + &linePtr->coordPtr[i]) != TCL_OK) { + return TCL_ERROR; + } + } + + /* + * Update arrowheads by throwing away any existing arrow-head + * information and calling ConfigureArrows to recompute it. + */ + + if (linePtr->firstArrowPtr != NULL) { + ckfree((char *) linePtr->firstArrowPtr); + linePtr->firstArrowPtr = NULL; + } + if (linePtr->lastArrowPtr != NULL) { + ckfree((char *) linePtr->lastArrowPtr); + linePtr->lastArrowPtr = NULL; + } + if (linePtr->arrow != noneUid) { + ConfigureArrows(canvas, linePtr); + } + ComputeLineBbox(canvas, linePtr); + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * ConfigureLine -- + * + * This procedure is invoked to configure various aspects + * of a line item such as its background color. + * + * Results: + * A standard Tcl result code. If an error occurs, then + * an error message is left in interp->result. + * + * Side effects: + * Configuration information, such as colors and stipple + * patterns, may be set for itemPtr. + * + *-------------------------------------------------------------- + */ + +static int +ConfigureLine(interp, canvas, itemPtr, argc, argv, flags) + Tcl_Interp *interp; /* Used for error reporting. */ + Tk_Canvas canvas; /* Canvas containing itemPtr. */ + Tk_Item *itemPtr; /* Line item to reconfigure. */ + int argc; /* Number of elements in argv. */ + char **argv; /* Arguments describing things to configure. */ + int flags; /* Flags to pass to Tk_ConfigureWidget. */ +{ + LineItem *linePtr = (LineItem *) itemPtr; + XGCValues gcValues; + GC newGC, arrowGC; + unsigned long mask; + Tk_Window tkwin; + + tkwin = Tk_CanvasTkwin(canvas); + if (Tk_ConfigureWidget(interp, tkwin, configSpecs, argc, argv, + (char *) linePtr, flags) != TCL_OK) { + return TCL_ERROR; + } + + /* + * A few of the options require additional processing, such as + * graphics contexts. + */ + + if (linePtr->fg == NULL) { + newGC = arrowGC = None; + } else { + gcValues.foreground = linePtr->fg->pixel; + gcValues.join_style = linePtr->joinStyle; + if (linePtr->width < 0) { + linePtr->width = 1; + } + gcValues.line_width = linePtr->width; + mask = GCForeground|GCJoinStyle|GCLineWidth; + if (linePtr->fillStipple != None) { + gcValues.stipple = linePtr->fillStipple; + gcValues.fill_style = FillStippled; + mask |= GCStipple|GCFillStyle; + } + if (linePtr->arrow == noneUid) { + gcValues.cap_style = linePtr->capStyle; + mask |= GCCapStyle; + } + newGC = Tk_GetGC(tkwin, mask, &gcValues); + gcValues.line_width = 0; + arrowGC = Tk_GetGC(tkwin, mask, &gcValues); + } + if (linePtr->gc != None) { + Tk_FreeGC(Tk_Display(tkwin), linePtr->gc); + } + if (linePtr->arrowGC != None) { + Tk_FreeGC(Tk_Display(tkwin), linePtr->arrowGC); + } + linePtr->gc = newGC; + linePtr->arrowGC = arrowGC; + + /* + * Keep spline parameters within reasonable limits. + */ + + if (linePtr->splineSteps < 1) { + linePtr->splineSteps = 1; + } else if (linePtr->splineSteps > 100) { + linePtr->splineSteps = 100; + } + + /* + * Setup arrowheads, if needed. If arrowheads are turned off, + * restore the line's endpoints (they were shortened when the + * arrowheads were added). + */ + + if ((linePtr->firstArrowPtr != NULL) && (linePtr->arrow != firstUid) + && (linePtr->arrow != bothUid)) { + linePtr->coordPtr[0] = linePtr->firstArrowPtr[0]; + linePtr->coordPtr[1] = linePtr->firstArrowPtr[1]; + ckfree((char *) linePtr->firstArrowPtr); + linePtr->firstArrowPtr = NULL; + } + if ((linePtr->lastArrowPtr != NULL) && (linePtr->arrow != lastUid) + && (linePtr->arrow != bothUid)) { + int i; + + i = 2*(linePtr->numPoints-1); + linePtr->coordPtr[i] = linePtr->lastArrowPtr[0]; + linePtr->coordPtr[i+1] = linePtr->lastArrowPtr[1]; + ckfree((char *) linePtr->lastArrowPtr); + linePtr->lastArrowPtr = NULL; + } + if (linePtr->arrow != noneUid) { + if ((linePtr->arrow != firstUid) && (linePtr->arrow != lastUid) + && (linePtr->arrow != bothUid)) { + Tcl_AppendResult(interp, "bad arrow spec \"", + linePtr->arrow, "\": must be none, first, last, or both", + (char *) NULL); + linePtr->arrow = noneUid; + return TCL_ERROR; + } + ConfigureArrows(canvas, linePtr); + } + + /* + * Recompute bounding box for line. + */ + + ComputeLineBbox(canvas, linePtr); + + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * DeleteLine -- + * + * This procedure is called to clean up the data structure + * associated with a line item. + * + * Results: + * None. + * + * Side effects: + * Resources associated with itemPtr are released. + * + *-------------------------------------------------------------- + */ + +static void +DeleteLine(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. */ +{ + LineItem *linePtr = (LineItem *) itemPtr; + + if (linePtr->coordPtr != NULL) { + ckfree((char *) linePtr->coordPtr); + } + if (linePtr->fg != NULL) { + Tk_FreeColor(linePtr->fg); + } + if (linePtr->fillStipple != None) { + Tk_FreeBitmap(display, linePtr->fillStipple); + } + if (linePtr->gc != None) { + Tk_FreeGC(display, linePtr->gc); + } + if (linePtr->arrowGC != None) { + Tk_FreeGC(display, linePtr->arrowGC); + } + if (linePtr->firstArrowPtr != NULL) { + ckfree((char *) linePtr->firstArrowPtr); + } + if (linePtr->lastArrowPtr != NULL) { + ckfree((char *) linePtr->lastArrowPtr); + } +} + +/* + *-------------------------------------------------------------- + * + * ComputeLineBbox -- + * + * This procedure is invoked to compute the bounding box of + * all the pixels that may be drawn as part of a line. + * + * Results: + * None. + * + * Side effects: + * The fields x1, y1, x2, and y2 are updated in the header + * for itemPtr. + * + *-------------------------------------------------------------- + */ + +static void +ComputeLineBbox(canvas, linePtr) + Tk_Canvas canvas; /* Canvas that contains item. */ + LineItem *linePtr; /* Item whose bbos is to be + * recomputed. */ +{ + double *coordPtr; + int i, width; + + coordPtr = linePtr->coordPtr; + linePtr->header.x1 = linePtr->header.x2 = (int) *coordPtr; + linePtr->header.y1 = linePtr->header.y2 = (int) coordPtr[1]; + + /* + * Compute the bounding box of all the points in the line, + * then expand in all directions by the line's width to take + * care of butting or rounded corners and projecting or + * rounded caps. This expansion is an overestimate (worst-case + * is square root of two over two) but it's simple. Don't do + * anything special for curves. This causes an additional + * overestimate in the bounding box, but is faster. + */ + + for (i = 1, coordPtr = linePtr->coordPtr+2; i < linePtr->numPoints; + i++, coordPtr += 2) { + TkIncludePoint((Tk_Item *) linePtr, coordPtr); + } + width = linePtr->width; + if (width < 1) { + width = 1; + } + linePtr->header.x1 -= width; + linePtr->header.x2 += width; + linePtr->header.y1 -= width; + linePtr->header.y2 += width; + + /* + * For mitered lines, make a second pass through all the points. + * Compute the locations of the two miter vertex points and add + * those into the bounding box. + */ + + if (linePtr->joinStyle == JoinMiter) { + for (i = linePtr->numPoints, coordPtr = linePtr->coordPtr; i >= 3; + i--, coordPtr += 2) { + double miter[4]; + int j; + + if (TkGetMiterPoints(coordPtr, coordPtr+2, coordPtr+4, + (double) width, miter, miter+2)) { + for (j = 0; j < 4; j += 2) { + TkIncludePoint((Tk_Item *) linePtr, miter+j); + } + } + } + } + + /* + * Add in the sizes of arrowheads, if any. + */ + + if (linePtr->arrow != noneUid) { + if (linePtr->arrow != lastUid) { + for (i = 0, coordPtr = linePtr->firstArrowPtr; i < PTS_IN_ARROW; + i++, coordPtr += 2) { + TkIncludePoint((Tk_Item *) linePtr, coordPtr); + } + } + if (linePtr->arrow != firstUid) { + for (i = 0, coordPtr = linePtr->lastArrowPtr; i < PTS_IN_ARROW; + i++, coordPtr += 2) { + TkIncludePoint((Tk_Item *) linePtr, coordPtr); + } + } + } + + /* + * Add one more pixel of fudge factor just to be safe (e.g. + * X may round differently than we do). + */ + + linePtr->header.x1 -= 1; + linePtr->header.x2 += 1; + linePtr->header.y1 -= 1; + linePtr->header.y2 += 1; +} + +/* + *-------------------------------------------------------------- + * + * DisplayLine -- + * + * This procedure is invoked to draw a line item in a given + * drawable. + * + * Results: + * None. + * + * Side effects: + * ItemPtr is drawn in drawable using the transformation + * information in canvas. + * + *-------------------------------------------------------------- + */ + +static void +DisplayLine(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). */ +{ + LineItem *linePtr = (LineItem *) itemPtr; + XPoint staticPoints[MAX_STATIC_POINTS]; + XPoint *pointPtr; + XPoint *pPtr; + double *coordPtr; + int i, numPoints; + + if (linePtr->gc == None) { + return; + } + + /* + * Build up an array of points in screen coordinates. Use a + * static array unless the line has an enormous number of points; + * in this case, dynamically allocate an array. For smoothed lines, + * generate the curve points on each redisplay. + */ + + if ((linePtr->smooth) && (linePtr->numPoints > 2)) { + numPoints = 1 + linePtr->numPoints*linePtr->splineSteps; + } else { + numPoints = linePtr->numPoints; + } + + if (numPoints <= MAX_STATIC_POINTS) { + pointPtr = staticPoints; + } else { + pointPtr = (XPoint *) ckalloc((unsigned) (numPoints * sizeof(XPoint))); + } + + if ((linePtr->smooth) && (linePtr->numPoints > 2)) { + numPoints = TkMakeBezierCurve(canvas, linePtr->coordPtr, + linePtr->numPoints, linePtr->splineSteps, pointPtr, + (double *) NULL); + } else { + for (i = 0, coordPtr = linePtr->coordPtr, pPtr = pointPtr; + i < linePtr->numPoints; i += 1, coordPtr += 2, pPtr++) { + Tk_CanvasDrawableCoords(canvas, coordPtr[0], coordPtr[1], + &pPtr->x, &pPtr->y); + } + } + + /* + * Display line, the free up line storage if it was dynamically + * allocated. If we're stippling, then modify the stipple offset + * in the GC. Be sure to reset the offset when done, since the + * GC is supposed to be read-only. + */ + + if (linePtr->fillStipple != None) { + Tk_CanvasSetStippleOrigin(canvas, linePtr->gc); + Tk_CanvasSetStippleOrigin(canvas, linePtr->arrowGC); + } + XDrawLines(display, drawable, linePtr->gc, pointPtr, numPoints, + CoordModeOrigin); + if (pointPtr != staticPoints) { + ckfree((char *) pointPtr); + } + + /* + * Display arrowheads, if they are wanted. + */ + + if (linePtr->firstArrowPtr != NULL) { + TkFillPolygon(canvas, linePtr->firstArrowPtr, PTS_IN_ARROW, + display, drawable, linePtr->gc, NULL); + } + if (linePtr->lastArrowPtr != NULL) { + TkFillPolygon(canvas, linePtr->lastArrowPtr, PTS_IN_ARROW, + display, drawable, linePtr->gc, NULL); + } + if (linePtr->fillStipple != None) { + XSetTSOrigin(display, linePtr->gc, 0, 0); + XSetTSOrigin(display, linePtr->arrowGC, 0, 0); + } +} + +/* + *-------------------------------------------------------------- + * + * LineToPoint -- + * + * Computes the distance from a given point to a given + * line, in canvas units. + * + * Results: + * The return value is 0 if the point whose x and y coordinates + * are pointPtr[0] and pointPtr[1] is inside the line. If the + * point isn't inside the line then the return value is the + * distance from the point to the line. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static double +LineToPoint(canvas, itemPtr, pointPtr) + Tk_Canvas canvas; /* Canvas containing item. */ + Tk_Item *itemPtr; /* Item to check against point. */ + double *pointPtr; /* Pointer to x and y coordinates. */ +{ + LineItem *linePtr = (LineItem *) itemPtr; + double *coordPtr, *linePoints; + double staticSpace[2*MAX_STATIC_POINTS]; + double poly[10]; + double bestDist, dist; + int numPoints, count; + int changedMiterToBevel; /* Non-zero means that a mitered corner + * had to be treated as beveled after all + * because the angle was < 11 degrees. */ + + bestDist = 1.0e36; + + /* + * Handle smoothed lines by generating an expanded set of points + * against which to do the check. + */ + + if ((linePtr->smooth) && (linePtr->numPoints > 2)) { + numPoints = 1 + linePtr->numPoints*linePtr->splineSteps; + if (numPoints <= MAX_STATIC_POINTS) { + linePoints = staticSpace; + } else { + linePoints = (double *) ckalloc((unsigned) + (2*numPoints*sizeof(double))); + } + numPoints = TkMakeBezierCurve(canvas, linePtr->coordPtr, + linePtr->numPoints, linePtr->splineSteps, (XPoint *) NULL, + linePoints); + } else { + numPoints = linePtr->numPoints; + linePoints = linePtr->coordPtr; + } + + /* + * The overall idea is to iterate through all of the edges of + * the line, computing a polygon for each edge and testing the + * point against that polygon. In addition, there are additional + * tests to deal with rounded joints and caps. + */ + + changedMiterToBevel = 0; + for (count = numPoints, coordPtr = linePoints; count >= 2; + count--, coordPtr += 2) { + + /* + * If rounding is done around the first point then compute + * the distance between the point and the point. + */ + + if (((linePtr->capStyle == CapRound) && (count == numPoints)) + || ((linePtr->joinStyle == JoinRound) + && (count != numPoints))) { + dist = hypot(coordPtr[0] - pointPtr[0], coordPtr[1] - pointPtr[1]) + - linePtr->width/2.0; + if (dist <= 0.0) { + bestDist = 0.0; + goto done; + } else if (dist < bestDist) { + bestDist = dist; + } + } + + /* + * Compute the polygonal shape corresponding to this edge, + * consisting of two points for the first point of the edge + * and two points for the last point of the edge. + */ + + if (count == numPoints) { + TkGetButtPoints(coordPtr+2, coordPtr, (double) linePtr->width, + linePtr->capStyle == CapProjecting, poly, poly+2); + } else if ((linePtr->joinStyle == JoinMiter) && !changedMiterToBevel) { + poly[0] = poly[6]; + poly[1] = poly[7]; + poly[2] = poly[4]; + poly[3] = poly[5]; + } else { + TkGetButtPoints(coordPtr+2, coordPtr, (double) linePtr->width, 0, + poly, poly+2); + + /* + * If this line uses beveled joints, then check the distance + * to a polygon comprising the last two points of the previous + * polygon and the first two from this polygon; this checks + * the wedges that fill the mitered joint. + */ + + if ((linePtr->joinStyle == JoinBevel) || changedMiterToBevel) { + poly[8] = poly[0]; + poly[9] = poly[1]; + dist = TkPolygonToPoint(poly, 5, pointPtr); + if (dist <= 0.0) { + bestDist = 0.0; + goto done; + } else if (dist < bestDist) { + bestDist = dist; + } + changedMiterToBevel = 0; + } + } + if (count == 2) { + TkGetButtPoints(coordPtr, coordPtr+2, (double) linePtr->width, + linePtr->capStyle == CapProjecting, poly+4, poly+6); + } else if (linePtr->joinStyle == JoinMiter) { + if (TkGetMiterPoints(coordPtr, coordPtr+2, coordPtr+4, + (double) linePtr->width, poly+4, poly+6) == 0) { + changedMiterToBevel = 1; + TkGetButtPoints(coordPtr, coordPtr+2, (double) linePtr->width, + 0, poly+4, poly+6); + } + } else { + TkGetButtPoints(coordPtr, coordPtr+2, (double) linePtr->width, 0, + poly+4, poly+6); + } + poly[8] = poly[0]; + poly[9] = poly[1]; + dist = TkPolygonToPoint(poly, 5, pointPtr); + if (dist <= 0.0) { + bestDist = 0.0; + goto done; + } else if (dist < bestDist) { + bestDist = dist; + } + } + + /* + * If caps are rounded, check the distance to the cap around the + * final end point of the line. + */ + + if (linePtr->capStyle == CapRound) { + dist = hypot(coordPtr[0] - pointPtr[0], coordPtr[1] - pointPtr[1]) + - linePtr->width/2.0; + if (dist <= 0.0) { + bestDist = 0.0; + goto done; + } else if (dist < bestDist) { + bestDist = dist; + } + } + + /* + * If there are arrowheads, check the distance to the arrowheads. + */ + + if (linePtr->arrow != noneUid) { + if (linePtr->arrow != lastUid) { + dist = TkPolygonToPoint(linePtr->firstArrowPtr, PTS_IN_ARROW, + pointPtr); + if (dist <= 0.0) { + bestDist = 0.0; + goto done; + } else if (dist < bestDist) { + bestDist = dist; + } + } + if (linePtr->arrow != firstUid) { + dist = TkPolygonToPoint(linePtr->lastArrowPtr, PTS_IN_ARROW, + pointPtr); + if (dist <= 0.0) { + bestDist = 0.0; + goto done; + } else if (dist < bestDist) { + bestDist = dist; + } + } + } + + done: + if ((linePoints != staticSpace) && (linePoints != linePtr->coordPtr)) { + ckfree((char *) linePoints); + } + return bestDist; +} + +/* + *-------------------------------------------------------------- + * + * LineToArea -- + * + * This procedure is called to determine whether an item + * lies entirely inside, entirely outside, or overlapping + * a given rectangular area. + * + * Results: + * -1 is returned if the item is entirely outside the + * area, 0 if it overlaps, and 1 if it is entirely + * inside the given area. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +LineToArea(canvas, itemPtr, rectPtr) + Tk_Canvas canvas; /* Canvas containing item. */ + Tk_Item *itemPtr; /* Item to check against line. */ + double *rectPtr; +{ + LineItem *linePtr = (LineItem *) itemPtr; + double staticSpace[2*MAX_STATIC_POINTS]; + double *linePoints; + int numPoints, result; + + /* + * Handle smoothed lines by generating an expanded set of points + * against which to do the check. + */ + + if ((linePtr->smooth) && (linePtr->numPoints > 2)) { + numPoints = 1 + linePtr->numPoints*linePtr->splineSteps; + if (numPoints <= MAX_STATIC_POINTS) { + linePoints = staticSpace; + } else { + linePoints = (double *) ckalloc((unsigned) + (2*numPoints*sizeof(double))); + } + numPoints = TkMakeBezierCurve(canvas, linePtr->coordPtr, + linePtr->numPoints, linePtr->splineSteps, (XPoint *) NULL, + linePoints); + } else { + numPoints = linePtr->numPoints; + linePoints = linePtr->coordPtr; + } + + /* + * Check the segments of the line. + */ + + result = TkThickPolyLineToArea(linePoints, numPoints, + (double) linePtr->width, linePtr->capStyle, linePtr->joinStyle, + rectPtr); + if (result == 0) { + goto done; + } + + /* + * Check arrowheads, if any. + */ + + if (linePtr->arrow != noneUid) { + if (linePtr->arrow != lastUid) { + if (TkPolygonToArea(linePtr->firstArrowPtr, PTS_IN_ARROW, + rectPtr) != result) { + result = 0; + goto done; + } + } + if (linePtr->arrow != firstUid) { + if (TkPolygonToArea(linePtr->lastArrowPtr, PTS_IN_ARROW, + rectPtr) != result) { + result = 0; + goto done; + } + } + } + + done: + if ((linePoints != staticSpace) && (linePoints != linePtr->coordPtr)) { + ckfree((char *) linePoints); + } + return result; +} + +/* + *-------------------------------------------------------------- + * + * ScaleLine -- + * + * This procedure is invoked to rescale a line item. + * + * Results: + * None. + * + * Side effects: + * The line referred to by itemPtr is rescaled so that the + * following transformation is applied to all point + * coordinates: + * x' = originX + scaleX*(x-originX) + * y' = originY + scaleY*(y-originY) + * + *-------------------------------------------------------------- + */ + +static void +ScaleLine(canvas, itemPtr, originX, originY, scaleX, scaleY) + Tk_Canvas canvas; /* Canvas containing line. */ + Tk_Item *itemPtr; /* Line 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. */ +{ + LineItem *linePtr = (LineItem *) itemPtr; + double *coordPtr; + int i; + + /* + * Delete any arrowheads before scaling all the points (so that + * the end-points of the line get restored). + */ + + if (linePtr->firstArrowPtr != NULL) { + linePtr->coordPtr[0] = linePtr->firstArrowPtr[0]; + linePtr->coordPtr[1] = linePtr->firstArrowPtr[1]; + ckfree((char *) linePtr->firstArrowPtr); + linePtr->firstArrowPtr = NULL; + } + if (linePtr->lastArrowPtr != NULL) { + int i; + + i = 2*(linePtr->numPoints-1); + linePtr->coordPtr[i] = linePtr->lastArrowPtr[0]; + linePtr->coordPtr[i+1] = linePtr->lastArrowPtr[1]; + ckfree((char *) linePtr->lastArrowPtr); + linePtr->lastArrowPtr = NULL; + } + for (i = 0, coordPtr = linePtr->coordPtr; i < linePtr->numPoints; + i++, coordPtr += 2) { + coordPtr[0] = originX + scaleX*(*coordPtr - originX); + coordPtr[1] = originY + scaleY*(coordPtr[1] - originY); + } + if (linePtr->arrow != noneUid) { + ConfigureArrows(canvas, linePtr); + } + ComputeLineBbox(canvas, linePtr); +} + +/* + *-------------------------------------------------------------- + * + * TranslateLine -- + * + * This procedure is called to move a line by a given amount. + * + * Results: + * None. + * + * Side effects: + * The position of the line is offset by (xDelta, yDelta), and + * the bounding box is updated in the generic part of the item + * structure. + * + *-------------------------------------------------------------- + */ + +static void +TranslateLine(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. */ +{ + LineItem *linePtr = (LineItem *) itemPtr; + double *coordPtr; + int i; + + for (i = 0, coordPtr = linePtr->coordPtr; i < linePtr->numPoints; + i++, coordPtr += 2) { + coordPtr[0] += deltaX; + coordPtr[1] += deltaY; + } + if (linePtr->firstArrowPtr != NULL) { + for (i = 0, coordPtr = linePtr->firstArrowPtr; i < PTS_IN_ARROW; + i++, coordPtr += 2) { + coordPtr[0] += deltaX; + coordPtr[1] += deltaY; + } + } + if (linePtr->lastArrowPtr != NULL) { + for (i = 0, coordPtr = linePtr->lastArrowPtr; i < PTS_IN_ARROW; + i++, coordPtr += 2) { + coordPtr[0] += deltaX; + coordPtr[1] += deltaY; + } + } + ComputeLineBbox(canvas, linePtr); +} + +/* + *-------------------------------------------------------------- + * + * ParseArrowShape -- + * + * This procedure is called back during option parsing to + * parse arrow shape information. + * + * Results: + * The return value is a standard Tcl result: TCL_OK means + * that the arrow shape information was parsed ok, and + * TCL_ERROR means it couldn't be parsed. + * + * Side effects: + * Arrow information in recordPtr is updated. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +ParseArrowShape(clientData, interp, tkwin, value, recordPtr, offset) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Used for error reporting. */ + Tk_Window tkwin; /* Not used. */ + char *value; /* Textual specification of arrow shape. */ + char *recordPtr; /* Pointer to item record in which to + * store arrow information. */ + int offset; /* Offset of shape information in widget + * record. */ +{ + LineItem *linePtr = (LineItem *) recordPtr; + double a, b, c; + int argc; + char **argv = NULL; + + if (offset != Tk_Offset(LineItem, arrowShapeA)) { + panic("ParseArrowShape received bogus offset"); + } + + if (Tcl_SplitList(interp, value, &argc, &argv) != TCL_OK) { + syntaxError: + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad arrow shape \"", value, + "\": must be list with three numbers", (char *) NULL); + if (argv != NULL) { + ckfree((char *) argv); + } + return TCL_ERROR; + } + if (argc != 3) { + goto syntaxError; + } + if ((Tk_CanvasGetCoord(interp, linePtr->canvas, argv[0], &a) != TCL_OK) + || (Tk_CanvasGetCoord(interp, linePtr->canvas, argv[1], &b) + != TCL_OK) + || (Tk_CanvasGetCoord(interp, linePtr->canvas, argv[2], &c) + != TCL_OK)) { + goto syntaxError; + } + linePtr->arrowShapeA = (float)a; + linePtr->arrowShapeB = (float)b; + linePtr->arrowShapeC = (float)c; + ckfree((char *) argv); + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * PrintArrowShape -- + * + * This procedure is a callback invoked by the configuration + * code to return a printable value describing an arrow shape. + * + * Results: + * None. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static char * +PrintArrowShape(clientData, tkwin, recordPtr, offset, freeProcPtr) + ClientData clientData; /* Not used. */ + Tk_Window tkwin; /* Window associated with linePtr's widget. */ + char *recordPtr; /* Pointer to item record containing current + * shape information. */ + int offset; /* Offset of arrow information in record. */ + Tcl_FreeProc **freeProcPtr; /* Store address of procedure to call to + * free string here. */ +{ + LineItem *linePtr = (LineItem *) recordPtr; + char *buffer; + + buffer = (char *) ckalloc(120); + sprintf(buffer, "%.5g %.5g %.5g", linePtr->arrowShapeA, + linePtr->arrowShapeB, linePtr->arrowShapeC); + *freeProcPtr = TCL_DYNAMIC; + return buffer; +} + +/* + *-------------------------------------------------------------- + * + * ConfigureArrows -- + * + * If arrowheads have been requested for a line, this + * procedure makes arrangements for the arrowheads. + * + * Results: + * Always returns TCL_OK. + * + * Side effects: + * Information in linePtr is set up for one or two arrowheads. + * the firstArrowPtr and lastArrowPtr polygons are allocated + * and initialized, if need be, and the end points of the line + * are adjusted so that a thick line doesn't stick out past + * the arrowheads. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +ConfigureArrows(canvas, linePtr) + Tk_Canvas canvas; /* Canvas in which arrows will be + * displayed (interp and tkwin + * fields are needed). */ + LineItem *linePtr; /* Item to configure for arrows. */ +{ + double *poly, *coordPtr; + double dx, dy, length, sinTheta, cosTheta, temp; + double fracHeight; /* Line width as fraction of + * arrowhead width. */ + double backup; /* Distance to backup end points + * so the line ends in the middle + * of the arrowhead. */ + double vertX, vertY; /* Position of arrowhead vertex. */ + double shapeA, shapeB, shapeC; /* Adjusted coordinates (see + * explanation below). */ + + /* + * The code below makes a tiny increase in the shape parameters + * for the line. This is a bit of a hack, but it seems to result + * in displays that more closely approximate the specified parameters. + * Without the adjustment, the arrows come out smaller than expected. + */ + + shapeA = linePtr->arrowShapeA + 0.001; + shapeB = linePtr->arrowShapeB + 0.001; + shapeC = linePtr->arrowShapeC + linePtr->width/2.0 + 0.001; + + /* + * If there's an arrowhead on the first point of the line, compute + * its polygon and adjust the first point of the line so that the + * line doesn't stick out past the leading edge of the arrowhead. + */ + + fracHeight = (linePtr->width/2.0)/shapeC; + backup = fracHeight*shapeB + shapeA*(1.0 - fracHeight)/2.0; + if (linePtr->arrow != lastUid) { + poly = linePtr->firstArrowPtr; + if (poly == NULL) { + poly = (double *) ckalloc((unsigned) + (2*PTS_IN_ARROW*sizeof(double))); + poly[0] = poly[10] = linePtr->coordPtr[0]; + poly[1] = poly[11] = linePtr->coordPtr[1]; + linePtr->firstArrowPtr = poly; + } + dx = poly[0] - linePtr->coordPtr[2]; + dy = poly[1] - linePtr->coordPtr[3]; + length = hypot(dx, dy); + if (length == 0) { + sinTheta = cosTheta = 0.0; + } else { + sinTheta = dy/length; + cosTheta = dx/length; + } + vertX = poly[0] - shapeA*cosTheta; + vertY = poly[1] - shapeA*sinTheta; + temp = shapeC*sinTheta; + poly[2] = poly[0] - shapeB*cosTheta + temp; + poly[8] = poly[2] - 2*temp; + temp = shapeC*cosTheta; + poly[3] = poly[1] - shapeB*sinTheta - temp; + poly[9] = poly[3] + 2*temp; + poly[4] = poly[2]*fracHeight + vertX*(1.0-fracHeight); + poly[5] = poly[3]*fracHeight + vertY*(1.0-fracHeight); + poly[6] = poly[8]*fracHeight + vertX*(1.0-fracHeight); + poly[7] = poly[9]*fracHeight + vertY*(1.0-fracHeight); + + /* + * Polygon done. Now move the first point towards the second so + * that the corners at the end of the line are inside the + * arrowhead. + */ + + linePtr->coordPtr[0] = poly[0] - backup*cosTheta; + linePtr->coordPtr[1] = poly[1] - backup*sinTheta; + } + + /* + * Similar arrowhead calculation for the last point of the line. + */ + + if (linePtr->arrow != firstUid) { + coordPtr = linePtr->coordPtr + 2*(linePtr->numPoints-2); + poly = linePtr->lastArrowPtr; + if (poly == NULL) { + poly = (double *) ckalloc((unsigned) + (2*PTS_IN_ARROW*sizeof(double))); + poly[0] = poly[10] = coordPtr[2]; + poly[1] = poly[11] = coordPtr[3]; + linePtr->lastArrowPtr = poly; + } + dx = poly[0] - coordPtr[0]; + dy = poly[1] - coordPtr[1]; + length = hypot(dx, dy); + if (length == 0) { + sinTheta = cosTheta = 0.0; + } else { + sinTheta = dy/length; + cosTheta = dx/length; + } + vertX = poly[0] - shapeA*cosTheta; + vertY = poly[1] - shapeA*sinTheta; + temp = shapeC*sinTheta; + poly[2] = poly[0] - shapeB*cosTheta + temp; + poly[8] = poly[2] - 2*temp; + temp = shapeC*cosTheta; + poly[3] = poly[1] - shapeB*sinTheta - temp; + poly[9] = poly[3] + 2*temp; + poly[4] = poly[2]*fracHeight + vertX*(1.0-fracHeight); + poly[5] = poly[3]*fracHeight + vertY*(1.0-fracHeight); + poly[6] = poly[8]*fracHeight + vertX*(1.0-fracHeight); + poly[7] = poly[9]*fracHeight + vertY*(1.0-fracHeight); + coordPtr[2] = poly[0] - backup*cosTheta; + coordPtr[3] = poly[1] - backup*sinTheta; + } + + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * LineToPostscript -- + * + * This procedure is called to generate Postscript for + * line items. + * + * 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. If no error occurs, then Postscript for the + * item is appended to the result. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static int +LineToPostscript(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. */ +{ + LineItem *linePtr = (LineItem *) itemPtr; + char buffer[200]; + char *style; + + if (linePtr->fg == NULL) { + return TCL_OK; + } + + /* + * Generate a path for the line's center-line (do this differently + * for straight lines and smoothed lines). + */ + + if ((!linePtr->smooth) || (linePtr->numPoints <= 2)) { + Tk_CanvasPsPath(interp, canvas, linePtr->coordPtr, linePtr->numPoints); + } else { + if (linePtr->fillStipple == None) { + TkMakeBezierPostscript(interp, canvas, linePtr->coordPtr, + linePtr->numPoints); + } else { + /* + * Special hack: Postscript printers don't appear to be able + * to turn a path drawn with "curveto"s into a clipping path + * without exceeding resource limits, so TkMakeBezierPostscript + * won't work for stippled curves. Instead, generate all of + * the intermediate points here and output them into the + * Postscript file with "lineto"s instead. + */ + + double staticPoints[2*MAX_STATIC_POINTS]; + double *pointPtr; + int numPoints; + + numPoints = 1 + linePtr->numPoints*linePtr->splineSteps; + pointPtr = staticPoints; + if (numPoints > MAX_STATIC_POINTS) { + pointPtr = (double *) ckalloc((unsigned) + (numPoints * 2 * sizeof(double))); + } + numPoints = TkMakeBezierCurve(canvas, linePtr->coordPtr, + linePtr->numPoints, linePtr->splineSteps, (XPoint *) NULL, + pointPtr); + Tk_CanvasPsPath(interp, canvas, pointPtr, numPoints); + if (pointPtr != staticPoints) { + ckfree((char *) pointPtr); + } + } + } + + /* + * Set other line-drawing parameters and stroke out the line. + */ + + sprintf(buffer, "%d setlinewidth\n", linePtr->width); + Tcl_AppendResult(interp, buffer, (char *) NULL); + style = "0 setlinecap\n"; + if (linePtr->capStyle == CapRound) { + style = "1 setlinecap\n"; + } else if (linePtr->capStyle == CapProjecting) { + style = "2 setlinecap\n"; + } + Tcl_AppendResult(interp, style, (char *) NULL); + style = "0 setlinejoin\n"; + if (linePtr->joinStyle == JoinRound) { + style = "1 setlinejoin\n"; + } else if (linePtr->joinStyle == JoinBevel) { + style = "2 setlinejoin\n"; + } + Tcl_AppendResult(interp, style, (char *) NULL); + if (Tk_CanvasPsColor(interp, canvas, linePtr->fg) != TCL_OK) { + return TCL_ERROR; + }; + if (linePtr->fillStipple != None) { + Tcl_AppendResult(interp, "StrokeClip ", (char *) NULL); + if (Tk_CanvasPsStipple(interp, canvas, linePtr->fillStipple) + != TCL_OK) { + return TCL_ERROR; + } + } else { + Tcl_AppendResult(interp, "stroke\n", (char *) NULL); + } + + /* + * Output polygons for the arrowheads, if there are any. + */ + + if (linePtr->firstArrowPtr != NULL) { + if (linePtr->fillStipple != None) { + Tcl_AppendResult(interp, "grestore gsave\n", + (char *) NULL); + } + if (ArrowheadPostscript(interp, canvas, linePtr, + linePtr->firstArrowPtr) != TCL_OK) { + return TCL_ERROR; + } + } + if (linePtr->lastArrowPtr != NULL) { + if (linePtr->fillStipple != None) { + Tcl_AppendResult(interp, "grestore gsave\n", (char *) NULL); + } + if (ArrowheadPostscript(interp, canvas, linePtr, + linePtr->lastArrowPtr) != TCL_OK) { + return TCL_ERROR; + } + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * ArrowheadPostscript -- + * + * This procedure is called to generate Postscript for + * an arrowhead for a line item. + * + * 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. If no error occurs, then Postscript for the + * arrowhead is appended to the result. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static int +ArrowheadPostscript(interp, canvas, linePtr, arrowPtr) + Tcl_Interp *interp; /* Leave Postscript or error message + * here. */ + Tk_Canvas canvas; /* Information about overall canvas. */ + LineItem *linePtr; /* Line item for which Postscript is + * being generated. */ + double *arrowPtr; /* Pointer to first of five points + * describing arrowhead polygon. */ +{ + Tk_CanvasPsPath(interp, canvas, arrowPtr, PTS_IN_ARROW); + if (linePtr->fillStipple != None) { + Tcl_AppendResult(interp, "clip ", (char *) NULL); + if (Tk_CanvasPsStipple(interp, canvas, linePtr->fillStipple) + != TCL_OK) { + return TCL_ERROR; + } + } else { + Tcl_AppendResult(interp, "fill\n", (char *) NULL); + } + return TCL_OK; +} diff --git a/generic/tkCanvPoly.c b/generic/tkCanvPoly.c new file mode 100644 index 0000000..1320438 --- /dev/null +++ b/generic/tkCanvPoly.c @@ -0,0 +1,998 @@ +/* + * tkCanvPoly.c -- + * + * This file implements polygon items for canvas widgets. + * + * Copyright (c) 1991-1994 The Regents of the University of California. + * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkCanvPoly.c 1.37 97/04/29 15:39:16 + */ + +#include +#include "tkInt.h" +#include "tkPort.h" + +/* + * The structure below defines the record for each polygon item. + */ + +typedef struct PolygonItem { + Tk_Item header; /* Generic stuff that's the same for all + * types. MUST BE FIRST IN STRUCTURE. */ + int numPoints; /* Number of points in polygon (always >= 3). + * Polygon is always closed. */ + int pointsAllocated; /* Number of points for which space is + * allocated at *coordPtr. */ + double *coordPtr; /* Pointer to malloc-ed array containing + * x- and y-coords of all points in polygon. + * X-coords are even-valued indices, y-coords + * are corresponding odd-valued indices. */ + int width; /* Width of outline. */ + XColor *outlineColor; /* Color for outline. */ + GC outlineGC; /* Graphics context for drawing outline. */ + XColor *fillColor; /* Foreground color for polygon. */ + Pixmap fillStipple; /* Stipple bitmap for filling polygon. */ + GC fillGC; /* Graphics context for filling polygon. */ + int smooth; /* Non-zero means draw shape smoothed (i.e. + * with Bezier splines). */ + int splineSteps; /* Number of steps in each spline segment. */ + int autoClosed; /* Zero means the given polygon was closed, + one means that we auto closed it. */ +} PolygonItem; + +/* + * Information used for parsing configuration specs: + */ + +static Tk_CustomOption tagsOption = {Tk_CanvasTagsParseProc, + Tk_CanvasTagsPrintProc, (ClientData) NULL +}; + +static Tk_ConfigSpec configSpecs[] = { + {TK_CONFIG_COLOR, "-fill", (char *) NULL, (char *) NULL, + "black", Tk_Offset(PolygonItem, fillColor), TK_CONFIG_NULL_OK}, + {TK_CONFIG_COLOR, "-outline", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(PolygonItem, outlineColor), TK_CONFIG_NULL_OK}, + {TK_CONFIG_BOOLEAN, "-smooth", (char *) NULL, (char *) NULL, + "0", Tk_Offset(PolygonItem, smooth), TK_CONFIG_DONT_SET_DEFAULT}, + {TK_CONFIG_INT, "-splinesteps", (char *) NULL, (char *) NULL, + "12", Tk_Offset(PolygonItem, splineSteps), TK_CONFIG_DONT_SET_DEFAULT}, + {TK_CONFIG_BITMAP, "-stipple", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(PolygonItem, fillStipple), TK_CONFIG_NULL_OK}, + {TK_CONFIG_CUSTOM, "-tags", (char *) NULL, (char *) NULL, + (char *) NULL, 0, TK_CONFIG_NULL_OK, &tagsOption}, + {TK_CONFIG_PIXELS, "-width", (char *) NULL, (char *) NULL, + "1", Tk_Offset(PolygonItem, width), TK_CONFIG_DONT_SET_DEFAULT}, + {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, 0} +}; + +/* + * Prototypes for procedures defined in this file: + */ + +static void ComputePolygonBbox _ANSI_ARGS_((Tk_Canvas canvas, + PolygonItem *polyPtr)); +static int ConfigurePolygon _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int argc, + char **argv, int flags)); +static int CreatePolygon _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, struct Tk_Item *itemPtr, + int argc, char **argv)); +static void DeletePolygon _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, Display *display)); +static void DisplayPolygon _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, Display *display, Drawable dst, + int x, int y, int width, int height)); +static int PolygonCoords _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, + int argc, char **argv)); +static int PolygonToArea _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double *rectPtr)); +static double PolygonToPoint _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double *pointPtr)); +static int PolygonToPostscript _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int prepass)); +static void ScalePolygon _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double originX, double originY, + double scaleX, double scaleY)); +static void TranslatePolygon _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double deltaX, double deltaY)); + +/* + * The structures below defines the polygon item type by means + * of procedures that can be invoked by generic item code. + */ + +Tk_ItemType tkPolygonType = { + "polygon", /* name */ + sizeof(PolygonItem), /* itemSize */ + CreatePolygon, /* createProc */ + configSpecs, /* configSpecs */ + ConfigurePolygon, /* configureProc */ + PolygonCoords, /* coordProc */ + DeletePolygon, /* deleteProc */ + DisplayPolygon, /* displayProc */ + 0, /* alwaysRedraw */ + PolygonToPoint, /* pointProc */ + PolygonToArea, /* areaProc */ + PolygonToPostscript, /* postscriptProc */ + ScalePolygon, /* scaleProc */ + TranslatePolygon, /* translateProc */ + (Tk_ItemIndexProc *) NULL, /* indexProc */ + (Tk_ItemCursorProc *) NULL, /* icursorProc */ + (Tk_ItemSelectionProc *) NULL, /* selectionProc */ + (Tk_ItemInsertProc *) NULL, /* insertProc */ + (Tk_ItemDCharsProc *) NULL, /* dTextProc */ + (Tk_ItemType *) NULL /* nextPtr */ +}; + +/* + * The definition below determines how large are static arrays + * used to hold spline points (splines larger than this have to + * have their arrays malloc-ed). + */ + +#define MAX_STATIC_POINTS 200 + +/* + *-------------------------------------------------------------- + * + * CreatePolygon -- + * + * This procedure is invoked to create a new polygon item in + * a canvas. + * + * 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, so it can be safely freed by the + * caller. + * + * Side effects: + * A new polygon item is created. + * + *-------------------------------------------------------------- + */ + +static int +CreatePolygon(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 polygon. */ +{ + PolygonItem *polyPtr = (PolygonItem *) itemPtr; + int i; + + if (argc < 6) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + Tk_PathName(Tk_CanvasTkwin(canvas)), " create ", + itemPtr->typePtr->name, + " x1 y1 x2 y2 x3 y3 ?x4 y4 ...? ?options?\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * Carry out initialization that is needed in order to clean + * up after errors during the the remainder of this procedure. + */ + + polyPtr->numPoints = 0; + polyPtr->pointsAllocated = 0; + polyPtr->coordPtr = NULL; + polyPtr->width = 1; + polyPtr->outlineColor = NULL; + polyPtr->outlineGC = None; + polyPtr->fillColor = NULL; + polyPtr->fillStipple = None; + polyPtr->fillGC = None; + polyPtr->smooth = 0; + polyPtr->splineSteps = 12; + polyPtr->autoClosed = 0; + + /* + * Count the number of points and then parse them into a point + * array. Leading arguments are assumed to be points if they + * start with a digit or a minus sign followed by a digit. + */ + + for (i = 4; i < (argc-1); i+=2) { + if ((!isdigit(UCHAR(argv[i][0]))) && + ((argv[i][0] != '-') || (!isdigit(UCHAR(argv[i][1]))))) { + break; + } + } + if (PolygonCoords(interp, canvas, itemPtr, i, argv) != TCL_OK) { + goto error; + } + + if (ConfigurePolygon(interp, canvas, itemPtr, argc-i, argv+i, 0) + == TCL_OK) { + return TCL_OK; + } + + error: + DeletePolygon(canvas, itemPtr, Tk_Display(Tk_CanvasTkwin(canvas))); + return TCL_ERROR; +} + +/* + *-------------------------------------------------------------- + * + * PolygonCoords -- + * + * This procedure is invoked to process the "coords" widget + * command on polygons. See the user documentation for details + * on what it does. + * + * Results: + * Returns TCL_OK or TCL_ERROR, and sets interp->result. + * + * Side effects: + * The coordinates for the given item may be changed. + * + *-------------------------------------------------------------- + */ + +static int +PolygonCoords(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, ... */ +{ + PolygonItem *polyPtr = (PolygonItem *) itemPtr; + char buffer[TCL_DOUBLE_SPACE]; + int i, numPoints; + + if (argc == 0) { + /* + * Print the coords used to create the polygon. If we auto + * closed the polygon then we don't report the last point. + */ + for (i = 0; i < 2*(polyPtr->numPoints - polyPtr->autoClosed); i++) { + Tcl_PrintDouble(interp, polyPtr->coordPtr[i], buffer); + Tcl_AppendElement(interp, buffer); + } + } else if (argc < 6) { + Tcl_AppendResult(interp, + "too few coordinates for polygon: must have at least 6", + (char *) NULL); + return TCL_ERROR; + } else if (argc & 1) { + Tcl_AppendResult(interp, + "odd number of coordinates specified for polygon", + (char *) NULL); + return TCL_ERROR; + } else { + numPoints = argc/2; + if (polyPtr->pointsAllocated <= numPoints) { + if (polyPtr->coordPtr != NULL) { + ckfree((char *) polyPtr->coordPtr); + } + + /* + * One extra point gets allocated here, just in case we have + * to add another point to close the polygon. + */ + + polyPtr->coordPtr = (double *) ckalloc((unsigned) + (sizeof(double) * (argc+2))); + polyPtr->pointsAllocated = numPoints+1; + } + for (i = argc-1; i >= 0; i--) { + if (Tk_CanvasGetCoord(interp, canvas, argv[i], + &polyPtr->coordPtr[i]) != TCL_OK) { + return TCL_ERROR; + } + } + polyPtr->numPoints = numPoints; + polyPtr->autoClosed = 0; + + /* + * Close the polygon if it isn't already closed. + */ + + if ((polyPtr->coordPtr[argc-2] != polyPtr->coordPtr[0]) + || (polyPtr->coordPtr[argc-1] != polyPtr->coordPtr[1])) { + polyPtr->autoClosed = 1; + polyPtr->numPoints++; + polyPtr->coordPtr[argc] = polyPtr->coordPtr[0]; + polyPtr->coordPtr[argc+1] = polyPtr->coordPtr[1]; + } + ComputePolygonBbox(canvas, polyPtr); + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * ConfigurePolygon -- + * + * This procedure is invoked to configure various aspects + * of a polygon item such as its background color. + * + * Results: + * A standard Tcl result code. If an error occurs, then + * an error message is left in interp->result. + * + * Side effects: + * Configuration information, such as colors and stipple + * patterns, may be set for itemPtr. + * + *-------------------------------------------------------------- + */ + +static int +ConfigurePolygon(interp, canvas, itemPtr, argc, argv, flags) + Tcl_Interp *interp; /* Interpreter for error reporting. */ + Tk_Canvas canvas; /* Canvas containing itemPtr. */ + Tk_Item *itemPtr; /* Polygon item to reconfigure. */ + int argc; /* Number of elements in argv. */ + char **argv; /* Arguments describing things to configure. */ + int flags; /* Flags to pass to Tk_ConfigureWidget. */ +{ + PolygonItem *polyPtr = (PolygonItem *) itemPtr; + XGCValues gcValues; + GC newGC; + unsigned long mask; + Tk_Window tkwin; + + tkwin = Tk_CanvasTkwin(canvas); + if (Tk_ConfigureWidget(interp, tkwin, configSpecs, argc, argv, + (char *) polyPtr, flags) != TCL_OK) { + return TCL_ERROR; + } + + /* + * A few of the options require additional processing, such as + * graphics contexts. + */ + + if (polyPtr->width < 1) { + polyPtr->width = 1; + } + if (polyPtr->outlineColor == NULL) { + newGC = None; + } else { + gcValues.foreground = polyPtr->outlineColor->pixel; + gcValues.line_width = polyPtr->width; + gcValues.cap_style = CapRound; + gcValues.join_style = JoinRound; + mask = GCForeground|GCLineWidth|GCCapStyle|GCJoinStyle; + newGC = Tk_GetGC(tkwin, mask, &gcValues); + } + if (polyPtr->outlineGC != None) { + Tk_FreeGC(Tk_Display(tkwin), polyPtr->outlineGC); + } + polyPtr->outlineGC = newGC; + + if (polyPtr->fillColor == NULL) { + newGC = None; + } else { + gcValues.foreground = polyPtr->fillColor->pixel; + mask = GCForeground; + if (polyPtr->fillStipple != None) { + gcValues.stipple = polyPtr->fillStipple; + gcValues.fill_style = FillStippled; + mask |= GCStipple|GCFillStyle; + } + newGC = Tk_GetGC(tkwin, mask, &gcValues); + } + if (polyPtr->fillGC != None) { + Tk_FreeGC(Tk_Display(tkwin), polyPtr->fillGC); + } + polyPtr->fillGC = newGC; + + /* + * Keep spline parameters within reasonable limits. + */ + + if (polyPtr->splineSteps < 1) { + polyPtr->splineSteps = 1; + } else if (polyPtr->splineSteps > 100) { + polyPtr->splineSteps = 100; + } + + ComputePolygonBbox(canvas, polyPtr); + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * DeletePolygon -- + * + * This procedure is called to clean up the data structure + * associated with a polygon item. + * + * Results: + * None. + * + * Side effects: + * Resources associated with itemPtr are released. + * + *-------------------------------------------------------------- + */ + +static void +DeletePolygon(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. */ +{ + PolygonItem *polyPtr = (PolygonItem *) itemPtr; + + if (polyPtr->coordPtr != NULL) { + ckfree((char *) polyPtr->coordPtr); + } + if (polyPtr->fillColor != NULL) { + Tk_FreeColor(polyPtr->fillColor); + } + if (polyPtr->fillStipple != None) { + Tk_FreeBitmap(display, polyPtr->fillStipple); + } + if (polyPtr->outlineColor != NULL) { + Tk_FreeColor(polyPtr->outlineColor); + } + if (polyPtr->outlineGC != None) { + Tk_FreeGC(display, polyPtr->outlineGC); + } + if (polyPtr->fillGC != None) { + Tk_FreeGC(display, polyPtr->fillGC); + } +} + +/* + *-------------------------------------------------------------- + * + * ComputePolygonBbox -- + * + * This procedure is invoked to compute the bounding box of + * all the pixels that may be drawn as part of a polygon. + * + * Results: + * None. + * + * Side effects: + * The fields x1, y1, x2, and y2 are updated in the header + * for itemPtr. + * + *-------------------------------------------------------------- + */ + +static void +ComputePolygonBbox(canvas, polyPtr) + Tk_Canvas canvas; /* Canvas that contains item. */ + PolygonItem *polyPtr; /* Item whose bbox is to be + * recomputed. */ +{ + double *coordPtr; + int i; + + coordPtr = polyPtr->coordPtr; + polyPtr->header.x1 = polyPtr->header.x2 = (int) *coordPtr; + polyPtr->header.y1 = polyPtr->header.y2 = (int) coordPtr[1]; + + for (i = 1, coordPtr = polyPtr->coordPtr+2; i < polyPtr->numPoints; + i++, coordPtr += 2) { + TkIncludePoint((Tk_Item *) polyPtr, coordPtr); + } + + /* + * Expand bounding box in all directions to account for the outline, + * which can stick out beyond the polygon. Add one extra pixel of + * fudge, just in case X rounds differently than we do. + */ + + i = (polyPtr->width+1)/2 + 1; + polyPtr->header.x1 -= i; + polyPtr->header.x2 += i; + polyPtr->header.y1 -= i; + polyPtr->header.y2 += i; +} + +/* + *-------------------------------------------------------------- + * + * TkFillPolygon -- + * + * This procedure is invoked to convert a polygon to screen + * coordinates and display it using a particular GC. + * + * Results: + * None. + * + * Side effects: + * ItemPtr is drawn in drawable using the transformation + * information in canvas. + * + *-------------------------------------------------------------- + */ + +void +TkFillPolygon(canvas, coordPtr, numPoints, display, drawable, gc, outlineGC) + Tk_Canvas canvas; /* Canvas whose coordinate system + * is to be used for drawing. */ + double *coordPtr; /* Array of coordinates for polygon: + * x1, y1, x2, y2, .... */ + int numPoints; /* Twice this many coordinates are + * present at *coordPtr. */ + Display *display; /* Display on which to draw polygon. */ + Drawable drawable; /* Pixmap or window in which to draw + * polygon. */ + GC gc; /* Graphics context for drawing. */ + GC outlineGC; /* If not None, use this to draw an + * outline around the polygon after + * filling it. */ +{ + XPoint staticPoints[MAX_STATIC_POINTS]; + XPoint *pointPtr; + XPoint *pPtr; + int i; + + /* + * Build up an array of points in screen coordinates. Use a + * static array unless the polygon has an enormous number of points; + * in this case, dynamically allocate an array. + */ + + if (numPoints <= MAX_STATIC_POINTS) { + pointPtr = staticPoints; + } else { + pointPtr = (XPoint *) ckalloc((unsigned) (numPoints * sizeof(XPoint))); + } + + for (i = 0, pPtr = pointPtr; i < numPoints; i += 1, coordPtr += 2, pPtr++) { + Tk_CanvasDrawableCoords(canvas, coordPtr[0], coordPtr[1], &pPtr->x, + &pPtr->y); + } + + /* + * Display polygon, then free up polygon storage if it was dynamically + * allocated. + */ + + if (gc != None) { + XFillPolygon(display, drawable, gc, pointPtr, numPoints, Complex, + CoordModeOrigin); + } + if (outlineGC != None) { + XDrawLines(display, drawable, outlineGC, pointPtr, + numPoints, CoordModeOrigin); + } + if (pointPtr != staticPoints) { + ckfree((char *) pointPtr); + } +} + +/* + *-------------------------------------------------------------- + * + * DisplayPolygon -- + * + * This procedure is invoked to draw a polygon item in a given + * drawable. + * + * Results: + * None. + * + * Side effects: + * ItemPtr is drawn in drawable using the transformation + * information in canvas. + * + *-------------------------------------------------------------- + */ + +static void +DisplayPolygon(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). */ +{ + PolygonItem *polyPtr = (PolygonItem *) itemPtr; + + if ((polyPtr->fillGC == None) && (polyPtr->outlineGC == None)) { + return; + } + + /* + * If we're stippling then modify the stipple offset in the GC. Be + * sure to reset the offset when done, since the GC is supposed to be + * read-only. + */ + + if ((polyPtr->fillStipple != None) && (polyPtr->fillGC != None)) { + Tk_CanvasSetStippleOrigin(canvas, polyPtr->fillGC); + } + + if (!polyPtr->smooth) { + TkFillPolygon(canvas, polyPtr->coordPtr, polyPtr->numPoints, + display, drawable, polyPtr->fillGC, polyPtr->outlineGC); + } else { + int numPoints; + XPoint staticPoints[MAX_STATIC_POINTS]; + XPoint *pointPtr; + + /* + * This is a smoothed polygon. Display using a set of generated + * spline points rather than the original points. + */ + + numPoints = 1 + polyPtr->numPoints*polyPtr->splineSteps; + if (numPoints <= MAX_STATIC_POINTS) { + pointPtr = staticPoints; + } else { + pointPtr = (XPoint *) ckalloc((unsigned) + (numPoints * sizeof(XPoint))); + } + numPoints = TkMakeBezierCurve(canvas, polyPtr->coordPtr, + polyPtr->numPoints, polyPtr->splineSteps, pointPtr, + (double *) NULL); + if (polyPtr->fillGC != None) { + XFillPolygon(display, drawable, polyPtr->fillGC, pointPtr, + numPoints, Complex, CoordModeOrigin); + } + if (polyPtr->outlineGC != None) { + XDrawLines(display, drawable, polyPtr->outlineGC, pointPtr, + numPoints, CoordModeOrigin); + } + if (pointPtr != staticPoints) { + ckfree((char *) pointPtr); + } + } + if ((polyPtr->fillStipple != None) && (polyPtr->fillGC != None)) { + XSetTSOrigin(display, polyPtr->fillGC, 0, 0); + } +} + +/* + *-------------------------------------------------------------- + * + * PolygonToPoint -- + * + * Computes the distance from a given point to a given + * polygon, in canvas units. + * + * Results: + * The return value is 0 if the point whose x and y coordinates + * are pointPtr[0] and pointPtr[1] is inside the polygon. If the + * point isn't inside the polygon then the return value is the + * distance from the point to the polygon. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static double +PolygonToPoint(canvas, itemPtr, pointPtr) + Tk_Canvas canvas; /* Canvas containing item. */ + Tk_Item *itemPtr; /* Item to check against point. */ + double *pointPtr; /* Pointer to x and y coordinates. */ +{ + PolygonItem *polyPtr = (PolygonItem *) itemPtr; + double *coordPtr, distance; + double staticSpace[2*MAX_STATIC_POINTS]; + int numPoints; + + if (!polyPtr->smooth) { + distance = TkPolygonToPoint(polyPtr->coordPtr, polyPtr->numPoints, + pointPtr); + } else { + /* + * Smoothed polygon. Generate a new set of points and use them + * for comparison. + */ + + numPoints = 1 + polyPtr->numPoints*polyPtr->splineSteps; + if (numPoints <= MAX_STATIC_POINTS) { + coordPtr = staticSpace; + } else { + coordPtr = (double *) ckalloc((unsigned) + (2*numPoints*sizeof(double))); + } + numPoints = TkMakeBezierCurve(canvas, polyPtr->coordPtr, + polyPtr->numPoints, polyPtr->splineSteps, (XPoint *) NULL, + coordPtr); + distance = TkPolygonToPoint(coordPtr, numPoints, pointPtr); + if (coordPtr != staticSpace) { + ckfree((char *) coordPtr); + } + } + if (polyPtr->outlineColor != NULL) { + distance -= polyPtr->width/2.0; + if (distance < 0) { + distance = 0; + } + } + return distance; +} + +/* + *-------------------------------------------------------------- + * + * PolygonToArea -- + * + * This procedure is called to determine whether an item + * lies entirely inside, entirely outside, or overlapping + * a given rectangular area. + * + * Results: + * -1 is returned if the item is entirely outside the area + * given by rectPtr, 0 if it overlaps, and 1 if it is entirely + * inside the given area. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +PolygonToArea(canvas, itemPtr, rectPtr) + Tk_Canvas canvas; /* Canvas containing item. */ + Tk_Item *itemPtr; /* Item to check against polygon. */ + double *rectPtr; /* Pointer to array of four coordinates + * (x1, y1, x2, y2) describing rectangular + * area. */ +{ + PolygonItem *polyPtr = (PolygonItem *) itemPtr; + double *coordPtr, rect2[4], halfWidth; + double staticSpace[2*MAX_STATIC_POINTS]; + int numPoints, result; + + /* + * Handle smoothed polygons by generating an expanded set of points + * against which to do the check. + */ + + if (polyPtr->smooth) { + numPoints = 1 + polyPtr->numPoints*polyPtr->splineSteps; + if (numPoints <= MAX_STATIC_POINTS) { + coordPtr = staticSpace; + } else { + coordPtr = (double *) ckalloc((unsigned) + (2*numPoints*sizeof(double))); + } + numPoints = TkMakeBezierCurve(canvas, polyPtr->coordPtr, + polyPtr->numPoints, polyPtr->splineSteps, (XPoint *) NULL, + coordPtr); + } else { + numPoints = polyPtr->numPoints; + coordPtr = polyPtr->coordPtr; + } + + if (polyPtr->width <= 1) { + /* + * The outline of the polygon doesn't stick out, so we can + * do a simple check. + */ + + result = TkPolygonToArea(coordPtr, numPoints, rectPtr); + } else { + /* + * The polygon has a wide outline, so the check is more complicated. + * First, check the line segments to see if they overlap the area. + */ + + result = TkThickPolyLineToArea(coordPtr, numPoints, + (double) polyPtr->width, CapRound, JoinRound, rectPtr); + if (result >= 0) { + goto done; + } + + /* + * There is no overlap between the polygon's outline and the + * rectangle. This means either the rectangle is entirely outside + * the polygon or entirely inside. To tell the difference, + * see whether the polygon (with 0 outline width) overlaps the + * rectangle bloated by half the outline width. + */ + + halfWidth = polyPtr->width/2.0; + rect2[0] = rectPtr[0] - halfWidth; + rect2[1] = rectPtr[1] - halfWidth; + rect2[2] = rectPtr[2] + halfWidth; + rect2[3] = rectPtr[3] + halfWidth; + if (TkPolygonToArea(coordPtr, numPoints, rect2) == -1) { + result = -1; + } else { + result = 0; + } + } + + done: + if ((coordPtr != staticSpace) && (coordPtr != polyPtr->coordPtr)) { + ckfree((char *) coordPtr); + } + return result; +} + +/* + *-------------------------------------------------------------- + * + * ScalePolygon -- + * + * This procedure is invoked to rescale a polygon item. + * + * Results: + * None. + * + * Side effects: + * The polygon referred to by itemPtr is rescaled so that the + * following transformation is applied to all point + * coordinates: + * x' = originX + scaleX*(x-originX) + * y' = originY + scaleY*(y-originY) + * + *-------------------------------------------------------------- + */ + +static void +ScalePolygon(canvas, itemPtr, originX, originY, scaleX, scaleY) + Tk_Canvas canvas; /* Canvas containing polygon. */ + Tk_Item *itemPtr; /* Polygon 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. */ +{ + PolygonItem *polyPtr = (PolygonItem *) itemPtr; + double *coordPtr; + int i; + + for (i = 0, coordPtr = polyPtr->coordPtr; i < polyPtr->numPoints; + i++, coordPtr += 2) { + *coordPtr = originX + scaleX*(*coordPtr - originX); + coordPtr[1] = originY + scaleY*(coordPtr[1] - originY); + } + ComputePolygonBbox(canvas, polyPtr); +} + +/* + *-------------------------------------------------------------- + * + * TranslatePolygon -- + * + * This procedure is called to move a polygon by a given + * amount. + * + * Results: + * None. + * + * Side effects: + * The position of the polygon is offset by (xDelta, yDelta), + * and the bounding box is updated in the generic part of the + * item structure. + * + *-------------------------------------------------------------- + */ + +static void +TranslatePolygon(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. */ +{ + PolygonItem *polyPtr = (PolygonItem *) itemPtr; + double *coordPtr; + int i; + + for (i = 0, coordPtr = polyPtr->coordPtr; i < polyPtr->numPoints; + i++, coordPtr += 2) { + *coordPtr += deltaX; + coordPtr[1] += deltaY; + } + ComputePolygonBbox(canvas, polyPtr); +} + +/* + *-------------------------------------------------------------- + * + * PolygonToPostscript -- + * + * This procedure is called to generate Postscript for + * polygon items. + * + * 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. If no error occurs, then Postscript for the + * item is appended to the result. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static int +PolygonToPostscript(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. */ +{ + char string[100]; + PolygonItem *polyPtr = (PolygonItem *) itemPtr; + + /* + * Fill the area of the polygon. + */ + + if (polyPtr->fillColor != NULL) { + if (!polyPtr->smooth) { + Tk_CanvasPsPath(interp, canvas, polyPtr->coordPtr, + polyPtr->numPoints); + } else { + TkMakeBezierPostscript(interp, canvas, polyPtr->coordPtr, + polyPtr->numPoints); + } + if (Tk_CanvasPsColor(interp, canvas, polyPtr->fillColor) != TCL_OK) { + return TCL_ERROR; + } + if (polyPtr->fillStipple != None) { + Tcl_AppendResult(interp, "eoclip ", (char *) NULL); + if (Tk_CanvasPsStipple(interp, canvas, polyPtr->fillStipple) + != TCL_OK) { + return TCL_ERROR; + } + if (polyPtr->outlineColor != NULL) { + Tcl_AppendResult(interp, "grestore gsave\n", (char *) NULL); + } + } else { + Tcl_AppendResult(interp, "eofill\n", (char *) NULL); + } + } + + /* + * Now draw the outline, if there is one. + */ + + if (polyPtr->outlineColor != NULL) { + if (!polyPtr->smooth) { + Tk_CanvasPsPath(interp, canvas, polyPtr->coordPtr, + polyPtr->numPoints); + } else { + TkMakeBezierPostscript(interp, canvas, polyPtr->coordPtr, + polyPtr->numPoints); + } + + sprintf(string, "%d setlinewidth\n", polyPtr->width); + Tcl_AppendResult(interp, string, + "1 setlinecap\n1 setlinejoin\n", (char *) NULL); + if (Tk_CanvasPsColor(interp, canvas, polyPtr->outlineColor) + != TCL_OK) { + return TCL_ERROR; + } + Tcl_AppendResult(interp, "stroke\n", (char *) NULL); + } + return TCL_OK; +} diff --git a/generic/tkCanvPs.c b/generic/tkCanvPs.c new file mode 100644 index 0000000..9bad194 --- /dev/null +++ b/generic/tkCanvPs.c @@ -0,0 +1,1163 @@ +/* + * tkCanvPs.c -- + * + * This module provides Postscript output support for canvases, + * including the "postscript" widget command plus a few utility + * procedures used for generating Postscript. + * + * Copyright (c) 1991-1994 The Regents of the University of California. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkCanvPs.c 1.57 97/10/28 18:08:39 + */ + +#include "tkInt.h" +#include "tkCanvas.h" +#include "tkPort.h" + +/* + * See tkCanvas.h for key data structures used to implement canvases. + */ + +/* + * One of the following structures is created to keep track of Postscript + * output being generated. It consists mostly of information provided on + * the widget command line. + */ + +typedef struct TkPostscriptInfo { + int x, y, width, height; /* Area to print, in canvas pixel + * coordinates. */ + int x2, y2; /* x+width and y+height. */ + char *pageXString; /* String value of "-pagex" option or NULL. */ + char *pageYString; /* String value of "-pagey" option or NULL. */ + double pageX, pageY; /* Postscript coordinates (in points) + * corresponding to pageXString and + * pageYString. Don't forget that y-values + * grow upwards for Postscript! */ + char *pageWidthString; /* Printed width of output. */ + char *pageHeightString; /* Printed height of output. */ + double scale; /* Scale factor for conversion: each pixel + * maps into this many points. */ + Tk_Anchor pageAnchor; /* How to anchor bbox on Postscript page. */ + int rotate; /* Non-zero means output should be rotated + * on page (landscape mode). */ + char *fontVar; /* If non-NULL, gives name of global variable + * containing font mapping information. + * Malloc'ed. */ + char *colorVar; /* If non-NULL, give name of global variable + * containing color mapping information. + * Malloc'ed. */ + char *colorMode; /* Mode for handling colors: "monochrome", + * "gray", or "color". Malloc'ed. */ + int colorLevel; /* Numeric value corresponding to colorMode: + * 0 for mono, 1 for gray, 2 for color. */ + char *fileName; /* Name of file in which to write Postscript; + * NULL means return Postscript info as + * result. Malloc'ed. */ + char *channelName; /* If -channel is specified, the name of + * the channel to use. */ + Tcl_Channel chan; /* Open channel corresponding to fileName. */ + Tcl_HashTable fontTable; /* Hash table containing names of all font + * families used in output. The hash table + * values are not used. */ + int prepass; /* Non-zero means that we're currently in + * the pre-pass that collects font information, + * so the Postscript generated isn't + * relevant. */ +} TkPostscriptInfo; + +/* + * The table below provides a template that's used to process arguments + * to the canvas "postscript" command and fill in TkPostscriptInfo + * structures. + */ + +static Tk_ConfigSpec configSpecs[] = { + {TK_CONFIG_STRING, "-colormap", (char *) NULL, (char *) NULL, + "", Tk_Offset(TkPostscriptInfo, colorVar), 0}, + {TK_CONFIG_STRING, "-colormode", (char *) NULL, (char *) NULL, + "", Tk_Offset(TkPostscriptInfo, colorMode), 0}, + {TK_CONFIG_STRING, "-file", (char *) NULL, (char *) NULL, + "", Tk_Offset(TkPostscriptInfo, fileName), 0}, + {TK_CONFIG_STRING, "-channel", (char *) NULL, (char *) NULL, + "", Tk_Offset(TkPostscriptInfo, channelName), 0}, + {TK_CONFIG_STRING, "-fontmap", (char *) NULL, (char *) NULL, + "", Tk_Offset(TkPostscriptInfo, fontVar), 0}, + {TK_CONFIG_PIXELS, "-height", (char *) NULL, (char *) NULL, + "", Tk_Offset(TkPostscriptInfo, height), 0}, + {TK_CONFIG_ANCHOR, "-pageanchor", (char *) NULL, (char *) NULL, + "", Tk_Offset(TkPostscriptInfo, pageAnchor), 0}, + {TK_CONFIG_STRING, "-pageheight", (char *) NULL, (char *) NULL, + "", Tk_Offset(TkPostscriptInfo, pageHeightString), 0}, + {TK_CONFIG_STRING, "-pagewidth", (char *) NULL, (char *) NULL, + "", Tk_Offset(TkPostscriptInfo, pageWidthString), 0}, + {TK_CONFIG_STRING, "-pagex", (char *) NULL, (char *) NULL, + "", Tk_Offset(TkPostscriptInfo, pageXString), 0}, + {TK_CONFIG_STRING, "-pagey", (char *) NULL, (char *) NULL, + "", Tk_Offset(TkPostscriptInfo, pageYString), 0}, + {TK_CONFIG_BOOLEAN, "-rotate", (char *) NULL, (char *) NULL, + "", Tk_Offset(TkPostscriptInfo, rotate), 0}, + {TK_CONFIG_PIXELS, "-width", (char *) NULL, (char *) NULL, + "", Tk_Offset(TkPostscriptInfo, width), 0}, + {TK_CONFIG_PIXELS, "-x", (char *) NULL, (char *) NULL, + "", Tk_Offset(TkPostscriptInfo, x), 0}, + {TK_CONFIG_PIXELS, "-y", (char *) NULL, (char *) NULL, + "", Tk_Offset(TkPostscriptInfo, y), 0}, + {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, 0} +}; + +/* + * Forward declarations for procedures defined later in this file: + */ + +static int GetPostscriptPoints _ANSI_ARGS_((Tcl_Interp *interp, + char *string, double *doublePtr)); + +/* + *-------------------------------------------------------------- + * + * TkCanvPostscriptCmd -- + * + * This procedure is invoked to process the "postscript" options + * of the widget command for canvas widgets. See the user + * documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +TkCanvPostscriptCmd(canvasPtr, interp, argc, argv) + TkCanvas *canvasPtr; /* Information about canvas widget. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. Caller has + * already parsed this command enough + * to know that argv[1] is + * "postscript". */ +{ + TkPostscriptInfo psInfo, *oldInfoPtr; + int result; + Tk_Item *itemPtr; +#define STRING_LENGTH 400 + char string[STRING_LENGTH+1], *p; + time_t now; + size_t length; + int deltaX = 0, deltaY = 0; /* Offset of lower-left corner of + * area to be marked up, measured + * in canvas units from the positioning + * point on the page (reflects + * anchor position). Initial values + * needed only to stop compiler + * warnings. */ + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; + Tcl_DString buffer; + + /* + *---------------------------------------------------------------- + * Initialize the data structure describing Postscript generation, + * then process all the arguments to fill the data structure in. + *---------------------------------------------------------------- + */ + + oldInfoPtr = canvasPtr->psInfoPtr; + canvasPtr->psInfoPtr = &psInfo; + psInfo.x = canvasPtr->xOrigin; + psInfo.y = canvasPtr->yOrigin; + psInfo.width = -1; + psInfo.height = -1; + psInfo.pageXString = NULL; + psInfo.pageYString = NULL; + psInfo.pageX = 72*4.25; + psInfo.pageY = 72*5.5; + psInfo.pageWidthString = NULL; + psInfo.pageHeightString = NULL; + psInfo.scale = 1.0; + psInfo.pageAnchor = TK_ANCHOR_CENTER; + psInfo.rotate = 0; + psInfo.fontVar = NULL; + psInfo.colorVar = NULL; + psInfo.colorMode = NULL; + psInfo.colorLevel = 0; + psInfo.fileName = NULL; + psInfo.channelName = NULL; + psInfo.chan = NULL; + psInfo.prepass = 0; + Tcl_InitHashTable(&psInfo.fontTable, TCL_STRING_KEYS); + result = Tk_ConfigureWidget(canvasPtr->interp, canvasPtr->tkwin, + configSpecs, argc-2, argv+2, (char *) &psInfo, + TK_CONFIG_ARGV_ONLY); + if (result != TCL_OK) { + goto cleanup; + } + + if (psInfo.width == -1) { + psInfo.width = Tk_Width(canvasPtr->tkwin); + } + if (psInfo.height == -1) { + psInfo.height = Tk_Height(canvasPtr->tkwin); + } + psInfo.x2 = psInfo.x + psInfo.width; + psInfo.y2 = psInfo.y + psInfo.height; + + if (psInfo.pageXString != NULL) { + if (GetPostscriptPoints(canvasPtr->interp, psInfo.pageXString, + &psInfo.pageX) != TCL_OK) { + goto cleanup; + } + } + if (psInfo.pageYString != NULL) { + if (GetPostscriptPoints(canvasPtr->interp, psInfo.pageYString, + &psInfo.pageY) != TCL_OK) { + goto cleanup; + } + } + if (psInfo.pageWidthString != NULL) { + if (GetPostscriptPoints(canvasPtr->interp, psInfo.pageWidthString, + &psInfo.scale) != TCL_OK) { + goto cleanup; + } + psInfo.scale /= psInfo.width; + } else if (psInfo.pageHeightString != NULL) { + if (GetPostscriptPoints(canvasPtr->interp, psInfo.pageHeightString, + &psInfo.scale) != TCL_OK) { + goto cleanup; + } + psInfo.scale /= psInfo.height; + } else { + psInfo.scale = (72.0/25.4)*WidthMMOfScreen(Tk_Screen(canvasPtr->tkwin)); + psInfo.scale /= WidthOfScreen(Tk_Screen(canvasPtr->tkwin)); + } + switch (psInfo.pageAnchor) { + case TK_ANCHOR_NW: + case TK_ANCHOR_W: + case TK_ANCHOR_SW: + deltaX = 0; + break; + case TK_ANCHOR_N: + case TK_ANCHOR_CENTER: + case TK_ANCHOR_S: + deltaX = -psInfo.width/2; + break; + case TK_ANCHOR_NE: + case TK_ANCHOR_E: + case TK_ANCHOR_SE: + deltaX = -psInfo.width; + break; + } + switch (psInfo.pageAnchor) { + case TK_ANCHOR_NW: + case TK_ANCHOR_N: + case TK_ANCHOR_NE: + deltaY = - psInfo.height; + break; + case TK_ANCHOR_W: + case TK_ANCHOR_CENTER: + case TK_ANCHOR_E: + deltaY = -psInfo.height/2; + break; + case TK_ANCHOR_SW: + case TK_ANCHOR_S: + case TK_ANCHOR_SE: + deltaY = 0; + break; + } + + if (psInfo.colorMode == NULL) { + psInfo.colorLevel = 2; + } else { + length = strlen(psInfo.colorMode); + if (strncmp(psInfo.colorMode, "monochrome", length) == 0) { + psInfo.colorLevel = 0; + } else if (strncmp(psInfo.colorMode, "gray", length) == 0) { + psInfo.colorLevel = 1; + } else if (strncmp(psInfo.colorMode, "color", length) == 0) { + psInfo.colorLevel = 2; + } else { + Tcl_AppendResult(canvasPtr->interp, "bad color mode \"", + psInfo.colorMode, "\": must be monochrome, ", + "gray, or color", (char *) NULL); + goto cleanup; + } + } + + if (psInfo.fileName != NULL) { + + /* + * Check that -file and -channel are not both specified. + */ + + if (psInfo.channelName != NULL) { + Tcl_AppendResult(canvasPtr->interp, "can't specify both -file", + " and -channel", (char *) NULL); + result = TCL_ERROR; + goto cleanup; + } + + /* + * Check that we are not in a safe interpreter. If we are, disallow + * the -file specification. + */ + + if (Tcl_IsSafe(canvasPtr->interp)) { + Tcl_AppendResult(canvasPtr->interp, "can't specify -file in a", + " safe interpreter", (char *) NULL); + result = TCL_ERROR; + goto cleanup; + } + + p = Tcl_TranslateFileName(canvasPtr->interp, psInfo.fileName, &buffer); + if (p == NULL) { + goto cleanup; + } + psInfo.chan = Tcl_OpenFileChannel(canvasPtr->interp, p, "w", 0666); + Tcl_DStringFree(&buffer); + if (psInfo.chan == NULL) { + goto cleanup; + } + } + + if (psInfo.channelName != NULL) { + int mode; + + /* + * Check that the channel is found in this interpreter and that it + * is open for writing. + */ + + psInfo.chan = Tcl_GetChannel(canvasPtr->interp, psInfo.channelName, + &mode); + if (psInfo.chan == (Tcl_Channel) NULL) { + result = TCL_ERROR; + goto cleanup; + } + if ((mode & TCL_WRITABLE) == 0) { + Tcl_AppendResult(canvasPtr->interp, "channel \"", + psInfo.channelName, "\" wasn't opened for writing", + (char *) NULL); + result = TCL_ERROR; + goto cleanup; + } + } + + /* + *-------------------------------------------------------- + * Make a pre-pass over all of the items, generating Postscript + * and then throwing it away. The purpose of this pass is just + * to collect information about all the fonts in use, so that + * we can output font information in the proper form required + * by the Document Structuring Conventions. + *-------------------------------------------------------- + */ + + psInfo.prepass = 1; + for (itemPtr = canvasPtr->firstItemPtr; itemPtr != NULL; + itemPtr = itemPtr->nextPtr) { + if ((itemPtr->x1 >= psInfo.x2) || (itemPtr->x2 < psInfo.x) + || (itemPtr->y1 >= psInfo.y2) || (itemPtr->y2 < psInfo.y)) { + continue; + } + if (itemPtr->typePtr->postscriptProc == NULL) { + continue; + } + result = (*itemPtr->typePtr->postscriptProc)(canvasPtr->interp, + (Tk_Canvas) canvasPtr, itemPtr, 1); + Tcl_ResetResult(canvasPtr->interp); + if (result != TCL_OK) { + /* + * An error just occurred. Just skip out of this loop. + * There's no need to report the error now; it can be + * reported later (errors can happen later that don't + * happen now, so we still have to check for errors later + * anyway). + */ + break; + } + } + psInfo.prepass = 0; + + /* + *-------------------------------------------------------- + * Generate the header and prolog for the Postscript. + *-------------------------------------------------------- + */ + + Tcl_AppendResult(canvasPtr->interp, "%!PS-Adobe-3.0 EPSF-3.0\n", + "%%Creator: Tk Canvas Widget\n", (char *) NULL); +#if !(defined(__WIN32__) || defined(MAC_TCL)) + if (!Tcl_IsSafe(interp)) { + struct passwd *pwPtr = getpwuid(getuid()); + Tcl_AppendResult(canvasPtr->interp, "%%For: ", + (pwPtr != NULL) ? pwPtr->pw_gecos : "Unknown", "\n", + (char *) NULL); + endpwent(); + } +#endif /* __WIN32__ || MAC_TCL */ + Tcl_AppendResult(canvasPtr->interp, "%%Title: Window ", + Tk_PathName(canvasPtr->tkwin), "\n", (char *) NULL); + time(&now); + Tcl_AppendResult(canvasPtr->interp, "%%CreationDate: ", + ctime(&now), (char *) NULL); + if (!psInfo.rotate) { + sprintf(string, "%d %d %d %d", + (int) (psInfo.pageX + psInfo.scale*deltaX), + (int) (psInfo.pageY + psInfo.scale*deltaY), + (int) (psInfo.pageX + psInfo.scale*(deltaX + psInfo.width) + + 1.0), + (int) (psInfo.pageY + psInfo.scale*(deltaY + psInfo.height) + + 1.0)); + } else { + sprintf(string, "%d %d %d %d", + (int) (psInfo.pageX - psInfo.scale*(deltaY + psInfo.height)), + (int) (psInfo.pageY + psInfo.scale*deltaX), + (int) (psInfo.pageX - psInfo.scale*deltaY + 1.0), + (int) (psInfo.pageY + psInfo.scale*(deltaX + psInfo.width) + + 1.0)); + } + Tcl_AppendResult(canvasPtr->interp, "%%BoundingBox: ", string, + "\n", (char *) NULL); + Tcl_AppendResult(canvasPtr->interp, "%%Pages: 1\n", + "%%DocumentData: Clean7Bit\n", (char *) NULL); + Tcl_AppendResult(canvasPtr->interp, "%%Orientation: ", + psInfo.rotate ? "Landscape\n" : "Portrait\n", (char *) NULL); + p = "%%DocumentNeededResources: font "; + for (hPtr = Tcl_FirstHashEntry(&psInfo.fontTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + Tcl_AppendResult(canvasPtr->interp, p, + Tcl_GetHashKey(&psInfo.fontTable, hPtr), + "\n", (char *) NULL); + p = "%%+ font "; + } + Tcl_AppendResult(canvasPtr->interp, "%%EndComments\n\n", (char *) NULL); + + /* + * Read a standard prolog file in a native way and insert it into + * the Postscript. + */ + + if (TkGetNativeProlog(canvasPtr->interp) != TCL_OK) { + result = TCL_ERROR; + goto cleanup; + } + if (psInfo.chan != NULL) { + Tcl_Write(psInfo.chan, canvasPtr->interp->result, -1); + Tcl_ResetResult(canvasPtr->interp); + } + + /* + *----------------------------------------------------------- + * Document setup: set the color level and include fonts. + *----------------------------------------------------------- + */ + + sprintf(string, "/CL %d def\n", psInfo.colorLevel); + Tcl_AppendResult(canvasPtr->interp, "%%BeginSetup\n", string, + (char *) NULL); + for (hPtr = Tcl_FirstHashEntry(&psInfo.fontTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + Tcl_AppendResult(canvasPtr->interp, "%%IncludeResource: font ", + Tcl_GetHashKey(&psInfo.fontTable, hPtr), "\n", (char *) NULL); + } + Tcl_AppendResult(canvasPtr->interp, "%%EndSetup\n\n", (char *) NULL); + + /* + *----------------------------------------------------------- + * Page setup: move to page positioning point, rotate if + * needed, set scale factor, offset for proper anchor position, + * and set clip region. + *----------------------------------------------------------- + */ + + Tcl_AppendResult(canvasPtr->interp, "%%Page: 1 1\n", "save\n", + (char *) NULL); + sprintf(string, "%.1f %.1f translate\n", psInfo.pageX, psInfo.pageY); + Tcl_AppendResult(canvasPtr->interp, string, (char *) NULL); + if (psInfo.rotate) { + Tcl_AppendResult(canvasPtr->interp, "90 rotate\n", (char *) NULL); + } + sprintf(string, "%.4g %.4g scale\n", psInfo.scale, psInfo.scale); + Tcl_AppendResult(canvasPtr->interp, string, (char *) NULL); + sprintf(string, "%d %d translate\n", deltaX - psInfo.x, deltaY); + Tcl_AppendResult(canvasPtr->interp, string, (char *) NULL); + sprintf(string, "%d %.15g moveto %d %.15g lineto %d %.15g lineto %d %.15g", + psInfo.x, Tk_CanvasPsY((Tk_Canvas) canvasPtr, (double) psInfo.y), + psInfo.x2, Tk_CanvasPsY((Tk_Canvas) canvasPtr, (double) psInfo.y), + psInfo.x2, Tk_CanvasPsY((Tk_Canvas) canvasPtr, (double) psInfo.y2), + psInfo.x, Tk_CanvasPsY((Tk_Canvas) canvasPtr, (double) psInfo.y2)); + 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_ResetResult(canvasPtr->interp); + } + + /* + *--------------------------------------------------------------------- + * Iterate through all the items, having each relevant one draw itself. + * Quit if any of the items returns an error. + *--------------------------------------------------------------------- + */ + + result = TCL_OK; + for (itemPtr = canvasPtr->firstItemPtr; itemPtr != NULL; + itemPtr = itemPtr->nextPtr) { + if ((itemPtr->x1 >= psInfo.x2) || (itemPtr->x2 < psInfo.x) + || (itemPtr->y1 >= psInfo.y2) || (itemPtr->y2 < psInfo.y)) { + continue; + } + if (itemPtr->typePtr->postscriptProc == NULL) { + continue; + } + Tcl_AppendResult(canvasPtr->interp, "gsave\n", (char *) NULL); + result = (*itemPtr->typePtr->postscriptProc)(canvasPtr->interp, + (Tk_Canvas) canvasPtr, itemPtr, 0); + if (result != TCL_OK) { + char msg[100]; + + sprintf(msg, "\n (generating Postscript for item %d)", + itemPtr->id); + Tcl_AddErrorInfo(canvasPtr->interp, msg); + goto cleanup; + } + Tcl_AppendResult(canvasPtr->interp, "grestore\n", (char *) NULL); + if (psInfo.chan != NULL) { + Tcl_Write(psInfo.chan, canvasPtr->interp->result, -1); + Tcl_ResetResult(canvasPtr->interp); + } + } + + /* + *--------------------------------------------------------------------- + * Output page-end information, such as commands to print the page + * and document trailer stuff. + *--------------------------------------------------------------------- + */ + + 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_ResetResult(canvasPtr->interp); + } + + /* + * Clean up psInfo to release malloc'ed stuff. + */ + + cleanup: + if (psInfo.pageXString != NULL) { + ckfree(psInfo.pageXString); + } + if (psInfo.pageYString != NULL) { + ckfree(psInfo.pageYString); + } + if (psInfo.pageWidthString != NULL) { + ckfree(psInfo.pageWidthString); + } + if (psInfo.pageHeightString != NULL) { + ckfree(psInfo.pageHeightString); + } + if (psInfo.fontVar != NULL) { + ckfree(psInfo.fontVar); + } + if (psInfo.colorVar != NULL) { + ckfree(psInfo.colorVar); + } + if (psInfo.colorMode != NULL) { + ckfree(psInfo.colorMode); + } + if (psInfo.fileName != NULL) { + ckfree(psInfo.fileName); + } + if ((psInfo.chan != NULL) && (psInfo.channelName == NULL)) { + Tcl_Close(canvasPtr->interp, psInfo.chan); + } + if (psInfo.channelName != NULL) { + ckfree(psInfo.channelName); + } + Tcl_DeleteHashTable(&psInfo.fontTable); + canvasPtr->psInfoPtr = oldInfoPtr; + return result; +} + +/* + *-------------------------------------------------------------- + * + * Tk_CanvasPsColor -- + * + * This procedure is called by individual canvas items when + * they want to set a color value for output. Given information + * about an X color, this procedure will generate Postscript + * commands to set up an appropriate color in Postscript. + * + * Results: + * Returns a standard Tcl return value. If an error occurs + * then an error message will be left in interp->result. + * If no error occurs, then additional Postscript will be + * appended to interp->result. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +int +Tk_CanvasPsColor(interp, canvas, colorPtr) + Tcl_Interp *interp; /* Interpreter for returning Postscript + * or error message. */ + Tk_Canvas canvas; /* Information about canvas. */ + XColor *colorPtr; /* Information about color. */ +{ + TkCanvas *canvasPtr = (TkCanvas *) canvas; + TkPostscriptInfo *psInfoPtr = canvasPtr->psInfoPtr; + int tmp; + double red, green, blue; + char string[200]; + + if (psInfoPtr->prepass) { + return TCL_OK; + } + + /* + * If there is a color map defined, then look up the color's name + * in the map and use the Postscript commands found there, if there + * are any. + */ + + if (psInfoPtr->colorVar != NULL) { + char *cmdString; + + cmdString = Tcl_GetVar2(interp, psInfoPtr->colorVar, + Tk_NameOfColor(colorPtr), 0); + if (cmdString != NULL) { + Tcl_AppendResult(interp, cmdString, "\n", (char *) NULL); + return TCL_OK; + } + } + + /* + * No color map entry for this color. Grab the color's intensities + * and output Postscript commands for them. Special note: X uses + * a range of 0-65535 for intensities, but most displays only use + * a range of 0-255, which maps to (0, 256, 512, ... 65280) in the + * X scale. This means that there's no way to get perfect white, + * since the highest intensity is only 65280 out of 65535. To + * work around this problem, rescale the X intensity to a 0-255 + * scale and use that as the basis for the Postscript colors. This + * scheme still won't work if the display only uses 4 bits per color, + * but most diplays use at least 8 bits. + */ + + tmp = colorPtr->red; + red = ((double) (tmp >> 8))/255.0; + tmp = colorPtr->green; + green = ((double) (tmp >> 8))/255.0; + tmp = colorPtr->blue; + blue = ((double) (tmp >> 8))/255.0; + sprintf(string, "%.3f %.3f %.3f setrgbcolor AdjustColor\n", + red, green, blue); + Tcl_AppendResult(interp, string, (char *) NULL); + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * Tk_CanvasPsFont -- + * + * This procedure is called by individual canvas items when + * they want to output text. Given information about an X + * font, this procedure will generate Postscript commands + * to set up an appropriate font in Postscript. + * + * Results: + * Returns a standard Tcl return value. If an error occurs + * then an error message will be left in interp->result. + * If no error occurs, then additional Postscript will be + * appended to the interp->result. + * + * Side effects: + * The Postscript font name is entered into psInfoPtr->fontTable + * if it wasn't already there. + * + *-------------------------------------------------------------- + */ + +int +Tk_CanvasPsFont(interp, canvas, tkfont) + Tcl_Interp *interp; /* Interpreter for returning Postscript + * or error message. */ + Tk_Canvas canvas; /* Information about canvas. */ + Tk_Font tkfont; /* Information about font in which text + * is to be printed. */ +{ + TkCanvas *canvasPtr = (TkCanvas *) canvas; + TkPostscriptInfo *psInfoPtr = canvasPtr->psInfoPtr; + char *end; + char pointString[20]; + Tcl_DString ds; + int i, points; + + /* + * First, look up the font's name in the font map, if there is one. + * If there is an entry for this font, it consists of a list + * containing font name and size. Use this information. + */ + + Tcl_DStringInit(&ds); + + if (psInfoPtr->fontVar != NULL) { + char *list, **argv; + int argc; + double size; + char *name; + + name = Tk_NameOfFont(tkfont); + list = Tcl_GetVar2(interp, psInfoPtr->fontVar, name, 0); + if (list != NULL) { + if (Tcl_SplitList(interp, list, &argc, &argv) != TCL_OK) { + badMapEntry: + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad font map entry for \"", name, + "\": \"", list, "\"", (char *) NULL); + return TCL_ERROR; + } + if (argc != 2) { + goto badMapEntry; + } + size = strtod(argv[1], &end); + if ((size <= 0) || (*end != 0)) { + goto badMapEntry; + } + + Tcl_DStringAppend(&ds, argv[0], -1); + points = (int) size; + + ckfree((char *) argv); + goto findfont; + } + } + + points = Tk_PostscriptFontName(tkfont, &ds); + + findfont: + sprintf(pointString, "%d", points); + Tcl_AppendResult(interp, "/", Tcl_DStringValue(&ds), " findfont ", + pointString, " scalefont ", (char *) NULL); + if (strncasecmp(Tcl_DStringValue(&ds), "Symbol", 7) != 0) { + Tcl_AppendResult(interp, "ISOEncode ", (char *) NULL); + } + Tcl_AppendResult(interp, "setfont\n", (char *) NULL); + Tcl_CreateHashEntry(&psInfoPtr->fontTable, Tcl_DStringValue(&ds), &i); + Tcl_DStringFree(&ds); + + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * Tk_CanvasPsBitmap -- + * + * This procedure is called to output the contents of a + * sub-region of a bitmap in proper image data format for + * Postscript (i.e. data between angle brackets, one bit + * per pixel). + * + * Results: + * Returns a standard Tcl return value. If an error occurs + * then an error message will be left in interp->result. + * If no error occurs, then additional Postscript will be + * appended to interp->result. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +int +Tk_CanvasPsBitmap(interp, canvas, bitmap, startX, startY, width, height) + Tcl_Interp *interp; /* Interpreter for returning Postscript + * or error message. */ + Tk_Canvas canvas; /* Information about canvas. */ + Pixmap bitmap; /* Bitmap for which to generate + * Postscript. */ + int startX, startY; /* Coordinates of upper-left corner + * of rectangular region to output. */ + int width, height; /* Height of rectangular region. */ +{ + TkCanvas *canvasPtr = (TkCanvas *) canvas; + TkPostscriptInfo *psInfoPtr = canvasPtr->psInfoPtr; + XImage *imagePtr; + int charsInLine, x, y, lastX, lastY, value, mask; + unsigned int totalWidth, totalHeight; + char string[100]; + Window dummyRoot; + int dummyX, dummyY; + unsigned dummyBorderwidth, dummyDepth; + + if (psInfoPtr->prepass) { + return TCL_OK; + } + + /* + * The following call should probably be a call to Tk_SizeOfBitmap + * instead, but it seems that we are occasionally invoked by custom + * item types that create their own bitmaps without registering them + * with Tk. XGetGeometry is a bit slower than Tk_SizeOfBitmap, but + * it shouldn't matter here. + */ + + XGetGeometry(Tk_Display(Tk_CanvasTkwin(canvas)), bitmap, &dummyRoot, + (int *) &dummyX, (int *) &dummyY, (unsigned int *) &totalWidth, + (unsigned int *) &totalHeight, &dummyBorderwidth, &dummyDepth); + imagePtr = XGetImage(Tk_Display(canvasPtr->tkwin), bitmap, 0, 0, + totalWidth, totalHeight, 1, XYPixmap); + Tcl_AppendResult(interp, "<", (char *) NULL); + mask = 0x80; + value = 0; + charsInLine = 0; + lastX = startX + width - 1; + lastY = startY + height - 1; + for (y = lastY; y >= startY; y--) { + for (x = startX; x <= lastX; x++) { + if (XGetPixel(imagePtr, x, y)) { + value |= mask; + } + mask >>= 1; + if (mask == 0) { + sprintf(string, "%02x", value); + Tcl_AppendResult(interp, string, (char *) NULL); + mask = 0x80; + value = 0; + charsInLine += 2; + if (charsInLine >= 60) { + Tcl_AppendResult(interp, "\n", (char *) NULL); + charsInLine = 0; + } + } + } + if (mask != 0x80) { + sprintf(string, "%02x", value); + Tcl_AppendResult(interp, string, (char *) NULL); + mask = 0x80; + value = 0; + charsInLine += 2; + } + } + Tcl_AppendResult(interp, ">", (char *) NULL); + XDestroyImage(imagePtr); + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * Tk_CanvasPsStipple -- + * + * This procedure is called by individual canvas items when + * they have created a path that they'd like to be filled with + * a stipple pattern. Given information about an X bitmap, + * this procedure will generate Postscript commands to fill + * the current clip region using a stipple pattern defined by the + * bitmap. + * + * Results: + * Returns a standard Tcl return value. If an error occurs + * then an error message will be left in interp->result. + * If no error occurs, then additional Postscript will be + * appended to interp->result. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +int +Tk_CanvasPsStipple(interp, canvas, bitmap) + Tcl_Interp *interp; /* Interpreter for returning Postscript + * or error message. */ + Tk_Canvas canvas; /* Information about canvas. */ + Pixmap bitmap; /* Bitmap to use for stippling. */ +{ + TkCanvas *canvasPtr = (TkCanvas *) canvas; + TkPostscriptInfo *psInfoPtr = canvasPtr->psInfoPtr; + int width, height; + char string[100]; + Window dummyRoot; + int dummyX, dummyY; + unsigned dummyBorderwidth, dummyDepth; + + if (psInfoPtr->prepass) { + return TCL_OK; + } + + /* + * The following call should probably be a call to Tk_SizeOfBitmap + * instead, but it seems that we are occasionally invoked by custom + * item types that create their own bitmaps without registering them + * with Tk. XGetGeometry is a bit slower than Tk_SizeOfBitmap, but + * it shouldn't matter here. + */ + + XGetGeometry(Tk_Display(Tk_CanvasTkwin(canvas)), bitmap, &dummyRoot, + (int *) &dummyX, (int *) &dummyY, (unsigned *) &width, + (unsigned *) &height, &dummyBorderwidth, &dummyDepth); + sprintf(string, "%d %d ", width, height); + Tcl_AppendResult(interp, string, (char *) NULL); + if (Tk_CanvasPsBitmap(interp, (Tk_Canvas) canvasPtr, bitmap, 0, 0, + width, height) != TCL_OK) { + return TCL_ERROR; + } + Tcl_AppendResult(interp, " StippleFill\n", (char *) NULL); + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * Tk_CanvasPsY -- + * + * Given a y-coordinate in canvas coordinates, this procedure + * returns a y-coordinate to use for Postscript output. + * + * Results: + * Returns the Postscript coordinate that corresponds to + * "y". + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +double +Tk_CanvasPsY(canvas, y) + Tk_Canvas canvas; /* Token for canvas on whose behalf + * Postscript is being generated. */ + double y; /* Y-coordinate in canvas coords. */ +{ + TkPostscriptInfo *psInfoPtr = ((TkCanvas *) canvas)->psInfoPtr; + + return psInfoPtr->y2 - y; +} + +/* + *-------------------------------------------------------------- + * + * Tk_CanvasPsPath -- + * + * Given an array of points for a path, generate Postscript + * commands to create the path. + * + * Results: + * Postscript commands get appended to what's in interp->result. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +void +Tk_CanvasPsPath(interp, canvas, coordPtr, numPoints) + Tcl_Interp *interp; /* Put generated Postscript in this + * interpreter's result field. */ + Tk_Canvas canvas; /* Canvas on whose behalf Postscript + * is being generated. */ + double *coordPtr; /* Pointer to first in array of + * 2*numPoints coordinates giving + * points for path. */ + int numPoints; /* Number of points at *coordPtr. */ +{ + TkPostscriptInfo *psInfoPtr = ((TkCanvas *) canvas)->psInfoPtr; + char buffer[200]; + + if (psInfoPtr->prepass) { + return; + } + sprintf(buffer, "%.15g %.15g moveto\n", coordPtr[0], + Tk_CanvasPsY(canvas, coordPtr[1])); + Tcl_AppendResult(interp, buffer, (char *) NULL); + for (numPoints--, coordPtr += 2; numPoints > 0; + numPoints--, coordPtr += 2) { + sprintf(buffer, "%.15g %.15g lineto\n", coordPtr[0], + Tk_CanvasPsY(canvas, coordPtr[1])); + Tcl_AppendResult(interp, buffer, (char *) NULL); + } +} + +/* + *-------------------------------------------------------------- + * + * GetPostscriptPoints -- + * + * Given a string, returns the number of Postscript points + * corresponding to that string. + * + * Results: + * The return value is a standard Tcl return result. If + * 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. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static int +GetPostscriptPoints(interp, string, doublePtr) + Tcl_Interp *interp; /* Use this for error reporting. */ + char *string; /* String describing a screen distance. */ + double *doublePtr; /* Place to store converted result. */ +{ + char *end; + double d; + + d = strtod(string, &end); + if (end == string) { + error: + Tcl_AppendResult(interp, "bad distance \"", string, + "\"", (char *) NULL); + return TCL_ERROR; + } + while ((*end != '\0') && isspace(UCHAR(*end))) { + end++; + } + switch (*end) { + case 'c': + d *= 72.0/2.54; + end++; + break; + case 'i': + d *= 72.0; + end++; + break; + case 'm': + d *= 72.0/25.4; + end++; + break; + case 0: + break; + case 'p': + end++; + break; + default: + goto error; + } + while ((*end != '\0') && isspace(UCHAR(*end))) { + end++; + } + if (*end != 0) { + goto error; + } + *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 new file mode 100644 index 0000000..2938ba1 --- /dev/null +++ b/generic/tkCanvText.c @@ -0,0 +1,1313 @@ +/* + * tkCanvText.c -- + * + * 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. + * + * 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 + */ + +#include +#include "tkInt.h" +#include "tkCanvas.h" +#include "tkPort.h" +#include "default.h" + +/* + * The structure below defines the record for each text item. + */ + +typedef struct TextItem { + Tk_Item header; /* Generic stuff that's the same for all + * types. MUST BE FIRST IN STRUCTURE. */ + Tk_CanvasTextInfo *textInfoPtr; + /* Pointer to a structure containing + * information about the selection and + * insertion cursor. The structure is owned + * by (and shared with) the generic canvas + * code. */ + /* + * Fields that are set by widget commands other than "configure". + */ + + double x, y; /* Positioning point for text. */ + int insertPos; /* Insertion cursor is displayed just to left + * of character with this index. */ + + /* + * Configuration settings that are updated by Tk_ConfigureWidget. + */ + + Tk_Anchor anchor; /* Where to anchor text relative to (x,y). */ + XColor *color; /* Color for text. */ + Tk_Font tkfont; /* Font for drawing text. */ + Tk_Justify justify; /* Justification mode for text. */ + Pixmap stipple; /* Stipple bitmap for text, or None. */ + char *text; /* Text for item (malloc-ed). */ + int width; /* Width of lines for word-wrap, pixels. + * Zero means no word-wrap. */ + + /* + * Fields whose values are derived from the current values of the + * configuration settings above. + */ + + int numChars; /* Number of non-NULL characters in text. */ + 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 + * text layout is drawn. */ + int rightEdge; /* Pixel just to right of right edge of + * area of text item. Used for selecting up + * to end of line. */ + GC gc; /* Graphics context for drawing text. */ + GC selTextGC; /* Graphics context for selected text. */ + GC cursorOffGC; /* If not None, this gives a graphics context + * to use to draw the insertion cursor when + * it's off. Used if the selection and + * insertion cursor colors are the same. */ +} TextItem; + +/* + * Information used for parsing configuration specs: + */ + +static Tk_CustomOption tagsOption = {Tk_CanvasTagsParseProc, + Tk_CanvasTagsPrintProc, (ClientData) NULL +}; + +static Tk_ConfigSpec configSpecs[] = { + {TK_CONFIG_ANCHOR, "-anchor", (char *) NULL, (char *) NULL, + "center", Tk_Offset(TextItem, anchor), + TK_CONFIG_DONT_SET_DEFAULT}, + {TK_CONFIG_COLOR, "-fill", (char *) NULL, (char *) NULL, + "black", Tk_Offset(TextItem, color), 0}, + {TK_CONFIG_FONT, "-font", (char *) NULL, (char *) NULL, + DEF_CANVTEXT_FONT, Tk_Offset(TextItem, tkfont), 0}, + {TK_CONFIG_JUSTIFY, "-justify", (char *) NULL, (char *) NULL, + "left", Tk_Offset(TextItem, justify), + TK_CONFIG_DONT_SET_DEFAULT}, + {TK_CONFIG_BITMAP, "-stipple", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(TextItem, stipple), TK_CONFIG_NULL_OK}, + {TK_CONFIG_CUSTOM, "-tags", (char *) NULL, (char *) NULL, + (char *) NULL, 0, TK_CONFIG_NULL_OK, &tagsOption}, + {TK_CONFIG_STRING, "-text", (char *) NULL, (char *) NULL, + "", Tk_Offset(TextItem, text), 0}, + {TK_CONFIG_PIXELS, "-width", (char *) NULL, (char *) NULL, + "0", Tk_Offset(TextItem, width), TK_CONFIG_DONT_SET_DEFAULT}, + {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, 0} +}; + +/* + * Prototypes for procedures defined in this file: + */ + +static void ComputeTextBbox _ANSI_ARGS_((Tk_Canvas canvas, + TextItem *textPtr)); +static int ConfigureText _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int argc, + char **argv, int flags)); +static int CreateText _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, struct Tk_Item *itemPtr, + int argc, char **argv)); +static void DeleteText _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, Display *display)); +static void DisplayCanvText _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, Display *display, Drawable dst, + int x, int y, int width, int height)); +static int GetSelText _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, int offset, char *buffer, + int maxBytes)); +static int GetTextIndex _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, + char *indexString, int *indexPtr)); +static void ScaleText _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double originX, double originY, + double scaleX, double scaleY)); +static void SetTextCursor _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, int index)); +static int TextCoords _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, + int argc, char **argv)); +static void TextDeleteChars _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, int first, int last)); +static void TextInsert _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, int beforeThis, char *string)); +static int TextToArea _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double *rectPtr)); +static double TextToPoint _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double *pointPtr)); +static int TextToPostscript _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int prepass)); +static void TranslateText _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double deltaX, double deltaY)); + +/* + * The structures below defines the rectangle and oval item types + * by means of procedures that can be invoked by generic item code. + */ + +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 */ +}; + +/* + *-------------------------------------------------------------- + * + * CreateText -- + * + * This procedure is invoked to create a new text item + * in a canvas. + * + * 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 + * so it can be safely freed by the caller. + * + * Side effects: + * A new text item is created. + * + *-------------------------------------------------------------- + */ + +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. */ +{ + TextItem *textPtr = (TextItem *) itemPtr; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + Tk_PathName(Tk_CanvasTkwin(canvas)), " create ", + itemPtr->typePtr->name, " x y ?options?\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * 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); + + textPtr->insertPos = 0; + + textPtr->anchor = TK_ANCHOR_CENTER; + textPtr->color = NULL; + textPtr->tkfont = NULL; + textPtr->justify = TK_JUSTIFY_LEFT; + textPtr->stipple = None; + textPtr->text = NULL; + textPtr->width = 0; + + textPtr->numChars = 0; + textPtr->textLayout = NULL; + textPtr->leftEdge = 0; + textPtr->rightEdge = 0; + textPtr->gc = None; + textPtr->selTextGC = None; + textPtr->cursorOffGC = None; + + /* + * Process the arguments to fill in the item record. + */ + + if ((Tk_CanvasGetCoord(interp, canvas, argv[0], &textPtr->x) != TCL_OK) + || (Tk_CanvasGetCoord(interp, canvas, argv[1], &textPtr->y) + != TCL_OK)) { + return TCL_ERROR; + } + + if (ConfigureText(interp, canvas, itemPtr, argc-2, argv+2, 0) != TCL_OK) { + DeleteText(canvas, itemPtr, Tk_Display(Tk_CanvasTkwin(canvas))); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * TextCoords -- + * + * This procedure is invoked to process the "coords" widget + * command on text items. See the user documentation for + * details on what it does. + * + * Results: + * Returns TCL_OK or TCL_ERROR, and sets interp->result. + * + * Side effects: + * The coordinates for the given item may be changed. + * + *-------------------------------------------------------------- + */ + +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, ... */ +{ + TextItem *textPtr = (TextItem *) itemPtr; + char x[TCL_DOUBLE_SPACE], y[TCL_DOUBLE_SPACE]; + + if (argc == 0) { + Tcl_PrintDouble(interp, textPtr->x, x); + Tcl_PrintDouble(interp, textPtr->y, y); + Tcl_AppendResult(interp, x, " ", y, (char *) NULL); + } else if (argc == 2) { + if ((Tk_CanvasGetCoord(interp, canvas, argv[0], &textPtr->x) != TCL_OK) + || (Tk_CanvasGetCoord(interp, canvas, argv[1], + &textPtr->y) != TCL_OK)) { + return TCL_ERROR; + } + ComputeTextBbox(canvas, textPtr); + } else { + sprintf(interp->result, + "wrong # coordinates: expected 0 or 2, got %d", argc); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * ConfigureText -- + * + * This procedure is invoked to configure various aspects + * of a text item, such as its border and background colors. + * + * Results: + * A standard Tcl result code. If an error occurs, then + * an error message is left in interp->result. + * + * Side effects: + * Configuration information, such as colors and stipple + * patterns, may be set for itemPtr. + * + *-------------------------------------------------------------- + */ + +static int +ConfigureText(interp, canvas, itemPtr, argc, argv, flags) + Tcl_Interp *interp; /* Interpreter for error reporting. */ + Tk_Canvas canvas; /* Canvas containing itemPtr. */ + Tk_Item *itemPtr; /* Rectangle item to reconfigure. */ + int argc; /* Number of elements in argv. */ + char **argv; /* Arguments describing things to configure. */ + int flags; /* Flags to pass to Tk_ConfigureWidget. */ +{ + TextItem *textPtr = (TextItem *) itemPtr; + XGCValues gcValues; + GC newGC, newSelGC; + unsigned long mask; + Tk_Window tkwin; + Tk_CanvasTextInfo *textInfoPtr = textPtr->textInfoPtr; + XColor *selBgColorPtr; + + tkwin = Tk_CanvasTkwin(canvas); + if (Tk_ConfigureWidget(interp, tkwin, configSpecs, argc, argv, + (char *) textPtr, flags) != TCL_OK) { + return TCL_ERROR; + } + + /* + * A few of the options require additional processing, such as + * graphics contexts. + */ + + newGC = newSelGC = None; + if ((textPtr->color != NULL) && (textPtr->tkfont != NULL)) { + gcValues.foreground = textPtr->color->pixel; + gcValues.font = Tk_FontId(textPtr->tkfont); + mask = GCForeground|GCFont; + if (textPtr->stipple != None) { + gcValues.stipple = textPtr->stipple; + gcValues.fill_style = FillStippled; + mask |= GCForeground|GCStipple|GCFillStyle; + } + newGC = Tk_GetGC(tkwin, mask, &gcValues); + gcValues.foreground = textInfoPtr->selFgColorPtr->pixel; + newSelGC = Tk_GetGC(tkwin, mask, &gcValues); + } + if (textPtr->gc != None) { + Tk_FreeGC(Tk_Display(tkwin), textPtr->gc); + } + textPtr->gc = newGC; + if (textPtr->selTextGC != None) { + Tk_FreeGC(Tk_Display(tkwin), textPtr->selTextGC); + } + textPtr->selTextGC = newSelGC; + + selBgColorPtr = Tk_3DBorderColor(textInfoPtr->selBorder); + if (Tk_3DBorderColor(textInfoPtr->insertBorder)->pixel + == selBgColorPtr->pixel) { + if (selBgColorPtr->pixel == BlackPixelOfScreen(Tk_Screen(tkwin))) { + gcValues.foreground = WhitePixelOfScreen(Tk_Screen(tkwin)); + } else { + gcValues.foreground = BlackPixelOfScreen(Tk_Screen(tkwin)); + } + newGC = Tk_GetGC(tkwin, GCForeground, &gcValues); + } else { + newGC = None; + } + if (textPtr->cursorOffGC != None) { + Tk_FreeGC(Tk_Display(tkwin), textPtr->cursorOffGC); + } + textPtr->cursorOffGC = newGC; + + + /* + * If the text was changed, move the selection and insertion indices + * to keep them inside the item. + */ + + textPtr->numChars = strlen(textPtr->text); + if (textInfoPtr->selItemPtr == itemPtr) { + if (textInfoPtr->selectFirst >= textPtr->numChars) { + textInfoPtr->selItemPtr = NULL; + } else { + if (textInfoPtr->selectLast >= textPtr->numChars) { + textInfoPtr->selectLast = textPtr->numChars-1; + } + if ((textInfoPtr->anchorItemPtr == itemPtr) + && (textInfoPtr->selectAnchor >= textPtr->numChars)) { + textInfoPtr->selectAnchor = textPtr->numChars-1; + } + } + } + if (textPtr->insertPos >= textPtr->numChars) { + textPtr->insertPos = textPtr->numChars; + } + + ComputeTextBbox(canvas, textPtr); + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * DeleteText -- + * + * This procedure is called to clean up the data structure + * associated with a text item. + * + * Results: + * None. + * + * Side effects: + * Resources associated with itemPtr are released. + * + *-------------------------------------------------------------- + */ + +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. */ +{ + TextItem *textPtr = (TextItem *) itemPtr; + + if (textPtr->color != NULL) { + Tk_FreeColor(textPtr->color); + } + Tk_FreeFont(textPtr->tkfont); + if (textPtr->stipple != None) { + Tk_FreeBitmap(display, textPtr->stipple); + } + if (textPtr->text != NULL) { + ckfree(textPtr->text); + } + + Tk_FreeTextLayout(textPtr->textLayout); + if (textPtr->gc != None) { + Tk_FreeGC(display, textPtr->gc); + } + if (textPtr->selTextGC != None) { + Tk_FreeGC(display, textPtr->selTextGC); + } + if (textPtr->cursorOffGC != None) { + Tk_FreeGC(display, textPtr->cursorOffGC); + } +} + +/* + *-------------------------------------------------------------- + * + * ComputeTextBbox -- + * + * This procedure is invoked to compute the bounding box of + * all the pixels that may be drawn as part of a text item. + * In addition, it recomputes all of the geometry information + * used to display a text item or check for mouse hits. + * + * Results: + * None. + * + * Side effects: + * The fields x1, y1, x2, and y2 are updated in the header + * for itemPtr, and the linePtr structure is regenerated + * for itemPtr. + * + *-------------------------------------------------------------- + */ + +static void +ComputeTextBbox(canvas, textPtr) + Tk_Canvas canvas; /* Canvas that contains item. */ + TextItem *textPtr; /* Item whose bbos 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->justify, 0, &width, &height); + + /* + * Use overall geometry information to compute the top-left corner + * of the bounding box for the text item. + */ + + leftX = (int) (textPtr->x + 0.5); + topY = (int) (textPtr->y + 0.5); + switch (textPtr->anchor) { + case TK_ANCHOR_NW: + case TK_ANCHOR_N: + case TK_ANCHOR_NE: + break; + + case TK_ANCHOR_W: + case TK_ANCHOR_CENTER: + case TK_ANCHOR_E: + topY -= height / 2; + break; + + case TK_ANCHOR_SW: + case TK_ANCHOR_S: + case TK_ANCHOR_SE: + topY -= height; + break; + } + switch (textPtr->anchor) { + case TK_ANCHOR_NW: + case TK_ANCHOR_W: + case TK_ANCHOR_SW: + break; + + case TK_ANCHOR_N: + case TK_ANCHOR_CENTER: + case TK_ANCHOR_S: + leftX -= width / 2; + break; + + case TK_ANCHOR_NE: + case TK_ANCHOR_E: + case TK_ANCHOR_SE: + leftX -= width; + break; + } + + textPtr->leftEdge = leftX; + textPtr->rightEdge = leftX + width; + + /* + * Last of all, update the bounding box for the item. The item's + * bounding box includes the bounding box of all its lines, plus + * an extra fudge factor for the cursor border (which could + * potentially be quite large). + */ + + textInfoPtr = textPtr->textInfoPtr; + fudge = (textInfoPtr->insertWidth + 1) / 2; + if (textInfoPtr->selBorderWidth > fudge) { + fudge = textInfoPtr->selBorderWidth; + } + textPtr->header.x1 = leftX - fudge; + textPtr->header.y1 = topY; + textPtr->header.x2 = leftX + width + fudge; + textPtr->header.y2 = topY + height; +} + +/* + *-------------------------------------------------------------- + * + * DisplayCanvText -- + * + * This procedure is invoked to draw a text item in a given + * drawable. + * + * Results: + * None. + * + * Side effects: + * ItemPtr is drawn in drawable using the transformation + * information in canvas. + * + *-------------------------------------------------------------- + */ + +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). */ +{ + TextItem *textPtr; + Tk_CanvasTextInfo *textInfoPtr; + int selFirst, selLast; + short drawableX, drawableY; + + textPtr = (TextItem *) itemPtr; + textInfoPtr = textPtr->textInfoPtr; + + if (textPtr->gc == None) { + return; + } + + /* + * If we're stippling, then modify the stipple offset in the GC. Be + * sure to reset the offset when done, since the GC is supposed to be + * read-only. + */ + + if (textPtr->stipple != None) { + Tk_CanvasSetStippleOrigin(canvas, textPtr->gc); + } + + selFirst = -1; + selLast = 0; /* lint. */ + if (textInfoPtr->selItemPtr == itemPtr) { + selFirst = textInfoPtr->selectFirst; + selLast = textInfoPtr->selectLast; + if (selLast >= textPtr->numChars) { + selLast = textPtr->numChars - 1; + } + if ((selFirst >= 0) && (selFirst <= selLast)) { + /* + * Draw a special background under the selection. + */ + + int xFirst, yFirst, hFirst; + int xLast, yLast, wLast; + + Tk_CharBbox(textPtr->textLayout, selFirst, + &xFirst, &yFirst, NULL, &hFirst); + Tk_CharBbox(textPtr->textLayout, selLast, + &xLast, &yLast, &wLast, NULL); + + /* + * If the selection spans the end of this line, then display + * selection background all the way to the end of the line. + * However, for the last line we only want to display up to the + * last character, not the end of the line. + */ + + x = xFirst; + height = hFirst; + for (y = yFirst ; y <= yLast; y += height) { + if (y == yLast) { + width = (xLast + wLast) - x; + } else { + width = textPtr->rightEdge - textPtr->leftEdge - x; + } + Tk_CanvasDrawableCoords(canvas, + (double) (textPtr->leftEdge + x + - textInfoPtr->selBorderWidth), + (double) (textPtr->header.y1 + y), + &drawableX, &drawableY); + Tk_Fill3DRectangle(Tk_CanvasTkwin(canvas), drawable, + textInfoPtr->selBorder, drawableX, drawableY, + width + 2 * textInfoPtr->selBorderWidth, + height, textInfoPtr->selBorderWidth, TK_RELIEF_RAISED); + x = 0; + } + } + } + + /* + * If the insertion point should be displayed, then draw a special + * background for the cursor before drawing the text. Note: if + * we're the cursor item but the cursor is turned off, then redraw + * background over the area of the cursor. This guarantees that + * the selection won't make the cursor invisible on mono displays, + * where both are drawn in the same color. + */ + + if ((textInfoPtr->focusItemPtr == itemPtr) && (textInfoPtr->gotFocus)) { + if (Tk_CharBbox(textPtr->textLayout, textPtr->insertPos, + &x, &y, NULL, &height)) { + Tk_CanvasDrawableCoords(canvas, + (double) (textPtr->leftEdge + x + - (textInfoPtr->insertWidth / 2)), + (double) (textPtr->header.y1 + y), + &drawableX, &drawableY); + if (textInfoPtr->cursorOn) { + Tk_Fill3DRectangle(Tk_CanvasTkwin(canvas), drawable, + textInfoPtr->insertBorder, + drawableX, drawableY, + textInfoPtr->insertWidth, height, + textInfoPtr->insertBorderWidth, TK_RELIEF_RAISED); + } else if (textPtr->cursorOffGC != None) { + /* + * Redraw the background over the area of the cursor, + * even though the cursor is turned off. This + * guarantees that the selection won't make the cursor + * invisible on mono displays, where both may be drawn + * in the same color. + */ + + XFillRectangle(display, drawable, textPtr->cursorOffGC, + drawableX, drawableY, + (unsigned) textInfoPtr->insertWidth, + (unsigned) height); + } + } + } + + + /* + * Display the text in two pieces: draw the entire text item, then + * draw the selected text on top of it. The selected text then + * will only need to be drawn if it has different attributes (such + * as foreground color) than regular text. + */ + + Tk_CanvasDrawableCoords(canvas, (double) textPtr->leftEdge, + (double) textPtr->header.y1, &drawableX, &drawableY); + Tk_DrawTextLayout(display, drawable, textPtr->gc, textPtr->textLayout, + drawableX, drawableY, 0, -1); + + if ((selFirst >= 0) && (textPtr->selTextGC != textPtr->gc)) { + Tk_DrawTextLayout(display, drawable, textPtr->selTextGC, + textPtr->textLayout, drawableX, drawableY, selFirst, + selLast + 1); + } + + if (textPtr->stipple != None) { + XSetTSOrigin(display, textPtr->gc, 0, 0); + } +} + +/* + *-------------------------------------------------------------- + * + * TextInsert -- + * + * Insert characters into a text item at a given position. + * + * Results: + * None. + * + * Side effects: + * The text in the given item is modified. The cursor and + * selection positions are also modified to reflect the + * insertion. + * + *-------------------------------------------------------------- + */ + +static void +TextInsert(canvas, itemPtr, beforeThis, 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 + * to be inserted. */ + char *string; /* New characters to be inserted. */ +{ + TextItem *textPtr = (TextItem *) itemPtr; + int length; + char *new; + Tk_CanvasTextInfo *textInfoPtr = textPtr->textInfoPtr; + + length = strlen(string); + if (length == 0) { + return; + } + if (beforeThis < 0) { + beforeThis = 0; + } + if (beforeThis > textPtr->numChars) { + beforeThis = textPtr->numChars; + } + + 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); + textPtr->text = new; + textPtr->numChars += length; + + /* + * Inserting characters invalidates indices such as those for the + * selection and cursor. Update the indices appropriately. + */ + + if (textInfoPtr->selItemPtr == itemPtr) { + if (textInfoPtr->selectFirst >= beforeThis) { + textInfoPtr->selectFirst += length; + } + if (textInfoPtr->selectLast >= beforeThis) { + textInfoPtr->selectLast += length; + } + if ((textInfoPtr->anchorItemPtr == itemPtr) + && (textInfoPtr->selectAnchor >= beforeThis)) { + textInfoPtr->selectAnchor += length; + } + } + if (textPtr->insertPos >= beforeThis) { + textPtr->insertPos += length; + } + ComputeTextBbox(canvas, textPtr); +} + +/* + *-------------------------------------------------------------- + * + * TextDeleteChars -- + * + * Delete one or more characters from a text item. + * + * Results: + * None. + * + * Side effects: + * Characters between "first" and "last", inclusive, get + * deleted from itemPtr, and things like the selection + * position get updated. + * + *-------------------------------------------------------------- + */ + +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. */ +{ + TextItem *textPtr = (TextItem *) itemPtr; + int count; + char *new; + Tk_CanvasTextInfo *textInfoPtr = textPtr->textInfoPtr; + + if (first < 0) { + first = 0; + } + if (last >= textPtr->numChars) { + last = textPtr->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); + textPtr->text = new; + textPtr->numChars -= count; + + /* + * Update indexes for the selection and cursor to reflect the + * renumbering of the remaining characters. + */ + + if (textInfoPtr->selItemPtr == itemPtr) { + if (textInfoPtr->selectFirst > first) { + textInfoPtr->selectFirst -= count; + if (textInfoPtr->selectFirst < first) { + textInfoPtr->selectFirst = first; + } + } + if (textInfoPtr->selectLast >= first) { + textInfoPtr->selectLast -= count; + if (textInfoPtr->selectLast < (first-1)) { + textInfoPtr->selectLast = (first-1); + } + } + if (textInfoPtr->selectFirst > textInfoPtr->selectLast) { + textInfoPtr->selItemPtr = NULL; + } + if ((textInfoPtr->anchorItemPtr == itemPtr) + && (textInfoPtr->selectAnchor > first)) { + textInfoPtr->selectAnchor -= count; + if (textInfoPtr->selectAnchor < first) { + textInfoPtr->selectAnchor = first; + } + } + } + if (textPtr->insertPos > first) { + textPtr->insertPos -= count; + if (textPtr->insertPos < first) { + textPtr->insertPos = first; + } + } + ComputeTextBbox(canvas, textPtr); + return; +} + +/* + *-------------------------------------------------------------- + * + * TextToPoint -- + * + * Computes the distance from a given point to a given + * text item, in canvas units. + * + * Results: + * The return value is 0 if the point whose x and y coordinates + * are pointPtr[0] and pointPtr[1] is inside the text item. If + * the point isn't inside the text item then the return value + * is the distance from the point to the text item. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static double +TextToPoint(canvas, itemPtr, pointPtr) + Tk_Canvas canvas; /* Canvas containing itemPtr. */ + Tk_Item *itemPtr; /* Item to check against point. */ + double *pointPtr; /* Pointer to x and y coordinates. */ +{ + TextItem *textPtr; + + textPtr = (TextItem *) itemPtr; + return (double) Tk_DistanceToTextLayout(textPtr->textLayout, + (int) pointPtr[0] - textPtr->leftEdge, + (int) pointPtr[1] - textPtr->header.y1); +} + +/* + *-------------------------------------------------------------- + * + * TextToArea -- + * + * This procedure is called to determine whether an item + * lies entirely inside, entirely outside, or overlapping + * a given rectangle. + * + * Results: + * -1 is returned if the item is entirely outside the area + * given by rectPtr, 0 if it overlaps, and 1 if it is entirely + * inside the given area. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static int +TextToArea(canvas, itemPtr, rectPtr) + Tk_Canvas canvas; /* Canvas containing itemPtr. */ + Tk_Item *itemPtr; /* Item to check against rectangle. */ + double *rectPtr; /* Pointer to array of four coordinates + * (x1, y1, x2, y2) describing rectangular + * area. */ +{ + TextItem *textPtr; + + textPtr = (TextItem *) itemPtr; + return Tk_IntersectTextLayout(textPtr->textLayout, + (int) (rectPtr[0] + 0.5) - textPtr->leftEdge, + (int) (rectPtr[1] + 0.5) - textPtr->header.y1, + (int) (rectPtr[2] - rectPtr[0] + 0.5), + (int) (rectPtr[3] - rectPtr[1] + 0.5)); +} + +/* + *-------------------------------------------------------------- + * + * ScaleText -- + * + * This procedure is invoked to rescale a text item. + * + * Results: + * None. + * + * Side effects: + * Scales the position of the text, but not the size + * of the font for the text. + * + *-------------------------------------------------------------- + */ + + /* 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. */ +{ + TextItem *textPtr = (TextItem *) itemPtr; + + textPtr->x = originX + scaleX*(textPtr->x - originX); + textPtr->y = originY + scaleY*(textPtr->y - originY); + ComputeTextBbox(canvas, textPtr); + return; +} + +/* + *-------------------------------------------------------------- + * + * TranslateText -- + * + * This procedure is called to move a text item by a + * given amount. + * + * Results: + * None. + * + * Side effects: + * The position of the text item is offset by (xDelta, yDelta), + * and the bounding box is updated in the generic part of the + * item structure. + * + *-------------------------------------------------------------- + */ + +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. */ +{ + TextItem *textPtr = (TextItem *) itemPtr; + + textPtr->x += deltaX; + textPtr->y += deltaY; + ComputeTextBbox(canvas, textPtr); +} + +/* + *-------------------------------------------------------------- + * + * GetTextIndex -- + * + * Parse an index into a text item and return either its value + * or an error. + * + * Results: + * 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. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static int +GetTextIndex(interp, canvas, itemPtr, string, indexPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tk_Canvas canvas; /* Canvas containing item. */ + Tk_Item *itemPtr; /* Item for which the index is being + * specified. */ + char *string; /* Specification of a particular character + * in itemPtr's text. */ + int *indexPtr; /* Where to store converted index. */ +{ + TextItem *textPtr = (TextItem *) itemPtr; + size_t length; + int c; + TkCanvas *canvasPtr = (TkCanvas *) canvas; + Tk_CanvasTextInfo *textInfoPtr = textPtr->textInfoPtr; + + c = string[0]; + length = strlen(string); + + if ((c == 'e') && (strncmp(string, "end", length) == 0)) { + *indexPtr = textPtr->numChars; + } else if ((c == 'i') && (strncmp(string, "insert", length) == 0)) { + *indexPtr = textPtr->insertPos; + } else if ((c == 's') && (strncmp(string, "sel.first", length) == 0) + && (length >= 5)) { + if (textInfoPtr->selItemPtr != itemPtr) { + interp->result = "selection isn't in item"; + 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"; + return TCL_ERROR; + } + *indexPtr = textInfoPtr->selectLast; + } else if (c == '@') { + int x, y; + double tmp; + char *end, *p; + + p = string+1; + tmp = strtod(p, &end); + if ((end == p) || (*end != ',')) { + goto badIndex; + } + x = (int) ((tmp < 0) ? tmp - 0.5 : tmp + 0.5); + p = end+1; + tmp = strtod(p, &end); + if ((end == p) || (*end != 0)) { + goto badIndex; + } + y = (int) ((tmp < 0) ? tmp - 0.5 : tmp + 0.5); + *indexPtr = Tk_PointToChar(textPtr->textLayout, + x + canvasPtr->scrollX1 - textPtr->leftEdge, + y + canvasPtr->scrollY1 - textPtr->header.y1); + } else if (Tcl_GetInt(interp, string, indexPtr) == TCL_OK) { + if (*indexPtr < 0){ + *indexPtr = 0; + } else if (*indexPtr > textPtr->numChars) { + *indexPtr = textPtr->numChars; + } + } else { + /* + * Some of the paths here leave messages in interp->result, + * so we have to clear it out before storing our own message. + */ + + badIndex: + Tcl_SetResult(interp, (char *) NULL, TCL_STATIC); + Tcl_AppendResult(interp, "bad index \"", string, "\"", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * SetTextCursor -- + * + * Set the position of the insertion cursor in this item. + * + * Results: + * None. + * + * Side effects: + * The cursor position will change. + * + *-------------------------------------------------------------- + */ + + /* 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. */ +{ + TextItem *textPtr = (TextItem *) itemPtr; + + if (index < 0) { + textPtr->insertPos = 0; + } else if (index > textPtr->numChars) { + textPtr->insertPos = textPtr->numChars; + } else { + textPtr->insertPos = index; + } +} + +/* + *-------------------------------------------------------------- + * + * GetSelText -- + * + * This procedure is invoked to return the selected portion + * of a text item. It is only called when this item has + * the selection. + * + * Results: + * The return value is the number of non-NULL bytes stored + * at buffer. Buffer is filled (or partially filled) with a + * NULL-terminated string containing part or all of the selection, + * as given by offset and maxBytes. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +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. */ +{ + TextItem *textPtr = (TextItem *) itemPtr; + int count; + Tk_CanvasTextInfo *textInfoPtr = textPtr->textInfoPtr; + + count = textInfoPtr->selectLast + 1 - textInfoPtr->selectFirst - offset; + if (textInfoPtr->selectLast == textPtr->numChars) { + count -= 1; + } + if (count > maxBytes) { + count = maxBytes; + } + if (count <= 0) { + return 0; + } + strncpy(buffer, textPtr->text + textInfoPtr->selectFirst + offset, + (size_t) count); + buffer[count] = '\0'; + return count; +} + +/* + *-------------------------------------------------------------- + * + * TextToPostscript -- + * + * This procedure is called to generate Postscript for + * text items. + * + * 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. If no error occurs, then Postscript for the + * item is appended to the result. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +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. */ +{ + TextItem *textPtr = (TextItem *) itemPtr; + int x, y; + Tk_FontMetrics fm; + char *justify; + char buffer[500]; + + if (textPtr->color == NULL) { + return TCL_OK; + } + + if (Tk_CanvasPsFont(interp, canvas, textPtr->tkfont) != TCL_OK) { + return TCL_ERROR; + } + if (prepass != 0) { + return TCL_OK; + } + if (Tk_CanvasPsColor(interp, canvas, textPtr->color) != TCL_OK) { + return TCL_ERROR; + } + if (textPtr->stipple != None) { + Tcl_AppendResult(interp, "/StippleText {\n ", + (char *) NULL); + Tk_CanvasPsStipple(interp, canvas, textPtr->stipple); + Tcl_AppendResult(interp, "} bind def\n", (char *) NULL); + } + + sprintf(buffer, "%.15g %.15g [\n", textPtr->x, + Tk_CanvasPsY(canvas, textPtr->y)); + Tcl_AppendResult(interp, buffer, (char *) NULL); + + Tk_TextLayoutToPostscript(interp, textPtr->textLayout); + + x = 0; y = 0; justify = NULL; /* lint. */ + switch (textPtr->anchor) { + case TK_ANCHOR_NW: x = 0; y = 0; break; + case TK_ANCHOR_N: x = 1; y = 0; break; + case TK_ANCHOR_NE: x = 2; y = 0; break; + case TK_ANCHOR_E: x = 2; y = 1; break; + case TK_ANCHOR_SE: x = 2; y = 2; break; + case TK_ANCHOR_S: x = 1; y = 2; break; + case TK_ANCHOR_SW: x = 0; y = 2; break; + case TK_ANCHOR_W: x = 0; y = 1; break; + case TK_ANCHOR_CENTER: x = 1; y = 1; break; + } + switch (textPtr->justify) { + case TK_JUSTIFY_LEFT: justify = "0"; break; + case TK_JUSTIFY_CENTER: justify = "0.5";break; + case TK_JUSTIFY_RIGHT: justify = "1"; break; + } + + Tk_GetFontMetrics(textPtr->tkfont, &fm); + sprintf(buffer, "] %d %g %g %s %s DrawText\n", + fm.linespace, x / -2.0, y / 2.0, justify, + ((textPtr->stipple == None) ? "false" : "true")); + Tcl_AppendResult(interp, buffer, (char *) NULL); + + return TCL_OK; +} diff --git a/generic/tkCanvUtil.c b/generic/tkCanvUtil.c new file mode 100644 index 0000000..9b52a80 --- /dev/null +++ b/generic/tkCanvUtil.c @@ -0,0 +1,376 @@ +/* + * tkCanvUtil.c -- + * + * This procedure contains a collection of utility procedures + * used by the implementations of various canvas item types. + * + * Copyright (c) 1994 Sun Microsystems, Inc. + * Copyright (c) 1994 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: @(#) tkCanvUtil.c 1.7 96/05/03 10:54:22 + */ + +#include "tk.h" +#include "tkCanvas.h" +#include "tkPort.h" + + +/* + *---------------------------------------------------------------------- + * + * Tk_CanvasTkwin -- + * + * Given a token for a canvas, this procedure returns the + * widget that represents the canvas. + * + * Results: + * The return value is a handle for the widget. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tk_Window +Tk_CanvasTkwin(canvas) + Tk_Canvas canvas; /* Token for the canvas. */ +{ + TkCanvas *canvasPtr = (TkCanvas *) canvas; + return canvasPtr->tkwin; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_CanvasDrawableCoords -- + * + * Given an (x,y) coordinate pair within a canvas, this procedure + * returns the corresponding coordinates at which the point should + * be drawn in the drawable used for display. + * + * Results: + * There is no return value. The values at *drawableXPtr and + * *drawableYPtr are filled in with the coordinates at which + * x and y should be drawn. These coordinates are clipped + * to fit within a "short", since this is what X uses in + * most cases for drawing. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tk_CanvasDrawableCoords(canvas, x, y, drawableXPtr, drawableYPtr) + Tk_Canvas canvas; /* Token for the canvas. */ + double x, y; /* Coordinates in canvas space. */ + short *drawableXPtr, *drawableYPtr; /* Screen coordinates are stored + * here. */ +{ + TkCanvas *canvasPtr = (TkCanvas *) canvas; + double tmp; + + tmp = x - canvasPtr->drawableXOrigin; + if (tmp > 0) { + tmp += 0.5; + } else { + tmp -= 0.5; + } + if (tmp > 32767) { + *drawableXPtr = 32767; + } else if (tmp < -32768) { + *drawableXPtr = -32768; + } else { + *drawableXPtr = (short) tmp; + } + + tmp = y - canvasPtr->drawableYOrigin; + if (tmp > 0) { + tmp += 0.5; + } else { + tmp -= 0.5; + } + if (tmp > 32767) { + *drawableYPtr = 32767; + } else if (tmp < -32768) { + *drawableYPtr = -32768; + } else { + *drawableYPtr = (short) tmp; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tk_CanvasWindowCoords -- + * + * Given an (x,y) coordinate pair within a canvas, this procedure + * returns the corresponding coordinates in the canvas's window. + * + * Results: + * There is no return value. The values at *screenXPtr and + * *screenYPtr are filled in with the coordinates at which + * (x,y) appears in the canvas's window. These coordinates + * are clipped to fit within a "short", since this is what X + * uses in most cases for drawing. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tk_CanvasWindowCoords(canvas, x, y, screenXPtr, screenYPtr) + Tk_Canvas canvas; /* Token for the canvas. */ + double x, y; /* Coordinates in canvas space. */ + short *screenXPtr, *screenYPtr; /* Screen coordinates are stored + * here. */ +{ + TkCanvas *canvasPtr = (TkCanvas *) canvas; + double tmp; + + tmp = x - canvasPtr->xOrigin; + if (tmp > 0) { + tmp += 0.5; + } else { + tmp -= 0.5; + } + if (tmp > 32767) { + *screenXPtr = 32767; + } else if (tmp < -32768) { + *screenXPtr = -32768; + } else { + *screenXPtr = (short) tmp; + } + + tmp = y - canvasPtr->yOrigin; + if (tmp > 0) { + tmp += 0.5; + } else { + tmp -= 0.5; + } + if (tmp > 32767) { + *screenYPtr = 32767; + } else if (tmp < -32768) { + *screenYPtr = -32768; + } else { + *screenYPtr = (short) tmp; + } +} + +/* + *-------------------------------------------------------------- + * + * Tk_CanvasGetCoord -- + * + * Given a string, returns a floating-point canvas coordinate + * corresponding to that string. + * + * Results: + * The return value is a standard Tcl return result. If + * 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. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +int +Tk_CanvasGetCoord(interp, canvas, string, doublePtr) + Tcl_Interp *interp; /* Interpreter for error reporting. */ + Tk_Canvas canvas; /* Canvas to which coordinate applies. */ + char *string; /* Describes coordinate (any screen + * coordinate form may be used here). */ + double *doublePtr; /* Place to store converted coordinate. */ +{ + TkCanvas *canvasPtr = (TkCanvas *) canvas; + if (Tk_GetScreenMM(canvasPtr->interp, canvasPtr->tkwin, string, + doublePtr) != TCL_OK) { + return TCL_ERROR; + } + *doublePtr *= canvasPtr->pixelsPerMM; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_CanvasSetStippleOrigin -- + * + * This procedure sets the stipple origin in a graphics context + * so that stipples drawn with the GC will line up with other + * stipples previously drawn in the canvas. + * + * Results: + * None. + * + * Side effects: + * The graphics context is modified. + * + *---------------------------------------------------------------------- + */ + +void +Tk_CanvasSetStippleOrigin(canvas, gc) + Tk_Canvas canvas; /* Token for a canvas. */ + GC gc; /* Graphics context that is about to be + * used to draw a stippled pattern as + * part of redisplaying the canvas. */ + +{ + TkCanvas *canvasPtr = (TkCanvas *) canvas; + + XSetTSOrigin(canvasPtr->display, gc, -canvasPtr->drawableXOrigin, + -canvasPtr->drawableYOrigin); +} + +/* + *---------------------------------------------------------------------- + * + * Tk_CanvasGetTextInfo -- + * + * This procedure returns a pointer to a structure containing + * information about the selection and insertion cursor for + * a canvas widget. Items such as text items save the pointer + * and use it to share access to the information with the generic + * canvas code. + * + * Results: + * The return value is a pointer to the structure holding text + * information for the canvas. Most of the fields should not + * be modified outside the generic canvas code; see the user + * documentation for details. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tk_CanvasTextInfo * +Tk_CanvasGetTextInfo(canvas) + Tk_Canvas canvas; /* Token for the canvas widget. */ +{ + return &((TkCanvas *) canvas)->textInfo; +} + +/* + *-------------------------------------------------------------- + * + * Tk_CanvasTagsParseProc -- + * + * This procedure is invoked during option processing to handle + * "-tags" options for canvas items. + * + * Results: + * A standard Tcl return value. + * + * Side effects: + * The tags for a given item get replaced by those indicated + * in the value argument. + * + *-------------------------------------------------------------- + */ + +int +Tk_CanvasTagsParseProc(clientData, interp, tkwin, value, widgRec, offset) + ClientData clientData; /* Not used.*/ + Tcl_Interp *interp; /* Used for reporting errors. */ + Tk_Window tkwin; /* Window containing canvas widget. */ + char *value; /* Value of option (list of tag + * names). */ + char *widgRec; /* Pointer to record for item. */ + int offset; /* Offset into item (ignored). */ +{ + register Tk_Item *itemPtr = (Tk_Item *) widgRec; + int argc, i; + char **argv; + Tk_Uid *newPtr; + + /* + * Break the value up into the individual tag names. + */ + + if (Tcl_SplitList(interp, value, &argc, &argv) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Make sure that there's enough space in the item to hold the + * tag names. + */ + + if (itemPtr->tagSpace < argc) { + newPtr = (Tk_Uid *) ckalloc((unsigned) (argc * sizeof(Tk_Uid))); + for (i = itemPtr->numTags-1; i >= 0; i--) { + newPtr[i] = itemPtr->tagPtr[i]; + } + if (itemPtr->tagPtr != itemPtr->staticTagSpace) { + ckfree((char *) itemPtr->tagPtr); + } + itemPtr->tagPtr = newPtr; + itemPtr->tagSpace = argc; + } + itemPtr->numTags = argc; + for (i = 0; i < argc; i++) { + itemPtr->tagPtr[i] = Tk_GetUid(argv[i]); + } + ckfree((char *) argv); + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * Tk_CanvasTagsPrintProc -- + * + * This procedure is invoked by the Tk configuration code + * to produce a printable string for the "-tags" configuration + * option for canvas items. + * + * Results: + * The return value is a string describing all the tags for + * the item referred to by "widgRec". In addition, *freeProcPtr + * is filled in with the address of a procedure to call to free + * the result string when it's no longer needed (or NULL to + * indicate that the string doesn't need to be freed). + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +char * +Tk_CanvasTagsPrintProc(clientData, tkwin, widgRec, offset, freeProcPtr) + ClientData clientData; /* Ignored. */ + Tk_Window tkwin; /* Window containing canvas widget. */ + char *widgRec; /* Pointer to record for item. */ + int offset; /* Ignored. */ + Tcl_FreeProc **freeProcPtr; /* Pointer to variable to fill in with + * information about how to reclaim + * storage for return string. */ +{ + register Tk_Item *itemPtr = (Tk_Item *) widgRec; + + if (itemPtr->numTags == 0) { + *freeProcPtr = (Tcl_FreeProc *) NULL; + return ""; + } + if (itemPtr->numTags == 1) { + *freeProcPtr = (Tcl_FreeProc *) NULL; + return (char *) itemPtr->tagPtr[0]; + } + *freeProcPtr = TCL_DYNAMIC; + return Tcl_Merge(itemPtr->numTags, (char **) itemPtr->tagPtr); +} diff --git a/generic/tkCanvWind.c b/generic/tkCanvWind.c new file mode 100644 index 0000000..61b21da --- /dev/null +++ b/generic/tkCanvWind.c @@ -0,0 +1,862 @@ +/* + * tkCanvWind.c -- + * + * This file implements window items for canvas widgets. + * + * Copyright (c) 1992-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: @(#) tkCanvWind.c 1.29 97/10/14 10:40:54 + */ + +#include +#include "tkInt.h" +#include "tkPort.h" +#include "tkCanvas.h" + +/* + * The structure below defines the record for each window item. + */ + +typedef struct WindowItem { + Tk_Item header; /* Generic stuff that's the same for all + * types. MUST BE FIRST IN STRUCTURE. */ + double x, y; /* Coordinates of positioning point for + * window. */ + Tk_Window tkwin; /* Window associated with item. NULL means + * window has been destroyed. */ + int width; /* Width to use for window (<= 0 means use + * window's requested width). */ + int height; /* Width to use for window (<= 0 means use + * window's requested width). */ + Tk_Anchor anchor; /* Where to anchor window relative to + * (x,y). */ + Tk_Canvas canvas; /* Canvas containing this item. */ +} WindowItem; + +/* + * Information used for parsing configuration specs: + */ + +static Tk_CustomOption tagsOption = {Tk_CanvasTagsParseProc, + Tk_CanvasTagsPrintProc, (ClientData) NULL +}; + +static Tk_ConfigSpec configSpecs[] = { + {TK_CONFIG_ANCHOR, "-anchor", (char *) NULL, (char *) NULL, + "center", Tk_Offset(WindowItem, anchor), TK_CONFIG_DONT_SET_DEFAULT}, + {TK_CONFIG_PIXELS, "-height", (char *) NULL, (char *) NULL, + "0", Tk_Offset(WindowItem, height), TK_CONFIG_DONT_SET_DEFAULT}, + {TK_CONFIG_CUSTOM, "-tags", (char *) NULL, (char *) NULL, + (char *) NULL, 0, TK_CONFIG_NULL_OK, &tagsOption}, + {TK_CONFIG_PIXELS, "-width", (char *) NULL, (char *) NULL, + "0", Tk_Offset(WindowItem, width), TK_CONFIG_DONT_SET_DEFAULT}, + {TK_CONFIG_WINDOW, "-window", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(WindowItem, tkwin), TK_CONFIG_NULL_OK}, + {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, 0} +}; + +/* + * Prototypes for procedures defined in this file: + */ + +static void ComputeWindowBbox _ANSI_ARGS_((Tk_Canvas canvas, + WindowItem *winItemPtr)); +static int ConfigureWinItem _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int argc, + char **argv, int flags)); +static int CreateWinItem _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, struct Tk_Item *itemPtr, + int argc, char **argv)); +static void DeleteWinItem _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, Display *display)); +static void DisplayWinItem _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, Display *display, Drawable dst, + int x, int y, int width, int height)); +static void ScaleWinItem _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double originX, double originY, + double scaleX, double scaleY)); +static void TranslateWinItem _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double deltaX, double deltaY)); +static int WinItemCoords _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int argc, + char **argv)); +static void WinItemLostSlaveProc _ANSI_ARGS_(( + ClientData clientData, Tk_Window tkwin)); +static void WinItemRequestProc _ANSI_ARGS_((ClientData clientData, + Tk_Window tkwin)); +static void WinItemStructureProc _ANSI_ARGS_(( + ClientData clientData, XEvent *eventPtr)); +static int WinItemToArea _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double *rectPtr)); +static double WinItemToPoint _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double *pointPtr)); + +/* + * The structure below defines the window item type by means of procedures + * that can be invoked by generic item code. + */ + +Tk_ItemType tkWindowType = { + "window", /* name */ + sizeof(WindowItem), /* itemSize */ + CreateWinItem, /* createProc */ + configSpecs, /* configSpecs */ + ConfigureWinItem, /* configureProc */ + WinItemCoords, /* coordProc */ + DeleteWinItem, /* deleteProc */ + DisplayWinItem, /* displayProc */ + 1, /* alwaysRedraw */ + WinItemToPoint, /* pointProc */ + WinItemToArea, /* areaProc */ + (Tk_ItemPostscriptProc *) NULL, /* postscriptProc */ + ScaleWinItem, /* scaleProc */ + TranslateWinItem, /* translateProc */ + (Tk_ItemIndexProc *) NULL, /* indexProc */ + (Tk_ItemCursorProc *) NULL, /* cursorProc */ + (Tk_ItemSelectionProc *) NULL, /* selectionProc */ + (Tk_ItemInsertProc *) NULL, /* insertProc */ + (Tk_ItemDCharsProc *) NULL, /* dTextProc */ + (Tk_ItemType *) NULL /* nextPtr */ +}; + + +/* + * The structure below defines the official type record for the + * placer: + */ + +static Tk_GeomMgr canvasGeomType = { + "canvas", /* name */ + WinItemRequestProc, /* requestProc */ + WinItemLostSlaveProc, /* lostSlaveProc */ +}; + +/* + *-------------------------------------------------------------- + * + * CreateWinItem -- + * + * This procedure is invoked to create a new window + * item in a canvas. + * + * 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, so it can be safely freed by the + * caller. + * + * Side effects: + * A new window item is created. + * + *-------------------------------------------------------------- + */ + +static int +CreateWinItem(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. */ +{ + WindowItem *winItemPtr = (WindowItem *) itemPtr; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + Tk_PathName(Tk_CanvasTkwin(canvas)), " create ", + itemPtr->typePtr->name, " x y ?options?\"", + (char *) NULL); + return TCL_ERROR; + } + + /* + * Initialize item's record. + */ + + winItemPtr->tkwin = NULL; + winItemPtr->width = 0; + winItemPtr->height = 0; + winItemPtr->anchor = TK_ANCHOR_CENTER; + winItemPtr->canvas = canvas; + + /* + * Process the arguments to fill in the item record. + */ + + if ((Tk_CanvasGetCoord(interp, canvas, argv[0], &winItemPtr->x) != TCL_OK) + || (Tk_CanvasGetCoord(interp, canvas, argv[1], + &winItemPtr->y) != TCL_OK)) { + return TCL_ERROR; + } + + if (ConfigureWinItem(interp, canvas, itemPtr, argc-2, argv+2, 0) + != TCL_OK) { + DeleteWinItem(canvas, itemPtr, Tk_Display(Tk_CanvasTkwin(canvas))); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * WinItemCoords -- + * + * This procedure is invoked to process the "coords" widget + * command on window items. See the user documentation for + * details on what it does. + * + * Results: + * Returns TCL_OK or TCL_ERROR, and sets interp->result. + * + * Side effects: + * The coordinates for the given item may be changed. + * + *-------------------------------------------------------------- + */ + +static int +WinItemCoords(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, ... */ +{ + WindowItem *winItemPtr = (WindowItem *) itemPtr; + char x[TCL_DOUBLE_SPACE], y[TCL_DOUBLE_SPACE]; + + if (argc == 0) { + Tcl_PrintDouble(interp, winItemPtr->x, x); + Tcl_PrintDouble(interp, winItemPtr->y, y); + Tcl_AppendResult(interp, x, " ", y, (char *) NULL); + } else if (argc == 2) { + if ((Tk_CanvasGetCoord(interp, canvas, argv[0], &winItemPtr->x) + != TCL_OK) || (Tk_CanvasGetCoord(interp, canvas, argv[1], + &winItemPtr->y) != TCL_OK)) { + return TCL_ERROR; + } + ComputeWindowBbox(canvas, winItemPtr); + } else { + sprintf(interp->result, + "wrong # coordinates: expected 0 or 2, got %d", argc); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * ConfigureWinItem -- + * + * This procedure is invoked to configure various aspects + * of a window item, such as its anchor position. + * + * Results: + * A standard Tcl result code. If an error occurs, then + * an error message is left in interp->result. + * + * Side effects: + * Configuration information may be set for itemPtr. + * + *-------------------------------------------------------------- + */ + +static int +ConfigureWinItem(interp, canvas, itemPtr, argc, argv, flags) + Tcl_Interp *interp; /* Used for error reporting. */ + Tk_Canvas canvas; /* Canvas containing itemPtr. */ + Tk_Item *itemPtr; /* Window item to reconfigure. */ + int argc; /* Number of elements in argv. */ + char **argv; /* Arguments describing things to configure. */ + int flags; /* Flags to pass to Tk_ConfigureWidget. */ +{ + WindowItem *winItemPtr = (WindowItem *) itemPtr; + Tk_Window oldWindow; + Tk_Window canvasTkwin; + + oldWindow = winItemPtr->tkwin; + canvasTkwin = Tk_CanvasTkwin(canvas); + if (Tk_ConfigureWidget(interp, canvasTkwin, configSpecs, argc, argv, + (char *) winItemPtr, flags) != TCL_OK) { + return TCL_ERROR; + } + + /* + * A few of the options require additional processing. + */ + + if (oldWindow != winItemPtr->tkwin) { + if (oldWindow != NULL) { + Tk_DeleteEventHandler(oldWindow, StructureNotifyMask, + WinItemStructureProc, (ClientData) winItemPtr); + Tk_ManageGeometry(oldWindow, (Tk_GeomMgr *) NULL, + (ClientData) NULL); + Tk_UnmaintainGeometry(oldWindow, canvasTkwin); + Tk_UnmapWindow(oldWindow); + } + if (winItemPtr->tkwin != NULL) { + Tk_Window ancestor, parent; + + /* + * Make sure that the canvas is either the parent of the + * window associated with the item or a descendant of that + * parent. Also, don't allow a top-level window to be + * managed inside a canvas. + */ + + parent = Tk_Parent(winItemPtr->tkwin); + for (ancestor = canvasTkwin; ; + ancestor = Tk_Parent(ancestor)) { + if (ancestor == parent) { + break; + } + if (((Tk_FakeWin *) (ancestor))->flags & TK_TOP_LEVEL) { + badWindow: + Tcl_AppendResult(interp, "can't use ", + Tk_PathName(winItemPtr->tkwin), + " in a window item of this canvas", (char *) NULL); + winItemPtr->tkwin = NULL; + return TCL_ERROR; + } + } + if (((Tk_FakeWin *) (winItemPtr->tkwin))->flags & TK_TOP_LEVEL) { + goto badWindow; + } + if (winItemPtr->tkwin == canvasTkwin) { + goto badWindow; + } + Tk_CreateEventHandler(winItemPtr->tkwin, StructureNotifyMask, + WinItemStructureProc, (ClientData) winItemPtr); + Tk_ManageGeometry(winItemPtr->tkwin, &canvasGeomType, + (ClientData) winItemPtr); + } + } + + ComputeWindowBbox(canvas, winItemPtr); + + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * DeleteWinItem -- + * + * This procedure is called to clean up the data structure + * associated with a window item. + * + * Results: + * None. + * + * Side effects: + * Resources associated with itemPtr are released. + * + *-------------------------------------------------------------- + */ + +static void +DeleteWinItem(canvas, itemPtr, display) + Tk_Canvas canvas; /* Overall info about widget. */ + Tk_Item *itemPtr; /* Item that is being deleted. */ + Display *display; /* Display containing window for + * canvas. */ +{ + WindowItem *winItemPtr = (WindowItem *) itemPtr; + Tk_Window canvasTkwin = Tk_CanvasTkwin(canvas); + + if (winItemPtr->tkwin != NULL) { + Tk_DeleteEventHandler(winItemPtr->tkwin, StructureNotifyMask, + WinItemStructureProc, (ClientData) winItemPtr); + Tk_ManageGeometry(winItemPtr->tkwin, (Tk_GeomMgr *) NULL, + (ClientData) NULL); + if (canvasTkwin != Tk_Parent(winItemPtr->tkwin)) { + Tk_UnmaintainGeometry(winItemPtr->tkwin, canvasTkwin); + } + Tk_UnmapWindow(winItemPtr->tkwin); + } +} + +/* + *-------------------------------------------------------------- + * + * ComputeWindowBbox -- + * + * This procedure is invoked to compute the bounding box of + * all the pixels that may be drawn as part of a window item. + * This procedure is where the child window's placement is + * computed. + * + * Results: + * None. + * + * Side effects: + * The fields x1, y1, x2, and y2 are updated in the header + * for itemPtr. + * + *-------------------------------------------------------------- + */ + +static void +ComputeWindowBbox(canvas, winItemPtr) + Tk_Canvas canvas; /* Canvas that contains item. */ + WindowItem *winItemPtr; /* Item whose bbox is to be + * recomputed. */ +{ + int width, height, x, y; + + x = (int) (winItemPtr->x + ((winItemPtr->x >= 0) ? 0.5 : - 0.5)); + y = (int) (winItemPtr->y + ((winItemPtr->y >= 0) ? 0.5 : - 0.5)); + + if (winItemPtr->tkwin == NULL) { + /* + * There is no window for this item yet. Just give it a 1x1 + * bounding box. Don't give it a 0x0 bounding box; there are + * strange cases where this bounding box might be used as the + * dimensions of the window, and 0x0 causes problems under X. + */ + + winItemPtr->header.x1 = x; + winItemPtr->header.x2 = winItemPtr->header.x1 + 1; + winItemPtr->header.y1 = y; + winItemPtr->header.y2 = winItemPtr->header.y1 + 1; + return; + } + + /* + * Compute dimensions of window. + */ + + width = winItemPtr->width; + if (width <= 0) { + width = Tk_ReqWidth(winItemPtr->tkwin); + if (width <= 0) { + width = 1; + } + } + height = winItemPtr->height; + if (height <= 0) { + height = Tk_ReqHeight(winItemPtr->tkwin); + if (height <= 0) { + height = 1; + } + } + + /* + * Compute location of window, using anchor information. + */ + + switch (winItemPtr->anchor) { + case TK_ANCHOR_N: + x -= width/2; + break; + case TK_ANCHOR_NE: + x -= width; + break; + case TK_ANCHOR_E: + x -= width; + y -= height/2; + break; + case TK_ANCHOR_SE: + x -= width; + y -= height; + break; + case TK_ANCHOR_S: + x -= width/2; + y -= height; + break; + case TK_ANCHOR_SW: + y -= height; + break; + case TK_ANCHOR_W: + y -= height/2; + break; + case TK_ANCHOR_NW: + break; + case TK_ANCHOR_CENTER: + x -= width/2; + y -= height/2; + break; + } + + /* + * Store the information in the item header. + */ + + winItemPtr->header.x1 = x; + winItemPtr->header.y1 = y; + winItemPtr->header.x2 = x + width; + winItemPtr->header.y2 = y + height; +} + +/* + *-------------------------------------------------------------- + * + * DisplayWinItem -- + * + * This procedure is invoked to "draw" a window item in a given + * drawable. Since the window draws itself, we needn't do any + * actual redisplay here. However, this procedure takes care + * of actually repositioning the child window so that it occupies + * the correct screen position. + * + * Results: + * None. + * + * Side effects: + * The child window's position may get changed. Note: this + * procedure gets called both when a window needs to be displayed + * and when it ceases to be visible on the screen (e.g. it was + * scrolled or moved off-screen or the enclosing canvas is + * unmapped). + * + *-------------------------------------------------------------- + */ + +static void +DisplayWinItem(canvas, itemPtr, display, drawable, regionX, regionY, + regionWidth, regionHeight) + 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 regionX, regionY, regionWidth, regionHeight; + /* Describes region of canvas that + * must be redisplayed (not used). */ +{ + WindowItem *winItemPtr = (WindowItem *) itemPtr; + int width, height; + short x, y; + Tk_Window canvasTkwin = Tk_CanvasTkwin(canvas); + + if (winItemPtr->tkwin == NULL) { + return; + } + + Tk_CanvasWindowCoords(canvas, (double) winItemPtr->header.x1, + (double) winItemPtr->header.y1, &x, &y); + width = winItemPtr->header.x2 - winItemPtr->header.x1; + height = winItemPtr->header.y2 - winItemPtr->header.y1; + + /* + * If the window is completely out of the visible area of the canvas + * then unmap it. This code used not to be present (why unmap the + * window if it isn't visible anyway?) but this could cause the + * window to suddenly reappear if the canvas window got resized. + */ + + if (((x + width) <= 0) || ((y + height) <= 0) + || (x >= Tk_Width(canvasTkwin)) || (y >= Tk_Height(canvasTkwin))) { + if (canvasTkwin == Tk_Parent(winItemPtr->tkwin)) { + Tk_UnmapWindow(winItemPtr->tkwin); + } else { + Tk_UnmaintainGeometry(winItemPtr->tkwin, canvasTkwin); + } + return; + } + + /* + * Reposition and map the window (but in different ways depending + * on whether the canvas is the window's parent). + */ + + if (canvasTkwin == Tk_Parent(winItemPtr->tkwin)) { + if ((x != Tk_X(winItemPtr->tkwin)) || (y != Tk_Y(winItemPtr->tkwin)) + || (width != Tk_Width(winItemPtr->tkwin)) + || (height != Tk_Height(winItemPtr->tkwin))) { + Tk_MoveResizeWindow(winItemPtr->tkwin, x, y, width, height); + } + Tk_MapWindow(winItemPtr->tkwin); + } else { + Tk_MaintainGeometry(winItemPtr->tkwin, canvasTkwin, x, y, + width, height); + } +} + +/* + *-------------------------------------------------------------- + * + * WinItemToPoint -- + * + * Computes the distance from a given point to a given + * rectangle, in canvas units. + * + * Results: + * The return value is 0 if the point whose x and y coordinates + * are coordPtr[0] and coordPtr[1] is inside the window. If the + * point isn't inside the window then the return value is the + * distance from the point to the window. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static double +WinItemToPoint(canvas, itemPtr, pointPtr) + Tk_Canvas canvas; /* Canvas containing item. */ + Tk_Item *itemPtr; /* Item to check against point. */ + double *pointPtr; /* Pointer to x and y coordinates. */ +{ + WindowItem *winItemPtr = (WindowItem *) itemPtr; + double x1, x2, y1, y2, xDiff, yDiff; + + x1 = winItemPtr->header.x1; + y1 = winItemPtr->header.y1; + x2 = winItemPtr->header.x2; + y2 = winItemPtr->header.y2; + + /* + * Point is outside rectangle. + */ + + if (pointPtr[0] < x1) { + xDiff = x1 - pointPtr[0]; + } else if (pointPtr[0] >= x2) { + xDiff = pointPtr[0] + 1 - x2; + } else { + xDiff = 0; + } + + if (pointPtr[1] < y1) { + yDiff = y1 - pointPtr[1]; + } else if (pointPtr[1] >= y2) { + yDiff = pointPtr[1] + 1 - y2; + } else { + yDiff = 0; + } + + return hypot(xDiff, yDiff); +} + +/* + *-------------------------------------------------------------- + * + * WinItemToArea -- + * + * This procedure is called to determine whether an item + * lies entirely inside, entirely outside, or overlapping + * a given rectangle. + * + * Results: + * -1 is returned if the item is entirely outside the area + * given by rectPtr, 0 if it overlaps, and 1 if it is entirely + * inside the given area. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static int +WinItemToArea(canvas, itemPtr, rectPtr) + Tk_Canvas canvas; /* Canvas containing item. */ + Tk_Item *itemPtr; /* Item to check against rectangle. */ + double *rectPtr; /* Pointer to array of four coordinates + * (x1, y1, x2, y2) describing rectangular + * area. */ +{ + WindowItem *winItemPtr = (WindowItem *) itemPtr; + + if ((rectPtr[2] <= winItemPtr->header.x1) + || (rectPtr[0] >= winItemPtr->header.x2) + || (rectPtr[3] <= winItemPtr->header.y1) + || (rectPtr[1] >= winItemPtr->header.y2)) { + return -1; + } + if ((rectPtr[0] <= winItemPtr->header.x1) + && (rectPtr[1] <= winItemPtr->header.y1) + && (rectPtr[2] >= winItemPtr->header.x2) + && (rectPtr[3] >= winItemPtr->header.y2)) { + return 1; + } + return 0; +} + +/* + *-------------------------------------------------------------- + * + * ScaleWinItem -- + * + * This procedure is invoked to rescale a rectangle or oval + * item. + * + * Results: + * None. + * + * Side effects: + * The rectangle or oval referred to by itemPtr is rescaled + * so that the following transformation is applied to all + * point coordinates: + * x' = originX + scaleX*(x-originX) + * y' = originY + scaleY*(y-originY) + * + *-------------------------------------------------------------- + */ + +static void +ScaleWinItem(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. */ +{ + WindowItem *winItemPtr = (WindowItem *) itemPtr; + + winItemPtr->x = originX + scaleX*(winItemPtr->x - originX); + winItemPtr->y = originY + scaleY*(winItemPtr->y - originY); + if (winItemPtr->width > 0) { + winItemPtr->width = (int) (scaleX*winItemPtr->width); + } + if (winItemPtr->height > 0) { + winItemPtr->height = (int) (scaleY*winItemPtr->height); + } + ComputeWindowBbox(canvas, winItemPtr); +} + +/* + *-------------------------------------------------------------- + * + * TranslateWinItem -- + * + * This procedure is called to move a rectangle or oval by a + * given amount. + * + * Results: + * None. + * + * Side effects: + * The position of the rectangle or oval is offset by + * (xDelta, yDelta), and the bounding box is updated in the + * generic part of the item structure. + * + *-------------------------------------------------------------- + */ + +static void +TranslateWinItem(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. */ +{ + WindowItem *winItemPtr = (WindowItem *) itemPtr; + + winItemPtr->x += deltaX; + winItemPtr->y += deltaY; + ComputeWindowBbox(canvas, winItemPtr); +} + +/* + *-------------------------------------------------------------- + * + * WinItemStructureProc -- + * + * This procedure is invoked whenever StructureNotify events + * occur for a window that's managed as part of a canvas window + * item. This procudure's only purpose is to clean up when + * windows are deleted. + * + * Results: + * None. + * + * Side effects: + * The window is disassociated from the window item when it is + * deleted. + * + *-------------------------------------------------------------- + */ + +static void +WinItemStructureProc(clientData, eventPtr) + ClientData clientData; /* Pointer to record describing window item. */ + XEvent *eventPtr; /* Describes what just happened. */ +{ + WindowItem *winItemPtr = (WindowItem *) clientData; + + if (eventPtr->type == DestroyNotify) { + winItemPtr->tkwin = NULL; + } +} + +/* + *-------------------------------------------------------------- + * + * WinItemRequestProc -- + * + * This procedure is invoked whenever a window that's associated + * with a window canvas item changes its requested dimensions. + * + * Results: + * None. + * + * Side effects: + * The size and location on the screen of the window may change, + * depending on the options specified for the window item. + * + *-------------------------------------------------------------- + */ + +static void +WinItemRequestProc(clientData, tkwin) + ClientData clientData; /* Pointer to record for window item. */ + Tk_Window tkwin; /* Window that changed its desired + * size. */ +{ + WindowItem *winItemPtr = (WindowItem *) clientData; + + ComputeWindowBbox(winItemPtr->canvas, winItemPtr); + DisplayWinItem(winItemPtr->canvas, (Tk_Item *) winItemPtr, + (Display *) NULL, (Drawable) None, 0, 0, 0, 0); +} + +/* + *-------------------------------------------------------------- + * + * WinItemLostSlaveProc -- + * + * This procedure is invoked by Tk whenever some other geometry + * claims control over a slave that used to be managed by us. + * + * Results: + * None. + * + * Side effects: + * Forgets all canvas-related information about the slave. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +WinItemLostSlaveProc(clientData, tkwin) + ClientData clientData; /* WindowItem structure for slave window that + * was stolen away. */ + Tk_Window tkwin; /* Tk's handle for the slave window. */ +{ + WindowItem *winItemPtr = (WindowItem *) clientData; + Tk_Window canvasTkwin = Tk_CanvasTkwin(winItemPtr->canvas); + + Tk_DeleteEventHandler(winItemPtr->tkwin, StructureNotifyMask, + WinItemStructureProc, (ClientData) winItemPtr); + if (canvasTkwin != Tk_Parent(winItemPtr->tkwin)) { + Tk_UnmaintainGeometry(winItemPtr->tkwin, canvasTkwin); + } + Tk_UnmapWindow(winItemPtr->tkwin); + winItemPtr->tkwin = NULL; +} diff --git a/generic/tkCanvas.c b/generic/tkCanvas.c new file mode 100644 index 0000000..b093226 --- /dev/null +++ b/generic/tkCanvas.c @@ -0,0 +1,3791 @@ +/* + * tkCanvas.c -- + * + * This module implements canvas widgets for the Tk toolkit. + * A canvas displays a background and a collection of graphical + * 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. + * + * 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 + */ + +#include "default.h" +#include "tkInt.h" +#include "tkPort.h" +#include "tkCanvas.h" + +/* + * See tkCanvas.h for key data structures used to implement canvases. + */ + +/* + * The structure defined below is used to keep track of a tag search + * in progress. Only the "prevPtr" field should be accessed by anyone + * other than StartTagSearch and NextItem. + */ + +typedef struct TagSearch { + TkCanvas *canvasPtr; /* Canvas widget being searched. */ + Tk_Uid tag; /* Tag to search for. 0 means return + * all items. */ + Tk_Item *prevPtr; /* Item just before last one found (or NULL + * if last one found was first in the item + * list of canvasPtr). */ + Tk_Item *currentPtr; /* Pointer to last item returned. */ + int searchOver; /* Non-zero means NextItem should always + * return NULL. */ +} TagSearch; + +/* + * Information used for argv parsing. + */ + +static Tk_ConfigSpec configSpecs[] = { + {TK_CONFIG_BORDER, "-background", "background", "Background", + DEF_CANVAS_BG_COLOR, Tk_Offset(TkCanvas, bgBorder), + TK_CONFIG_COLOR_ONLY}, + {TK_CONFIG_BORDER, "-background", "background", "Background", + DEF_CANVAS_BG_MONO, Tk_Offset(TkCanvas, 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", + DEF_CANVAS_BORDER_WIDTH, Tk_Offset(TkCanvas, borderWidth), 0}, + {TK_CONFIG_DOUBLE, "-closeenough", "closeEnough", "CloseEnough", + DEF_CANVAS_CLOSE_ENOUGH, Tk_Offset(TkCanvas, closeEnough), 0}, + {TK_CONFIG_BOOLEAN, "-confine", "confine", "Confine", + DEF_CANVAS_CONFINE, Tk_Offset(TkCanvas, confine), 0}, + {TK_CONFIG_ACTIVE_CURSOR, "-cursor", "cursor", "Cursor", + DEF_CANVAS_CURSOR, Tk_Offset(TkCanvas, cursor), TK_CONFIG_NULL_OK}, + {TK_CONFIG_PIXELS, "-height", "height", "Height", + DEF_CANVAS_HEIGHT, Tk_Offset(TkCanvas, height), 0}, + {TK_CONFIG_COLOR, "-highlightbackground", "highlightBackground", + "HighlightBackground", DEF_CANVAS_HIGHLIGHT_BG, + Tk_Offset(TkCanvas, highlightBgColorPtr), 0}, + {TK_CONFIG_COLOR, "-highlightcolor", "highlightColor", "HighlightColor", + DEF_CANVAS_HIGHLIGHT, Tk_Offset(TkCanvas, highlightColorPtr), 0}, + {TK_CONFIG_PIXELS, "-highlightthickness", "highlightThickness", + "HighlightThickness", + DEF_CANVAS_HIGHLIGHT_WIDTH, Tk_Offset(TkCanvas, highlightWidth), 0}, + {TK_CONFIG_BORDER, "-insertbackground", "insertBackground", "Foreground", + DEF_CANVAS_INSERT_BG, Tk_Offset(TkCanvas, textInfo.insertBorder), 0}, + {TK_CONFIG_PIXELS, "-insertborderwidth", "insertBorderWidth", "BorderWidth", + DEF_CANVAS_INSERT_BD_COLOR, + Tk_Offset(TkCanvas, textInfo.insertBorderWidth), TK_CONFIG_COLOR_ONLY}, + {TK_CONFIG_PIXELS, "-insertborderwidth", "insertBorderWidth", "BorderWidth", + DEF_CANVAS_INSERT_BD_MONO, + Tk_Offset(TkCanvas, textInfo.insertBorderWidth), TK_CONFIG_MONO_ONLY}, + {TK_CONFIG_INT, "-insertofftime", "insertOffTime", "OffTime", + DEF_CANVAS_INSERT_OFF_TIME, Tk_Offset(TkCanvas, insertOffTime), 0}, + {TK_CONFIG_INT, "-insertontime", "insertOnTime", "OnTime", + DEF_CANVAS_INSERT_ON_TIME, Tk_Offset(TkCanvas, insertOnTime), 0}, + {TK_CONFIG_PIXELS, "-insertwidth", "insertWidth", "InsertWidth", + DEF_CANVAS_INSERT_WIDTH, Tk_Offset(TkCanvas, textInfo.insertWidth), 0}, + {TK_CONFIG_RELIEF, "-relief", "relief", "Relief", + DEF_CANVAS_RELIEF, Tk_Offset(TkCanvas, relief), 0}, + {TK_CONFIG_STRING, "-scrollregion", "scrollRegion", "ScrollRegion", + DEF_CANVAS_SCROLL_REGION, Tk_Offset(TkCanvas, regionString), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_BORDER, "-selectbackground", "selectBackground", "Foreground", + DEF_CANVAS_SELECT_COLOR, Tk_Offset(TkCanvas, textInfo.selBorder), + TK_CONFIG_COLOR_ONLY}, + {TK_CONFIG_BORDER, "-selectbackground", "selectBackground", "Foreground", + DEF_CANVAS_SELECT_MONO, Tk_Offset(TkCanvas, textInfo.selBorder), + TK_CONFIG_MONO_ONLY}, + {TK_CONFIG_PIXELS, "-selectborderwidth", "selectBorderWidth", "BorderWidth", + DEF_CANVAS_SELECT_BD_COLOR, + Tk_Offset(TkCanvas, textInfo.selBorderWidth), TK_CONFIG_COLOR_ONLY}, + {TK_CONFIG_PIXELS, "-selectborderwidth", "selectBorderWidth", "BorderWidth", + DEF_CANVAS_SELECT_BD_MONO, Tk_Offset(TkCanvas, textInfo.selBorderWidth), + TK_CONFIG_MONO_ONLY}, + {TK_CONFIG_COLOR, "-selectforeground", "selectForeground", "Background", + DEF_CANVAS_SELECT_FG_COLOR, Tk_Offset(TkCanvas, textInfo.selFgColorPtr), + TK_CONFIG_COLOR_ONLY}, + {TK_CONFIG_COLOR, "-selectforeground", "selectForeground", "Background", + DEF_CANVAS_SELECT_FG_MONO, Tk_Offset(TkCanvas, textInfo.selFgColorPtr), + TK_CONFIG_MONO_ONLY}, + {TK_CONFIG_STRING, "-takefocus", "takeFocus", "TakeFocus", + DEF_CANVAS_TAKE_FOCUS, Tk_Offset(TkCanvas, takeFocus), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_PIXELS, "-width", "width", "Width", + DEF_CANVAS_WIDTH, Tk_Offset(TkCanvas, width), 0}, + {TK_CONFIG_STRING, "-xscrollcommand", "xScrollCommand", "ScrollCommand", + DEF_CANVAS_X_SCROLL_CMD, Tk_Offset(TkCanvas, xScrollCmd), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_PIXELS, "-xscrollincrement", "xScrollIncrement", + "ScrollIncrement", + DEF_CANVAS_X_SCROLL_INCREMENT, Tk_Offset(TkCanvas, xScrollIncrement), + 0}, + {TK_CONFIG_STRING, "-yscrollcommand", "yScrollCommand", "ScrollCommand", + DEF_CANVAS_Y_SCROLL_CMD, Tk_Offset(TkCanvas, yScrollCmd), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_PIXELS, "-yscrollincrement", "yScrollIncrement", + "ScrollIncrement", + DEF_CANVAS_Y_SCROLL_INCREMENT, Tk_Offset(TkCanvas, yScrollIncrement), + 0}, + {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, 0} +}; + +/* + * List of all the item types known at present: + */ + +static Tk_ItemType *typeList = NULL; /* NULL means initialization hasn't + * been done yet. */ + +/* + * Standard item types provided by Tk: + */ + +extern Tk_ItemType tkArcType, tkBitmapType, tkImageType, tkLineType; +extern Tk_ItemType tkOvalType, tkPolygonType; +extern Tk_ItemType tkRectangleType, tkTextType, tkWindowType; + +/* + * Various Tk_Uid's used by this module (set up during initialization): + */ + +static Tk_Uid allUid = NULL; +static Tk_Uid currentUid = NULL; + +/* + * Statistics counters: + */ + +static int numIdSearches; +static int numSlowSearches; + +/* + * Prototypes for procedures defined later in this file: + */ + +static void CanvasBindProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +static void CanvasBlinkProc _ANSI_ARGS_((ClientData clientData)); +static void CanvasCmdDeletedProc _ANSI_ARGS_(( + ClientData clientData)); +static void CanvasDoEvent _ANSI_ARGS_((TkCanvas *canvasPtr, + XEvent *eventPtr)); +static void CanvasEventProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +static int CanvasFetchSelection _ANSI_ARGS_(( + ClientData clientData, int offset, + char *buffer, int maxBytes)); +static Tk_Item * CanvasFindClosest _ANSI_ARGS_((TkCanvas *canvasPtr, + double coords[2])); +static void CanvasFocusProc _ANSI_ARGS_((TkCanvas *canvasPtr, + int gotFocus)); +static void CanvasLostSelection _ANSI_ARGS_(( + ClientData clientData)); +static void CanvasSelectTo _ANSI_ARGS_((TkCanvas *canvasPtr, + Tk_Item *itemPtr, int index)); +static void CanvasSetOrigin _ANSI_ARGS_((TkCanvas *canvasPtr, + int xOrigin, int yOrigin)); +static void CanvasUpdateScrollbars _ANSI_ARGS_(( + TkCanvas *canvasPtr)); +static int CanvasWidgetCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static void CanvasWorldChanged _ANSI_ARGS_(( + ClientData instanceData)); +static int ConfigureCanvas _ANSI_ARGS_((Tcl_Interp *interp, + TkCanvas *canvasPtr, int argc, char **argv, + int flags)); +static void DestroyCanvas _ANSI_ARGS_((char *memPtr)); +static void DisplayCanvas _ANSI_ARGS_((ClientData clientData)); +static void DoItem _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Item *itemPtr, Tk_Uid tag)); +static int FindItems _ANSI_ARGS_((Tcl_Interp *interp, + TkCanvas *canvasPtr, int argc, char **argv, + char *newTag, char *cmdName, char *option)); +static int FindArea _ANSI_ARGS_((Tcl_Interp *interp, + TkCanvas *canvasPtr, char **argv, Tk_Uid uid, + int enclosed)); +static double GridAlign _ANSI_ARGS_((double coord, double spacing)); +static void InitCanvas _ANSI_ARGS_((void)); +static Tk_Item * NextItem _ANSI_ARGS_((TagSearch *searchPtr)); +static void PickCurrentItem _ANSI_ARGS_((TkCanvas *canvasPtr, + XEvent *eventPtr)); +static void PrintScrollFractions _ANSI_ARGS_((int screen1, + int screen2, int object1, int object2, + char *string)); +static void RelinkItems _ANSI_ARGS_((TkCanvas *canvasPtr, + char *tag, Tk_Item *prevPtr)); +static Tk_Item * StartTagSearch _ANSI_ARGS_((TkCanvas *canvasPtr, + char *tag, TagSearch *searchPtr)); + +/* + * The structure below defines canvas class behavior by means of procedures + * that can be invoked from generic window code. + */ + +static TkClassProcs canvasClass = { + NULL, /* createProc. */ + CanvasWorldChanged, /* geometryProc. */ + NULL /* modalProc. */ +}; + + +/* + *-------------------------------------------------------------- + * + * Tk_CanvasCmd -- + * + * This procedure is invoked to process the "canvas" 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_CanvasCmd(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; + TkCanvas *canvasPtr; + Tk_Window new; + + if (typeList == NULL) { + InitCanvas(); + } + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " pathName ?options?\"", (char *) NULL); + return TCL_ERROR; + } + + new = Tk_CreateWindowFromPath(interp, tkwin, argv[1], (char *) NULL); + if (new == NULL) { + return TCL_ERROR; + } + + /* + * Initialize fields that won't be initialized by ConfigureCanvas, + * or which ConfigureCanvas expects to have reasonable values + * (e.g. resource pointers). + */ + + canvasPtr = (TkCanvas *) ckalloc(sizeof(TkCanvas)); + canvasPtr->tkwin = new; + canvasPtr->display = Tk_Display(new); + canvasPtr->interp = interp; + canvasPtr->widgetCmd = Tcl_CreateCommand(interp, + Tk_PathName(canvasPtr->tkwin), CanvasWidgetCmd, + (ClientData) canvasPtr, CanvasCmdDeletedProc); + canvasPtr->firstItemPtr = NULL; + canvasPtr->lastItemPtr = NULL; + canvasPtr->borderWidth = 0; + canvasPtr->bgBorder = NULL; + canvasPtr->relief = TK_RELIEF_FLAT; + canvasPtr->highlightWidth = 0; + canvasPtr->highlightBgColorPtr = NULL; + canvasPtr->highlightColorPtr = NULL; + canvasPtr->inset = 0; + canvasPtr->pixmapGC = None; + canvasPtr->width = None; + canvasPtr->height = None; + canvasPtr->confine = 0; + canvasPtr->textInfo.selBorder = NULL; + canvasPtr->textInfo.selBorderWidth = 0; + canvasPtr->textInfo.selFgColorPtr = NULL; + canvasPtr->textInfo.selItemPtr = NULL; + canvasPtr->textInfo.selectFirst = -1; + canvasPtr->textInfo.selectLast = -1; + canvasPtr->textInfo.anchorItemPtr = NULL; + canvasPtr->textInfo.selectAnchor = 0; + canvasPtr->textInfo.insertBorder = NULL; + canvasPtr->textInfo.insertWidth = 0; + canvasPtr->textInfo.insertBorderWidth = 0; + canvasPtr->textInfo.focusItemPtr = NULL; + canvasPtr->textInfo.gotFocus = 0; + canvasPtr->textInfo.cursorOn = 0; + canvasPtr->insertOnTime = 0; + canvasPtr->insertOffTime = 0; + canvasPtr->insertBlinkHandler = (Tcl_TimerToken) NULL; + canvasPtr->xOrigin = canvasPtr->yOrigin = 0; + canvasPtr->drawableXOrigin = canvasPtr->drawableYOrigin = 0; + canvasPtr->bindingTable = NULL; + canvasPtr->currentItemPtr = NULL; + canvasPtr->newCurrentPtr = NULL; + canvasPtr->closeEnough = 0.0; + canvasPtr->pickEvent.type = LeaveNotify; + canvasPtr->pickEvent.xcrossing.x = 0; + canvasPtr->pickEvent.xcrossing.y = 0; + canvasPtr->state = 0; + canvasPtr->xScrollCmd = NULL; + canvasPtr->yScrollCmd = NULL; + canvasPtr->scrollX1 = 0; + canvasPtr->scrollY1 = 0; + canvasPtr->scrollX2 = 0; + canvasPtr->scrollY2 = 0; + canvasPtr->regionString = NULL; + canvasPtr->xScrollIncrement = 0; + canvasPtr->yScrollIncrement = 0; + canvasPtr->scanX = 0; + canvasPtr->scanXOrigin = 0; + canvasPtr->scanY = 0; + canvasPtr->scanYOrigin = 0; + canvasPtr->hotPtr = NULL; + canvasPtr->hotPrevPtr = NULL; + canvasPtr->cursor = None; + canvasPtr->takeFocus = NULL; + canvasPtr->pixelsPerMM = WidthOfScreen(Tk_Screen(new)); + canvasPtr->pixelsPerMM /= WidthMMOfScreen(Tk_Screen(new)); + canvasPtr->flags = 0; + canvasPtr->nextId = 1; + canvasPtr->psInfoPtr = NULL; + + Tk_SetClass(canvasPtr->tkwin, "Canvas"); + TkSetClassProcs(canvasPtr->tkwin, &canvasClass, (ClientData) canvasPtr); + Tk_CreateEventHandler(canvasPtr->tkwin, + ExposureMask|StructureNotifyMask|FocusChangeMask, + CanvasEventProc, (ClientData) canvasPtr); + Tk_CreateEventHandler(canvasPtr->tkwin, KeyPressMask|KeyReleaseMask + |ButtonPressMask|ButtonReleaseMask|EnterWindowMask + |LeaveWindowMask|PointerMotionMask|VirtualEventMask, + CanvasBindProc, (ClientData) canvasPtr); + Tk_CreateSelHandler(canvasPtr->tkwin, XA_PRIMARY, XA_STRING, + CanvasFetchSelection, (ClientData) canvasPtr, XA_STRING); + if (ConfigureCanvas(interp, canvasPtr, argc-2, argv+2, 0) != TCL_OK) { + goto error; + } + + interp->result = Tk_PathName(canvasPtr->tkwin); + return TCL_OK; + + error: + Tk_DestroyWindow(canvasPtr->tkwin); + return TCL_ERROR; +} + +/* + *-------------------------------------------------------------- + * + * CanvasWidgetCmd -- + * + * This procedure is invoked to process the Tcl command + * that corresponds to a widget managed by this module. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +static int +CanvasWidgetCmd(clientData, interp, argc, argv) + ClientData clientData; /* Information about canvas + * widget. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + TkCanvas *canvasPtr = (TkCanvas *) clientData; + size_t length; + int c, result; + Tk_Item *itemPtr = NULL; /* Initialization needed only to + * prevent compiler warning. */ + TagSearch search; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " option ?arg arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_Preserve((ClientData) canvasPtr); + result = TCL_OK; + c = argv[1][0]; + length = strlen(argv[1]); + if ((c == 'a') && (strncmp(argv[1], "addtag", length) == 0)) { + if (argc < 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " addtags tag searchCommand ?arg arg ...?\"", + (char *) NULL); + goto error; + } + result = FindItems(interp, canvasPtr, argc-3, argv+3, argv[2], argv[0], + " addtag tag"); + } else if ((c == 'b') && (strncmp(argv[1], "bbox", length) == 0) + && (length >= 2)) { + int i, gotAny; + int x1 = 0, y1 = 0, x2 = 0, y2 = 0; /* Initializations needed + * only to prevent compiler + * warnings. */ + + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " bbox tagOrId ?tagOrId ...?\"", + (char *) NULL); + goto error; + } + gotAny = 0; + for (i = 2; i < argc; i++) { + for (itemPtr = StartTagSearch(canvasPtr, argv[i], &search); + itemPtr != NULL; itemPtr = NextItem(&search)) { + if ((itemPtr->x1 >= itemPtr->x2) + || (itemPtr->y1 >= itemPtr->y2)) { + continue; + } + if (!gotAny) { + x1 = itemPtr->x1; + y1 = itemPtr->y1; + x2 = itemPtr->x2; + y2 = itemPtr->y2; + gotAny = 1; + } else { + if (itemPtr->x1 < x1) { + x1 = itemPtr->x1; + } + if (itemPtr->y1 < y1) { + y1 = itemPtr->y1; + } + if (itemPtr->x2 > x2) { + x2 = itemPtr->x2; + } + if (itemPtr->y2 > y2) { + y2 = itemPtr->y2; + } + } + } + } + if (gotAny) { + sprintf(interp->result, "%d %d %d %d", x1, y1, x2, y2); + } + } else if ((c == 'b') && (strncmp(argv[1], "bind", length) == 0) + && (length >= 2)) { + ClientData object; + + if ((argc < 3) || (argc > 5)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " bind tagOrId ?sequence? ?command?\"", + (char *) NULL); + goto error; + } + + /* + * Figure out what object to use for the binding (individual + * item vs. tag). + */ + + object = 0; + if (isdigit(UCHAR(argv[2][0]))) { + int id; + char *end; + + id = strtoul(argv[2], &end, 0); + if (*end != 0) { + goto bindByTag; + } + for (itemPtr = canvasPtr->firstItemPtr; itemPtr != NULL; + itemPtr = itemPtr->nextPtr) { + if (itemPtr->id == id) { + object = (ClientData) itemPtr; + break; + } + } + if (object == 0) { + Tcl_AppendResult(interp, "item \"", argv[2], + "\" doesn't exist", (char *) NULL); + goto error; + } + } else { + bindByTag: + object = (ClientData) Tk_GetUid(argv[2]); + } + + /* + * Make a binding table if the canvas doesn't already have + * one. + */ + + if (canvasPtr->bindingTable == NULL) { + canvasPtr->bindingTable = Tk_CreateBindingTable(interp); + } + + if (argc == 5) { + int append = 0; + unsigned long mask; + + if (argv[4][0] == 0) { + result = Tk_DeleteBinding(interp, canvasPtr->bindingTable, + object, argv[3]); + goto done; + } + if (argv[4][0] == '+') { + argv[4]++; + append = 1; + } + mask = Tk_CreateBinding(interp, canvasPtr->bindingTable, + object, argv[3], argv[4], append); + if (mask == 0) { + goto error; + } + if (mask & (unsigned) ~(ButtonMotionMask|Button1MotionMask + |Button2MotionMask|Button3MotionMask|Button4MotionMask + |Button5MotionMask|ButtonPressMask|ButtonReleaseMask + |EnterWindowMask|LeaveWindowMask|KeyPressMask + |KeyReleaseMask|PointerMotionMask|VirtualEventMask)) { + Tk_DeleteBinding(interp, canvasPtr->bindingTable, + object, argv[3]); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "requested illegal events; ", + "only key, button, motion, enter, leave, and virtual ", + "events may be used", (char *) NULL); + goto error; + } + } else if (argc == 4) { + char *command; + + command = Tk_GetBinding(interp, canvasPtr->bindingTable, + object, argv[3]); + if (command == NULL) { + goto error; + } + interp->result = command; + } else { + Tk_GetAllBindings(interp, canvasPtr->bindingTable, object); + } + } else if ((c == 'c') && (strcmp(argv[1], "canvasx") == 0)) { + int x; + double grid; + + if ((argc < 3) || (argc > 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " canvasx screenx ?gridspacing?\"", + (char *) NULL); + goto error; + } + if (Tk_GetPixels(interp, canvasPtr->tkwin, argv[2], &x) != TCL_OK) { + goto error; + } + if (argc == 4) { + if (Tk_CanvasGetCoord(interp, (Tk_Canvas) canvasPtr, argv[3], + &grid) != TCL_OK) { + goto error; + } + } else { + grid = 0.0; + } + x += canvasPtr->xOrigin; + Tcl_PrintDouble(interp, GridAlign((double) x, grid), interp->result); + } else if ((c == 'c') && (strcmp(argv[1], "canvasy") == 0)) { + int y; + double grid; + + if ((argc < 3) || (argc > 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " canvasy screeny ?gridspacing?\"", + (char *) NULL); + goto error; + } + if (Tk_GetPixels(interp, canvasPtr->tkwin, argv[2], &y) != TCL_OK) { + goto error; + } + if (argc == 4) { + if (Tk_CanvasGetCoord(interp, (Tk_Canvas) canvasPtr, + argv[3], &grid) != TCL_OK) { + goto error; + } + } else { + grid = 0.0; + } + y += canvasPtr->yOrigin; + Tcl_PrintDouble(interp, GridAlign((double) y, grid), interp->result); + } 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; + } + result = Tk_ConfigureValue(interp, canvasPtr->tkwin, configSpecs, + (char *) canvasPtr, argv[2], 0); + } else if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0) + && (length >= 3)) { + if (argc == 2) { + result = Tk_ConfigureInfo(interp, canvasPtr->tkwin, configSpecs, + (char *) canvasPtr, (char *) NULL, 0); + } else if (argc == 3) { + result = Tk_ConfigureInfo(interp, canvasPtr->tkwin, configSpecs, + (char *) canvasPtr, argv[2], 0); + } else { + result = ConfigureCanvas(interp, canvasPtr, argc-2, argv+2, + TK_CONFIG_ARGV_ONLY); + } + } else if ((c == 'c') && (strncmp(argv[1], "coords", length) == 0) + && (length >= 3)) { + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " coords tagOrId ?x y x y ...?\"", + (char *) NULL); + goto error; + } + itemPtr = StartTagSearch(canvasPtr, argv[2], &search); + if (itemPtr != NULL) { + if (argc != 3) { + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + itemPtr->x1, itemPtr->y1, itemPtr->x2, itemPtr->y2); + } + if (itemPtr->typePtr->coordProc != NULL) { + result = (*itemPtr->typePtr->coordProc)(interp, + (Tk_Canvas) canvasPtr, itemPtr, argc-3, argv+3); + } + if (argc != 3) { + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + itemPtr->x1, itemPtr->y1, itemPtr->x2, itemPtr->y2); + } + } + } else if ((c == 'c') && (strncmp(argv[1], "create", length) == 0) + && (length >= 2)) { + Tk_ItemType *typePtr; + Tk_ItemType *matchPtr = NULL; + Tk_Item *itemPtr; + + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " create type ?arg arg ...?\"", (char *) NULL); + goto error; + } + c = argv[2][0]; + length = strlen(argv[2]); + for (typePtr = typeList; typePtr != NULL; typePtr = typePtr->nextPtr) { + if ((c == typePtr->name[0]) + && (strncmp(argv[2], typePtr->name, length) == 0)) { + if (matchPtr != NULL) { + badType: + Tcl_AppendResult(interp, + "unknown or ambiguous item type \"", + argv[2], "\"", (char *) NULL); + goto error; + } + matchPtr = typePtr; + } + } + if (matchPtr == NULL) { + goto badType; + } + typePtr = matchPtr; + itemPtr = (Tk_Item *) ckalloc((unsigned) typePtr->itemSize); + itemPtr->id = canvasPtr->nextId; + canvasPtr->nextId++; + itemPtr->tagPtr = itemPtr->staticTagSpace; + itemPtr->tagSpace = TK_TAG_SPACE; + itemPtr->numTags = 0; + itemPtr->typePtr = typePtr; + if ((*typePtr->createProc)(interp, (Tk_Canvas) canvasPtr, + itemPtr, argc-3, argv+3) != TCL_OK) { + ckfree((char *) itemPtr); + goto error; + } + itemPtr->nextPtr = NULL; + canvasPtr->hotPtr = itemPtr; + canvasPtr->hotPrevPtr = canvasPtr->lastItemPtr; + if (canvasPtr->lastItemPtr == NULL) { + canvasPtr->firstItemPtr = itemPtr; + } else { + canvasPtr->lastItemPtr->nextPtr = itemPtr; + } + canvasPtr->lastItemPtr = itemPtr; + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + itemPtr->x1, itemPtr->y1, itemPtr->x2, itemPtr->y2); + canvasPtr->flags |= REPICK_NEEDED; + sprintf(interp->result, "%d", itemPtr->id); + } else if ((c == 'd') && (strncmp(argv[1], "dchars", length) == 0) + && (length >= 2)) { + int first, last; + + if ((argc != 4) && (argc != 5)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " dchars tagOrId first ?last?\"", + (char *) NULL); + goto error; + } + for (itemPtr = StartTagSearch(canvasPtr, argv[2], &search); + itemPtr != NULL; itemPtr = NextItem(&search)) { + if ((itemPtr->typePtr->indexProc == NULL) + || (itemPtr->typePtr->dCharsProc == NULL)) { + continue; + } + if ((*itemPtr->typePtr->indexProc)(interp, (Tk_Canvas) canvasPtr, + itemPtr, argv[3], &first) != TCL_OK) { + goto error; + } + if (argc == 5) { + if ((*itemPtr->typePtr->indexProc)(interp, + (Tk_Canvas) canvasPtr, itemPtr, argv[4], &last) + != TCL_OK) { + goto error; + } + } else { + last = first; + } + + /* + * Redraw both item's old and new areas: it's possible + * that a delete could result in a new area larger than + * the old area. + */ + + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + itemPtr->x1, itemPtr->y1, itemPtr->x2, itemPtr->y2); + (*itemPtr->typePtr->dCharsProc)((Tk_Canvas) canvasPtr, + itemPtr, first, last); + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + itemPtr->x1, itemPtr->y1, itemPtr->x2, itemPtr->y2); + } + } else if ((c == 'd') && (strncmp(argv[1], "delete", length) == 0) + && (length >= 2)) { + int i; + + for (i = 2; i < argc; i++) { + for (itemPtr = StartTagSearch(canvasPtr, argv[i], &search); + itemPtr != NULL; itemPtr = NextItem(&search)) { + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + itemPtr->x1, itemPtr->y1, itemPtr->x2, itemPtr->y2); + if (canvasPtr->bindingTable != NULL) { + Tk_DeleteAllBindings(canvasPtr->bindingTable, + (ClientData) itemPtr); + } + (*itemPtr->typePtr->deleteProc)((Tk_Canvas) canvasPtr, itemPtr, + canvasPtr->display); + if (itemPtr->tagPtr != itemPtr->staticTagSpace) { + ckfree((char *) itemPtr->tagPtr); + } + if (search.prevPtr == NULL) { + canvasPtr->firstItemPtr = itemPtr->nextPtr; + if (canvasPtr->firstItemPtr == NULL) { + canvasPtr->lastItemPtr = NULL; + } + } else { + search.prevPtr->nextPtr = itemPtr->nextPtr; + } + if (canvasPtr->lastItemPtr == itemPtr) { + canvasPtr->lastItemPtr = search.prevPtr; + } + ckfree((char *) itemPtr); + if (itemPtr == canvasPtr->currentItemPtr) { + canvasPtr->currentItemPtr = NULL; + canvasPtr->flags |= REPICK_NEEDED; + } + if (itemPtr == canvasPtr->newCurrentPtr) { + canvasPtr->newCurrentPtr = NULL; + canvasPtr->flags |= REPICK_NEEDED; + } + if (itemPtr == canvasPtr->textInfo.focusItemPtr) { + canvasPtr->textInfo.focusItemPtr = NULL; + } + if (itemPtr == canvasPtr->textInfo.selItemPtr) { + canvasPtr->textInfo.selItemPtr = NULL; + } + if ((itemPtr == canvasPtr->hotPtr) + || (itemPtr == canvasPtr->hotPrevPtr)) { + canvasPtr->hotPtr = NULL; + } + } + } + } else if ((c == 'd') && (strncmp(argv[1], "dtag", length) == 0) + && (length >= 2)) { + Tk_Uid tag; + int i; + + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " dtag tagOrId ?tagToDelete?\"", + (char *) NULL); + goto error; + } + if (argc == 4) { + tag = Tk_GetUid(argv[3]); + } else { + tag = Tk_GetUid(argv[2]); + } + for (itemPtr = StartTagSearch(canvasPtr, argv[2], &search); + itemPtr != NULL; itemPtr = NextItem(&search)) { + for (i = itemPtr->numTags-1; i >= 0; i--) { + if (itemPtr->tagPtr[i] == tag) { + itemPtr->tagPtr[i] = itemPtr->tagPtr[itemPtr->numTags-1]; + itemPtr->numTags--; + } + } + } + } else if ((c == 'f') && (strncmp(argv[1], "find", length) == 0) + && (length >= 2)) { + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " find searchCommand ?arg arg ...?\"", + (char *) NULL); + goto error; + } + result = FindItems(interp, canvasPtr, argc-2, argv+2, (char *) NULL, + argv[0]," find"); + } else if ((c == 'f') && (strncmp(argv[1], "focus", length) == 0) + && (length >= 2)) { + if (argc > 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " focus ?tagOrId?\"", + (char *) NULL); + goto error; + } + itemPtr = canvasPtr->textInfo.focusItemPtr; + if (argc == 2) { + if (itemPtr != NULL) { + sprintf(interp->result, "%d", itemPtr->id); + } + goto done; + } + if ((itemPtr != NULL) && (canvasPtr->textInfo.gotFocus)) { + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + itemPtr->x1, itemPtr->y1, itemPtr->x2, itemPtr->y2); + } + if (argv[2][0] == 0) { + canvasPtr->textInfo.focusItemPtr = NULL; + goto done; + } + for (itemPtr = StartTagSearch(canvasPtr, argv[2], &search); + itemPtr != NULL; itemPtr = NextItem(&search)) { + if (itemPtr->typePtr->icursorProc != NULL) { + break; + } + } + if (itemPtr == NULL) { + goto done; + } + canvasPtr->textInfo.focusItemPtr = itemPtr; + if (canvasPtr->textInfo.gotFocus) { + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + itemPtr->x1, itemPtr->y1, itemPtr->x2, itemPtr->y2); + } + } else if ((c == 'g') && (strncmp(argv[1], "gettags", length) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " gettags tagOrId\"", (char *) NULL); + goto error; + } + itemPtr = StartTagSearch(canvasPtr, argv[2], &search); + if (itemPtr != NULL) { + int i; + for (i = 0; i < itemPtr->numTags; i++) { + Tcl_AppendElement(interp, (char *) itemPtr->tagPtr[i]); + } + } + } else if ((c == 'i') && (strncmp(argv[1], "icursor", length) == 0) + && (length >= 2)) { + int index; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " icursor tagOrId index\"", + (char *) NULL); + goto error; + } + for (itemPtr = StartTagSearch(canvasPtr, argv[2], &search); + itemPtr != NULL; itemPtr = NextItem(&search)) { + if ((itemPtr->typePtr->indexProc == NULL) + || (itemPtr->typePtr->icursorProc == NULL)) { + goto done; + } + if ((*itemPtr->typePtr->indexProc)(interp, (Tk_Canvas) canvasPtr, + itemPtr, argv[3], &index) != TCL_OK) { + goto error; + } + (*itemPtr->typePtr->icursorProc)((Tk_Canvas) canvasPtr, itemPtr, + index); + if ((itemPtr == canvasPtr->textInfo.focusItemPtr) + && (canvasPtr->textInfo.cursorOn)) { + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + itemPtr->x1, itemPtr->y1, itemPtr->x2, itemPtr->y2); + } + } + } else if ((c == 'i') && (strncmp(argv[1], "index", length) == 0) + && (length >= 3)) { + int index; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " index tagOrId string\"", + (char *) NULL); + goto error; + } + for (itemPtr = StartTagSearch(canvasPtr, argv[2], &search); + itemPtr != NULL; itemPtr = NextItem(&search)) { + if (itemPtr->typePtr->indexProc != NULL) { + break; + } + } + if (itemPtr == NULL) { + Tcl_AppendResult(interp, "can't find an indexable item \"", + argv[2], "\"", (char *) NULL); + goto error; + } + if ((*itemPtr->typePtr->indexProc)(interp, (Tk_Canvas) canvasPtr, + itemPtr, argv[3], &index) != TCL_OK) { + goto error; + } + sprintf(interp->result, "%d", index); + } else if ((c == 'i') && (strncmp(argv[1], "insert", length) == 0) + && (length >= 3)) { + int beforeThis; + + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " insert tagOrId beforeThis string\"", + (char *) NULL); + goto error; + } + for (itemPtr = StartTagSearch(canvasPtr, argv[2], &search); + itemPtr != NULL; itemPtr = NextItem(&search)) { + if ((itemPtr->typePtr->indexProc == NULL) + || (itemPtr->typePtr->insertProc == NULL)) { + continue; + } + if ((*itemPtr->typePtr->indexProc)(interp, (Tk_Canvas) canvasPtr, + itemPtr, argv[3], &beforeThis) != TCL_OK) { + goto error; + } + + /* + * Redraw both item's old and new areas: it's possible + * that an insertion could result in a new area either + * larger or smaller than the old area. + */ + + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + itemPtr->x1, itemPtr->y1, itemPtr->x2, itemPtr->y2); + (*itemPtr->typePtr->insertProc)((Tk_Canvas) canvasPtr, + itemPtr, beforeThis, argv[4]); + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, itemPtr->x1, + itemPtr->y1, itemPtr->x2, itemPtr->y2); + } + } else if ((c == 'i') && (strncmp(argv[1], "itemcget", length) == 0) + && (length >= 6)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " itemcget tagOrId option\"", + (char *) NULL); + return TCL_ERROR; + } + itemPtr = StartTagSearch(canvasPtr, argv[2], &search); + if (itemPtr != NULL) { + result = Tk_ConfigureValue(canvasPtr->interp, canvasPtr->tkwin, + itemPtr->typePtr->configSpecs, (char *) itemPtr, + argv[3], 0); + } + } else if ((c == 'i') && (strncmp(argv[1], "itemconfigure", length) == 0) + && (length >= 6)) { + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " itemconfigure tagOrId ?option value ...?\"", + (char *) NULL); + goto error; + } + for (itemPtr = StartTagSearch(canvasPtr, argv[2], &search); + itemPtr != NULL; itemPtr = NextItem(&search)) { + if (argc == 3) { + result = Tk_ConfigureInfo(canvasPtr->interp, canvasPtr->tkwin, + itemPtr->typePtr->configSpecs, (char *) itemPtr, + (char *) NULL, 0); + } else if (argc == 4) { + result = Tk_ConfigureInfo(canvasPtr->interp, canvasPtr->tkwin, + itemPtr->typePtr->configSpecs, (char *) itemPtr, + argv[3], 0); + } else { + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + itemPtr->x1, itemPtr->y1, itemPtr->x2, itemPtr->y2); + result = (*itemPtr->typePtr->configProc)(interp, + (Tk_Canvas) canvasPtr, itemPtr, argc-3, argv+3, + TK_CONFIG_ARGV_ONLY); + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + itemPtr->x1, itemPtr->y1, itemPtr->x2, itemPtr->y2); + canvasPtr->flags |= REPICK_NEEDED; + } + if ((result != TCL_OK) || (argc < 5)) { + break; + } + } + } else if ((c == 'l') && (strncmp(argv[1], "lower", length) == 0)) { + Tk_Item *prevPtr; + + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " lower tagOrId ?belowThis?\"", + (char *) NULL); + goto error; + } + + /* + * First find the item just after which we'll insert the + * named items. + */ + + if (argc == 3) { + prevPtr = NULL; + } else { + prevPtr = StartTagSearch(canvasPtr, argv[3], &search); + if (prevPtr != NULL) { + prevPtr = search.prevPtr; + } else { + Tcl_AppendResult(interp, "tag \"", argv[3], + "\" doesn't match any items", (char *) NULL); + goto error; + } + } + RelinkItems(canvasPtr, argv[2], prevPtr); + } else if ((c == 'm') && (strncmp(argv[1], "move", length) == 0)) { + double xAmount, yAmount; + + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " move tagOrId xAmount yAmount\"", + (char *) NULL); + goto error; + } + if ((Tk_CanvasGetCoord(interp, (Tk_Canvas) canvasPtr, argv[3], + &xAmount) != TCL_OK) || (Tk_CanvasGetCoord(interp, + (Tk_Canvas) canvasPtr, argv[4], &yAmount) != TCL_OK)) { + goto error; + } + for (itemPtr = StartTagSearch(canvasPtr, argv[2], &search); + itemPtr != NULL; itemPtr = NextItem(&search)) { + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + itemPtr->x1, itemPtr->y1, itemPtr->x2, itemPtr->y2); + (void) (*itemPtr->typePtr->translateProc)((Tk_Canvas) canvasPtr, + itemPtr, xAmount, yAmount); + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + itemPtr->x1, itemPtr->y1, itemPtr->x2, itemPtr->y2); + canvasPtr->flags |= REPICK_NEEDED; + } + } else if ((c == 'p') && (strncmp(argv[1], "postscript", length) == 0)) { + result = TkCanvPostscriptCmd(canvasPtr, interp, argc, argv); + } else if ((c == 'r') && (strncmp(argv[1], "raise", length) == 0)) { + Tk_Item *prevPtr; + + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " raise tagOrId ?aboveThis?\"", + (char *) NULL); + goto error; + } + + /* + * First find the item just after which we'll insert the + * named items. + */ + + if (argc == 3) { + prevPtr = canvasPtr->lastItemPtr; + } else { + prevPtr = NULL; + for (itemPtr = StartTagSearch(canvasPtr, argv[3], &search); + itemPtr != NULL; itemPtr = NextItem(&search)) { + prevPtr = itemPtr; + } + if (prevPtr == NULL) { + Tcl_AppendResult(interp, "tagOrId \"", argv[3], + "\" doesn't match any items", (char *) NULL); + goto error; + } + } + RelinkItems(canvasPtr, argv[2], prevPtr); + } else if ((c == 's') && (strncmp(argv[1], "scale", length) == 0) + && (length >= 3)) { + double xOrigin, yOrigin, xScale, yScale; + + if (argc != 7) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " scale tagOrId xOrigin yOrigin xScale yScale\"", + (char *) NULL); + goto error; + } + if ((Tk_CanvasGetCoord(interp, (Tk_Canvas) canvasPtr, + argv[3], &xOrigin) != TCL_OK) + || (Tk_CanvasGetCoord(interp, (Tk_Canvas) canvasPtr, + argv[4], &yOrigin) != TCL_OK) + || (Tcl_GetDouble(interp, argv[5], &xScale) != TCL_OK) + || (Tcl_GetDouble(interp, argv[6], &yScale) != TCL_OK)) { + goto error; + } + if ((xScale == 0.0) || (yScale == 0.0)) { + interp->result = "scale factor cannot be zero"; + goto error; + } + for (itemPtr = StartTagSearch(canvasPtr, argv[2], &search); + itemPtr != NULL; itemPtr = NextItem(&search)) { + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + itemPtr->x1, itemPtr->y1, itemPtr->x2, itemPtr->y2); + (void) (*itemPtr->typePtr->scaleProc)((Tk_Canvas) canvasPtr, + itemPtr, xOrigin, yOrigin, xScale, yScale); + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + itemPtr->x1, itemPtr->y1, itemPtr->x2, itemPtr->y2); + canvasPtr->flags |= REPICK_NEEDED; + } + } else if ((c == 's') && (strncmp(argv[1], "scan", length) == 0) + && (length >= 3)) { + int x, y; + + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " scan mark|dragto x y\"", (char *) NULL); + goto error; + } + if ((Tcl_GetInt(interp, argv[3], &x) != TCL_OK) + || (Tcl_GetInt(interp, argv[4], &y) != TCL_OK)){ + goto error; + } + if ((argv[2][0] == 'm') + && (strncmp(argv[2], "mark", strlen(argv[2])) == 0)) { + canvasPtr->scanX = x; + canvasPtr->scanXOrigin = canvasPtr->xOrigin; + canvasPtr->scanY = y; + canvasPtr->scanYOrigin = canvasPtr->yOrigin; + } else if ((argv[2][0] == 'd') + && (strncmp(argv[2], "dragto", strlen(argv[2])) == 0)) { + int newXOrigin, newYOrigin, tmp; + + /* + * Compute a new view origin for the canvas, amplifying the + * mouse motion. + */ + + tmp = canvasPtr->scanXOrigin - 10*(x - canvasPtr->scanX) + - canvasPtr->scrollX1; + newXOrigin = canvasPtr->scrollX1 + tmp; + tmp = canvasPtr->scanYOrigin - 10*(y - canvasPtr->scanY) + - canvasPtr->scrollY1; + newYOrigin = canvasPtr->scrollY1 + tmp; + CanvasSetOrigin(canvasPtr, newXOrigin, newYOrigin); + } else { + Tcl_AppendResult(interp, "bad scan option \"", argv[2], + "\": must be mark or dragto", (char *) NULL); + goto error; + } + } else if ((c == 's') && (strncmp(argv[1], "select", length) == 0) + && (length >= 2)) { + int index; + + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " select option ?tagOrId? ?arg?\"", (char *) NULL); + goto error; + } + if (argc >= 4) { + for (itemPtr = StartTagSearch(canvasPtr, argv[3], &search); + itemPtr != NULL; itemPtr = NextItem(&search)) { + if ((itemPtr->typePtr->indexProc != NULL) + && (itemPtr->typePtr->selectionProc != NULL)){ + break; + } + } + if (itemPtr == NULL) { + Tcl_AppendResult(interp, + "can't find an indexable and selectable item \"", + argv[3], "\"", (char *) NULL); + goto error; + } + } + if (argc == 5) { + if ((*itemPtr->typePtr->indexProc)(interp, (Tk_Canvas) canvasPtr, + itemPtr, argv[4], &index) != TCL_OK) { + goto error; + } + } + length = strlen(argv[2]); + c = argv[2][0]; + if ((c == 'a') && (strncmp(argv[2], "adjust", length) == 0)) { + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " select adjust tagOrId index\"", + (char *) NULL); + goto error; + } + if (canvasPtr->textInfo.selItemPtr == itemPtr) { + if (index < (canvasPtr->textInfo.selectFirst + + canvasPtr->textInfo.selectLast)/2) { + canvasPtr->textInfo.selectAnchor = + canvasPtr->textInfo.selectLast + 1; + } else { + canvasPtr->textInfo.selectAnchor = + canvasPtr->textInfo.selectFirst; + } + } + CanvasSelectTo(canvasPtr, itemPtr, index); + } else if ((c == 'c') && (argv[2] != NULL) + && (strncmp(argv[2], "clear", length) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " select clear\"", (char *) NULL); + goto error; + } + if (canvasPtr->textInfo.selItemPtr != NULL) { + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + canvasPtr->textInfo.selItemPtr->x1, + canvasPtr->textInfo.selItemPtr->y1, + canvasPtr->textInfo.selItemPtr->x2, + canvasPtr->textInfo.selItemPtr->y2); + canvasPtr->textInfo.selItemPtr = NULL; + } + goto done; + } else if ((c == 'f') && (strncmp(argv[2], "from", length) == 0)) { + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " select from tagOrId index\"", + (char *) NULL); + goto error; + } + canvasPtr->textInfo.anchorItemPtr = itemPtr; + canvasPtr->textInfo.selectAnchor = index; + } else if ((c == 'i') && (strncmp(argv[2], "item", length) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " select item\"", (char *) NULL); + goto error; + } + if (canvasPtr->textInfo.selItemPtr != NULL) { + sprintf(interp->result, "%d", + canvasPtr->textInfo.selItemPtr->id); + } + } else if ((c == 't') && (strncmp(argv[2], "to", length) == 0)) { + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " select to tagOrId index\"", + (char *) NULL); + goto error; + } + CanvasSelectTo(canvasPtr, itemPtr, index); + } else { + Tcl_AppendResult(interp, "bad select option \"", argv[2], + "\": must be adjust, clear, from, item, or to", + (char *) NULL); + goto error; + } + } else if ((c == 't') && (strncmp(argv[1], "type", length) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " type tag\"", (char *) NULL); + goto error; + } + itemPtr = StartTagSearch(canvasPtr, argv[2], &search); + if (itemPtr != NULL) { + interp->result = itemPtr->typePtr->name; + } + } else if ((c == 'x') && (strncmp(argv[1], "xview", length) == 0)) { + int count, type; + int newX = 0; /* Initialization needed only to prevent + * gcc warnings. */ + double fraction; + + if (argc == 2) { + PrintScrollFractions(canvasPtr->xOrigin + canvasPtr->inset, + canvasPtr->xOrigin + Tk_Width(canvasPtr->tkwin) + - canvasPtr->inset, canvasPtr->scrollX1, + canvasPtr->scrollX2, interp->result); + } else { + type = Tk_GetScrollInfo(interp, argc, argv, &fraction, &count); + switch (type) { + case TK_SCROLL_ERROR: + goto error; + case TK_SCROLL_MOVETO: + newX = canvasPtr->scrollX1 - canvasPtr->inset + + (int) (fraction * (canvasPtr->scrollX2 + - canvasPtr->scrollX1) + 0.5); + break; + case TK_SCROLL_PAGES: + newX = (int) (canvasPtr->xOrigin + count * .9 + * (Tk_Width(canvasPtr->tkwin) - 2*canvasPtr->inset)); + break; + case TK_SCROLL_UNITS: + if (canvasPtr->xScrollIncrement > 0) { + newX = canvasPtr->xOrigin + + count*canvasPtr->xScrollIncrement; + } else { + newX = (int) (canvasPtr->xOrigin + count * .1 + * (Tk_Width(canvasPtr->tkwin) + - 2*canvasPtr->inset)); + } + break; + } + CanvasSetOrigin(canvasPtr, newX, canvasPtr->yOrigin); + } + } else if ((c == 'y') && (strncmp(argv[1], "yview", length) == 0)) { + int count, type; + int newY = 0; /* Initialization needed only to prevent + * gcc warnings. */ + double fraction; + + if (argc == 2) { + PrintScrollFractions(canvasPtr->yOrigin + canvasPtr->inset, + canvasPtr->yOrigin + Tk_Height(canvasPtr->tkwin) + - canvasPtr->inset, canvasPtr->scrollY1, + canvasPtr->scrollY2, interp->result); + } else { + type = Tk_GetScrollInfo(interp, argc, argv, &fraction, &count); + switch (type) { + case TK_SCROLL_ERROR: + goto error; + case TK_SCROLL_MOVETO: + newY = canvasPtr->scrollY1 - canvasPtr->inset + + (int) (fraction*(canvasPtr->scrollY2 + - canvasPtr->scrollY1) + 0.5); + break; + case TK_SCROLL_PAGES: + newY = (int) (canvasPtr->yOrigin + count * .9 + * (Tk_Height(canvasPtr->tkwin) + - 2*canvasPtr->inset)); + break; + case TK_SCROLL_UNITS: + if (canvasPtr->yScrollIncrement > 0) { + newY = canvasPtr->yOrigin + + count*canvasPtr->yScrollIncrement; + } else { + newY = (int) (canvasPtr->yOrigin + count * .1 + * (Tk_Height(canvasPtr->tkwin) + - 2*canvasPtr->inset)); + } + break; + } + CanvasSetOrigin(canvasPtr, canvasPtr->xOrigin, newY); + } + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be addtag, bbox, bind, ", + "canvasx, canvasy, cget, configure, coords, create, ", + "dchars, delete, dtag, find, focus, ", + "gettags, icursor, index, insert, itemcget, itemconfigure, ", + "lower, move, postscript, raise, scale, scan, ", + "select, type, xview, or yview", + (char *) NULL); + goto error; + } + done: + Tcl_Release((ClientData) canvasPtr); + return result; + + error: + Tcl_Release((ClientData) canvasPtr); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * DestroyCanvas -- + * + * This procedure is invoked by Tcl_EventuallyFree or Tcl_Release + * to clean up the internal structure of a canvas at a safe time + * (when no-one is using it anymore). + * + * Results: + * None. + * + * Side effects: + * Everything associated with the canvas is freed up. + * + *---------------------------------------------------------------------- + */ + +static void +DestroyCanvas(memPtr) + char *memPtr; /* Info about canvas widget. */ +{ + TkCanvas *canvasPtr = (TkCanvas *) memPtr; + Tk_Item *itemPtr; + + /* + * Free up all of the items in the canvas. + */ + + for (itemPtr = canvasPtr->firstItemPtr; itemPtr != NULL; + itemPtr = canvasPtr->firstItemPtr) { + canvasPtr->firstItemPtr = itemPtr->nextPtr; + (*itemPtr->typePtr->deleteProc)((Tk_Canvas) canvasPtr, itemPtr, + canvasPtr->display); + if (itemPtr->tagPtr != itemPtr->staticTagSpace) { + ckfree((char *) itemPtr->tagPtr); + } + ckfree((char *) itemPtr); + } + + /* + * Free up all the stuff that requires special handling, + * then let Tk_FreeOptions handle all the standard option-related + * stuff. + */ + + if (canvasPtr->pixmapGC != None) { + Tk_FreeGC(canvasPtr->display, canvasPtr->pixmapGC); + } + Tcl_DeleteTimerHandler(canvasPtr->insertBlinkHandler); + if (canvasPtr->bindingTable != NULL) { + Tk_DeleteBindingTable(canvasPtr->bindingTable); + } + Tk_FreeOptions(configSpecs, (char *) canvasPtr, canvasPtr->display, 0); + ckfree((char *) canvasPtr); +} + +/* + *---------------------------------------------------------------------- + * + * ConfigureCanvas -- + * + * This procedure is called to process an argv/argc list, plus + * the Tk option database, in order to configure (or + * reconfigure) a canvas widget. + * + * Results: + * The return value is a standard Tcl result. If TCL_ERROR is + * returned, then interp->result contains an error message. + * + * Side effects: + * Configuration information, such as colors, border width, + * etc. get set for canvasPtr; old resources get freed, + * if there were any. + * + *---------------------------------------------------------------------- + */ + +static int +ConfigureCanvas(interp, canvasPtr, argc, argv, flags) + Tcl_Interp *interp; /* Used for error reporting. */ + TkCanvas *canvasPtr; /* 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. */ +{ + XGCValues gcValues; + GC new; + + if (Tk_ConfigureWidget(interp, canvasPtr->tkwin, configSpecs, + argc, argv, (char *) canvasPtr, flags) != TCL_OK) { + return TCL_ERROR; + } + + /* + * A few options need special processing, such as setting the + * background from a 3-D border and creating a GC for copying + * bits to the screen. + */ + + Tk_SetBackgroundFromBorder(canvasPtr->tkwin, canvasPtr->bgBorder); + + if (canvasPtr->highlightWidth < 0) { + canvasPtr->highlightWidth = 0; + } + canvasPtr->inset = canvasPtr->borderWidth + canvasPtr->highlightWidth; + + gcValues.function = GXcopy; + gcValues.foreground = Tk_3DBorderColor(canvasPtr->bgBorder)->pixel; + gcValues.graphics_exposures = False; + new = Tk_GetGC(canvasPtr->tkwin, + GCFunction|GCForeground|GCGraphicsExposures, &gcValues); + if (canvasPtr->pixmapGC != None) { + Tk_FreeGC(canvasPtr->display, canvasPtr->pixmapGC); + } + canvasPtr->pixmapGC = new; + + /* + * Reset the desired dimensions for the window. + */ + + Tk_GeometryRequest(canvasPtr->tkwin, canvasPtr->width + 2*canvasPtr->inset, + canvasPtr->height + 2*canvasPtr->inset); + + /* + * Restart the cursor timing sequence in case the on-time or off-time + * just changed. + */ + + if (canvasPtr->textInfo.gotFocus) { + CanvasFocusProc(canvasPtr, 1); + } + + /* + * Recompute the scroll region. + */ + + canvasPtr->scrollX1 = 0; + canvasPtr->scrollY1 = 0; + canvasPtr->scrollX2 = 0; + canvasPtr->scrollY2 = 0; + if (canvasPtr->regionString != NULL) { + int argc2; + char **argv2; + + if (Tcl_SplitList(canvasPtr->interp, canvasPtr->regionString, + &argc2, &argv2) != TCL_OK) { + return TCL_ERROR; + } + if (argc2 != 4) { + Tcl_AppendResult(interp, "bad scrollRegion \"", + canvasPtr->regionString, "\"", (char *) NULL); + badRegion: + ckfree(canvasPtr->regionString); + ckfree((char *) argv2); + canvasPtr->regionString = NULL; + return TCL_ERROR; + } + if ((Tk_GetPixels(canvasPtr->interp, canvasPtr->tkwin, + argv2[0], &canvasPtr->scrollX1) != TCL_OK) + || (Tk_GetPixels(canvasPtr->interp, canvasPtr->tkwin, + argv2[1], &canvasPtr->scrollY1) != TCL_OK) + || (Tk_GetPixels(canvasPtr->interp, canvasPtr->tkwin, + argv2[2], &canvasPtr->scrollX2) != TCL_OK) + || (Tk_GetPixels(canvasPtr->interp, canvasPtr->tkwin, + argv2[3], &canvasPtr->scrollY2) != TCL_OK)) { + goto badRegion; + } + ckfree((char *) argv2); + } + + /* + * Reset the canvas's origin (this is a no-op unless confine + * mode has just been turned on or the scroll region has changed). + */ + + CanvasSetOrigin(canvasPtr, canvasPtr->xOrigin, canvasPtr->yOrigin); + canvasPtr->flags |= UPDATE_SCROLLBARS|REDRAW_BORDERS; + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + canvasPtr->xOrigin, canvasPtr->yOrigin, + canvasPtr->xOrigin + Tk_Width(canvasPtr->tkwin), + canvasPtr->yOrigin + Tk_Height(canvasPtr->tkwin)); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * CanvasWorldChanged -- + * + * This procedure is called when the world has changed in some + * way and the widget needs to recompute all its graphics contexts + * and determine its new geometry. + * + * Results: + * None. + * + * Side effects: + * Configures all items in the canvas with a empty argc/argv, for + * the side effect of causing all the items to recompute their + * geometry and to be redisplayed. + * + *--------------------------------------------------------------------------- + */ + +static void +CanvasWorldChanged(instanceData) + ClientData instanceData; /* Information about widget. */ +{ + TkCanvas *canvasPtr; + Tk_Item *itemPtr; + int result; + + canvasPtr = (TkCanvas *) instanceData; + itemPtr = canvasPtr->firstItemPtr; + for ( ; itemPtr != NULL; itemPtr = itemPtr->nextPtr) { + result = (*itemPtr->typePtr->configProc)(canvasPtr->interp, + (Tk_Canvas) canvasPtr, itemPtr, 0, NULL, + TK_CONFIG_ARGV_ONLY); + if (result != TCL_OK) { + Tcl_ResetResult(canvasPtr->interp); + } + } + canvasPtr->flags |= REPICK_NEEDED; + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + canvasPtr->xOrigin, canvasPtr->yOrigin, + canvasPtr->xOrigin + Tk_Width(canvasPtr->tkwin), + canvasPtr->yOrigin + Tk_Height(canvasPtr->tkwin)); +} + +/* + *-------------------------------------------------------------- + * + * DisplayCanvas -- + * + * This procedure redraws the contents of a canvas window. + * It is invoked as a do-when-idle handler, so it only runs + * when there's nothing else for the application to do. + * + * Results: + * None. + * + * Side effects: + * Information appears on the screen. + * + *-------------------------------------------------------------- + */ + +static void +DisplayCanvas(clientData) + ClientData clientData; /* Information about widget. */ +{ + TkCanvas *canvasPtr = (TkCanvas *) clientData; + Tk_Window tkwin = canvasPtr->tkwin; + Tk_Item *itemPtr; + Pixmap pixmap; + int screenX1, screenX2, screenY1, screenY2, width, height; + + if (canvasPtr->tkwin == NULL) { + return; + } + if (!Tk_IsMapped(tkwin)) { + goto done; + } + + /* + * Choose a new current item if that is needed (this could cause + * event handlers to be invoked). + */ + + while (canvasPtr->flags & REPICK_NEEDED) { + Tcl_Preserve((ClientData) canvasPtr); + canvasPtr->flags &= ~REPICK_NEEDED; + PickCurrentItem(canvasPtr, &canvasPtr->pickEvent); + tkwin = canvasPtr->tkwin; + Tcl_Release((ClientData) canvasPtr); + if (tkwin == NULL) { + return; + } + } + + /* + * Compute the intersection between the area that needs redrawing + * and the area that's visible on the screen. + */ + + if ((canvasPtr->redrawX1 < canvasPtr->redrawX2) + && (canvasPtr->redrawY1 < canvasPtr->redrawY2)) { + screenX1 = canvasPtr->xOrigin + canvasPtr->inset; + screenY1 = canvasPtr->yOrigin + canvasPtr->inset; + screenX2 = canvasPtr->xOrigin + Tk_Width(tkwin) - canvasPtr->inset; + screenY2 = canvasPtr->yOrigin + Tk_Height(tkwin) - canvasPtr->inset; + if (canvasPtr->redrawX1 > screenX1) { + screenX1 = canvasPtr->redrawX1; + } + if (canvasPtr->redrawY1 > screenY1) { + screenY1 = canvasPtr->redrawY1; + } + if (canvasPtr->redrawX2 < screenX2) { + screenX2 = canvasPtr->redrawX2; + } + if (canvasPtr->redrawY2 < screenY2) { + screenY2 = canvasPtr->redrawY2; + } + if ((screenX1 >= screenX2) || (screenY1 >= screenY2)) { + goto borders; + } + + /* + * Redrawing is done in a temporary pixmap that is allocated + * here and freed at the end of the procedure. All drawing + * is done to the pixmap, and the pixmap is copied to the + * screen at the end of the procedure. The temporary pixmap + * serves two purposes: + * + * 1. It provides a smoother visual effect (no clearing and + * gradual redraw will be visible to users). + * 2. It allows us to redraw only the objects that overlap + * the redraw area. Otherwise incorrect results could + * occur from redrawing things that stick outside of + * the redraw area (we'd have to redraw everything in + * order to make the overlaps look right). + * + * Some tricky points about the pixmap: + * + * 1. We only allocate a large enough pixmap to hold the + * area that has to be redisplayed. This saves time in + * in the X server for large objects that cover much + * more than the area being redisplayed: only the area + * of the pixmap will actually have to be redrawn. + * 2. Some X servers (e.g. the one for DECstations) have troubles + * with characters that overlap an edge of the pixmap (on the + * DEC servers, as of 8/18/92, such characters are drawn one + * pixel too far to the right). To handle this problem, + * make the pixmap a bit larger than is absolutely needed + * so that for normal-sized fonts the characters that overlap + * the edge of the pixmap will be outside the area we care + * about. + */ + + canvasPtr->drawableXOrigin = screenX1 - 30; + canvasPtr->drawableYOrigin = screenY1 - 30; + pixmap = Tk_GetPixmap(Tk_Display(tkwin), Tk_WindowId(tkwin), + (screenX2 + 30 - canvasPtr->drawableXOrigin), + (screenY2 + 30 - canvasPtr->drawableYOrigin), + Tk_Depth(tkwin)); + + /* + * Clear the area to be redrawn. + */ + + width = screenX2 - screenX1; + height = screenY2 - screenY1; + + XFillRectangle(Tk_Display(tkwin), pixmap, canvasPtr->pixmapGC, + screenX1 - canvasPtr->drawableXOrigin, + screenY1 - canvasPtr->drawableYOrigin, (unsigned int) width, + (unsigned int) height); + + /* + * Scan through the item list, redrawing those items that need it. + * An item must be redraw if either (a) it intersects the smaller + * on-screen area or (b) it intersects the full canvas area and its + * type requests that it be redrawn always (e.g. so subwindows can + * be unmapped when they move off-screen). + */ + + for (itemPtr = canvasPtr->firstItemPtr; itemPtr != NULL; + itemPtr = itemPtr->nextPtr) { + if ((itemPtr->x1 >= screenX2) + || (itemPtr->y1 >= screenY2) + || (itemPtr->x2 < screenX1) + || (itemPtr->y2 < screenY1)) { + if (!itemPtr->typePtr->alwaysRedraw + || (itemPtr->x1 >= canvasPtr->redrawX2) + || (itemPtr->y1 >= canvasPtr->redrawY2) + || (itemPtr->x2 < canvasPtr->redrawX1) + || (itemPtr->y2 < canvasPtr->redrawY1)) { + continue; + } + } + (*itemPtr->typePtr->displayProc)((Tk_Canvas) canvasPtr, itemPtr, + canvasPtr->display, pixmap, screenX1, screenY1, width, + height); + } + + /* + * Copy from the temporary pixmap to the screen, then free up + * the temporary pixmap. + */ + + XCopyArea(Tk_Display(tkwin), pixmap, Tk_WindowId(tkwin), + canvasPtr->pixmapGC, + screenX1 - canvasPtr->drawableXOrigin, + screenY1 - canvasPtr->drawableYOrigin, + (unsigned) (screenX2 - screenX1), + (unsigned) (screenY2 - screenY1), + screenX1 - canvasPtr->xOrigin, screenY1 - canvasPtr->yOrigin); + Tk_FreePixmap(Tk_Display(tkwin), pixmap); + } + + /* + * Draw the window borders, if needed. + */ + + borders: + if (canvasPtr->flags & REDRAW_BORDERS) { + canvasPtr->flags &= ~REDRAW_BORDERS; + if (canvasPtr->borderWidth > 0) { + Tk_Draw3DRectangle(tkwin, Tk_WindowId(tkwin), + canvasPtr->bgBorder, canvasPtr->highlightWidth, + canvasPtr->highlightWidth, + Tk_Width(tkwin) - 2*canvasPtr->highlightWidth, + Tk_Height(tkwin) - 2*canvasPtr->highlightWidth, + canvasPtr->borderWidth, canvasPtr->relief); + } + if (canvasPtr->highlightWidth != 0) { + GC gc; + + if (canvasPtr->textInfo.gotFocus) { + gc = Tk_GCForColor(canvasPtr->highlightColorPtr, + Tk_WindowId(tkwin)); + } else { + gc = Tk_GCForColor(canvasPtr->highlightBgColorPtr, + Tk_WindowId(tkwin)); + } + Tk_DrawFocusHighlight(tkwin, gc, canvasPtr->highlightWidth, + Tk_WindowId(tkwin)); + } + } + + done: + canvasPtr->flags &= ~REDRAW_PENDING; + canvasPtr->redrawX1 = canvasPtr->redrawX2 = 0; + canvasPtr->redrawY1 = canvasPtr->redrawY2 = 0; + if (canvasPtr->flags & UPDATE_SCROLLBARS) { + CanvasUpdateScrollbars(canvasPtr); + } +} + +/* + *-------------------------------------------------------------- + * + * CanvasEventProc -- + * + * This procedure is invoked by the Tk dispatcher for various + * events on canvases. + * + * Results: + * None. + * + * Side effects: + * When the window gets deleted, internal structures get + * cleaned up. When it gets exposed, it is redisplayed. + * + *-------------------------------------------------------------- + */ + +static void +CanvasEventProc(clientData, eventPtr) + ClientData clientData; /* Information about window. */ + XEvent *eventPtr; /* Information about event. */ +{ + TkCanvas *canvasPtr = (TkCanvas *) clientData; + + if (eventPtr->type == Expose) { + int x, y; + + x = eventPtr->xexpose.x + canvasPtr->xOrigin; + y = eventPtr->xexpose.y + canvasPtr->yOrigin; + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, x, y, + x + eventPtr->xexpose.width, + y + eventPtr->xexpose.height); + if ((eventPtr->xexpose.x < canvasPtr->inset) + || (eventPtr->xexpose.y < canvasPtr->inset) + || ((eventPtr->xexpose.x + eventPtr->xexpose.width) + > (Tk_Width(canvasPtr->tkwin) - canvasPtr->inset)) + || ((eventPtr->xexpose.y + eventPtr->xexpose.height) + > (Tk_Height(canvasPtr->tkwin) - canvasPtr->inset))) { + canvasPtr->flags |= REDRAW_BORDERS; + } + } else if (eventPtr->type == DestroyNotify) { + if (canvasPtr->tkwin != NULL) { + canvasPtr->tkwin = NULL; + Tcl_DeleteCommandFromToken(canvasPtr->interp, + canvasPtr->widgetCmd); + } + if (canvasPtr->flags & REDRAW_PENDING) { + Tcl_CancelIdleCall(DisplayCanvas, (ClientData) canvasPtr); + } + Tcl_EventuallyFree((ClientData) canvasPtr, DestroyCanvas); + } else if (eventPtr->type == ConfigureNotify) { + canvasPtr->flags |= UPDATE_SCROLLBARS; + + /* + * The call below is needed in order to recenter the canvas if + * it's confined and its scroll region is smaller than the window. + */ + + CanvasSetOrigin(canvasPtr, canvasPtr->xOrigin, canvasPtr->yOrigin); + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, canvasPtr->xOrigin, + canvasPtr->yOrigin, + canvasPtr->xOrigin + Tk_Width(canvasPtr->tkwin), + canvasPtr->yOrigin + Tk_Height(canvasPtr->tkwin)); + canvasPtr->flags |= REDRAW_BORDERS; + } else if (eventPtr->type == FocusIn) { + if (eventPtr->xfocus.detail != NotifyInferior) { + CanvasFocusProc(canvasPtr, 1); + } + } else if (eventPtr->type == FocusOut) { + if (eventPtr->xfocus.detail != NotifyInferior) { + CanvasFocusProc(canvasPtr, 0); + } + } else if (eventPtr->type == UnmapNotify) { + Tk_Item *itemPtr; + + /* + * Special hack: if the canvas is unmapped, then must notify + * all items with "alwaysRedraw" set, so that they know that + * they are no longer displayed. + */ + + for (itemPtr = canvasPtr->firstItemPtr; itemPtr != NULL; + itemPtr = itemPtr->nextPtr) { + if (itemPtr->typePtr->alwaysRedraw) { + (*itemPtr->typePtr->displayProc)((Tk_Canvas) canvasPtr, + itemPtr, canvasPtr->display, None, 0, 0, 0, 0); + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * CanvasCmdDeletedProc -- + * + * 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 +CanvasCmdDeletedProc(clientData) + ClientData clientData; /* Pointer to widget record for widget. */ +{ + TkCanvas *canvasPtr = (TkCanvas *) clientData; + Tk_Window tkwin = canvasPtr->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. + */ + + if (tkwin != NULL) { + canvasPtr->tkwin = NULL; + Tk_DestroyWindow(tkwin); + } +} + +/* + *-------------------------------------------------------------- + * + * Tk_CanvasEventuallyRedraw -- + * + * Arrange for part or all of a canvas widget to redrawn at + * some convenient time in the future. + * + * Results: + * None. + * + * Side effects: + * The screen will eventually be refreshed. + * + *-------------------------------------------------------------- + */ + +void +Tk_CanvasEventuallyRedraw(canvas, x1, y1, x2, y2) + Tk_Canvas canvas; /* Information about widget. */ + int x1, y1; /* Upper left corner of area to redraw. + * Pixels on edge are redrawn. */ + int x2, y2; /* Lower right corner of area to redraw. + * Pixels on edge are not redrawn. */ +{ + TkCanvas *canvasPtr = (TkCanvas *) canvas; + if ((x1 == x2) || (y1 == y2)) { + return; + } + if (canvasPtr->flags & REDRAW_PENDING) { + if (x1 <= canvasPtr->redrawX1) { + canvasPtr->redrawX1 = x1; + } + if (y1 <= canvasPtr->redrawY1) { + canvasPtr->redrawY1 = y1; + } + if (x2 >= canvasPtr->redrawX2) { + canvasPtr->redrawX2 = x2; + } + if (y2 >= canvasPtr->redrawY2) { + canvasPtr->redrawY2 = y2; + } + } else { + canvasPtr->redrawX1 = x1; + canvasPtr->redrawY1 = y1; + canvasPtr->redrawX2 = x2; + canvasPtr->redrawY2 = y2; + Tcl_DoWhenIdle(DisplayCanvas, (ClientData) canvasPtr); + canvasPtr->flags |= REDRAW_PENDING; + } +} + +/* + *-------------------------------------------------------------- + * + * Tk_CreateItemType -- + * + * This procedure may be invoked to add a new kind of canvas + * element to the core item types supported by Tk. + * + * Results: + * None. + * + * Side effects: + * From now on, the new item type will be useable in canvas + * widgets (e.g. typePtr->name can be used as the item type + * in "create" widget commands). If there was already a + * type with the same name as in typePtr, it is replaced with + * the new type. + * + *-------------------------------------------------------------- + */ + +void +Tk_CreateItemType(typePtr) + Tk_ItemType *typePtr; /* Information about item type; + * storage must be statically + * allocated (must live forever). */ +{ + Tk_ItemType *typePtr2, *prevPtr; + + if (typeList == NULL) { + InitCanvas(); + } + + /* + * If there's already an item type with the given name, remove it. + */ + + for (typePtr2 = typeList, prevPtr = NULL; typePtr2 != NULL; + prevPtr = typePtr2, typePtr2 = typePtr2->nextPtr) { + if (strcmp(typePtr2->name, typePtr->name) == 0) { + if (prevPtr == NULL) { + typeList = typePtr2->nextPtr; + } else { + prevPtr->nextPtr = typePtr2->nextPtr; + } + break; + } + } + typePtr->nextPtr = typeList; + typeList = typePtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_GetItemTypes -- + * + * This procedure returns a pointer to the list of all item + * types. + * + * Results: + * The return value is a pointer to the first in the list + * of item types currently supported by canvases. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tk_ItemType * +Tk_GetItemTypes() +{ + if (typeList == NULL) { + InitCanvas(); + } + return typeList; +} + +/* + *-------------------------------------------------------------- + * + * InitCanvas -- + * + * This procedure is invoked to perform once-only-ever + * initialization for the module, such as setting up + * the type table. + * + * Results: + * None. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static void +InitCanvas() +{ + if (typeList != NULL) { + return; + } + typeList = &tkRectangleType; + tkRectangleType.nextPtr = &tkTextType; + tkTextType.nextPtr = &tkLineType; + tkLineType.nextPtr = &tkPolygonType; + tkPolygonType.nextPtr = &tkImageType; + tkImageType.nextPtr = &tkOvalType; + tkOvalType.nextPtr = &tkBitmapType; + tkBitmapType.nextPtr = &tkArcType; + tkArcType.nextPtr = &tkWindowType; + tkWindowType.nextPtr = NULL; + allUid = Tk_GetUid("all"); + currentUid = Tk_GetUid("current"); +} + +/* + *-------------------------------------------------------------- + * + * StartTagSearch -- + * + * This procedure is called to initiate an enumeration of + * all items in a given canvas that contain a given tag. + * + * Results: + * The return value is a pointer to the first item in + * canvasPtr that matches tag, or NULL if there is no + * such item. The information at *searchPtr is initialized + * such that successive calls to NextItem will return + * successive items that match tag. + * + * Side effects: + * SearchPtr is linked into a list of searches in progress + * on canvasPtr, so that elements can safely be deleted + * while the search is in progress. EndTagSearch must be + * called at the end of the search to unlink searchPtr from + * this list. + * + *-------------------------------------------------------------- + */ + +static Tk_Item * +StartTagSearch(canvasPtr, tag, searchPtr) + TkCanvas *canvasPtr; /* Canvas whose items are to be + * searched. */ + char *tag; /* String giving tag value. */ + TagSearch *searchPtr; /* Record describing tag search; + * will be initialized here. */ +{ + int id; + Tk_Item *itemPtr, *prevPtr; + Tk_Uid *tagPtr; + Tk_Uid uid; + int count; + + /* + * Initialize the search. + */ + + searchPtr->canvasPtr = canvasPtr; + searchPtr->searchOver = 0; + + /* + * Find the first matching item in one of several ways. If the tag + * is a number then it selects the single item with the matching + * identifier. In this case see if the item being requested is the + * hot item, in which case the search can be skipped. + */ + + if (isdigit(UCHAR(*tag))) { + char *end; + + numIdSearches++; + id = strtoul(tag, &end, 0); + if (*end == 0) { + itemPtr = canvasPtr->hotPtr; + prevPtr = canvasPtr->hotPrevPtr; + if ((itemPtr == NULL) || (itemPtr->id != id) || (prevPtr == NULL) + || (prevPtr->nextPtr != itemPtr)) { + numSlowSearches++; + for (prevPtr = NULL, itemPtr = canvasPtr->firstItemPtr; + itemPtr != NULL; + prevPtr = itemPtr, itemPtr = itemPtr->nextPtr) { + if (itemPtr->id == id) { + break; + } + } + } + searchPtr->prevPtr = prevPtr; + searchPtr->searchOver = 1; + canvasPtr->hotPtr = itemPtr; + canvasPtr->hotPrevPtr = prevPtr; + return itemPtr; + } + } + + searchPtr->tag = uid = Tk_GetUid(tag); + if (uid == allUid) { + + /* + * All items match. + */ + + searchPtr->tag = NULL; + searchPtr->prevPtr = NULL; + searchPtr->currentPtr = canvasPtr->firstItemPtr; + return canvasPtr->firstItemPtr; + } + + /* + * None of the above. Search for an item with a matching tag. + */ + + for (prevPtr = NULL, itemPtr = canvasPtr->firstItemPtr; itemPtr != NULL; + prevPtr = itemPtr, itemPtr = itemPtr->nextPtr) { + for (tagPtr = itemPtr->tagPtr, count = itemPtr->numTags; + count > 0; tagPtr++, count--) { + if (*tagPtr == uid) { + searchPtr->prevPtr = prevPtr; + searchPtr->currentPtr = itemPtr; + return itemPtr; + } + } + } + searchPtr->prevPtr = prevPtr; + searchPtr->searchOver = 1; + return NULL; +} + +/* + *-------------------------------------------------------------- + * + * NextItem -- + * + * This procedure returns successive items that match a given + * tag; it should be called only after StartTagSearch has been + * used to begin a search. + * + * Results: + * The return value is a pointer to the next item that matches + * the tag specified to StartTagSearch, or NULL if no such + * item exists. *SearchPtr is updated so that the next call + * to this procedure will return the next item. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static Tk_Item * +NextItem(searchPtr) + TagSearch *searchPtr; /* Record describing search in + * progress. */ +{ + Tk_Item *itemPtr, *prevPtr; + int count; + Tk_Uid uid; + Tk_Uid *tagPtr; + + /* + * Find next item in list (this may not actually be a suitable + * one to return), and return if there are no items left. + */ + + prevPtr = searchPtr->prevPtr; + if (prevPtr == NULL) { + itemPtr = searchPtr->canvasPtr->firstItemPtr; + } else { + itemPtr = prevPtr->nextPtr; + } + if ((itemPtr == NULL) || (searchPtr->searchOver)) { + searchPtr->searchOver = 1; + return NULL; + } + if (itemPtr != searchPtr->currentPtr) { + /* + * The structure of the list has changed. Probably the + * previously-returned item was removed from the list. + * In this case, don't advance prevPtr; just return + * its new successor (i.e. do nothing here). + */ + } else { + prevPtr = itemPtr; + itemPtr = prevPtr->nextPtr; + } + + /* + * Handle special case of "all" search by returning next item. + */ + + uid = searchPtr->tag; + if (uid == NULL) { + searchPtr->prevPtr = prevPtr; + searchPtr->currentPtr = itemPtr; + return itemPtr; + } + + /* + * Look for an item with a particular tag. + */ + + for ( ; itemPtr != NULL; prevPtr = itemPtr, itemPtr = itemPtr->nextPtr) { + for (tagPtr = itemPtr->tagPtr, count = itemPtr->numTags; + count > 0; tagPtr++, count--) { + if (*tagPtr == uid) { + searchPtr->prevPtr = prevPtr; + searchPtr->currentPtr = itemPtr; + return itemPtr; + } + } + } + searchPtr->prevPtr = prevPtr; + searchPtr->searchOver = 1; + return NULL; +} + +/* + *-------------------------------------------------------------- + * + * DoItem -- + * + * This is a utility procedure called by FindItems. It + * either adds itemPtr's id to the result forming in interp, + * or it adds a new tag to itemPtr, depending on the value + * of tag. + * + * Results: + * None. + * + * 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 + * list of tags. + * + *-------------------------------------------------------------- + */ + +static void +DoItem(interp, itemPtr, tag) + Tcl_Interp *interp; /* Interpreter in which to (possibly) + * record item id. */ + Tk_Item *itemPtr; /* Item to (possibly) modify. */ + Tk_Uid tag; /* Tag to add to those already + * present for item, or NULL. */ +{ + Tk_Uid *tagPtr; + int count; + + /* + * Handle the "add-to-result" case and return, if appropriate. + */ + + if (tag == NULL) { + char msg[30]; + sprintf(msg, "%d", itemPtr->id); + Tcl_AppendElement(interp, msg); + return; + } + + for (tagPtr = itemPtr->tagPtr, count = itemPtr->numTags; + count > 0; tagPtr++, count--) { + if (tag == *tagPtr) { + return; + } + } + + /* + * Grow the tag space if there's no more room left in the current + * block. + */ + + if (itemPtr->tagSpace == itemPtr->numTags) { + Tk_Uid *newTagPtr; + + itemPtr->tagSpace += 5; + newTagPtr = (Tk_Uid *) ckalloc((unsigned) + (itemPtr->tagSpace * sizeof(Tk_Uid))); + memcpy((VOID *) newTagPtr, (VOID *) itemPtr->tagPtr, + (itemPtr->numTags * sizeof(Tk_Uid))); + if (itemPtr->tagPtr != itemPtr->staticTagSpace) { + ckfree((char *) itemPtr->tagPtr); + } + itemPtr->tagPtr = newTagPtr; + tagPtr = &itemPtr->tagPtr[itemPtr->numTags]; + } + + /* + * Add in the new tag. + */ + + *tagPtr = tag; + itemPtr->numTags++; +} + +/* + *-------------------------------------------------------------- + * + * FindItems -- + * + * This procedure does all the work of implementing the + * "find" and "addtag" options of the canvas widget command, + * which locate items that have certain features (location, + * tags, position in display list, etc.). + * + * 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. + * + * Side effects: + * If newTag is non-NULL, then all the items that match the + * information in argc/argv have that tag added to their + * lists of tags. + * + *-------------------------------------------------------------- + */ + +static int +FindItems(interp, canvasPtr, argc, argv, newTag, cmdName, option) + Tcl_Interp *interp; /* Interpreter for error reporting. */ + TkCanvas *canvasPtr; /* Canvas whose items are to be + * searched. */ + int argc; /* Number of entries in argv. Must be + * greater than zero. */ + char **argv; /* Arguments that describe what items + * to search for (see user doc on + * "find" and "addtag" options). */ + 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. */ + char *cmdName; /* Name of original Tcl command, for + * use in error messages. */ + char *option; /* For error messages: gives option + * from Tcl command and other stuff + * up to what's in argc/argv. */ +{ + int c; + size_t length; + TagSearch search; + Tk_Item *itemPtr; + Tk_Uid uid; + + if (newTag != NULL) { + uid = Tk_GetUid(newTag); + } else { + uid = NULL; + } + c = argv[0][0]; + length = strlen(argv[0]); + if ((c == 'a') && (strncmp(argv[0], "above", length) == 0) + && (length >= 2)) { + Tk_Item *lastPtr = NULL; + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + cmdName, option, " above tagOrId", (char *) NULL); + return TCL_ERROR; + } + for (itemPtr = StartTagSearch(canvasPtr, argv[1], &search); + itemPtr != NULL; itemPtr = NextItem(&search)) { + lastPtr = itemPtr; + } + if ((lastPtr != NULL) && (lastPtr->nextPtr != NULL)) { + DoItem(interp, lastPtr->nextPtr, uid); + } + } else if ((c == 'a') && (strncmp(argv[0], "all", length) == 0) + && (length >= 2)) { + if (argc != 1) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + cmdName, option, " all", (char *) NULL); + return TCL_ERROR; + } + + for (itemPtr = canvasPtr->firstItemPtr; itemPtr != NULL; + itemPtr = itemPtr->nextPtr) { + DoItem(interp, itemPtr, uid); + } + } else if ((c == 'b') && (strncmp(argv[0], "below", length) == 0)) { + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + cmdName, option, " below tagOrId", (char *) NULL); + return TCL_ERROR; + } + (void) StartTagSearch(canvasPtr, argv[1], &search); + if (search.prevPtr != NULL) { + DoItem(interp, search.prevPtr, uid); + } + } else if ((c == 'c') && (strncmp(argv[0], "closest", length) == 0)) { + double closestDist; + Tk_Item *startPtr, *closestPtr; + double coords[2], halo; + int x1, y1, x2, y2; + + if ((argc < 3) || (argc > 5)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + cmdName, option, " closest x y ?halo? ?start?", + (char *) NULL); + return TCL_ERROR; + } + if ((Tk_CanvasGetCoord(interp, (Tk_Canvas) canvasPtr, argv[1], + &coords[0]) != TCL_OK) || (Tk_CanvasGetCoord(interp, + (Tk_Canvas) canvasPtr, argv[2], &coords[1]) != TCL_OK)) { + return TCL_ERROR; + } + if (argc > 3) { + if (Tk_CanvasGetCoord(interp, (Tk_Canvas) canvasPtr, argv[3], + &halo) != TCL_OK) { + return TCL_ERROR; + } + if (halo < 0.0) { + Tcl_AppendResult(interp, "can't have negative halo value \"", + argv[3], "\"", (char *) NULL); + return TCL_ERROR; + } + } else { + halo = 0.0; + } + + /* + * Find the item at which to start the search. + */ + + startPtr = canvasPtr->firstItemPtr; + if (argc == 5) { + itemPtr = StartTagSearch(canvasPtr, argv[4], &search); + if (itemPtr != NULL) { + startPtr = itemPtr; + } + } + + /* + * The code below is optimized so that it can eliminate most + * items without having to call their item-specific procedures. + * This is done by keeping a bounding box (x1, y1, x2, y2) that + * an item's bbox must overlap if the item is to have any + * chance of being closer than the closest so far. + */ + + itemPtr = startPtr; + if (itemPtr == NULL) { + return TCL_OK; + } + closestDist = (*itemPtr->typePtr->pointProc)((Tk_Canvas) canvasPtr, + itemPtr, coords) - halo; + if (closestDist < 0.0) { + closestDist = 0.0; + } + while (1) { + double newDist; + + /* + * Update the bounding box using itemPtr, which is the + * new closest item. + */ + + x1 = (int) (coords[0] - closestDist - halo - 1); + y1 = (int) (coords[1] - closestDist - halo - 1); + x2 = (int) (coords[0] + closestDist + halo + 1); + y2 = (int) (coords[1] + closestDist + halo + 1); + closestPtr = itemPtr; + + /* + * Search for an item that beats the current closest one. + * Work circularly through the canvas's item list until + * getting back to the starting item. + */ + + while (1) { + itemPtr = itemPtr->nextPtr; + if (itemPtr == NULL) { + itemPtr = canvasPtr->firstItemPtr; + } + if (itemPtr == startPtr) { + DoItem(interp, closestPtr, uid); + return TCL_OK; + } + if ((itemPtr->x1 >= x2) || (itemPtr->x2 <= x1) + || (itemPtr->y1 >= y2) || (itemPtr->y2 <= y1)) { + continue; + } + newDist = (*itemPtr->typePtr->pointProc)((Tk_Canvas) canvasPtr, + itemPtr, coords) - halo; + if (newDist < 0.0) { + newDist = 0.0; + } + if (newDist <= closestDist) { + closestDist = newDist; + break; + } + } + } + } else if ((c == 'e') && (strncmp(argv[0], "enclosed", length) == 0)) { + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + cmdName, option, " enclosed x1 y1 x2 y2", (char *) NULL); + return TCL_ERROR; + } + return FindArea(interp, canvasPtr, argv+1, uid, 1); + } else if ((c == 'o') && (strncmp(argv[0], "overlapping", length) == 0)) { + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + cmdName, option, " overlapping x1 y1 x2 y2", + (char *) NULL); + return TCL_ERROR; + } + return FindArea(interp, canvasPtr, argv+1, uid, 0); + } else if ((c == 'w') && (strncmp(argv[0], "withtag", length) == 0)) { + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + cmdName, option, " withtag tagOrId", (char *) NULL); + return TCL_ERROR; + } + for (itemPtr = StartTagSearch(canvasPtr, argv[1], &search); + itemPtr != NULL; itemPtr = NextItem(&search)) { + DoItem(interp, itemPtr, uid); + } + } else { + Tcl_AppendResult(interp, "bad search command \"", argv[0], + "\": must be above, all, below, closest, enclosed, ", + "overlapping, or withtag", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * FindArea -- + * + * This procedure implements area searches for the "find" + * and "addtag" options. + * + * 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 + * hold an error message. + * + * Side effects: + * If uid is non-NULL, then all the items overlapping + * or enclosed by the area in argv have that tag added to + * their lists of tags. + * + *-------------------------------------------------------------- + */ + +static int +FindArea(interp, canvasPtr, argv, uid, enclosed) + Tcl_Interp *interp; /* Interpreter for error reporting + * and result storing. */ + TkCanvas *canvasPtr; /* Canvas whose items are to be + * searched. */ + char **argv; /* Array of four arguments that + * give the coordinates of the + * rectangular area to search. */ + 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. */ + int enclosed; /* 0 means overlapping or enclosed + * items are OK, 1 means only enclosed + * items are OK. */ +{ + double rect[4], tmp; + int x1, y1, x2, y2; + Tk_Item *itemPtr; + + if ((Tk_CanvasGetCoord(interp, (Tk_Canvas) canvasPtr, argv[0], + &rect[0]) != TCL_OK) + || (Tk_CanvasGetCoord(interp, (Tk_Canvas) canvasPtr, argv[1], + &rect[1]) != TCL_OK) + || (Tk_CanvasGetCoord(interp, (Tk_Canvas) canvasPtr, argv[2], + &rect[2]) != TCL_OK) + || (Tk_CanvasGetCoord(interp, (Tk_Canvas) canvasPtr, argv[3], + &rect[3]) != TCL_OK)) { + return TCL_ERROR; + } + if (rect[0] > rect[2]) { + tmp = rect[0]; rect[0] = rect[2]; rect[2] = tmp; + } + if (rect[1] > rect[3]) { + tmp = rect[1]; rect[1] = rect[3]; rect[3] = tmp; + } + + /* + * Use an integer bounding box for a quick test, to avoid + * calling item-specific code except for items that are close. + */ + + x1 = (int) (rect[0]-1.0); + y1 = (int) (rect[1]-1.0); + x2 = (int) (rect[2]+1.0); + y2 = (int) (rect[3]+1.0); + for (itemPtr = canvasPtr->firstItemPtr; itemPtr != NULL; + itemPtr = itemPtr->nextPtr) { + if ((itemPtr->x1 >= x2) || (itemPtr->x2 <= x1) + || (itemPtr->y1 >= y2) || (itemPtr->y2 <= y1)) { + continue; + } + if ((*itemPtr->typePtr->areaProc)((Tk_Canvas) canvasPtr, itemPtr, rect) + >= enclosed) { + DoItem(interp, itemPtr, uid); + } + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * RelinkItems -- + * + * Move one or more items to a different place in the + * display order for a canvas. + * + * Results: + * None. + * + * Side effects: + * The items identified by "tag" are moved so that they + * are all together in the display list and immediately + * after prevPtr. The order of the moved items relative + * to each other is not changed. + * + *-------------------------------------------------------------- + */ + +static void +RelinkItems(canvasPtr, tag, prevPtr) + TkCanvas *canvasPtr; /* Canvas to be modified. */ + char *tag; /* Tag identifying items to be moved + * in the redisplay list. */ + Tk_Item *prevPtr; /* Reposition the items so that they + * go just after this item (NULL means + * put at beginning of list). */ +{ + Tk_Item *itemPtr; + TagSearch search; + Tk_Item *firstMovePtr, *lastMovePtr; + + /* + * Find all of the items to be moved and remove them from + * the list, making an auxiliary list running from firstMovePtr + * to lastMovePtr. Record their areas for redisplay. + */ + + firstMovePtr = lastMovePtr = NULL; + for (itemPtr = StartTagSearch(canvasPtr, tag, &search); + itemPtr != NULL; itemPtr = NextItem(&search)) { + if (itemPtr == prevPtr) { + /* + * Item after which insertion is to occur is being + * moved! Switch to insert after its predecessor. + */ + + prevPtr = search.prevPtr; + } + if (search.prevPtr == NULL) { + canvasPtr->firstItemPtr = itemPtr->nextPtr; + } else { + search.prevPtr->nextPtr = itemPtr->nextPtr; + } + if (canvasPtr->lastItemPtr == itemPtr) { + canvasPtr->lastItemPtr = search.prevPtr; + } + if (firstMovePtr == NULL) { + firstMovePtr = itemPtr; + } else { + lastMovePtr->nextPtr = itemPtr; + } + lastMovePtr = itemPtr; + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, itemPtr->x1, itemPtr->y1, + itemPtr->x2, itemPtr->y2); + canvasPtr->flags |= REPICK_NEEDED; + } + + /* + * Insert the list of to-be-moved items back into the canvas's + * at the desired position. + */ + + if (firstMovePtr == NULL) { + return; + } + if (prevPtr == NULL) { + lastMovePtr->nextPtr = canvasPtr->firstItemPtr; + canvasPtr->firstItemPtr = firstMovePtr; + } else { + lastMovePtr->nextPtr = prevPtr->nextPtr; + prevPtr->nextPtr = firstMovePtr; + } + if (canvasPtr->lastItemPtr == prevPtr) { + canvasPtr->lastItemPtr = lastMovePtr; + } +} + +/* + *-------------------------------------------------------------- + * + * CanvasBindProc -- + * + * This procedure is invoked by the Tk dispatcher to handle + * events associated with bindings on items. + * + * Results: + * None. + * + * Side effects: + * Depends on the command invoked as part of the binding + * (if there was any). + * + *-------------------------------------------------------------- + */ + +static void +CanvasBindProc(clientData, eventPtr) + ClientData clientData; /* Pointer to canvas structure. */ + XEvent *eventPtr; /* Pointer to X event that just + * happened. */ +{ + TkCanvas *canvasPtr = (TkCanvas *) clientData; + + Tcl_Preserve((ClientData) canvasPtr); + + /* + * This code below keeps track of the current modifier state in + * canvasPtr>state. This information is used to defer repicks of + * the current item while buttons are down. + */ + + if ((eventPtr->type == ButtonPress) || (eventPtr->type == ButtonRelease)) { + int mask; + + switch (eventPtr->xbutton.button) { + case Button1: + mask = Button1Mask; + break; + case Button2: + mask = Button2Mask; + break; + case Button3: + mask = Button3Mask; + break; + case Button4: + mask = Button4Mask; + break; + case Button5: + mask = Button5Mask; + break; + default: + mask = 0; + break; + } + + /* + * For button press events, repick the current item using the + * button state before the event, then process the event. For + * button release events, first process the event, then repick + * the current item using the button state *after* the event + * (the button has logically gone up before we change the + * current item). + */ + + if (eventPtr->type == ButtonPress) { + /* + * On a button press, first repick the current item using + * the button state before the event, the process the event. + */ + + canvasPtr->state = eventPtr->xbutton.state; + PickCurrentItem(canvasPtr, eventPtr); + canvasPtr->state ^= mask; + CanvasDoEvent(canvasPtr, eventPtr); + } else { + /* + * Button release: first process the event, with the button + * still considered to be down. Then repick the current + * item under the assumption that the button is no longer down. + */ + + canvasPtr->state = eventPtr->xbutton.state; + CanvasDoEvent(canvasPtr, eventPtr); + eventPtr->xbutton.state ^= mask; + canvasPtr->state = eventPtr->xbutton.state; + PickCurrentItem(canvasPtr, eventPtr); + eventPtr->xbutton.state ^= mask; + } + goto done; + } else if ((eventPtr->type == EnterNotify) + || (eventPtr->type == LeaveNotify)) { + canvasPtr->state = eventPtr->xcrossing.state; + PickCurrentItem(canvasPtr, eventPtr); + goto done; + } else if (eventPtr->type == MotionNotify) { + canvasPtr->state = eventPtr->xmotion.state; + PickCurrentItem(canvasPtr, eventPtr); + } + CanvasDoEvent(canvasPtr, eventPtr); + + done: + Tcl_Release((ClientData) canvasPtr); +} + +/* + *-------------------------------------------------------------- + * + * PickCurrentItem -- + * + * Find the topmost item in a canvas that contains a given + * location and mark the the current item. If the current + * item has changed, generate a fake exit event on the old + * current item and a fake enter event on the new current + * item. + * + * Results: + * None. + * + * Side effects: + * The current item for canvasPtr may change. If it does, + * then the commands associated with item entry and exit + * could do just about anything. A binding script could + * delete the canvas, so callers should protect themselves + * with Tcl_Preserve and Tcl_Release. + * + *-------------------------------------------------------------- + */ + +static void +PickCurrentItem(canvasPtr, eventPtr) + TkCanvas *canvasPtr; /* Canvas widget in which to select + * current item. */ + XEvent *eventPtr; /* Event describing location of + * mouse cursor. Must be EnterWindow, + * LeaveWindow, ButtonRelease, or + * MotionNotify. */ +{ + double coords[2]; + int buttonDown; + + /* + * Check whether or not a button is down. If so, we'll log entry + * and exit into and out of the current item, but not entry into + * any other item. This implements a form of grabbing equivalent + * to what the X server does for windows. + */ + + buttonDown = canvasPtr->state + & (Button1Mask|Button2Mask|Button3Mask|Button4Mask|Button5Mask); + if (!buttonDown) { + canvasPtr->flags &= ~LEFT_GRABBED_ITEM; + } + + /* + * Save information about this event in the canvas. The event in + * the canvas is used for two purposes: + * + * 1. Event bindings: if the current item changes, fake events are + * generated to allow item-enter and item-leave bindings to trigger. + * 2. Reselection: if the current item gets deleted, can use the + * saved event to find a new current item. + * Translate MotionNotify events into EnterNotify events, since that's + * what gets reported to item handlers. + */ + + if (eventPtr != &canvasPtr->pickEvent) { + if ((eventPtr->type == MotionNotify) + || (eventPtr->type == ButtonRelease)) { + canvasPtr->pickEvent.xcrossing.type = EnterNotify; + canvasPtr->pickEvent.xcrossing.serial = eventPtr->xmotion.serial; + canvasPtr->pickEvent.xcrossing.send_event + = eventPtr->xmotion.send_event; + canvasPtr->pickEvent.xcrossing.display = eventPtr->xmotion.display; + canvasPtr->pickEvent.xcrossing.window = eventPtr->xmotion.window; + canvasPtr->pickEvent.xcrossing.root = eventPtr->xmotion.root; + canvasPtr->pickEvent.xcrossing.subwindow = None; + canvasPtr->pickEvent.xcrossing.time = eventPtr->xmotion.time; + canvasPtr->pickEvent.xcrossing.x = eventPtr->xmotion.x; + canvasPtr->pickEvent.xcrossing.y = eventPtr->xmotion.y; + canvasPtr->pickEvent.xcrossing.x_root = eventPtr->xmotion.x_root; + canvasPtr->pickEvent.xcrossing.y_root = eventPtr->xmotion.y_root; + canvasPtr->pickEvent.xcrossing.mode = NotifyNormal; + canvasPtr->pickEvent.xcrossing.detail = NotifyNonlinear; + canvasPtr->pickEvent.xcrossing.same_screen + = eventPtr->xmotion.same_screen; + canvasPtr->pickEvent.xcrossing.focus = False; + canvasPtr->pickEvent.xcrossing.state = eventPtr->xmotion.state; + } else { + canvasPtr->pickEvent = *eventPtr; + } + } + + /* + * If this is a recursive call (there's already a partially completed + * call pending on the stack; it's in the middle of processing a + * Leave event handler for the old current item) then just return; + * the pending call will do everything that's needed. + */ + + if (canvasPtr->flags & REPICK_IN_PROGRESS) { + return; + } + + /* + * A LeaveNotify event automatically means that there's no current + * object, so the check for closest item can be skipped. + */ + + coords[0] = canvasPtr->pickEvent.xcrossing.x + canvasPtr->xOrigin; + coords[1] = canvasPtr->pickEvent.xcrossing.y + canvasPtr->yOrigin; + if (canvasPtr->pickEvent.type != LeaveNotify) { + canvasPtr->newCurrentPtr = CanvasFindClosest(canvasPtr, coords); + } else { + canvasPtr->newCurrentPtr = NULL; + } + + if ((canvasPtr->newCurrentPtr == canvasPtr->currentItemPtr) + && !(canvasPtr->flags & LEFT_GRABBED_ITEM)) { + /* + * Nothing to do: the current item hasn't changed. + */ + + return; + } + + /* + * Simulate a LeaveNotify event on the previous current item and + * an EnterNotify event on the new current item. Remove the "current" + * tag from the previous current item and place it on the new current + * item. + */ + + if ((canvasPtr->newCurrentPtr != canvasPtr->currentItemPtr) + && (canvasPtr->currentItemPtr != NULL) + && !(canvasPtr->flags & LEFT_GRABBED_ITEM)) { + XEvent event; + Tk_Item *itemPtr = canvasPtr->currentItemPtr; + int i; + + event = canvasPtr->pickEvent; + event.type = LeaveNotify; + + /* + * If the event's detail happens to be NotifyInferior the + * binding mechanism will discard the event. To be consistent, + * always use NotifyAncestor. + */ + + event.xcrossing.detail = NotifyAncestor; + canvasPtr->flags |= REPICK_IN_PROGRESS; + CanvasDoEvent(canvasPtr, &event); + canvasPtr->flags &= ~REPICK_IN_PROGRESS; + + /* + * The check below is needed because there could be an event + * handler for that deletes the current item. + */ + + if ((itemPtr == canvasPtr->currentItemPtr) && !buttonDown) { + for (i = itemPtr->numTags-1; i >= 0; i--) { + if (itemPtr->tagPtr[i] == currentUid) { + itemPtr->tagPtr[i] = itemPtr->tagPtr[itemPtr->numTags-1]; + itemPtr->numTags--; + break; + } + } + } + + /* + * Note: during CanvasDoEvent above, it's possible that + * canvasPtr->newCurrentPtr got reset to NULL because the + * item was deleted. + */ + } + if ((canvasPtr->newCurrentPtr != canvasPtr->currentItemPtr) && buttonDown) { + canvasPtr->flags |= LEFT_GRABBED_ITEM; + return; + } + + /* + * Special note: it's possible that canvasPtr->newCurrentPtr == + * canvasPtr->currentItemPtr here. This can happen, for example, + * if LEFT_GRABBED_ITEM was set. + */ + + canvasPtr->flags &= ~LEFT_GRABBED_ITEM; + canvasPtr->currentItemPtr = canvasPtr->newCurrentPtr; + if (canvasPtr->currentItemPtr != NULL) { + XEvent event; + + DoItem((Tcl_Interp *) NULL, canvasPtr->currentItemPtr, currentUid); + event = canvasPtr->pickEvent; + event.type = EnterNotify; + event.xcrossing.detail = NotifyAncestor; + CanvasDoEvent(canvasPtr, &event); + } +} + +/* + *---------------------------------------------------------------------- + * + * CanvasFindClosest -- + * + * Given x and y coordinates, find the topmost canvas item that + * is "close" to the coordinates. + * + * Results: + * The return value is a pointer to the topmost item that is + * close to (x,y), or NULL if no item is close. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Tk_Item * +CanvasFindClosest(canvasPtr, coords) + TkCanvas *canvasPtr; /* Canvas widget to search. */ + double coords[2]; /* Desired x,y position in canvas, + * not screen, coordinates.) */ +{ + Tk_Item *itemPtr; + Tk_Item *bestPtr; + int x1, y1, x2, y2; + + x1 = (int) (coords[0] - canvasPtr->closeEnough); + y1 = (int) (coords[1] - canvasPtr->closeEnough); + x2 = (int) (coords[0] + canvasPtr->closeEnough); + y2 = (int) (coords[1] + canvasPtr->closeEnough); + + bestPtr = NULL; + for (itemPtr = canvasPtr->firstItemPtr; itemPtr != NULL; + itemPtr = itemPtr->nextPtr) { + if ((itemPtr->x1 > x2) || (itemPtr->x2 < x1) + || (itemPtr->y1 > y2) || (itemPtr->y2 < y1)) { + continue; + } + if ((*itemPtr->typePtr->pointProc)((Tk_Canvas) canvasPtr, + itemPtr, coords) <= canvasPtr->closeEnough) { + bestPtr = itemPtr; + } + } + return bestPtr; +} + +/* + *-------------------------------------------------------------- + * + * CanvasDoEvent -- + * + * This procedure is called to invoke binding processing + * for a new event that is associated with the current item + * for a canvas. + * + * Results: + * None. + * + * Side effects: + * Depends on the bindings for the canvas. A binding script + * could delete the canvas, so callers should protect themselves + * with Tcl_Preserve and Tcl_Release. + * + *-------------------------------------------------------------- + */ + +static void +CanvasDoEvent(canvasPtr, eventPtr) + TkCanvas *canvasPtr; /* Canvas widget in which event + * occurred. */ + XEvent *eventPtr; /* Real or simulated X event that + * is to be processed. */ +{ +#define NUM_STATIC 3 + ClientData staticObjects[NUM_STATIC]; + ClientData *objectPtr; + int numObjects, i; + Tk_Item *itemPtr; + + if (canvasPtr->bindingTable == NULL) { + return; + } + + itemPtr = canvasPtr->currentItemPtr; + if ((eventPtr->type == KeyPress) || (eventPtr->type == KeyRelease)) { + itemPtr = canvasPtr->textInfo.focusItemPtr; + } + if (itemPtr == NULL) { + return; + } + + /* + * Set up an array with all the relevant objects for processing + * this event. The relevant objects are (a) the event's item, + * (b) the tags associated with the event's item, and (c) the + * tag "all". If there are a lot of tags then malloc an array + * to hold all of the objects. + */ + + numObjects = itemPtr->numTags + 2; + if (numObjects <= NUM_STATIC) { + objectPtr = staticObjects; + } else { + objectPtr = (ClientData *) ckalloc((unsigned) + (numObjects * sizeof(ClientData))); + } + objectPtr[0] = (ClientData) allUid; + for (i = itemPtr->numTags-1; i >= 0; i--) { + objectPtr[i+1] = (ClientData) itemPtr->tagPtr[i]; + } + objectPtr[itemPtr->numTags+1] = (ClientData) itemPtr; + + /* + * Invoke the binding system, then free up the object array if + * it was malloc-ed. + */ + + if (canvasPtr->tkwin != NULL) { + Tk_BindEvent(canvasPtr->bindingTable, eventPtr, canvasPtr->tkwin, + numObjects, objectPtr); + } + if (objectPtr != staticObjects) { + ckfree((char *) objectPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * CanvasBlinkProc -- + * + * This procedure is called as a timer handler to blink the + * insertion cursor off and on. + * + * Results: + * None. + * + * Side effects: + * The cursor gets turned on or off, redisplay gets invoked, + * and this procedure reschedules itself. + * + *---------------------------------------------------------------------- + */ + +static void +CanvasBlinkProc(clientData) + ClientData clientData; /* Pointer to record describing entry. */ +{ + TkCanvas *canvasPtr = (TkCanvas *) clientData; + + if (!canvasPtr->textInfo.gotFocus || (canvasPtr->insertOffTime == 0)) { + return; + } + if (canvasPtr->textInfo.cursorOn) { + canvasPtr->textInfo.cursorOn = 0; + canvasPtr->insertBlinkHandler = Tcl_CreateTimerHandler( + canvasPtr->insertOffTime, CanvasBlinkProc, + (ClientData) canvasPtr); + } else { + canvasPtr->textInfo.cursorOn = 1; + canvasPtr->insertBlinkHandler = Tcl_CreateTimerHandler( + canvasPtr->insertOnTime, CanvasBlinkProc, + (ClientData) canvasPtr); + } + if (canvasPtr->textInfo.focusItemPtr != NULL) { + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + canvasPtr->textInfo.focusItemPtr->x1, + canvasPtr->textInfo.focusItemPtr->y1, + canvasPtr->textInfo.focusItemPtr->x2, + canvasPtr->textInfo.focusItemPtr->y2); + } +} + +/* + *---------------------------------------------------------------------- + * + * CanvasFocusProc -- + * + * This procedure is called whenever a canvas gets or loses the + * input focus. It's also called whenever the window is + * reconfigured while it has the focus. + * + * Results: + * None. + * + * Side effects: + * The cursor gets turned on or off. + * + *---------------------------------------------------------------------- + */ + +static void +CanvasFocusProc(canvasPtr, gotFocus) + TkCanvas *canvasPtr; /* Canvas that just got or lost focus. */ + int gotFocus; /* 1 means window is getting focus, 0 means + * it's losing it. */ +{ + Tcl_DeleteTimerHandler(canvasPtr->insertBlinkHandler); + if (gotFocus) { + canvasPtr->textInfo.gotFocus = 1; + canvasPtr->textInfo.cursorOn = 1; + if (canvasPtr->insertOffTime != 0) { + canvasPtr->insertBlinkHandler = Tcl_CreateTimerHandler( + canvasPtr->insertOffTime, CanvasBlinkProc, + (ClientData) canvasPtr); + } + } else { + canvasPtr->textInfo.gotFocus = 0; + canvasPtr->textInfo.cursorOn = 0; + canvasPtr->insertBlinkHandler = (Tcl_TimerToken) NULL; + } + if (canvasPtr->textInfo.focusItemPtr != NULL) { + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + canvasPtr->textInfo.focusItemPtr->x1, + canvasPtr->textInfo.focusItemPtr->y1, + canvasPtr->textInfo.focusItemPtr->x2, + canvasPtr->textInfo.focusItemPtr->y2); + } + if (canvasPtr->highlightWidth > 0) { + canvasPtr->flags |= REDRAW_BORDERS; + if (!(canvasPtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(DisplayCanvas, (ClientData) canvasPtr); + canvasPtr->flags |= REDRAW_PENDING; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * CanvasSelectTo -- + * + * Modify the selection by moving its un-anchored end. This could + * make the selection either larger or smaller. + * + * Results: + * None. + * + * Side effects: + * The selection changes. + * + *---------------------------------------------------------------------- + */ + +static void +CanvasSelectTo(canvasPtr, itemPtr, index) + TkCanvas *canvasPtr; /* Information about widget. */ + Tk_Item *itemPtr; /* Item that is to hold selection. */ + int index; /* Index of element that is to become the + * "other" end of the selection. */ +{ + int oldFirst, oldLast; + Tk_Item *oldSelPtr; + + oldFirst = canvasPtr->textInfo.selectFirst; + oldLast = canvasPtr->textInfo.selectLast; + oldSelPtr = canvasPtr->textInfo.selItemPtr; + + /* + * Grab the selection if we don't own it already. + */ + + if (canvasPtr->textInfo.selItemPtr == NULL) { + Tk_OwnSelection(canvasPtr->tkwin, XA_PRIMARY, CanvasLostSelection, + (ClientData) canvasPtr); + } else if (canvasPtr->textInfo.selItemPtr != itemPtr) { + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + canvasPtr->textInfo.selItemPtr->x1, + canvasPtr->textInfo.selItemPtr->y1, + canvasPtr->textInfo.selItemPtr->x2, + canvasPtr->textInfo.selItemPtr->y2); + } + canvasPtr->textInfo.selItemPtr = itemPtr; + + if (canvasPtr->textInfo.anchorItemPtr != itemPtr) { + canvasPtr->textInfo.anchorItemPtr = itemPtr; + canvasPtr->textInfo.selectAnchor = index; + } + if (canvasPtr->textInfo.selectAnchor <= index) { + canvasPtr->textInfo.selectFirst = canvasPtr->textInfo.selectAnchor; + canvasPtr->textInfo.selectLast = index; + } else { + canvasPtr->textInfo.selectFirst = index; + canvasPtr->textInfo.selectLast = canvasPtr->textInfo.selectAnchor - 1; + } + if ((canvasPtr->textInfo.selectFirst != oldFirst) + || (canvasPtr->textInfo.selectLast != oldLast) + || (itemPtr != oldSelPtr)) { + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + itemPtr->x1, itemPtr->y1, itemPtr->x2, itemPtr->y2); + } +} + +/* + *-------------------------------------------------------------- + * + * CanvasFetchSelection -- + * + * This procedure is invoked by Tk to return part or all of + * the selection, when the selection is in a canvas widget. + * This procedure always returns the selection as a STRING. + * + * Results: + * The return value is the number of non-NULL bytes stored + * at buffer. Buffer is filled (or partially filled) with a + * NULL-terminated string containing part or all of the selection, + * as given by offset and maxBytes. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static int +CanvasFetchSelection(clientData, offset, buffer, maxBytes) + ClientData clientData; /* Information about canvas 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. */ +{ + TkCanvas *canvasPtr = (TkCanvas *) clientData; + + if (canvasPtr->textInfo.selItemPtr == NULL) { + return -1; + } + if (canvasPtr->textInfo.selItemPtr->typePtr->selectionProc == NULL) { + return -1; + } + return (*canvasPtr->textInfo.selItemPtr->typePtr->selectionProc)( + (Tk_Canvas) canvasPtr, canvasPtr->textInfo.selItemPtr, offset, + buffer, maxBytes); +} + +/* + *---------------------------------------------------------------------- + * + * CanvasLostSelection -- + * + * This procedure is called back by Tk when the selection is + * grabbed away from a canvas widget. + * + * Results: + * None. + * + * Side effects: + * The existing selection is unhighlighted, and the window is + * marked as not containing a selection. + * + *---------------------------------------------------------------------- + */ + +static void +CanvasLostSelection(clientData) + ClientData clientData; /* Information about entry widget. */ +{ + TkCanvas *canvasPtr = (TkCanvas *) clientData; + + if (canvasPtr->textInfo.selItemPtr != NULL) { + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + canvasPtr->textInfo.selItemPtr->x1, + canvasPtr->textInfo.selItemPtr->y1, + canvasPtr->textInfo.selItemPtr->x2, + canvasPtr->textInfo.selItemPtr->y2); + } + canvasPtr->textInfo.selItemPtr = NULL; +} + +/* + *-------------------------------------------------------------- + * + * GridAlign -- + * + * Given a coordinate and a grid spacing, this procedure + * computes the location of the nearest grid line to the + * coordinate. + * + * Results: + * The return value is the location of the grid line nearest + * to coord. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static double +GridAlign(coord, spacing) + double coord; /* Coordinate to grid-align. */ + double spacing; /* Spacing between grid lines. If <= 0 + * then no alignment is done. */ +{ + if (spacing <= 0.0) { + return coord; + } + if (coord < 0) { + return -((int) ((-coord)/spacing + 0.5)) * spacing; + } + return ((int) (coord/spacing + 0.5)) * spacing; +} + +/* + *---------------------------------------------------------------------- + * + * PrintScrollFractions -- + * + * Given the range that's visible in the window and the "100% + * range" for what's in the canvas, print a string containing + * the scroll fractions. This procedure is used for both x + * and y scrolling. + * + * Results: + * The memory pointed to by string is modified to hold + * two real numbers containing the scroll fractions (between + * 0 and 1) corresponding to the other arguments. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +PrintScrollFractions(screen1, screen2, object1, object2, string) + int screen1; /* Lowest coordinate visible in the window. */ + int screen2; /* Highest coordinate visible in the window. */ + int object1; /* Lowest coordinate in the object. */ + int object2; /* Highest coordinate in the object. */ + char *string; /* Two real numbers get printed here. Must + * have enough storage for two %g + * conversions. */ +{ + double range, f1, f2; + + range = object2 - object1; + if (range <= 0) { + f1 = 0; + f2 = 1.0; + } else { + f1 = (screen1 - object1)/range; + if (f1 < 0) { + f1 = 0.0; + } + f2 = (screen2 - object1)/range; + if (f2 > 1.0) { + f2 = 1.0; + } + if (f2 < f1) { + f2 = f1; + } + } + sprintf(string, "%g %g", f1, f2); +} + +/* + *-------------------------------------------------------------- + * + * CanvasUpdateScrollbars -- + * + * This procedure is invoked whenever a canvas has changed in + * a way that requires scrollbars to be redisplayed (e.g. the + * view in the canvas has changed). + * + * Results: + * None. + * + * Side effects: + * If there are scrollbars associated with the canvas, then + * their scrolling commands are invoked to cause them to + * redisplay. If errors occur, additional Tcl commands may + * be invoked to process the errors. + * + *-------------------------------------------------------------- + */ + +static void +CanvasUpdateScrollbars(canvasPtr) + TkCanvas *canvasPtr; /* Information about canvas. */ +{ + int result; + char buffer[200]; + Tcl_Interp *interp; + int xOrigin, yOrigin, inset, width, height, scrollX1, scrollX2, + scrollY1, scrollY2; + char *xScrollCmd, *yScrollCmd; + + /* + * Save all the relevant values from the canvasPtr, because it might be + * deleted as part of either of the two calls to Tcl_VarEval below. + */ + + interp = canvasPtr->interp; + Tcl_Preserve((ClientData) interp); + xScrollCmd = canvasPtr->xScrollCmd; + if (xScrollCmd != (char *) NULL) { + Tcl_Preserve((ClientData) xScrollCmd); + } + yScrollCmd = canvasPtr->yScrollCmd; + if (yScrollCmd != (char *) NULL) { + Tcl_Preserve((ClientData) yScrollCmd); + } + xOrigin = canvasPtr->xOrigin; + yOrigin = canvasPtr->yOrigin; + inset = canvasPtr->inset; + width = Tk_Width(canvasPtr->tkwin); + height = Tk_Height(canvasPtr->tkwin); + scrollX1 = canvasPtr->scrollX1; + scrollX2 = canvasPtr->scrollX2; + scrollY1 = canvasPtr->scrollY1; + scrollY2 = canvasPtr->scrollY2; + canvasPtr->flags &= ~UPDATE_SCROLLBARS; + if (canvasPtr->xScrollCmd != NULL) { + PrintScrollFractions(xOrigin + inset, xOrigin + width - inset, + scrollX1, scrollX2, buffer); + result = Tcl_VarEval(interp, xScrollCmd, " ", buffer, (char *) NULL); + if (result != TCL_OK) { + Tcl_BackgroundError(interp); + } + Tcl_ResetResult(interp); + Tcl_Release((ClientData) xScrollCmd); + } + + if (yScrollCmd != NULL) { + PrintScrollFractions(yOrigin + inset, yOrigin + height - inset, + scrollY1, scrollY2, buffer); + result = Tcl_VarEval(interp, yScrollCmd, " ", buffer, (char *) NULL); + if (result != TCL_OK) { + Tcl_BackgroundError(interp); + } + Tcl_ResetResult(interp); + Tcl_Release((ClientData) yScrollCmd); + } + Tcl_Release((ClientData) interp); +} + +/* + *-------------------------------------------------------------- + * + * CanvasSetOrigin -- + * + * This procedure is invoked to change the mapping between + * canvas coordinates and screen coordinates in the canvas + * window. + * + * Results: + * None. + * + * Side effects: + * The canvas will be redisplayed to reflect the change in + * view. In addition, scrollbars will be updated if there + * are any. + * + *-------------------------------------------------------------- + */ + +static void +CanvasSetOrigin(canvasPtr, xOrigin, yOrigin) + TkCanvas *canvasPtr; /* Information about canvas. */ + int xOrigin; /* New X origin for canvas (canvas x-coord + * corresponding to left edge of canvas + * window). */ + int yOrigin; /* New Y origin for canvas (canvas y-coord + * corresponding to top edge of canvas + * window). */ +{ + int left, right, top, bottom, delta; + + /* + * If scroll increments have been set, round the window origin + * to the nearest multiple of the increments. Remember, the + * origin is the place just inside the borders, not the upper + * left corner. + */ + + if (canvasPtr->xScrollIncrement > 0) { + if (xOrigin >= 0) { + xOrigin += canvasPtr->xScrollIncrement/2; + xOrigin -= (xOrigin + canvasPtr->inset) + % canvasPtr->xScrollIncrement; + } else { + xOrigin = (-xOrigin) + canvasPtr->xScrollIncrement/2; + xOrigin = -(xOrigin - (xOrigin - canvasPtr->inset) + % canvasPtr->xScrollIncrement); + } + } + if (canvasPtr->yScrollIncrement > 0) { + if (yOrigin >= 0) { + yOrigin += canvasPtr->yScrollIncrement/2; + yOrigin -= (yOrigin + canvasPtr->inset) + % canvasPtr->yScrollIncrement; + } else { + yOrigin = (-yOrigin) + canvasPtr->yScrollIncrement/2; + yOrigin = -(yOrigin - (yOrigin - canvasPtr->inset) + % canvasPtr->yScrollIncrement); + } + } + + /* + * Adjust the origin if necessary to keep as much as possible of the + * canvas in the view. The variables left, right, etc. keep track of + * how much extra space there is on each side of the view before it + * will stick out past the scroll region. If one side sticks out past + * the edge of the scroll region, adjust the view to bring that side + * back to the edge of the scrollregion (but don't move it so much that + * the other side sticks out now). If scroll increments are in effect, + * be sure to adjust only by full increments. + */ + + if ((canvasPtr->confine) && (canvasPtr->regionString != NULL)) { + left = xOrigin + canvasPtr->inset - canvasPtr->scrollX1; + right = canvasPtr->scrollX2 + - (xOrigin + Tk_Width(canvasPtr->tkwin) - canvasPtr->inset); + top = yOrigin + canvasPtr->inset - canvasPtr->scrollY1; + bottom = canvasPtr->scrollY2 + - (yOrigin + Tk_Height(canvasPtr->tkwin) - canvasPtr->inset); + if ((left < 0) && (right > 0)) { + delta = (right > -left) ? -left : right; + if (canvasPtr->xScrollIncrement > 0) { + delta -= delta % canvasPtr->xScrollIncrement; + } + xOrigin += delta; + } else if ((right < 0) && (left > 0)) { + delta = (left > -right) ? -right : left; + if (canvasPtr->xScrollIncrement > 0) { + delta -= delta % canvasPtr->xScrollIncrement; + } + xOrigin -= delta; + } + if ((top < 0) && (bottom > 0)) { + delta = (bottom > -top) ? -top : bottom; + if (canvasPtr->yScrollIncrement > 0) { + delta -= delta % canvasPtr->yScrollIncrement; + } + yOrigin += delta; + } else if ((bottom < 0) && (top > 0)) { + delta = (top > -bottom) ? -bottom : top; + if (canvasPtr->yScrollIncrement > 0) { + delta -= delta % canvasPtr->yScrollIncrement; + } + yOrigin -= delta; + } + } + + if ((xOrigin == canvasPtr->xOrigin) && (yOrigin == canvasPtr->yOrigin)) { + return; + } + + /* + * Tricky point: must redisplay not only everything that's visible + * in the window's final configuration, but also everything that was + * visible in the initial configuration. This is needed because some + * item types, like windows, need to know when they move off-screen + * so they can explicitly undisplay themselves. + */ + + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + canvasPtr->xOrigin, canvasPtr->yOrigin, + canvasPtr->xOrigin + Tk_Width(canvasPtr->tkwin), + canvasPtr->yOrigin + Tk_Height(canvasPtr->tkwin)); + canvasPtr->xOrigin = xOrigin; + canvasPtr->yOrigin = yOrigin; + canvasPtr->flags |= UPDATE_SCROLLBARS; + Tk_CanvasEventuallyRedraw((Tk_Canvas) canvasPtr, + canvasPtr->xOrigin, canvasPtr->yOrigin, + canvasPtr->xOrigin + Tk_Width(canvasPtr->tkwin), + canvasPtr->yOrigin + Tk_Height(canvasPtr->tkwin)); +} diff --git a/generic/tkCanvas.h b/generic/tkCanvas.h new file mode 100644 index 0000000..52b3a51 --- /dev/null +++ b/generic/tkCanvas.h @@ -0,0 +1,257 @@ +/* + * tkCanvas.h -- + * + * Declarations shared among all the files that implement + * canvas widgets. + * + * Copyright (c) 1991-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkCanvas.h 1.41 96/02/15 18:51:28 + */ + +#ifndef _TKCANVAS +#define _TKCANVAS + +#ifndef _TK +#include "tk.h" +#endif + +/* + * The record below describes a canvas widget. It is made available + * to the item procedures so they can access certain shared fields such + * as the overall displacement and scale factor for the canvas. + */ + +typedef struct TkCanvas { + Tk_Window tkwin; /* Window that embodies the canvas. NULL + * means that the window has been destroyed + * but the data structures haven't yet been + * cleaned up.*/ + Display *display; /* Display containing widget; needed, among + * other things, to release resources after + * tkwin has already gone away. */ + Tcl_Interp *interp; /* Interpreter associated with canvas. */ + Tcl_Command widgetCmd; /* Token for canvas's widget command. */ + Tk_Item *firstItemPtr; /* First in list of all items in canvas, + * or NULL if canvas empty. */ + Tk_Item *lastItemPtr; /* Last in list of all items in canvas, + * or NULL if canvas empty. */ + + /* + * Information used when displaying widget: + */ + + int borderWidth; /* Width of 3-D border around window. */ + Tk_3DBorder bgBorder; /* Used for canvas background. */ + int relief; /* Indicates whether window as a whole is + * raised, sunken, or flat. */ + int highlightWidth; /* Width in pixels of highlight to draw + * around widget when it has the focus. + * <= 0 means don't draw a highlight. */ + XColor *highlightBgColorPtr; + /* Color for drawing traversal highlight + * area when highlight is off. */ + XColor *highlightColorPtr; /* 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. */ + GC pixmapGC; /* Used to copy bits from a pixmap to the + * screen and also to clear the pixmap. */ + int width, height; /* Dimensions to request for canvas window, + * specified in pixels. */ + int redrawX1, redrawY1; /* Upper left corner of area to redraw, + * in pixel coordinates. Border pixels + * are included. Only valid if + * REDRAW_PENDING flag is set. */ + int redrawX2, redrawY2; /* Lower right corner of area to redraw, + * in integer canvas coordinates. Border + * pixels will *not* be redrawn. */ + int confine; /* Non-zero means constrain view to keep + * as much of canvas visible as possible. */ + + /* + * Information used to manage the selection and insertion cursor: + */ + + Tk_CanvasTextInfo textInfo; /* Contains lots of fields; see tk.h for + * details. This structure is shared with + * the code that implements individual items. */ + int insertOnTime; /* Number of milliseconds cursor should spend + * in "on" state for each blink. */ + int insertOffTime; /* Number of milliseconds cursor should spend + * in "off" state for each blink. */ + Tcl_TimerToken insertBlinkHandler; + /* Timer handler used to blink cursor on and + * off. */ + + /* + * Transformation applied to canvas as a whole: to compute screen + * coordinates (X,Y) from canvas coordinates (x,y), do the following: + * + * X = x - xOrigin; + * Y = y - yOrigin; + */ + + int xOrigin, yOrigin; /* Canvas coordinates corresponding to + * upper-left corner of window, given in + * canvas pixel units. */ + int drawableXOrigin, drawableYOrigin; + /* During redisplay, these fields give the + * canvas coordinates corresponding to + * the upper-left corner of the drawable + * where items are actually being drawn + * (typically a pixmap smaller than the + * whole window). */ + + /* + * Information used for event bindings associated with items. + */ + + Tk_BindingTable bindingTable; + /* Table of all bindings currently defined + * for this canvas. NULL means that no + * bindings exist, so the table hasn't been + * created. Each "object" used for this + * table is either a Tk_Uid for a tag or + * the address of an item named by id. */ + Tk_Item *currentItemPtr; /* The item currently containing the mouse + * pointer, or NULL if none. */ + Tk_Item *newCurrentPtr; /* The item that is about to become the + * current one, or NULL. This field is + * used to detect deletions of the new + * current item pointer that occur during + * Leave processing of the previous current + * item. */ + double closeEnough; /* The mouse is assumed to be inside an + * item if it is this close to it. */ + XEvent pickEvent; /* The event upon which the current choice + * of currentItem is based. Must be saved + * so that if the currentItem is deleted, + * can pick another. */ + int state; /* Last known modifier state. Used to + * defer picking a new current object + * while buttons are down. */ + + /* + * Information used for managing scrollbars: + */ + + char *xScrollCmd; /* Command prefix for communicating with + * horizontal scrollbar. NULL means no + * horizontal scrollbar. Malloc'ed*/ + char *yScrollCmd; /* Command prefix for communicating with + * vertical scrollbar. NULL means no + * vertical scrollbar. Malloc'ed*/ + int scrollX1, scrollY1, scrollX2, scrollY2; + /* These four coordinates define the region + * that is the 100% area for scrolling (i.e. + * these numbers determine the size and + * location of the sliders on scrollbars). + * Units are pixels in canvas coords. */ + char *regionString; /* The option string from which scrollX1 + * etc. are derived. Malloc'ed. */ + int xScrollIncrement; /* If >0, defines a grid for horizontal + * scrolling. This is the size of the "unit", + * and the left edge of the screen will always + * lie on an even unit boundary. */ + int yScrollIncrement; /* If >0, defines a grid for horizontal + * scrolling. This is the size of the "unit", + * and the left edge of the screen will always + * lie on an even unit boundary. */ + + /* + * Information used for scanning: + */ + + int scanX; /* X-position at which scan started (e.g. + * button was pressed here). */ + int scanXOrigin; /* Value of xOrigin field when scan started. */ + int scanY; /* Y-position at which scan started (e.g. + * button was pressed here). */ + int scanYOrigin; /* Value of yOrigin field when scan started. */ + + /* + * Information used to speed up searches by remembering the last item + * created or found with an item id search. + */ + + Tk_Item *hotPtr; /* Pointer to "hot" item (one that's been + * recently used. NULL means there's no + * hot item. */ + Tk_Item *hotPrevPtr; /* Pointer to predecessor to hotPtr (NULL + * means item is first in list). This is + * only a hint and may not really be hotPtr's + * predecessor. */ + + /* + * Miscellaneous information: + */ + + Tk_Cursor cursor; /* Current cursor for window, or None. */ + char *takeFocus; /* Value of -takefocus option; not used in + * the C code, but used by keyboard traversal + * scripts. Malloc'ed, but may be NULL. */ + double pixelsPerMM; /* Scale factor between MM and pixels; + * used when converting coordinates. */ + int flags; /* Various flags; see below for + * definitions. */ + int nextId; /* Number to use as id for next item + * created in widget. */ + struct TkPostscriptInfo *psInfoPtr; + /* Pointer to information used for generating + * Postscript for the canvas. NULL means + * no Postscript is currently being + * generated. */ +} TkCanvas; + +/* + * Flag bits for canvases: + * + * REDRAW_PENDING - 1 means a DoWhenIdle handler has already + * been created to redraw some or all of the + * canvas. + * REDRAW_BORDERS - 1 means that the borders need to be redrawn + * during the next redisplay operation. + * REPICK_NEEDED - 1 means DisplayCanvas should pick a new + * current item before redrawing the canvas. + * GOT_FOCUS - 1 means the focus is currently in this + * widget, so should draw the insertion cursor + * and traversal highlight. + * CURSOR_ON - 1 means the insertion cursor is in the "on" + * phase of its blink cycle. 0 means either + * we don't have the focus or the cursor is in + * the "off" phase of its cycle. + * UPDATE_SCROLLBARS - 1 means the scrollbars should get updated + * as part of the next display operation. + * LEFT_GRABBED_ITEM - 1 means that the mouse left the current + * item while a grab was in effect, so we + * didn't change canvasPtr->currentItemPtr. + * REPICK_IN_PROGRESS - 1 means PickCurrentItem is currently + * executing. If it should be called recursively, + * it should simply return immediately. + */ + +#define REDRAW_PENDING 1 +#define REDRAW_BORDERS 2 +#define REPICK_NEEDED 4 +#define GOT_FOCUS 8 +#define CURSOR_ON 0x10 +#define UPDATE_SCROLLBARS 0x20 +#define LEFT_GRABBED_ITEM 0x40 +#define REPICK_IN_PROGRESS 0x100 + +/* + * Canvas-related procedures that are shared among Tk modules but not + * exported to the outside world: + */ + +extern int TkCanvPostscriptCmd _ANSI_ARGS_((TkCanvas *canvasPtr, + Tcl_Interp *interp, int argc, char **argv)); + +#endif /* _TKCANVAS */ diff --git a/generic/tkClipboard.c b/generic/tkClipboard.c new file mode 100644 index 0000000..e1c9510 --- /dev/null +++ b/generic/tkClipboard.c @@ -0,0 +1,606 @@ +/* + * tkClipboard.c -- + * + * This file manages the clipboard for the Tk toolkit, + * maintaining a collection of data buffers that will be + * supplied on demand to requesting applications. + * + * Copyright (c) 1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkClipboard.c 1.15 96/05/03 10:51:08 + */ + +#include "tkInt.h" +#include "tkPort.h" +#include "tkSelect.h" + +/* + * Prototypes for procedures used only in this file: + */ + +static int ClipboardAppHandler _ANSI_ARGS_((ClientData clientData, + int offset, char *buffer, int maxBytes)); +static int ClipboardHandler _ANSI_ARGS_((ClientData clientData, + int offset, char *buffer, int maxBytes)); +static int ClipboardWindowHandler _ANSI_ARGS_(( + ClientData clientData, int offset, char *buffer, + int maxBytes)); +static void ClipboardLostSel _ANSI_ARGS_((ClientData clientData)); + +/* + *---------------------------------------------------------------------- + * + * ClipboardHandler -- + * + * This procedure acts as selection handler for the + * clipboard manager. It extracts the required chunk of + * data from the buffer chain for a given selection target. + * + * Results: + * The return value is a count of the number of bytes + * actually stored at buffer. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ClipboardHandler(clientData, offset, buffer, maxBytes) + ClientData clientData; /* Information about data to fetch. */ + int offset; /* Return selection bytes starting at this + * offset. */ + char *buffer; /* Place to store converted selection. */ + int maxBytes; /* Maximum # of bytes to store at buffer. */ +{ + TkClipboardTarget *targetPtr = (TkClipboardTarget*) clientData; + TkClipboardBuffer *cbPtr; + char *srcPtr, *destPtr; + int count = 0; + int scanned = 0; + size_t length, freeCount; + + /* + * Skip to buffer containing offset byte + */ + + for (cbPtr = targetPtr->firstBufferPtr; ; cbPtr = cbPtr->nextPtr) { + if (cbPtr == NULL) { + return 0; + } + if (scanned + cbPtr->length > offset) { + break; + } + scanned += cbPtr->length; + } + + /* + * Copy up to maxBytes or end of list, switching buffers as needed. + */ + + freeCount = maxBytes; + srcPtr = cbPtr->buffer + (offset - scanned); + destPtr = buffer; + length = cbPtr->length - (offset - scanned); + while (1) { + if (length > freeCount) { + strncpy(destPtr, srcPtr, freeCount); + return maxBytes; + } else { + strncpy(destPtr, srcPtr, length); + destPtr += length; + count += length; + freeCount -= length; + } + cbPtr = cbPtr->nextPtr; + if (cbPtr == NULL) { + break; + } + srcPtr = cbPtr->buffer; + length = cbPtr->length; + } + return count; +} + +/* + *---------------------------------------------------------------------- + * + * ClipboardAppHandler -- + * + * This procedure acts as selection handler for retrievals of type + * TK_APPLICATION. It returns the name of the application that + * owns the clipboard. Note: we can't use the default Tk + * selection handler for this selection type, because the clipboard + * window isn't a "real" window and doesn't have the necessary + * information. + * + * Results: + * The return value is a count of the number of bytes + * actually stored at buffer. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ClipboardAppHandler(clientData, offset, buffer, maxBytes) + ClientData clientData; /* Pointer to TkDisplay structure. */ + int offset; /* Return selection bytes starting at this + * offset. */ + char *buffer; /* Place to store converted selection. */ + int maxBytes; /* Maximum # of bytes to store at buffer. */ +{ + TkDisplay *dispPtr = (TkDisplay *) clientData; + size_t length; + char *p; + + p = dispPtr->clipboardAppPtr->winPtr->nameUid; + length = strlen(p); + length -= offset; + if (length <= 0) { + return 0; + } + if (length > (size_t) maxBytes) { + length = maxBytes; + } + strncpy(buffer, p, length); + return length; +} + +/* + *---------------------------------------------------------------------- + * + * ClipboardWindowHandler -- + * + * This procedure acts as selection handler for retrievals of + * type TK_WINDOW. Since the clipboard doesn't correspond to + * any particular window, we just return ".". We can't use Tk's + * default handler for this selection type, because the clipboard + * window isn't a valid window. + * + * Results: + * The return value is 1, the number of non-null bytes stored + * at buffer. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ClipboardWindowHandler(clientData, offset, buffer, maxBytes) + ClientData clientData; /* Not used. */ + int offset; /* Return selection bytes starting at this + * offset. */ + char *buffer; /* Place to store converted selection. */ + int maxBytes; /* Maximum # of bytes to store at buffer. */ +{ + buffer[0] = '.'; + buffer[1] = 0; + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * ClipboardLostSel -- + * + * This procedure is invoked whenever clipboard ownership is + * claimed by another window. It just sets a flag so that we + * know the clipboard was taken away. + * + * Results: + * None. + * + * Side effects: + * The clipboard is marked as inactive. + * + *---------------------------------------------------------------------- + */ + +static void +ClipboardLostSel(clientData) + ClientData clientData; /* Pointer to TkDisplay structure. */ +{ + TkDisplay *dispPtr = (TkDisplay*) clientData; + + dispPtr->clipboardActive = 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_ClipboardClear -- + * + * Take control of the clipboard and clear out the previous + * contents. This procedure must be invoked before any + * calls to Tk_AppendToClipboard. + * + * Results: + * A standard Tcl result. If an error occurs, an error message is + * left in interp->result. + * + * Side effects: + * From now on, requests for the CLIPBOARD selection will be + * directed to the clipboard manager routines associated with + * clipWindow for the display of tkwin. In order to guarantee + * atomicity, no event handling should occur between + * Tk_ClipboardClear and the following Tk_AppendToClipboard + * calls. This procedure may cause a user-defined LostSel command + * to be invoked when the CLIPBOARD is claimed, so any calling + * function should be reentrant at the point Tk_ClipboardClear is + * invoked. + * + *---------------------------------------------------------------------- + */ + +int +Tk_ClipboardClear(interp, tkwin) + Tcl_Interp *interp; /* Interpreter to use for error reporting. */ + Tk_Window tkwin; /* Window in application that is clearing + * clipboard; identifies application and + * display. */ +{ + TkWindow *winPtr = (TkWindow *) tkwin; + TkDisplay *dispPtr = winPtr->dispPtr; + TkClipboardTarget *targetPtr, *nextTargetPtr; + TkClipboardBuffer *cbPtr, *nextCbPtr; + + if (dispPtr->clipWindow == NULL) { + int result; + + result = TkClipInit(interp, dispPtr); + if (result != TCL_OK) { + return result; + } + } + + /* + * Discard any existing clipboard data and delete the selection + * handler(s) associated with that data. + */ + + for (targetPtr = dispPtr->clipTargetPtr; targetPtr != NULL; + targetPtr = nextTargetPtr) { + for (cbPtr = targetPtr->firstBufferPtr; cbPtr != NULL; + cbPtr = nextCbPtr) { + ckfree(cbPtr->buffer); + nextCbPtr = cbPtr->nextPtr; + ckfree((char *) cbPtr); + } + nextTargetPtr = targetPtr->nextPtr; + Tk_DeleteSelHandler(dispPtr->clipWindow, dispPtr->clipboardAtom, + targetPtr->type); + ckfree((char *) targetPtr); + } + dispPtr->clipTargetPtr = NULL; + + /* + * Reclaim the clipboard selection if we lost it. + */ + + if (!dispPtr->clipboardActive) { + Tk_OwnSelection(dispPtr->clipWindow, dispPtr->clipboardAtom, + ClipboardLostSel, (ClientData) dispPtr); + dispPtr->clipboardActive = 1; + } + dispPtr->clipboardAppPtr = winPtr->mainPtr; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_ClipboardAppend -- + * + * Append a buffer of data to the clipboard. The first buffer of + * a given type determines the format for that type. Any successive + * appends to that type must have the same format or an error will + * be returned. Tk_ClipboardClear must be called before a sequence + * of Tk_ClipboardAppend calls can be issued. In order to guarantee + * atomicity, no event handling should occur between Tk_ClipboardClear + * and the following Tk_AppendToClipboard calls. + * + * Results: + * A standard Tcl result. If an error is returned, an error message + * is left in interp->result. + * + * Side effects: + * The specified buffer will be copied onto the end of the clipboard. + * The clipboard maintains a list of buffers which will be used to + * supply the data for a selection get request. The first time a given + * type is appended, Tk_ClipboardAppend will register a selection + * handler of the appropriate type. + * + *---------------------------------------------------------------------- + */ + +int +Tk_ClipboardAppend(interp, tkwin, type, format, buffer) + Tcl_Interp *interp; /* Used for error reporting. */ + Tk_Window tkwin; /* Window that selects a display. */ + Atom type; /* The desired conversion type for this + * clipboard item, e.g. STRING or LENGTH. */ + Atom format; /* Format in which the selection + * information should be returned to + * the requestor. */ + char* buffer; /* NULL terminated string containing the data + * to be added to the clipboard. */ +{ + TkWindow *winPtr = (TkWindow *) tkwin; + TkDisplay *dispPtr = winPtr->dispPtr; + TkClipboardTarget *targetPtr; + TkClipboardBuffer *cbPtr; + + /* + * If this application doesn't already own the clipboard, clear + * the clipboard. If we don't own the clipboard selection, claim it. + */ + + if (dispPtr->clipboardAppPtr != winPtr->mainPtr) { + Tk_ClipboardClear(interp, tkwin); + } else if (!dispPtr->clipboardActive) { + Tk_OwnSelection(dispPtr->clipWindow, dispPtr->clipboardAtom, + ClipboardLostSel, (ClientData) dispPtr); + dispPtr->clipboardActive = 1; + } + + /* + * Check to see if the specified target is already present on the + * clipboard. If it isn't, we need to create a new target; otherwise, + * we just append the new buffer to the clipboard list. + */ + + for (targetPtr = dispPtr->clipTargetPtr; targetPtr != NULL; + targetPtr = targetPtr->nextPtr) { + if (targetPtr->type == type) + break; + } + if (targetPtr == NULL) { + targetPtr = (TkClipboardTarget*) ckalloc(sizeof(TkClipboardTarget)); + targetPtr->type = type; + targetPtr->format = format; + targetPtr->firstBufferPtr = targetPtr->lastBufferPtr = NULL; + targetPtr->nextPtr = dispPtr->clipTargetPtr; + dispPtr->clipTargetPtr = targetPtr; + Tk_CreateSelHandler(dispPtr->clipWindow, dispPtr->clipboardAtom, + type, ClipboardHandler, (ClientData) targetPtr, format); + } else if (targetPtr->format != format) { + Tcl_AppendResult(interp, "format \"", Tk_GetAtomName(tkwin, format), + "\" does not match current format \"", + Tk_GetAtomName(tkwin, targetPtr->format),"\" for ", + Tk_GetAtomName(tkwin, type), (char *) NULL); + return TCL_ERROR; + } + + /* + * Append a new buffer to the buffer chain. + */ + + cbPtr = (TkClipboardBuffer*) ckalloc(sizeof(TkClipboardBuffer)); + cbPtr->nextPtr = NULL; + if (targetPtr->lastBufferPtr != NULL) { + targetPtr->lastBufferPtr->nextPtr = cbPtr; + } else { + targetPtr->firstBufferPtr = cbPtr; + } + targetPtr->lastBufferPtr = cbPtr; + + cbPtr->length = strlen(buffer); + cbPtr->buffer = (char *) ckalloc((unsigned) (cbPtr->length + 1)); + strcpy(cbPtr->buffer, buffer); + + TkSelUpdateClipboard((TkWindow*)(dispPtr->clipWindow), targetPtr); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_ClipboardCmd -- + * + * This procedure is invoked to process the "clipboard" 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_ClipboardCmd(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; + char *path = NULL; + size_t length; + int count; + char c; + char **args; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option ?arg arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + c = argv[1][0]; + length = strlen(argv[1]); + if ((c == 'a') && (strncmp(argv[1], "append", length) == 0)) { + Atom target, format; + char *targetName = NULL; + char *formatName = NULL; + + for (count = argc-2, args = argv+2; count > 1; count -= 2, args += 2) { + if (args[0][0] != '-') { + break; + } + c = args[0][1]; + length = strlen(args[0]); + if ((c == '-') && (length == 2)) { + args++; + count--; + break; + } + if ((c == 'd') && (strncmp(args[0], "-displayof", length) == 0)) { + path = args[1]; + } else if ((c == 'f') + && (strncmp(args[0], "-format", length) == 0)) { + formatName = args[1]; + } else if ((c == 't') + && (strncmp(args[0], "-type", length) == 0)) { + targetName = args[1]; + } else { + Tcl_AppendResult(interp, "unknown option \"", args[0], + "\"", (char *) NULL); + return TCL_ERROR; + } + } + if (count != 1) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " append ?options? data\"", (char *) NULL); + return TCL_ERROR; + } + if (path != NULL) { + tkwin = Tk_NameToWindow(interp, path, tkwin); + } + if (tkwin == NULL) { + return TCL_ERROR; + } + if (targetName != NULL) { + target = Tk_InternAtom(tkwin, targetName); + } else { + target = XA_STRING; + } + if (formatName != NULL) { + format = Tk_InternAtom(tkwin, formatName); + } else { + format = XA_STRING; + } + return Tk_ClipboardAppend(interp, tkwin, target, format, args[0]); + } else if ((c == 'c') && (strncmp(argv[1], "clear", length) == 0)) { + for (count = argc-2, args = argv+2; count > 0; count -= 2, args += 2) { + if (args[0][0] != '-') { + break; + } + if (count < 2) { + Tcl_AppendResult(interp, "value for \"", *args, + "\" missing", (char *) NULL); + return TCL_ERROR; + } + c = args[0][1]; + length = strlen(args[0]); + if ((c == 'd') && (strncmp(args[0], "-displayof", length) == 0)) { + path = args[1]; + } else { + Tcl_AppendResult(interp, "unknown option \"", args[0], + "\"", (char *) NULL); + return TCL_ERROR; + } + } + if (count > 0) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " clear ?options?\"", (char *) NULL); + return TCL_ERROR; + } + if (path != NULL) { + tkwin = Tk_NameToWindow(interp, path, tkwin); + } + if (tkwin == NULL) { + return TCL_ERROR; + } + return Tk_ClipboardClear(interp, tkwin); + } else { + sprintf(interp->result, + "bad option \"%.50s\": must be clear or append", + argv[1]); + return TCL_ERROR; + } +} + +/* + *---------------------------------------------------------------------- + * + * TkClipInit -- + * + * This procedure is called to initialize the window for claiming + * clipboard ownership and for receiving selection get results. This + * function is called from tkSelect.c as well as tkClipboard.c. + * + * 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. + * + * Side effects: + * Sets up the clipWindow and related data structures. + * + *---------------------------------------------------------------------- + */ + +int +TkClipInit(interp, dispPtr) + Tcl_Interp *interp; /* Interpreter to use for error + * reporting. */ + register TkDisplay *dispPtr;/* Display to initialize. */ +{ + XSetWindowAttributes atts; + + dispPtr->clipTargetPtr = NULL; + dispPtr->clipboardActive = 0; + dispPtr->clipboardAppPtr = NULL; + + /* + * Create the window used for clipboard ownership and selection retrieval, + * and set up an event handler for it. + */ + + dispPtr->clipWindow = Tk_CreateWindow(interp, (Tk_Window) NULL, + "_clip", DisplayString(dispPtr->display)); + if (dispPtr->clipWindow == NULL) { + return TCL_ERROR; + } + atts.override_redirect = True; + Tk_ChangeWindowAttributes(dispPtr->clipWindow, CWOverrideRedirect, &atts); + Tk_MakeWindowExist(dispPtr->clipWindow); + + if (dispPtr->multipleAtom == None) { + /* + * Need to invoke selection initialization to make sure that + * atoms we depend on below are defined. + */ + + TkSelInit(dispPtr->clipWindow); + } + + /* + * Create selection handlers for types TK_APPLICATION and TK_WINDOW + * on this window. Can't use the default handlers for these types + * because this isn't a full-fledged window. + */ + + Tk_CreateSelHandler(dispPtr->clipWindow, dispPtr->clipboardAtom, + dispPtr->applicationAtom, ClipboardAppHandler, + (ClientData) dispPtr, XA_STRING); + Tk_CreateSelHandler(dispPtr->clipWindow, dispPtr->clipboardAtom, + dispPtr->windowAtom, ClipboardWindowHandler, + (ClientData) dispPtr, XA_STRING); + return TCL_OK; +} diff --git a/generic/tkCmds.c b/generic/tkCmds.c new file mode 100644 index 0000000..34e2867 --- /dev/null +++ b/generic/tkCmds.c @@ -0,0 +1,1646 @@ +/* + * tkCmds.c -- + * + * This file contains a collection of Tk-related Tcl commands + * 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. + * + * 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 + */ + +#include "tkPort.h" +#include "tkInt.h" +#include + +/* + * Forward declarations for procedures defined later in this file: + */ + +static TkWindow * GetToplevel _ANSI_ARGS_((Tk_Window tkwin)); +static char * WaitVariableProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, char *name1, char *name2, + int flags)); +static void WaitVisibilityProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +static void WaitWindowProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); + +/* + *---------------------------------------------------------------------- + * + * Tk_BellCmd -- + * + * This procedure is invoked to process the "bell" 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_BellCmd(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; + size_t length; + + if ((argc != 1) && (argc != 3)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?-displayof window?\"", (char *) NULL); + 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); + return TCL_ERROR; + } + tkwin = Tk_NameToWindow(interp, argv[2], tkwin); + if (tkwin == NULL) { + return TCL_ERROR; + } + } + XBell(Tk_Display(tkwin), 0); + XForceScreenSaver(Tk_Display(tkwin), ScreenSaverReset); + XFlush(Tk_Display(tkwin)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_BindCmd -- + * + * This procedure is invoked to process the "bind" 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_BindCmd(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; + TkWindow *winPtr; + ClientData object; + + if ((argc < 2) || (argc > 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " window ?pattern? ?command?\"", (char *) NULL); + return TCL_ERROR; + } + if (argv[1][0] == '.') { + winPtr = (TkWindow *) Tk_NameToWindow(interp, argv[1], tkwin); + if (winPtr == NULL) { + return TCL_ERROR; + } + object = (ClientData) winPtr->pathName; + } else { + winPtr = (TkWindow *) clientData; + object = (ClientData) Tk_GetUid(argv[1]); + } + + if (argc == 4) { + int append = 0; + unsigned long mask; + + if (argv[3][0] == 0) { + return Tk_DeleteBinding(interp, winPtr->mainPtr->bindingTable, + object, argv[2]); + } + if (argv[3][0] == '+') { + argv[3]++; + append = 1; + } + mask = Tk_CreateBinding(interp, winPtr->mainPtr->bindingTable, + object, argv[2], argv[3], append); + if (mask == 0) { + return TCL_ERROR; + } + } else if (argc == 3) { + char *command; + + command = Tk_GetBinding(interp, winPtr->mainPtr->bindingTable, + object, argv[2]); + if (command == NULL) { + Tcl_ResetResult(interp); + return TCL_OK; + } + interp->result = command; + } else { + Tk_GetAllBindings(interp, winPtr->mainPtr->bindingTable, object); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TkBindEventProc -- + * + * This procedure is invoked by Tk_HandleEvent for each event; it + * causes any appropriate bindings for that event to be invoked. + * + * Results: + * None. + * + * Side effects: + * Depends on what bindings have been established with the "bind" + * command. + * + *---------------------------------------------------------------------- + */ + +void +TkBindEventProc(winPtr, eventPtr) + TkWindow *winPtr; /* Pointer to info about window. */ + XEvent *eventPtr; /* Information about event. */ +{ +#define MAX_OBJS 20 + ClientData objects[MAX_OBJS], *objPtr; + static Tk_Uid allUid = NULL; + TkWindow *topLevPtr; + int i, count; + char *p; + Tcl_HashEntry *hPtr; + + if ((winPtr->mainPtr == NULL) || (winPtr->mainPtr->bindingTable == NULL)) { + return; + } + + objPtr = objects; + if (winPtr->numTags != 0) { + /* + * Make a copy of the tags for the window, replacing window names + * with pointers to the pathName from the appropriate window. + */ + + if (winPtr->numTags > MAX_OBJS) { + objPtr = (ClientData *) ckalloc((unsigned) + (winPtr->numTags * sizeof(ClientData))); + } + for (i = 0; i < winPtr->numTags; i++) { + p = (char *) winPtr->tagPtr[i]; + if (*p == '.') { + hPtr = Tcl_FindHashEntry(&winPtr->mainPtr->nameTable, p); + if (hPtr != NULL) { + p = ((TkWindow *) Tcl_GetHashValue(hPtr))->pathName; + } else { + p = NULL; + } + } + objPtr[i] = (ClientData) p; + } + count = winPtr->numTags; + } else { + objPtr[0] = (ClientData) winPtr->pathName; + objPtr[1] = (ClientData) winPtr->classUid; + for (topLevPtr = winPtr; + (topLevPtr != NULL) && !(topLevPtr->flags & TK_TOP_LEVEL); + topLevPtr = topLevPtr->parentPtr) { + /* Empty loop body. */ + } + if ((winPtr != topLevPtr) && (topLevPtr != NULL)) { + count = 4; + objPtr[2] = (ClientData) topLevPtr->pathName; + } else { + count = 3; + } + if (allUid == NULL) { + allUid = Tk_GetUid("all"); + } + objPtr[count-1] = (ClientData) allUid; + } + Tk_BindEvent(winPtr->mainPtr->bindingTable, eventPtr, (Tk_Window) winPtr, + count, objPtr); + if (objPtr != objects) { + ckfree((char *) objPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tk_BindtagsCmd -- + * + * This procedure is invoked to process the "bindtags" 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_BindtagsCmd(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; + TkWindow *winPtr, *winPtr2; + int i, tagArgc; + char *p, **tagArgv; + + if ((argc < 2) || (argc > 3)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " window ?tags?\"", (char *) NULL); + return TCL_ERROR; + } + winPtr = (TkWindow *) Tk_NameToWindow(interp, argv[1], tkwin); + if (winPtr == NULL) { + return TCL_ERROR; + } + if (argc == 2) { + if (winPtr->numTags == 0) { + Tcl_AppendElement(interp, winPtr->pathName); + Tcl_AppendElement(interp, winPtr->classUid); + for (winPtr2 = winPtr; + (winPtr2 != NULL) && !(winPtr2->flags & TK_TOP_LEVEL); + winPtr2 = winPtr2->parentPtr) { + /* Empty loop body. */ + } + if ((winPtr != winPtr2) && (winPtr2 != NULL)) { + Tcl_AppendElement(interp, winPtr2->pathName); + } + Tcl_AppendElement(interp, "all"); + } else { + for (i = 0; i < winPtr->numTags; i++) { + Tcl_AppendElement(interp, (char *) winPtr->tagPtr[i]); + } + } + return TCL_OK; + } + if (winPtr->tagPtr != NULL) { + TkFreeBindingTags(winPtr); + } + if (argv[2][0] == 0) { + return TCL_OK; + } + if (Tcl_SplitList(interp, argv[2], &tagArgc, &tagArgv) != TCL_OK) { + return TCL_ERROR; + } + winPtr->numTags = tagArgc; + winPtr->tagPtr = (ClientData *) ckalloc((unsigned) + (tagArgc * sizeof(ClientData))); + for (i = 0; i < tagArgc; i++) { + p = tagArgv[i]; + if (p[0] == '.') { + char *copy; + + /* + * Handle names starting with "." specially: store a malloc'ed + * string, rather than a Uid; at event time we'll look up the + * name in the window table and use the corresponding window, + * if there is one. + */ + + copy = (char *) ckalloc((unsigned) (strlen(p) + 1)); + strcpy(copy, p); + winPtr->tagPtr[i] = (ClientData) copy; + } else { + winPtr->tagPtr[i] = (ClientData) Tk_GetUid(p); + } + } + ckfree((char *) tagArgv); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TkFreeBindingTags -- + * + * This procedure is called to free all of the binding tags + * associated with a window; typically it is only invoked where + * there are window-specific tags. + * + * Results: + * None. + * + * Side effects: + * Any binding tags for winPtr are freed. + * + *---------------------------------------------------------------------- + */ + +void +TkFreeBindingTags(winPtr) + TkWindow *winPtr; /* Window whose tags are to be released. */ +{ + int i; + char *p; + + for (i = 0; i < winPtr->numTags; i++) { + p = (char *) (winPtr->tagPtr[i]); + if (*p == '.') { + /* + * Names starting with "." are malloced rather than Uids, so + * they have to be freed. + */ + + ckfree(p); + } + } + ckfree((char *) winPtr->tagPtr); + winPtr->numTags = 0; + winPtr->tagPtr = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_DestroyCmd -- + * + * This procedure is invoked to process the "destroy" 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_DestroyCmd(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 window; + Tk_Window tkwin = (Tk_Window) clientData; + int i; + + for (i = 1; i < argc; i++) { + window = Tk_NameToWindow(interp, argv[i], tkwin); + if (window == NULL) { + Tcl_ResetResult(interp); + continue; + } + Tk_DestroyWindow(window); + if (window == tkwin) { + /* + * We just deleted the main window for the application! This + * makes it impossible to do anything more (tkwin isn't + * valid anymore). + */ + + break; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_LowerCmd -- + * + * This procedure is invoked to process the "lower" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tk_LowerCmd(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 main = (Tk_Window) clientData; + Tk_Window tkwin, other; + + if ((argc != 2) && (argc != 3)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " window ?belowThis?\"", (char *) NULL); + return TCL_ERROR; + } + + tkwin = Tk_NameToWindow(interp, argv[1], main); + if (tkwin == NULL) { + return TCL_ERROR; + } + if (argc == 2) { + other = NULL; + } else { + other = Tk_NameToWindow(interp, argv[2], main); + if (other == NULL) { + return TCL_ERROR; + } + } + if (Tk_RestackWindow(tkwin, Below, other) != TCL_OK) { + Tcl_AppendResult(interp, "can't lower \"", argv[1], "\" below \"", + argv[2], "\"", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_RaiseCmd -- + * + * This procedure is invoked to process the "raise" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tk_RaiseCmd(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 main = (Tk_Window) clientData; + Tk_Window tkwin, other; + + if ((argc != 2) && (argc != 3)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " window ?aboveThis?\"", (char *) NULL); + return TCL_ERROR; + } + + tkwin = Tk_NameToWindow(interp, argv[1], main); + if (tkwin == NULL) { + return TCL_ERROR; + } + if (argc == 2) { + other = NULL; + } else { + other = Tk_NameToWindow(interp, argv[2], main); + if (other == NULL) { + return TCL_ERROR; + } + } + if (Tk_RestackWindow(tkwin, Above, other) != TCL_OK) { + Tcl_AppendResult(interp, "can't raise \"", argv[1], "\" above \"", + argv[2], "\"", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_TkObjCmd -- + * + * This procedure is invoked to process the "tk" 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_TkObjCmd(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. */ +{ + int index; + Tk_Window tkwin; + static char *optionStrings[] = { + "appname", "scaling", NULL + }; + enum options { + TK_APPNAME, TK_SCALING + }; + + tkwin = (Tk_Window) clientData; + + 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 TK_APPNAME: { + TkWindow *winPtr; + char *string; + + winPtr = (TkWindow *) tkwin; + + if (objc > 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?newName?"); + return TCL_ERROR; + } + if (objc == 3) { + string = Tcl_GetStringFromObj(objv[2], NULL); + winPtr->nameUid = Tk_GetUid(Tk_SetAppName(tkwin, string)); + } + Tcl_SetStringObj(Tcl_GetObjResult(interp), winPtr->nameUid, -1); + break; + } + case TK_SCALING: { + Screen *screenPtr; + int skip, width, height; + double d; + + screenPtr = Tk_Screen(tkwin); + + skip = TkGetDisplayOf(interp, objc - 2, objv + 2, &tkwin); + if (skip < 0) { + return TCL_ERROR; + } + if (objc - skip == 2) { + d = 25.4 / 72; + d *= WidthOfScreen(screenPtr); + d /= WidthMMOfScreen(screenPtr); + Tcl_SetDoubleObj(Tcl_GetObjResult(interp), d); + } else if (objc - skip == 3) { + if (Tcl_GetDoubleFromObj(interp, objv[2 + skip], &d) != TCL_OK) { + return TCL_ERROR; + } + d = (25.4 / 72) / d; + width = (int) (d * WidthOfScreen(screenPtr) + 0.5); + if (width <= 0) { + width = 1; + } + height = (int) (d * HeightOfScreen(screenPtr) + 0.5); + if (height <= 0) { + height = 1; + } + WidthMMOfScreen(screenPtr) = width; + HeightMMOfScreen(screenPtr) = height; + } else { + Tcl_WrongNumArgs(interp, 2, objv, + "?-displayof window? ?factor?"); + return TCL_ERROR; + } + break; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_TkwaitCmd -- + * + * This procedure is invoked to process the "tkwait" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tk_TkwaitCmd(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; + int c, done; + size_t length; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " variable|visibility|window name\"", (char *) NULL); + return TCL_ERROR; + } + c = argv[1][0]; + length = strlen(argv[1]); + if ((c == 'v') && (strncmp(argv[1], "variable", length) == 0) + && (length >= 2)) { + if (Tcl_TraceVar(interp, argv[2], + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + WaitVariableProc, (ClientData) &done) != TCL_OK) { + return TCL_ERROR; + } + done = 0; + while (!done) { + Tcl_DoOneEvent(0); + } + Tcl_UntraceVar(interp, argv[2], + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + WaitVariableProc, (ClientData) &done); + } else if ((c == 'v') && (strncmp(argv[1], "visibility", length) == 0) + && (length >= 2)) { + Tk_Window window; + + window = Tk_NameToWindow(interp, argv[2], tkwin); + if (window == NULL) { + return TCL_ERROR; + } + Tk_CreateEventHandler(window, VisibilityChangeMask|StructureNotifyMask, + WaitVisibilityProc, (ClientData) &done); + done = 0; + while (!done) { + Tcl_DoOneEvent(0); + } + if (done != 1) { + /* + * Note that we do not delete the event handler because it + * was deleted automatically when the window was destroyed. + */ + + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "window \"", argv[2], + "\" was deleted before its visibility changed", + (char *) NULL); + return TCL_ERROR; + } + Tk_DeleteEventHandler(window, VisibilityChangeMask|StructureNotifyMask, + WaitVisibilityProc, (ClientData) &done); + } else if ((c == 'w') && (strncmp(argv[1], "window", length) == 0)) { + Tk_Window window; + + window = Tk_NameToWindow(interp, argv[2], tkwin); + if (window == NULL) { + return TCL_ERROR; + } + Tk_CreateEventHandler(window, StructureNotifyMask, + WaitWindowProc, (ClientData) &done); + done = 0; + while (!done) { + Tcl_DoOneEvent(0); + } + /* + * Note: there's no need to delete the event handler. It was + * deleted automatically when the window was destroyed. + */ + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be variable, visibility, or window", (char *) NULL); + return TCL_ERROR; + } + + /* + * Clear out the interpreter's result, since it may have been set + * by event handlers. + */ + + Tcl_ResetResult(interp); + return TCL_OK; +} + + /* ARGSUSED */ +static char * +WaitVariableProc(clientData, interp, name1, name2, flags) + ClientData clientData; /* Pointer to integer to set to 1. */ + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *name1; /* Name of variable. */ + char *name2; /* Second part of variable name. */ + int flags; /* Information about what happened. */ +{ + int *donePtr = (int *) clientData; + + *donePtr = 1; + return (char *) NULL; +} + + /*ARGSUSED*/ +static void +WaitVisibilityProc(clientData, eventPtr) + ClientData clientData; /* Pointer to integer to set to 1. */ + XEvent *eventPtr; /* Information about event (not used). */ +{ + int *donePtr = (int *) clientData; + + if (eventPtr->type == VisibilityNotify) { + *donePtr = 1; + } + if (eventPtr->type == DestroyNotify) { + *donePtr = 2; + } +} + +static void +WaitWindowProc(clientData, eventPtr) + ClientData clientData; /* Pointer to integer to set to 1. */ + XEvent *eventPtr; /* Information about event. */ +{ + int *donePtr = (int *) clientData; + + if (eventPtr->type == DestroyNotify) { + *donePtr = 1; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tk_UpdateCmd -- + * + * This procedure is invoked to process the "update" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tk_UpdateCmd(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. */ +{ + int flags; + TkDisplay *dispPtr; + + if (argc == 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); + return TCL_ERROR; + } + flags = TCL_IDLE_EVENTS; + } else { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " ?idletasks?\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * Handle all pending events, sync all displays, and repeat over + * and over again until all pending events have been handled. + * Special note: it's possible that the entire application could + * be destroyed by an event handler that occurs during the update. + * Thus, don't use any information from tkwin after calling + * Tcl_DoOneEvent. + */ + + while (1) { + while (Tcl_DoOneEvent(flags) != 0) { + /* Empty loop body */ + } + for (dispPtr = tkDisplayList; dispPtr != NULL; + dispPtr = dispPtr->nextPtr) { + XSync(dispPtr->display, False); + } + if (Tcl_DoOneEvent(flags) == 0) { + break; + } + } + + /* + * Must clear the interpreter's result because event handlers could + * have executed commands. + */ + + Tcl_ResetResult(interp); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_WinfoObjCmd -- + * + * This procedure is invoked to process the "winfo" 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_WinfoObjCmd(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. */ +{ + int index, x, y, width, height, useX, useY, class, skip; + char buf[128]; + char *string; + TkWindow *winPtr; + Tk_Window tkwin; + + static TkStateMap visualMap[] = { + {PseudoColor, "pseudocolor"}, + {GrayScale, "grayscale"}, + {DirectColor, "directcolor"}, + {TrueColor, "truecolor"}, + {StaticColor, "staticcolor"}, + {StaticGray, "staticgray"}, + {-1, NULL} + }; + static char *optionStrings[] = { + "cells", "children", "class", "colormapfull", + "depth", "geometry", "height", "id", + "ismapped", "manager", "name", "parent", + "pointerx", "pointery", "pointerxy", "reqheight", + "reqwidth", "rootx", "rooty", "screen", + "screencells", "screendepth", "screenheight", "screenwidth", + "screenmmheight","screenmmwidth","screenvisual","server", + "toplevel", "viewable", "visual", "visualid", + "vrootheight", "vrootwidth", "vrootx", "vrooty", + "width", "x", "y", + + "atom", "atomname", "containing", "interps", + "pathname", + + "exists", "fpixels", "pixels", "rgb", + "visualsavailable", + + NULL + }; + enum options { + WIN_CELLS, WIN_CHILDREN, WIN_CLASS, WIN_COLORMAPFULL, + WIN_DEPTH, WIN_GEOMETRY, WIN_HEIGHT, WIN_ID, + WIN_ISMAPPED, WIN_MANAGER, WIN_NAME, WIN_PARENT, + WIN_POINTERX, WIN_POINTERY, WIN_POINTERXY, WIN_REQHEIGHT, + WIN_REQWIDTH, WIN_ROOTX, WIN_ROOTY, WIN_SCREEN, + WIN_SCREENCELLS,WIN_SCREENDEPTH,WIN_SCREENHEIGHT,WIN_SCREENWIDTH, + WIN_SCREENMMHEIGHT,WIN_SCREENMMWIDTH,WIN_SCREENVISUAL,WIN_SERVER, + WIN_TOPLEVEL, WIN_VIEWABLE, WIN_VISUAL, WIN_VISUALID, + WIN_VROOTHEIGHT,WIN_VROOTWIDTH, WIN_VROOTX, WIN_VROOTY, + WIN_WIDTH, WIN_X, WIN_Y, + + WIN_ATOM, WIN_ATOMNAME, WIN_CONTAINING, WIN_INTERPS, + WIN_PATHNAME, + + WIN_EXISTS, WIN_FPIXELS, WIN_PIXELS, WIN_RGB, + WIN_VISUALSAVAILABLE + }; + + tkwin = (Tk_Window) clientData; + + 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; + } + + if (index < WIN_ATOM) { + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "window"); + return TCL_ERROR; + } + string = Tcl_GetStringFromObj(objv[2], NULL); + tkwin = Tk_NameToWindow(interp, string, tkwin); + if (tkwin == NULL) { + return TCL_ERROR; + } + } + winPtr = (TkWindow *) tkwin; + + switch ((enum options) index) { + case WIN_CELLS: { + Tcl_ResetResult(interp); + Tcl_SetIntObj(Tcl_GetObjResult(interp), + 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); + } + break; + } + case WIN_CLASS: { + Tcl_ResetResult(interp); + Tcl_SetStringObj(Tcl_GetObjResult(interp), Tk_Class(tkwin), -1); + break; + } + case WIN_COLORMAPFULL: { + Tcl_ResetResult(interp); + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), + TkpCmapStressed(tkwin, Tk_Colormap(tkwin))); + break; + } + case WIN_DEPTH: { + Tcl_ResetResult(interp); + Tcl_SetIntObj(Tcl_GetObjResult(interp), Tk_Depth(tkwin)); + break; + } + case WIN_GEOMETRY: { + Tcl_ResetResult(interp); + 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); + break; + } + case WIN_HEIGHT: { + Tcl_ResetResult(interp); + Tcl_SetIntObj(Tcl_GetObjResult(interp), Tk_Height(tkwin)); + break; + } + case WIN_ID: { + Tk_MakeWindowExist(tkwin); + TkpPrintWindowId(buf, Tk_WindowId(tkwin)); + Tcl_ResetResult(interp); + Tcl_SetStringObj(Tcl_GetObjResult(interp), buf, -1); + break; + } + case WIN_ISMAPPED: { + Tcl_ResetResult(interp); + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), + (int) Tk_IsMapped(tkwin)); + break; + } + case WIN_MANAGER: { + Tcl_ResetResult(interp); + if (winPtr->geomMgrPtr != NULL) { + Tcl_SetStringObj(Tcl_GetObjResult(interp), + winPtr->geomMgrPtr->name, -1); + } + break; + } + case WIN_NAME: { + Tcl_ResetResult(interp); + Tcl_SetStringObj(Tcl_GetObjResult(interp), Tk_Name(tkwin), -1); + break; + } + case WIN_PARENT: { + Tcl_ResetResult(interp); + if (winPtr->parentPtr != NULL) { + Tcl_SetStringObj(Tcl_GetObjResult(interp), + winPtr->parentPtr->pathName, -1); + } + break; + } + case WIN_POINTERX: { + useX = 1; + useY = 0; + goto pointerxy; + } + case WIN_POINTERY: { + useX = 0; + useY = 1; + goto pointerxy; + } + case WIN_POINTERXY: { + useX = 1; + useY = 1; + + pointerxy: + winPtr = GetToplevel(tkwin); + if (winPtr == NULL) { + x = -1; + y = -1; + } else { + TkGetPointerCoords((Tk_Window) winPtr, &x, &y); + } + Tcl_ResetResult(interp); + if (useX & useY) { + sprintf(buf, "%d %d", x, y); + Tcl_SetStringObj(Tcl_GetObjResult(interp), buf, -1); + } else if (useX) { + Tcl_SetIntObj(Tcl_GetObjResult(interp), x); + } else { + Tcl_SetIntObj(Tcl_GetObjResult(interp), y); + } + break; + } + case WIN_REQHEIGHT: { + Tcl_ResetResult(interp); + Tcl_SetIntObj(Tcl_GetObjResult(interp), Tk_ReqHeight(tkwin)); + break; + } + case WIN_REQWIDTH: { + Tcl_ResetResult(interp); + Tcl_SetIntObj(Tcl_GetObjResult(interp), Tk_ReqWidth(tkwin)); + break; + } + case WIN_ROOTX: { + Tk_GetRootCoords(tkwin, &x, &y); + Tcl_ResetResult(interp); + Tcl_SetIntObj(Tcl_GetObjResult(interp), x); + break; + } + case WIN_ROOTY: { + Tk_GetRootCoords(tkwin, &x, &y); + Tcl_ResetResult(interp); + Tcl_SetIntObj(Tcl_GetObjResult(interp), y); + break; + } + case WIN_SCREEN: { + sprintf(buf, "%d", Tk_ScreenNumber(tkwin)); + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + Tk_DisplayName(tkwin), ".", buf, NULL); + break; + } + case WIN_SCREENCELLS: { + Tcl_ResetResult(interp); + Tcl_SetIntObj(Tcl_GetObjResult(interp), + CellsOfScreen(Tk_Screen(tkwin))); + break; + } + case WIN_SCREENDEPTH: { + Tcl_ResetResult(interp); + Tcl_SetIntObj(Tcl_GetObjResult(interp), + DefaultDepthOfScreen(Tk_Screen(tkwin))); + break; + } + case WIN_SCREENHEIGHT: { + Tcl_ResetResult(interp); + Tcl_SetIntObj(Tcl_GetObjResult(interp), + HeightOfScreen(Tk_Screen(tkwin))); + break; + } + case WIN_SCREENWIDTH: { + Tcl_ResetResult(interp); + Tcl_SetIntObj(Tcl_GetObjResult(interp), + WidthOfScreen(Tk_Screen(tkwin))); + break; + } + case WIN_SCREENMMHEIGHT: { + Tcl_ResetResult(interp); + Tcl_SetIntObj(Tcl_GetObjResult(interp), + HeightMMOfScreen(Tk_Screen(tkwin))); + break; + } + case WIN_SCREENMMWIDTH: { + Tcl_ResetResult(interp); + Tcl_SetIntObj(Tcl_GetObjResult(interp), + WidthMMOfScreen(Tk_Screen(tkwin))); + break; + } + case WIN_SCREENVISUAL: { + class = DefaultVisualOfScreen(Tk_Screen(tkwin))->class; + goto visual; + } + case WIN_SERVER: { + TkGetServerInfo(interp, tkwin); + break; + } + case WIN_TOPLEVEL: { + winPtr = GetToplevel(tkwin); + if (winPtr != NULL) { + Tcl_ResetResult(interp); + Tcl_SetStringObj(Tcl_GetObjResult(interp), + winPtr->pathName, -1); + } + break; + } + case WIN_VIEWABLE: { + int viewable; + + viewable = 0; + for ( ; ; winPtr = winPtr->parentPtr) { + if ((winPtr == NULL) || !(winPtr->flags & TK_MAPPED)) { + break; + } + if (winPtr->flags & TK_TOP_LEVEL) { + viewable = 1; + break; + } + } + Tcl_ResetResult(interp); + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), viewable); + break; + } + case WIN_VISUAL: { + class = Tk_Visual(tkwin)->class; + + visual: + string = TkFindStateString(visualMap, class); + if (string == NULL) { + string = "unknown"; + } + Tcl_ResetResult(interp); + Tcl_SetStringObj(Tcl_GetObjResult(interp), string, -1); + break; + } + case WIN_VISUALID: { + Tcl_ResetResult(interp); + sprintf(buf, "0x%x", + (unsigned int) XVisualIDFromVisual(Tk_Visual(tkwin))); + Tcl_SetStringObj(Tcl_GetObjResult(interp), buf, -1); + break; + } + case WIN_VROOTHEIGHT: { + Tk_GetVRootGeometry(tkwin, &x, &y, &width, &height); + Tcl_ResetResult(interp); + Tcl_SetIntObj(Tcl_GetObjResult(interp), height); + break; + } + case WIN_VROOTWIDTH: { + Tk_GetVRootGeometry(tkwin, &x, &y, &width, &height); + Tcl_ResetResult(interp); + Tcl_SetIntObj(Tcl_GetObjResult(interp), width); + break; + } + case WIN_VROOTX: { + Tk_GetVRootGeometry(tkwin, &x, &y, &width, &height); + Tcl_ResetResult(interp); + Tcl_SetIntObj(Tcl_GetObjResult(interp), x); + break; + } + case WIN_VROOTY: { + Tk_GetVRootGeometry(tkwin, &x, &y, &width, &height); + Tcl_ResetResult(interp); + Tcl_SetIntObj(Tcl_GetObjResult(interp), y); + break; + } + case WIN_WIDTH: { + Tcl_ResetResult(interp); + Tcl_SetIntObj(Tcl_GetObjResult(interp), Tk_Width(tkwin)); + break; + } + case WIN_X: { + Tcl_ResetResult(interp); + Tcl_SetIntObj(Tcl_GetObjResult(interp), Tk_X(tkwin)); + break; + } + case WIN_Y: { + Tcl_ResetResult(interp); + Tcl_SetIntObj(Tcl_GetObjResult(interp), Tk_Y(tkwin)); + break; + } + + /* + * Uses -displayof. + */ + + case WIN_ATOM: { + skip = TkGetDisplayOf(interp, objc - 2, objv + 2, &tkwin); + if (skip < 0) { + return TCL_ERROR; + } + if (objc - skip != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?-displayof window? name"); + return TCL_ERROR; + } + objv += skip; + string = Tcl_GetStringFromObj(objv[2], NULL); + Tcl_ResetResult(interp); + Tcl_SetLongObj(Tcl_GetObjResult(interp), + (long) Tk_InternAtom(tkwin, string)); + break; + } + case WIN_ATOMNAME: { + char *name; + long id; + + skip = TkGetDisplayOf(interp, objc - 2, objv + 2, &tkwin); + if (skip < 0) { + return TCL_ERROR; + } + if (objc - skip != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?-displayof window? id"); + return TCL_ERROR; + } + objv += skip; + 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), + "no atom exists with id \"", string, "\"", NULL); + return TCL_ERROR; + } + Tcl_SetStringObj(Tcl_GetObjResult(interp), name, -1); + break; + } + case WIN_CONTAINING: { + skip = TkGetDisplayOf(interp, objc - 2, objv + 2, &tkwin); + if (skip < 0) { + return TCL_ERROR; + } + if (objc - skip != 4) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-displayof window? rootX rootY"); + return TCL_ERROR; + } + objv += skip; + string = Tcl_GetStringFromObj(objv[2], NULL); + if (Tk_GetPixels(interp, tkwin, string, &x) != TCL_OK) { + return TCL_ERROR; + } + string = Tcl_GetStringFromObj(objv[3], NULL); + if (Tk_GetPixels(interp, tkwin, string, &y) != TCL_OK) { + return TCL_ERROR; + } + tkwin = Tk_CoordsToWindow(x, y, tkwin); + if (tkwin != NULL) { + Tcl_ResetResult(interp); + Tcl_SetStringObj(Tcl_GetObjResult(interp), + Tk_PathName(tkwin), -1); + } + break; + } + case WIN_INTERPS: { + int result; + + skip = TkGetDisplayOf(interp, objc - 2, objv + 2, &tkwin); + if (skip < 0) { + return TCL_ERROR; + } + if (objc - skip != 2) { + Tcl_WrongNumArgs(interp, 2, objv, "?-displayof window?"); + return TCL_ERROR; + } + result = TkGetInterpNames(interp, tkwin); + return result; + } + case WIN_PATHNAME: { + int id; + + skip = TkGetDisplayOf(interp, objc - 2, objv + 2, &tkwin); + if (skip < 0) { + return TCL_ERROR; + } + if (objc - skip != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?-displayof window? id"); + return TCL_ERROR; + } + string = Tcl_GetStringFromObj(objv[2 + skip], NULL); + if (TkpScanWindowId(interp, string, &id) != TCL_OK) { + return TCL_ERROR; + } + winPtr = (TkWindow *) + 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, + "\" doesn't exist in this application", (char *) NULL); + return TCL_ERROR; + } + + /* + * If the window is a utility window with no associated path + * (such as a wrapper window or send communication window), just + * return an empty string. + */ + + tkwin = (Tk_Window) winPtr; + if (Tk_PathName(tkwin) != NULL) { + Tcl_ResetResult(interp); + Tcl_SetStringObj(Tcl_GetObjResult(interp), + Tk_PathName(tkwin), -1); + } + break; + } + + /* + * objv[3] is window. + */ + + case WIN_EXISTS: { + int alive; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "window"); + return TCL_ERROR; + } + string = Tcl_GetStringFromObj(objv[2], NULL); + winPtr = (TkWindow *) Tk_NameToWindow(interp, string, tkwin); + 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); + break; + } + case WIN_FPIXELS: { + double mm, pixels; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "window number"); + return TCL_ERROR; + } + string = Tcl_GetStringFromObj(objv[2], NULL); + tkwin = Tk_NameToWindow(interp, string, tkwin); + if (tkwin == NULL) { + return TCL_ERROR; + } + string = Tcl_GetStringFromObj(objv[3], NULL); + if (Tk_GetScreenMM(interp, tkwin, string, &mm) != TCL_OK) { + return TCL_ERROR; + } + pixels = mm * WidthOfScreen(Tk_Screen(tkwin)) + / WidthMMOfScreen(Tk_Screen(tkwin)); + Tcl_ResetResult(interp); + Tcl_SetDoubleObj(Tcl_GetObjResult(interp), pixels); + break; + } + case WIN_PIXELS: { + int pixels; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "window number"); + return TCL_ERROR; + } + string = Tcl_GetStringFromObj(objv[2], NULL); + tkwin = Tk_NameToWindow(interp, string, tkwin); + if (tkwin == NULL) { + return TCL_ERROR; + } + string = Tcl_GetStringFromObj(objv[3], NULL); + if (Tk_GetPixels(interp, tkwin, string, &pixels) != TCL_OK) { + return TCL_ERROR; + } + Tcl_ResetResult(interp); + Tcl_SetIntObj(Tcl_GetObjResult(interp), pixels); + break; + } + case WIN_RGB: { + XColor *colorPtr; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "window colorName"); + return TCL_ERROR; + } + string = Tcl_GetStringFromObj(objv[2], NULL); + tkwin = Tk_NameToWindow(interp, string, tkwin); + if (tkwin == NULL) { + return TCL_ERROR; + } + string = Tcl_GetStringFromObj(objv[3], NULL); + colorPtr = Tk_GetColor(interp, tkwin, string); + if (colorPtr == NULL) { + return TCL_ERROR; + } + sprintf(buf, "%d %d %d", colorPtr->red, colorPtr->green, + colorPtr->blue); + Tk_FreeColor(colorPtr); + Tcl_ResetResult(interp); + Tcl_SetStringObj(Tcl_GetObjResult(interp), buf, -1); + break; + } + case WIN_VISUALSAVAILABLE: { + XVisualInfo template, *visInfoPtr; + int count, i; + char visualIdString[16]; + int includeVisualId; + Tcl_Obj *strPtr; + + if (objc == 3) { + includeVisualId = 0; + } else if ((objc == 4) + && (strcmp(Tcl_GetStringFromObj(objv[3], NULL), + "includeids") == 0)) { + includeVisualId = 1; + } else { + Tcl_WrongNumArgs(interp, 2, objv, "window ?includeids?"); + return TCL_ERROR; + } + + string = Tcl_GetStringFromObj(objv[2], NULL); + tkwin = Tk_NameToWindow(interp, string, tkwin); + if (tkwin == NULL) { + return TCL_ERROR; + } + + template.screen = Tk_ScreenNumber(tkwin); + visInfoPtr = XGetVisualInfo(Tk_Display(tkwin), VisualScreenMask, + &template, &count); + Tcl_ResetResult(interp); + if (visInfoPtr == NULL) { + Tcl_SetStringObj(Tcl_GetObjResult(interp), + "can't find any visuals for screen", -1); + return TCL_ERROR; + } + for (i = 0; i < count; i++) { + string = TkFindStateString(visualMap, visInfoPtr[i].class); + if (string == NULL) { + strcpy(buf, "unknown"); + } else { + sprintf(buf, "%s %d", string, visInfoPtr[i].depth); + } + if (includeVisualId) { + sprintf(visualIdString, " 0x%x", + (unsigned int) visInfoPtr[i].visualid); + strcat(buf, visualIdString); + } + strPtr = Tcl_NewStringObj(buf, -1); + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), + strPtr); + } + XFree((char *) visInfoPtr); + break; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TkGetDisplayOf -- + * + * Parses a "-displayof window" option for various commands. If + * present, the literal "-displayof" should be in objv[0] and the + * window name in objv[1]. + * + * Results: + * The return value is 0 if the argument strings did not contain + * the "-displayof" option. The return value is 2 if the + * argument strings contained both the "-displayof" option and + * a valid window name. Otherwise, the return value is -1 if + * the window name was missing or did not specify a valid window. + * + * If the return value was 2, *tkwinPtr is filled with the + * token for the window specified on the command line. If the + * return value was -1, an error message is left in interp's + * result object. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TkGetDisplayOf(interp, objc, objv, tkwinPtr) + Tcl_Interp *interp; /* Interpreter for error reporting. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. If it is present, + * "-displayof" should be in objv[0] and + * objv[1] the name of a window. */ + Tk_Window *tkwinPtr; /* On input, contains main window of + * application associated with interp. On + * output, filled with window specified as + * option to "-displayof" argument, or + * unmodified if "-displayof" argument was not + * present. */ +{ + char *string; + int length; + + if (objc < 1) { + return 0; + } + string = Tcl_GetStringFromObj(objv[0], &length); + if ((length >= 2) && (strncmp(string, "-displayof", (unsigned) length) == 0)) { + if (objc < 2) { + Tcl_SetStringObj(Tcl_GetObjResult(interp), + "value for \"-displayof\" missing", -1); + return -1; + } + string = Tcl_GetStringFromObj(objv[1], NULL); + *tkwinPtr = Tk_NameToWindow(interp, string, *tkwinPtr); + if (*tkwinPtr == NULL) { + return -1; + } + return 2; + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * TkDeadAppCmd -- + * + * If an application has been deleted then all Tk commands will be + * re-bound to this procedure. + * + * Results: + * A standard Tcl error is reported to let the user know that + * the application is dead. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +TkDeadAppCmd(clientData, interp, argc, argv) + ClientData clientData; /* Dummy. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_AppendResult(interp, "can't invoke \"", argv[0], + "\" command: application has been destroyed", (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * GetToplevel -- + * + * Retrieves the toplevel window which is the nearest ancestor of + * of the specified window. + * + * Results: + * Returns the toplevel window or NULL if the window has no + * ancestor which is a toplevel. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static TkWindow * +GetToplevel(tkwin) + Tk_Window tkwin; /* Window for which the toplevel should be + * deterined. */ +{ + TkWindow *winPtr = (TkWindow *) tkwin; + + while (!(winPtr->flags & TK_TOP_LEVEL)) { + winPtr = winPtr->parentPtr; + if (winPtr == NULL) { + return NULL; + } + } + return winPtr; +} diff --git a/generic/tkColor.c b/generic/tkColor.c new file mode 100644 index 0000000..781971c --- /dev/null +++ b/generic/tkColor.c @@ -0,0 +1,397 @@ +/* + * tkColor.c -- + * + * This file maintains a database of color values for the Tk + * toolkit, in order to avoid round-trips to the server to + * map color names to pixel values. + * + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkColor.c 1.44 96/11/04 13:55:25 + */ + +#include + +/* + * 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: + */ + +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; + +/* + * Hash table for value -> TkColor mapping, and key structure used to + * index into that table: + */ + +static Tcl_HashTable valueTable; +typedef struct { + int red, green, blue; /* Values for desired color. */ + Colormap colormap; /* Colormap from which color will be + * allocated. */ + 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)); + +/* + *---------------------------------------------------------------------- + * + * Tk_GetColor -- + * + * Given a string name for a color, map the name to a corresponding + * XColor structure. + * + * Results: + * The return value is a pointer to an XColor structure that + * 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. + * + * 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_FreeColor so that the database is cleaned up when colors + * aren't in use anymore. + * + *---------------------------------------------------------------------- + */ + +XColor * +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 + * suitable for passing to XParseColor). */ +{ + NameKey nameKey; + Tcl_HashEntry *nameHashPtr; + int new; + TkColor *tkColPtr; + Display *display = Tk_Display(tkwin); + + if (!initialized) { + ColorInit(); + } + + /* + * First, check to see if there's already a mapping for this color + * name. + */ + + nameKey.name = name; + nameKey.colormap = Tk_Colormap(tkwin); + nameKey.display = display; + nameHashPtr = Tcl_CreateHashEntry(&nameTable, (char *) &nameKey, &new); + if (!new) { + tkColPtr = (TkColor *) Tcl_GetHashValue(nameHashPtr); + tkColPtr->refCount++; + return &tkColPtr->color; + } + + /* + * The name isn't currently known. Map from the name to a pixel + * value. + */ + + tkColPtr = TkpGetColor(tkwin, name); + if (tkColPtr == NULL) { + if (interp != NULL) { + if (*name == '#') { + Tcl_AppendResult(interp, "invalid color name \"", name, + "\"", (char *) NULL); + } else { + Tcl_AppendResult(interp, "unknown color name \"", name, + "\"", (char *) NULL); + } + } + Tcl_DeleteHashEntry(nameHashPtr); + return (XColor *) NULL; + } + + /* + * Now create a new TkColor structure and add it to nameTable. + */ + + tkColPtr->magic = COLOR_MAGIC; + tkColPtr->gc = None; + tkColPtr->screen = Tk_Screen(tkwin); + tkColPtr->colormap = nameKey.colormap; + tkColPtr->visual = Tk_Visual(tkwin); + tkColPtr->refCount = 1; + tkColPtr->tablePtr = &nameTable; + tkColPtr->hashPtr = nameHashPtr; + Tcl_SetHashValue(nameHashPtr, tkColPtr); + + return &tkColPtr->color; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_GetColorByValue -- + * + * Given a desired set of red-green-blue intensities for a color, + * locate a pixel value to use to draw that color in a given + * window. + * + * Results: + * The return value is a pointer to an XColor structure that + * indicates the closest red, blue, and green intensities available + * to those specified in colorPtr, and also specifies a pixel + * value to use to draw in that color. + * + * Side effects: + * 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_FreeColor, so that the database is cleaned up when colors + * aren't in use anymore. + * + *---------------------------------------------------------------------- + */ + +XColor * +Tk_GetColorByValue(tkwin, colorPtr) + Tk_Window tkwin; /* Window where color will be used. */ + XColor *colorPtr; /* Red, green, and blue fields indicate + * desired color. */ +{ + ValueKey valueKey; + Tcl_HashEntry *valueHashPtr; + int new; + TkColor *tkColPtr; + Display *display = Tk_Display(tkwin); + + if (!initialized) { + ColorInit(); + } + + /* + * First, check to see if there's already a mapping for this color + * name. + */ + + valueKey.red = colorPtr->red; + valueKey.green = colorPtr->green; + valueKey.blue = colorPtr->blue; + valueKey.colormap = Tk_Colormap(tkwin); + valueKey.display = display; + valueHashPtr = Tcl_CreateHashEntry(&valueTable, (char *) &valueKey, &new); + if (!new) { + tkColPtr = (TkColor *) Tcl_GetHashValue(valueHashPtr); + tkColPtr->refCount++; + return &tkColPtr->color; + } + + /* + * The name isn't currently known. Find a pixel value for this + * color and add a new structure to valueTable. + */ + + tkColPtr = TkpGetColorByValue(tkwin, colorPtr); + tkColPtr->magic = COLOR_MAGIC; + tkColPtr->gc = None; + tkColPtr->screen = Tk_Screen(tkwin); + tkColPtr->colormap = valueKey.colormap; + tkColPtr->visual = Tk_Visual(tkwin); + tkColPtr->refCount = 1; + tkColPtr->tablePtr = &valueTable; + tkColPtr->hashPtr = valueHashPtr; + Tcl_SetHashValue(valueHashPtr, tkColPtr); + return &tkColPtr->color; +} + +/* + *-------------------------------------------------------------- + * + * Tk_NameOfColor -- + * + * Given a color, return a textual string identifying + * the color. + * + * Results: + * If colorPtr was created by Tk_GetColor, then the return + * value is the "string" that was used to create it. + * Otherwise the return value is a string that could have + * been passed to Tk_GetColor to allocate that color. The + * storage for the returned string is only guaranteed to + * persist up until the next call to this procedure. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +char * +Tk_NameOfColor(colorPtr) + XColor *colorPtr; /* Color whose name is desired. */ +{ + register TkColor *tkColPtr = (TkColor *) colorPtr; + static char string[20]; + + if ((tkColPtr->magic == COLOR_MAGIC) + && (tkColPtr->tablePtr == &nameTable)) { + return ((NameKey *) tkColPtr->hashPtr->key.words)->name; + } + sprintf(string, "#%04x%04x%04x", colorPtr->red, colorPtr->green, + colorPtr->blue); + return string; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_GCForColor -- + * + * Given a color allocated from this module, this procedure + * returns a GC that can be used for simple drawing with that + * color. + * + * Results: + * The return value is a GC with color set as its foreground + * color and all other fields defaulted. This GC is only valid + * as long as the color exists; it is freed automatically when + * the last reference to the color is freed. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +GC +Tk_GCForColor(colorPtr, drawable) + XColor *colorPtr; /* Color for which a GC is desired. Must + * have been allocated by Tk_GetColor or + * Tk_GetColorByName. */ + Drawable drawable; /* Drawable in which the color will be + * used (must have same screen and depth + * as the one for which the color was + * allocated). */ +{ + TkColor *tkColPtr = (TkColor *) colorPtr; + XGCValues gcValues; + + /* + * Do a quick sanity check to make sure this color was really + * allocated by Tk_GetColor. + */ + + if (tkColPtr->magic != COLOR_MAGIC) { + panic("Tk_GCForColor called with bogus color"); + } + + if (tkColPtr->gc == None) { + gcValues.foreground = tkColPtr->color.pixel; + tkColPtr->gc = XCreateGC(DisplayOfScreen(tkColPtr->screen), + drawable, GCForeground, &gcValues); + } + return tkColPtr->gc; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_FreeColor -- + * + * This procedure is called to release a color allocated by + * Tk_GetColor. + * + * Results: + * None. + * + * Side effects: + * The reference count associated with colorPtr is deleted, and + * the color is released to X if there are no remaining uses + * for it. + * + *---------------------------------------------------------------------- + */ + +void +Tk_FreeColor(colorPtr) + XColor *colorPtr; /* Color to be released. Must have been + * allocated by Tk_GetColor or + * Tk_GetColorByValue. */ +{ + register TkColor *tkColPtr = (TkColor *) colorPtr; + Screen *screen = tkColPtr->screen; + + /* + * Do a quick sanity check to make sure this color was really + * allocated by Tk_GetColor. + */ + + if (tkColPtr->magic != COLOR_MAGIC) { + 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; + } + TkpFreeColor(tkColPtr); + Tcl_DeleteHashEntry(tkColPtr->hashPtr); + tkColPtr->magic = 0; + ckfree((char *) tkColPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * ColorInit -- + * + * Initialize the structure used for color management. + * + * Results: + * None. + * + * Side effects: + * Read the code. + * + *---------------------------------------------------------------------- + */ + +static void +ColorInit() +{ + initialized = 1; + Tcl_InitHashTable(&nameTable, sizeof(NameKey)/sizeof(int)); + Tcl_InitHashTable(&valueTable, sizeof(ValueKey)/sizeof(int)); +} diff --git a/generic/tkColor.h b/generic/tkColor.h new file mode 100644 index 0000000..9653243 --- /dev/null +++ b/generic/tkColor.h @@ -0,0 +1,60 @@ +/* + * tkColor.h -- + * + * Declarations of data types and functions used by the + * Tk color module. + * + * Copyright (c) 1996 by Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkColor.h 1.1 96/10/22 16:53:09 + */ + +#ifndef _TKCOLOR +#define _TKCOLOR + +#include + +/* + * 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. + */ + +#define COLOR_MAGIC ((unsigned int) 0x46140277) + +typedef struct TkColor { + XColor color; /* Information about this color. */ + unsigned int magic; /* Used for quick integrity check on this + * structure. Must always have the + * value COLOR_MAGIC. */ + GC gc; /* Simple gc with this color as foreground + * color and all other fields defaulted. + * May be None. */ + Screen *screen; /* Screen where this color is valid. Used + * to delete it, and to find its display. */ + Colormap colormap; /* Colormap from which this entry was + * allocated. */ + Visual *visual; /* Visual associated with colormap. */ + int refCount; /* Number of uses of 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). */ +} TkColor; + +/* + * Common APIs exported from all platform-specific implementations. + */ + +#ifndef TkpFreeColor +EXTERN void TkpFreeColor _ANSI_ARGS_((TkColor *tkColPtr)); +#endif +EXTERN TkColor * TkpGetColor _ANSI_ARGS_((Tk_Window tkwin, + Tk_Uid name)); +EXTERN TkColor * TkpGetColorByValue _ANSI_ARGS_((Tk_Window tkwin, + XColor *colorPtr)); + +#endif /* _TKCOLOR */ diff --git a/generic/tkConfig.c b/generic/tkConfig.c new file mode 100644 index 0000000..2204714 --- /dev/null +++ b/generic/tkConfig.c @@ -0,0 +1,990 @@ +/* + * tkConfig.c -- + * + * This file contains the Tk_ConfigureWidget procedure. + * + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkConfig.c 1.53 96/04/26 10:29:31 + */ + +#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, + * interp->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 interp->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: { + sprintf(interp->result, "bad config table: unknown type %d", + specPtr->type); + 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. 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). + * + * 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; + } + interp->result = FormatConfigInfo(interp, tkwin, specPtr, widgRec); + interp->freeProc = 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). 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). + * + * 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/tkConsole.c b/generic/tkConsole.c new file mode 100644 index 0000000..c213371 --- /dev/null +++ b/generic/tkConsole.c @@ -0,0 +1,616 @@ +/* + * tkConsole.c -- + * + * This file implements a Tcl console for systems that may not + * otherwise have access to a console. It uses the Text widget + * and provides special access via a console command. + * + * Copyright (c) 1995-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: @(#) tkConsole.c 1.54 97/10/17 10:46:08 + */ + +#include "tk.h" +#include + +/* + * A data structure of the following type holds information for each console + * which a handler (i.e. a Tcl command) has been defined for a particular + * top-level window. + */ + +typedef struct ConsoleInfo { + Tcl_Interp *consoleInterp; /* Interpreter for the console. */ + Tcl_Interp *interp; /* Interpreter to send console commands. */ +} ConsoleInfo; + +static Tcl_Interp *gStdoutInterp = NULL; + +/* + * Forward declarations for procedures defined later in this file: + * + * The first three will be used in the tk app shells... + */ + +void TkConsoleCreate _ANSI_ARGS_((void)); +int TkConsoleInit _ANSI_ARGS_((Tcl_Interp *interp)); +void TkConsolePrint _ANSI_ARGS_((Tcl_Interp *interp, + int devId, char *buffer, long size)); + +static int ConsoleCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static void ConsoleDeleteProc _ANSI_ARGS_((ClientData clientData)); +static void ConsoleEventProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +static int InterpreterCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); + +static int ConsoleInput _ANSI_ARGS_((ClientData instanceData, + char *buf, int toRead, int *errorCode)); +static int ConsoleOutput _ANSI_ARGS_((ClientData instanceData, + char *buf, int toWrite, int *errorCode)); +static int ConsoleClose _ANSI_ARGS_((ClientData instanceData, + Tcl_Interp *interp)); +static void ConsoleWatch _ANSI_ARGS_((ClientData instanceData, + int mask)); +static int ConsoleHandle _ANSI_ARGS_((ClientData instanceData, + int direction, ClientData *handlePtr)); + +/* + * This structure describes the channel type structure for file based IO: + */ + +static Tcl_ChannelType consoleChannelType = { + "console", /* Type name. */ + NULL, /* Always non-blocking.*/ + ConsoleClose, /* Close proc. */ + ConsoleInput, /* Input proc. */ + ConsoleOutput, /* Output proc. */ + NULL, /* Seek proc. */ + NULL, /* Set option proc. */ + NULL, /* Get option proc. */ + ConsoleWatch, /* Watch for events on console. */ + ConsoleHandle, /* Get a handle from the device. */ +}; + +/* + *---------------------------------------------------------------------- + * + * TkConsoleCreate -- + * + * Create the console channels and install them as the standard + * channels. All I/O will be discarded until TkConsoleInit is + * called to attach the console to a text widget. + * + * Results: + * None. + * + * Side effects: + * Creates the console channel and installs it as the standard + * channels. + * + *---------------------------------------------------------------------- + */ + +void +TkConsoleCreate() +{ + Tcl_Channel consoleChannel; + + 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_SetStdChannel(consoleChannel, TCL_STDIN); + consoleChannel = Tcl_CreateChannel(&consoleChannelType, "console1", + (ClientData) TCL_STDOUT, TCL_WRITABLE); + if (consoleChannel != NULL) { + Tcl_SetChannelOption(NULL, consoleChannel, "-translation", "lf"); + Tcl_SetChannelOption(NULL, consoleChannel, "-buffering", "none"); + } + Tcl_SetStdChannel(consoleChannel, TCL_STDOUT); + consoleChannel = Tcl_CreateChannel(&consoleChannelType, "console2", + (ClientData) TCL_STDERR, TCL_WRITABLE); + if (consoleChannel != NULL) { + Tcl_SetChannelOption(NULL, consoleChannel, "-translation", "lf"); + Tcl_SetChannelOption(NULL, consoleChannel, "-buffering", "none"); + } + Tcl_SetStdChannel(consoleChannel, TCL_STDERR); +} + +/* + *---------------------------------------------------------------------- + * + * TkConsoleInit -- + * + * Initialize the console. This code actually creates a new + * application and associated interpreter. This effectivly hides + * the implementation from the main application. + * + * Results: + * None. + * + * Side effects: + * A new console it created. + * + *---------------------------------------------------------------------- + */ + +int +TkConsoleInit(interp) + Tcl_Interp *interp; /* Interpreter to use for prompting. */ +{ + Tcl_Interp *consoleInterp; + ConsoleInfo *info; + Tk_Window mainWindow = Tk_MainWindow(interp); +#ifdef MAC_TCL + static char initCmd[] = "source -rsrc {Console}"; +#else + static char initCmd[] = "source $tk_library/console.tcl"; +#endif + + consoleInterp = Tcl_CreateInterp(); + if (consoleInterp == NULL) { + goto error; + } + + /* + * Initialized Tcl and Tk. + */ + + if (Tcl_Init(consoleInterp) != TCL_OK) { + goto error; + } + if (Tk_Init(consoleInterp) != TCL_OK) { + goto error; + } + gStdoutInterp = interp; + + /* + * Add console commands to the interp + */ + info = (ConsoleInfo *) ckalloc(sizeof(ConsoleInfo)); + info->interp = interp; + info->consoleInterp = consoleInterp; + Tcl_CreateCommand(interp, "console", ConsoleCmd, (ClientData) info, + (Tcl_CmdDeleteProc *) ConsoleDeleteProc); + Tcl_CreateCommand(consoleInterp, "consoleinterp", InterpreterCmd, + (ClientData) info, (Tcl_CmdDeleteProc *) NULL); + + Tk_CreateEventHandler(mainWindow, StructureNotifyMask, ConsoleEventProc, + (ClientData) info); + + Tcl_Preserve((ClientData) consoleInterp); + if (Tcl_Eval(consoleInterp, initCmd) == TCL_ERROR) { + /* goto error; -- no problem for now... */ + printf("Eval error: %s", consoleInterp->result); + } + Tcl_Release((ClientData) consoleInterp); + return TCL_OK; + + error: + if (consoleInterp != NULL) { + Tcl_DeleteInterp(consoleInterp); + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * ConsoleOutput-- + * + * Writes the given output on the IO channel. Returns count of how + * many characters were actually written, and an error indication. + * + * Results: + * A count of how many characters were written is returned and an + * error indication is returned in an output argument. + * + * Side effects: + * Writes output on the actual channel. + * + *---------------------------------------------------------------------- + */ + +static int +ConsoleOutput(instanceData, buf, toWrite, errorCode) + ClientData instanceData; /* Indicates which device to use. */ + char *buf; /* The data buffer. */ + int toWrite; /* How many bytes to write? */ + int *errorCode; /* Where to store error code. */ +{ + *errorCode = 0; + Tcl_SetErrno(0); + + if (gStdoutInterp != NULL) { + TkConsolePrint(gStdoutInterp, (int) instanceData, buf, toWrite); + } + + return toWrite; +} + +/* + *---------------------------------------------------------------------- + * + * ConsoleInput -- + * + * Read input from the console. Not currently implemented. + * + * Results: + * Always returns EOF. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +ConsoleInput(instanceData, buf, bufSize, errorCode) + ClientData instanceData; /* Unused. */ + char *buf; /* Where to store data read. */ + int bufSize; /* How much space is available + * in the buffer? */ + int *errorCode; /* Where to store error code. */ +{ + return 0; /* Always return EOF. */ +} + +/* + *---------------------------------------------------------------------- + * + * ConsoleClose -- + * + * Closes the IO channel. + * + * Results: + * Always returns 0 (success). + * + * Side effects: + * Frees the dummy file associated with the channel. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +ConsoleClose(instanceData, interp) + ClientData instanceData; /* Unused. */ + Tcl_Interp *interp; /* Unused. */ +{ + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * ConsoleWatch -- + * + * Called by the notifier to set up the console device so that + * events will be noticed. Since there are no events on the + * console, this routine just returns without doing anything. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +ConsoleWatch(instanceData, mask) + ClientData instanceData; /* Device ID for the channel. */ + int mask; /* OR-ed combination of + * TCL_READABLE, TCL_WRITABLE and + * TCL_EXCEPTION, for the events + * we are interested in. */ +{ +} + +/* + *---------------------------------------------------------------------- + * + * ConsoleHandle -- + * + * Invoked by the generic IO layer to get a handle from a channel. + * Because console channels are not devices, this function always + * fails. + * + * Results: + * Always returns TCL_ERROR. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +ConsoleHandle(instanceData, direction, handlePtr) + ClientData instanceData; /* Device ID for the channel. */ + int direction; /* TCL_READABLE or TCL_WRITABLE to indicate + * which direction of the channel is being + * requested. */ + ClientData *handlePtr; /* Where to store handle */ +{ + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * ConsoleCmd -- + * + * The console command implements a Tcl interface to the various console + * options. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ConsoleCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + ConsoleInfo *info = (ConsoleInfo *) clientData; + char c; + int length; + int result; + Tcl_Interp *consoleInterp; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option ?arg arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + + c = argv[1][0]; + length = strlen(argv[1]); + result = TCL_OK; + consoleInterp = info->consoleInterp; + Tcl_Preserve((ClientData) consoleInterp); + if ((c == 't') && (strncmp(argv[1], "title", length)) == 0) { + Tcl_DString dString; + + Tcl_DStringInit(&dString); + Tcl_DStringAppend(&dString, "wm title . ", -1); + if (argc == 3) { + Tcl_DStringAppendElement(&dString, argv[2]); + } + Tcl_Eval(consoleInterp, Tcl_DStringValue(&dString)); + Tcl_DStringFree(&dString); + } else if ((c == 'h') && (strncmp(argv[1], "hide", length)) == 0) { + Tcl_Eval(info->consoleInterp, "wm withdraw ."); + } else if ((c == 's') && (strncmp(argv[1], "show", length)) == 0) { + Tcl_Eval(info->consoleInterp, "wm deiconify ."); + } else if ((c == 'e') && (strncmp(argv[1], "eval", length)) == 0) { + if (argc == 3) { + Tcl_Eval(info->consoleInterp, argv[2]); + } else { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " eval command\"", (char *) NULL); + return TCL_ERROR; + } + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be hide, show, or title", + (char *) NULL); + result = TCL_ERROR; + } + Tcl_Release((ClientData) consoleInterp); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * InterpreterCmd -- + * + * This command allows the console interp to communicate with the + * main interpreter. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +InterpreterCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + ConsoleInfo *info = (ConsoleInfo *) clientData; + char c; + int length; + int result; + Tcl_Interp *otherInterp; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option ?arg arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + + c = argv[1][0]; + length = strlen(argv[1]); + otherInterp = info->interp; + Tcl_Preserve((ClientData) otherInterp); + if ((c == 'e') && (strncmp(argv[1], "eval", length)) == 0) { + result = Tcl_GlobalEval(otherInterp, argv[2]); + Tcl_AppendResult(interp, otherInterp->result, (char *) NULL); + } else if ((c == 'r') && (strncmp(argv[1], "record", length)) == 0) { + Tcl_RecordAndEval(otherInterp, argv[2], TCL_EVAL_GLOBAL); + result = TCL_OK; + Tcl_AppendResult(interp, otherInterp->result, (char *) NULL); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be eval or record", + (char *) NULL); + result = TCL_ERROR; + } + Tcl_Release((ClientData) otherInterp); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * ConsoleDeleteProc -- + * + * If the console command is deleted we destroy the console window + * and all associated data structures. + * + * Results: + * None. + * + * Side effects: + * A new console it created. + * + *---------------------------------------------------------------------- + */ + +void +ConsoleDeleteProc(clientData) + ClientData clientData; +{ + ConsoleInfo *info = (ConsoleInfo *) clientData; + + Tcl_DeleteInterp(info->consoleInterp); + info->consoleInterp = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * ConsoleEventProc -- + * + * This event procedure is registered on the main window of the + * slave interpreter. If the user or a running script causes the + * main window to be destroyed, then we need to inform the console + * interpreter by invoking "tkConsoleExit". + * + * Results: + * None. + * + * Side effects: + * Invokes the "tkConsoleExit" procedure in the console interp. + * + *---------------------------------------------------------------------- + */ + +static void +ConsoleEventProc(clientData, eventPtr) + ClientData clientData; + XEvent *eventPtr; +{ + ConsoleInfo *info = (ConsoleInfo *) clientData; + Tcl_Interp *consoleInterp; + + if (eventPtr->type == DestroyNotify) { + consoleInterp = info->consoleInterp; + + /* + * It is possible that the console interpreter itself has + * already been deleted. In that case the consoleInterp + * field will be set to NULL. If the interpreter is already + * gone, we do not have to do any work here. + */ + + if (consoleInterp == (Tcl_Interp *) NULL) { + return; + } + Tcl_Preserve((ClientData) consoleInterp); + Tcl_Eval(consoleInterp, "tkConsoleExit"); + Tcl_Release((ClientData) consoleInterp); + } +} + +/* + *---------------------------------------------------------------------- + * + * TkConsolePrint -- + * + * Prints to the give text to the console. Given the main interp + * this functions find the appropiate console interp and forwards + * the text to be added to that console. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TkConsolePrint(interp, devId, buffer, size) + Tcl_Interp *interp; /* Main interpreter. */ + int devId; /* TCL_STDOUT for stdout, TCL_STDERR for + * stderr. */ + char *buffer; /* Text buffer. */ + long size; /* Size of text buffer. */ +{ + Tcl_DString command, output; + Tcl_CmdInfo cmdInfo; + char *cmd; + ConsoleInfo *info; + Tcl_Interp *consoleInterp; + int result; + + if (interp == NULL) { + return; + } + + if (devId == TCL_STDERR) { + cmd = "tkConsoleOutput stderr "; + } else { + cmd = "tkConsoleOutput stdout "; + } + + result = Tcl_GetCommandInfo(interp, "console", &cmdInfo); + if (result == 0) { + return; + } + info = (ConsoleInfo *) cmdInfo.clientData; + + Tcl_DStringInit(&output); + Tcl_DStringAppend(&output, buffer, size); + + Tcl_DStringInit(&command); + Tcl_DStringAppend(&command, cmd, strlen(cmd)); + Tcl_DStringAppendElement(&command, output.string); + + consoleInterp = info->consoleInterp; + Tcl_Preserve((ClientData) consoleInterp); + Tcl_Eval(consoleInterp, command.string); + Tcl_Release((ClientData) consoleInterp); + + Tcl_DStringFree(&command); + Tcl_DStringFree(&output); +} diff --git a/generic/tkCursor.c b/generic/tkCursor.c new file mode 100644 index 0000000..e185109 --- /dev/null +++ b/generic/tkCursor.c @@ -0,0 +1,384 @@ +/* + * tkCursor.c -- + * + * This file maintains a database of read-only cursors for the Tk + * toolkit. This allows cursors to be shared between widgets and + * 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. + * + * 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 + */ + +#include "tkPort.h" +#include "tkInt.h" + +/* + * A TkCursor structure exists for each cursor that is currently + * active. Each structure is indexed with two hash tables defined + * below. One of the tables is idTable, and the other is either + * nameTable or dataTable, also defined below. + */ + +/* + * 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: + */ + +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 + * cursor (bitmap contents, etc.) to a TkCursor structure: + */ + +static Tcl_HashTable dataTable; +typedef struct { + char *source; /* Cursor bits. */ + char *mask; /* Mask bits. */ + int width, height; /* Dimensions of cursor (and data + * and mask). */ + int xHot, yHot; /* Location of cursor hot-spot. */ + Tk_Uid fg, bg; /* Colors for cursor. */ + Display *display; /* Display on which cursor will be used. */ +} DataKey; + +/* + * Hash table that maps from to the TkCursor structure + * for the cursor. This table is used by Tk_FreeCursor. + */ + +static Tcl_HashTable idTable; +typedef struct { + Display *display; /* Display for which cursor was allocated. */ + Tk_Cursor cursor; /* Cursor identifier. */ +} IdKey; + +static int initialized = 0; /* 0 means static structures haven't been + * initialized yet. */ + +/* + * Forward declarations for procedures defined in this file: + */ + +static void CursorInit _ANSI_ARGS_((void)); + +/* + *---------------------------------------------------------------------- + * + * Tk_GetCursor -- + * + * Given a string describing a cursor, locate (or create if necessary) + * a cursor that fits the description. + * + * 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. + * 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. + * + *---------------------------------------------------------------------- + */ + +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 + * for details on legal syntax. */ +{ + NameKey nameKey; + IdKey idKey; + Tcl_HashEntry *nameHashPtr, *idHashPtr; + register TkCursor *cursorPtr; + int new; + + if (!initialized) { + CursorInit(); + } + + nameKey.name = string; + nameKey.display = Tk_Display(tkwin); + nameHashPtr = Tcl_CreateHashEntry(&nameTable, (char *) &nameKey, &new); + if (!new) { + cursorPtr = (TkCursor *) Tcl_GetHashValue(nameHashPtr); + cursorPtr->refCount++; + return cursorPtr->cursor; + } + + cursorPtr = TkGetCursorByName(interp, tkwin, string); + + if (cursorPtr == NULL) { + Tcl_DeleteHashEntry(nameHashPtr); + return None; + } + + /* + * Add information about this cursor to our database. + */ + + cursorPtr->refCount = 1; + cursorPtr->otherTable = &nameTable; + cursorPtr->hashPtr = nameHashPtr; + idKey.display = nameKey.display; + idKey.cursor = cursorPtr->cursor; + idHashPtr = Tcl_CreateHashEntry(&idTable, (char *) &idKey, &new); + if (!new) { + panic("cursor already registered in Tk_GetCursor"); + } + Tcl_SetHashValue(nameHashPtr, cursorPtr); + Tcl_SetHashValue(idHashPtr, cursorPtr); + + return cursorPtr->cursor; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_GetCursorFromData -- + * + * Given a description of the bits and colors for a cursor, + * make a cursor that has the given properties. + * + * 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 + * 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. + * + *---------------------------------------------------------------------- + */ + +Tk_Cursor +Tk_GetCursorFromData(interp, tkwin, source, mask, width, height, + xHot, yHot, fg, bg) + Tcl_Interp *interp; /* Interpreter to use for error reporting. */ + Tk_Window tkwin; /* Window in which cursor will be used. */ + char *source; /* Bitmap data for cursor shape. */ + char *mask; /* Bitmap data for cursor mask. */ + int width, height; /* Dimensions of cursor. */ + int xHot, yHot; /* Location of hot-spot in cursor. */ + Tk_Uid fg; /* Foreground color for cursor. */ + Tk_Uid bg; /* Background color for cursor. */ +{ + DataKey dataKey; + IdKey idKey; + Tcl_HashEntry *dataHashPtr, *idHashPtr; + register TkCursor *cursorPtr; + int new; + XColor fgColor, bgColor; + + if (!initialized) { + CursorInit(); + } + + dataKey.source = source; + dataKey.mask = mask; + dataKey.width = width; + dataKey.height = height; + dataKey.xHot = xHot; + dataKey.yHot = yHot; + dataKey.fg = fg; + dataKey.bg = bg; + dataKey.display = Tk_Display(tkwin); + dataHashPtr = Tcl_CreateHashEntry(&dataTable, (char *) &dataKey, &new); + if (!new) { + cursorPtr = (TkCursor *) Tcl_GetHashValue(dataHashPtr); + cursorPtr->refCount++; + return cursorPtr->cursor; + } + + /* + * No suitable cursor exists yet. Make one using the data + * available and add it to the database. + */ + + if (XParseColor(dataKey.display, Tk_Colormap(tkwin), fg, &fgColor) == 0) { + Tcl_AppendResult(interp, "invalid color name \"", fg, "\"", + (char *) NULL); + goto error; + } + if (XParseColor(dataKey.display, Tk_Colormap(tkwin), bg, &bgColor) == 0) { + Tcl_AppendResult(interp, "invalid color name \"", bg, "\"", + (char *) NULL); + goto error; + } + + cursorPtr = TkCreateCursorFromData(tkwin, source, mask, width, height, + xHot, yHot, fgColor, bgColor); + + if (cursorPtr == NULL) { + goto error; + } + + cursorPtr->refCount = 1; + cursorPtr->otherTable = &dataTable; + cursorPtr->hashPtr = dataHashPtr; + idKey.display = dataKey.display; + idKey.cursor = cursorPtr->cursor; + idHashPtr = Tcl_CreateHashEntry(&idTable, (char *) &idKey, &new); + if (!new) { + panic("cursor already registered in Tk_GetCursorFromData"); + } + Tcl_SetHashValue(dataHashPtr, cursorPtr); + Tcl_SetHashValue(idHashPtr, cursorPtr); + return cursorPtr->cursor; + + error: + Tcl_DeleteHashEntry(dataHashPtr); + return None; +} + +/* + *-------------------------------------------------------------- + * + * Tk_NameOfCursor -- + * + * Given a cursor, return a textual string identifying it. + * + * Results: + * If cursor was created by Tk_GetCursor, then the return + * value is the "string" that was used to create it. + * Otherwise the return value is a string giving the X + * identifier for the cursor. The storage for the returned + * string is only guaranteed to persist up until the next + * call to this procedure. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +char * +Tk_NameOfCursor(display, cursor) + Display *display; /* Display for which cursor was allocated. */ + Tk_Cursor cursor; /* Identifier for cursor whose name is + * wanted. */ +{ + IdKey idKey; + Tcl_HashEntry *idHashPtr; + TkCursor *cursorPtr; + static char string[20]; + + if (!initialized) { + printid: + sprintf(string, "cursor id 0x%x", (unsigned int) cursor); + return string; + } + idKey.display = display; + idKey.cursor = cursor; + idHashPtr = Tcl_FindHashEntry(&idTable, (char *) &idKey); + if (idHashPtr == NULL) { + goto printid; + } + cursorPtr = (TkCursor *) Tcl_GetHashValue(idHashPtr); + if (cursorPtr->otherTable != &nameTable) { + goto printid; + } + return ((NameKey *) cursorPtr->hashPtr->key.words)->name; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_FreeCursor -- + * + * This procedure is called to release a cursor allocated by + * Tk_GetCursor or TkGetCursorFromData. + * + * Results: + * None. + * + * Side effects: + * The reference count associated with cursor is decremented, and + * it is officially deallocated if no-one is using it anymore. + * + *---------------------------------------------------------------------- + */ + +void +Tk_FreeCursor(display, cursor) + Display *display; /* Display for which cursor was allocated. */ + Tk_Cursor cursor; /* Identifier for cursor to be released. */ +{ + IdKey idKey; + Tcl_HashEntry *idHashPtr; + register TkCursor *cursorPtr; + + if (!initialized) { + panic("Tk_FreeCursor called before Tk_GetCursor"); + } + + idKey.display = display; + idKey.cursor = cursor; + idHashPtr = Tcl_FindHashEntry(&idTable, (char *) &idKey); + 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); + } +} + +/* + *---------------------------------------------------------------------- + * + * CursorInit -- + * + * Initialize the structures used for cursor management. + * + * Results: + * None. + * + * Side effects: + * Read the code. + * + *---------------------------------------------------------------------- + */ + +static void +CursorInit() +{ + initialized = 1; + Tcl_InitHashTable(&nameTable, sizeof(NameKey)/sizeof(int)); + Tcl_InitHashTable(&dataTable, sizeof(DataKey)/sizeof(int)); + + /* + * The call below is tricky: can't use sizeof(IdKey) because it + * gets padded with extra unpredictable bytes on some 64-bit + * machines. + */ + + Tcl_InitHashTable(&idTable, (sizeof(Display *) + sizeof(Tk_Cursor)) + /sizeof(int)); +} diff --git a/generic/tkEntry.c b/generic/tkEntry.c new file mode 100644 index 0000000..35cc66c --- /dev/null +++ b/generic/tkEntry.c @@ -0,0 +1,2313 @@ +/* + * tkEntry.c -- + * + * This module implements entry widgets for the Tk + * toolkit. An entry displays a string and allows + * the string to be edited. + * + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkEntry.c 1.112 97/11/06 16:56:16 + */ + +#include "tkInt.h" +#include "default.h" + +/* + * A data structure of the following type is kept for each entry + * widget managed by this file: + */ + +typedef struct { + Tk_Window tkwin; /* Window that embodies the entry. NULL + * means that the window has been destroyed + * but the data structures haven't yet been + * cleaned up.*/ + Display *display; /* Display containing widget. Used, among + * other things, so that resources can be + * freed even after tkwin has gone away. */ + Tcl_Interp *interp; /* Interpreter associated with entry. */ + Tcl_Command widgetCmd; /* Token for entry's widget command. */ + + /* + * Fields that are set by widget commands other than "configure". + */ + + char *string; /* Pointer to storage for string; + * NULL-terminated; malloc-ed. */ + int insertPos; /* Index of character 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 selectAnchor; /* Fixed end of selection (i.e. "select to" + * operation will use this as one end of the + * selection). */ + + /* + * Information for scanning: + */ + + 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. */ + + /* + * Configuration settings that are updated by Tk_ConfigureWidget. + */ + + Tk_3DBorder normalBorder; /* Used for drawing border around whole + * window, plus used for background. */ + int borderWidth; /* Width of 3-D border around window. */ + Tk_Cursor cursor; /* Current cursor for window, or None. */ + int exportSelection; /* Non-zero means tie internal entry selection + * to X selection. */ + Tk_Font tkfont; /* Information about text font, or NULL. */ + XColor *fgColorPtr; /* Text color in normal mode. */ + XColor *highlightBgColorPtr;/* Color for drawing traversal highlight + * area when highlight is off. */ + XColor *highlightColorPtr; /* Color for drawing traversal highlight. */ + int highlightWidth; /* Width in pixels of highlight to draw + * around widget when it has the focus. + * <= 0 means don't draw a highlight. */ + Tk_3DBorder insertBorder; /* Used to draw vertical bar for insertion + * cursor. */ + int insertBorderWidth; /* Width of 3-D border around insert cursor. */ + int insertOffTime; /* Number of milliseconds cursor should spend + * in "off" state for each blink. */ + int insertOnTime; /* Number of milliseconds cursor should spend + * in "on" state for each blink. */ + int insertWidth; /* Total width of insert cursor. */ + Tk_Justify justify; /* Justification to use for text within + * window. */ + int relief; /* 3-D effect: TK_RELIEF_RAISED, etc. */ + Tk_3DBorder selBorder; /* Border and background for selected + * characters. */ + int selBorderWidth; /* Width of border around selection. */ + XColor *selFgColorPtr; /* Foreground color for selected text. */ + char *showChar; /* Value of -show option. If non-NULL, first + * character is used for displaying all + * characters in entry. Malloc'ed. */ + Tk_Uid state; /* Normal or disabled. Entry is read-only + * when disabled. */ + char *textVarName; /* Name of variable (malloc'ed) or NULL. + * If non-NULL, entry's string tracks the + * contents of this variable and vice versa. */ + char *takeFocus; /* Value of -takefocus option; not used in + * the C code, but used by keyboard traversal + * scripts. Malloc'ed, but may be NULL. */ + int prefWidth; /* Desired width of window, measured in + * average characters. */ + char *scrollCmd; /* Command prefix for communicating with + * scrollbar(s). Malloc'ed. NULL means + * no command to issue. */ + + /* + * Fields whose values are derived from the current values of the + * 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 + * length as string but whose characters + * are all equal to showChar. Malloc'ed. */ + 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). */ + Tcl_TimerToken insertBlinkHandler; + /* Timer handler used to blink cursor on and + * off. */ + GC textGC; /* For drawing normal text. */ + GC selTextGC; /* For drawing selected text. */ + GC highlightGC; /* For drawing traversal highlight. */ + int avgWidth; /* Width of average character. */ + int flags; /* Miscellaneous flags; see below for + * definitions. */ +} Entry; + +/* + * Assigned bits of "flags" fields of Entry structures, and what those + * bits mean: + * + * REDRAW_PENDING: Non-zero means a DoWhenIdle handler has + * already been queued to redisplay the entry. + * BORDER_NEEDED: Non-zero means 3-D border must be redrawn + * around window during redisplay. Normally + * only text portion needs to be redrawn. + * CURSOR_ON: Non-zero means insert cursor is displayed at + * present. 0 means it isn't displayed. + * GOT_FOCUS: Non-zero means this window has the input + * focus. + * UPDATE_SCROLLBAR: Non-zero means scrollbar should be updated + * during next redisplay operation. + * GOT_SELECTION: Non-zero means we've claimed the selection. + */ + +#define REDRAW_PENDING 1 +#define BORDER_NEEDED 2 +#define CURSOR_ON 4 +#define GOT_FOCUS 8 +#define UPDATE_SCROLLBAR 0x10 +#define GOT_SELECTION 0x20 + +/* + * The following macro defines how many extra pixels to leave on each + * side of the text in the entry. + */ + +#define XPAD 1 +#define YPAD 1 + +/* + * Information used for argv parsing. + */ + +static Tk_ConfigSpec configSpecs[] = { + {TK_CONFIG_BORDER, "-background", "background", "Background", + DEF_ENTRY_BG_COLOR, Tk_Offset(Entry, normalBorder), + TK_CONFIG_COLOR_ONLY}, + {TK_CONFIG_BORDER, "-background", "background", "Background", + DEF_ENTRY_BG_MONO, Tk_Offset(Entry, normalBorder), + 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_ENTRY_BORDER_WIDTH, Tk_Offset(Entry, borderWidth), 0}, + {TK_CONFIG_ACTIVE_CURSOR, "-cursor", "cursor", "Cursor", + DEF_ENTRY_CURSOR, Tk_Offset(Entry, cursor), TK_CONFIG_NULL_OK}, + {TK_CONFIG_BOOLEAN, "-exportselection", "exportSelection", + "ExportSelection", DEF_ENTRY_EXPORT_SELECTION, + Tk_Offset(Entry, exportSelection), 0}, + {TK_CONFIG_SYNONYM, "-fg", "foreground", (char *) NULL, + (char *) NULL, 0, 0}, + {TK_CONFIG_FONT, "-font", "font", "Font", + DEF_ENTRY_FONT, Tk_Offset(Entry, tkfont), 0}, + {TK_CONFIG_COLOR, "-foreground", "foreground", "Foreground", + DEF_ENTRY_FG, Tk_Offset(Entry, fgColorPtr), 0}, + {TK_CONFIG_COLOR, "-highlightbackground", "highlightBackground", + "HighlightBackground", DEF_ENTRY_HIGHLIGHT_BG, + Tk_Offset(Entry, highlightBgColorPtr), 0}, + {TK_CONFIG_COLOR, "-highlightcolor", "highlightColor", "HighlightColor", + DEF_ENTRY_HIGHLIGHT, Tk_Offset(Entry, highlightColorPtr), 0}, + {TK_CONFIG_PIXELS, "-highlightthickness", "highlightThickness", + "HighlightThickness", + DEF_ENTRY_HIGHLIGHT_WIDTH, Tk_Offset(Entry, highlightWidth), 0}, + {TK_CONFIG_BORDER, "-insertbackground", "insertBackground", "Foreground", + DEF_ENTRY_INSERT_BG, Tk_Offset(Entry, insertBorder), 0}, + {TK_CONFIG_PIXELS, "-insertborderwidth", "insertBorderWidth", "BorderWidth", + DEF_ENTRY_INSERT_BD_COLOR, Tk_Offset(Entry, insertBorderWidth), + TK_CONFIG_COLOR_ONLY}, + {TK_CONFIG_PIXELS, "-insertborderwidth", "insertBorderWidth", "BorderWidth", + DEF_ENTRY_INSERT_BD_MONO, Tk_Offset(Entry, insertBorderWidth), + TK_CONFIG_MONO_ONLY}, + {TK_CONFIG_INT, "-insertofftime", "insertOffTime", "OffTime", + DEF_ENTRY_INSERT_OFF_TIME, Tk_Offset(Entry, insertOffTime), 0}, + {TK_CONFIG_INT, "-insertontime", "insertOnTime", "OnTime", + DEF_ENTRY_INSERT_ON_TIME, Tk_Offset(Entry, insertOnTime), 0}, + {TK_CONFIG_PIXELS, "-insertwidth", "insertWidth", "InsertWidth", + DEF_ENTRY_INSERT_WIDTH, Tk_Offset(Entry, insertWidth), 0}, + {TK_CONFIG_JUSTIFY, "-justify", "justify", "Justify", + DEF_ENTRY_JUSTIFY, Tk_Offset(Entry, justify), 0}, + {TK_CONFIG_RELIEF, "-relief", "relief", "Relief", + DEF_ENTRY_RELIEF, Tk_Offset(Entry, relief), 0}, + {TK_CONFIG_BORDER, "-selectbackground", "selectBackground", "Foreground", + DEF_ENTRY_SELECT_COLOR, Tk_Offset(Entry, selBorder), + TK_CONFIG_COLOR_ONLY}, + {TK_CONFIG_BORDER, "-selectbackground", "selectBackground", "Foreground", + DEF_ENTRY_SELECT_MONO, Tk_Offset(Entry, selBorder), + TK_CONFIG_MONO_ONLY}, + {TK_CONFIG_PIXELS, "-selectborderwidth", "selectBorderWidth", "BorderWidth", + DEF_ENTRY_SELECT_BD_COLOR, Tk_Offset(Entry, selBorderWidth), + TK_CONFIG_COLOR_ONLY}, + {TK_CONFIG_PIXELS, "-selectborderwidth", "selectBorderWidth", "BorderWidth", + DEF_ENTRY_SELECT_BD_MONO, Tk_Offset(Entry, selBorderWidth), + TK_CONFIG_MONO_ONLY}, + {TK_CONFIG_COLOR, "-selectforeground", "selectForeground", "Background", + DEF_ENTRY_SELECT_FG_COLOR, Tk_Offset(Entry, selFgColorPtr), + TK_CONFIG_COLOR_ONLY}, + {TK_CONFIG_COLOR, "-selectforeground", "selectForeground", "Background", + DEF_ENTRY_SELECT_FG_MONO, Tk_Offset(Entry, selFgColorPtr), + TK_CONFIG_MONO_ONLY}, + {TK_CONFIG_STRING, "-show", "show", "Show", + DEF_ENTRY_SHOW, Tk_Offset(Entry, showChar), TK_CONFIG_NULL_OK}, + {TK_CONFIG_UID, "-state", "state", "State", + DEF_ENTRY_STATE, Tk_Offset(Entry, state), 0}, + {TK_CONFIG_STRING, "-takefocus", "takeFocus", "TakeFocus", + DEF_ENTRY_TAKE_FOCUS, Tk_Offset(Entry, takeFocus), TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-textvariable", "textVariable", "Variable", + DEF_ENTRY_TEXT_VARIABLE, Tk_Offset(Entry, textVarName), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_INT, "-width", "width", "Width", + DEF_ENTRY_WIDTH, Tk_Offset(Entry, prefWidth), 0}, + {TK_CONFIG_STRING, "-xscrollcommand", "xScrollCommand", "ScrollCommand", + DEF_ENTRY_SCROLL_COMMAND, Tk_Offset(Entry, scrollCmd), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, 0} +}; + +/* + * Flags for GetEntryIndex procedure: + */ + +#define ZERO_OK 1 +#define LAST_PLUS_ONE_OK 2 + +/* + * Forward declarations for procedures defined later in this file: + */ + +static int ConfigureEntry _ANSI_ARGS_((Tcl_Interp *interp, + Entry *entryPtr, int argc, char **argv, + int flags)); +static void DeleteChars _ANSI_ARGS_((Entry *entryPtr, int index, + int count)); +static void DestroyEntry _ANSI_ARGS_((char *memPtr)); +static void DisplayEntry _ANSI_ARGS_((ClientData clientData)); +static void EntryBlinkProc _ANSI_ARGS_((ClientData clientData)); +static void EntryCmdDeletedProc _ANSI_ARGS_(( + ClientData clientData)); +static void EntryComputeGeometry _ANSI_ARGS_((Entry *entryPtr)); +static void EntryEventProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +static void EntryFocusProc _ANSI_ARGS_ ((Entry *entryPtr, + int gotFocus)); +static int EntryFetchSelection _ANSI_ARGS_((ClientData clientData, + int offset, char *buffer, int maxBytes)); +static void EntryLostSelection _ANSI_ARGS_(( + ClientData clientData)); +static void EventuallyRedraw _ANSI_ARGS_((Entry *entryPtr)); +static void EntryScanTo _ANSI_ARGS_((Entry *entryPtr, int y)); +static void EntrySetValue _ANSI_ARGS_((Entry *entryPtr, + char *value)); +static void EntrySelectTo _ANSI_ARGS_(( + Entry *entryPtr, int index)); +static char * EntryTextVarProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, char *name1, char *name2, + int flags)); +static void EntryUpdateScrollbar _ANSI_ARGS_((Entry *entryPtr)); +static void EntryValueChanged _ANSI_ARGS_((Entry *entryPtr)); +static void EntryVisibleRange _ANSI_ARGS_((Entry *entryPtr, + double *firstPtr, double *lastPtr)); +static int EntryWidgetCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static void EntryWorldChanged _ANSI_ARGS_(( + ClientData instanceData)); +static int GetEntryIndex _ANSI_ARGS_((Tcl_Interp *interp, + Entry *entryPtr, char *string, int *indexPtr)); +static void InsertChars _ANSI_ARGS_((Entry *entryPtr, int index, + char *string)); + +/* + * The structure below defines entry class behavior by means of procedures + * that can be invoked from generic window code. + */ + +static TkClassProcs entryClass = { + NULL, /* createProc. */ + EntryWorldChanged, /* geometryProc. */ + NULL /* modalProc. */ +}; + + +/* + *-------------------------------------------------------------- + * + * Tk_EntryCmd -- + * + * This procedure is invoked to process the "entry" 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_EntryCmd(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; + register Entry *entryPtr; + Tk_Window new; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " pathName ?options?\"", (char *) NULL); + return TCL_ERROR; + } + + new = Tk_CreateWindowFromPath(interp, tkwin, argv[1], (char *) NULL); + if (new == NULL) { + return TCL_ERROR; + } + + /* + * Initialize the fields of the structure that won't be initialized + * by ConfigureEntry, or that ConfigureEntry requires to be + * initialized already (e.g. resource pointers). + */ + + entryPtr = (Entry *) ckalloc(sizeof(Entry)); + entryPtr->tkwin = new; + entryPtr->display = Tk_Display(new); + entryPtr->interp = interp; + entryPtr->widgetCmd = Tcl_CreateCommand(interp, + Tk_PathName(entryPtr->tkwin), EntryWidgetCmd, + (ClientData) entryPtr, EntryCmdDeletedProc); + entryPtr->string = (char *) ckalloc(1); + entryPtr->string[0] = '\0'; + entryPtr->insertPos = 0; + entryPtr->selectFirst = -1; + entryPtr->selectLast = -1; + entryPtr->selectAnchor = 0; + entryPtr->scanMarkX = 0; + entryPtr->scanMarkIndex = 0; + + entryPtr->normalBorder = NULL; + entryPtr->borderWidth = 0; + entryPtr->cursor = None; + entryPtr->exportSelection = 1; + entryPtr->tkfont = NULL; + entryPtr->fgColorPtr = NULL; + entryPtr->highlightBgColorPtr = NULL; + entryPtr->highlightColorPtr = NULL; + entryPtr->highlightWidth = 0; + entryPtr->insertBorder = NULL; + entryPtr->insertBorderWidth = 0; + entryPtr->insertOffTime = 0; + entryPtr->insertOnTime = 0; + entryPtr->insertWidth = 0; + entryPtr->justify = TK_JUSTIFY_LEFT; + entryPtr->relief = TK_RELIEF_FLAT; + entryPtr->selBorder = NULL; + entryPtr->selBorderWidth = 0; + entryPtr->selFgColorPtr = NULL; + entryPtr->showChar = NULL; + entryPtr->state = tkNormalUid; + entryPtr->textVarName = NULL; + entryPtr->takeFocus = NULL; + entryPtr->prefWidth = 0; + entryPtr->scrollCmd = NULL; + + entryPtr->numChars = 0; + entryPtr->displayString = NULL; + entryPtr->inset = XPAD; + entryPtr->textLayout = NULL; + entryPtr->layoutX = 0; + entryPtr->layoutY = 0; + entryPtr->leftIndex = 0; + entryPtr->leftX = 0; + entryPtr->insertBlinkHandler = (Tcl_TimerToken) NULL; + entryPtr->textGC = None; + entryPtr->selTextGC = None; + entryPtr->highlightGC = None; + entryPtr->avgWidth = 1; + entryPtr->flags = 0; + + Tk_SetClass(entryPtr->tkwin, "Entry"); + TkSetClassProcs(entryPtr->tkwin, &entryClass, (ClientData) entryPtr); + Tk_CreateEventHandler(entryPtr->tkwin, + ExposureMask|StructureNotifyMask|FocusChangeMask, + EntryEventProc, (ClientData) entryPtr); + Tk_CreateSelHandler(entryPtr->tkwin, XA_PRIMARY, XA_STRING, + EntryFetchSelection, (ClientData) entryPtr, XA_STRING); + if (ConfigureEntry(interp, entryPtr, argc-2, argv+2, 0) != TCL_OK) { + goto error; + } + + interp->result = Tk_PathName(entryPtr->tkwin); + return TCL_OK; + + error: + Tk_DestroyWindow(entryPtr->tkwin); + return TCL_ERROR; +} + +/* + *-------------------------------------------------------------- + * + * EntryWidgetCmd -- + * + * This procedure is invoked to process the Tcl command + * that corresponds to a widget managed by this module. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +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. */ +{ + register Entry *entryPtr = (Entry *) clientData; + int result = TCL_OK; + size_t length; + int c; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " option ?arg arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_Preserve((ClientData) entryPtr); + c = argv[1][0]; + length = strlen(argv[1]); + if ((c == 'b') && (strncmp(argv[1], "bbox", length) == 0)) { + int index; + int x, y, width, height; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " bbox index\"", + (char *) NULL); + goto error; + } + if (GetEntryIndex(interp, entryPtr, argv[2], &index) != TCL_OK) { + goto error; + } + 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); + } 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; + } + result = Tk_ConfigureValue(interp, entryPtr->tkwin, configSpecs, + (char *) entryPtr, argv[2], 0); + } else if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0) + && (length >= 2)) { + if (argc == 2) { + result = Tk_ConfigureInfo(interp, entryPtr->tkwin, configSpecs, + (char *) entryPtr, (char *) NULL, 0); + } else if (argc == 3) { + result = Tk_ConfigureInfo(interp, entryPtr->tkwin, configSpecs, + (char *) entryPtr, argv[2], 0); + } else { + result = ConfigureEntry(interp, entryPtr, argc-2, argv+2, + TK_CONFIG_ARGV_ONLY); + } + } else if ((c == 'd') && (strncmp(argv[1], "delete", length) == 0)) { + int first, last; + + if ((argc < 3) || (argc > 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " delete firstIndex ?lastIndex?\"", + (char *) NULL); + goto error; + } + if (GetEntryIndex(interp, entryPtr, argv[2], &first) != TCL_OK) { + goto error; + } + if (argc == 3) { + 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); + } + } else if ((c == 'g') && (strncmp(argv[1], "get", length) == 0)) { + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " get\"", (char *) NULL); + goto error; + } + interp->result = entryPtr->string; + } else if ((c == 'i') && (strncmp(argv[1], "icursor", length) == 0) + && (length >= 2)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " icursor pos\"", + (char *) NULL); + goto error; + } + if (GetEntryIndex(interp, entryPtr, argv[2], &entryPtr->insertPos) + != TCL_OK) { + goto error; + } + EventuallyRedraw(entryPtr); + } 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 (GetEntryIndex(interp, entryPtr, argv[2], &index) != TCL_OK) { + goto error; + } + sprintf(interp->result, "%d", index); + } else if ((c == 'i') && (strncmp(argv[1], "insert", length) == 0) + && (length >= 3)) { + int index; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " insert index text\"", + (char *) NULL); + goto error; + } + if (GetEntryIndex(interp, entryPtr, argv[2], &index) != TCL_OK) { + goto error; + } + if (entryPtr->state == tkNormalUid) { + InsertChars(entryPtr, index, argv[3]); + } + } else if ((c == 's') && (length >= 2) + && (strncmp(argv[1], "scan", length) == 0)) { + int x; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " scan mark|dragto x\"", (char *) NULL); + goto error; + } + if (Tcl_GetInt(interp, argv[3], &x) != TCL_OK) { + goto error; + } + if ((argv[2][0] == 'm') + && (strncmp(argv[2], "mark", strlen(argv[2])) == 0)) { + entryPtr->scanMarkX = x; + entryPtr->scanMarkIndex = entryPtr->leftIndex; + } else if ((argv[2][0] == 'd') + && (strncmp(argv[2], "dragto", strlen(argv[2])) == 0)) { + EntryScanTo(entryPtr, x); + } else { + Tcl_AppendResult(interp, "bad scan option \"", argv[2], + "\": must be mark or dragto", (char *) NULL); + goto error; + } + } else if ((c == 's') && (length >= 2) + && (strncmp(argv[1], "selection", length) == 0)) { + int index, index2; + + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " select option ?index?\"", (char *) NULL); + goto error; + } + length = strlen(argv[2]); + c = argv[2][0]; + if ((c == 'c') && (strncmp(argv[2], "clear", length) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " selection clear\"", (char *) NULL); + goto error; + } + if (entryPtr->selectFirst != -1) { + entryPtr->selectFirst = entryPtr->selectLast = -1; + EventuallyRedraw(entryPtr); + } + goto done; + } else if ((c == 'p') && (strncmp(argv[2], "present", length) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " selection present\"", (char *) NULL); + goto error; + } + if (entryPtr->selectFirst == -1) { + interp->result = "0"; + } else { + interp->result = "1"; + } + goto done; + } + if (argc >= 4) { + if (GetEntryIndex(interp, entryPtr, argv[3], &index) != TCL_OK) { + goto error; + } + } + if ((c == 'a') && (strncmp(argv[2], "adjust", length) == 0)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " selection adjust index\"", + (char *) NULL); + goto error; + } + if (entryPtr->selectFirst >= 0) { + int half1, half2; + + half1 = (entryPtr->selectFirst + entryPtr->selectLast)/2; + half2 = (entryPtr->selectFirst + entryPtr->selectLast + 1)/2; + if (index < half1) { + entryPtr->selectAnchor = entryPtr->selectLast; + } else if (index > half2) { + entryPtr->selectAnchor = entryPtr->selectFirst; + } else { + /* + * We're at about the halfway point in the selection; + * just keep the existing anchor. + */ + } + } + EntrySelectTo(entryPtr, index); + } else if ((c == 'f') && (strncmp(argv[2], "from", length) == 0)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " selection from index\"", + (char *) NULL); + goto error; + } + entryPtr->selectAnchor = index; + } else if ((c == 'r') && (strncmp(argv[2], "range", length) == 0)) { + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " selection range start end\"", + (char *) NULL); + goto error; + } + if (GetEntryIndex(interp, entryPtr, argv[4], &index2) != TCL_OK) { + goto error; + } + if (index >= index2) { + entryPtr->selectFirst = entryPtr->selectLast = -1; + } else { + entryPtr->selectFirst = index; + entryPtr->selectLast = index2; + } + if (!(entryPtr->flags & GOT_SELECTION) + && (entryPtr->exportSelection)) { + Tk_OwnSelection(entryPtr->tkwin, XA_PRIMARY, + EntryLostSelection, (ClientData) entryPtr); + entryPtr->flags |= GOT_SELECTION; + } + EventuallyRedraw(entryPtr); + } else if ((c == 't') && (strncmp(argv[2], "to", length) == 0)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " selection to index\"", + (char *) NULL); + goto error; + } + EntrySelectTo(entryPtr, index); + } else { + Tcl_AppendResult(interp, "bad selection option \"", argv[2], + "\": must be adjust, clear, from, present, range, or to", + (char *) NULL); + goto error; + } + } else if ((c == 'x') && (strncmp(argv[1], "xview", length) == 0)) { + int index, type, count, charsPerPage; + double fraction, first, last; + + if (argc == 2) { + EntryVisibleRange(entryPtr, &first, &last); + sprintf(interp->result, "%g %g", first, last); + 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); + index = entryPtr->leftIndex; + switch (type) { + case TK_SCROLL_ERROR: + goto error; + case TK_SCROLL_MOVETO: + index = (int) ((fraction * entryPtr->numChars) + 0.5); + break; + case TK_SCROLL_PAGES: + charsPerPage = ((Tk_Width(entryPtr->tkwin) + - 2*entryPtr->inset) / entryPtr->avgWidth) - 2; + if (charsPerPage < 1) { + charsPerPage = 1; + } + index += charsPerPage*count; + break; + case TK_SCROLL_UNITS: + index += count; + break; + } + } + if (index >= entryPtr->numChars) { + index = entryPtr->numChars-1; + } + if (index < 0) { + index = 0; + } + entryPtr->leftIndex = index; + entryPtr->flags |= UPDATE_SCROLLBAR; + EntryComputeGeometry(entryPtr); + EventuallyRedraw(entryPtr); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be bbox, cget, configure, delete, get, ", + "icursor, index, insert, scan, selection, or xview", + (char *) NULL); + goto error; + } + done: + Tcl_Release((ClientData) entryPtr); + return result; + + error: + Tcl_Release((ClientData) entryPtr); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * DestroyEntry -- + * + * This procedure is invoked by Tcl_EventuallyFree or Tcl_Release + * to clean up the internal structure of an entry at a safe time + * (when no-one is using it anymore). + * + * Results: + * None. + * + * Side effects: + * Everything associated with the entry is freed up. + * + *---------------------------------------------------------------------- + */ + +static void +DestroyEntry(memPtr) + char *memPtr; /* Info about entry widget. */ +{ + register Entry *entryPtr = (Entry *) memPtr; + + /* + * Free up all the stuff that requires special handling, then + * let Tk_FreeOptions handle all the standard option-related + * stuff. + */ + + ckfree(entryPtr->string); + if (entryPtr->textVarName != NULL) { + Tcl_UntraceVar(entryPtr->interp, entryPtr->textVarName, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + EntryTextVarProc, (ClientData) entryPtr); + } + if (entryPtr->textGC != None) { + Tk_FreeGC(entryPtr->display, entryPtr->textGC); + } + if (entryPtr->selTextGC != None) { + Tk_FreeGC(entryPtr->display, entryPtr->selTextGC); + } + Tcl_DeleteTimerHandler(entryPtr->insertBlinkHandler); + if (entryPtr->displayString != NULL) { + ckfree(entryPtr->displayString); + } + Tk_FreeTextLayout(entryPtr->textLayout); + Tk_FreeOptions(configSpecs, (char *) entryPtr, entryPtr->display, 0); + ckfree((char *) entryPtr); +} + +/* + *---------------------------------------------------------------------- + * + * ConfigureEntry -- + * + * This procedure is called to process an argv/argc list, plus + * the Tk option database, in order to configure (or reconfigure) + * an entry widget. + * + * Results: + * The return value is a standard Tcl result. If TCL_ERROR is + * returned, then interp->result contains an error message. + * + * Side effects: + * Configuration information, such as colors, border width, + * etc. get set for entryPtr; old resources get freed, + * if there were any. + * + *---------------------------------------------------------------------- + */ + +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. */ + int argc; /* Number of valid entries in argv. */ + char **argv; /* Arguments. */ + int flags; /* Flags to pass to Tk_ConfigureWidget. */ +{ + int oldExport; + + /* + * Eliminate any existing trace on a variable monitored by the entry. + */ + + if (entryPtr->textVarName != NULL) { + Tcl_UntraceVar(interp, entryPtr->textVarName, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + EntryTextVarProc, (ClientData) entryPtr); + } + + oldExport = entryPtr->exportSelection; + if (Tk_ConfigureWidget(interp, entryPtr->tkwin, configSpecs, + argc, argv, (char *) entryPtr, flags) != TCL_OK) { + return TCL_ERROR; + } + + /* + * If the entry is tied to the value of a variable, then set up + * a trace on the variable's value, create the variable if it doesn't + * exist, and set the entry's value from the variable's value. + */ + + if (entryPtr->textVarName != NULL) { + char *value; + + value = Tcl_GetVar(interp, entryPtr->textVarName, TCL_GLOBAL_ONLY); + if (value == NULL) { + EntryValueChanged(entryPtr); + } else { + EntrySetValue(entryPtr, value); + } + Tcl_TraceVar(interp, entryPtr->textVarName, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + EntryTextVarProc, (ClientData) entryPtr); + } + + /* + * A few other options also need special processing, such as parsing + * the geometry and setting the background from a 3-D border. + */ + + if ((entryPtr->state != tkNormalUid) + && (entryPtr->state != tkDisabledUid)) { + Tcl_AppendResult(interp, "bad state value \"", entryPtr->state, + "\": must be normal or disabled", (char *) NULL); + entryPtr->state = tkNormalUid; + return TCL_ERROR; + } + + Tk_SetBackgroundFromBorder(entryPtr->tkwin, entryPtr->normalBorder); + + if (entryPtr->insertWidth <= 0) { + entryPtr->insertWidth = 2; + } + if (entryPtr->insertBorderWidth > entryPtr->insertWidth/2) { + entryPtr->insertBorderWidth = entryPtr->insertWidth/2; + } + + /* + * Restart the cursor timing sequence in case the on-time or off-time + * just changed. + */ + + if (entryPtr->flags & GOT_FOCUS) { + EntryFocusProc(entryPtr, 1); + } + + /* + * Claim the selection if we've suddenly started exporting it. + */ + + if (entryPtr->exportSelection && (!oldExport) + && (entryPtr->selectFirst != -1) + && !(entryPtr->flags & GOT_SELECTION)) { + Tk_OwnSelection(entryPtr->tkwin, XA_PRIMARY, EntryLostSelection, + (ClientData) entryPtr); + entryPtr->flags |= GOT_SELECTION; + } + + /* + * Recompute the window's geometry and arrange for it to be + * redisplayed. + */ + + Tk_SetInternalBorder(entryPtr->tkwin, + entryPtr->borderWidth + entryPtr->highlightWidth); + if (entryPtr->highlightWidth <= 0) { + entryPtr->highlightWidth = 0; + } + entryPtr->inset = entryPtr->highlightWidth + entryPtr->borderWidth + XPAD; + + EntryWorldChanged((ClientData) entryPtr); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * EntryWorldChanged -- + * + * This procedure is called when the world has changed in some + * way and the widget needs to recompute all its graphics contexts + * and determine its new geometry. + * + * Results: + * None. + * + * Side effects: + * Entry will be relayed out and redisplayed. + * + *--------------------------------------------------------------------------- + */ + +static void +EntryWorldChanged(instanceData) + ClientData instanceData; /* Information about widget. */ +{ + XGCValues gcValues; + GC gc; + unsigned long mask; + Entry *entryPtr; + + entryPtr = (Entry *) instanceData; + + entryPtr->avgWidth = Tk_TextWidth(entryPtr->tkfont, "0", 1); + if (entryPtr->avgWidth == 0) { + entryPtr->avgWidth = 1; + } + + gcValues.foreground = entryPtr->fgColorPtr->pixel; + gcValues.font = Tk_FontId(entryPtr->tkfont); + gcValues.graphics_exposures = False; + mask = GCForeground | GCFont | GCGraphicsExposures; + gc = Tk_GetGC(entryPtr->tkwin, mask, &gcValues); + if (entryPtr->textGC != None) { + Tk_FreeGC(entryPtr->display, entryPtr->textGC); + } + entryPtr->textGC = gc; + + gcValues.foreground = entryPtr->selFgColorPtr->pixel; + gcValues.font = Tk_FontId(entryPtr->tkfont); + mask = GCForeground | GCFont; + gc = Tk_GetGC(entryPtr->tkwin, mask, &gcValues); + if (entryPtr->selTextGC != None) { + Tk_FreeGC(entryPtr->display, entryPtr->selTextGC); + } + entryPtr->selTextGC = gc; + + /* + * Recompute the window's geometry and arrange for it to be + * redisplayed. + */ + + EntryComputeGeometry(entryPtr); + entryPtr->flags |= UPDATE_SCROLLBAR; + EventuallyRedraw(entryPtr); +} + +/* + *-------------------------------------------------------------- + * + * DisplayEntry -- + * + * This procedure redraws the contents of an entry window. + * + * Results: + * None. + * + * Side effects: + * Information appears on the screen. + * + *-------------------------------------------------------------- + */ + +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; + int xBound; + Tk_FontMetrics fm; + Pixmap pixmap; + int showSelection; + + entryPtr->flags &= ~REDRAW_PENDING; + if ((entryPtr->tkwin == NULL) || !Tk_IsMapped(tkwin)) { + return; + } + + Tk_GetFontMetrics(entryPtr->tkfont, &fm); + + /* + * Update the scrollbar if that's needed. + */ + + if (entryPtr->flags & UPDATE_SCROLLBAR) { + entryPtr->flags &= ~UPDATE_SCROLLBAR; + EntryUpdateScrollbar(entryPtr); + } + + /* + * In order to avoid screen flashes, this procedure redraws the + * textual area of the entry into off-screen memory, then copies + * it back on-screen in a single operation. This means there's + * no point in time where the on-screen image has been cleared. + */ + + pixmap = Tk_GetPixmap(entryPtr->display, Tk_WindowId(tkwin), + Tk_Width(tkwin), Tk_Height(tkwin), Tk_Depth(tkwin)); + + /* + * Compute x-coordinate of the pixel just after last visible + * one, plus vertical position of baseline of text. + */ + + xBound = Tk_Width(tkwin) - entryPtr->inset; + baseY = (Tk_Height(tkwin) + fm.ascent - fm.descent) / 2; + + /* + * On Windows and Mac, we need to hide the selection whenever we + * don't have the focus. + */ + +#ifdef ALWAYS_SHOW_SELECTION + showSelection = 1; +#else + showSelection = (entryPtr->flags & GOT_FOCUS); +#endif + + /* + * Draw the background in three layers. From bottom to top the + * layers are: normal background, selection background, and + * insertion cursor background. + */ + + Tk_Fill3DRectangle(tkwin, pixmap, entryPtr->normalBorder, + 0, 0, Tk_Width(tkwin), Tk_Height(tkwin), 0, TK_RELIEF_FLAT); + 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; + } + if ((selStartX - entryPtr->selBorderWidth) < xBound) { + Tk_CharBbox(entryPtr->textLayout, entryPtr->selectLast - 1, + &x, NULL, &w, NULL); + selEndX = x + w + entryPtr->layoutX; + Tk_Fill3DRectangle(tkwin, pixmap, entryPtr->selBorder, + selStartX - entryPtr->selBorderWidth, + baseY - fm.ascent - entryPtr->selBorderWidth, + (selEndX - selStartX) + 2*entryPtr->selBorderWidth, + (fm.ascent + fm.descent) + 2*entryPtr->selBorderWidth, + entryPtr->selBorderWidth, TK_RELIEF_RAISED); + } + } + + /* + * Draw a special background for the insertion cursor, overriding + * even the selection background. As a special hack to keep the + * cursor visible when the insertion cursor color is the same as + * the color for selected text (e.g., on mono displays), write + * background in the cursor area (instead of nothing) when the + * cursor isn't on. Otherwise the selection would hide the cursor. + */ + + 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; + } + 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); + } 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); + } + } + } + + /* + * Draw the text in two pieces: first the unselected portion, then the + * selected portion on top of it. + */ + + 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; + + if (entryPtr->selectFirst - entryPtr->leftIndex < 0) { + first = entryPtr->leftIndex; + } else { + first = entryPtr->selectFirst; + } + Tk_DrawTextLayout(entryPtr->display, pixmap, entryPtr->selTextGC, + entryPtr->textLayout, entryPtr->layoutX, entryPtr->layoutY, + first, entryPtr->selectLast); + } + + /* + * Draw the border and focus highlight last, so they will overwrite + * any text that extends past the viewable part of the window. + */ + + 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, + entryPtr->borderWidth, entryPtr->relief); + } + if (entryPtr->highlightWidth != 0) { + GC gc; + + if (entryPtr->flags & GOT_FOCUS) { + gc = Tk_GCForColor(entryPtr->highlightColorPtr, pixmap); + } else { + gc = Tk_GCForColor(entryPtr->highlightBgColorPtr, pixmap); + } + Tk_DrawFocusHighlight(tkwin, gc, entryPtr->highlightWidth, pixmap); + } + + /* + * Everything's been redisplayed; now copy the pixmap onto the screen + * and free up the pixmap. + */ + + XCopyArea(entryPtr->display, pixmap, Tk_WindowId(tkwin), entryPtr->textGC, + 0, 0, (unsigned) Tk_Width(tkwin), (unsigned) Tk_Height(tkwin), + 0, 0); + Tk_FreePixmap(entryPtr->display, pixmap); + entryPtr->flags &= ~BORDER_NEEDED; +} + +/* + *---------------------------------------------------------------------- + * + * EntryComputeGeometry -- + * + * This procedure is invoked to recompute information about where + * in its window an entry's string will be displayed. It also + * computes the requested size for the window. + * + * Results: + * None. + * + * Side effects: + * The leftX and tabOrigin fields are recomputed for entryPtr, + * and leftIndex may be adjusted. Tk_GeometryRequest is called + * to register the desired dimensions for the window. + * + *---------------------------------------------------------------------- + */ + +static void +EntryComputeGeometry(entryPtr) + Entry *entryPtr; /* Widget record for entry. */ +{ + int totalLength, overflow, maxOffScreen, rightX; + int height, width, i; + Tk_FontMetrics fm; + char *p, *displayString; + + /* + * 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; + } + Tk_FreeTextLayout(entryPtr->textLayout); + entryPtr->textLayout = Tk_ComputeTextLayout(entryPtr->tkfont, + displayString, entryPtr->numChars, 0, entryPtr->justify, + TK_IGNORE_NEWLINES, &totalLength, &height); + + entryPtr->layoutY = (Tk_Height(entryPtr->tkwin) - height) / 2; + + /* + * Recompute where the leftmost character on the display will + * be drawn (entryPtr->leftX) and adjust leftIndex if necessary + * so that we don't let characters hang off the edge of the + * window unless the entire window is full. + */ + + overflow = totalLength - (Tk_Width(entryPtr->tkwin) - 2*entryPtr->inset); + if (overflow <= 0) { + entryPtr->leftIndex = 0; + if (entryPtr->justify == TK_JUSTIFY_LEFT) { + entryPtr->leftX = entryPtr->inset; + } else if (entryPtr->justify == TK_JUSTIFY_RIGHT) { + entryPtr->leftX = Tk_Width(entryPtr->tkwin) - entryPtr->inset + - totalLength; + } else { + entryPtr->leftX = (Tk_Width(entryPtr->tkwin) - totalLength)/2; + } + entryPtr->layoutX = entryPtr->leftX; + } else { + /* + * The whole string can't fit in the window. Compute the + * maximum number of characters that may be off-screen to + * the left without leaving empty space on the right of the + * window, then don't let leftIndex be any greater than that. + */ + + maxOffScreen = Tk_PointToChar(entryPtr->textLayout, overflow, 0); + Tk_CharBbox(entryPtr->textLayout, maxOffScreen, + &rightX, NULL, NULL, NULL); + if (rightX < overflow) { + maxOffScreen += 1; + } + if (entryPtr->leftIndex > maxOffScreen) { + entryPtr->leftIndex = maxOffScreen; + } + Tk_CharBbox(entryPtr->textLayout, entryPtr->leftIndex, + &rightX, NULL, NULL, NULL); + entryPtr->leftX = entryPtr->inset; + entryPtr->layoutX = entryPtr->leftX - rightX; + } + + Tk_GetFontMetrics(entryPtr->tkfont, &fm); + height = fm.linespace + 2*entryPtr->inset + 2*(YPAD-XPAD); + if (entryPtr->prefWidth > 0) { + width = entryPtr->prefWidth*entryPtr->avgWidth + 2*entryPtr->inset; + } else { + if (totalLength == 0) { + width = entryPtr->avgWidth + 2*entryPtr->inset; + } else { + width = totalLength + 2*entryPtr->inset; + } + } + Tk_GeometryRequest(entryPtr->tkwin, width, height); +} + +/* + *---------------------------------------------------------------------- + * + * InsertChars -- + * + * Add new characters to an entry widget. + * + * Results: + * None. + * + * Side effects: + * New information gets added to entryPtr; it will be redisplayed + * soon, but not necessarily immediately. + * + *---------------------------------------------------------------------- + */ + +static void +InsertChars(entryPtr, index, string) + register 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 + * string). */ +{ + int length; + char *new; + + length = strlen(string); + if (length == 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); + entryPtr->string = new; + entryPtr->numChars += length; + + /* + * Inserting characters invalidates all indexes into the string. + * Touch up the indexes so that they still refer to the same + * characters (at new positions). When updating the selection + * end-points, don't include the new text in the selection unless + * it was completely surrounded by the selection. + */ + + if (entryPtr->selectFirst >= index) { + entryPtr->selectFirst += length; + } + if (entryPtr->selectLast > index) { + entryPtr->selectLast += length; + } + if ((entryPtr->selectAnchor > index) || (entryPtr->selectFirst >= index)) { + entryPtr->selectAnchor += length; + } + if (entryPtr->leftIndex > index) { + entryPtr->leftIndex += length; + } + if (entryPtr->insertPos >= index) { + entryPtr->insertPos += length; + } + EntryValueChanged(entryPtr); +} + +/* + *---------------------------------------------------------------------- + * + * DeleteChars -- + * + * Remove one or more characters from an entry widget. + * + * Results: + * None. + * + * Side effects: + * Memory gets freed, the entry gets modified and (eventually) + * redisplayed. + * + *---------------------------------------------------------------------- + */ + +static void +DeleteChars(entryPtr, index, count) + register Entry *entryPtr; /* Entry widget to modify. */ + int index; /* Index of first character to delete. */ + int count; /* How many characters to delete. */ +{ + char *new; + + if ((index + count) > entryPtr->numChars) { + count = entryPtr->numChars - index; + } + if (count <= 0) { + return; + } + + new = (char *) ckalloc((unsigned) (entryPtr->numChars + 1 - count)); + strncpy(new, entryPtr->string, (size_t) index); + strcpy(new+index, entryPtr->string+index+count); + ckfree(entryPtr->string); + entryPtr->string = new; + entryPtr->numChars -= count; + + /* + * Deleting characters results in the remaining characters being + * renumbered. Update the various indexes into the string to reflect + * this change. + */ + + if (entryPtr->selectFirst >= index) { + if (entryPtr->selectFirst >= (index+count)) { + entryPtr->selectFirst -= count; + } else { + entryPtr->selectFirst = index; + } + } + if (entryPtr->selectLast >= index) { + if (entryPtr->selectLast >= (index+count)) { + entryPtr->selectLast -= count; + } else { + entryPtr->selectLast = index; + } + } + if (entryPtr->selectLast <= entryPtr->selectFirst) { + entryPtr->selectFirst = entryPtr->selectLast = -1; + } + if (entryPtr->selectAnchor >= index) { + if (entryPtr->selectAnchor >= (index+count)) { + entryPtr->selectAnchor -= count; + } else { + entryPtr->selectAnchor = index; + } + } + if (entryPtr->leftIndex > index) { + if (entryPtr->leftIndex >= (index+count)) { + entryPtr->leftIndex -= count; + } else { + entryPtr->leftIndex = index; + } + } + if (entryPtr->insertPos >= index) { + if (entryPtr->insertPos >= (index+count)) { + entryPtr->insertPos -= count; + } else { + entryPtr->insertPos = index; + } + } + EntryValueChanged(entryPtr); +} + +/* + *---------------------------------------------------------------------- + * + * EntryValueChanged -- + * + * This procedure is invoked when characters are inserted into + * an entry or deleted from it. It updates the entry's associated + * variable, if there is one, and does other bookkeeping such + * as arranging for redisplay. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +EntryValueChanged(entryPtr) + Entry *entryPtr; /* Entry whose value just changed. */ +{ + char *newValue; + + if (entryPtr->textVarName == NULL) { + newValue = NULL; + } else { + newValue = Tcl_SetVar(entryPtr->interp, entryPtr->textVarName, + entryPtr->string, TCL_GLOBAL_ONLY); + } + + if ((newValue != NULL) && (strcmp(newValue, entryPtr->string) != 0)) { + /* + * The value of the variable is different than what we asked for. + * This means that a trace on the variable modified it. In this + * case our trace procedure wasn't invoked since the modification + * came while a trace was already active on the variable. So, + * update our value to reflect the variable's latest value. + */ + + EntrySetValue(entryPtr, newValue); + } else { + /* + * Arrange for redisplay. + */ + + entryPtr->flags |= UPDATE_SCROLLBAR; + EntryComputeGeometry(entryPtr); + EventuallyRedraw(entryPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * EntrySetValue -- + * + * Replace the contents of a text entry with a given value. This + * procedure is invoked when updating the entry from the entry's + * associated variable. + * + * Results: + * None. + * + * Side effects: + * The string displayed in the entry will change. The selection, + * insertion point, and view may have to be adjusted to keep them + * within the bounds of the new string. Note: this procedure does + * *not* update the entry's associated variable, since that could + * result in an infinite loop. + * + *---------------------------------------------------------------------- + */ + +static void +EntrySetValue(entryPtr, value) + register Entry *entryPtr; /* Entry whose value is to be + * changed. */ + char *value; /* New text to display in entry. */ +{ + ckfree(entryPtr->string); + entryPtr->numChars = strlen(value); + entryPtr->string = (char *) ckalloc((unsigned) (entryPtr->numChars + 1)); + strcpy(entryPtr->string, value); + if (entryPtr->selectFirst != -1) { + if (entryPtr->selectFirst >= entryPtr->numChars) { + entryPtr->selectFirst = 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) { + entryPtr->leftIndex = 0; + } + } + if (entryPtr->insertPos > entryPtr->numChars) { + entryPtr->insertPos = entryPtr->numChars; + } + + entryPtr->flags |= UPDATE_SCROLLBAR; + EntryComputeGeometry(entryPtr); + EventuallyRedraw(entryPtr); +} + +/* + *-------------------------------------------------------------- + * + * EntryEventProc -- + * + * This procedure is invoked by the Tk dispatcher for various + * events on entryes. + * + * Results: + * None. + * + * Side effects: + * When the window gets deleted, internal structures get + * cleaned up. When it gets exposed, it is redisplayed. + * + *-------------------------------------------------------------- + */ + +static void +EntryEventProc(clientData, eventPtr) + ClientData clientData; /* Information about window. */ + XEvent *eventPtr; /* Information about event. */ +{ + Entry *entryPtr = (Entry *) clientData; + if (eventPtr->type == Expose) { + EventuallyRedraw(entryPtr); + entryPtr->flags |= BORDER_NEEDED; + } else if (eventPtr->type == DestroyNotify) { + if (entryPtr->tkwin != NULL) { + entryPtr->tkwin = NULL; + Tcl_DeleteCommandFromToken(entryPtr->interp, entryPtr->widgetCmd); + } + if (entryPtr->flags & REDRAW_PENDING) { + Tcl_CancelIdleCall(DisplayEntry, (ClientData) entryPtr); + } + Tcl_EventuallyFree((ClientData) entryPtr, DestroyEntry); + } else if (eventPtr->type == ConfigureNotify) { + Tcl_Preserve((ClientData) entryPtr); + entryPtr->flags |= UPDATE_SCROLLBAR; + EntryComputeGeometry(entryPtr); + EventuallyRedraw(entryPtr); + Tcl_Release((ClientData) entryPtr); + } else if (eventPtr->type == FocusIn) { + if (eventPtr->xfocus.detail != NotifyInferior) { + EntryFocusProc(entryPtr, 1); + } + } else if (eventPtr->type == FocusOut) { + if (eventPtr->xfocus.detail != NotifyInferior) { + EntryFocusProc(entryPtr, 0); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * EntryCmdDeletedProc -- + * + * 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 +EntryCmdDeletedProc(clientData) + ClientData clientData; /* Pointer to widget record for widget. */ +{ + Entry *entryPtr = (Entry *) clientData; + Tk_Window tkwin = entryPtr->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. + */ + + if (tkwin != NULL) { + entryPtr->tkwin = NULL; + Tk_DestroyWindow(tkwin); + } +} + +/* + *-------------------------------------------------------------- + * + * GetEntryIndex -- + * + * Parse an index into an entry and return either its value + * or an error. + * + * Results: + * A standard Tcl result. If all went well, then *indexPtr 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. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static int +GetEntryIndex(interp, entryPtr, string, indexPtr) + Tcl_Interp *interp; /* For error messages. */ + Entry *entryPtr; /* Entry for which the index is being + * specified. */ + char *string; /* Specifies character in entryPtr. */ + int *indexPtr; /* Where to store converted index. */ +{ + size_t length; + + length = strlen(string); + + if (string[0] == 'a') { + if (strncmp(string, "anchor", length) == 0) { + *indexPtr = entryPtr->selectAnchor; + } else { + badIndex: + + /* + * Some of the paths here leave messages in interp->result, + * so we have to clear it out before storing our own message. + */ + + Tcl_SetResult(interp, (char *) NULL, TCL_STATIC); + Tcl_AppendResult(interp, "bad entry index \"", string, + "\"", (char *) NULL); + return TCL_ERROR; + } + } else if (string[0] == 'e') { + if (strncmp(string, "end", length) == 0) { + *indexPtr = entryPtr->numChars; + } else { + goto badIndex; + } + } else if (string[0] == 'i') { + if (strncmp(string, "insert", length) == 0) { + *indexPtr = entryPtr->insertPos; + } else { + goto badIndex; + } + } else if (string[0] == 's') { + if (entryPtr->selectFirst == -1) { + interp->result = "selection isn't in entry"; + return TCL_ERROR; + } + if (length < 5) { + goto badIndex; + } + if (strncmp(string, "sel.first", length) == 0) { + *indexPtr = entryPtr->selectFirst; + } else if (strncmp(string, "sel.last", length) == 0) { + *indexPtr = entryPtr->selectLast; + } else { + goto badIndex; + } + } else if (string[0] == '@') { + int x, roundUp; + + if (Tcl_GetInt(interp, string+1, &x) != TCL_OK) { + goto badIndex; + } + if (x < entryPtr->inset) { + x = entryPtr->inset; + } + roundUp = 0; + if (x >= (Tk_Width(entryPtr->tkwin) - entryPtr->inset)) { + x = Tk_Width(entryPtr->tkwin) - entryPtr->inset - 1; + roundUp = 1; + } + *indexPtr = Tk_PointToChar(entryPtr->textLayout, + x - entryPtr->layoutX, 0); + + /* + * Special trick: if the x-position was off-screen to the right, + * round the index up to refer to the character just after the + * last visible one on the screen. This is needed to enable the + * last character to be selected, for example. + */ + + if (roundUp && (*indexPtr < entryPtr->numChars)) { + *indexPtr += 1; + } + } else { + if (Tcl_GetInt(interp, string, indexPtr) != TCL_OK) { + goto badIndex; + } + if (*indexPtr < 0){ + *indexPtr = 0; + } else if (*indexPtr > entryPtr->numChars) { + *indexPtr = entryPtr->numChars; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * EntryScanTo -- + * + * Given a y-coordinate (presumably of the curent mouse location) + * drag the view in the window to implement the scan operation. + * + * Results: + * None. + * + * Side effects: + * The view in the window may change. + * + *---------------------------------------------------------------------- + */ + +static void +EntryScanTo(entryPtr, x) + register Entry *entryPtr; /* Information about widget. */ + int x; /* X-coordinate to use for scan + * operation. */ +{ + int newLeftIndex; + + /* + * Compute new leftIndex for entry by amplifying the difference + * between the current position and the place where the scan + * started (the "mark" position). If we run off the left or right + * side of the entry, then reset the mark point so that the current + * position continues to correspond to the edge of the window. + * This means that the picture will start dragging as soon as the + * mouse reverses direction (without this reset, might have to slide + * mouse a long ways back before the picture starts moving again). + */ + + newLeftIndex = entryPtr->scanMarkIndex + - (10*(x - entryPtr->scanMarkX))/entryPtr->avgWidth; + if (newLeftIndex >= entryPtr->numChars) { + 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); + EventuallyRedraw(entryPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * EntrySelectTo -- + * + * Modify the selection by moving its un-anchored end. This could + * make the selection either larger or smaller. + * + * Results: + * None. + * + * Side effects: + * The selection changes. + * + *---------------------------------------------------------------------- + */ + +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. */ +{ + int newFirst, newLast; + + /* + * Grab the selection if we don't own it already. + */ + + if (!(entryPtr->flags & GOT_SELECTION) && (entryPtr->exportSelection)) { + Tk_OwnSelection(entryPtr->tkwin, XA_PRIMARY, EntryLostSelection, + (ClientData) entryPtr); + entryPtr->flags |= GOT_SELECTION; + } + + /* + * Pick new starting and ending points for the selection. + */ + + if (entryPtr->selectAnchor > entryPtr->numChars) { + entryPtr->selectAnchor = entryPtr->numChars; + } + if (entryPtr->selectAnchor <= index) { + newFirst = entryPtr->selectAnchor; + newLast = index; + } else { + newFirst = index; + newLast = entryPtr->selectAnchor; + if (newLast < 0) { + newFirst = newLast = -1; + } + } + if ((entryPtr->selectFirst == newFirst) + && (entryPtr->selectLast == newLast)) { + return; + } + entryPtr->selectFirst = newFirst; + entryPtr->selectLast = newLast; + EventuallyRedraw(entryPtr); +} + +/* + *---------------------------------------------------------------------- + * + * EntryFetchSelection -- + * + * This procedure is called back by Tk when the selection is + * requested by someone. It returns part or all of the selection + * in a buffer provided by the caller. + * + * Results: + * The return value is the number of non-NULL bytes stored + * at buffer. Buffer is filled (or partially filled) with a + * NULL-terminated string containing part or all of the selection, + * as given by offset and maxBytes. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +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. */ +{ + Entry *entryPtr = (Entry *) clientData; + int count; + char *displayString; + + if ((entryPtr->selectFirst < 0) || !(entryPtr->exportSelection)) { + return -1; + } + count = entryPtr->selectLast - entryPtr->selectFirst - offset; + if (count > maxBytes) { + count = maxBytes; + } + if (count <= 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; +} + +/* + *---------------------------------------------------------------------- + * + * EntryLostSelection -- + * + * This procedure is called back by Tk when the selection is + * grabbed away from an entry widget. + * + * Results: + * None. + * + * Side effects: + * The existing selection is unhighlighted, and the window is + * marked as not containing a selection. + * + *---------------------------------------------------------------------- + */ + +static void +EntryLostSelection(clientData) + ClientData clientData; /* Information about entry widget. */ +{ + Entry *entryPtr = (Entry *) clientData; + + entryPtr->flags &= ~GOT_SELECTION; + + /* + * On Windows and Mac systems, we want to remember the selection + * for the next time the focus enters the window. On Unix, we need + * to clear the selection since it is always visible. + */ + +#ifdef ALWAYS_SHOW_SELECTION + if ((entryPtr->selectFirst != -1) && entryPtr->exportSelection) { + entryPtr->selectFirst = -1; + entryPtr->selectLast = -1; + EventuallyRedraw(entryPtr); + } +#endif +} + +/* + *---------------------------------------------------------------------- + * + * EventuallyRedraw -- + * + * Ensure that an entry is eventually redrawn on the display. + * + * Results: + * None. + * + * Side effects: + * Information gets redisplayed. Right now we don't do selective + * redisplays: the whole window will be redrawn. This doesn't + * seem to hurt performance noticeably, but if it does then this + * could be changed. + * + *---------------------------------------------------------------------- + */ + +static void +EventuallyRedraw(entryPtr) + register Entry *entryPtr; /* Information about widget. */ +{ + if ((entryPtr->tkwin == NULL) || !Tk_IsMapped(entryPtr->tkwin)) { + return; + } + + /* + * Right now we don't do selective redisplays: the whole window + * will be redrawn. This doesn't seem to hurt performance noticeably, + * but if it does then this could be changed. + */ + + if (!(entryPtr->flags & REDRAW_PENDING)) { + entryPtr->flags |= REDRAW_PENDING; + Tcl_DoWhenIdle(DisplayEntry, (ClientData) entryPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * EntryVisibleRange -- + * + * Return information about the range of the entry that is + * currently visible. + * + * Results: + * *firstPtr and *lastPtr are modified to hold fractions between + * 0 and 1 identifying the range of characters visible in the + * entry. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +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. */ +{ + int charsInWindow; + + if (entryPtr->numChars == 0) { + *firstPtr = 0.0; + *lastPtr = 1.0; + } else { + charsInWindow = 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; + } + charsInWindow -= entryPtr->leftIndex; + if (charsInWindow == 0) { + charsInWindow = 1; + } + *firstPtr = ((double) entryPtr->leftIndex)/entryPtr->numChars; + *lastPtr = ((double) (entryPtr->leftIndex + charsInWindow)) + /entryPtr->numChars; + } +} + +/* + *---------------------------------------------------------------------- + * + * EntryUpdateScrollbar -- + * + * This procedure is invoked whenever information has changed in + * an entry in a way that would invalidate a scrollbar display. + * If there is an associated scrollbar, then this procedure updates + * it by invoking a Tcl command. + * + * Results: + * None. + * + * Side effects: + * A Tcl command is invoked, and an additional command may be + * invoked to process errors in the command. + * + *---------------------------------------------------------------------- + */ + +static void +EntryUpdateScrollbar(entryPtr) + Entry *entryPtr; /* Information about widget. */ +{ + char args[100]; + int code; + double first, last; + Tcl_Interp *interp; + + if (entryPtr->scrollCmd == NULL) { + return; + } + + interp = entryPtr->interp; + Tcl_Preserve((ClientData) interp); + EntryVisibleRange(entryPtr, &first, &last); + sprintf(args, " %g %g", first, last); + code = Tcl_VarEval(interp, entryPtr->scrollCmd, args, (char *) NULL); + if (code != TCL_OK) { + Tcl_AddErrorInfo(interp, + "\n (horizontal scrolling command executed by entry)"); + Tcl_BackgroundError(interp); + } + Tcl_SetResult(interp, (char *) NULL, TCL_STATIC); + Tcl_Release((ClientData) interp); +} + +/* + *---------------------------------------------------------------------- + * + * EntryBlinkProc -- + * + * This procedure is called as a timer handler to blink the + * insertion cursor off and on. + * + * Results: + * None. + * + * Side effects: + * The cursor gets turned on or off, redisplay gets invoked, + * and this procedure reschedules itself. + * + *---------------------------------------------------------------------- + */ + +static void +EntryBlinkProc(clientData) + ClientData clientData; /* Pointer to record describing entry. */ +{ + register Entry *entryPtr = (Entry *) clientData; + + if (!(entryPtr->flags & GOT_FOCUS) || (entryPtr->insertOffTime == 0)) { + return; + } + if (entryPtr->flags & CURSOR_ON) { + entryPtr->flags &= ~CURSOR_ON; + entryPtr->insertBlinkHandler = Tcl_CreateTimerHandler( + entryPtr->insertOffTime, EntryBlinkProc, (ClientData) entryPtr); + } else { + entryPtr->flags |= CURSOR_ON; + entryPtr->insertBlinkHandler = Tcl_CreateTimerHandler( + entryPtr->insertOnTime, EntryBlinkProc, (ClientData) entryPtr); + } + EventuallyRedraw(entryPtr); +} + +/* + *---------------------------------------------------------------------- + * + * EntryFocusProc -- + * + * This procedure is called whenever the entry gets or loses the + * input focus. It's also called whenever the window is reconfigured + * while it has the focus. + * + * Results: + * None. + * + * Side effects: + * The cursor gets turned on or off. + * + *---------------------------------------------------------------------- + */ + +static void +EntryFocusProc(entryPtr, gotFocus) + register Entry *entryPtr; /* Entry that got or lost focus. */ + int gotFocus; /* 1 means window is getting focus, 0 means + * it's losing it. */ +{ + Tcl_DeleteTimerHandler(entryPtr->insertBlinkHandler); + if (gotFocus) { + entryPtr->flags |= GOT_FOCUS | CURSOR_ON; + if (entryPtr->insertOffTime != 0) { + entryPtr->insertBlinkHandler = Tcl_CreateTimerHandler( + entryPtr->insertOnTime, EntryBlinkProc, + (ClientData) entryPtr); + } + } else { + entryPtr->flags &= ~(GOT_FOCUS | CURSOR_ON); + entryPtr->insertBlinkHandler = (Tcl_TimerToken) NULL; + } + EventuallyRedraw(entryPtr); +} + +/* + *-------------------------------------------------------------- + * + * EntryTextVarProc -- + * + * This procedure is invoked when someone changes the variable + * whose contents are to be displayed in an entry. + * + * Results: + * NULL is always returned. + * + * Side effects: + * The text displayed in the entry will change to match the + * variable. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static char * +EntryTextVarProc(clientData, interp, name1, name2, flags) + ClientData clientData; /* Information about button. */ + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *name1; /* Not used. */ + char *name2; /* Not used. */ + int flags; /* Information about what happened. */ +{ + register Entry *entryPtr = (Entry *) clientData; + char *value; + + /* + * If the variable is unset, then immediately recreate it unless + * the whole interpreter is going away. + */ + + if (flags & TCL_TRACE_UNSETS) { + if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) { + Tcl_SetVar(interp, entryPtr->textVarName, entryPtr->string, + TCL_GLOBAL_ONLY); + Tcl_TraceVar(interp, entryPtr->textVarName, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + EntryTextVarProc, clientData); + } + return (char *) NULL; + } + + /* + * Update the entry's text with the value of the variable, unless + * the entry already has that value (this happens when the variable + * changes value because we changed it because someone typed in + * the entry). + */ + + value = Tcl_GetVar(interp, entryPtr->textVarName, TCL_GLOBAL_ONLY); + if (value == NULL) { + value = ""; + } + if (strcmp(value, entryPtr->string) != 0) { + EntrySetValue(entryPtr, value); + } + return (char *) NULL; +} diff --git a/generic/tkError.c b/generic/tkError.c new file mode 100644 index 0000000..3d52793 --- /dev/null +++ b/generic/tkError.c @@ -0,0 +1,307 @@ +/* + * tkError.c -- + * + * This file provides a high-performance mechanism for + * selectively dealing with errors that occur in talking + * to the X server. This is useful, for example, when + * communicating with a window that may not exist. + * + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkError.c 1.23 97/04/25 16:51:27 + */ + +#include "tkPort.h" +#include "tkInt.h" + +/* + * The default X error handler gets saved here, so that it can + * be invoked if an error occurs that we can't handle. + */ + +static int (*defaultHandler) _ANSI_ARGS_((Display *display, + XErrorEvent *eventPtr)) = NULL; + + +/* + * Forward references to procedures declared later in this file: + */ + +static int ErrorProc _ANSI_ARGS_((Display *display, + XErrorEvent *errEventPtr)); + +/* + *-------------------------------------------------------------- + * + * Tk_CreateErrorHandler -- + * + * Arrange for all a given procedure to be invoked whenever + * certain errors occur. + * + * Results: + * The return value is a token identifying the handler; + * it must be passed to Tk_DeleteErrorHandler to delete the + * handler. + * + * Side effects: + * If an X error occurs that matches the error, request, + * and minor arguments, then errorProc will be invoked. + * ErrorProc should have the following structure: + * + * int + * errorProc(clientData, errorEventPtr) + * caddr_t clientData; + * XErrorEvent *errorEventPtr; + * { + * } + * + * The clientData argument will be the same as the clientData + * argument to this procedure, and errorEvent will describe + * the error. If errorProc returns 0, it means that it + * completely "handled" the error: no further processing + * should be done. If errorProc returns 1, it means that it + * didn't know how to deal with the error, so we should look + * for other error handlers, or invoke the default error + * handler if no other handler returns zero. Handlers are + * invoked in order of age: youngest handler first. + * + * Note: errorProc will only be called for errors associated + * with X requests made AFTER this call, but BEFORE the handler + * is deleted by calling Tk_DeleteErrorHandler. + * + *-------------------------------------------------------------- + */ + +Tk_ErrorHandler +Tk_CreateErrorHandler(display, error, request, minorCode, errorProc, clientData) + Display *display; /* Display for which to handle + * errors. */ + int error; /* Consider only errors with this + * error_code (-1 means consider + * all errors). */ + int request; /* Consider only errors with this + * major request code (-1 means + * consider all major codes). */ + int minorCode; /* Consider only errors with this + * minor request code (-1 means + * consider all minor codes). */ + Tk_ErrorProc *errorProc; /* Procedure to invoke when a + * matching error occurs. NULL means + * just ignore matching errors. */ + ClientData clientData; /* Arbitrary value to pass to + * errorProc. */ +{ + register TkErrorHandler *errorPtr; + register TkDisplay *dispPtr; + + /* + * Find the display. If Tk doesn't know about this display then + * it's an error: panic. + */ + + dispPtr = TkGetDisplay(display); + if (dispPtr == NULL) { + panic("Unknown display passed to Tk_CreateErrorHandler"); + } + + /* + * Make sure that X calls us whenever errors occur. + */ + + if (defaultHandler == NULL) { + defaultHandler = XSetErrorHandler(ErrorProc); + } + + /* + * Create the handler record. + */ + + errorPtr = (TkErrorHandler *) ckalloc(sizeof(TkErrorHandler)); + errorPtr->dispPtr = dispPtr; + errorPtr->firstRequest = NextRequest(display); + errorPtr->lastRequest = (unsigned) -1; + errorPtr->error = error; + errorPtr->request = request; + errorPtr->minorCode = minorCode; + errorPtr->errorProc = errorProc; + errorPtr->clientData = clientData; + errorPtr->nextPtr = dispPtr->errorPtr; + dispPtr->errorPtr = errorPtr; + + return (Tk_ErrorHandler) errorPtr; +} + +/* + *-------------------------------------------------------------- + * + * Tk_DeleteErrorHandler -- + * + * Do not use an error handler anymore. + * + * Results: + * None. + * + * Side effects: + * The handler denoted by the "handler" argument will not + * be invoked for any X errors associated with requests + * made after this call. However, if errors arrive later + * for requests made BEFORE this call, then the handler + * will still be invoked. Call XSync if you want to be + * sure that all outstanding errors have been received + * and processed. + * + *-------------------------------------------------------------- + */ + +void +Tk_DeleteErrorHandler(handler) + Tk_ErrorHandler handler; /* Token for handler to delete; + * was previous return value from + * Tk_CreateErrorHandler. */ +{ + register TkErrorHandler *errorPtr = (TkErrorHandler *) handler; + register TkDisplay *dispPtr = errorPtr->dispPtr; + + errorPtr->lastRequest = NextRequest(dispPtr->display) - 1; + + /* + * Every once-in-a-while, cleanup handlers that are no longer + * active. We probably won't be able to free the handler that + * was just deleted (need to wait for any outstanding requests to + * be processed by server), but there may be previously-deleted + * handlers that are now ready for garbage collection. To reduce + * the cost of the cleanup, let a few dead handlers pile up, then + * clean them all at once. This adds a bit of overhead to errors + * that might occur while the dead handlers are hanging around, + * but reduces the overhead of scanning the list to clean up + * (particularly if there are many handlers that stay around + * forever). + */ + + dispPtr->deleteCount += 1; + if (dispPtr->deleteCount >= 10) { + register TkErrorHandler *prevPtr; + TkErrorHandler *nextPtr; + int lastSerial; + + dispPtr->deleteCount = 0; + lastSerial = LastKnownRequestProcessed(dispPtr->display); + errorPtr = dispPtr->errorPtr; + for (prevPtr = NULL; errorPtr != NULL; errorPtr = nextPtr) { + nextPtr = errorPtr->nextPtr; + if ((errorPtr->lastRequest != (unsigned long) -1) + && (errorPtr->lastRequest <= (unsigned long) lastSerial)) { + if (prevPtr == NULL) { + dispPtr->errorPtr = nextPtr; + } else { + prevPtr->nextPtr = nextPtr; + } + ckfree((char *) errorPtr); + continue; + } + prevPtr = errorPtr; + } + } +} + +/* + *-------------------------------------------------------------- + * + * ErrorProc -- + * + * This procedure is invoked by the X system when error + * events arrive. + * + * Results: + * If it returns, the return value is zero. However, + * it is possible that one of the error handlers may + * just exit. + * + * Side effects: + * This procedure does two things. First, it uses the + * serial # in the error event to eliminate handlers whose + * expiration serials are now in the past. Second, it + * invokes any handlers that want to deal with the error. + * + *-------------------------------------------------------------- + */ + +static int +ErrorProc(display, errEventPtr) + Display *display; /* Display for which error + * occurred. */ + register XErrorEvent *errEventPtr; /* Information about error. */ +{ + register TkDisplay *dispPtr; + register TkErrorHandler *errorPtr; + + /* + * See if we know anything about the display. If not, then + * invoke the default error handler. + */ + + dispPtr = TkGetDisplay(display); + if (dispPtr == NULL) { + goto couldntHandle; + } + + /* + * Otherwise invoke any relevant handlers for the error, in order. + */ + + for (errorPtr = dispPtr->errorPtr; errorPtr != NULL; + errorPtr = errorPtr->nextPtr) { + if ((errorPtr->firstRequest > errEventPtr->serial) + || ((errorPtr->error != -1) + && (errorPtr->error != errEventPtr->error_code)) + || ((errorPtr->request != -1) + && (errorPtr->request != errEventPtr->request_code)) + || ((errorPtr->minorCode != -1) + && (errorPtr->minorCode != errEventPtr->minor_code)) + || ((errorPtr->lastRequest != (unsigned long) -1) + && (errorPtr->lastRequest < errEventPtr->serial))) { + continue; + } + if (errorPtr->errorProc == NULL) { + return 0; + } else { + if ((*errorPtr->errorProc)(errorPtr->clientData, + errEventPtr) == 0) { + return 0; + } + } + } + + /* + * See if the error is a BadWindow error. If so, and it refers + * to a window that still exists in our window table, then ignore + * the error. Errors like this can occur if a window owned by us + * is deleted by someone externally, like a window manager. We'll + * ignore the errors at least long enough to clean up internally and + * remove the entry from the window table. + * + * NOTE: For embedding, we must also check whether the window was + * recently deleted. If so, it may be that Tk generated operations on + * windows that were deleted by the container. Now we are getting + * the errors (BadWindow) after Tk already deleted the window itself. + */ + + if ((errEventPtr->error_code == BadWindow) && + ((Tk_IdToWindow(display, (Window) errEventPtr->resourceid) != + NULL) || + (TkpWindowWasRecentlyDeleted((Window) errEventPtr->resourceid, + dispPtr)))) { + return 0; + } + + /* + * We couldn't handle the error. Use the default handler. + */ + + couldntHandle: + return (*defaultHandler)(display, errEventPtr); +} diff --git a/generic/tkEvent.c b/generic/tkEvent.c new file mode 100644 index 0000000..045a478 --- /dev/null +++ b/generic/tkEvent.c @@ -0,0 +1,1038 @@ +/* + * tkEvent.c -- + * + * This file provides basic low-level facilities for managing + * X events in Tk. + * + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkEvent.c 1.20 96/09/20 09:33:38 + */ + +#include "tkPort.h" +#include "tkInt.h" +#include + +/* + * There's a potential problem if a handler is deleted while it's + * current (i.e. its procedure is executing), since Tk_HandleEvent + * will need to read the handler's "nextPtr" field when the procedure + * returns. To handle this problem, structures of the type below + * indicate the next handler to be processed for any (recursively + * nested) dispatches in progress. The nextHandler fields get + * updated if the handlers pointed to are deleted. Tk_HandleEvent + * also needs to know if the entire window gets deleted; the winPtr + * field is set to zero if that particular window gets deleted. + */ + +typedef struct InProgress { + XEvent *eventPtr; /* Event currently being handled. */ + TkWindow *winPtr; /* Window for event. Gets set to None if + * window is deleted while event is being + * handled. */ + TkEventHandler *nextHandler; /* Next handler in search. */ + struct InProgress *nextPtr; /* Next higher nested search. */ +} InProgress; + +static InProgress *pendingPtr = NULL; + /* Topmost search in progress, or + * NULL if none. */ + +/* + * For each call to Tk_CreateGenericHandler, an instance of the following + * structure will be created. All of the active handlers are linked into a + * list. + */ + +typedef struct GenericHandler { + Tk_GenericProc *proc; /* Procedure to dispatch on all X events. */ + ClientData clientData; /* Client data to pass to procedure. */ + int deleteFlag; /* Flag to set when this handler is deleted. */ + struct GenericHandler *nextPtr; + /* Next handler in list of all generic + * handlers, or NULL for end of list. */ +} GenericHandler; + +static GenericHandler *genericList = NULL; + /* First handler in the list, or NULL. */ +static GenericHandler *lastGenericPtr = NULL; + /* Last handler in list. */ + +/* + * There's a potential problem if Tk_HandleEvent is entered recursively. + * A handler cannot be deleted physically until we have returned from + * calling it. Otherwise, we're looking at unallocated memory in advancing to + * its `next' entry. We deal with the problem by using the `delete flag' and + * deleting handlers only when it's known that there's no handler active. + * + * The following variable has a non-zero value when a handler is active. + */ + +static int genericHandlersActive = 0; + +/* + * The following structure is used for queueing X-style events on the + * Tcl event queue. + */ + +typedef struct TkWindowEvent { + Tcl_Event header; /* Standard information for all events. */ + XEvent event; /* The X event. */ +} TkWindowEvent; + +/* + * Array of event masks corresponding to each X event: + */ + +static unsigned long eventMasks[TK_LASTEVENT] = { + 0, + 0, + KeyPressMask, /* KeyPress */ + KeyReleaseMask, /* KeyRelease */ + ButtonPressMask, /* ButtonPress */ + ButtonReleaseMask, /* ButtonRelease */ + PointerMotionMask|PointerMotionHintMask|ButtonMotionMask + |Button1MotionMask|Button2MotionMask|Button3MotionMask + |Button4MotionMask|Button5MotionMask, + /* MotionNotify */ + EnterWindowMask, /* EnterNotify */ + LeaveWindowMask, /* LeaveNotify */ + FocusChangeMask, /* FocusIn */ + FocusChangeMask, /* FocusOut */ + KeymapStateMask, /* KeymapNotify */ + ExposureMask, /* Expose */ + ExposureMask, /* GraphicsExpose */ + ExposureMask, /* NoExpose */ + VisibilityChangeMask, /* VisibilityNotify */ + SubstructureNotifyMask, /* CreateNotify */ + StructureNotifyMask, /* DestroyNotify */ + StructureNotifyMask, /* UnmapNotify */ + StructureNotifyMask, /* MapNotify */ + SubstructureRedirectMask, /* MapRequest */ + StructureNotifyMask, /* ReparentNotify */ + StructureNotifyMask, /* ConfigureNotify */ + SubstructureRedirectMask, /* ConfigureRequest */ + StructureNotifyMask, /* GravityNotify */ + ResizeRedirectMask, /* ResizeRequest */ + StructureNotifyMask, /* CirculateNotify */ + SubstructureRedirectMask, /* CirculateRequest */ + PropertyChangeMask, /* PropertyNotify */ + 0, /* SelectionClear */ + 0, /* SelectionRequest */ + 0, /* SelectionNotify */ + ColormapChangeMask, /* ColormapNotify */ + 0, /* ClientMessage */ + 0, /* Mapping Notify */ + VirtualEventMask, /* VirtualEvents */ + ActivateMask, /* ActivateNotify */ + ActivateMask /* DeactivateNotify */ +}; + +/* + * If someone has called Tk_RestrictEvents, the information below + * keeps track of it. + */ + +static Tk_RestrictProc *restrictProc; + /* Procedure to call. NULL means no + * restrictProc is currently in effect. */ +static ClientData restrictArg; /* Argument to pass to restrictProc. */ + +/* + * Prototypes for procedures that are only referenced locally within + * this file. + */ + +static void DelayedMotionProc _ANSI_ARGS_((ClientData clientData)); +static int WindowEventProc _ANSI_ARGS_((Tcl_Event *evPtr, + int flags)); + +/* + *-------------------------------------------------------------- + * + * Tk_CreateEventHandler -- + * + * Arrange for a given procedure to be invoked whenever + * events from a given class occur in a given window. + * + * Results: + * None. + * + * Side effects: + * From now on, whenever an event of the type given by + * mask occurs for token and is processed by Tk_HandleEvent, + * proc will be called. See the manual entry for details + * of the calling sequence and return value for proc. + * + *-------------------------------------------------------------- + */ + +void +Tk_CreateEventHandler(token, mask, proc, clientData) + Tk_Window token; /* Token for window in which to + * create handler. */ + unsigned long mask; /* Events for which proc should + * be called. */ + Tk_EventProc *proc; /* Procedure to call for each + * selected event */ + ClientData clientData; /* Arbitrary data to pass to proc. */ +{ + register TkEventHandler *handlerPtr; + register TkWindow *winPtr = (TkWindow *) token; + int found; + + /* + * Skim through the list of existing handlers to (a) compute the + * overall event mask for the window (so we can pass this new + * value to the X system) and (b) see if there's already a handler + * declared with the same callback and clientData (if so, just + * change the mask). If no existing handler matches, then create + * a new handler. + */ + + found = 0; + if (winPtr->handlerList == NULL) { + handlerPtr = (TkEventHandler *) ckalloc( + (unsigned) sizeof(TkEventHandler)); + winPtr->handlerList = handlerPtr; + goto initHandler; + } else { + for (handlerPtr = winPtr->handlerList; ; + handlerPtr = handlerPtr->nextPtr) { + if ((handlerPtr->proc == proc) + && (handlerPtr->clientData == clientData)) { + handlerPtr->mask = mask; + found = 1; + } + if (handlerPtr->nextPtr == NULL) { + break; + } + } + } + + /* + * Create a new handler if no matching old handler was found. + */ + + if (!found) { + handlerPtr->nextPtr = (TkEventHandler *) + ckalloc(sizeof(TkEventHandler)); + handlerPtr = handlerPtr->nextPtr; + initHandler: + handlerPtr->mask = mask; + handlerPtr->proc = proc; + handlerPtr->clientData = clientData; + handlerPtr->nextPtr = NULL; + } + + /* + * No need to call XSelectInput: Tk always selects on all events + * for all windows (needed to support bindings on classes and "all"). + */ +} + +/* + *-------------------------------------------------------------- + * + * Tk_DeleteEventHandler -- + * + * Delete a previously-created handler. + * + * Results: + * None. + * + * Side effects: + * If there existed a handler as described by the + * parameters, the handler is deleted so that proc + * will not be invoked again. + * + *-------------------------------------------------------------- + */ + +void +Tk_DeleteEventHandler(token, mask, proc, clientData) + Tk_Window token; /* Same as corresponding arguments passed */ + unsigned long mask; /* previously to Tk_CreateEventHandler. */ + Tk_EventProc *proc; + ClientData clientData; +{ + register TkEventHandler *handlerPtr; + register InProgress *ipPtr; + TkEventHandler *prevPtr; + register TkWindow *winPtr = (TkWindow *) token; + + /* + * Find the event handler to be deleted, or return + * immediately if it doesn't exist. + */ + + for (handlerPtr = winPtr->handlerList, prevPtr = NULL; ; + prevPtr = handlerPtr, handlerPtr = handlerPtr->nextPtr) { + if (handlerPtr == NULL) { + return; + } + if ((handlerPtr->mask == mask) && (handlerPtr->proc == proc) + && (handlerPtr->clientData == clientData)) { + break; + } + } + + /* + * If Tk_HandleEvent is about to process this handler, tell it to + * process the next one instead. + */ + + for (ipPtr = pendingPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { + if (ipPtr->nextHandler == handlerPtr) { + ipPtr->nextHandler = handlerPtr->nextPtr; + } + } + + /* + * Free resources associated with the handler. + */ + + if (prevPtr == NULL) { + winPtr->handlerList = handlerPtr->nextPtr; + } else { + prevPtr->nextPtr = handlerPtr->nextPtr; + } + ckfree((char *) handlerPtr); + + + /* + * No need to call XSelectInput: Tk always selects on all events + * for all windows (needed to support bindings on classes and "all"). + */ +} + +/*-------------------------------------------------------------- + * + * Tk_CreateGenericHandler -- + * + * Register a procedure to be called on each X event, regardless + * of display or window. Generic handlers are useful for capturing + * events that aren't associated with windows, or events for windows + * not managed by Tk. + * + * Results: + * None. + * + * Side Effects: + * From now on, whenever an X event is given to Tk_HandleEvent, + * invoke proc, giving it clientData and the event as arguments. + * + *-------------------------------------------------------------- + */ + +void +Tk_CreateGenericHandler(proc, clientData) + Tk_GenericProc *proc; /* Procedure to call on every event. */ + ClientData clientData; /* One-word value to pass to proc. */ +{ + GenericHandler *handlerPtr; + + handlerPtr = (GenericHandler *) ckalloc (sizeof (GenericHandler)); + + handlerPtr->proc = proc; + handlerPtr->clientData = clientData; + handlerPtr->deleteFlag = 0; + handlerPtr->nextPtr = NULL; + if (genericList == NULL) { + genericList = handlerPtr; + } else { + lastGenericPtr->nextPtr = handlerPtr; + } + lastGenericPtr = handlerPtr; +} + +/* + *-------------------------------------------------------------- + * + * Tk_DeleteGenericHandler -- + * + * Delete a previously-created generic handler. + * + * Results: + * None. + * + * Side Effects: + * If there existed a handler as described by the parameters, + * that handler is logically deleted so that proc will not be + * invoked again. The physical deletion happens in the event + * loop in Tk_HandleEvent. + * + *-------------------------------------------------------------- + */ + +void +Tk_DeleteGenericHandler(proc, clientData) + Tk_GenericProc *proc; + ClientData clientData; +{ + GenericHandler * handler; + + for (handler = genericList; handler; handler = handler->nextPtr) { + if ((handler->proc == proc) && (handler->clientData == clientData)) { + handler->deleteFlag = 1; + } + } +} + +/* + *-------------------------------------------------------------- + * + * Tk_HandleEvent -- + * + * Given an event, invoke all the handlers that have + * been registered for the event. + * + * Results: + * None. + * + * Side effects: + * Depends on the handlers. + * + *-------------------------------------------------------------- + */ + +void +Tk_HandleEvent(eventPtr) + XEvent *eventPtr; /* Event to dispatch. */ +{ + register TkEventHandler *handlerPtr; + register GenericHandler *genericPtr; + register GenericHandler *genPrevPtr; + TkWindow *winPtr; + unsigned long mask; + InProgress ip; + Window handlerWindow; + TkDisplay *dispPtr; + Tcl_Interp *interp = (Tcl_Interp *) NULL; + + /* + * Next, invoke all the generic event handlers (those that are + * invoked for all events). If a generic event handler reports that + * an event is fully processed, go no further. + */ + + for (genPrevPtr = NULL, genericPtr = genericList; genericPtr != NULL; ) { + if (genericPtr->deleteFlag) { + if (!genericHandlersActive) { + GenericHandler *tmpPtr; + + /* + * This handler needs to be deleted and there are no + * calls pending through the handler, so now is a safe + * time to delete it. + */ + + tmpPtr = genericPtr->nextPtr; + if (genPrevPtr == NULL) { + genericList = tmpPtr; + } else { + genPrevPtr->nextPtr = tmpPtr; + } + if (tmpPtr == NULL) { + lastGenericPtr = genPrevPtr; + } + (void) ckfree((char *) genericPtr); + genericPtr = tmpPtr; + continue; + } + } else { + int done; + + genericHandlersActive++; + done = (*genericPtr->proc)(genericPtr->clientData, eventPtr); + genericHandlersActive--; + if (done) { + return; + } + } + genPrevPtr = genericPtr; + genericPtr = genPrevPtr->nextPtr; + } + + /* + * If the event is a MappingNotify event, find its display and + * refresh the keyboard mapping information for the display. + * After that there's nothing else to do with the event, so just + * quit. + */ + + if (eventPtr->type == MappingNotify) { + dispPtr = TkGetDisplay(eventPtr->xmapping.display); + if (dispPtr != NULL) { + XRefreshKeyboardMapping(&eventPtr->xmapping); + dispPtr->bindInfoStale = 1; + } + return; + } + + /* + * Events selected by StructureNotify require special handling. + * They look the same as those selected by SubstructureNotify. + * The only difference is whether the "event" and "window" fields + * are the same. Compare the two fields and convert StructureNotify + * to SubstructureNotify if necessary. + */ + + handlerWindow = eventPtr->xany.window; + mask = eventMasks[eventPtr->xany.type]; + if (mask == StructureNotifyMask) { + if (eventPtr->xmap.event != eventPtr->xmap.window) { + mask = SubstructureNotifyMask; + handlerWindow = eventPtr->xmap.event; + } + } + winPtr = (TkWindow *) Tk_IdToWindow(eventPtr->xany.display, handlerWindow); + if (winPtr == NULL) { + + /* + * There isn't a TkWindow structure for this window. + * However, if the event is a PropertyNotify event then call + * the selection manager (it deals beneath-the-table with + * certain properties). + */ + + if (eventPtr->type == PropertyNotify) { + TkSelPropProc(eventPtr); + } + return; + } + + /* + * Once a window has started getting deleted, don't process any more + * events for it except for the DestroyNotify event. This check is + * needed because a DestroyNotify handler could re-invoke the event + * loop, causing other pending events to be handled for the window + * (the window doesn't get totally expunged from our tables until + * after the DestroyNotify event has been completely handled). + */ + + if ((winPtr->flags & TK_ALREADY_DEAD) + && (eventPtr->type != DestroyNotify)) { + return; + } + + if (winPtr->mainPtr != NULL) { + + /* + * Protect interpreter for this window from possible deletion + * while we are dealing with the event for this window. Thus, + * widget writers do not have to worry about protecting the + * interpreter in their own code. + */ + + interp = winPtr->mainPtr->interp; + Tcl_Preserve((ClientData) interp); + + /* + * Call focus-related code to look at FocusIn, FocusOut, Enter, + * and Leave events; depending on its return value, ignore the + * event. + */ + + if ((mask & (FocusChangeMask|EnterWindowMask|LeaveWindowMask)) + && !TkFocusFilterEvent(winPtr, eventPtr)) { + Tcl_Release((ClientData) interp); + return; + } + + /* + * Redirect KeyPress and KeyRelease events to the focus window, + * or ignore them entirely if there is no focus window. + */ + + if (mask & (KeyPressMask|KeyReleaseMask)) { + winPtr->dispPtr->lastEventTime = eventPtr->xkey.time; + winPtr = TkFocusKeyEvent(winPtr, eventPtr); + if (winPtr == NULL) { + Tcl_Release((ClientData) interp); + return; + } + } + + /* + * Call a grab-related procedure to do special processing on + * pointer events. + */ + + if (mask & (ButtonPressMask|ButtonReleaseMask|PointerMotionMask + |EnterWindowMask|LeaveWindowMask)) { + if (mask & (ButtonPressMask|ButtonReleaseMask)) { + winPtr->dispPtr->lastEventTime = eventPtr->xbutton.time; + } else if (mask & PointerMotionMask) { + winPtr->dispPtr->lastEventTime = eventPtr->xmotion.time; + } else { + winPtr->dispPtr->lastEventTime = eventPtr->xcrossing.time; + } + if (TkPointerEvent(eventPtr, winPtr) == 0) { + goto done; + } + } + } + +#ifdef TK_USE_INPUT_METHODS + /* + * Pass the event to the input method(s), if there are any, and + * discard the event if the input method(s) insist. Create the + * input context for the window if it hasn't already been done + * (XFilterEvent needs this context). + */ + + if (!(winPtr->flags & TK_CHECKED_IC)) { + if (winPtr->dispPtr->inputMethod != NULL) { + winPtr->inputContext = XCreateIC( + winPtr->dispPtr->inputMethod, XNInputStyle, + XIMPreeditNothing|XIMStatusNothing, + XNClientWindow, winPtr->window, + XNFocusWindow, winPtr->window, NULL); + } + winPtr->flags |= TK_CHECKED_IC; + } + if (XFilterEvent(eventPtr, None)) { + goto done; + } +#endif /* TK_USE_INPUT_METHODS */ + + /* + * For events where it hasn't already been done, update the current + * time in the display. + */ + + if (eventPtr->type == PropertyNotify) { + winPtr->dispPtr->lastEventTime = eventPtr->xproperty.time; + } + + /* + * There's a potential interaction here with Tk_DeleteEventHandler. + * Read the documentation for pendingPtr. + */ + + ip.eventPtr = eventPtr; + ip.winPtr = winPtr; + ip.nextHandler = NULL; + ip.nextPtr = pendingPtr; + pendingPtr = &ip; + if (mask == 0) { + if ((eventPtr->type == SelectionClear) + || (eventPtr->type == SelectionRequest) + || (eventPtr->type == SelectionNotify)) { + TkSelEventProc((Tk_Window) winPtr, eventPtr); + } else if ((eventPtr->type == ClientMessage) + && (eventPtr->xclient.message_type == + Tk_InternAtom((Tk_Window) winPtr, "WM_PROTOCOLS"))) { + TkWmProtocolEventProc(winPtr, eventPtr); + } + } else { + for (handlerPtr = winPtr->handlerList; handlerPtr != NULL; ) { + if ((handlerPtr->mask & mask) != 0) { + ip.nextHandler = handlerPtr->nextPtr; + (*(handlerPtr->proc))(handlerPtr->clientData, eventPtr); + handlerPtr = ip.nextHandler; + } else { + handlerPtr = handlerPtr->nextPtr; + } + } + + /* + * Pass the event to the "bind" command mechanism. But, don't + * do this for SubstructureNotify events. The "bind" command + * doesn't support them anyway, and it's easier to filter out + * these events here than in the lower-level procedures. + */ + + if ((ip.winPtr != None) && (mask != SubstructureNotifyMask)) { + TkBindEventProc(winPtr, eventPtr); + } + } + pendingPtr = ip.nextPtr; +done: + + /* + * Release the interpreter for this window so that it can be potentially + * deleted if requested. + */ + + if (interp != (Tcl_Interp *) NULL) { + Tcl_Release((ClientData) interp); + } +} + +/* + *-------------------------------------------------------------- + * + * TkEventDeadWindow -- + * + * This procedure is invoked when it is determined that + * a window is dead. It cleans up event-related information + * about the window. + * + * Results: + * None. + * + * Side effects: + * Various things get cleaned up and recycled. + * + *-------------------------------------------------------------- + */ + +void +TkEventDeadWindow(winPtr) + TkWindow *winPtr; /* Information about the window + * that is being deleted. */ +{ + register TkEventHandler *handlerPtr; + register InProgress *ipPtr; + + /* + * While deleting all the handlers, be careful to check for + * Tk_HandleEvent being about to process one of the deleted + * handlers. If it is, tell it to quit (all of the handlers + * are being deleted). + */ + + while (winPtr->handlerList != NULL) { + handlerPtr = winPtr->handlerList; + winPtr->handlerList = handlerPtr->nextPtr; + for (ipPtr = pendingPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { + if (ipPtr->nextHandler == handlerPtr) { + ipPtr->nextHandler = NULL; + } + if (ipPtr->winPtr == winPtr) { + ipPtr->winPtr = None; + } + } + ckfree((char *) handlerPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * TkCurrentTime -- + * + * Try to deduce the current time. "Current time" means the time + * of the event that led to the current code being executed, which + * means the time in the most recently-nested invocation of + * Tk_HandleEvent. + * + * Results: + * The return value is the time from the current event, or + * CurrentTime if there is no current event or if the current + * event contains no time. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Time +TkCurrentTime(dispPtr) + TkDisplay *dispPtr; /* Display for which the time is desired. */ +{ + register XEvent *eventPtr; + + if (pendingPtr == NULL) { + return dispPtr->lastEventTime; + } + eventPtr = pendingPtr->eventPtr; + switch (eventPtr->type) { + case ButtonPress: + case ButtonRelease: + return eventPtr->xbutton.time; + case KeyPress: + case KeyRelease: + return eventPtr->xkey.time; + case MotionNotify: + return eventPtr->xmotion.time; + case EnterNotify: + case LeaveNotify: + return eventPtr->xcrossing.time; + case PropertyNotify: + return eventPtr->xproperty.time; + } + return dispPtr->lastEventTime; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_RestrictEvents -- + * + * This procedure is used to globally restrict the set of events + * that will be dispatched. The restriction is done by filtering + * all incoming X events through a procedure that determines + * whether they are to be processed immediately, deferred, or + * discarded. + * + * Results: + * The return value is the previous restriction procedure in effect, + * if there was one, or NULL if there wasn't. + * + * Side effects: + * From now on, proc will be called to determine whether to process, + * defer or discard each incoming X event. + * + *---------------------------------------------------------------------- + */ + +Tk_RestrictProc * +Tk_RestrictEvents(proc, arg, prevArgPtr) + Tk_RestrictProc *proc; /* Procedure to call for each incoming + * event. */ + ClientData arg; /* Arbitrary argument to pass to proc. */ + ClientData *prevArgPtr; /* Place to store information about previous + * argument. */ +{ + Tk_RestrictProc *prev; + + prev = restrictProc; + *prevArgPtr = restrictArg; + restrictProc = proc; + restrictArg = arg; + return prev; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_QueueWindowEvent -- + * + * Given an X-style window event, this procedure adds it to the + * Tcl event queue at the given position. This procedure also + * performs mouse motion event collapsing if possible. + * + * Results: + * None. + * + * Side effects: + * Adds stuff to the event queue, which will eventually be + * processed. + * + *---------------------------------------------------------------------- + */ + +void +Tk_QueueWindowEvent(eventPtr, position) + XEvent *eventPtr; /* Event to add to queue. This + * procedures copies it before adding + * it to the queue. */ + Tcl_QueuePosition position; /* Where to put it on the queue: + * TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, + * or TCL_QUEUE_MARK. */ +{ + TkWindowEvent *wevPtr; + TkDisplay *dispPtr; + + /* + * Find our display structure for the event's display. + */ + + for (dispPtr = tkDisplayList; ; dispPtr = dispPtr->nextPtr) { + if (dispPtr == NULL) { + return; + } + if (dispPtr->display == eventPtr->xany.display) { + break; + } + } + + if ((dispPtr->delayedMotionPtr != NULL) && (position == TCL_QUEUE_TAIL)) { + if ((eventPtr->type == MotionNotify) && (eventPtr->xmotion.window + == dispPtr->delayedMotionPtr->event.xmotion.window)) { + /* + * The new event is a motion event in the same window as the + * saved motion event. Just replace the saved event with the + * new one. + */ + + dispPtr->delayedMotionPtr->event = *eventPtr; + return; + } else if ((eventPtr->type != GraphicsExpose) + && (eventPtr->type != NoExpose) + && (eventPtr->type != Expose)) { + /* + * The new event may conflict with the saved motion event. Queue + * the saved motion event now so that it will be processed before + * the new event. + */ + + Tcl_QueueEvent(&dispPtr->delayedMotionPtr->header, position); + dispPtr->delayedMotionPtr = NULL; + Tcl_CancelIdleCall(DelayedMotionProc, (ClientData) dispPtr); + } + } + + wevPtr = (TkWindowEvent *) ckalloc(sizeof(TkWindowEvent)); + wevPtr->header.proc = WindowEventProc; + wevPtr->event = *eventPtr; + if ((eventPtr->type == MotionNotify) && (position == TCL_QUEUE_TAIL)) { + /* + * The new event is a motion event so don't queue it immediately; + * save it around in case another motion event arrives that it can + * be collapsed with. + */ + + if (dispPtr->delayedMotionPtr != NULL) { + panic("Tk_QueueWindowEvent found unexpected delayed motion event"); + } + dispPtr->delayedMotionPtr = wevPtr; + Tcl_DoWhenIdle(DelayedMotionProc, (ClientData) dispPtr); + } else { + Tcl_QueueEvent(&wevPtr->header, position); + } +} + +/* + *--------------------------------------------------------------------------- + * + * TkQueueEventForAllChildren -- + * + * Given an XEvent, recursively queue the event for this window and + * all non-toplevel children of the given window. + * + * Results: + * None. + * + * Side effects: + * Events queued. + * + *--------------------------------------------------------------------------- + */ + +void +TkQueueEventForAllChildren(winPtr, eventPtr) + TkWindow *winPtr; /* Window to which event is sent. */ + XEvent *eventPtr; /* The event to be sent. */ +{ + TkWindow *childPtr; + + eventPtr->xany.window = winPtr->window; + Tk_QueueWindowEvent(eventPtr, TCL_QUEUE_TAIL); + + childPtr = winPtr->childList; + while (childPtr != NULL) { + if (!Tk_IsTopLevel(childPtr)) { + TkQueueEventForAllChildren(childPtr, eventPtr); + } + childPtr = childPtr->nextPtr; + } +} + +/* + *---------------------------------------------------------------------- + * + * WindowEventProc -- + * + * This procedure is called by Tcl_DoOneEvent when a window event + * reaches the front of the event queue. This procedure is responsible + * for actually handling the event. + * + * Results: + * Returns 1 if the event was handled, meaning it should be removed + * from the queue. Returns 0 if the event was not handled, meaning + * it should stay on the queue. The event isn't handled if the + * TCL_WINDOW_EVENTS bit isn't set in flags, if a restrict proc + * prevents the event from being handled. + * + * Side effects: + * Whatever the event handlers for the event do. + * + *---------------------------------------------------------------------- + */ + +static int +WindowEventProc(evPtr, flags) + Tcl_Event *evPtr; /* Event to service. */ + int flags; /* Flags that indicate what events to + * handle, such as TCL_WINDOW_EVENTS. */ +{ + TkWindowEvent *wevPtr = (TkWindowEvent *) evPtr; + Tk_RestrictAction result; + + if (!(flags & TCL_WINDOW_EVENTS)) { + return 0; + } + if (restrictProc != NULL) { + result = (*restrictProc)(restrictArg, &wevPtr->event); + if (result != TK_PROCESS_EVENT) { + if (result == TK_DEFER_EVENT) { + return 0; + } else { + /* + * TK_DELETE_EVENT: return and say we processed the event, + * even though we didn't do anything at all. + */ + return 1; + } + } + } + Tk_HandleEvent(&wevPtr->event); + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * DelayedMotionProc -- + * + * This procedure is invoked as an idle handler when a mouse motion + * event has been delayed. It queues the delayed event so that it + * will finally be serviced. + * + * Results: + * None. + * + * Side effects: + * The delayed mouse motion event gets added to the Tcl event + * queue for servicing. + * + *---------------------------------------------------------------------- + */ + +static void +DelayedMotionProc(clientData) + ClientData clientData; /* Pointer to display containing a delayed + * motion event to be serviced. */ +{ + TkDisplay *dispPtr = (TkDisplay *) clientData; + + if (dispPtr->delayedMotionPtr == NULL) { + panic("DelayedMotionProc found no delayed mouse motion event"); + } + Tcl_QueueEvent(&dispPtr->delayedMotionPtr->header, TCL_QUEUE_TAIL); + dispPtr->delayedMotionPtr = NULL; +} + +/* + *-------------------------------------------------------------- + * + * Tk_MainLoop -- + * + * Call Tcl_DoOneEvent over and over again in an infinite + * loop as long as there exist any main windows. + * + * Results: + * None. + * + * Side effects: + * Arbitrary; depends on handlers for events. + * + *-------------------------------------------------------------- + */ + +void +Tk_MainLoop() +{ + while (Tk_GetNumMainWindows() > 0) { + Tcl_DoOneEvent(0); + } +} diff --git a/generic/tkFileFilter.c b/generic/tkFileFilter.c new file mode 100644 index 0000000..1b7e61a --- /dev/null +++ b/generic/tkFileFilter.c @@ -0,0 +1,486 @@ +/* + * tkFileFilter.c -- + * + * Process the -filetypes option for the file dialogs on Windows and the + * Mac. + * + * 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: @(#) tkFileFilter.c 1.6 97/04/30 15:55:35 + * + */ + +#include "tkInt.h" +#include "tkFileFilter.h" + +static int AddClause _ANSI_ARGS_(( + Tcl_Interp * interp, FileFilter * filterPtr, + char * patternsStr, char * ostypesStr, + int isWindows)); +static void FreeClauses _ANSI_ARGS_((FileFilter * filterPtr)); +static void FreeGlobPatterns _ANSI_ARGS_(( + FileFilterClause * clausePtr)); +static void FreeMacFileTypes _ANSI_ARGS_(( + FileFilterClause * clausePtr)); +static FileFilter * GetFilter _ANSI_ARGS_((FileFilterList * flistPtr, + char * name)); + +/* + *---------------------------------------------------------------------- + * + * TkInitFileFilters -- + * + * Initializes a FileFilterList data structure. A FileFilterList + * must be initialized EXACTLY ONCE before any calls to + * TkGetFileFilters() is made. The usual flow of control is: + * TkInitFileFilters(&flist); + * TkGetFileFilters(&flist, ...); + * TkGetFileFilters(&flist, ...); + * ... + * TkFreeFileFilters(&flist); + * + * Results: + * None. + * + * Side effects: + * The fields in flistPtr are initialized. + *---------------------------------------------------------------------- + */ + +void +TkInitFileFilters(flistPtr) + FileFilterList * flistPtr; /* The structure to be initialized. */ +{ + flistPtr->filters = NULL; + flistPtr->filtersTail = NULL; + flistPtr->numFilters = 0; +} + +/* + *---------------------------------------------------------------------- + * + * TkGetFileFilters -- + * + * This function is called by the Mac and Windows implementation + * of tk_getOpenFile and tk_getSaveFile to translate the string + * value of the -filetypes option of into an easy-to-parse C + * structure (flistPtr). The caller of this function will then use + * flistPtr to perform filetype matching in a platform specific way. + * + * flistPtr must be initialized (See comments in TkInitFileFilters). + * + * Results: + * A standard TCL return value. + * + * Side effects: + * The fields in flistPtr are changed according to string. + *---------------------------------------------------------------------- + */ +int +TkGetFileFilters(interp, flistPtr, string, isWindows) + Tcl_Interp *interp; /* Interpreter to use for error reporting. */ + FileFilterList * flistPtr; /* Stores the list of file filters. */ + char * string; /* Value of the -filetypes option. */ + int isWindows; /* True if we are running on Windows. */ +{ + int listArgc; + char ** listArgv = NULL; + char ** typeInfo = NULL; + int code = TCL_OK; + int i; + + if (Tcl_SplitList(interp, string, &listArgc, &listArgv) != TCL_OK) { + return TCL_ERROR; + } + if (listArgc == 0) { + goto done; + } + + /* + * Free the filter information that have been allocated the previous + * time -- the -filefilters option may have been used more than once in + * the command line. + */ + TkFreeFileFilters(flistPtr); + + for (i = 0; ifilters; + while (filterPtr) { + toFree = filterPtr; + filterPtr=filterPtr->next; + FreeClauses(toFree); + ckfree((char*)toFree->name); + ckfree((char*)toFree); + } + flistPtr->filters = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * AddClause -- + * + * Add one FileFilterClause to filterPtr. + * + * Results: + * A standard TCL result. + * + * Side effects: + * The list of filter clauses are updated in filterPtr. + *---------------------------------------------------------------------- + */ + +static int AddClause(interp, filterPtr, patternsStr, ostypesStr, isWindows) + Tcl_Interp * interp; /* Interpreter to use for error reporting. */ + FileFilter * filterPtr; /* Stores the new filter clause */ + char * patternsStr; /* A TCL list of glob patterns. */ + char * ostypesStr; /* A TCL list of Mac OSType strings. */ + int isWindows; /* True if we are running on Windows; False + * if we are running on the Mac; Glob + * patterns need to be processed differently + * on these two platforms */ +{ + char ** globList = NULL; + int globCount; + char ** ostypeList = NULL; + int ostypeCount; + FileFilterClause * clausePtr; + int i; + int code = TCL_OK; + + if (Tcl_SplitList(interp, patternsStr, &globCount, &globList)!= TCL_OK) { + code = TCL_ERROR; + goto done; + } + if (ostypesStr != NULL) { + if (Tcl_SplitList(interp, ostypesStr, &ostypeCount, &ostypeList) + != TCL_OK) { + code = TCL_ERROR; + goto done; + } + for (i=0; ipatterns = NULL; + clausePtr->patternsTail = NULL; + clausePtr->macTypes = NULL; + clausePtr->macTypesTail = NULL; + + if (filterPtr->clauses == NULL) { + filterPtr->clauses = filterPtr->clausesTail = clausePtr; + } else { + filterPtr->clausesTail->next = clausePtr; + filterPtr->clausesTail = clausePtr; + } + clausePtr->next = NULL; + + if (globCount > 0 && globList != NULL) { + for (i=0; ipattern = (char*)ckalloc(len+1); + globPtr->pattern[0] = '*'; + strcpy(globPtr->pattern+1, globList[i]); + } + else if (isWindows) { + if (strcmp(globList[i], "*") == 0) { + globPtr->pattern = (char*)ckalloc(4*sizeof(char)); + strcpy(globPtr->pattern, "*.*"); + } + else if (strcmp(globList[i], "") == 0) { + /* + * An empty string means "match all files with no + * extensions" + * BUG: "*." actually matches with all files on Win95 + */ + globPtr->pattern = (char*)ckalloc(3*sizeof(char)); + strcpy(globPtr->pattern, "*."); + } + else { + globPtr->pattern = (char*)ckalloc(len); + strcpy(globPtr->pattern, globList[i]); + } + } else { + globPtr->pattern = (char*)ckalloc(len); + strcpy(globPtr->pattern, globList[i]); + } + + /* + * Add the glob pattern into the list of patterns. + */ + + if (clausePtr->patterns == NULL) { + clausePtr->patterns = clausePtr->patternsTail = globPtr; + } else { + clausePtr->patternsTail->next = globPtr; + clausePtr->patternsTail = globPtr; + } + globPtr->next = NULL; + } + } + if (ostypeCount > 0 && ostypeList != NULL) { + for (i=0; itype, ostypeList[i], sizeof(OSType)); + + /* + * Add the Mac type pattern into the list of Mac types + */ + if (clausePtr->macTypes == NULL) { + clausePtr->macTypes = clausePtr->macTypesTail = mfPtr; + } else { + clausePtr->macTypesTail->next = mfPtr; + clausePtr->macTypesTail = mfPtr; + } + mfPtr->next = NULL; + } + } + + done: + if (globList) { + ckfree((char*)globList); + } + if (ostypeList) { + ckfree((char*)ostypeList); + } + + return code; +} + +/* + *---------------------------------------------------------------------- + * + * GetFilter -- + * + * Add one FileFilter to flistPtr. + * + * Results: + * A standard TCL result. + * + * Side effects: + * The list of filters are updated in flistPtr. + *---------------------------------------------------------------------- + */ + +static FileFilter * GetFilter(flistPtr, name) + FileFilterList * flistPtr; /* The FileFilterList that contains the + * newly created filter */ + char * name; /* Name of the filter. It is usually displayed + * in the "File Types" listbox in the file + * dialogs. */ +{ + FileFilter * filterPtr; + + for (filterPtr=flistPtr->filters; filterPtr; filterPtr=filterPtr->next) { + if (strcmp(filterPtr->name, name)==0) { + return filterPtr; + } + } + + filterPtr = (FileFilter*)ckalloc(sizeof(FileFilter)); + filterPtr->clauses = NULL; + filterPtr->clausesTail = NULL; + filterPtr->name = (char*)ckalloc((strlen(name)+1) * sizeof(char)); + strcpy(filterPtr->name, name); + + if (flistPtr->filters == NULL) { + flistPtr->filters = flistPtr->filtersTail = filterPtr; + } else { + flistPtr->filtersTail->next = filterPtr; + flistPtr->filtersTail = filterPtr; + } + filterPtr->next = NULL; + + ++flistPtr->numFilters; + return filterPtr; +} + +/* + *---------------------------------------------------------------------- + * + * FreeClauses -- + * + * Frees the malloc'ed file type clause + * + * Results: + * None. + * + * Side effects: + * The list of clauses in filterPtr->clauses are freed. + *---------------------------------------------------------------------- + */ + +static void +FreeClauses(filterPtr) + FileFilter * filterPtr; /* FileFilter whose clauses are to be freed */ +{ + FileFilterClause * clausePtr, * toFree; + + clausePtr = filterPtr->clauses; + while (clausePtr) { + toFree = clausePtr; + clausePtr=clausePtr->next; + FreeGlobPatterns(toFree); + FreeMacFileTypes(toFree); + ckfree((char*)toFree); + } + filterPtr->clauses = NULL; + filterPtr->clausesTail = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * FreeGlobPatterns -- + * + * Frees the malloc'ed glob patterns in a clause + * + * Results: + * None. + * + * Side effects: + * The list of glob patterns in clausePtr->patterns are freed. + *---------------------------------------------------------------------- + */ + +static void +FreeGlobPatterns(clausePtr) + FileFilterClause * clausePtr;/* The clause whose patterns are to be freed*/ +{ + GlobPattern * globPtr, * toFree; + + globPtr = clausePtr->patterns; + while (globPtr) { + toFree = globPtr; + globPtr=globPtr->next; + + ckfree((char*)toFree->pattern); + ckfree((char*)toFree); + } + clausePtr->patterns = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * FreeMacFileTypes -- + * + * Frees the malloc'ed Mac file types in a clause + * + * Results: + * None. + * + * Side effects: + * The list of Mac file types in clausePtr->macTypes are freed. + *---------------------------------------------------------------------- + */ + +static void +FreeMacFileTypes(clausePtr) + FileFilterClause * clausePtr; /* The clause whose mac types are to be + * freed */ +{ + MacFileType * mfPtr, * toFree; + + mfPtr = clausePtr->macTypes; + while (mfPtr) { + toFree = mfPtr; + mfPtr=mfPtr->next; + ckfree((char*)toFree); + } + clausePtr->macTypes = NULL; +} diff --git a/generic/tkFileFilter.h b/generic/tkFileFilter.h new file mode 100644 index 0000000..2b113fc --- /dev/null +++ b/generic/tkFileFilter.h @@ -0,0 +1,83 @@ +/* + * tkFileFilter.h -- + * + * Declarations for the file filter processing routines needed by + * the file selection dialogs. + * + * 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: @(#) tkFileFilter.h 1.1 96/08/27 15:05:38 + * + */ + +#ifndef _TK_FILE_FILTER +#define _TK_FILE_FILTER + +#ifdef MAC_TCL +#include +#else +#define OSType long +#endif + +typedef struct GlobPattern { + struct GlobPattern * next; /* Chains to the next glob pattern + * in a glob pattern list */ + char * pattern; /* String value of the pattern, such + * as "*.txt" or "*.*" + */ +} GlobPattern; + +typedef struct MacFileType { + struct MacFileType * next; /* Chains to the next mac file type + * in a mac file type list */ + OSType type; /* Mac file type, such as 'TEXT' or + * 'GIFF' */ +} MacFileType; + +typedef struct FileFilterClause { + struct FileFilterClause * next; /* Chains to the next clause in + * a clause list */ + GlobPattern * patterns; /* Head of glob pattern type list */ + GlobPattern * patternsTail; /* Tail of glob pattern type list */ + MacFileType * macTypes; /* Head of mac file type list */ + MacFileType * macTypesTail; /* Tail of mac file type list */ +} FileFilterClause; + +typedef struct FileFilter { + struct FileFilter * next; /* Chains to the next filter + * in a filter list */ + char * name; /* Name of the file filter, + * such as "Text Documents" */ + FileFilterClause * clauses; /* Head of the clauses list */ + FileFilterClause * clausesTail; /* Tail of the clauses list */ +} FileFilter; + +/*---------------------------------------------------------------------- + * FileFilterList -- + * + * The routine TkGetFileFilters() translates the string value of the + * -filefilters option into a FileFilterList structure, which consists + * of a list of file filters. + * + * Each file filter consists of one or more clauses. Each clause has + * one or more glob patterns and/or one or more Mac file types + *---------------------------------------------------------------------- + */ + +typedef struct FileFilterList { + FileFilter * filters; /* Head of the filter list */ + FileFilter * filtersTail; /* Tail of the filter list */ + int numFilters; /* number of filters in the list */ +} FileFilterList; + +EXTERN void TkFreeFileFilters _ANSI_ARGS_(( + FileFilterList * flistPtr)); +EXTERN void TkInitFileFilters _ANSI_ARGS_(( + FileFilterList * flistPtr)); +EXTERN int TkGetFileFilters _ANSI_ARGS_ ((Tcl_Interp *interp, + FileFilterList * flistPtr, char * string, + int isWindows)); +#endif diff --git a/generic/tkFocus.c b/generic/tkFocus.c new file mode 100644 index 0000000..fe8f2c5 --- /dev/null +++ b/generic/tkFocus.c @@ -0,0 +1,998 @@ +/* + * tkFocus.c -- + * + * This file contains procedures that manage the input + * focus for Tk. + * + * 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: @(#) tkFocus.c 1.48 97/10/31 09:55:22 + */ + +#include "tkInt.h" +#include "tkPort.h" + + +/* + * For each top-level window that has ever received the focus, there + * is a record of the following type: + */ + +typedef struct TkToplevelFocusInfo { + TkWindow *topLevelPtr; /* Information about top-level window. */ + TkWindow *focusWinPtr; /* The next time the focus comes to this + * top-level, it will be given to this + * window. */ + struct TkToplevelFocusInfo *nextPtr; + /* Next in list of all toplevel focus records + * for a given application. */ +} ToplevelFocusInfo; + +/* + * One of the following structures exists for each display used by + * each application. These are linked together from the TkMainInfo + * structure. These structures are needed because it isn't + * sufficient to store a single piece of focus information in each + * display or in each application: we need the cross-product. + * There needs to be separate information for each display, because + * it's possible to have multiple focus windows active simultaneously + * on different displays. There also needs to be separate information + * for each application, because of embedding: if an embedded + * application has the focus, its container application also has + * the focus. Thus we keep a list of structures for each application: + * the same display can appear in structures for several applications + * at once. + */ + +typedef struct TkDisplayFocusInfo { + TkDisplay *dispPtr; /* Display that this information pertains + * to. */ + struct TkWindow *focusWinPtr; + /* Window that currently has the focus for + * this application on this display, or NULL + * if none. */ + struct TkWindow *focusOnMapPtr; + /* This points to a toplevel window that is + * supposed to receive the X input focus as + * soon as it is mapped (needed to handle the + * fact that X won't allow the focus on an + * unmapped window). NULL means no delayed + * focus op in progress for this display. */ + int forceFocus; /* Associated with focusOnMapPtr: non-zero + * means claim the focus even if some other + * application currently has it. */ + unsigned long focusSerial; /* Serial number of last request this + * application made to change the focus on + * this display. Used to identify stale + * focus notifications coming from the + * X server. */ + struct TkDisplayFocusInfo *nextPtr; + /* Next in list of all display focus + * records for a given application. */ +} DisplayFocusInfo; + +/* + * Global used for debugging. + */ + +int tclFocusDebug = 0; + +/* + * The following magic value is stored in the "send_event" field of + * FocusIn and FocusOut events that are generated in this file. This + * allows us to separate "real" events coming from the server from + * those that we generated. + */ + +#define GENERATED_EVENT_MAGIC ((Bool) 0x547321ac) + +/* + * Forward declarations for procedures defined in this file: + */ + + +static DisplayFocusInfo *FindDisplayFocusInfo _ANSI_ARGS_((TkMainInfo *mainPtr, + TkDisplay *dispPtr)); +static void FocusMapProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +static void GenerateFocusEvents _ANSI_ARGS_((TkWindow *sourcePtr, + TkWindow *destPtr)); +static void SetFocus _ANSI_ARGS_((TkWindow *winPtr, int force)); + +/* + *-------------------------------------------------------------- + * + * Tk_FocusCmd -- + * + * This procedure is invoked to process the "focus" 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_FocusCmd(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; + TkWindow *winPtr = (TkWindow *) clientData; + TkWindow *newPtr, *focusWinPtr, *topLevelPtr; + ToplevelFocusInfo *tlFocusPtr; + char c; + size_t length; + + /* + * If invoked with no arguments, just return the current focus window. + */ + + if (argc == 1) { + focusWinPtr = TkGetFocusWin(winPtr); + if (focusWinPtr != NULL) { + interp->result = focusWinPtr->pathName; + } + return TCL_OK; + } + + /* + * If invoked with a single argument beginning with "." then focus + * on that window. + */ + + if (argc == 2) { + if (argv[1][0] == 0) { + return TCL_OK; + } + if (argv[1][0] == '.') { + newPtr = (TkWindow *) Tk_NameToWindow(interp, argv[1], tkwin); + if (newPtr == NULL) { + return TCL_ERROR; + } + if (!(newPtr->flags & TK_ALREADY_DEAD)) { + SetFocus(newPtr, 0); + } + return TCL_OK; + } + } + + 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; + } + newPtr = (TkWindow *) Tk_NameToWindow(interp, argv[2], 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) { + interp->result = tlFocusPtr->focusWinPtr->pathName; + return TCL_OK; + } + } + interp->result = topLevelPtr->pathName; + return TCL_OK; + } + } + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be -displayof, -force, or -lastfor", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * TkFocusFilterEvent -- + * + * This procedure is invoked by Tk_HandleEvent when it encounters + * a FocusIn, FocusOut, Enter, or Leave event. + * + * Results: + * A return value of 1 means that Tk_HandleEvent should process + * the event normally (i.e. event handlers should be invoked). + * A return value of 0 means that this event should be ignored. + * + * Side effects: + * Additional events may be generated, and the focus may switch. + * + *-------------------------------------------------------------- + */ + +int +TkFocusFilterEvent(winPtr, eventPtr) + TkWindow *winPtr; /* Window that focus event is directed to. */ + XEvent *eventPtr; /* FocusIn, FocusOut, Enter, or Leave + * event. */ +{ + /* + * Design notes: the window manager and X server work together to + * transfer the focus among top-level windows. This procedure takes + * care of transferring the focus from a top-level or wrapper window + * to the actual window within that top-level that has the focus. + * We do this by synthesizing X events to move the focus around. + * None of the FocusIn and FocusOut events generated by X are ever + * used outside of this procedure; only the synthesized events get + * through to the rest of the application. At one point (e.g. + * Tk4.0b1) Tk used to call X to move the focus from a top-level to + * one of its descendants, then just pass through the events + * generated by X. This approach didn't work very well, for a + * variety of reasons. For example, if X generates the events they + * go at the back of the event queue, which could cause problems if + * other things have already happened, such as moving the focus to + * yet another window. + */ + + ToplevelFocusInfo *tlFocusPtr; + DisplayFocusInfo *displayFocusPtr; + TkDisplay *dispPtr = winPtr->dispPtr; + TkWindow *newFocusPtr; + int retValue, delta; + + /* + * If this was a generated event, just turn off the generated + * flag and pass the event through to Tk bindings. + */ + + if (eventPtr->xfocus.send_event == GENERATED_EVENT_MAGIC) { + eventPtr->xfocus.send_event = 0; + return 1; + } + + /* + * Check for special events generated by embedded applications to + * request the input focus. If this is one of those events, make + * the change in focus and return without any additional processing + * of the event (note: the "detail" field of the event indicates + * whether to claim the focus even if we don't already have it). + */ + + if ((eventPtr->xfocus.mode == EMBEDDED_APP_WANTS_FOCUS) + && (eventPtr->type == FocusIn)) { + SetFocus(winPtr, eventPtr->xfocus.detail); + return 0; + } + + /* + * This was not a generated event. We'll return 1 (so that the + * event will be processed) if it's an Enter or Leave event, and + * 0 (so that the event won't be processed) if it's a FocusIn or + * FocusOut event. + */ + + retValue = 0; + displayFocusPtr = FindDisplayFocusInfo(winPtr->mainPtr, winPtr->dispPtr); + if (eventPtr->type == FocusIn) { + /* + * Skip FocusIn events that cause confusion + * NotifyVirtual and NotifyNonlinearVirtual - Virtual events occur + * on windows in between the origin and destination of the + * focus change. For FocusIn we may see this when focus + * goes into an embedded child. We don't care about this, + * although we may end up getting a NotifyPointer later. + * NotifyInferior - focus is coming to us from an embedded child. + * When focus is on an embeded focus, we still think we have + * the focus, too, so this message doesn't change our state. + * NotifyPointerRoot - should never happen because this is sent + * to the root window. + * + * Interesting FocusIn events are + * NotifyAncestor - focus is coming from our parent, probably the root. + * NotifyNonlinear - focus is coming from a different branch, probably + * another toplevel. + * NotifyPointer - implicit focus because of the mouse position. + * This is only interesting on toplevels, when it means that the + * focus has been set to the root window but the mouse is over + * this toplevel. We take the focus implicitly (probably no + * window manager) + */ + + if ((eventPtr->xfocus.detail == NotifyVirtual) + || (eventPtr->xfocus.detail == NotifyNonlinearVirtual) + || (eventPtr->xfocus.detail == NotifyPointerRoot) + || (eventPtr->xfocus.detail == NotifyInferior)) { + return retValue; + } + } else if (eventPtr->type == FocusOut) { + /* + * Skip FocusOut events that cause confusion. + * NotifyPointer - the pointer is in us or a child, and we are losing + * focus because of an XSetInputFocus. Other focus events + * will set our state properly. + * NotifyPointerRoot - should never happen because this is sent + * to the root window. + * NotifyInferior - focus leaving us for an embedded child. We + * retain a notion of focus when an embedded child has focus. + * + * Interesting events are: + * NotifyAncestor - focus is going to root. + * NotifyNonlinear - focus is going to another branch, probably + * another toplevel. + * NotifyVirtual, NotifyNonlinearVirtual - focus is passing through, + * and we need to make sure we track this. + */ + + if ((eventPtr->xfocus.detail == NotifyPointer) + || (eventPtr->xfocus.detail == NotifyPointerRoot) + || (eventPtr->xfocus.detail == NotifyInferior)) { + return retValue; + } + } else { + retValue = 1; + if (eventPtr->xcrossing.detail == NotifyInferior) { + return retValue; + } + } + + /* + * If winPtr isn't a top-level window than just ignore the event. + */ + + winPtr = TkWmFocusToplevel(winPtr); + if (winPtr == NULL) { + return retValue; + } + + /* + * If there is a grab in effect and this window is outside the + * grabbed tree, then ignore the event. + */ + + if (TkGrabState(winPtr) == TK_GRAB_EXCLUDED) { + return retValue; + } + + /* + * It is possible that there were outstanding FocusIn and FocusOut + * events on their way to us at the time the focus was changed + * internally with the "focus" command. If so, these events could + * potentially cause us to lose the focus (switch it to the window + * of the last FocusIn event) even though the focus change occurred + * after those events. The following code detects this and ignores + * the stale events. + * + * Note: the focusSerial is only generated by TkpChangeFocus, + * whereas in Tk 4.2 there was always a nop marker generated. + */ + + delta = eventPtr->xfocus.serial - displayFocusPtr->focusSerial; + if (delta < 0) { + return retValue; + } + + /* + * Find the ToplevelFocusInfo structure for the window, and make a new one + * if there isn't one already. + */ + + for (tlFocusPtr = winPtr->mainPtr->tlFocusPtr; tlFocusPtr != NULL; + tlFocusPtr = tlFocusPtr->nextPtr) { + if (tlFocusPtr->topLevelPtr == winPtr) { + break; + } + } + if (tlFocusPtr == NULL) { + tlFocusPtr = (ToplevelFocusInfo *) ckalloc(sizeof(ToplevelFocusInfo)); + tlFocusPtr->topLevelPtr = tlFocusPtr->focusWinPtr = winPtr; + tlFocusPtr->nextPtr = winPtr->mainPtr->tlFocusPtr; + winPtr->mainPtr->tlFocusPtr = tlFocusPtr; + } + newFocusPtr = tlFocusPtr->focusWinPtr; + + if (eventPtr->type == FocusIn) { + GenerateFocusEvents(displayFocusPtr->focusWinPtr, newFocusPtr); + displayFocusPtr->focusWinPtr = newFocusPtr; + dispPtr->focusPtr = newFocusPtr; + + /* + * NotifyPointer gets set when the focus has been set to the root window + * but we have the pointer. We'll treat this like an implicit + * focus in event so that upon Leave events we release focus. + */ + + if (!(winPtr->flags & TK_EMBEDDED)) { + if (eventPtr->xfocus.detail == NotifyPointer) { + dispPtr->implicitWinPtr = winPtr; + } else { + dispPtr->implicitWinPtr = NULL; + } + } + } else if (eventPtr->type == FocusOut) { + GenerateFocusEvents(displayFocusPtr->focusWinPtr, (TkWindow *) NULL); + + /* + * Reset dispPtr->focusPtr, but only if it currently is the same + * as this application's focusWinPtr: this check is needed to + * handle embedded applications in the same process. + */ + + if (dispPtr->focusPtr == displayFocusPtr->focusWinPtr) { + dispPtr->focusPtr = NULL; + } + displayFocusPtr->focusWinPtr = NULL; + } else if (eventPtr->type == EnterNotify) { + /* + * If there is no window manager, or if the window manager isn't + * moving the focus around (e.g. the disgusting "NoTitleFocus" + * option has been selected in twm), then we won't get FocusIn + * or FocusOut events. Instead, the "focus" field will be set + * in an Enter event to indicate that we've already got the focus + * when the mouse enters the window (even though we didn't get + * a FocusIn event). Watch for this and grab the focus when it + * happens. Note: if this is an embedded application then don't + * accept the focus implicitly like this; the container + * application will give us the focus explicitly if it wants us + * to have it. + */ + + if (eventPtr->xcrossing.focus && + (displayFocusPtr->focusWinPtr == NULL) + && !(winPtr->flags & TK_EMBEDDED)) { + if (tclFocusDebug) { + printf("Focussed implicitly on %s\n", + newFocusPtr->pathName); + } + + GenerateFocusEvents(displayFocusPtr->focusWinPtr, newFocusPtr); + displayFocusPtr->focusWinPtr = newFocusPtr; + dispPtr->implicitWinPtr = winPtr; + dispPtr->focusPtr = newFocusPtr; + } + } else if (eventPtr->type == LeaveNotify) { + /* + * If the pointer just left a window for which we automatically + * claimed the focus on enter, move the focus back to the root + * window, where it was before we claimed it above. Note: + * dispPtr->implicitWinPtr may not be the same as + * displayFocusPtr->focusWinPtr (e.g. because the "focus" + * command was used to redirect the focus after it arrived at + * dispPtr->implicitWinPtr)!! In addition, we generate events + * because the window manager won't give us a FocusOut event when + * we focus on the root. + */ + + if ((dispPtr->implicitWinPtr != NULL) + && !(winPtr->flags & TK_EMBEDDED)) { + if (tclFocusDebug) { + printf("Defocussed implicit Async\n"); + } + GenerateFocusEvents(displayFocusPtr->focusWinPtr, + (TkWindow *) NULL); + XSetInputFocus(dispPtr->display, PointerRoot, RevertToPointerRoot, + CurrentTime); + displayFocusPtr->focusWinPtr = NULL; + dispPtr->implicitWinPtr = NULL; + } + } + return retValue; +} + +/* + *---------------------------------------------------------------------- + * + * SetFocus -- + * + * This procedure is invoked to change the focus window for a + * given display in a given application. + * + * Results: + * None. + * + * Side effects: + * Event handlers may be invoked to process the change of + * focus. + * + *---------------------------------------------------------------------- + */ + +static void +SetFocus(winPtr, force) + TkWindow *winPtr; /* Window that is to be the new focus for + * its display and application. */ + int force; /* If non-zero, set the X focus to this + * window even if the application doesn't + * currently have the X focus. */ +{ + ToplevelFocusInfo *tlFocusPtr; + DisplayFocusInfo *displayFocusPtr; + TkWindow *topLevelPtr; + int allMapped, serial; + + displayFocusPtr = FindDisplayFocusInfo(winPtr->mainPtr, winPtr->dispPtr); + if (winPtr == displayFocusPtr->focusWinPtr) { + return; + } + + /* + * Find the top-level window for winPtr, then find (or create) + * a record for the top-level. Also see whether winPtr and all its + * ancestors are mapped. + */ + + allMapped = 1; + for (topLevelPtr = winPtr; ; topLevelPtr = topLevelPtr->parentPtr) { + if (topLevelPtr == NULL) { + /* + * The window is being deleted. No point in worrying about + * giving it the focus. + */ + return; + } + if (!(topLevelPtr->flags & TK_MAPPED)) { + allMapped = 0; + } + if (topLevelPtr->flags & TK_TOP_LEVEL) { + break; + } + } + + /* + * If the new focus window isn't mapped, then we can't focus on it + * (X will generate an error, for example). Instead, create an + * event handler that will set the focus to this window once it gets + * mapped. At the same time, delete any old handler that might be + * around; it's no longer relevant. + */ + + if (displayFocusPtr->focusOnMapPtr != NULL) { + Tk_DeleteEventHandler( + (Tk_Window) displayFocusPtr->focusOnMapPtr, + StructureNotifyMask, FocusMapProc, + (ClientData) displayFocusPtr->focusOnMapPtr); + displayFocusPtr->focusOnMapPtr = NULL; + } + if (!allMapped) { + Tk_CreateEventHandler((Tk_Window) winPtr, + VisibilityChangeMask, FocusMapProc, + (ClientData) winPtr); + displayFocusPtr->focusOnMapPtr = winPtr; + displayFocusPtr->forceFocus = force; + return; + } + + for (tlFocusPtr = winPtr->mainPtr->tlFocusPtr; tlFocusPtr != NULL; + tlFocusPtr = tlFocusPtr->nextPtr) { + if (tlFocusPtr->topLevelPtr == topLevelPtr) { + break; + } + } + if (tlFocusPtr == NULL) { + tlFocusPtr = (ToplevelFocusInfo *) ckalloc(sizeof(ToplevelFocusInfo)); + tlFocusPtr->topLevelPtr = topLevelPtr; + tlFocusPtr->nextPtr = winPtr->mainPtr->tlFocusPtr; + winPtr->mainPtr->tlFocusPtr = tlFocusPtr; + } + tlFocusPtr->focusWinPtr = winPtr; + + /* + * Reset the window system's focus window and generate focus events, + * with two special cases: + * + * 1. If the application is embedded and doesn't currently have the + * focus, don't set the focus directly. Instead, see if the + * embedding code can claim the focus from the enclosing + * container. + * 2. Otherwise, if the application doesn't currently have the + * focus, don't change the window system's focus unless it was + * already in this application or "force" was specified. + */ + + if ((topLevelPtr->flags & TK_EMBEDDED) + && (displayFocusPtr->focusWinPtr == NULL)) { + TkpClaimFocus(topLevelPtr, force); + } else if ((displayFocusPtr->focusWinPtr != NULL) || force) { + /* + * Generate events to shift focus between Tk windows. + * We do this regardless of what TkpChangeFocus does with + * the real X focus so that Tk widgets track focus commands + * when there is no window manager. GenerateFocusEvents will + * set up a serial number marker so we discard focus events + * that are triggered by the ChangeFocus. + */ + + serial = TkpChangeFocus(TkpGetWrapperWindow(topLevelPtr), force); + if (serial != 0) { + displayFocusPtr->focusSerial = serial; + } + GenerateFocusEvents(displayFocusPtr->focusWinPtr, winPtr); + displayFocusPtr->focusWinPtr = winPtr; + winPtr->dispPtr->focusPtr = winPtr; + } +} + +/* + *---------------------------------------------------------------------- + * + * TkGetFocusWin -- + * + * Given a window, this procedure returns the current focus + * window for its application and display. + * + * Results: + * The return value is a pointer to the window that currently + * has the input focus for the specified application and + * display, or NULL if none. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +TkWindow * +TkGetFocusWin(winPtr) + TkWindow *winPtr; /* Window that selects an application + * and a display. */ +{ + DisplayFocusInfo *displayFocusPtr; + + if (winPtr == NULL) { + return (TkWindow *) NULL; + } + + displayFocusPtr = FindDisplayFocusInfo(winPtr->mainPtr, winPtr->dispPtr); + return displayFocusPtr->focusWinPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TkFocusKeyEvent -- + * + * Given a window and a key press or release event that arrived for + * the window, use information about the keyboard focus to compute + * which window should really get the event. In addition, update + * the event to refer to its new window. + * + * Results: + * The return value is a pointer to the window that has the input + * focus in winPtr's application, or NULL if winPtr's application + * doesn't have the input focus. If a non-NULL value is returned, + * eventPtr will be updated to refer properly to the focus window. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +TkWindow * +TkFocusKeyEvent(winPtr, eventPtr) + TkWindow *winPtr; /* Window that selects an application + * and a display. */ + XEvent *eventPtr; /* X event to redirect (should be KeyPress + * or KeyRelease). */ +{ + DisplayFocusInfo *displayFocusPtr; + TkWindow *focusWinPtr; + int focusX, focusY, vRootX, vRootY, vRootWidth, vRootHeight; + + displayFocusPtr = FindDisplayFocusInfo(winPtr->mainPtr, winPtr->dispPtr); + focusWinPtr = displayFocusPtr->focusWinPtr; + + /* + * The code below is a debugging aid to make sure that dispPtr->focusPtr + * is kept properly in sync with the "truth", which is the value in + * displayFocusPtr->focusWinPtr. + */ + +#ifdef TCL_MEM_DEBUG + if (focusWinPtr != winPtr->dispPtr->focusPtr) { + printf("TkFocusKeyEvent found dispPtr->focusPtr out of sync:\n"); + printf("expected %s, got %s\n", + (focusWinPtr != NULL) ? focusWinPtr->pathName : "??", + (winPtr->dispPtr->focusPtr != NULL) ? + winPtr->dispPtr->focusPtr->pathName : "??"); + } +#endif + + if ((focusWinPtr != NULL) && (focusWinPtr->mainPtr == winPtr->mainPtr)) { + /* + * Map the x and y coordinates to make sense in the context of + * the focus window, if possible (make both -1 if the map-from + * and map-to windows don't share the same screen). + */ + + if ((focusWinPtr->display != winPtr->display) + || (focusWinPtr->screenNum != winPtr->screenNum)) { + eventPtr->xkey.x = -1; + eventPtr->xkey.y = -1; + } else { + Tk_GetVRootGeometry((Tk_Window) focusWinPtr, &vRootX, &vRootY, + &vRootWidth, &vRootHeight); + Tk_GetRootCoords((Tk_Window) focusWinPtr, &focusX, &focusY); + eventPtr->xkey.x = eventPtr->xkey.x_root - vRootX - focusX; + eventPtr->xkey.y = eventPtr->xkey.y_root - vRootY - focusY; + } + eventPtr->xkey.window = focusWinPtr->window; + return focusWinPtr; + } + + /* + * The event doesn't belong to us. Perhaps, due to embedding, it + * really belongs to someone else. Give the embedding code a chance + * to redirect the event. + */ + + TkpRedirectKeyEvent(winPtr, eventPtr); + return (TkWindow *) NULL; +} + +/* + *---------------------------------------------------------------------- + * + * TkFocusDeadWindow -- + * + * This procedure is invoked when it is determined that + * a window is dead. It cleans up focus-related information + * about the window. + * + * Results: + * None. + * + * Side effects: + * Various things get cleaned up and recycled. + * + *---------------------------------------------------------------------- + */ + +void +TkFocusDeadWindow(winPtr) + register TkWindow *winPtr; /* Information about the window + * that is being deleted. */ +{ + ToplevelFocusInfo *tlFocusPtr, *prevPtr; + DisplayFocusInfo *displayFocusPtr; + TkDisplay *dispPtr = winPtr->dispPtr; + + /* + * Search for focus records that refer to this window either as + * the top-level window or the current focus window. + */ + + displayFocusPtr = FindDisplayFocusInfo(winPtr->mainPtr, winPtr->dispPtr); + for (prevPtr = NULL, tlFocusPtr = winPtr->mainPtr->tlFocusPtr; + tlFocusPtr != NULL; + prevPtr = tlFocusPtr, tlFocusPtr = tlFocusPtr->nextPtr) { + if (winPtr == tlFocusPtr->topLevelPtr) { + /* + * The top-level window is the one being deleted: free + * the focus record and release the focus back to PointerRoot + * if we acquired it implicitly. + */ + + if (dispPtr->implicitWinPtr == winPtr) { + if (tclFocusDebug) { + printf("releasing focus to root after %s died\n", + tlFocusPtr->topLevelPtr->pathName); + } + dispPtr->implicitWinPtr = NULL; + displayFocusPtr->focusWinPtr = NULL; + dispPtr->focusPtr = NULL; + } + if (displayFocusPtr->focusWinPtr == tlFocusPtr->focusWinPtr) { + displayFocusPtr->focusWinPtr = NULL; + dispPtr->focusPtr = NULL; + } + if (prevPtr == NULL) { + winPtr->mainPtr->tlFocusPtr = tlFocusPtr->nextPtr; + } else { + prevPtr->nextPtr = tlFocusPtr->nextPtr; + } + ckfree((char *) tlFocusPtr); + break; + } else if (winPtr == tlFocusPtr->focusWinPtr) { + /* + * The deleted window had the focus for its top-level: + * move the focus to the top-level itself. + */ + + tlFocusPtr->focusWinPtr = tlFocusPtr->topLevelPtr; + if ((displayFocusPtr->focusWinPtr == winPtr) + && !(tlFocusPtr->topLevelPtr->flags & TK_ALREADY_DEAD)) { + if (tclFocusDebug) { + printf("forwarding focus to %s after %s died\n", + tlFocusPtr->topLevelPtr->pathName, + winPtr->pathName); + } + GenerateFocusEvents(displayFocusPtr->focusWinPtr, + tlFocusPtr->topLevelPtr); + displayFocusPtr->focusWinPtr = tlFocusPtr->topLevelPtr; + dispPtr->focusPtr = tlFocusPtr->topLevelPtr; + } + break; + } + } + + if (displayFocusPtr->focusOnMapPtr == winPtr) { + displayFocusPtr->focusOnMapPtr = NULL; + } +} + +/* + *---------------------------------------------------------------------- + * + * GenerateFocusEvents -- + * + * This procedure is called to create FocusIn and FocusOut events to + * move the input focus from one window to another. + * + * Results: + * None. + * + * Side effects: + * FocusIn and FocusOut events are generated. + * + *---------------------------------------------------------------------- + */ + +static void +GenerateFocusEvents(sourcePtr, destPtr) + TkWindow *sourcePtr; /* Window that used to have the focus (may + * be NULL). */ + TkWindow *destPtr; /* New window to have the focus (may be + * NULL). */ + +{ + XEvent event; + TkWindow *winPtr; + + winPtr = sourcePtr; + if (winPtr == NULL) { + winPtr = destPtr; + if (winPtr == NULL) { + return; + } + } + + event.xfocus.serial = LastKnownRequestProcessed(winPtr->display); + event.xfocus.send_event = GENERATED_EVENT_MAGIC; + event.xfocus.display = winPtr->display; + event.xfocus.mode = NotifyNormal; + TkInOutEvents(&event, sourcePtr, destPtr, FocusOut, FocusIn, + TCL_QUEUE_MARK); +} + +/* + *---------------------------------------------------------------------- + * + * FocusMapProc -- + * + * This procedure is called as an event handler for VisibilityNotify + * events, if a window receives the focus at a time when its + * toplevel isn't mapped. The procedure is needed because X + * won't allow the focus to be set to an unmapped window; we + * detect when the toplevel is mapped and set the focus to it then. + * + * Results: + * None. + * + * Side effects: + * If this is a map event, the focus gets set to the toplevel + * given by clientData. + * + *---------------------------------------------------------------------- + */ + +static void +FocusMapProc(clientData, eventPtr) + ClientData clientData; /* Toplevel window. */ + XEvent *eventPtr; /* Information about event. */ +{ + TkWindow *winPtr = (TkWindow *) clientData; + DisplayFocusInfo *displayFocusPtr; + + if (eventPtr->type == VisibilityNotify) { + displayFocusPtr = FindDisplayFocusInfo(winPtr->mainPtr, + winPtr->dispPtr); + if (tclFocusDebug) { + printf("auto-focussing on %s, force %d\n", winPtr->pathName, + displayFocusPtr->forceFocus); + } + Tk_DeleteEventHandler((Tk_Window) winPtr, VisibilityChangeMask, + FocusMapProc, clientData); + displayFocusPtr->focusOnMapPtr = NULL; + SetFocus(winPtr, displayFocusPtr->forceFocus); + } +} + +/* + *---------------------------------------------------------------------- + * + * FindDisplayFocusInfo -- + * + * Given an application and a display, this procedure locate the + * focus record for that combination. If no such record exists, + * it creates a new record and initializes it. + * + * Results: + * The return value is a pointer to the record. + * + * Side effects: + * A new record will be allocated if there wasn't one already. + * + *---------------------------------------------------------------------- + */ + +static DisplayFocusInfo * +FindDisplayFocusInfo(mainPtr, dispPtr) + TkMainInfo *mainPtr; /* Record that identifies a particular + * application. */ + TkDisplay *dispPtr; /* Display whose focus information is + * needed. */ +{ + DisplayFocusInfo *displayFocusPtr; + + for (displayFocusPtr = mainPtr->displayFocusPtr; + displayFocusPtr != NULL; + displayFocusPtr = displayFocusPtr->nextPtr) { + if (displayFocusPtr->dispPtr == dispPtr) { + return displayFocusPtr; + } + } + + /* + * The record doesn't exist yet. Make a new one. + */ + + displayFocusPtr = (DisplayFocusInfo *) ckalloc(sizeof(DisplayFocusInfo)); + displayFocusPtr->dispPtr = dispPtr; + displayFocusPtr->focusWinPtr = NULL; + displayFocusPtr->focusOnMapPtr = NULL; + displayFocusPtr->forceFocus = 0; + displayFocusPtr->focusSerial = 0; + displayFocusPtr->nextPtr = mainPtr->displayFocusPtr; + mainPtr->displayFocusPtr = displayFocusPtr; + return displayFocusPtr; +} diff --git a/generic/tkFont.c b/generic/tkFont.c new file mode 100644 index 0000000..11929b6 --- /dev/null +++ b/generic/tkFont.c @@ -0,0 +1,3008 @@ +/* + * tkFont.c -- + * + * This file maintains a database of fonts for the Tk toolkit. + * It also provides several utility procedures for measuring and + * displaying text. + * + * 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: @(#) tkFont.c 1.74 97/10/10 14:34:11 + */ + +#include "tkInt.h" +#include "tkFont.h" + +/* + * The following structure is used to keep track of all the fonts that + * exist in the current application. It must be stored in the + * TkMainInfo for the application. + */ + +typedef struct TkFontInfo { + Tcl_HashTable fontCache; /* Map a string to an existing Tk_Font. + * Keys are CachedFontKey structs, values are + * TkFont structs. */ + 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. */ + TkMainInfo *mainPtr; /* Application that owns this structure. */ + int updatePending; +} 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. + */ + +typedef struct NamedFont { + int refCount; /* Number of users of named font. */ + int deletePending; /* Non-zero if font should be deleted when + * last reference goes away. */ + TkFontAttributes fa; /* Desired attributes for named font. */ +} NamedFont; + +/* + * The following two structures are used to keep track of string + * measurement information when using the text layout facilities. + * + * A LayoutChunk represents a contiguous range of text that can be measured + * and displayed by low-level text calls. In general, chunks will be + * delimited by newlines and tabs. Low-level, platform-specific things + * like kerning and non-integer character widths may occur between the + * characters in a single chunk, but not between characters in different + * chunks. + * + * A TextLayout is a collection of LayoutChunks. It can be displayed with + * respect to any origin. It is the implementation of the Tk_TextLayout + * opaque token. + */ + +typedef struct LayoutChunk { + CONST char *start; /* Pointer to simple string to be displayed. + * This is a pointer into the TkTextLayout's + * string. */ + int numChars; /* The number of characters in this chunk. */ + int numDisplayChars; /* The number of characters to display when + * this chunk is displayed. Can be less than + * numChars if extra space characters were + * absorbed by the end of the chunk. This + * will be < 0 if this is a chunk that is + * holding a tab or newline. */ + int x, y; /* The origin of the first character in this + * chunk with respect to the upper-left hand + * corner of the TextLayout. */ + int totalWidth; /* Width in pixels of this chunk. Used + * when hit testing the invisible spaces at + * the end of a chunk. */ + int displayWidth; /* Width in pixels of the displayable + * characters in this chunk. Can be less than + * width if extra space characters were + * absorbed by the end of the chunk. */ +} LayoutChunk; + +typedef struct TextLayout { + Tk_Font tkfont; /* The font used when laying out the text. */ + CONST char *string; /* The string that was layed out. */ + int width; /* The maximum width of all lines in the + * text layout. */ + int numChunks; /* Number of chunks actually used in + * following array. */ + LayoutChunk chunks[1]; /* Array of chunks. The actual size will + * be maxChunks. THIS FIELD MUST BE THE LAST + * IN THE STRUCTURE. */ +} TextLayout; + +/* + * The following structures are used as two-way maps between the values for + * the fields in the TkFontAttributes structure and the strings used in + * Tcl, when parsing both option-value format and style-list format font + * name strings. + */ + +static TkStateMap weightMap[] = { + {TK_FW_NORMAL, "normal"}, + {TK_FW_BOLD, "bold"}, + {TK_FW_UNKNOWN, NULL} +}; + +static TkStateMap slantMap[] = { + {TK_FS_ROMAN, "roman"}, + {TK_FS_ITALIC, "italic"}, + {TK_FS_UNKNOWN, NULL} +}; + +static TkStateMap underlineMap[] = { + {1, "underline"}, + {0, NULL} +}; + +static TkStateMap overstrikeMap[] = { + {1, "overstrike"}, + {0, NULL} +}; + +/* + * The following structures are used when parsing XLFD's into a set of + * TkFontAttributes. + */ + +static TkStateMap xlfdWeightMap[] = { + {TK_FW_NORMAL, "normal"}, + {TK_FW_NORMAL, "medium"}, + {TK_FW_NORMAL, "book"}, + {TK_FW_NORMAL, "light"}, + {TK_FW_BOLD, "bold"}, + {TK_FW_BOLD, "demi"}, + {TK_FW_BOLD, "demibold"}, + {TK_FW_NORMAL, NULL} /* Assume anything else is "normal". */ +}; + +static TkStateMap xlfdSlantMap[] = { + {TK_FS_ROMAN, "r"}, + {TK_FS_ITALIC, "i"}, + {TK_FS_OBLIQUE, "o"}, + {TK_FS_ROMAN, NULL} /* Assume anything else is "roman". */ +}; + +static TkStateMap xlfdSetwidthMap[] = { + {TK_SW_NORMAL, "normal"}, + {TK_SW_CONDENSE, "narrow"}, + {TK_SW_CONDENSE, "semicondensed"}, + {TK_SW_CONDENSE, "condensed"}, + {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. + */ + +static char *fontOpt[] = { + "-family", + "-size", + "-weight", + "-slant", + "-underline", + "-overstrike", + NULL +}; + +#define FONT_FAMILY 0 +#define FONT_SIZE 1 +#define FONT_WEIGHT 2 +#define FONT_SLANT 3 +#define FONT_UNDERLINE 4 +#define FONT_OVERSTRIKE 5 +#define FONT_NUMFIELDS 6 /* Length of fontOpt array. */ + +#define GetFontAttributes(tkfont) \ + ((CONST TkFontAttributes *) &((TkFont *) (tkfont))->fa) + +#define GetFontMetrics(tkfont) \ + ((CONST TkFontMetrics *) &((TkFont *) (tkfont))->fm) + + +static int ConfigAttributesObj _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, int objc, Tcl_Obj *CONST objv[], + TkFontAttributes *faPtr)); +static int FieldSpecified _ANSI_ARGS_((CONST char *field)); +static int GetAttributeInfoObj _ANSI_ARGS_((Tcl_Interp *interp, + CONST TkFontAttributes *faPtr, Tcl_Obj *objPtr)); +static LayoutChunk * NewChunk _ANSI_ARGS_((TextLayout **layoutPtrPtr, + int *maxPtr, CONST char *start, int numChars, + int curX, int newX, int y)); +static int ParseFontNameObj _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, Tcl_Obj *objPtr, + TkFontAttributes *faPtr)); +static void RecomputeWidgets _ANSI_ARGS_((TkWindow *winPtr)); +static void TheWorldHasChanged _ANSI_ARGS_(( + ClientData clientData)); +static void UpdateDependantFonts _ANSI_ARGS_((TkFontInfo *fiPtr, + Tk_Window tkwin, Tcl_HashEntry *namedHashPtr)); + + + + +/* + *--------------------------------------------------------------------------- + * + * TkFontPkgInit -- + * + * This procedure is called when an application is created. It + * initializes all the structures that are used by the font + * package on a per application basis. + * + * Results: + * Returns a token that must be stored in the TkMainInfo for this + * application. + * + * Side effects: + * Memory allocated. + * + *--------------------------------------------------------------------------- + */ +void +TkFontPkgInit(mainPtr) + TkMainInfo *mainPtr; /* The application being created. */ +{ + TkFontInfo *fiPtr; + + fiPtr = (TkFontInfo *) ckalloc(sizeof(TkFontInfo)); + Tcl_InitHashTable(&fiPtr->fontCache, sizeof(CachedFontKey) / sizeof(int)); + Tcl_InitHashTable(&fiPtr->namedTable, TCL_ONE_WORD_KEYS); + fiPtr->mainPtr = mainPtr; + fiPtr->updatePending = 0; + mainPtr->fontInfoPtr = fiPtr; +} + +/* + *--------------------------------------------------------------------------- + * + * TkFontPkgFree -- + * + * This procedure is called when an application is deleted. It + * deletes all the structures that were used by the font package + * for this application. + * + * Results: + * None. + * + * Side effects: + * Memory freed. + * + *--------------------------------------------------------------------------- + */ + +void +TkFontPkgFree(mainPtr) + TkMainInfo *mainPtr; /* The application being deleted. */ +{ + TkFontInfo *fiPtr; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + + fiPtr = mainPtr->fontInfoPtr; + + if (fiPtr->fontCache.numEntries != 0) { + panic("TkFontPkgFree: all fonts should have been freed already"); + } + Tcl_DeleteHashTable(&fiPtr->fontCache); + + hPtr = Tcl_FirstHashEntry(&fiPtr->namedTable, &search); + while (hPtr != NULL) { + ckfree((char *) Tcl_GetHashValue(hPtr)); + hPtr = Tcl_NextHashEntry(&search); + } + Tcl_DeleteHashTable(&fiPtr->namedTable); + if (fiPtr->updatePending != 0) { + Tcl_CancelIdleCall(TheWorldHasChanged, (ClientData) fiPtr); + } + ckfree((char *) fiPtr); +} + +/* + *--------------------------------------------------------------------------- + * + * Tk_FontObjCmd -- + * + * This procedure is implemented to process the "font" 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_FontObjCmd(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. */ +{ + int index; + Tk_Window tkwin; + TkFontInfo *fiPtr; + static char *optionStrings[] = { + "actual", "configure", "create", "delete", + "families", "measure", "metrics", "names", + NULL + }; + enum options { + FONT_ACTUAL, FONT_CONFIGURE, FONT_CREATE, FONT_DELETE, + FONT_FAMILIES, FONT_MEASURE, FONT_METRICS, FONT_NAMES + }; + + tkwin = (Tk_Window) clientData; + fiPtr = ((TkWindow *) tkwin)->mainPtr->fontInfoPtr; + + 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 FONT_ACTUAL: { + int skip, result; + Tk_Font tkfont; + Tcl_Obj *objPtr; + CONST TkFontAttributes *faPtr; + + skip = TkGetDisplayOf(interp, objc - 3, objv + 3, &tkwin); + if (skip < 0) { + return TCL_ERROR; + } + if ((objc < 3) || (objc - skip > 4)) { + Tcl_WrongNumArgs(interp, 2, objv, + "font ?-displayof window? ?option?"); + return TCL_ERROR; + } + tkfont = Tk_GetFontFromObj(interp, tkwin, objv[2]); + if (tkfont == NULL) { + return TCL_ERROR; + } + objc -= skip; + objv += skip; + faPtr = GetFontAttributes(tkfont); + objPtr = NULL; + if (objc > 3) { + objPtr = objv[3]; + } + result = GetAttributeInfoObj(interp, faPtr, objPtr); + Tk_FreeFont(tkfont); + return result; + } + case FONT_CONFIGURE: { + int result; + char *string; + Tcl_Obj *objPtr; + NamedFont *nfPtr; + Tcl_HashEntry *namedHashPtr; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "fontname ?options?"); + return TCL_ERROR; + } + string = Tk_GetUid(Tcl_GetStringFromObj(objv[2], NULL)); + 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, + "\" doesn't exist", NULL); + return TCL_ERROR; + } + if (objc == 3) { + objPtr = NULL; + } else if (objc == 4) { + objPtr = objv[3]; + } else { + result = ConfigAttributesObj(interp, tkwin, objc - 3, + objv + 3, &nfPtr->fa); + UpdateDependantFonts(fiPtr, tkwin, namedHashPtr); + return result; + } + return GetAttributeInfoObj(interp, &nfPtr->fa, objPtr); + } + case FONT_CREATE: { + int skip, i; + char *name; + char buf[32]; + TkFontAttributes fa; + Tcl_HashEntry *namedHashPtr; + + skip = 3; + if (objc < 3) { + name = NULL; + } else { + name = Tcl_GetStringFromObj(objv[2], NULL); + if (name[0] == '-') { + name = NULL; + } + } + if (name == NULL) { + /* + * No font name specified. Generate one of the form "fontX". + */ + + for (i = 1; ; i++) { + sprintf(buf, "font%d", i); + namedHashPtr = Tcl_FindHashEntry(&fiPtr->namedTable, + Tk_GetUid(buf)); + if (namedHashPtr == NULL) { + break; + } + } + name = buf; + skip = 2; + } + TkInitFontAttributes(&fa); + if (ConfigAttributesObj(interp, tkwin, objc - skip, objv + skip, + &fa) != TCL_OK) { + return TCL_ERROR; + } + if (TkCreateNamedFont(interp, tkwin, name, &fa) != TCL_OK) { + return TCL_ERROR; + } + Tcl_SetStringObj(Tcl_GetObjResult(interp), name, -1); + break; + } + case FONT_DELETE: { + int i; + char *string; + NamedFont *nfPtr; + Tcl_HashEntry *namedHashPtr; + + /* + * Delete the named font. If there are still widgets using this + * font, then it isn't deleted right away. + */ + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "fontname ?fontname ...?"); + return TCL_ERROR; + } + for (i = 2; i < objc; i++) { + string = Tk_GetUid(Tcl_GetStringFromObj(objv[i], NULL)); + namedHashPtr = Tcl_FindHashEntry(&fiPtr->namedTable, string); + if (namedHashPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "named font \"", string, + "\" doesn't exist", (char *) NULL); + return TCL_ERROR; + } + nfPtr = (NamedFont *) Tcl_GetHashValue(namedHashPtr); + if (nfPtr->refCount != 0) { + nfPtr->deletePending = 1; + } else { + Tcl_DeleteHashEntry(namedHashPtr); + ckfree((char *) nfPtr); + } + } + break; + } + case FONT_FAMILIES: { + int skip; + + skip = TkGetDisplayOf(interp, objc - 2, objv + 2, &tkwin); + if (skip < 0) { + return TCL_ERROR; + } + if (objc - skip != 2) { + Tcl_WrongNumArgs(interp, 2, objv, "?-displayof window?"); + return TCL_ERROR; + } + TkpGetFontFamilies(interp, tkwin); + break; + } + case FONT_MEASURE: { + char *string; + Tk_Font tkfont; + int length, skip; + + skip = TkGetDisplayOf(interp, objc - 3, objv + 3, &tkwin); + if (skip < 0) { + return TCL_ERROR; + } + if (objc - skip != 4) { + Tcl_WrongNumArgs(interp, 2, objv, + "font ?-displayof window? text"); + return TCL_ERROR; + } + tkfont = Tk_GetFontFromObj(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)); + Tk_FreeFont(tkfont); + break; + } + case FONT_METRICS: { + char buf[64]; + Tk_Font tkfont; + int skip, index, i; + CONST TkFontMetrics *fmPtr; + static char *switches[] = { + "-ascent", "-descent", "-linespace", "-fixed", NULL + }; + + skip = TkGetDisplayOf(interp, objc - 3, objv + 3, &tkwin); + if (skip < 0) { + return TCL_ERROR; + } + if ((objc < 3) || ((objc - skip) > 4)) { + Tcl_WrongNumArgs(interp, 2, objv, + "font ?-displayof window? ?option?"); + return TCL_ERROR; + } + tkfont = Tk_GetFontFromObj(interp, tkwin, objv[2]); + if (tkfont == NULL) { + return TCL_ERROR; + } + objc -= skip; + objv += skip; + fmPtr = GetFontMetrics(tkfont); + if (objc == 3) { + 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); + } else { + if (Tcl_GetIndexFromObj(interp, objv[3], switches, + "metric", 0, &index) != TCL_OK) { + Tk_FreeFont(tkfont); + return TCL_ERROR; + } + i = 0; /* Needed only to prevent compiler + * warning. */ + switch (index) { + case 0: i = fmPtr->ascent; break; + case 1: i = fmPtr->descent; break; + case 2: i = fmPtr->ascent + fmPtr->descent; break; + case 3: i = fmPtr->fixed; break; + } + Tcl_SetIntObj(Tcl_GetObjResult(interp), i); + } + Tk_FreeFont(tkfont); + break; + } + case FONT_NAMES: { + char *string; + Tcl_Obj *strPtr; + NamedFont *nfPtr; + Tcl_HashSearch search; + Tcl_HashEntry *namedHashPtr; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "names"); + return TCL_ERROR; + } + 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); + } + namedHashPtr = Tcl_NextHashEntry(&search); + } + break; + } + } + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * UpdateDependantFonts, TheWorldHasChanged, RecomputeWidgets -- + * + * Called when the attributes of a named font changes. Updates all + * the instantiated fonts that depend on that named font and then + * uses the brute force approach and prepares every widget to + * recompute its geometry. + * + * Results: + * None. + * + * Side effects: + * Things get queued for redisplay. + * + *--------------------------------------------------------------------------- + */ + +static void +UpdateDependantFonts(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. */ +{ + Tcl_HashEntry *cacheHashPtr; + Tcl_HashSearch search; + TkFont *fontPtr; + NamedFont *nfPtr; + + nfPtr = (NamedFont *) Tcl_GetHashValue(namedHashPtr); + if (nfPtr->refCount == 0) { + /* + * Well nobody's using this named font, so don't have to tell + * any widgets to recompute themselves. + */ + + 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); + } + } + cacheHashPtr = Tcl_NextHashEntry(&search); + } +} + +static void +TheWorldHasChanged(clientData) + ClientData clientData; /* Info about application's fonts. */ +{ + TkFontInfo *fiPtr; + + fiPtr = (TkFontInfo *) clientData; + fiPtr->updatePending = 0; + + RecomputeWidgets(fiPtr->mainPtr->winPtr); +} + +static void +RecomputeWidgets(winPtr) + TkWindow *winPtr; /* Window to which command is sent. */ +{ + if ((winPtr->classProcsPtr != NULL) + && (winPtr->classProcsPtr->geometryProc != NULL)) { + (*winPtr->classProcsPtr->geometryProc)(winPtr->instanceData); + } + for (winPtr = winPtr->childList; winPtr != NULL; winPtr = winPtr->nextPtr) { + RecomputeWidgets(winPtr); + } +} + +/* + *--------------------------------------------------------------------------- + * + * TkCreateNamedFont -- + * + * Create the specified named font with the given attributes in the + * named font table associated with the interp. + * + * 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. + * + * Side effects: + * Assume there used to exist a named font by the specified name, and + * that the named font had been deleted, but there were still some + * widgets using the named font at the time it was deleted. If a + * new named font is created with the same name, all those widgets + * that were using the old named font will be redisplayed using + * the new named font's attributes. + * + *--------------------------------------------------------------------------- + */ + +int +TkCreateNamedFont(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. */ + TkFontAttributes *faPtr; /* Attributes for the new named font. */ +{ + TkFontInfo *fiPtr; + Tcl_HashEntry *namedHashPtr; + int new; + NamedFont *nfPtr; + + 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, + "\" already exists", (char *) NULL); + return TCL_ERROR; + } + + /* + * Recreating a named font with the same name as a previous + * named font. Some widgets were still using that named + * font, so they need to get redisplayed. + */ + + nfPtr->fa = *faPtr; + nfPtr->deletePending = 0; + UpdateDependantFonts(fiPtr, tkwin, namedHashPtr); + return TCL_OK; + } + + nfPtr = (NamedFont *) ckalloc(sizeof(NamedFont)); + nfPtr->deletePending = 0; + Tcl_SetHashValue(namedHashPtr, nfPtr); + nfPtr->fa = *faPtr; + nfPtr->refCount = 0; + nfPtr->deletePending = 0; + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * Tk_GetFont -- + * + * Given a string description of a font, map the description to a + * corresponding Tk_Font that represents the font. + * + * 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. + * + * 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. + * + *--------------------------------------------------------------------------- + */ + +Tk_Font +Tk_GetFont(interp, tkwin, string) + Tcl_Interp *interp; /* Interp for database and error return. */ + Tk_Window tkwin; /* For display on which font will be used. */ + CONST char *string; /* String describing font, as: named font, + * native format, or parseable string. */ +{ + 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 */ + return tkfont; +} + +/* + *--------------------------------------------------------------------------- + * + * Tk_GetFontFromObj -- + * + * Given a string description of a font, map the description to a + * corresponding Tk_Font that represents the font. + * + * 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's result object. + * + * 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. + * + *--------------------------------------------------------------------------- + */ + +Tk_Font +Tk_GetFontFromObj(interp, tkwin, objPtr) + Tcl_Interp *interp; /* Interp for database and error return. */ + Tk_Window tkwin; /* For display 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; + int new, descent; + NamedFont *nfPtr; + char *string; + + fiPtr = ((TkWindow *) tkwin)->mainPtr->fontInfoPtr; + string = Tcl_GetStringFromObj(objPtr, NULL); + + key.display = Tk_Display(tkwin); + key.string = Tk_GetUid(string); + cacheHashPtr = Tcl_CreateHashEntry(&fiPtr->fontCache, (char *) &key, &new); + + if (new == 0) { + /* + * We have already constructed a font with this description for + * this display. Bump the reference count of the cached font. + */ + + fontPtr = (TkFont *) Tcl_GetHashValue(cacheHashPtr); + fontPtr->refCount++; + return (Tk_Font) fontPtr; + } + + namedHashPtr = Tcl_FindHashEntry(&fiPtr->namedTable, key.string); + if (namedHashPtr != NULL) { + /* + * Construct a font based on a named font. + */ + + nfPtr = (NamedFont *) Tcl_GetHashValue(namedHashPtr); + nfPtr->refCount++; + + fontPtr = TkpGetFontFromAttributes(NULL, tkwin, &nfPtr->fa); + } else { + /* + * Native font? + */ + + fontPtr = TkpGetNativeFont(tkwin, string); + if (fontPtr == NULL) { + TkFontAttributes fa; + + TkInitFontAttributes(&fa); + if (ParseFontNameObj(interp, tkwin, objPtr, &fa) != TCL_OK) { + Tcl_DeleteHashEntry(cacheHashPtr); + return NULL; + } + + /* + * String contained the attributes inline. + */ + + fontPtr = TkpGetFontFromAttributes(NULL, tkwin, &fa); + } + } + Tcl_SetHashValue(cacheHashPtr, fontPtr); + + fontPtr->refCount = 1; + fontPtr->cacheHashPtr = cacheHashPtr; + fontPtr->namedHashPtr = namedHashPtr; + + Tk_MeasureChars((Tk_Font) fontPtr, "0", 1, 0, 0, &fontPtr->tabWidth); + if (fontPtr->tabWidth == 0) { + fontPtr->tabWidth = fontPtr->fm.maxWidth; + } + fontPtr->tabWidth *= 8; + + /* + * Make sure the tab width isn't zero (some fonts may not have enough + * information to set a reasonable tab width). + */ + + if (fontPtr->tabWidth == 0) { + fontPtr->tabWidth = 1; + } + + /* + * Get information used for drawing underlines in generic code on a + * non-underlined font. + */ + + descent = fontPtr->fm.descent; + fontPtr->underlinePos = descent / 2; + fontPtr->underlineHeight = fontPtr->fa.pointsize / 10; + if (fontPtr->underlineHeight == 0) { + fontPtr->underlineHeight = 1; + } + if (fontPtr->underlinePos + fontPtr->underlineHeight > descent) { + /* + * If this set of values would cause the bottom of the underline + * bar to stick below the descent of the font, jack the underline + * up a bit higher. + */ + + fontPtr->underlineHeight = descent - fontPtr->underlinePos; + if (fontPtr->underlineHeight == 0) { + fontPtr->underlinePos--; + fontPtr->underlineHeight = 1; + } + } + + return (Tk_Font) fontPtr; +} + +/* + *--------------------------------------------------------------------------- + * + * Tk_NameOfFont -- + * + * Given a font, return a textual string identifying it. + * + * Results: + * The return value is the description that was passed to + * Tk_GetFont() to create the font. The storage for the returned + * string is only guaranteed to persist until the font is deleted. + * The caller should not modify this string. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +char * +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; +} + +/* + *--------------------------------------------------------------------------- + * + * Tk_FreeFont -- + * + * Called to release a font allocated by Tk_GetFont(). + * + * Results: + * None. + * + * Side effects: + * The reference count associated with font is decremented, and + * only deallocated when no one is using it. + * + *--------------------------------------------------------------------------- + */ + +void +Tk_FreeFont(tkfont) + Tk_Font tkfont; /* Font to be released. */ +{ + TkFont *fontPtr; + 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. + */ + + nfPtr = (NamedFont *) Tcl_GetHashValue(fontPtr->namedHashPtr); + nfPtr->refCount--; + if ((nfPtr->refCount == 0) && (nfPtr->deletePending != 0)) { + Tcl_DeleteHashEntry(fontPtr->namedHashPtr); + ckfree((char *) nfPtr); + } + } + Tcl_DeleteHashEntry(fontPtr->cacheHashPtr); + TkpDeleteFont(fontPtr); + } +} + +/* + *--------------------------------------------------------------------------- + * + * Tk_FontId -- + * + * Given a font, return an opaque handle that should be selected + * into the XGCValues structure in order to get the constructed + * gc to use this font. This procedure would go away if the + * XGCValues structure were replaced with a TkGCValues structure. + * + * Results: + * As above. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +Font +Tk_FontId(tkfont) + Tk_Font tkfont; /* Font that is going to be selected into GC. */ +{ + TkFont *fontPtr; + + fontPtr = (TkFont *) tkfont; + return fontPtr->fid; +} + +/* + *--------------------------------------------------------------------------- + * + * Tk_GetFontMetrics -- + * + * Returns overall ascent and descent metrics for the given font. + * These values can be used to space multiple lines of text and + * to align the baselines of text in different fonts. + * + * Results: + * If *heightPtr is non-NULL, it is filled with the overall height + * of the font, which is the sum of the ascent and descent. + * If *ascentPtr or *descentPtr is non-NULL, they are filled with + * the ascent and/or descent information for the font. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ +void +Tk_GetFontMetrics(tkfont, fmPtr) + Tk_Font tkfont; /* Font in which metrics are calculated. */ + Tk_FontMetrics *fmPtr; /* Pointer to structure in which font + * metrics for tkfont will be stored. */ +{ + TkFont *fontPtr; + + fontPtr = (TkFont *) tkfont; + fmPtr->ascent = fontPtr->fm.ascent; + fmPtr->descent = fontPtr->fm.descent; + fmPtr->linespace = fontPtr->fm.ascent + fontPtr->fm.descent; +} + +/* + *--------------------------------------------------------------------------- + * + * Tk_PostscriptFontName -- + * + * Given a Tk_Font, return the name of the corresponding Postscript + * font. + * + * Results: + * The return value is the pointsize of the given Tk_Font. + * The name of the Postscript font is appended to dsPtr. + * + * Side effects: + * If the font does not exist on the printer, the print job will + * fail at print time. Given a "reasonable" Postscript printer, + * the following Tk_Font font families should print correctly: + * + * Avant Garde, Arial, Bookman, Courier, Courier New, Geneva, + * Helvetica, Monaco, New Century Schoolbook, New York, + * Palatino, Symbol, Times, Times New Roman, Zapf Chancery, + * and Zapf Dingbats. + * + * Any other Tk_Font font families may not print correctly + * because the computed Postscript font name may be incorrect. + * + *--------------------------------------------------------------------------- + */ + + +int +Tk_PostscriptFontName(tkfont, dsPtr) + Tk_Font tkfont; /* Font in which text will be printed. */ + Tcl_DString *dsPtr; /* Pointer to an initialized Tcl_DString to + * which the name of the Postscript font that + * corresponds to tkfont will be appended. */ +{ + TkFont *fontPtr; + char *family, *weightString, *slantString; + char *src, *dest; + int upper, len; + + len = Tcl_DStringLength(dsPtr); + fontPtr = (TkFont *) tkfont; + + /* + * Convert the case-insensitive Tk_Font family name to the + * case-sensitive Postscript family name. Take out any spaces and + * capitalize the first letter of each word. + */ + + family = fontPtr->fa.family; + if (strncasecmp(family, "itc ", 4) == 0) { + family = family + 4; + } + if ((strcasecmp(family, "Arial") == 0) + || (strcasecmp(family, "Geneva") == 0)) { + family = "Helvetica"; + } else if ((strcasecmp(family, "Times New Roman") == 0) + || (strcasecmp(family, "New York") == 0)) { + family = "Times"; + } else if ((strcasecmp(family, "Courier New") == 0) + || (strcasecmp(family, "Monaco") == 0)) { + family = "Courier"; + } else if (strcasecmp(family, "AvantGarde") == 0) { + family = "AvantGarde"; + } else if (strcasecmp(family, "ZapfChancery") == 0) { + family = "ZapfChancery"; + } else if (strcasecmp(family, "ZapfDingbats") == 0) { + family = "ZapfDingbats"; + } else { + /* + * Inline, capitalize the first letter of each word, lowercase the + * rest of the letters in each word, and then take out the spaces + * between the words. This may make the DString shorter, which is + * safe to do. + */ + + Tcl_DStringAppend(dsPtr, family, -1); + + src = dest = Tcl_DStringValue(dsPtr) + len; + upper = 1; + for (; *src != '\0'; src++, dest++) { + while (isspace(UCHAR(*src))) { + src++; + upper = 1; + } + *dest = *src; + if ((upper != 0) && (islower(UCHAR(*src)))) { + *dest = toupper(UCHAR(*src)); + } + upper = 0; + } + *dest = '\0'; + Tcl_DStringSetLength(dsPtr, dest - Tcl_DStringValue(dsPtr)); + family = Tcl_DStringValue(dsPtr) + len; + } + if (family != Tcl_DStringValue(dsPtr) + len) { + Tcl_DStringAppend(dsPtr, family, -1); + family = Tcl_DStringValue(dsPtr) + len; + } + + if (strcasecmp(family, "NewCenturySchoolbook") == 0) { + Tcl_DStringSetLength(dsPtr, len); + Tcl_DStringAppend(dsPtr, "NewCenturySchlbk", -1); + family = Tcl_DStringValue(dsPtr) + len; + } + + /* + * Get the string to use for the weight. + */ + + weightString = NULL; + if (fontPtr->fa.weight == TK_FW_NORMAL) { + if (strcmp(family, "Bookman") == 0) { + weightString = "Light"; + } else if (strcmp(family, "AvantGarde") == 0) { + weightString = "Book"; + } else if (strcmp(family, "ZapfChancery") == 0) { + weightString = "Medium"; + } + } else { + if ((strcmp(family, "Bookman") == 0) + || (strcmp(family, "AvantGarde") == 0)) { + weightString = "Demi"; + } else { + weightString = "Bold"; + } + } + + /* + * Get the string to use for the slant. + */ + + slantString = NULL; + if (fontPtr->fa.slant == TK_FS_ROMAN) { + ; + } else { + if ((strcmp(family, "Helvetica") == 0) + || (strcmp(family, "Courier") == 0) + || (strcmp(family, "AvantGarde") == 0)) { + slantString = "Oblique"; + } else { + slantString = "Italic"; + } + } + + /* + * The string "Roman" needs to be added to some fonts that are not bold + * and not italic. + */ + + if ((slantString == NULL) && (weightString == NULL)) { + if ((strcmp(family, "Times") == 0) + || (strcmp(family, "NewCenturySchlbk") == 0) + || (strcmp(family, "Palatino") == 0)) { + Tcl_DStringAppend(dsPtr, "-Roman", -1); + } + } else { + Tcl_DStringAppend(dsPtr, "-", -1); + if (weightString != NULL) { + Tcl_DStringAppend(dsPtr, weightString, -1); + } + if (slantString != NULL) { + Tcl_DStringAppend(dsPtr, slantString, -1); + } + } + + return fontPtr->fa.pointsize; +} + +/* + *--------------------------------------------------------------------------- + * + * Tk_TextWidth -- + * + * A wrapper function for the more complicated interface of + * Tk_MeasureChars. Computes how much space the given + * simple string needs. + * + * Results: + * The return value is the width (in pixels) of the given string. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +int +Tk_TextWidth(tkfont, string, numChars) + Tk_Font tkfont; /* Font in which text will be measured. */ + CONST char *string; /* String whose width will be computed. */ + int numChars; /* Number of characters to consider from + * string, or < 0 for strlen(). */ +{ + int width; + + if (numChars < 0) { + numChars = strlen(string); + } + Tk_MeasureChars(tkfont, string, numChars, 0, 0, &width); + return width; +} + +/* + *--------------------------------------------------------------------------- + * + * Tk_UnderlineChars -- + * + * This procedure draws an underline for a given range of characters + * in a given string. It doesn't draw the characters (which are + * assumed to have been displayed previously); it just draws the + * underline. This procedure would mainly be used to quickly + * underline a few characters without having to construct an + * underlined font. To produce properly underlined text, the + * appropriate underlined font should be constructed and used. + * + * Results: + * None. + * + * Side effects: + * Information gets displayed in "drawable". + * + *---------------------------------------------------------------------- + */ + +void +Tk_UnderlineChars(display, drawable, gc, tkfont, string, x, y, firstChar, + lastChar) + Display *display; /* Display on which to draw. */ + Drawable drawable; /* Window or pixmap in which to draw. */ + GC gc; /* Graphics context for actually drawing + * line. */ + Tk_Font tkfont; /* Font used in GC; must have been allocated + * by Tk_GetFont(). Used for character + * dimensions, etc. */ + CONST char *string; /* String containing characters to be + * underlined or overstruck. */ + int x, y; /* Coordinates at which first character of + * string is drawn. */ + int firstChar; /* Index of first character. */ + int lastChar; /* Index of one after the last character. */ +{ + TkFont *fontPtr; + int startX, endX; + + fontPtr = (TkFont *) tkfont; + + Tk_MeasureChars(tkfont, string, firstChar, 0, 0, &startX); + Tk_MeasureChars(tkfont, string, lastChar, 0, 0, &endX); + + XFillRectangle(display, drawable, gc, x + startX, + y + fontPtr->underlinePos, (unsigned int) (endX - startX), + (unsigned int) fontPtr->underlineHeight); +} + +/* + *--------------------------------------------------------------------------- + * + * Tk_ComputeTextLayout -- + * + * Computes the amount of screen space needed to display a + * multi-line, justified string of text. Records all the + * measurements that were done to determine to size and + * positioning of the individual lines of text; this information + * can be used by the Tk_DrawTextLayout() procedure to + * display the text quickly (without remeasuring it). + * + * This procedure is useful for simple widgets that want to + * display single-font, multi-line text and want Tk to handle the + * details. + * + * Results: + * The return value is a Tk_TextLayout token that holds the + * measurement information for the given string. The token is + * only valid for the given string. If the string is freed, + * the token is no longer valid and must also be freed. To free + * the token, call Tk_FreeTextLayout(). + * + * The dimensions of the screen area needed to display the text + * are stored in *widthPtr and *heightPtr. + * + * Side effects: + * Memory is allocated to hold the measurement information. + * + *--------------------------------------------------------------------------- + */ + +Tk_TextLayout +Tk_ComputeTextLayout(tkfont, string, numChars, wrapLength, justify, flags, + widthPtr, heightPtr) + Tk_Font tkfont; /* Font that will be used to display text. */ + CONST char *string; /* String whose dimensions are to be + * computed. */ + int numChars; /* Number of characters to consider from + * string, or < 0 for strlen(). */ + int wrapLength; /* Longest permissible line length, in + * pixels. <= 0 means no automatic wrapping: + * just let lines get as long as needed. */ + Tk_Justify justify; /* How to justify lines. */ + int flags; /* Flag bits OR-ed together. + * TK_IGNORE_TABS means that tab characters + * should not be expanded. TK_IGNORE_NEWLINES + * means that newline characters should not + * cause a line break. */ + int *widthPtr; /* Filled with width of string. */ + int *heightPtr; /* Filled with height of string. */ +{ + TkFont *fontPtr; + CONST char *start, *end, *special; + int n, y, charsThisChunk, maxChunks; + int baseline, height, curX, newX, maxWidth; + TextLayout *layoutPtr; + LayoutChunk *chunkPtr; + CONST TkFontMetrics *fmPtr; +#define MAX_LINES 50 + int staticLineLengths[MAX_LINES]; + int *lineLengths; + int maxLines, curLine, layoutHeight; + + lineLengths = staticLineLengths; + maxLines = MAX_LINES; + + fontPtr = (TkFont *) tkfont; + fmPtr = &fontPtr->fm; + + height = fmPtr->ascent + fmPtr->descent; + + if (numChars < 0) { + numChars = strlen(string); + } + + maxChunks = 1; + + layoutPtr = (TextLayout *) ckalloc(sizeof(TextLayout) + + (maxChunks - 1) * sizeof(LayoutChunk)); + layoutPtr->tkfont = tkfont; + layoutPtr->string = string; + layoutPtr->numChunks = 0; + + baseline = fmPtr->ascent; + maxWidth = 0; + + /* + * Divide the string up into simple strings and measure each string. + */ + + curX = 0; + + end = string + numChars; + special = string; + + 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) { + /* + * Find the next special character in the string. + */ + + for (special = start; special < end; special++) { + if (!(flags & TK_IGNORE_NEWLINES)) { + if ((*special == '\n') || (*special == '\r')) { + break; + } + } + if (!(flags & TK_IGNORE_TABS)) { + if (*special == '\t') { + break; + } + } + } + } + + /* + * Special points at the next special character (or the end of the + * string). Process characters between start and special. + */ + + chunkPtr = NULL; + if (start < special) { + charsThisChunk = Tk_MeasureChars(tkfont, start, special - start, + wrapLength - curX, flags, &newX); + newX += curX; + flags &= ~TK_AT_LEAST_ONE; + if (charsThisChunk > 0) { + chunkPtr = NewChunk(&layoutPtr, &maxChunks, start, + charsThisChunk, curX, newX, baseline); + + start += charsThisChunk; + curX = newX; + } + } + + if ((start == special) && (special < end)) { + /* + * Handle the special character. + */ + + chunkPtr = NULL; + if (*special == '\t') { + newX = curX + fontPtr->tabWidth; + newX -= newX % fontPtr->tabWidth; + NewChunk(&layoutPtr, &maxChunks, start, 1, curX, newX, + baseline)->numDisplayChars = -1; + start++; + if ((start < end) && + ((wrapLength <= 0) || (newX <= wrapLength))) { + /* + * More chars can still fit on this line. + */ + + curX = newX; + flags &= ~TK_AT_LEAST_ONE; + continue; + } + } else { + NewChunk(&layoutPtr, &maxChunks, start, 1, curX, 1000000000, + baseline)->numDisplayChars = -1; + start++; + goto wrapLine; + } + } + + /* + * No more characters are going to go on this line, either because + * no more characters can fit or there are no more characters left. + * Consume all extra spaces at end of line. + */ + + while ((start < end) && isspace(UCHAR(*start))) { + if (!(flags & TK_IGNORE_NEWLINES)) { + if ((*start == '\n') || (*start == '\r')) { + break; + } + } + if (!(flags & TK_IGNORE_TABS)) { + if (*start == '\t') { + break; + } + } + start++; + } + if (chunkPtr != NULL) { + /* + * Append all the extra spaces on this line to the end of the + * last text chunk. + */ + charsThisChunk = start - (chunkPtr->start + chunkPtr->numChars); + if (charsThisChunk > 0) { + chunkPtr->numChars += Tk_MeasureChars(tkfont, + chunkPtr->start + chunkPtr->numChars, charsThisChunk, + 0, 0, &chunkPtr->totalWidth); + chunkPtr->totalWidth += curX; + } + } + + wrapLine: + flags |= TK_AT_LEAST_ONE; + + /* + * Save current line length, then move current position to start of + * next line. + */ + + if (curX > maxWidth) { + maxWidth = curX; + } + + /* + * Remember width of this line, so that all chunks on this line + * 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++; + + curX = 0; + baseline += height; + } + + /* + * If last line ends with a newline, then we need to make a 0 width + * chunk on the next line. Otherwise "Hello" and "Hello\n" are the + * same height. + */ + + if ((layoutPtr->numChunks > 0) && ((flags & TK_IGNORE_NEWLINES) == 0)) { + if (layoutPtr->chunks[layoutPtr->numChunks - 1].start[0] == '\n') { + chunkPtr = NewChunk(&layoutPtr, &maxChunks, start, 0, curX, + 1000000000, baseline); + chunkPtr->numDisplayChars = -1; + baseline += height; + } + } + + /* + * Using maximum line length, shift all the chunks so that the lines are + * all justified correctly. + */ + + curLine = 0; + chunkPtr = layoutPtr->chunks; + y = chunkPtr->y; + for (n = 0; n < layoutPtr->numChunks; n++) { + int extra; + + if (chunkPtr->y != y) { + curLine++; + y = chunkPtr->y; + } + extra = maxWidth - lineLengths[curLine]; + if (justify == TK_JUSTIFY_CENTER) { + chunkPtr->x += extra / 2; + } else if (justify == TK_JUSTIFY_RIGHT) { + chunkPtr->x += extra; + } + chunkPtr++; + } + + layoutPtr->width = maxWidth; + layoutHeight = baseline - fmPtr->ascent; + if (layoutPtr->numChunks == 0) { + layoutHeight = height; + + /* + * This fake chunk is used by the other procedures so that they can + * pretend that there is a chunk with no chars in it, which makes + * the coding simpler. + */ + + layoutPtr->numChunks = 1; + layoutPtr->chunks[0].start = string; + layoutPtr->chunks[0].numChars = 0; + layoutPtr->chunks[0].numDisplayChars = -1; + layoutPtr->chunks[0].x = 0; + layoutPtr->chunks[0].y = fmPtr->ascent; + layoutPtr->chunks[0].totalWidth = 0; + layoutPtr->chunks[0].displayWidth = 0; + } + + if (widthPtr != NULL) { + *widthPtr = layoutPtr->width; + } + if (heightPtr != NULL) { + *heightPtr = layoutHeight; + } + if (lineLengths != staticLineLengths) { + ckfree((char *) lineLengths); + } + + return (Tk_TextLayout) layoutPtr; +} + +/* + *--------------------------------------------------------------------------- + * + * Tk_FreeTextLayout -- + * + * This procedure is called to release the storage associated with + * a Tk_TextLayout when it is no longer needed. + * + * Results: + * None. + * + * Side effects: + * Memory is freed. + * + *--------------------------------------------------------------------------- + */ + +void +Tk_FreeTextLayout(textLayout) + Tk_TextLayout textLayout; /* The text layout to be released. */ +{ + TextLayout *layoutPtr; + + layoutPtr = (TextLayout *) textLayout; + if (layoutPtr != NULL) { + ckfree((char *) layoutPtr); + } +} + +/* + *--------------------------------------------------------------------------- + * + * Tk_DrawTextLayout -- + * + * Use the information in the Tk_TextLayout token to display a + * multi-line, justified string of text. + * + * This procedure is useful for simple widgets that need to + * display single-font, multi-line text and want Tk to handle + * the details. + * + * Results: + * None. + * + * Side effects: + * Text drawn on the screen. + * + *--------------------------------------------------------------------------- + */ + +void +Tk_DrawTextLayout(display, drawable, gc, layout, x, y, firstChar, lastChar) + Display *display; /* Display on which to draw. */ + Drawable drawable; /* Window or pixmap in which to draw. */ + GC gc; /* Graphics context to use for drawing text. */ + Tk_TextLayout layout; /* Layout information, from a previous call + * to Tk_ComputeTextLayout(). */ + int x, y; /* Upper-left hand corner of rectangle in + * which to draw (pixels). */ + int firstChar; /* The index of the first character to draw + * from the given text item. 0 specfies the + * beginning. */ + int lastChar; /* The index just after the last character + * to draw from the given text item. A number + * < 0 means to draw all characters. */ +{ + TextLayout *layoutPtr; + int i, numDisplayChars, drawX; + LayoutChunk *chunkPtr; + + layoutPtr = (TextLayout *) layout; + if (layoutPtr == NULL) { + return; + } + + if (lastChar < 0) { + lastChar = 100000000; + } + chunkPtr = layoutPtr->chunks; + for (i = 0; i < layoutPtr->numChunks; i++) { + numDisplayChars = chunkPtr->numDisplayChars; + if ((numDisplayChars > 0) && (firstChar < numDisplayChars)) { + if (firstChar <= 0) { + drawX = 0; + firstChar = 0; + } else { + Tk_MeasureChars(layoutPtr->tkfont, chunkPtr->start, firstChar, + 0, 0, &drawX); + } + if (lastChar < numDisplayChars) { + numDisplayChars = lastChar; + } + Tk_DrawChars(display, drawable, gc, layoutPtr->tkfont, + chunkPtr->start + firstChar, numDisplayChars - firstChar, + x + chunkPtr->x + drawX, y + chunkPtr->y); + } + firstChar -= chunkPtr->numChars; + lastChar -= chunkPtr->numChars; + if (lastChar <= 0) { + break; + } + chunkPtr++; + } +} + +/* + *--------------------------------------------------------------------------- + * + * Tk_UnderlineTextLayout -- + * + * Use the information in the Tk_TextLayout token to display an + * underline below an individual character. This procedure does + * not draw the text, just the underline. + * + * This procedure is useful for simple widgets that need to + * display single-font, multi-line text with an individual + * character underlined and want Tk to handle the details. + * To display larger amounts of underlined text, construct + * and use an underlined font. + * + * Results: + * None. + * + * Side effects: + * Underline drawn on the screen. + * + *--------------------------------------------------------------------------- + */ + +void +Tk_UnderlineTextLayout(display, drawable, gc, layout, x, y, underline) + Display *display; /* Display on which to draw. */ + Drawable drawable; /* Window or pixmap in which to draw. */ + GC gc; /* Graphics context to use for drawing text. */ + Tk_TextLayout layout; /* Layout information, from a previous call + * to Tk_ComputeTextLayout(). */ + int x, y; /* Upper-left hand corner of rectangle in + * which to draw (pixels). */ + int underline; /* Index of the single character to + * underline, or -1 for no underline. */ +{ + TextLayout *layoutPtr; + TkFont *fontPtr; + int xx, yy, width, height; + + if ((Tk_CharBbox(layout, underline, &xx, &yy, &width, &height) != 0) + && (width != 0)) { + layoutPtr = (TextLayout *) layout; + fontPtr = (TkFont *) layoutPtr->tkfont; + + XFillRectangle(display, drawable, gc, x + xx, + y + yy + fontPtr->fm.ascent + fontPtr->underlinePos, + (unsigned int) width, (unsigned int) fontPtr->underlineHeight); + } +} + +/* + *--------------------------------------------------------------------------- + * + * Tk_PointToChar -- + * + * Use the information in the Tk_TextLayout token to determine the + * character closest to the given point. The point must be + * specified with respect to the upper-left hand corner of the + * text layout, which is considered to be located at (0, 0). + * + * Any point whose y-value is less that 0 will be considered closest + * to the first character in the text layout; any point whose y-value + * is greater than the height of the text layout will be considered + * closest to the last character in the text layout. + * + * Any point whose x-value is less than 0 will be considered closest + * to the first character on that line; any point whose x-value is + * greater than the width of the text layout will be considered + * closest to the last character on that line. + * + * Results: + * The return value is the index of the character that was + * closest to the point. Given a text layout with no characters, + * the value 0 will always be returned, referring to a hypothetical + * zero-width placeholder character. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +int +Tk_PointToChar(layout, x, y) + Tk_TextLayout layout; /* Layout information, from a previous call + * to Tk_ComputeTextLayout(). */ + int x, y; /* Coordinates of point to check, with + * respect to the upper-left corner of the + * text layout. */ +{ + TextLayout *layoutPtr; + LayoutChunk *chunkPtr, *lastPtr; + TkFont *fontPtr; + int i, n, dummy, baseline, pos; + + if (y < 0) { + /* + * Point lies above any line in this layout. Return the index of + * the first char. + */ + + return 0; + } + + /* + * Find which line contains the point. + */ + + layoutPtr = (TextLayout *) layout; + fontPtr = (TkFont *) layoutPtr->tkfont; + lastPtr = chunkPtr = layoutPtr->chunks; + for (i = 0; i < layoutPtr->numChunks; i++) { + baseline = chunkPtr->y; + if (y < baseline + fontPtr->fm.descent) { + if (x < chunkPtr->x) { + /* + * Point is to the left of all chunks on this line. Return + * the index of the first character on this line. + */ + + return chunkPtr->start - layoutPtr->string; + } + if (x >= layoutPtr->width) { + /* + * If point lies off right side of the text layout, return + * the last char in the last chunk on this line. Without + * this, it might return the index of the first char that + * was located outside of the text layout. + */ + + x = INT_MAX; + } + + /* + * Examine all chunks on this line to see which one contains + * the specified point. + */ + + lastPtr = chunkPtr; + while ((i < layoutPtr->numChunks) && (chunkPtr->y == baseline)) { + if (x < chunkPtr->x + chunkPtr->totalWidth) { + /* + * Point falls on one of the characters in this chunk. + */ + + if (chunkPtr->numDisplayChars < 0) { + /* + * This is a special chunk that encapsulates a single + * tab or newline char. + */ + + 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; + } + lastPtr = chunkPtr; + chunkPtr++; + i++; + } + + /* + * Point is to the right of all chars in all the chunks on this + * line. Return the index just past the last char in the last + * chunk on this line. + */ + + pos = (lastPtr->start + lastPtr->numChars) - layoutPtr->string; + if (i < layoutPtr->numChunks) { + pos--; + } + return pos; + } + lastPtr = chunkPtr; + chunkPtr++; + } + + /* + * Point lies below any line in this text layout. Return the index + * just past the last char. + */ + + return (lastPtr->start + lastPtr->numChars) - layoutPtr->string; +} + +/* + *--------------------------------------------------------------------------- + * + * Tk_CharBbox -- + * + * Use the information in the Tk_TextLayout token to return the + * bounding box for the character specified by index. + * + * The width of the bounding box is the advance width of the + * character, and does not include and left- or right-bearing. + * Any character that extends partially outside of the + * text layout is considered to be truncated at the edge. Any + * character which is located completely outside of the text + * layout is considered to be zero-width and pegged against + * the edge. + * + * The height of the bounding box is the line height for this font, + * extending from the top of the ascent to the bottom of the + * descent. Information about the actual height of the individual + * letter is not available. + * + * A text layout that contains no characters is considered to + * contain a single zero-width placeholder character. + * + * Results: + * The return value is 0 if the index did not specify a character + * in the text layout, or non-zero otherwise. In that case, + * *bbox is filled with the bounding box of the character. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +int +Tk_CharBbox(layout, index, xPtr, yPtr, widthPtr, heightPtr) + Tk_TextLayout layout; /* Layout information, from a previous call to + * Tk_ComputeTextLayout(). */ + int index; /* The index of the character whose bbox is + * desired. */ + int *xPtr, *yPtr; /* Filled with the upper-left hand corner, in + * pixels, of the bounding box for the character + * specified by index, if non-NULL. */ + int *widthPtr, *heightPtr; + /* Filled with the width and height of the + * bounding box for the character specified by + * index, if non-NULL. */ +{ + TextLayout *layoutPtr; + LayoutChunk *chunkPtr; + int i, x, w; + Tk_Font tkfont; + TkFont *fontPtr; + + if (index < 0) { + return 0; + } + + layoutPtr = (TextLayout *) layout; + chunkPtr = layoutPtr->chunks; + tkfont = layoutPtr->tkfont; + fontPtr = (TkFont *) tkfont; + + for (i = 0; i < layoutPtr->numChunks; i++) { + if (chunkPtr->numDisplayChars < 0) { + if (index == 0) { + x = chunkPtr->x; + w = chunkPtr->totalWidth; + goto check; + } + } else if (index < chunkPtr->numChars) { + if (xPtr != NULL) { + Tk_MeasureChars(tkfont, chunkPtr->start, index, 0, 0, &x); + x += chunkPtr->x; + } + if (widthPtr != NULL) { + Tk_MeasureChars(tkfont, chunkPtr->start + index, 1, 0, 0, &w); + } + goto check; + } + index -= chunkPtr->numChars; + chunkPtr++; + } + if (index == 0) { + /* + * Special case to get location just past last char in layout. + */ + + chunkPtr--; + x = chunkPtr->x + chunkPtr->totalWidth; + w = 0; + } else { + return 0; + } + + /* + * Ensure that the bbox lies within the text layout. This forces all + * chars that extend off the right edge of the text layout to have + * truncated widths, and all chars that are completely off the right + * edge of the text layout to peg to the edge and have 0 width. + */ + check: + if (yPtr != NULL) { + *yPtr = chunkPtr->y - fontPtr->fm.ascent; + } + if (heightPtr != NULL) { + *heightPtr = fontPtr->fm.ascent + fontPtr->fm.descent; + } + + if (x > layoutPtr->width) { + x = layoutPtr->width; + } + if (xPtr != NULL) { + *xPtr = x; + } + if (widthPtr != NULL) { + if (x + w > layoutPtr->width) { + w = layoutPtr->width - x; + } + *widthPtr = w; + } + + return 1; +} + +/* + *--------------------------------------------------------------------------- + * + * Tk_DistanceToTextLayout -- + * + * Computes the distance in pixels from the given point to the + * given text layout. Non-displaying space characters that occur + * at the end of individual lines in the text layout are ignored + * for hit detection purposes. + * + * Results: + * The return value is 0 if the point (x, y) is inside the text + * layout. If the point isn't inside the text layout then the + * return value is the distance in pixels from the point to the + * text item. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +int +Tk_DistanceToTextLayout(layout, x, y) + Tk_TextLayout layout; /* Layout information, from a previous call + * to Tk_ComputeTextLayout(). */ + int x, y; /* Coordinates of point to check, with + * respect to the upper-left corner of the + * text layout (in pixels). */ +{ + int i, x1, x2, y1, y2, xDiff, yDiff, dist, minDist, ascent, descent; + LayoutChunk *chunkPtr; + TextLayout *layoutPtr; + TkFont *fontPtr; + + layoutPtr = (TextLayout *) layout; + fontPtr = (TkFont *) layoutPtr->tkfont; + ascent = fontPtr->fm.ascent; + descent = fontPtr->fm.descent; + + minDist = 0; + chunkPtr = layoutPtr->chunks; + for (i = 0; i < layoutPtr->numChunks; i++) { + if (chunkPtr->start[0] == '\n') { + /* + * Newline characters are not counted when computing distance + * (but tab characters would still be considered). + */ + + chunkPtr++; + continue; + } + + x1 = chunkPtr->x; + y1 = chunkPtr->y - ascent; + x2 = chunkPtr->x + chunkPtr->displayWidth; + y2 = chunkPtr->y + descent; + + if (x < x1) { + xDiff = x1 - x; + } else if (x >= x2) { + xDiff = x - x2 + 1; + } else { + xDiff = 0; + } + + if (y < y1) { + yDiff = y1 - y; + } else if (y >= y2) { + yDiff = y - y2 + 1; + } else { + yDiff = 0; + } + if ((xDiff == 0) && (yDiff == 0)) { + return 0; + } + dist = (int) hypot((double) xDiff, (double) yDiff); + if ((dist < minDist) || (minDist == 0)) { + minDist = dist; + } + chunkPtr++; + } + return minDist; +} + +/* + *--------------------------------------------------------------------------- + * + * Tk_IntersectTextLayout -- + * + * Determines whether a text layout lies entirely inside, + * entirely outside, or overlaps a given rectangle. Non-displaying + * space characters that occur at the end of individual lines in + * the text layout are ignored for intersection calculations. + * + * Results: + * The return value is -1 if the text layout is entirely outside of + * the rectangle, 0 if it overlaps, and 1 if it is entirely inside + * of the rectangle. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +int +Tk_IntersectTextLayout(layout, x, y, width, height) + Tk_TextLayout layout; /* Layout information, from a previous call + * to Tk_ComputeTextLayout(). */ + int x, y; /* Upper-left hand corner, in pixels, of + * rectangular area to compare with text + * layout. Coordinates are with respect to + * the upper-left hand corner of the text + * layout itself. */ + int width, height; /* The width and height of the above + * rectangular area, in pixels. */ +{ + int result, i, x1, y1, x2, y2; + TextLayout *layoutPtr; + LayoutChunk *chunkPtr; + TkFont *fontPtr; + int left, top, right, bottom; + + /* + * Scan the chunks one at a time, seeing whether each is entirely in, + * entirely out, or overlapping the rectangle. If an overlap is + * detected, return immediately; otherwise wait until all chunks have + * been processed and see if they were all inside or all outside. + */ + + layoutPtr = (TextLayout *) layout; + chunkPtr = layoutPtr->chunks; + fontPtr = (TkFont *) layoutPtr->tkfont; + + left = x; + top = y; + right = x + width; + bottom = y + height; + + result = 0; + for (i = 0; i < layoutPtr->numChunks; i++) { + if (chunkPtr->start[0] == '\n') { + /* + * Newline characters are not counted when computing area + * intersection (but tab characters would still be considered). + */ + + chunkPtr++; + continue; + } + + x1 = chunkPtr->x; + y1 = chunkPtr->y - fontPtr->fm.ascent; + x2 = chunkPtr->x + chunkPtr->displayWidth; + y2 = chunkPtr->y + fontPtr->fm.descent; + + if ((right < x1) || (left >= x2) + || (bottom < y1) || (top >= y2)) { + if (result == 1) { + return 0; + } + result = -1; + } else if ((x1 < left) || (x2 >= right) + || (y1 < top) || (y2 >= bottom)) { + return 0; + } else if (result == -1) { + return 0; + } else { + result = 1; + } + chunkPtr++; + } + return result; +} + +/* + *--------------------------------------------------------------------------- + * + * Tk_TextLayoutToPostscript -- + * + * Outputs the contents of a text layout in Postscript format. + * The set of lines in the text layout will be rendered by the user + * supplied Postscript function. The function should be of the form: + * + * justify x y string function -- + * + * Justify is -1, 0, or 1, depending on whether the following string + * should be left, center, or right justified, x and y is the + * location for the origin of the string, string is the sequence + * of characters to be printed, and function is the name of the + * caller-provided function; the function should leave nothing + * on the stack. + * + * The meaning of the origin of the string (x and y) depends on + * the justification. For left justification, x is where the + * left edge of the string should appear. For center justification, + * x is where the center of the string should appear. And for right + * justification, x is where the right edge of the string should + * appear. This behavior is necessary because, for example, right + * justified text on the screen is justified with screen metrics. + * The same string needs to be justified with printer metrics on + * the printer to appear in the correct place with respect to other + * similarly justified strings. In all circumstances, y is the + * location of the baseline for the string. + * + * Results: + * Interp->result is modified to hold the Postscript code that + * will render the text layout. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +void +Tk_TextLayoutToPostscript(interp, layout) + Tcl_Interp *interp; /* Filled with Postscript code. */ + Tk_TextLayout layout; /* The layout to be rendered. */ +{ +#define MAXUSE 128 + char buf[MAXUSE+10]; + LayoutChunk *chunkPtr; + int i, j, used, c, baseline; + TextLayout *layoutPtr; + + layoutPtr = (TextLayout *) layout; + chunkPtr = layoutPtr->chunks; + baseline = chunkPtr->y; + used = 0; + buf[used++] = '('; + for (i = 0; i < layoutPtr->numChunks; i++) { + if (baseline != chunkPtr->y) { + buf[used++] = ')'; + buf[used++] = '\n'; + buf[used++] = '('; + baseline = chunkPtr->y; + } + if (chunkPtr->numDisplayChars <= 0) { + if (chunkPtr->start[0] == '\t') { + buf[used++] = '\\'; + buf[used++] = 't'; + } + } else { + for (j = 0; j < chunkPtr->numDisplayChars; j++) { + c = UCHAR(chunkPtr->start[j]); + if ((c == '(') || (c == ')') || (c == '\\') || (c < 0x20) + || (c >= UCHAR(0x7f))) { + /* + * Tricky point: the "03" is necessary in the sprintf + * below, so that a full three digits of octal are + * always generated. Without the "03", a number + * following this sequence could be interpreted by + * Postscript as part of this sequence. + */ + + sprintf(buf + used, "\\%03o", c); + used += 4; + } else { + buf[used++] = c; + } + if (used >= MAXUSE) { + buf[used] = '\0'; + Tcl_AppendResult(interp, buf, (char *) NULL); + used = 0; + } + } + } + if (used >= MAXUSE) { + /* + * If there are a whole bunch of returns or tabs in a row, + * then buf[] could get filled up. + */ + + buf[used] = '\0'; + Tcl_AppendResult(interp, buf, (char *) NULL); + used = 0; + } + chunkPtr++; + } + buf[used++] = ')'; + buf[used++] = '\n'; + buf[used] = '\0'; + Tcl_AppendResult(interp, buf, (char *) NULL); +} + +/* + *--------------------------------------------------------------------------- + * + * 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 + * initialized font attributes structure. + * + * Results: + * A standard Tcl return value. If TCL_ERROR is returned, an + * error message will be left in interp's result object. + * + * Side effects: + * The fields of the font attributes structure get filled in with + * information from argc/argv. If an error occurs while parsing, + * the font attributes structure will contain all modifications + * specified in the command line options up to the point of the + * error. + * + *--------------------------------------------------------------------------- + */ + +static int +ConfigAttributesObj(interp, tkwin, objc, objv, faPtr) + Tcl_Interp *interp; /* Interp for error return. */ + Tk_Window tkwin; /* For display on which font will be used. */ + int objc; /* Number of elements in argv. */ + Tcl_Obj *CONST objv[]; /* Command line options. */ + TkFontAttributes *faPtr; /* Font attributes structure whose fields + * are to be modified. Structure must already + * be properly initialized. */ +{ + int i, n, index; + Tcl_Obj *value; + char *option, *string; + + 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]; + + if (Tcl_GetIndexFromObj(interp, objv[i], fontOpt, "option", 1, + &index) != TCL_OK) { + return TCL_ERROR; + } + switch (index) { + case FONT_FAMILY: + string = Tcl_GetStringFromObj(value, NULL); + faPtr->family = Tk_GetUid(string); + break; + + case FONT_SIZE: + if (Tcl_GetIntFromObj(interp, value, &n) != TCL_OK) { + return TCL_ERROR; + } + faPtr->pointsize = n; + break; + + case FONT_WEIGHT: + string = Tcl_GetStringFromObj(value, NULL); + n = TkFindStateNum(interp, option, weightMap, string); + 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); + if (n == TK_FS_UNKNOWN) { + return TCL_ERROR; + } + faPtr->slant = n; + break; + + case FONT_UNDERLINE: + if (Tcl_GetBooleanFromObj(interp, value, &n) != TCL_OK) { + return TCL_ERROR; + } + faPtr->underline = n; + break; + + case FONT_OVERSTRIKE: + if (Tcl_GetBooleanFromObj(interp, value, &n) != TCL_OK) { + return TCL_ERROR; + } + faPtr->overstrike = n; + break; + } + } + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * GetAttributeInfoObj -- + * + * Return information about the font attributes as a Tcl list. + * + * Results: + * The return value is TCL_OK if the objPtr was non-NULL and + * specified a valid font attribute, TCL_ERROR otherwise. If TCL_OK + * is returned, the interp's result object is modified to hold a + * description of either the current value of a single option, or a + * list of all options and their current values for the given font + * attributes. If TCL_ERROR is returned, the interp's result is + * set to an error message describing that the objPtr did not refer + * to a valid option. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +static int +GetAttributeInfoObj(interp, faPtr, objPtr) + Tcl_Interp *interp; /* Interp to hold result. */ + 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. */ +{ + int i, index, start, end, num; + char *str; + Tcl_Obj *newPtr; + + start = 0; + end = FONT_NUMFIELDS; + if (objPtr != NULL) { + if (Tcl_GetIndexFromObj(interp, objPtr, fontOpt, "option", 1, + &index) != TCL_OK) { + return TCL_ERROR; + } + start = index; + end = index + 1; + } + + 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 = ""; + } + break; + + case FONT_SIZE: + num = faPtr->pointsize; + break; + + case FONT_WEIGHT: + str = TkFindStateString(weightMap, faPtr->weight); + break; + + case FONT_SLANT: + str = TkFindStateString(slantMap, faPtr->slant); + break; + + case FONT_UNDERLINE: + num = faPtr->underline; + break; + + case FONT_OVERSTRIKE: + num = 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); + } + } + } + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * ParseFontNameObj -- + * + * Converts a object into a set of font attributes that can be used + * to construct a font. + * + * The string rep of the object can be one of the following forms: + * XLFD (see X documentation) + * "Family [size [style] [style ...]]" + * "-option value [-option value ...]" + * + * Results: + * The return value is TCL_ERROR if the object was syntactically + * invalid. In that case an error message is left in interp's + * result object. Otherwise, fills the font attribute buffer with + * the values parsed from the string and returns TCL_OK; + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +static int +ParseFontNameObj(interp, tkwin, objPtr, faPtr) + Tcl_Interp *interp; /* Interp for error return. */ + 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. */ +{ + char *dash; + int objc, result, i, n; + Tcl_Obj **objv; + TkXLFDAttributes xa; + char *string; + + string = Tcl_GetStringFromObj(objPtr, NULL); + if (*string == '-') { + /* + * This may be an XLFD or an "-option value" string. + * + * If the string begins with "-*" or a "-foundry-family-*" pattern, + * then consider it an XLFD. + */ + + if (string[1] == '*') { + goto xlfd; + } + dash = strchr(string + 1, '-'); + if ((dash != NULL) && (!isspace(UCHAR(dash[-1])))) { + goto xlfd; + } + + if (Tcl_ListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) { + return TCL_ERROR; + } + + return ConfigAttributesObj(interp, tkwin, objc, objv, faPtr); + } + + if (*string == '*') { + /* + * This appears to be an XLFD. + */ + + xlfd: + xa.fa = *faPtr; + result = TkParseXLFD(string, &xa); + if (result == TCL_OK) { + *faPtr = xa.fa; + return result; + } + } + + /* + * Wasn't an XLFD or "-option value" string. Try it as a + * "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); + return TCL_ERROR; + } + + faPtr->family = Tk_GetUid(Tcl_GetStringFromObj(objv[0], NULL)); + if (objc > 1) { + if (Tcl_GetIntFromObj(interp, objv[1], &n) != TCL_OK) { + return TCL_ERROR; + } + faPtr->pointsize = n; + } + + i = 2; + if (objc == 3) { + if (Tcl_ListObjGetElements(interp, objv[2], &objc, &objv) != TCL_OK) { + return TCL_ERROR; + } + i = 0; + } + for ( ; i < objc; i++) { + string = Tcl_GetStringFromObj(objv[i], NULL); + n = TkFindStateNum(NULL, NULL, weightMap, string); + if (n != TK_FW_UNKNOWN) { + faPtr->weight = n; + continue; + } + n = TkFindStateNum(NULL, NULL, slantMap, string); + if (n != TK_FS_UNKNOWN) { + faPtr->slant = n; + continue; + } + n = TkFindStateNum(NULL, NULL, underlineMap, string); + if (n != 0) { + faPtr->underline = n; + continue; + } + n = TkFindStateNum(NULL, NULL, overstrikeMap, string); + if (n != 0) { + faPtr->overstrike = n; + continue; + } + + /* + * Unknown style. + */ + + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "unknown font style \"", string, "\"", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * TkParseXLFD -- + * + * Break up a fully specified XLFD into a set of font attributes. + * + * Results: + * Return value is TCL_ERROR if string was not a fully specified XLFD. + * Otherwise, fills font attribute buffer with the values parsed + * from the XLFD and returns TCL_OK. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +int +TkParseXLFD(string, 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. */ +{ + char *src; + CONST char *str; + int i, j; + char *field[XLFD_NUMFIELDS + 2]; + Tcl_DString ds; + + memset(field, '\0', sizeof(field)); + + str = string; + if (*str == '-') { + str++; + } + + Tcl_DStringInit(&ds); + Tcl_DStringAppend(&ds, (char *) str, -1); + src = Tcl_DStringValue(&ds); + + field[0] = src; + for (i = 0; *src != '\0'; src++) { + if (isupper(UCHAR(*src))) { + *src = tolower(UCHAR(*src)); + } + if (*src == '-') { + i++; + if (i > XLFD_NUMFIELDS) { + break; + } + *src = '\0'; + field[i] = src + 1; + } + } + + /* + * 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 + * 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". + */ + + if ((i > XLFD_ADD_STYLE) && (FieldSpecified(field[XLFD_ADD_STYLE]))) { + if (atoi(field[XLFD_ADD_STYLE]) != 0) { + for (j = XLFD_NUMFIELDS - 1; j >= XLFD_ADD_STYLE; j--) { + field[j + 1] = field[j]; + } + field[XLFD_ADD_STYLE] = NULL; + i++; + } + } + + /* + * Bail if we don't have enough of the fields (up to pointsize). + */ + + if (i < XLFD_FAMILY) { + Tcl_DStringFree(&ds); + return TCL_ERROR; + } + + if (FieldSpecified(field[XLFD_FOUNDRY])) { + xaPtr->foundry = Tk_GetUid(field[XLFD_FOUNDRY]); + } + + if (FieldSpecified(field[XLFD_FAMILY])) { + xaPtr->fa.family = Tk_GetUid(field[XLFD_FAMILY]); + } + if (FieldSpecified(field[XLFD_WEIGHT])) { + xaPtr->fa.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; + } else { + xaPtr->fa.slant = TK_FS_ITALIC; + } + } + if (FieldSpecified(field[XLFD_SETWIDTH])) { + xaPtr->setwidth = TkFindStateNum(NULL, NULL, xlfdSetwidthMap, + field[XLFD_SETWIDTH]); + } + + /* XLFD_ADD_STYLE ignored. */ + + /* + * Pointsize in tenths of a point, but treat it as tenths of a pixel. + */ + + if (FieldSpecified(field[XLFD_POINT_SIZE])) { + if (field[XLFD_POINT_SIZE][0] == '[') { + /* + * Some X fonts have the point size specified as follows: + * + * [ N1 N2 N3 N4 ] + * + * where N1 is the point size (in points, not decipoints!), and + * N2, N3, and N4 are some additional numbers that I don't know + * the purpose of, so I ignore them. + */ + + xaPtr->fa.pointsize = atoi(field[XLFD_POINT_SIZE] + 1); + } else if (Tcl_GetInt(NULL, field[XLFD_POINT_SIZE], + &xaPtr->fa.pointsize) == TCL_OK) { + xaPtr->fa.pointsize /= 10; + } else { + return TCL_ERROR; + } + } + + /* + * Pixel height of font. If specified, overrides pointsize. + */ + + if (FieldSpecified(field[XLFD_PIXEL_SIZE])) { + if (field[XLFD_PIXEL_SIZE][0] == '[') { + /* + * Some X fonts have the pixel size specified as follows: + * + * [ N1 N2 N3 N4 ] + * + * where N1 is the pixel size, and where N2, N3, and N4 + * are some additional numbers that I don't know + * the purpose of, so I ignore them. + */ + + xaPtr->fa.pointsize = atoi(field[XLFD_PIXEL_SIZE] + 1); + } else if (Tcl_GetInt(NULL, field[XLFD_PIXEL_SIZE], + &xaPtr->fa.pointsize) != TCL_OK) { + return TCL_ERROR; + } + } + + xaPtr->fa.pointsize = -xaPtr->fa.pointsize; + + /* XLFD_RESOLUTION_X ignored. */ + + /* XLFD_RESOLUTION_Y ignored. */ + + /* XLFD_SPACING ignored. */ + + /* XLFD_AVERAGE_WIDTH ignored. */ + + if (FieldSpecified(field[XLFD_REGISTRY])) { + xaPtr->charset = TkFindStateNum(NULL, NULL, xlfdCharsetMap, + field[XLFD_REGISTRY]); + } + if (FieldSpecified(field[XLFD_ENCODING])) { + xaPtr->encoding = atoi(field[XLFD_ENCODING]); + } + + Tcl_DStringFree(&ds); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * FieldSpecified -- + * + * Helper function for TkParseXLFD(). Determines if a field in the + * XLFD was set to a non-null, non-don't-care value. + * + * Results: + * The return value is 0 if the field in the XLFD was not set and + * should be ignored, non-zero otherwise. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +static int +FieldSpecified(field) + CONST char *field; /* The field of the XLFD to check. Strictly + * speaking, only when the string is "*" does it mean + * don't-care. However, an unspecified or question + * mark is also interpreted as don't-care. */ +{ + char ch; + + if (field == NULL) { + return 0; + } + ch = field[0]; + return (ch != '*' && ch != '?'); +} + +/* + *--------------------------------------------------------------------------- + * + * 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; +} + diff --git a/generic/tkFont.h b/generic/tkFont.h new file mode 100644 index 0000000..758c329 --- /dev/null +++ b/generic/tkFont.h @@ -0,0 +1,208 @@ +/* + * tkFont.h -- + * + * Declarations for interfaces between the generic and platform- + * specific parts of the font package. This information is not + * visible outside of the font package. + * + * 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: @(#) tkFont.h 1.11 97/05/07 14:44:13 + */ + +#ifndef _TKFONT +#define _TKFONT + +/* + * The following structure keeps track of the attributes of a font. It can + * be used to keep track of either the desired attributes or the actual + * attributes gotten when the font was instantiated. + */ + +typedef struct TkFontAttributes { + Tk_Uid family; /* Font family. The most important field. */ + int pointsize; /* 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. */ + int underline; /* Non-zero for underline font. */ + int overstrike; /* Non-zero for overstrike font. */ +} TkFontAttributes; + +/* + * Possible values for the "weight" field in a TkFontAttributes structure. + * Weight is a subjective term and depends on what the company that created + * the font considers bold. + */ + +#define TK_FW_NORMAL 0 +#define TK_FW_BOLD 1 + +#define TK_FW_UNKNOWN -1 /* Unknown weight. This value is used for + * error checking and is never actually stored + * in the weight field. */ + +/* + * Possible values for the "slant" field in a TkFontAttributes structure. + */ + +#define TK_FS_ROMAN 0 +#define TK_FS_ITALIC 1 +#define TK_FS_OBLIQUE 2 /* This value is only used when parsing X + * font names to determine the closest + * match. It is only stored in the + * XLFDAttributes structure, never in the + * slant field of the TkFontAttributes. */ + +#define TK_FS_UNKNOWN -1 /* Unknown slant. This value is used for + * error checking and is never actually stored + * in the slant field. */ + +/* + * The following structure keeps track of the metrics for an instantiated + * font. The metrics are the physical properties of the font itself. + */ + +typedef struct TkFontMetrics { + int ascent; /* From baseline to top of font. */ + int descent; /* From baseline to bottom of font. */ + int maxWidth; /* Width of widest character in font. */ + int fixed; /* Non-zero if this is a fixed-width font, + * 0 otherwise. */ +} TkFontMetrics; + +/* + * The following structure is used to keep track of the generic information + * about a font. Each platform-specific font is represented by a structure + * with the following structure at its beginning, plus any platform- + * specific stuff after that. + */ + +typedef struct TkFont { + /* + * Fields used and maintained exclusively by generic code. + */ + + int refCount; /* Number of users of the TkFont. */ + 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. */ + int tabWidth; /* Width of tabs in this font (pixels). */ + int underlinePos; /* Offset from baseline to origin of + * underline bar (used for drawing underlines + * on a non-underlined font). */ + int underlineHeight; /* Height of underline bar (used for drawing + * underlines on a non-underlined font). */ + + /* + * Fields in the generic font structure that are filled in by + * platform-specific code. + */ + + Font fid; /* For backwards compatibility with XGCValues + * structures. Remove when TkGCValues is + * implemented. */ + TkFontAttributes fa; /* Actual font attributes obtained when the + * the font was created, as opposed to the + * desired attributes passed in to + * TkpGetFontFromAttributes(). The desired + * metrics can be determined from the string + * that was used to create this font. */ + TkFontMetrics fm; /* Font metrics determined when font was + * created. */ +} TkFont; + +/* + * The following structure is used to return attributes when parsing an + * XLFD. The extra information is of interest to the Unix-specific code + * when attempting to find the closest matching font. + */ + +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. */ +} TkXLFDAttributes; + +/* + * Possible values for the "setwidth" field in a TkXLFDAttributes structure. + * The setwidth is whether characters are considered wider or narrower than + * normal. + */ + +#define TK_SW_NORMAL 0 +#define TK_SW_CONDENSE 1 +#define TK_SW_EXPAND 2 +#define TK_SW_UNKNOWN 3 /* Unknown setwidth. This value may be + * 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. + */ + +#define XLFD_FOUNDRY 0 +#define XLFD_FAMILY 1 +#define XLFD_WEIGHT 2 +#define XLFD_SLANT 3 +#define XLFD_SETWIDTH 4 +#define XLFD_ADD_STYLE 5 +#define XLFD_PIXEL_SIZE 6 +#define XLFD_POINT_SIZE 7 +#define XLFD_RESOLUTION_X 8 +#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. */ + +/* + * Exported from 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)); + +/* + * Common APIs exported to tkFont.c from all platform-specific + * implementations. + */ + +EXTERN void TkpDeleteFont _ANSI_ARGS_((TkFont *tkFontPtr)); +EXTERN TkFont * TkpGetFontFromAttributes _ANSI_ARGS_(( + TkFont *tkFontPtr, Tk_Window tkwin, + CONST TkFontAttributes *faPtr)); +EXTERN void TkpGetFontFamilies _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin)); +EXTERN TkFont * TkpGetNativeFont _ANSI_ARGS_((Tk_Window tkwin, + CONST char *name)); + +#endif /* _TKFONT */ diff --git a/generic/tkFrame.c b/generic/tkFrame.c new file mode 100644 index 0000000..a11f566 --- /dev/null +++ b/generic/tkFrame.c @@ -0,0 +1,939 @@ +/* + * tkFrame.c -- + * + * This module implements "frame" and "toplevel" widgets for + * the Tk toolkit. Frames are windows with a background color + * and possibly a 3-D effect, but not much else in the way of + * attributes. + * + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkFrame.c 1.82 97/08/08 17:26:26 + */ + +#include "default.h" +#include "tkPort.h" +#include "tkInt.h" + +/* + * A data structure of the following type is kept for each + * frame that currently exists for this process: + */ + +typedef struct { + Tk_Window tkwin; /* Window that embodies the frame. NULL + * means that the window has been destroyed + * but the data structures haven't yet been + * cleaned up. */ + Display *display; /* Display containing widget. Used, among + * other things, so that resources can be + * freed even after tkwin has gone away. */ + Tcl_Interp *interp; /* Interpreter associated with widget. Used + * to delete widget command. */ + Tcl_Command widgetCmd; /* Token for frame's widget command. */ + char *className; /* Class name for widget (from configuration + * option). Malloc-ed. */ + int mask; /* Either FRAME or TOPLEVEL; used to select + * which configuration options are valid for + * widget. */ + char *screenName; /* Screen on which widget is created. Non-null + * only for top-levels. Malloc-ed, may be + * NULL. */ + char *visualName; /* Textual description of visual for window, + * from -visual option. Malloc-ed, may be + * NULL. */ + char *colormapName; /* Textual description of colormap for window, + * from -colormap option. Malloc-ed, may be + * NULL. */ + char *menuName; /* Textual description of menu to use for + * menubar. Malloc-ed, may be NULL. */ + Colormap colormap; /* If not None, identifies a colormap + * allocated for this window, which must be + * freed when the window is deleted. */ + Tk_3DBorder border; /* Structure used to draw 3-D border and + * background. NULL means no background + * or border. */ + int borderWidth; /* Width of 3-D border (if any). */ + 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. + * 0 means don't draw a highlight. */ + XColor *highlightBgColorPtr; + /* Color for drawing traversal highlight + * area when highlight is off. */ + XColor *highlightColorPtr; /* Color for drawing traversal highlight. */ + int width; /* Width to request for window. <= 0 means + * don't request any size. */ + int height; /* Height to request for window. <= 0 means + * don't request any size. */ + Tk_Cursor cursor; /* Current cursor for window, or None. */ + char *takeFocus; /* Value of -takefocus option; not used in + * the C code, but used by keyboard traversal + * scripts. Malloc'ed, but may be NULL. */ + int isContainer; /* 1 means this window is a container, 0 means + * that it isn't. */ + char *useThis; /* If the window is embedded, this points to + * the name of the window in which it is + * embedded (malloc'ed). For non-embedded + * windows this is NULL. */ + int flags; /* Various flags; see below for + * definitions. */ +} Frame; + +/* + * Flag bits for frames: + * + * REDRAW_PENDING: Non-zero means a DoWhenIdle handler + * has already been queued to redraw + * this window. + * GOT_FOCUS: Non-zero means this widget currently + * has the input focus. + */ + +#define REDRAW_PENDING 1 +#define GOT_FOCUS 4 + +/* + * The following flag bits are used so that there can be separate + * defaults for some configuration options for frames and toplevels. + */ + +#define FRAME TK_CONFIG_USER_BIT +#define TOPLEVEL (TK_CONFIG_USER_BIT << 1) +#define BOTH (FRAME | TOPLEVEL) + +static Tk_ConfigSpec configSpecs[] = { + {TK_CONFIG_BORDER, "-background", "background", "Background", + DEF_FRAME_BG_COLOR, Tk_Offset(Frame, border), + BOTH|TK_CONFIG_COLOR_ONLY|TK_CONFIG_NULL_OK}, + {TK_CONFIG_BORDER, "-background", "background", "Background", + DEF_FRAME_BG_MONO, Tk_Offset(Frame, border), + BOTH|TK_CONFIG_MONO_ONLY|TK_CONFIG_NULL_OK}, + {TK_CONFIG_SYNONYM, "-bd", "borderWidth", (char *) NULL, + (char *) NULL, 0, BOTH}, + {TK_CONFIG_SYNONYM, "-bg", "background", (char *) NULL, + (char *) NULL, 0, BOTH}, + {TK_CONFIG_PIXELS, "-borderwidth", "borderWidth", "BorderWidth", + DEF_FRAME_BORDER_WIDTH, Tk_Offset(Frame, borderWidth), BOTH}, + {TK_CONFIG_STRING, "-class", "class", "Class", + DEF_FRAME_CLASS, Tk_Offset(Frame, className), FRAME}, + {TK_CONFIG_STRING, "-class", "class", "Class", + DEF_TOPLEVEL_CLASS, Tk_Offset(Frame, className), TOPLEVEL}, + {TK_CONFIG_STRING, "-colormap", "colormap", "Colormap", + DEF_FRAME_COLORMAP, Tk_Offset(Frame, colormapName), + BOTH|TK_CONFIG_NULL_OK}, + {TK_CONFIG_BOOLEAN, "-container", "container", "Container", + DEF_FRAME_CONTAINER, Tk_Offset(Frame, isContainer), BOTH}, + {TK_CONFIG_ACTIVE_CURSOR, "-cursor", "cursor", "Cursor", + DEF_FRAME_CURSOR, Tk_Offset(Frame, cursor), BOTH|TK_CONFIG_NULL_OK}, + {TK_CONFIG_PIXELS, "-height", "height", "Height", + DEF_FRAME_HEIGHT, Tk_Offset(Frame, height), BOTH}, + {TK_CONFIG_COLOR, "-highlightbackground", "highlightBackground", + "HighlightBackground", DEF_FRAME_HIGHLIGHT_BG, + Tk_Offset(Frame, highlightBgColorPtr), BOTH}, + {TK_CONFIG_COLOR, "-highlightcolor", "highlightColor", "HighlightColor", + DEF_FRAME_HIGHLIGHT, Tk_Offset(Frame, highlightColorPtr), BOTH}, + {TK_CONFIG_PIXELS, "-highlightthickness", "highlightThickness", + "HighlightThickness", + DEF_FRAME_HIGHLIGHT_WIDTH, Tk_Offset(Frame, highlightWidth), BOTH}, + {TK_CONFIG_STRING, "-menu", "menu", "Menu", + DEF_TOPLEVEL_MENU, Tk_Offset(Frame, menuName), + TOPLEVEL|TK_CONFIG_NULL_OK}, + {TK_CONFIG_RELIEF, "-relief", "relief", "Relief", + DEF_FRAME_RELIEF, Tk_Offset(Frame, relief), BOTH}, + {TK_CONFIG_STRING, "-screen", "screen", "Screen", + DEF_TOPLEVEL_SCREEN, Tk_Offset(Frame, screenName), + TOPLEVEL|TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-takefocus", "takeFocus", "TakeFocus", + DEF_FRAME_TAKE_FOCUS, Tk_Offset(Frame, takeFocus), + BOTH|TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-use", "use", "Use", + DEF_FRAME_USE, Tk_Offset(Frame, useThis), TOPLEVEL|TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-visual", "visual", "Visual", + DEF_FRAME_VISUAL, Tk_Offset(Frame, visualName), + BOTH|TK_CONFIG_NULL_OK}, + {TK_CONFIG_PIXELS, "-width", "width", "Width", + DEF_FRAME_WIDTH, Tk_Offset(Frame, width), BOTH}, + {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, 0} +}; + +/* + * Forward declarations for procedures defined later in this file: + */ + +static int ConfigureFrame _ANSI_ARGS_((Tcl_Interp *interp, + Frame *framePtr, int argc, char **argv, + int flags)); +static void DestroyFrame _ANSI_ARGS_((char *memPtr)); +static void DisplayFrame _ANSI_ARGS_((ClientData clientData)); +static void FrameCmdDeletedProc _ANSI_ARGS_(( + ClientData clientData)); +static void FrameEventProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +static int FrameWidgetCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static void MapFrame _ANSI_ARGS_((ClientData clientData)); + +/* + *-------------------------------------------------------------- + * + * Tk_FrameCmd, Tk_ToplevelCmd -- + * + * These procedures are invoked to process the "frame" and + * "toplevel" Tcl commands. See the user documentation for + * details on what they do. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. These procedures are just wrappers; + * they call ButtonCreate to do all of the real work. + * + *-------------------------------------------------------------- + */ + +int +Tk_FrameCmd(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 TkCreateFrame(clientData, interp, argc, argv, 0, (char *) NULL); +} + +int +Tk_ToplevelCmd(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 TkCreateFrame(clientData, interp, argc, argv, 1, (char *) NULL); +} + +/* + *-------------------------------------------------------------- + * + * TkFrameCreate -- + * + * This procedure is invoked to process the "frame" and "toplevel" + * Tcl commands; it is also invoked directly by Tk_Init to create + * a new main window. See the user documentation for the "frame" + * and "toplevel" commands for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +int +TkCreateFrame(clientData, interp, argc, argv, toplevel, appName) + ClientData clientData; /* Main window associated with interpreter. + * If we're called by Tk_Init to create a + * new application, then this is NULL. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ + int toplevel; /* Non-zero means create a toplevel window, + * zero means create a frame. */ + char *appName; /* Should only be non-NULL if clientData is + * NULL: gives the base name to use for the + * new application. */ +{ + Tk_Window tkwin = (Tk_Window) clientData; + Frame *framePtr; + Tk_Window new; + char *className, *screenName, *visualName, *colormapName, *arg, *useOption; + int i, c, length, depth; + unsigned int mask; + Colormap colormap; + Visual *visual; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " pathName ?options?\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * Pre-process the argument list. Scan through it to find any + * "-class", "-screen", "-visual", and "-colormap" options. These + * arguments need to be processed specially, before the window + * is configured using the usual Tk mechanisms. + */ + + className = colormapName = screenName = visualName = useOption = NULL; + colormap = None; + for (i = 2; i < argc; i += 2) { + arg = argv[i]; + length = strlen(arg); + if (length < 2) { + continue; + } + c = arg[1]; + if ((c == 'c') && (strncmp(arg, "-class", strlen(arg)) == 0) + && (length >= 3)) { + className = argv[i+1]; + } else if ((c == 'c') + && (strncmp(arg, "-colormap", strlen(arg)) == 0)) { + colormapName = argv[i+1]; + } else if ((c == 's') && toplevel + && (strncmp(arg, "-screen", strlen(arg)) == 0)) { + screenName = argv[i+1]; + } else if ((c == 'u') && toplevel + && (strncmp(arg, "-use", strlen(arg)) == 0)) { + useOption = argv[i+1]; + } else if ((c == 'v') + && (strncmp(arg, "-visual", strlen(arg)) == 0)) { + visualName = argv[i+1]; + } + } + + /* + * Create the window, and deal with the special options -use, + * -classname, -colormap, -screenname, and -visual. These options + * must be handle before calling ConfigureFrame below, and they must + * also be processed in a particular order, for the following + * reasons: + * 1. Must set the window's class before calling ConfigureFrame, + * so that unspecified options are looked up in the option + * database using the correct class. + * 2. Must set visual information before calling ConfigureFrame + * so that colors are allocated in a proper colormap. + * 3. Must call TkpUseWindow before setting non-default visual + * information, since TkpUseWindow changes the defaults. + */ + + if (screenName == NULL) { + screenName = (toplevel) ? "" : NULL; + } + if (tkwin != NULL) { + new = Tk_CreateWindowFromPath(interp, tkwin, argv[1], screenName); + } else { + /* + * We were called from Tk_Init; create a new application. + */ + + if (appName == NULL) { + panic("TkCreateFrame didn't get application name"); + } + new = TkCreateMainWindow(interp, screenName, appName); + } + if (new == NULL) { + goto error; + } + if (className == NULL) { + className = Tk_GetOption(new, "class", "Class"); + if (className == NULL) { + className = (toplevel) ? "Toplevel" : "Frame"; + } + } + Tk_SetClass(new, className); + if (useOption == NULL) { + useOption = Tk_GetOption(new, "use", "Use"); + } + if (useOption != NULL) { + if (TkpUseWindow(interp, new, useOption) != TCL_OK) { + goto error; + } + } + if (visualName == NULL) { + visualName = Tk_GetOption(new, "visual", "Visual"); + } + if (colormapName == NULL) { + colormapName = Tk_GetOption(new, "colormap", "Colormap"); + } + if (visualName != NULL) { + visual = Tk_GetVisual(interp, new, visualName, &depth, + (colormapName == NULL) ? &colormap : (Colormap *) NULL); + if (visual == NULL) { + goto error; + } + Tk_SetWindowVisual(new, visual, depth, colormap); + } + if (colormapName != NULL) { + colormap = Tk_GetColormap(interp, new, colormapName); + if (colormap == None) { + goto error; + } + Tk_SetWindowColormap(new, colormap); + } + + /* + * For top-level windows, provide an initial geometry request of + * 200x200, just so the window looks nicer on the screen if it + * doesn't request a size for itself. + */ + + if (toplevel) { + Tk_GeometryRequest(new, 200, 200); + } + + /* + * Create the widget record, process configuration options, and + * create event handlers. Then fill in a few additional fields + * in the widget record from the special options. + */ + + framePtr = (Frame *) ckalloc(sizeof(Frame)); + framePtr->tkwin = new; + framePtr->display = Tk_Display(new); + framePtr->interp = interp; + framePtr->widgetCmd = Tcl_CreateCommand(interp, + Tk_PathName(new), FrameWidgetCmd, + (ClientData) framePtr, FrameCmdDeletedProc); + framePtr->className = NULL; + framePtr->mask = (toplevel) ? TOPLEVEL : FRAME; + framePtr->screenName = NULL; + framePtr->visualName = NULL; + framePtr->colormapName = NULL; + framePtr->colormap = colormap; + framePtr->border = NULL; + framePtr->borderWidth = 0; + framePtr->relief = TK_RELIEF_FLAT; + framePtr->highlightWidth = 0; + framePtr->highlightBgColorPtr = NULL; + framePtr->highlightColorPtr = NULL; + framePtr->width = 0; + framePtr->height = 0; + framePtr->cursor = None; + framePtr->takeFocus = NULL; + framePtr->isContainer = 0; + framePtr->useThis = NULL; + framePtr->flags = 0; + framePtr->menuName = NULL; + + /* + * Store backreference to frame widget in window structure. + */ + TkSetClassProcs(new, NULL, (ClientData) framePtr); + + mask = ExposureMask | StructureNotifyMask | FocusChangeMask; + if (toplevel) { + mask |= ActivateMask; + } + Tk_CreateEventHandler(new, mask, FrameEventProc, (ClientData) framePtr); + if (ConfigureFrame(interp, framePtr, argc-2, argv+2, 0) != TCL_OK) { + goto error; + } + if ((framePtr->isContainer)) { + if (framePtr->useThis == NULL) { + TkpMakeContainer(framePtr->tkwin); + } else { + Tcl_AppendResult(interp,"A window cannot have both the -use ", + "and the -container option set."); + return TCL_ERROR; + } + } + if (toplevel) { + Tcl_DoWhenIdle(MapFrame, (ClientData) framePtr); + } + interp->result = Tk_PathName(new); + return TCL_OK; + + error: + if (new != NULL) { + Tk_DestroyWindow(new); + } + return TCL_ERROR; +} + +/* + *-------------------------------------------------------------- + * + * FrameWidgetCmd -- + * + * This procedure is invoked to process the Tcl command + * that corresponds to a frame widget. See the user + * documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +static int +FrameWidgetCmd(clientData, interp, argc, argv) + ClientData clientData; /* Information about frame widget. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + register Frame *framePtr = (Frame *) clientData; + int result; + size_t length; + int c, i; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " option ?arg arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_Preserve((ClientData) framePtr); + 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); + result = TCL_ERROR; + goto done; + } + result = Tk_ConfigureValue(interp, framePtr->tkwin, configSpecs, + (char *) framePtr, argv[2], framePtr->mask); + } else if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0) + && (length >= 2)) { + if (argc == 2) { + result = Tk_ConfigureInfo(interp, framePtr->tkwin, configSpecs, + (char *) framePtr, (char *) NULL, framePtr->mask); + } else if (argc == 3) { + result = Tk_ConfigureInfo(interp, framePtr->tkwin, configSpecs, + (char *) framePtr, argv[2], framePtr->mask); + } else { + /* + * Don't allow the options -class, -colormap, -container, + * -newcmap, -screen, -use, or -visual to be changed. + */ + + for (i = 2; i < argc; i++) { + length = strlen(argv[i]); + if (length < 2) { + continue; + } + c = argv[i][1]; + if (((c == 'c') && (strncmp(argv[i], "-class", length) == 0) + && (length >= 2)) + || ((c == 'c') && (framePtr->mask == TOPLEVEL) + && (strncmp(argv[i], "-colormap", length) == 0) + && (length >= 3)) + || ((c == 'c') + && (strncmp(argv[i], "-container", length) == 0) + && (length >= 3)) + || ((c == 's') && (framePtr->mask == TOPLEVEL) + && (strncmp(argv[i], "-screen", length) == 0)) + || ((c == 'u') && (framePtr->mask == TOPLEVEL) + && (strncmp(argv[i], "-use", length) == 0)) + || ((c == 'v') && (framePtr->mask == TOPLEVEL) + && (strncmp(argv[i], "-visual", length) == 0))) { + Tcl_AppendResult(interp, "can't modify ", argv[i], + " option after widget is created", (char *) NULL); + result = TCL_ERROR; + goto done; + } + } + result = ConfigureFrame(interp, framePtr, argc-2, argv+2, + TK_CONFIG_ARGV_ONLY); + } + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be cget or configure", (char *) NULL); + result = TCL_ERROR; + } + + done: + Tcl_Release((ClientData) framePtr); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * DestroyFrame -- + * + * This procedure is invoked by Tcl_EventuallyFree or Tcl_Release + * to clean up the internal structure of a frame at a safe time + * (when no-one is using it anymore). + * + * Results: + * None. + * + * Side effects: + * Everything associated with the frame is freed up. + * + *---------------------------------------------------------------------- + */ + +static void +DestroyFrame(memPtr) + char *memPtr; /* Info about frame widget. */ +{ + register Frame *framePtr = (Frame *) memPtr; + + Tk_FreeOptions(configSpecs, (char *) framePtr, framePtr->display, + framePtr->mask); + if (framePtr->colormap != None) { + Tk_FreeColormap(framePtr->display, framePtr->colormap); + } + ckfree((char *) framePtr); +} + +/* + *---------------------------------------------------------------------- + * + * ConfigureFrame -- + * + * This procedure is called to process an argv/argc list, plus + * the Tk option database, in order to configure (or + * reconfigure) a frame widget. + * + * Results: + * The return value is a standard Tcl result. If TCL_ERROR is + * returned, then interp->result contains an error message. + * + * Side effects: + * Configuration information, such as text string, colors, font, + * etc. get set for framePtr; old resources get freed, if there + * were any. + * + *---------------------------------------------------------------------- + */ + +static int +ConfigureFrame(interp, framePtr, argc, argv, flags) + Tcl_Interp *interp; /* Used for error reporting. */ + register Frame *framePtr; /* 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. */ +{ + char *oldMenuName; + + /* + * Need the old menubar name for the menu code to delete it. + */ + + if (framePtr->menuName == NULL) { + oldMenuName = NULL; + } else { + oldMenuName = ckalloc(strlen(framePtr->menuName) + 1); + strcpy(oldMenuName, framePtr->menuName); + } + + if (Tk_ConfigureWidget(interp, framePtr->tkwin, configSpecs, + argc, argv, (char *) framePtr, flags | framePtr->mask) != TCL_OK) { + return TCL_ERROR; + } + + if (((oldMenuName == NULL) && (framePtr->menuName != NULL)) + || ((oldMenuName != NULL) && (framePtr->menuName == NULL)) + || ((oldMenuName != NULL) && (framePtr->menuName != NULL) + && strcmp(oldMenuName, framePtr->menuName) != 0)) { + TkSetWindowMenuBar(interp, framePtr->tkwin, oldMenuName, + framePtr->menuName); + } + + if (framePtr->border != NULL) { + Tk_SetBackgroundFromBorder(framePtr->tkwin, framePtr->border); + } else { + Tk_SetWindowBackgroundPixmap(framePtr->tkwin, None); + } + + if (framePtr->highlightWidth < 0) { + framePtr->highlightWidth = 0; + } + Tk_SetInternalBorder(framePtr->tkwin, + framePtr->borderWidth + framePtr->highlightWidth); + if ((framePtr->width > 0) || (framePtr->height > 0)) { + Tk_GeometryRequest(framePtr->tkwin, framePtr->width, + framePtr->height); + } + + if (oldMenuName != NULL) { + ckfree(oldMenuName); + } + + if (Tk_IsMapped(framePtr->tkwin)) { + if (!(framePtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(DisplayFrame, (ClientData) framePtr); + } + framePtr->flags |= REDRAW_PENDING; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * DisplayFrame -- + * + * This procedure is invoked to display a frame widget. + * + * Results: + * None. + * + * Side effects: + * Commands are output to X to display the frame in its + * current mode. + * + *---------------------------------------------------------------------- + */ + +static void +DisplayFrame(clientData) + ClientData clientData; /* Information about widget. */ +{ + register Frame *framePtr = (Frame *) clientData; + register Tk_Window tkwin = framePtr->tkwin; + GC gc; + + framePtr->flags &= ~REDRAW_PENDING; + if ((framePtr->tkwin == NULL) || !Tk_IsMapped(tkwin) + || framePtr->isContainer) { + return; + } + + if (framePtr->border != NULL) { + Tk_Fill3DRectangle(tkwin, Tk_WindowId(tkwin), + framePtr->border, framePtr->highlightWidth, + framePtr->highlightWidth, + Tk_Width(tkwin) - 2*framePtr->highlightWidth, + Tk_Height(tkwin) - 2*framePtr->highlightWidth, + framePtr->borderWidth, framePtr->relief); + } + if (framePtr->highlightWidth != 0) { + if (framePtr->flags & GOT_FOCUS) { + gc = Tk_GCForColor(framePtr->highlightColorPtr, + Tk_WindowId(tkwin)); + } else { + gc = Tk_GCForColor(framePtr->highlightBgColorPtr, + Tk_WindowId(tkwin)); + } + Tk_DrawFocusHighlight(tkwin, gc, framePtr->highlightWidth, + Tk_WindowId(tkwin)); + } +} + +/* + *-------------------------------------------------------------- + * + * FrameEventProc -- + * + * This procedure is invoked by the Tk dispatcher on + * structure changes to a frame. For frames with 3D + * borders, this procedure is also invoked for exposures. + * + * Results: + * None. + * + * Side effects: + * When the window gets deleted, internal structures get + * cleaned up. When it gets exposed, it is redisplayed. + * + *-------------------------------------------------------------- + */ + +static void +FrameEventProc(clientData, eventPtr) + ClientData clientData; /* Information about window. */ + register XEvent *eventPtr; /* Information about event. */ +{ + register Frame *framePtr = (Frame *) clientData; + + if (((eventPtr->type == Expose) && (eventPtr->xexpose.count == 0)) + || (eventPtr->type == ConfigureNotify)) { + goto redraw; + } else if (eventPtr->type == DestroyNotify) { + if (framePtr->menuName != NULL) { + TkSetWindowMenuBar(framePtr->interp, framePtr->tkwin, + framePtr->menuName, NULL); + ckfree(framePtr->menuName); + framePtr->menuName = NULL; + } + if (framePtr->tkwin != NULL) { + + /* + * If this window is a container, then this event could be + * coming from the embedded application, in which case + * Tk_DestroyWindow hasn't been called yet. When Tk_DestroyWindow + * is called later, then another destroy event will be generated. + * We need to be sure we ignore the second event, since the frame + * could be gone by then. To do so, delete the event handler + * explicitly (normally it's done implicitly by Tk_DestroyWindow). + */ + + Tk_DeleteEventHandler(framePtr->tkwin, + ExposureMask|StructureNotifyMask|FocusChangeMask, + FrameEventProc, (ClientData) framePtr); + framePtr->tkwin = NULL; + Tcl_DeleteCommandFromToken(framePtr->interp, framePtr->widgetCmd); + } + if (framePtr->flags & REDRAW_PENDING) { + Tcl_CancelIdleCall(DisplayFrame, (ClientData) framePtr); + } + Tcl_CancelIdleCall(MapFrame, (ClientData) framePtr); + Tcl_EventuallyFree((ClientData) framePtr, DestroyFrame); + } else if (eventPtr->type == FocusIn) { + if (eventPtr->xfocus.detail != NotifyInferior) { + framePtr->flags |= GOT_FOCUS; + if (framePtr->highlightWidth > 0) { + goto redraw; + } + } + } else if (eventPtr->type == FocusOut) { + if (eventPtr->xfocus.detail != NotifyInferior) { + framePtr->flags &= ~GOT_FOCUS; + if (framePtr->highlightWidth > 0) { + goto redraw; + } + } + } else if (eventPtr->type == ActivateNotify) { + TkpSetMainMenubar(framePtr->interp, framePtr->tkwin, + framePtr->menuName); + } + return; + + redraw: + if ((framePtr->tkwin != NULL) && !(framePtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(DisplayFrame, (ClientData) framePtr); + framePtr->flags |= REDRAW_PENDING; + } +} + +/* + *---------------------------------------------------------------------- + * + * FrameCmdDeletedProc -- + * + * 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 +FrameCmdDeletedProc(clientData) + ClientData clientData; /* Pointer to widget record for widget. */ +{ + Frame *framePtr = (Frame *) clientData; + Tk_Window tkwin = framePtr->tkwin; + + if (framePtr->menuName != NULL) { + TkSetWindowMenuBar(framePtr->interp, framePtr->tkwin, + framePtr->menuName, NULL); + ckfree(framePtr->menuName); + framePtr->menuName = NULL; + } + + /* + * 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. + */ + + if (tkwin != NULL) { + framePtr->tkwin = NULL; + Tk_DestroyWindow(tkwin); + } +} + +/* + *---------------------------------------------------------------------- + * + * MapFrame -- + * + * This procedure is invoked as a when-idle handler to map a + * newly-created top-level frame. + * + * Results: + * None. + * + * Side effects: + * The frame given by the clientData argument is mapped. + * + *---------------------------------------------------------------------- + */ + +static void +MapFrame(clientData) + ClientData clientData; /* Pointer to frame structure. */ +{ + Frame *framePtr = (Frame *) clientData; + + /* + * Wait for all other background events to be processed before + * mapping window. This ensures that the window's correct geometry + * will have been determined before it is first mapped, so that the + * window manager doesn't get a false idea of its desired geometry. + */ + + Tcl_Preserve((ClientData) framePtr); + while (1) { + if (Tcl_DoOneEvent(TCL_IDLE_EVENTS) == 0) { + break; + } + + /* + * After each event, make sure that the window still exists + * and quit if the window has been destroyed. + */ + + if (framePtr->tkwin == NULL) { + Tcl_Release((ClientData) framePtr); + return; + } + } + Tk_MapWindow(framePtr->tkwin); + Tcl_Release((ClientData) framePtr); +} + +/* + *-------------------------------------------------------------- + * + * TkInstallFrameMenu -- + * + * This function is needed when a Windows HWND is created + * and a menubar has been set to the window with a system + * menu. It notifies the menu package so that the system + * menu can be rebuilt. + * + * Results: + * None. + * + * Side effects: + * The system menu (if any) is created for the menubar + * associated with this frame. + * + *-------------------------------------------------------------- + */ + +void +TkInstallFrameMenu(tkwin) + Tk_Window tkwin; /* The window that was just created. */ +{ + TkWindow *winPtr = (TkWindow *) tkwin; + + if (winPtr->mainPtr != NULL) { + Frame *framePtr; + framePtr = (Frame*) winPtr->instanceData; + TkpMenuNotifyToplevelCreate(winPtr->mainPtr->interp, + framePtr->menuName); + } +} diff --git a/generic/tkGC.c b/generic/tkGC.c new file mode 100644 index 0000000..f68db12 --- /dev/null +++ b/generic/tkGC.c @@ -0,0 +1,363 @@ +/* + * tkGC.c -- + * + * This file maintains a database of read-only graphics contexts + * for the Tk toolkit, in order to allow GC's to be shared. + * + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994 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: @(#) tkGC.c 1.18 96/02/15 18:53:32 + */ + +#include "tkPort.h" +#include "tk.h" + +/* + * One of the following data structures exists for each GC that is + * currently active. The structure is indexed with two hash tables, + * one based on the values in the graphics context and the other + * based on the display and GC identifier. + */ + +typedef struct { + GC gc; /* Graphics context. */ + Display *display; /* Display to which gc belongs. */ + int refCount; /* Number of active uses of gc. */ + Tcl_HashEntry *valueHashPtr;/* Entry in valueTable (needed when deleting + * this structure). */ +} TkGC; + +/* + * Hash table to map from a GC's values to a TkGC structure describing + * a GC with those values (used by Tk_GetGC). + */ + +static Tcl_HashTable valueTable; +typedef struct { + XGCValues values; /* Desired values for GC. */ + Display *display; /* Display for which GC is valid. */ + int screenNum; /* screen number of display */ + int depth; /* and depth for which GC is valid. */ +} ValueKey; + +/* + * Hash table for -> TkGC mapping. This table is used by + * Tk_FreeGC. + */ + +static Tcl_HashTable idTable; +typedef struct { + Display *display; /* Display for which GC was allocated. */ + GC gc; /* X's identifier for GC. */ +} IdKey; + +static int initialized = 0; /* 0 means static structures haven't been + * initialized yet. */ + +/* + * Forward declarations for procedures defined in this file: + */ + +static void GCInit _ANSI_ARGS_((void)); + +/* + *---------------------------------------------------------------------- + * + * Tk_GetGC -- + * + * Given a desired set of values for a graphics context, find + * a read-only graphics context with the desired values. + * + * Results: + * The return value is the X identifer for the desired graphics + * context. The caller should never modify this GC, and should + * call Tk_FreeGC when the GC is no longer needed. + * + * Side effects: + * The GC is added to an internal database with a reference count. + * For each call to this procedure, there should eventually be a call + * to Tk_FreeGC, so that the database can be cleaned up when GC's + * aren't needed anymore. + * + *---------------------------------------------------------------------- + */ + +GC +Tk_GetGC(tkwin, valueMask, valuePtr) + Tk_Window tkwin; /* Window in which GC will be used. */ + register unsigned long valueMask; + /* 1 bits correspond to values specified + * in *valuesPtr; other values are set + * from defaults. */ + register XGCValues *valuePtr; + /* Values are specified here for bits set + * in valueMask. */ +{ + ValueKey valueKey; + IdKey idKey; + Tcl_HashEntry *valueHashPtr, *idHashPtr; + register TkGC *gcPtr; + int new; + Drawable d, freeDrawable; + + if (!initialized) { + GCInit(); + } + + /* + * Must zero valueKey at start to clear out pad bytes that may be + * part of structure on some systems. + */ + + memset((VOID *) &valueKey, 0, sizeof(valueKey)); + + /* + * First, check to see if there's already a GC that will work + * for this request (exact matches only, sorry). + */ + + if (valueMask & GCFunction) { + valueKey.values.function = valuePtr->function; + } else { + valueKey.values.function = GXcopy; + } + if (valueMask & GCPlaneMask) { + valueKey.values.plane_mask = valuePtr->plane_mask; + } else { + valueKey.values.plane_mask = (unsigned) ~0; + } + if (valueMask & GCForeground) { + valueKey.values.foreground = valuePtr->foreground; + } else { + valueKey.values.foreground = 0; + } + if (valueMask & GCBackground) { + valueKey.values.background = valuePtr->background; + } else { + valueKey.values.background = 1; + } + if (valueMask & GCLineWidth) { + valueKey.values.line_width = valuePtr->line_width; + } else { + valueKey.values.line_width = 0; + } + if (valueMask & GCLineStyle) { + valueKey.values.line_style = valuePtr->line_style; + } else { + valueKey.values.line_style = LineSolid; + } + if (valueMask & GCCapStyle) { + valueKey.values.cap_style = valuePtr->cap_style; + } else { + valueKey.values.cap_style = CapButt; + } + if (valueMask & GCJoinStyle) { + valueKey.values.join_style = valuePtr->join_style; + } else { + valueKey.values.join_style = JoinMiter; + } + if (valueMask & GCFillStyle) { + valueKey.values.fill_style = valuePtr->fill_style; + } else { + valueKey.values.fill_style = FillSolid; + } + if (valueMask & GCFillRule) { + valueKey.values.fill_rule = valuePtr->fill_rule; + } else { + valueKey.values.fill_rule = EvenOddRule; + } + if (valueMask & GCArcMode) { + valueKey.values.arc_mode = valuePtr->arc_mode; + } else { + valueKey.values.arc_mode = ArcPieSlice; + } + if (valueMask & GCTile) { + valueKey.values.tile = valuePtr->tile; + } else { + valueKey.values.tile = None; + } + if (valueMask & GCStipple) { + valueKey.values.stipple = valuePtr->stipple; + } else { + valueKey.values.stipple = None; + } + if (valueMask & GCTileStipXOrigin) { + valueKey.values.ts_x_origin = valuePtr->ts_x_origin; + } else { + valueKey.values.ts_x_origin = 0; + } + if (valueMask & GCTileStipYOrigin) { + valueKey.values.ts_y_origin = valuePtr->ts_y_origin; + } else { + valueKey.values.ts_y_origin = 0; + } + if (valueMask & GCFont) { + valueKey.values.font = valuePtr->font; + } else { + valueKey.values.font = None; + } + if (valueMask & GCSubwindowMode) { + valueKey.values.subwindow_mode = valuePtr->subwindow_mode; + } else { + valueKey.values.subwindow_mode = ClipByChildren; + } + if (valueMask & GCGraphicsExposures) { + valueKey.values.graphics_exposures = valuePtr->graphics_exposures; + } else { + valueKey.values.graphics_exposures = True; + } + if (valueMask & GCClipXOrigin) { + valueKey.values.clip_x_origin = valuePtr->clip_x_origin; + } else { + valueKey.values.clip_x_origin = 0; + } + if (valueMask & GCClipYOrigin) { + valueKey.values.clip_y_origin = valuePtr->clip_y_origin; + } else { + valueKey.values.clip_y_origin = 0; + } + if (valueMask & GCClipMask) { + valueKey.values.clip_mask = valuePtr->clip_mask; + } else { + valueKey.values.clip_mask = None; + } + if (valueMask & GCDashOffset) { + valueKey.values.dash_offset = valuePtr->dash_offset; + } else { + valueKey.values.dash_offset = 0; + } + if (valueMask & GCDashList) { + valueKey.values.dashes = valuePtr->dashes; + } else { + valueKey.values.dashes = 4; + } + valueKey.display = Tk_Display(tkwin); + valueKey.screenNum = Tk_ScreenNumber(tkwin); + valueKey.depth = Tk_Depth(tkwin); + valueHashPtr = Tcl_CreateHashEntry(&valueTable, (char *) &valueKey, &new); + if (!new) { + gcPtr = (TkGC *) Tcl_GetHashValue(valueHashPtr); + gcPtr->refCount++; + return gcPtr->gc; + } + + /* + * No GC is currently available for this set of values. Allocate a + * new GC and add a new structure to the database. + */ + + gcPtr = (TkGC *) ckalloc(sizeof(TkGC)); + + /* + * Find or make a drawable to use to specify the screen and depth + * of the GC. We may have to make a small pixmap, to avoid doing + * Tk_MakeWindowExist on the window. + */ + + freeDrawable = None; + if (Tk_WindowId(tkwin) != None) { + d = Tk_WindowId(tkwin); + } else if (valueKey.depth == + DefaultDepth(valueKey.display, valueKey.screenNum)) { + d = RootWindow(valueKey.display, valueKey.screenNum); + } else { + d = Tk_GetPixmap(valueKey.display, + RootWindow(valueKey.display, valueKey.screenNum), + 1, 1, valueKey.depth); + freeDrawable = d; + } + + gcPtr->gc = XCreateGC(valueKey.display, d, valueMask, &valueKey.values); + gcPtr->display = valueKey.display; + gcPtr->refCount = 1; + gcPtr->valueHashPtr = valueHashPtr; + idKey.display = valueKey.display; + idKey.gc = gcPtr->gc; + idHashPtr = Tcl_CreateHashEntry(&idTable, (char *) &idKey, &new); + if (!new) { + panic("GC already registered in Tk_GetGC"); + } + Tcl_SetHashValue(valueHashPtr, gcPtr); + Tcl_SetHashValue(idHashPtr, gcPtr); + if (freeDrawable != None) { + Tk_FreePixmap(valueKey.display, freeDrawable); + } + + return gcPtr->gc; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_FreeGC -- + * + * This procedure is called to release a graphics context allocated by + * Tk_GetGC. + * + * Results: + * None. + * + * Side effects: + * The reference count associated with gc is decremented, and + * gc is officially deallocated if no-one is using it anymore. + * + *---------------------------------------------------------------------- + */ + +void +Tk_FreeGC(display, gc) + Display *display; /* Display for which gc was allocated. */ + GC gc; /* Graphics context to be released. */ +{ + IdKey idKey; + Tcl_HashEntry *idHashPtr; + register TkGC *gcPtr; + + if (!initialized) { + panic("Tk_FreeGC called before Tk_GetGC"); + } + + idKey.display = display; + idKey.gc = gc; + idHashPtr = Tcl_FindHashEntry(&idTable, (char *) &idKey); + if (idHashPtr == NULL) { + panic("Tk_FreeGC received unknown gc argument"); + } + gcPtr = (TkGC *) Tcl_GetHashValue(idHashPtr); + gcPtr->refCount--; + if (gcPtr->refCount == 0) { + Tk_FreeXId(gcPtr->display, (XID) XGContextFromGC(gcPtr->gc)); + XFreeGC(gcPtr->display, gcPtr->gc); + Tcl_DeleteHashEntry(gcPtr->valueHashPtr); + Tcl_DeleteHashEntry(idHashPtr); + ckfree((char *) gcPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * GCInit -- + * + * Initialize the structures used for GC management. + * + * Results: + * None. + * + * Side effects: + * Read the code. + * + *---------------------------------------------------------------------- + */ + +static void +GCInit() +{ + initialized = 1; + Tcl_InitHashTable(&valueTable, sizeof(ValueKey)/sizeof(int)); + Tcl_InitHashTable(&idTable, sizeof(IdKey)/sizeof(int)); +} diff --git a/generic/tkGeometry.c b/generic/tkGeometry.c new file mode 100644 index 0000000..ec2c959 --- /dev/null +++ b/generic/tkGeometry.c @@ -0,0 +1,582 @@ +/* + * tkGeometry.c -- + * + * This file contains generic Tk code for geometry management + * (stuff that's used by all geometry managers). + * + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkGeometry.c 1.31 96/02/15 18:53:32 + */ + +#include "tkPort.h" +#include "tkInt.h" + +/* + * Data structures of the following type are used by Tk_MaintainGeometry. + * For each slave managed by Tk_MaintainGeometry, there is one of these + * structures associated with its master. + */ + +typedef struct MaintainSlave { + Tk_Window slave; /* The slave window being positioned. */ + Tk_Window master; /* The master that determines slave's + * position; it must be a descendant of + * slave's parent. */ + int x, y; /* Desired position of slave relative to + * master. */ + int width, height; /* Desired dimensions of slave. */ + struct MaintainSlave *nextPtr; + /* Next in list of Maintains associated + * with master. */ +} MaintainSlave; + +/* + * For each window that has been specified as a master to + * Tk_MaintainGeometry, there is a structure of the following type: + */ + +typedef struct MaintainMaster { + Tk_Window ancestor; /* The lowest ancestor of this window + * for which we have *not* created a + * StructureNotify handler. May be the + * same as the window itself. */ + int checkScheduled; /* Non-zero means that there is already a + * call to MaintainCheckProc scheduled as + * an idle handler. */ + MaintainSlave *slavePtr; /* First in list of all slaves associated + * with this master. */ +} MaintainMaster; + +/* + * Hash table that maps from a master's Tk_Window token to a list of + * Maintains for that master: + */ + +static Tcl_HashTable maintainHashTable; + +/* + * Has maintainHashTable been initialized yet? + */ + +static int initialized = 0; + +/* + * Prototypes for static procedures in this file: + */ + +static void MaintainCheckProc _ANSI_ARGS_((ClientData clientData)); +static void MaintainMasterProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +static void MaintainSlaveProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); + +/* + *-------------------------------------------------------------- + * + * Tk_ManageGeometry -- + * + * Arrange for a particular procedure to manage the geometry + * of a given slave window. + * + * Results: + * None. + * + * Side effects: + * Proc becomes the new geometry manager for tkwin, replacing + * any previous geometry manager. The geometry manager will + * be notified (by calling procedures in *mgrPtr) when interesting + * things happen in the future. If there was an existing geometry + * manager for tkwin different from the new one, it is notified + * by calling its lostSlaveProc. + * + *-------------------------------------------------------------- + */ + +void +Tk_ManageGeometry(tkwin, mgrPtr, clientData) + Tk_Window tkwin; /* Window whose geometry is to + * be managed by proc. */ + Tk_GeomMgr *mgrPtr; /* Static structure describing the + * geometry manager. This structure + * must never go away. */ + ClientData clientData; /* Arbitrary one-word argument to + * pass to geometry manager procedures. */ +{ + register TkWindow *winPtr = (TkWindow *) tkwin; + + if ((winPtr->geomMgrPtr != NULL) && (mgrPtr != NULL) + && ((winPtr->geomMgrPtr != mgrPtr) + || (winPtr->geomData != clientData)) + && (winPtr->geomMgrPtr->lostSlaveProc != NULL)) { + (*winPtr->geomMgrPtr->lostSlaveProc)(winPtr->geomData, tkwin); + } + + winPtr->geomMgrPtr = mgrPtr; + winPtr->geomData = clientData; +} + +/* + *-------------------------------------------------------------- + * + * Tk_GeometryRequest -- + * + * This procedure is invoked by widget code to indicate + * its preferences about the size of a window it manages. + * In general, widget code should call this procedure + * rather than Tk_ResizeWindow. + * + * Results: + * None. + * + * Side effects: + * The geometry manager for tkwin (if any) is invoked to + * handle the request. If possible, it will reconfigure + * tkwin and/or other windows to satisfy the request. The + * caller gets no indication of success or failure, but it + * will get X events if the window size was actually + * changed. + * + *-------------------------------------------------------------- + */ + +void +Tk_GeometryRequest(tkwin, reqWidth, reqHeight) + Tk_Window tkwin; /* Window that geometry information + * pertains to. */ + int reqWidth, reqHeight; /* Minimum desired dimensions for + * window, in pixels. */ +{ + register TkWindow *winPtr = (TkWindow *) tkwin; + + /* + * X gets very upset if a window requests a width or height of + * zero, so rounds requested sizes up to at least 1. + */ + + if (reqWidth <= 0) { + reqWidth = 1; + } + if (reqHeight <= 0) { + reqHeight = 1; + } + if ((reqWidth == winPtr->reqWidth) && (reqHeight == winPtr->reqHeight)) { + return; + } + winPtr->reqWidth = reqWidth; + winPtr->reqHeight = reqHeight; + if ((winPtr->geomMgrPtr != NULL) + && (winPtr->geomMgrPtr->requestProc != NULL)) { + (*winPtr->geomMgrPtr->requestProc)(winPtr->geomData, tkwin); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tk_SetInternalBorder -- + * + * Notify relevant geometry managers that a window has an internal + * border of a given width and that child windows should not be + * placed on that border. + * + * Results: + * None. + * + * Side effects: + * The border width is recorded for the window, and all geometry + * managers of all children are notified so that can re-layout, if + * necessary. + * + *---------------------------------------------------------------------- + */ + +void +Tk_SetInternalBorder(tkwin, width) + Tk_Window tkwin; /* Window that will have internal border. */ + int width; /* Width of internal border, in pixels. */ +{ + register TkWindow *winPtr = (TkWindow *) tkwin; + + if (width == winPtr->internalBorderWidth) { + return; + } + if (width < 0) { + width = 0; + } + winPtr->internalBorderWidth = width; + + /* + * All the slaves for which this is the master window must now be + * repositioned to take account of the new internal border width. + * To signal all the geometry managers to do this, just resize the + * window to its current size. The ConfigureNotify event will + * cause geometry managers to recompute everything. + */ + + Tk_ResizeWindow(tkwin, Tk_Width(tkwin), Tk_Height(tkwin)); +} + +/* + *---------------------------------------------------------------------- + * + * Tk_MaintainGeometry -- + * + * This procedure is invoked by geometry managers to handle slaves + * whose master's are not their parents. It translates the desired + * geometry for the slave into the coordinate system of the parent + * and respositions the slave if it isn't already at the right place. + * Furthermore, it sets up event handlers so that if the master (or + * any of its ancestors up to the slave's parent) is mapped, unmapped, + * or moved, then the slave will be adjusted to match. + * + * Results: + * None. + * + * Side effects: + * Event handlers are created and state is allocated to keep track + * of slave. Note: if slave was already managed for master by + * Tk_MaintainGeometry, then the previous information is replaced + * with the new information. The caller must eventually call + * Tk_UnmaintainGeometry to eliminate the correspondence (or, the + * state is automatically freed when either window is destroyed). + * + *---------------------------------------------------------------------- + */ + +void +Tk_MaintainGeometry(slave, master, x, y, width, height) + Tk_Window slave; /* Slave for geometry management. */ + Tk_Window master; /* Master for slave; must be a descendant + * of slave's parent. */ + int x, y; /* Desired position of slave within master. */ + int width, height; /* Desired dimensions for slave. */ +{ + Tcl_HashEntry *hPtr; + MaintainMaster *masterPtr; + register MaintainSlave *slavePtr; + int new, map; + Tk_Window ancestor, parent; + + if (!initialized) { + initialized = 1; + Tcl_InitHashTable(&maintainHashTable, TCL_ONE_WORD_KEYS); + } + + /* + * See if there is already a MaintainMaster structure for the master; + * if not, then create one. + */ + + parent = Tk_Parent(slave); + hPtr = Tcl_CreateHashEntry(&maintainHashTable, (char *) master, &new); + if (!new) { + masterPtr = (MaintainMaster *) Tcl_GetHashValue(hPtr); + } else { + masterPtr = (MaintainMaster *) ckalloc(sizeof(MaintainMaster)); + masterPtr->ancestor = master; + masterPtr->checkScheduled = 0; + masterPtr->slavePtr = NULL; + Tcl_SetHashValue(hPtr, masterPtr); + } + + /* + * Create a MaintainSlave structure for the slave if there isn't + * already one. + */ + + for (slavePtr = masterPtr->slavePtr; slavePtr != NULL; + slavePtr = slavePtr->nextPtr) { + if (slavePtr->slave == slave) { + goto gotSlave; + } + } + slavePtr = (MaintainSlave *) ckalloc(sizeof(MaintainSlave)); + slavePtr->slave = slave; + slavePtr->master = master; + slavePtr->nextPtr = masterPtr->slavePtr; + masterPtr->slavePtr = slavePtr; + Tk_CreateEventHandler(slave, StructureNotifyMask, MaintainSlaveProc, + (ClientData) slavePtr); + + /* + * Make sure that there are event handlers registered for all + * the windows between master and slave's parent (including master + * but not slave's parent). There may already be handlers for master + * and some of its ancestors (masterPtr->ancestor tells how many). + */ + + for (ancestor = master; ancestor != parent; + ancestor = Tk_Parent(ancestor)) { + if (ancestor == masterPtr->ancestor) { + Tk_CreateEventHandler(ancestor, StructureNotifyMask, + MaintainMasterProc, (ClientData) masterPtr); + masterPtr->ancestor = Tk_Parent(ancestor); + } + } + + /* + * Fill in up-to-date information in the structure, then update the + * window if it's not currently in the right place or state. + */ + + gotSlave: + slavePtr->x = x; + slavePtr->y = y; + slavePtr->width = width; + slavePtr->height = height; + map = 1; + for (ancestor = slavePtr->master; ; ancestor = Tk_Parent(ancestor)) { + if (!Tk_IsMapped(ancestor) && (ancestor != parent)) { + map = 0; + } + if (ancestor == parent) { + if ((x != Tk_X(slavePtr->slave)) + || (y != Tk_Y(slavePtr->slave)) + || (width != Tk_Width(slavePtr->slave)) + || (height != Tk_Height(slavePtr->slave))) { + Tk_MoveResizeWindow(slavePtr->slave, x, y, width, height); + } + if (map) { + Tk_MapWindow(slavePtr->slave); + } else { + Tk_UnmapWindow(slavePtr->slave); + } + break; + } + x += Tk_X(ancestor) + Tk_Changes(ancestor)->border_width; + y += Tk_Y(ancestor) + Tk_Changes(ancestor)->border_width; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tk_UnmaintainGeometry -- + * + * This procedure cancels a previous Tk_MaintainGeometry call, + * so that the relationship between slave and master is no longer + * maintained. + * + * Results: + * None. + * + * Side effects: + * The slave is unmapped and state is released, so that slave won't + * track master any more. If we weren't previously managing slave + * relative to master, then this procedure has no effect. + * + *---------------------------------------------------------------------- + */ + +void +Tk_UnmaintainGeometry(slave, master) + Tk_Window slave; /* Slave for geometry management. */ + Tk_Window master; /* Master for slave; must be a descendant + * of slave's parent. */ +{ + Tcl_HashEntry *hPtr; + MaintainMaster *masterPtr; + register MaintainSlave *slavePtr, *prevPtr; + Tk_Window ancestor; + + if (!initialized) { + initialized = 1; + Tcl_InitHashTable(&maintainHashTable, TCL_ONE_WORD_KEYS); + } + + if (!(((TkWindow *) slave)->flags & TK_ALREADY_DEAD)) { + Tk_UnmapWindow(slave); + } + hPtr = Tcl_FindHashEntry(&maintainHashTable, (char *) master); + if (hPtr == NULL) { + return; + } + masterPtr = (MaintainMaster *) Tcl_GetHashValue(hPtr); + slavePtr = masterPtr->slavePtr; + if (slavePtr->slave == slave) { + masterPtr->slavePtr = slavePtr->nextPtr; + } else { + for (prevPtr = slavePtr, slavePtr = slavePtr->nextPtr; ; + prevPtr = slavePtr, slavePtr = slavePtr->nextPtr) { + if (slavePtr == NULL) { + return; + } + if (slavePtr->slave == slave) { + prevPtr->nextPtr = slavePtr->nextPtr; + break; + } + } + } + Tk_DeleteEventHandler(slavePtr->slave, StructureNotifyMask, + MaintainSlaveProc, (ClientData) slavePtr); + ckfree((char *) slavePtr); + if (masterPtr->slavePtr == NULL) { + if (masterPtr->ancestor != NULL) { + for (ancestor = master; ; ancestor = Tk_Parent(ancestor)) { + Tk_DeleteEventHandler(ancestor, StructureNotifyMask, + MaintainMasterProc, (ClientData) masterPtr); + if (ancestor == masterPtr->ancestor) { + break; + } + } + } + if (masterPtr->checkScheduled) { + Tcl_CancelIdleCall(MaintainCheckProc, (ClientData) masterPtr); + } + Tcl_DeleteHashEntry(hPtr); + ckfree((char *) masterPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * MaintainMasterProc -- + * + * This procedure is invoked by the Tk event dispatcher in + * response to StructureNotify events on the master or one + * of its ancestors, on behalf of Tk_MaintainGeometry. + * + * Results: + * None. + * + * Side effects: + * It schedules a call to MaintainCheckProc, which will eventually + * caused the postions and mapped states to be recalculated for all + * the maintained slaves of the master. Or, if the master window is + * being deleted then state is cleaned up. + * + *---------------------------------------------------------------------- + */ + +static void +MaintainMasterProc(clientData, eventPtr) + ClientData clientData; /* Pointer to MaintainMaster structure + * for the master window. */ + XEvent *eventPtr; /* Describes what just happened. */ +{ + MaintainMaster *masterPtr = (MaintainMaster *) clientData; + MaintainSlave *slavePtr; + int done; + + if ((eventPtr->type == ConfigureNotify) + || (eventPtr->type == MapNotify) + || (eventPtr->type == UnmapNotify)) { + if (!masterPtr->checkScheduled) { + masterPtr->checkScheduled = 1; + Tcl_DoWhenIdle(MaintainCheckProc, (ClientData) masterPtr); + } + } else if (eventPtr->type == DestroyNotify) { + /* + * Delete all of the state associated with this master, but + * be careful not to use masterPtr after the last slave is + * deleted, since its memory will have been freed. + */ + + done = 0; + do { + slavePtr = masterPtr->slavePtr; + if (slavePtr->nextPtr == NULL) { + done = 1; + } + Tk_UnmaintainGeometry(slavePtr->slave, slavePtr->master); + } while (!done); + } +} + +/* + *---------------------------------------------------------------------- + * + * MaintainSlaveProc -- + * + * This procedure is invoked by the Tk event dispatcher in + * response to StructureNotify events on a slave being managed + * by Tk_MaintainGeometry. + * + * Results: + * None. + * + * Side effects: + * If the event is a DestroyNotify event then the Maintain state + * and event handlers for this slave are deleted. + * + *---------------------------------------------------------------------- + */ + +static void +MaintainSlaveProc(clientData, eventPtr) + ClientData clientData; /* Pointer to MaintainSlave structure + * for master-slave pair. */ + XEvent *eventPtr; /* Describes what just happened. */ +{ + MaintainSlave *slavePtr = (MaintainSlave *) clientData; + + if (eventPtr->type == DestroyNotify) { + Tk_UnmaintainGeometry(slavePtr->slave, slavePtr->master); + } +} + +/* + *---------------------------------------------------------------------- + * + * MaintainCheckProc -- + * + * This procedure is invoked by the Tk event dispatcher as an + * idle handler, when a master or one of its ancestors has been + * reconfigured, mapped, or unmapped. Its job is to scan all of + * the slaves for the master and reposition them, map them, or + * unmap them as needed to maintain their geometry relative to + * the master. + * + * Results: + * None. + * + * Side effects: + * Slaves can get repositioned, mapped, or unmapped. + * + *---------------------------------------------------------------------- + */ + +static void +MaintainCheckProc(clientData) + ClientData clientData; /* Pointer to MaintainMaster structure + * for the master window. */ +{ + MaintainMaster *masterPtr = (MaintainMaster *) clientData; + MaintainSlave *slavePtr; + Tk_Window ancestor, parent; + int x, y, map; + + masterPtr->checkScheduled = 0; + for (slavePtr = masterPtr->slavePtr; slavePtr != NULL; + slavePtr = slavePtr->nextPtr) { + parent = Tk_Parent(slavePtr->slave); + x = slavePtr->x; + y = slavePtr->y; + map = 1; + for (ancestor = slavePtr->master; ; ancestor = Tk_Parent(ancestor)) { + if (!Tk_IsMapped(ancestor) && (ancestor != parent)) { + map = 0; + } + if (ancestor == parent) { + if ((x != Tk_X(slavePtr->slave)) + || (y != Tk_Y(slavePtr->slave))) { + Tk_MoveWindow(slavePtr->slave, x, y); + } + if (map) { + Tk_MapWindow(slavePtr->slave); + } else { + Tk_UnmapWindow(slavePtr->slave); + } + break; + } + x += Tk_X(ancestor) + Tk_Changes(ancestor)->border_width; + y += Tk_Y(ancestor) + Tk_Changes(ancestor)->border_width; + } + } +} diff --git a/generic/tkGet.c b/generic/tkGet.c new file mode 100644 index 0000000..56258a6 --- /dev/null +++ b/generic/tkGet.c @@ -0,0 +1,586 @@ +/* + * tkGet.c -- + * + * This file contains a number of "Tk_GetXXX" procedures, which + * parse text strings into useful forms for Tk. This file has + * the simpler procedures, like Tk_GetDirection and Tk_GetUid. + * The more complex procedures like Tk_GetColor are in separate + * files. + * + * Copyright (c) 1991-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkGet.c 1.13 96/04/26 10:25:46 + */ + +#include "tkInt.h" +#include "tkPort.h" + +/* + * The hash table below is used to keep track of all the Tk_Uids created + * so far. + */ + +static Tcl_HashTable uidTable; +static int initialized = 0; + +/* + *-------------------------------------------------------------- + * + * Tk_GetAnchor -- + * + * Given a string, return the corresponding Tk_Anchor. + * + * Results: + * The return value is a standard Tcl return result. If + * 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. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +int +Tk_GetAnchor(interp, string, anchorPtr) + Tcl_Interp *interp; /* Use this for error reporting. */ + char *string; /* String describing a direction. */ + Tk_Anchor *anchorPtr; /* Where to store Tk_Anchor corresponding + * to string. */ +{ + switch (string[0]) { + case 'n': + if (string[1] == 0) { + *anchorPtr = TK_ANCHOR_N; + return TCL_OK; + } else if ((string[1] == 'e') && (string[2] == 0)) { + *anchorPtr = TK_ANCHOR_NE; + return TCL_OK; + } else if ((string[1] == 'w') && (string[2] == 0)) { + *anchorPtr = TK_ANCHOR_NW; + return TCL_OK; + } + goto error; + case 's': + if (string[1] == 0) { + *anchorPtr = TK_ANCHOR_S; + return TCL_OK; + } else if ((string[1] == 'e') && (string[2] == 0)) { + *anchorPtr = TK_ANCHOR_SE; + return TCL_OK; + } else if ((string[1] == 'w') && (string[2] == 0)) { + *anchorPtr = TK_ANCHOR_SW; + return TCL_OK; + } else { + goto error; + } + case 'e': + if (string[1] == 0) { + *anchorPtr = TK_ANCHOR_E; + return TCL_OK; + } + goto error; + case 'w': + if (string[1] == 0) { + *anchorPtr = TK_ANCHOR_W; + return TCL_OK; + } + goto error; + case 'c': + if (strncmp(string, "center", strlen(string)) == 0) { + *anchorPtr = TK_ANCHOR_CENTER; + return TCL_OK; + } + goto error; + } + + error: + Tcl_AppendResult(interp, "bad anchor position \"", string, + "\": must be n, ne, e, se, s, sw, w, nw, or center", + (char *) NULL); + return TCL_ERROR; +} + +/* + *-------------------------------------------------------------- + * + * Tk_NameOfAnchor -- + * + * Given a Tk_Anchor, return the string that corresponds + * to it. + * + * Results: + * None. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +char * +Tk_NameOfAnchor(anchor) + Tk_Anchor anchor; /* Anchor for which identifying string + * is desired. */ +{ + switch (anchor) { + case TK_ANCHOR_N: return "n"; + case TK_ANCHOR_NE: return "ne"; + case TK_ANCHOR_E: return "e"; + case TK_ANCHOR_SE: return "se"; + case TK_ANCHOR_S: return "s"; + case TK_ANCHOR_SW: return "sw"; + case TK_ANCHOR_W: return "w"; + case TK_ANCHOR_NW: return "nw"; + case TK_ANCHOR_CENTER: return "center"; + } + return "unknown anchor position"; +} + +/* + *-------------------------------------------------------------- + * + * Tk_GetJoinStyle -- + * + * Given a string, return the corresponding Tk_JoinStyle. + * + * Results: + * The return value is a standard Tcl return result. If + * 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. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +int +Tk_GetJoinStyle(interp, string, joinPtr) + Tcl_Interp *interp; /* Use this for error reporting. */ + char *string; /* String describing a justification style. */ + int *joinPtr; /* Where to store join style corresponding + * to string. */ +{ + int c; + size_t length; + + c = string[0]; + length = strlen(string); + + if ((c == 'b') && (strncmp(string, "bevel", length) == 0)) { + *joinPtr = JoinBevel; + return TCL_OK; + } + if ((c == 'm') && (strncmp(string, "miter", length) == 0)) { + *joinPtr = JoinMiter; + return TCL_OK; + } + if ((c == 'r') && (strncmp(string, "round", length) == 0)) { + *joinPtr = JoinRound; + return TCL_OK; + } + + Tcl_AppendResult(interp, "bad join style \"", string, + "\": must be bevel, miter, or round", + (char *) NULL); + return TCL_ERROR; +} + +/* + *-------------------------------------------------------------- + * + * Tk_NameOfJoinStyle -- + * + * Given a Tk_JoinStyle, return the string that corresponds + * to it. + * + * Results: + * None. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +char * +Tk_NameOfJoinStyle(join) + int join; /* Join style for which identifying string + * is desired. */ +{ + switch (join) { + case JoinBevel: return "bevel"; + case JoinMiter: return "miter"; + case JoinRound: return "round"; + } + return "unknown join style"; +} + +/* + *-------------------------------------------------------------- + * + * Tk_GetCapStyle -- + * + * Given a string, return the corresponding Tk_CapStyle. + * + * Results: + * The return value is a standard Tcl return result. If + * 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. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +int +Tk_GetCapStyle(interp, string, capPtr) + Tcl_Interp *interp; /* Use this for error reporting. */ + char *string; /* String describing a justification style. */ + int *capPtr; /* Where to store cap style corresponding + * to string. */ +{ + int c; + size_t length; + + c = string[0]; + length = strlen(string); + + if ((c == 'b') && (strncmp(string, "butt", length) == 0)) { + *capPtr = CapButt; + return TCL_OK; + } + if ((c == 'p') && (strncmp(string, "projecting", length) == 0)) { + *capPtr = CapProjecting; + return TCL_OK; + } + if ((c == 'r') && (strncmp(string, "round", length) == 0)) { + *capPtr = CapRound; + return TCL_OK; + } + + Tcl_AppendResult(interp, "bad cap style \"", string, + "\": must be butt, projecting, or round", + (char *) NULL); + return TCL_ERROR; +} + +/* + *-------------------------------------------------------------- + * + * Tk_NameOfCapStyle -- + * + * Given a Tk_CapStyle, return the string that corresponds + * to it. + * + * Results: + * None. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +char * +Tk_NameOfCapStyle(cap) + int cap; /* Cap style for which identifying string + * is desired. */ +{ + switch (cap) { + case CapButt: return "butt"; + case CapProjecting: return "projecting"; + case CapRound: return "round"; + } + return "unknown cap style"; +} + +/* + *-------------------------------------------------------------- + * + * Tk_GetJustify -- + * + * Given a string, return the corresponding Tk_Justify. + * + * Results: + * The return value is a standard Tcl return result. If + * 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. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +int +Tk_GetJustify(interp, string, justifyPtr) + Tcl_Interp *interp; /* Use this for error reporting. */ + char *string; /* String describing a justification style. */ + Tk_Justify *justifyPtr; /* Where to store Tk_Justify corresponding + * to string. */ +{ + int c; + size_t length; + + c = string[0]; + length = strlen(string); + + if ((c == 'l') && (strncmp(string, "left", length) == 0)) { + *justifyPtr = TK_JUSTIFY_LEFT; + return TCL_OK; + } + if ((c == 'r') && (strncmp(string, "right", length) == 0)) { + *justifyPtr = TK_JUSTIFY_RIGHT; + return TCL_OK; + } + if ((c == 'c') && (strncmp(string, "center", length) == 0)) { + *justifyPtr = TK_JUSTIFY_CENTER; + return TCL_OK; + } + + Tcl_AppendResult(interp, "bad justification \"", string, + "\": must be left, right, or center", + (char *) NULL); + return TCL_ERROR; +} + +/* + *-------------------------------------------------------------- + * + * Tk_NameOfJustify -- + * + * Given a Tk_Justify, return the string that corresponds + * to it. + * + * Results: + * None. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +char * +Tk_NameOfJustify(justify) + Tk_Justify justify; /* Justification style for which + * identifying string is desired. */ +{ + switch (justify) { + case TK_JUSTIFY_LEFT: return "left"; + case TK_JUSTIFY_RIGHT: return "right"; + case TK_JUSTIFY_CENTER: return "center"; + } + return "unknown justification style"; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_GetUid -- + * + * Given a string, this procedure returns a unique identifier + * for the string. + * + * Results: + * This procedure returns a Tk_Uid corresponding to the "string" + * argument. The Tk_Uid has a string value identical to string + * (strcmp will return 0), but it's guaranteed that any other + * calls to this procedure with a string equal to "string" will + * return exactly the same result (i.e. can compare Tk_Uid + * *values* directly, without having to call strcmp on what they + * point to). + * + * Side effects: + * New information may be entered into the identifier table. + * + *---------------------------------------------------------------------- + */ + +Tk_Uid +Tk_GetUid(string) + CONST char *string; /* String to convert. */ +{ + int dummy; + + if (!initialized) { + Tcl_InitHashTable(&uidTable, TCL_STRING_KEYS); + initialized = 1; + } + return (Tk_Uid) Tcl_GetHashKey(&uidTable, + Tcl_CreateHashEntry(&uidTable, string, &dummy)); +} + +/* + *-------------------------------------------------------------- + * + * Tk_GetScreenMM -- + * + * Given a string, returns the number of screen millimeters + * corresponding to that string. + * + * Results: + * The return value is a standard Tcl return result. If + * 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. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +int +Tk_GetScreenMM(interp, tkwin, string, doublePtr) + Tcl_Interp *interp; /* Use this for error reporting. */ + Tk_Window tkwin; /* Window whose screen determines conversion + * from centimeters and other absolute + * units. */ + char *string; /* String describing a screen distance. */ + double *doublePtr; /* Place to store converted result. */ +{ + char *end; + double d; + + d = strtod(string, &end); + if (end == string) { + error: + Tcl_AppendResult(interp, "bad screen distance \"", string, + "\"", (char *) NULL); + return TCL_ERROR; + } + while ((*end != '\0') && isspace(UCHAR(*end))) { + end++; + } + switch (*end) { + case 0: + d /= WidthOfScreen(Tk_Screen(tkwin)); + d *= WidthMMOfScreen(Tk_Screen(tkwin)); + break; + case 'c': + d *= 10; + end++; + break; + case 'i': + d *= 25.4; + end++; + break; + case 'm': + end++; + break; + case 'p': + d *= 25.4/72.0; + end++; + break; + default: + goto error; + } + while ((*end != '\0') && isspace(UCHAR(*end))) { + end++; + } + if (*end != 0) { + goto error; + } + *doublePtr = d; + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * Tk_GetPixels -- + * + * Given a string, returns the number of pixels corresponding + * to that string. + * + * Results: + * The return value is a standard Tcl return result. If + * 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. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +int +Tk_GetPixels(interp, tkwin, string, intPtr) + Tcl_Interp *interp; /* Use this for error reporting. */ + Tk_Window tkwin; /* Window whose screen determines conversion + * from centimeters and other absolute + * units. */ + char *string; /* String describing a justification style. */ + int *intPtr; /* Place to store converted result. */ +{ + char *end; + double d; + + d = strtod(string, &end); + if (end == string) { + error: + Tcl_AppendResult(interp, "bad screen distance \"", string, + "\"", (char *) NULL); + return TCL_ERROR; + } + while ((*end != '\0') && isspace(UCHAR(*end))) { + end++; + } + switch (*end) { + case 0: + break; + case 'c': + d *= 10*WidthOfScreen(Tk_Screen(tkwin)); + d /= WidthMMOfScreen(Tk_Screen(tkwin)); + end++; + break; + case 'i': + d *= 25.4*WidthOfScreen(Tk_Screen(tkwin)); + d /= WidthMMOfScreen(Tk_Screen(tkwin)); + end++; + break; + case 'm': + d *= WidthOfScreen(Tk_Screen(tkwin)); + d /= WidthMMOfScreen(Tk_Screen(tkwin)); + end++; + break; + case 'p': + d *= (25.4/72.0)*WidthOfScreen(Tk_Screen(tkwin)); + d /= WidthMMOfScreen(Tk_Screen(tkwin)); + end++; + break; + default: + goto error; + } + while ((*end != '\0') && isspace(UCHAR(*end))) { + end++; + } + if (*end != 0) { + goto error; + } + if (d < 0) { + *intPtr = (int) (d - 0.5); + } else { + *intPtr = (int) (d + 0.5); + } + return TCL_OK; +} diff --git a/generic/tkGrab.c b/generic/tkGrab.c new file mode 100644 index 0000000..869e0b3 --- /dev/null +++ b/generic/tkGrab.c @@ -0,0 +1,1535 @@ +/* + * tkGrab.c -- + * + * 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. + * + * 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 + */ + +#include "tkPort.h" +#include "tkInt.h" + +/* + * The grab state machine has four states: ungrabbed, button pressed, + * grabbed, and button pressed while grabbed. In addition, there are + * three pieces of grab state information: the current grab window, + * the current restrict window, and whether the mouse is captured. + * + * The current grab window specifies the point in the Tk window + * heirarchy above which pointer events will not be reported. Any + * window within the subtree below the grab window will continue to + * receive events as normal. Events outside of the grab tree will be + * reported to the grab window. + * + * If the current restrict window is set, then all pointer events will + * be reported only to the restrict window. The restrict window is + * normally set during an automatic button grab. + * + * The mouse capture state specifies whether the window system will + * report mouse events outside of any Tk toplevels. This is set + * during a global grab or an automatic button grab. + * + * The transitions between different states is given in the following + * table: + * + * Event\State U B G GB + * ----------- -- -- -- -- + * FirstPress B B GB GB + * Press B B G GB + * Release U B G GB + * LastRelease U U G G + * Grab G G G G + * Ungrab U B U U + * + * Note: U=Ungrabbed, B=Button, G=Grabbed, GB=Grab and Button + * + * In addition, the following conditions are always true: + * + * State\Variable Grab Restrict Capture + * -------------- ---- -------- ------- + * Ungrabbed 0 0 0 + * Button 0 1 1 + * Grabbed 1 0 b/g + * Grab and Button 1 1 1 + * + * Note: 0 means variable is set to NULL, 1 means variable is set to + * some window, b/g means the variable is set to a window if a button + * is currently down or a global grab is in effect. + * + * The final complication to all of this is enter and leave events. + * In order to correctly handle all of the various cases, Tk cannot + * rely on X enter/leave events in all situations. The following + * describes the correct sequence of enter and leave events that + * should be observed by Tk scripts: + * + * Event(state) Enter/Leave From -> To + * ------------ ---------------------- + * LastRelease(B | GB): restrict window -> anc(grab window, event window) + * Grab(U | B): event window -> anc(grab window, event window) + * Grab(G): anc(old grab window, event window) -> + * anc(new grab window, event window) + * Grab(GB): restrict window -> anc(new grab window, event window) + * Ungrab(G): anc(grab window, event window) -> event window + * Ungrab(GB): restrict window -> event window + * + * Note: anc(x,y) returns the least ancestor of y that is in the tree + * of x, terminating at toplevels. + */ + +/* + * The following structure is used to pass information to + * GrabRestrictProc from EatGrabEvents. + */ + +typedef struct { + Display *display; /* Display from which to discard events. */ + unsigned int serial; /* Serial number with which to compare. */ +} GrabInfo; + +/* + * Bit definitions for grabFlags field of TkDisplay structures: + * + * GRAB_GLOBAL 1 means this is a global grab (we grabbed via + * the server so all applications are locked out). + * 0 means this is a local grab that affects + * only this application. + * GRAB_TEMP_GLOBAL 1 means we've temporarily grabbed via the + * server because a button is down and we want + * to make sure that we get the button-up + * event. The grab will be released when the + * last mouse button goes up. + */ + +#define GRAB_GLOBAL 1 +#define GRAB_TEMP_GLOBAL 4 + +/* + * The following structure is a Tcl_Event that triggers a change in + * the grabWinPtr field of a display. This event guarantees that + * the change occurs in the proper order relative to enter and leave + * events. + */ + +typedef struct NewGrabWinEvent { + Tcl_Event header; /* Standard information for all Tcl events. */ + TkDisplay *dispPtr; /* Display whose grab window is to change. */ + Window grabWindow; /* New grab window for display. This is + * recorded instead of a (TkWindow *) because + * it will allow us to detect cases where + * the window is destroyed before this event + * is processed. */ +} NewGrabWinEvent; + +/* + * The following magic value is stored in the "send_event" field of + * EnterNotify and LeaveNotify events that are generated in this + * file. This allows us to separate "real" events coming from the + * server from those that we generated. + */ + +#define GENERATED_EVENT_MAGIC ((Bool) 0x147321ac) + +/* + * Mask that selects any of the state bits corresponding to buttons, + * plus masks that select individual buttons' bits: + */ + +#define ALL_BUTTONS \ + (Button1Mask|Button2Mask|Button3Mask|Button4Mask|Button5Mask) +static unsigned int buttonStates[] = { + Button1Mask, Button2Mask, Button3Mask, Button4Mask, Button5Mask +}; + +/* + * Forward declarations for procedures declared later in this file: + */ + +static void EatGrabEvents _ANSI_ARGS_((TkDisplay *dispPtr, + unsigned int serial)); +static TkWindow * FindCommonAncestor _ANSI_ARGS_((TkWindow *winPtr1, + TkWindow *winPtr2, int *countPtr1, + int *countPtr2)); +static Tk_RestrictAction GrabRestrictProc _ANSI_ARGS_((ClientData arg, + XEvent *eventPtr)); +static int GrabWinEventProc _ANSI_ARGS_((Tcl_Event *evPtr, + int flags)); +static void MovePointer2 _ANSI_ARGS_((TkWindow *sourcePtr, + TkWindow *destPtr, int mode, int leaveEvents, + int EnterEvents)); +static void QueueGrabWindowChange _ANSI_ARGS_((TkDisplay *dispPtr, + TkWindow *grabWinPtr)); +static void ReleaseButtonGrab _ANSI_ARGS_((TkDisplay *dispPtr)); + +/* + *---------------------------------------------------------------------- + * + * Tk_GrabCmd -- + * + * This procedure is invoked to process the "grab" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tk_GrabCmd(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. */ +{ + int globalGrab, c; + Tk_Window tkwin; + TkDisplay *dispPtr; + size_t length; + + if (argc < 2) { + badArgs: + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " ?-global? window\" or \"", argv[0], + " option ?arg arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + c = argv[1][0]; + length = strlen(argv[1]); + if (c == '.') { + if (argc != 2) { + goto badArgs; + } + tkwin = Tk_NameToWindow(interp, argv[1], (Tk_Window) clientData); + if (tkwin == NULL) { + return TCL_ERROR; + } + return Tk_Grab(interp, tkwin, 0); + } else if ((c == '-') && (strncmp(argv[1], "-global", length) == 0) + && (length >= 2)) { + if (argc != 3) { + goto badArgs; + } + tkwin = Tk_NameToWindow(interp, argv[2], (Tk_Window) clientData); + if (tkwin == NULL) { + return TCL_ERROR; + } + return Tk_Grab(interp, tkwin, 1); + } else if ((c == 'c') && (strncmp(argv[1], "current", length) == 0)) { + if (argc > 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " current ?window?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 3) { + tkwin = Tk_NameToWindow(interp, argv[2], (Tk_Window) clientData); + if (tkwin == NULL) { + return TCL_ERROR; + } + dispPtr = ((TkWindow *) tkwin)->dispPtr; + if (dispPtr->eventualGrabWinPtr != NULL) { + interp->result = dispPtr->eventualGrabWinPtr->pathName; + } + } else { + for (dispPtr = tkDisplayList; dispPtr != NULL; + dispPtr = dispPtr->nextPtr) { + if (dispPtr->eventualGrabWinPtr != NULL) { + Tcl_AppendElement(interp, + dispPtr->eventualGrabWinPtr->pathName); + } + } + } + return TCL_OK; + } else if ((c == 'r') && (strncmp(argv[1], "release", length) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " release window\"", (char *) NULL); + return TCL_ERROR; + } + tkwin = Tk_NameToWindow(interp, argv[2], (Tk_Window) clientData); + if (tkwin == NULL) { + Tcl_ResetResult(interp); + } else { + Tk_Ungrab(tkwin); + } + } else if ((c == 's') && (strncmp(argv[1], "set", length) == 0) + && (length >= 2)) { + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " set ?-global? window\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 3) { + globalGrab = 0; + tkwin = Tk_NameToWindow(interp, argv[2], (Tk_Window) clientData); + } else { + globalGrab = 1; + length = strlen(argv[2]); + if ((strncmp(argv[2], "-global", length) != 0) || (length < 2)) { + Tcl_AppendResult(interp, "bad argument \"", argv[2], + "\": must be \"", argv[0], " set ?-global? window\"", + (char *) NULL); + return TCL_ERROR; + } + tkwin = Tk_NameToWindow(interp, argv[3], (Tk_Window) clientData); + } + if (tkwin == NULL) { + return TCL_ERROR; + } + return Tk_Grab(interp, tkwin, globalGrab); + } else if ((c == 's') && (strncmp(argv[1], "status", length) == 0) + && (length >= 2)) { + TkWindow *winPtr; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " status window\"", (char *) NULL); + return TCL_ERROR; + } + winPtr = (TkWindow *) Tk_NameToWindow(interp, argv[2], + (Tk_Window) clientData); + if (winPtr == NULL) { + return TCL_ERROR; + } + dispPtr = winPtr->dispPtr; + if (dispPtr->eventualGrabWinPtr != winPtr) { + interp->result = "none"; + } else if (dispPtr->grabFlags & GRAB_GLOBAL) { + interp->result = "global"; + } else { + interp->result = "local"; + } + } else { + Tcl_AppendResult(interp, "unknown or ambiguous option \"", argv[1], + "\": must be current, release, set, or status", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_Grab -- + * + * Grabs the pointer and keyboard, so that mouse-related events are + * only reported relative to a given window and its descendants. + * + * 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. + * + * Side effects: + * Once this call completes successfully, no window outside the + * tree rooted at tkwin will receive pointer- or keyboard-related + * events until the next call to Tk_Ungrab. If a previous grab was + * in effect within this application, then it is replaced with a new + * one. + * + *---------------------------------------------------------------------- + */ + +int +Tk_Grab(interp, tkwin, grabGlobal) + Tcl_Interp *interp; /* Used for error reporting. */ + Tk_Window tkwin; /* Window on whose behalf the pointer + * is to be grabbed. */ + int grabGlobal; /* Non-zero means issue a grab to the + * server so that no other application + * gets mouse or keyboard events. + * Zero means the grab only applies + * within this application. */ +{ + int grabResult, numTries; + TkWindow *winPtr = (TkWindow *) tkwin; + TkDisplay *dispPtr = winPtr->dispPtr; + TkWindow *winPtr2; + unsigned int serial; + + ReleaseButtonGrab(dispPtr); + if (dispPtr->eventualGrabWinPtr != NULL) { + if ((dispPtr->eventualGrabWinPtr == winPtr) + && (grabGlobal == ((dispPtr->grabFlags & GRAB_GLOBAL) != 0))) { + return TCL_OK; + } + if (dispPtr->eventualGrabWinPtr->mainPtr != winPtr->mainPtr) { + alreadyGrabbed: + interp->result = "grab failed: another application has grab"; + return TCL_ERROR; + } + Tk_Ungrab((Tk_Window) dispPtr->eventualGrabWinPtr); + } + + Tk_MakeWindowExist(tkwin); + if (!grabGlobal) { + Window dummy1, dummy2; + int dummy3, dummy4, dummy5, dummy6; + unsigned int state; + + /* + * Local grab. However, if any mouse buttons are down, turn + * it into a global grab temporarily, until the last button + * goes up. This does two things: (a) it makes sure that we + * see the button-up event; and (b) it allows us to track mouse + * motion among all of the windows of this application. + */ + + dispPtr->grabFlags &= ~(GRAB_GLOBAL|GRAB_TEMP_GLOBAL); + XQueryPointer(dispPtr->display, winPtr->window, &dummy1, + &dummy2, &dummy3, &dummy4, &dummy5, &dummy6, &state); + if ((state & ALL_BUTTONS) != 0) { + dispPtr->grabFlags |= GRAB_TEMP_GLOBAL; + goto setGlobalGrab; + } + } else { + dispPtr->grabFlags |= GRAB_GLOBAL; + setGlobalGrab: + + /* + * Tricky point: must ungrab before grabbing. This is needed + * in case there is a button auto-grab already in effect. If + * there is, and the mouse has moved to a different window, X + * won't generate enter and leave events to move the mouse if + * we grab without ungrabbing. + */ + + XUngrabPointer(dispPtr->display, CurrentTime); + serial = NextRequest(dispPtr->display); + + /* + * Another tricky point: there are races with some window + * managers that can cause grabs to fail because the window + * manager hasn't released its grab quickly enough. To work + * around this problem, retry a few times after AlreadyGrabbed + * errors to give the grab release enough time to register with + * the server. + */ + + grabResult = 0; /* Needed only to prevent gcc + * compiler warnings. */ + for (numTries = 0; numTries < 10; numTries++) { + grabResult = XGrabPointer(dispPtr->display, winPtr->window, + True, ButtonPressMask|ButtonReleaseMask|ButtonMotionMask + |PointerMotionMask, GrabModeAsync, GrabModeAsync, None, + None, CurrentTime); + if (grabResult != AlreadyGrabbed) { + break; + } + Tcl_Sleep(100); + } + if (grabResult != 0) { + grabError: + if (grabResult == GrabNotViewable) { + interp->result = "grab failed: window not viewable"; + } else if (grabResult == AlreadyGrabbed) { + goto alreadyGrabbed; + } else if (grabResult == GrabFrozen) { + interp->result = "grab failed: keyboard or pointer frozen"; + } else if (grabResult == GrabInvalidTime) { + interp->result = "grab failed: invalid time"; + } else { + char msg[100]; + + sprintf(msg, "grab failed for unknown reason (code %d)", + grabResult); + Tcl_AppendResult(interp, msg, (char *) NULL); + } + return TCL_ERROR; + } + grabResult = XGrabKeyboard(dispPtr->display, Tk_WindowId(tkwin), + False, GrabModeAsync, GrabModeAsync, CurrentTime); + if (grabResult != 0) { + XUngrabPointer(dispPtr->display, CurrentTime); + goto grabError; + } + + /* + * Eat up any grab-related events generated by the server for the + * grab. There are several reasons for doing this: + * + * 1. We have to synthesize the events for local grabs anyway, since + * the server doesn't participate in them. + * 2. The server doesn't always generate the right events for global + * grabs (e.g. it generates events even if the current window is + * in the grab tree, which we don't want). + * 3. We want all the grab-related events to be processed immediately + * (before other events that are already queued); events coming + * from the server will be in the wrong place, but events we + * synthesize here will go to the front of the queue. + */ + + EatGrabEvents(dispPtr, serial); + } + + /* + * Synthesize leave events to move the pointer from its current window + * up to the lowest ancestor that it has in common with the grab window. + * However, only do this if the pointer is outside the grab window's + * subtree but inside the grab window's application. + */ + + if ((dispPtr->serverWinPtr != NULL) + && (dispPtr->serverWinPtr->mainPtr == winPtr->mainPtr)) { + for (winPtr2 = dispPtr->serverWinPtr; ; winPtr2 = winPtr2->parentPtr) { + if (winPtr2 == winPtr) { + break; + } + if (winPtr2 == NULL) { + MovePointer2(dispPtr->serverWinPtr, winPtr, NotifyGrab, 1, 0); + break; + } + } + } + QueueGrabWindowChange(dispPtr, winPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_Ungrab -- + * + * Releases a grab on the mouse pointer and keyboard, if there + * is one set on the specified window. + * + * Results: + * None. + * + * Side effects: + * Pointer and keyboard events will start being delivered to other + * windows again. + * + *---------------------------------------------------------------------- + */ + +void +Tk_Ungrab(tkwin) + Tk_Window tkwin; /* Window whose grab should be + * released. */ +{ + TkDisplay *dispPtr; + TkWindow *grabWinPtr, *winPtr; + unsigned int serial; + + grabWinPtr = (TkWindow *) tkwin; + dispPtr = grabWinPtr->dispPtr; + if (grabWinPtr != dispPtr->eventualGrabWinPtr) { + return; + } + ReleaseButtonGrab(dispPtr); + QueueGrabWindowChange(dispPtr, (TkWindow *) NULL); + if (dispPtr->grabFlags & (GRAB_GLOBAL|GRAB_TEMP_GLOBAL)) { + dispPtr->grabFlags &= ~(GRAB_GLOBAL|GRAB_TEMP_GLOBAL); + serial = NextRequest(dispPtr->display); + XUngrabPointer(dispPtr->display, CurrentTime); + XUngrabKeyboard(dispPtr->display, CurrentTime); + EatGrabEvents(dispPtr, serial); + } + + /* + * Generate events to move the pointer back to the window where it + * really is. Some notes: + * 1. As with grabs, only do this if the "real" window is not a + * descendant of the grab window, since in this case the pointer + * is already where it's supposed to be. + * 2. If the "real" window is in some other application then don't + * generate any events at all, since everything's already been + * reported correctly. + * 3. Only generate enter events. Don't generate leave events, + * because we never told the lower-level windows that they + * had the pointer in the first place. + */ + + for (winPtr = dispPtr->serverWinPtr; ; winPtr = winPtr->parentPtr) { + if (winPtr == grabWinPtr) { + break; + } + if (winPtr == NULL) { + if ((dispPtr->serverWinPtr == NULL) || + (dispPtr->serverWinPtr->mainPtr == grabWinPtr->mainPtr)) { + MovePointer2(grabWinPtr, dispPtr->serverWinPtr, + NotifyUngrab, 0, 1); + } + break; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * ReleaseButtonGrab -- + * + * This procedure is called to release a simulated button grab, if + * there is one in effect. A button grab is present whenever + * dispPtr->buttonWinPtr is non-NULL or when the GRAB_TEMP_GLOBAL + * flag is set. + * + * Results: + * None. + * + * Side effects: + * DispPtr->buttonWinPtr is reset to NULL, and enter and leave + * events are generated if necessary to move the pointer from + * the button grab window to its current window. + * + *---------------------------------------------------------------------- + */ + +static void +ReleaseButtonGrab(dispPtr) + register TkDisplay *dispPtr; /* Display whose button grab is to be + * released. */ +{ + unsigned int serial; + + if (dispPtr->buttonWinPtr != NULL) { + if (dispPtr->buttonWinPtr != dispPtr->serverWinPtr) { + MovePointer2(dispPtr->buttonWinPtr, dispPtr->serverWinPtr, + NotifyUngrab, 1, 1); + } + dispPtr->buttonWinPtr = NULL; + } + if (dispPtr->grabFlags & GRAB_TEMP_GLOBAL) { + dispPtr->grabFlags &= ~GRAB_TEMP_GLOBAL; + serial = NextRequest(dispPtr->display); + XUngrabPointer(dispPtr->display, CurrentTime); + XUngrabKeyboard(dispPtr->display, CurrentTime); + EatGrabEvents(dispPtr, serial); + } +} + +/* + *---------------------------------------------------------------------- + * + * TkPointerEvent -- + * + * This procedure is called for each pointer-related event, before + * the event has been processed. It does various things to make + * grabs work correctly. + * + * Results: + * If the return value is 1 it means the event should be processed + * (event handlers should be invoked). If the return value is 0 + * it means the event should be ignored in order to make grabs + * work correctly. In some cases this procedure modifies the event. + * + * Side effects: + * Grab state information may be updated. New events may also be + * pushed back onto the event queue to replace or augment the + * one passed in here. + * + *---------------------------------------------------------------------- + */ + +int +TkPointerEvent(eventPtr, winPtr) + register XEvent *eventPtr; /* Pointer to the event. */ + TkWindow *winPtr; /* Tk's information for window + * where event was reported. */ +{ + register TkWindow *winPtr2; + TkDisplay *dispPtr = winPtr->dispPtr; + unsigned int serial; + int outsideGrabTree = 0; + int ancestorOfGrab = 0; + int appGrabbed = 0; /* Non-zero means event is being + * reported to an application that is + * affected by the grab. */ + + /* + * Collect information about the grab (if any). + */ + + switch (TkGrabState(winPtr)) { + case TK_GRAB_IN_TREE: + appGrabbed = 1; + break; + case TK_GRAB_ANCESTOR: + appGrabbed = 1; + outsideGrabTree = 1; + ancestorOfGrab = 1; + break; + case TK_GRAB_EXCLUDED: + appGrabbed = 1; + outsideGrabTree = 1; + break; + } + + if ((eventPtr->type == EnterNotify) || (eventPtr->type == LeaveNotify)) { + /* + * Keep track of what window the mouse is *really* over. + * Any events that we generate have a special send_event value, + * which is detected below and used to ignore the event for + * purposes of setting serverWinPtr. + */ + + if (eventPtr->xcrossing.send_event != GENERATED_EVENT_MAGIC) { + if ((eventPtr->type == LeaveNotify) && + (winPtr->flags & TK_TOP_LEVEL)) { + dispPtr->serverWinPtr = NULL; + } else { + dispPtr->serverWinPtr = winPtr; + } + } + + /* + * When a grab is active, X continues to report enter and leave + * events for windows outside the tree of the grab window: + * 1. Detect these events and ignore them except for + * windows above the grab window. + * 2. Allow Enter and Leave events to pass through the + * windows above the grab window, but never let them + * end up with the pointer *in* one of those windows. + */ + + if (dispPtr->grabWinPtr != NULL) { + if (outsideGrabTree && appGrabbed) { + if (!ancestorOfGrab) { + return 0; + } + switch (eventPtr->xcrossing.detail) { + case NotifyInferior: + return 0; + case NotifyAncestor: + eventPtr->xcrossing.detail = NotifyVirtual; + break; + case NotifyNonlinear: + eventPtr->xcrossing.detail = NotifyNonlinearVirtual; + break; + } + } + + /* + * Make buttons have the same grab-like behavior inside a grab + * as they do outside a grab: do this by ignoring enter and + * leave events except for the window in which the button was + * pressed. + */ + + if ((dispPtr->buttonWinPtr != NULL) + && (winPtr != dispPtr->buttonWinPtr)) { + return 0; + } + } + return 1; + } + + if (!appGrabbed) { + return 1; + } + + if (eventPtr->type == MotionNotify) { + /* + * When grabs are active, X reports motion events relative to the + * window under the pointer. Instead, it should report the events + * relative to the window the button went down in, if there is a + * button down. Otherwise, if the pointer window is outside the + * subtree of the grab window, the events should be reported + * relative to the grab window. Otherwise, the event should be + * reported to the pointer window. + */ + + winPtr2 = winPtr; + if (dispPtr->buttonWinPtr != NULL) { + winPtr2 = dispPtr->buttonWinPtr; + } else if (outsideGrabTree || (dispPtr->serverWinPtr == NULL)) { + winPtr2 = dispPtr->grabWinPtr; + } + if (winPtr2 != winPtr) { + TkChangeEventWindow(eventPtr, winPtr2); + Tk_QueueWindowEvent(eventPtr, TCL_QUEUE_HEAD); + return 0; + } + return 1; + } + + /* + * Process ButtonPress and ButtonRelease events: + * 1. Keep track of whether a button is down and what window it + * went down in. + * 2. If the first button goes down outside the grab tree, pretend + * it went down in the grab window. Note: it's important to + * redirect events to the grab window like this in order to make + * things like menus work, where button presses outside the + * grabbed menu need to be seen. An application can always + * ignore the events if they occur outside its window. + * 3. If a button press or release occurs outside the window where + * the first button was pressed, retarget the event so it's reported + * to the window where the first button was pressed. + * 4. If the last button is released in a window different than where + * the first button was pressed, generate Enter/Leave events to + * move the mouse from the button window to its current window. + * 5. If the grab is set at a time when a button is already down, or + * if the window where the button was pressed was deleted, then + * dispPtr->buttonWinPtr will stay NULL. Just forget about the + * auto-grab for the button press; events will go to whatever + * window contains the pointer. If this window isn't in the grab + * tree then redirect events to the grab window. + * 6. When a button is pressed during a local grab, the X server sets + * a grab of its own, since it doesn't even know about our local + * grab. This causes enter and leave events no longer to be + * generated in the same way as for global grabs. To eliminate this + * problem, set a temporary global grab when the first button goes + * down and release it when the last button comes up. + */ + + if ((eventPtr->type == ButtonPress) || (eventPtr->type == ButtonRelease)) { + winPtr2 = dispPtr->buttonWinPtr; + if (winPtr2 == NULL) { + if (outsideGrabTree) { + winPtr2 = dispPtr->grabWinPtr; /* Note 5. */ + } else { + winPtr2 = winPtr; /* Note 5. */ + } + } + if (eventPtr->type == ButtonPress) { + if ((eventPtr->xbutton.state & ALL_BUTTONS) == 0) { + if (outsideGrabTree) { + TkChangeEventWindow(eventPtr, dispPtr->grabWinPtr); + Tk_QueueWindowEvent(eventPtr, TCL_QUEUE_HEAD); + return 0; /* Note 2. */ + } + if (!(dispPtr->grabFlags & GRAB_GLOBAL)) { /* Note 6. */ + serial = NextRequest(dispPtr->display); + if (XGrabPointer(dispPtr->display, + dispPtr->grabWinPtr->window, True, + ButtonPressMask|ButtonReleaseMask|ButtonMotionMask, + GrabModeAsync, GrabModeAsync, None, None, + CurrentTime) == 0) { + EatGrabEvents(dispPtr, serial); + if (XGrabKeyboard(dispPtr->display, winPtr->window, + False, GrabModeAsync, GrabModeAsync, + CurrentTime) == 0) { + dispPtr->grabFlags |= GRAB_TEMP_GLOBAL; + } else { + XUngrabPointer(dispPtr->display, CurrentTime); + } + } + } + dispPtr->buttonWinPtr = winPtr; + return 1; + } + } else { + if ((eventPtr->xbutton.state & ALL_BUTTONS) + == buttonStates[eventPtr->xbutton.button - Button1]) { + ReleaseButtonGrab(dispPtr); /* Note 4. */ + } + } + if (winPtr2 != winPtr) { + TkChangeEventWindow(eventPtr, winPtr2); + Tk_QueueWindowEvent(eventPtr, TCL_QUEUE_HEAD); + return 0; /* Note 3. */ + } + } + + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * TkChangeEventWindow -- + * + * Given an event and a new window to which the event should be + * retargeted, modify fields of the event so that the event is + * properly retargeted to the new window. + * + * Results: + * The following fields of eventPtr are modified: window, + * subwindow, x, y, same_screen. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TkChangeEventWindow(eventPtr, winPtr) + register XEvent *eventPtr; /* Event to retarget. Must have + * type ButtonPress, ButtonRelease, KeyPress, + * KeyRelease, MotionNotify, EnterNotify, + * or LeaveNotify. */ + TkWindow *winPtr; /* New target window for event. */ +{ + int x, y, sameScreen, bd; + register TkWindow *childPtr; + + eventPtr->xmotion.window = Tk_WindowId(winPtr); + if (eventPtr->xmotion.root == + RootWindow(winPtr->display, winPtr->screenNum)) { + Tk_GetRootCoords((Tk_Window) winPtr, &x, &y); + eventPtr->xmotion.x = eventPtr->xmotion.x_root - x; + eventPtr->xmotion.y = eventPtr->xmotion.y_root - y; + eventPtr->xmotion.subwindow = None; + for (childPtr = winPtr->childList; childPtr != NULL; + childPtr = childPtr->nextPtr) { + if (childPtr->flags & TK_TOP_LEVEL) { + continue; + } + x = eventPtr->xmotion.x - childPtr->changes.x; + y = eventPtr->xmotion.y - childPtr->changes.y; + bd = childPtr->changes.border_width; + if ((x >= -bd) && (y >= -bd) + && (x < (childPtr->changes.width + bd)) + && (y < (childPtr->changes.height + bd))) { + eventPtr->xmotion.subwindow = childPtr->window; + } + } + sameScreen = 1; + } else { + eventPtr->xmotion.x = 0; + eventPtr->xmotion.y = 0; + eventPtr->xmotion.subwindow = None; + sameScreen = 0; + } + if (eventPtr->type == MotionNotify) { + eventPtr->xmotion.same_screen = sameScreen; + } else { + eventPtr->xbutton.same_screen = sameScreen; + } +} + +/* + *---------------------------------------------------------------------- + * + * TkInOutEvents -- + * + * This procedure synthesizes EnterNotify and LeaveNotify events + * to correctly transfer the pointer from one window to another. + * It can also be used to generate FocusIn and FocusOut events + * to move the input focus. + * + * Results: + * None. + * + * Side effects: + * Synthesized events may be pushed back onto the event queue. + * The event pointed to by eventPtr is modified. + * + *---------------------------------------------------------------------- + */ + +void +TkInOutEvents(eventPtr, sourcePtr, destPtr, leaveType, enterType, position) + XEvent *eventPtr; /* A template X event. Must have all fields + * properly set except for type, window, + * subwindow, x, y, detail, and same_screen + * (Not all of these fields are valid for + * FocusIn/FocusOut events; x_root and y_root + * must be valid for Enter/Leave events, even + * though x and y needn't be valid). */ + TkWindow *sourcePtr; /* Window that used to have the pointer or + * focus (NULL means it was not in a window + * managed by this process). */ + TkWindow *destPtr; /* Window that is to end up with the pointer + * or focus (NULL means it's not one managed + * by this process). */ + int leaveType; /* Type of events to generate for windows + * being left (LeaveNotify or FocusOut). 0 + * means don't generate leave events. */ + int enterType; /* Type of events to generate for windows + * being entered (EnterNotify or FocusIn). 0 + * means don't generate enter events. */ + Tcl_QueuePosition position; /* Position at which events are added to + * the system event queue. */ +{ + register TkWindow *winPtr; + int upLevels, downLevels, i, j, focus; + + /* + * There are four possible cases to deal with: + * + * 1. SourcePtr and destPtr are the same. There's nothing to do in + * this case. + * 2. SourcePtr is an ancestor of destPtr in the same top-level + * window. Must generate events down the window tree from source + * to dest. + * 3. DestPtr is an ancestor of sourcePtr in the same top-level + * window. Must generate events up the window tree from sourcePtr + * to destPtr. + * 4. All other cases. Must first generate events up the window tree + * from sourcePtr to its top-level, then down from destPtr's + * top-level to destPtr. This form is called "non-linear." + * + * The call to FindCommonAncestor separates these four cases and decides + * how many levels up and down events have to be generated for. + */ + + if (sourcePtr == destPtr) { + return; + } + if ((leaveType == FocusOut) || (enterType == FocusIn)) { + focus = 1; + } else { + focus = 0; + } + FindCommonAncestor(sourcePtr, destPtr, &upLevels, &downLevels); + + /* + * Generate enter/leave events and add them to the grab event queue. + */ + + +#define QUEUE(w, t, d) \ + if (w->window != None) { \ + eventPtr->type = t; \ + if (focus) { \ + eventPtr->xfocus.window = w->window; \ + eventPtr->xfocus.detail = d; \ + } else { \ + eventPtr->xcrossing.detail = d; \ + TkChangeEventWindow(eventPtr, w); \ + } \ + Tk_QueueWindowEvent(eventPtr, position); \ + } + + if (downLevels == 0) { + + /* + * SourcePtr is an inferior of destPtr. + */ + + if (leaveType != 0) { + QUEUE(sourcePtr, leaveType, NotifyAncestor); + for (winPtr = sourcePtr->parentPtr, i = upLevels-1; i > 0; + winPtr = winPtr->parentPtr, i--) { + QUEUE(winPtr, leaveType, NotifyVirtual); + } + } + if ((enterType != 0) && (destPtr != NULL)) { + QUEUE(destPtr, enterType, NotifyInferior); + } + } else if (upLevels == 0) { + + /* + * DestPtr is an inferior of sourcePtr. + */ + + if ((leaveType != 0) && (sourcePtr != NULL)) { + QUEUE(sourcePtr, leaveType, NotifyInferior); + } + if (enterType != 0) { + for (i = downLevels-1; i > 0; i--) { + for (winPtr = destPtr->parentPtr, j = 1; j < i; + winPtr = winPtr->parentPtr, j++) { + } + QUEUE(winPtr, enterType, NotifyVirtual); + } + if (destPtr != NULL) { + QUEUE(destPtr, enterType, NotifyAncestor); + } + } + } else { + + /* + * Non-linear: neither window is an inferior of the other. + */ + + if (leaveType != 0) { + QUEUE(sourcePtr, leaveType, NotifyNonlinear); + for (winPtr = sourcePtr->parentPtr, i = upLevels-1; i > 0; + winPtr = winPtr->parentPtr, i--) { + QUEUE(winPtr, leaveType, NotifyNonlinearVirtual); + } + } + if (enterType != 0) { + for (i = downLevels-1; i > 0; i--) { + for (winPtr = destPtr->parentPtr, j = 1; j < i; + winPtr = winPtr->parentPtr, j++) { + } + QUEUE(winPtr, enterType, NotifyNonlinearVirtual); + } + if (destPtr != NULL) { + QUEUE(destPtr, enterType, NotifyNonlinear); + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * MovePointer2 -- + * + * This procedure synthesizes EnterNotify and LeaveNotify events + * to correctly transfer the pointer from one window to another. + * It is different from TkInOutEvents in that no template X event + * needs to be supplied; this procedure generates the template + * event and calls TkInOutEvents. + * + * Results: + * None. + * + * Side effects: + * Synthesized events may be pushed back onto the event queue. + * + *---------------------------------------------------------------------- + */ + +static void +MovePointer2(sourcePtr, destPtr, mode, leaveEvents, enterEvents) + TkWindow *sourcePtr; /* Window currently containing pointer (NULL + * means it's not one managed by this + * process). */ + TkWindow *destPtr; /* Window that is to end up containing the + * pointer (NULL means it's not one managed + * by this process). */ + int mode; /* Mode for enter/leave events, such as + * NotifyNormal or NotifyUngrab. */ + int leaveEvents; /* Non-zero means generate leave events for the + * windows being left. Zero means don't + * generate leave events. */ + int enterEvents; /* Non-zero means generate enter events for the + * windows being entered. Zero means don't + * generate enter events. */ +{ + XEvent event; + Window dummy1, dummy2; + int dummy3, dummy4; + TkWindow *winPtr; + + winPtr = sourcePtr; + if ((winPtr == NULL) || (winPtr->window == None)) { + winPtr = destPtr; + if ((winPtr == NULL) || (winPtr->window == None)) { + return; + } + } + + event.xcrossing.serial = LastKnownRequestProcessed( + winPtr->display); + event.xcrossing.send_event = GENERATED_EVENT_MAGIC; + event.xcrossing.display = winPtr->display; + event.xcrossing.root = RootWindow(winPtr->display, + winPtr->screenNum); + event.xcrossing.time = TkCurrentTime(winPtr->dispPtr); + XQueryPointer(winPtr->display, winPtr->window, &dummy1, &dummy2, + &event.xcrossing.x_root, &event.xcrossing.y_root, + &dummy3, &dummy4, &event.xcrossing.state); + event.xcrossing.mode = mode; + event.xcrossing.focus = False; + TkInOutEvents(&event, sourcePtr, destPtr, (leaveEvents) ? LeaveNotify : 0, + (enterEvents) ? EnterNotify : 0, TCL_QUEUE_MARK); +} + +/* + *---------------------------------------------------------------------- + * + * TkGrabDeadWindow -- + * + * This procedure is invoked whenever a window is deleted, so that + * grab-related cleanup can be performed. + * + * Results: + * None. + * + * Side effects: + * Various cleanups happen, such as generating events to move the + * pointer back to its "natural" window as if an ungrab had been + * done. See the code. + * + *---------------------------------------------------------------------- + */ + +void +TkGrabDeadWindow(winPtr) + register TkWindow *winPtr; /* Window that is in the process + * of being deleted. */ +{ + TkDisplay *dispPtr = winPtr->dispPtr; + + if (dispPtr->eventualGrabWinPtr == winPtr) { + /* + * Grab window was deleted. Release the grab. + */ + + Tk_Ungrab((Tk_Window) dispPtr->eventualGrabWinPtr); + } else if (dispPtr->buttonWinPtr == winPtr) { + ReleaseButtonGrab(dispPtr); + } + if (dispPtr->serverWinPtr == winPtr) { + if (winPtr->flags & TK_TOP_LEVEL) { + dispPtr->serverWinPtr = NULL; + } else { + dispPtr->serverWinPtr = winPtr->parentPtr; + } + } + if (dispPtr->grabWinPtr == winPtr) { + dispPtr->grabWinPtr = NULL; + } +} + +/* + *---------------------------------------------------------------------- + * + * EatGrabEvents -- + * + * This procedure is called to eliminate any Enter, Leave, + * FocusIn, or FocusOut events in the event queue for a + * display that have mode NotifyGrab or NotifyUngrab and + * have a serial number no less than a given value and are not + * generated by the grab module. + * + * Results: + * None. + * + * Side effects: + * DispPtr's display gets sync-ed, and some of the events get + * removed from the Tk event queue. + * + *---------------------------------------------------------------------- + */ + +static void +EatGrabEvents(dispPtr, serial) + TkDisplay *dispPtr; /* Display from which to consume events. */ + unsigned int serial; /* Only discard events that have a serial + * number at least this great. */ +{ + Tk_RestrictProc *oldProc; + GrabInfo info; + ClientData oldArg, dummy; + + info.display = dispPtr->display; + info.serial = serial; + TkpSync(info.display); + oldProc = Tk_RestrictEvents(GrabRestrictProc, (ClientData)&info, &oldArg); + while (Tcl_ServiceEvent(TCL_WINDOW_EVENTS)) { + } + Tk_RestrictEvents(oldProc, oldArg, &dummy); +} + +/* + *---------------------------------------------------------------------- + * + * GrabRestrictProc -- + * + * A Tk_RestrictProc used by EatGrabEvents to eliminate any + * Enter, Leave, FocusIn, or FocusOut events in the event queue + * for a display that has mode NotifyGrab or NotifyUngrab and + * have a serial number no less than a given value. + * + * Results: + * Returns either TK_DISCARD_EVENT or TK_DEFER_EVENT. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Tk_RestrictAction +GrabRestrictProc(arg, eventPtr) + ClientData arg; + XEvent *eventPtr; +{ + GrabInfo *info = (GrabInfo *) arg; + int mode, diff; + + /* + * The diff caculation is trickier than it may seem. Don't forget + * that serial numbers can wrap around, so can't compare the two + * serial numbers directly. + */ + + diff = eventPtr->xany.serial - info->serial; + if ((eventPtr->type == EnterNotify) + || (eventPtr->type == LeaveNotify)) { + mode = eventPtr->xcrossing.mode; + } else if ((eventPtr->type == FocusIn) + || (eventPtr->type == FocusOut)) { + mode = eventPtr->xfocus.mode; + } else { + mode = NotifyNormal; + } + if ((info->display != eventPtr->xany.display) || (mode == NotifyNormal) + || (diff < 0)) { + return TK_DEFER_EVENT; + } else { + return TK_DISCARD_EVENT; + } +} + +/* + *---------------------------------------------------------------------- + * + * QueueGrabWindowChange -- + * + * This procedure queues a special event in the Tcl event queue, + * which will cause the "grabWinPtr" field for the display to get + * modified when the event is processed. This is needed to make + * sure that the grab window changes at the proper time relative + * to grab-related enter and leave events that are also in the + * queue. In particular, this approach works even when multiple + * grabs and ungrabs happen back-to-back. + * + * Results: + * None. + * + * Side effects: + * DispPtr->grabWinPtr will be modified later (by GrabWinEventProc) + * when the event is removed from the grab event queue. + * + *---------------------------------------------------------------------- + */ + +static void +QueueGrabWindowChange(dispPtr, grabWinPtr) + TkDisplay *dispPtr; /* Display on which to change the grab + * window. */ + TkWindow *grabWinPtr; /* Window that is to become the new grab + * window (may be NULL). */ +{ + NewGrabWinEvent *grabEvPtr; + + grabEvPtr = (NewGrabWinEvent *) ckalloc(sizeof(NewGrabWinEvent)); + grabEvPtr->header.proc = GrabWinEventProc; + grabEvPtr->dispPtr = dispPtr; + if (grabWinPtr == NULL) { + grabEvPtr->grabWindow = None; + } else { + grabEvPtr->grabWindow = grabWinPtr->window; + } + Tcl_QueueEvent(&grabEvPtr->header, TCL_QUEUE_MARK); + dispPtr->eventualGrabWinPtr = grabWinPtr; +} + +/* + *---------------------------------------------------------------------- + * + * GrabWinEventProc -- + * + * This procedure is invoked as a handler for Tcl_Events of type + * NewGrabWinEvent. It updates the current grab window field in + * a display. + * + * Results: + * Returns 1 if the event was processed, 0 if it should be deferred + * for processing later. + * + * Side effects: + * The grabWinPtr field is modified in the display associated with + * the event. + * + *---------------------------------------------------------------------- + */ + +static int +GrabWinEventProc(evPtr, flags) + Tcl_Event *evPtr; /* Event of type NewGrabWinEvent. */ + int flags; /* Flags argument to Tk_DoOneEvent: indicates + * what kinds of events are being processed + * right now. */ +{ + NewGrabWinEvent *grabEvPtr = (NewGrabWinEvent *) evPtr; + + grabEvPtr->dispPtr->grabWinPtr = (TkWindow *) Tk_IdToWindow( + grabEvPtr->dispPtr->display, grabEvPtr->grabWindow); + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * FindCommonAncestor -- + * + * Given two windows, this procedure finds their least common + * ancestor and also computes how many levels up this ancestor + * is from each of the original windows. + * + * Results: + * If the windows are in different applications or top-level + * windows, then NULL is returned and *countPtr1 and *countPtr2 + * are set to the depths of the two windows in their respective + * top-level windows (1 means the window is a top-level, 2 means + * its parent is a top-level, and so on). Otherwise, the return + * value is a pointer to the common ancestor and the counts are + * set to the distance of winPtr1 and winPtr2 from this ancestor + * (1 means they're children, 2 means grand-children, etc.). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static TkWindow * +FindCommonAncestor(winPtr1, winPtr2, countPtr1, countPtr2) + TkWindow *winPtr1; /* First window. May be NULL. */ + TkWindow *winPtr2; /* Second window. May be NULL. */ + int *countPtr1; /* Store nesting level of winPtr1 within + * common ancestor here. */ + int *countPtr2; /* Store nesting level of winPtr2 within + * common ancestor here. */ +{ + register TkWindow *winPtr; + TkWindow *ancestorPtr; + int count1, count2, i; + + /* + * Mark winPtr1 and all of its ancestors with a special flag bit. + */ + + if (winPtr1 != NULL) { + for (winPtr = winPtr1; winPtr != NULL; winPtr = winPtr->parentPtr) { + winPtr->flags |= TK_GRAB_FLAG; + if (winPtr->flags & TK_TOP_LEVEL) { + break; + } + } + } + + /* + * Search upwards from winPtr2 until an ancestor of winPtr1 is + * found or a top-level window is reached. + */ + + winPtr = winPtr2; + count2 = 0; + ancestorPtr = NULL; + if (winPtr2 != NULL) { + for (; winPtr != NULL; count2++, winPtr = winPtr->parentPtr) { + if (winPtr->flags & TK_GRAB_FLAG) { + ancestorPtr = winPtr; + break; + } + if (winPtr->flags & TK_TOP_LEVEL) { + count2++; + break; + } + } + } + + /* + * Search upwards from winPtr1 again, clearing the flag bits and + * remembering how many levels up we had to go. + */ + + if (winPtr1 == NULL) { + count1 = 0; + } else { + count1 = -1; + for (i = 0, winPtr = winPtr1; winPtr != NULL; + i++, winPtr = winPtr->parentPtr) { + winPtr->flags &= ~TK_GRAB_FLAG; + if (winPtr == ancestorPtr) { + count1 = i; + } + if (winPtr->flags & TK_TOP_LEVEL) { + if (count1 == -1) { + count1 = i+1; + } + break; + } + } + } + + *countPtr1 = count1; + *countPtr2 = count2; + return ancestorPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TkPositionInTree -- + * + * Compute where the given window is relative to a particular + * subtree of the window hierarchy. + * + * Results: + * + * Returns TK_GRAB_IN_TREE if the window is contained in the + * subtree. Returns TK_GRAB_ANCESTOR if the window is an + * ancestor of the subtree, in the same toplevel. Otherwise + * it returns TK_GRAB_EXCLUDED. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TkPositionInTree(winPtr, treePtr) + TkWindow *winPtr; /* Window to be checked. */ + TkWindow *treePtr; /* Root of tree to compare against. */ +{ + TkWindow *winPtr2; + + for (winPtr2 = winPtr; winPtr2 != treePtr; + winPtr2 = winPtr2->parentPtr) { + if (winPtr2 == NULL) { + for (winPtr2 = treePtr; winPtr2 != NULL; + winPtr2 = winPtr2->parentPtr) { + if (winPtr2 == winPtr) { + return TK_GRAB_ANCESTOR; + } + if (winPtr2->flags & TK_TOP_LEVEL) { + break; + } + } + return TK_GRAB_EXCLUDED; + } + } + return TK_GRAB_IN_TREE; +} + +/* + *---------------------------------------------------------------------- + * + * TkGrabState -- + * + * Given a window, this procedure returns a value that indicates + * the grab state of the application relative to the window. + * + * Results: + * The return value is one of three things: + * TK_GRAB_NONE - no grab is in effect. + * TK_GRAB_IN_TREE - there is a grab in effect, and winPtr + * is in the grabbed subtree. + * TK_GRAB_ANCESTOR - there is a grab in effect; winPtr is + * an ancestor of the grabbed window, in + * the same toplevel. + * TK_GRAB_EXCLUDED - there is a grab in effect; winPtr is + * outside the tree of the grab and is not + * an ancestor of the grabbed window in the + * same toplevel. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TkGrabState(winPtr) + TkWindow *winPtr; /* Window for which grab information is + * needed. */ +{ + TkWindow *grabWinPtr = winPtr->dispPtr->grabWinPtr; + + if (grabWinPtr == NULL) { + return TK_GRAB_NONE; + } + if ((winPtr->mainPtr != grabWinPtr->mainPtr) + && !(winPtr->dispPtr->grabFlags & GRAB_GLOBAL)) { + return TK_GRAB_NONE; + } + + return TkPositionInTree(winPtr, grabWinPtr); +} diff --git a/generic/tkGrid.c b/generic/tkGrid.c new file mode 100644 index 0000000..ea11a01 --- /dev/null +++ b/generic/tkGrid.c @@ -0,0 +1,2615 @@ +/* + * tkGrid.c -- + * + * Grid based geometry manager. + * + * 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: @(#) tkGrid.c 1.39 97/10/10 10:12:03 + */ + +#include "tkInt.h" + +/* + * Convenience Macros + */ + +#ifdef MAX +# undef MAX +#endif +#define MAX(x,y) ((x) > (y) ? (x) : (y)) +#ifdef MIN +# undef MIN +#endif +#define MIN(x,y) ((x) > (y) ? (y) : (x)) + +#define COLUMN (1) /* working on column offsets */ +#define ROW (2) /* working on row offsets */ + +#define CHECK_ONLY (1) /* check max slot constraint */ +#define CHECK_SPACE (2) /* alloc more space, don't change max */ + +/* + * Pre-allocate enough row and column slots for "typical" sized tables + * this value should be chosen so by the time the extra malloc's are + * required, the layout calculations overwehlm them. [A "slot" contains + * information for either a row or column, depending upon the context.] + */ + +#define TYPICAL_SIZE 25 /* (arbitrary guess) */ +#define PREALLOC 10 /* extra slots to allocate */ + +/* + * Data structures are allocated dynamically to support arbitrary sized tables. + * However, the space is proportional to the highest numbered slot with + * some non-default property. This limit is used to head off mistakes and + * denial of service attacks by limiting the amount of storage required. + */ + +#define MAX_ELEMENT 10000 + +/* + * Special characters to support relative layouts. + */ + +#define REL_SKIP 'x' /* Skip this column. */ +#define REL_HORIZ '-' /* Extend previous widget horizontally. */ +#define REL_VERT '^' /* Extend widget from row above. */ + +/* + * Structure to hold information for grid masters. A slot is either + * a row or column. + */ + +typedef struct SlotInfo { + int minSize; /* The minimum size of this slot (in pixels). + * It is set via the rowconfigure or + * columnconfigure commands. */ + int weight; /* The resize weight of this slot. (0) means + * this slot doesn't resize. Extra space in + * the layout is given distributed among slots + * inproportion to their weights. */ + int pad; /* Extra padding, in pixels, required for + * this slot. This amount is "added" to the + * largest slave in the slot. */ + int offset; /* This is a cached value used for + * introspection. It is the pixel + * offset of the right or bottom edge + * of this slot from the beginning of the + * layout. */ + int temp; /* This is a temporary value used for + * calculating adjusted weights when + * shrinking the layout below its + * nominal size. */ +} SlotInfo; + +/* + * Structure to hold information during layout calculations. There + * is one of these for each slot, an array for each of the rows or columns. + */ + +typedef struct GridLayout { + struct Gridder *binNextPtr; /* The next slave window in this bin. + * Each bin contains a list of all + * slaves whose spans are >1 and whose + * right edges fall in this slot. */ + int minSize; /* Minimum size needed for this slot, + * in pixels. This is the space required + * to hold any slaves contained entirely + * in this slot, adjusted for any slot + * constrants, such as size or padding. */ + int pad; /* Padding needed for this slot */ + int weight; /* Slot weight, controls resizing. */ + int minOffset; /* The minimum offset, in pixels, from + * the beginning of the layout to the + * right/bottom edge of the slot calculated + * from top/left to bottom/right. */ + int maxOffset; /* The maximum offset, in pixels, from + * the beginning of the layout to the + * right-or-bottom edge of the slot calculated + * from bottom-or-right to top-or-left. */ +} GridLayout; + +/* + * Keep one of these for each geometry master. + */ + +typedef struct { + SlotInfo *columnPtr; /* Pointer to array of column constraints. */ + SlotInfo *rowPtr; /* Pointer to array of row constraints. */ + int columnEnd; /* The last column occupied by any slave. */ + int columnMax; /* The number of columns with constraints. */ + int columnSpace; /* The number of slots currently allocated for + * column constraints. */ + int rowEnd; /* The last row occupied by any slave. */ + int rowMax; /* The number of rows with constraints. */ + int rowSpace; /* The number of slots currently allocated + * for row constraints. */ + int startX; /* Pixel offset of this layout within its + * parent. */ + int startY; /* Pixel offset of this layout within its + * parent. */ +} GridMaster; + +/* + * For each window that the grid cares about (either because + * the window is managed by the grid or because the window + * has slaves that are managed by the grid), there is a + * structure of the following type: + */ + +typedef struct Gridder { + Tk_Window tkwin; /* Tk token for window. NULL means that + * the window has been deleted, but the + * gridder hasn't had a chance to clean up + * yet because the structure is still in + * use. */ + struct Gridder *masterPtr; /* Master window within which this window + * is managed (NULL means this window + * isn't managed by the gridder). */ + struct Gridder *nextPtr; /* Next window managed within same + * parent. List order doesn't matter. */ + struct Gridder *slavePtr; /* First in list of slaves managed + * inside this window (NULL means + * no grid slaves). */ + GridMaster *masterDataPtr; /* Additional data for geometry master. */ + int column, row; /* Location in the grid (starting + * from zero). */ + int numCols, numRows; /* Number of columns or rows this slave spans. + * Should be at least 1. */ + int padX, padY; /* Total additional pixels to leave around the + * window (half of this space is left on each + * side). This is space *outside* the window: + * we'll allocate extra space in frame but + * won't enlarge window). */ + int iPadX, iPadY; /* Total extra pixels to allocate inside the + * window (half this amount will appear on + * each side). */ + int sticky; /* which sides of its cavity this window + * sticks to. See below for definitions */ + int doubleBw; /* Twice the window's last known border + * width. If this changes, the window + * must be re-arranged within its parent. */ + int *abortPtr; /* If non-NULL, it means that there is a nested + * call to ArrangeGrid already working on + * this window. *abortPtr may be set to 1 to + * abort that nested call. This happens, for + * example, if tkwin or any of its slaves + * is deleted. */ + int flags; /* Miscellaneous flags; see below + * for definitions. */ + + /* + * These fields are used temporarily for layout calculations only. + */ + + struct Gridder *binNextPtr; /* Link to next span>1 slave in this bin. */ + int size; /* Nominal size (width or height) in pixels + * of the slave. This includes the padding. */ +} Gridder; + +/* Flag values for "sticky"ness The 16 combinations subsume the packer's + * notion of anchor and fill. + * + * STICK_NORTH This window sticks to the top of its cavity. + * STICK_EAST This window sticks to the right edge of its cavity. + * STICK_SOUTH This window sticks to the bottom of its cavity. + * STICK_WEST This window sticks to the left edge of its cavity. + */ + +#define STICK_NORTH 1 +#define STICK_EAST 2 +#define STICK_SOUTH 4 +#define STICK_WEST 8 + +/* + * Flag values for Grid structures: + * + * REQUESTED_RELAYOUT: 1 means a Tcl_DoWhenIdle request + * has already been made to re-arrange + * all the slaves of this window. + * + * DONT_PROPAGATE: 1 means don't set this window's requested + * size. 0 means if this window is a master + * then Tk will set its requested size to fit + * the needs of its slaves. + */ + +#define REQUESTED_RELAYOUT 1 +#define DONT_PROPAGATE 2 + +/* + * Hash table used to map from Tk_Window tokens to corresponding + * Grid structures: + */ + +static Tcl_HashTable gridHashTable; +static int initialized = 0; + +/* + * Prototypes for procedures used only in this file: + */ + +static void AdjustForSticky _ANSI_ARGS_((Gridder *slavePtr, int *xPtr, + int *yPtr, int *widthPtr, int *heightPtr)); +static int AdjustOffsets _ANSI_ARGS_((int width, + int elements, SlotInfo *slotPtr)); +static void ArrangeGrid _ANSI_ARGS_((ClientData clientData)); +static int CheckSlotData _ANSI_ARGS_((Gridder *masterPtr, int slot, + int slotType, int checkOnly)); +static int ConfigureSlaves _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, int argc, char *argv[])); +static void DestroyGrid _ANSI_ARGS_((char *memPtr)); +static Gridder *GetGrid _ANSI_ARGS_((Tk_Window tkwin)); +static void GridStructureProc _ANSI_ARGS_(( + ClientData clientData, XEvent *eventPtr)); +static void GridLostSlaveProc _ANSI_ARGS_((ClientData clientData, + Tk_Window tkwin)); +static void GridReqProc _ANSI_ARGS_((ClientData clientData, + Tk_Window tkwin)); +static void InitMasterData _ANSI_ARGS_((Gridder *masterPtr)); +static int ResolveConstraints _ANSI_ARGS_((Gridder *gridPtr, + int rowOrColumn, int maxOffset)); +static void SetGridSize _ANSI_ARGS_((Gridder *gridPtr)); +static void StickyToString _ANSI_ARGS_((int flags, char *result)); +static int StringToSticky _ANSI_ARGS_((char *string)); +static void Unlink _ANSI_ARGS_((Gridder *gridPtr)); + +static Tk_GeomMgr gridMgrType = { + "grid", /* name */ + GridReqProc, /* requestProc */ + GridLostSlaveProc, /* lostSlaveProc */ +}; + +/* + *-------------------------------------------------------------- + * + * Tk_GridCmd -- + * + * This procedure is invoked to process the "grid" 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_GridCmd(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; + Gridder *masterPtr; /* master grid record */ + GridMaster *gridPtr; /* pointer to grid data */ + size_t length; /* streing length of argument */ + char c; /* 1st character of argument */ + + if ((argc >= 2) && ((argv[1][0] == '.') || (argv[1][0] == REL_SKIP) || + (argv[1][0] == REL_VERT))) { + return ConfigureSlaves(interp, tkwin, argc-1, argv+1); + } + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " option arg ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + c = argv[1][0]; + length = strlen(argv[1]); + + if ((c == 'b') && (strncmp(argv[1], "bbox", length) == 0)) { + Tk_Window master; + int row, column; /* origin for bounding box */ + int row2, column2; /* end of bounding box */ + 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 */ + + if (argc!=3 && argc != 5 && argc != 7) { + Tcl_AppendResult(interp, "wrong number of arguments: ", + "must be \"",argv[0], + " bbox master ?column row ?column row??\"", + (char *) NULL); + return TCL_ERROR; + } + + master = Tk_NameToWindow(interp, argv[2], tkwin); + if (master == NULL) { + return TCL_ERROR; + } + masterPtr = GetGrid(master); + + if (argc >= 5) { + if (Tcl_GetInt(interp, argv[3], &column) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[4], &row) != TCL_OK) { + return TCL_ERROR; + } + column2 = column; + row2 = row; + } + + if (argc == 7) { + if (Tcl_GetInt(interp, argv[5], &column2) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[6], &row2) != TCL_OK) { + return TCL_ERROR; + } + } + + gridPtr = masterPtr->masterDataPtr; + if (gridPtr == NULL) { + sprintf(interp->result, "%d %d %d %d",0,0,0,0); + return(TCL_OK); + } + + SetGridSize(masterPtr); + endX = MAX(gridPtr->columnEnd, gridPtr->columnMax); + endY = MAX(gridPtr->rowEnd, gridPtr->rowMax); + + if ((endX == 0) || (endY == 0)) { + sprintf(interp->result, "%d %d %d %d",0,0,0,0); + return(TCL_OK); + } + if (argc == 3) { + row = column = 0; + row2 = endY; + column2 = endX; + } + + if (column > column2) { + int temp = column; + column = column2, column2 = temp; + } + if (row > row2) { + int temp = row; + row = row2, row2 = temp; + } + + if (column > 0 && column < endX) { + x = gridPtr->columnPtr[column-1].offset; + } else if (column > 0) { + x = gridPtr->columnPtr[endX-1].offset; + } + + if (row > 0 && row < endY) { + y = gridPtr->rowPtr[row-1].offset; + } else if (row > 0) { + y = gridPtr->rowPtr[endY-1].offset; + } + + if (column2 < 0) { + width = 0; + } else if (column2 >= endX) { + width = gridPtr->columnPtr[endX-1].offset - x; + } else { + width = gridPtr->columnPtr[column2].offset - x; + } + + if (row2 < 0) { + height = 0; + } else if (row2 >= endY) { + height = gridPtr->rowPtr[endY-1].offset - y; + } else { + height = gridPtr->rowPtr[row2].offset - y; + } + + sprintf(interp->result, "%d %d %d %d", + x + gridPtr->startX, y + gridPtr->startY, width, height); + } else if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0)) { + if (argv[2][0] != '.') { + Tcl_AppendResult(interp, "bad argument \"", argv[2], + "\": must be name of window", (char *) NULL); + return TCL_ERROR; + } + return ConfigureSlaves(interp, tkwin, argc-2, argv+2); + } else if (((c == 'f') && (strncmp(argv[1], "forget", length) == 0)) || + ((c == 'r') && (strncmp(argv[1], "remove", length) == 0))) { + Tk_Window slave; + Gridder *slavePtr; + int i; + + for (i = 2; i < argc; i++) { + slave = Tk_NameToWindow(interp, argv[i], tkwin); + if (slave == NULL) { + return TCL_ERROR; + } + slavePtr = GetGrid(slave); + if (slavePtr->masterPtr != NULL) { + + /* + * For "forget", reset all the settings to their defaults + */ + + if (c == 'f') { + slavePtr->column = slavePtr->row = -1; + slavePtr->numCols = 1; + slavePtr->numRows = 1; + slavePtr->padX = slavePtr->padY = 0; + slavePtr->iPadX = slavePtr->iPadY = 0; + slavePtr->doubleBw = 2*Tk_Changes(tkwin)->border_width; + slavePtr->flags = 0; + slavePtr->sticky = 0; + } + Tk_ManageGeometry(slave, (Tk_GeomMgr *) NULL, + (ClientData) NULL); + if (slavePtr->masterPtr->tkwin != Tk_Parent(slavePtr->tkwin)) { + Tk_UnmaintainGeometry(slavePtr->tkwin, + slavePtr->masterPtr->tkwin); + } + Unlink(slavePtr); + Tk_UnmapWindow(slavePtr->tkwin); + } + } + } else if ((c == 'i') && (strncmp(argv[1], "info", length) == 0)) { + register Gridder *slavePtr; + Tk_Window slave; + char buffer[70]; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " info window\"", (char *) NULL); + return TCL_ERROR; + } + slave = Tk_NameToWindow(interp, argv[2], tkwin); + if (slave == NULL) { + return TCL_ERROR; + } + slavePtr = GetGrid(slave); + if (slavePtr->masterPtr == NULL) { + interp->result[0] = '\0'; + return TCL_OK; + } + + Tcl_AppendElement(interp, "-in"); + Tcl_AppendElement(interp, Tk_PathName(slavePtr->masterPtr->tkwin)); + sprintf(buffer, " -column %d -row %d -columnspan %d -rowspan %d", + slavePtr->column, slavePtr->row, + slavePtr->numCols, slavePtr->numRows); + Tcl_AppendResult(interp, buffer, (char *) NULL); + sprintf(buffer, " -ipadx %d -ipady %d -padx %d -pady %d", + slavePtr->iPadX/2, slavePtr->iPadY/2, slavePtr->padX/2, + slavePtr->padY/2); + Tcl_AppendResult(interp, buffer, (char *) NULL); + StickyToString(slavePtr->sticky,buffer); + Tcl_AppendResult(interp, " -sticky ", buffer, (char *) NULL); + } else if((c == 'l') && (strncmp(argv[1], "location", length) == 0)) { + Tk_Window master; + register SlotInfo *slotPtr; + int x, y; /* Offset in pixels, from edge of parent. */ + int i, j; /* Corresponding column and row indeces. */ + int endX, endY; /* end of grid */ + + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " location master x y\"", (char *)NULL); + return TCL_ERROR; + } + + master = Tk_NameToWindow(interp, argv[2], tkwin); + if (master == NULL) { + return TCL_ERROR; + } + + if (Tk_GetPixels(interp, master, argv[3], &x) != TCL_OK) { + return TCL_ERROR; + } + if (Tk_GetPixels(interp, master, argv[4], &y) != TCL_OK) { + return TCL_ERROR; + } + + masterPtr = GetGrid(master); + if (masterPtr->masterDataPtr == NULL) { + sprintf(interp->result, "%d %d", -1, -1); + return TCL_OK; + } + gridPtr = masterPtr->masterDataPtr; + + /* + * Update any pending requests. This is not always the + * steady state value, as more configure events could be in + * the pipeline, but its as close as its easy to get. + */ + + while (masterPtr->flags & REQUESTED_RELAYOUT) { + Tk_CancelIdleCall(ArrangeGrid, (ClientData) masterPtr); + ArrangeGrid ((ClientData) masterPtr); + } + SetGridSize(masterPtr); + endX = MAX(gridPtr->columnEnd, gridPtr->columnMax); + endY = MAX(gridPtr->rowEnd, gridPtr->rowMax); + + slotPtr = masterPtr->masterDataPtr->columnPtr; + if (x < masterPtr->masterDataPtr->startX) { + i = -1; + } else { + x -= masterPtr->masterDataPtr->startX; + for (i=0;slotPtr[i].offset < x && i < endX; i++) { + /* null body */ + } + } + + slotPtr = masterPtr->masterDataPtr->rowPtr; + if (y < masterPtr->masterDataPtr->startY) { + j = -1; + } else { + y -= masterPtr->masterDataPtr->startY; + for (j=0;slotPtr[j].offset < y && j < endY; j++) { + /* null body */ + } + } + + sprintf(interp->result, "%d %d", i, j); + } else if ((c == 'p') && (strncmp(argv[1], "propagate", length) == 0)) { + Tk_Window master; + int propagate; + + if (argc > 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " propagate window ?boolean?\"", + (char *) NULL); + return TCL_ERROR; + } + master = Tk_NameToWindow(interp, argv[2], tkwin); + if (master == NULL) { + return TCL_ERROR; + } + masterPtr = GetGrid(master); + if (argc == 3) { + interp->result = (masterPtr->flags & DONT_PROPAGATE) ? "0" : "1"; + return TCL_OK; + } + if (Tcl_GetBoolean(interp, argv[3], &propagate) != TCL_OK) { + return TCL_ERROR; + } + if ((!propagate) ^ (masterPtr->flags&DONT_PROPAGATE)) { + masterPtr->flags ^= DONT_PROPAGATE; + + /* + * Re-arrange the master to allow new geometry information to + * propagate upwards to the master's master. + */ + + if (masterPtr->abortPtr != NULL) { + *masterPtr->abortPtr = 1; + } + if (!(masterPtr->flags & REQUESTED_RELAYOUT)) { + masterPtr->flags |= REQUESTED_RELAYOUT; + Tcl_DoWhenIdle(ArrangeGrid, (ClientData) masterPtr); + } + } + } else if ((c == 's') && (strncmp(argv[1], "size", length) == 0) + && (length > 1)) { + Tk_Window master; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " size window\"", (char *) NULL); + return TCL_ERROR; + } + master = Tk_NameToWindow(interp, argv[2], tkwin); + if (master == NULL) { + return TCL_ERROR; + } + masterPtr = GetGrid(master); + + if (masterPtr->masterDataPtr != NULL) { + SetGridSize(masterPtr); + gridPtr = masterPtr->masterDataPtr; + sprintf(interp->result, "%d %d", + MAX(gridPtr->columnEnd, gridPtr->columnMax), + MAX(gridPtr->rowEnd, gridPtr->rowMax)); + } else { + sprintf(interp->result, "%d %d",0, 0); + } + } else if ((c == 's') && (strncmp(argv[1], "slaves", length) == 0) + && (length > 1)) { + Tk_Window master; + Gridder *slavePtr; + int i, value; + int row = -1, column = -1; + + if ((argc < 3) || ((argc%2) == 0)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " slaves window ?-option value...?\"", + (char *) NULL); + return TCL_ERROR; + } + + for (i=3; islavePtr; slavePtr != NULL; + slavePtr = slavePtr->nextPtr) { + if (column>=0 && (slavePtr->column > column + || slavePtr->column+slavePtr->numCols-1 < column)) { + continue; + } + if (row>=0 && (slavePtr->row > row || + slavePtr->row+slavePtr->numRows-1 < row)) { + continue; + } + Tcl_AppendElement(interp, Tk_PathName(slavePtr->tkwin)); + } + + /* + * Sample argument combinations: + * grid columnconfigure -option + * grid columnconfigure -option value -option value + * grid rowconfigure + * grid rowconfigure -option + * grid rowconfigure -option value -option value. + */ + + } else if(((c == 'c') && (strncmp(argv[1], "columnconfigure", length) == 0) + && (length >= 3)) || + ((c == 'r') && (strncmp(argv[1], "rowconfigure", length) == 0) + && (length >=2))) { + Tk_Window master; + SlotInfo *slotPtr = NULL; + int slot; /* the column or row number */ + size_t length; /* the # of chars in the "-option" string */ + int slotType; /* COLUMN or ROW */ + int size; /* the configuration value */ + int checkOnly; /* check the size only */ + int argcPtr; /* Number of items in index list */ + char **argvPtr; /* array of indeces */ + char **indexP; /* String value of current index list item. */ + int ok; /* temporary TCL result code */ + int i; + + if (((argc%2 != 0) && (argc>6)) || (argc < 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ", argv[1], " master index ?-option value...?\"", + (char *)NULL); + return TCL_ERROR; + } + + master = Tk_NameToWindow(interp, argv[2], tkwin); + if (master == NULL) { + return TCL_ERROR; + } + + if (Tcl_SplitList(interp, argv[3], &argcPtr, &argvPtr) != TCL_OK) { + return TCL_ERROR; + } + + checkOnly = ((argc == 4) || (argc == 5)); + masterPtr = GetGrid(master); + slotType = (c == 'c') ? COLUMN : ROW; + if (checkOnly && argcPtr > 1) { + Tcl_AppendResult(interp, argv[3], + " must be a single element.", (char *) NULL); + Tcl_Free((char *)argvPtr); + return TCL_ERROR; + } + for (indexP=argvPtr; *indexP != NULL; indexP++) { + if (Tcl_GetInt(interp, *indexP, &slot) != TCL_OK) { + Tcl_Free((char *)argvPtr); + return TCL_ERROR; + } + ok = CheckSlotData(masterPtr, slot, slotType, checkOnly); + if ((ok!=TCL_OK) && ((argc<4) || (argc>5))) { + Tcl_AppendResult(interp, argv[0], + " ", argv[1], ": \"", *argvPtr,"\" is out of range", + (char *) NULL); + Tcl_Free((char *)argvPtr); + return TCL_ERROR; + } else if (ok == TCL_OK) { + slotPtr = (slotType == COLUMN) ? + masterPtr->masterDataPtr->columnPtr : + masterPtr->masterDataPtr->rowPtr; + } + + /* + * Return all of the options for this row or column. If the + * request is out of range, return all 0's. + */ + + if (argc == 4) { + Tcl_Free((char *)argvPtr); + } + if ((argc == 4) && (ok == TCL_OK)) { + sprintf(interp->result,"-minsize %d -pad %d -weight %d", + slotPtr[slot].minSize,slotPtr[slot].pad, + slotPtr[slot].weight); + return (TCL_OK); + } else if (argc == 4) { + sprintf(interp->result,"-minsize %d -pad %d -weight %d", 0,0,0); + return (TCL_OK); + } + + /* + * Loop through each option value pair, setting the values as required. + * If only one option is given, with no value, the current value is + * returned. + */ + + for (i=4; iresult,"%d",value); + } else if (Tk_GetPixels(interp, master, argv[i+1], &size) + != TCL_OK) { + Tcl_Free((char *)argvPtr); + return TCL_ERROR; + } else { + slotPtr[slot].minSize = size; + } + } + 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); + } else if (Tcl_GetInt(interp, argv[i+1], &wt) != TCL_OK) { + Tcl_Free((char *)argvPtr); + return TCL_ERROR; + } else if (wt < 0) { + Tcl_AppendResult(interp, "invalid arg \"", argv[i], + "\": should be non-negative", (char *) NULL); + Tcl_Free((char *)argvPtr); + return TCL_ERROR; + } else { + slotPtr[slot].weight = wt; + } + } + 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); + } else if (Tk_GetPixels(interp, master, argv[i+1], &size) + != TCL_OK) { + Tcl_Free((char *)argvPtr); + return TCL_ERROR; + } else if (size < 0) { + Tcl_AppendResult(interp, "invalid arg \"", argv[i], + "\": should be non-negative", (char *) NULL); + Tcl_Free((char *)argvPtr); + return TCL_ERROR; + } else { + slotPtr[slot].pad = size; + } + } else { + Tcl_AppendResult(interp, "invalid arg \"", + argv[i], "\": expecting -minsize, -pad, or -weight.", + (char *) NULL); + Tcl_Free((char *)argvPtr); + return TCL_ERROR; + } + } + } + Tcl_Free((char *)argvPtr); + + /* + * If we changed a property, re-arrange the table, + * and check for constraint shrinkage. + */ + + if (argc != 5) { + if (slotType == ROW) { + int last = masterPtr->masterDataPtr->rowMax - 1; + while ((last >= 0) && (slotPtr[last].weight == 0) + && (slotPtr[last].pad == 0) + && (slotPtr[last].minSize == 0)) { + last--; + } + masterPtr->masterDataPtr->rowMax = last+1; + } else { + int last = masterPtr->masterDataPtr->columnMax - 1; + while ((last >= 0) && (slotPtr[last].weight == 0) + && (slotPtr[last].pad == 0) + && (slotPtr[last].minSize == 0)) { + last--; + } + masterPtr->masterDataPtr->columnMax = last + 1; + } + + if (masterPtr->abortPtr != NULL) { + *masterPtr->abortPtr = 1; + } + if (!(masterPtr->flags & REQUESTED_RELAYOUT)) { + masterPtr->flags |= REQUESTED_RELAYOUT; + Tcl_DoWhenIdle(ArrangeGrid, (ClientData) masterPtr); + } + } + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be bbox, columnconfigure, configure, forget, info, ", + "location, propagate, remove, rowconfigure, size, or slaves.", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * GridReqProc -- + * + * This procedure is invoked by Tk_GeometryRequest for + * windows managed by the grid. + * + * Results: + * None. + * + * Side effects: + * Arranges for tkwin, and all its managed siblings, to + * be re-arranged at the next idle point. + * + *-------------------------------------------------------------- + */ + +static void +GridReqProc(clientData, tkwin) + ClientData clientData; /* Grid's information about + * window that got new preferred + * geometry. */ + Tk_Window tkwin; /* Other Tk-related information + * about the window. */ +{ + register Gridder *gridPtr = (Gridder *) clientData; + + gridPtr = gridPtr->masterPtr; + if (!(gridPtr->flags & REQUESTED_RELAYOUT)) { + gridPtr->flags |= REQUESTED_RELAYOUT; + Tcl_DoWhenIdle(ArrangeGrid, (ClientData) gridPtr); + } +} + +/* + *-------------------------------------------------------------- + * + * GridLostSlaveProc -- + * + * This procedure is invoked by Tk whenever some other geometry + * claims control over a slave that used to be managed by us. + * + * Results: + * None. + * + * Side effects: + * Forgets all grid-related information about the slave. + * + *-------------------------------------------------------------- + */ + +static void +GridLostSlaveProc(clientData, tkwin) + ClientData clientData; /* Grid structure for slave window that + * was stolen away. */ + Tk_Window tkwin; /* Tk's handle for the slave window. */ +{ + register Gridder *slavePtr = (Gridder *) clientData; + + if (slavePtr->masterPtr->tkwin != Tk_Parent(slavePtr->tkwin)) { + Tk_UnmaintainGeometry(slavePtr->tkwin, slavePtr->masterPtr->tkwin); + } + Unlink(slavePtr); + Tk_UnmapWindow(slavePtr->tkwin); +} + +/* + *-------------------------------------------------------------- + * + * AdjustOffsets -- + * + * This procedure adjusts the size of the layout to fit in the + * space provided. If it needs more space, the extra is added + * according to the weights. If it needs less, the space is removed + * according to the weights, but at no time does the size drop below + * the minsize specified for that slot. + * + * Results: + * The initial offset of the layout, + * if all the weights are zero, else 0. + * + * Side effects: + * The slot offsets are modified to shrink the layout. + * + *-------------------------------------------------------------- + */ + +static int +AdjustOffsets(size, slots, slotPtr) + int size; /* The total layout size (in pixels). */ + int slots; /* Number of slots. */ + register SlotInfo *slotPtr; /* Pointer to slot array. */ +{ + register int slot; /* Current slot. */ + int diff; /* Extra pixels needed to add to the layout. */ + int totalWeight = 0; /* Sum of the weights for all the slots. */ + int weight = 0; /* Sum of the weights so far. */ + int minSize = 0; /* Minimum possible layout size. */ + int newDiff; /* The most pixels that can be added on + * the current pass. */ + + diff = size - slotPtr[slots-1].offset; + + /* + * The layout is already the correct size; all done. + */ + + if (diff == 0) { + return(0); + } + + /* + * If all the weights are zero, center the layout in its parent if + * there is extra space, else clip on the bottom/right. + */ + + for (slot=0; slot < slots; slot++) { + totalWeight += slotPtr[slot].weight; + } + + if (totalWeight == 0 ) { + return(diff > 0 ? diff/2 : 0); + } + + /* + * Add extra space according to the slot weights. This is done + * cumulatively to prevent round-off error accumulation. + */ + + if (diff > 0) { + for (weight=slot=0; slot < slots; slot++) { + weight += slotPtr[slot].weight; + slotPtr[slot].offset += diff * weight / totalWeight; + } + return(0); + } + + /* + * The layout must shrink below its requested size. Compute the + * minimum possible size by looking at the slot minSizes. + */ + + for (slot=0; slot < slots; slot++) { + if (slotPtr[slot].weight > 0) { + minSize += slotPtr[slot].minSize; + } else if (slot > 0) { + minSize += slotPtr[slot].offset - slotPtr[slot-1].offset; + } else { + minSize += slotPtr[slot].offset; + } + } + + /* + * If the requested size is less than the minimum required size, + * set the slot sizes to their minimum values, then clip on the + * bottom/right. + */ + + if (size <= minSize) { + int offset = 0; + for (slot=0; slot < slots; slot++) { + if (slotPtr[slot].weight > 0) { + offset += slotPtr[slot].minSize; + } else if (slot > 0) { + offset += slotPtr[slot].offset - slotPtr[slot-1].offset; + } else { + offset += slotPtr[slot].offset; + } + slotPtr[slot].offset = offset; + } + return(0); + } + + /* + * Remove space from slots according to their weights. The weights + * get renormalized anytime a slot shrinks to its minimum size. + */ + + while (diff < 0) { + + /* + * Find the total weight for the shrinkable slots. + */ + + for (totalWeight=slot=0; slot < slots; slot++) { + int current = (slot == 0) ? slotPtr[slot].offset : + slotPtr[slot].offset - slotPtr[slot-1].offset; + if (current > slotPtr[slot].minSize) { + totalWeight += slotPtr[slot].weight; + slotPtr[slot].temp = slotPtr[slot].weight; + } else { + slotPtr[slot].temp = 0; + } + } + if (totalWeight == 0) { + break; + } + + /* + * Find the maximum amount of space we can distribute this pass. + */ + + newDiff = diff; + for (slot = 0; slot < slots; slot++) { + int current; /* current size of this slot */ + int maxDiff; /* max diff that would cause + * this slot to equal its minsize */ + if (slotPtr[slot].temp == 0) { + continue; + } + current = (slot == 0) ? slotPtr[slot].offset : + slotPtr[slot].offset - slotPtr[slot-1].offset; + maxDiff = totalWeight * (slotPtr[slot].minSize - current) + / slotPtr[slot].temp; + if (maxDiff > newDiff) { + newDiff = maxDiff; + } + } + + /* + * Now distribute the space. + */ + + for (weight=slot=0; slot < slots; slot++) { + weight += slotPtr[slot].temp; + slotPtr[slot].offset += newDiff * weight / totalWeight; + } + diff -= newDiff; + } + return(0); +} + +/* + *-------------------------------------------------------------- + * + * AdjustForSticky -- + * + * This procedure adjusts the size of a slave in its cavity based + * on its "sticky" flags. + * + * Results: + * The input x, y, width, and height are changed to represent the + * desired coordinates of the slave. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static void +AdjustForSticky(slavePtr, xPtr, yPtr, widthPtr, heightPtr) + Gridder *slavePtr; /* Slave window to arrange in its cavity. */ + int *xPtr; /* Pixel location of the left edge of the cavity. */ + int *yPtr; /* Pixel location of the top edge of the cavity. */ + int *widthPtr; /* Width of the cavity (in pixels). */ + int *heightPtr; /* Height of the cavity (in pixels). */ +{ + int diffx=0; /* Cavity width - slave width. */ + int diffy=0; /* Cavity hight - slave height. */ + int sticky = slavePtr->sticky; + + *xPtr += slavePtr->padX/2; + *widthPtr -= slavePtr->padX; + *yPtr += slavePtr->padY/2; + *heightPtr -= slavePtr->padY; + + if (*widthPtr > (Tk_ReqWidth(slavePtr->tkwin) + slavePtr->iPadX)) { + diffx = *widthPtr - (Tk_ReqWidth(slavePtr->tkwin) + slavePtr->iPadX); + *widthPtr = Tk_ReqWidth(slavePtr->tkwin) + slavePtr->iPadX; + } + + if (*heightPtr > (Tk_ReqHeight(slavePtr->tkwin) + slavePtr->iPadY)) { + diffy = *heightPtr - (Tk_ReqHeight(slavePtr->tkwin) + slavePtr->iPadY); + *heightPtr = Tk_ReqHeight(slavePtr->tkwin) + slavePtr->iPadY; + } + + if (sticky&STICK_EAST && sticky&STICK_WEST) { + *widthPtr += diffx; + } + if (sticky&STICK_NORTH && sticky&STICK_SOUTH) { + *heightPtr += diffy; + } + if (!(sticky&STICK_WEST)) { + *xPtr += (sticky&STICK_EAST) ? diffx : diffx/2; + } + if (!(sticky&STICK_NORTH)) { + *yPtr += (sticky&STICK_SOUTH) ? diffy : diffy/2; + } +} + +/* + *-------------------------------------------------------------- + * + * ArrangeGrid -- + * + * This procedure is invoked (using the Tcl_DoWhenIdle + * mechanism) to re-layout a set of windows managed by + * the grid. It is invoked at idle time so that a + * series of grid requests can be merged into a single + * layout operation. + * + * Results: + * None. + * + * Side effects: + * The slaves of masterPtr may get resized or moved. + * + *-------------------------------------------------------------- + */ + +static void +ArrangeGrid(clientData) + ClientData clientData; /* Structure describing parent whose slaves + * are to be re-layed out. */ +{ + register Gridder *masterPtr = (Gridder *) clientData; + register Gridder *slavePtr; + GridMaster *slotPtr = masterPtr->masterDataPtr; + int abort; + int width, height; /* requested size of layout, in pixels */ + int realWidth, realHeight; /* actual size layout should take-up */ + + masterPtr->flags &= ~REQUESTED_RELAYOUT; + + /* + * If the parent has no slaves anymore, then don't do anything + * at all: just leave the parent's size as-is. Otherwise there is + * no way to "relinquish" control over the parent so another geometry + * manager can take over. + */ + + if (masterPtr->slavePtr == NULL) { + return; + } + + if (masterPtr->masterDataPtr == NULL) { + return; + } + + /* + * Abort any nested call to ArrangeGrid for this window, since + * we'll do everything necessary here, and set up so this call + * can be aborted if necessary. + */ + + if (masterPtr->abortPtr != NULL) { + *masterPtr->abortPtr = 1; + } + masterPtr->abortPtr = &abort; + abort = 0; + Tcl_Preserve((ClientData) masterPtr); + + /* + * Call the constraint engine to fill in the row and column offsets. + */ + + SetGridSize(masterPtr); + width = ResolveConstraints(masterPtr, COLUMN, 0); + height = ResolveConstraints(masterPtr, ROW, 0); + width += 2*Tk_InternalBorderWidth(masterPtr->tkwin); + height += 2*Tk_InternalBorderWidth(masterPtr->tkwin); + + if (((width != Tk_ReqWidth(masterPtr->tkwin)) + || (height != Tk_ReqHeight(masterPtr->tkwin))) + && !(masterPtr->flags & DONT_PROPAGATE)) { + Tk_GeometryRequest(masterPtr->tkwin, width, height); + if (width>1 && height>1) { + masterPtr->flags |= REQUESTED_RELAYOUT; + Tcl_DoWhenIdle(ArrangeGrid, (ClientData) masterPtr); + } + masterPtr->abortPtr = NULL; + Tcl_Release((ClientData) masterPtr); + return; + } + + /* + * If the currently requested layout size doesn't match the parent's + * window size, then adjust the slot offsets according to the + * weights. If all of the weights are zero, center the layout in + * its parent. I haven't decided what to do if the parent is smaller + * than the requested size. + */ + + realWidth = Tk_Width(masterPtr->tkwin) - + 2*Tk_InternalBorderWidth(masterPtr->tkwin); + realHeight = Tk_Height(masterPtr->tkwin) - + 2*Tk_InternalBorderWidth(masterPtr->tkwin); + slotPtr->startX = AdjustOffsets(realWidth, + MAX(slotPtr->columnEnd,slotPtr->columnMax), slotPtr->columnPtr); + slotPtr->startY = AdjustOffsets(realHeight, + MAX(slotPtr->rowEnd,slotPtr->rowMax), slotPtr->rowPtr); + slotPtr->startX += Tk_InternalBorderWidth(masterPtr->tkwin); + slotPtr->startY += Tk_InternalBorderWidth(masterPtr->tkwin); + + /* + * Now adjust the actual size of the slave to its cavity by + * computing the cavity size, and adjusting the widget according + * to its stickyness. + */ + + for (slavePtr = masterPtr->slavePtr; slavePtr != NULL && !abort; + slavePtr = slavePtr->nextPtr) { + int x, y; /* top left coordinate */ + int width, height; /* slot or slave size */ + int col = slavePtr->column; + int row = slavePtr->row; + + x = (col>0) ? slotPtr->columnPtr[col-1].offset : 0; + y = (row>0) ? slotPtr->rowPtr[row-1].offset : 0; + + width = slotPtr->columnPtr[slavePtr->numCols+col-1].offset - x; + height = slotPtr->rowPtr[slavePtr->numRows+row-1].offset - y; + + x += slotPtr->startX; + y += slotPtr->startY; + + AdjustForSticky(slavePtr, &x, &y, &width, &height); + + /* + * Now put the window in the proper spot. (This was taken directly + * from tkPack.c.) If the slave is a child of the master, then + * do this here. Otherwise let Tk_MaintainGeometry do the work. + */ + + if (masterPtr->tkwin == Tk_Parent(slavePtr->tkwin)) { + if ((width <= 0) || (height <= 0)) { + Tk_UnmapWindow(slavePtr->tkwin); + } else { + if ((x != Tk_X(slavePtr->tkwin)) + || (y != Tk_Y(slavePtr->tkwin)) + || (width != Tk_Width(slavePtr->tkwin)) + || (height != Tk_Height(slavePtr->tkwin))) { + Tk_MoveResizeWindow(slavePtr->tkwin, x, y, width, height); + } + if (abort) { + break; + } + + /* + * Don't map the slave if the master isn't mapped: wait + * until the master gets mapped later. + */ + + if (Tk_IsMapped(masterPtr->tkwin)) { + Tk_MapWindow(slavePtr->tkwin); + } + } + } else { + if ((width <= 0) || (height <= 0)) { + Tk_UnmaintainGeometry(slavePtr->tkwin, masterPtr->tkwin); + Tk_UnmapWindow(slavePtr->tkwin); + } else { + Tk_MaintainGeometry(slavePtr->tkwin, masterPtr->tkwin, + x, y, width, height); + } + } + } + + masterPtr->abortPtr = NULL; + Tcl_Release((ClientData) masterPtr); +} + +/* + *-------------------------------------------------------------- + * + * ResolveConstraints -- + * + * Resolve all of the column and row boundaries. Most of + * the calculations are identical for rows and columns, so this procedure + * is called twice, once for rows, and again for columns. + * + * Results: + * The offset (in pixels) from the left/top edge of this layout is + * returned. + * + * Side effects: + * The slot offsets are copied into the SlotInfo structure for the + * geometry master. + * + *-------------------------------------------------------------- + */ + +static int +ResolveConstraints(masterPtr, slotType, maxOffset) + Gridder *masterPtr; /* The geometry master for this grid. */ + int slotType; /* Either ROW or COLUMN. */ + int maxOffset; /* The actual maximum size of this layout + * in pixels, or 0 (not currently used). */ +{ + register SlotInfo *slotPtr; /* Pointer to row/col constraints. */ + register Gridder *slavePtr; /* List of slave windows in this grid. */ + int constraintCount; /* Count of rows or columns that have + * constraints. */ + int slotCount; /* Last occupied row or column. */ + int gridCount; /* The larger of slotCount and constraintCount. + */ + GridLayout *layoutPtr; /* Temporary layout structure. */ + int requiredSize; /* The natural size of the grid (pixels). + * This is the minimum size needed to + * accomodate all of the slaves at their + * requested sizes. */ + int offset; /* The pixel offset of the right edge of the + * current slot from the beginning of the + * layout. */ + int slot; /* The current slot. */ + int start; /* The first slot of a contiguous set whose + * constraints are not yet fully resolved. */ + int end; /* The Last slot of a contiguous set whose + * constraints are not yet fully resolved. */ + + /* + * For typical sized tables, we'll use stack space for the layout data + * to avoid the overhead of a malloc and free for every layout. + */ + + GridLayout layoutData[TYPICAL_SIZE + 1]; + + if (slotType == COLUMN) { + constraintCount = masterPtr->masterDataPtr->columnMax; + slotCount = masterPtr->masterDataPtr->columnEnd; + slotPtr = masterPtr->masterDataPtr->columnPtr; + } else { + constraintCount = masterPtr->masterDataPtr->rowMax; + slotCount = masterPtr->masterDataPtr->rowEnd; + slotPtr = masterPtr->masterDataPtr->rowPtr; + } + + /* + * Make sure there is enough memory for the layout. + */ + + gridCount = MAX(constraintCount,slotCount); + if (gridCount >= TYPICAL_SIZE) { + layoutPtr = (GridLayout *) Tcl_Alloc(sizeof(GridLayout) * (1+gridCount)); + } else { + layoutPtr = layoutData; + } + + /* + * Allocate an extra layout slot to represent the left/top edge of + * the 0th slot to make it easier to calculate slot widths from + * offsets without special case code. + * Initialize the "dummy" slot to the left/top of the table. + * This slot avoids special casing the first slot. + */ + + layoutPtr->minOffset = 0; + layoutPtr->maxOffset = 0; + layoutPtr++; + + /* + * Step 1. + * Copy the slot constraints into the layout structure, + * and initialize the rest of the fields. + */ + + for (slot=0; slot < constraintCount; slot++) { + layoutPtr[slot].minSize = slotPtr[slot].minSize; + layoutPtr[slot].weight = slotPtr[slot].weight; + layoutPtr[slot].pad = slotPtr[slot].pad; + layoutPtr[slot].binNextPtr = NULL; + } + for(;slot 1 by their right edges. This + * allows the computation on minimum and maximum possible layout + * sizes at each slot boundary, without the need to re-sort the slaves. + */ + + switch (slotType) { + case COLUMN: + for (slavePtr = masterPtr->slavePtr; slavePtr != NULL; + slavePtr = slavePtr->nextPtr) { + int rightEdge = slavePtr->column + slavePtr->numCols - 1; + slavePtr->size = Tk_ReqWidth(slavePtr->tkwin) + + slavePtr->padX + slavePtr->iPadX + slavePtr->doubleBw; + if (slavePtr->numCols > 1) { + slavePtr->binNextPtr = layoutPtr[rightEdge].binNextPtr; + layoutPtr[rightEdge].binNextPtr = slavePtr; + } else { + int size = slavePtr->size + layoutPtr[rightEdge].pad; + if (size > layoutPtr[rightEdge].minSize) { + layoutPtr[rightEdge].minSize = size; + } + } + } + break; + case ROW: + for (slavePtr = masterPtr->slavePtr; slavePtr != NULL; + slavePtr = slavePtr->nextPtr) { + int rightEdge = slavePtr->row + slavePtr->numRows - 1; + slavePtr->size = Tk_ReqHeight(slavePtr->tkwin) + + slavePtr->padY + slavePtr->iPadY + slavePtr->doubleBw; + if (slavePtr->numRows > 1) { + slavePtr->binNextPtr = layoutPtr[rightEdge].binNextPtr; + layoutPtr[rightEdge].binNextPtr = slavePtr; + } else { + int size = slavePtr->size + layoutPtr[rightEdge].pad; + if (size > layoutPtr[rightEdge].minSize) { + layoutPtr[rightEdge].minSize = size; + } + } + } + break; + } + + /* + * Step 3. + * Determine the minimum slot offsets going from left to right + * that would fit all of the slaves. This determines the minimum + */ + + for (offset=slot=0; slot < gridCount; slot++) { + layoutPtr[slot].minOffset = layoutPtr[slot].minSize + offset; + for (slavePtr = layoutPtr[slot].binNextPtr; slavePtr != NULL; + slavePtr = slavePtr->binNextPtr) { + int span = (slotType == COLUMN) ? slavePtr->numCols : slavePtr->numRows; + int required = slavePtr->size + layoutPtr[slot - span].minOffset; + if (required > layoutPtr[slot].minOffset) { + layoutPtr[slot].minOffset = required; + } + } + offset = layoutPtr[slot].minOffset; + } + + /* + * At this point, we know the minimum required size of the entire layout. + * It might be prudent to stop here if our "master" will resize itself + * to this size. + */ + + requiredSize = offset; + if (maxOffset > offset) { + offset=maxOffset; + } + + /* + * Step 4. + * Determine the minimum slot offsets going from right to left, + * bounding the pixel range of each slot boundary. + * Pre-fill all of the right offsets with the actual size of the table; + * they will be reduced as required. + */ + + for (slot=0; slot < gridCount; slot++) { + layoutPtr[slot].maxOffset = offset; + } + for (slot=gridCount-1; slot > 0;) { + for (slavePtr = layoutPtr[slot].binNextPtr; slavePtr != NULL; + slavePtr = slavePtr->binNextPtr) { + int span = (slotType == COLUMN) ? slavePtr->numCols : slavePtr->numRows; + int require = offset - slavePtr->size; + int startSlot = slot - span; + if (startSlot >=0 && require < layoutPtr[startSlot].maxOffset) { + layoutPtr[startSlot].maxOffset = require; + } + } + offset -= layoutPtr[slot].minSize; + slot--; + if (layoutPtr[slot].maxOffset < offset) { + offset = layoutPtr[slot].maxOffset; + } else { + layoutPtr[slot].maxOffset = offset; + } + } + + /* + * Step 5. + * At this point, each slot boundary has a range of values that + * will satisfy the overall layout size. + * Make repeated passes over the layout structure looking for + * spans of slot boundaries where the minOffsets are less than + * the maxOffsets, and adjust the offsets according to the slot + * weights. At each pass, at least one slot boundary will have + * its range of possible values fixed at a single value. + */ + + for (start=0; start < gridCount;) { + int totalWeight = 0; /* Sum of the weights for all of the + * slots in this span. */ + int need = 0; /* The minimum space needed to layout + * this span. */ + int have; /* The actual amount of space that will + * be taken up by this span. */ + int weight; /* Cumulative weights of the columns in + * this span. */ + int noWeights = 0; /* True if the span has no weights. */ + + /* + * Find a span by identifying ranges of slots whose edges are + * already constrained at fixed offsets, but whose internal + * slot boundaries have a range of possible positions. + */ + + if (layoutPtr[start].minOffset == layoutPtr[start].maxOffset) { + start++; + continue; + } + + for (end=start+1; end0) && + (diff*totalWeight/weight) < (have-need)) { + have = diff * totalWeight / weight + need; + } + } + + /* + * Now distribute the extra space among the slots by + * adjusting the minSizes and minOffsets. + */ + + for (weight=0,slot=start; slot start; slot--) { + layoutPtr[slot-1].maxOffset = + layoutPtr[slot].maxOffset-layoutPtr[slot].minSize; + } + } + + + /* + * Step 6. + * All of the space has been apportioned; copy the + * layout information back into the master. + */ + + for (slot=0; slot < gridCount; slot++) { + slotPtr[slot].offset = layoutPtr[slot].minOffset; + } + + --layoutPtr; + if (layoutPtr != layoutData) { + Tcl_Free((char *)layoutPtr); + } + return requiredSize; +} + +/* + *-------------------------------------------------------------- + * + * GetGrid -- + * + * This internal procedure is used to locate a Grid + * structure for a given window, creating one if one + * doesn't exist already. + * + * Results: + * The return value is a pointer to the Grid structure + * corresponding to tkwin. + * + * Side effects: + * A new grid structure may be created. If so, then + * a callback is set up to clean things up when the + * window is deleted. + * + *-------------------------------------------------------------- + */ + +static Gridder * +GetGrid(tkwin) + Tk_Window tkwin; /* Token for window for which + * grid structure is desired. */ +{ + register Gridder *gridPtr; + Tcl_HashEntry *hPtr; + int new; + + if (!initialized) { + initialized = 1; + Tcl_InitHashTable(&gridHashTable, TCL_ONE_WORD_KEYS); + } + + /* + * See if there's already grid for this window. If not, + * then create a new one. + */ + + hPtr = Tcl_CreateHashEntry(&gridHashTable, (char *) tkwin, &new); + if (!new) { + return (Gridder *) Tcl_GetHashValue(hPtr); + } + gridPtr = (Gridder *) Tcl_Alloc(sizeof(Gridder)); + gridPtr->tkwin = tkwin; + gridPtr->masterPtr = NULL; + gridPtr->masterDataPtr = NULL; + gridPtr->nextPtr = NULL; + gridPtr->slavePtr = NULL; + gridPtr->binNextPtr = NULL; + + gridPtr->column = gridPtr->row = -1; + gridPtr->numCols = 1; + gridPtr->numRows = 1; + + gridPtr->padX = gridPtr->padY = 0; + gridPtr->iPadX = gridPtr->iPadY = 0; + gridPtr->doubleBw = 2*Tk_Changes(tkwin)->border_width; + gridPtr->abortPtr = NULL; + gridPtr->flags = 0; + gridPtr->sticky = 0; + gridPtr->size = 0; + gridPtr->masterDataPtr = NULL; + Tcl_SetHashValue(hPtr, gridPtr); + Tk_CreateEventHandler(tkwin, StructureNotifyMask, + GridStructureProc, (ClientData) gridPtr); + return gridPtr; +} + +/* + *-------------------------------------------------------------- + * + * SetGridSize -- + * + * This internal procedure sets the size of the grid occupied + * by slaves. + * + * Results: + * none + * + * Side effects: + * The width and height arguments are filled in the master data structure. + * Additional space is allocated for the constraints to accomodate + * the offsets. + * + *-------------------------------------------------------------- + */ + +static void +SetGridSize(masterPtr) + Gridder *masterPtr; /* The geometry master for this grid. */ +{ + register Gridder *slavePtr; /* Current slave window. */ + int maxX = 0, maxY = 0; + + for (slavePtr = masterPtr->slavePtr; slavePtr != NULL; + slavePtr = slavePtr->nextPtr) { + maxX = MAX(maxX,slavePtr->numCols + slavePtr->column); + maxY = MAX(maxY,slavePtr->numRows + slavePtr->row); + } + masterPtr->masterDataPtr->columnEnd = maxX; + masterPtr->masterDataPtr->rowEnd = maxY; + CheckSlotData(masterPtr, maxX, COLUMN, CHECK_SPACE); + CheckSlotData(masterPtr, maxY, ROW, CHECK_SPACE); +} + +/* + *-------------------------------------------------------------- + * + * CheckSlotData -- + * + * This internal procedure is used to manage the storage for + * row and column (slot) constraints. + * + * Results: + * TRUE if the index is OK, False otherwise. + * + * Side effects: + * A new master grid structure may be created. If so, then + * it is initialized. In addition, additional storage for + * a row or column constraints may be allocated, and the constraint + * maximums are adjusted. + * + *-------------------------------------------------------------- + */ + +static int +CheckSlotData(masterPtr, slot, slotType, checkOnly) + Gridder *masterPtr; /* the geometry master for this grid */ + int slot; /* which slot to look at */ + int slotType; /* ROW or COLUMN */ + int checkOnly; /* don't allocate new space if true */ +{ + int numSlot; /* number of slots already allocated (Space) */ + int end; /* last used constraint */ + + /* + * If slot is out of bounds, return immediately. + */ + + if (slot < 0 || slot >= MAX_ELEMENT) { + return TCL_ERROR; + } + + if ((checkOnly == CHECK_ONLY) && (masterPtr->masterDataPtr == NULL)) { + return TCL_ERROR; + } + + /* + * If we need to allocate more space, allocate a little extra to avoid + * repeated re-alloc's for large tables. We need enough space to + * hold all of the offsets as well. + */ + + InitMasterData(masterPtr); + end = (slotType == ROW) ? masterPtr->masterDataPtr->rowMax : + masterPtr->masterDataPtr->columnMax; + if (checkOnly == CHECK_ONLY) { + return (end < slot) ? TCL_ERROR : TCL_OK; + } else { + numSlot = (slotType == ROW) ? masterPtr->masterDataPtr->rowSpace + : masterPtr->masterDataPtr->columnSpace; + if (slot >= numSlot) { + int newNumSlot = slot + PREALLOC ; + size_t oldSize = numSlot * sizeof(SlotInfo) ; + size_t newSize = newNumSlot * sizeof(SlotInfo) ; + SlotInfo *new = (SlotInfo *) Tcl_Alloc(newSize); + SlotInfo *old = (slotType == ROW) ? + masterPtr->masterDataPtr->rowPtr : + masterPtr->masterDataPtr->columnPtr; + memcpy((VOID *) new, (VOID *) old, oldSize ); + memset((VOID *) (new+numSlot), 0, newSize - oldSize ); + Tcl_Free((char *) old); + if (slotType == ROW) { + masterPtr->masterDataPtr->rowPtr = new ; + masterPtr->masterDataPtr->rowSpace = newNumSlot ; + } else { + masterPtr->masterDataPtr->columnPtr = new; + masterPtr->masterDataPtr->columnSpace = newNumSlot ; + } + } + if (slot >= end && checkOnly != CHECK_SPACE) { + if (slotType == ROW) { + masterPtr->masterDataPtr->rowMax = slot+1; + } else { + masterPtr->masterDataPtr->columnMax = slot+1; + } + } + return TCL_OK; + } +} + +/* + *-------------------------------------------------------------- + * + * InitMasterData -- + * + * This internal procedure is used to allocate and initialize + * the data for a geometry master, if the data + * doesn't exist already. + * + * Results: + * none + * + * Side effects: + * A new master grid structure may be created. If so, then + * it is initialized. + * + *-------------------------------------------------------------- + */ + +static void +InitMasterData(masterPtr) + Gridder *masterPtr; +{ + size_t size; + if (masterPtr->masterDataPtr == NULL) { + GridMaster *gridPtr = masterPtr->masterDataPtr = + (GridMaster *) Tcl_Alloc(sizeof(GridMaster)); + size = sizeof(SlotInfo) * TYPICAL_SIZE; + + gridPtr->columnEnd = 0; + gridPtr->columnMax = 0; + gridPtr->columnPtr = (SlotInfo *) Tcl_Alloc(size); + gridPtr->columnSpace = 0; + gridPtr->columnSpace = TYPICAL_SIZE; + gridPtr->rowEnd = 0; + gridPtr->rowMax = 0; + gridPtr->rowPtr = (SlotInfo *) Tcl_Alloc(size); + gridPtr->rowSpace = 0; + gridPtr->rowSpace = TYPICAL_SIZE; + + memset((VOID *) gridPtr->columnPtr, 0, size); + memset((VOID *) gridPtr->rowPtr, 0, size); + } +} + +/* + *---------------------------------------------------------------------- + * + * Unlink -- + * + * Remove a grid from its parent's list of slaves. + * + * Results: + * None. + * + * Side effects: + * The parent will be scheduled for re-arranging, and the size of the + * grid will be adjusted accordingly + * + *---------------------------------------------------------------------- + */ + +static void +Unlink(slavePtr) + register Gridder *slavePtr; /* Window to unlink. */ +{ + register Gridder *masterPtr, *slavePtr2; + GridMaster *gridPtr; /* pointer to grid data */ + + masterPtr = slavePtr->masterPtr; + if (masterPtr == NULL) { + return; + } + + gridPtr = masterPtr->masterDataPtr; + if (masterPtr->slavePtr == slavePtr) { + masterPtr->slavePtr = slavePtr->nextPtr; + } + else { + for (slavePtr2 = masterPtr->slavePtr; ; slavePtr2 = slavePtr2->nextPtr) { + if (slavePtr2 == NULL) { + panic("Unlink couldn't find previous window"); + } + if (slavePtr2->nextPtr == slavePtr) { + slavePtr2->nextPtr = slavePtr->nextPtr; + break; + } + } + } + if (!(masterPtr->flags & REQUESTED_RELAYOUT)) { + masterPtr->flags |= REQUESTED_RELAYOUT; + Tcl_DoWhenIdle(ArrangeGrid, (ClientData) masterPtr); + } + if (masterPtr->abortPtr != NULL) { + *masterPtr->abortPtr = 1; + } + + if ((slavePtr->numCols+slavePtr->column == gridPtr->columnMax) + || (slavePtr->numRows+slavePtr->row == gridPtr->rowMax)) { + } + slavePtr->masterPtr = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * DestroyGrid -- + * + * This procedure is invoked by Tk_EventuallyFree or Tcl_Release + * to clean up the internal structure of a grid at a safe time + * (when no-one is using it anymore). Cleaning up the grid involves + * freeing the main structure for all windows. and the master structure + * for geometry managers. + * + * Results: + * None. + * + * Side effects: + * Everything associated with the grid is freed up. + * + *---------------------------------------------------------------------- + */ + +static void +DestroyGrid(memPtr) + char *memPtr; /* Info about window that is now dead. */ +{ + register Gridder *gridPtr = (Gridder *) memPtr; + + if (gridPtr->masterDataPtr != NULL) { + if (gridPtr->masterDataPtr->rowPtr != NULL) { + Tcl_Free((char *) gridPtr->masterDataPtr -> rowPtr); + } + if (gridPtr->masterDataPtr->columnPtr != NULL) { + Tcl_Free((char *) gridPtr->masterDataPtr -> columnPtr); + } + Tcl_Free((char *) gridPtr->masterDataPtr); + } + Tcl_Free((char *) gridPtr); +} + +/* + *---------------------------------------------------------------------- + * + * GridStructureProc -- + * + * This procedure is invoked by the Tk event dispatcher in response + * to StructureNotify events. + * + * Results: + * None. + * + * Side effects: + * If a window was just deleted, clean up all its grid-related + * information. If it was just resized, re-configure its slaves, if + * any. + * + *---------------------------------------------------------------------- + */ + +static void +GridStructureProc(clientData, eventPtr) + ClientData clientData; /* Our information about window + * referred to by eventPtr. */ + XEvent *eventPtr; /* Describes what just happened. */ +{ + register Gridder *gridPtr = (Gridder *) clientData; + + if (eventPtr->type == ConfigureNotify) { + if (!(gridPtr->flags & REQUESTED_RELAYOUT)) { + gridPtr->flags |= REQUESTED_RELAYOUT; + Tcl_DoWhenIdle(ArrangeGrid, (ClientData) gridPtr); + } + if (gridPtr->doubleBw != 2*Tk_Changes(gridPtr->tkwin)->border_width) { + if ((gridPtr->masterPtr != NULL) && + !(gridPtr->masterPtr->flags & REQUESTED_RELAYOUT)) { + gridPtr->doubleBw = 2*Tk_Changes(gridPtr->tkwin)->border_width; + gridPtr->masterPtr->flags |= REQUESTED_RELAYOUT; + Tcl_DoWhenIdle(ArrangeGrid, (ClientData) gridPtr->masterPtr); + } + } + } else if (eventPtr->type == DestroyNotify) { + register Gridder *gridPtr2, *nextPtr; + + if (gridPtr->masterPtr != NULL) { + Unlink(gridPtr); + } + for (gridPtr2 = gridPtr->slavePtr; gridPtr2 != NULL; + gridPtr2 = nextPtr) { + Tk_UnmapWindow(gridPtr2->tkwin); + gridPtr2->masterPtr = NULL; + nextPtr = gridPtr2->nextPtr; + gridPtr2->nextPtr = NULL; + } + Tcl_DeleteHashEntry(Tcl_FindHashEntry(&gridHashTable, + (char *) gridPtr->tkwin)); + if (gridPtr->flags & REQUESTED_RELAYOUT) { + Tk_CancelIdleCall(ArrangeGrid, (ClientData) gridPtr); + } + gridPtr->tkwin = NULL; + Tk_EventuallyFree((ClientData) gridPtr, DestroyGrid); + } else if (eventPtr->type == MapNotify) { + if (!(gridPtr->flags & REQUESTED_RELAYOUT)) { + gridPtr->flags |= REQUESTED_RELAYOUT; + Tcl_DoWhenIdle(ArrangeGrid, (ClientData) gridPtr); + } + } else if (eventPtr->type == UnmapNotify) { + register Gridder *gridPtr2; + + for (gridPtr2 = gridPtr->slavePtr; gridPtr2 != NULL; + gridPtr2 = gridPtr2->nextPtr) { + Tk_UnmapWindow(gridPtr2->tkwin); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * ConfigureSlaves -- + * + * This implements the guts of the "grid configure" command. Given + * a list of slaves and configuration options, it arranges for the + * grid to manage the slaves and sets the specified options. + * arguments consist of windows or window shortcuts followed by + * "-option value" pairs. + * + * Results: + * TCL_OK is returned if all went well. Otherwise, TCL_ERROR is + * returned and interp->result is set to contain an error message. + * + * Side effects: + * Slave windows get taken over by the grid. + * + *---------------------------------------------------------------------- + */ + +static int +ConfigureSlaves(interp, tkwin, argc, argv) + Tcl_Interp *interp; /* Interpreter for error reporting. */ + Tk_Window tkwin; /* Any window in application containing + * slaves. Used to look up slave names. */ + int argc; /* Number of elements in argv. */ + char *argv[]; /* Argument strings: contains one or more + * window names followed by any number + * of "option value" pairs. Caller must + * make sure that there is at least one + * window name. */ +{ + Gridder *masterPtr; + Gridder *slavePtr; + Tk_Window other, slave, parent, ancestor; + int i, j, c, tmp; + size_t length; + int numWindows; + int width; + int defaultColumn = 0; /* default column number */ + int defaultColumnSpan = 1; /* default number of columns */ + char *lastWindow; /* use this window to base current + * Row/col on */ + + /* + * Count the number of windows, or window short-cuts. + */ + + for(numWindows=i=0;i 1 && firstChar == '-') { + break; + } + if (length > 1) { + Tcl_AppendResult(interp, "unexpected parameter, \"", + argv[i], "\", in configure list. ", + "Should be window name or option", (char *) NULL); + return TCL_ERROR; + } + + if ((firstChar == REL_HORIZ) && ((numWindows == 0) || + (*argv[i-1] == REL_SKIP) || (*argv[i-1] == REL_VERT))) { + Tcl_AppendResult(interp, + "Must specify window before shortcut '-'.", + (char *) NULL); + return TCL_ERROR; + } + + if ((firstChar == REL_VERT) || (firstChar == REL_SKIP) + || (firstChar == REL_HORIZ)) { + continue; + } + + Tcl_AppendResult(interp, "invalid window shortcut, \"", + argv[i], "\" should be '-', 'x', or '^'", (char *) NULL); + return TCL_ERROR; + } + numWindows = i; + + if ((argc-numWindows)&1) { + Tcl_AppendResult(interp, "extra option or", + " option with no value", (char *) NULL); + return TCL_ERROR; + } + + /* + * Iterate over all of the slave windows and short-cuts, parsing + * options for each slave. It's a bit wasteful to re-parse the + * options for each slave, but things get too messy if we try to + * parse the arguments just once at the beginning. For example, + * if a slave already is managed we want to just change a few + * existing values without resetting everything. If there are + * multiple windows, the -in option only gets processed for the + * first window. + */ + + masterPtr = NULL; + for (j = 0; j < numWindows; j++) { + char firstChar = *argv[j]; + + /* + * '^' and 'x' cause us to skip a column. '-' is processed + * as part of its preceeding slave. + */ + + if ((firstChar == REL_VERT) || (firstChar == REL_SKIP)) { + defaultColumn++; + continue; + } + if (firstChar == REL_HORIZ) { + continue; + } + + for (defaultColumnSpan=1; + j + defaultColumnSpan < numWindows && + (*argv[j+defaultColumnSpan] == REL_HORIZ); + defaultColumnSpan++) { + /* null body */ + } + + slave = Tk_NameToWindow(interp, argv[j], tkwin); + if (slave == NULL) { + return TCL_ERROR; + } + if (Tk_IsTopLevel(slave)) { + Tcl_AppendResult(interp, "can't manage \"", argv[j], + "\": it's a top-level window", (char *) NULL); + return TCL_ERROR; + } + slavePtr = GetGrid(slave); + + /* + * The following statement is taken from tkPack.c: + * + * "If the slave isn't currently managed, reset all of its + * configuration information to default values (there could + * be old values left from a previous packer)." + * + * I [D.S.] disagree with this statement. If a slave is disabled (using + * "forget") and then re-enabled, I submit that 90% of the time the + * programmer will want it to retain its old configuration information. + * If the programmer doesn't want this behavior, then the + * defaults can be reestablished by hand, without having to worry + * about keeping track of the old state. + */ + + for (i = numWindows; i < argc; i+=2) { + length = strlen(argv[i]); + c = argv[i][1]; + + if (length < 2) { + Tcl_AppendResult(interp, "unknown or ambiguous option \"", + argv[i], "\": must be ", + "-column, -columnspan, -in, -ipadx, -ipady, ", + "-padx, -pady, -row, -rowspan, or -sticky", + (char *) NULL); + return TCL_ERROR; + } + if ((c == 'c') && (strncmp(argv[i], "-column", length) == 0)) { + if (Tcl_GetInt(interp, argv[i+1], &tmp) != TCL_OK || tmp<0) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad column value \"", argv[i+1], + "\": must be a non-negative integer", (char *)NULL); + return TCL_ERROR; + } + slavePtr->column = tmp; + } else if ((c == 'c') + && (strncmp(argv[i], "-columnspan", length) == 0)) { + if (Tcl_GetInt(interp, argv[i+1], &tmp) != TCL_OK || tmp <= 0) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad columnspan value \"", argv[i+1], + "\": must be a positive integer", (char *)NULL); + return TCL_ERROR; + } + slavePtr->numCols = tmp; + } else if ((c == 'i') && (strncmp(argv[i], "-in", length) == 0)) { + other = Tk_NameToWindow(interp, argv[i+1], tkwin); + if (other == NULL) { + return TCL_ERROR; + } + if (other == slave) { + sprintf(interp->result,"Window can't be managed in itself"); + return TCL_ERROR; + } + masterPtr = GetGrid(other); + InitMasterData(masterPtr); + } else if ((c == 'i') + && (strncmp(argv[i], "-ipadx", length) == 0)) { + if ((Tk_GetPixels(interp, slave, argv[i+1], &tmp) != TCL_OK) + || (tmp < 0)) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad ipadx value \"", argv[i+1], + "\": must be positive screen distance", + (char *) NULL); + return TCL_ERROR; + } + slavePtr->iPadX = tmp*2; + } else if ((c == 'i') + && (strncmp(argv[i], "-ipady", length) == 0)) { + if ((Tk_GetPixels(interp, slave, argv[i+1], &tmp) != TCL_OK) + || (tmp< 0)) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad ipady value \"", argv[i+1], + "\": must be positive screen distance", + (char *) NULL); + return TCL_ERROR; + } + slavePtr->iPadY = tmp*2; + } else if ((c == 'p') + && (strncmp(argv[i], "-padx", length) == 0)) { + if ((Tk_GetPixels(interp, slave, argv[i+1], &tmp) != TCL_OK) + || (tmp< 0)) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad padx value \"", argv[i+1], + "\": must be positive screen distance", + (char *) NULL); + return TCL_ERROR; + } + slavePtr->padX = tmp*2; + } else if ((c == 'p') + && (strncmp(argv[i], "-pady", length) == 0)) { + if ((Tk_GetPixels(interp, slave, argv[i+1], &tmp) != TCL_OK) + || (tmp< 0)) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad pady value \"", argv[i+1], + "\": must be positive screen distance", + (char *) NULL); + return TCL_ERROR; + } + slavePtr->padY = tmp*2; + } else if ((c == 'r') && (strncmp(argv[i], "-row", length) == 0)) { + if (Tcl_GetInt(interp, argv[i+1], &tmp) != TCL_OK || tmp<0) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad grid value \"", argv[i+1], + "\": must be a non-negative integer", (char *)NULL); + return TCL_ERROR; + } + slavePtr->row = tmp; + } else if ((c == 'r') + && (strncmp(argv[i], "-rowspan", length) == 0)) { + if ((Tcl_GetInt(interp, argv[i+1], &tmp) != TCL_OK) || tmp<=0) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad rowspan value \"", argv[i+1], + "\": must be a positive integer", (char *)NULL); + return TCL_ERROR; + } + slavePtr->numRows = tmp; + } else if ((c == 's') + && strncmp(argv[i], "-sticky", length) == 0) { + int sticky = StringToSticky(argv[i+1]); + if (sticky == -1) { + Tcl_AppendResult(interp, "bad stickyness value \"", argv[i+1], + "\": must be a string containing n, e, s, and/or w", + (char *)NULL); + return TCL_ERROR; + } + slavePtr->sticky = sticky; + } else { + Tcl_AppendResult(interp, "unknown or ambiguous option \"", + argv[i], "\": must be ", + "-column, -columnspan, -in, -ipadx, -ipady, ", + "-padx, -pady, -row, -rowspan, or -sticky", + (char *) NULL); + return TCL_ERROR; + } + } + + /* + * Make sure we have a geometry master. We look at: + * 1) the -in flag + * 2) the geometry master of the first slave (if specified) + * 3) the parent of the first slave. + */ + + if (masterPtr == NULL) { + masterPtr = slavePtr->masterPtr; + } + parent = Tk_Parent(slave); + if (masterPtr == NULL) { + masterPtr = GetGrid(parent); + InitMasterData(masterPtr); + } + + if (slavePtr->masterPtr != NULL && slavePtr->masterPtr != masterPtr) { + Unlink(slavePtr); + slavePtr->masterPtr = NULL; + } + + if (slavePtr->masterPtr == NULL) { + Gridder *tempPtr = masterPtr->slavePtr; + slavePtr->masterPtr = masterPtr; + masterPtr->slavePtr = slavePtr; + slavePtr->nextPtr = tempPtr; + } + + /* + * Make sure that the slave's parent is either the master or + * an ancestor of the master, and that the master and slave + * aren't the same. + */ + + for (ancestor = masterPtr->tkwin; ; ancestor = Tk_Parent(ancestor)) { + if (ancestor == parent) { + break; + } + if (Tk_IsTopLevel(ancestor)) { + Tcl_AppendResult(interp, "can't put ", argv[j], + " inside ", Tk_PathName(masterPtr->tkwin), + (char *) NULL); + Unlink(slavePtr); + return TCL_ERROR; + } + } + + /* + * Try to make sure our master isn't managed by us. + */ + + if (masterPtr->masterPtr == slavePtr) { + Tcl_AppendResult(interp, "can't put ", argv[j], + " inside ", Tk_PathName(masterPtr->tkwin), + ", would cause management loop.", + (char *) NULL); + Unlink(slavePtr); + return TCL_ERROR; + } + + Tk_ManageGeometry(slave, &gridMgrType, (ClientData) slavePtr); + + /* + * Assign default position information. + */ + + if (slavePtr->column == -1) { + slavePtr->column = defaultColumn; + } + slavePtr->numCols += defaultColumnSpan - 1; + if (slavePtr->row == -1) { + if (masterPtr->masterDataPtr == NULL) { + slavePtr->row = 0; + } else { + slavePtr->row = masterPtr->masterDataPtr->rowEnd; + } + } + defaultColumn += slavePtr->numCols; + defaultColumnSpan = 1; + + /* + * Arrange for the parent to be re-arranged at the first + * idle moment. + */ + + if (masterPtr->abortPtr != NULL) { + *masterPtr->abortPtr = 1; + } + if (!(masterPtr->flags & REQUESTED_RELAYOUT)) { + masterPtr->flags |= REQUESTED_RELAYOUT; + Tcl_DoWhenIdle(ArrangeGrid, (ClientData) masterPtr); + } + } + + /* Now look for all the "^"'s. */ + + lastWindow = NULL; + for (j = 0; j < numWindows; j++) { + struct Gridder *otherPtr; + int match; /* found a match for the ^ */ + int lastRow, lastColumn; /* implied end of table */ + + if (*argv[j] == '.') { + lastWindow = argv[j]; + } + if (*argv[j] != REL_VERT) { + continue; + } + + if (masterPtr == NULL) { + Tcl_AppendResult(interp, "can't use '^', cant find master", + (char *) NULL); + return TCL_ERROR; + } + + for (width=1; width+j < numWindows && *argv[j+width] == REL_VERT; + width++) { + /* Null Body */ + } + + /* + * Find the implied grid location of the ^ + */ + + if (lastWindow == NULL) { + if (masterPtr->masterDataPtr != NULL) { + SetGridSize(masterPtr); + lastRow = masterPtr->masterDataPtr->rowEnd - 1; + } else { + lastRow = 0; + } + lastColumn = 0; + } else { + other = Tk_NameToWindow(interp, lastWindow, tkwin); + otherPtr = GetGrid(other); + lastRow = otherPtr->row; + lastColumn = otherPtr->column + otherPtr->numCols; + } + + for (match=0, slavePtr = masterPtr->slavePtr; slavePtr != NULL; + slavePtr = slavePtr->nextPtr) { + + if (slavePtr->numCols == width + && slavePtr->column == lastColumn + && slavePtr->row + slavePtr->numRows == lastRow) { + slavePtr->numRows++; + match++; + } + lastWindow = Tk_PathName(slavePtr->tkwin); + } + if (!match) { + Tcl_AppendResult(interp, "can't find slave to extend with \"^\".", + (char *) NULL); + return TCL_ERROR; + } + j += width - 1; + } + + if (masterPtr == NULL) { + Tcl_AppendResult(interp, "can't determine master window", + (char *) NULL); + return TCL_ERROR; + } + SetGridSize(masterPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * StickyToString + * + * Converts the internal boolean combination of "sticky" bits onto + * a TCL list element containing zero or mor of n, s, e, or w. + * + * Results: + * A string is placed into the "result" pointer. + * + * Side effects: + * none. + * + *---------------------------------------------------------------------- + */ + +static void +StickyToString(flags, result) + int flags; /* the sticky flags */ + char *result; /* where to put the result */ +{ + int count = 0; + if (flags&STICK_NORTH) { + result[count++] = 'n'; + } + if (flags&STICK_EAST) { + result[count++] = 'e'; + } + if (flags&STICK_SOUTH) { + result[count++] = 's'; + } + if (flags&STICK_WEST) { + result[count++] = 'w'; + } + if (count) { + result[count] = '\0'; + } else { + sprintf(result,"{}"); + } +} + +/* + *---------------------------------------------------------------------- + * + * StringToSticky -- + * + * Converts an ascii string representing a widgets stickyness + * into the boolean result. + * + * Results: + * The boolean combination of the "sticky" bits is retuned. If an + * error occurs, such as an invalid character, -1 is returned instead. + * + * Side effects: + * none + * + *---------------------------------------------------------------------- + */ + +static int +StringToSticky(string) + char *string; +{ + int sticky = 0; + char c; + + while ((c = *string++) != '\0') { + switch (c) { + case 'n': case 'N': sticky |= STICK_NORTH; break; + case 'e': case 'E': sticky |= STICK_EAST; break; + case 's': case 'S': sticky |= STICK_SOUTH; break; + case 'w': case 'W': sticky |= STICK_WEST; break; + case ' ': case ',': case '\t': case '\r': case '\n': break; + default: return -1; + } + } + return sticky; +} diff --git a/generic/tkImage.c b/generic/tkImage.c new file mode 100644 index 0000000..251fe30 --- /dev/null +++ b/generic/tkImage.c @@ -0,0 +1,789 @@ +/* + * tkImage.c -- + * + * This module implements the image protocol, which allows lots + * of different kinds of images to be used in lots of different + * widgets. + * + * Copyright (c) 1994 The Regents of the University of California. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkImage.c 1.15 97/10/09 09:57:50 + */ + +#include "tkInt.h" +#include "tkPort.h" + +/* + * Each call to Tk_GetImage returns a pointer to one of the following + * structures, which is used as a token by clients (widgets) that + * display images. + */ + +typedef struct Image { + Tk_Window tkwin; /* Window passed to Tk_GetImage (needed to + * "re-get" the image later if the manager + * changes). */ + Display *display; /* Display for tkwin. Needed because when + * the image is eventually freed tkwin may + * not exist anymore. */ + struct ImageMaster *masterPtr; + /* Master for this image (identifiers image + * manager, for example). */ + ClientData instanceData; + /* One word argument to pass to image manager + * when dealing with this image instance. */ + Tk_ImageChangedProc *changeProc; + /* Code in widget to call when image changes + * in a way that affects redisplay. */ + ClientData widgetClientData; + /* Argument to pass to changeProc. */ + struct Image *nextPtr; /* Next in list of all image instances + * associated with the same name. */ + +} Image; + +/* + * For each image master there is one of the following structures, + * which represents a name in the image table and all of the images + * instantiated from it. Entries in mainPtr->imageTable point to + * these structures. + */ + +typedef struct ImageMaster { + Tk_ImageType *typePtr; /* Information about image type. NULL means + * that no image manager owns this image: the + * image was deleted. */ + ClientData masterData; /* One-word argument to pass to image mgr + * when dealing with the master, as opposed + * to instances. */ + int width, height; /* Last known dimensions for image. */ + Tcl_HashTable *tablePtr; /* Pointer to hash table containing image + * (the imageTable field in some TkMainInfo + * structure). */ + Tcl_HashEntry *hPtr; /* Hash entry in mainPtr->imageTable for + * this structure (used to delete the hash + * entry). */ + Image *instancePtr; /* Pointer to first in list of instances + * derived from this name. */ +} ImageMaster; + +/* + * The following variable points to the first in a list of all known + * image types. + */ + +static Tk_ImageType *imageTypeList = NULL; + +/* + * Prototypes for local procedures: + */ + +static void DeleteImage _ANSI_ARGS_((ImageMaster *masterPtr)); + +/* + *---------------------------------------------------------------------- + * + * Tk_CreateImageType -- + * + * This procedure is invoked by an image manager to tell Tk about + * a new kind of image and the procedures that manage the new type. + * The procedure is typically invoked during Tcl_AppInit. + * + * Results: + * None. + * + * Side effects: + * The new image type is entered into a table used in the "image + * create" command. + * + *---------------------------------------------------------------------- + */ + +void +Tk_CreateImageType(typePtr) + Tk_ImageType *typePtr; /* Structure describing the type. All of + * the fields except "nextPtr" must be filled + * in by caller. Must not have been passed + * to Tk_CreateImageType previously. */ +{ + typePtr->nextPtr = imageTypeList; + imageTypeList = typePtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_ImageCmd -- + * + * This procedure is invoked to process the "image" 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_ImageCmd(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. */ +{ + TkWindow *winPtr = (TkWindow *) clientData; + int c, i, new, firstOption; + size_t length; + Tk_ImageType *typePtr; + ImageMaster *masterPtr; + Image *imagePtr; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + char idString[30], *name; + static int id = 0; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option ?args?\"", (char *) NULL); + return TCL_ERROR; + } + c = argv[1][0]; + length = strlen(argv[1]); + if ((c == 'c') && (strncmp(argv[1], "create", length) == 0)) { + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " create type ?name? ?options?\"", (char *) NULL); + return TCL_ERROR; + } + c = argv[2][0]; + + /* + * Look up the image type. + */ + + for (typePtr = imageTypeList; typePtr != NULL; + typePtr = typePtr->nextPtr) { + if ((c == typePtr->name[0]) + && (strcmp(argv[2], typePtr->name) == 0)) { + break; + } + } + if (typePtr == NULL) { + Tcl_AppendResult(interp, "image type \"", argv[2], + "\" doesn't exist", (char *) NULL); + return TCL_ERROR; + } + + /* + * Figure out a name to use for the new image. + */ + + if ((argc == 3) || (argv[3][0] == '-')) { + id++; + sprintf(idString, "image%d", id); + name = idString; + firstOption = 3; + } else { + name = argv[3]; + firstOption = 4; + } + + /* + * Create the data structure for the new image. + */ + + hPtr = Tcl_CreateHashEntry(&winPtr->mainPtr->imageTable, name, &new); + if (new) { + masterPtr = (ImageMaster *) ckalloc(sizeof(ImageMaster)); + masterPtr->typePtr = NULL; + masterPtr->masterData = NULL; + masterPtr->width = masterPtr->height = 1; + masterPtr->tablePtr = &winPtr->mainPtr->imageTable; + masterPtr->hPtr = hPtr; + masterPtr->instancePtr = NULL; + Tcl_SetHashValue(hPtr, masterPtr); + } else { + /* + * An image already exists by this name. Disconnect the + * instances from the master. + */ + + masterPtr = (ImageMaster *) Tcl_GetHashValue(hPtr); + if (masterPtr->typePtr != NULL) { + for (imagePtr = masterPtr->instancePtr; imagePtr != NULL; + imagePtr = imagePtr->nextPtr) { + (*masterPtr->typePtr->freeProc)( + imagePtr->instanceData, imagePtr->display); + (*imagePtr->changeProc)(imagePtr->widgetClientData, 0, 0, + masterPtr->width, masterPtr->height, masterPtr->width, + masterPtr->height); + } + (*masterPtr->typePtr->deleteProc)(masterPtr->masterData); + masterPtr->typePtr = NULL; + } + } + + /* + * Call the image type manager so that it can perform its own + * initialization, then re-"get" for any existing instances of + * the image. + */ + + if ((*typePtr->createProc)(interp, name, argc-firstOption, + argv+firstOption, typePtr, (Tk_ImageMaster) masterPtr, + &masterPtr->masterData) != TCL_OK) { + DeleteImage(masterPtr); + return TCL_ERROR; + } + masterPtr->typePtr = typePtr; + for (imagePtr = masterPtr->instancePtr; imagePtr != NULL; + imagePtr = imagePtr->nextPtr) { + imagePtr->instanceData = (*typePtr->getProc)( + imagePtr->tkwin, masterPtr->masterData); + } + interp->result = Tcl_GetHashKey(&winPtr->mainPtr->imageTable, hPtr); + } else if ((c == 'd') && (strncmp(argv[1], "delete", length) == 0)) { + for (i = 2; i < argc; i++) { + hPtr = Tcl_FindHashEntry(&winPtr->mainPtr->imageTable, argv[i]); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "image \"", argv[i], + "\" doesn't exist", (char *) NULL); + return TCL_ERROR; + } + masterPtr = (ImageMaster *) Tcl_GetHashValue(hPtr); + DeleteImage(masterPtr); + } + } else if ((c == 'h') && (strncmp(argv[1], "height", length) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " height name\"", (char *) NULL); + return TCL_ERROR; + } + hPtr = Tcl_FindHashEntry(&winPtr->mainPtr->imageTable, argv[2]); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "image \"", argv[2], + "\" doesn't exist", (char *) NULL); + return TCL_ERROR; + } + masterPtr = (ImageMaster *) Tcl_GetHashValue(hPtr); + sprintf(interp->result, "%d", masterPtr->height); + } else if ((c == 'n') && (strncmp(argv[1], "names", length) == 0)) { + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " names\"", (char *) NULL); + return TCL_ERROR; + } + for (hPtr = Tcl_FirstHashEntry(&winPtr->mainPtr->imageTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + Tcl_AppendElement(interp, Tcl_GetHashKey( + &winPtr->mainPtr->imageTable, hPtr)); + } + } else if ((c == 't') && (strcmp(argv[1], "type") == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " type name\"", (char *) NULL); + return TCL_ERROR; + } + hPtr = Tcl_FindHashEntry(&winPtr->mainPtr->imageTable, argv[2]); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "image \"", argv[2], + "\" doesn't exist", (char *) NULL); + return TCL_ERROR; + } + masterPtr = (ImageMaster *) Tcl_GetHashValue(hPtr); + if (masterPtr->typePtr != NULL) { + interp->result = masterPtr->typePtr->name; + } + } else if ((c == 't') && (strcmp(argv[1], "types") == 0)) { + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " types\"", (char *) NULL); + return TCL_ERROR; + } + for (typePtr = imageTypeList; typePtr != NULL; + typePtr = typePtr->nextPtr) { + Tcl_AppendElement(interp, typePtr->name); + } + } else if ((c == 'w') && (strncmp(argv[1], "width", length) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " width name\"", (char *) NULL); + return TCL_ERROR; + } + hPtr = Tcl_FindHashEntry(&winPtr->mainPtr->imageTable, argv[2]); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "image \"", argv[2], + "\" doesn't exist", (char *) NULL); + return TCL_ERROR; + } + masterPtr = (ImageMaster *) Tcl_GetHashValue(hPtr); + sprintf(interp->result, "%d", masterPtr->width); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be create, delete, height, names, type, types,", + " or width", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_ImageChanged -- + * + * This procedure is called by an image manager whenever something + * has happened that requires the image to be redrawn (some of its + * pixels have changed, or its size has changed). + * + * Results: + * None. + * + * Side effects: + * Any widgets that display the image are notified so that they + * can redisplay themselves as appropriate. + * + *---------------------------------------------------------------------- + */ + +void +Tk_ImageChanged(imageMaster, x, y, width, height, imageWidth, + imageHeight) + Tk_ImageMaster imageMaster; /* Image that needs redisplay. */ + int x, y; /* Coordinates of upper-left pixel of + * region of image that needs to be + * redrawn. */ + int width, height; /* Dimensions (in pixels) of region of + * image to redraw. If either dimension + * is zero then the image doesn't need to + * be redrawn (perhaps all that happened is + * that its size changed). */ + int imageWidth, imageHeight;/* New dimensions of image. */ +{ + ImageMaster *masterPtr = (ImageMaster *) imageMaster; + Image *imagePtr; + + masterPtr->width = imageWidth; + masterPtr->height = imageHeight; + for (imagePtr = masterPtr->instancePtr; imagePtr != NULL; + imagePtr = imagePtr->nextPtr) { + (*imagePtr->changeProc)(imagePtr->widgetClientData, x, y, + width, height, imageWidth, imageHeight); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tk_NameOfImage -- + * + * Given a token for an image master, this procedure returns + * the name of the image. + * + * Results: + * The return value is the string name for imageMaster. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tk_NameOfImage(imageMaster) + Tk_ImageMaster imageMaster; /* Token for image. */ +{ + ImageMaster *masterPtr = (ImageMaster *) imageMaster; + + return Tcl_GetHashKey(masterPtr->tablePtr, masterPtr->hPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tk_GetImage -- + * + * This procedure is invoked by a widget when it wants to use + * a particular image in a particular window. + * + * 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. + * + * Side effects: + * Tk records the fact that the widget is using the image, and + * it will invoke changeProc later if the widget needs redisplay + * (i.e. its size changes or some of its pixels change). The + * caller must eventually invoke Tk_FreeImage when it no longer + * needs the image. + * + *---------------------------------------------------------------------- + */ + +Tk_Image +Tk_GetImage(interp, tkwin, name, changeProc, clientData) + Tcl_Interp *interp; /* Place to leave error message if image + * can't be found. */ + Tk_Window tkwin; /* Token for window in which image will + * be used. */ + char *name; /* Name of desired image. */ + Tk_ImageChangedProc *changeProc; + /* Procedure to invoke when redisplay is + * needed because image's pixels or size + * changed. */ + ClientData clientData; /* One-word argument to pass to damageProc. */ +{ + Tcl_HashEntry *hPtr; + ImageMaster *masterPtr; + Image *imagePtr; + + hPtr = Tcl_FindHashEntry(&((TkWindow *) tkwin)->mainPtr->imageTable, name); + if (hPtr == NULL) { + goto noSuchImage; + } + masterPtr = (ImageMaster *) Tcl_GetHashValue(hPtr); + if (masterPtr->typePtr == NULL) { + goto noSuchImage; + } + imagePtr = (Image *) ckalloc(sizeof(Image)); + imagePtr->tkwin = tkwin; + imagePtr->display = Tk_Display(tkwin); + imagePtr->masterPtr = masterPtr; + imagePtr->instanceData = + (*masterPtr->typePtr->getProc)(tkwin, masterPtr->masterData); + imagePtr->changeProc = changeProc; + imagePtr->widgetClientData = clientData; + imagePtr->nextPtr = masterPtr->instancePtr; + masterPtr->instancePtr = imagePtr; + return (Tk_Image) imagePtr; + + noSuchImage: + Tcl_AppendResult(interp, "image \"", name, "\" doesn't exist", + (char *) NULL); + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_FreeImage -- + * + * This procedure is invoked by a widget when it no longer needs + * an image acquired by a previous call to Tk_GetImage. For each + * call to Tk_GetImage there must be exactly one call to Tk_FreeImage. + * + * Results: + * None. + * + * Side effects: + * The association between the image and the widget is removed. + * + *---------------------------------------------------------------------- + */ + +void +Tk_FreeImage(image) + Tk_Image image; /* Token for image that is no longer + * needed by a widget. */ +{ + Image *imagePtr = (Image *) image; + ImageMaster *masterPtr = imagePtr->masterPtr; + Image *prevPtr; + + /* + * Clean up the particular instance. + */ + + if (masterPtr->typePtr != NULL) { + (*masterPtr->typePtr->freeProc)(imagePtr->instanceData, + imagePtr->display); + } + prevPtr = masterPtr->instancePtr; + if (prevPtr == imagePtr) { + masterPtr->instancePtr = imagePtr->nextPtr; + } else { + while (prevPtr->nextPtr != imagePtr) { + prevPtr = prevPtr->nextPtr; + } + prevPtr->nextPtr = imagePtr->nextPtr; + } + ckfree((char *) imagePtr); + + /* + * If there are no more instances left for the master, and if the + * master image has been deleted, then delete the master too. + */ + + if ((masterPtr->typePtr == NULL) && (masterPtr->instancePtr == NULL)) { + Tcl_DeleteHashEntry(masterPtr->hPtr); + ckfree((char *) masterPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tk_RedrawImage -- + * + * This procedure is called by widgets that contain images in order + * to redisplay an image on the screen or an off-screen pixmap. + * + * Results: + * None. + * + * Side effects: + * The image's manager is notified, and it redraws the desired + * portion of the image before returning. + * + *---------------------------------------------------------------------- + */ + +void +Tk_RedrawImage(image, imageX, imageY, width, height, drawable, + drawableX, drawableY) + Tk_Image image; /* Token for image to redisplay. */ + int imageX, imageY; /* Upper-left pixel of region in image that + * needs to be redisplayed. */ + int width, height; /* Dimensions of region to redraw. */ + Drawable drawable; /* Drawable in which to display image + * (window or pixmap). If this is a pixmap, + * it must have the same depth as the window + * used in the Tk_GetImage call for the + * image. */ + int drawableX, drawableY; /* Coordinates in drawable that correspond + * to imageX and imageY. */ +{ + Image *imagePtr = (Image *) image; + + if (imagePtr->masterPtr->typePtr == NULL) { + /* + * No master for image, so nothing to display. + */ + + return; + } + + /* + * Clip the redraw area to the area of the image. + */ + + if (imageX < 0) { + width += imageX; + drawableX -= imageX; + imageX = 0; + } + if (imageY < 0) { + height += imageY; + drawableY -= imageY; + imageY = 0; + } + if ((imageX + width) > imagePtr->masterPtr->width) { + width = imagePtr->masterPtr->width - imageX; + } + if ((imageY + height) > imagePtr->masterPtr->height) { + height = imagePtr->masterPtr->height - imageY; + } + (*imagePtr->masterPtr->typePtr->displayProc)( + imagePtr->instanceData, imagePtr->display, drawable, + imageX, imageY, width, height, drawableX, drawableY); +} + +/* + *---------------------------------------------------------------------- + * + * Tk_SizeOfImage -- + * + * This procedure returns the current dimensions of an image. + * + * Results: + * The width and height of the image are returned in *widthPtr + * and *heightPtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tk_SizeOfImage(image, widthPtr, heightPtr) + Tk_Image image; /* Token for image whose size is wanted. */ + int *widthPtr; /* Return width of image here. */ + int *heightPtr; /* Return height of image here. */ +{ + Image *imagePtr = (Image *) image; + + *widthPtr = imagePtr->masterPtr->width; + *heightPtr = imagePtr->masterPtr->height; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_DeleteImage -- + * + * Given the name of an image, this procedure destroys the + * image. + * + * Results: + * None. + * + * Side effects: + * The image is destroyed; existing instances will display as + * blank areas. If no such image exists then the procedure does + * nothing. + * + *---------------------------------------------------------------------- + */ + +void +Tk_DeleteImage(interp, name) + Tcl_Interp *interp; /* Interpreter in which the image was + * created. */ + char *name; /* Name of image. */ +{ + Tcl_HashEntry *hPtr; + TkWindow *winPtr; + + winPtr = (TkWindow *) Tk_MainWindow(interp); + if (winPtr == NULL) { + return; + } + hPtr = Tcl_FindHashEntry(&winPtr->mainPtr->imageTable, name); + if (hPtr == NULL) { + return; + } + DeleteImage((ImageMaster *) Tcl_GetHashValue(hPtr)); +} + +/* + *---------------------------------------------------------------------- + * + * DeleteImage -- + * + * This procedure is responsible for deleting an image. + * + * Results: + * None. + * + * Side effects: + * The connection is dropped between instances of this image and + * an image master. Image instances will redisplay themselves + * as empty areas, but existing instances will not be deleted. + * + *---------------------------------------------------------------------- + */ + +static void +DeleteImage(masterPtr) + ImageMaster *masterPtr; /* Pointer to main data structure for image. */ +{ + Image *imagePtr; + Tk_ImageType *typePtr; + + typePtr = masterPtr->typePtr; + masterPtr->typePtr = NULL; + if (typePtr != NULL) { + for (imagePtr = masterPtr->instancePtr; imagePtr != NULL; + imagePtr = imagePtr->nextPtr) { + (*typePtr->freeProc)(imagePtr->instanceData, + imagePtr->display); + (*imagePtr->changeProc)(imagePtr->widgetClientData, 0, 0, + masterPtr->width, masterPtr->height, masterPtr->width, + masterPtr->height); + } + (*typePtr->deleteProc)(masterPtr->masterData); + } + if (masterPtr->instancePtr == NULL) { + Tcl_DeleteHashEntry(masterPtr->hPtr); + ckfree((char *) masterPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * TkDeleteAllImages -- + * + * This procedure is called when an application is deleted. It + * calls back all of the managers for all images so that they + * can cleanup, then it deletes all of Tk's internal information + * about images. + * + * Results: + * None. + * + * Side effects: + * All information for all images gets deleted. + * + *---------------------------------------------------------------------- + */ + +void +TkDeleteAllImages(mainPtr) + TkMainInfo *mainPtr; /* Structure describing application that is + * going away. */ +{ + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; + ImageMaster *masterPtr; + + for (hPtr = Tcl_FirstHashEntry(&mainPtr->imageTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + masterPtr = (ImageMaster *) Tcl_GetHashValue(hPtr); + DeleteImage(masterPtr); + } + Tcl_DeleteHashTable(&mainPtr->imageTable); +} + +/* + *---------------------------------------------------------------------- + * + * Tk_GetImageMasterData -- + * + * Given the name of an image, this procedure returns the type + * of the image and the clientData associated with its master. + * + * Results: + * If there is no image by the given name, then NULL is returned + * and a NULL value is stored at *typePtrPtr. Otherwise the return + * value is the clientData returned by the createProc when the + * image was created and a pointer to the type structure for the + * image is stored at *typePtrPtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +ClientData +Tk_GetImageMasterData(interp, name, typePtrPtr) + Tcl_Interp *interp; /* Interpreter in which the image was + * created. */ + char *name; /* Name of image. */ + Tk_ImageType **typePtrPtr; /* Points to location to fill in with + * pointer to type information for image. */ +{ + Tcl_HashEntry *hPtr; + TkWindow *winPtr; + ImageMaster *masterPtr; + + winPtr = (TkWindow *) Tk_MainWindow(interp); + hPtr = Tcl_FindHashEntry(&winPtr->mainPtr->imageTable, name); + if (hPtr == NULL) { + *typePtrPtr = NULL; + return NULL; + } + masterPtr = (ImageMaster *) Tcl_GetHashValue(hPtr); + *typePtrPtr = masterPtr->typePtr; + return masterPtr->masterData; +} diff --git a/generic/tkImgBmap.c b/generic/tkImgBmap.c new file mode 100644 index 0000000..f8a1d6e --- /dev/null +++ b/generic/tkImgBmap.c @@ -0,0 +1,1061 @@ +/* + * tkImgBmap.c -- + * + * This procedure implements images of type "bitmap" for Tk. + * + * Copyright (c) 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: @(#) tkImgBmap.c 1.33 97/07/31 09:08:22 + */ + +#include "tkInt.h" +#include "tkPort.h" + +/* + * The following data structure represents the master for a bitmap + * image: + */ + +typedef struct BitmapMaster { + Tk_ImageMaster tkMaster; /* Tk's token for image master. NULL means + * the image is being deleted. */ + Tcl_Interp *interp; /* Interpreter for application that is + * using image. */ + Tcl_Command imageCmd; /* Token for image command (used to delete + * it when the image goes away). NULL means + * the image command has already been + * deleted. */ + int width, height; /* Dimensions of image. */ + char *data; /* Data comprising bitmap (suitable for + * input to XCreateBitmapFromData). May + * be NULL if no data. Malloc'ed. */ + char *maskData; /* Data for bitmap's mask (suitable for + * input to XCreateBitmapFromData). + * Malloc'ed. */ + Tk_Uid fgUid; /* Value of -foreground option (malloc'ed). */ + Tk_Uid bgUid; /* Value of -background option (malloc'ed). */ + char *fileString; /* Value of -file option (malloc'ed). */ + char *dataString; /* Value of -data option (malloc'ed). */ + char *maskFileString; /* Value of -maskfile option (malloc'ed). */ + char *maskDataString; /* Value of -maskdata option (malloc'ed). */ + struct BitmapInstance *instancePtr; + /* First in list of all instances associated + * with this master. */ +} BitmapMaster; + +/* + * The following data structure represents all of the instances of an + * image that lie within a particular window: + */ + +typedef struct BitmapInstance { + int refCount; /* Number of instances that share this + * data structure. */ + BitmapMaster *masterPtr; /* Pointer to master for image. */ + Tk_Window tkwin; /* Window in which the instances will be + * displayed. */ + XColor *fg; /* Foreground color for displaying image. */ + XColor *bg; /* Background color for displaying image. */ + Pixmap bitmap; /* The bitmap to display. */ + Pixmap mask; /* Mask: only display bitmap pixels where + * there are 1's here. */ + GC gc; /* Graphics context for displaying bitmap. + * None means there was an error while + * setting up the instance, so it cannot + * be displayed. */ + struct BitmapInstance *nextPtr; + /* Next in list of all instance structures + * associated with masterPtr (NULL means + * end of list). */ +} BitmapInstance; + +/* + * The type record for bitmap images: + */ + +static int GetByte _ANSI_ARGS_((Tcl_Channel chan)); +static int ImgBmapCreate _ANSI_ARGS_((Tcl_Interp *interp, + char *name, int argc, char **argv, + Tk_ImageType *typePtr, Tk_ImageMaster master, + ClientData *clientDataPtr)); +static ClientData ImgBmapGet _ANSI_ARGS_((Tk_Window tkwin, + ClientData clientData)); +static void ImgBmapDisplay _ANSI_ARGS_((ClientData clientData, + Display *display, Drawable drawable, + int imageX, int imageY, int width, int height, + int drawableX, int drawableY)); +static void ImgBmapFree _ANSI_ARGS_((ClientData clientData, + Display *display)); +static void ImgBmapDelete _ANSI_ARGS_((ClientData clientData)); + +Tk_ImageType tkBitmapImageType = { + "bitmap", /* name */ + ImgBmapCreate, /* createProc */ + ImgBmapGet, /* getProc */ + ImgBmapDisplay, /* displayProc */ + ImgBmapFree, /* freeProc */ + ImgBmapDelete, /* deleteProc */ + (Tk_ImageType *) NULL /* nextPtr */ +}; + +/* + * Information used for parsing configuration specs: + */ + +static Tk_ConfigSpec configSpecs[] = { + {TK_CONFIG_UID, "-background", (char *) NULL, (char *) NULL, + "", Tk_Offset(BitmapMaster, bgUid), 0}, + {TK_CONFIG_STRING, "-data", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(BitmapMaster, dataString), TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-file", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(BitmapMaster, fileString), TK_CONFIG_NULL_OK}, + {TK_CONFIG_UID, "-foreground", (char *) NULL, (char *) NULL, + "#000000", Tk_Offset(BitmapMaster, fgUid), 0}, + {TK_CONFIG_STRING, "-maskdata", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(BitmapMaster, maskDataString), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-maskfile", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(BitmapMaster, maskFileString), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, 0} +}; + +/* + * The following data structure is used to describe the state of + * parsing a bitmap file or string. It is used for communication + * between TkGetBitmapData and NextBitmapWord. + */ + +#define MAX_WORD_LENGTH 100 +typedef struct ParseInfo { + char *string; /* Next character of string data for bitmap, + * or NULL if bitmap is being read from + * file. */ + Tcl_Channel chan; /* File containing bitmap data, or NULL + * if no file. */ + char word[MAX_WORD_LENGTH+1]; + /* Current word of bitmap data, NULL + * terminated. */ + int wordLength; /* Number of non-NULL bytes in word. */ +} ParseInfo; + +/* + * Prototypes for procedures used only locally in this file: + */ + +static int ImgBmapCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static void ImgBmapCmdDeletedProc _ANSI_ARGS_(( + ClientData clientData)); +static void ImgBmapConfigureInstance _ANSI_ARGS_(( + BitmapInstance *instancePtr)); +static int ImgBmapConfigureMaster _ANSI_ARGS_(( + BitmapMaster *masterPtr, int argc, char **argv, + int flags)); +static int NextBitmapWord _ANSI_ARGS_((ParseInfo *parseInfoPtr)); + +/* + *---------------------------------------------------------------------- + * + * ImgBmapCreate -- + * + * This procedure is called by the Tk image code to create "test" + * images. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * The data structure for a new image is allocated. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +ImgBmapCreate(interp, name, argc, argv, typePtr, master, clientDataPtr) + Tcl_Interp *interp; /* Interpreter for application containing + * image. */ + char *name; /* Name to use for image. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings for options (doesn't + * include image name or type). */ + Tk_ImageType *typePtr; /* Pointer to our type record (not used). */ + Tk_ImageMaster master; /* Token for image, to be used by us in + * later callbacks. */ + ClientData *clientDataPtr; /* Store manager's token for image here; + * it will be returned in later callbacks. */ +{ + BitmapMaster *masterPtr; + + masterPtr = (BitmapMaster *) ckalloc(sizeof(BitmapMaster)); + masterPtr->tkMaster = master; + masterPtr->interp = interp; + masterPtr->imageCmd = Tcl_CreateCommand(interp, name, ImgBmapCmd, + (ClientData) masterPtr, ImgBmapCmdDeletedProc); + masterPtr->width = masterPtr->height = 0; + masterPtr->data = NULL; + masterPtr->maskData = NULL; + masterPtr->fgUid = NULL; + masterPtr->bgUid = NULL; + masterPtr->fileString = NULL; + masterPtr->dataString = NULL; + masterPtr->maskFileString = NULL; + masterPtr->maskDataString = NULL; + masterPtr->instancePtr = NULL; + if (ImgBmapConfigureMaster(masterPtr, argc, argv, 0) != TCL_OK) { + ImgBmapDelete((ClientData) masterPtr); + return TCL_ERROR; + } + *clientDataPtr = (ClientData) masterPtr; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ImgBmapConfigureMaster -- + * + * This procedure is called when a bitmap image is created or + * reconfigured. It process configuration options and resets + * any instances of the image. + * + * Results: + * A standard Tcl return value. If TCL_ERROR is returned then + * an error message is left in masterPtr->interp->result. + * + * Side effects: + * Existing instances of the image will be redisplayed to match + * the new configuration options. + * + *---------------------------------------------------------------------- + */ + +static int +ImgBmapConfigureMaster(masterPtr, argc, argv, flags) + BitmapMaster *masterPtr; /* Pointer to data structure describing + * overall bitmap image to (reconfigure). */ + int argc; /* Number of entries in argv. */ + char **argv; /* Pairs of configuration options for image. */ + int flags; /* Flags to pass to Tk_ConfigureWidget, + * such as TK_CONFIG_ARGV_ONLY. */ +{ + BitmapInstance *instancePtr; + int maskWidth, maskHeight, dummy1, dummy2; + + if (Tk_ConfigureWidget(masterPtr->interp, Tk_MainWindow(masterPtr->interp), + configSpecs, argc, argv, (char *) masterPtr, flags) + != TCL_OK) { + return TCL_ERROR; + } + + /* + * Parse the bitmap and/or mask to create binary data. Make sure that + * the bitmap and mask have the same dimensions. + */ + + if (masterPtr->data != NULL) { + ckfree(masterPtr->data); + masterPtr->data = NULL; + } + if ((masterPtr->fileString != NULL) || (masterPtr->dataString != NULL)) { + masterPtr->data = TkGetBitmapData(masterPtr->interp, + masterPtr->dataString, masterPtr->fileString, + &masterPtr->width, &masterPtr->height, &dummy1, &dummy2); + if (masterPtr->data == NULL) { + return TCL_ERROR; + } + } + if (masterPtr->maskData != NULL) { + ckfree(masterPtr->maskData); + masterPtr->maskData = NULL; + } + if ((masterPtr->maskFileString != NULL) + || (masterPtr->maskDataString != NULL)) { + if (masterPtr->data == NULL) { + masterPtr->interp->result = "can't have mask without bitmap"; + return TCL_ERROR; + } + masterPtr->maskData = TkGetBitmapData(masterPtr->interp, + masterPtr->maskDataString, masterPtr->maskFileString, + &maskWidth, &maskHeight, &dummy1, &dummy2); + if (masterPtr->maskData == NULL) { + return TCL_ERROR; + } + if ((maskWidth != masterPtr->width) + || (maskHeight != masterPtr->height)) { + ckfree(masterPtr->maskData); + masterPtr->maskData = NULL; + masterPtr->interp->result = "bitmap and mask have different sizes"; + return TCL_ERROR; + } + } + + /* + * Cycle through all of the instances of this image, regenerating + * the information for each instance. Then force the image to be + * redisplayed everywhere that it is used. + */ + + for (instancePtr = masterPtr->instancePtr; instancePtr != NULL; + instancePtr = instancePtr->nextPtr) { + ImgBmapConfigureInstance(instancePtr); + } + Tk_ImageChanged(masterPtr->tkMaster, 0, 0, masterPtr->width, + masterPtr->height, masterPtr->width, masterPtr->height); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ImgBmapConfigureInstance -- + * + * This procedure is called to create displaying information for + * a bitmap image instance based on the configuration information + * in the master. It is invoked both when new instances are + * created and when the master is reconfigured. + * + * Results: + * None. + * + * Side effects: + * Generates errors via Tcl_BackgroundError if there are problems + * in setting up the instance. + * + *---------------------------------------------------------------------- + */ + +static void +ImgBmapConfigureInstance(instancePtr) + BitmapInstance *instancePtr; /* Instance to reconfigure. */ +{ + BitmapMaster *masterPtr = instancePtr->masterPtr; + XColor *colorPtr; + XGCValues gcValues; + GC gc; + unsigned int mask; + + /* + * For each of the options in masterPtr, translate the string + * form into an internal form appropriate for instancePtr. + */ + + if (*masterPtr->bgUid != 0) { + colorPtr = Tk_GetColor(masterPtr->interp, instancePtr->tkwin, + masterPtr->bgUid); + if (colorPtr == NULL) { + goto error; + } + } else { + colorPtr = NULL; + } + if (instancePtr->bg != NULL) { + Tk_FreeColor(instancePtr->bg); + } + instancePtr->bg = colorPtr; + + colorPtr = Tk_GetColor(masterPtr->interp, instancePtr->tkwin, + masterPtr->fgUid); + if (colorPtr == NULL) { + goto error; + } + if (instancePtr->fg != NULL) { + Tk_FreeColor(instancePtr->fg); + } + instancePtr->fg = colorPtr; + + if (instancePtr->bitmap != None) { + Tk_FreePixmap(Tk_Display(instancePtr->tkwin), instancePtr->bitmap); + instancePtr->bitmap = None; + } + if (masterPtr->data != NULL) { + instancePtr->bitmap = XCreateBitmapFromData( + Tk_Display(instancePtr->tkwin), + RootWindowOfScreen(Tk_Screen(instancePtr->tkwin)), + masterPtr->data, (unsigned) masterPtr->width, + (unsigned) masterPtr->height); + } + + if (instancePtr->mask != None) { + Tk_FreePixmap(Tk_Display(instancePtr->tkwin), instancePtr->mask); + instancePtr->mask = None; + } + if (masterPtr->maskData != NULL) { + instancePtr->mask = XCreateBitmapFromData( + Tk_Display(instancePtr->tkwin), + RootWindowOfScreen(Tk_Screen(instancePtr->tkwin)), + masterPtr->maskData, (unsigned) masterPtr->width, + (unsigned) masterPtr->height); + } + + if (masterPtr->data != NULL) { + gcValues.foreground = instancePtr->fg->pixel; + gcValues.graphics_exposures = False; + mask = GCForeground|GCGraphicsExposures; + if (instancePtr->bg != NULL) { + gcValues.background = instancePtr->bg->pixel; + mask |= GCBackground; + if (instancePtr->mask != None) { + gcValues.clip_mask = instancePtr->mask; + mask |= GCClipMask; + } + } else { + gcValues.clip_mask = instancePtr->bitmap; + mask |= GCClipMask; + } + gc = Tk_GetGC(instancePtr->tkwin, mask, &gcValues); + } else { + gc = None; + } + if (instancePtr->gc != None) { + Tk_FreeGC(Tk_Display(instancePtr->tkwin), instancePtr->gc); + } + instancePtr->gc = gc; + return; + + error: + /* + * An error occurred: clear the graphics context in the instance to + * make it clear that this instance cannot be displayed. Then report + * the error. + */ + + if (instancePtr->gc != None) { + Tk_FreeGC(Tk_Display(instancePtr->tkwin), instancePtr->gc); + } + instancePtr->gc = None; + Tcl_AddErrorInfo(masterPtr->interp, "\n (while configuring image \""); + Tcl_AddErrorInfo(masterPtr->interp, Tk_NameOfImage(masterPtr->tkMaster)); + Tcl_AddErrorInfo(masterPtr->interp, "\")"); + Tcl_BackgroundError(masterPtr->interp); +} + +/* + *---------------------------------------------------------------------- + * + * TkGetBitmapData -- + * + * Given a file name or ASCII string, this procedure parses the + * file or string contents to produce binary data for a bitmap. + * + * Results: + * If the bitmap description was parsed successfully then the + * return value is a malloc-ed array containing the bitmap data. + * The dimensions of the data are stored in *widthPtr and + * *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. + * + * Side effects: + * A bitmap is created. + * + *---------------------------------------------------------------------- + */ + +char * +TkGetBitmapData(interp, string, fileName, widthPtr, heightPtr, + hotXPtr, hotYPtr) + Tcl_Interp *interp; /* For reporting errors. */ + char *string; /* String describing bitmap. May + * be NULL. */ + char *fileName; /* Name of file containing bitmap + * description. Used only if string + * is NULL. Must not be NULL if + * string is NULL. */ + int *widthPtr, *heightPtr; /* Dimensions of bitmap get returned + * here. */ + int *hotXPtr, *hotYPtr; /* Position of hot spot or -1,-1. */ +{ + int width, height, numBytes, hotX, hotY; + char *p, *end, *expandedFileName; + ParseInfo pi; + char *data = NULL; + Tcl_DString buffer; + + pi.string = string; + if (string == NULL) { + if (Tcl_IsSafe(interp)) { + Tcl_AppendResult(interp, "can't get bitmap data from a file in a", + " safe interpreter", (char *) NULL); + return NULL; + } + expandedFileName = Tcl_TranslateFileName(interp, fileName, &buffer); + if (expandedFileName == NULL) { + return NULL; + } + pi.chan = Tcl_OpenFileChannel(interp, expandedFileName, "r", 0); + Tcl_DStringFree(&buffer); + if (pi.chan == NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "couldn't read bitmap file \"", + fileName, "\": ", Tcl_PosixError(interp), (char *) NULL); + return NULL; + } + } else { + pi.chan = NULL; + } + + /* + * Parse the lines that define the dimensions of the bitmap, + * plus the first line that defines the bitmap data (it declares + * the name of a data variable but doesn't include any actual + * data). These lines look something like the following: + * + * #define foo_width 16 + * #define foo_height 16 + * #define foo_x_hot 3 + * #define foo_y_hot 3 + * static char foo_bits[] = { + * + * The x_hot and y_hot lines may or may not be present. It's + * important to check for "char" in the last line, in order to + * reject old X10-style bitmaps that used shorts. + */ + + width = 0; + height = 0; + hotX = -1; + hotY = -1; + while (1) { + if (NextBitmapWord(&pi) != TCL_OK) { + goto error; + } + if ((pi.wordLength >= 6) && (pi.word[pi.wordLength-6] == '_') + && (strcmp(pi.word+pi.wordLength-6, "_width") == 0)) { + if (NextBitmapWord(&pi) != TCL_OK) { + goto error; + } + width = strtol(pi.word, &end, 0); + if ((end == pi.word) || (*end != 0)) { + goto error; + } + } else if ((pi.wordLength >= 7) && (pi.word[pi.wordLength-7] == '_') + && (strcmp(pi.word+pi.wordLength-7, "_height") == 0)) { + if (NextBitmapWord(&pi) != TCL_OK) { + goto error; + } + height = strtol(pi.word, &end, 0); + if ((end == pi.word) || (*end != 0)) { + goto error; + } + } else if ((pi.wordLength >= 6) && (pi.word[pi.wordLength-6] == '_') + && (strcmp(pi.word+pi.wordLength-6, "_x_hot") == 0)) { + if (NextBitmapWord(&pi) != TCL_OK) { + goto error; + } + hotX = strtol(pi.word, &end, 0); + if ((end == pi.word) || (*end != 0)) { + goto error; + } + } else if ((pi.wordLength >= 6) && (pi.word[pi.wordLength-6] == '_') + && (strcmp(pi.word+pi.wordLength-6, "_y_hot") == 0)) { + if (NextBitmapWord(&pi) != TCL_OK) { + goto error; + } + hotY = strtol(pi.word, &end, 0); + if ((end == pi.word) || (*end != 0)) { + goto error; + } + } else if ((pi.word[0] == 'c') && (strcmp(pi.word, "char") == 0)) { + while (1) { + if (NextBitmapWord(&pi) != TCL_OK) { + goto error; + } + if ((pi.word[0] == '{') && (pi.word[1] == 0)) { + goto getData; + } + } + } else if ((pi.word[0] == '{') && (pi.word[1] == 0)) { + Tcl_AppendResult(interp, "format error in bitmap data; ", + "looks like it's an obsolete X10 bitmap file", + (char *) NULL); + goto errorCleanup; + } + } + + /* + * Now we've read everything but the data. Allocate an array + * and read in the data. + */ + + getData: + if ((width <= 0) || (height <= 0)) { + goto error; + } + numBytes = ((width+7)/8) * height; + data = (char *) ckalloc((unsigned) numBytes); + for (p = data; numBytes > 0; p++, numBytes--) { + if (NextBitmapWord(&pi) != TCL_OK) { + goto error; + } + *p = (char) strtol(pi.word, &end, 0); + if (end == pi.word) { + goto error; + } + } + + /* + * All done. Clean up and return. + */ + + if (pi.chan != NULL) { + Tcl_Close(NULL, pi.chan); + } + *widthPtr = width; + *heightPtr = height; + *hotXPtr = hotX; + *hotYPtr = hotY; + return data; + + error: + interp->result = "format error in bitmap data"; + errorCleanup: + if (data != NULL) { + ckfree(data); + } + if (pi.chan != NULL) { + Tcl_Close(NULL, pi.chan); + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * NextBitmapWord -- + * + * This procedure retrieves the next word of information (stuff + * between commas or white space) from a bitmap description. + * + * Results: + * Returns TCL_OK if all went well. In this case the next word, + * and its length, will be availble in *parseInfoPtr. If the end + * of the bitmap description was reached then TCL_ERROR is returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +NextBitmapWord(parseInfoPtr) + ParseInfo *parseInfoPtr; /* Describes what we're reading + * and where we are in it. */ +{ + char *src, *dst; + int c; + + parseInfoPtr->wordLength = 0; + dst = parseInfoPtr->word; + if (parseInfoPtr->string != NULL) { + for (src = parseInfoPtr->string; isspace(UCHAR(*src)) || (*src == ','); + src++) { + if (*src == 0) { + return TCL_ERROR; + } + } + for ( ; !isspace(UCHAR(*src)) && (*src != ',') && (*src != 0); src++) { + *dst = *src; + dst++; + parseInfoPtr->wordLength++; + if (parseInfoPtr->wordLength > MAX_WORD_LENGTH) { + return TCL_ERROR; + } + } + parseInfoPtr->string = src; + } else { + for (c = GetByte(parseInfoPtr->chan); isspace(UCHAR(c)) || (c == ','); + c = GetByte(parseInfoPtr->chan)) { + if (c == EOF) { + return TCL_ERROR; + } + } + for ( ; !isspace(UCHAR(c)) && (c != ',') && (c != EOF); + c = GetByte(parseInfoPtr->chan)) { + *dst = c; + dst++; + parseInfoPtr->wordLength++; + if (parseInfoPtr->wordLength > MAX_WORD_LENGTH) { + return TCL_ERROR; + } + } + } + if (parseInfoPtr->wordLength == 0) { + return TCL_ERROR; + } + parseInfoPtr->word[parseInfoPtr->wordLength] = 0; + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * ImgBmapCmd -- + * + * This procedure is invoked to process the Tcl command + * that corresponds to an image managed by this module. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +static int +ImgBmapCmd(clientData, interp, argc, argv) + ClientData clientData; /* Information about the image master. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + BitmapMaster *masterPtr = (BitmapMaster *) clientData; + int c, code; + size_t length; + + if (argc < 2) { + sprintf(interp->result, + "wrong # args: should be \"%.50s option ?arg arg ...?\"", + argv[0]); + return TCL_ERROR; + } + 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); + return TCL_ERROR; + } + return Tk_ConfigureValue(interp, Tk_MainWindow(interp), configSpecs, + (char *) masterPtr, argv[2], 0); + } else if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0) + && (length >= 2)) { + if (argc == 2) { + code = Tk_ConfigureInfo(interp, Tk_MainWindow(interp), + configSpecs, (char *) masterPtr, (char *) NULL, 0); + } else if (argc == 3) { + code = Tk_ConfigureInfo(interp, Tk_MainWindow(interp), + configSpecs, (char *) masterPtr, argv[2], 0); + } else { + code = ImgBmapConfigureMaster(masterPtr, argc-2, argv+2, + TK_CONFIG_ARGV_ONLY); + } + return code; + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be cget or configure", (char *) NULL); + return TCL_ERROR; + } +} + +/* + *---------------------------------------------------------------------- + * + * ImgBmapGet -- + * + * This procedure is called for each use of a bitmap image in a + * widget. + * + * Results: + * The return value is a token for the instance, which is passed + * back to us in calls to ImgBmapDisplay and ImgBmapFree. + * + * Side effects: + * A data structure is set up for the instance (or, an existing + * instance is re-used for the new one). + * + *---------------------------------------------------------------------- + */ + +static ClientData +ImgBmapGet(tkwin, masterData) + Tk_Window tkwin; /* Window in which the instance will be + * used. */ + ClientData masterData; /* Pointer to our master structure for the + * image. */ +{ + BitmapMaster *masterPtr = (BitmapMaster *) masterData; + BitmapInstance *instancePtr; + + /* + * See if there is already an instance for this window. If so + * then just re-use it. + */ + + for (instancePtr = masterPtr->instancePtr; instancePtr != NULL; + instancePtr = instancePtr->nextPtr) { + if (instancePtr->tkwin == tkwin) { + instancePtr->refCount++; + return (ClientData) instancePtr; + } + } + + /* + * The image isn't already in use in this window. Make a new + * instance of the image. + */ + + instancePtr = (BitmapInstance *) ckalloc(sizeof(BitmapInstance)); + instancePtr->refCount = 1; + instancePtr->masterPtr = masterPtr; + instancePtr->tkwin = tkwin; + instancePtr->fg = NULL; + instancePtr->bg = NULL; + instancePtr->bitmap = None; + instancePtr->mask = None; + instancePtr->gc = None; + instancePtr->nextPtr = masterPtr->instancePtr; + masterPtr->instancePtr = instancePtr; + ImgBmapConfigureInstance(instancePtr); + + /* + * If this is the first instance, must set the size of the image. + */ + + if (instancePtr->nextPtr == NULL) { + Tk_ImageChanged(masterPtr->tkMaster, 0, 0, 0, 0, masterPtr->width, + masterPtr->height); + } + + return (ClientData) instancePtr; +} + +/* + *---------------------------------------------------------------------- + * + * ImgBmapDisplay -- + * + * This procedure is invoked to draw a bitmap image. + * + * Results: + * None. + * + * Side effects: + * A portion of the image gets rendered in a pixmap or window. + * + *---------------------------------------------------------------------- + */ + +static void +ImgBmapDisplay(clientData, display, drawable, imageX, imageY, width, + height, drawableX, drawableY) + ClientData clientData; /* Pointer to BitmapInstance structure for + * for instance to be displayed. */ + Display *display; /* Display on which to draw image. */ + Drawable drawable; /* Pixmap or window in which to draw image. */ + int imageX, imageY; /* Upper-left corner of region within image + * to draw. */ + int width, height; /* Dimensions of region within image to draw. */ + int drawableX, drawableY; /* Coordinates within drawable that + * correspond to imageX and imageY. */ +{ + BitmapInstance *instancePtr = (BitmapInstance *) clientData; + int masking; + + /* + * If there's no graphics context, it means that an error occurred + * while creating the image instance so it can't be displayed. + */ + + if (instancePtr->gc == None) { + return; + } + + /* + * If masking is in effect, must modify the mask origin within + * the graphics context to line up with the image's origin. + * Then draw the image and reset the clip origin, if there's + * a mask. + */ + + masking = (instancePtr->mask != None) || (instancePtr->bg == NULL); + if (masking) { + XSetClipOrigin(display, instancePtr->gc, drawableX - imageX, + drawableY - imageY); + } + XCopyPlane(display, instancePtr->bitmap, drawable, instancePtr->gc, + imageX, imageY, (unsigned) width, (unsigned) height, + drawableX, drawableY, 1); + if (masking) { + XSetClipOrigin(display, instancePtr->gc, 0, 0); + } +} + +/* + *---------------------------------------------------------------------- + * + * ImgBmapFree -- + * + * This procedure is called when a widget ceases to use a + * particular instance of an image. + * + * Results: + * None. + * + * Side effects: + * Internal data structures get cleaned up. + * + *---------------------------------------------------------------------- + */ + +static void +ImgBmapFree(clientData, display) + ClientData clientData; /* Pointer to BitmapInstance structure for + * for instance to be displayed. */ + Display *display; /* Display containing window that used image. */ +{ + BitmapInstance *instancePtr = (BitmapInstance *) clientData; + BitmapInstance *prevPtr; + + instancePtr->refCount--; + if (instancePtr->refCount > 0) { + return; + } + + /* + * There are no more uses of the image within this widget. Free + * the instance structure. + */ + + if (instancePtr->fg != NULL) { + Tk_FreeColor(instancePtr->fg); + } + if (instancePtr->bg != NULL) { + Tk_FreeColor(instancePtr->bg); + } + if (instancePtr->bitmap != None) { + Tk_FreePixmap(display, instancePtr->bitmap); + } + if (instancePtr->mask != None) { + Tk_FreePixmap(display, instancePtr->mask); + } + if (instancePtr->gc != None) { + Tk_FreeGC(display, instancePtr->gc); + } + if (instancePtr->masterPtr->instancePtr == instancePtr) { + instancePtr->masterPtr->instancePtr = instancePtr->nextPtr; + } else { + for (prevPtr = instancePtr->masterPtr->instancePtr; + prevPtr->nextPtr != instancePtr; prevPtr = prevPtr->nextPtr) { + /* Empty loop body */ + } + prevPtr->nextPtr = instancePtr->nextPtr; + } + ckfree((char *) instancePtr); +} + +/* + *---------------------------------------------------------------------- + * + * ImgBmapDelete -- + * + * This procedure is called by the image code to delete the + * master structure for an image. + * + * Results: + * None. + * + * Side effects: + * Resources associated with the image get freed. + * + *---------------------------------------------------------------------- + */ + +static void +ImgBmapDelete(masterData) + ClientData masterData; /* Pointer to BitmapMaster structure for + * image. Must not have any more instances. */ +{ + BitmapMaster *masterPtr = (BitmapMaster *) masterData; + + if (masterPtr->instancePtr != NULL) { + panic("tried to delete bitmap image when instances still exist"); + } + masterPtr->tkMaster = NULL; + if (masterPtr->imageCmd != NULL) { + Tcl_DeleteCommandFromToken(masterPtr->interp, masterPtr->imageCmd); + } + if (masterPtr->data != NULL) { + ckfree(masterPtr->data); + } + if (masterPtr->maskData != NULL) { + ckfree(masterPtr->maskData); + } + Tk_FreeOptions(configSpecs, (char *) masterPtr, (Display *) NULL, 0); + ckfree((char *) masterPtr); +} + +/* + *---------------------------------------------------------------------- + * + * ImgBmapCmdDeletedProc -- + * + * This procedure is invoked when the image command for an image + * is deleted. It deletes the image. + * + * Results: + * None. + * + * Side effects: + * The image is deleted. + * + *---------------------------------------------------------------------- + */ + +static void +ImgBmapCmdDeletedProc(clientData) + ClientData clientData; /* Pointer to BitmapMaster structure for + * image. */ +{ + BitmapMaster *masterPtr = (BitmapMaster *) clientData; + + masterPtr->imageCmd = NULL; + if (masterPtr->tkMaster != NULL) { + Tk_DeleteImage(masterPtr->interp, Tk_NameOfImage(masterPtr->tkMaster)); + } +} + +/* + *---------------------------------------------------------------------- + * + * GetByte -- + * + * Get the next byte from the open channel. + * + * Results: + * The next byte or EOF. + * + * Side effects: + * We read from the channel. + * + *---------------------------------------------------------------------- + */ + +static int +GetByte(chan) + Tcl_Channel chan; /* The channel we read from. */ +{ + char buffer; + int size; + + size = Tcl_Read(chan, &buffer, 1); + if (size <= 0) { + return EOF; + } else { + return buffer; + } +} diff --git a/generic/tkImgGIF.c b/generic/tkImgGIF.c new file mode 100644 index 0000000..a2ad081 --- /dev/null +++ b/generic/tkImgGIF.c @@ -0,0 +1,1059 @@ +/* + * tkImgGIF.c -- + * + * A photo image file handler for GIF files. Reads 87a and 89a GIF + * files. At present there is no write function. GIF images may be + * read using the -data option of the photo image by representing + * the data as BASE64 encoded ascii. Derived from the giftoppm code + * found in the pbmplus package and tkImgFmtPPM.c in the tk4.0b2 + * distribution. + * + * Copyright (c) Reed Wade (wade@cs.utk.edu), University of Tennessee + * 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. + * + * This file also contains code from the giftoppm program, which is + * copyrighted as follows: + * + * +-------------------------------------------------------------------+ + * | Copyright 1990, David Koblas. | + * | Permission to use, copy, modify, and distribute this software | + * | and its documentation for any purpose and without fee is hereby | + * | granted, provided that the above copyright notice appear in all | + * | copies and that both that copyright notice and this permission | + * | notice appear in supporting documentation. This software is | + * | provided "as is" without express or implied warranty. | + * +-------------------------------------------------------------------+ + * + * SCCS: @(#) tkImgGIF.c 1.19 97/08/13 15:23:45 + */ + +/* + * GIF's are represented as data in base64 format. + * base64 strings consist of 4 6-bit characters -> 3 8 bit bytes. + * A-Z, a-z, 0-9, + and / represent the 64 values (in order). + * '=' is a trailing padding char when the un-encoded data is not a + * multiple of 3 bytes. We'll ignore white space when encountered. + * Any other invalid character is treated as an EOF + */ + +#define GIF_SPECIAL (256) +#define GIF_PAD (GIF_SPECIAL+1) +#define GIF_SPACE (GIF_SPECIAL+2) +#define GIF_BAD (GIF_SPECIAL+3) +#define GIF_DONE (GIF_SPECIAL+4) + +/* + * structure to "mimic" FILE for Mread, so we can look like fread. + * The decoder state keeps track of which byte we are about to read, + * or EOF. + */ + +typedef struct mFile { + unsigned char *data; /* mmencoded source string */ + int c; /* bits left over from previous character */ + int state; /* decoder state (0-4 or GIF_DONE) */ +} MFile; + +#include "tkInt.h" +#include "tkPort.h" + +/* + * The format record for the GIF file format: + */ + +static int FileMatchGIF _ANSI_ARGS_((Tcl_Channel chan, char *fileName, + char *formatString, int *widthPtr, int *heightPtr)); +static int FileReadGIF _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Channel chan, char *fileName, char *formatString, + Tk_PhotoHandle imageHandle, int destX, int destY, + int width, int height, int srcX, int srcY)); +static int StringMatchGIF _ANSI_ARGS_(( char *string, + char *formatString, int *widthPtr, int *heightPtr)); +static int StringReadGIF _ANSI_ARGS_((Tcl_Interp *interp, char *string, + char *formatString, Tk_PhotoHandle imageHandle, + int destX, int destY, int width, int height, + int srcX, int srcY)); + +Tk_PhotoImageFormat tkImgFmtGIF = { + "GIF", /* name */ + FileMatchGIF, /* fileMatchProc */ + StringMatchGIF, /* stringMatchProc */ + FileReadGIF, /* fileReadProc */ + StringReadGIF, /* stringReadProc */ + NULL, /* fileWriteProc */ + NULL, /* stringWriteProc */ +}; + +#define INTERLACE 0x40 +#define LOCALCOLORMAP 0x80 +#define BitSet(byte, bit) (((byte) & (bit)) == (bit)) +#define MAXCOLORMAPSIZE 256 +#define CM_RED 0 +#define CM_GREEN 1 +#define CM_BLUE 2 +#define CM_ALPHA 3 +#define MAX_LWZ_BITS 12 +#define LM_to_uint(a,b) (((b)<<8)|(a)) +#define ReadOK(file,buffer,len) (Fread(buffer, len, 1, file) != 0) + +/* + * HACK ALERT!! HACK ALERT!! HACK ALERT!! + * This code is hard-wired for reading from files. In order to read + * from a data stream, we'll trick fread so we can reuse the same code + */ + +static int fromData=0; + +/* + * Prototypes for local procedures defined in this file: + */ + +static int DoExtension _ANSI_ARGS_((Tcl_Channel chan, int label, + int *transparent)); +static int GetCode _ANSI_ARGS_((Tcl_Channel chan, int code_size, + int flag)); +static int GetDataBlock _ANSI_ARGS_((Tcl_Channel chan, + unsigned char *buf)); +static int LWZReadByte _ANSI_ARGS_((Tcl_Channel chan, int flag, + int input_code_size)); +static int ReadColorMap _ANSI_ARGS_((Tcl_Channel chan, int number, + unsigned char buffer[MAXCOLORMAPSIZE][4])); +static int ReadGIFHeader _ANSI_ARGS_((Tcl_Channel chan, + int *widthPtr, int *heightPtr)); +static int ReadImage _ANSI_ARGS_((Tcl_Interp *interp, + char *imagePtr, Tcl_Channel chan, + int len, int rows, + unsigned char cmap[MAXCOLORMAPSIZE][4], + int width, int height, int srcX, int srcY, + int interlace, int transparent)); + +/* + * these are for the BASE64 image reader code only + */ + +static int Fread _ANSI_ARGS_((unsigned char *dst, size_t size, + size_t count, Tcl_Channel chan)); +static int Mread _ANSI_ARGS_((unsigned char *dst, size_t size, + size_t count, MFile *handle)); +static int Mgetc _ANSI_ARGS_((MFile *handle)); +static int char64 _ANSI_ARGS_((int c)); +static void mInit _ANSI_ARGS_((unsigned char *string, + MFile *handle)); + +/* + *---------------------------------------------------------------------- + * + * FileMatchGIF -- + * + * This procedure is invoked by the photo image type to see if + * a file contains image data in GIF format. + * + * Results: + * The return value is 1 if the first characters in file f look + * like GIF data, and 0 otherwise. + * + * Side effects: + * The access position in f may change. + * + *---------------------------------------------------------------------- + */ + +static int +FileMatchGIF(chan, fileName, formatString, widthPtr, heightPtr) + Tcl_Channel chan; /* The image file, open for reading. */ + char *fileName; /* The name of the image file. */ + char *formatString; /* User-specified format string, or NULL. */ + int *widthPtr, *heightPtr; /* The dimensions of the image are + * returned here if the file is a valid + * raw GIF file. */ +{ + return ReadGIFHeader(chan, widthPtr, heightPtr); +} + +/* + *---------------------------------------------------------------------- + * + * FileReadGIF -- + * + * This procedure is called by the photo image type to read + * GIF format data from a file and write it into a given + * photo image. + * + * Results: + * A standard TCL completion code. If TCL_ERROR is returned + * then an error message is left in interp->result. + * + * Side effects: + * The access position in file f is changed, and new data is + * added to the image given by imageHandle. + * + *---------------------------------------------------------------------- + */ + +static int +FileReadGIF(interp, chan, fileName, formatString, imageHandle, destX, destY, + width, height, srcX, srcY) + Tcl_Interp *interp; /* Interpreter to use for reporting errors. */ + Tcl_Channel chan; /* The image file, open for reading. */ + char *fileName; /* The name of the image file. */ + char *formatString; /* User-specified format string, or NULL. */ + Tk_PhotoHandle imageHandle; /* The photo image to write into. */ + int destX, destY; /* Coordinates of top-left pixel in + * photo image to be written to. */ + int width, height; /* Dimensions of block of photo image to + * be written to. */ + int srcX, srcY; /* Coordinates of top-left pixel to be used + * in image being read. */ +{ + int fileWidth, fileHeight; + int nBytes; + Tk_PhotoImageBlock block; + unsigned char buf[100]; + int bitPixel; + unsigned char colorMap[MAXCOLORMAPSIZE][4]; + int transparent = -1; + + if (!ReadGIFHeader(chan, &fileWidth, &fileHeight)) { + Tcl_AppendResult(interp, "couldn't read GIF header from file \"", + fileName, "\"", NULL); + return TCL_ERROR; + } + if ((fileWidth <= 0) || (fileHeight <= 0)) { + Tcl_AppendResult(interp, "GIF image file \"", fileName, + "\" has dimension(s) <= 0", (char *) NULL); + return TCL_ERROR; + } + + if (Fread(buf, 1, 3, chan) != 3) { + return TCL_OK; + } + bitPixel = 2<<(buf[0]&0x07); + + if (BitSet(buf[0], LOCALCOLORMAP)) { /* Global Colormap */ + if (!ReadColorMap(chan, bitPixel, colorMap)) { + Tcl_AppendResult(interp, "error reading color map", + (char *) NULL); + return TCL_ERROR; + } + } + + if ((srcX + width) > fileWidth) { + width = fileWidth - srcX; + } + if ((srcY + height) > fileHeight) { + height = fileHeight - srcY; + } + if ((width <= 0) || (height <= 0) + || (srcX >= fileWidth) || (srcY >= fileHeight)) { + return TCL_OK; + } + + Tk_PhotoExpand(imageHandle, destX + width, destY + height); + + block.width = width; + block.height = height; + block.pixelSize = 4; + block.pitch = block.pixelSize * block.width; + block.offset[0] = 0; + block.offset[1] = 1; + block.offset[2] = 2; + nBytes = height * block.pitch; + block.pixelPtr = (unsigned char *) ckalloc((unsigned) nBytes); + + while (1) { + if (Fread(buf, 1, 1, chan) != 1) { + /* + * Premature end of image. We should really notify + * the user, but for now just show garbage. + */ + + break; + } + + if (buf[0] == ';') { + /* + * GIF terminator. + */ + + break; + } + + if (buf[0] == '!') { + /* + * This is a GIF extension. + */ + + if (Fread(buf, 1, 1, chan) != 1) { + interp->result = + "error reading extension function code in GIF image"; + goto error; + } + if (DoExtension(chan, buf[0], &transparent) < 0) { + interp->result = "error reading extension in GIF image"; + goto error; + } + continue; + } + + if (buf[0] != ',') { + /* + * Not a valid start character; ignore it. + */ + continue; + } + + if (Fread(buf, 1, 9, chan) != 9) { + interp->result = "couldn't read left/top/width/height in GIF image"; + goto error; + } + + bitPixel = 1<<((buf[8]&0x07)+1); + + if (BitSet(buf[8], LOCALCOLORMAP)) { + if (!ReadColorMap(chan, bitPixel, colorMap)) { + Tcl_AppendResult(interp, "error reading color map", + (char *) NULL); + goto error; + } + } + if (ReadImage(interp, (char *) block.pixelPtr, chan, width, + height, colorMap, fileWidth, fileHeight, srcX, srcY, + BitSet(buf[8], INTERLACE), transparent) != TCL_OK) { + goto error; + } + break; + } + + if (transparent == -1) { + Tk_PhotoPutBlock(imageHandle, &block, destX, destY, width, height); + } else { + int x, y, end; + unsigned char *imagePtr, *rowPtr, *pixelPtr; + + imagePtr = rowPtr = block.pixelPtr; + for (y = 0; y < height; y++) { + x = 0; + pixelPtr = rowPtr; + while(x < width) { + /* search for first non-transparent pixel */ + while ((x < width) && !(pixelPtr[CM_ALPHA])) { + x++; pixelPtr += 4; + } + end = x; + /* search for first transparent pixel */ + while ((end < width) && pixelPtr[CM_ALPHA]) { + end++; pixelPtr += 4; + } + if (end > x) { + block.pixelPtr = rowPtr + 4 * x; + Tk_PhotoPutBlock(imageHandle, &block, destX+x, + destY+y, end-x, 1); + } + x = end; + } + rowPtr += block.pitch; + } + block.pixelPtr = imagePtr; + } + ckfree((char *) block.pixelPtr); + return TCL_OK; + + error: + ckfree((char *) block.pixelPtr); + return TCL_ERROR; + +} + +/* + *---------------------------------------------------------------------- + * + * StringMatchGIF -- + * + * This procedure is invoked by the photo image type to see if + * a string contains image data in GIF format. + * + * Results: + * The return value is 1 if the first characters in the string + * like GIF data, and 0 otherwise. + * + * Side effects: + * the size of the image is placed in widthPre and heightPtr. + * + *---------------------------------------------------------------------- + */ + +static int +StringMatchGIF(string, formatString, widthPtr, heightPtr) + char *string; /* the string containing the image data */ + char *formatString; /* the image format string */ + int *widthPtr; /* where to put the string width */ + int *heightPtr; /* where to put the string height */ +{ + unsigned char header[10]; + int got; + MFile handle; + mInit((unsigned char *) string, &handle); + got = Mread(header, 10, 1, &handle); + if (got != 10 + || ((strncmp("GIF87a", (char *) header, 6) != 0) + && (strncmp("GIF89a", (char *) header, 6) != 0))) { + return 0; + } + *widthPtr = LM_to_uint(header[6],header[7]); + *heightPtr = LM_to_uint(header[8],header[9]); + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * StringReadGif -- -- + * + * This procedure is called by the photo image type to read + * GIF format data from a base64 encoded string, and give it to + * the photo image. + * + * Results: + * A standard TCL completion code. If TCL_ERROR is returned + * then an error message is left in interp->result. + * + * Side effects: + * new data is added to the image given by imageHandle. This + * procedure calls FileReadGif by redefining the operation of + * fprintf temporarily. + * + *---------------------------------------------------------------------- + */ + +static int +StringReadGIF(interp,string,formatString,imageHandle, + destX, destY, width, height, srcX, srcY) + Tcl_Interp *interp; /* interpreter for reporting errors in */ + char *string; /* string containing the image */ + char *formatString; /* format string if any */ + Tk_PhotoHandle imageHandle; /* the image to write this data into */ + int destX, destY; /* The rectangular region of the */ + int width, height; /* image to copy */ + int srcX, srcY; +{ + int result; + MFile handle; + mInit((unsigned char *)string,&handle); + fromData = 1; + result = FileReadGIF(interp, (Tcl_Channel) &handle, "inline data", + formatString, imageHandle, destX, destY, width, height, + srcX, srcY); + fromData = 0; + return(result); +} + +/* + *---------------------------------------------------------------------- + * + * ReadGIFHeader -- + * + * This procedure reads the GIF header from the beginning of a + * GIF file and returns the dimensions of the image. + * + * Results: + * The return value is 1 if file "f" appears to start with + * a valid GIF header, 0 otherwise. If the header is valid, + * then *widthPtr and *heightPtr are modified to hold the + * dimensions of the image. + * + * Side effects: + * The access position in f advances. + * + *---------------------------------------------------------------------- + */ + +static int +ReadGIFHeader(chan, widthPtr, heightPtr) + Tcl_Channel chan; /* Image file to read the header from */ + int *widthPtr, *heightPtr; /* The dimensions of the image are + * returned here. */ +{ + unsigned char buf[7]; + + if ((Fread(buf, 1, 6, chan) != 6) + || ((strncmp("GIF87a", (char *) buf, 6) != 0) + && (strncmp("GIF89a", (char *) buf, 6) != 0))) { + return 0; + } + + if (Fread(buf, 1, 4, chan) != 4) { + return 0; + } + + *widthPtr = LM_to_uint(buf[0],buf[1]); + *heightPtr = LM_to_uint(buf[2],buf[3]); + return 1; +} + +/* + *----------------------------------------------------------------- + * The code below is copied from the giftoppm program and modified + * just slightly. + *----------------------------------------------------------------- + */ + +static int +ReadColorMap(chan, number, buffer) + Tcl_Channel chan; + int number; + unsigned char buffer[MAXCOLORMAPSIZE][4]; +{ + int i; + unsigned char rgb[3]; + + for (i = 0; i < number; ++i) { + if (! ReadOK(chan, rgb, sizeof(rgb))) { + return 0; + } + + buffer[i][CM_RED] = rgb[0] ; + buffer[i][CM_GREEN] = rgb[1] ; + buffer[i][CM_BLUE] = rgb[2] ; + buffer[i][CM_ALPHA] = 255 ; + } + return 1; +} + + + +static int +DoExtension(chan, label, transparent) + Tcl_Channel chan; + int label; + int *transparent; +{ + static unsigned char buf[256]; + int count; + + switch (label) { + case 0x01: /* Plain Text Extension */ + break; + + case 0xff: /* Application Extension */ + break; + + case 0xfe: /* Comment Extension */ + do { + count = GetDataBlock(chan, (unsigned char*) buf); + } while (count > 0); + return count; + + case 0xf9: /* Graphic Control Extension */ + count = GetDataBlock(chan, (unsigned char*) buf); + if (count < 0) { + return 1; + } + if ((buf[0] & 0x1) != 0) { + *transparent = buf[3]; + } + + do { + count = GetDataBlock(chan, (unsigned char*) buf); + } while (count > 0); + return count; + } + + do { + count = GetDataBlock(chan, (unsigned char*) buf); + } while (count > 0); + return count; +} + +static int ZeroDataBlock = 0; + +static int +GetDataBlock(chan, buf) + Tcl_Channel chan; + unsigned char *buf; +{ + unsigned char count; + + if (! ReadOK(chan, &count,1)) { + return -1; + } + + ZeroDataBlock = count == 0; + + if ((count != 0) && (! ReadOK(chan, buf, count))) { + return -1; + } + + return count; +} + + +static int +ReadImage(interp, imagePtr, chan, len, rows, cmap, + width, height, srcX, srcY, interlace, transparent) + Tcl_Interp *interp; + char *imagePtr; + Tcl_Channel chan; + int len, rows; + unsigned char cmap[MAXCOLORMAPSIZE][4]; + int width, height; + int srcX, srcY; + int interlace; + int transparent; +{ + unsigned char c; + int v; + int xpos = 0, ypos = 0, pass = 0; + char *pixelPtr; + + + /* + * Initialize the Compression routines + */ + if (! ReadOK(chan, &c, 1)) { + Tcl_AppendResult(interp, "error reading GIF image: ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + + if (LWZReadByte(chan, 1, c) < 0) { + interp->result = "format error in GIF image"; + return TCL_ERROR; + } + + if (transparent!=-1) { + cmap[transparent][CM_RED] = 0; + cmap[transparent][CM_GREEN] = 0; + cmap[transparent][CM_BLUE] = 0; + cmap[transparent][CM_ALPHA] = 0; + } + + pixelPtr = imagePtr; + while ((v = LWZReadByte(chan, 0, c)) >= 0 ) { + + if ((xpos>=srcX) && (xpos=srcY) && (ypos= height) { + ++pass; + switch (pass) { + case 1: + ypos = 4; break; + case 2: + ypos = 2; break; + case 3: + ypos = 1; break; + default: + return TCL_OK; + } + } + } else { + ++ypos; + } + pixelPtr = imagePtr + (ypos-srcY) * len * 4; + } + if (ypos >= height) + break; + } + return TCL_OK; +} + +static int +LWZReadByte(chan, flag, input_code_size) + Tcl_Channel chan; + int flag; + int input_code_size; +{ + static int fresh = 0; + int code, incode; + static int code_size, set_code_size; + static int max_code, max_code_size; + static int firstcode, oldcode; + static int clear_code, end_code; + static int table[2][(1<< MAX_LWZ_BITS)]; + static int stack[(1<<(MAX_LWZ_BITS))*2], *sp; + register int i; + + if (flag) { + set_code_size = input_code_size; + code_size = set_code_size+1; + clear_code = 1 << set_code_size ; + end_code = clear_code + 1; + max_code_size = 2*clear_code; + max_code = clear_code+2; + + GetCode(chan, 0, 1); + + fresh = 1; + + for (i = 0; i < clear_code; ++i) { + table[0][i] = 0; + table[1][i] = i; + } + for (; i < (1< stack) { + return *--sp; + } + + while ((code = GetCode(chan, code_size, 0)) >= 0) { + if (code == clear_code) { + for (i = 0; i < clear_code; ++i) { + table[0][i] = 0; + table[1][i] = i; + } + + for (; i < (1< 0) + /* Empty body */; + + if (count != 0) { + return -2; + } + } + + incode = code; + + if (code >= max_code) { + *sp++ = firstcode; + code = oldcode; + } + + while (code >= clear_code) { + *sp++ = table[1][code]; + if (code == table[0][code]) { + return -2; + + /* + * Used to be this instead, Steve Ball suggested + * the change to just return. + printf("circular table entry BIG ERROR\n"); + */ + } + code = table[0][code]; + } + + *sp++ = firstcode = table[1][code]; + + if ((code = max_code) <(1<=max_code_size) && (max_code_size < (1< stack) + return *--sp; + } + return code; +} + + +static int +GetCode(chan, code_size, flag) + Tcl_Channel chan; + int code_size; + int flag; +{ + static unsigned char buf[280]; + static int curbit, lastbit, done, last_byte; + int i, j, ret; + unsigned char count; + + if (flag) { + curbit = 0; + lastbit = 0; + done = 0; + return 0; + } + + + if ( (curbit+code_size) >= lastbit) { + if (done) { + /* ran off the end of my bits */ + return -1; + } + if (last_byte >= 2) { + buf[0] = buf[last_byte-2]; + } + if (last_byte >= 1) { + buf[1] = buf[last_byte-1]; + } + + if ((count = GetDataBlock(chan, &buf[2])) == 0) { + done = 1; + } + + last_byte = 2 + count; + curbit = (curbit - lastbit) + 16; + lastbit = (2+count)*8 ; + } + + ret = 0; + for (i = curbit, j = 0; j < code_size; ++i, ++j) { + ret |= ((buf[ i / 8 ] & (1 << (i % 8))) != 0) << j; + } + + curbit += code_size; + + return ret; +} + +/* + *---------------------------------------------------------------------- + * + * Minit -- -- + * + * This procedure initializes a base64 decoder handle + * + * Results: + * none + * + * Side effects: + * the base64 handle is initialized + * + *---------------------------------------------------------------------- + */ + +static void +mInit(string, handle) + unsigned char *string; /* string containing initial mmencoded data */ + MFile *handle; /* mmdecode "file" handle */ +{ + handle->data = string; + handle->state = 0; +} + +/* + *---------------------------------------------------------------------- + * + * Mread -- + * + * This procedure is invoked by the GIF file reader as a + * temporary replacement for "fread", to get GIF data out + * of a string (using Mgetc). + * + * Results: + * The return value is the number of characters "read" + * + * Side effects: + * The base64 handle will change state. + * + *---------------------------------------------------------------------- + */ + +static int +Mread(dst, chunkSize, numChunks, handle) + unsigned char *dst; /* where to put the result */ + size_t chunkSize; /* size of each transfer */ + size_t numChunks; /* number of chunks */ + MFile *handle; /* mmdecode "file" handle */ +{ + register int i, c; + int count = chunkSize * numChunks; + + for(i=0; istate == GIF_DONE) { + return(GIF_DONE); + } + + do { + c = char64(*handle->data); + handle->data++; + } while (c==GIF_SPACE); + + if (c>GIF_SPECIAL) { + handle->state = GIF_DONE; + return(handle->state ? handle->c : GIF_DONE); + } + + switch (handle->state++) { + case 0: + handle->c = c<<2; + result = Mgetc(handle); + break; + case 1: + result = handle->c | (c>>4); + handle->c = (c&0xF)<<4; + break; + case 2: + result = handle->c | (c>>2); + handle->c = (c&0x3) << 6; + break; + case 3: + result = handle->c | c; + handle->state = 0; + break; + } + return(result); +} + +/* + *---------------------------------------------------------------------- + * + * char64 -- + * + * This procedure converts a base64 ascii character into its binary + * equivalent. This code is a slightly modified version of the + * char64 proc in N. Borenstein's metamail decoder. + * + * Results: + * The binary value, or an error code. + * + * Side effects: + * None. + *---------------------------------------------------------------------- + */ + +static int +char64(c) +int c; +{ + switch(c) { + case 'A': return(0); case 'B': return(1); case 'C': return(2); + case 'D': return(3); case 'E': return(4); case 'F': return(5); + case 'G': return(6); case 'H': return(7); case 'I': return(8); + case 'J': return(9); case 'K': return(10); case 'L': return(11); + case 'M': return(12); case 'N': return(13); case 'O': return(14); + case 'P': return(15); case 'Q': return(16); case 'R': return(17); + case 'S': return(18); case 'T': return(19); case 'U': return(20); + case 'V': return(21); case 'W': return(22); case 'X': return(23); + case 'Y': return(24); case 'Z': return(25); case 'a': return(26); + case 'b': return(27); case 'c': return(28); case 'd': return(29); + case 'e': return(30); case 'f': return(31); case 'g': return(32); + case 'h': return(33); case 'i': return(34); case 'j': return(35); + case 'k': return(36); case 'l': return(37); case 'm': return(38); + case 'n': return(39); case 'o': return(40); case 'p': return(41); + case 'q': return(42); case 'r': return(43); case 's': return(44); + case 't': return(45); case 'u': return(46); case 'v': return(47); + case 'w': return(48); case 'x': return(49); case 'y': return(50); + case 'z': return(51); case '0': return(52); case '1': return(53); + case '2': return(54); case '3': return(55); case '4': return(56); + case '5': return(57); case '6': return(58); case '7': return(59); + case '8': return(60); case '9': return(61); case '+': return(62); + case '/': return(63); + + case ' ': case '\t': case '\n': case '\r': case '\f': return(GIF_SPACE); + case '=': return(GIF_PAD); + case '\0': return(GIF_DONE); + default: return(GIF_BAD); + } +} + +/* + *---------------------------------------------------------------------- + * + * Fread -- + * + * This procedure calls either fread or Mread to read data + * from a file or a base64 encoded string. + * + * Results: - same as fread + * + *---------------------------------------------------------------------- + */ + +static int +Fread(dst, hunk, count, chan) + unsigned char *dst; /* where to put the result */ + size_t hunk,count; /* how many */ + Tcl_Channel chan; +{ + if (fromData) { + return(Mread(dst, hunk, count, (MFile *) chan)); + } else { + return Tcl_Read(chan, (char *) dst, (int) (hunk * count)); + } +} diff --git a/generic/tkImgPPM.c b/generic/tkImgPPM.c new file mode 100644 index 0000000..3a54003 --- /dev/null +++ b/generic/tkImgPPM.c @@ -0,0 +1,421 @@ +/* + * tkImgPPM.c -- + * + * A photo image file handler for PPM (Portable PixMap) files. + * + * Copyright (c) 1994 The Australian National University. + * 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. + * + * Author: Paul Mackerras (paulus@cs.anu.edu.au), + * Department of Computer Science, + * Australian National University. + * + * SCCS: @(#) tkImgPPM.c 1.16 97/10/28 14:51:46 + */ + +#include "tkInt.h" +#include "tkPort.h" + +/* + * The maximum amount of memory to allocate for data read from the + * file. If we need more than this, we do it in pieces. + */ + +#define MAX_MEMORY 10000 /* don't allocate > 10KB */ + +/* + * Define PGM and PPM, i.e. gray images and color images. + */ + +#define PGM 1 +#define PPM 2 + +/* + * The format record for the PPM file format: + */ + +static int FileMatchPPM _ANSI_ARGS_((Tcl_Channel chan, + char *fileName, char *formatString, + int *widthPtr, int *heightPtr)); +static int FileReadPPM _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Channel chan, char *fileName, + char *formatString, Tk_PhotoHandle imageHandle, + int destX, int destY, int width, int height, + int srcX, int srcY)); +static int FileWritePPM _ANSI_ARGS_((Tcl_Interp *interp, + char *fileName, char *formatString, + Tk_PhotoImageBlock *blockPtr)); + +Tk_PhotoImageFormat tkImgFmtPPM = { + "PPM", /* name */ + FileMatchPPM, /* fileMatchProc */ + NULL, /* stringMatchProc */ + FileReadPPM, /* fileReadProc */ + NULL, /* stringReadProc */ + FileWritePPM, /* fileWriteProc */ + NULL, /* stringWriteProc */ +}; + +/* + * Prototypes for local procedures defined in this file: + */ + +static int ReadPPMFileHeader _ANSI_ARGS_((Tcl_Channel chan, + int *widthPtr, int *heightPtr, + int *maxIntensityPtr)); + +/* + *---------------------------------------------------------------------- + * + * FileMatchPPM -- + * + * This procedure is invoked by the photo image type to see if + * a file contains image data in PPM format. + * + * Results: + * The return value is >0 if the first characters in file "f" look + * like PPM data, and 0 otherwise. + * + * Side effects: + * The access position in f may change. + * + *---------------------------------------------------------------------- + */ + +static int +FileMatchPPM(chan, fileName, formatString, widthPtr, heightPtr) + Tcl_Channel chan; /* The image file, open for reading. */ + char *fileName; /* The name of the image file. */ + char *formatString; /* User-specified format string, or NULL. */ + int *widthPtr, *heightPtr; /* The dimensions of the image are + * returned here if the file is a valid + * raw PPM file. */ +{ + int dummy; + + return ReadPPMFileHeader(chan, widthPtr, heightPtr, &dummy); +} + +/* + *---------------------------------------------------------------------- + * + * FileReadPPM -- + * + * This procedure is called by the photo image type to read + * PPM format data from a file and write it into a given + * photo image. + * + * Results: + * A standard TCL completion code. If TCL_ERROR is returned + * then an error message is left in interp->result. + * + * Side effects: + * The access position in file f is changed, and new data is + * added to the image given by imageHandle. + * + *---------------------------------------------------------------------- + */ + +static int +FileReadPPM(interp, chan, fileName, formatString, imageHandle, destX, destY, + width, height, srcX, srcY) + Tcl_Interp *interp; /* Interpreter to use for reporting errors. */ + Tcl_Channel chan; /* The image file, open for reading. */ + char *fileName; /* The name of the image file. */ + char *formatString; /* User-specified format string, or NULL. */ + Tk_PhotoHandle imageHandle; /* The photo image to write into. */ + int destX, destY; /* Coordinates of top-left pixel in + * photo image to be written to. */ + int width, height; /* Dimensions of block of photo image to + * be written to. */ + int srcX, srcY; /* Coordinates of top-left pixel to be used + * in image being read. */ +{ + int fileWidth, fileHeight, maxIntensity; + int nLines, nBytes, h, type, count; + unsigned char *pixelPtr; + Tk_PhotoImageBlock block; + + type = ReadPPMFileHeader(chan, &fileWidth, &fileHeight, &maxIntensity); + if (type == 0) { + Tcl_AppendResult(interp, "couldn't read raw PPM header from file \"", + fileName, "\"", NULL); + return TCL_ERROR; + } + if ((fileWidth <= 0) || (fileHeight <= 0)) { + Tcl_AppendResult(interp, "PPM image file \"", fileName, + "\" has dimension(s) <= 0", (char *) NULL); + return TCL_ERROR; + } + if ((maxIntensity <= 0) || (maxIntensity >= 256)) { + char buffer[30]; + + sprintf(buffer, "%d", maxIntensity); + Tcl_AppendResult(interp, "PPM image file \"", fileName, + "\" has bad maximum intensity value ", buffer, + (char *) NULL); + return TCL_ERROR; + } + + if ((srcX + width) > fileWidth) { + width = fileWidth - srcX; + } + if ((srcY + height) > fileHeight) { + height = fileHeight - srcY; + } + if ((width <= 0) || (height <= 0) + || (srcX >= fileWidth) || (srcY >= fileHeight)) { + return TCL_OK; + } + + if (type == PGM) { + block.pixelSize = 1; + block.offset[0] = 0; + block.offset[1] = 0; + block.offset[2] = 0; + } + else { + block.pixelSize = 3; + block.offset[0] = 0; + block.offset[1] = 1; + block.offset[2] = 2; + } + block.width = width; + block.pitch = block.pixelSize * fileWidth; + + Tk_PhotoExpand(imageHandle, destX + width, destY + height); + + if (srcY > 0) { + Tcl_Seek(chan, (srcY * block.pitch), SEEK_CUR); + } + + nLines = (MAX_MEMORY + block.pitch - 1) / block.pitch; + if (nLines > height) { + nLines = height; + } + if (nLines <= 0) { + nLines = 1; + } + nBytes = nLines * block.pitch; + pixelPtr = (unsigned char *) ckalloc((unsigned) nBytes); + block.pixelPtr = pixelPtr + srcX * block.pixelSize; + + for (h = height; h > 0; h -= nLines) { + if (nLines > h) { + nLines = h; + nBytes = nLines * block.pitch; + } + count = Tcl_Read(chan, (char *) pixelPtr, nBytes); + if (count != nBytes) { + Tcl_AppendResult(interp, "error reading PPM image file \"", + fileName, "\": ", + Tcl_Eof(chan) ? "not enough data" : Tcl_PosixError(interp), + (char *) NULL); + ckfree((char *) pixelPtr); + return TCL_ERROR; + } + if (maxIntensity != 255) { + unsigned char *p; + + for (p = pixelPtr; count > 0; count--, p++) { + *p = (((int) *p) * 255)/maxIntensity; + } + } + block.height = nLines; + Tk_PhotoPutBlock(imageHandle, &block, destX, destY, width, nLines); + destY += nLines; + } + + ckfree((char *) pixelPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FileWritePPM -- + * + * This procedure is invoked to write image data to a file in PPM + * format. + * + * Results: + * A standard TCL completion code. If TCL_ERROR is returned + * then an error message is left in interp->result. + * + * Side effects: + * Data is written to the file given by "fileName". + * + *---------------------------------------------------------------------- + */ + +static int +FileWritePPM(interp, fileName, formatString, blockPtr) + Tcl_Interp *interp; + char *fileName; + char *formatString; + Tk_PhotoImageBlock *blockPtr; +{ + Tcl_Channel chan; + int w, h; + int greenOffset, blueOffset, nBytes; + unsigned char *pixelPtr, *pixLinePtr; + char header[30]; + + chan = Tcl_OpenFileChannel(interp, fileName, "w", 0666); + if (chan == NULL) { + return TCL_ERROR; + } + + sprintf(header, "P6\n%d %d\n255\n", blockPtr->width, blockPtr->height); + Tcl_Write(chan, header, -1); + + pixLinePtr = blockPtr->pixelPtr + blockPtr->offset[0]; + greenOffset = blockPtr->offset[1] - blockPtr->offset[0]; + blueOffset = blockPtr->offset[2] - blockPtr->offset[0]; + + if ((greenOffset == 1) && (blueOffset == 2) && (blockPtr->pixelSize == 3) + && (blockPtr->pitch == (blockPtr->width * 3))) { + nBytes = blockPtr->height * blockPtr->pitch; + if (Tcl_Write(chan, (char *) pixLinePtr, nBytes) != nBytes) { + goto writeerror; + } + } else { + for (h = blockPtr->height; h > 0; h--) { + pixelPtr = pixLinePtr; + for (w = blockPtr->width; w > 0; w--) { + if ((Tcl_Write(chan, (char *) &pixelPtr[0], 1) == -1) + || (Tcl_Write(chan, (char *) &pixelPtr[greenOffset], 1) == -1) + || (Tcl_Write(chan, (char *) &pixelPtr[blueOffset], 1) == -1)) { + goto writeerror; + } + pixelPtr += blockPtr->pixelSize; + } + pixLinePtr += blockPtr->pitch; + } + } + + if (Tcl_Close(NULL, chan) == 0) { + return TCL_OK; + } + chan = NULL; + + writeerror: + Tcl_AppendResult(interp, "error writing \"", fileName, "\": ", + Tcl_PosixError(interp), (char *) NULL); + if (chan != NULL) { + Tcl_Close(NULL, chan); + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * ReadPPMFileHeader -- + * + * This procedure reads the PPM header from the beginning of a + * PPM file and returns information from the header. + * + * Results: + * The return value is PGM if file "f" appears to start with + * a valid PGM header, PPM if "f" appears to start with a valid + * PPM header, and 0 otherwise. If the header is valid, + * then *widthPtr and *heightPtr are modified to hold the + * dimensions of the image and *maxIntensityPtr is modified to + * hold the value of a "fully on" intensity value. + * + * Side effects: + * The access position in f advances. + * + *---------------------------------------------------------------------- + */ + +static int +ReadPPMFileHeader(chan, widthPtr, heightPtr, maxIntensityPtr) + Tcl_Channel chan; /* Image file to read the header from */ + int *widthPtr, *heightPtr; /* The dimensions of the image are + * returned here. */ + int *maxIntensityPtr; /* The maximum intensity value for + * the image is stored here. */ +{ +#define BUFFER_SIZE 1000 + char buffer[BUFFER_SIZE]; + int i, numFields, firstInLine; + int type = 0; + char c; + + /* + * Read 4 space-separated fields from the file, ignoring + * comments (any line that starts with "#"). + */ + + if (Tcl_Read(chan, &c, 1) != 1) { + return 0; + } + firstInLine = 1; + i = 0; + for (numFields = 0; numFields < 4; numFields++) { + /* + * Skip comments and white space. + */ + + while (1) { + while (isspace(UCHAR(c))) { + firstInLine = (c == '\n'); + if (Tcl_Read(chan, &c, 1) != 1) { + return 0; + } + } + if (c != '#') { + break; + } + do { + if (Tcl_Read(chan, &c, 1) != 1) { + return 0; + } + } while (c != '\n'); + firstInLine = 1; + } + + /* + * Read a field (everything up to the next white space). + */ + + while (!isspace(UCHAR(c))) { + if (i < (BUFFER_SIZE-2)) { + buffer[i] = c; + i++; + } + if (Tcl_Read(chan, &c, 1) != 1) { + goto done; + } + } + if (i < (BUFFER_SIZE-1)) { + buffer[i] = ' '; + i++; + } + firstInLine = 0; + } + done: + buffer[i] = 0; + + /* + * Parse the fields, which are: id, width, height, maxIntensity. + */ + + if (strncmp(buffer, "P6 ", 3) == 0) { + type = PPM; + } else if (strncmp(buffer, "P5 ", 3) == 0) { + type = PGM; + } else { + return 0; + } + if (sscanf(buffer+3, "%d %d %d", widthPtr, heightPtr, maxIntensityPtr) + != 3) { + return 0; + } + return type; +} diff --git a/generic/tkImgPhoto.c b/generic/tkImgPhoto.c new file mode 100644 index 0000000..86fbf80 --- /dev/null +++ b/generic/tkImgPhoto.c @@ -0,0 +1,4144 @@ +/* + * tkImgPhoto.c -- + * + * Implements images of type "photo" for Tk. Photo images are + * stored in full color (24 bits per pixel) and displayed using + * dithering if necessary. + * + * Copyright (c) 1994 The Australian National University. + * 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. + * + * Author: Paul Mackerras (paulus@cs.anu.edu.au), + * Department of Computer Science, + * Australian National University. + * + * SCCS: @(#) tkImgPhoto.c 1.60 97/08/08 11:32:46 + */ + +#include "tkInt.h" +#include "tkPort.h" +#include "tclMath.h" +#include + +/* + * Declaration for internal Xlib function used here: + */ + +extern _XInitImageFuncPtrs _ANSI_ARGS_((XImage *image)); + +/* + * A signed 8-bit integral type. If chars are unsigned and the compiler + * isn't an ANSI one, then we have to use short instead (which wastes + * space) to get signed behavior. + */ + +#if defined(__STDC__) || defined(_AIX) + typedef signed char schar; +#else +# ifndef __CHAR_UNSIGNED__ + typedef char schar; +# else + typedef short schar; +# endif +#endif + +/* + * An unsigned 32-bit integral type, used for pixel values. + * We use int rather than long here to accommodate those systems + * where longs are 64 bits. + */ + +typedef unsigned int pixel; + +/* + * The maximum number of pixels to transmit to the server in a + * single XPutImage call. + */ + +#define MAX_PIXELS 65536 + +/* + * The set of colors required to display a photo image in a window depends on: + * - the visual used by the window + * - the palette, which specifies how many levels of each primary + * color to use, and + * - the gamma value for the image. + * + * Pixel values allocated for specific colors are valid only for the + * colormap in which they were allocated. Sets of pixel values + * allocated for displaying photos are re-used in other windows if + * possible, that is, if the display, colormap, palette and gamma + * values match. A hash table is used to locate these sets of pixel + * values, using the following data structure as key: + */ + +typedef struct { + Display *display; /* Qualifies the colormap resource ID */ + Colormap colormap; /* Colormap that the windows are using. */ + double gamma; /* Gamma exponent value for images. */ + Tk_Uid palette; /* Specifies how many shades of each primary + * we want to allocate. */ +} ColorTableId; + +/* + * For a particular (display, colormap, palette, gamma) combination, + * a data structure of the following type is used to store the allocated + * pixel values and other information: + */ + +typedef struct ColorTable { + ColorTableId id; /* Information used in selecting this + * color table. */ + int flags; /* See below. */ + int refCount; /* Number of instances using this map. */ + int liveRefCount; /* Number of instances which are actually + * in use, using this map. */ + int numColors; /* Number of colors allocated for this map. */ + + XVisualInfo visualInfo; /* Information about the visual for windows + * using this color table. */ + + pixel redValues[256]; /* Maps 8-bit values of red intensity + * to a pixel value or index in pixelMap. */ + pixel greenValues[256]; /* Ditto for green intensity */ + pixel blueValues[256]; /* Ditto for blue intensity */ + unsigned long *pixelMap; /* Actual pixel values allocated. */ + + unsigned char colorQuant[3][256]; + /* Maps 8-bit intensities to quantized + * intensities. The first index is 0 for + * red, 1 for green, 2 for blue. */ +} ColorTable; + +/* + * Bit definitions for the flags field of a ColorTable. + * BLACK_AND_WHITE: 1 means only black and white colors are + * available. + * COLOR_WINDOW: 1 means a full 3-D color cube has been + * allocated. + * DISPOSE_PENDING: 1 means a call to DisposeColorTable has + * been scheduled as an idle handler, but it + * hasn't been invoked yet. + * MAP_COLORS: 1 means pixel values should be mapped + * through pixelMap. + */ + +#define BLACK_AND_WHITE 1 +#define COLOR_WINDOW 2 +#define DISPOSE_PENDING 4 +#define MAP_COLORS 8 + +/* + * Definition of the data associated with each photo image master. + */ + +typedef struct PhotoMaster { + Tk_ImageMaster tkMaster; /* Tk's token for image master. NULL means + * the image is being deleted. */ + Tcl_Interp *interp; /* Interpreter associated with the + * application using this image. */ + Tcl_Command imageCmd; /* Token for image command (used to delete + * it when the image goes away). NULL means + * the image command has already been + * deleted. */ + int flags; /* Sundry flags, defined below. */ + int width, height; /* Dimensions of image. */ + int userWidth, userHeight; /* User-declared image dimensions. */ + Tk_Uid palette; /* User-specified default palette for + * instances of this image. */ + double gamma; /* Display gamma value to correct for. */ + char *fileString; /* Name of file to read into image. */ + char *dataString; /* String value to use as contents of image. */ + char *format; /* User-specified format of data in image + * file or string value. */ + unsigned char *pix24; /* Local storage for 24-bit image. */ + int ditherX, ditherY; /* Location of first incorrectly + * dithered pixel in image. */ + TkRegion validRegion; /* Tk region indicating which parts of + * the image have valid image data. */ + struct PhotoInstance *instancePtr; + /* First in the list of instances + * associated with this master. */ +} PhotoMaster; + +/* + * Bit definitions for the flags field of a PhotoMaster. + * COLOR_IMAGE: 1 means that the image has different color + * components. + * IMAGE_CHANGED: 1 means that the instances of this image + * need to be redithered. + */ + +#define COLOR_IMAGE 1 +#define IMAGE_CHANGED 2 + +/* + * The following data structure represents all of the instances of + * a photo image in windows on a given screen that are using the + * same colormap. + */ + +typedef struct PhotoInstance { + PhotoMaster *masterPtr; /* Pointer to master for image. */ + Display *display; /* Display for windows using this instance. */ + Colormap colormap; /* The image may only be used in windows with + * this particular colormap. */ + struct PhotoInstance *nextPtr; + /* Pointer to the next instance in the list + * of instances associated with this master. */ + int refCount; /* Number of instances using this structure. */ + Tk_Uid palette; /* Palette for these particular instances. */ + double gamma; /* Gamma value for these instances. */ + Tk_Uid defaultPalette; /* Default palette to use if a palette + * is not specified for the master. */ + ColorTable *colorTablePtr; /* Pointer to information about colors + * allocated for image display in windows + * like this one. */ + Pixmap pixels; /* X pixmap containing dithered image. */ + int width, height; /* Dimensions of the pixmap. */ + schar *error; /* Error image, used in dithering. */ + XImage *imagePtr; /* Image structure for converted pixels. */ + XVisualInfo visualInfo; /* Information about the visual that these + * windows are using. */ + GC gc; /* Graphics context for writing images + * to the pixmap. */ +} PhotoInstance; + +/* + * The following data structure is used to return information + * from ParseSubcommandOptions: + */ + +struct SubcommandOptions { + int options; /* Individual bits indicate which + * options were specified - see below. */ + char *name; /* Name specified without an option. */ + int fromX, fromY; /* Values specified for -from option. */ + int fromX2, fromY2; /* Second coordinate pair for -from option. */ + int toX, toY; /* Values specified for -to option. */ + int toX2, toY2; /* Second coordinate pair for -to option. */ + int zoomX, zoomY; /* Values specified for -zoom option. */ + int subsampleX, subsampleY; /* Values specified for -subsample option. */ + char *format; /* Value specified for -format option. */ +}; + +/* + * Bit definitions for use with ParseSubcommandOptions: + * Each bit is set in the allowedOptions parameter on a call to + * ParseSubcommandOptions if that option is allowed for the current + * photo image subcommand. On return, the bit is set in the options + * field of the SubcommandOptions structure if that option was specified. + * + * OPT_FORMAT: Set if -format option allowed/specified. + * OPT_FROM: Set if -from option allowed/specified. + * OPT_SHRINK: Set if -shrink option allowed/specified. + * OPT_SUBSAMPLE: Set if -subsample option allowed/spec'd. + * OPT_TO: Set if -to option allowed/specified. + * OPT_ZOOM: Set if -zoom option allowed/specified. + */ + +#define OPT_FORMAT 1 +#define OPT_FROM 2 +#define OPT_SHRINK 4 +#define OPT_SUBSAMPLE 8 +#define OPT_TO 0x10 +#define OPT_ZOOM 0x20 + +/* + * List of option names. The order here must match the order of + * declarations of the OPT_* constants above. + */ + +static char *optionNames[] = { + "-format", + "-from", + "-shrink", + "-subsample", + "-to", + "-zoom", + (char *) NULL +}; + +/* + * The type record for photo images: + */ + +static int ImgPhotoCreate _ANSI_ARGS_((Tcl_Interp *interp, + char *name, int argc, char **argv, + Tk_ImageType *typePtr, Tk_ImageMaster master, + ClientData *clientDataPtr)); +static ClientData ImgPhotoGet _ANSI_ARGS_((Tk_Window tkwin, + ClientData clientData)); +static void ImgPhotoDisplay _ANSI_ARGS_((ClientData clientData, + Display *display, Drawable drawable, + int imageX, int imageY, int width, int height, + int drawableX, int drawableY)); +static void ImgPhotoFree _ANSI_ARGS_((ClientData clientData, + Display *display)); +static void ImgPhotoDelete _ANSI_ARGS_((ClientData clientData)); + +Tk_ImageType tkPhotoImageType = { + "photo", /* name */ + ImgPhotoCreate, /* createProc */ + ImgPhotoGet, /* getProc */ + ImgPhotoDisplay, /* displayProc */ + ImgPhotoFree, /* freeProc */ + ImgPhotoDelete, /* deleteProc */ + (Tk_ImageType *) NULL /* nextPtr */ +}; + +/* + * Default configuration + */ + +#define DEF_PHOTO_GAMMA "1" +#define DEF_PHOTO_HEIGHT "0" +#define DEF_PHOTO_PALETTE "" +#define DEF_PHOTO_WIDTH "0" + +/* + * Information used for parsing configuration specifications: + */ +static Tk_ConfigSpec configSpecs[] = { + {TK_CONFIG_STRING, "-data", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(PhotoMaster, dataString), TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-format", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(PhotoMaster, format), TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-file", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(PhotoMaster, fileString), TK_CONFIG_NULL_OK}, + {TK_CONFIG_DOUBLE, "-gamma", (char *) NULL, (char *) NULL, + DEF_PHOTO_GAMMA, Tk_Offset(PhotoMaster, gamma), 0}, + {TK_CONFIG_INT, "-height", (char *) NULL, (char *) NULL, + DEF_PHOTO_HEIGHT, Tk_Offset(PhotoMaster, userHeight), 0}, + {TK_CONFIG_UID, "-palette", (char *) NULL, (char *) NULL, + DEF_PHOTO_PALETTE, Tk_Offset(PhotoMaster, palette), 0}, + {TK_CONFIG_INT, "-width", (char *) NULL, (char *) NULL, + DEF_PHOTO_WIDTH, Tk_Offset(PhotoMaster, userWidth), 0}, + {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, 0} +}; + +/* + * Hash table used to hash from (display, colormap, palette, gamma) + * to ColorTable address. + */ + +static Tcl_HashTable imgPhotoColorHash; +static int imgPhotoColorHashInitialized; +#define N_COLOR_HASH (sizeof(ColorTableId) / sizeof(int)) + +/* + * Pointer to the first in the list of known photo image formats. + */ + +static Tk_PhotoImageFormat *formatList = NULL; + +/* + * Forward declarations + */ + +static int ImgPhotoCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static int ParseSubcommandOptions _ANSI_ARGS_(( + struct SubcommandOptions *optPtr, + Tcl_Interp *interp, int allowedOptions, + int *indexPtr, int argc, char **argv)); +static void ImgPhotoCmdDeletedProc _ANSI_ARGS_(( + ClientData clientData)); +static int ImgPhotoConfigureMaster _ANSI_ARGS_(( + Tcl_Interp *interp, PhotoMaster *masterPtr, + int argc, char **argv, int flags)); +static void ImgPhotoConfigureInstance _ANSI_ARGS_(( + PhotoInstance *instancePtr)); +static void ImgPhotoSetSize _ANSI_ARGS_((PhotoMaster *masterPtr, + int width, int height)); +static void ImgPhotoInstanceSetSize _ANSI_ARGS_(( + PhotoInstance *instancePtr)); +static int IsValidPalette _ANSI_ARGS_((PhotoInstance *instancePtr, + char *palette)); +static int CountBits _ANSI_ARGS_((pixel mask)); +static void GetColorTable _ANSI_ARGS_((PhotoInstance *instancePtr)); +static void FreeColorTable _ANSI_ARGS_((ColorTable *colorPtr)); +static void AllocateColors _ANSI_ARGS_((ColorTable *colorPtr)); +static void DisposeColorTable _ANSI_ARGS_((ClientData clientData)); +static void DisposeInstance _ANSI_ARGS_((ClientData clientData)); +static int ReclaimColors _ANSI_ARGS_((ColorTableId *id, + int numColors)); +static int MatchFileFormat _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Channel chan, char *fileName, + char *formatString, + Tk_PhotoImageFormat **imageFormatPtr, + int *widthPtr, int *heightPtr)); +static int MatchStringFormat _ANSI_ARGS_((Tcl_Interp *interp, + char *string, char *formatString, + Tk_PhotoImageFormat **imageFormatPtr, + int *widthPtr, int *heightPtr)); +static void Dither _ANSI_ARGS_((PhotoMaster *masterPtr, + int x, int y, int width, int height)); +static void DitherInstance _ANSI_ARGS_((PhotoInstance *instancePtr, + int x, int y, int width, int height)); + +#undef MIN +#define MIN(a, b) ((a) < (b)? (a): (b)) +#undef MAX +#define MAX(a, b) ((a) > (b)? (a): (b)) + +/* + *---------------------------------------------------------------------- + * + * Tk_CreatePhotoImageFormat -- + * + * This procedure is invoked by an image file handler to register + * a new photo image format and the procedures that handle the + * new format. The procedure is typically invoked during + * Tcl_AppInit. + * + * Results: + * None. + * + * Side effects: + * The new image file format is entered into a table used in the + * photo image "read" and "write" subcommands. + * + *---------------------------------------------------------------------- + */ + +void +Tk_CreatePhotoImageFormat(formatPtr) + Tk_PhotoImageFormat *formatPtr; + /* Structure describing the format. All of + * the fields except "nextPtr" must be filled + * in by caller. Must not have been passed + * to Tk_CreatePhotoImageFormat previously. */ +{ + Tk_PhotoImageFormat *copyPtr; + + copyPtr = (Tk_PhotoImageFormat *) ckalloc(sizeof(Tk_PhotoImageFormat)); + *copyPtr = *formatPtr; + copyPtr->name = (char *) ckalloc((unsigned) (strlen(formatPtr->name) + 1)); + strcpy(copyPtr->name, formatPtr->name); + copyPtr->nextPtr = formatList; + formatList = copyPtr; +} + +/* + *---------------------------------------------------------------------- + * + * ImgPhotoCreate -- + * + * This procedure is called by the Tk image code to create + * a new photo image. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * The data structure for a new photo image is allocated and + * initialized. + * + *---------------------------------------------------------------------- + */ + +static int +ImgPhotoCreate(interp, name, argc, argv, typePtr, master, clientDataPtr) + Tcl_Interp *interp; /* Interpreter for application containing + * image. */ + char *name; /* Name to use for image. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings for options (doesn't + * include image name or type). */ + Tk_ImageType *typePtr; /* Pointer to our type record (not used). */ + Tk_ImageMaster master; /* Token for image, to be used by us in + * later callbacks. */ + ClientData *clientDataPtr; /* Store manager's token for image here; + * it will be returned in later callbacks. */ +{ + PhotoMaster *masterPtr; + + /* + * Allocate and initialize the photo image master record. + */ + + masterPtr = (PhotoMaster *) ckalloc(sizeof(PhotoMaster)); + memset((void *) masterPtr, 0, sizeof(PhotoMaster)); + masterPtr->tkMaster = master; + masterPtr->interp = interp; + masterPtr->imageCmd = Tcl_CreateCommand(interp, name, ImgPhotoCmd, + (ClientData) masterPtr, ImgPhotoCmdDeletedProc); + masterPtr->palette = NULL; + masterPtr->pix24 = NULL; + masterPtr->instancePtr = NULL; + masterPtr->validRegion = TkCreateRegion(); + + /* + * Process configuration options given in the image create command. + */ + + if (ImgPhotoConfigureMaster(interp, masterPtr, argc, argv, 0) != TCL_OK) { + ImgPhotoDelete((ClientData) masterPtr); + return TCL_ERROR; + } + + *clientDataPtr = (ClientData) masterPtr; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ImgPhotoCmd -- + * + * This procedure is invoked to process the Tcl command that + * corresponds to a photo image. See the user documentation + * for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +ImgPhotoCmd(clientData, interp, argc, argv) + ClientData clientData; /* Information about photo master. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + PhotoMaster *masterPtr = (PhotoMaster *) clientData; + int c, result, index; + int x, y, width, height; + int dataWidth, dataHeight; + struct SubcommandOptions options; + int listArgc; + char **listArgv; + char **srcArgv; + unsigned char *pixelPtr; + Tk_PhotoImageBlock block; + Tk_Window tkwin; + char string[16]; + XColor color; + Tk_PhotoImageFormat *imageFormat; + int imageWidth, imageHeight; + int matched; + Tcl_Channel chan; + Tk_PhotoHandle srcHandle; + size_t length; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option ?arg arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + c = argv[1][0]; + length = strlen(argv[1]); + + if ((c == 'b') && (strncmp(argv[1], "blank", length) == 0)) { + /* + * photo blank command - just call Tk_PhotoBlank. + */ + + if (argc == 2) { + Tk_PhotoBlank(masterPtr); + } else { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " blank\"", (char *) NULL); + return TCL_ERROR; + } + } else if ((c == 'c') && (length >= 2) + && (strncmp(argv[1], "cget", length) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " cget option\"", + (char *) NULL); + return TCL_ERROR; + } + Tk_ConfigureValue(interp, Tk_MainWindow(interp), configSpecs, + (char *) masterPtr, argv[2], 0); + } else if ((c == 'c') && (length >= 3) + && (strncmp(argv[1], "configure", length) == 0)) { + /* + * photo configure command - handle this in the standard way. + */ + + if (argc == 2) { + return Tk_ConfigureInfo(interp, Tk_MainWindow(interp), + configSpecs, (char *) masterPtr, (char *) NULL, 0); + } + if (argc == 3) { + return Tk_ConfigureInfo(interp, Tk_MainWindow(interp), + configSpecs, (char *) masterPtr, argv[2], 0); + } + return ImgPhotoConfigureMaster(interp, masterPtr, argc-2, argv+2, + TK_CONFIG_ARGV_ONLY); + } else if ((c == 'c') && (length >= 3) + && (strncmp(argv[1], "copy", length) == 0)) { + /* + * photo copy command - first parse options. + */ + + index = 2; + memset((VOID *) &options, 0, sizeof(options)); + options.zoomX = options.zoomY = 1; + options.subsampleX = options.subsampleY = 1; + options.name = NULL; + if (ParseSubcommandOptions(&options, interp, + OPT_FROM | OPT_TO | OPT_ZOOM | OPT_SUBSAMPLE | OPT_SHRINK, + &index, argc, argv) != TCL_OK) { + return TCL_ERROR; + } + if (options.name == NULL || index < argc) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " copy source-image ?-from x1 y1 x2 y2?", + " ?-to x1 y1 x2 y2? ?-zoom x y? ?-subsample x y?", + "\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * Look for the source image and get a pointer to its image data. + * Check the values given for the -from option. + */ + + if ((srcHandle = Tk_FindPhoto(interp, options.name)) == NULL) { + Tcl_AppendResult(interp, "image \"", argv[2], "\" doesn't", + " exist or is not a photo image", (char *) NULL); + return TCL_ERROR; + } + Tk_PhotoGetImage(srcHandle, &block); + if ((options.fromX2 > block.width) || (options.fromY2 > block.height) + || (options.fromX2 > block.width) + || (options.fromY2 > block.height)) { + Tcl_AppendResult(interp, "coordinates for -from option extend ", + "outside source image", (char *) NULL); + return TCL_ERROR; + } + + /* + * Fill in default values for unspecified parameters. + */ + + if (((options.options & OPT_FROM) == 0) || (options.fromX2 < 0)) { + options.fromX2 = block.width; + options.fromY2 = block.height; + } + if (((options.options & OPT_TO) == 0) || (options.toX2 < 0)) { + width = options.fromX2 - options.fromX; + if (options.subsampleX > 0) { + width = (width + options.subsampleX - 1) / options.subsampleX; + } else if (options.subsampleX == 0) { + width = 0; + } else { + width = (width - options.subsampleX - 1) / -options.subsampleX; + } + options.toX2 = options.toX + width * options.zoomX; + + height = options.fromY2 - options.fromY; + if (options.subsampleY > 0) { + height = (height + options.subsampleY - 1) + / options.subsampleY; + } else if (options.subsampleY == 0) { + height = 0; + } else { + height = (height - options.subsampleY - 1) + / -options.subsampleY; + } + options.toY2 = options.toY + height * options.zoomY; + } + + /* + * Set the destination image size if the -shrink option was specified. + */ + + if (options.options & OPT_SHRINK) { + ImgPhotoSetSize(masterPtr, options.toX2, options.toY2); + } + + /* + * Copy the image data over using Tk_PhotoPutZoomedBlock. + */ + + block.pixelPtr += options.fromX * block.pixelSize + + options.fromY * block.pitch; + block.width = options.fromX2 - options.fromX; + block.height = options.fromY2 - options.fromY; + Tk_PhotoPutZoomedBlock((Tk_PhotoHandle) masterPtr, &block, + options.toX, options.toY, options.toX2 - options.toX, + options.toY2 - options.toY, options.zoomX, options.zoomY, + options.subsampleX, options.subsampleY); + + } else if ((c == 'g') && (strncmp(argv[1], "get", length) == 0)) { + /* + * photo get command - first parse and check parameters. + */ + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " get x y\"", (char *) NULL); + return TCL_ERROR; + } + if ((Tcl_GetInt(interp, argv[2], &x) != TCL_OK) + || (Tcl_GetInt(interp, argv[3], &y) != TCL_OK)) { + return TCL_ERROR; + } + if ((x < 0) || (x >= masterPtr->width) + || (y < 0) || (y >= masterPtr->height)) { + Tcl_AppendResult(interp, argv[0], " get: ", + "coordinates out of range", (char *) NULL); + return TCL_ERROR; + } + + /* + * Extract the value of the desired pixel and format it as a string. + */ + + pixelPtr = masterPtr->pix24 + (y * masterPtr->width + x) * 3; + sprintf(string, "%d %d %d", pixelPtr[0], pixelPtr[1], + pixelPtr[2]); + Tcl_AppendResult(interp, string, (char *) NULL); + } else if ((c == 'p') && (strncmp(argv[1], "put", length) == 0)) { + /* + * photo put command - first parse the options and colors specified. + */ + + index = 2; + memset((VOID *) &options, 0, sizeof(options)); + options.name = NULL; + if (ParseSubcommandOptions(&options, interp, OPT_TO, + &index, argc, argv) != TCL_OK) { + return TCL_ERROR; + } + if ((options.name == NULL) || (index < argc)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " put {{colors...}...} ?-to x1 y1 x2 y2?\"", + (char *) NULL); + return TCL_ERROR; + } + if (Tcl_SplitList(interp, options.name, &dataHeight, &srcArgv) + != TCL_OK) { + return TCL_ERROR; + } + tkwin = Tk_MainWindow(interp); + block.pixelPtr = NULL; + dataWidth = 0; + pixelPtr = NULL; + for (y = 0; y < dataHeight; ++y) { + if (Tcl_SplitList(interp, srcArgv[y], &listArgc, &listArgv) + != TCL_OK) { + break; + } + if (y == 0) { + dataWidth = listArgc; + pixelPtr = (unsigned char *) ckalloc((unsigned) + dataWidth * dataHeight * 3); + block.pixelPtr = pixelPtr; + } else { + if (listArgc != dataWidth) { + Tcl_AppendResult(interp, "all elements of color list must", + " have the same number of elements", + (char *) NULL); + ckfree((char *) listArgv); + break; + } + } + for (x = 0; x < dataWidth; ++x) { + if (!XParseColor(Tk_Display(tkwin), Tk_Colormap(tkwin), + listArgv[x], &color)) { + Tcl_AppendResult(interp, "can't parse color \"", + listArgv[x], "\"", (char *) NULL); + break; + } + *pixelPtr++ = color.red >> 8; + *pixelPtr++ = color.green >> 8; + *pixelPtr++ = color.blue >> 8; + } + ckfree((char *) listArgv); + if (x < dataWidth) + break; + } + ckfree((char *) srcArgv); + if (y < dataHeight || dataHeight == 0 || dataWidth == 0) { + if (block.pixelPtr != NULL) { + ckfree((char *) block.pixelPtr); + } + if (y < dataHeight) { + return TCL_ERROR; + } + return TCL_OK; + } + + /* + * Fill in default values for the -to option, then + * copy the block in using Tk_PhotoPutBlock. + */ + + if (((options.options & OPT_TO) == 0) || (options.toX2 < 0)) { + options.toX2 = options.toX + dataWidth; + options.toY2 = options.toY + dataHeight; + } + block.width = dataWidth; + block.height = dataHeight; + block.pitch = dataWidth * 3; + block.pixelSize = 3; + block.offset[0] = 0; + block.offset[1] = 1; + block.offset[2] = 2; + Tk_PhotoPutBlock((ClientData)masterPtr, &block, + options.toX, options.toY, options.toX2 - options.toX, + options.toY2 - options.toY); + ckfree((char *) block.pixelPtr); + } else if ((c == 'r') && (length >= 3) + && (strncmp(argv[1], "read", length) == 0)) { + /* + * photo read command - first parse the options specified. + */ + + index = 2; + memset((VOID *) &options, 0, sizeof(options)); + options.name = NULL; + options.format = NULL; + if (ParseSubcommandOptions(&options, interp, + OPT_FORMAT | OPT_FROM | OPT_TO | OPT_SHRINK, + &index, argc, argv) != TCL_OK) { + return TCL_ERROR; + } + if ((options.name == NULL) || (index < argc)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " read fileName ?-format format-name?", + " ?-from x1 y1 x2 y2? ?-to x y? ?-shrink?\"", + (char *) NULL); + return TCL_ERROR; + } + + /* + * Prevent file system access in safe interpreters. + */ + + if (Tcl_IsSafe(interp)) { + Tcl_AppendResult(interp, "can't get image from a file in a", + " safe interpreter", (char *) NULL); + return TCL_ERROR; + } + + /* + * Open the image file and look for a handler for it. + */ + + chan = Tcl_OpenFileChannel(interp, options.name, "r", 0); + if (chan == NULL) { + return TCL_ERROR; + } + if (Tcl_SetChannelOption(interp, chan, "-translation", "binary") + != TCL_OK) { + return TCL_ERROR; + } + if (MatchFileFormat(interp, chan, options.name, options.format, + &imageFormat, &imageWidth, &imageHeight) != TCL_OK) { + Tcl_Close(NULL, chan); + return TCL_ERROR; + } + + /* + * Check the values given for the -from option. + */ + + if ((options.fromX > imageWidth) || (options.fromY > imageHeight) + || (options.fromX2 > imageWidth) + || (options.fromY2 > imageHeight)) { + Tcl_AppendResult(interp, "coordinates for -from option extend ", + "outside source image", (char *) NULL); + Tcl_Close(NULL, chan); + return TCL_ERROR; + } + if (((options.options & OPT_FROM) == 0) || (options.fromX2 < 0)) { + width = imageWidth - options.fromX; + height = imageHeight - options.fromY; + } else { + width = options.fromX2 - options.fromX; + height = options.fromY2 - options.fromY; + } + + /* + * If the -shrink option was specified, set the size of the image. + */ + + if (options.options & OPT_SHRINK) { + ImgPhotoSetSize(masterPtr, options.toX + width, + options.toY + height); + } + + /* + * Call the handler's file read procedure to read the data + * into the image. + */ + + result = (*imageFormat->fileReadProc)(interp, chan, options.name, + options.format, (Tk_PhotoHandle) masterPtr, options.toX, + options.toY, width, height, options.fromX, options.fromY); + if (chan != NULL) { + Tcl_Close(NULL, chan); + } + return result; + } else if ((c == 'r') && (length >= 3) + && (strncmp(argv[1], "redither", length) == 0)) { + + if (argc == 2) { + /* + * Call Dither if any part of the image is not correctly + * dithered at present. + */ + + x = masterPtr->ditherX; + y = masterPtr->ditherY; + if (masterPtr->ditherX != 0) { + Dither(masterPtr, x, y, masterPtr->width - x, 1); + } + if (masterPtr->ditherY < masterPtr->height) { + x = 0; + Dither(masterPtr, 0, masterPtr->ditherY, masterPtr->width, + masterPtr->height - masterPtr->ditherY); + } + + if (y < masterPtr->height) { + /* + * Tell the core image code that part of the image has changed. + */ + + Tk_ImageChanged(masterPtr->tkMaster, x, y, + (masterPtr->width - x), (masterPtr->height - y), + masterPtr->width, masterPtr->height); + } + + } else { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " redither\"", (char *) NULL); + return TCL_ERROR; + } + } else if ((c == 'w') && (strncmp(argv[1], "write", length) == 0)) { + + /* + * Prevent file system access in safe interpreters. + */ + + if (Tcl_IsSafe(interp)) { + Tcl_AppendResult(interp, "can't write image to a file in a", + " safe interpreter", (char *) NULL); + return TCL_ERROR; + } + + /* + * photo write command - first parse and check any options given. + */ + + index = 2; + memset((VOID *) &options, 0, sizeof(options)); + options.name = NULL; + options.format = NULL; + if (ParseSubcommandOptions(&options, interp, OPT_FORMAT | OPT_FROM, + &index, argc, argv) != TCL_OK) { + return TCL_ERROR; + } + if ((options.name == NULL) || (index < argc)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " write fileName ?-format format-name?", + "?-from x1 y1 x2 y2?\"", (char *) NULL); + return TCL_ERROR; + } + if ((options.fromX > masterPtr->width) + || (options.fromY > masterPtr->height) + || (options.fromX2 > masterPtr->width) + || (options.fromY2 > masterPtr->height)) { + Tcl_AppendResult(interp, "coordinates for -from option extend ", + "outside image", (char *) NULL); + return TCL_ERROR; + } + + /* + * Fill in default values for unspecified parameters. + */ + + if (((options.options & OPT_FROM) == 0) || (options.fromX2 < 0)) { + options.fromX2 = masterPtr->width; + options.fromY2 = masterPtr->height; + } + + /* + * Search for an appropriate image file format handler, + * and give an error if none is found. + */ + + matched = 0; + for (imageFormat = formatList; imageFormat != NULL; + imageFormat = imageFormat->nextPtr) { + if ((options.format == NULL) + || (strncasecmp(options.format, imageFormat->name, + strlen(imageFormat->name)) == 0)) { + matched = 1; + if (imageFormat->fileWriteProc != NULL) { + break; + } + } + } + if (imageFormat == NULL) { + if (options.format == NULL) { + Tcl_AppendResult(interp, "no available image file format ", + "has file writing capability", (char *) NULL); + } else if (!matched) { + Tcl_AppendResult(interp, "image file format \"", + options.format, "\" is unknown", (char *) NULL); + } else { + Tcl_AppendResult(interp, "image file format \"", + options.format, "\" has no file writing capability", + (char *) NULL); + } + return TCL_ERROR; + } + + /* + * Call the handler's file write procedure to write out + * the image. + */ + + Tk_PhotoGetImage((Tk_PhotoHandle) masterPtr, &block); + block.pixelPtr += options.fromY * block.pitch + options.fromX * 3; + block.width = options.fromX2 - options.fromX; + block.height = options.fromY2 - options.fromY; + return (*imageFormat->fileWriteProc)(interp, options.name, + options.format, &block); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be blank, cget, configure, copy, get, put,", + " read, redither, or write", (char *) NULL); + return TCL_ERROR; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ParseSubcommandOptions -- + * + * This procedure is invoked to process one of the options + * which may be specified for the photo image subcommands, + * namely, -from, -to, -zoom, -subsample, -format, and -shrink. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Fields in *optPtr get filled in. + * + *---------------------------------------------------------------------- + */ + +static int +ParseSubcommandOptions(optPtr, interp, allowedOptions, optIndexPtr, argc, argv) + struct SubcommandOptions *optPtr; + /* Information about the options specified + * and the values given is returned here. */ + Tcl_Interp *interp; /* Interpreter to use for reporting errors. */ + int allowedOptions; /* Indicates which options are valid for + * the current command. */ + int *optIndexPtr; /* Points to a variable containing the + * current index in argv; this variable is + * updated by this procedure. */ + int argc; /* Number of arguments in argv[]. */ + char **argv; /* Arguments to be parsed. */ +{ + int index, c, bit, currentBit; + size_t length; + char *option, **listPtr; + int values[4]; + int numValues, maxValues, argIndex; + + for (index = *optIndexPtr; index < argc; *optIndexPtr = ++index) { + /* + * We can have one value specified without an option; + * it goes into optPtr->name. + */ + + option = argv[index]; + if (option[0] != '-') { + if (optPtr->name == NULL) { + optPtr->name = option; + continue; + } + break; + } + + /* + * Work out which option this is. + */ + + length = strlen(option); + c = option[0]; + bit = 0; + currentBit = 1; + for (listPtr = optionNames; *listPtr != NULL; ++listPtr) { + if ((c == *listPtr[0]) + && (strncmp(option, *listPtr, length) == 0)) { + if (bit != 0) { + bit = 0; /* An ambiguous option. */ + break; + } + bit = currentBit; + } + currentBit <<= 1; + } + + /* + * If this option is not recognized and allowed, put + * an error message in the interpreter and return. + */ + + if ((allowedOptions & bit) == 0) { + Tcl_AppendResult(interp, "unrecognized option \"", argv[index], + "\": must be ", (char *)NULL); + bit = 1; + for (listPtr = optionNames; *listPtr != NULL; ++listPtr) { + if ((allowedOptions & bit) != 0) { + if ((allowedOptions & (bit - 1)) != 0) { + Tcl_AppendResult(interp, ", ", (char *) NULL); + if ((allowedOptions & ~((bit << 1) - 1)) == 0) { + Tcl_AppendResult(interp, "or ", (char *) NULL); + } + } + Tcl_AppendResult(interp, *listPtr, (char *) NULL); + } + bit <<= 1; + } + return TCL_ERROR; + } + + /* + * For the -from, -to, -zoom and -subsample options, + * parse the values given. Report an error if too few + * or too many values are given. + */ + + if ((bit != OPT_SHRINK) && (bit != OPT_FORMAT)) { + maxValues = ((bit == OPT_FROM) || (bit == OPT_TO))? 4: 2; + argIndex = index + 1; + for (numValues = 0; numValues < maxValues; ++numValues) { + if ((argIndex < argc) && (isdigit(UCHAR(argv[argIndex][0])) + || ((argv[argIndex][0] == '-') + && (isdigit(UCHAR(argv[argIndex][1])))))) { + if (Tcl_GetInt(interp, argv[argIndex], &values[numValues]) + != TCL_OK) { + return TCL_ERROR; + } + } else { + break; + } + ++argIndex; + } + + if (numValues == 0) { + Tcl_AppendResult(interp, "the \"", argv[index], "\" option ", + "requires one ", maxValues == 2? "or two": "to four", + " integer values", (char *) NULL); + return TCL_ERROR; + } + *optIndexPtr = (index += numValues); + + /* + * Y values default to the corresponding X value if not specified. + */ + + if (numValues == 1) { + values[1] = values[0]; + } + if (numValues == 3) { + values[3] = values[2]; + } + + /* + * Check the values given and put them in the appropriate + * field of the SubcommandOptions structure. + */ + + switch (bit) { + case OPT_FROM: + if ((values[0] < 0) || (values[1] < 0) || ((numValues > 2) + && ((values[2] < 0) || (values[3] < 0)))) { + Tcl_AppendResult(interp, "value(s) for the -from", + " option must be non-negative", (char *) NULL); + return TCL_ERROR; + } + if (numValues <= 2) { + optPtr->fromX = values[0]; + optPtr->fromY = values[1]; + optPtr->fromX2 = -1; + optPtr->fromY2 = -1; + } else { + optPtr->fromX = MIN(values[0], values[2]); + optPtr->fromY = MIN(values[1], values[3]); + optPtr->fromX2 = MAX(values[0], values[2]); + optPtr->fromY2 = MAX(values[1], values[3]); + } + break; + case OPT_SUBSAMPLE: + optPtr->subsampleX = values[0]; + optPtr->subsampleY = values[1]; + break; + case OPT_TO: + if ((values[0] < 0) || (values[1] < 0) || ((numValues > 2) + && ((values[2] < 0) || (values[3] < 0)))) { + Tcl_AppendResult(interp, "value(s) for the -to", + " option must be non-negative", (char *) NULL); + return TCL_ERROR; + } + if (numValues <= 2) { + optPtr->toX = values[0]; + optPtr->toY = values[1]; + optPtr->toX2 = -1; + optPtr->toY2 = -1; + } else { + optPtr->toX = MIN(values[0], values[2]); + optPtr->toY = MIN(values[1], values[3]); + optPtr->toX2 = MAX(values[0], values[2]); + optPtr->toY2 = MAX(values[1], values[3]); + } + break; + case OPT_ZOOM: + if ((values[0] <= 0) || (values[1] <= 0)) { + Tcl_AppendResult(interp, "value(s) for the -zoom", + " option must be positive", (char *) NULL); + return TCL_ERROR; + } + optPtr->zoomX = values[0]; + optPtr->zoomY = values[1]; + break; + } + } else if (bit == OPT_FORMAT) { + /* + * The -format option takes a single string value. + */ + + if (index + 1 < argc) { + *optIndexPtr = ++index; + optPtr->format = argv[index]; + } else { + Tcl_AppendResult(interp, "the \"-format\" option ", + "requires a value", (char *) NULL); + return TCL_ERROR; + } + } + + /* + * Remember that we saw this option. + */ + + optPtr->options |= bit; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ImgPhotoConfigureMaster -- + * + * This procedure is called when a photo image is created or + * reconfigured. It processes configuration options and resets + * any instances of the image. + * + * Results: + * A standard Tcl return value. If TCL_ERROR is returned then + * an error message is left in masterPtr->interp->result. + * + * Side effects: + * Existing instances of the image will be redisplayed to match + * the new configuration options. + * + *---------------------------------------------------------------------- + */ + +static int +ImgPhotoConfigureMaster(interp, masterPtr, argc, argv, flags) + Tcl_Interp *interp; /* Interpreter to use for reporting errors. */ + PhotoMaster *masterPtr; /* Pointer to data structure describing + * overall photo image to (re)configure. */ + int argc; /* Number of entries in argv. */ + char **argv; /* Pairs of configuration options for image. */ + int flags; /* Flags to pass to Tk_ConfigureWidget, + * such as TK_CONFIG_ARGV_ONLY. */ +{ + PhotoInstance *instancePtr; + char *oldFileString, *oldDataString, *oldPaletteString; + double oldGamma; + int result; + Tcl_Channel chan; + Tk_PhotoImageFormat *imageFormat; + int imageWidth, imageHeight; + + /* + * Save the current values for fileString and dataString, so we + * can tell if the user specifies them anew. + */ + + oldFileString = masterPtr->fileString; + oldDataString = (oldFileString == NULL)? masterPtr->dataString: NULL; + oldPaletteString = masterPtr->palette; + oldGamma = masterPtr->gamma; + + /* + * Process the configuration options specified. + */ + + if (Tk_ConfigureWidget(interp, Tk_MainWindow(interp), configSpecs, + argc, argv, (char *) masterPtr, flags) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Regard the empty string for -file, -data or -format as the null + * value. + */ + + if ((masterPtr->fileString != NULL) && (masterPtr->fileString[0] == 0)) { + ckfree(masterPtr->fileString); + masterPtr->fileString = NULL; + } + if ((masterPtr->dataString != NULL) && (masterPtr->dataString[0] == 0)) { + ckfree(masterPtr->dataString); + masterPtr->dataString = NULL; + } + if ((masterPtr->format != NULL) && (masterPtr->format[0] == 0)) { + ckfree(masterPtr->format); + masterPtr->format = NULL; + } + + /* + * Set the image to the user-requested size, if any, + * and make sure storage is correctly allocated for this image. + */ + + ImgPhotoSetSize(masterPtr, masterPtr->width, masterPtr->height); + + /* + * Read in the image from the file or string if the user has + * specified the -file or -data option. + */ + + if ((masterPtr->fileString != NULL) + && (masterPtr->fileString != oldFileString)) { + + /* + * Prevent file system access in a safe interpreter. + */ + + if (Tcl_IsSafe(interp)) { + Tcl_AppendResult(interp, "can't get image from a file in a", + " safe interpreter", (char *) NULL); + return TCL_ERROR; + } + + chan = Tcl_OpenFileChannel(interp, masterPtr->fileString, "r", 0); + if (chan == NULL) { + return TCL_ERROR; + } + if (Tcl_SetChannelOption(interp, chan, "-translation", "binary") + != TCL_OK) { + return TCL_ERROR; + } + if (MatchFileFormat(interp, chan, masterPtr->fileString, + masterPtr->format, &imageFormat, &imageWidth, + &imageHeight) != TCL_OK) { + Tcl_Close(NULL, chan); + return TCL_ERROR; + } + ImgPhotoSetSize(masterPtr, imageWidth, imageHeight); + result = (*imageFormat->fileReadProc)(interp, chan, + masterPtr->fileString, masterPtr->format, + (Tk_PhotoHandle) masterPtr, 0, 0, + imageWidth, imageHeight, 0, 0); + Tcl_Close(NULL, chan); + if (result != TCL_OK) { + return TCL_ERROR; + } + + masterPtr->flags |= IMAGE_CHANGED; + } + + if ((masterPtr->fileString == NULL) && (masterPtr->dataString != NULL) + && (masterPtr->dataString != oldDataString)) { + + if (MatchStringFormat(interp, masterPtr->dataString, + masterPtr->format, &imageFormat, &imageWidth, + &imageHeight) != TCL_OK) { + return TCL_ERROR; + } + ImgPhotoSetSize(masterPtr, imageWidth, imageHeight); + if ((*imageFormat->stringReadProc)(interp, masterPtr->dataString, + masterPtr->format, (Tk_PhotoHandle) masterPtr, + 0, 0, imageWidth, imageHeight, 0, 0) != TCL_OK) { + return TCL_ERROR; + } + + masterPtr->flags |= IMAGE_CHANGED; + } + + /* + * Enforce a reasonable value for gamma. + */ + + if (masterPtr->gamma <= 0) { + masterPtr->gamma = 1.0; + } + + if ((masterPtr->gamma != oldGamma) + || (masterPtr->palette != oldPaletteString)) { + masterPtr->flags |= IMAGE_CHANGED; + } + + /* + * Cycle through all of the instances of this image, regenerating + * the information for each instance. Then force the image to be + * redisplayed everywhere that it is used. + */ + + for (instancePtr = masterPtr->instancePtr; instancePtr != NULL; + instancePtr = instancePtr->nextPtr) { + ImgPhotoConfigureInstance(instancePtr); + } + + /* + * Inform the generic image code that the image + * has (potentially) changed. + */ + + Tk_ImageChanged(masterPtr->tkMaster, 0, 0, masterPtr->width, + masterPtr->height, masterPtr->width, masterPtr->height); + masterPtr->flags &= ~IMAGE_CHANGED; + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ImgPhotoConfigureInstance -- + * + * This procedure is called to create displaying information for + * a photo image instance based on the configuration information + * in the master. It is invoked both when new instances are + * created and when the master is reconfigured. + * + * Results: + * None. + * + * Side effects: + * Generates errors via Tcl_BackgroundError if there are problems + * in setting up the instance. + * + *---------------------------------------------------------------------- + */ + +static void +ImgPhotoConfigureInstance(instancePtr) + PhotoInstance *instancePtr; /* Instance to reconfigure. */ +{ + PhotoMaster *masterPtr = instancePtr->masterPtr; + XImage *imagePtr; + int bitsPerPixel; + ColorTable *colorTablePtr; + XRectangle validBox; + + /* + * If the -palette configuration option has been set for the master, + * use the value specified for our palette, but only if it is + * a valid palette for our windows. Use the gamma value specified + * the master. + */ + + if ((masterPtr->palette && masterPtr->palette[0]) + && IsValidPalette(instancePtr, masterPtr->palette)) { + instancePtr->palette = masterPtr->palette; + } else { + instancePtr->palette = instancePtr->defaultPalette; + } + instancePtr->gamma = masterPtr->gamma; + + /* + * If we don't currently have a color table, or if the one we + * have no longer applies (e.g. because our palette or gamma + * has changed), get a new one. + */ + + colorTablePtr = instancePtr->colorTablePtr; + if ((colorTablePtr == NULL) + || (instancePtr->colormap != colorTablePtr->id.colormap) + || (instancePtr->palette != colorTablePtr->id.palette) + || (instancePtr->gamma != colorTablePtr->id.gamma)) { + /* + * Free up our old color table, and get a new one. + */ + + if (colorTablePtr != NULL) { + colorTablePtr->liveRefCount -= 1; + FreeColorTable(colorTablePtr); + } + GetColorTable(instancePtr); + + /* + * Create a new XImage structure for sending data to + * the X server, if necessary. + */ + + if (instancePtr->colorTablePtr->flags & BLACK_AND_WHITE) { + bitsPerPixel = 1; + } else { + bitsPerPixel = instancePtr->visualInfo.depth; + } + + if ((instancePtr->imagePtr == NULL) + || (instancePtr->imagePtr->bits_per_pixel != bitsPerPixel)) { + if (instancePtr->imagePtr != NULL) { + XFree((char *) instancePtr->imagePtr); + } + imagePtr = XCreateImage(instancePtr->display, + instancePtr->visualInfo.visual, (unsigned) bitsPerPixel, + (bitsPerPixel > 1? ZPixmap: XYBitmap), 0, (char *) NULL, + 1, 1, 32, 0); + instancePtr->imagePtr = imagePtr; + + /* + * Determine the endianness of this machine. + * We create images using the local host's endianness, rather + * than the endianness of the server; otherwise we would have + * to byte-swap any 16 or 32 bit values that we store in the + * image in those situations where the server's endianness + * is different from ours. + */ + + if (imagePtr != NULL) { + union { + int i; + char c[sizeof(int)]; + } kludge; + + imagePtr->bitmap_unit = sizeof(pixel) * NBBY; + kludge.i = 0; + kludge.c[0] = 1; + imagePtr->byte_order = (kludge.i == 1) ? LSBFirst : MSBFirst; + _XInitImageFuncPtrs(imagePtr); + } + } + } + + /* + * If the user has specified a width and/or height for the master + * which is different from our current width/height, set the size + * to the values specified by the user. If we have no pixmap, we + * do this also, since it has the side effect of allocating a + * pixmap for us. + */ + + if ((instancePtr->pixels == None) || (instancePtr->error == NULL) + || (instancePtr->width != masterPtr->width) + || (instancePtr->height != masterPtr->height)) { + ImgPhotoInstanceSetSize(instancePtr); + } + + /* + * Redither this instance if necessary. + */ + + if ((masterPtr->flags & IMAGE_CHANGED) + || (instancePtr->colorTablePtr != colorTablePtr)) { + TkClipBox(masterPtr->validRegion, &validBox); + if ((validBox.width > 0) && (validBox.height > 0)) { + DitherInstance(instancePtr, validBox.x, validBox.y, + validBox.width, validBox.height); + } + } + +} + +/* + *---------------------------------------------------------------------- + * + * ImgPhotoGet -- + * + * This procedure is called for each use of a photo image in a + * widget. + * + * Results: + * The return value is a token for the instance, which is passed + * back to us in calls to ImgPhotoDisplay and ImgPhotoFree. + * + * Side effects: + * A data structure is set up for the instance (or, an existing + * instance is re-used for the new one). + * + *---------------------------------------------------------------------- + */ + +static ClientData +ImgPhotoGet(tkwin, masterData) + Tk_Window tkwin; /* Window in which the instance will be + * used. */ + ClientData masterData; /* Pointer to our master structure for the + * image. */ +{ + PhotoMaster *masterPtr = (PhotoMaster *) masterData; + PhotoInstance *instancePtr; + Colormap colormap; + int mono, nRed, nGreen, nBlue; + XVisualInfo visualInfo, *visInfoPtr; + XRectangle validBox; + char buf[16]; + int numVisuals; + XColor *white, *black; + XGCValues gcValues; + + /* + * Table of "best" choices for palette for PseudoColor displays + * with between 3 and 15 bits/pixel. + */ + + static int paletteChoice[13][3] = { + /* #red, #green, #blue */ + {2, 2, 2, /* 3 bits, 8 colors */}, + {2, 3, 2, /* 4 bits, 12 colors */}, + {3, 4, 2, /* 5 bits, 24 colors */}, + {4, 5, 3, /* 6 bits, 60 colors */}, + {5, 6, 4, /* 7 bits, 120 colors */}, + {7, 7, 4, /* 8 bits, 198 colors */}, + {8, 10, 6, /* 9 bits, 480 colors */}, + {10, 12, 8, /* 10 bits, 960 colors */}, + {14, 15, 9, /* 11 bits, 1890 colors */}, + {16, 20, 12, /* 12 bits, 3840 colors */}, + {20, 24, 16, /* 13 bits, 7680 colors */}, + {26, 30, 20, /* 14 bits, 15600 colors */}, + {32, 32, 30, /* 15 bits, 30720 colors */} + }; + + /* + * See if there is already an instance for windows using + * the same colormap. If so then just re-use it. + */ + + colormap = Tk_Colormap(tkwin); + for (instancePtr = masterPtr->instancePtr; instancePtr != NULL; + instancePtr = instancePtr->nextPtr) { + if ((colormap == instancePtr->colormap) + && (Tk_Display(tkwin) == instancePtr->display)) { + + /* + * Re-use this instance. + */ + + if (instancePtr->refCount == 0) { + /* + * We are resurrecting this instance. + */ + + Tcl_CancelIdleCall(DisposeInstance, (ClientData) instancePtr); + if (instancePtr->colorTablePtr != NULL) { + FreeColorTable(instancePtr->colorTablePtr); + } + GetColorTable(instancePtr); + } + instancePtr->refCount++; + return (ClientData) instancePtr; + } + } + + /* + * The image isn't already in use in a window with the same colormap. + * Make a new instance of the image. + */ + + instancePtr = (PhotoInstance *) ckalloc(sizeof(PhotoInstance)); + instancePtr->masterPtr = masterPtr; + instancePtr->display = Tk_Display(tkwin); + instancePtr->colormap = Tk_Colormap(tkwin); + Tk_PreserveColormap(instancePtr->display, instancePtr->colormap); + instancePtr->refCount = 1; + instancePtr->colorTablePtr = NULL; + instancePtr->pixels = None; + instancePtr->error = NULL; + instancePtr->width = 0; + instancePtr->height = 0; + instancePtr->imagePtr = 0; + instancePtr->nextPtr = masterPtr->instancePtr; + masterPtr->instancePtr = instancePtr; + + /* + * Obtain information about the visual and decide on the + * default palette. + */ + + visualInfo.screen = Tk_ScreenNumber(tkwin); + visualInfo.visualid = XVisualIDFromVisual(Tk_Visual(tkwin)); + visInfoPtr = XGetVisualInfo(Tk_Display(tkwin), + VisualScreenMask | VisualIDMask, &visualInfo, &numVisuals); + nRed = 2; + nGreen = nBlue = 0; + mono = 1; + if (visInfoPtr != NULL) { + instancePtr->visualInfo = *visInfoPtr; + switch (visInfoPtr->class) { + case DirectColor: + case TrueColor: + nRed = 1 << CountBits(visInfoPtr->red_mask); + nGreen = 1 << CountBits(visInfoPtr->green_mask); + nBlue = 1 << CountBits(visInfoPtr->blue_mask); + mono = 0; + break; + case PseudoColor: + case StaticColor: + if (visInfoPtr->depth > 15) { + nRed = 32; + nGreen = 32; + nBlue = 32; + mono = 0; + } else if (visInfoPtr->depth >= 3) { + int *ip = paletteChoice[visInfoPtr->depth - 3]; + + nRed = ip[0]; + nGreen = ip[1]; + nBlue = ip[2]; + mono = 0; + } + break; + case GrayScale: + case StaticGray: + nRed = 1 << visInfoPtr->depth; + break; + } + XFree((char *) visInfoPtr); + + } else { + panic("ImgPhotoGet couldn't find visual for window"); + } + + sprintf(buf, ((mono) ? "%d": "%d/%d/%d"), nRed, nGreen, nBlue); + instancePtr->defaultPalette = Tk_GetUid(buf); + + /* + * Make a GC with background = black and foreground = white. + */ + + white = Tk_GetColor(masterPtr->interp, tkwin, "white"); + black = Tk_GetColor(masterPtr->interp, tkwin, "black"); + gcValues.foreground = (white != NULL)? white->pixel: + WhitePixelOfScreen(Tk_Screen(tkwin)); + gcValues.background = (black != NULL)? black->pixel: + BlackPixelOfScreen(Tk_Screen(tkwin)); + gcValues.graphics_exposures = False; + instancePtr->gc = Tk_GetGC(tkwin, + GCForeground|GCBackground|GCGraphicsExposures, &gcValues); + + /* + * Set configuration options and finish the initialization of the instance. + */ + + ImgPhotoConfigureInstance(instancePtr); + + /* + * If this is the first instance, must set the size of the image. + */ + + if (instancePtr->nextPtr == NULL) { + Tk_ImageChanged(masterPtr->tkMaster, 0, 0, 0, 0, + masterPtr->width, masterPtr->height); + } + + /* + * Dither the image to fill in this instance's pixmap. + */ + + TkClipBox(masterPtr->validRegion, &validBox); + if ((validBox.width > 0) && (validBox.height > 0)) { + DitherInstance(instancePtr, validBox.x, validBox.y, validBox.width, + validBox.height); + } + + return (ClientData) instancePtr; +} + +/* + *---------------------------------------------------------------------- + * + * ImgPhotoDisplay -- + * + * This procedure is invoked to draw a photo image. + * + * Results: + * None. + * + * Side effects: + * A portion of the image gets rendered in a pixmap or window. + * + *---------------------------------------------------------------------- + */ + +static void +ImgPhotoDisplay(clientData, display, drawable, imageX, imageY, width, + height, drawableX, drawableY) + ClientData clientData; /* Pointer to PhotoInstance structure for + * for instance to be displayed. */ + Display *display; /* Display on which to draw image. */ + Drawable drawable; /* Pixmap or window in which to draw image. */ + int imageX, imageY; /* Upper-left corner of region within image + * to draw. */ + int width, height; /* Dimensions of region within image to draw. */ + int drawableX, drawableY; /* Coordinates within drawable that + * correspond to imageX and imageY. */ +{ + PhotoInstance *instancePtr = (PhotoInstance *) clientData; + + /* + * If there's no pixmap, it means that an error occurred + * while creating the image instance so it can't be displayed. + */ + + if (instancePtr->pixels == None) { + return; + } + + /* + * masterPtr->region describes which parts of the image contain + * valid data. We set this region as the clip mask for the gc, + * setting its origin appropriately, and use it when drawing the + * image. + */ + + TkSetRegion(display, instancePtr->gc, instancePtr->masterPtr->validRegion); + XSetClipOrigin(display, instancePtr->gc, drawableX - imageX, + drawableY - imageY); + XCopyArea(display, instancePtr->pixels, drawable, instancePtr->gc, + imageX, imageY, (unsigned) width, (unsigned) height, + drawableX, drawableY); + XSetClipMask(display, instancePtr->gc, None); + XSetClipOrigin(display, instancePtr->gc, 0, 0); +} + +/* + *---------------------------------------------------------------------- + * + * ImgPhotoFree -- + * + * This procedure is called when a widget ceases to use a + * particular instance of an image. We don't actually get + * rid of the instance until later because we may be about + * to get this instance again. + * + * Results: + * None. + * + * Side effects: + * Internal data structures get cleaned up, later. + * + *---------------------------------------------------------------------- + */ + +static void +ImgPhotoFree(clientData, display) + ClientData clientData; /* Pointer to PhotoInstance structure for + * for instance to be displayed. */ + Display *display; /* Display containing window that used image. */ +{ + PhotoInstance *instancePtr = (PhotoInstance *) clientData; + ColorTable *colorPtr; + + instancePtr->refCount -= 1; + if (instancePtr->refCount > 0) { + return; + } + + /* + * There are no more uses of the image within this widget. + * Decrement the count of live uses of its color table, so + * that its colors can be reclaimed if necessary, and + * set up an idle call to free the instance structure. + */ + + colorPtr = instancePtr->colorTablePtr; + if (colorPtr != NULL) { + colorPtr->liveRefCount -= 1; + } + + Tcl_DoWhenIdle(DisposeInstance, (ClientData) instancePtr); +} + +/* + *---------------------------------------------------------------------- + * + * ImgPhotoDelete -- + * + * This procedure is called by the image code to delete the + * master structure for an image. + * + * Results: + * None. + * + * Side effects: + * Resources associated with the image get freed. + * + *---------------------------------------------------------------------- + */ + +static void +ImgPhotoDelete(masterData) + ClientData masterData; /* Pointer to PhotoMaster structure for + * image. Must not have any more instances. */ +{ + PhotoMaster *masterPtr = (PhotoMaster *) masterData; + PhotoInstance *instancePtr; + + while ((instancePtr = masterPtr->instancePtr) != NULL) { + if (instancePtr->refCount > 0) { + panic("tried to delete photo image when instances still exist"); + } + Tcl_CancelIdleCall(DisposeInstance, (ClientData) instancePtr); + DisposeInstance((ClientData) instancePtr); + } + masterPtr->tkMaster = NULL; + if (masterPtr->imageCmd != NULL) { + Tcl_DeleteCommandFromToken(masterPtr->interp, masterPtr->imageCmd); + } + if (masterPtr->pix24 != NULL) { + ckfree((char *) masterPtr->pix24); + } + if (masterPtr->validRegion != NULL) { + TkDestroyRegion(masterPtr->validRegion); + } + Tk_FreeOptions(configSpecs, (char *) masterPtr, (Display *) NULL, 0); + ckfree((char *) masterPtr); +} + +/* + *---------------------------------------------------------------------- + * + * ImgPhotoCmdDeletedProc -- + * + * This procedure is invoked when the image command for an image + * is deleted. It deletes the image. + * + * Results: + * None. + * + * Side effects: + * The image is deleted. + * + *---------------------------------------------------------------------- + */ + +static void +ImgPhotoCmdDeletedProc(clientData) + ClientData clientData; /* Pointer to PhotoMaster structure for + * image. */ +{ + PhotoMaster *masterPtr = (PhotoMaster *) clientData; + + masterPtr->imageCmd = NULL; + if (masterPtr->tkMaster != NULL) { + Tk_DeleteImage(masterPtr->interp, Tk_NameOfImage(masterPtr->tkMaster)); + } +} + +/* + *---------------------------------------------------------------------- + * + * ImgPhotoSetSize -- + * + * This procedure reallocates the image storage and instance + * pixmaps for a photo image, as necessary, to change the + * image's size to `width' x `height' pixels. + * + * Results: + * None. + * + * Side effects: + * Storage gets reallocated, for the master and all its instances. + * + *---------------------------------------------------------------------- + */ + +static void +ImgPhotoSetSize(masterPtr, width, height) + PhotoMaster *masterPtr; + int width, height; +{ + unsigned char *newPix24; + int h, offset, pitch; + unsigned char *srcPtr, *destPtr; + XRectangle validBox, clipBox; + TkRegion clipRegion; + PhotoInstance *instancePtr; + + if (masterPtr->userWidth > 0) { + width = masterPtr->userWidth; + } + if (masterPtr->userHeight > 0) { + height = masterPtr->userHeight; + } + + /* + * We have to trim the valid region if it is currently + * larger than the new image size. + */ + + TkClipBox(masterPtr->validRegion, &validBox); + if ((validBox.x + validBox.width > width) + || (validBox.y + validBox.height > height)) { + clipBox.x = 0; + clipBox.y = 0; + clipBox.width = width; + clipBox.height = height; + clipRegion = TkCreateRegion(); + TkUnionRectWithRegion(&clipBox, clipRegion, clipRegion); + TkIntersectRegion(masterPtr->validRegion, clipRegion, + masterPtr->validRegion); + TkDestroyRegion(clipRegion); + TkClipBox(masterPtr->validRegion, &validBox); + } + + if ((width != masterPtr->width) || (height != masterPtr->height) + || (masterPtr->pix24 == NULL)) { + + /* + * Reallocate storage for the 24-bit image and copy + * over valid regions. + */ + + pitch = width * 3; + newPix24 = (unsigned char *) ckalloc((unsigned) (height * pitch)); + + /* + * Zero the new array. The dithering code shouldn't read the + * areas outside validBox, but they might be copied to another + * photo image or written to a file. + */ + + if ((masterPtr->pix24 != NULL) + && ((width == masterPtr->width) || (width == validBox.width))) { + if (validBox.y > 0) { + memset((VOID *) newPix24, 0, (size_t) (validBox.y * pitch)); + } + h = validBox.y + validBox.height; + if (h < height) { + memset((VOID *) (newPix24 + h * pitch), 0, + (size_t) ((height - h) * pitch)); + } + } else { + memset((VOID *) newPix24, 0, (size_t) (height * pitch)); + } + + if (masterPtr->pix24 != NULL) { + + /* + * Copy the common area over to the new array array and + * free the old array. + */ + + if (width == masterPtr->width) { + + /* + * The region to be copied is contiguous. + */ + + offset = validBox.y * pitch; + memcpy((VOID *) (newPix24 + offset), + (VOID *) (masterPtr->pix24 + offset), + (size_t) (validBox.height * pitch)); + + } else if ((validBox.width > 0) && (validBox.height > 0)) { + + /* + * Area to be copied is not contiguous - copy line by line. + */ + + destPtr = newPix24 + (validBox.y * width + validBox.x) * 3; + srcPtr = masterPtr->pix24 + (validBox.y * masterPtr->width + + validBox.x) * 3; + for (h = validBox.height; h > 0; h--) { + memcpy((VOID *) destPtr, (VOID *) srcPtr, + (size_t) (validBox.width * 3)); + destPtr += width * 3; + srcPtr += masterPtr->width * 3; + } + } + + ckfree((char *) masterPtr->pix24); + } + + masterPtr->pix24 = newPix24; + masterPtr->width = width; + masterPtr->height = height; + + /* + * Dithering will be correct up to the end of the last + * pre-existing complete scanline. + */ + + if ((validBox.x > 0) || (validBox.y > 0)) { + masterPtr->ditherX = 0; + masterPtr->ditherY = 0; + } else if (validBox.width == width) { + if ((int) validBox.height < masterPtr->ditherY) { + masterPtr->ditherX = 0; + masterPtr->ditherY = validBox.height; + } + } else { + if ((masterPtr->ditherY > 0) + || ((int) validBox.width < masterPtr->ditherX)) { + masterPtr->ditherX = validBox.width; + masterPtr->ditherY = 0; + } + } + } + + /* + * Now adjust the sizes of the pixmaps for all of the instances. + */ + + for (instancePtr = masterPtr->instancePtr; instancePtr != NULL; + instancePtr = instancePtr->nextPtr) { + ImgPhotoInstanceSetSize(instancePtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * ImgPhotoInstanceSetSize -- + * + * This procedure reallocates the instance pixmap and dithering + * error array for a photo instance, as necessary, to change the + * image's size to `width' x `height' pixels. + * + * Results: + * None. + * + * Side effects: + * Storage gets reallocated, here and in the X server. + * + *---------------------------------------------------------------------- + */ + +static void +ImgPhotoInstanceSetSize(instancePtr) + PhotoInstance *instancePtr; /* Instance whose size is to be + * changed. */ +{ + PhotoMaster *masterPtr; + schar *newError; + schar *errSrcPtr, *errDestPtr; + int h, offset; + XRectangle validBox; + Pixmap newPixmap; + + masterPtr = instancePtr->masterPtr; + TkClipBox(masterPtr->validRegion, &validBox); + + if ((instancePtr->width != masterPtr->width) + || (instancePtr->height != masterPtr->height) + || (instancePtr->pixels == None)) { + newPixmap = Tk_GetPixmap(instancePtr->display, + RootWindow(instancePtr->display, + instancePtr->visualInfo.screen), + (masterPtr->width > 0) ? masterPtr->width: 1, + (masterPtr->height > 0) ? masterPtr->height: 1, + instancePtr->visualInfo.depth); + + /* + * The following is a gross hack needed to properly support colormaps + * under Windows. Before the pixels can be copied to the pixmap, + * the relevent colormap must be associated with the drawable. + * Normally we can infer this association from the window that + * was used to create the pixmap. However, in this case we're + * using the root window, so we have to be more explicit. + */ + + TkSetPixmapColormap(newPixmap, instancePtr->colormap); + + if (instancePtr->pixels != None) { + /* + * Copy any common pixels from the old pixmap and free it. + */ + XCopyArea(instancePtr->display, instancePtr->pixels, newPixmap, + instancePtr->gc, validBox.x, validBox.y, + validBox.width, validBox.height, validBox.x, validBox.y); + Tk_FreePixmap(instancePtr->display, instancePtr->pixels); + } + instancePtr->pixels = newPixmap; + } + + if ((instancePtr->width != masterPtr->width) + || (instancePtr->height != masterPtr->height) + || (instancePtr->error == NULL)) { + + newError = (schar *) ckalloc((unsigned) + (masterPtr->height * masterPtr->width * 3 * sizeof(schar))); + + /* + * Zero the new array so that we don't get bogus error values + * propagating into areas we dither later. + */ + + if ((instancePtr->error != NULL) + && ((instancePtr->width == masterPtr->width) + || (validBox.width == masterPtr->width))) { + if (validBox.y > 0) { + memset((VOID *) newError, 0, (size_t) + (validBox.y * masterPtr->width * 3 * sizeof(schar))); + } + h = validBox.y + validBox.height; + if (h < masterPtr->height) { + memset((VOID *) (newError + h * masterPtr->width * 3), 0, + (size_t) ((masterPtr->height - h) + * masterPtr->width * 3 * sizeof(schar))); + } + } else { + memset((VOID *) newError, 0, (size_t) + (masterPtr->height * masterPtr->width * 3 * sizeof(schar))); + } + + if (instancePtr->error != NULL) { + + /* + * Copy the common area over to the new array + * and free the old array. + */ + + if (masterPtr->width == instancePtr->width) { + + offset = validBox.y * masterPtr->width * 3; + memcpy((VOID *) (newError + offset), + (VOID *) (instancePtr->error + offset), + (size_t) (validBox.height + * masterPtr->width * 3 * sizeof(schar))); + + } else if (validBox.width > 0 && validBox.height > 0) { + + errDestPtr = newError + + (validBox.y * masterPtr->width + validBox.x) * 3; + errSrcPtr = instancePtr->error + + (validBox.y * instancePtr->width + validBox.x) * 3; + for (h = validBox.height; h > 0; --h) { + memcpy((VOID *) errDestPtr, (VOID *) errSrcPtr, + validBox.width * 3 * sizeof(schar)); + errDestPtr += masterPtr->width * 3; + errSrcPtr += instancePtr->width * 3; + } + } + ckfree((char *) instancePtr->error); + } + + instancePtr->error = newError; + } + + instancePtr->width = masterPtr->width; + instancePtr->height = masterPtr->height; +} + +/* + *---------------------------------------------------------------------- + * + * IsValidPalette -- + * + * This procedure is called to check whether a value given for + * the -palette option is valid for a particular instance + * of a photo image. + * + * Results: + * A boolean value: 1 if the palette is acceptable, 0 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +IsValidPalette(instancePtr, palette) + PhotoInstance *instancePtr; /* Instance to which the palette + * specification is to be applied. */ + char *palette; /* Palette specification string. */ +{ + int nRed, nGreen, nBlue, mono, numColors; + char *endp; + + /* + * First parse the specification: it must be of the form + * %d or %d/%d/%d. + */ + + nRed = strtol(palette, &endp, 10); + if ((endp == palette) || ((*endp != 0) && (*endp != '/')) + || (nRed < 2) || (nRed > 256)) { + return 0; + } + + if (*endp == 0) { + mono = 1; + nGreen = nBlue = nRed; + } else { + palette = endp + 1; + nGreen = strtol(palette, &endp, 10); + if ((endp == palette) || (*endp != '/') || (nGreen < 2) + || (nGreen > 256)) { + return 0; + } + palette = endp + 1; + nBlue = strtol(palette, &endp, 10); + if ((endp == palette) || (*endp != 0) || (nBlue < 2) + || (nBlue > 256)) { + return 0; + } + mono = 0; + } + + switch (instancePtr->visualInfo.class) { + case DirectColor: + case TrueColor: + if ((nRed > (1 << CountBits(instancePtr->visualInfo.red_mask))) + || (nGreen > (1 + << CountBits(instancePtr->visualInfo.green_mask))) + || (nBlue > (1 + << CountBits(instancePtr->visualInfo.blue_mask)))) { + return 0; + } + break; + case PseudoColor: + case StaticColor: + numColors = nRed; + if (!mono) { + numColors *= nGreen*nBlue; + } + if (numColors > (1 << instancePtr->visualInfo.depth)) { + return 0; + } + break; + case GrayScale: + case StaticGray: + if (!mono || (nRed > (1 << instancePtr->visualInfo.depth))) { + return 0; + } + break; + } + + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * CountBits -- + * + * This procedure counts how many bits are set to 1 in `mask'. + * + * Results: + * The integer number of bits. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +CountBits(mask) + pixel mask; /* Value to count the 1 bits in. */ +{ + int n; + + for( n = 0; mask != 0; mask &= mask - 1 ) + n++; + return n; +} + +/* + *---------------------------------------------------------------------- + * + * GetColorTable -- + * + * This procedure is called to allocate a table of colormap + * information for an instance of a photo image. Only one such + * table is allocated for all photo instances using the same + * display, colormap, palette and gamma values, so that the + * application need only request a set of colors from the X + * server once for all such photo widgets. This procedure + * maintains a hash table to find previously-allocated + * ColorTables. + * + * Results: + * None. + * + * Side effects: + * A new ColorTable may be allocated and placed in the hash + * table, and have colors allocated for it. + * + *---------------------------------------------------------------------- + */ + +static void +GetColorTable(instancePtr) + PhotoInstance *instancePtr; /* Instance needing a color table. */ +{ + ColorTable *colorPtr; + Tcl_HashEntry *entry; + ColorTableId id; + int isNew; + + /* + * Look for an existing ColorTable in the hash table. + */ + + memset((VOID *) &id, 0, sizeof(id)); + id.display = instancePtr->display; + id.colormap = instancePtr->colormap; + id.palette = instancePtr->palette; + id.gamma = instancePtr->gamma; + if (!imgPhotoColorHashInitialized) { + Tcl_InitHashTable(&imgPhotoColorHash, N_COLOR_HASH); + imgPhotoColorHashInitialized = 1; + } + entry = Tcl_CreateHashEntry(&imgPhotoColorHash, (char *) &id, &isNew); + + if (!isNew) { + /* + * Re-use the existing entry. + */ + + colorPtr = (ColorTable *) Tcl_GetHashValue(entry); + + } else { + /* + * No color table currently available; need to make one. + */ + + colorPtr = (ColorTable *) ckalloc(sizeof(ColorTable)); + + /* + * The following line of code should not normally be needed due + * to the assignment in the following line. However, it compensates + * for bugs in some compilers (HP, for example) where + * sizeof(ColorTable) is 24 but the assignment only copies 20 bytes, + * leaving 4 bytes uninitialized; these cause problems when using + * the id for lookups in imgPhotoColorHash, and can result in + * core dumps. + */ + + memset((VOID *) &colorPtr->id, 0, sizeof(ColorTableId)); + colorPtr->id = id; + Tk_PreserveColormap(colorPtr->id.display, colorPtr->id.colormap); + colorPtr->flags = 0; + colorPtr->refCount = 0; + colorPtr->liveRefCount = 0; + colorPtr->numColors = 0; + colorPtr->visualInfo = instancePtr->visualInfo; + colorPtr->pixelMap = NULL; + Tcl_SetHashValue(entry, colorPtr); + } + + colorPtr->refCount++; + colorPtr->liveRefCount++; + instancePtr->colorTablePtr = colorPtr; + if (colorPtr->flags & DISPOSE_PENDING) { + Tcl_CancelIdleCall(DisposeColorTable, (ClientData) colorPtr); + colorPtr->flags &= ~DISPOSE_PENDING; + } + + /* + * Allocate colors for this color table if necessary. + */ + + if ((colorPtr->numColors == 0) + && ((colorPtr->flags & BLACK_AND_WHITE) == 0)) { + AllocateColors(colorPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * FreeColorTable -- + * + * This procedure is called when an instance ceases using a + * color table. + * + * Results: + * None. + * + * Side effects: + * If no other instances are using this color table, a when-idle + * handler is registered to free up the color table and the colors + * allocated for it. + * + *---------------------------------------------------------------------- + */ + +static void +FreeColorTable(colorPtr) + ColorTable *colorPtr; /* Pointer to the color table which is + * no longer required by an instance. */ +{ + colorPtr->refCount--; + if (colorPtr->refCount > 0) { + return; + } + if ((colorPtr->flags & DISPOSE_PENDING) == 0) { + Tcl_DoWhenIdle(DisposeColorTable, (ClientData) colorPtr); + colorPtr->flags |= DISPOSE_PENDING; + } +} + +/* + *---------------------------------------------------------------------- + * + * AllocateColors -- + * + * This procedure allocates the colors required by a color table, + * and sets up the fields in the color table data structure which + * are used in dithering. + * + * Results: + * None. + * + * Side effects: + * Colors are allocated from the X server. Fields in the + * color table data structure are updated. + * + *---------------------------------------------------------------------- + */ + +static void +AllocateColors(colorPtr) + ColorTable *colorPtr; /* Pointer to the color table requiring + * colors to be allocated. */ +{ + int i, r, g, b, rMult, mono; + int numColors, nRed, nGreen, nBlue; + double fr, fg, fb, igam; + XColor *colors; + unsigned long *pixels; + + /* 16-bit intensity value for i/n of full intensity. */ +# define CFRAC(i, n) ((i) * 65535 / (n)) + + /* As for CFRAC, but apply exponent of g. */ +# define CGFRAC(i, n, g) ((int)(65535 * pow((double)(i) / (n), (g)))) + + /* + * First parse the palette specification to get the required number of + * shades of each primary. + */ + + mono = sscanf(colorPtr->id.palette, "%d/%d/%d", &nRed, &nGreen, &nBlue) + <= 1; + igam = 1.0 / colorPtr->id.gamma; + + /* + * Each time around this loop, we reduce the number of colors we're + * trying to allocate until we succeed in allocating all of the colors + * we need. + */ + + for (;;) { + /* + * If we are using 1 bit/pixel, we don't need to allocate + * any colors (we just use the foreground and background + * colors in the GC). + */ + + if (mono && (nRed <= 2)) { + colorPtr->flags |= BLACK_AND_WHITE; + return; + } + + /* + * Calculate the RGB coordinates of the colors we want to + * allocate and store them in *colors. + */ + + if ((colorPtr->visualInfo.class == DirectColor) + || (colorPtr->visualInfo.class == TrueColor)) { + + /* + * Direct/True Color: allocate shades of red, green, blue + * independently. + */ + + if (mono) { + numColors = nGreen = nBlue = nRed; + } else { + numColors = MAX(MAX(nRed, nGreen), nBlue); + } + colors = (XColor *) ckalloc(numColors * sizeof(XColor)); + + for (i = 0; i < numColors; ++i) { + if (igam == 1.0) { + colors[i].red = CFRAC(i, nRed - 1); + colors[i].green = CFRAC(i, nGreen - 1); + colors[i].blue = CFRAC(i, nBlue - 1); + } else { + colors[i].red = CGFRAC(i, nRed - 1, igam); + colors[i].green = CGFRAC(i, nGreen - 1, igam); + colors[i].blue = CGFRAC(i, nBlue - 1, igam); + } + } + } else { + /* + * PseudoColor, StaticColor, GrayScale or StaticGray visual: + * we have to allocate each color in the color cube separately. + */ + + numColors = (mono) ? nRed: (nRed * nGreen * nBlue); + colors = (XColor *) ckalloc(numColors * sizeof(XColor)); + + if (!mono) { + /* + * Color display using a PseudoColor or StaticColor visual. + */ + + i = 0; + for (r = 0; r < nRed; ++r) { + for (g = 0; g < nGreen; ++g) { + for (b = 0; b < nBlue; ++b) { + if (igam == 1.0) { + colors[i].red = CFRAC(r, nRed - 1); + colors[i].green = CFRAC(g, nGreen - 1); + colors[i].blue = CFRAC(b, nBlue - 1); + } else { + colors[i].red = CGFRAC(r, nRed - 1, igam); + colors[i].green = CGFRAC(g, nGreen - 1, igam); + colors[i].blue = CGFRAC(b, nBlue - 1, igam); + } + i++; + } + } + } + } else { + /* + * Monochrome display - allocate the shades of grey we want. + */ + + for (i = 0; i < numColors; ++i) { + if (igam == 1.0) { + r = CFRAC(i, numColors - 1); + } else { + r = CGFRAC(i, numColors - 1, igam); + } + colors[i].red = colors[i].green = colors[i].blue = r; + } + } + } + + /* + * Now try to allocate the colors we've calculated. + */ + + pixels = (unsigned long *) ckalloc(numColors * sizeof(unsigned long)); + for (i = 0; i < numColors; ++i) { + if (!XAllocColor(colorPtr->id.display, colorPtr->id.colormap, + &colors[i])) { + + /* + * Can't get all the colors we want in the default colormap; + * first try freeing colors from other unused color tables. + */ + + if (!ReclaimColors(&colorPtr->id, numColors - i) + || !XAllocColor(colorPtr->id.display, + colorPtr->id.colormap, &colors[i])) { + /* + * Still can't allocate the color. + */ + break; + } + } + pixels[i] = colors[i].pixel; + } + + /* + * If we didn't get all of the colors, reduce the + * resolution of the color cube, free the ones we got, + * and try again. + */ + + if (i >= numColors) { + break; + } + XFreeColors(colorPtr->id.display, colorPtr->id.colormap, pixels, i, 0); + ckfree((char *) colors); + ckfree((char *) pixels); + + if (!mono) { + if ((nRed == 2) && (nGreen == 2) && (nBlue == 2)) { + /* + * Fall back to 1-bit monochrome display. + */ + + mono = 1; + } else { + /* + * Reduce the number of shades of each primary to about + * 3/4 of the previous value. This should reduce the + * total number of colors required to about half the + * previous value for PseudoColor displays. + */ + + nRed = (nRed * 3 + 2) / 4; + nGreen = (nGreen * 3 + 2) / 4; + nBlue = (nBlue * 3 + 2) / 4; + } + } else { + /* + * Reduce the number of shades of gray to about 1/2. + */ + + nRed = nRed / 2; + } + } + + /* + * We have allocated all of the necessary colors: + * fill in various fields of the ColorTable record. + */ + + if (!mono) { + colorPtr->flags |= COLOR_WINDOW; + + /* + * The following is a hairy hack. We only want to index into + * the pixelMap on colormap displays. However, if the display + * is on Windows, then we actually want to store the index not + * the value since we will be passing the color table into the + * TkPutImage call. + */ + +#ifndef __WIN32__ + if ((colorPtr->visualInfo.class != DirectColor) + && (colorPtr->visualInfo.class != TrueColor)) { + colorPtr->flags |= MAP_COLORS; + } +#endif /* __WIN32__ */ + } + + colorPtr->numColors = numColors; + colorPtr->pixelMap = pixels; + + /* + * Set up quantization tables for dithering. + */ + rMult = nGreen * nBlue; + for (i = 0; i < 256; ++i) { + r = (i * (nRed - 1) + 127) / 255; + if (mono) { + fr = (double) colors[r].red / 65535.0; + if (colorPtr->id.gamma != 1.0 ) { + fr = pow(fr, colorPtr->id.gamma); + } + colorPtr->colorQuant[0][i] = (int)(fr * 255.99); + colorPtr->redValues[i] = colors[r].pixel; + } else { + g = (i * (nGreen - 1) + 127) / 255; + b = (i * (nBlue - 1) + 127) / 255; + if ((colorPtr->visualInfo.class == DirectColor) + || (colorPtr->visualInfo.class == TrueColor)) { + colorPtr->redValues[i] = colors[r].pixel + & colorPtr->visualInfo.red_mask; + colorPtr->greenValues[i] = colors[g].pixel + & colorPtr->visualInfo.green_mask; + colorPtr->blueValues[i] = colors[b].pixel + & colorPtr->visualInfo.blue_mask; + } else { + r *= rMult; + g *= nBlue; + colorPtr->redValues[i] = r; + colorPtr->greenValues[i] = g; + colorPtr->blueValues[i] = b; + } + fr = (double) colors[r].red / 65535.0; + fg = (double) colors[g].green / 65535.0; + fb = (double) colors[b].blue / 65535.0; + if (colorPtr->id.gamma != 1.0) { + fr = pow(fr, colorPtr->id.gamma); + fg = pow(fg, colorPtr->id.gamma); + fb = pow(fb, colorPtr->id.gamma); + } + colorPtr->colorQuant[0][i] = (int)(fr * 255.99); + colorPtr->colorQuant[1][i] = (int)(fg * 255.99); + colorPtr->colorQuant[2][i] = (int)(fb * 255.99); + } + } + + ckfree((char *) colors); +} + +/* + *---------------------------------------------------------------------- + * + * DisposeColorTable -- + * + * + * Results: + * None. + * + * Side effects: + * The colors in the argument color table are freed, as is the + * color table structure itself. The color table is removed + * from the hash table which is used to locate color tables. + * + *---------------------------------------------------------------------- + */ + +static void +DisposeColorTable(clientData) + ClientData clientData; /* Pointer to the ColorTable whose + * colors are to be released. */ +{ + ColorTable *colorPtr; + Tcl_HashEntry *entry; + + colorPtr = (ColorTable *) clientData; + if (colorPtr->pixelMap != NULL) { + if (colorPtr->numColors > 0) { + XFreeColors(colorPtr->id.display, colorPtr->id.colormap, + colorPtr->pixelMap, colorPtr->numColors, 0); + Tk_FreeColormap(colorPtr->id.display, colorPtr->id.colormap); + } + ckfree((char *) colorPtr->pixelMap); + } + + entry = Tcl_FindHashEntry(&imgPhotoColorHash, (char *) &colorPtr->id); + if (entry == NULL) { + panic("DisposeColorTable couldn't find hash entry"); + } + Tcl_DeleteHashEntry(entry); + + ckfree((char *) colorPtr); +} + +/* + *---------------------------------------------------------------------- + * + * ReclaimColors -- + * + * This procedure is called to try to free up colors in the + * colormap used by a color table. It looks for other color + * tables with the same colormap and with a zero live reference + * count, and frees their colors. It only does so if there is + * the possibility of freeing up at least `numColors' colors. + * + * Results: + * The return value is TRUE if any colors were freed, FALSE + * otherwise. + * + * Side effects: + * ColorTables which are not currently in use may lose their + * color allocations. + * + *---------------------------------------------------------------------- */ + +static int +ReclaimColors(id, numColors) + ColorTableId *id; /* Pointer to information identifying + * the color table which needs more colors. */ + int numColors; /* Number of colors required. */ +{ + Tcl_HashSearch srch; + Tcl_HashEntry *entry; + ColorTable *colorPtr; + int nAvail; + + /* + * First scan through the color hash table to get an + * upper bound on how many colors we might be able to free. + */ + + nAvail = 0; + entry = Tcl_FirstHashEntry(&imgPhotoColorHash, &srch); + while (entry != NULL) { + colorPtr = (ColorTable *) Tcl_GetHashValue(entry); + if ((colorPtr->id.display == id->display) + && (colorPtr->id.colormap == id->colormap) + && (colorPtr->liveRefCount == 0 )&& (colorPtr->numColors != 0) + && ((colorPtr->id.palette != id->palette) + || (colorPtr->id.gamma != id->gamma))) { + + /* + * We could take this guy's colors off him. + */ + + nAvail += colorPtr->numColors; + } + entry = Tcl_NextHashEntry(&srch); + } + + /* + * nAvail is an (over)estimate of the number of colors we could free. + */ + + if (nAvail < numColors) { + return 0; + } + + /* + * Scan through a second time freeing colors. + */ + + entry = Tcl_FirstHashEntry(&imgPhotoColorHash, &srch); + while ((entry != NULL) && (numColors > 0)) { + colorPtr = (ColorTable *) Tcl_GetHashValue(entry); + if ((colorPtr->id.display == id->display) + && (colorPtr->id.colormap == id->colormap) + && (colorPtr->liveRefCount == 0) && (colorPtr->numColors != 0) + && ((colorPtr->id.palette != id->palette) + || (colorPtr->id.gamma != id->gamma))) { + + /* + * Free the colors that this ColorTable has. + */ + + XFreeColors(colorPtr->id.display, colorPtr->id.colormap, + colorPtr->pixelMap, colorPtr->numColors, 0); + numColors -= colorPtr->numColors; + colorPtr->numColors = 0; + ckfree((char *) colorPtr->pixelMap); + colorPtr->pixelMap = NULL; + } + + entry = Tcl_NextHashEntry(&srch); + } + return 1; /* we freed some colors */ +} + +/* + *---------------------------------------------------------------------- + * + * DisposeInstance -- + * + * This procedure is called to finally free up an instance + * of a photo image which is no longer required. + * + * Results: + * None. + * + * Side effects: + * The instance data structure and the resources it references + * are freed. + * + *---------------------------------------------------------------------- + */ + +static void +DisposeInstance(clientData) + ClientData clientData; /* Pointer to the instance whose resources + * are to be released. */ +{ + PhotoInstance *instancePtr = (PhotoInstance *) clientData; + PhotoInstance *prevPtr; + + if (instancePtr->pixels != None) { + Tk_FreePixmap(instancePtr->display, instancePtr->pixels); + } + if (instancePtr->gc != None) { + Tk_FreeGC(instancePtr->display, instancePtr->gc); + } + if (instancePtr->imagePtr != NULL) { + XFree((char *) instancePtr->imagePtr); + } + if (instancePtr->error != NULL) { + ckfree((char *) instancePtr->error); + } + if (instancePtr->colorTablePtr != NULL) { + FreeColorTable(instancePtr->colorTablePtr); + } + + if (instancePtr->masterPtr->instancePtr == instancePtr) { + instancePtr->masterPtr->instancePtr = instancePtr->nextPtr; + } else { + for (prevPtr = instancePtr->masterPtr->instancePtr; + prevPtr->nextPtr != instancePtr; prevPtr = prevPtr->nextPtr) { + /* Empty loop body */ + } + prevPtr->nextPtr = instancePtr->nextPtr; + } + Tk_FreeColormap(instancePtr->display, instancePtr->colormap); + ckfree((char *) instancePtr); +} + +/* + *---------------------------------------------------------------------- + * + * MatchFileFormat -- + * + * This procedure is called to find a photo image file format + * handler which can parse the image data in the given file. + * If a user-specified format string is provided, only handlers + * whose names match a prefix of the format string are tried. + * + * Results: + * A standard TCL return value. If the return value is TCL_OK, a + * pointer to the image format record is returned in + * *imageFormatPtr, and the width and height of the image are + * returned in *widthPtr and *heightPtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +MatchFileFormat(interp, chan, fileName, formatString, imageFormatPtr, + widthPtr, heightPtr) + Tcl_Interp *interp; /* Interpreter to use for reporting errors. */ + Tcl_Channel chan; /* The image file, open for reading. */ + char *fileName; /* The name of the image file. */ + char *formatString; /* User-specified format string, or NULL. */ + Tk_PhotoImageFormat **imageFormatPtr; + /* A pointer to the photo image format + * record is returned here. */ + int *widthPtr, *heightPtr; /* The dimensions of the image are + * returned here. */ +{ + int matched; + Tk_PhotoImageFormat *formatPtr; + + /* + * Scan through the table of file format handlers to find + * one which can handle the image. + */ + + matched = 0; + for (formatPtr = formatList; formatPtr != NULL; + formatPtr = formatPtr->nextPtr) { + if (formatString != NULL) { + if (strncasecmp(formatString, formatPtr->name, + strlen(formatPtr->name)) != 0) { + continue; + } + matched = 1; + if (formatPtr->fileMatchProc == NULL) { + Tcl_AppendResult(interp, "-file option isn't supported for ", + formatString, " images", (char *) NULL); + return TCL_ERROR; + } + } + if (formatPtr->fileMatchProc != NULL) { + (void) Tcl_Seek(chan, 0L, SEEK_SET); + + if ((*formatPtr->fileMatchProc)(chan, fileName, formatString, + widthPtr, heightPtr)) { + if (*widthPtr < 1) { + *widthPtr = 1; + } + if (*heightPtr < 1) { + *heightPtr = 1; + } + break; + } + } + } + + if (formatPtr == NULL) { + if ((formatString != NULL) && !matched) { + Tcl_AppendResult(interp, "image file format \"", formatString, + "\" is not supported", (char *) NULL); + } else { + Tcl_AppendResult(interp, + "couldn't recognize data in image file \"", + fileName, "\"", (char *) NULL); + } + return TCL_ERROR; + } + + *imageFormatPtr = formatPtr; + (void) Tcl_Seek(chan, 0L, SEEK_SET); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * MatchStringFormat -- + * + * This procedure is called to find a photo image file format + * handler which can parse the image data in the given string. + * If a user-specified format string is provided, only handlers + * whose names match a prefix of the format string are tried. + * + * Results: + * A standard TCL return value. If the return value is TCL_OK, a + * pointer to the image format record is returned in + * *imageFormatPtr, and the width and height of the image are + * returned in *widthPtr and *heightPtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +MatchStringFormat(interp, string, formatString, imageFormatPtr, + widthPtr, heightPtr) + Tcl_Interp *interp; /* Interpreter to use for reporting errors. */ + char *string; /* String containing the image data. */ + char *formatString; /* User-specified format string, or NULL. */ + Tk_PhotoImageFormat **imageFormatPtr; + /* A pointer to the photo image format + * record is returned here. */ + int *widthPtr, *heightPtr; /* The dimensions of the image are + * returned here. */ +{ + int matched; + Tk_PhotoImageFormat *formatPtr; + + /* + * Scan through the table of file format handlers to find + * one which can handle the image. + */ + + matched = 0; + for (formatPtr = formatList; formatPtr != NULL; + formatPtr = formatPtr->nextPtr) { + if (formatString != NULL) { + if (strncasecmp(formatString, formatPtr->name, + strlen(formatPtr->name)) != 0) { + continue; + } + matched = 1; + if (formatPtr->stringMatchProc == NULL) { + Tcl_AppendResult(interp, "-data option isn't supported for ", + formatString, " images", (char *) NULL); + return TCL_ERROR; + } + } + if ((formatPtr->stringMatchProc != NULL) + && (*formatPtr->stringMatchProc)(string, formatString, + widthPtr, heightPtr)) { + break; + } + } + + if (formatPtr == NULL) { + if ((formatString != NULL) && !matched) { + Tcl_AppendResult(interp, "image format \"", formatString, + "\" is not supported", (char *) NULL); + } else { + Tcl_AppendResult(interp, "couldn't recognize image data", + (char *) NULL); + } + return TCL_ERROR; + } + + *imageFormatPtr = formatPtr; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_FindPhoto -- + * + * This procedure is called to get an opaque handle (actually a + * PhotoMaster *) for a given image, which can be used in + * subsequent calls to Tk_PhotoPutBlock, etc. The `name' + * parameter is the name of the image. + * + * Results: + * The handle for the photo image, or NULL if there is no + * photo image with the name given. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tk_PhotoHandle +Tk_FindPhoto(interp, imageName) + Tcl_Interp *interp; /* Interpreter (application) in which image + * exists. */ + char *imageName; /* Name of the desired photo image. */ +{ + ClientData clientData; + Tk_ImageType *typePtr; + + clientData = Tk_GetImageMasterData(interp, imageName, &typePtr); + if (typePtr != &tkPhotoImageType) { + return NULL; + } + return (Tk_PhotoHandle) clientData; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_PhotoPutBlock -- + * + * This procedure is called to put image data into a photo image. + * + * Results: + * None. + * + * Side effects: + * The image data is stored. The image may be expanded. + * The Tk image code is informed that the image has changed. + * + *---------------------------------------------------------------------- */ + +void +Tk_PhotoPutBlock(handle, blockPtr, x, y, width, height) + Tk_PhotoHandle handle; /* Opaque handle for the photo image + * to be updated. */ + register Tk_PhotoImageBlock *blockPtr; + /* Pointer to a structure describing the + * pixel data to be copied into the image. */ + int x, y; /* Coordinates of the top-left pixel to + * be updated in the image. */ + int width, height; /* Dimensions of the area of the image + * to be updated. */ +{ + register PhotoMaster *masterPtr; + int xEnd, yEnd; + int greenOffset, blueOffset; + int wLeft, hLeft; + int wCopy, hCopy; + unsigned char *srcPtr, *srcLinePtr; + unsigned char *destPtr, *destLinePtr; + int pitch; + XRectangle rect; + + masterPtr = (PhotoMaster *) handle; + + if ((masterPtr->userWidth != 0) && ((x + width) > masterPtr->userWidth)) { + width = masterPtr->userWidth - x; + } + if ((masterPtr->userHeight != 0) + && ((y + height) > masterPtr->userHeight)) { + height = masterPtr->userHeight - y; + } + if ((width <= 0) || (height <= 0)) + return; + + xEnd = x + width; + yEnd = y + height; + if ((xEnd > masterPtr->width) || (yEnd > masterPtr->height)) { + ImgPhotoSetSize(masterPtr, MAX(xEnd, masterPtr->width), + MAX(yEnd, masterPtr->height)); + } + + if ((y < masterPtr->ditherY) || ((y == masterPtr->ditherY) + && (x < masterPtr->ditherX))) { + /* + * The dithering isn't correct past the start of this block. + */ + masterPtr->ditherX = x; + masterPtr->ditherY = y; + } + + /* + * If this image block could have different red, green and blue + * components, mark it as a color image. + */ + + greenOffset = blockPtr->offset[1] - blockPtr->offset[0]; + blueOffset = blockPtr->offset[2] - blockPtr->offset[0]; + if ((greenOffset != 0) || (blueOffset != 0)) { + masterPtr->flags |= COLOR_IMAGE; + } + + /* + * Copy the data into our local 24-bit/pixel array. + * If we can do it with a single memcpy, we do. + */ + + destLinePtr = masterPtr->pix24 + (y * masterPtr->width + x) * 3; + pitch = masterPtr->width * 3; + + if ((blockPtr->pixelSize == 3) && (greenOffset == 1) && (blueOffset == 2) + && (width <= blockPtr->width) && (height <= blockPtr->height) + && ((height == 1) || ((x == 0) && (width == masterPtr->width) + && (blockPtr->pitch == pitch)))) { + memcpy((VOID *) destLinePtr, + (VOID *) (blockPtr->pixelPtr + blockPtr->offset[0]), + (size_t) (height * width * 3)); + } else { + for (hLeft = height; hLeft > 0;) { + srcLinePtr = blockPtr->pixelPtr + blockPtr->offset[0]; + hCopy = MIN(hLeft, blockPtr->height); + hLeft -= hCopy; + for (; hCopy > 0; --hCopy) { + destPtr = destLinePtr; + for (wLeft = width; wLeft > 0;) { + wCopy = MIN(wLeft, blockPtr->width); + wLeft -= wCopy; + srcPtr = srcLinePtr; + for (; wCopy > 0; --wCopy) { + *destPtr++ = srcPtr[0]; + *destPtr++ = srcPtr[greenOffset]; + *destPtr++ = srcPtr[blueOffset]; + srcPtr += blockPtr->pixelSize; + } + } + srcLinePtr += blockPtr->pitch; + destLinePtr += pitch; + } + } + } + + /* + * Add this new block to the region which specifies which data is valid. + */ + + rect.x = x; + rect.y = y; + rect.width = width; + rect.height = height; + TkUnionRectWithRegion(&rect, masterPtr->validRegion, + masterPtr->validRegion); + + /* + * Update each instance. + */ + + Dither(masterPtr, x, y, width, height); + + /* + * Tell the core image code that this image has changed. + */ + + Tk_ImageChanged(masterPtr->tkMaster, x, y, width, height, masterPtr->width, + masterPtr->height); +} + +/* + *---------------------------------------------------------------------- + * + * Tk_PhotoPutZoomedBlock -- + * + * This procedure is called to put image data into a photo image, + * with possible subsampling and/or zooming of the pixels. + * + * Results: + * None. + * + * Side effects: + * The image data is stored. The image may be expanded. + * The Tk image code is informed that the image has changed. + * + *---------------------------------------------------------------------- + */ + +void +Tk_PhotoPutZoomedBlock(handle, blockPtr, x, y, width, height, zoomX, zoomY, + subsampleX, subsampleY) + Tk_PhotoHandle handle; /* Opaque handle for the photo image + * to be updated. */ + register Tk_PhotoImageBlock *blockPtr; + /* Pointer to a structure describing the + * pixel data to be copied into the image. */ + int x, y; /* Coordinates of the top-left pixel to + * be updated in the image. */ + int width, height; /* Dimensions of the area of the image + * to be updated. */ + int zoomX, zoomY; /* Zoom factors for the X and Y axes. */ + int subsampleX, subsampleY; /* Subsampling factors for the X and Y axes. */ +{ + register PhotoMaster *masterPtr; + int xEnd, yEnd; + int greenOffset, blueOffset; + int wLeft, hLeft; + int wCopy, hCopy; + int blockWid, blockHt; + unsigned char *srcPtr, *srcLinePtr, *srcOrigPtr; + unsigned char *destPtr, *destLinePtr; + int pitch; + int xRepeat, yRepeat; + int blockXSkip, blockYSkip; + XRectangle rect; + + if ((zoomX == 1) && (zoomY == 1) && (subsampleX == 1) + && (subsampleY == 1)) { + Tk_PhotoPutBlock(handle, blockPtr, x, y, width, height); + return; + } + + masterPtr = (PhotoMaster *) handle; + + if ((zoomX <= 0) || (zoomY <= 0)) + return; + if ((masterPtr->userWidth != 0) && ((x + width) > masterPtr->userWidth)) { + width = masterPtr->userWidth - x; + } + if ((masterPtr->userHeight != 0) + && ((y + height) > masterPtr->userHeight)) { + height = masterPtr->userHeight - y; + } + if ((width <= 0) || (height <= 0)) + return; + + xEnd = x + width; + yEnd = y + height; + if ((xEnd > masterPtr->width) || (yEnd > masterPtr->height)) { + int sameSrc = (blockPtr->pixelPtr == masterPtr->pix24); + ImgPhotoSetSize(masterPtr, MAX(xEnd, masterPtr->width), + MAX(yEnd, masterPtr->height)); + if (sameSrc) { + blockPtr->pixelPtr = masterPtr->pix24; + } + } + + if ((y < masterPtr->ditherY) || ((y == masterPtr->ditherY) + && (x < masterPtr->ditherX))) { + /* + * The dithering isn't correct past the start of this block. + */ + + masterPtr->ditherX = x; + masterPtr->ditherY = y; + } + + /* + * If this image block could have different red, green and blue + * components, mark it as a color image. + */ + + greenOffset = blockPtr->offset[1] - blockPtr->offset[0]; + blueOffset = blockPtr->offset[2] - blockPtr->offset[0]; + if ((greenOffset != 0) || (blueOffset != 0)) { + masterPtr->flags |= COLOR_IMAGE; + } + + /* + * Work out what area the pixel data in the block expands to after + * subsampling and zooming. + */ + + blockXSkip = subsampleX * blockPtr->pixelSize; + blockYSkip = subsampleY * blockPtr->pitch; + if (subsampleX > 0) + blockWid = ((blockPtr->width + subsampleX - 1) / subsampleX) * zoomX; + else if (subsampleX == 0) + blockWid = width; + else + blockWid = ((blockPtr->width - subsampleX - 1) / -subsampleX) * zoomX; + if (subsampleY > 0) + blockHt = ((blockPtr->height + subsampleY - 1) / subsampleY) * zoomY; + else if (subsampleY == 0) + blockHt = height; + else + blockHt = ((blockPtr->height - subsampleY - 1) / -subsampleY) * zoomY; + + /* + * Copy the data into our local 24-bit/pixel array. + */ + + destLinePtr = masterPtr->pix24 + (y * masterPtr->width + x) * 3; + srcOrigPtr = blockPtr->pixelPtr + blockPtr->offset[0]; + if (subsampleX < 0) { + srcOrigPtr += (blockPtr->width - 1) * blockPtr->pixelSize; + } + if (subsampleY < 0) { + srcOrigPtr += (blockPtr->height - 1) * blockPtr->pitch; + } + + pitch = masterPtr->width * 3; + for (hLeft = height; hLeft > 0; ) { + hCopy = MIN(hLeft, blockHt); + hLeft -= hCopy; + yRepeat = zoomY; + srcLinePtr = srcOrigPtr; + for (; hCopy > 0; --hCopy) { + destPtr = destLinePtr; + for (wLeft = width; wLeft > 0;) { + wCopy = MIN(wLeft, blockWid); + wLeft -= wCopy; + srcPtr = srcLinePtr; + for (; wCopy > 0; wCopy -= zoomX) { + for (xRepeat = MIN(wCopy, zoomX); xRepeat > 0; xRepeat--) { + *destPtr++ = srcPtr[0]; + *destPtr++ = srcPtr[greenOffset]; + *destPtr++ = srcPtr[blueOffset]; + } + srcPtr += blockXSkip; + } + } + destLinePtr += pitch; + yRepeat--; + if (yRepeat <= 0) { + srcLinePtr += blockYSkip; + yRepeat = zoomY; + } + } + } + + /* + * Add this new block to the region that specifies which data is valid. + */ + + rect.x = x; + rect.y = y; + rect.width = width; + rect.height = height; + TkUnionRectWithRegion(&rect, masterPtr->validRegion, + masterPtr->validRegion); + + /* + * Update each instance. + */ + + Dither(masterPtr, x, y, width, height); + + /* + * Tell the core image code that this image has changed. + */ + + Tk_ImageChanged(masterPtr->tkMaster, x, y, width, height, masterPtr->width, + masterPtr->height); +} + +/* + *---------------------------------------------------------------------- + * + * Dither -- + * + * This procedure is called to update an area of each instance's + * pixmap by dithering the corresponding area of the image master. + * + * Results: + * None. + * + * Side effects: + * The pixmap of each instance of this image gets updated. + * The fields in *masterPtr indicating which area of the image + * is correctly dithered get updated. + * + *---------------------------------------------------------------------- + */ + +static void +Dither(masterPtr, x, y, width, height) + PhotoMaster *masterPtr; /* Image master whose instances are + * to be updated. */ + int x, y; /* Coordinates of the top-left pixel + * in the area to be dithered. */ + int width, height; /* Dimensions of the area to be dithered. */ +{ + PhotoInstance *instancePtr; + + if ((width <= 0) || (height <= 0)) { + return; + } + + for (instancePtr = masterPtr->instancePtr; instancePtr != NULL; + instancePtr = instancePtr->nextPtr) { + DitherInstance(instancePtr, x, y, width, height); + } + + /* + * Work out whether this block will be correctly dithered + * and whether it will extend the correctly dithered region. + */ + + if (((y < masterPtr->ditherY) + || ((y == masterPtr->ditherY) && (x <= masterPtr->ditherX))) + && ((y + height) > (masterPtr->ditherY))) { + + /* + * This block starts inside (or immediately after) the correctly + * dithered region, so the first scan line at least will be right. + * Furthermore this block extends into scanline masterPtr->ditherY. + */ + + if ((x == 0) && (width == masterPtr->width)) { + /* + * We are doing the full width, therefore the dithering + * will be correct to the end. + */ + + masterPtr->ditherX = 0; + masterPtr->ditherY = y + height; + } else { + /* + * We are doing partial scanlines, therefore the + * correctly-dithered region will be extended by + * at most one scan line. + */ + + if (x <= masterPtr->ditherX) { + masterPtr->ditherX = x + width; + if (masterPtr->ditherX >= masterPtr->width) { + masterPtr->ditherX = 0; + masterPtr->ditherY++; + } + } + } + } + +} + +/* + *---------------------------------------------------------------------- + * + * DitherInstance -- + * + * This procedure is called to update an area of an instance's + * pixmap by dithering the corresponding area of the master. + * + * Results: + * None. + * + * Side effects: + * The instance's pixmap gets updated. + * + *---------------------------------------------------------------------- + */ + +static void +DitherInstance(instancePtr, xStart, yStart, width, height) + PhotoInstance *instancePtr; /* The instance to be updated. */ + int xStart, yStart; /* Coordinates of the top-left pixel in the + * block to be dithered. */ + int width, height; /* Dimensions of the block to be dithered. */ +{ + PhotoMaster *masterPtr; + ColorTable *colorPtr; + XImage *imagePtr; + int nLines, bigEndian; + int i, c, x, y; + int xEnd, yEnd; + int bitsPerPixel, bytesPerLine, lineLength; + unsigned char *srcLinePtr, *srcPtr; + schar *errLinePtr, *errPtr; + unsigned char *destBytePtr, *dstLinePtr; + pixel *destLongPtr; + pixel firstBit, word, mask; + int col[3]; + int doDithering = 1; + + colorPtr = instancePtr->colorTablePtr; + masterPtr = instancePtr->masterPtr; + + /* + * Turn dithering off in certain cases where it is not + * needed (TrueColor, DirectColor with many colors). + */ + + if ((colorPtr->visualInfo.class == DirectColor) + || (colorPtr->visualInfo.class == TrueColor)) { + int nRed, nGreen, nBlue, result; + + result = sscanf(colorPtr->id.palette, "%d/%d/%d", &nRed, + &nGreen, &nBlue); + if ((nRed >= 256) + && ((result == 1) || ((nGreen >= 256) && (nBlue >= 256)))) { + doDithering = 0; + } + } + + /* + * First work out how many lines to do at a time, + * then how many bytes we'll need for pixel storage, + * and allocate it. + */ + + nLines = (MAX_PIXELS + width - 1) / width; + if (nLines < 1) { + nLines = 1; + } + if (nLines > height ) { + nLines = height; + } + + imagePtr = instancePtr->imagePtr; + if (imagePtr == NULL) { + return; /* we must be really tight on memory */ + } + bitsPerPixel = imagePtr->bits_per_pixel; + bytesPerLine = ((bitsPerPixel * width + 31) >> 3) & ~3; + imagePtr->width = width; + imagePtr->height = nLines; + imagePtr->bytes_per_line = bytesPerLine; + imagePtr->data = (char *) ckalloc((unsigned) (imagePtr->bytes_per_line * nLines)); + bigEndian = imagePtr->bitmap_bit_order == MSBFirst; + firstBit = bigEndian? (1 << (imagePtr->bitmap_unit - 1)): 1; + + lineLength = masterPtr->width * 3; + srcLinePtr = masterPtr->pix24 + yStart * lineLength + xStart * 3; + errLinePtr = instancePtr->error + yStart * lineLength + xStart * 3; + xEnd = xStart + width; + + /* + * Loop over the image, doing at most nLines lines before + * updating the screen image. + */ + + for (; height > 0; height -= nLines) { + if (nLines > height) { + nLines = height; + } + dstLinePtr = (unsigned char *) imagePtr->data; + yEnd = yStart + nLines; + for (y = yStart; y < yEnd; ++y) { + srcPtr = srcLinePtr; + errPtr = errLinePtr; + destBytePtr = dstLinePtr; + destLongPtr = (pixel *) dstLinePtr; + if (colorPtr->flags & COLOR_WINDOW) { + /* + * Color window. We dither the three components + * independently, using Floyd-Steinberg dithering, + * which propagates errors from the quantization of + * pixels to the pixels below and to the right. + */ + + for (x = xStart; x < xEnd; ++x) { + if (doDithering) { + for (i = 0; i < 3; ++i) { + /* + * Compute the error propagated into this pixel + * for this component. + * If e[x,y] is the array of quantization error + * values, we compute + * 7/16 * e[x-1,y] + 1/16 * e[x-1,y-1] + * + 5/16 * e[x,y-1] + 3/16 * e[x+1,y-1] + * and round it to an integer. + * + * The expression ((c + 2056) >> 4) - 128 + * computes round(c / 16), and works correctly on + * machines without a sign-extending right shift. + */ + + c = (x > 0) ? errPtr[-3] * 7: 0; + if (y > 0) { + if (x > 0) { + c += errPtr[-lineLength-3]; + } + c += errPtr[-lineLength] * 5; + if ((x + 1) < masterPtr->width) { + c += errPtr[-lineLength+3] * 3; + } + } + + /* + * Add the propagated error to the value of this + * component, quantize it, and store the + * quantization error. + */ + + c = ((c + 2056) >> 4) - 128 + *srcPtr++; + if (c < 0) { + c = 0; + } else if (c > 255) { + c = 255; + } + col[i] = colorPtr->colorQuant[i][c]; + *errPtr++ = c - col[i]; + } + } else { + /* + * Output is virtually continuous in this case, + * so don't bother dithering. + */ + + col[0] = *srcPtr++; + col[1] = *srcPtr++; + col[2] = *srcPtr++; + } + + /* + * Translate the quantized component values into + * an X pixel value, and store it in the image. + */ + + i = colorPtr->redValues[col[0]] + + colorPtr->greenValues[col[1]] + + colorPtr->blueValues[col[2]]; + if (colorPtr->flags & MAP_COLORS) { + i = colorPtr->pixelMap[i]; + } + switch (bitsPerPixel) { + case NBBY: + *destBytePtr++ = i; + break; +#ifndef __WIN32__ +/* + * This case is not valid for Windows because the image format is different + * from the pixel format in Win32. Eventually we need to fix the image + * code in Tk to use the Windows native image ordering. This would speed + * up the image code for all of the common sizes. + */ + + case NBBY * sizeof(pixel): + *destLongPtr++ = i; + break; +#endif + default: + XPutPixel(imagePtr, x - xStart, y - yStart, + (unsigned) i); + } + } + + } else if (bitsPerPixel > 1) { + /* + * Multibit monochrome window. The operation here is similar + * to the color window case above, except that there is only + * one component. If the master image is in color, use the + * luminance computed as + * 0.344 * red + 0.5 * green + 0.156 * blue. + */ + + for (x = xStart; x < xEnd; ++x) { + c = (x > 0) ? errPtr[-1] * 7: 0; + if (y > 0) { + if (x > 0) { + c += errPtr[-lineLength-1]; + } + c += errPtr[-lineLength] * 5; + if (x + 1 < masterPtr->width) { + c += errPtr[-lineLength+1] * 3; + } + } + c = ((c + 2056) >> 4) - 128; + + if ((masterPtr->flags & COLOR_IMAGE) == 0) { + c += srcPtr[0]; + } else { + c += (unsigned)(srcPtr[0] * 11 + srcPtr[1] * 16 + + srcPtr[2] * 5 + 16) >> 5; + } + srcPtr += 3; + + if (c < 0) { + c = 0; + } else if (c > 255) { + c = 255; + } + i = colorPtr->colorQuant[0][c]; + *errPtr++ = c - i; + i = colorPtr->redValues[i]; + switch (bitsPerPixel) { + case NBBY: + *destBytePtr++ = i; + break; +#ifndef __WIN32__ +/* + * This case is not valid for Windows because the image format is different + * from the pixel format in Win32. Eventually we need to fix the image + * code in Tk to use the Windows native image ordering. This would speed + * up the image code for all of the common sizes. + */ + + case NBBY * sizeof(pixel): + *destLongPtr++ = i; + break; +#endif + default: + XPutPixel(imagePtr, x - xStart, y - yStart, + (unsigned) i); + } + } + } else { + /* + * 1-bit monochrome window. This is similar to the + * multibit monochrome case above, except that the + * quantization is simpler (we only have black = 0 + * and white = 255), and we produce an XY-Bitmap. + */ + + word = 0; + mask = firstBit; + for (x = xStart; x < xEnd; ++x) { + /* + * If we have accumulated a whole word, store it + * in the image and start a new word. + */ + + if (mask == 0) { + *destLongPtr++ = word; + mask = firstBit; + word = 0; + } + + c = (x > 0) ? errPtr[-1] * 7: 0; + if (y > 0) { + if (x > 0) { + c += errPtr[-lineLength-1]; + } + c += errPtr[-lineLength] * 5; + if (x + 1 < masterPtr->width) { + c += errPtr[-lineLength+1] * 3; + } + } + c = ((c + 2056) >> 4) - 128; + + if ((masterPtr->flags & COLOR_IMAGE) == 0) { + c += srcPtr[0]; + } else { + c += (unsigned)(srcPtr[0] * 11 + srcPtr[1] * 16 + + srcPtr[2] * 5 + 16) >> 5; + } + srcPtr += 3; + + if (c < 0) { + c = 0; + } else if (c > 255) { + c = 255; + } + if (c >= 128) { + word |= mask; + *errPtr++ = c - 255; + } else { + *errPtr++ = c; + } + mask = bigEndian? (mask >> 1): (mask << 1); + } + *destLongPtr = word; + } + srcLinePtr += lineLength; + errLinePtr += lineLength; + dstLinePtr += bytesPerLine; + } + + /* + * Update the pixmap for this instance with the block of + * pixels that we have just computed. + */ + + TkPutImage(colorPtr->pixelMap, colorPtr->numColors, + instancePtr->display, instancePtr->pixels, + instancePtr->gc, imagePtr, 0, 0, xStart, yStart, + (unsigned) width, (unsigned) nLines); + yStart = yEnd; + + } + + ckfree(imagePtr->data); + imagePtr->data = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_PhotoBlank -- + * + * This procedure is called to clear an entire photo image. + * + * Results: + * None. + * + * Side effects: + * The valid region for the image is set to the null region. + * The generic image code is notified that the image has changed. + * + *---------------------------------------------------------------------- + */ + +void +Tk_PhotoBlank(handle) + Tk_PhotoHandle handle; /* Handle for the image to be blanked. */ +{ + PhotoMaster *masterPtr; + PhotoInstance *instancePtr; + + masterPtr = (PhotoMaster *) handle; + masterPtr->ditherX = masterPtr->ditherY = 0; + masterPtr->flags = 0; + + /* + * The image has valid data nowhere. + */ + + if (masterPtr->validRegion != NULL) { + TkDestroyRegion(masterPtr->validRegion); + } + masterPtr->validRegion = TkCreateRegion(); + + /* + * Clear out the 24-bit pixel storage array. + * Clear out the dithering error arrays for each instance. + */ + + memset((VOID *) masterPtr->pix24, 0, + (size_t) (masterPtr->width * masterPtr->height * 3)); + for (instancePtr = masterPtr->instancePtr; instancePtr != NULL; + instancePtr = instancePtr->nextPtr) { + if (instancePtr->error) { + memset((VOID *) instancePtr->error, 0, + (size_t) (masterPtr->width * masterPtr->height + * 3 * sizeof(schar))); + } + } + + /* + * Tell the core image code that this image has changed. + */ + + Tk_ImageChanged(masterPtr->tkMaster, 0, 0, masterPtr->width, + masterPtr->height, masterPtr->width, masterPtr->height); +} + +/* + *---------------------------------------------------------------------- + * + * Tk_PhotoExpand -- + * + * This procedure is called to request that a photo image be + * expanded if necessary to be at least `width' pixels wide and + * `height' pixels high. If the user has declared a definite + * image size (using the -width and -height configuration + * options) then this call has no effect. + * + * Results: + * None. + * + * Side effects: + * The size of the photo image may change; if so the generic + * image code is informed. + * + *---------------------------------------------------------------------- + */ + +void +Tk_PhotoExpand(handle, width, height) + Tk_PhotoHandle handle; /* Handle for the image to be expanded. */ + int width, height; /* Desired minimum dimensions of the image. */ +{ + PhotoMaster *masterPtr; + + masterPtr = (PhotoMaster *) handle; + + if (width <= masterPtr->width) { + width = masterPtr->width; + } + if (height <= masterPtr->height) { + height = masterPtr->height; + } + if ((width != masterPtr->width) || (height != masterPtr->height)) { + ImgPhotoSetSize(masterPtr, MAX(width, masterPtr->width), + MAX(height, masterPtr->height)); + Tk_ImageChanged(masterPtr->tkMaster, 0, 0, 0, 0, masterPtr->width, + masterPtr->height); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tk_PhotoGetSize -- + * + * This procedure is called to obtain the current size of a photo + * image. + * + * Results: + * The image's width and height are returned in *widthp + * and *heightp. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tk_PhotoGetSize(handle, widthPtr, heightPtr) + Tk_PhotoHandle handle; /* Handle for the image whose dimensions + * are requested. */ + int *widthPtr, *heightPtr; /* The dimensions of the image are returned + * here. */ +{ + PhotoMaster *masterPtr; + + masterPtr = (PhotoMaster *) handle; + *widthPtr = masterPtr->width; + *heightPtr = masterPtr->height; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_PhotoSetSize -- + * + * This procedure is called to set size of a photo image. + * This call is equivalent to using the -width and -height + * configuration options. + * + * Results: + * None. + * + * Side effects: + * The size of the image may change; if so the generic + * image code is informed. + * + *---------------------------------------------------------------------- + */ + +void +Tk_PhotoSetSize(handle, width, height) + Tk_PhotoHandle handle; /* Handle for the image whose size is to + * be set. */ + int width, height; /* New dimensions for the image. */ +{ + PhotoMaster *masterPtr; + + masterPtr = (PhotoMaster *) handle; + + masterPtr->userWidth = width; + masterPtr->userHeight = height; + ImgPhotoSetSize(masterPtr, ((width > 0) ? width: masterPtr->width), + ((height > 0) ? height: masterPtr->height)); + Tk_ImageChanged(masterPtr->tkMaster, 0, 0, 0, 0, + masterPtr->width, masterPtr->height); +} + +/* + *---------------------------------------------------------------------- + * + * Tk_PhotoGetImage -- + * + * This procedure is called to obtain image data from a photo + * image. This procedure fills in the Tk_PhotoImageBlock structure + * pointed to by `blockPtr' with details of the address and + * layout of the image data in memory. + * + * Results: + * TRUE (1) indicating that image data is available, + * for backwards compatibility with the old photo widget. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tk_PhotoGetImage(handle, blockPtr) + Tk_PhotoHandle handle; /* Handle for the photo image from which + * image data is desired. */ + Tk_PhotoImageBlock *blockPtr; + /* Information about the address and layout + * of the image data is returned here. */ +{ + PhotoMaster *masterPtr; + + masterPtr = (PhotoMaster *) handle; + blockPtr->pixelPtr = masterPtr->pix24; + blockPtr->width = masterPtr->width; + blockPtr->height = masterPtr->height; + blockPtr->pitch = masterPtr->width * 3; + blockPtr->pixelSize = 3; + blockPtr->offset[0] = 0; + blockPtr->offset[1] = 1; + blockPtr->offset[2] = 2; + return 1; +} diff --git a/generic/tkImgUtil.c b/generic/tkImgUtil.c new file mode 100644 index 0000000..31504b8 --- /dev/null +++ b/generic/tkImgUtil.c @@ -0,0 +1,78 @@ +/* + * tkImgUtil.c -- + * + * This file contains image related utility functions. + * + * Copyright (c) 1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkImgUtil.c 1.3 96/02/15 18:53:12 + */ + +#include "tkInt.h" +#include "tkPort.h" +#include "xbytes.h" + + +/* + *---------------------------------------------------------------------- + * + * TkAlignImageData -- + * + * This function takes an image and copies the data into an + * aligned buffer, performing any necessary bit swapping. + * + * Results: + * Returns a newly allocated buffer that should be freed by the + * caller. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +TkAlignImageData(image, alignment, bitOrder) + XImage *image; /* Image to be aligned. */ + int alignment; /* Number of bytes to which the data should + * be aligned (e.g. 2 or 4) */ + int bitOrder; /* Desired bit order: LSBFirst or MSBFirst. */ +{ + long dataWidth; + char *data, *srcPtr, *destPtr; + int i, j; + + if (image->bits_per_pixel != 1) { + panic("TkAlignImageData: Can't handle image depths greater than 1."); + } + + /* + * Compute line width for output data buffer. + */ + + dataWidth = image->bytes_per_line; + if (dataWidth % alignment) { + dataWidth += (alignment - (dataWidth % alignment)); + } + + data = ckalloc(dataWidth * image->height); + + destPtr = data; + for (i = 0; i < image->height; i++) { + srcPtr = &image->data[i * image->bytes_per_line]; + for (j = 0; j < dataWidth; j++) { + if (j >= image->bytes_per_line) { + *destPtr = 0; + } else if (image->bitmap_bit_order != bitOrder) { + *destPtr = xBitReverseTable[(unsigned char)(*(srcPtr++))]; + } else { + *destPtr = *(srcPtr++); + } + destPtr++; + } + } + return data; +} diff --git a/generic/tkInitScript.h b/generic/tkInitScript.h new file mode 100644 index 0000000..e86d16e --- /dev/null +++ b/generic/tkInitScript.h @@ -0,0 +1,73 @@ +/* + * tkInitScript.h -- + * + * This file contains Unix & Windows common init script + * It is not used on the Mac. (the mac init script is in tkMacInit.c) + * + * 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: @(#) tkInitScript.h 1.3 97/08/11 19:12:28 + */ + + + +/* + * The following string is the startup script executed in new + * interpreters. It looks in several different directories + * for a script "tk.tcl" that is compatible with this version + * of Tk. The tk.tcl script does all of the real work of + * initialization. + * When called from a safe interpreter, it does not use file exists. + * we don't use pwd either because of safe interpreters. + */ + +static char initScript[] = +"proc tkInit {} {\n\ + global tk_library tk_version tk_patchLevel env errorInfo\n\ + rename tkInit {}\n\ + set errors \"\"\n\ + if {![info exists tk_library]} {\n\ + set tk_library .\n\ + }\n\ + set dirs {}\n\ + if {[info exists env(TK_LIBRARY)]} {\n\ + lappend dirs $env(TK_LIBRARY)\n\ + }\n\ + lappend dirs $tk_library\n\ + lappend dirs [file join [file dirname [info library]] tk$tk_version]\n\ + set parentDir [file dirname [file dirname [info nameofexecutable]]]\n\ + lappend dirs [file join $parentDir tk$tk_version]\n\ + lappend dirs [file join $parentDir lib tk$tk_version]\n\ + lappend dirs [file join $parentDir library]\n\ + set parentParentDir [file dirname $parentDir]\n\ + if [string match {*[ab]*} $tk_patchLevel] {\n\ + set dirSuffix $tk_patchLevel\n\ + } else {\n\ + set dirSuffix $tk_version\n\ + }\n\ + lappend dirs [file join $parentParentDir tk$dirSuffix library]\n\ + lappend dirs [file join $parentParentDir library]\n\ + lappend dirs [file join [file dirname \ + [file dirname [info library]]] tk$dirSuffix library]\n\ + foreach i $dirs {\n\ + set tk_library $i\n\ + set tkfile [file join $i tk.tcl]\n\ + if {[interp issafe] || [file exists $tkfile]} {\n\ + if {![catch {uplevel #0 [list source $tkfile]} msg]} {\n\ + return\n\ + } else {\n\ + append errors \"$tkfile: $msg\n$errorInfo\n\"\n\ + }\n\ + }\n\ + }\n\ + set msg \"Can't find a usable tk.tcl in the following directories: \n\"\n\ + append msg \" $dirs\n\n\"\n\ + append msg \"$errors\n\n\"\n\ + append msg \"This probably means that Tk wasn't installed properly.\n\"\n\ + error $msg\n\ +}\n\ +tkInit"; + diff --git a/generic/tkInt.h b/generic/tkInt.h new file mode 100644 index 0000000..b5dd92d --- /dev/null +++ b/generic/tkInt.h @@ -0,0 +1,990 @@ +/* + * tkInt.h -- + * + * Declarations for things used internally by the Tk + * procedures but not exported outside the module. + * + * 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: @(#) tkInt.h 1.204 97/10/31 09:55:20 + */ + +#ifndef _TKINT +#define _TKINT + +#ifndef _TK +#include "tk.h" +#endif +#ifndef _TCL +#include "tcl.h" +#endif +#ifndef _TKPORT +#include +#endif + +/* + * Opaque type declarations: + */ + +typedef struct TkColormap TkColormap; +typedef struct TkGrabEvent TkGrabEvent; +typedef struct Tk_PostscriptInfo Tk_PostscriptInfo; +typedef struct TkpCursor_ *TkpCursor; +typedef struct TkRegion_ *TkRegion; +typedef struct TkStressedCmap TkStressedCmap; +typedef struct TkBindInfo_ *TkBindInfo; + +/* + * Procedure types. + */ + +typedef int (TkBindEvalProc) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, XEvent *eventPtr, Tk_Window tkwin, + KeySym keySym)); +typedef void (TkBindFreeProc) _ANSI_ARGS_((ClientData clientData)); +typedef Window (TkClassCreateProc) _ANSI_ARGS_((Tk_Window tkwin, + Window parent, ClientData instanceData)); +typedef void (TkClassGeometryProc) _ANSI_ARGS_((ClientData instanceData)); +typedef void (TkClassModalProc) _ANSI_ARGS_((Tk_Window tkwin, + XEvent *eventPtr)); + + +/* + * Widget class procedures used to implement platform specific widget + * behavior. + */ + +typedef struct TkClassProcs { + TkClassCreateProc *createProc; + /* Procedure to invoke when the + platform-dependent window needs to be + created. */ + TkClassGeometryProc *geometryProc; + /* Procedure to invoke when the geometry of a + window needs to be recalculated as a result + of some change in the system. */ + TkClassModalProc *modalProc; + /* Procedure to invoke after all bindings on a + widget have been triggered in order to + handle a modal loop. */ +} TkClassProcs; + +/* + * One of the following structures is maintained for each cursor in + * use in the system. This structure is used by tkCursor.c and the + * various system specific cursor files. + */ + +typedef struct TkCursor { + Tk_Cursor cursor; /* System specific identifier for cursor. */ + int refCount; /* Number of active uses of cursor. */ + 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). */ +} TkCursor; + +/* + * One of the following structures is maintained for each display + * containing a window managed by Tk: + */ + +typedef struct TkDisplay { + Display *display; /* Xlib's info about display. */ + struct TkDisplay *nextPtr; /* Next in list of all displays. */ + char *name; /* Name of display (with any screen + * identifier removed). Malloc-ed. */ + Time lastEventTime; /* Time of last event received for this + * display. */ + + /* + * Information used primarily by tkBind.c: + */ + + int bindInfoStale; /* Non-zero means the variables in this + * part of the structure are potentially + * incorrect and should be recomputed. */ + unsigned int modeModMask; /* Has one bit set to indicate the modifier + * corresponding to "mode shift". If no + * such modifier, than this is zero. */ + unsigned int metaModMask; /* Has one bit set to indicate the modifier + * corresponding to the "Meta" key. If no + * such modifier, then this is zero. */ + unsigned int altModMask; /* Has one bit set to indicate the modifier + * corresponding to the "Meta" key. If no + * such modifier, then this is zero. */ + enum {LU_IGNORE, LU_CAPS, LU_SHIFT} lockUsage; + /* Indicates how to interpret lock modifier. */ + int numModKeyCodes; /* Number of entries in modKeyCodes array + * below. */ + KeyCode *modKeyCodes; /* Pointer to an array giving keycodes for + * all of the keys that have modifiers + * associated with them. Malloc'ed, but + * may be NULL. */ + + /* + * Information used by tkError.c only: + */ + + struct TkErrorHandler *errorPtr; + /* First in list of error handlers + * for this display. NULL means + * no handlers exist at present. */ + int deleteCount; /* Counts # of handlers deleted since + * last time inactive handlers were + * garbage-collected. When this number + * gets big, handlers get cleaned up. */ + + /* + * Information used by tkSend.c only: + */ + + Tk_Window commTkwin; /* Window used for communication + * between interpreters during "send" + * commands. NULL means send info hasn't + * been initialized yet. */ + Atom commProperty; /* X's name for comm property. */ + Atom registryProperty; /* X's name for property containing + * registry of interpreter names. */ + Atom appNameProperty; /* X's name for property used to hold the + * application name on each comm window. */ + + /* + * Information used by tkSelect.c and tkClipboard.c only: + */ + + struct TkSelectionInfo *selectionInfoPtr; + /* First in list of selection information + * records. Each entry contains information + * about the current owner of a particular + * selection on this display. */ + Atom multipleAtom; /* Atom for MULTIPLE. None means + * selection stuff isn't initialized. */ + Atom incrAtom; /* Atom for INCR. */ + Atom targetsAtom; /* Atom for TARGETS. */ + Atom timestampAtom; /* Atom for TIMESTAMP. */ + Atom textAtom; /* Atom for TEXT. */ + Atom compoundTextAtom; /* Atom for COMPOUND_TEXT. */ + Atom applicationAtom; /* Atom for TK_APPLICATION. */ + Atom windowAtom; /* Atom for TK_WINDOW. */ + Atom clipboardAtom; /* Atom for CLIPBOARD. */ + + Tk_Window clipWindow; /* Window used for clipboard ownership and to + * retrieve selections between processes. NULL + * means clipboard info hasn't been + * initialized. */ + int clipboardActive; /* 1 means we currently own the clipboard + * selection, 0 means we don't. */ + struct TkMainInfo *clipboardAppPtr; + /* Last application that owned clipboard. */ + struct TkClipboardTarget *clipTargetPtr; + /* First in list of clipboard type information + * records. Each entry contains information + * about the buffers for a given selection + * target. */ + + /* + * Information used by tkAtom.c only: + */ + + int atomInit; /* 0 means stuff below hasn't been + * initialized yet. */ + Tcl_HashTable nameTable; /* Maps from names to Atom's. */ + Tcl_HashTable atomTable; /* Maps from Atom's back to names. */ + + /* + * Information used by tkCursor.c only: + */ + + Font cursorFont; /* Font to use for standard cursors. + * None means font not loaded yet. */ + + /* + * Information used by tkGrab.c only: + */ + + struct TkWindow *grabWinPtr; + /* Window in which the pointer is currently + * grabbed, or NULL if none. */ + struct TkWindow *eventualGrabWinPtr; + /* Value that grabWinPtr will have once the + * grab event queue (below) has been + * completely emptied. */ + struct TkWindow *buttonWinPtr; + /* Window in which first mouse button was + * pressed while grab was in effect, or NULL + * if no such press in effect. */ + struct TkWindow *serverWinPtr; + /* If no application contains the pointer then + * this is NULL. Otherwise it contains the + * last window for which we've gotten an + * Enter or Leave event from the server (i.e. + * the last window known to have contained + * the pointer). Doesn't reflect events + * that were synthesized in tkGrab.c. */ + TkGrabEvent *firstGrabEventPtr; + /* First in list of enter/leave events + * synthesized by grab code. These events + * must be processed in order before any other + * events are processed. NULL means no such + * events. */ + TkGrabEvent *lastGrabEventPtr; + /* Last in list of synthesized events, or NULL + * if list is empty. */ + int grabFlags; /* Miscellaneous flag values. See definitions + * in tkGrab.c. */ + + /* + * Information used by tkXId.c only: + */ + + struct TkIdStack *idStackPtr; + /* First in list of chunks of free resource + * identifiers, or NULL if there are no free + * resources. */ + XID (*defaultAllocProc) _ANSI_ARGS_((Display *display)); + /* Default resource allocator for display. */ + struct TkIdStack *windowStackPtr; + /* First in list of chunks of window + * identifers that can't be reused right + * now. */ + int idCleanupScheduled; /* 1 means a call to WindowIdCleanup has + * already been scheduled, 0 means it + * hasn't. */ + + /* + * Information maintained by tkWindow.c for use later on by tkXId.c: + */ + + + int destroyCount; /* Number of Tk_DestroyWindow operations + * in progress. */ + unsigned long lastDestroyRequest; + /* Id of most recent XDestroyWindow request; + * can re-use ids in windowStackPtr when + * server has seen this request and event + * queue is empty. */ + + /* + * Information used by tkVisual.c only: + */ + + TkColormap *cmapPtr; /* First in list of all non-default colormaps + * allocated for this display. */ + + /* + * Information used by tkFocus.c only: + */ + + struct TkWindow *implicitWinPtr; + /* If the focus arrived at a toplevel window + * implicitly via an Enter event (rather + * than via a FocusIn event), this points + * to the toplevel window. Otherwise it is + * NULL. */ + struct TkWindow *focusPtr; /* Points to the window on this display that + * should be receiving keyboard events. When + * multiple applications on the display have + * the focus, this will refer to the + * innermost window in the innermost + * application. This information isn't used + * under Unix or Windows, but it's needed on + * the Macintosh. */ + + /* + * Used by tkColor.c only: + */ + + TkStressedCmap *stressPtr; /* First in list of colormaps that have + * filled up, so we have to pick an + * approximate color. */ + + /* + * Used by tkEvent.c only: + */ + + struct TkWindowEvent *delayedMotionPtr; + /* Points to a malloc-ed motion event + * whose processing has been delayed in + * the hopes that another motion event + * will come along right away and we can + * merge the two of them together. NULL + * means that there is no delayed motion + * event. */ + + /* + * Miscellaneous information: + */ + +#ifdef TK_USE_INPUT_METHODS + XIM inputMethod; /* Input method for this display */ +#endif /* TK_USE_INPUT_METHODS */ + Tcl_HashTable winTable; /* Maps from X window ids to TkWindow ptrs. */ + + int refCount; /* Reference count of how many Tk applications + * are using this display. Used to clean up + * the display when we no longer have any + * Tk applications using it. + */ +} TkDisplay; + +/* + * One of the following structures exists for each error handler + * created by a call to Tk_CreateErrorHandler. The structure + * is managed by tkError.c. + */ + +typedef struct TkErrorHandler { + TkDisplay *dispPtr; /* Display to which handler applies. */ + unsigned long firstRequest; /* Only errors with serial numbers + * >= to this are considered. */ + unsigned long lastRequest; /* Only errors with serial numbers + * <= to this are considered. This + * field is filled in when XUnhandle + * is called. -1 means XUnhandle + * hasn't been called yet. */ + int error; /* Consider only errors with this + * error_code (-1 means consider + * all errors). */ + int request; /* Consider only errors with this + * major request code (-1 means + * consider all major codes). */ + int minorCode; /* Consider only errors with this + * minor request code (-1 means + * consider all minor codes). */ + Tk_ErrorProc *errorProc; /* Procedure to invoke when a matching + * error occurs. NULL means just ignore + * errors. */ + ClientData clientData; /* Arbitrary value to pass to + * errorProc. */ + struct TkErrorHandler *nextPtr; + /* Pointer to next older handler for + * this display, or NULL for end of + * list. */ +} TkErrorHandler; + +/* + * One of the following structures exists for each event handler + * created by calling Tk_CreateEventHandler. This information + * is used by tkEvent.c only. + */ + +typedef struct TkEventHandler { + unsigned long mask; /* Events for which to invoke + * proc. */ + Tk_EventProc *proc; /* Procedure to invoke when an event + * in mask occurs. */ + ClientData clientData; /* Argument to pass to proc. */ + struct TkEventHandler *nextPtr; + /* Next in list of handlers + * associated with window (NULL means + * end of list). */ +} TkEventHandler; + +/* + * Tk keeps one of the following data structures for each main + * window (created by a call to Tk_CreateMainWindow). It stores + * information that is shared by all of the windows associated + * with a particular main window. + */ + +typedef struct TkMainInfo { + int refCount; /* Number of windows whose "mainPtr" fields + * point here. When this becomes zero, can + * free up the structure (the reference + * count is zero because windows can get + * deleted in almost any order; the main + * window isn't necessarily the last one + * deleted). */ + struct TkWindow *winPtr; /* Pointer to main window. */ + Tcl_Interp *interp; /* Interpreter associated with application. */ + Tcl_HashTable nameTable; /* Hash table mapping path names to TkWindow + * structs for all windows related to this + * main window. Managed by tkWindow.c. */ + Tk_BindingTable bindingTable; + /* Used in conjunction with "bind" command + * to bind events to Tcl commands. */ + TkBindInfo bindInfo; /* Information used by tkBind.c on a per + * interpreter basis. */ + struct TkFontInfo *fontInfoPtr; + /* Hold named font tables. Used only by + * tkFont.c. */ + + /* + * Information used only by tkFocus.c and tk*Embed.c: + */ + + struct TkToplevelFocusInfo *tlFocusPtr; + /* First in list of records containing focus + * information for each top-level in the + * application. Used only by tkFocus.c. */ + struct TkDisplayFocusInfo *displayFocusPtr; + /* First in list of records containing focus + * information for each display that this + * application has ever used. Used only + * by tkFocus.c. */ + + struct ElArray *optionRootPtr; + /* Top level of option hierarchy for this + * main window. NULL means uninitialized. + * Managed by tkOption.c. */ + Tcl_HashTable imageTable; /* Maps from image names to Tk_ImageMaster + * structures. Managed by tkImage.c. */ + int strictMotif; /* This is linked to the tk_strictMotif + * global variable. */ + struct TkMainInfo *nextPtr; /* Next in list of all main windows managed by + * this process. */ +} TkMainInfo; + +/* + * Tk keeps the following data structure for each of it's builtin + * bitmaps. This structure is only used by tkBitmap.c and other + * platform specific bitmap files. + */ + +typedef struct { + char *source; /* Bits for bitmap. */ + int width, height; /* Dimensions of bitmap. */ + int native; /* 0 means generic (X style) bitmap, + * 1 means native style bitmap. */ +} TkPredefBitmap; + +/* + * Tk keeps one of the following structures for each window. + * Some of the information (like size and location) is a shadow + * of information managed by the X server, and some is special + * information used here, such as event and geometry management + * information. This information is (mostly) managed by tkWindow.c. + * WARNING: the declaration below must be kept consistent with the + * Tk_FakeWin structure in tk.h. If you change one, be sure to + * change the other!! + */ + +typedef struct TkWindow { + + /* + * Structural information: + */ + + Display *display; /* Display containing window. */ + TkDisplay *dispPtr; /* Tk's information about display + * for window. */ + int screenNum; /* Index of screen for window, among all + * those for dispPtr. */ + Visual *visual; /* Visual to use for window. If not default, + * MUST be set before X window is created. */ + int depth; /* Number of bits/pixel. */ + Window window; /* X's id for window. NULL means window + * hasn't actually been created yet, or it's + * been deleted. */ + struct TkWindow *childList; /* First in list of child windows, + * or NULL if no children. List is in + * stacking order, lowest window first.*/ + struct TkWindow *lastChildPtr; + /* Last in list of child windows (highest + * in stacking order), or NULL if no + * children. */ + struct TkWindow *parentPtr; /* Pointer to parent window (logical + * parent, not necessarily X parent). NULL + * means either this is the main window, or + * the window's parent has already been + * deleted. */ + struct TkWindow *nextPtr; /* Next higher sibling (in stacking order) + * in list of children with same parent. NULL + * means end of list. */ + TkMainInfo *mainPtr; /* Information shared by all windows + * associated with a particular main + * window. NULL means this window is + * a rogue that isn't associated with + * any application (at present, this + * only happens for the dummy windows + * used for "send" communication). */ + + /* + * Name and type information for the window: + */ + + char *pathName; /* Path name of window (concatenation + * of all names between this window and + * its top-level ancestor). This is a + * pointer into an entry in + * mainPtr->nameTable. NULL means that + * the window hasn't been completely + * created yet. */ + Tk_Uid nameUid; /* Name of the window within its parent + * (unique within the parent). */ + Tk_Uid classUid; /* Class of the window. NULL means window + * hasn't been given a class yet. */ + + /* + * Geometry and other attributes of window. This information + * may not be updated on the server immediately; stuff that + * hasn't been reflected in the server yet is called "dirty". + * At present, information can be dirty only if the window + * hasn't yet been created. + */ + + XWindowChanges changes; /* Geometry and other info about + * window. */ + unsigned int dirtyChanges; /* Bits indicate fields of "changes" + * that are dirty. */ + XSetWindowAttributes atts; /* Current attributes of window. */ + unsigned long dirtyAtts; /* Bits indicate fields of "atts" + * that are dirty. */ + + unsigned int flags; /* Various flag values: these are all + * defined in tk.h (confusing, but they're + * needed there for some query macros). */ + + /* + * Information kept by the event manager (tkEvent.c): + */ + + TkEventHandler *handlerList;/* First in list of event handlers + * declared for this window, or + * NULL if none. */ +#ifdef TK_USE_INPUT_METHODS + XIC inputContext; /* Input context (for input methods). */ +#endif /* TK_USE_INPUT_METHODS */ + + /* + * Information used for event bindings (see "bind" and "bindtags" + * commands in tkCmds.c): + */ + + ClientData *tagPtr; /* Points to array of tags used for bindings + * on this window. Each tag is a Tk_Uid. + * Malloc'ed. NULL means no tags. */ + int numTags; /* Number of tags at *tagPtr. */ + + /* + * Information used by tkOption.c to manage options for the + * window. + */ + + int optionLevel; /* -1 means no option information is + * currently cached for this window. + * Otherwise this gives the level in + * the option stack at which info is + * cached. */ + /* + * Information used by tkSelect.c to manage the selection. + */ + + struct TkSelHandler *selHandlerList; + /* First in list of handlers for + * returning the selection in various + * forms. */ + + /* + * Information used by tkGeometry.c for geometry management. + */ + + Tk_GeomMgr *geomMgrPtr; /* Information about geometry manager for + * this window. */ + ClientData geomData; /* Argument for geometry manager procedures. */ + int reqWidth, reqHeight; /* Arguments from last call to + * Tk_GeometryRequest, or 0's if + * Tk_GeometryRequest hasn't been + * called. */ + int internalBorderWidth; /* Width of internal border of window + * (0 means no internal border). Geometry + * managers should not normally place children + * on top of the border. */ + + /* + * Information maintained by tkWm.c for window manager communication. + */ + + struct TkWmInfo *wmInfoPtr; /* For top-level windows (and also + * for special Unix menubar and wrapper + * windows), points to structure with + * wm-related info (see tkWm.c). For + * other windows, this is NULL. */ + + /* + * Information used by widget classes. + */ + + TkClassProcs *classProcsPtr; + ClientData instanceData; + + /* + * Platform specific information private to each port. + */ + + struct TkWindowPrivate *privatePtr; +} TkWindow; + +/* + * The following structure is used as a two way map between integers + * and strings, usually to map between an internal C representation + * and the strings used in Tcl. + */ + +typedef struct TkStateMap { + int numKey; /* Integer representation of a value. */ + char *strKey; /* String representation of a value. */ +} TkStateMap; + +/* + * This structure is used by the Mac and Window porting layers as + * the internal representation of a clip_mask in a GC. + */ + +typedef struct TkpClipMask { + int type; /* One of TKP_CLIP_PIXMAP or TKP_CLIP_REGION */ + union { + Pixmap pixmap; + TkRegion region; + } value; +} TkpClipMask; + +#define TKP_CLIP_PIXMAP 0 +#define TKP_CLIP_REGION 1 + +/* + * Pointer to first entry in list of all displays currently known. + */ + +extern TkDisplay *tkDisplayList; + +/* + * Return values from TkGrabState: + */ + +#define TK_GRAB_NONE 0 +#define TK_GRAB_IN_TREE 1 +#define TK_GRAB_ANCESTOR 2 +#define TK_GRAB_EXCLUDED 3 + +/* + * The macro below is used to modify a "char" value (e.g. by casting + * it to an unsigned character) so that it can be used safely with + * macros such as isspace. + */ + +#define UCHAR(c) ((unsigned char) (c)) + +/* + * The following symbol is used in the mode field of FocusIn events + * generated by an embedded application to request the input focus from + * its container. + */ + +#define EMBEDDED_APP_WANTS_FOCUS (NotifyNormal + 20) + +/* + * Miscellaneous variables shared among Tk modules but not exported + * to the outside world: + */ + +extern Tk_Uid tkActiveUid; +extern Tk_ImageType tkBitmapImageType; +extern Tk_Uid tkDisabledUid; +extern Tk_PhotoImageFormat tkImgFmtGIF; +extern void (*tkHandleEventProc) _ANSI_ARGS_(( + XEvent* eventPtr)); +extern Tk_PhotoImageFormat tkImgFmtPPM; +extern TkMainInfo *tkMainWindowList; +extern Tk_Uid tkNormalUid; +extern Tk_ImageType tkPhotoImageType; +extern Tcl_HashTable tkPredefBitmapTable; +extern int tkSendSerial; + +/* + * Internal procedures shared among Tk modules but not exported + * to the outside world: + */ + +EXTERN char * TkAlignImageData _ANSI_ARGS_((XImage *image, + int alignment, int bitOrder)); +EXTERN TkWindow * TkAllocWindow _ANSI_ARGS_((TkDisplay *dispPtr, + int screenNum, TkWindow *parentPtr)); +EXTERN int TkAreaToPolygon _ANSI_ARGS_((double *polyPtr, + int numPoints, double *rectPtr)); +EXTERN void TkBezierPoints _ANSI_ARGS_((double control[], + int numSteps, double *coordPtr)); +EXTERN void TkBezierScreenPoints _ANSI_ARGS_((Tk_Canvas canvas, + double control[], int numSteps, + XPoint *xPointPtr)); +EXTERN void TkBindDeadWindow _ANSI_ARGS_((TkWindow *winPtr)); +EXTERN void TkBindEventProc _ANSI_ARGS_((TkWindow *winPtr, + XEvent *eventPtr)); +EXTERN void TkBindFree _ANSI_ARGS_((TkMainInfo *mainPtr)); +EXTERN void TkBindInit _ANSI_ARGS_((TkMainInfo *mainPtr)); +EXTERN void TkChangeEventWindow _ANSI_ARGS_((XEvent *eventPtr, + TkWindow *winPtr)); +#ifndef TkClipBox +EXTERN void TkClipBox _ANSI_ARGS_((TkRegion rgn, + XRectangle* rect_return)); +#endif +EXTERN int TkClipInit _ANSI_ARGS_((Tcl_Interp *interp, + TkDisplay *dispPtr)); +EXTERN void TkComputeAnchor _ANSI_ARGS_((Tk_Anchor anchor, + Tk_Window tkwin, int padX, int padY, + int innerWidth, int innerHeight, int *xPtr, + int *yPtr)); +EXTERN int TkCopyAndGlobalEval _ANSI_ARGS_((Tcl_Interp *interp, + char *script)); +EXTERN unsigned long TkCreateBindingProcedure _ANSI_ARGS_(( + Tcl_Interp *interp, Tk_BindingTable bindingTable, + ClientData object, char *eventString, + TkBindEvalProc *evalProc, TkBindFreeProc *freeProc, + ClientData clientData)); +EXTERN TkCursor * TkCreateCursorFromData _ANSI_ARGS_((Tk_Window tkwin, + char *source, char *mask, int width, int height, + int xHot, int yHot, XColor fg, XColor bg)); +EXTERN int TkCreateFrame _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv, + int toplevel, char *appName)); +EXTERN Tk_Window TkCreateMainWindow _ANSI_ARGS_((Tcl_Interp *interp, + char *screenName, char *baseName)); +#ifndef TkCreateRegion +EXTERN TkRegion TkCreateRegion _ANSI_ARGS_((void)); +#endif +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)); +#ifndef TkDestroyRegion +EXTERN void TkDestroyRegion _ANSI_ARGS_((TkRegion rgn)); +#endif +EXTERN void TkDoConfigureNotify _ANSI_ARGS_((TkWindow *winPtr)); +EXTERN void TkDrawInsetFocusHighlight _ANSI_ARGS_(( + Tk_Window tkwin, GC gc, int width, + Drawable drawable, int padding)); +EXTERN void TkEventCleanupProc _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp)); +EXTERN void TkEventDeadWindow _ANSI_ARGS_((TkWindow *winPtr)); +EXTERN void TkFillPolygon _ANSI_ARGS_((Tk_Canvas canvas, + double *coordPtr, int numPoints, Display *display, + Drawable drawable, GC gc, GC outlineGC)); +EXTERN int TkFindStateNum _ANSI_ARGS_((Tcl_Interp *interp, + CONST char *option, CONST TkStateMap *mapPtr, + CONST char *strKey)); +EXTERN char * TkFindStateString _ANSI_ARGS_(( + CONST TkStateMap *mapPtr, int numKey)); +EXTERN void TkFocusDeadWindow _ANSI_ARGS_((TkWindow *winPtr)); +EXTERN int TkFocusFilterEvent _ANSI_ARGS_((TkWindow *winPtr, + XEvent *eventPtr)); +EXTERN TkWindow * TkFocusKeyEvent _ANSI_ARGS_((TkWindow *winPtr, + XEvent *eventPtr)); +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_(( + TkWindow *winPtr, int active)); +EXTERN char * TkGetBitmapData _ANSI_ARGS_((Tcl_Interp *interp, + char *string, char *fileName, int *widthPtr, + int *heightPtr, int *hotXPtr, int *hotYPtr)); +EXTERN void TkGetButtPoints _ANSI_ARGS_((double p1[], double p2[], + double width, int project, double m1[], + double m2[])); +EXTERN TkCursor * TkGetCursorByName _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, Tk_Uid string)); +EXTERN char * TkGetDefaultScreenName _ANSI_ARGS_((Tcl_Interp *interp, + char *screenName)); +EXTERN TkDisplay * TkGetDisplay _ANSI_ARGS_((Display *display)); +EXTERN int TkGetDisplayOf _ANSI_ARGS_((Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[], + Tk_Window *tkwinPtr)); +EXTERN TkWindow * TkGetFocusWin _ANSI_ARGS_((TkWindow *winPtr)); +EXTERN int TkGetInterpNames _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin)); +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 void TkGrabDeadWindow _ANSI_ARGS_((TkWindow *winPtr)); +EXTERN int TkGrabState _ANSI_ARGS_((TkWindow *winPtr)); +EXTERN TkWindow * TkIDToWindow _ANSI_ARGS_((Window window, + TkDisplay *display)); +EXTERN void TkIncludePoint _ANSI_ARGS_((Tk_Item *itemPtr, + double *pointPtr)); +EXTERN void TkInitXId _ANSI_ARGS_((TkDisplay *dispPtr)); +EXTERN void TkInOutEvents _ANSI_ARGS_((XEvent *eventPtr, + TkWindow *sourcePtr, TkWindow *destPtr, + int leaveType, int enterType, + Tcl_QueuePosition position)); +EXTERN void TkInstallFrameMenu _ANSI_ARGS_((Tk_Window tkwin)); +#ifndef TkIntersectRegion +EXTERN void TkIntersectRegion _ANSI_ARGS_((TkRegion sra, + TkRegion srcb, TkRegion dr_return)); +#endif +EXTERN char * TkKeysymToString _ANSI_ARGS_((KeySym keysym)); +EXTERN int TkLineToArea _ANSI_ARGS_((double end1Ptr[2], + double end2Ptr[2], double rectPtr[4])); +EXTERN double TkLineToPoint _ANSI_ARGS_((double end1Ptr[2], + double end2Ptr[2], double pointPtr[2])); +EXTERN int TkListAppend _ANSI_ARGS_((void **headPtrPtr, + void *itemPtr, size_t size)); +EXTERN int TkListDelete _ANSI_ARGS_((void **headPtrPtr, + void *itemPtr, size_t size)); +EXTERN void * TkListFind _ANSI_ARGS_((void *headPtr, void *itemPtr, + size_t size)); +EXTERN int TkMakeBezierCurve _ANSI_ARGS_((Tk_Canvas canvas, + double *pointPtr, int numPoints, int numSteps, + XPoint xPoints[], double dblPoints[])); +EXTERN void TkMakeBezierPostscript _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, double *pointPtr, + int numPoints)); +EXTERN void TkOptionClassChanged _ANSI_ARGS_((TkWindow *winPtr)); +EXTERN void TkOptionDeadWindow _ANSI_ARGS_((TkWindow *winPtr)); +EXTERN int TkOvalToArea _ANSI_ARGS_((double *ovalPtr, + double *rectPtr)); +EXTERN double TkOvalToPoint _ANSI_ARGS_((double ovalPtr[4], + double width, int filled, double pointPtr[2])); +EXTERN int TkpChangeFocus _ANSI_ARGS_((TkWindow *winPtr, + int force)); +EXTERN void TkpCloseDisplay _ANSI_ARGS_((TkDisplay *dispPtr)); +EXTERN void TkpClaimFocus _ANSI_ARGS_((TkWindow *topLevelPtr, + int force)); +#ifndef TkpCmapStressed +EXTERN int TkpCmapStressed _ANSI_ARGS_((Tk_Window tkwin, + Colormap colormap)); +#endif +#ifndef TkpCreateNativeBitmap +EXTERN Pixmap TkpCreateNativeBitmap _ANSI_ARGS_((Display *display, + char * source)); +#endif +#ifndef TkpDefineNativeBitmaps +EXTERN void TkpDefineNativeBitmaps _ANSI_ARGS_((void)); +#endif +EXTERN void TkpDisplayWarning _ANSI_ARGS_((char *msg, + char *title)); +EXTERN void TkpGetAppName _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_DString *name)); +EXTERN unsigned long TkpGetMS _ANSI_ARGS_((void)); +#ifndef TkpGetNativeAppBitmap +EXTERN Pixmap TkpGetNativeAppBitmap _ANSI_ARGS_((Display *display, + char *name, int *width, int *height)); +#endif +EXTERN TkWindow * TkpGetOtherWindow _ANSI_ARGS_((TkWindow *winPtr)); +EXTERN TkWindow * TkpGetWrapperWindow _ANSI_ARGS_((TkWindow *winPtr)); +EXTERN int TkpInit _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN void TkpInitializeMenuBindings _ANSI_ARGS_(( + Tcl_Interp *interp, Tk_BindingTable bindingTable)); +EXTERN void TkpMakeContainer _ANSI_ARGS_((Tk_Window tkwin)); +EXTERN void TkpMakeMenuWindow _ANSI_ARGS_((Tk_Window tkwin, + int transient)); +EXTERN Window TkpMakeWindow _ANSI_ARGS_((TkWindow *winPtr, + Window parent)); +EXTERN void TkpMenuNotifyToplevelCreate _ANSI_ARGS_(( + Tcl_Interp *, char *menuName)); +EXTERN TkDisplay * TkpOpenDisplay _ANSI_ARGS_((char *display_name)); +EXTERN void TkPointerDeadWindow _ANSI_ARGS_((TkWindow *winPtr)); +EXTERN int TkPointerEvent _ANSI_ARGS_((XEvent *eventPtr, + TkWindow *winPtr)); +EXTERN int TkPolygonToArea _ANSI_ARGS_((double *polyPtr, + int numPoints, double *rectPtr)); +EXTERN double TkPolygonToPoint _ANSI_ARGS_((double *polyPtr, + int numPoints, double *pointPtr)); +EXTERN int TkPositionInTree _ANSI_ARGS_((TkWindow *winPtr, + TkWindow *treePtr)); +#ifndef TkpPrintWindowId +EXTERN void TkpPrintWindowId _ANSI_ARGS_((char *buf, + Window window)); +#endif +EXTERN void TkpRedirectKeyEvent _ANSI_ARGS_((TkWindow *winPtr, + XEvent *eventPtr)); +#ifndef TkpScanWindowId +EXTERN int TkpScanWindowId _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int *idPtr)); +#endif +EXTERN void TkpSetCapture _ANSI_ARGS_((TkWindow *winPtr)); +EXTERN void TkpSetCursor _ANSI_ARGS_((TkpCursor cursor)); +EXTERN void TkpSetMainMenubar _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, char *menuName)); +#ifndef TkpSync +EXTERN void TkpSync _ANSI_ARGS_((Display *display)); +#endif +EXTERN int TkpTestembedCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int TkpUseWindow _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, char *string)); +#ifndef TkPutImage +EXTERN void TkPutImage _ANSI_ARGS_((unsigned long *colors, + int ncolors, Display* display, Drawable d, + GC gc, XImage* image, int src_x, int src_y, + int dest_x, int dest_y, unsigned int width, + unsigned int height)); +#endif +EXTERN int TkpWindowWasRecentlyDeleted _ANSI_ARGS_((Window win, + TkDisplay *dispPtr)); +EXTERN void TkpWmSetState _ANSI_ARGS_((TkWindow *winPtr, + int state)); +EXTERN void TkQueueEventForAllChildren _ANSI_ARGS_(( + TkWindow *winPtr, XEvent *eventPtr)); +#ifndef TkRectInRegion +EXTERN int TkRectInRegion _ANSI_ARGS_((TkRegion rgn, + int x, int y, unsigned int width, + unsigned int height)); +#endif +EXTERN int TkScrollWindow _ANSI_ARGS_((Tk_Window tkwin, GC gc, + int x, int y, int width, int height, int dx, + int dy, TkRegion damageRgn)); +EXTERN void TkSelDeadWindow _ANSI_ARGS_((TkWindow *winPtr)); +EXTERN void TkSelEventProc _ANSI_ARGS_((Tk_Window tkwin, + XEvent *eventPtr)); +EXTERN void TkSelInit _ANSI_ARGS_((Tk_Window tkwin)); +EXTERN void TkSelPropProc _ANSI_ARGS_((XEvent *eventPtr)); +EXTERN void TkSetClassProcs _ANSI_ARGS_((Tk_Window tkwin, + TkClassProcs *procs, ClientData instanceData)); +#ifndef TkSetPixmapColormap +EXTERN void TkSetPixmapColormap _ANSI_ARGS_((Pixmap pixmap, + Colormap colormap)); +#endif +#ifndef TkSetRegion +EXTERN void TkSetRegion _ANSI_ARGS_((Display* display, GC gc, + TkRegion rgn)); +#endif +EXTERN void TkSetWindowMenuBar _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, char *oldMenuName, + char *menuName)); +EXTERN KeySym TkStringToKeysym _ANSI_ARGS_((char *name)); +EXTERN int TkThickPolyLineToArea _ANSI_ARGS_((double *coordPtr, + int numPoints, double width, int capStyle, + int joinStyle, double *rectPtr)); +#ifndef TkUnionRectWithRegion +EXTERN void TkUnionRectWithRegion _ANSI_ARGS_((XRectangle* rect, + TkRegion src, TkRegion dr_return)); +#endif +EXTERN void TkWmAddToColormapWindows _ANSI_ARGS_(( + TkWindow *winPtr)); +EXTERN void TkWmDeadWindow _ANSI_ARGS_((TkWindow *winPtr)); +EXTERN TkWindow * TkWmFocusToplevel _ANSI_ARGS_((TkWindow *winPtr)); +EXTERN void TkWmMapWindow _ANSI_ARGS_((TkWindow *winPtr)); +EXTERN void TkWmNewWindow _ANSI_ARGS_((TkWindow *winPtr)); +EXTERN void TkWmProtocolEventProc _ANSI_ARGS_((TkWindow *winPtr, + XEvent *evenvPtr)); +EXTERN void TkWmRemoveFromColormapWindows _ANSI_ARGS_(( + TkWindow *winPtr)); +EXTERN void TkWmRestackToplevel _ANSI_ARGS_((TkWindow *winPtr, + int aboveBelow, TkWindow *otherPtr)); +EXTERN void TkWmSetClass _ANSI_ARGS_((TkWindow *winPtr)); +EXTERN void TkWmUnmapWindow _ANSI_ARGS_((TkWindow *winPtr)); +EXTERN int TkXFileProc _ANSI_ARGS_((ClientData clientData, + int mask, int flags)); + +/* + * Unsupported commands. + */ +EXTERN int TkUnsupported1Cmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); + +#endif /* _TKINT */ diff --git a/generic/tkListbox.c b/generic/tkListbox.c new file mode 100644 index 0000000..234130d --- /dev/null +++ b/generic/tkListbox.c @@ -0,0 +1,2335 @@ +/* + * tkListbox.c -- + * + * This module implements listbox widgets for the Tk + * toolkit. A listbox displays a collection of strings, + * one per line, and provides scrolling and selection. + * + * 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: @(#) tkListbox.c 1.120 97/10/29 13:06:59 + */ + +#include "tkPort.h" +#include "default.h" +#include "tkInt.h" + +/* + * One record of the following type is kept for each element + * associated with a listbox widget: + */ + +typedef struct Element { + int textLength; /* # non-NULL characters in text. */ + int lBearing; /* Distance from first character's + * origin to left edge of character. */ + int pixelWidth; /* Total width of element in pixels (including + * left bearing and right bearing). */ + int selected; /* 1 means this item is selected, 0 means + * it isn't. */ + struct Element *nextPtr; /* Next in list of all elements of this + * listbox, or NULL for last element. */ + char text[4]; /* Characters of this element, NULL- + * terminated. The actual space allocated + * here will be as large as needed (> 4, + * most likely). Must be the last field + * of the record. */ +} Element; + +#define ElementSize(stringLength) \ + ((unsigned) (sizeof(Element) - 3 + stringLength)) + +/* + * A data structure of the following type is kept for each listbox + * widget managed by this file: + */ + +typedef struct { + Tk_Window tkwin; /* Window that embodies the listbox. NULL + * means that the window has been destroyed + * but the data structures haven't yet been + * cleaned up.*/ + Display *display; /* Display containing widget. Used, among + * other things, so that resources can be + * freed even after tkwin has gone away. */ + Tcl_Interp *interp; /* Interpreter associated with listbox. */ + Tcl_Command widgetCmd; /* Token for listbox's widget command. */ + int numElements; /* Total number of elements in this listbox. */ + Element *firstPtr; /* First in list of elements (NULL if no + * elements). */ + Element *lastPtr; /* Last in list of elements (NULL if no + * elements). */ + + /* + * Information used when displaying widget: + */ + + Tk_3DBorder normalBorder; /* Used for drawing border around whole + * window, plus used for background. */ + int borderWidth; /* Width of 3-D border around window. */ + 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. + * <= 0 means don't draw a highlight. */ + XColor *highlightBgColorPtr; + /* Color for drawing traversal highlight + * area when highlight is off. */ + XColor *highlightColorPtr; /* 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 *fgColorPtr; /* Text color in normal mode. */ + GC textGC; /* For drawing normal text. */ + Tk_3DBorder selBorder; /* Borders and backgrounds for selected + * elements. */ + int selBorderWidth; /* Width of border around selection. */ + XColor *selFgColorPtr; /* Foreground color for selected elements. */ + GC selTextGC; /* For drawing selected text. */ + int width; /* Desired width of window, in characters. */ + int height; /* Desired height of window, in lines. */ + int lineHeight; /* Number of pixels allocated for each line + * in display. */ + int topIndex; /* Index of top-most element visible in + * window. */ + int fullLines; /* Number of lines that fit are completely + * visible in window. There may be one + * additional line at the bottom that is + * partially visible. */ + int partialLine; /* 0 means that the window holds exactly + * fullLines lines. 1 means that there is + * one additional line that is partially + * visble. */ + int setGrid; /* Non-zero means pass gridding information + * to window manager. */ + + /* + * Information to support horizontal scrolling: + */ + + int maxWidth; /* Width (in pixels) of widest string in + * listbox. */ + int xScrollUnit; /* Number of pixels in one "unit" for + * horizontal scrolling (window scrolls + * horizontally in increments of this size). + * This is an average character size. */ + int xOffset; /* The left edge of each string in the + * listbox is offset to the left by this + * many pixels (0 means no offset, positive + * means there is an offset). */ + + /* + * Information about what's selected or active, if any. + */ + + Tk_Uid selectMode; /* Selection style: single, browse, multiple, + * or extended. This value isn't used in C + * code, but the Tcl bindings use it. */ + int numSelected; /* Number of elements currently selected. */ + int selectAnchor; /* Fixed end of selection (i.e. element + * at which selection was started.) */ + int exportSelection; /* Non-zero means tie internal listbox + * to X selection. */ + int active; /* Index of "active" element (the one that + * has been selected by keyboard traversal). + * -1 means none. */ + + /* + * Information for scanning: + */ + + int scanMarkX; /* X-position at which scan started (e.g. + * button was pressed here). */ + int scanMarkY; /* Y-position at which scan started (e.g. + * button was pressed here). */ + int scanMarkXOffset; /* Value of "xOffset" field when scan + * started. */ + int scanMarkYIndex; /* Index of line that was at top of window + * when scan started. */ + + /* + * Miscellaneous information: + */ + + Tk_Cursor cursor; /* Current cursor for window, or None. */ + char *takeFocus; /* Value of -takefocus option; not used in + * the C code, but used by keyboard traversal + * scripts. Malloc'ed, but may be NULL. */ + char *yScrollCmd; /* Command prefix for communicating with + * vertical scrollbar. NULL means no command + * to issue. Malloc'ed. */ + char *xScrollCmd; /* Command prefix for communicating with + * horizontal scrollbar. NULL means no command + * to issue. Malloc'ed. */ + int flags; /* Various flag bits: see below for + * definitions. */ +} Listbox; + +/* + * Flag bits for listboxes: + * + * REDRAW_PENDING: Non-zero means a DoWhenIdle handler + * has already been queued to redraw + * this window. + * UPDATE_V_SCROLLBAR: Non-zero means vertical scrollbar needs + * to be updated. + * UPDATE_H_SCROLLBAR: Non-zero means horizontal scrollbar needs + * to be updated. + * GOT_FOCUS: Non-zero means this widget currently + * has the input focus. + */ + +#define REDRAW_PENDING 1 +#define UPDATE_V_SCROLLBAR 2 +#define UPDATE_H_SCROLLBAR 4 +#define GOT_FOCUS 8 + +/* + * Information used for argv parsing: + */ + +static Tk_ConfigSpec configSpecs[] = { + {TK_CONFIG_BORDER, "-background", "background", "Background", + DEF_LISTBOX_BG_COLOR, Tk_Offset(Listbox, normalBorder), + TK_CONFIG_COLOR_ONLY}, + {TK_CONFIG_BORDER, "-background", "background", "Background", + DEF_LISTBOX_BG_MONO, Tk_Offset(Listbox, normalBorder), + 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_LISTBOX_BORDER_WIDTH, Tk_Offset(Listbox, borderWidth), 0}, + {TK_CONFIG_ACTIVE_CURSOR, "-cursor", "cursor", "Cursor", + DEF_LISTBOX_CURSOR, Tk_Offset(Listbox, cursor), TK_CONFIG_NULL_OK}, + {TK_CONFIG_BOOLEAN, "-exportselection", "exportSelection", + "ExportSelection", DEF_LISTBOX_EXPORT_SELECTION, + Tk_Offset(Listbox, exportSelection), 0}, + {TK_CONFIG_SYNONYM, "-fg", "foreground", (char *) NULL, + (char *) NULL, 0, 0}, + {TK_CONFIG_FONT, "-font", "font", "Font", + DEF_LISTBOX_FONT, Tk_Offset(Listbox, tkfont), 0}, + {TK_CONFIG_COLOR, "-foreground", "foreground", "Foreground", + DEF_LISTBOX_FG, Tk_Offset(Listbox, fgColorPtr), 0}, + {TK_CONFIG_INT, "-height", "height", "Height", + DEF_LISTBOX_HEIGHT, Tk_Offset(Listbox, height), 0}, + {TK_CONFIG_COLOR, "-highlightbackground", "highlightBackground", + "HighlightBackground", DEF_LISTBOX_HIGHLIGHT_BG, + Tk_Offset(Listbox, highlightBgColorPtr), 0}, + {TK_CONFIG_COLOR, "-highlightcolor", "highlightColor", "HighlightColor", + DEF_LISTBOX_HIGHLIGHT, Tk_Offset(Listbox, highlightColorPtr), 0}, + {TK_CONFIG_PIXELS, "-highlightthickness", "highlightThickness", + "HighlightThickness", + DEF_LISTBOX_HIGHLIGHT_WIDTH, Tk_Offset(Listbox, highlightWidth), 0}, + {TK_CONFIG_RELIEF, "-relief", "relief", "Relief", + DEF_LISTBOX_RELIEF, Tk_Offset(Listbox, relief), 0}, + {TK_CONFIG_BORDER, "-selectbackground", "selectBackground", "Foreground", + DEF_LISTBOX_SELECT_COLOR, Tk_Offset(Listbox, selBorder), + TK_CONFIG_COLOR_ONLY}, + {TK_CONFIG_BORDER, "-selectbackground", "selectBackground", "Foreground", + DEF_LISTBOX_SELECT_MONO, Tk_Offset(Listbox, selBorder), + TK_CONFIG_MONO_ONLY}, + {TK_CONFIG_PIXELS, "-selectborderwidth", "selectBorderWidth", "BorderWidth", + DEF_LISTBOX_SELECT_BD, Tk_Offset(Listbox, selBorderWidth), 0}, + {TK_CONFIG_COLOR, "-selectforeground", "selectForeground", "Background", + DEF_LISTBOX_SELECT_FG_COLOR, Tk_Offset(Listbox, selFgColorPtr), + TK_CONFIG_COLOR_ONLY}, + {TK_CONFIG_COLOR, "-selectforeground", "selectForeground", "Background", + DEF_LISTBOX_SELECT_FG_MONO, Tk_Offset(Listbox, selFgColorPtr), + TK_CONFIG_MONO_ONLY}, + {TK_CONFIG_UID, "-selectmode", "selectMode", "SelectMode", + DEF_LISTBOX_SELECT_MODE, Tk_Offset(Listbox, selectMode), 0}, + {TK_CONFIG_BOOLEAN, "-setgrid", "setGrid", "SetGrid", + DEF_LISTBOX_SET_GRID, Tk_Offset(Listbox, setGrid), 0}, + {TK_CONFIG_STRING, "-takefocus", "takeFocus", "TakeFocus", + DEF_LISTBOX_TAKE_FOCUS, Tk_Offset(Listbox, takeFocus), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_INT, "-width", "width", "Width", + DEF_LISTBOX_WIDTH, Tk_Offset(Listbox, width), 0}, + {TK_CONFIG_STRING, "-xscrollcommand", "xScrollCommand", "ScrollCommand", + DEF_LISTBOX_SCROLL_COMMAND, Tk_Offset(Listbox, xScrollCmd), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-yscrollcommand", "yScrollCommand", "ScrollCommand", + DEF_LISTBOX_SCROLL_COMMAND, Tk_Offset(Listbox, yScrollCmd), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, 0} +}; + +/* + * Forward declarations for procedures defined later in this file: + */ + +static void ChangeListboxOffset _ANSI_ARGS_((Listbox *listPtr, + int offset)); +static void ChangeListboxView _ANSI_ARGS_((Listbox *listPtr, + int index)); +static int ConfigureListbox _ANSI_ARGS_((Tcl_Interp *interp, + Listbox *listPtr, int argc, char **argv, + int flags)); +static void DeleteEls _ANSI_ARGS_((Listbox *listPtr, int first, + int last)); +static void DestroyListbox _ANSI_ARGS_((char *memPtr)); +static void DisplayListbox _ANSI_ARGS_((ClientData clientData)); +static int GetListboxIndex _ANSI_ARGS_((Tcl_Interp *interp, + Listbox *listPtr, char *string, int endIsSize, + int *indexPtr)); +static void InsertEls _ANSI_ARGS_((Listbox *listPtr, int index, + int argc, char **argv)); +static void ListboxCmdDeletedProc _ANSI_ARGS_(( + ClientData clientData)); +static void ListboxComputeGeometry _ANSI_ARGS_((Listbox *listPtr, + int fontChanged, int maxIsStale, int updateGrid)); +static void ListboxEventProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +static int ListboxFetchSelection _ANSI_ARGS_(( + ClientData clientData, int offset, char *buffer, + int maxBytes)); +static void ListboxLostSelection _ANSI_ARGS_(( + ClientData clientData)); +static void ListboxRedrawRange _ANSI_ARGS_((Listbox *listPtr, + int first, int last)); +static void ListboxScanTo _ANSI_ARGS_((Listbox *listPtr, + int x, int y)); +static void ListboxSelect _ANSI_ARGS_((Listbox *listPtr, + int first, int last, int select)); +static void ListboxUpdateHScrollbar _ANSI_ARGS_((Listbox *listPtr)); +static void ListboxUpdateVScrollbar _ANSI_ARGS_((Listbox *listPtr)); +static int ListboxWidgetCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static void ListboxWorldChanged _ANSI_ARGS_(( + ClientData instanceData)); +static int NearestListboxElement _ANSI_ARGS_((Listbox *listPtr, + int y)); + +/* + * The structure below defines button class behavior by means of procedures + * that can be invoked from generic window code. + */ + +static TkClassProcs listboxClass = { + NULL, /* createProc. */ + ListboxWorldChanged, /* geometryProc. */ + NULL /* modalProc. */ +}; + + +/* + *-------------------------------------------------------------- + * + * Tk_ListboxCmd -- + * + * This procedure is invoked to process the "listbox" 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_ListboxCmd(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. */ +{ + register Listbox *listPtr; + Tk_Window new; + Tk_Window tkwin = (Tk_Window) clientData; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " pathName ?options?\"", (char *) NULL); + return TCL_ERROR; + } + + new = Tk_CreateWindowFromPath(interp, tkwin, argv[1], (char *) NULL); + if (new == NULL) { + return TCL_ERROR; + } + + /* + * Initialize the fields of the structure that won't be initialized + * by ConfigureListbox, or that ConfigureListbox requires to be + * initialized already (e.g. resource pointers). + */ + + listPtr = (Listbox *) ckalloc(sizeof(Listbox)); + listPtr->tkwin = new; + listPtr->display = Tk_Display(new); + listPtr->interp = interp; + listPtr->widgetCmd = Tcl_CreateCommand(interp, + Tk_PathName(listPtr->tkwin), ListboxWidgetCmd, + (ClientData) listPtr, ListboxCmdDeletedProc); + listPtr->numElements = 0; + listPtr->firstPtr = NULL; + listPtr->lastPtr = NULL; + listPtr->normalBorder = NULL; + listPtr->borderWidth = 0; + listPtr->relief = TK_RELIEF_RAISED; + listPtr->highlightWidth = 0; + listPtr->highlightBgColorPtr = NULL; + listPtr->highlightColorPtr = NULL; + listPtr->inset = 0; + listPtr->tkfont = NULL; + listPtr->fgColorPtr = NULL; + listPtr->textGC = None; + listPtr->selBorder = NULL; + listPtr->selBorderWidth = 0; + listPtr->selFgColorPtr = None; + listPtr->selTextGC = None; + listPtr->width = 0; + listPtr->height = 0; + listPtr->lineHeight = 0; + listPtr->topIndex = 0; + listPtr->fullLines = 1; + listPtr->partialLine = 0; + listPtr->setGrid = 0; + listPtr->maxWidth = 0; + listPtr->xScrollUnit = 1; + listPtr->xOffset = 0; + listPtr->selectMode = NULL; + listPtr->numSelected = 0; + listPtr->selectAnchor = 0; + listPtr->exportSelection = 1; + listPtr->active = 0; + listPtr->scanMarkX = 0; + listPtr->scanMarkY = 0; + listPtr->scanMarkXOffset = 0; + listPtr->scanMarkYIndex = 0; + listPtr->cursor = None; + listPtr->takeFocus = NULL; + listPtr->xScrollCmd = NULL; + listPtr->yScrollCmd = NULL; + listPtr->flags = 0; + + Tk_SetClass(listPtr->tkwin, "Listbox"); + TkSetClassProcs(listPtr->tkwin, &listboxClass, (ClientData) listPtr); + Tk_CreateEventHandler(listPtr->tkwin, + ExposureMask|StructureNotifyMask|FocusChangeMask, + ListboxEventProc, (ClientData) listPtr); + Tk_CreateSelHandler(listPtr->tkwin, XA_PRIMARY, XA_STRING, + ListboxFetchSelection, (ClientData) listPtr, XA_STRING); + if (ConfigureListbox(interp, listPtr, argc-2, argv+2, 0) != TCL_OK) { + goto error; + } + + interp->result = Tk_PathName(listPtr->tkwin); + return TCL_OK; + + error: + Tk_DestroyWindow(listPtr->tkwin); + return TCL_ERROR; +} + +/* + *-------------------------------------------------------------- + * + * ListboxWidgetCmd -- + * + * This procedure is invoked to process the Tcl command + * that corresponds to a widget managed by this module. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +static int +ListboxWidgetCmd(clientData, interp, argc, argv) + ClientData clientData; /* Information about listbox widget. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + register Listbox *listPtr = (Listbox *) clientData; + int result = TCL_OK; + size_t length; + int c; + Tk_FontMetrics fm; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " option ?arg arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_Preserve((ClientData) listPtr); + c = argv[1][0]; + length = strlen(argv[1]); + if ((c == 'a') && (strncmp(argv[1], "activate", length) == 0)) { + int index; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " activate index\"", + (char *) NULL); + goto error; + } + ListboxRedrawRange(listPtr, listPtr->active, listPtr->active); + if (GetListboxIndex(interp, listPtr, argv[2], 0, &index) != TCL_OK) { + goto error; + } + if (index >= listPtr->numElements) { + index = listPtr->numElements-1; + } + if (index < 0) { + index = 0; + } + listPtr->active = index; + ListboxRedrawRange(listPtr, listPtr->active, listPtr->active); + } else if ((c == 'b') && (strncmp(argv[1], "bbox", length) == 0)) { + int index, x, y, i; + Element *elPtr; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " bbox index\"", (char *) NULL); + goto error; + } + if (GetListboxIndex(interp, listPtr, argv[2], 0, &index) != TCL_OK) { + goto error; + } + if ((index >= listPtr->numElements) || (index < 0)) { + goto done; + } + for (i = 0, elPtr = listPtr->firstPtr; i < index; + i++, elPtr = elPtr->nextPtr) { + /* Empty loop body. */ + } + if ((index >= listPtr->topIndex) && (index < listPtr->numElements) + && (index < (listPtr->topIndex + listPtr->fullLines + + listPtr->partialLine))) { + 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); + } + } 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; + } + result = Tk_ConfigureValue(interp, listPtr->tkwin, configSpecs, + (char *) listPtr, argv[2], 0); + } else if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0) + && (length >= 2)) { + if (argc == 2) { + result = Tk_ConfigureInfo(interp, listPtr->tkwin, configSpecs, + (char *) listPtr, (char *) NULL, 0); + } else if (argc == 3) { + result = Tk_ConfigureInfo(interp, listPtr->tkwin, configSpecs, + (char *) listPtr, argv[2], 0); + } else { + result = ConfigureListbox(interp, listPtr, argc-2, argv+2, + TK_CONFIG_ARGV_ONLY); + } + } else if ((c == 'c') && (strncmp(argv[1], "curselection", length) == 0) + && (length >= 2)) { + int i, count; + char index[20]; + Element *elPtr; + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " curselection\"", + (char *) NULL); + goto error; + } + count = 0; + for (i = 0, elPtr = listPtr->firstPtr; elPtr != NULL; + i++, elPtr = elPtr->nextPtr) { + if (elPtr->selected) { + sprintf(index, "%d", i); + Tcl_AppendElement(interp, index); + count++; + } + } + if (count != listPtr->numSelected) { + panic("ListboxWidgetCmd: selection count incorrect"); + } + } else if ((c == 'd') && (strncmp(argv[1], "delete", length) == 0)) { + int first, last; + + if ((argc < 3) || (argc > 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " delete firstIndex ?lastIndex?\"", + (char *) NULL); + goto error; + } + if (GetListboxIndex(interp, listPtr, argv[2], 0, &first) != TCL_OK) { + goto error; + } + if (first < listPtr->numElements) { + if (argc == 3) { + last = first; + } else { + if (GetListboxIndex(interp, listPtr, argv[3], 0, + &last) != TCL_OK) { + goto error; + } + if (last >= listPtr->numElements) { + last = listPtr->numElements-1; + } + } + DeleteEls(listPtr, first, last); + } + } else if ((c == 'g') && (strncmp(argv[1], "get", length) == 0)) { + int first, last, i; + Element *elPtr; + + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " get first ?last?\"", (char *) NULL); + goto error; + } + if (GetListboxIndex(interp, listPtr, argv[2], 0, &first) != TCL_OK) { + goto error; + } + if ((argc == 4) && (GetListboxIndex(interp, listPtr, argv[3], + 0, &last) != TCL_OK)) { + goto error; + } + if (first >= listPtr->numElements) { + goto done; + } + if (last >= listPtr->numElements) { + last = listPtr->numElements-1; + } + + for (elPtr = listPtr->firstPtr, i = 0; i < first; + i++, elPtr = elPtr->nextPtr) { + /* Empty loop body. */ + } + if (elPtr != NULL) { + if (argc == 3) { + if (first >= 0) { + interp->result = elPtr->text; + } + } else { + for ( ; i <= last; i++, elPtr = elPtr->nextPtr) { + Tcl_AppendElement(interp, elPtr->text); + } + } + } + } 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 index\"", + (char *) NULL); + goto error; + } + if (GetListboxIndex(interp, listPtr, argv[2], 1, &index) + != TCL_OK) { + goto error; + } + sprintf(interp->result, "%d", index); + } else if ((c == 'i') && (strncmp(argv[1], "insert", length) == 0) + && (length >= 3)) { + int index; + + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " insert index ?element element ...?\"", + (char *) NULL); + goto error; + } + if (GetListboxIndex(interp, listPtr, argv[2], 1, &index) + != TCL_OK) { + goto error; + } + InsertEls(listPtr, index, argc-3, argv+3); + } else if ((c == 'n') && (strncmp(argv[1], "nearest", length) == 0)) { + int index, y; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " nearest y\"", (char *) NULL); + goto error; + } + if (Tcl_GetInt(interp, argv[2], &y) != TCL_OK) { + goto error; + } + index = NearestListboxElement(listPtr, y); + sprintf(interp->result, "%d", index); + } else if ((c == 's') && (length >= 2) + && (strncmp(argv[1], "scan", length) == 0)) { + int x, y; + + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " scan mark|dragto x y\"", (char *) NULL); + goto error; + } + if ((Tcl_GetInt(interp, argv[3], &x) != TCL_OK) + || (Tcl_GetInt(interp, argv[4], &y) != TCL_OK)) { + goto error; + } + if ((argv[2][0] == 'm') + && (strncmp(argv[2], "mark", strlen(argv[2])) == 0)) { + listPtr->scanMarkX = x; + listPtr->scanMarkY = y; + listPtr->scanMarkXOffset = listPtr->xOffset; + listPtr->scanMarkYIndex = listPtr->topIndex; + } else if ((argv[2][0] == 'd') + && (strncmp(argv[2], "dragto", strlen(argv[2])) == 0)) { + ListboxScanTo(listPtr, x, y); + } else { + Tcl_AppendResult(interp, "bad scan option \"", argv[2], + "\": must be mark or dragto", (char *) NULL); + goto error; + } + } else if ((c == 's') && (strncmp(argv[1], "see", length) == 0) + && (length >= 3)) { + int index, diff; + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " see index\"", + (char *) NULL); + goto error; + } + if (GetListboxIndex(interp, listPtr, argv[2], 0, &index) != TCL_OK) { + goto error; + } + if (index >= listPtr->numElements) { + index = listPtr->numElements-1; + } + if (index < 0) { + index = 0; + } + diff = listPtr->topIndex-index; + if (diff > 0) { + if (diff <= (listPtr->fullLines/3)) { + ChangeListboxView(listPtr, index); + } else { + ChangeListboxView(listPtr, index - (listPtr->fullLines-1)/2); + } + } else { + diff = index - (listPtr->topIndex + listPtr->fullLines - 1); + if (diff > 0) { + if (diff <= (listPtr->fullLines/3)) { + ChangeListboxView(listPtr, listPtr->topIndex + diff); + } else { + ChangeListboxView(listPtr, + index - (listPtr->fullLines-1)/2); + } + } + } + } else if ((c == 's') && (length >= 3) + && (strncmp(argv[1], "selection", length) == 0)) { + int first, last; + + if ((argc != 4) && (argc != 5)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " selection option index ?index?\"", + (char *) NULL); + goto error; + } + if (GetListboxIndex(interp, listPtr, argv[3], 0, &first) != TCL_OK) { + goto error; + } + if (argc == 5) { + if (GetListboxIndex(interp, listPtr, argv[4], 0, &last) != TCL_OK) { + goto error; + } + } else { + last = first; + } + length = strlen(argv[2]); + c = argv[2][0]; + if ((c == 'a') && (strncmp(argv[2], "anchor", length) == 0)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " selection anchor index\"", (char *) NULL); + goto error; + } + if (first >= listPtr->numElements) { + first = listPtr->numElements-1; + } + if (first < 0) { + first = 0; + } + listPtr->selectAnchor = first; + } else if ((c == 'c') && (strncmp(argv[2], "clear", length) == 0)) { + ListboxSelect(listPtr, first, last, 0); + } else if ((c == 'i') && (strncmp(argv[2], "includes", length) == 0)) { + int i; + Element *elPtr; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " selection includes index\"", (char *) NULL); + goto error; + } + if ((first < 0) || (first >= listPtr->numElements)) { + interp->result = "0"; + goto done; + } + for (elPtr = listPtr->firstPtr, i = 0; i < first; + i++, elPtr = elPtr->nextPtr) { + /* Empty loop body. */ + } + if (elPtr->selected) { + interp->result = "1"; + } else { + interp->result = "0"; + } + } else if ((c == 's') && (strncmp(argv[2], "set", length) == 0)) { + ListboxSelect(listPtr, first, last, 1); + } else { + Tcl_AppendResult(interp, "bad selection option \"", argv[2], + "\": must be anchor, clear, includes, or set", + (char *) NULL); + goto error; + } + } else if ((c == 's') && (length >= 2) + && (strncmp(argv[1], "size", length) == 0)) { + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " size\"", (char *) NULL); + goto error; + } + sprintf(interp->result, "%d", listPtr->numElements); + } else if ((c == 'x') && (strncmp(argv[1], "xview", length) == 0)) { + int index, count, type, windowWidth, windowUnits; + int offset = 0; /* Initialized to stop gcc warnings. */ + double fraction, fraction2; + + windowWidth = Tk_Width(listPtr->tkwin) + - 2*(listPtr->inset + listPtr->selBorderWidth); + if (argc == 2) { + if (listPtr->maxWidth == 0) { + interp->result = "0 1"; + } else { + 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); + } + } else if (argc == 3) { + if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) { + goto error; + } + ChangeListboxOffset(listPtr, index*listPtr->xScrollUnit); + } else { + type = Tk_GetScrollInfo(interp, argc, argv, &fraction, &count); + switch (type) { + case TK_SCROLL_ERROR: + goto error; + case TK_SCROLL_MOVETO: + offset = (int) (fraction*listPtr->maxWidth + 0.5); + break; + case TK_SCROLL_PAGES: + windowUnits = windowWidth/listPtr->xScrollUnit; + if (windowUnits > 2) { + offset = listPtr->xOffset + + count*listPtr->xScrollUnit*(windowUnits-2); + } else { + offset = listPtr->xOffset + count*listPtr->xScrollUnit; + } + break; + case TK_SCROLL_UNITS: + offset = listPtr->xOffset + count*listPtr->xScrollUnit; + break; + } + ChangeListboxOffset(listPtr, offset); + } + } else if ((c == 'y') && (strncmp(argv[1], "yview", length) == 0)) { + int index, count, type; + double fraction, fraction2; + + if (argc == 2) { + if (listPtr->numElements == 0) { + interp->result = "0 1"; + } else { + 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); + } + } else if (argc == 3) { + if (GetListboxIndex(interp, listPtr, argv[2], 0, &index) + != TCL_OK) { + goto error; + } + ChangeListboxView(listPtr, index); + } else { + type = Tk_GetScrollInfo(interp, argc, argv, &fraction, &count); + switch (type) { + case TK_SCROLL_ERROR: + goto error; + case TK_SCROLL_MOVETO: + index = (int) (listPtr->numElements*fraction + 0.5); + break; + case TK_SCROLL_PAGES: + if (listPtr->fullLines > 2) { + index = listPtr->topIndex + + count*(listPtr->fullLines-2); + } else { + index = listPtr->topIndex + count; + } + break; + case TK_SCROLL_UNITS: + index = listPtr->topIndex + count; + break; + } + ChangeListboxView(listPtr, index); + } + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be activate, bbox, cget, configure, ", + "curselection, delete, get, index, insert, nearest, ", + "scan, see, selection, size, ", + "xview, or yview", (char *) NULL); + goto error; + } + done: + Tcl_Release((ClientData) listPtr); + return result; + + error: + Tcl_Release((ClientData) listPtr); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * DestroyListbox -- + * + * This procedure is invoked by Tcl_EventuallyFree or Tcl_Release + * to clean up the internal structure of a listbox at a safe time + * (when no-one is using it anymore). + * + * Results: + * None. + * + * Side effects: + * Everything associated with the listbox is freed up. + * + *---------------------------------------------------------------------- + */ + +static void +DestroyListbox(memPtr) + char *memPtr; /* Info about listbox widget. */ +{ + register Listbox *listPtr = (Listbox *) memPtr; + register Element *elPtr, *nextPtr; + + /* + * Free up all of the list elements. + */ + + for (elPtr = listPtr->firstPtr; elPtr != NULL; ) { + nextPtr = elPtr->nextPtr; + ckfree((char *) elPtr); + elPtr = nextPtr; + } + + /* + * Free up all the stuff that requires special handling, then + * let Tk_FreeOptions handle all the standard option-related + * stuff. + */ + + if (listPtr->textGC != None) { + Tk_FreeGC(listPtr->display, listPtr->textGC); + } + if (listPtr->selTextGC != None) { + Tk_FreeGC(listPtr->display, listPtr->selTextGC); + } + Tk_FreeOptions(configSpecs, (char *) listPtr, listPtr->display, 0); + ckfree((char *) listPtr); +} + +/* + *---------------------------------------------------------------------- + * + * ConfigureListbox -- + * + * This procedure is called to process an argv/argc list, plus + * the Tk option database, in order to configure (or reconfigure) + * a listbox widget. + * + * Results: + * The return value is a standard Tcl result. If TCL_ERROR is + * returned, then interp->result contains an error message. + * + * Side effects: + * Configuration information, such as colors, border width, + * etc. get set for listPtr; old resources get freed, + * if there were any. + * + *---------------------------------------------------------------------- + */ + +static int +ConfigureListbox(interp, listPtr, argc, argv, flags) + Tcl_Interp *interp; /* Used for error reporting. */ + register Listbox *listPtr; /* 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 oldExport; + + oldExport = listPtr->exportSelection; + if (Tk_ConfigureWidget(interp, listPtr->tkwin, configSpecs, + argc, argv, (char *) listPtr, flags) != TCL_OK) { + return TCL_ERROR; + } + + /* + * A few options need special processing, such as setting the + * background from a 3-D border. + */ + + Tk_SetBackgroundFromBorder(listPtr->tkwin, listPtr->normalBorder); + + if (listPtr->highlightWidth < 0) { + listPtr->highlightWidth = 0; + } + listPtr->inset = listPtr->highlightWidth + listPtr->borderWidth; + + /* + * Claim the selection if we've suddenly started exporting it and + * there is a selection to export. + */ + + if (listPtr->exportSelection && !oldExport + && (listPtr->numSelected != 0)) { + Tk_OwnSelection(listPtr->tkwin, XA_PRIMARY, ListboxLostSelection, + (ClientData) listPtr); + } + + ListboxWorldChanged((ClientData) listPtr); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * ListboxWorldChanged -- + * + * This procedure is called when the world has changed in some + * way and the widget needs to recompute all its graphics contexts + * and determine its new geometry. + * + * Results: + * None. + * + * Side effects: + * Listbox will be relayed out and redisplayed. + * + *--------------------------------------------------------------------------- + */ + +static void +ListboxWorldChanged(instanceData) + ClientData instanceData; /* Information about widget. */ +{ + XGCValues gcValues; + GC gc; + unsigned long mask; + Listbox *listPtr; + + listPtr = (Listbox *) instanceData; + + gcValues.foreground = listPtr->fgColorPtr->pixel; + gcValues.font = Tk_FontId(listPtr->tkfont); + gcValues.graphics_exposures = False; + mask = GCForeground | GCFont | GCGraphicsExposures; + gc = Tk_GetGC(listPtr->tkwin, mask, &gcValues); + if (listPtr->textGC != None) { + Tk_FreeGC(listPtr->display, listPtr->textGC); + } + listPtr->textGC = gc; + + gcValues.foreground = listPtr->selFgColorPtr->pixel; + gcValues.font = Tk_FontId(listPtr->tkfont); + mask = GCForeground | GCFont; + gc = Tk_GetGC(listPtr->tkwin, mask, &gcValues); + if (listPtr->selTextGC != None) { + Tk_FreeGC(listPtr->display, listPtr->selTextGC); + } + listPtr->selTextGC = gc; + + /* + * Register the desired geometry for the window and arrange for + * the window to be redisplayed. + */ + + ListboxComputeGeometry(listPtr, 1, 1, 1); + listPtr->flags |= UPDATE_V_SCROLLBAR|UPDATE_H_SCROLLBAR; + ListboxRedrawRange(listPtr, 0, listPtr->numElements-1); +} + +/* + *-------------------------------------------------------------- + * + * DisplayListbox -- + * + * This procedure redraws the contents of a listbox window. + * + * Results: + * None. + * + * Side effects: + * Information appears on the screen. + * + *-------------------------------------------------------------- + */ + +static void +DisplayListbox(clientData) + ClientData clientData; /* Information about window. */ +{ + register Listbox *listPtr = (Listbox *) clientData; + register Tk_Window tkwin = listPtr->tkwin; + register Element *elPtr; + GC gc; + int i, limit, x, y, width, prevSelected; + Tk_FontMetrics fm; + int left, right; /* Non-zero values here indicate + * that the left or right edge of + * the listbox is off-screen. */ + Pixmap pixmap; + + listPtr->flags &= ~REDRAW_PENDING; + if (listPtr->flags & UPDATE_V_SCROLLBAR) { + ListboxUpdateVScrollbar(listPtr); + } + if (listPtr->flags & UPDATE_H_SCROLLBAR) { + ListboxUpdateHScrollbar(listPtr); + } + listPtr->flags &= ~(REDRAW_PENDING|UPDATE_V_SCROLLBAR|UPDATE_H_SCROLLBAR); + if ((listPtr->tkwin == NULL) || !Tk_IsMapped(tkwin)) { + return; + } + + /* + * Redrawing is done in a temporary pixmap that is allocated + * here and freed at the end of the procedure. All drawing is + * done to the pixmap, and the pixmap is copied to the screen + * at the end of the procedure. This provides the smoothest + * possible visual effects (no flashing on the screen). + */ + + pixmap = Tk_GetPixmap(listPtr->display, Tk_WindowId(tkwin), + Tk_Width(tkwin), Tk_Height(tkwin), Tk_Depth(tkwin)); + Tk_Fill3DRectangle(tkwin, pixmap, listPtr->normalBorder, 0, 0, + Tk_Width(tkwin), Tk_Height(tkwin), 0, TK_RELIEF_FLAT); + + /* + * Iterate through all of the elements of the listbox, displaying each + * in turn. Selected elements use a different GC and have a raised + * background. + */ + + limit = listPtr->topIndex + listPtr->fullLines + listPtr->partialLine - 1; + if (limit >= listPtr->numElements) { + limit = listPtr->numElements-1; + } + left = right = 0; + if (listPtr->xOffset > 0) { + left = listPtr->selBorderWidth+1; + } + if ((listPtr->maxWidth - listPtr->xOffset) > (Tk_Width(listPtr->tkwin) + - 2*(listPtr->inset + listPtr->selBorderWidth))) { + right = listPtr->selBorderWidth+1; + } + prevSelected = 0; + for (elPtr = listPtr->firstPtr, i = 0; (elPtr != NULL) && (i <= limit); + prevSelected = elPtr->selected, elPtr = elPtr->nextPtr, i++) { + if (i < listPtr->topIndex) { + continue; + } + x = listPtr->inset; + y = ((i - listPtr->topIndex) * listPtr->lineHeight) + + listPtr->inset; + gc = listPtr->textGC; + if (elPtr->selected) { + gc = listPtr->selTextGC; + width = Tk_Width(tkwin) - 2*listPtr->inset; + Tk_Fill3DRectangle(tkwin, pixmap, listPtr->selBorder, x, y, + width, listPtr->lineHeight, 0, TK_RELIEF_FLAT); + + /* + * Draw beveled edges around the selection, if there are visible + * edges next to this element. Special considerations: + * 1. The left and right bevels may not be visible if horizontal + * scrolling is enabled (the "left" and "right" variables + * are zero to indicate that the corresponding bevel is + * visible). + * 2. Top and bottom bevels are only drawn if this is the + * first or last seleted item. + * 3. If the left or right bevel isn't visible, then the "left" + * and "right" variables, computed above, have non-zero values + * that extend the top and bottom bevels so that the mitered + * corners are off-screen. + */ + + if (left == 0) { + Tk_3DVerticalBevel(tkwin, pixmap, listPtr->selBorder, + x, y, listPtr->selBorderWidth, listPtr->lineHeight, + 1, TK_RELIEF_RAISED); + } + if (right == 0) { + Tk_3DVerticalBevel(tkwin, pixmap, listPtr->selBorder, + x + width - listPtr->selBorderWidth, y, + listPtr->selBorderWidth, listPtr->lineHeight, + 0, TK_RELIEF_RAISED); + } + if (!prevSelected) { + Tk_3DHorizontalBevel(tkwin, pixmap, listPtr->selBorder, + x-left, y, width+left+right, listPtr->selBorderWidth, + 1, 1, 1, TK_RELIEF_RAISED); + } + if ((elPtr->nextPtr == NULL) || !elPtr->nextPtr->selected) { + Tk_3DHorizontalBevel(tkwin, pixmap, listPtr->selBorder, x-left, + y + listPtr->lineHeight - listPtr->selBorderWidth, + width+left+right, listPtr->selBorderWidth, 0, 0, 0, + TK_RELIEF_RAISED); + } + } + Tk_GetFontMetrics(listPtr->tkfont, &fm); + y += fm.ascent + listPtr->selBorderWidth; + x = listPtr->inset + listPtr->selBorderWidth - elPtr->lBearing + - listPtr->xOffset; + Tk_DrawChars(listPtr->display, pixmap, gc, listPtr->tkfont, + elPtr->text, elPtr->textLength, x, y); + + /* + * If this is the active element, underline it. + */ + + if ((i == listPtr->active) && (listPtr->flags & GOT_FOCUS)) { + Tk_UnderlineChars(listPtr->display, pixmap, gc, listPtr->tkfont, + elPtr->text, x, y, 0, elPtr->textLength); + } + } + + /* + * Redraw the border for the listbox to make sure that it's on top + * of any of the text of the listbox entries. + */ + + Tk_Draw3DRectangle(tkwin, pixmap, listPtr->normalBorder, + listPtr->highlightWidth, listPtr->highlightWidth, + Tk_Width(tkwin) - 2*listPtr->highlightWidth, + Tk_Height(tkwin) - 2*listPtr->highlightWidth, + listPtr->borderWidth, listPtr->relief); + if (listPtr->highlightWidth > 0) { + GC gc; + + if (listPtr->flags & GOT_FOCUS) { + gc = Tk_GCForColor(listPtr->highlightColorPtr, pixmap); + } else { + gc = Tk_GCForColor(listPtr->highlightBgColorPtr, pixmap); + } + Tk_DrawFocusHighlight(tkwin, gc, listPtr->highlightWidth, pixmap); + } + XCopyArea(listPtr->display, pixmap, Tk_WindowId(tkwin), + listPtr->textGC, 0, 0, (unsigned) Tk_Width(tkwin), + (unsigned) Tk_Height(tkwin), 0, 0); + Tk_FreePixmap(listPtr->display, pixmap); +} + +/* + *---------------------------------------------------------------------- + * + * ListboxComputeGeometry -- + * + * This procedure is invoked to recompute geometry information + * such as the sizes of the elements and the overall dimensions + * desired for the listbox. + * + * Results: + * None. + * + * Side effects: + * Geometry information is updated and a new requested size is + * registered for the widget. Internal border and gridding + * information is also set. + * + *---------------------------------------------------------------------- + */ + +static void +ListboxComputeGeometry(listPtr, fontChanged, maxIsStale, updateGrid) + Listbox *listPtr; /* Listbox whose geometry is to be + * recomputed. */ + int fontChanged; /* Non-zero means the font may have changed + * so per-element width information also + * has to be computed. */ + int maxIsStale; /* Non-zero means the "maxWidth" field may + * no longer be up-to-date and must + * be recomputed. If fontChanged is 1 then + * this must be 1. */ + int updateGrid; /* Non-zero means call Tk_SetGrid or + * Tk_UnsetGrid to update gridding for + * the window. */ +{ + register Element *elPtr; + int width, height, pixelWidth, pixelHeight; + Tk_FontMetrics fm; + + if (fontChanged || maxIsStale) { + listPtr->xScrollUnit = Tk_TextWidth(listPtr->tkfont, "0", 1); + if (listPtr->xScrollUnit == 0) { + listPtr->xScrollUnit = 1; + } + listPtr->maxWidth = 0; + for (elPtr = listPtr->firstPtr; elPtr != NULL; elPtr = elPtr->nextPtr) { + if (fontChanged) { + elPtr->pixelWidth = Tk_TextWidth(listPtr->tkfont, + elPtr->text, elPtr->textLength); + elPtr->lBearing = 0; + } + if (elPtr->pixelWidth > listPtr->maxWidth) { + listPtr->maxWidth = elPtr->pixelWidth; + } + } + } + + Tk_GetFontMetrics(listPtr->tkfont, &fm); + listPtr->lineHeight = fm.linespace + 1 + 2*listPtr->selBorderWidth; + width = listPtr->width; + if (width <= 0) { + width = (listPtr->maxWidth + listPtr->xScrollUnit - 1) + /listPtr->xScrollUnit; + if (width < 1) { + width = 1; + } + } + pixelWidth = width*listPtr->xScrollUnit + 2*listPtr->inset + + 2*listPtr->selBorderWidth; + height = listPtr->height; + if (listPtr->height <= 0) { + height = listPtr->numElements; + if (height < 1) { + height = 1; + } + } + pixelHeight = height*listPtr->lineHeight + 2*listPtr->inset; + Tk_GeometryRequest(listPtr->tkwin, pixelWidth, pixelHeight); + Tk_SetInternalBorder(listPtr->tkwin, listPtr->inset); + if (updateGrid) { + if (listPtr->setGrid) { + Tk_SetGrid(listPtr->tkwin, width, height, listPtr->xScrollUnit, + listPtr->lineHeight); + } else { + Tk_UnsetGrid(listPtr->tkwin); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * InsertEls -- + * + * Add new elements to a listbox widget. + * + * Results: + * None. + * + * Side effects: + * New information gets added to listPtr; it will be redisplayed + * soon, but not immediately. + * + *---------------------------------------------------------------------- + */ + +static void +InsertEls(listPtr, index, argc, argv) + register Listbox *listPtr; /* Listbox that is to get the new + * elements. */ + int index; /* Add the new elements before this + * element. */ + int argc; /* Number of new elements to add. */ + char **argv; /* New elements (one per entry). */ +{ + register Element *prevPtr, *newPtr; + int length, i, oldMaxWidth; + + /* + * Find the element before which the new ones will be inserted. + */ + + if (index <= 0) { + index = 0; + } + if (index > listPtr->numElements) { + index = listPtr->numElements; + } + if (index == 0) { + prevPtr = NULL; + } else if (index == listPtr->numElements) { + prevPtr = listPtr->lastPtr; + } else { + for (prevPtr = listPtr->firstPtr, i = index - 1; i > 0; i--) { + prevPtr = prevPtr->nextPtr; + } + } + + /* + * For each new element, create a record, initialize it, and link + * it into the list of elements. + */ + + oldMaxWidth = listPtr->maxWidth; + for (i = argc ; i > 0; i--, argv++, prevPtr = newPtr) { + length = strlen(*argv); + newPtr = (Element *) ckalloc(ElementSize(length)); + newPtr->textLength = length; + strcpy(newPtr->text, *argv); + newPtr->pixelWidth = Tk_TextWidth(listPtr->tkfont, newPtr->text, + newPtr->textLength); + newPtr->lBearing = 0; + if (newPtr->pixelWidth > listPtr->maxWidth) { + listPtr->maxWidth = newPtr->pixelWidth; + } + newPtr->selected = 0; + if (prevPtr == NULL) { + newPtr->nextPtr = listPtr->firstPtr; + listPtr->firstPtr = newPtr; + } else { + newPtr->nextPtr = prevPtr->nextPtr; + prevPtr->nextPtr = newPtr; + } + } + if ((prevPtr != NULL) && (prevPtr->nextPtr == NULL)) { + listPtr->lastPtr = prevPtr; + } + listPtr->numElements += argc; + + /* + * Update the selection and other indexes to account for the + * renumbering that has just occurred. Then arrange for the new + * information to be displayed. + */ + + if (index <= listPtr->selectAnchor) { + listPtr->selectAnchor += argc; + } + if (index < listPtr->topIndex) { + listPtr->topIndex += argc; + } + if (index <= listPtr->active) { + listPtr->active += argc; + if ((listPtr->active >= listPtr->numElements) + && (listPtr->numElements > 0)) { + listPtr->active = listPtr->numElements-1; + } + } + listPtr->flags |= UPDATE_V_SCROLLBAR; + if (listPtr->maxWidth != oldMaxWidth) { + listPtr->flags |= UPDATE_H_SCROLLBAR; + } + ListboxComputeGeometry(listPtr, 0, 0, 0); + ListboxRedrawRange(listPtr, index, listPtr->numElements-1); +} + +/* + *---------------------------------------------------------------------- + * + * DeleteEls -- + * + * Remove one or more elements from a listbox widget. + * + * Results: + * None. + * + * Side effects: + * Memory gets freed, the listbox gets modified and (eventually) + * redisplayed. + * + *---------------------------------------------------------------------- + */ + +static void +DeleteEls(listPtr, first, last) + register Listbox *listPtr; /* Listbox widget to modify. */ + int first; /* Index of first element to delete. */ + int last; /* Index of last element to delete. */ +{ + register Element *prevPtr, *elPtr; + int count, i, widthChanged; + + /* + * Adjust the range to fit within the existing elements of the + * listbox, and make sure there's something to delete. + */ + + if (first < 0) { + first = 0; + } + if (last >= listPtr->numElements) { + last = listPtr->numElements-1; + } + count = last + 1 - first; + if (count <= 0) { + return; + } + + /* + * Find the element just before the ones to delete. + */ + + if (first == 0) { + prevPtr = NULL; + } else { + for (i = first-1, prevPtr = listPtr->firstPtr; i > 0; i--) { + prevPtr = prevPtr->nextPtr; + } + } + + /* + * Delete the requested number of elements. + */ + + widthChanged = 0; + for (i = count; i > 0; i--) { + if (prevPtr == NULL) { + elPtr = listPtr->firstPtr; + listPtr->firstPtr = elPtr->nextPtr; + if (listPtr->firstPtr == NULL) { + listPtr->lastPtr = NULL; + } + } else { + elPtr = prevPtr->nextPtr; + prevPtr->nextPtr = elPtr->nextPtr; + if (prevPtr->nextPtr == NULL) { + listPtr->lastPtr = prevPtr; + } + } + if (elPtr->pixelWidth == listPtr->maxWidth) { + widthChanged = 1; + } + if (elPtr->selected) { + listPtr->numSelected -= 1; + } + ckfree((char *) elPtr); + } + listPtr->numElements -= count; + + /* + * Update the selection and viewing information to reflect the change + * in the element numbering, and redisplay to slide information up over + * the elements that were deleted. + */ + + if (first <= listPtr->selectAnchor) { + listPtr->selectAnchor -= count; + if (listPtr->selectAnchor < first) { + listPtr->selectAnchor = first; + } + } + if (first <= listPtr->topIndex) { + listPtr->topIndex -= count; + if (listPtr->topIndex < first) { + listPtr->topIndex = first; + } + } + if (listPtr->topIndex > (listPtr->numElements - listPtr->fullLines)) { + listPtr->topIndex = listPtr->numElements - listPtr->fullLines; + if (listPtr->topIndex < 0) { + listPtr->topIndex = 0; + } + } + if (listPtr->active > last) { + listPtr->active -= count; + } else if (listPtr->active >= first) { + listPtr->active = first; + if ((listPtr->active >= listPtr->numElements) + && (listPtr->numElements > 0)) { + listPtr->active = listPtr->numElements-1; + } + } + listPtr->flags |= UPDATE_V_SCROLLBAR; + ListboxComputeGeometry(listPtr, 0, widthChanged, 0); + if (widthChanged) { + listPtr->flags |= UPDATE_H_SCROLLBAR; + } + ListboxRedrawRange(listPtr, first, listPtr->numElements-1); +} + +/* + *-------------------------------------------------------------- + * + * ListboxEventProc -- + * + * This procedure is invoked by the Tk dispatcher for various + * events on listboxes. + * + * Results: + * None. + * + * Side effects: + * When the window gets deleted, internal structures get + * cleaned up. When it gets exposed, it is redisplayed. + * + *-------------------------------------------------------------- + */ + +static void +ListboxEventProc(clientData, eventPtr) + ClientData clientData; /* Information about window. */ + XEvent *eventPtr; /* Information about event. */ +{ + Listbox *listPtr = (Listbox *) clientData; + + if (eventPtr->type == Expose) { + ListboxRedrawRange(listPtr, + NearestListboxElement(listPtr, eventPtr->xexpose.y), + NearestListboxElement(listPtr, eventPtr->xexpose.y + + eventPtr->xexpose.height)); + } else if (eventPtr->type == DestroyNotify) { + if (listPtr->tkwin != NULL) { + if (listPtr->setGrid) { + Tk_UnsetGrid(listPtr->tkwin); + } + listPtr->tkwin = NULL; + Tcl_DeleteCommandFromToken(listPtr->interp, listPtr->widgetCmd); + } + if (listPtr->flags & REDRAW_PENDING) { + Tcl_CancelIdleCall(DisplayListbox, (ClientData) listPtr); + } + Tcl_EventuallyFree((ClientData) listPtr, DestroyListbox); + } else if (eventPtr->type == ConfigureNotify) { + int vertSpace; + + vertSpace = Tk_Height(listPtr->tkwin) - 2*listPtr->inset; + listPtr->fullLines = vertSpace / listPtr->lineHeight; + if ((listPtr->fullLines*listPtr->lineHeight) < vertSpace) { + listPtr->partialLine = 1; + } else { + listPtr->partialLine = 0; + } + listPtr->flags |= UPDATE_V_SCROLLBAR|UPDATE_H_SCROLLBAR; + ChangeListboxView(listPtr, listPtr->topIndex); + ChangeListboxOffset(listPtr, listPtr->xOffset); + + /* + * Redraw the whole listbox. It's hard to tell what needs + * to be redrawn (e.g. if the listbox has shrunk then we + * may only need to redraw the borders), so just redraw + * everything for safety. + */ + + ListboxRedrawRange(listPtr, 0, listPtr->numElements-1); + } else if (eventPtr->type == FocusIn) { + if (eventPtr->xfocus.detail != NotifyInferior) { + listPtr->flags |= GOT_FOCUS; + ListboxRedrawRange(listPtr, 0, listPtr->numElements-1); + } + } else if (eventPtr->type == FocusOut) { + if (eventPtr->xfocus.detail != NotifyInferior) { + listPtr->flags &= ~GOT_FOCUS; + ListboxRedrawRange(listPtr, 0, listPtr->numElements-1); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * ListboxCmdDeletedProc -- + * + * 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 +ListboxCmdDeletedProc(clientData) + ClientData clientData; /* Pointer to widget record for widget. */ +{ + Listbox *listPtr = (Listbox *) clientData; + Tk_Window tkwin = listPtr->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. + */ + + if (tkwin != NULL) { + if (listPtr->setGrid) { + Tk_UnsetGrid(listPtr->tkwin); + } + listPtr->tkwin = NULL; + Tk_DestroyWindow(tkwin); + } +} + +/* + *-------------------------------------------------------------- + * + * GetListboxIndex -- + * + * Parse an index into a listbox and return either its value + * or an error. + * + * 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. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static int +GetListboxIndex(interp, listPtr, string, endIsSize, indexPtr) + Tcl_Interp *interp; /* For error messages. */ + Listbox *listPtr; /* Listbox for which the index is being + * specified. */ + char *string; /* Specifies an element in the listbox. */ + int endIsSize; /* If 1, "end" refers to the number of + * entries in the listbox. If 0, "end" + * refers to 1 less than the number of + * entries. */ + int *indexPtr; /* Where to store converted index. */ +{ + int c; + size_t length; + + length = strlen(string); + c = string[0]; + if ((c == 'a') && (strncmp(string, "active", length) == 0) + && (length >= 2)) { + *indexPtr = listPtr->active; + } else if ((c == 'a') && (strncmp(string, "anchor", length) == 0) + && (length >= 2)) { + *indexPtr = listPtr->selectAnchor; + } else if ((c == 'e') && (strncmp(string, "end", length) == 0)) { + if (endIsSize) { + *indexPtr = listPtr->numElements; + } else { + *indexPtr = listPtr->numElements - 1; + } + } else if (c == '@') { + int y; + char *p, *end; + + p = string+1; + strtol(p, &end, 0); + if ((end == p) || (*end != ',')) { + goto badIndex; + } + p = end+1; + y = strtol(p, &end, 0); + if ((end == p) || (*end != 0)) { + goto badIndex; + } + *indexPtr = NearestListboxElement(listPtr, y); + } else { + if (Tcl_GetInt(interp, string, indexPtr) != TCL_OK) { + Tcl_ResetResult(interp); + goto badIndex; + } + } + return TCL_OK; + + badIndex: + Tcl_AppendResult(interp, "bad listbox index \"", string, + "\": must be active, anchor, end, @x,y, or a number", + (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * ChangeListboxView -- + * + * Change the view on a listbox widget so that a given element + * is displayed at the top. + * + * Results: + * None. + * + * Side effects: + * What's displayed on the screen is changed. If there is a + * scrollbar associated with this widget, then the scrollbar + * is instructed to change its display too. + * + *---------------------------------------------------------------------- + */ + +static void +ChangeListboxView(listPtr, index) + register Listbox *listPtr; /* Information about widget. */ + int index; /* Index of element in listPtr + * that should now appear at the + * top of the listbox. */ +{ + if (index >= (listPtr->numElements - listPtr->fullLines)) { + index = listPtr->numElements - listPtr->fullLines; + } + if (index < 0) { + index = 0; + } + if (listPtr->topIndex != index) { + listPtr->topIndex = index; + if (!(listPtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(DisplayListbox, (ClientData) listPtr); + listPtr->flags |= REDRAW_PENDING; + } + listPtr->flags |= UPDATE_V_SCROLLBAR; + } +} + +/* + *---------------------------------------------------------------------- + * + * ChangListboxOffset -- + * + * Change the horizontal offset for a listbox. + * + * Results: + * None. + * + * Side effects: + * The listbox may be redrawn to reflect its new horizontal + * offset. + * + *---------------------------------------------------------------------- + */ + +static void +ChangeListboxOffset(listPtr, offset) + register Listbox *listPtr; /* Information about widget. */ + int offset; /* Desired new "xOffset" for + * listbox. */ +{ + int maxOffset; + + /* + * Make sure that the new offset is within the allowable range, and + * round it off to an even multiple of xScrollUnit. + */ + + maxOffset = listPtr->maxWidth - (Tk_Width(listPtr->tkwin) - + 2*listPtr->inset - 2*listPtr->selBorderWidth) + + listPtr->xScrollUnit - 1; + if (offset > maxOffset) { + offset = maxOffset; + } + if (offset < 0) { + offset = 0; + } + offset -= offset % listPtr->xScrollUnit; + if (offset != listPtr->xOffset) { + listPtr->xOffset = offset; + listPtr->flags |= UPDATE_H_SCROLLBAR; + ListboxRedrawRange(listPtr, 0, listPtr->numElements); + } +} + +/* + *---------------------------------------------------------------------- + * + * ListboxScanTo -- + * + * Given a point (presumably of the curent mouse location) + * drag the view in the window to implement the scan operation. + * + * Results: + * None. + * + * Side effects: + * The view in the window may change. + * + *---------------------------------------------------------------------- + */ + +static void +ListboxScanTo(listPtr, x, y) + register Listbox *listPtr; /* Information about widget. */ + int x; /* X-coordinate to use for scan + * operation. */ + int y; /* Y-coordinate to use for scan + * operation. */ +{ + int newTopIndex, newOffset, maxIndex, maxOffset; + + maxIndex = listPtr->numElements - listPtr->fullLines; + maxOffset = listPtr->maxWidth + (listPtr->xScrollUnit - 1) + - (Tk_Width(listPtr->tkwin) - 2*listPtr->inset + - 2*listPtr->selBorderWidth - listPtr->xScrollUnit); + + /* + * Compute new top line for screen by amplifying the difference + * between the current position and the place where the scan + * started (the "mark" position). If we run off the top or bottom + * of the list, then reset the mark point so that the current + * position continues to correspond to the edge of the window. + * This means that the picture will start dragging as soon as the + * mouse reverses direction (without this reset, might have to slide + * mouse a long ways back before the picture starts moving again). + */ + + newTopIndex = listPtr->scanMarkYIndex + - (10*(y - listPtr->scanMarkY))/listPtr->lineHeight; + if (newTopIndex > maxIndex) { + newTopIndex = listPtr->scanMarkYIndex = maxIndex; + listPtr->scanMarkY = y; + } else if (newTopIndex < 0) { + newTopIndex = listPtr->scanMarkYIndex = 0; + listPtr->scanMarkY = y; + } + ChangeListboxView(listPtr, newTopIndex); + + /* + * Compute new left edge for display in a similar fashion by amplifying + * the difference between the current position and the place where the + * scan started. + */ + + newOffset = listPtr->scanMarkXOffset - (10*(x - listPtr->scanMarkX)); + if (newOffset > maxOffset) { + newOffset = listPtr->scanMarkXOffset = maxOffset; + listPtr->scanMarkX = x; + } else if (newOffset < 0) { + newOffset = listPtr->scanMarkXOffset = 0; + listPtr->scanMarkX = x; + } + ChangeListboxOffset(listPtr, newOffset); +} + +/* + *---------------------------------------------------------------------- + * + * NearestListboxElement -- + * + * Given a y-coordinate inside a listbox, compute the index of + * the element under that y-coordinate (or closest to that + * y-coordinate). + * + * Results: + * The return value is an index of an element of listPtr. If + * listPtr has no elements, then 0 is always returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +NearestListboxElement(listPtr, y) + register Listbox *listPtr; /* Information about widget. */ + int y; /* Y-coordinate in listPtr's window. */ +{ + int index; + + index = (y - listPtr->inset)/listPtr->lineHeight; + if (index >= (listPtr->fullLines + listPtr->partialLine)) { + index = listPtr->fullLines + listPtr->partialLine - 1; + } + if (index < 0) { + index = 0; + } + index += listPtr->topIndex; + if (index >= listPtr->numElements) { + index = listPtr->numElements-1; + } + return index; +} + +/* + *---------------------------------------------------------------------- + * + * ListboxSelect -- + * + * Select or deselect one or more elements in a listbox.. + * + * Results: + * None. + * + * Side effects: + * All of the elements in the range between first and last are + * marked as either selected or deselected, depending on the + * "select" argument. Any items whose state changes are redisplayed. + * The selection is claimed from X when the number of selected + * elements changes from zero to non-zero. + * + *---------------------------------------------------------------------- + */ + +static void +ListboxSelect(listPtr, first, last, select) + register Listbox *listPtr; /* Information about widget. */ + int first; /* Index of first element to + * select or deselect. */ + int last; /* Index of last element to + * select or deselect. */ + int select; /* 1 means select items, 0 means + * deselect them. */ +{ + int i, firstRedisplay, increment, oldCount; + Element *elPtr; + + if (last < first) { + i = first; + first = last; + last = i; + } + if ((last < 0) || (first >= listPtr->numElements)) { + return; + } + if (first < 0) { + first = 0; + } + if (last >= listPtr->numElements) { + last = listPtr->numElements - 1; + } + oldCount = listPtr->numSelected; + firstRedisplay = -1; + increment = select ? 1 : -1; + for (i = 0, elPtr = listPtr->firstPtr; i < first; + i++, elPtr = elPtr->nextPtr) { + /* Empty loop body. */ + } + for ( ; i <= last; i++, elPtr = elPtr->nextPtr) { + if (elPtr->selected == select) { + continue; + } + listPtr->numSelected += increment; + elPtr->selected = select; + if (firstRedisplay < 0) { + firstRedisplay = i; + } + } + if (firstRedisplay >= 0) { + ListboxRedrawRange(listPtr, first, last); + } + if ((oldCount == 0) && (listPtr->numSelected > 0) + && (listPtr->exportSelection)) { + Tk_OwnSelection(listPtr->tkwin, XA_PRIMARY, ListboxLostSelection, + (ClientData) listPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * ListboxFetchSelection -- + * + * This procedure is called back by Tk when the selection is + * requested by someone. It returns part or all of the selection + * in a buffer provided by the caller. + * + * Results: + * The return value is the number of non-NULL bytes stored + * at buffer. Buffer is filled (or partially filled) with a + * NULL-terminated string containing part or all of the selection, + * as given by offset and maxBytes. The selection is returned + * as a Tcl list with one list element for each element in the + * listbox. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ListboxFetchSelection(clientData, offset, buffer, maxBytes) + ClientData clientData; /* Information about listbox widget. */ + int offset; /* Offset within selection of first + * byte 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. */ +{ + register Listbox *listPtr = (Listbox *) clientData; + register Element *elPtr; + Tcl_DString selection; + int length, count, needNewline; + + if (!listPtr->exportSelection) { + return -1; + } + + /* + * Use a dynamic string to accumulate the contents of the selection. + */ + + needNewline = 0; + Tcl_DStringInit(&selection); + for (elPtr = listPtr->firstPtr; elPtr != NULL; elPtr = elPtr->nextPtr) { + if (elPtr->selected) { + if (needNewline) { + Tcl_DStringAppend(&selection, "\n", 1); + } + Tcl_DStringAppend(&selection, elPtr->text, elPtr->textLength); + needNewline = 1; + } + } + + length = Tcl_DStringLength(&selection); + if (length == 0) { + return -1; + } + + /* + * Copy the requested portion of the selection to the buffer. + */ + + count = length - offset; + if (count <= 0) { + count = 0; + } else { + if (count > maxBytes) { + count = maxBytes; + } + memcpy((VOID *) buffer, + (VOID *) (Tcl_DStringValue(&selection) + offset), + (size_t) count); + } + buffer[count] = '\0'; + Tcl_DStringFree(&selection); + return count; +} + +/* + *---------------------------------------------------------------------- + * + * ListboxLostSelection -- + * + * This procedure is called back by Tk when the selection is + * grabbed away from a listbox widget. + * + * Results: + * None. + * + * Side effects: + * The existing selection is unhighlighted, and the window is + * marked as not containing a selection. + * + *---------------------------------------------------------------------- + */ + +static void +ListboxLostSelection(clientData) + ClientData clientData; /* Information about listbox widget. */ +{ + register Listbox *listPtr = (Listbox *) clientData; + + if ((listPtr->exportSelection) && (listPtr->numElements > 0)) { + ListboxSelect(listPtr, 0, listPtr->numElements-1, 0); + } +} + +/* + *---------------------------------------------------------------------- + * + * ListboxRedrawRange -- + * + * Ensure that a given range of elements is eventually redrawn on + * the display (if those elements in fact appear on the display). + * + * Results: + * None. + * + * Side effects: + * Information gets redisplayed. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +ListboxRedrawRange(listPtr, first, last) + register Listbox *listPtr; /* Information about widget. */ + int first; /* Index of first element in list + * that needs to be redrawn. */ + int last; /* Index of last element in list + * that needs to be redrawn. May + * be less than first; + * these just bracket a range. */ +{ + if ((listPtr->tkwin == NULL) || !Tk_IsMapped(listPtr->tkwin) + || (listPtr->flags & REDRAW_PENDING)) { + return; + } + Tcl_DoWhenIdle(DisplayListbox, (ClientData) listPtr); + listPtr->flags |= REDRAW_PENDING; +} + +/* + *---------------------------------------------------------------------- + * + * ListboxUpdateVScrollbar -- + * + * This procedure is invoked whenever information has changed in + * a listbox in a way that would invalidate a vertical scrollbar + * display. If there is an associated scrollbar, then this command + * updates it by invoking a Tcl command. + * + * Results: + * None. + * + * Side effects: + * A Tcl command is invoked, and an additional command may be + * invoked to process errors in the command. + * + *---------------------------------------------------------------------- + */ + +static void +ListboxUpdateVScrollbar(listPtr) + register Listbox *listPtr; /* Information about widget. */ +{ + char string[100]; + double first, last; + int result; + Tcl_Interp *interp; + + if (listPtr->yScrollCmd == NULL) { + return; + } + if (listPtr->numElements == 0) { + first = 0.0; + last = 1.0; + } else { + first = listPtr->topIndex/((double) listPtr->numElements); + last = (listPtr->topIndex+listPtr->fullLines) + /((double) listPtr->numElements); + if (last > 1.0) { + last = 1.0; + } + } + sprintf(string, " %g %g", first, last); + + /* + * We must hold onto the interpreter from the listPtr because the data + * at listPtr might be freed as a result of the Tcl_VarEval. + */ + + interp = listPtr->interp; + Tcl_Preserve((ClientData) interp); + result = Tcl_VarEval(interp, listPtr->yScrollCmd, string, + (char *) NULL); + if (result != TCL_OK) { + Tcl_AddErrorInfo(interp, + "\n (vertical scrolling command executed by listbox)"); + Tcl_BackgroundError(interp); + } + Tcl_Release((ClientData) interp); +} + +/* + *---------------------------------------------------------------------- + * + * ListboxUpdateHScrollbar -- + * + * This procedure is invoked whenever information has changed in + * a listbox in a way that would invalidate a horizontal scrollbar + * display. If there is an associated horizontal scrollbar, then + * this command updates it by invoking a Tcl command. + * + * Results: + * None. + * + * Side effects: + * A Tcl command is invoked, and an additional command may be + * invoked to process errors in the command. + * + *---------------------------------------------------------------------- + */ + +static void +ListboxUpdateHScrollbar(listPtr) + register Listbox *listPtr; /* Information about widget. */ +{ + char string[60]; + int result, windowWidth; + double first, last; + Tcl_Interp *interp; + + if (listPtr->xScrollCmd == NULL) { + return; + } + windowWidth = Tk_Width(listPtr->tkwin) - 2*(listPtr->inset + + listPtr->selBorderWidth); + if (listPtr->maxWidth == 0) { + first = 0; + last = 1.0; + } else { + first = listPtr->xOffset/((double) listPtr->maxWidth); + last = (listPtr->xOffset + windowWidth) + /((double) listPtr->maxWidth); + if (last > 1.0) { + last = 1.0; + } + } + sprintf(string, " %g %g", first, last); + + /* + * We must hold onto the interpreter because the data referred to at + * listPtr might be freed as a result of the call to Tcl_VarEval. + */ + + interp = listPtr->interp; + Tcl_Preserve((ClientData) interp); + result = Tcl_VarEval(interp, listPtr->xScrollCmd, string, + (char *) NULL); + if (result != TCL_OK) { + Tcl_AddErrorInfo(interp, + "\n (horizontal scrolling command executed by listbox)"); + Tcl_BackgroundError(interp); + } + Tcl_Release((ClientData) interp); +} diff --git a/generic/tkMacWinMenu.c b/generic/tkMacWinMenu.c new file mode 100644 index 0000000..8ae403b --- /dev/null +++ b/generic/tkMacWinMenu.c @@ -0,0 +1,134 @@ +/* + * tkMacWinMenu.c -- + * + * This module implements the common elements of the Mac and Windows + * specific features of menus. This file is not used for UNIX. + * + * 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: @(#) tkMacWinMenu.c 1.39 97/04/09 14:56:59 + */ + +#include "tkMenu.h" + +static int postCommandGeneration; + +static int PreprocessMenu _ANSI_ARGS_((TkMenu *menuPtr)); + + +/* + *---------------------------------------------------------------------- + * + * PreprocessMenu -- + * + * The guts of the preprocessing. Recursive. + * + * Results: + * The return value is a standard Tcl result (errors can occur + * while the postcommands are being processed). + * + * Side effects: + * Since commands can get executed while this routine is being executed, + * the entire world can change. + * + *---------------------------------------------------------------------- + */ + +static int +PreprocessMenu(menuPtr) + TkMenu *menuPtr; +{ + int index, result, finished; + TkMenu *cascadeMenuPtr; + + Tcl_Preserve((ClientData) menuPtr); + + /* + * First, let's process the post command on ourselves. If this command + * destroys this menu, or if there was an error, we are done. + */ + + result = TkPostCommand(menuPtr); + if ((result != TCL_OK) || (menuPtr->tkwin == NULL)) { + goto done; + } + + /* + * Now, we go through structure and process all of the commands. + * Since the structure is changing, we stop after we do one command, + * and start over. When we get through without doing any, we are done. + */ + + + do { + finished = 1; + for (index = 0; index < menuPtr->numEntries; index++) { + if ((menuPtr->entries[index]->type == CASCADE_ENTRY) + && (menuPtr->entries[index]->name != NULL)) { + if ((menuPtr->entries[index]->childMenuRefPtr != NULL) + && (menuPtr->entries[index]->childMenuRefPtr->menuPtr + != NULL)) { + cascadeMenuPtr = + menuPtr->entries[index]->childMenuRefPtr->menuPtr; + if (cascadeMenuPtr->postCommandGeneration != + postCommandGeneration) { + cascadeMenuPtr->postCommandGeneration = + postCommandGeneration; + result = PreprocessMenu(cascadeMenuPtr); + if (result != TCL_OK) { + goto done; + } + finished = 0; + break; + } + } + } + } + } while (!finished); + + done: + Tcl_Release((ClientData)menuPtr); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TkPreprocessMenu -- + * + * On the Mac and on Windows, all of the postcommand processing has + * to be done on the entire tree underneath the main window to be + * posted. This means that we have to traverse the menu tree and + * issue the postcommands for all of the menus that have cascades + * attached. Since the postcommands can change the menu structure while + * we are traversing, we have to be extremely careful. Basically, the + * idea is to traverse the structure until we succesfully process + * one postcommand. Then we start over, and do it again until + * we traverse the whole structure without processing any postcommands. + * + * We are also going to set up the cascade back pointers in here + * since we have to traverse the entire structure underneath the menu + * anyway, We can clear the postcommand marks while we do that. + * + * Results: + * The return value is a standard Tcl result (errors can occur + * while the postcommands are being processed). + * + * Side effects: + * Since commands can get executed while this routine is being executed, + * the entire world can change. + * + *---------------------------------------------------------------------- + */ + +int +TkPreprocessMenu(menuPtr) + TkMenu *menuPtr; +{ + postCommandGeneration++; + menuPtr->postCommandGeneration = postCommandGeneration; + return PreprocessMenu(menuPtr); +} diff --git a/generic/tkMain.c b/generic/tkMain.c new file mode 100644 index 0000000..ed823bd --- /dev/null +++ b/generic/tkMain.c @@ -0,0 +1,390 @@ +/* + * tkMain.c -- + * + * This file contains a generic main program for Tk-based applications. + * It can be used as-is for many applications, just by supplying a + * different appInitProc procedure for each specific application. + * Or, it can be used as a template for creating new main programs + * for Tk applications. + * + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkMain.c 1.154 97/08/29 10:40:43 + */ + +#include +#include +#include +#include +#include +#ifdef NO_STDLIB_H +# include "../compat/stdlib.h" +#else +# include +#endif + +/* + * Declarations for various library procedures and variables (don't want + * to include tkInt.h or tkPort.h here, because people might copy this + * file out of the Tk source directory to make their own modified versions). + * Note: don't declare "exit" here even though a declaration is really + * needed, because it will conflict with a declaration elsewhere on + * some systems. + */ + +extern int isatty _ANSI_ARGS_((int fd)); +#if !defined(__WIN32__) && !defined(_WIN32) +extern char * strrchr _ANSI_ARGS_((CONST char *string, int c)); +#endif +extern void TkpDisplayWarning _ANSI_ARGS_((char *msg, + char *title)); + +/* + * Global variables used by the main program: + */ + +static Tcl_Interp *interp; /* Interpreter for this application. */ +static Tcl_DString command; /* Used to assemble lines of terminal input + * into Tcl commands. */ +static Tcl_DString line; /* Used to read the next line from the + * terminal input. */ +static int tty; /* Non-zero means standard input is a + * terminal-like device. Zero means it's + * a file. */ + +/* + * Forward declarations for procedures defined later in this file. + */ + +static void Prompt _ANSI_ARGS_((Tcl_Interp *interp, int partial)); +static void StdinProc _ANSI_ARGS_((ClientData clientData, + int mask)); + +/* + *---------------------------------------------------------------------- + * + * Tk_Main -- + * + * Main program for Wish and most other Tk-based applications. + * + * Results: + * None. This procedure never returns (it exits the process when + * it's done. + * + * Side effects: + * This procedure initializes the Tk world and then starts + * interpreting commands; almost anything could happen, depending + * on the script being interpreted. + * + *---------------------------------------------------------------------- + */ + +void +Tk_Main(argc, argv, appInitProc) + int argc; /* Number of arguments. */ + char **argv; /* Array of argument strings. */ + Tcl_AppInitProc *appInitProc; /* Application-specific initialization + * procedure to call after most + * initialization but before starting + * to execute commands. */ +{ + char *args, *fileName; + char buf[20]; + int code; + size_t length; + Tcl_Channel inChannel, outChannel; + + Tcl_FindExecutable(argv[0]); + interp = Tcl_CreateInterp(); +#ifdef TCL_MEM_DEBUG + Tcl_InitMemory(interp); +#endif + + /* + * Parse command-line arguments. A leading "-file" argument is + * ignored (a historical relic from the distant past). If the + * next argument doesn't start with a "-" then strip it off and + * use it as the name of a script file to process. + */ + + fileName = NULL; + if (argc > 1) { + length = strlen(argv[1]); + if ((length >= 2) && (strncmp(argv[1], "-file", length) == 0)) { + argc--; + argv++; + } + } + if ((argc > 1) && (argv[1][0] != '-')) { + fileName = argv[1]; + argc--; + argv++; + } + + /* + * Make command-line arguments available in the Tcl variables "argc" + * and "argv". + */ + + args = Tcl_Merge(argc-1, argv+1); + Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY); + ckfree(args); + sprintf(buf, "%d", argc-1); + Tcl_SetVar(interp, "argc", buf, TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "argv0", (fileName != NULL) ? fileName : argv[0], + TCL_GLOBAL_ONLY); + + /* + * Set the "tcl_interactive" variable. + */ + + /* + * For now, under Windows, we assume we are not running as a console mode + * app, so we need to use the GUI console. In order to enable this, we + * always claim to be running on a tty. This probably isn't the right + * way to do it. + */ + +#ifdef __WIN32__ + tty = 1; +#else + tty = isatty(0); +#endif + Tcl_SetVar(interp, "tcl_interactive", + ((fileName == NULL) && tty) ? "1" : "0", TCL_GLOBAL_ONLY); + + /* + * Invoke application-specific initialization. + */ + + if ((*appInitProc)(interp) != TCL_OK) { + TkpDisplayWarning(interp->result, "Application initialization failed"); + } + + /* + * Invoke the script specified on the command line, if any. + */ + + if (fileName != NULL) { + code = Tcl_EvalFile(interp, fileName); + if (code != TCL_OK) { + /* + * The following statement guarantees that the errorInfo + * variable is set properly. + */ + + Tcl_AddErrorInfo(interp, ""); + TkpDisplayWarning(Tcl_GetVar(interp, "errorInfo", + TCL_GLOBAL_ONLY), "Error in startup script"); + Tcl_DeleteInterp(interp); + Tcl_Exit(1); + } + tty = 0; + } else { + + /* + * Evaluate the .rc file, if one has been specified. + */ + + Tcl_SourceRCFile(interp); + + /* + * Establish a channel handler for stdin. + */ + + inChannel = Tcl_GetStdChannel(TCL_STDIN); + if (inChannel) { + Tcl_CreateChannelHandler(inChannel, TCL_READABLE, StdinProc, + (ClientData) inChannel); + } + if (tty) { + Prompt(interp, 0); + } + } + + outChannel = Tcl_GetStdChannel(TCL_STDOUT); + if (outChannel) { + Tcl_Flush(outChannel); + } + Tcl_DStringInit(&command); + Tcl_DStringInit(&line); + Tcl_ResetResult(interp); + + /* + * Loop infinitely, waiting for commands to execute. When there + * are no windows left, Tk_MainLoop returns and we exit. + */ + + Tk_MainLoop(); + Tcl_DeleteInterp(interp); + Tcl_Exit(0); +} + +/* + *---------------------------------------------------------------------- + * + * StdinProc -- + * + * This procedure is invoked by the event dispatcher whenever + * standard input becomes readable. It grabs the next line of + * input characters, adds them to a command being assembled, and + * executes the command if it's complete. + * + * Results: + * None. + * + * Side effects: + * Could be almost arbitrary, depending on the command that's + * typed. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +StdinProc(clientData, mask) + ClientData clientData; /* Not used. */ + int mask; /* Not used. */ +{ + static int gotPartial = 0; + char *cmd; + int code, count; + Tcl_Channel chan = (Tcl_Channel) clientData; + + count = Tcl_Gets(chan, &line); + + if (count < 0) { + if (!gotPartial) { + if (tty) { + Tcl_Exit(0); + } else { + Tcl_DeleteChannelHandler(chan, StdinProc, (ClientData) chan); + } + return; + } + } + + (void) Tcl_DStringAppend(&command, Tcl_DStringValue(&line), -1); + cmd = Tcl_DStringAppend(&command, "\n", -1); + Tcl_DStringFree(&line); + if (!Tcl_CommandComplete(cmd)) { + gotPartial = 1; + goto prompt; + } + gotPartial = 0; + + /* + * Disable the stdin channel handler while evaluating the command; + * otherwise if the command re-enters the event loop we might + * process commands from stdin before the current command is + * finished. Among other things, this will trash the text of the + * command being evaluated. + */ + + Tcl_CreateChannelHandler(chan, 0, StdinProc, (ClientData) chan); + code = Tcl_RecordAndEval(interp, cmd, TCL_EVAL_GLOBAL); + + chan = Tcl_GetStdChannel(TCL_STDIN); + if (chan) { + Tcl_CreateChannelHandler(chan, TCL_READABLE, StdinProc, + (ClientData) chan); + } + Tcl_DStringFree(&command); + if (*interp->result != 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); + } + } + + /* + * Output a prompt. + */ + + prompt: + if (tty) { + Prompt(interp, gotPartial); + } + Tcl_ResetResult(interp); +} + +/* + *---------------------------------------------------------------------- + * + * Prompt -- + * + * Issue a prompt on standard output, or invoke a script + * to issue the prompt. + * + * Results: + * None. + * + * Side effects: + * A prompt gets output, and a Tcl script may be evaluated + * in interp. + * + *---------------------------------------------------------------------- + */ + +static void +Prompt(interp, partial) + Tcl_Interp *interp; /* Interpreter to use for prompting. */ + int partial; /* Non-zero means there already + * exists a partial command, so use + * the secondary prompt. */ +{ + char *promptCmd; + int code; + Tcl_Channel outChannel, errChannel; + + promptCmd = Tcl_GetVar(interp, + partial ? "tcl_prompt2" : "tcl_prompt1", TCL_GLOBAL_ONLY); + if (promptCmd == NULL) { +defaultPrompt: + if (!partial) { + + /* + * We must check that outChannel is a real channel - it + * is possible that someone has transferred stdout out of + * this interpreter with "interp transfer". + */ + + outChannel = Tcl_GetChannel(interp, "stdout", NULL); + if (outChannel != (Tcl_Channel) NULL) { + Tcl_Write(outChannel, "% ", 2); + } + } + } else { + code = Tcl_Eval(interp, promptCmd); + if (code != TCL_OK) { + Tcl_AddErrorInfo(interp, + "\n (script that generates prompt)"); + /* + * We must check that errChannel is a real channel - it + * is possible that someone has transferred stderr out of + * this interpreter with "interp transfer". + */ + + errChannel = Tcl_GetChannel(interp, "stderr", NULL); + if (errChannel != (Tcl_Channel) NULL) { + Tcl_Write(errChannel, interp->result, -1); + Tcl_Write(errChannel, "\n", 1); + } + goto defaultPrompt; + } + } + outChannel = Tcl_GetChannel(interp, "stdout", NULL); + if (outChannel != (Tcl_Channel) NULL) { + Tcl_Flush(outChannel); + } +} diff --git a/generic/tkMenu.c b/generic/tkMenu.c new file mode 100644 index 0000000..05a6b4a --- /dev/null +++ b/generic/tkMenu.c @@ -0,0 +1,3057 @@ +/* + * tkMenu.c -- + * + * This file contains most of the code for implementing menus in Tk. It takes + * care of all of the generic (platform-independent) parts of menus, and + * is supplemented by platform-specific files. The geometry calculation + * 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. + * + * 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 + */ + +/* + * Notes on implementation of menus: + * + * Menus can be used in three ways: + * - as a popup menu, either as part of a menubutton or standalone. + * - as a menubar. The menu's cascade items are arranged according to + * the specific platform to provide the user access to the menus at all + * times + * - as a tearoff palette. This is a window with the menu's items in it. + * + * The goal is to provide the Tk developer with a way to use a common + * set of menus for all of these tasks. + * + * In order to make the bindings for cascade menus work properly under Unix, + * the cascade menus' pathnames must be proper children of the menu that + * they are cascade from. So if there is a menu .m, and it has two + * cascades labelled "File" and "Edit", the cascade menus might have + * the pathnames .m.file and .m.edit. Another constraint is that the menus + * used for menubars must be children of the toplevel widget that they + * are attached to. And on the Macintosh, the platform specific menu handle + * for cascades attached to a menu bar must have a title that matches the + * label for the cascade menu. + * + * To handle all of the constraints, Tk menubars and tearoff menus are + * implemented using menu clones. Menu clones are full menus in their own + * right; they have a Tk window and pathname associated with them; they have + * a TkMenu structure and array of entries. However, they are linked with the + * original menu that they were cloned from. The reflect the attributes of + * the original, or "master", menu. So if an item is added to a menu, and + * that menu has clones, then the item must be added to all of its clones + * also. Menus are cloned when a menu is torn-off or when a menu is assigned + * as a menubar using the "-menu" option of the toplevel's pathname configure + * subcommand. When a clone is destroyed, only the clone is destroyed, but + * when the master menu is destroyed, all clones are also destroyed. This + * allows the developer to just deal with one set of menus when creating + * and destroying. + * + * Clones are rather tricky when a menu with cascade entries is cloned (such + * as a menubar). Not only does the menu have to be cloned, but each cascade + * entry's corresponding menu must also be cloned. This maintains the pathname + * parent-child hierarchy necessary for menubars and toplevels to work. + * This leads to several special cases: + * + * 1. When a new menu is created, and it is pointed to by cascade entries in + * cloned menus, the new menu has to be cloned to parallel the cascade + * structure. + * 2. When a cascade item is added to a menu that has been cloned, and the + * menu that the cascade item points to exists, that menu has to be cloned. + * 3. When the menu that a cascade entry points to is changed, the old + * cloned cascade menu has to be discarded, and the new one has to be cloned. + * + */ + +#include "tkPort.h" +#include "tkMenu.h" + +#define MENU_HASH_KEY "tkMenus" + +static int menusInitialized; /* Whether or not the hash tables, etc., have + * been setup */ + +/* + * Configuration specs for individual menu entries. If this changes, be sure + * 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} +}; + +/* + * 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. + */ + +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", + "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", + "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} +}; + +/* + * Prototypes for static procedures in this file: + */ + +static int CloneMenu _ANSI_ARGS_((TkMenu *menuPtr, + char *newMenuName, char *newMenuTypeString)); +static int ConfigureMenu _ANSI_ARGS_((Tcl_Interp *interp, + TkMenu *menuPtr, int argc, char **argv, + int flags)); +static int ConfigureMenuCloneEntries _ANSI_ARGS_(( + Tcl_Interp *interp, TkMenu *menuPtr, int index, + int argc, char **argv, int flags)); +static int ConfigureMenuEntry _ANSI_ARGS_((TkMenuEntry *mePtr, + int argc, char **argv, int flags)); +static void DeleteMenuCloneEntries _ANSI_ARGS_((TkMenu *menuPtr, + int first, int last)); +static void DestroyMenuHashTable _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp)); +static void DestroyMenuInstance _ANSI_ARGS_((TkMenu *menuPtr)); +static void DestroyMenuEntry _ANSI_ARGS_((char *memPtr)); +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)); +static int MenuAddOrInsert _ANSI_ARGS_((Tcl_Interp *interp, + TkMenu *menuPtr, char *indexString, int argc, + char **argv)); +static void MenuCmdDeletedProc _ANSI_ARGS_(( + ClientData clientData)); +static TkMenuEntry * MenuNewEntry _ANSI_ARGS_((TkMenu *menuPtr, int index, + int type)); +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 void MenuWorldChanged _ANSI_ARGS_(( + ClientData instanceData)); +static void RecursivelyDeleteMenu _ANSI_ARGS_((TkMenu *menuPtr)); +static void UnhookCascadeEntry _ANSI_ARGS_((TkMenuEntry *mePtr)); + +/* + * The structure below is a list of procs that respond to certain window + * manager events. One of these includes a font change, which forces + * the geometry proc to be called. + */ + +static TkClassProcs menuClass = { + NULL, /* createProc. */ + MenuWorldChanged /* geometryProc. */ +}; + + + +/* + *-------------------------------------------------------------- + * + * Tk_MenuCmd -- + * + * This procedure is invoked to process the "menu" 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_MenuCmd(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; + Tk_Window new; + register TkMenu *menuPtr; + TkMenuReferences *menuRefPtr; + int i, len; + char *arg, c; + int toplevel; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " pathName ?options?\"", (char *) NULL); + 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) { + toplevel = 0; + } + break; + } + } + + new = Tk_CreateWindowFromPath(interp, tkwin, argv[1], toplevel ? "" + : NULL); + if (new == NULL) { + return TCL_ERROR; + } + + /* + * Initialize the data structure for the menu. + */ + + menuPtr = (TkMenu *) ckalloc(sizeof(TkMenu)); + menuPtr->tkwin = new; + menuPtr->display = Tk_Display(new); + menuPtr->interp = interp; + menuPtr->widgetCmd = Tcl_CreateCommand(interp, + Tk_PathName(menuPtr->tkwin), MenuWidgetCmd, + (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->postCommandGeneration = 0; + menuPtr->postedCascade = NULL; + menuPtr->nextInstancePtr = NULL; + menuPtr->masterMenuPtr = menuPtr; + menuPtr->menuType = UNKNOWN_TYPE; + menuPtr->menuFlags = 0; + menuPtr->parentTopLevelPtr = NULL; + menuPtr->menuTypeName = NULL; + menuPtr->title = NULL; + TkMenuInitializeDrawingFields(menuPtr); + + menuRefPtr = TkCreateMenuReferences(menuPtr->interp, + Tk_PathName(menuPtr->tkwin)); + menuRefPtr->menuPtr = menuPtr; + menuPtr->menuRefPtr = menuRefPtr; + if (TCL_OK != TkpNewMenu(menuPtr)) { + goto 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 a menu has a parent menu pointing to it as a cascade entry, the + * parent menu needs to be told that this menu now exists so that + * the platform-part of the menu is correctly updated. + * + * If a menu has an instance and has cascade entries, then each cascade + * menu must also have a parallel instance. This is especially true on + * the Mac, where each menu has to have a separate title everytime it is in + * a menubar. For instance, say you have a menu .m1 with a cascade entry + * for .m2, where .m2 does not exist yet. You then put .m1 into a menubar. + * This creates a menubar instance for .m1, but since .m2 is not there, + * nothing else happens. When we go to create .m2, we hook it up properly + * with .m1. However, we now need to clone .m2 and assign the clone of .m2 + * to be the cascade entry for the clone of .m1. This is special case + * #1 listed in the introductory comment. + */ + + if (menuRefPtr->parentEntryPtr != NULL) { + TkMenuEntry *cascadeListPtr = menuRefPtr->parentEntryPtr; + TkMenuEntry *nextCascadePtr; + char *newMenuName; + char *newArgv[2]; + + while (cascadeListPtr != NULL) { + + nextCascadePtr = cascadeListPtr->nextCascadePtr; + + /* + * If we have a new master menu, and an existing cloned menu + * points to this menu in a cascade entry, we have to clone + * the new menu and point the entry to the clone instead + * of the menu we are creating. Otherwise, ConfigureMenuEntry + * will hook up the platform-specific cascade linkages now + * that the menu we are creating exists. + */ + + if ((menuPtr->masterMenuPtr != menuPtr) + || ((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); + } else { + newMenuName = TkNewMenuName(menuPtr->interp, + Tk_PathName(cascadeListPtr->menuPtr->tkwin), + menuPtr); + CloneMenu(menuPtr, newMenuName, "normal"); + + /* + * 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); + } + } + cascadeListPtr = nextCascadePtr; + } + } + + /* + * If there already exist toplevel widgets that refer to this menu, + * find them and notify them so that they can reconfigure their + * geometry to reflect the menu. + */ + + if (menuRefPtr->topLevelListPtr != NULL) { + TkMenuTopLevelList *topLevelListPtr = menuRefPtr->topLevelListPtr; + TkMenuTopLevelList *nextPtr; + Tk_Window listtkwin; + while (topLevelListPtr != NULL) { + + /* + * Need to get the next pointer first. TkSetWindowMenuBar + * changes the list, so that the next pointer is different + * after calling it. + */ + + nextPtr = topLevelListPtr->nextPtr; + listtkwin = topLevelListPtr->tkwin; + TkSetWindowMenuBar(menuPtr->interp, listtkwin, + Tk_PathName(menuPtr->tkwin), Tk_PathName(menuPtr->tkwin)); + topLevelListPtr = nextPtr; + } + } + + interp->result = Tk_PathName(menuPtr->tkwin); + return TCL_OK; + + error: + Tk_DestroyWindow(menuPtr->tkwin); + return TCL_ERROR; +} + +/* + *-------------------------------------------------------------- + * + * MenuWidgetCmd -- + * + * This procedure is invoked to process the Tcl command + * that corresponds to a widget managed by this module. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +static int +MenuWidgetCmd(clientData, interp, argc, argv) + ClientData clientData; /* Information about menu widget. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + register TkMenu *menuPtr = (TkMenu *) clientData; + register TkMenuEntry *mePtr; + int result = TCL_OK; + size_t length; + int c; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " option ?arg arg ...?\"", (char *) NULL); + 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; + } + } + 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; + } + if (MenuAddOrInsert(interp, menuPtr, (char *) NULL, + argc-2, argv+2) != TCL_OK) { + goto error; + } + } 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; + } + 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); + } + } else if ((c == 'd') && (strncmp(argv[1], "delete", length) == 0)) { + int first, last; + + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " delete first ?last?\"", (char *) NULL); + goto error; + } + if (TkGetMenuIndex(interp, menuPtr, argv[2], 0, &first) != TCL_OK) { + goto error; + } + if (argc == 3) { + last = first; + } else { + if (TkGetMenuIndex(interp, menuPtr, argv[3], 0, &last) != TCL_OK) { + goto error; + } + } + if (menuPtr->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); + } 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; + } + } else if ((c == 'i') && (strncmp(argv[1], "invoke", length) == 0) + && (length >= 3)) { + 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; + } + + /* + * 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, argv[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]); + } + } 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; + } + done: + Tcl_Release((ClientData) menuPtr); + return result; + + error: + Tcl_Release((ClientData) menuPtr); + return TCL_ERROR; +} + + +/* + *---------------------------------------------------------------------- + * + * TkInvokeMenu -- + * + * Given a menu and an index, takes the appropriate action for the + * entry associated with that index. + * + * Results: + * Standard Tcl result. + * + * Side effects: + * Commands may get excecuted; variables may get set; sub-menus may + * get posted. + * + *---------------------------------------------------------------------- + */ + +int +TkInvokeMenu(interp, menuPtr, index) + Tcl_Interp *interp; /* The interp that the menu lives in. */ + TkMenu *menuPtr; /* The menu we are invoking. */ + int index; /* The zero based index of the item we + * are invoking */ +{ + int result = TCL_OK; + TkMenuEntry *mePtr; + + if (index < 0) { + goto done; + } + mePtr = menuPtr->entries[index]; + if (mePtr->state == tkDisabledUid) { + 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) { + if (mePtr->entryFlags & ENTRY_SELECTED) { + if (Tcl_SetVar(interp, mePtr->name, mePtr->offValue, + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { + result = TCL_ERROR; + } + } else { + if (Tcl_SetVar(interp, mePtr->name, mePtr->onValue, + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { + result = TCL_ERROR; + } + } + } else if (mePtr->type == RADIO_BUTTON_ENTRY) { + if (Tcl_SetVar(interp, mePtr->name, mePtr->onValue, + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { + result = TCL_ERROR; + } + } + if ((result == TCL_OK) && (mePtr->command != NULL)) { + result = TkCopyAndGlobalEval(interp, mePtr->command); + } + Tcl_Release((ClientData) mePtr); + done: + return result; +} + + + +/* + *---------------------------------------------------------------------- + * + * DestroyMenuInstance -- + * + * This procedure is invoked by TkDestroyMenu + * to clean up the internal structure of a menu at a safe time + * (when no-one is using it anymore). Only takes care of one instance + * of the menu. + * + * Results: + * None. + * + * Side effects: + * Everything associated with the menu is freed up. + * + *---------------------------------------------------------------------- + */ + +static void +DestroyMenuInstance(menuPtr) + TkMenu *menuPtr; /* Info about menu widget. */ +{ + int i, numEntries = menuPtr->numEntries; + TkMenu *menuInstancePtr; + TkMenuEntry *cascadePtr, *nextCascadePtr; + char *newArgv[2]; + TkMenu *parentMasterMenuPtr; + TkMenuEntry *parentMasterEntryPtr; + TkMenu *parentMenuPtr; + + /* + * If the menu has any cascade menu entries pointing to it, the cascade + * entries need to be told that the menu is going away. We need to clear + * the menu ptr field in the menu reference at this point in the code + * so that everything else can forget about this menu properly. We also + * need to reset -menu field of all entries that are not master menus + * back to this entry name if this is a master menu pointed to by another + * master menu. If there is a clone menu that points to this menu, + * then this menu is itself a clone, so when this menu goes away, + * the -menu field of the pointing entry must be set back to this + * menu's master menu name so that later if another menu is created + * the cascade hierarchy can be maintained. + */ + + TkpDestroyMenu(menuPtr); + cascadePtr = menuPtr->menuRefPtr->parentEntryPtr; + menuPtr->menuRefPtr->menuPtr = NULL; + TkFreeMenuReferences(menuPtr->menuRefPtr); + + for (; cascadePtr != NULL; cascadePtr = nextCascadePtr) { + parentMenuPtr = cascadePtr->menuPtr; + nextCascadePtr = cascadePtr->nextCascadePtr; + + if (menuPtr->masterMenuPtr != menuPtr) { + parentMasterMenuPtr = cascadePtr->menuPtr->masterMenuPtr; + parentMasterEntryPtr = + parentMasterMenuPtr->entries[cascadePtr->index]; + newArgv[0] = "-menu"; + newArgv[1] = parentMasterEntryPtr->name; + ConfigureMenuEntry(cascadePtr, 2, newArgv, TK_CONFIG_ARGV_ONLY); + } else { + ConfigureMenuEntry(cascadePtr, 0, (char **) NULL, 0); + } + } + + if (menuPtr->masterMenuPtr != menuPtr) { + for (menuInstancePtr = menuPtr->masterMenuPtr; + menuInstancePtr != NULL; + menuInstancePtr = menuInstancePtr->nextInstancePtr) { + if (menuInstancePtr->nextInstancePtr == menuPtr) { + menuInstancePtr->nextInstancePtr = + menuInstancePtr->nextInstancePtr->nextInstancePtr; + break; + } + } + } else if (menuPtr->nextInstancePtr != NULL) { + panic("Attempting to delete master menu when there are still clones."); + } + + /* + * Free up all the stuff that requires special handling, then + * let Tk_FreeOptions handle all the standard option-related + * stuff. + */ + + for (i = numEntries - 1; i >= 0; i--) { + DestroyMenuEntry((char *) menuPtr->entries[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); +} + +/* + *---------------------------------------------------------------------- + * + * TkDestroyMenu -- + * + * This procedure is invoked by Tcl_EventuallyFree or Tcl_Release + * to clean up the internal structure of a menu at a safe time + * (when no-one is using it anymore). If called on a master instance, + * destroys all of the slave instances. If called on a non-master + * instance, just destroys that instance. + * + * Results: + * None. + * + * Side effects: + * Everything associated with the menu is freed up. + * + *---------------------------------------------------------------------- + */ + +void +TkDestroyMenu(menuPtr) + TkMenu *menuPtr; /* Info about menu widget. */ +{ + TkMenu *menuInstancePtr; + TkMenuTopLevelList *topLevelListPtr, *nextTopLevelPtr; + + if (menuPtr->menuFlags & MENU_DELETION_PENDING) { + return; + } + + /* + * Now destroy all non-tearoff instances of this menu if this is a + * parent menu. Is this loop safe enough? Are there going to be + * destroy bindings on child menus which kill the parent? If not, + * we have to do a slightly more complex scheme. + */ + + if (menuPtr->masterMenuPtr == menuPtr) { + menuPtr->menuFlags |= MENU_DELETION_PENDING; + while (menuPtr->nextInstancePtr != NULL) { + menuInstancePtr = menuPtr->nextInstancePtr; + menuPtr->nextInstancePtr = menuInstancePtr->nextInstancePtr; + if (menuInstancePtr->tkwin != NULL) { + Tk_DestroyWindow(menuInstancePtr->tkwin); + } + } + menuPtr->menuFlags &= ~MENU_DELETION_PENDING; + } + + /* + * If any toplevel widgets have this menu as their menubar, + * the geometry of the window may have to be recalculated. + */ + + topLevelListPtr = menuPtr->menuRefPtr->topLevelListPtr; + while (topLevelListPtr != NULL) { + nextTopLevelPtr = topLevelListPtr->nextPtr; + TkpSetWindowMenuBar(topLevelListPtr->tkwin, NULL); + topLevelListPtr = nextTopLevelPtr; + } + DestroyMenuInstance(menuPtr); +} + +/* + *---------------------------------------------------------------------- + * + * UnhookCascadeEntry -- + * + * This entry is removed from the list of entries that point to the + * cascade menu. This is done in preparation for changing the menu + * that this entry points to. + * + * Results: + * None + * + * Side effects: + * The appropriate lists are modified. + * + *---------------------------------------------------------------------- + */ + +static void +UnhookCascadeEntry(mePtr) + TkMenuEntry *mePtr; /* The cascade entry we are removing + * from the cascade list. */ +{ + TkMenuEntry *cascadeEntryPtr; + TkMenuEntry *prevCascadePtr; + TkMenuReferences *menuRefPtr; + + menuRefPtr = mePtr->childMenuRefPtr; + if (menuRefPtr == NULL) { + return; + } + + cascadeEntryPtr = menuRefPtr->parentEntryPtr; + if (cascadeEntryPtr == NULL) { + return; + } + + /* + * Singularly linked list deletion. The two special cases are + * 1. one element; 2. The first element is the one we want. + */ + + if (cascadeEntryPtr == mePtr) { + if (cascadeEntryPtr->nextCascadePtr == NULL) { + + /* + * This is the last menu entry which points to this + * menu, so we need to clear out the list pointer in the + * cascade itself. + */ + + menuRefPtr->parentEntryPtr = NULL; + TkFreeMenuReferences(menuRefPtr); + } else { + menuRefPtr->parentEntryPtr = cascadeEntryPtr->nextCascadePtr; + } + mePtr->nextCascadePtr = NULL; + } else { + for (prevCascadePtr = cascadeEntryPtr, + cascadeEntryPtr = cascadeEntryPtr->nextCascadePtr; + cascadeEntryPtr != NULL; + prevCascadePtr = cascadeEntryPtr, + cascadeEntryPtr = cascadeEntryPtr->nextCascadePtr) { + if (cascadeEntryPtr == mePtr){ + prevCascadePtr->nextCascadePtr = + cascadeEntryPtr->nextCascadePtr; + cascadeEntryPtr->nextCascadePtr = NULL; + break; + } + } + } + mePtr->childMenuRefPtr = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * DestroyMenuEntry -- + * + * This procedure is invoked by Tcl_EventuallyFree or Tcl_Release + * to clean up the internal structure of a menu entry at a safe time + * (when no-one is using it anymore). + * + * Results: + * None. + * + * Side effects: + * Everything associated with the menu entry is freed. + * + *---------------------------------------------------------------------- + */ + +static void +DestroyMenuEntry(memPtr) + char *memPtr; /* Pointer to entry to be freed. */ +{ + register TkMenuEntry *mePtr = (TkMenuEntry *) memPtr; + TkMenu *menuPtr = mePtr->menuPtr; + + if (menuPtr->postedCascade == mePtr) { + + /* + * Ignore errors while unposting the menu, since it's possible + * that the menu has already been deleted and the unpost will + * generate an error. + */ + + TkPostSubmenu(menuPtr->interp, menuPtr, (TkMenuEntry *) NULL); + } + + /* + * Free up all the stuff that requires special handling, then + * let Tk_FreeOptions handle all the standard option-related + * stuff. + */ + + if (mePtr->type == CASCADE_ENTRY) { + UnhookCascadeEntry(mePtr); + } + if (mePtr->image != NULL) { + Tk_FreeImage(mePtr->image); + } + if (mePtr->selectImage != NULL) { + Tk_FreeImage(mePtr->selectImage); + } + if (mePtr->name != NULL) { + Tcl_UntraceVar(menuPtr->interp, mePtr->name, + 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)); + ckfree((char *) mePtr); +} + +/* + *--------------------------------------------------------------------------- + * + * MenuWorldChanged -- + * + * This procedure is called when the world has changed in some + * way (such as the fonts in the system changing) and the widget needs + * to recompute all its graphics contexts and determine its new geometry. + * + * Results: + * None. + * + * Side effects: + * Menu will be relayed out and redisplayed. + * + *--------------------------------------------------------------------------- + */ + +static void +MenuWorldChanged(instanceData) + ClientData instanceData; /* Information about widget. */ +{ + TkMenu *menuPtr = (TkMenu *) instanceData; + int i; + + TkMenuConfigureDrawOptions(menuPtr); + for (i = 0; i < menuPtr->numEntries; i++) { + TkMenuConfigureEntryDrawOptions(menuPtr->entries[i], + menuPtr->entries[i]->index); + TkpConfigureMenuEntry(menuPtr->entries[i]); + } +} + + +/* + *---------------------------------------------------------------------- + * + * ConfigureMenu -- + * + * This procedure is called to process an argv/argc list, plus + * the Tk option database, in order to configure (or + * reconfigure) a menu widget. + * + * Results: + * The return value is a standard Tcl result. If TCL_ERROR is + * returned, then interp->result contains an error message. + * + * Side effects: + * Configuration information, such as colors, font, etc. get set + * for menuPtr; old resources get freed, if there were any. + * + *---------------------------------------------------------------------- + */ + +static int +ConfigureMenu(interp, menuPtr, argc, argv, flags) + 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 i; + TkMenu* menuListPtr; + + for (menuListPtr = menuPtr->masterMenuPtr; menuListPtr != NULL; + menuListPtr = menuListPtr->nextInstancePtr) { + + if (Tk_ConfigureWidget(interp, menuListPtr->tkwin, + tkMenuConfigSpecs, argc, argv, (char *) menuListPtr, + flags) != TCL_OK) { + return TCL_ERROR; + } + + /* + * When a menu is created, the type is in all of the arguments + * to the menu command. Let Tk_ConfigureWidget take care of + * parsing them, and then set the type after we can look at + * the type string. Once set, a menu's type cannot be changed + */ + + 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; + } + } + + /* + * 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) { + if ((menuListPtr->numEntries == 0) + || (menuListPtr->entries[0]->type != TEAROFF_ENTRY)) { + if (MenuNewEntry(menuListPtr, 0, TEAROFF_ENTRY) == 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; + } + menuListPtr->numEntries--; + if (menuListPtr->numEntries == 0) { + ckfree((char *) menuListPtr->entries); + menuListPtr->entries = NULL; + } + } + + 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 + * entries in the menu, since some of the things in the children + * (such as graphics contexts) may have to change to reflect changes + * in the parent. + */ + + for (i = 0; i < menuListPtr->numEntries; i++) { + TkMenuEntry *mePtr; + + mePtr = menuListPtr->entries[i]; + ConfigureMenuEntry(mePtr, 0, + (char **) NULL, TK_CONFIG_ARGV_ONLY + | COMMAND_MASK << mePtr->type); + } + + TkEventuallyRecomputeMenu(menuListPtr); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * 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 interp->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, 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. */ +{ + TkMenu *menuPtr = mePtr->menuPtr; + int index = mePtr->index; + 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) { + mePtr->labelLength = 0; + } else { + mePtr->labelLength = strlen(mePtr->label); + } + if (mePtr->accel == NULL) { + mePtr->accelLength = 0; + } else { + mePtr->accelLength = strlen(mePtr->accel); + } + + /* + * If this is a cascade entry, the platform-specific data of the child + * menu has to be updated. Also, the links that point to parents and + * cascades have to be updated. + */ + + if ((mePtr->type == CASCADE_ENTRY) && (mePtr->name != NULL)) { + TkMenuEntry *cascadeEntryPtr; + TkMenu *cascadeMenuPtr; + int alreadyThere; + TkMenuReferences *menuRefPtr; + char *oldHashKey = NULL; /* Initialization only needed to + * prevent compiler warning. */ + + /* + * This is a cascade entry. If the menu that the cascade entry + * is pointing to has changed, we need to remove this entry + * from the list of entries pointing to the old menu, and add a + * cascade reference to the list of entries pointing to the + * new menu. + * + * BUG: We are not recloning for special case #3 yet. + */ + + if (mePtr->childMenuRefPtr != NULL) { + oldHashKey = Tcl_GetHashKey(TkGetMenuHashTable(menuPtr->interp), + mePtr->childMenuRefPtr->hashEntryPtr); + if (strcmp(oldHashKey, mePtr->name) != 0) { + UnhookCascadeEntry(mePtr); + } + } + + if ((mePtr->childMenuRefPtr == NULL) + || (strcmp(oldHashKey, mePtr->name) != 0)) { + menuRefPtr = TkCreateMenuReferences(menuPtr->interp, + mePtr->name); + cascadeMenuPtr = menuRefPtr->menuPtr; + mePtr->childMenuRefPtr = menuRefPtr; + + if (menuRefPtr->parentEntryPtr == NULL) { + menuRefPtr->parentEntryPtr = mePtr; + } else { + alreadyThere = 0; + for (cascadeEntryPtr = menuRefPtr->parentEntryPtr; + cascadeEntryPtr != NULL; + cascadeEntryPtr = + cascadeEntryPtr->nextCascadePtr) { + if (cascadeEntryPtr == mePtr) { + alreadyThere = 1; + break; + } + } + + /* + * Put the item at the front of the list. + */ + + if (!alreadyThere) { + mePtr->nextCascadePtr = menuRefPtr->parentEntryPtr; + menuRefPtr->parentEntryPtr = mePtr; + } + } + } + } + + if (TkMenuConfigureEntryDrawOptions(mePtr, index) != TCL_OK) { + return TCL_ERROR; + } + + if (TkpConfigureMenuEntry(mePtr) != TCL_OK) { + 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, + TkMenuImageProc, (ClientData) mePtr); + if (image == NULL) { + return TCL_ERROR; + } + } else { + image = NULL; + } + if (mePtr->image != NULL) { + Tk_FreeImage(mePtr->image); + } + mePtr->image = image; + if (mePtr->selectImageString != NULL) { + image = Tk_GetImage(menuPtr->interp, menuPtr->tkwin, mePtr->selectImageString, + TkMenuSelectImageProc, (ClientData) mePtr); + if (image == NULL) { + return TCL_ERROR; + } + } else { + image = NULL; + } + if (mePtr->selectImage != NULL) { + Tk_FreeImage(mePtr->selectImage); + } + mePtr->selectImage = image; + + TkEventuallyRecomputeMenu(menuPtr); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * 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. + * + * Side effects: + * Configuration information such as label and accelerator get + * set for mePtr; old resources get freed, if there were any. + * + *---------------------------------------------------------------------- + */ + +static int +ConfigureMenuCloneEntries(interp, menuPtr, index, argc, argv, flags) + 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. */ +{ + TkMenuEntry *mePtr; + TkMenu *menuListPtr; + char *oldCascadeName = NULL, *newMenuName = NULL; + int cascadeEntryChanged; + TkMenuReferences *oldCascadeMenuRefPtr, *cascadeMenuRefPtr = NULL; + + /* + * 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 + * clone chain, and has an entry with a cascade menu, the clones of + * the menu will point to clones of the cascade menu. We have + * to destroy the clones of the cascades, clone the new cascade + * menu, and configure the entry to point to the new clone. + */ + + mePtr = menuPtr->masterMenuPtr->entries[index]; + if (mePtr->type == CASCADE_ENTRY) { + oldCascadeName = mePtr->name; + } + + if (ConfigureMenuEntry(mePtr, argc, argv, flags) != TCL_OK) { + return TCL_ERROR; + } + + cascadeEntryChanged = (mePtr->type == CASCADE_ENTRY) + && (oldCascadeName != mePtr->name); + + if (cascadeEntryChanged) { + newMenuName = mePtr->name; + if (newMenuName != NULL) { + cascadeMenuRefPtr = TkFindMenuReferences(menuPtr->interp, + mePtr->name); + } + } + + for (menuListPtr = menuPtr->masterMenuPtr->nextInstancePtr; + menuListPtr != NULL; + menuListPtr = menuListPtr->nextInstancePtr) { + + mePtr = menuListPtr->entries[index]; + + if (cascadeEntryChanged && (mePtr->name != NULL)) { + oldCascadeMenuRefPtr = TkFindMenuReferences(menuPtr->interp, + mePtr->name); + + if ((oldCascadeMenuRefPtr != NULL) + && (oldCascadeMenuRefPtr->menuPtr != NULL)) { + RecursivelyDeleteMenu(oldCascadeMenuRefPtr->menuPtr); + } + } + + if (ConfigureMenuEntry(mePtr, argc, argv, flags) != TCL_OK) { + return TCL_ERROR; + } + + if (cascadeEntryChanged && (newMenuName != NULL)) { + if (cascadeMenuRefPtr->menuPtr != NULL) { + char *newArgV[2]; + char *newCloneName; + + newCloneName = TkNewMenuName(menuPtr->interp, + Tk_PathName(menuListPtr->tkwin), + cascadeMenuRefPtr->menuPtr); + CloneMenu(cascadeMenuRefPtr->menuPtr, newCloneName, + "normal"); + + newArgV[0] = "-menu"; + newArgV[1] = newCloneName; + ConfigureMenuEntry(mePtr, 2, newArgV, flags); + ckfree(newCloneName); + } + } + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * TkGetMenuIndex -- + * + * Parse a textual index into a menu and return the numerical + * index of the indicated entry. + * + * Results: + * 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. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +int +TkGetMenuIndex(interp, menuPtr, string, 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 + * 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 i; + + if ((string[0] == 'a') && (strcmp(string, "active") == 0)) { + *indexPtr = menuPtr->active; + return TCL_OK; + } + + if (((string[0] == 'l') && (strcmp(string, "last") == 0)) + || ((string[0] == 'e') && (strcmp(string, "end") == 0))) { + *indexPtr = menuPtr->numEntries - ((lastOK) ? 0 : 1); + return TCL_OK; + } + + if ((string[0] == 'n') && (strcmp(string, "none") == 0)) { + *indexPtr = -1; + return TCL_OK; + } + + if (string[0] == '@') { + if (GetIndexFromCoords(interp, menuPtr, string, indexPtr) + == TCL_OK) { + return TCL_OK; + } + } + + if (isdigit(UCHAR(string[0]))) { + if (Tcl_GetInt(interp, string, &i) == TCL_OK) { + if (i >= menuPtr->numEntries) { + if (lastOK) { + i = menuPtr->numEntries; + } else { + i = menuPtr->numEntries-1; + } + } else if (i < 0) { + i = -1; + } + *indexPtr = i; + return TCL_OK; + } + Tcl_SetResult(interp, (char *) NULL, TCL_STATIC); + } + + for (i = 0; i < menuPtr->numEntries; i++) { + char *label; + + label = menuPtr->entries[i]->label; + if ((label != NULL) + && (Tcl_StringMatch(menuPtr->entries[i]->label, string))) { + *indexPtr = i; + return TCL_OK; + } + } + + Tcl_AppendResult(interp, "bad menu entry index \"", + string, "\"", (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * MenuCmdDeletedProc -- + * + * 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 +MenuCmdDeletedProc(clientData) + ClientData clientData; /* Pointer to widget record for widget. */ +{ + TkMenu *menuPtr = (TkMenu *) clientData; + Tk_Window tkwin = menuPtr->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. + */ + + if (tkwin != NULL) { + menuPtr->tkwin = NULL; + Tk_DestroyWindow(tkwin); + } +} + +/* + *---------------------------------------------------------------------- + * + * MenuNewEntry -- + * + * This procedure allocates and initializes a new menu entry. + * + * Results: + * The return value is a pointer to a new menu entry structure, + * which has been malloc-ed, initialized, and entered into the + * entry array for the menu. + * + * Side effects: + * Storage gets allocated. + * + *---------------------------------------------------------------------- + */ + +static TkMenuEntry * +MenuNewEntry(menuPtr, index, type) + TkMenu *menuPtr; /* Menu that will hold the new entry. */ + int index; /* Where in the menu the new entry is to + * go. */ + int type; /* The type of the new entry. */ +{ + TkMenuEntry *mePtr; + TkMenuEntry **newEntries; + int i; + + /* + * Create a new array of entries with an empty slot for the + * new entry. + */ + + newEntries = (TkMenuEntry **) ckalloc((unsigned) + ((menuPtr->numEntries+1)*sizeof(TkMenuEntry *))); + for (i = 0; i < index; i++) { + newEntries[i] = menuPtr->entries[i]; + } + for ( ; i < menuPtr->numEntries; i++) { + newEntries[i+1] = menuPtr->entries[i]; + newEntries[i+1]->index = i + 1; + } + if (menuPtr->numEntries != 0) { + ckfree((char *) menuPtr->entries); + } + menuPtr->entries = newEntries; + menuPtr->numEntries++; + mePtr = (TkMenuEntry *) ckalloc(sizeof(TkMenuEntry)); + menuPtr->entries[index] = mePtr; + mePtr->type = type; + mePtr->menuPtr = menuPtr; + mePtr->label = NULL; + mePtr->labelLength = 0; + mePtr->underline = -1; + mePtr->bitmap = None; + mePtr->imageString = NULL; + mePtr->image = NULL; + mePtr->selectImageString = NULL; + mePtr->selectImage = NULL; + mePtr->accel = 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->childMenuRefPtr = NULL; + mePtr->onValue = NULL; + mePtr->offValue = NULL; + mePtr->entryFlags = 0; + mePtr->index = index; + mePtr->nextCascadePtr = NULL; + TkMenuInitializeEntryDrawingFields(mePtr); + if (TkpMenuNewEntry(mePtr) != TCL_OK) { + ckfree((char *) mePtr); + return NULL; + } + + return mePtr; +} + +/* + *---------------------------------------------------------------------- + * + * MenuAddOrInsert -- + * + * This procedure does all of the work of the "add" and "insert" + * widget commands, allowing the code for these to be shared. + * + * Results: + * A standard Tcl return value. + * + * Side effects: + * A new menu entry is created in menuPtr. + * + *---------------------------------------------------------------------- + */ + +static int +MenuAddOrInsert(interp, menuPtr, indexString, argc, argv) + Tcl_Interp *interp; /* Used for error reporting. */ + TkMenu *menuPtr; /* Widget in which to create new + * entry. */ + char *indexString; /* String 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 + * is type of entry, others are + * config options. */ +{ + int c, type, index; + size_t length; + TkMenuEntry *mePtr; + TkMenu *menuListPtr; + + if (indexString != NULL) { + if (TkGetMenuIndex(interp, menuPtr, indexString, 1, &index) + != TCL_OK) { + return TCL_ERROR; + } + } else { + index = menuPtr->numEntries; + } + if (index < 0) { + Tcl_AppendResult(interp, "bad index \"", indexString, "\"", + (char *) NULL); + return TCL_ERROR; + } + if (menuPtr->tearOff && (index == 0)) { + index = 1; + } + + /* + * 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); + return TCL_ERROR; + } + + /* + * Now we have to add an entry for every instance related to this menu. + */ + + for (menuListPtr = menuPtr->masterMenuPtr; menuListPtr != NULL; + menuListPtr = menuListPtr->nextInstancePtr) { + + mePtr = MenuNewEntry(menuListPtr, index, type); + if (mePtr == NULL) { + return TCL_ERROR; + } + if (ConfigureMenuEntry(mePtr, argc-1, argv+1, 0) != TCL_OK) { + TkMenu *errorMenuPtr; + int i; + + for (errorMenuPtr = menuPtr->masterMenuPtr; + errorMenuPtr != NULL; + errorMenuPtr = errorMenuPtr->nextInstancePtr) { + Tcl_EventuallyFree((ClientData) errorMenuPtr->entries[index], + DestroyMenuEntry); + for (i = index; i < errorMenuPtr->numEntries - 1; i++) { + errorMenuPtr->entries[i] = errorMenuPtr->entries[i + 1]; + errorMenuPtr->entries[i]->index = i; + } + errorMenuPtr->numEntries--; + if (errorMenuPtr->numEntries == 0) { + ckfree((char *) errorMenuPtr->entries); + errorMenuPtr->entries = NULL; + } + if (errorMenuPtr == menuListPtr) { + break; + } + } + return TCL_ERROR; + } + + /* + * If a menu has cascades, then every instance of the menu has + * to have its own parallel cascade structure. So adding an + * entry to a menu with clones means that the menu that the + * entry points to has to be cloned for every clone the + * master menu has. This is special case #2 in the comment + * at the top of this file. + */ + + if ((menuPtr != menuListPtr) && (type == CASCADE_ENTRY)) { + if ((mePtr->name != NULL) && (mePtr->childMenuRefPtr != NULL) + && (mePtr->childMenuRefPtr->menuPtr != NULL)) { + TkMenu *cascadeMenuPtr = + mePtr->childMenuRefPtr->menuPtr->masterMenuPtr; + char *newCascadeName; + char *newArgv[2]; + TkMenuReferences *menuRefPtr; + + newCascadeName = TkNewMenuName(menuListPtr->interp, + Tk_PathName(menuListPtr->tkwin), + cascadeMenuPtr); + CloneMenu(cascadeMenuPtr, newCascadeName, "normal"); + + menuRefPtr = TkFindMenuReferences(menuListPtr->interp, + newCascadeName); + if (menuRefPtr == NULL) { + panic("CloneMenu failed inside of MenuAddOrInsert."); + } + newArgv[0] = "-menu"; + newArgv[1] = newCascadeName; + ConfigureMenuEntry(mePtr, 2, newArgv, 0); + ckfree(newCascadeName); + } + } + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * MenuVarProc -- + * + * This procedure is invoked when someone changes the + * state variable associated with a radiobutton or checkbutton + * menu entry. The entry's selected state is set to match + * the value of the variable. + * + * Results: + * NULL is always returned. + * + * Side effects: + * The menu entry may become selected or deselected. + * + *-------------------------------------------------------------- + */ + +static char * +MenuVarProc(clientData, interp, name1, name2, flags) + ClientData clientData; /* Information about menu entry. */ + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *name1; /* First part of variable's name. */ + char *name2; /* Second part of variable's name. */ + int flags; /* Describes what just happened. */ +{ + TkMenuEntry *mePtr = (TkMenuEntry *) clientData; + TkMenu *menuPtr; + char *value; + + menuPtr = mePtr->menuPtr; + + /* + * If the variable is being unset, then re-establish the + * trace unless the whole interpreter is going away. + */ + + if (flags & TCL_TRACE_UNSETS) { + mePtr->entryFlags &= ~ENTRY_SELECTED; + if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) { + Tcl_TraceVar(interp, mePtr->name, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + MenuVarProc, clientData); + } + TkpConfigureMenuEntry(mePtr); + TkEventuallyRedrawMenu(menuPtr, (TkMenuEntry *) NULL); + return (char *) NULL; + } + + /* + * Use the value of the variable to update the selected status of + * the menu entry. + */ + + value = Tcl_GetVar(interp, mePtr->name, TCL_GLOBAL_ONLY); + if (value == NULL) { + value = ""; + } + if (strcmp(value, mePtr->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; + } + TkpConfigureMenuEntry(mePtr); + TkEventuallyRedrawMenu(menuPtr, mePtr); + return (char *) NULL; +} + +/* + *---------------------------------------------------------------------- + * + * TkActivateMenuEntry -- + * + * This procedure is invoked to make a particular menu entry + * the active one, deactivating any other entry that might + * currently be active. + * + * Results: + * The return value is a standard Tcl result (errors can occur + * while posting and unposting submenus). + * + * Side effects: + * Menu entries get redisplayed, and the active entry changes. + * Submenus may get posted and unposted. + * + *---------------------------------------------------------------------- + */ + +int +TkActivateMenuEntry(menuPtr, index) + register TkMenu *menuPtr; /* Menu in which to activate. */ + int index; /* Index of entry to activate, or + * -1 to deactivate all entries. */ +{ + register TkMenuEntry *mePtr; + int result = TCL_OK; + + if (menuPtr->active >= 0) { + mePtr = menuPtr->entries[menuPtr->active]; + + /* + * Don't change the state unless it's currently active (state + * might already have been changed to disabled). + */ + + if (mePtr->state == tkActiveUid) { + mePtr->state = tkNormalUid; + } + TkEventuallyRedrawMenu(menuPtr, menuPtr->entries[menuPtr->active]); + } + menuPtr->active = index; + if (index >= 0) { + mePtr = menuPtr->entries[index]; + mePtr->state = tkActiveUid; + TkEventuallyRedrawMenu(menuPtr, mePtr); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TkPostCommand -- + * + * Execute the postcommand for the given menu. + * + * Results: + * The return value is a standard Tcl result (errors can occur + * while the postcommands are being processed). + * + * Side effects: + * Since commands can get executed while this routine is being executed, + * the entire world can change. + * + *---------------------------------------------------------------------- + */ + +int +TkPostCommand(menuPtr) + TkMenu *menuPtr; +{ + int result; + + /* + * If there is a command for the menu, execute it. This + * may change the size of the menu, so be sure to recompute + * the menu's geometry if needed. + */ + + if (menuPtr->postCommand != NULL) { + result = TkCopyAndGlobalEval(menuPtr->interp, + menuPtr->postCommand); + if (result != TCL_OK) { + return result; + } + TkRecomputeMenu(menuPtr); + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * CloneMenu -- + * + * Creates a child copy of the menu. It will be inserted into + * the menu's instance chain. All attributes and entry + * attributes will be duplicated. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Allocates storage. After the menu is created, any + * configuration done with this menu or any related one + * will be reflected in all of them. + * + *-------------------------------------------------------------- + */ + +static int +CloneMenu(menuPtr, newMenuName, newMenuTypeString) + 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 + * a menubar, or a tearoff? */ +{ + int returnResult; + int menuType; + size_t length; + TkMenuReferences *menuRefPtr; + Tcl_Obj *commandObjPtr; + + if (newMenuTypeString == 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; + } + } + + 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)); + } else { + Tcl_ListObjAppendElement(menuPtr->interp, commandObjPtr, + Tcl_NewStringObj(newMenuTypeString, -1)); + } + Tcl_IncrRefCount(commandObjPtr); + Tcl_Preserve((ClientData) menuPtr); + returnResult = Tcl_EvalObj(menuPtr->interp, commandObjPtr); + Tcl_DecrRefCount(commandObjPtr); + + /* + * Make sure the tcl command actually created the clone. + */ + + if ((returnResult == TCL_OK) && + ((menuRefPtr = TkFindMenuReferences(menuPtr->interp, newMenuName)) + != (TkMenuReferences *) NULL) + && (menuPtr->numEntries == menuRefPtr->menuPtr->numEntries)) { + TkMenu *newMenuPtr = menuRefPtr->menuPtr; + char *newArgv[3]; + int i, numElements; + + /* + * Now put this newly created menu into the parent menu's instance + * chain. + */ + + if (menuPtr->nextInstancePtr == NULL) { + menuPtr->nextInstancePtr = newMenuPtr; + newMenuPtr->masterMenuPtr = menuPtr->masterMenuPtr; + } else { + TkMenu *masterMenuPtr; + + masterMenuPtr = menuPtr->masterMenuPtr; + newMenuPtr->nextInstancePtr = masterMenuPtr->nextInstancePtr; + masterMenuPtr->nextInstancePtr = newMenuPtr; + newMenuPtr->masterMenuPtr = masterMenuPtr; + } + + /* + * Add the master menu's window to the bind tags for this window + * after this window's tag. This is so the user can bind to either + * this clone (which may not be easy to do) or the entire menu + * clone structure. + */ + + newArgv[0] = "bindtags"; + newArgv[1] = Tk_PathName(newMenuPtr->tkwin); + 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 *elementPtr; + + Tcl_ListObjLength(newMenuPtr->interp, bindingsPtr, &numElements); + for (i = 0; i < numElements; i++) { + Tcl_ListObjIndex(newMenuPtr->interp, bindingsPtr, i, + &elementPtr); + windowName = Tcl_GetStringFromObj(elementPtr, NULL); + if (strcmp(windowName, Tk_PathName(newMenuPtr->tkwin)) + == 0) { + Tcl_Obj *newElementPtr = Tcl_NewStringObj( + Tk_PathName(newMenuPtr->masterMenuPtr->tkwin), -1); + 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); + break; + } + } + Tcl_DecrRefCount(bindingsPtr); + } + Tcl_ResetResult(menuPtr->interp); + + /* + * Clone all of the cascade menus that this menu points to. + */ + + 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)) { + cascadeRefPtr = + TkFindMenuReferences(menuPtr->interp, + menuPtr->entries[i]->name); + if ((cascadeRefPtr != NULL) && (cascadeRefPtr->menuPtr)) { + char *nameString; + + 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); + } + } + } + + returnResult = TCL_OK; + } else { + returnResult = TCL_ERROR; + } + Tcl_Release((ClientData) menuPtr); + return returnResult; +} + +/* + *---------------------------------------------------------------------- + * + * MenuDoYPosition -- + * + * Given arguments from an option command line, returns the Y position. + * + * Results: + * Returns TCL_OK or TCL_Error + * + * Side effects: + * yPosition is set to the Y-position of the menu entry. + * + *---------------------------------------------------------------------- + */ + +static int +MenuDoYPosition(interp, menuPtr, arg) + Tcl_Interp *interp; + TkMenu *menuPtr; + char *arg; +{ + int index; + + TkRecomputeMenu(menuPtr); + if (TkGetMenuIndex(interp, menuPtr, arg, 0, &index) != TCL_OK) { + goto error; + } + if (index < 0) { + interp->result = "0"; + } else { + sprintf(interp->result, "%d", menuPtr->entries[index]->y); + } + return TCL_OK; + +error: + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * GetIndexFromCoords -- + * + * Given a string of the form "@int", return the menu item corresponding + * to int. + * + * Results: + * If int is a valid number, *indexPtr will be the number of the menuentry + * that is the correct height. If int is invaled, *indexPtr will be + * unchanged. Returns appropriate Tcl error number. + * + * Side effects: + * If int is invalid, interp's result will set to NULL. + * + *---------------------------------------------------------------------- + */ + +static int +GetIndexFromCoords(interp, menuPtr, string, indexPtr) + Tcl_Interp *interp; /* interp of menu */ + TkMenu *menuPtr; /* the menu we are searching */ + char *string; /* The @string we are parsing */ + int *indexPtr; /* The index of the item that matches */ +{ + int x, y, i; + char *p, *end; + + TkRecomputeMenu(menuPtr); + p = string + 1; + y = strtol(p, &end, 0); + if (end == p) { + goto error; + } + if (*end == ',') { + x = y; + p = end + 1; + y = strtol(p, &end, 0); + if (end == p) { + goto error; + } + } else { + x = menuPtr->borderWidth; + } + + for (i = 0; i < menuPtr->numEntries; i++) { + if ((x >= menuPtr->entries[i]->x) && (y >= menuPtr->entries[i]->y) + && (x < (menuPtr->entries[i]->x + menuPtr->entries[i]->width)) + && (y < (menuPtr->entries[i]->y + + menuPtr->entries[i]->height))) { + break; + } + } + if (i >= menuPtr->numEntries) { + /* i = menuPtr->numEntries - 1; */ + i = -1; + } + *indexPtr = i; + return TCL_OK; + + error: + Tcl_SetResult(interp, (char *) NULL, TCL_STATIC); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * RecursivelyDeleteMenu -- + * + * Deletes a menu and any cascades underneath it. Used for deleting + * instances when a menu is no longer being used as a menubar, + * for instance. + * + * Results: + * None. + * + * Side effects: + * Destroys the menu and all cascade menus underneath it. + * + *---------------------------------------------------------------------- + */ + +static void +RecursivelyDeleteMenu(menuPtr) + TkMenu *menuPtr; /* The menubar instance we are deleting */ +{ + int i; + TkMenuEntry *mePtr; + + for (i = 0; i < menuPtr->numEntries; i++) { + mePtr = menuPtr->entries[i]; + if ((mePtr->type == CASCADE_ENTRY) + && (mePtr->childMenuRefPtr != NULL) + && (mePtr->childMenuRefPtr->menuPtr != NULL)) { + RecursivelyDeleteMenu(mePtr->childMenuRefPtr->menuPtr); + } + } + Tk_DestroyWindow(menuPtr->tkwin); +} + +/* + *---------------------------------------------------------------------- + * + * TkNewMenuName -- + * + * Makes a new unique name for a cloned menu. Will be a child + * of oldName. + * + * Results: + * Returns a char * which has been allocated; caller must free. + * + * Side effects: + * Memory is allocated. + * + *---------------------------------------------------------------------- + */ + +char * +TkNewMenuName(interp, parentName, menuPtr) + Tcl_Interp *interp; /* The interp the new name has to live in.*/ + char *parentName; /* The prefix path of the new name. */ + TkMenu *menuPtr; /* The menu we are cloning. */ +{ + Tcl_DString resultDString; + Tcl_DString childDString; + char *destString; + int offset, i; + int doDot = parentName[strlen(parentName) - 1] != '.'; + Tcl_CmdInfo cmdInfo; + char *returnString; + Tcl_HashTable *nameTablePtr = NULL; + TkWindow *winPtr = (TkWindow *) menuPtr->tkwin; + if (winPtr->mainPtr != NULL) { + nameTablePtr = &(winPtr->mainPtr->nameTable); + } + + Tcl_DStringInit(&childDString); + Tcl_DStringAppend(&childDString, Tk_PathName(menuPtr->tkwin), -1); + for (destString = Tcl_DStringValue(&childDString); + *destString != '\0'; destString++) { + if (*destString == '.') { + *destString = '#'; + } + } + + offset = 0; + + for (i = 0; ; i++) { + if (i == 0) { + Tcl_DStringInit(&resultDString); + Tcl_DStringAppend(&resultDString, parentName, -1); + if (doDot) { + Tcl_DStringAppend(&resultDString, ".", -1); + } + Tcl_DStringAppend(&resultDString, + Tcl_DStringValue(&childDString), -1); + destString = Tcl_DStringValue(&resultDString); + } else { + if (i == 1) { + offset = Tcl_DStringLength(&resultDString); + Tcl_DStringSetLength(&resultDString, offset + 10); + destString = Tcl_DStringValue(&resultDString); + } + sprintf(destString + offset, "%d", i); + } + 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; +} + +/* + *---------------------------------------------------------------------- + * + * TkSetWindowMenuBar -- + * + * Associates a menu with a window. Called by ConfigureFrame in + * in response to a "-menu .foo" configuration option for a top + * level. + * + * Results: + * None. + * + * Side effects: + * The old menu clones for the menubar are thrown away, and a + * handler is set up to allocate the new ones. + * + *---------------------------------------------------------------------- + */ +void +TkSetWindowMenuBar(interp, tkwin, oldMenuName, menuName) + Tcl_Interp *interp; /* The interpreter the toplevel lives in. */ + Tk_Window tkwin; /* The toplevel window */ + char *oldMenuName; /* The name of the menubar previously set in + * this toplevel. NULL means no menu was + * set previously. */ + char *menuName; /* The name of the new menubar that the + * toplevel needs to be set to. NULL means + * that their is no menu now. */ +{ + TkMenuTopLevelList *topLevelListPtr, *prevTopLevelPtr; + TkMenu *menuPtr; + TkMenuReferences *menuRefPtr; + + TkMenuInit(); + + /* + * Destroy the menubar instances of the old menu. Take this window + * out of the old menu's top level reference list. + */ + + if (oldMenuName != NULL) { + menuRefPtr = TkFindMenuReferences(interp, oldMenuName); + if (menuRefPtr != NULL) { + + /* + * Find the menubar instance that is to be removed. Destroy + * it and all of the cascades underneath it. + */ + + if (menuRefPtr->menuPtr != NULL) { + TkMenu *instancePtr; + + menuPtr = menuRefPtr->menuPtr; + + for (instancePtr = menuPtr->masterMenuPtr; + instancePtr != NULL; + instancePtr = instancePtr->nextInstancePtr) { + if (instancePtr->menuType == MENUBAR + && instancePtr->parentTopLevelPtr == tkwin) { + RecursivelyDeleteMenu(instancePtr); + break; + } + } + } + + /* + * Now we need to remove this toplevel from the list of toplevels + * that reference this menu. + */ + + for (topLevelListPtr = menuRefPtr->topLevelListPtr, + prevTopLevelPtr = NULL; + (topLevelListPtr != NULL) + && (topLevelListPtr->tkwin != tkwin); + prevTopLevelPtr = topLevelListPtr, + topLevelListPtr = topLevelListPtr->nextPtr) { + + /* + * Empty loop body. + */ + + } + + /* + * Now we have found the toplevel reference that matches the + * tkwin; remove this reference from the list. + */ + + if (topLevelListPtr != NULL) { + if (prevTopLevelPtr == NULL) { + menuRefPtr->topLevelListPtr = + menuRefPtr->topLevelListPtr->nextPtr; + } else { + prevTopLevelPtr->nextPtr = topLevelListPtr->nextPtr; + } + ckfree((char *) topLevelListPtr); + TkFreeMenuReferences(menuRefPtr); + } + } + } + + /* + * Now, add the clone references for the new menu. + */ + + if (menuName != NULL && menuName[0] != 0) { + TkMenu *menuBarPtr = NULL; + + menuRefPtr = TkCreateMenuReferences(interp, menuName); + + menuPtr = menuRefPtr->menuPtr; + if (menuPtr != NULL) { + char *cloneMenuName; + TkMenuReferences *cloneMenuRefPtr; + char *newArgv[4]; + + /* + * Clone the menu and all of the cascades underneath it. + */ + + cloneMenuName = TkNewMenuName(interp, Tk_PathName(tkwin), + menuPtr); + CloneMenu(menuPtr, cloneMenuName, "menubar"); + + cloneMenuRefPtr = TkFindMenuReferences(interp, cloneMenuName); + if ((cloneMenuRefPtr != NULL) + && (cloneMenuRefPtr->menuPtr != NULL)) { + cloneMenuRefPtr->menuPtr->parentTopLevelPtr = tkwin; + menuBarPtr = cloneMenuRefPtr->menuPtr; + newArgv[0] = "-cursor"; + newArgv[1] = ""; + ConfigureMenu(menuPtr->interp, cloneMenuRefPtr->menuPtr, + 2, newArgv, TK_CONFIG_ARGV_ONLY); + } + + TkpSetWindowMenuBar(tkwin, menuBarPtr); + + ckfree(cloneMenuName); + } else { + TkpSetWindowMenuBar(tkwin, NULL); + } + + + /* + * Add this window to the menu's list of windows that refer + * to this menu. + */ + + topLevelListPtr = (TkMenuTopLevelList *) + ckalloc(sizeof(TkMenuTopLevelList)); + topLevelListPtr->tkwin = tkwin; + topLevelListPtr->nextPtr = menuRefPtr->topLevelListPtr; + menuRefPtr->topLevelListPtr = topLevelListPtr; + } else { + TkpSetWindowMenuBar(tkwin, NULL); + } + TkpSetMainMenubar(interp, tkwin, menuName); +} + +/* + *---------------------------------------------------------------------- + * + * DestroyMenuHashTable -- + * + * Called when an interp is deleted and a menu hash table has + * been set in it. + * + * Results: + * None. + * + * Side effects: + * The hash table is destroyed. + * + *---------------------------------------------------------------------- + */ + +static void +DestroyMenuHashTable(clientData, interp) + ClientData clientData; /* The menu hash table we are destroying */ + Tcl_Interp *interp; /* The interpreter we are destroying */ +{ + Tcl_DeleteHashTable((Tcl_HashTable *) clientData); + ckfree((char *) clientData); +} + +/* + *---------------------------------------------------------------------- + * + * TkGetMenuHashTable -- + * + * For a given interp, give back the menu hash table that goes with + * it. If the hash table does not exist, it is created. + * + * Results: + * Returns a hash table pointer. + * + * Side effects: + * A new hash table is created if there were no table in the interp + * originally. + * + *---------------------------------------------------------------------- + */ + +Tcl_HashTable * +TkGetMenuHashTable(interp) + Tcl_Interp *interp; /* The interp we need the hash table in.*/ +{ + Tcl_HashTable *menuTablePtr; + + menuTablePtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, MENU_HASH_KEY, + NULL); + if (menuTablePtr == NULL) { + menuTablePtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(menuTablePtr, TCL_STRING_KEYS); + Tcl_SetAssocData(interp, MENU_HASH_KEY, DestroyMenuHashTable, + (ClientData) menuTablePtr); + } + return menuTablePtr; +} + +/* + *---------------------------------------------------------------------- + * + * TkCreateMenuReferences -- + * + * Given a pathname, gives back a pointer to a TkMenuReferences structure. + * If a reference is not already in the hash table, one is created. + * + * 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. + * + * Side effects: + * A new hash table entry is created if there were no references + * to the menu originally. + * + *---------------------------------------------------------------------- + */ + +TkMenuReferences * +TkCreateMenuReferences(interp, pathName) + Tcl_Interp *interp; + char *pathName; /* The path of the menu widget */ +{ + Tcl_HashEntry *hashEntryPtr; + TkMenuReferences *menuRefPtr; + int newEntry; + Tcl_HashTable *menuTablePtr = TkGetMenuHashTable(interp); + + hashEntryPtr = Tcl_CreateHashEntry(menuTablePtr, pathName, &newEntry); + if (newEntry) { + menuRefPtr = (TkMenuReferences *) ckalloc(sizeof(TkMenuReferences)); + menuRefPtr->menuPtr = NULL; + menuRefPtr->topLevelListPtr = NULL; + menuRefPtr->parentEntryPtr = NULL; + menuRefPtr->hashEntryPtr = hashEntryPtr; + Tcl_SetHashValue(hashEntryPtr, (char *) menuRefPtr); + } else { + menuRefPtr = (TkMenuReferences *) Tcl_GetHashValue(hashEntryPtr); + } + return menuRefPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TkFindMenuReferences -- + * + * 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 * +TkFindMenuReferences(interp, pathName) + Tcl_Interp *interp; /* The interp the menu is living in. */ + char *pathName; /* The path of the menu widget */ +{ + Tcl_HashEntry *hashEntryPtr; + TkMenuReferences *menuRefPtr = NULL; + Tcl_HashTable *menuTablePtr; + + menuTablePtr = TkGetMenuHashTable(interp); + hashEntryPtr = Tcl_FindHashEntry(menuTablePtr, pathName); + if (hashEntryPtr != NULL) { + menuRefPtr = (TkMenuReferences *) Tcl_GetHashValue(hashEntryPtr); + } + return menuRefPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TkFreeMenuReferences -- + * + * This is called after one of the fields in a menu reference + * is cleared. It cleans up the ref if it is now empty. + * + * Results: + * None. + * + * Side effects: + * If this is the last field to be cleared, the menu ref is + * taken out of the hash table. + * + *---------------------------------------------------------------------- + */ + +void +TkFreeMenuReferences(menuRefPtr) + TkMenuReferences *menuRefPtr; /* The menu reference to + * free */ +{ + if ((menuRefPtr->menuPtr == NULL) + && (menuRefPtr->parentEntryPtr == NULL) + && (menuRefPtr->topLevelListPtr == NULL)) { + Tcl_DeleteHashEntry(menuRefPtr->hashEntryPtr); + ckfree((char *) menuRefPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * DeleteMenuCloneEntries -- + * + * For every clone in this clone chain, delete the menu entries + * given by the parameters. + * + * Results: + * None. + * + * Side effects: + * The appropriate entries are deleted from all clones of this menu. + * + *---------------------------------------------------------------------- + */ + +static void +DeleteMenuCloneEntries(menuPtr, first, last) + TkMenu *menuPtr; /* the menu the command was issued with */ + int first; /* the zero-based first entry in the set + * of entries to delete. */ + int last; /* the zero-based last entry */ +{ + + TkMenu *menuListPtr; + int numDeleted, i; + + numDeleted = last + 1 - first; + for (menuListPtr = menuPtr->masterMenuPtr; menuListPtr != NULL; + menuListPtr = menuListPtr->nextInstancePtr) { + for (i = last; i >= first; i--) { + Tcl_EventuallyFree((ClientData) menuListPtr->entries[i], + DestroyMenuEntry); + } + for (i = last + 1; i < menuListPtr->numEntries; i++) { + menuListPtr->entries[i - numDeleted] = menuListPtr->entries[i]; + menuListPtr->entries[i - numDeleted]->index = i; + } + menuListPtr->numEntries -= numDeleted; + if (menuListPtr->numEntries == 0) { + ckfree((char *) menuListPtr->entries); + menuListPtr->entries = NULL; + } + if ((menuListPtr->active >= first) + && (menuListPtr->active <= last)) { + menuListPtr->active = -1; + } else if (menuListPtr->active > last) { + menuListPtr->active -= numDeleted; + } + TkEventuallyRecomputeMenu(menuListPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * TkMenuInit -- + * + * 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 +TkMenuInit() +{ + if (!menusInitialized) { + TkpMenuInit(); + menusInitialized = 1; + } +} diff --git a/generic/tkMenu.h b/generic/tkMenu.h new file mode 100644 index 0000000..6f30d72 --- /dev/null +++ b/generic/tkMenu.h @@ -0,0 +1,541 @@ +/* + * tkMenu.h -- + * + * Declarations shared among all of the files that implement menu 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: @(#) tkMenu.h 1.60 97/06/20 14:43:21 + */ + +#ifndef _TKMENU +#define _TKMENU + +#ifndef _TK +#include "tk.h" +#endif + +#ifndef _TKINT +#include "tkInt.h" +#endif + +#ifndef _DEFAULT +#include "default.h" +#endif + +/* + * Dummy types used by the platform menu code. + */ + +typedef struct TkMenuPlatformData_ *TkMenuPlatformData; +typedef struct TkMenuPlatformEntryData_ *TkMenuPlatformEntryData; + +/* + * One of the following data structures is kept for each entry of each + * menu managed by this file: + */ + +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. */ + int labelLength; /* Number of non-NULL characters in label. */ + Tk_Uid state; /* 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. + * If not None then label is 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 menu entry, or NULL if + * none. */ + char *selectImageString; /* Name of image to display when selected + * (malloc'ed), 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 + * 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 + * don't draw it. */ + /* + * Display attributes + */ + + Tk_3DBorder border; /* Structure used to draw background for + * entry. NULL means use overall border + * for menu. */ + XColor *fg; /* Foreground color to use for entry. NULL + * means use foreground color from menu. */ + Tk_3DBorder activeBorder; /* 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 + * active. NULL means use active foreground + * from menu. */ + XColor *indicatorFg; /* 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 + * use overall font for menu. */ + int columnBreak; /* 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 + * margin to accomodate a standard check + * mark and a default right margin. If this + * is 1, then the item has no such margins. + * and checkbuttons and radiobuttons with + * this set will have a rectangle drawn + * in the indicator around the item if + * the item is checked. + * This is useful palette menus.*/ + int indicatorSpace; /* The width of the indicator space for this + * entry. + */ + int labelWidth; /* Number of pixels to allow for displaying + * labels in menu entries. */ + + /* + * Information used to implement this entry's action: + */ + + char *command; /* Command to invoke when entry is invoked. + * Malloc'ed. */ + char *name; /* 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 + * (only for radio and check buttons). + * Malloc'ed. */ + char *offValue; /* Value to store in variable when not + * selected (only for check buttons). + * Malloc'ed. */ + + /* + * Information used for drawing this menu entry. + */ + + int width; /* Number of pixels occupied by entry in + * horizontal dimension. Not used except + * in menubars. The width of norma menus + * is dependent on the rest of the menu. */ + int x; /* X-coordinate of leftmost pixel in entry */ + int height; /* Number of pixels occupied by entry in + * vertical dimension, including raised + * border drawn around entry when active. */ + int y; /* Y-coordinate of topmost pixel in entry. */ + GC textGC; /* GC for drawing text in entry. NULL means + * use overall textGC for menu. */ + GC activeGC; /* GC for drawing text in entry when active. + * NULL means use overall activeGC for + * menu. */ + GC disabledGC; /* Used to produce disabled effect for entry. + * NULL means use overall disabledGC from + * menu structure. See comments for + * disabledFg in menu structure for more + * information. */ + GC indicatorGC; /* For drawing indicators. None means use + * GC from menu. */ + + /* + * Miscellaneous fields. + */ + + int entryFlags; /* Various flags. See below for + definitions. */ + int index; /* Need to know which index we are. This + * is zero-based. This is the top-left entry + * of the menu. */ + + /* + * Bookeeping for master menus and cascade menus. + */ + + struct TkMenuReferences *childMenuRefPtr; + /* A pointer to the hash table entry for + * the child menu. Stored here when the menu + * entry is configured so that a hash lookup + * is not necessary later.*/ + struct TkMenuEntry *nextCascadePtr; + /* The next cascade entry that is a parent of + * this entry's child cascade menu. NULL + * end of list, this is not a cascade entry, + * or the menu that this entry point to + * does not yet exist. */ + TkMenuPlatformEntryData platformEntryData; + /* The data for the specific type of menu. + * Depends on platform and menu type what + * kind of options are in this structure. + */ +} TkMenuEntry; + +/* + * Flag values defined for menu entries: + * + * ENTRY_SELECTED: Non-zero means this is a radio or check + * 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_PLATFORM_FLAG1 - 4 These flags are reserved for use by the + * platform-dependent implementation of menus + * and should not be used by anything else. + */ + +#define ENTRY_SELECTED 1 +#define ENTRY_NEEDS_REDISPLAY 2 +#define ENTRY_LAST_COLUMN 4 +#define ENTRY_PLATFORM_FLAG1 (1 << 30) +#define ENTRY_PLATFORM_FLAG2 (1 << 29) +#define ENTRY_PLATFORM_FLAG3 (1 << 28) +#define ENTRY_PLATFORM_FLAG4 (1 << 27) + +/* + * 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 + +/* + * Mask bits for above types: + */ + +#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) + +/* + * A data structure of the following type is kept for each + * menu widget: + */ + +typedef struct TkMenu { + Tk_Window tkwin; /* Window that embodies the pane. NULL + * means that the window has been destroyed + * but the data structures haven't yet been + * cleaned up.*/ + Display *display; /* Display containing widget. Needed, among + * other things, so that resources can be + * freed up even after tkwin has gone away. */ + Tcl_Interp *interp; /* Interpreter associated with menu. */ + Tcl_Command widgetCmd; /* Token for menu's widget command. */ + TkMenuEntry **entries; /* Array of pointers to all the entries + * in the menu. NULL means no entries. */ + int numEntries; /* Number of elements in entries. */ + int active; /* Index of active entry. -1 means + * nothing active. */ + int menuType; /* MASTER_MENU, TEAROFF_MENU, or MENUBAR. + * See below for definitions. */ + char *menuTypeName; /* Used to control whether created tkwin + * is a toplevel or not. "normal", "menubar", + * or "toplevel" */ + + /* + * Information used when displaying widget: + */ + + Tk_3DBorder border; /* 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 + * 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 + * means use normalFg with a 50% stipple + * instead. */ + XColor *activeFg; /* Foreground color for active entry. */ + XColor *indicatorFg; /* Color for indicators in radio and check + * button entries. */ + Pixmap gray; /* Bitmap for drawing disabled entries in + * a stippled fashion. None means not + * allocated yet. */ + GC textGC; /* GC for drawing text and other features + * of menu entries. */ + GC disabledGC; /* Used to produce disabled effect. If + * disabledFg isn't NULL, this GC is used to + * draw text and icons for disabled entries. + * Otherwise text and icons are drawn with + * normalGC and this GC is used to stipple + * background across them. */ + GC activeGC; /* GC for drawing active entry. */ + GC indicatorGC; /* For drawing indicators. */ + GC disabledImageGC; /* Used for drawing disabled images. They + * have to be stippled. This is created + * when the image is about to be drawn the + * first time. */ + + /* + * Information about geometry of menu. + */ + + int totalWidth; /* Width of entire menu */ + int totalHeight; /* Height of entire menu */ + + /* + * Miscellaneous information: + */ + + int tearOff; /* 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 + * the mouse is released. On others, an + * 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 + * 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 + * run whenever the menu is torn-off. */ + char *takeFocus; /* 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 + * trees when preprocessing postcommands + * on some platforms. See PostMenu for + * more details. */ + int postCommandGeneration; /* Need to do pre-invocation post command + * traversal */ + int menuFlags; /* Flags for use by X; see below for + definition */ + TkMenuEntry *postedCascade; /* Points to menu entry for cascaded submenu + * that is currently posted or NULL if no + * submenu posted. */ + struct TkMenu *nextInstancePtr; + /* The next instance of this menu in the + * chain. */ + struct TkMenu *masterMenuPtr; + /* A pointer to the original menu for this + * clone chain. Points back to this structure + * if this menu is a master menu. */ + Tk_Window parentTopLevelPtr;/* If this menu is a menubar, this is the + * toplevel that owns the menu. Only applicable + * for menubar clones. + */ + struct TkMenuReferences *menuRefPtr; + /* Each menu is hashed into a table with the + * name of the menu's window as the key. + * The information in this hash table includes + * a pointer to the menu (so that cascades + * can find this menu), a pointer to the + * list of toplevel widgets that have this + * menu as its menubar, and a list of menu + * entries that have this menu specified + * as a cascade. */ + TkMenuPlatformData platformData; + /* The data for the specific type of menu. + * Depends on platform and menu type what + * kind of options are in this structure. + */ +} TkMenu; + +/* + * When the toplevel configure -menu command is executed, the menu may not + * exist yet. We need to keep a linked list of windows that reference + * a particular menu. + */ + +typedef struct TkMenuTopLevelList { + struct TkMenuTopLevelList *nextPtr; + /* The next window in the list */ + Tk_Window tkwin; /* The window that has this menu as its + * menubar. */ +} TkMenuTopLevelList; + +/* + * The following structure is used to keep track of things which + * reference a menu. It is created when: + * - a menu is created. + * - a cascade entry is added to a menu with a non-null name + * - the "-menu" configuration option is used on a toplevel widget + * with a non-null parameter. + * + * One of these three fields must be non-NULL, but any of the fields may + * be NULL. This structure makes it easy to determine whether or not + * anything like recalculating platform data or geometry is necessary + * when one of the three actions above is performed. + */ + +typedef struct TkMenuReferences { + struct TkMenu *menuPtr; /* The menu data structure. This is NULL + * if the menu does not exist. */ + TkMenuTopLevelList *topLevelListPtr; + /* First in the list of all toplevels that + * have this menu as its menubar. NULL if no + * toplevel widgets have this menu as its + * menubar. */ + TkMenuEntry *parentEntryPtr;/* First in the list of all cascade menu + * entries that have this menu as their child. + * NULL means no cascade entries. */ + Tcl_HashEntry *hashEntryPtr;/* This is needed because the pathname of the + * window (which is what we hash on) may not + * be around when we are deleting. + */ +} TkMenuReferences; + +/* + * Flag bits for menus: + * + * REDRAW_PENDING: Non-zero means a DoWhenIdle handler + * has already been queued to redraw + * this window. + * RESIZE_PENDING: Non-zero means a call to ComputeMenuGeometry + * has already been scheduled. + * MENU_DELETION_PENDING Non-zero means that we are currently destroying + * this menu. This is useful when we are in the + * middle of cleaning this master menu's chain of + * menus up when TkDestroyMenu was called again on + * this menu (via a destroy binding or somesuch). + * MENU_PLATFORM_FLAG1... Reserved for use by the platform-specific menu + * code. + */ + +#define REDRAW_PENDING 1 +#define RESIZE_PENDING 2 +#define MENU_DELETION_PENDING 4 +#define MENU_PLATFORM_FLAG1 (1 << 30) +#define MENU_PLATFORM_FLAG2 (1 << 29) +#define MENU_PLATFORM_FLAG3 (1 << 28) + +/* + * Each menu created by the user is a MASTER_MENU. When a menu is torn off, + * a TEAROFF_MENU instance is created. When a menu is assigned to a toplevel + * as a menu bar, a MENUBAR instance is created. All instances have the same + * configuration information. If the master instance is deleted, all instances + * are deleted. If one of the other instances is deleted, only that instance + * is deleted. + */ + +#define UNKNOWN_TYPE -1 +#define MASTER_MENU 0 +#define TEAROFF_MENU 1 +#define MENUBAR 2 + +/* + * Various geometry definitions: + */ + +#define CASCADE_ARROW_HEIGHT 10 +#define CASCADE_ARROW_WIDTH 8 +#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: + */ + +EXTERN int TkActivateMenuEntry _ANSI_ARGS_((TkMenu *menuPtr, + int index)); +EXTERN void TkBindMenu _ANSI_ARGS_(( + Tk_Window tkwin, TkMenu *menuPtr)); +EXTERN TkMenuReferences * + TkCreateMenuReferences _ANSI_ARGS_((Tcl_Interp *interp, + char *pathName)); +EXTERN void TkDestroyMenu _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)); +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, + int *indexPtr)); +EXTERN void TkMenuInitializeDrawingFields _ANSI_ARGS_((TkMenu *menuPtr)); +EXTERN void TkMenuInitializeEntryDrawingFields _ANSI_ARGS_(( + TkMenuEntry *mePtr)); +EXTERN int TkInvokeMenu _ANSI_ARGS_((Tcl_Interp *interp, + TkMenu *menuPtr, int index)); +EXTERN void TkMenuConfigureDrawOptions _ANSI_ARGS_(( + TkMenu *menuPtr)); +EXTERN int TkMenuConfigureEntryDrawOptions _ANSI_ARGS_(( + TkMenuEntry *mePtr, int index)); +EXTERN void TkMenuFreeDrawOptions _ANSI_ARGS_((TkMenu *menuPtr)); +EXTERN void TkMenuEntryFreeDrawOptions _ANSI_ARGS_(( + TkMenuEntry *mePtr)); +EXTERN void TkMenuEventProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +EXTERN void TkMenuImageProc _ANSI_ARGS_(( + ClientData clientData, int x, int y, int width, + int height, int imgWidth, int imgHeight)); +EXTERN void TkMenuInit _ANSI_ARGS_((void)); +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 int TkPostCommand _ANSI_ARGS_((TkMenu *menuPtr)); +EXTERN int TkPostSubmenu _ANSI_ARGS_((Tcl_Interp *interp, + TkMenu *menuPtr, TkMenuEntry *mePtr)); +EXTERN int TkPostTearoffMenu _ANSI_ARGS_((Tcl_Interp *interp, + TkMenu *menuPtr, int x, int y)); +EXTERN int TkPreprocessMenu _ANSI_ARGS_((TkMenu *menuPtr)); +EXTERN void TkRecomputeMenu _ANSI_ARGS_((TkMenu *menuPtr)); + +/* + * These routines are the platform-dependent routines called by the + * common code. + */ + +EXTERN void TkpComputeMenubarGeometry _ANSI_ARGS_((TkMenu *menuPtr)); +EXTERN void TkpComputeStandardMenuGeometry _ANSI_ARGS_ + ((TkMenu *menuPtr)); +EXTERN int TkpConfigureMenuEntry + _ANSI_ARGS_((TkMenuEntry *mePtr)); +EXTERN void TkpDestroyMenu _ANSI_ARGS_((TkMenu *menuPtr)); +EXTERN void TkpDestroyMenuEntry + _ANSI_ARGS_((TkMenuEntry *mEntryPtr)); +EXTERN void TkpDrawMenuEntry _ANSI_ARGS_((TkMenuEntry *mePtr, + Drawable d, Tk_Font tkfont, + CONST Tk_FontMetrics *menuMetricsPtr, int x, + int y, int width, int height, int strictMotif, + int drawArrow)); +EXTERN void TkpMenuInit _ANSI_ARGS_((void)); +EXTERN int TkpMenuNewEntry _ANSI_ARGS_((TkMenuEntry *mePtr)); +EXTERN int TkpNewMenu _ANSI_ARGS_((TkMenu *menuPtr)); +EXTERN int TkpPostMenu _ANSI_ARGS_((Tcl_Interp *interp, + TkMenu *menuPtr, int x, int y)); +EXTERN void TkpSetWindowMenuBar _ANSI_ARGS_((Tk_Window tkwin, + TkMenu *menuPtr)); + +#endif /* _TKMENU */ + diff --git a/generic/tkMenuDraw.c b/generic/tkMenuDraw.c new file mode 100644 index 0000000..be218a0 --- /dev/null +++ b/generic/tkMenuDraw.c @@ -0,0 +1,1018 @@ +/* + * tkMenuDraw.c -- + * + * This module implements the platform-independent drawing and + * geometry calculations of menu 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: @(#) tkMenuDraw.c 1.46 97/10/28 14:26:00 + */ + +#include "tkMenu.h" + +/* + * Forward declarations for procedures defined later in this file: + */ + +static void AdjustMenuCoords _ANSI_ARGS_ ((TkMenu *menuPtr, + TkMenuEntry *mePtr, int *xPtr, int *yPtr, + char *string)); +static void ComputeMenuGeometry _ANSI_ARGS_(( + ClientData clientData)); +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. + * + * Results: + * None. + * + * Side effects: + * menuPtr fields are initialized. + * + *---------------------------------------------------------------------- + */ + +void +TkMenuInitializeDrawingFields(menuPtr) + TkMenu *menuPtr; /* The menu we are initializing. */ +{ + menuPtr->textGC = None; + menuPtr->gray = None; + menuPtr->disabledGC = None; + menuPtr->activeGC = None; + menuPtr->indicatorGC = None; + menuPtr->disabledImageGC = None; + menuPtr->totalWidth = menuPtr->totalHeight = 0; +} + +/* + *---------------------------------------------------------------------- + * + * TkMenuInitializeEntryDrawingFields -- + * + * Fills in drawing fields of a new menu entry. Called when an + * entry is created. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TkMenuInitializeEntryDrawingFields(mePtr) + TkMenuEntry *mePtr; /* The menu we are initializing. */ +{ + mePtr->width = 0; + mePtr->height = 0; + mePtr->x = 0; + mePtr->y = 0; + mePtr->indicatorSpace = 0; + mePtr->labelWidth = 0; + mePtr->textGC = None; + mePtr->activeGC = None; + mePtr->disabledGC = None; + mePtr->indicatorGC = None; +} + +/* + *---------------------------------------------------------------------- + * + * TkMenuFreeDrawOptions -- + * + * Frees up any structures allocated for the drawing of a menu. + * Called when menu is deleted. + * + * Results: + * None. + * + * Side effects: + * Storage is released. + * + *---------------------------------------------------------------------- + */ + +void +TkMenuFreeDrawOptions(menuPtr) + TkMenu *menuPtr; +{ + if (menuPtr->textGC != None) { + Tk_FreeGC(menuPtr->display, menuPtr->textGC); + } + if (menuPtr->disabledImageGC != None) { + Tk_FreeGC(menuPtr->display, menuPtr->disabledImageGC); + } + if (menuPtr->gray != None) { + Tk_FreeBitmap(menuPtr->display, menuPtr->gray); + } + if (menuPtr->disabledGC != None) { + Tk_FreeGC(menuPtr->display, menuPtr->disabledGC); + } + if (menuPtr->activeGC != None) { + Tk_FreeGC(menuPtr->display, menuPtr->activeGC); + } + if (menuPtr->indicatorGC != None) { + Tk_FreeGC(menuPtr->display, menuPtr->indicatorGC); + } +} + +/* + *---------------------------------------------------------------------- + * + * TkMenuEntryFreeDrawOptions -- + * + * Frees up drawing structures for a menu entry. Called when + * menu entry is freed. + * + * RESULTS: + * None. + * + * Side effects: + * Storage is freed. + * + *---------------------------------------------------------------------- + */ + +void +TkMenuEntryFreeDrawOptions(mePtr) + TkMenuEntry *mePtr; +{ + if (mePtr->textGC != None) { + Tk_FreeGC(mePtr->menuPtr->display, mePtr->textGC); + } + if (mePtr->disabledGC != None) { + Tk_FreeGC(mePtr->menuPtr->display, mePtr->disabledGC); + } + if (mePtr->activeGC != None) { + Tk_FreeGC(mePtr->menuPtr->display, mePtr->activeGC); + } + if (mePtr->indicatorGC != None) { + Tk_FreeGC(mePtr->menuPtr->display, mePtr->indicatorGC); + } +} + +/* + *---------------------------------------------------------------------- + * + * TkMenuConfigureDrawOptions -- + * + * Sets the menu's drawing attributes in preparation for drawing + * the menu. + * + * RESULTS: + * None. + * + * Side effects: + * Storage is allocated. + * + *---------------------------------------------------------------------- + */ + +void +TkMenuConfigureDrawOptions(menuPtr) + TkMenu *menuPtr; /* The menu we are configuring. */ +{ + XGCValues gcValues; + GC newGC; + unsigned long mask; + + /* + * 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. + */ + + Tk_SetBackgroundFromBorder(menuPtr->tkwin, menuPtr->border); + + gcValues.font = Tk_FontId(menuPtr->tkfont); + gcValues.foreground = menuPtr->fg->pixel; + gcValues.background = Tk_3DBorderColor(menuPtr->border)->pixel; + newGC = Tk_GetGC(menuPtr->tkwin, GCForeground|GCBackground|GCFont, + &gcValues); + if (menuPtr->textGC != None) { + Tk_FreeGC(menuPtr->display, menuPtr->textGC); + } + 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; + 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")); + } + if (menuPtr->gray != None) { + gcValues.fill_style = FillStippled; + gcValues.stipple = menuPtr->gray; + mask = GCForeground|GCFillStyle|GCStipple; + } + } + newGC = Tk_GetGC(menuPtr->tkwin, mask, &gcValues); + if (menuPtr->disabledGC != None) { + Tk_FreeGC(menuPtr->display, menuPtr->disabledGC); + } + menuPtr->disabledGC = newGC; + + gcValues.foreground = Tk_3DBorderColor(menuPtr->border)->pixel; + if (menuPtr->gray == None) { + menuPtr->gray = Tk_GetBitmap(menuPtr->interp, menuPtr->tkwin, + Tk_GetUid("gray50")); + } + if (menuPtr->gray != None) { + gcValues.fill_style = FillStippled; + gcValues.stipple = menuPtr->gray; + newGC = Tk_GetGC(menuPtr->tkwin, + GCForeground|GCFillStyle|GCStipple, &gcValues); + } + if (menuPtr->disabledImageGC != None) { + Tk_FreeGC(menuPtr->display, menuPtr->disabledImageGC); + } + menuPtr->disabledImageGC = newGC; + + gcValues.font = Tk_FontId(menuPtr->tkfont); + gcValues.foreground = menuPtr->activeFg->pixel; + gcValues.background = + Tk_3DBorderColor(menuPtr->activeBorder)->pixel; + newGC = Tk_GetGC(menuPtr->tkwin, GCForeground|GCBackground|GCFont, + &gcValues); + if (menuPtr->activeGC != None) { + Tk_FreeGC(menuPtr->display, menuPtr->activeGC); + } + menuPtr->activeGC = newGC; + + gcValues.foreground = menuPtr->indicatorFg->pixel; + gcValues.background = Tk_3DBorderColor(menuPtr->border)->pixel; + newGC = Tk_GetGC(menuPtr->tkwin, GCForeground|GCBackground|GCFont, + &gcValues); + if (menuPtr->indicatorGC != None) { + Tk_FreeGC(menuPtr->display, menuPtr->indicatorGC); + } + menuPtr->indicatorGC = newGC; +} + +/* + *---------------------------------------------------------------------- + * + * TkMenuConfigureEntryDrawOptions -- + * + * Calculates any entry-specific draw options for the given menu + * entry. + * + * Results: + * Returns a standard Tcl error. + * + * Side effects: + * Storage may be allocated. + * + *---------------------------------------------------------------------- + */ + +int +TkMenuConfigureEntryDrawOptions(mePtr, index) + TkMenuEntry *mePtr; + int index; +{ + + XGCValues gcValues; + GC newGC, newActiveGC, newDisabledGC, newIndicatorGC; + unsigned long mask; + Tk_Font tkfont; + TkMenu *menuPtr = mePtr->menuPtr; + + tkfont = (mePtr->tkfont == NULL) ? menuPtr->tkfont : mePtr->tkfont; + + if (mePtr->state == tkActiveUid) { + if (index != menuPtr->active) { + TkActivateMenuEntry(menuPtr, index); + } + } else { + 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; + + gcValues.font = Tk_FontId(tkfont); + + /* + * Note: disable GraphicsExpose events; we know there won't be + * obscured areas when copying from an off-screen pixmap to the + * screen and this gets rid of unnecessary events. + */ + + gcValues.graphics_exposures = False; + newGC = Tk_GetGC(menuPtr->tkwin, + GCForeground|GCBackground|GCFont|GCGraphicsExposures, + &gcValues); + + if (mePtr->indicatorFg != NULL) { + gcValues.foreground = mePtr->indicatorFg->pixel; + } else if (menuPtr->indicatorFg != NULL) { + gcValues.foreground = menuPtr->indicatorFg->pixel; + } + newIndicatorGC = Tk_GetGC(menuPtr->tkwin, + GCForeground|GCBackground|GCGraphicsExposures, + &gcValues); + + if ((menuPtr->disabledFg != NULL) || (mePtr->image != NULL)) { + gcValues.foreground = menuPtr->disabledFg->pixel; + mask = GCForeground|GCBackground|GCFont|GCGraphicsExposures; + } else { + gcValues.foreground = gcValues.background; + gcValues.fill_style = FillStippled; + gcValues.stipple = menuPtr->gray; + mask = GCForeground|GCFillStyle|GCStipple; + } + 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; + newActiveGC = Tk_GetGC(menuPtr->tkwin, + GCForeground|GCBackground|GCFont|GCGraphicsExposures, + &gcValues); + } else { + newGC = None; + newActiveGC = None; + newDisabledGC = None; + newIndicatorGC = None; + } + if (mePtr->textGC != None) { + Tk_FreeGC(menuPtr->display, mePtr->textGC); + } + mePtr->textGC = newGC; + if (mePtr->activeGC != None) { + Tk_FreeGC(menuPtr->display, mePtr->activeGC); + } + mePtr->activeGC = newActiveGC; + if (mePtr->disabledGC != None) { + Tk_FreeGC(menuPtr->display, mePtr->disabledGC); + } + mePtr->disabledGC = newDisabledGC; + if (mePtr->indicatorGC != None) { + Tk_FreeGC(menuPtr->display, mePtr->indicatorGC); + } + mePtr->indicatorGC = newIndicatorGC; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TkEventuallyRecomputeMenu -- + * + * Tells Tcl to redo the geometry because this menu has changed. + * + * Results: + * None. + * + * Side effects: + * Menu geometry is recomputed at idle time, and the menu will be + * redisplayed. + * + *---------------------------------------------------------------------- + */ + +void +TkEventuallyRecomputeMenu(menuPtr) + TkMenu *menuPtr; +{ + if (!(menuPtr->menuFlags & RESIZE_PENDING)) { + menuPtr->menuFlags |= RESIZE_PENDING; + Tcl_DoWhenIdle(ComputeMenuGeometry, (ClientData) menuPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * TkRecomputeMenu -- + * + * Tells Tcl to redo the geometry because this menu has changed. + * Does it now; removes any ComputeMenuGeometries from the idler. + * + * Results: + * None. + * + * Side effects: + * Menu geometry is immediately reconfigured. + * + *---------------------------------------------------------------------- + */ + +void +TkRecomputeMenu(menuPtr) + TkMenu *menuPtr; +{ + if (menuPtr->menuFlags & RESIZE_PENDING) { + Tcl_CancelIdleCall(ComputeMenuGeometry, (ClientData) menuPtr); + ComputeMenuGeometry((ClientData) menuPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * TkEventuallyRedrawMenu -- + * + * Arrange for an entry of a menu, or the whole menu, to be + * redisplayed at some point in the future. + * + * Results: + * None. + * + * Side effects: + * A when-idle hander is scheduled to do the redisplay, if there + * isn't one already scheduled. + * + *---------------------------------------------------------------------- + */ + +void +TkEventuallyRedrawMenu(menuPtr, mePtr) + register TkMenu *menuPtr; /* Information about menu to redraw. */ + register TkMenuEntry *mePtr; /* Entry to redraw. NULL means redraw + * all the entries in the menu. */ +{ + int i; + + if (menuPtr->tkwin == NULL) { + return; + } + if (mePtr != NULL) { + mePtr->entryFlags |= ENTRY_NEEDS_REDISPLAY; + } else { + for (i = 0; i < menuPtr->numEntries; i++) { + menuPtr->entries[i]->entryFlags |= ENTRY_NEEDS_REDISPLAY; + } + } + if (!Tk_IsMapped(menuPtr->tkwin) + || (menuPtr->menuFlags & REDRAW_PENDING)) { + return; + } + Tcl_DoWhenIdle(DisplayMenu, (ClientData) menuPtr); + menuPtr->menuFlags |= REDRAW_PENDING; +} + +/* + *-------------------------------------------------------------- + * + * ComputeMenuGeometry -- + * + * This procedure is invoked to recompute the size and + * layout of a menu. It is called as a when-idle handler so + * that it only gets done once, even if a group of changes is + * made to the menu. + * + * Results: + * None. + * + * Side effects: + * Fields of menu entries are changed to reflect their + * current positions, and the size of the menu window + * itself may be changed. + * + *-------------------------------------------------------------- + */ + +static void +ComputeMenuGeometry(clientData) + ClientData clientData; /* Structure describing menu. */ +{ + TkMenu *menuPtr = (TkMenu *) clientData; + + if (menuPtr->tkwin == NULL) { + return; + } + + if (menuPtr->menuType == MENUBAR) { + TkpComputeMenubarGeometry(menuPtr); + } else { + TkpComputeStandardMenuGeometry(menuPtr); + } + + if ((menuPtr->totalWidth != Tk_ReqWidth(menuPtr->tkwin)) || + (menuPtr->totalHeight != Tk_ReqHeight(menuPtr->tkwin))) { + Tk_GeometryRequest(menuPtr->tkwin, menuPtr->totalWidth, + menuPtr->totalHeight); + } + + /* + * Must always force a redisplay here if the window is mapped + * (even if the size didn't change, something else might have + * changed in the menu, such as a label or accelerator). The + * resize will force a redisplay above. + */ + + TkEventuallyRedrawMenu(menuPtr, (TkMenuEntry *) NULL); + + menuPtr->menuFlags &= ~RESIZE_PENDING; +} + +/* + *---------------------------------------------------------------------- + * + * TkMenuSelectImageProc -- + * + * This procedure is invoked by the image code whenever the manager + * for an image does something that affects the size of contents + * of an image displayed in a menu entry when it is selected. + * + * Results: + * None. + * + * Side effects: + * Arranges for the menu to get redisplayed. + * + *---------------------------------------------------------------------- + */ + +void +TkMenuSelectImageProc(clientData, x, y, width, height, imgWidth, + imgHeight) + ClientData clientData; /* Pointer to widget record. */ + int x, y; /* Upper left pixel (within image) + * that must be redisplayed. */ + int width, height; /* Dimensions of area to redisplay + * (may be <= 0). */ + int imgWidth, imgHeight; /* New dimensions of image. */ +{ + register TkMenuEntry *mePtr = (TkMenuEntry *) clientData; + + if ((mePtr->entryFlags & ENTRY_SELECTED) + && !(mePtr->menuPtr->menuFlags & + REDRAW_PENDING)) { + mePtr->menuPtr->menuFlags |= REDRAW_PENDING; + Tcl_DoWhenIdle(DisplayMenu, (ClientData) mePtr->menuPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * DisplayMenu -- + * + * This procedure is invoked to display a menu widget. + * + * Results: + * None. + * + * Side effects: + * Commands are output to X to display the menu in its + * current mode. + * + *---------------------------------------------------------------------- + */ + +static void +DisplayMenu(clientData) + ClientData clientData; /* Information about widget. */ +{ + register TkMenu *menuPtr = (TkMenu *) clientData; + register TkMenuEntry *mePtr; + register Tk_Window tkwin = menuPtr->tkwin; + int index, strictMotif; + Tk_Font tkfont = menuPtr->tkfont; + Tk_FontMetrics menuMetrics; + int width; + + menuPtr->menuFlags &= ~REDRAW_PENDING; + if ((menuPtr->tkwin == NULL) || !Tk_IsMapped(tkwin)) { + return; + } + + 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); + } + + strictMotif = Tk_StrictMotif(menuPtr->tkwin); + + /* + * See note in ComputeMenuGeometry. We don't want to be doing font metrics + * all of the time. + */ + + Tk_GetFontMetrics(menuPtr->tkfont, &menuMetrics); + + /* + * Loop through all of the entries, drawing them one at a time. + */ + + for (index = 0; index < menuPtr->numEntries; index++) { + mePtr = menuPtr->entries[index]; + if (menuPtr->menuType != MENUBAR) { + if (!(mePtr->entryFlags & ENTRY_NEEDS_REDISPLAY)) { + continue; + } + } + mePtr->entryFlags &= ~ENTRY_NEEDS_REDISPLAY; + + if (menuPtr->menuType == MENUBAR) { + width = mePtr->width; + } else { + if (mePtr->entryFlags & ENTRY_LAST_COLUMN) { + width = Tk_Width(menuPtr->tkwin) - mePtr->x + - menuPtr->activeBorderWidth; + } else { + width = mePtr->width + menuPtr->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) { + mePtr = menuPtr->entries[index - 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, + TK_RELIEF_FLAT); + } + } + + if (menuPtr->menuType != MENUBAR) { + 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; + } 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, + 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; + } + Tk_Fill3DRectangle(tkwin, Tk_WindowId(tkwin), menuPtr->border, x, y, + width, height, 0, TK_RELIEF_FLAT); + } + + Tk_Draw3DRectangle(menuPtr->tkwin, Tk_WindowId(tkwin), + menuPtr->border, 0, 0, Tk_Width(tkwin), Tk_Height(tkwin), + menuPtr->borderWidth, menuPtr->relief); +} + +/* + *-------------------------------------------------------------- + * + * TkMenuEventProc -- + * + * This procedure is invoked by the Tk dispatcher for various + * events on menus. + * + * Results: + * None. + * + * Side effects: + * When the window gets deleted, internal structures get + * cleaned up. When it gets exposed, it is redisplayed. + * + *-------------------------------------------------------------- + */ + +void +TkMenuEventProc(clientData, eventPtr) + ClientData clientData; /* Information about window. */ + XEvent *eventPtr; /* Information about event. */ +{ + TkMenu *menuPtr = (TkMenu *) clientData; + + if ((eventPtr->type == Expose) && (eventPtr->xexpose.count == 0)) { + TkEventuallyRedrawMenu(menuPtr, (TkMenuEntry *) NULL); + } else if (eventPtr->type == ConfigureNotify) { + TkEventuallyRecomputeMenu(menuPtr); + TkEventuallyRedrawMenu(menuPtr, (TkMenuEntry *) NULL); + } else if (eventPtr->type == ActivateNotify) { + if (menuPtr->menuType == TEAROFF_MENU) { + TkpSetMainMenubar(menuPtr->interp, menuPtr->tkwin, NULL); + } + } else if (eventPtr->type == DestroyNotify) { + if (menuPtr->tkwin != NULL) { + menuPtr->tkwin = NULL; + Tcl_DeleteCommandFromToken(menuPtr->interp, menuPtr->widgetCmd); + } + if (menuPtr->menuFlags & REDRAW_PENDING) { + Tcl_CancelIdleCall(DisplayMenu, (ClientData) menuPtr); + } + if (menuPtr->menuFlags & RESIZE_PENDING) { + Tcl_CancelIdleCall(ComputeMenuGeometry, (ClientData) menuPtr); + } + TkDestroyMenu(menuPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * TkMenuImageProc -- + * + * This procedure is invoked by the image code whenever the manager + * for an image does something that affects the size of contents + * of an image displayed in a menu entry. + * + * Results: + * None. + * + * Side effects: + * Arranges for the menu to get redisplayed. + * + *---------------------------------------------------------------------- + */ + +void +TkMenuImageProc(clientData, x, y, width, height, imgWidth, + imgHeight) + ClientData clientData; /* Pointer to widget record. */ + int x, y; /* Upper left pixel (within image) + * that must be redisplayed. */ + int width, height; /* Dimensions of area to redisplay + * (may be <= 0). */ + int imgWidth, imgHeight; /* New dimensions of image. */ +{ + register TkMenu *menuPtr = ((TkMenuEntry *)clientData)->menuPtr; + + if ((menuPtr->tkwin != NULL) && !(menuPtr->menuFlags + & RESIZE_PENDING)) { + menuPtr->menuFlags |= RESIZE_PENDING; + Tcl_DoWhenIdle(ComputeMenuGeometry, (ClientData) menuPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * TkPostTearoffMenu -- + * + * Posts a menu on the screen. Used to post tearoff menus. On Unix, + * all menus are posted this way. Adjusts the menu's position + * so that it fits on the screen, and maps and raises the menu. + * + * Results: + * Returns a standard Tcl Error. + * + * Side effects: + * The menu is posted. + * + *---------------------------------------------------------------------- + */ + +int +TkPostTearoffMenu(interp, menuPtr, x, y) + Tcl_Interp *interp; /* The interpreter of the menu */ + TkMenu *menuPtr; /* The menu we are posting */ + int x; /* The root X coordinate where we + * are posting */ + int y; /* The root Y coordinate where we + * are posting */ +{ + int vRootX, vRootY, vRootWidth, vRootHeight; + int tmp, result; + + TkActivateMenuEntry(menuPtr, -1); + TkRecomputeMenu(menuPtr); + result = TkPostCommand(menuPtr); + if (result != TCL_OK) { + return result; + } + + /* + * The post commands could have deleted the menu, which means + * we are dead and should go away. + */ + + if (menuPtr->tkwin == NULL) { + return TCL_OK; + } + + /* + * Adjust the position of the menu if necessary to keep it + * visible on the screen. There are two special tricks to + * make this work right: + * + * 1. If a virtual root window manager is being used then + * the coordinates are in the virtual root window of + * menuPtr's parent; since the menu uses override-redirect + * mode it will be in the *real* root window for the screen, + * so we have to map the coordinates from the virtual root + * (if any) to the real root. Can't get the virtual root + * from the menu itself (it will never be seen by the wm) + * so use its parent instead (it would be better to have an + * an option that names a window to use for this...). + * 2. The menu may not have been mapped yet, so its current size + * might be the default 1x1. To compute how much space it + * needs, use its requested size, not its actual size. + * + * Note that this code assumes square screen regions and all + * positive coordinates. This does not work on a Mac with + * multiple monitors. But then again, Tk has other problems + * with this. + */ + + Tk_GetVRootGeometry(Tk_Parent(menuPtr->tkwin), &vRootX, &vRootY, + &vRootWidth, &vRootHeight); + x += vRootX; + y += vRootY; + tmp = WidthOfScreen(Tk_Screen(menuPtr->tkwin)) + - Tk_ReqWidth(menuPtr->tkwin); + if (x > tmp) { + x = tmp; + } + if (x < 0) { + x = 0; + } + tmp = HeightOfScreen(Tk_Screen(menuPtr->tkwin)) + - Tk_ReqHeight(menuPtr->tkwin); + if (y > tmp) { + y = tmp; + } + if (y < 0) { + y = 0; + } + Tk_MoveToplevelWindow(menuPtr->tkwin, x, y); + if (!Tk_IsMapped(menuPtr->tkwin)) { + Tk_MapWindow(menuPtr->tkwin); + } + TkWmRestackToplevel((TkWindow *) menuPtr->tkwin, Above, NULL); + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * TkPostSubmenu -- + * + * This procedure arranges for a particular submenu (i.e. the + * menu corresponding to a given cascade entry) to be + * posted. + * + * Results: + * A standard Tcl return result. Errors may occur in the + * Tcl commands generated to post and unpost submenus. + * + * Side effects: + * If there is already a submenu posted, it is unposted. + * The new submenu is then posted. + * + *-------------------------------------------------------------- + */ + +int +TkPostSubmenu(interp, menuPtr, mePtr) + Tcl_Interp *interp; /* Used for invoking sub-commands and + * reporting errors. */ + register TkMenu *menuPtr; /* Information about menu as a whole. */ + register TkMenuEntry *mePtr; /* Info about submenu that is to be + * posted. NULL means make sure that + * no submenu is posted. */ +{ + char string[30]; + int result, x, y; + + if (mePtr == menuPtr->postedCascade) { + return TCL_OK; + } + + if (menuPtr->postedCascade != NULL) { + + /* + * Note: when unposting a submenu, we have to redraw the entire + * parent menu. This is because of a combination of the following + * things: + * (a) the submenu partially overlaps the parent. + * (b) the submenu specifies "save under", which causes the X + * server to make a copy of the information under it when it + * is posted. When the submenu is unposted, the X server + * copies this data back and doesn't generate any Expose + * events for the parent. + * (c) the parent may have redisplayed itself after the submenu + * was posted, in which case the saved information is no + * longer correct. + * The simplest solution is just force a complete redisplay of + * the parent. + */ + + TkEventuallyRedrawMenu(menuPtr, (TkMenuEntry *) NULL); + result = Tcl_VarEval(interp, menuPtr->postedCascade->name, + " unpost", (char *) NULL); + menuPtr->postedCascade = NULL; + if (result != TCL_OK) { + return result; + } + } + + if ((mePtr != NULL) && (mePtr->name != 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 + * menu entry (this is an attempt to match Motif behavior). + * + * The menu has to redrawn so that the entry can change relief. + */ + + Tk_GetRootCoords(menuPtr->tkwin, &x, &y); + AdjustMenuCoords(menuPtr, mePtr, &x, &y, string); + result = Tcl_VarEval(interp, mePtr->name, " post ", string, + (char *) NULL); + if (result != TCL_OK) { + return result; + } + menuPtr->postedCascade = mePtr; + TkEventuallyRedrawMenu(menuPtr, mePtr); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * AdjustMenuCoords -- + * + * Adjusts the given coordinates down and the left to give a Motif + * look. + * + * Results: + * None. + * + * Side effects: + * The menu is eventually redrawn if necessary. + * + *---------------------------------------------------------------------- + */ + +static void +AdjustMenuCoords(menuPtr, mePtr, xPtr, yPtr, string) + TkMenu *menuPtr; + TkMenuEntry *mePtr; + int *xPtr; + int *yPtr; + char *string; +{ + if (menuPtr->menuType == MENUBAR) { + *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; + } + sprintf(string, "%d %d", *xPtr, *yPtr); +} diff --git a/generic/tkMenubutton.c b/generic/tkMenubutton.c new file mode 100644 index 0000000..ca2070e --- /dev/null +++ b/generic/tkMenubutton.c @@ -0,0 +1,865 @@ +/* + * tkMenubutton.c -- + * + * This module implements button-like widgets that are used + * to invoke pull-down menus. + * + * 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: @(#) tkMenubutton.c 1.94 97/07/31 09:10:37 + */ + +#include "tkMenubutton.h" +#include "tkPort.h" +#include "default.h" + +/* + * Uids internal to menubuttons. + */ + +static Tk_Uid aboveUid = NULL; +static Tk_Uid belowUid = NULL; +static Tk_Uid leftUid = NULL; +static Tk_Uid rightUid = NULL; +static Tk_Uid flushUid = NULL; + +/* + * Information used for parsing configuration specs: + */ + +static Tk_ConfigSpec configSpecs[] = { + {TK_CONFIG_BORDER, "-activebackground", "activeBackground", "Foreground", + DEF_MENUBUTTON_ACTIVE_BG_COLOR, Tk_Offset(TkMenuButton, activeBorder), + TK_CONFIG_COLOR_ONLY}, + {TK_CONFIG_BORDER, "-activebackground", "activeBackground", "Foreground", + DEF_MENUBUTTON_ACTIVE_BG_MONO, Tk_Offset(TkMenuButton, activeBorder), + TK_CONFIG_MONO_ONLY}, + {TK_CONFIG_COLOR, "-activeforeground", "activeForeground", "Background", + DEF_MENUBUTTON_ACTIVE_FG_COLOR, Tk_Offset(TkMenuButton, activeFg), + TK_CONFIG_COLOR_ONLY}, + {TK_CONFIG_COLOR, "-activeforeground", "activeForeground", "Background", + DEF_MENUBUTTON_ACTIVE_FG_MONO, Tk_Offset(TkMenuButton, activeFg), + TK_CONFIG_MONO_ONLY}, + {TK_CONFIG_ANCHOR, "-anchor", "anchor", "Anchor", + DEF_MENUBUTTON_ANCHOR, Tk_Offset(TkMenuButton, anchor), 0}, + {TK_CONFIG_BORDER, "-background", "background", "Background", + DEF_MENUBUTTON_BG_COLOR, Tk_Offset(TkMenuButton, normalBorder), + TK_CONFIG_COLOR_ONLY}, + {TK_CONFIG_BORDER, "-background", "background", "Background", + DEF_MENUBUTTON_BG_MONO, Tk_Offset(TkMenuButton, normalBorder), + 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_BITMAP, "-bitmap", "bitmap", "Bitmap", + DEF_MENUBUTTON_BITMAP, Tk_Offset(TkMenuButton, bitmap), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_PIXELS, "-borderwidth", "borderWidth", "BorderWidth", + DEF_MENUBUTTON_BORDER_WIDTH, Tk_Offset(TkMenuButton, borderWidth), 0}, + {TK_CONFIG_ACTIVE_CURSOR, "-cursor", "cursor", "Cursor", + DEF_MENUBUTTON_CURSOR, Tk_Offset(TkMenuButton, cursor), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_UID, "-direction", "direction", "Direction", + DEF_MENUBUTTON_DIRECTION, Tk_Offset(TkMenuButton, direction), + 0}, + {TK_CONFIG_COLOR, "-disabledforeground", "disabledForeground", + "DisabledForeground", DEF_MENUBUTTON_DISABLED_FG_COLOR, + Tk_Offset(TkMenuButton, disabledFg), + TK_CONFIG_COLOR_ONLY|TK_CONFIG_NULL_OK}, + {TK_CONFIG_COLOR, "-disabledforeground", "disabledForeground", + "DisabledForeground", DEF_MENUBUTTON_DISABLED_FG_MONO, + Tk_Offset(TkMenuButton, 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_MENUBUTTON_FONT, Tk_Offset(TkMenuButton, tkfont), 0}, + {TK_CONFIG_COLOR, "-foreground", "foreground", "Foreground", + DEF_MENUBUTTON_FG, Tk_Offset(TkMenuButton, normalFg), 0}, + {TK_CONFIG_STRING, "-height", "height", "Height", + DEF_MENUBUTTON_HEIGHT, Tk_Offset(TkMenuButton, heightString), 0}, + {TK_CONFIG_COLOR, "-highlightbackground", "highlightBackground", + "HighlightBackground", DEF_MENUBUTTON_HIGHLIGHT_BG, + Tk_Offset(TkMenuButton, highlightBgColorPtr), 0}, + {TK_CONFIG_COLOR, "-highlightcolor", "highlightColor", "HighlightColor", + DEF_MENUBUTTON_HIGHLIGHT, Tk_Offset(TkMenuButton, highlightColorPtr), + 0}, + {TK_CONFIG_PIXELS, "-highlightthickness", "highlightThickness", + "HighlightThickness", DEF_MENUBUTTON_HIGHLIGHT_WIDTH, + Tk_Offset(TkMenuButton, highlightWidth), 0}, + {TK_CONFIG_STRING, "-image", "image", "Image", + DEF_MENUBUTTON_IMAGE, Tk_Offset(TkMenuButton, imageString), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_BOOLEAN, "-indicatoron", "indicatorOn", "IndicatorOn", + DEF_MENUBUTTON_INDICATOR, Tk_Offset(TkMenuButton, indicatorOn), 0}, + {TK_CONFIG_JUSTIFY, "-justify", "justify", "Justify", + DEF_MENUBUTTON_JUSTIFY, Tk_Offset(TkMenuButton, justify), 0}, + {TK_CONFIG_STRING, "-menu", "menu", "Menu", + DEF_MENUBUTTON_MENU, Tk_Offset(TkMenuButton, menuName), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_PIXELS, "-padx", "padX", "Pad", + DEF_MENUBUTTON_PADX, Tk_Offset(TkMenuButton, padX), 0}, + {TK_CONFIG_PIXELS, "-pady", "padY", "Pad", + DEF_MENUBUTTON_PADY, Tk_Offset(TkMenuButton, padY), 0}, + {TK_CONFIG_RELIEF, "-relief", "relief", "Relief", + DEF_MENUBUTTON_RELIEF, Tk_Offset(TkMenuButton, relief), 0}, + {TK_CONFIG_UID, "-state", "state", "State", + DEF_MENUBUTTON_STATE, Tk_Offset(TkMenuButton, state), 0}, + {TK_CONFIG_STRING, "-takefocus", "takeFocus", "TakeFocus", + DEF_MENUBUTTON_TAKE_FOCUS, Tk_Offset(TkMenuButton, takeFocus), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-text", "text", "Text", + DEF_MENUBUTTON_TEXT, Tk_Offset(TkMenuButton, text), 0}, + {TK_CONFIG_STRING, "-textvariable", "textVariable", "Variable", + DEF_MENUBUTTON_TEXT_VARIABLE, Tk_Offset(TkMenuButton, textVarName), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_INT, "-underline", "underline", "Underline", + DEF_MENUBUTTON_UNDERLINE, Tk_Offset(TkMenuButton, underline), 0}, + {TK_CONFIG_STRING, "-width", "width", "Width", + DEF_MENUBUTTON_WIDTH, Tk_Offset(TkMenuButton, widthString), 0}, + {TK_CONFIG_PIXELS, "-wraplength", "wrapLength", "WrapLength", + DEF_MENUBUTTON_WRAP_LENGTH, Tk_Offset(TkMenuButton, wrapLength), 0}, + {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, 0} +}; + +/* + * Forward declarations for procedures defined later in this file: + */ + +static void MenuButtonCmdDeletedProc _ANSI_ARGS_(( + ClientData clientData)); +static void MenuButtonEventProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +static void MenuButtonImageProc _ANSI_ARGS_((ClientData clientData, + int x, int y, int width, int height, int imgWidth, + int imgHeight)); +static char * MenuButtonTextVarProc _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp, + char *name1, char *name2, int flags)); +static int MenuButtonWidgetCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static int ConfigureMenuButton _ANSI_ARGS_((Tcl_Interp *interp, + TkMenuButton *mbPtr, int argc, char **argv, + int flags)); +static void DestroyMenuButton _ANSI_ARGS_((char *memPtr)); + +/* + *-------------------------------------------------------------- + * + * Tk_MenubuttonCmd -- + * + * This procedure is invoked to process the "button", "label", + * "radiobutton", and "checkbutton" Tcl commands. See the + * user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +int +Tk_MenubuttonCmd(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. */ +{ + register TkMenuButton *mbPtr; + Tk_Window tkwin = (Tk_Window) clientData; + Tk_Window new; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " pathName ?options?\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * Create the new window. + */ + + new = Tk_CreateWindowFromPath(interp, tkwin, argv[1], (char *) NULL); + if (new == NULL) { + return TCL_ERROR; + } + + Tk_SetClass(new, "Menubutton"); + mbPtr = TkpCreateMenuButton(new); + + TkSetClassProcs(new, &tkpMenubuttonClass, (ClientData) mbPtr); + + /* + * Initialize the data structure for the button. + */ + + mbPtr->tkwin = new; + mbPtr->display = Tk_Display (new); + mbPtr->interp = interp; + mbPtr->widgetCmd = Tcl_CreateCommand(interp, Tk_PathName(mbPtr->tkwin), + MenuButtonWidgetCmd, (ClientData) mbPtr, MenuButtonCmdDeletedProc); + mbPtr->menuName = NULL; + mbPtr->text = NULL; + mbPtr->underline = -1; + mbPtr->textVarName = NULL; + mbPtr->bitmap = None; + mbPtr->imageString = NULL; + mbPtr->image = NULL; + mbPtr->state = tkNormalUid; + mbPtr->normalBorder = NULL; + mbPtr->activeBorder = NULL; + mbPtr->borderWidth = 0; + mbPtr->relief = TK_RELIEF_FLAT; + mbPtr->highlightWidth = 0; + mbPtr->highlightBgColorPtr = NULL; + mbPtr->highlightColorPtr = NULL; + mbPtr->inset = 0; + mbPtr->tkfont = NULL; + mbPtr->normalFg = NULL; + mbPtr->activeFg = NULL; + mbPtr->disabledFg = NULL; + mbPtr->normalTextGC = None; + mbPtr->activeTextGC = None; + mbPtr->gray = None; + mbPtr->disabledGC = None; + mbPtr->leftBearing = 0; + mbPtr->rightBearing = 0; + mbPtr->widthString = NULL; + mbPtr->heightString = NULL; + mbPtr->width = 0; + mbPtr->width = 0; + mbPtr->wrapLength = 0; + mbPtr->padX = 0; + mbPtr->padY = 0; + mbPtr->anchor = TK_ANCHOR_CENTER; + mbPtr->justify = TK_JUSTIFY_CENTER; + mbPtr->textLayout = NULL; + mbPtr->indicatorOn = 0; + mbPtr->indicatorWidth = 0; + mbPtr->indicatorHeight = 0; + mbPtr->cursor = None; + mbPtr->takeFocus = NULL; + mbPtr->flags = 0; + if (aboveUid == NULL) { + aboveUid = Tk_GetUid("above"); + belowUid = Tk_GetUid("below"); + leftUid = Tk_GetUid("left"); + rightUid = Tk_GetUid("right"); + flushUid = Tk_GetUid("flush"); + } + mbPtr->direction = flushUid; + + Tk_CreateEventHandler(mbPtr->tkwin, + ExposureMask|StructureNotifyMask|FocusChangeMask, + MenuButtonEventProc, (ClientData) mbPtr); + if (ConfigureMenuButton(interp, mbPtr, argc-2, argv+2, 0) != TCL_OK) { + Tk_DestroyWindow(mbPtr->tkwin); + return TCL_ERROR; + } + + interp->result = Tk_PathName(mbPtr->tkwin); + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * MenuButtonWidgetCmd -- + * + * This procedure is invoked to process the Tcl command + * that corresponds to a widget managed by this module. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +static int +MenuButtonWidgetCmd(clientData, interp, argc, argv) + ClientData clientData; /* Information about button widget. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + register TkMenuButton *mbPtr = (TkMenuButton *) clientData; + int result; + size_t length; + int c; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option ?arg arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_Preserve((ClientData) mbPtr); + 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); + result = TCL_ERROR; + } else { + result = Tk_ConfigureValue(interp, mbPtr->tkwin, configSpecs, + (char *) mbPtr, argv[2], 0); + } + } else if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0) + && (length >= 2)) { + if (argc == 2) { + result = Tk_ConfigureInfo(interp, mbPtr->tkwin, configSpecs, + (char *) mbPtr, (char *) NULL, 0); + } else if (argc == 3) { + result = Tk_ConfigureInfo(interp, mbPtr->tkwin, configSpecs, + (char *) mbPtr, argv[2], 0); + } else { + result = ConfigureMenuButton(interp, mbPtr, argc-2, argv+2, + TK_CONFIG_ARGV_ONLY); + } + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be cget or configure", + (char *) NULL); + result = TCL_ERROR; + } + Tcl_Release((ClientData) mbPtr); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * DestroyMenuButton -- + * + * This procedure is invoked to recycle all of the resources + * associated with a button widget. It is invoked as a + * when-idle handler in order to make sure that there is no + * other use of the button pending at the time of the deletion. + * + * Results: + * None. + * + * Side effects: + * Everything associated with the widget is freed up. + * + *---------------------------------------------------------------------- + */ + +static void +DestroyMenuButton(memPtr) + char *memPtr; /* Info about button widget. */ +{ + register TkMenuButton *mbPtr = (TkMenuButton *) memPtr; + + /* + * Free up all the stuff that requires special handling, then + * let Tk_FreeOptions handle all the standard option-related + * stuff. + */ + + if (mbPtr->textVarName != NULL) { + Tcl_UntraceVar(mbPtr->interp, mbPtr->textVarName, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + MenuButtonTextVarProc, (ClientData) mbPtr); + } + if (mbPtr->image != NULL) { + Tk_FreeImage(mbPtr->image); + } + if (mbPtr->normalTextGC != None) { + Tk_FreeGC(mbPtr->display, mbPtr->normalTextGC); + } + if (mbPtr->activeTextGC != None) { + Tk_FreeGC(mbPtr->display, mbPtr->activeTextGC); + } + if (mbPtr->gray != None) { + Tk_FreeBitmap(mbPtr->display, mbPtr->gray); + } + if (mbPtr->disabledGC != None) { + Tk_FreeGC(mbPtr->display, mbPtr->disabledGC); + } + Tk_FreeTextLayout(mbPtr->textLayout); + Tk_FreeOptions(configSpecs, (char *) mbPtr, mbPtr->display, 0); + ckfree((char *) mbPtr); +} + +/* + *---------------------------------------------------------------------- + * + * ConfigureMenuButton -- + * + * This procedure is called to process an argv/argc list, plus + * the Tk option database, in order to configure (or + * reconfigure) a menubutton widget. + * + * Results: + * The return value is a standard Tcl result. If TCL_ERROR is + * returned, then interp->result contains an error message. + * + * Side effects: + * Configuration information, such as text string, colors, font, + * etc. get set for mbPtr; old resources get freed, if there + * were any. The menubutton is redisplayed. + * + *---------------------------------------------------------------------- + */ + +static int +ConfigureMenuButton(interp, mbPtr, argc, argv, flags) + Tcl_Interp *interp; /* Used for error reporting. */ + register TkMenuButton *mbPtr; /* 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 result; + Tk_Image image; + + /* + * Eliminate any existing trace on variables monitored by the menubutton. + */ + + if (mbPtr->textVarName != NULL) { + Tcl_UntraceVar(interp, mbPtr->textVarName, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + MenuButtonTextVarProc, (ClientData) mbPtr); + } + + result = Tk_ConfigureWidget(interp, mbPtr->tkwin, configSpecs, + argc, argv, (char *) mbPtr, flags); + if (result != 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. + */ + + if ((mbPtr->state == tkActiveUid) && !Tk_StrictMotif(mbPtr->tkwin)) { + Tk_SetBackgroundFromBorder(mbPtr->tkwin, mbPtr->activeBorder); + } else { + Tk_SetBackgroundFromBorder(mbPtr->tkwin, mbPtr->normalBorder); + if ((mbPtr->state != tkNormalUid) && (mbPtr->state != tkActiveUid) + && (mbPtr->state != tkDisabledUid)) { + Tcl_AppendResult(interp, "bad state value \"", mbPtr->state, + "\": must be normal, active, or disabled", (char *) NULL); + mbPtr->state = tkNormalUid; + return TCL_ERROR; + } + } + + if ((mbPtr->direction != aboveUid) && (mbPtr->direction != belowUid) + && (mbPtr->direction != leftUid) && (mbPtr->direction != rightUid) + && (mbPtr->direction != flushUid)) { + Tcl_AppendResult(interp, "bad direction value \"", mbPtr->direction, + "\": must be above, below, left, right, or flush", + (char *) NULL); + mbPtr->direction = belowUid; + return TCL_ERROR; + } + + if (mbPtr->highlightWidth < 0) { + mbPtr->highlightWidth = 0; + } + + if (mbPtr->padX < 0) { + mbPtr->padX = 0; + } + if (mbPtr->padY < 0) { + mbPtr->padY = 0; + } + + /* + * Get the image for the widget, if there is one. Allocate the + * new image before freeing the old one, so that the reference + * count doesn't go to zero and cause image data to be discarded. + */ + + if (mbPtr->imageString != NULL) { + image = Tk_GetImage(mbPtr->interp, mbPtr->tkwin, + mbPtr->imageString, MenuButtonImageProc, (ClientData) mbPtr); + if (image == NULL) { + return TCL_ERROR; + } + } else { + image = NULL; + } + if (mbPtr->image != NULL) { + Tk_FreeImage(mbPtr->image); + } + mbPtr->image = image; + + if ((mbPtr->image == NULL) && (mbPtr->bitmap == None) + && (mbPtr->textVarName != NULL)) { + /* + * The menubutton displays a variable. Set up a trace to watch + * for any changes in it. + */ + + char *value; + + value = Tcl_GetVar(interp, mbPtr->textVarName, TCL_GLOBAL_ONLY); + if (value == NULL) { + Tcl_SetVar(interp, mbPtr->textVarName, mbPtr->text, + TCL_GLOBAL_ONLY); + } else { + if (mbPtr->text != NULL) { + ckfree(mbPtr->text); + } + mbPtr->text = (char *) ckalloc((unsigned) (strlen(value) + 1)); + strcpy(mbPtr->text, value); + } + Tcl_TraceVar(interp, mbPtr->textVarName, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + MenuButtonTextVarProc, (ClientData) mbPtr); + } + + /* + * Recompute the geometry for the button. + */ + + if ((mbPtr->bitmap != None) || (mbPtr->image != NULL)) { + if (Tk_GetPixels(interp, mbPtr->tkwin, mbPtr->widthString, + &mbPtr->width) != TCL_OK) { + widthError: + Tcl_AddErrorInfo(interp, "\n (processing -width option)"); + return TCL_ERROR; + } + if (Tk_GetPixels(interp, mbPtr->tkwin, mbPtr->heightString, + &mbPtr->height) != TCL_OK) { + heightError: + Tcl_AddErrorInfo(interp, "\n (processing -height option)"); + return TCL_ERROR; + } + } else { + if (Tcl_GetInt(interp, mbPtr->widthString, &mbPtr->width) + != TCL_OK) { + goto widthError; + } + if (Tcl_GetInt(interp, mbPtr->heightString, &mbPtr->height) + != TCL_OK) { + goto heightError; + } + } + TkMenuButtonWorldChanged((ClientData) mbPtr); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * TkMenuButtonWorldChanged -- + * + * This procedure is called when the world has changed in some + * way and the widget needs to recompute all its graphics contexts + * and determine its new geometry. + * + * Results: + * None. + * + * Side effects: + * TkMenuButton will be relayed out and redisplayed. + * + *--------------------------------------------------------------------------- + */ + +void +TkMenuButtonWorldChanged(instanceData) + ClientData instanceData; /* Information about widget. */ +{ + XGCValues gcValues; + GC gc; + unsigned long mask; + TkMenuButton *mbPtr; + + mbPtr = (TkMenuButton *) instanceData; + + gcValues.font = Tk_FontId(mbPtr->tkfont); + gcValues.foreground = mbPtr->normalFg->pixel; + gcValues.background = Tk_3DBorderColor(mbPtr->normalBorder)->pixel; + + /* + * Note: GraphicsExpose events are disabled in GC's because they're + * used to copy stuff from an off-screen pixmap onto the screen (we know + * that there's no problem with obscured areas). + */ + + gcValues.graphics_exposures = False; + mask = GCForeground | GCBackground | GCFont | GCGraphicsExposures; + gc = Tk_GetGC(mbPtr->tkwin, mask, &gcValues); + if (mbPtr->normalTextGC != None) { + Tk_FreeGC(mbPtr->display, mbPtr->normalTextGC); + } + mbPtr->normalTextGC = gc; + + gcValues.font = Tk_FontId(mbPtr->tkfont); + gcValues.foreground = mbPtr->activeFg->pixel; + gcValues.background = Tk_3DBorderColor(mbPtr->activeBorder)->pixel; + mask = GCForeground | GCBackground | GCFont; + gc = Tk_GetGC(mbPtr->tkwin, mask, &gcValues); + if (mbPtr->activeTextGC != None) { + Tk_FreeGC(mbPtr->display, mbPtr->activeTextGC); + } + mbPtr->activeTextGC = gc; + + gcValues.font = Tk_FontId(mbPtr->tkfont); + gcValues.background = Tk_3DBorderColor(mbPtr->normalBorder)->pixel; + if ((mbPtr->disabledFg != NULL) && (mbPtr->imageString == NULL)) { + gcValues.foreground = mbPtr->disabledFg->pixel; + mask = GCForeground | GCBackground | GCFont; + } else { + gcValues.foreground = gcValues.background; + mask = GCForeground; + if (mbPtr->gray == None) { + mbPtr->gray = Tk_GetBitmap(NULL, mbPtr->tkwin, + Tk_GetUid("gray50")); + } + if (mbPtr->gray != None) { + gcValues.fill_style = FillStippled; + gcValues.stipple = mbPtr->gray; + mask |= GCFillStyle | GCStipple; + } + } + gc = Tk_GetGC(mbPtr->tkwin, mask, &gcValues); + if (mbPtr->disabledGC != None) { + Tk_FreeGC(mbPtr->display, mbPtr->disabledGC); + } + mbPtr->disabledGC = gc; + + TkpComputeMenuButtonGeometry(mbPtr); + + /* + * Lastly, arrange for the button to be redisplayed. + */ + + if (Tk_IsMapped(mbPtr->tkwin) && !(mbPtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(TkpDisplayMenuButton, (ClientData) mbPtr); + mbPtr->flags |= REDRAW_PENDING; + } +} + +/* + *-------------------------------------------------------------- + * + * MenuButtonEventProc -- + * + * This procedure is invoked by the Tk dispatcher for various + * events on buttons. + * + * Results: + * None. + * + * Side effects: + * When the window gets deleted, internal structures get + * cleaned up. When it gets exposed, it is redisplayed. + * + *-------------------------------------------------------------- + */ + +static void +MenuButtonEventProc(clientData, eventPtr) + ClientData clientData; /* Information about window. */ + XEvent *eventPtr; /* Information about event. */ +{ + TkMenuButton *mbPtr = (TkMenuButton *) clientData; + if ((eventPtr->type == Expose) && (eventPtr->xexpose.count == 0)) { + goto redraw; + } else if (eventPtr->type == ConfigureNotify) { + /* + * Must redraw after size changes, since layout could have changed + * and borders will need to be redrawn. + */ + + goto redraw; + } else if (eventPtr->type == DestroyNotify) { + TkpDestroyMenuButton(mbPtr); + if (mbPtr->tkwin != NULL) { + mbPtr->tkwin = NULL; + Tcl_DeleteCommandFromToken(mbPtr->interp, mbPtr->widgetCmd); + } + if (mbPtr->flags & REDRAW_PENDING) { + Tcl_CancelIdleCall(TkpDisplayMenuButton, (ClientData) mbPtr); + } + Tcl_EventuallyFree((ClientData) mbPtr, DestroyMenuButton); + } else if (eventPtr->type == FocusIn) { + if (eventPtr->xfocus.detail != NotifyInferior) { + mbPtr->flags |= GOT_FOCUS; + if (mbPtr->highlightWidth > 0) { + goto redraw; + } + } + } else if (eventPtr->type == FocusOut) { + if (eventPtr->xfocus.detail != NotifyInferior) { + mbPtr->flags &= ~GOT_FOCUS; + if (mbPtr->highlightWidth > 0) { + goto redraw; + } + } + } + return; + + redraw: + if ((mbPtr->tkwin != NULL) && !(mbPtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(TkpDisplayMenuButton, (ClientData) mbPtr); + mbPtr->flags |= REDRAW_PENDING; + } +} + +/* + *---------------------------------------------------------------------- + * + * MenuButtonCmdDeletedProc -- + * + * 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 +MenuButtonCmdDeletedProc(clientData) + ClientData clientData; /* Pointer to widget record for widget. */ +{ + TkMenuButton *mbPtr = (TkMenuButton *) clientData; + Tk_Window tkwin = mbPtr->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. + */ + + if (tkwin != NULL) { + mbPtr->tkwin = NULL; + Tk_DestroyWindow(tkwin); + } +} + +/* + *-------------------------------------------------------------- + * + * MenuButtonTextVarProc -- + * + * This procedure is invoked when someone changes the variable + * whose contents are to be displayed in a menu button. + * + * Results: + * NULL is always returned. + * + * Side effects: + * The text displayed in the menu button will change to match the + * variable. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static char * +MenuButtonTextVarProc(clientData, interp, name1, name2, flags) + ClientData clientData; /* Information about button. */ + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *name1; /* Name of variable. */ + char *name2; /* Second part of variable name. */ + int flags; /* Information about what happened. */ +{ + register TkMenuButton *mbPtr = (TkMenuButton *) clientData; + char *value; + + /* + * If the variable is unset, then immediately recreate it unless + * the whole interpreter is going away. + */ + + if (flags & TCL_TRACE_UNSETS) { + if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) { + Tcl_SetVar(interp, mbPtr->textVarName, mbPtr->text, + TCL_GLOBAL_ONLY); + Tcl_TraceVar(interp, mbPtr->textVarName, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + MenuButtonTextVarProc, clientData); + } + return (char *) NULL; + } + + value = Tcl_GetVar(interp, mbPtr->textVarName, TCL_GLOBAL_ONLY); + if (value == NULL) { + value = ""; + } + if (mbPtr->text != NULL) { + ckfree(mbPtr->text); + } + mbPtr->text = (char *) ckalloc((unsigned) (strlen(value) + 1)); + strcpy(mbPtr->text, value); + TkpComputeMenuButtonGeometry(mbPtr); + + if ((mbPtr->tkwin != NULL) && Tk_IsMapped(mbPtr->tkwin) + && !(mbPtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(TkpDisplayMenuButton, (ClientData) mbPtr); + mbPtr->flags |= REDRAW_PENDING; + } + return (char *) NULL; +} + +/* + *---------------------------------------------------------------------- + * + * MenuButtonImageProc -- + * + * This procedure is invoked by the image code whenever the manager + * for an image does something that affects the size of contents + * of an image displayed in a button. + * + * Results: + * None. + * + * Side effects: + * Arranges for the button to get redisplayed. + * + *---------------------------------------------------------------------- + */ + +static void +MenuButtonImageProc(clientData, x, y, width, height, imgWidth, imgHeight) + ClientData clientData; /* Pointer to widget record. */ + int x, y; /* Upper left pixel (within image) + * that must be redisplayed. */ + int width, height; /* Dimensions of area to redisplay + * (may be <= 0). */ + int imgWidth, imgHeight; /* New dimensions of image. */ +{ + register TkMenuButton *mbPtr = (TkMenuButton *) clientData; + + if (mbPtr->tkwin != NULL) { + TkpComputeMenuButtonGeometry(mbPtr); + if (Tk_IsMapped(mbPtr->tkwin) && !(mbPtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(TkpDisplayMenuButton, (ClientData) mbPtr); + mbPtr->flags |= REDRAW_PENDING; + } + } +} diff --git a/generic/tkMenubutton.h b/generic/tkMenubutton.h new file mode 100644 index 0000000..0fb0f65 --- /dev/null +++ b/generic/tkMenubutton.h @@ -0,0 +1,207 @@ +/* + * tkMenubutton.h -- + * + * Declarations of types and functions used to implement + * the menubutton widget. + * + * Copyright (c) 1996-1997 by Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkMenubutton.h 1.3 97/04/11 11:24:15 + */ + +#ifndef _TKMENUBUTTON +#define _TKMENUBUTTON + +#ifndef _TKINT +#include "tkInt.h" +#endif + +/* + * A data structure of the following type is kept for each + * widget managed by this file: + */ + +typedef struct { + Tk_Window tkwin; /* Window that embodies the widget. NULL + * means that the window has been destroyed + * but the data structures haven't yet been + * cleaned up.*/ + Display *display; /* Display containing widget. Needed, among + * other things, so that resources can bee + * freed up even after tkwin has gone away. */ + Tcl_Interp *interp; /* Interpreter associated with menubutton. */ + Tcl_Command widgetCmd; /* Token for menubutton's widget command. */ + char *menuName; /* Name of menu associated with widget. + * Malloc-ed. */ + + /* + * Information about what's displayed in the menu button: + */ + + char *text; /* Text to display in button (malloc'ed) + * or NULL. */ + int underline; /* Index of character to underline. */ + 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 and underline + * 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. */ + + /* + * 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. + * <= 0 means don't draw a highlight. */ + XColor *highlightBgColorPtr; + /* Color for drawing traversal highlight + * area when highlight is off. */ + XColor *highlightColorPtr; /* 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 + * means use normalFg with a 50% stipple + * instead. */ + GC normalTextGC; /* GC for drawing text in normal mode. */ + GC activeTextGC; /* GC for drawing text in active mode (NULL + * means use normalTextGC). */ + Pixmap gray; /* Pixmap for displaying disabled text/icon 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. */ + int leftBearing; /* Distance from text origin to leftmost drawn + * pixel (positive means to right). */ + int rightBearing; /* Amount text sticks right from its origin. */ + 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 + * onto next line. <= 0 means don't wrap + * except at newlines. */ + int padX, padY; /* Extra space around text or bitmap (pixels + * on each side). */ + Tk_Anchor anchor; /* Where text/bitmap should be displayed + * inside window region. */ + Tk_Justify justify; /* Justification to use for multi-line text. */ + int textWidth; /* Width needed to display text as requested, + * in pixels. */ + int textHeight; /* Height needed to display text as requested, + * in pixels. */ + Tk_TextLayout textLayout; /* Saved text layout information. */ + int indicatorOn; /* Non-zero means display indicator; 0 means + * don't display. */ + int indicatorHeight; /* Height of indicator in pixels. This same + * amount of extra space is also left on each + * side of the indicator. 0 if no indicator. */ + int indicatorWidth; /* Width of indicator in pixels, including + * indicatorHeight in padding on each side. + * 0 if no indicator. */ + + /* + * Miscellaneous information: + */ + + Tk_Uid direction; /* Direction for where to pop the menu. + * Valid directions are "above", "below", + * "left", "right", and "flush". "flush" + * means that the upper left corner of the + * menubutton is where the menu pops up. + * "above" and "below" will attempt to pop + * the menu compleletly above or below + * the menu respectively. + * "left" and "right" will pop the menu + * left or right, and the active item + * will be next to the button. */ + Tk_Cursor cursor; /* Current cursor for window, or None. */ + char *takeFocus; /* Value of -takefocus option; not used in + * the C code, but used by keyboard traversal + * scripts. Malloc'ed, but may be NULL. */ + int flags; /* Various flags; see below for + * definitions. */ +} TkMenuButton; + +/* + * Flag bits for buttons: + * + * REDRAW_PENDING: Non-zero means a DoWhenIdle handler + * has already been queued to redraw + * this window. + * POSTED: Non-zero means that the menu associated + * with this button has been posted (typically + * because of an active button press). + * GOT_FOCUS: Non-zero means this button currently + * has the input focus. + */ + +#define REDRAW_PENDING 1 +#define POSTED 2 +#define GOT_FOCUS 4 + +/* + * The following constants define the dimensions of the cascade indicator, + * which is displayed if the "-indicatoron" option is true. The units for + * these options are 1/10 millimeters. + */ + +#define INDICATOR_WIDTH 40 +#define INDICATOR_HEIGHT 17 + +/* + * Declaration of variables shared between the files in the button module. + */ + +extern TkClassProcs tkpMenubuttonClass; + +/* + * Declaration of procedures used in the implementation of the button + * widget. + */ + +EXTERN void TkpComputeMenuButtonGeometry _ANSI_ARGS_(( + TkMenuButton *mbPtr)); +EXTERN TkMenuButton * TkpCreateMenuButton _ANSI_ARGS_((Tk_Window tkwin)); +EXTERN void TkpDisplayMenuButton _ANSI_ARGS_(( + ClientData clientData)); +EXTERN void TkpDestroyMenuButton _ANSI_ARGS_(( + TkMenuButton *mbPtr)); +EXTERN void TkMenuButtonWorldChanged _ANSI_ARGS_(( + ClientData instanceData)); + +#endif /* _TKMENUBUTTON */ diff --git a/generic/tkMessage.c b/generic/tkMessage.c new file mode 100644 index 0000000..1984bac --- /dev/null +++ b/generic/tkMessage.c @@ -0,0 +1,848 @@ +/* + * tkMessage.c -- + * + * This module implements a message widgets for the Tk + * toolkit. A message widget displays a multi-line string + * 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. + * + * 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 + */ + +#include "tkPort.h" +#include "default.h" +#include "tkInt.h" + +/* + * A data structure of the following type is kept for each message + * widget managed by this file: + */ + +typedef struct { + Tk_Window tkwin; /* Window that embodies the message. NULL + * means that the window has been destroyed + * but the data structures haven't yet been + * cleaned up.*/ + Display *display; /* Display containing widget. Used, among + * other things, so that resources can be + * freed even after tkwin has gone away. */ + Tcl_Interp *interp; /* Interpreter associated with message. */ + Tcl_Command widgetCmd; /* Token for message's widget command. */ + + /* + * Information used when displaying widget: + */ + + char *string; /* String displayed in message. */ + int numChars; /* Number of characters in string, not + * including terminating NULL character. */ + char *textVarName; /* Name of variable (malloc'ed) or NULL. + * If non-NULL, message displays the contents + * of this variable. */ + Tk_3DBorder border; /* Structure used to draw 3-D border and + * background. NULL means a border hasn't + * been created yet. */ + 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. + * <= 0 means don't draw a highlight. */ + XColor *highlightBgColorPtr; + /* Color for drawing traversal highlight + * area when highlight is off. */ + XColor *highlightColorPtr; /* Color for drawing traversal highlight. */ + Tk_Font tkfont; /* Information about text font, or NULL. */ + XColor *fgColorPtr; /* Foreground color in normal mode. */ + int padX, padY; /* User-requested extra space around text. */ + int width; /* User-requested width, in pixels. 0 means + * compute width using aspect ratio below. */ + int aspect; /* Desired aspect ratio for window + * (100*width/height). */ + int msgWidth; /* Width in pixels needed to display + * message. */ + int msgHeight; /* Height in pixels needed to display + * message. */ + Tk_Anchor anchor; /* Where to position text within window region + * if window is larger or smaller than + * needed. */ + Tk_Justify justify; /* Justification for text. */ + + GC textGC; /* GC for drawing text in normal mode. */ + Tk_TextLayout textLayout; /* Saved layout information. */ + + /* + * Miscellaneous information: + */ + + Tk_Cursor cursor; /* Current cursor for window, or None. */ + char *takeFocus; /* Value of -takefocus option; not used in + * the C code, but used by keyboard traversal + * scripts. Malloc'ed, but may be NULL. */ + int flags; /* Various flags; see below for + * definitions. */ +} Message; + +/* + * Flag bits for messages: + * + * REDRAW_PENDING: Non-zero means a DoWhenIdle handler + * has already been queued to redraw + * this window. + * GOT_FOCUS: Non-zero means this button currently + * has the input focus. + */ + +#define REDRAW_PENDING 1 +#define GOT_FOCUS 4 + +/* + * Information used for argv parsing. + */ + +static Tk_ConfigSpec configSpecs[] = { + {TK_CONFIG_ANCHOR, "-anchor", "anchor", "Anchor", + DEF_MESSAGE_ANCHOR, Tk_Offset(Message, anchor), 0}, + {TK_CONFIG_INT, "-aspect", "aspect", "Aspect", + DEF_MESSAGE_ASPECT, Tk_Offset(Message, aspect), 0}, + {TK_CONFIG_BORDER, "-background", "background", "Background", + DEF_MESSAGE_BG_COLOR, Tk_Offset(Message, border), + TK_CONFIG_COLOR_ONLY}, + {TK_CONFIG_BORDER, "-background", "background", "Background", + DEF_MESSAGE_BG_MONO, Tk_Offset(Message, 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_MESSAGE_BORDER_WIDTH, Tk_Offset(Message, borderWidth), 0}, + {TK_CONFIG_ACTIVE_CURSOR, "-cursor", "cursor", "Cursor", + DEF_MESSAGE_CURSOR, Tk_Offset(Message, cursor), TK_CONFIG_NULL_OK}, + {TK_CONFIG_SYNONYM, "-fg", "foreground", (char *) NULL, + (char *) NULL, 0, 0}, + {TK_CONFIG_FONT, "-font", "font", "Font", + DEF_MESSAGE_FONT, Tk_Offset(Message, tkfont), 0}, + {TK_CONFIG_COLOR, "-foreground", "foreground", "Foreground", + DEF_MESSAGE_FG, Tk_Offset(Message, fgColorPtr), 0}, + {TK_CONFIG_COLOR, "-highlightbackground", "highlightBackground", + "HighlightBackground", DEF_MESSAGE_HIGHLIGHT_BG, + Tk_Offset(Message, highlightBgColorPtr), 0}, + {TK_CONFIG_COLOR, "-highlightcolor", "highlightColor", "HighlightColor", + DEF_MESSAGE_HIGHLIGHT, Tk_Offset(Message, highlightColorPtr), 0}, + {TK_CONFIG_PIXELS, "-highlightthickness", "highlightThickness", + "HighlightThickness", + DEF_MESSAGE_HIGHLIGHT_WIDTH, Tk_Offset(Message, highlightWidth), 0}, + {TK_CONFIG_JUSTIFY, "-justify", "justify", "Justify", + DEF_MESSAGE_JUSTIFY, Tk_Offset(Message, justify), 0}, + {TK_CONFIG_PIXELS, "-padx", "padX", "Pad", + DEF_MESSAGE_PADX, Tk_Offset(Message, padX), 0}, + {TK_CONFIG_PIXELS, "-pady", "padY", "Pad", + DEF_MESSAGE_PADY, Tk_Offset(Message, padY), 0}, + {TK_CONFIG_RELIEF, "-relief", "relief", "Relief", + DEF_MESSAGE_RELIEF, Tk_Offset(Message, relief), 0}, + {TK_CONFIG_STRING, "-takefocus", "takeFocus", "TakeFocus", + DEF_MESSAGE_TAKE_FOCUS, Tk_Offset(Message, takeFocus), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-text", "text", "Text", + DEF_MESSAGE_TEXT, Tk_Offset(Message, string), 0}, + {TK_CONFIG_STRING, "-textvariable", "textVariable", "Variable", + DEF_MESSAGE_TEXT_VARIABLE, Tk_Offset(Message, textVarName), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_PIXELS, "-width", "width", "Width", + DEF_MESSAGE_WIDTH, Tk_Offset(Message, width), 0}, + {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, 0} +}; + +/* + * Forward declarations for procedures defined later in this file: + */ + +static void MessageCmdDeletedProc _ANSI_ARGS_(( + ClientData clientData)); +static void MessageEventProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +static char * MessageTextVarProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, char *name1, char *name2, + int flags)); +static int MessageWidgetCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static void MessageWorldChanged _ANSI_ARGS_(( + ClientData instanceData)); +static void ComputeMessageGeometry _ANSI_ARGS_((Message *msgPtr)); +static int ConfigureMessage _ANSI_ARGS_((Tcl_Interp *interp, + Message *msgPtr, int argc, char **argv, + int flags)); +static void DestroyMessage _ANSI_ARGS_((char *memPtr)); +static void DisplayMessage _ANSI_ARGS_((ClientData clientData)); + +/* + * The structure below defines message class behavior by means of procedures + * that can be invoked from generic window code. + */ + +static TkClassProcs messageClass = { + NULL, /* createProc. */ + MessageWorldChanged, /* geometryProc. */ + NULL /* modalProc. */ +}; + + +/* + *-------------------------------------------------------------- + * + * Tk_MessageCmd -- + * + * This procedure is invoked to process the "message" 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_MessageCmd(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. */ +{ + register Message *msgPtr; + Tk_Window new; + Tk_Window tkwin = (Tk_Window) clientData; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " pathName ?options?\"", (char *) NULL); + return TCL_ERROR; + } + + new = Tk_CreateWindowFromPath(interp, tkwin, argv[1], (char *) NULL); + if (new == NULL) { + return TCL_ERROR; + } + + msgPtr = (Message *) ckalloc(sizeof(Message)); + msgPtr->tkwin = new; + msgPtr->display = Tk_Display(new); + msgPtr->interp = interp; + msgPtr->widgetCmd = Tcl_CreateCommand(interp, Tk_PathName(msgPtr->tkwin), + MessageWidgetCmd, (ClientData) msgPtr, MessageCmdDeletedProc); + msgPtr->textLayout = NULL; + msgPtr->string = NULL; + msgPtr->numChars = 0; + msgPtr->textVarName = NULL; + msgPtr->border = NULL; + msgPtr->borderWidth = 0; + msgPtr->relief = TK_RELIEF_FLAT; + msgPtr->highlightWidth = 0; + msgPtr->highlightBgColorPtr = NULL; + msgPtr->highlightColorPtr = NULL; + msgPtr->tkfont = NULL; + msgPtr->fgColorPtr = NULL; + msgPtr->textGC = None; + msgPtr->padX = 0; + msgPtr->padY = 0; + msgPtr->anchor = TK_ANCHOR_CENTER; + msgPtr->width = 0; + msgPtr->aspect = 150; + msgPtr->msgWidth = 0; + msgPtr->msgHeight = 0; + msgPtr->justify = TK_JUSTIFY_LEFT; + msgPtr->cursor = None; + msgPtr->takeFocus = NULL; + msgPtr->flags = 0; + + Tk_SetClass(msgPtr->tkwin, "Message"); + TkSetClassProcs(msgPtr->tkwin, &messageClass, (ClientData) msgPtr); + Tk_CreateEventHandler(msgPtr->tkwin, + ExposureMask|StructureNotifyMask|FocusChangeMask, + MessageEventProc, (ClientData) msgPtr); + if (ConfigureMessage(interp, msgPtr, argc-2, argv+2, 0) != TCL_OK) { + goto error; + } + + interp->result = Tk_PathName(msgPtr->tkwin); + return TCL_OK; + + error: + Tk_DestroyWindow(msgPtr->tkwin); + return TCL_ERROR; +} + +/* + *-------------------------------------------------------------- + * + * MessageWidgetCmd -- + * + * This procedure is invoked to process the Tcl command + * that corresponds to a widget managed by this module. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +static int +MessageWidgetCmd(clientData, interp, argc, argv) + ClientData clientData; /* Information about message widget. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + register Message *msgPtr = (Message *) clientData; + size_t length; + int c; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option ?arg arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + 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); + return TCL_ERROR; + } + return Tk_ConfigureValue(interp, msgPtr->tkwin, configSpecs, + (char *) msgPtr, argv[2], 0); + } else if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0) + && (length >= 2)) { + if (argc == 2) { + return Tk_ConfigureInfo(interp, msgPtr->tkwin, configSpecs, + (char *) msgPtr, (char *) NULL, 0); + } else if (argc == 3) { + return Tk_ConfigureInfo(interp, msgPtr->tkwin, configSpecs, + (char *) msgPtr, argv[2], 0); + } else { + return ConfigureMessage(interp, msgPtr, argc-2, argv+2, + TK_CONFIG_ARGV_ONLY); + } + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be cget or configure", (char *) NULL); + return TCL_ERROR; + } +} + +/* + *---------------------------------------------------------------------- + * + * DestroyMessage -- + * + * This procedure is invoked by Tcl_EventuallyFree or Tcl_Release + * to clean up the internal structure of a message at a safe time + * (when no-one is using it anymore). + * + * Results: + * None. + * + * Side effects: + * Everything associated with the message is freed up. + * + *---------------------------------------------------------------------- + */ + +static void +DestroyMessage(memPtr) + char *memPtr; /* Info about message widget. */ +{ + register Message *msgPtr = (Message *) memPtr; + + /* + * Free up all the stuff that requires special handling, then + * let Tk_FreeOptions handle all the standard option-related + * stuff. + */ + + Tk_FreeTextLayout(msgPtr->textLayout); + if (msgPtr->textVarName != NULL) { + Tcl_UntraceVar(msgPtr->interp, msgPtr->textVarName, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + MessageTextVarProc, (ClientData) msgPtr); + } + if (msgPtr->textGC != None) { + Tk_FreeGC(msgPtr->display, msgPtr->textGC); + } + Tk_FreeOptions(configSpecs, (char *) msgPtr, msgPtr->display, 0); + ckfree((char *) msgPtr); +} + +/* + *---------------------------------------------------------------------- + * + * ConfigureMessage -- + * + * This procedure is called to process an argv/argc list, plus + * the Tk option database, in order to configure (or + * reconfigure) a message widget. + * + * Results: + * The return value is a standard Tcl result. If TCL_ERROR is + * returned, then interp->result contains an error message. + * + * Side effects: + * Configuration information, such as text string, colors, font, + * etc. get set for msgPtr; old resources get freed, if there + * were any. + * + *---------------------------------------------------------------------- + */ + +static int +ConfigureMessage(interp, msgPtr, argc, argv, flags) + Tcl_Interp *interp; /* Used for error reporting. */ + register Message *msgPtr; /* 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. */ +{ + /* + * Eliminate any existing trace on a variable monitored by the message. + */ + + if (msgPtr->textVarName != NULL) { + Tcl_UntraceVar(interp, msgPtr->textVarName, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + MessageTextVarProc, (ClientData) msgPtr); + } + + if (Tk_ConfigureWidget(interp, msgPtr->tkwin, configSpecs, + argc, argv, (char *) msgPtr, flags) != TCL_OK) { + return TCL_ERROR; + } + + /* + * If the message is to display the value of a variable, then set up + * a trace on the variable's value, create the variable if it doesn't + * exist, and fetch its current value. + */ + + if (msgPtr->textVarName != NULL) { + char *value; + + value = Tcl_GetVar(interp, msgPtr->textVarName, TCL_GLOBAL_ONLY); + if (value == NULL) { + Tcl_SetVar(interp, msgPtr->textVarName, msgPtr->string, + TCL_GLOBAL_ONLY); + } else { + if (msgPtr->string != NULL) { + ckfree(msgPtr->string); + } + msgPtr->string = strcpy(ckalloc(strlen(value) + 1), value); + } + Tcl_TraceVar(interp, msgPtr->textVarName, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + MessageTextVarProc, (ClientData) msgPtr); + } + + /* + * A few other options need special processing, such as setting + * the background from a 3-D border or handling special defaults + * that couldn't be specified to Tk_ConfigureWidget. + */ + + msgPtr->numChars = strlen(msgPtr->string); + + Tk_SetBackgroundFromBorder(msgPtr->tkwin, msgPtr->border); + + if (msgPtr->highlightWidth < 0) { + msgPtr->highlightWidth = 0; + } + + MessageWorldChanged((ClientData) msgPtr); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * MessageWorldChanged -- + * + * This procedure is called when the world has changed in some + * way and the widget needs to recompute all its graphics contexts + * and determine its new geometry. + * + * Results: + * None. + * + * Side effects: + * Message will be relayed out and redisplayed. + * + *--------------------------------------------------------------------------- + */ + +static void +MessageWorldChanged(instanceData) + ClientData instanceData; /* Information about widget. */ +{ + XGCValues gcValues; + GC gc; + Tk_FontMetrics fm; + Message *msgPtr; + + msgPtr = (Message *) instanceData; + + gcValues.font = Tk_FontId(msgPtr->tkfont); + gcValues.foreground = msgPtr->fgColorPtr->pixel; + gc = Tk_GetGC(msgPtr->tkwin, GCForeground | GCFont, &gcValues); + if (msgPtr->textGC != None) { + Tk_FreeGC(msgPtr->display, msgPtr->textGC); + } + msgPtr->textGC = gc; + + Tk_GetFontMetrics(msgPtr->tkfont, &fm); + if (msgPtr->padX < 0) { + msgPtr->padX = fm.ascent / 2; + } + if (msgPtr->padY == -1) { + msgPtr->padY = fm.ascent / 4; + } + + /* + * Recompute the desired geometry for the window, and arrange for + * the window to be redisplayed. + */ + + ComputeMessageGeometry(msgPtr); + if ((msgPtr->tkwin != NULL) && Tk_IsMapped(msgPtr->tkwin) + && !(msgPtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(DisplayMessage, (ClientData) msgPtr); + msgPtr->flags |= REDRAW_PENDING; + } +} + +/* + *-------------------------------------------------------------- + * + * ComputeMessageGeometry -- + * + * Compute the desired geometry for a message window, + * taking into account the desired aspect ratio for the + * window. + * + * Results: + * None. + * + * Side effects: + * Tk_GeometryRequest is called to inform the geometry + * manager of the desired geometry for this window. + * + *-------------------------------------------------------------- + */ + +static void +ComputeMessageGeometry(msgPtr) + register Message *msgPtr; /* Information about window. */ +{ + int width, inc, height; + int thisWidth, thisHeight, maxWidth; + int aspect, lowerBound, upperBound, inset; + + Tk_FreeTextLayout(msgPtr->textLayout); + + inset = msgPtr->borderWidth + msgPtr->highlightWidth; + + /* + * Compute acceptable bounds for the final aspect ratio. + */ + + aspect = msgPtr->aspect/10; + if (aspect < 5) { + aspect = 5; + } + lowerBound = msgPtr->aspect - aspect; + upperBound = msgPtr->aspect + aspect; + + /* + * Do the computation in multiple passes: start off with + * a very wide window, and compute its height. Then change + * the width and try again. Reduce the size of the change + * and iterate until dimensions are found that approximate + * the desired aspect ratio. Or, if the user gave an explicit + * width then just use that. + */ + + if (msgPtr->width > 0) { + width = msgPtr->width; + inc = 0; + } else { + width = WidthOfScreen(Tk_Screen(msgPtr->tkwin))/2; + inc = width/2; + } + + for ( ; ; inc /= 2) { + msgPtr->textLayout = Tk_ComputeTextLayout(msgPtr->tkfont, + msgPtr->string, msgPtr->numChars, width, msgPtr->justify, + 0, &thisWidth, &thisHeight); + maxWidth = thisWidth + 2 * (inset + msgPtr->padX); + height = thisHeight + 2 * (inset + msgPtr->padY); + + if (inc <= 2) { + break; + } + aspect = (100 * maxWidth) / height; + + if (aspect < lowerBound) { + width += inc; + } else if (aspect > upperBound) { + width -= inc; + } else { + break; + } + Tk_FreeTextLayout(msgPtr->textLayout); + } + msgPtr->msgWidth = thisWidth; + msgPtr->msgHeight = thisHeight; + Tk_GeometryRequest(msgPtr->tkwin, maxWidth, height); + Tk_SetInternalBorder(msgPtr->tkwin, inset); +} + +/* + *-------------------------------------------------------------- + * + * DisplayMessage -- + * + * This procedure redraws the contents of a message window. + * + * Results: + * None. + * + * Side effects: + * Information appears on the screen. + * + *-------------------------------------------------------------- + */ + +static void +DisplayMessage(clientData) + ClientData clientData; /* Information about window. */ +{ + register Message *msgPtr = (Message *) clientData; + register Tk_Window tkwin = msgPtr->tkwin; + int x, y; + + msgPtr->flags &= ~REDRAW_PENDING; + if ((msgPtr->tkwin == NULL) || !Tk_IsMapped(tkwin)) { + return; + } + Tk_Fill3DRectangle(tkwin, Tk_WindowId(tkwin), msgPtr->border, 0, 0, + Tk_Width(tkwin), Tk_Height(tkwin), 0, TK_RELIEF_FLAT); + + /* + * Compute starting y-location for message based on message size + * and anchor option. + */ + + TkComputeAnchor(msgPtr->anchor, tkwin, msgPtr->padX, msgPtr->padY, + msgPtr->msgWidth, msgPtr->msgHeight, &x, &y); + Tk_DrawTextLayout(Tk_Display(tkwin), Tk_WindowId(tkwin), msgPtr->textGC, + msgPtr->textLayout, x, y, 0, -1); + + if (msgPtr->relief != TK_RELIEF_FLAT) { + Tk_Draw3DRectangle(tkwin, Tk_WindowId(tkwin), msgPtr->border, + msgPtr->highlightWidth, msgPtr->highlightWidth, + Tk_Width(tkwin) - 2*msgPtr->highlightWidth, + Tk_Height(tkwin) - 2*msgPtr->highlightWidth, + msgPtr->borderWidth, msgPtr->relief); + } + if (msgPtr->highlightWidth != 0) { + GC gc; + + if (msgPtr->flags & GOT_FOCUS) { + gc = Tk_GCForColor(msgPtr->highlightColorPtr, Tk_WindowId(tkwin)); + } else { + gc = Tk_GCForColor(msgPtr->highlightBgColorPtr, Tk_WindowId(tkwin)); + } + Tk_DrawFocusHighlight(tkwin, gc, msgPtr->highlightWidth, + Tk_WindowId(tkwin)); + } +} + +/* + *-------------------------------------------------------------- + * + * MessageEventProc -- + * + * This procedure is invoked by the Tk dispatcher for various + * events on messages. + * + * Results: + * None. + * + * Side effects: + * When the window gets deleted, internal structures get + * cleaned up. When it gets exposed, it is redisplayed. + * + *-------------------------------------------------------------- + */ + +static void +MessageEventProc(clientData, eventPtr) + ClientData clientData; /* Information about window. */ + XEvent *eventPtr; /* Information about event. */ +{ + Message *msgPtr = (Message *) clientData; + + if (((eventPtr->type == Expose) && (eventPtr->xexpose.count == 0)) + || (eventPtr->type == ConfigureNotify)) { + goto redraw; + } else if (eventPtr->type == DestroyNotify) { + if (msgPtr->tkwin != NULL) { + msgPtr->tkwin = NULL; + Tcl_DeleteCommandFromToken(msgPtr->interp, msgPtr->widgetCmd); + } + if (msgPtr->flags & REDRAW_PENDING) { + Tcl_CancelIdleCall(DisplayMessage, (ClientData) msgPtr); + } + Tcl_EventuallyFree((ClientData) msgPtr, DestroyMessage); + } else if (eventPtr->type == FocusIn) { + if (eventPtr->xfocus.detail != NotifyInferior) { + msgPtr->flags |= GOT_FOCUS; + if (msgPtr->highlightWidth > 0) { + goto redraw; + } + } + } else if (eventPtr->type == FocusOut) { + if (eventPtr->xfocus.detail != NotifyInferior) { + msgPtr->flags &= ~GOT_FOCUS; + if (msgPtr->highlightWidth > 0) { + goto redraw; + } + } + } + return; + + redraw: + if ((msgPtr->tkwin != NULL) && !(msgPtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(DisplayMessage, (ClientData) msgPtr); + msgPtr->flags |= REDRAW_PENDING; + } +} + +/* + *---------------------------------------------------------------------- + * + * MessageCmdDeletedProc -- + * + * 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 +MessageCmdDeletedProc(clientData) + ClientData clientData; /* Pointer to widget record for widget. */ +{ + Message *msgPtr = (Message *) clientData; + Tk_Window tkwin = msgPtr->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. + */ + + if (tkwin != NULL) { + msgPtr->tkwin = NULL; + Tk_DestroyWindow(tkwin); + } +} + +/* + *-------------------------------------------------------------- + * + * MessageTextVarProc -- + * + * This procedure is invoked when someone changes the variable + * whose contents are to be displayed in a message. + * + * Results: + * NULL is always returned. + * + * Side effects: + * The text displayed in the message will change to match the + * variable. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static char * +MessageTextVarProc(clientData, interp, name1, name2, flags) + ClientData clientData; /* Information about message. */ + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *name1; /* Name of variable. */ + char *name2; /* Second part of variable name. */ + int flags; /* Information about what happened. */ +{ + register Message *msgPtr = (Message *) clientData; + char *value; + + /* + * If the variable is unset, then immediately recreate it unless + * the whole interpreter is going away. + */ + + if (flags & TCL_TRACE_UNSETS) { + if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) { + Tcl_SetVar(interp, msgPtr->textVarName, msgPtr->string, + TCL_GLOBAL_ONLY); + Tcl_TraceVar(interp, msgPtr->textVarName, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + MessageTextVarProc, clientData); + } + return (char *) NULL; + } + + value = Tcl_GetVar(interp, msgPtr->textVarName, TCL_GLOBAL_ONLY); + if (value == NULL) { + value = ""; + } + if (msgPtr->string != NULL) { + ckfree(msgPtr->string); + } + msgPtr->numChars = strlen(value); + msgPtr->string = (char *) ckalloc((unsigned) (msgPtr->numChars + 1)); + strcpy(msgPtr->string, value); + ComputeMessageGeometry(msgPtr); + + if ((msgPtr->tkwin != NULL) && Tk_IsMapped(msgPtr->tkwin) + && !(msgPtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(DisplayMessage, (ClientData) msgPtr); + msgPtr->flags |= REDRAW_PENDING; + } + return (char *) NULL; +} diff --git a/generic/tkOption.c b/generic/tkOption.c new file mode 100644 index 0000000..b2bef64 --- /dev/null +++ b/generic/tkOption.c @@ -0,0 +1,1397 @@ +/* + * tkOption.c -- + * + * This module contains procedures to manage the option + * database, which allows various strings to be associated + * 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. + * + * 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 + */ + +#include "tkPort.h" +#include "tkInt.h" + +/* + * The option database is stored as one tree for each main window. + * Each name or class field in an option is associated with a node or + * leaf of the tree. For example, the options "x.y.z" and "x.y*a" + * each correspond to three nodes in the tree; they share the nodes + * "x" and "x.y", but have different leaf nodes. One of the following + * structures exists for each node or leaf in the option tree. It is + * actually stored as part of the parent node, and describes a particular + * child of the parent. + */ + +typedef struct Element { + Tk_Uid nameUid; /* Name or class from one element of + * an option spec. */ + union { + struct ElArray *arrayPtr; /* If this is an intermediate node, + * a pointer to a structure describing + * the remaining elements of all + * options whose prefixes are the + * same up through this element. */ + Tk_Uid valueUid; /* For leaf nodes, this is the string + * value of the option. */ + } child; + int priority; /* Used to select among matching + * options. Includes both the + * priority level and a serial #. + * Greater value means higher + * priority. Irrelevant except in + * leaf nodes. */ + int flags; /* OR-ed combination of bits. See + * below for values. */ +} Element; + +/* + * Flags in Element structures: + * + * CLASS - Non-zero means this element refers to a class, + * Zero means this element refers to a name. + * NODE - Zero means this is a leaf element (the child + * field is a value, not a pointer to another node). + * One means this is a node element. + * WILDCARD - Non-zero means this there was a star in the + * original specification just before this element. + * Zero means there was a dot. + */ + +#define TYPE_MASK 0x7 + +#define CLASS 0x1 +#define NODE 0x2 +#define WILDCARD 0x4 + +#define EXACT_LEAF_NAME 0x0 +#define EXACT_LEAF_CLASS 0x1 +#define EXACT_NODE_NAME 0x2 +#define EXACT_NODE_CLASS 0x3 +#define WILDCARD_LEAF_NAME 0x4 +#define WILDCARD_LEAF_CLASS 0x5 +#define WILDCARD_NODE_NAME 0x6 +#define WILDCARD_NODE_CLASS 0x7 + +/* + * The following structure is used to manage a dynamic array of + * Elements. These structures are used for two purposes: to store + * the contents of a node in the option tree, and for the option + * stacks described below. + */ + +typedef struct ElArray { + int arraySize; /* Number of elements actually + * allocated in the "els" array. */ + int numUsed; /* Number of elements currently in + * use out of els. */ + Element *nextToUse; /* Pointer to &els[numUsed]. */ + Element els[1]; /* Array of structures describing + * children of this node. The + * array will actually contain enough + * elements for all of the children + * (and even a few extras, perhaps). + * This must be the last field in + * the structure. */ +} ElArray; + +#define EL_ARRAY_SIZE(numEls) ((unsigned) (sizeof(ElArray) \ + + ((numEls)-1)*sizeof(Element))) +#define INITIAL_SIZE 5 + +/* + * In addition to the option tree, which is a relatively static structure, + * there are eight additional structures called "stacks", which are used + * to speed up queries into the option database. The stack structures + * are designed for the situation where an individual widget makes repeated + * requests for its particular options. The requests differ only in + * their last name/class, so during the first request we extract all + * the options pertaining to the particular widget and save them in a + * stack-like cache; subsequent requests for the same widget can search + * the cache relatively quickly. In fact, the cache is a hierarchical + * one, storing a list of relevant options for this widget and all of + * its ancestors up to the application root; hence the name "stack". + * + * Each of the eight stacks consists of an array of Elements, ordered in + * terms of levels in the window hierarchy. All the elements relevant + * for the top-level widget appear first in the array, followed by all + * those from the next-level widget on the path to the current widget, + * etc. down to those for the current widget. + * + * Cached information is divided into eight stacks according to the + * CLASS, NODE, and WILDCARD flags. Leaf and non-leaf information is + * kept separate to speed up individual probes (non-leaf information is + * only relevant when building the stacks, but isn't relevant when + * making probes; similarly, only non-leaf information is relevant + * when the stacks are being extended to the next widget down in the + * widget hierarchy). Wildcard elements are handled separately from + * "exact" elements because once they appear at a particular level in + * the stack they remain active for all deeper levels; exact elements + * are only relevant at a particular level. For example, when searching + * for options relevant in a particular window, the entire wildcard + * stacks get checked, but only the portions of the exact stacks that + * pertain to the window's parent. Lastly, name and class stacks are + * kept separate because different search keys are used when searching + * them; keeping them separate speeds up the searches. + */ + +#define NUM_STACKS 8 +static ElArray *stacks[NUM_STACKS]; +static TkWindow *cachedWindow = NULL; /* Lowest-level window currently + * loaded in stacks at present. + * NULL means stacks have never + * been used, or have been + * invalidated because of a change + * to the database. */ + +/* + * One of the following structures is used to keep track of each + * level in the stacks. + */ + +typedef struct StackLevel { + TkWindow *winPtr; /* Window corresponding to this stack + * level. */ + int bases[NUM_STACKS]; /* For each stack, index of first + * element on stack corresponding to + * this level (used to restore "numUsed" + * fields when popping out of a level. */ +} StackLevel; + +/* + * Information about all of the stack levels that are currently + * active. This array grows dynamically to become as large as needed. + */ + +static StackLevel *levels = NULL; + /* Array describing current stack. */ +static int numLevels = 0; /* Total space allocated. */ +static int curLevel = -1; /* Highest level currently in use. Note: + * curLevel is never 0! (I don't remember + * why anymore...) */ + +/* + * The variable below is a serial number for all options entered into + * the database so far. It increments on each addition to the option + * database. It is used in computing option priorities, so that the + * most recent entry wins when choosing between options at the same + * priority level. + */ + +static int serial = 0; + +/* + * Special "no match" Element to use as default for searches. + */ + +static Element defaultMatch; + +/* + * Forward declarations for procedures defined in this file: + */ + +static int AddFromString _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, char *string, int priority)); +static void ClearOptionTree _ANSI_ARGS_((ElArray *arrayPtr)); +static ElArray * ExtendArray _ANSI_ARGS_((ElArray *arrayPtr, + Element *elPtr)); +static void ExtendStacks _ANSI_ARGS_((ElArray *arrayPtr, + int leaf)); +static int GetDefaultOptions _ANSI_ARGS_((Tcl_Interp *interp, + TkWindow *winPtr)); +static ElArray * NewArray _ANSI_ARGS_((int numEls)); +static void OptionInit _ANSI_ARGS_((TkMainInfo *mainPtr)); +static int ParsePriority _ANSI_ARGS_((Tcl_Interp *interp, + char *string)); +static int ReadOptionFile _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, char *fileName, int priority)); +static void SetupStacks _ANSI_ARGS_((TkWindow *winPtr, int leaf)); + +/* + *-------------------------------------------------------------- + * + * Tk_AddOption -- + * + * Add a new option to the option database. + * + * Results: + * None. + * + * Side effects: + * Information is added to the option database. + * + *-------------------------------------------------------------- + */ + +void +Tk_AddOption(tkwin, name, value, priority) + Tk_Window tkwin; /* Window token; option will be associated + * with main window for this window. */ + char *name; /* Multi-element name of option. */ + char *value; /* String value for option. */ + int priority; /* Overall priority level to use for + * this option, such as TK_USER_DEFAULT_PRIO + * or TK_INTERACTIVE_PRIO. Must be between + * 0 and TK_MAX_PRIO. */ +{ + TkWindow *winPtr = ((TkWindow *) tkwin)->mainPtr->winPtr; + register ElArray **arrayPtrPtr; + register Element *elPtr; + Element newEl; + register char *p; + char *field; + int count, firstField, length; +#define TMP_SIZE 100 + char tmp[TMP_SIZE+1]; + + if (winPtr->mainPtr->optionRootPtr == NULL) { + OptionInit(winPtr->mainPtr); + } + cachedWindow = NULL; /* Invalidate the cache. */ + + /* + * Compute the priority for the new element, including both the + * overall level and the serial number (to disambiguate with the + * level). + */ + + if (priority < 0) { + priority = 0; + } else if (priority > TK_MAX_PRIO) { + priority = TK_MAX_PRIO; + } + newEl.priority = (priority << 24) + serial; + serial++; + + /* + * Parse the option one field at a time. + */ + + arrayPtrPtr = &(((TkWindow *) tkwin)->mainPtr->optionRootPtr); + p = name; + for (firstField = 1; ; firstField = 0) { + + /* + * Scan the next field from the name and convert it to a Tk_Uid. + * Must copy the field before calling Tk_Uid, so that a terminating + * NULL may be added without modifying the source string. + */ + + if (*p == '*') { + newEl.flags = WILDCARD; + p++; + } else { + newEl.flags = 0; + } + field = p; + while ((*p != 0) && (*p != '.') && (*p != '*')) { + p++; + } + length = p - field; + if (length > TMP_SIZE) { + length = TMP_SIZE; + } + strncpy(tmp, field, (size_t) length); + tmp[length] = 0; + newEl.nameUid = Tk_GetUid(tmp); + if (isupper(UCHAR(*field))) { + newEl.flags |= CLASS; + } + + if (*p != 0) { + + /* + * New element will be a node. If this option can't possibly + * apply to this main window, then just skip it. Otherwise, + * add it to the parent, if it isn't already there, and descend + * into it. + */ + + newEl.flags |= NODE; + if (firstField && !(newEl.flags & WILDCARD) + && (newEl.nameUid != winPtr->nameUid) + && (newEl.nameUid != winPtr->classUid)) { + return; + } + for (elPtr = (*arrayPtrPtr)->els, count = (*arrayPtrPtr)->numUsed; + ; elPtr++, count--) { + if (count == 0) { + newEl.child.arrayPtr = NewArray(5); + *arrayPtrPtr = ExtendArray(*arrayPtrPtr, &newEl); + arrayPtrPtr = &((*arrayPtrPtr)->nextToUse[-1].child.arrayPtr); + break; + } + if ((elPtr->nameUid == newEl.nameUid) + && (elPtr->flags == newEl.flags)) { + arrayPtrPtr = &(elPtr->child.arrayPtr); + break; + } + } + if (*p == '.') { + p++; + } + } else { + + /* + * New element is a leaf. Add it to the parent, if it isn't + * already there. If it exists already, keep whichever value + * has highest priority. + */ + + newEl.child.valueUid = Tk_GetUid(value); + for (elPtr = (*arrayPtrPtr)->els, count = (*arrayPtrPtr)->numUsed; + ; elPtr++, count--) { + if (count == 0) { + *arrayPtrPtr = ExtendArray(*arrayPtrPtr, &newEl); + return; + } + if ((elPtr->nameUid == newEl.nameUid) + && (elPtr->flags == newEl.flags)) { + if (elPtr->priority < newEl.priority) { + elPtr->priority = newEl.priority; + elPtr->child.valueUid = newEl.child.valueUid; + } + return; + } + } + } + } +} + +/* + *-------------------------------------------------------------- + * + * Tk_GetOption -- + * + * Retrieve an option from the option database. + * + * Results: + * The return value is the value specified in the option + * database for the given name and class on the given + * window. If there is nothing specified in the database + * for that option, then NULL is returned. + * + * Side effects: + * The internal caches used to speed up option mapping + * may be modified, if this tkwin is different from the + * last tkwin used for option retrieval. + * + *-------------------------------------------------------------- + */ + +Tk_Uid +Tk_GetOption(tkwin, name, className) + Tk_Window tkwin; /* Token for window that option is + * associated with. */ + char *name; /* Name of option. */ + char *className; /* Class of option. NULL means there + * is no class for this option: just + * check for name. */ +{ + Tk_Uid nameId, classId; + register Element *elPtr, *bestPtr; + register int count; + + /* + * Note: no need to call OptionInit here: it will be done by + * the SetupStacks call below (squeeze out those nanoseconds). + */ + + if (tkwin != (Tk_Window) cachedWindow) { + SetupStacks((TkWindow *) tkwin, 1); + } + + nameId = Tk_GetUid(name); + bestPtr = &defaultMatch; + for (elPtr = stacks[EXACT_LEAF_NAME]->els, + count = stacks[EXACT_LEAF_NAME]->numUsed; count > 0; + elPtr++, count--) { + if ((elPtr->nameUid == nameId) + && (elPtr->priority > bestPtr->priority)) { + bestPtr = elPtr; + } + } + for (elPtr = stacks[WILDCARD_LEAF_NAME]->els, + count = stacks[WILDCARD_LEAF_NAME]->numUsed; count > 0; + elPtr++, count--) { + if ((elPtr->nameUid == nameId) + && (elPtr->priority > bestPtr->priority)) { + bestPtr = elPtr; + } + } + if (className != NULL) { + classId = Tk_GetUid(className); + for (elPtr = stacks[EXACT_LEAF_CLASS]->els, + count = stacks[EXACT_LEAF_CLASS]->numUsed; count > 0; + elPtr++, count--) { + if ((elPtr->nameUid == classId) + && (elPtr->priority > bestPtr->priority)) { + bestPtr = elPtr; + } + } + for (elPtr = stacks[WILDCARD_LEAF_CLASS]->els, + count = stacks[WILDCARD_LEAF_CLASS]->numUsed; count > 0; + elPtr++, count--) { + if ((elPtr->nameUid == classId) + && (elPtr->priority > bestPtr->priority)) { + bestPtr = elPtr; + } + } + } + return bestPtr->child.valueUid; +} + +/* + *-------------------------------------------------------------- + * + * Tk_OptionCmd -- + * + * This procedure is invoked to process the "option" 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_OptionCmd(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; + size_t length; + char c; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " cmd arg ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + c = argv[1][0]; + length = strlen(argv[1]); + if ((c == 'a') && (strncmp(argv[1], "add", length) == 0)) { + int priority; + + if ((argc != 4) && (argc != 5)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " add pattern value ?priority?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 4) { + priority = TK_INTERACTIVE_PRIO; + } else { + priority = ParsePriority(interp, argv[4]); + if (priority < 0) { + return TCL_ERROR; + } + } + Tk_AddOption(tkwin, argv[2], argv[3], priority); + return TCL_OK; + } else if ((c == 'c') && (strncmp(argv[1], "clear", length) == 0)) { + TkMainInfo *mainPtr; + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " clear\"", (char *) NULL); + return TCL_ERROR; + } + mainPtr = ((TkWindow *) tkwin)->mainPtr; + if (mainPtr->optionRootPtr != NULL) { + ClearOptionTree(mainPtr->optionRootPtr); + mainPtr->optionRootPtr = NULL; + } + cachedWindow = NULL; + return TCL_OK; + } else if ((c == 'g') && (strncmp(argv[1], "get", length) == 0)) { + Tk_Window window; + Tk_Uid value; + + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " get window name class\"", (char *) NULL); + return TCL_ERROR; + } + window = Tk_NameToWindow(interp, argv[2], tkwin); + if (window == NULL) { + return TCL_ERROR; + } + value = Tk_GetOption(window, argv[3], argv[4]); + if (value != NULL) { + interp->result = value; + } + return TCL_OK; + } else if ((c == 'r') && (strncmp(argv[1], "readfile", length) == 0)) { + int priority; + + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " readfile fileName ?priority?\"", + (char *) NULL); + return TCL_ERROR; + } + if (argc == 4) { + priority = ParsePriority(interp, argv[3]); + if (priority < 0) { + return TCL_ERROR; + } + } else { + priority = TK_INTERACTIVE_PRIO; + } + return ReadOptionFile(interp, tkwin, argv[2], priority); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be add, clear, get, or readfile", (char *) NULL); + return TCL_ERROR; + } +} + +/* + *-------------------------------------------------------------- + * + * TkOptionDeadWindow -- + * + * This procedure is called whenever a window is deleted. + * It cleans up any option-related stuff associated with + * the window. + * + * Results: + * None. + * + * Side effects: + * Option-related resources are freed. See code below + * for details. + * + *-------------------------------------------------------------- + */ + +void +TkOptionDeadWindow(winPtr) + register TkWindow *winPtr; /* Window to be cleaned up. */ +{ + /* + * If this window is in the option stacks, then clear the stacks. + */ + + if (winPtr->optionLevel != -1) { + int i; + + for (i = 1; i <= curLevel; i++) { + levels[i].winPtr->optionLevel = -1; + } + curLevel = -1; + cachedWindow = NULL; + } + + /* + * If this window was a main window, then delete its option + * database. + */ + + if ((winPtr->mainPtr->winPtr == winPtr) + && (winPtr->mainPtr->optionRootPtr != NULL)) { + ClearOptionTree(winPtr->mainPtr->optionRootPtr); + winPtr->mainPtr->optionRootPtr = NULL; + } +} + +/* + *---------------------------------------------------------------------- + * + * TkOptionClassChanged -- + * + * This procedure is invoked when a window's class changes. If + * the window is on the option cache, this procedure flushes + * any information for the window, since the new class could change + * what is relevant. + * + * Results: + * None. + * + * Side effects: + * The option cache may be flushed in part or in whole. + * + *---------------------------------------------------------------------- + */ + +void +TkOptionClassChanged(winPtr) + TkWindow *winPtr; /* Window whose class changed. */ +{ + int i, j, *basePtr; + ElArray *arrayPtr; + + if (winPtr->optionLevel == -1) { + return; + } + + /* + * Find the lowest stack level that refers to this window, then + * flush all of the levels above the matching one. + */ + + for (i = 1; i <= curLevel; i++) { + if (levels[i].winPtr == winPtr) { + for (j = i; j <= curLevel; j++) { + levels[j].winPtr->optionLevel = -1; + } + curLevel = i-1; + basePtr = levels[i].bases; + for (j = 0; j < NUM_STACKS; j++) { + arrayPtr = stacks[j]; + arrayPtr->numUsed = basePtr[j]; + arrayPtr->nextToUse = &arrayPtr->els[arrayPtr->numUsed]; + } + if (curLevel <= 0) { + cachedWindow = NULL; + } else { + cachedWindow = levels[curLevel].winPtr; + } + break; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * ParsePriority -- + * + * Parse a string priority value. + * + * 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. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ParsePriority(interp, string) + Tcl_Interp *interp; /* Interpreter to use for error reporting. */ + char *string; /* Describes a priority level, either + * symbolically or numerically. */ +{ + int priority, c; + size_t length; + + c = string[0]; + length = strlen(string); + if ((c == 'w') + && (strncmp(string, "widgetDefault", length) == 0)) { + return TK_WIDGET_DEFAULT_PRIO; + } else if ((c == 's') + && (strncmp(string, "startupFile", length) == 0)) { + return TK_STARTUP_FILE_PRIO; + } else if ((c == 'u') + && (strncmp(string, "userDefault", length) == 0)) { + return TK_USER_DEFAULT_PRIO; + } else if ((c == 'i') + && (strncmp(string, "interactive", length) == 0)) { + return TK_INTERACTIVE_PRIO; + } else { + char *end; + + priority = strtoul(string, &end, 0); + if ((end == string) || (*end != 0) || (priority < 0) + || (priority > 100)) { + Tcl_AppendResult(interp, "bad priority level \"", string, + "\": must be widgetDefault, startupFile, userDefault, ", + "interactive, or a number between 0 and 100", + (char *) NULL); + return -1; + } + } + return priority; +} + +/* + *---------------------------------------------------------------------- + * + * AddFromString -- + * + * Given a string containing lines in the standard format for + * X resources (see other documentation for details on what this + * is), parse the resource specifications and enter them as options + * for tkwin's main window. + * + * 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 + * string is totally trashed by this procedure. If you care about + * its contents, make a copy before calling here. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +AddFromString(interp, tkwin, string, priority) + Tcl_Interp *interp; /* Interpreter to use for reporting results. */ + Tk_Window tkwin; /* Token for window: options are entered + * for this window's main window. */ + char *string; /* String containing option specifiers. */ + int priority; /* Priority level to use for options in + * this string, such as TK_USER_DEFAULT_PRIO + * or TK_INTERACTIVE_PRIO. Must be between + * 0 and TK_MAX_PRIO. */ +{ + register char *src, *dst; + char *name, *value; + int lineNum; + + src = string; + lineNum = 1; + while (1) { + + /* + * Skip leading white space and empty lines and comment lines, and + * check for the end of the spec. + */ + + while ((*src == ' ') || (*src == '\t')) { + src++; + } + if ((*src == '#') || (*src == '!')) { + do { + src++; + if ((src[0] == '\\') && (src[1] == '\n')) { + src += 2; + lineNum++; + } + } while ((*src != '\n') && (*src != 0)); + } + if (*src == '\n') { + src++; + lineNum++; + continue; + } + if (*src == '\0') { + break; + } + + /* + * Parse off the option name, collapsing out backslash-newline + * sequences of course. + */ + + dst = name = src; + while (*src != ':') { + if ((*src == '\0') || (*src == '\n')) { + sprintf(interp->result, "missing colon on line %d", + lineNum); + return TCL_ERROR; + } + if ((src[0] == '\\') && (src[1] == '\n')) { + src += 2; + lineNum++; + } else { + *dst = *src; + dst++; + src++; + } + } + + /* + * Eliminate trailing white space on the name, and null-terminate + * it. + */ + + while ((dst != name) && ((dst[-1] == ' ') || (dst[-1] == '\t'))) { + dst--; + } + *dst = '\0'; + + /* + * Skip white space between the name and the value. + */ + + src++; + while ((*src == ' ') || (*src == '\t')) { + src++; + } + if (*src == '\0') { + sprintf(interp->result, "missing value on line %d", lineNum); + return TCL_ERROR; + } + + /* + * Parse off the value, squeezing out backslash-newline sequences + * along the way. + */ + + dst = value = src; + while (*src != '\n') { + if (*src == '\0') { + sprintf(interp->result, "missing newline on line %d", + lineNum); + return TCL_ERROR; + } + if ((src[0] == '\\') && (src[1] == '\n')) { + src += 2; + lineNum++; + } else { + *dst = *src; + dst++; + src++; + } + } + *dst = 0; + + /* + * Enter the option into the database. + */ + + Tk_AddOption(tkwin, name, value, priority); + src++; + lineNum++; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ReadOptionFile -- + * + * Read a file of options ("resources" in the old X terminology) + * and load them into the option database. + * + * 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. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ReadOptionFile(interp, tkwin, fileName, priority) + Tcl_Interp *interp; /* Interpreter to use for reporting results. */ + Tk_Window tkwin; /* Token for window: options are entered + * for this window's main window. */ + char *fileName; /* Name of file containing options. */ + int priority; /* Priority level to use for options in + * this file, such as TK_USER_DEFAULT_PRIO + * or TK_INTERACTIVE_PRIO. Must be between + * 0 and TK_MAX_PRIO. */ +{ + char *realName, *buffer; + int result, bufferSize; + Tcl_Channel chan; + Tcl_DString newName; + + /* + * Prevent file system access in a safe interpreter. + */ + + if (Tcl_IsSafe(interp)) { + Tcl_AppendResult(interp, "can't read options from a file in a", + " safe interpreter", (char *) NULL); + return TCL_ERROR; + } + + realName = Tcl_TranslateFileName(interp, fileName, &newName); + if (realName == NULL) { + return TCL_ERROR; + } + chan = Tcl_OpenFileChannel(interp, realName, "r", 0); + Tcl_DStringFree(&newName); + if (chan == NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "couldn't open \"", fileName, + "\": ", Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + + /* + * Compute size of file by seeking to the end of the file. This will + * overallocate if we are performing CRLF translation. + */ + + bufferSize = Tcl_Seek(chan, 0L, SEEK_END); + (void) Tcl_Seek(chan, 0L, SEEK_SET); + + if (bufferSize < 0) { + Tcl_AppendResult(interp, "error seeking to end of file \"", + fileName, "\":", Tcl_PosixError(interp), (char *) NULL); + Tcl_Close(NULL, chan); + return TCL_ERROR; + + } + buffer = (char *) ckalloc((unsigned) bufferSize+1); + bufferSize = Tcl_Read(chan, buffer, bufferSize); + if (bufferSize < 0) { + Tcl_AppendResult(interp, "error reading file \"", fileName, "\":", + Tcl_PosixError(interp), (char *) NULL); + Tcl_Close(NULL, chan); + return TCL_ERROR; + } + Tcl_Close(NULL, chan); + buffer[bufferSize] = 0; + result = AddFromString(interp, tkwin, buffer, priority); + ckfree(buffer); + return result; +} + +/* + *-------------------------------------------------------------- + * + * NewArray -- + * + * Create a new ElArray structure of a given size. + * + * Results: + * The return value is a pointer to a properly initialized + * element array with "numEls" space. The array is marked + * as having no active elements. + * + * Side effects: + * Memory is allocated. + * + *-------------------------------------------------------------- + */ + +static ElArray * +NewArray(numEls) + int numEls; /* How many elements of space to allocate. */ +{ + register ElArray *arrayPtr; + + arrayPtr = (ElArray *) ckalloc(EL_ARRAY_SIZE(numEls)); + arrayPtr->arraySize = numEls; + arrayPtr->numUsed = 0; + arrayPtr->nextToUse = arrayPtr->els; + return arrayPtr; +} + +/* + *-------------------------------------------------------------- + * + * ExtendArray -- + * + * Add a new element to an array, extending the array if + * necessary. + * + * Results: + * The return value is a pointer to the new array, which + * will be different from arrayPtr if the array got expanded. + * + * Side effects: + * Memory may be allocated or freed. + * + *-------------------------------------------------------------- + */ + +static ElArray * +ExtendArray(arrayPtr, elPtr) + register ElArray *arrayPtr; /* Array to be extended. */ + register Element *elPtr; /* Element to be copied into array. */ +{ + /* + * If the current array has filled up, make it bigger. + */ + + if (arrayPtr->numUsed >= arrayPtr->arraySize) { + register ElArray *newPtr; + + newPtr = (ElArray *) ckalloc(EL_ARRAY_SIZE(2*arrayPtr->arraySize)); + newPtr->arraySize = 2*arrayPtr->arraySize; + newPtr->numUsed = arrayPtr->numUsed; + newPtr->nextToUse = &newPtr->els[newPtr->numUsed]; + memcpy((VOID *) newPtr->els, (VOID *) arrayPtr->els, + (arrayPtr->arraySize*sizeof(Element))); + ckfree((char *) arrayPtr); + arrayPtr = newPtr; + } + + *arrayPtr->nextToUse = *elPtr; + arrayPtr->nextToUse++; + arrayPtr->numUsed++; + return arrayPtr; +} + +/* + *-------------------------------------------------------------- + * + * SetupStacks -- + * + * Arrange the stacks so that they cache all the option + * information for a particular window. + * + * Results: + * None. + * + * Side effects: + * The stacks are modified to hold information for tkwin + * and all its ancestors in the window hierarchy. + * + *-------------------------------------------------------------- + */ + +static void +SetupStacks(winPtr, leaf) + TkWindow *winPtr; /* Window for which information is to + * be cached. */ + int leaf; /* Non-zero means this is the leaf + * window being probed. Zero means this + * is an ancestor of the desired leaf. */ +{ + int level, i, *iPtr; + register StackLevel *levelPtr; + register ElArray *arrayPtr; + + /* + * The following array defines the order in which the current + * stacks are searched to find matching entries to add to the + * stacks. Given the current priority-based scheme, the order + * below is no longer relevant; all that matters is that an + * element is on the list *somewhere*. The ordering is a relic + * of the old days when priorities were determined differently. + */ + + static int searchOrder[] = {WILDCARD_NODE_CLASS, WILDCARD_NODE_NAME, + EXACT_NODE_CLASS, EXACT_NODE_NAME, -1}; + + if (winPtr->mainPtr->optionRootPtr == NULL) { + OptionInit(winPtr->mainPtr); + } + + /* + * Step 1: make sure that options are cached for this window's + * parent. + */ + + if (winPtr->parentPtr != NULL) { + level = winPtr->parentPtr->optionLevel; + if ((level == -1) || (cachedWindow == NULL)) { + SetupStacks(winPtr->parentPtr, 0); + level = winPtr->parentPtr->optionLevel; + } + level++; + } else { + level = 1; + } + + /* + * Step 2: pop extra unneeded information off the stacks and + * mark those windows as no longer having cached information. + */ + + if (curLevel >= level) { + while (curLevel >= level) { + levels[curLevel].winPtr->optionLevel = -1; + curLevel--; + } + levelPtr = &levels[level]; + for (i = 0; i < NUM_STACKS; i++) { + arrayPtr = stacks[i]; + arrayPtr->numUsed = levelPtr->bases[i]; + arrayPtr->nextToUse = &arrayPtr->els[arrayPtr->numUsed]; + } + } + curLevel = winPtr->optionLevel = level; + + /* + * Step 3: if the root database information isn't loaded or + * isn't valid, initialize level 0 of the stack from the + * database root (this only happens if winPtr is a main window). + */ + + if ((curLevel == 1) + && ((cachedWindow == NULL) + || (cachedWindow->mainPtr != winPtr->mainPtr))) { + for (i = 0; i < NUM_STACKS; i++) { + arrayPtr = stacks[i]; + arrayPtr->numUsed = 0; + arrayPtr->nextToUse = arrayPtr->els; + } + ExtendStacks(winPtr->mainPtr->optionRootPtr, 0); + } + + /* + * Step 4: create a new stack level; grow the level array if + * we've run out of levels. Clear the stacks for EXACT_LEAF_NAME + * and EXACT_LEAF_CLASS (anything that was there is of no use + * any more). + */ + + if (curLevel >= numLevels) { + StackLevel *newLevels; + + newLevels = (StackLevel *) ckalloc((unsigned) + (numLevels*2*sizeof(StackLevel))); + memcpy((VOID *) newLevels, (VOID *) levels, + (numLevels*sizeof(StackLevel))); + ckfree((char *) levels); + numLevels *= 2; + levels = newLevels; + } + levelPtr = &levels[curLevel]; + levelPtr->winPtr = winPtr; + arrayPtr = stacks[EXACT_LEAF_NAME]; + arrayPtr->numUsed = 0; + arrayPtr->nextToUse = arrayPtr->els; + arrayPtr = stacks[EXACT_LEAF_CLASS]; + arrayPtr->numUsed = 0; + arrayPtr->nextToUse = arrayPtr->els; + levelPtr->bases[EXACT_LEAF_NAME] = stacks[EXACT_LEAF_NAME]->numUsed; + levelPtr->bases[EXACT_LEAF_CLASS] = stacks[EXACT_LEAF_CLASS]->numUsed; + levelPtr->bases[EXACT_NODE_NAME] = stacks[EXACT_NODE_NAME]->numUsed; + levelPtr->bases[EXACT_NODE_CLASS] = stacks[EXACT_NODE_CLASS]->numUsed; + levelPtr->bases[WILDCARD_LEAF_NAME] = stacks[WILDCARD_LEAF_NAME]->numUsed; + levelPtr->bases[WILDCARD_LEAF_CLASS] = stacks[WILDCARD_LEAF_CLASS]->numUsed; + levelPtr->bases[WILDCARD_NODE_NAME] = stacks[WILDCARD_NODE_NAME]->numUsed; + levelPtr->bases[WILDCARD_NODE_CLASS] = stacks[WILDCARD_NODE_CLASS]->numUsed; + + + /* + * Step 5: scan the current stack level looking for matches to this + * window's name or class; where found, add new information to the + * stacks. + */ + + for (iPtr = searchOrder; *iPtr != -1; iPtr++) { + register Element *elPtr; + int count; + Tk_Uid id; + + i = *iPtr; + if (i & CLASS) { + id = winPtr->classUid; + } else { + id = winPtr->nameUid; + } + elPtr = stacks[i]->els; + count = levelPtr->bases[i]; + + /* + * For wildcard stacks, check all entries; for non-wildcard + * stacks, only check things that matched in the parent. + */ + + if (!(i & WILDCARD)) { + elPtr += levelPtr[-1].bases[i]; + count -= levelPtr[-1].bases[i]; + } + for ( ; count > 0; elPtr++, count--) { + if (elPtr->nameUid != id) { + continue; + } + ExtendStacks(elPtr->child.arrayPtr, leaf); + } + } + cachedWindow = winPtr; +} + +/* + *-------------------------------------------------------------- + * + * ExtendStacks -- + * + * Given an element array, copy all the elements from the + * array onto the system stacks (except for irrelevant leaf + * elements). + * + * Results: + * None. + * + * Side effects: + * The option stacks are extended. + * + *-------------------------------------------------------------- + */ + +static void +ExtendStacks(arrayPtr, leaf) + ElArray *arrayPtr; /* Array of elements to copy onto stacks. */ + int leaf; /* If zero, then don't copy exact leaf + * elements. */ +{ + register int count; + register Element *elPtr; + + for (elPtr = arrayPtr->els, count = arrayPtr->numUsed; + count > 0; elPtr++, count--) { + if (!(elPtr->flags & (NODE|WILDCARD)) && !leaf) { + continue; + } + stacks[elPtr->flags] = ExtendArray(stacks[elPtr->flags], elPtr); + } +} + +/* + *-------------------------------------------------------------- + * + * OptionInit -- + * + * Initialize data structures for option handling. + * + * Results: + * None. + * + * Side effects: + * Option-related data structures get initialized. + * + *-------------------------------------------------------------- + */ + +static void +OptionInit(mainPtr) + register TkMainInfo *mainPtr; /* Top-level information about + * window that isn't initialized + * yet. */ +{ + int i; + Tcl_Interp *interp; + + /* + * First, once-only initialization. + */ + + if (numLevels == 0) { + + numLevels = 5; + levels = (StackLevel *) ckalloc((unsigned) (5*sizeof(StackLevel))); + for (i = 0; i < NUM_STACKS; i++) { + stacks[i] = NewArray(10); + levels[0].bases[i] = 0; + } + + defaultMatch.nameUid = NULL; + defaultMatch.child.valueUid = NULL; + defaultMatch.priority = -1; + defaultMatch.flags = 0; + } + + /* + * Then, per-main-window initialization. Create and delete dummy + * interpreter for message logging. + */ + + mainPtr->optionRootPtr = NewArray(20); + interp = Tcl_CreateInterp(); + (void) GetDefaultOptions(interp, mainPtr->winPtr); + Tcl_DeleteInterp(interp); +} + +/* + *-------------------------------------------------------------- + * + * ClearOptionTree -- + * + * This procedure is called to erase everything in a + * hierarchical option database. + * + * Results: + * None. + * + * Side effects: + * All the options associated with arrayPtr are deleted, + * along with all option subtrees. The space pointed to + * by arrayPtr is freed. + * + *-------------------------------------------------------------- + */ + +static void +ClearOptionTree(arrayPtr) + ElArray *arrayPtr; /* Array of options; delete everything + * referred to recursively by this. */ +{ + register Element *elPtr; + int count; + + for (count = arrayPtr->numUsed, elPtr = arrayPtr->els; count > 0; + count--, elPtr++) { + if (elPtr->flags & NODE) { + ClearOptionTree(elPtr->child.arrayPtr); + } + } + ckfree((char *) arrayPtr); +} + +/* + *-------------------------------------------------------------- + * + * GetDefaultOptions -- + * + * This procedure is invoked to load the default set of options + * for a window. + * + * Results: + * None. + * + * Side effects: + * Options are added to those for winPtr's main window. If + * there exists a RESOURCE_MANAGER proprety for winPtr's + * display, that is used. Otherwise, the .Xdefaults file in + * the user's home directory is used. + * + *-------------------------------------------------------------- + */ + +static int +GetDefaultOptions(interp, winPtr) + Tcl_Interp *interp; /* Interpreter to use for error reporting. */ + TkWindow *winPtr; /* Fetch option defaults for main window + * associated with this. */ +{ + char *regProp; + int result, actualFormat; + unsigned long numItems, bytesAfter; + Atom actualType; + + /* + * Try the RESOURCE_MANAGER property on the root window first. + */ + + regProp = NULL; + result = XGetWindowProperty(winPtr->display, + RootWindow(winPtr->display, 0), + XA_RESOURCE_MANAGER, 0, 100000, + False, XA_STRING, &actualType, &actualFormat, + &numItems, &bytesAfter, (unsigned char **) ®Prop); + + if ((result == Success) && (actualType == XA_STRING) + && (actualFormat == 8)) { + result = AddFromString(interp, (Tk_Window) winPtr, regProp, + TK_USER_DEFAULT_PRIO); + XFree(regProp); + return result; + } + + /* + * No luck there. Try a .Xdefaults file in the user's home + * directory. + */ + + if (regProp != NULL) { + XFree(regProp); + } + result = ReadOptionFile(interp, (Tk_Window) winPtr, "~/.Xdefaults", + TK_USER_DEFAULT_PRIO); + return result; +} diff --git a/generic/tkPack.c b/generic/tkPack.c new file mode 100644 index 0000000..4ff1049 --- /dev/null +++ b/generic/tkPack.c @@ -0,0 +1,1727 @@ +/* + * tkPack.c -- + * + * This file contains code to implement the "packer" + * geometry manager for Tk. + * + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkPack.c 1.64 96/05/03 10:51:52 + */ + +#include "tkPort.h" +#include "tkInt.h" + +typedef enum {TOP, BOTTOM, LEFT, RIGHT} Side; + +/* For each window that the packer cares about (either because + * the window is managed by the packer or because the window + * has slaves that are managed by the packer), there is a + * structure of the following type: + */ + +typedef struct Packer { + Tk_Window tkwin; /* Tk token for window. NULL means that + * the window has been deleted, but the + * packet hasn't had a chance to clean up + * yet because the structure is still in + * use. */ + struct Packer *masterPtr; /* Master window within which this window + * is packed (NULL means this window + * isn't managed by the packer). */ + struct Packer *nextPtr; /* Next window packed within same + * parent. List is priority-ordered: + * first on list gets packed first. */ + struct Packer *slavePtr; /* First in list of slaves packed + * inside this window (NULL means + * no packed slaves). */ + Side side; /* Side of parent against which + * this window is packed. */ + Tk_Anchor anchor; /* If frame allocated for window is larger + * than window needs, this indicates how + * where to position window in frame. */ + int padX, padY; /* Total additional pixels to leave around the + * window (half of this space is left on each + * side). This is space *outside* the window: + * we'll allocate extra space in frame but + * won't enlarge window). */ + int iPadX, iPadY; /* Total extra pixels to allocate inside the + * window (half this amount will appear on + * each side). */ + int doubleBw; /* Twice the window's last known border + * width. If this changes, the window + * must be repacked within its parent. */ + int *abortPtr; /* If non-NULL, it means that there is a nested + * call to ArrangePacking already working on + * this window. *abortPtr may be set to 1 to + * abort that nested call. This happens, for + * example, if tkwin or any of its slaves + * is deleted. */ + int flags; /* Miscellaneous flags; see below + * for definitions. */ +} Packer; + +/* + * Flag values for Packer structures: + * + * REQUESTED_REPACK: 1 means a Tcl_DoWhenIdle request + * has already been made to repack + * all the slaves of this window. + * FILLX: 1 means if frame allocated for window + * is wider than window needs, expand window + * to fill frame. 0 means don't make window + * any larger than needed. + * FILLY: Same as FILLX, except for height. + * EXPAND: 1 means this window's frame will absorb any + * extra space in the parent window. + * OLD_STYLE: 1 means this window is being managed with + * the old-style packer algorithms (before + * Tk version 3.3). The main difference is + * that padding and filling are done differently. + * DONT_PROPAGATE: 1 means don't set this window's requested + * size. 0 means if this window is a master + * then Tk will set its requested size to fit + * the needs of its slaves. + */ + +#define REQUESTED_REPACK 1 +#define FILLX 2 +#define FILLY 4 +#define EXPAND 8 +#define OLD_STYLE 16 +#define DONT_PROPAGATE 32 + +/* + * Hash table used to map from Tk_Window tokens to corresponding + * Packer structures: + */ + +static Tcl_HashTable packerHashTable; + +/* + * Have statics in this module been initialized? + */ + +static int initialized = 0; + +/* + * The following structure is the official type record for the + * packer: + */ + +static void PackReqProc _ANSI_ARGS_((ClientData clientData, + Tk_Window tkwin)); +static void PackLostSlaveProc _ANSI_ARGS_((ClientData clientData, + Tk_Window tkwin)); + +static Tk_GeomMgr packerType = { + "pack", /* name */ + PackReqProc, /* requestProc */ + PackLostSlaveProc, /* lostSlaveProc */ +}; + +/* + * Forward declarations for procedures defined later in this file: + */ + +static void ArrangePacking _ANSI_ARGS_((ClientData clientData)); +static int ConfigureSlaves _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, int argc, char *argv[])); +static void DestroyPacker _ANSI_ARGS_((char *memPtr)); +static Packer * GetPacker _ANSI_ARGS_((Tk_Window tkwin)); +static int PackAfter _ANSI_ARGS_((Tcl_Interp *interp, + Packer *prevPtr, Packer *masterPtr, int argc, + char **argv)); +static void PackReqProc _ANSI_ARGS_((ClientData clientData, + Tk_Window tkwin)); +static void PackStructureProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +static void Unlink _ANSI_ARGS_((Packer *packPtr)); +static int XExpansion _ANSI_ARGS_((Packer *slavePtr, + int cavityWidth)); +static int YExpansion _ANSI_ARGS_((Packer *slavePtr, + int cavityHeight)); + +/* + *-------------------------------------------------------------- + * + * Tk_PackCmd -- + * + * This procedure is invoked to process the "pack" 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_PackCmd(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; + size_t length; + int c; + + if ((argc >= 2) && (argv[1][0] == '.')) { + return ConfigureSlaves(interp, tkwin, argc-1, argv+1); + } + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " option arg ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + c = argv[1][0]; + length = strlen(argv[1]); + if ((c == 'a') && (length >= 2) + && (strncmp(argv[1], "after", length) == 0)) { + Packer *prevPtr; + Tk_Window tkwin2; + + tkwin2 = Tk_NameToWindow(interp, argv[2], tkwin); + if (tkwin2 == NULL) { + return TCL_ERROR; + } + prevPtr = GetPacker(tkwin2); + if (prevPtr->masterPtr == NULL) { + Tcl_AppendResult(interp, "window \"", argv[2], + "\" isn't packed", (char *) NULL); + return TCL_ERROR; + } + return PackAfter(interp, prevPtr, prevPtr->masterPtr, argc-3, argv+3); + } else if ((c == 'a') && (length >= 2) + && (strncmp(argv[1], "append", length) == 0)) { + Packer *masterPtr; + register Packer *prevPtr; + Tk_Window tkwin2; + + tkwin2 = Tk_NameToWindow(interp, argv[2], tkwin); + if (tkwin2 == NULL) { + return TCL_ERROR; + } + masterPtr = GetPacker(tkwin2); + prevPtr = masterPtr->slavePtr; + if (prevPtr != NULL) { + while (prevPtr->nextPtr != NULL) { + prevPtr = prevPtr->nextPtr; + } + } + return PackAfter(interp, prevPtr, masterPtr, argc-3, argv+3); + } else if ((c == 'b') && (strncmp(argv[1], "before", length) == 0)) { + Packer *packPtr, *masterPtr; + register Packer *prevPtr; + Tk_Window tkwin2; + + tkwin2 = Tk_NameToWindow(interp, argv[2], tkwin); + if (tkwin2 == NULL) { + return TCL_ERROR; + } + packPtr = GetPacker(tkwin2); + if (packPtr->masterPtr == NULL) { + Tcl_AppendResult(interp, "window \"", argv[2], + "\" isn't packed", (char *) NULL); + return TCL_ERROR; + } + masterPtr = packPtr->masterPtr; + prevPtr = masterPtr->slavePtr; + if (prevPtr == packPtr) { + prevPtr = NULL; + } else { + for ( ; ; prevPtr = prevPtr->nextPtr) { + if (prevPtr == NULL) { + panic("\"pack before\" couldn't find predecessor"); + } + if (prevPtr->nextPtr == packPtr) { + break; + } + } + } + return PackAfter(interp, prevPtr, masterPtr, argc-3, argv+3); + } else if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0)) { + if (argv[2][0] != '.') { + Tcl_AppendResult(interp, "bad argument \"", argv[2], + "\": must be name of window", (char *) NULL); + return TCL_ERROR; + } + return ConfigureSlaves(interp, tkwin, argc-2, argv+2); + } else if ((c == 'f') && (strncmp(argv[1], "forget", length) == 0)) { + Tk_Window slave; + Packer *slavePtr; + int i; + + for (i = 2; i < argc; i++) { + slave = Tk_NameToWindow(interp, argv[i], tkwin); + if (slave == NULL) { + continue; + } + slavePtr = GetPacker(slave); + if ((slavePtr != NULL) && (slavePtr->masterPtr != NULL)) { + Tk_ManageGeometry(slave, (Tk_GeomMgr *) NULL, + (ClientData) NULL); + if (slavePtr->masterPtr->tkwin != Tk_Parent(slavePtr->tkwin)) { + Tk_UnmaintainGeometry(slavePtr->tkwin, + slavePtr->masterPtr->tkwin); + } + Unlink(slavePtr); + Tk_UnmapWindow(slavePtr->tkwin); + } + } + } else if ((c == 'i') && (strncmp(argv[1], "info", length) == 0)) { + register Packer *slavePtr; + Tk_Window slave; + char buffer[300]; + static char *sideNames[] = {"top", "bottom", "left", "right"}; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " info window\"", (char *) NULL); + return TCL_ERROR; + } + slave = Tk_NameToWindow(interp, argv[2], tkwin); + if (slave == NULL) { + return TCL_ERROR; + } + slavePtr = GetPacker(slave); + if (slavePtr->masterPtr == NULL) { + Tcl_AppendResult(interp, "window \"", argv[2], + "\" isn't packed", (char *) NULL); + return TCL_ERROR; + } + Tcl_AppendElement(interp, "-in"); + Tcl_AppendElement(interp, Tk_PathName(slavePtr->masterPtr->tkwin)); + Tcl_AppendElement(interp, "-anchor"); + Tcl_AppendElement(interp, Tk_NameOfAnchor(slavePtr->anchor)); + Tcl_AppendResult(interp, " -expand ", + (slavePtr->flags & EXPAND) ? "1" : "0", " -fill ", + (char *) NULL); + switch (slavePtr->flags & (FILLX|FILLY)) { + case 0: + Tcl_AppendResult(interp, "none", (char *) NULL); + break; + case FILLX: + Tcl_AppendResult(interp, "x", (char *) NULL); + break; + case FILLY: + Tcl_AppendResult(interp, "y", (char *) NULL); + break; + case FILLX|FILLY: + Tcl_AppendResult(interp, "both", (char *) NULL); + break; + } + sprintf(buffer, " -ipadx %d -ipady %d -padx %d -pady %d", + slavePtr->iPadX/2, slavePtr->iPadY/2, slavePtr->padX/2, + slavePtr->padY/2); + Tcl_AppendResult(interp, buffer, " -side ", sideNames[slavePtr->side], + (char *) NULL); + } else if ((c == 'p') && (strncmp(argv[1], "propagate", length) == 0)) { + Tk_Window master; + Packer *masterPtr; + int propagate; + + if (argc > 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " propagate window ?boolean?\"", (char *) NULL); + return TCL_ERROR; + } + master = Tk_NameToWindow(interp, argv[2], tkwin); + if (master == NULL) { + return TCL_ERROR; + } + masterPtr = GetPacker(master); + if (argc == 3) { + if (masterPtr->flags & DONT_PROPAGATE) { + interp->result = "0"; + } else { + interp->result = "1"; + } + return TCL_OK; + } + if (Tcl_GetBoolean(interp, argv[3], &propagate) != TCL_OK) { + return TCL_ERROR; + } + if (propagate) { + masterPtr->flags &= ~DONT_PROPAGATE; + + /* + * Repack the master to allow new geometry information to + * propagate upwards to the master's master. + */ + + if (masterPtr->abortPtr != NULL) { + *masterPtr->abortPtr = 1; + } + if (!(masterPtr->flags & REQUESTED_REPACK)) { + masterPtr->flags |= REQUESTED_REPACK; + Tcl_DoWhenIdle(ArrangePacking, (ClientData) masterPtr); + } + } else { + masterPtr->flags |= DONT_PROPAGATE; + } + } else if ((c == 's') && (strncmp(argv[1], "slaves", length) == 0)) { + Tk_Window master; + Packer *masterPtr, *slavePtr; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " slaves window\"", (char *) NULL); + return TCL_ERROR; + } + master = Tk_NameToWindow(interp, argv[2], tkwin); + if (master == NULL) { + return TCL_ERROR; + } + masterPtr = GetPacker(master); + for (slavePtr = masterPtr->slavePtr; slavePtr != NULL; + slavePtr = slavePtr->nextPtr) { + Tcl_AppendElement(interp, Tk_PathName(slavePtr->tkwin)); + } + } else if ((c == 'u') && (strncmp(argv[1], "unpack", length) == 0)) { + Tk_Window tkwin2; + Packer *packPtr; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " unpack window\"", (char *) NULL); + return TCL_ERROR; + } + tkwin2 = Tk_NameToWindow(interp, argv[2], tkwin); + if (tkwin2 == NULL) { + return TCL_ERROR; + } + packPtr = GetPacker(tkwin2); + if ((packPtr != NULL) && (packPtr->masterPtr != NULL)) { + Tk_ManageGeometry(tkwin2, (Tk_GeomMgr *) NULL, + (ClientData) NULL); + if (packPtr->masterPtr->tkwin != Tk_Parent(packPtr->tkwin)) { + Tk_UnmaintainGeometry(packPtr->tkwin, + packPtr->masterPtr->tkwin); + } + Unlink(packPtr); + Tk_UnmapWindow(packPtr->tkwin); + } + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be configure, forget, info, ", + "propagate, or slaves", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * PackReqProc -- + * + * This procedure is invoked by Tk_GeometryRequest for + * windows managed by the packer. + * + * Results: + * None. + * + * Side effects: + * Arranges for tkwin, and all its managed siblings, to + * be re-packed at the next idle point. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +PackReqProc(clientData, tkwin) + ClientData clientData; /* Packer's information about + * window that got new preferred + * geometry. */ + Tk_Window tkwin; /* Other Tk-related information + * about the window. */ +{ + register Packer *packPtr = (Packer *) clientData; + + packPtr = packPtr->masterPtr; + if (!(packPtr->flags & REQUESTED_REPACK)) { + packPtr->flags |= REQUESTED_REPACK; + Tcl_DoWhenIdle(ArrangePacking, (ClientData) packPtr); + } +} + +/* + *-------------------------------------------------------------- + * + * PackLostSlaveProc -- + * + * This procedure is invoked by Tk whenever some other geometry + * claims control over a slave that used to be managed by us. + * + * Results: + * None. + * + * Side effects: + * Forgets all packer-related information about the slave. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +PackLostSlaveProc(clientData, tkwin) + ClientData clientData; /* Packer structure for slave window that + * was stolen away. */ + Tk_Window tkwin; /* Tk's handle for the slave window. */ +{ + register Packer *slavePtr = (Packer *) clientData; + + if (slavePtr->masterPtr->tkwin != Tk_Parent(slavePtr->tkwin)) { + Tk_UnmaintainGeometry(slavePtr->tkwin, slavePtr->masterPtr->tkwin); + } + Unlink(slavePtr); + Tk_UnmapWindow(slavePtr->tkwin); +} + +/* + *-------------------------------------------------------------- + * + * ArrangePacking -- + * + * This procedure is invoked (using the Tcl_DoWhenIdle + * mechanism) to re-layout a set of windows managed by + * the packer. It is invoked at idle time so that a + * series of packer requests can be merged into a single + * layout operation. + * + * Results: + * None. + * + * Side effects: + * The packed slaves of masterPtr may get resized or + * moved. + * + *-------------------------------------------------------------- + */ + +static void +ArrangePacking(clientData) + ClientData clientData; /* Structure describing parent whose slaves + * are to be re-layed out. */ +{ + register Packer *masterPtr = (Packer *) clientData; + register Packer *slavePtr; + int cavityX, cavityY, cavityWidth, cavityHeight; + /* These variables keep track of the + * as-yet-unallocated space remaining in + * the middle of the parent window. */ + int frameX, frameY, frameWidth, frameHeight; + /* These variables keep track of the frame + * allocated to the current window. */ + int x, y, width, height; /* These variables are used to hold the + * actual geometry of the current window. */ + int intBWidth; /* Width of internal border in parent window, + * if any. */ + int abort; /* May get set to non-zero to abort this + * repacking operation. */ + int borderX, borderY; + int maxWidth, maxHeight, tmp; + + masterPtr->flags &= ~REQUESTED_REPACK; + + /* + * If the parent has no slaves anymore, then don't do anything + * at all: just leave the parent's size as-is. + */ + + if (masterPtr->slavePtr == NULL) { + return; + } + + /* + * Abort any nested call to ArrangePacking for this window, since + * we'll do everything necessary here, and set up so this call + * can be aborted if necessary. + */ + + if (masterPtr->abortPtr != NULL) { + *masterPtr->abortPtr = 1; + } + masterPtr->abortPtr = &abort; + abort = 0; + Tcl_Preserve((ClientData) masterPtr); + + /* + * Pass #1: scan all the slaves to figure out the total amount + * of space needed. Two separate width and height values are + * computed: + * + * width - Holds the sum of the widths (plus padding) of + * all the slaves seen so far that were packed LEFT + * or RIGHT. + * height - Holds the sum of the heights (plus padding) of + * all the slaves seen so far that were packed TOP + * or BOTTOM. + * + * maxWidth - Gradually builds up the width needed by the master + * to just barely satisfy all the slave's needs. For + * each slave, the code computes the width needed for + * all the slaves so far and updates maxWidth if the + * new value is greater. + * maxHeight - Same as maxWidth, except keeps height info. + */ + + intBWidth = Tk_InternalBorderWidth(masterPtr->tkwin); + width = height = maxWidth = maxHeight = 2*intBWidth; + for (slavePtr = masterPtr->slavePtr; slavePtr != NULL; + slavePtr = slavePtr->nextPtr) { + if ((slavePtr->side == TOP) || (slavePtr->side == BOTTOM)) { + tmp = Tk_ReqWidth(slavePtr->tkwin) + slavePtr->doubleBw + + slavePtr->padX + slavePtr->iPadX + width; + if (tmp > maxWidth) { + maxWidth = tmp; + } + height += Tk_ReqHeight(slavePtr->tkwin) + slavePtr->doubleBw + + slavePtr->padY + slavePtr->iPadY; + } else { + tmp = Tk_ReqHeight(slavePtr->tkwin) + slavePtr->doubleBw + + slavePtr->padY + slavePtr->iPadY + height; + if (tmp > maxHeight) { + maxHeight = tmp; + } + width += Tk_ReqWidth(slavePtr->tkwin) + slavePtr->doubleBw + + slavePtr->padX + slavePtr->iPadX; + } + } + if (width > maxWidth) { + maxWidth = width; + } + if (height > maxHeight) { + maxHeight = height; + } + + /* + * If the total amount of space needed in the parent window has + * changed, and if we're propagating geometry information, then + * notify the next geometry manager up and requeue ourselves to + * start again after the parent has had a chance to + * resize us. + */ + + if (((maxWidth != Tk_ReqWidth(masterPtr->tkwin)) + || (maxHeight != Tk_ReqHeight(masterPtr->tkwin))) + && !(masterPtr->flags & DONT_PROPAGATE)) { + Tk_GeometryRequest(masterPtr->tkwin, maxWidth, maxHeight); + masterPtr->flags |= REQUESTED_REPACK; + Tcl_DoWhenIdle(ArrangePacking, (ClientData) masterPtr); + goto done; + } + + /* + * Pass #2: scan the slaves a second time assigning + * new sizes. The "cavity" variables keep track of the + * unclaimed space in the cavity of the window; this + * shrinks inward as we allocate windows around the + * edges. The "frame" variables keep track of the space + * allocated to the current window and its frame. The + * current window is then placed somewhere inside the + * frame, depending on anchor. + */ + + cavityX = cavityY = x = y = intBWidth; + cavityWidth = Tk_Width(masterPtr->tkwin) - 2*intBWidth; + cavityHeight = Tk_Height(masterPtr->tkwin) - 2*intBWidth; + for (slavePtr = masterPtr->slavePtr; slavePtr != NULL; + slavePtr = slavePtr->nextPtr) { + if ((slavePtr->side == TOP) || (slavePtr->side == BOTTOM)) { + frameWidth = cavityWidth; + frameHeight = Tk_ReqHeight(slavePtr->tkwin) + slavePtr->doubleBw + + slavePtr->padY + slavePtr->iPadY; + if (slavePtr->flags & EXPAND) { + frameHeight += YExpansion(slavePtr, cavityHeight); + } + cavityHeight -= frameHeight; + if (cavityHeight < 0) { + frameHeight += cavityHeight; + cavityHeight = 0; + } + frameX = cavityX; + if (slavePtr->side == TOP) { + frameY = cavityY; + cavityY += frameHeight; + } else { + frameY = cavityY + cavityHeight; + } + } else { + frameHeight = cavityHeight; + frameWidth = Tk_ReqWidth(slavePtr->tkwin) + slavePtr->doubleBw + + slavePtr->padX + slavePtr->iPadX; + if (slavePtr->flags & EXPAND) { + frameWidth += XExpansion(slavePtr, cavityWidth); + } + cavityWidth -= frameWidth; + if (cavityWidth < 0) { + frameWidth += cavityWidth; + cavityWidth = 0; + } + frameY = cavityY; + if (slavePtr->side == LEFT) { + frameX = cavityX; + cavityX += frameWidth; + } else { + frameX = cavityX + cavityWidth; + } + } + + /* + * Now that we've got the size of the frame for the window, + * compute the window's actual size and location using the + * fill, padding, and frame factors. The variables "borderX" + * and "borderY" are used to handle the differences between + * old-style packing and the new style (in old-style, iPadX + * and iPadY are always zero and padding is completely ignored + * except when computing frame size). + */ + + if (slavePtr->flags & OLD_STYLE) { + borderX = borderY = 0; + } else { + borderX = slavePtr->padX; + borderY = slavePtr->padY; + } + width = Tk_ReqWidth(slavePtr->tkwin) + slavePtr->doubleBw + + slavePtr->iPadX; + if ((slavePtr->flags & FILLX) + || (width > (frameWidth - borderX))) { + width = frameWidth - borderX; + } + height = Tk_ReqHeight(slavePtr->tkwin) + slavePtr->doubleBw + + slavePtr->iPadY; + if ((slavePtr->flags & FILLY) + || (height > (frameHeight - borderY))) { + height = frameHeight - borderY; + } + borderX /= 2; + borderY /= 2; + switch (slavePtr->anchor) { + case TK_ANCHOR_N: + x = frameX + (frameWidth - width)/2; + y = frameY + borderY; + break; + case TK_ANCHOR_NE: + x = frameX + frameWidth - width - borderX; + y = frameY + borderY; + break; + case TK_ANCHOR_E: + x = frameX + frameWidth - width - borderX; + y = frameY + (frameHeight - height)/2; + break; + case TK_ANCHOR_SE: + x = frameX + frameWidth - width - borderX; + y = frameY + frameHeight - height - borderY; + break; + case TK_ANCHOR_S: + x = frameX + (frameWidth - width)/2; + y = frameY + frameHeight - height - borderY; + break; + case TK_ANCHOR_SW: + x = frameX + borderX; + y = frameY + frameHeight - height - borderY; + break; + case TK_ANCHOR_W: + x = frameX + borderX; + y = frameY + (frameHeight - height)/2; + break; + case TK_ANCHOR_NW: + x = frameX + borderX; + y = frameY + borderY; + break; + case TK_ANCHOR_CENTER: + x = frameX + (frameWidth - width)/2; + y = frameY + (frameHeight - height)/2; + break; + default: + panic("bad frame factor in ArrangePacking"); + } + width -= slavePtr->doubleBw; + height -= slavePtr->doubleBw; + + /* + * The final step is to set the position, size, and mapped/unmapped + * state of the slave. If the slave is a child of the master, then + * do this here. Otherwise let Tk_MaintainGeometry do the work. + */ + + if (masterPtr->tkwin == Tk_Parent(slavePtr->tkwin)) { + if ((width <= 0) || (height <= 0)) { + Tk_UnmapWindow(slavePtr->tkwin); + } else { + if ((x != Tk_X(slavePtr->tkwin)) + || (y != Tk_Y(slavePtr->tkwin)) + || (width != Tk_Width(slavePtr->tkwin)) + || (height != Tk_Height(slavePtr->tkwin))) { + Tk_MoveResizeWindow(slavePtr->tkwin, x, y, width, height); + } + if (abort) { + goto done; + } + + /* + * Don't map the slave if the master isn't mapped: wait + * until the master gets mapped later. + */ + + if (Tk_IsMapped(masterPtr->tkwin)) { + Tk_MapWindow(slavePtr->tkwin); + } + } + } else { + if ((width <= 0) || (height <= 0)) { + Tk_UnmaintainGeometry(slavePtr->tkwin, masterPtr->tkwin); + Tk_UnmapWindow(slavePtr->tkwin); + } else { + Tk_MaintainGeometry(slavePtr->tkwin, masterPtr->tkwin, + x, y, width, height); + } + } + + /* + * Changes to the window's structure could cause almost anything + * to happen, including deleting the parent or child. If this + * happens, we'll be told to abort. + */ + + if (abort) { + goto done; + } + } + + done: + masterPtr->abortPtr = NULL; + Tcl_Release((ClientData) masterPtr); +} + +/* + *---------------------------------------------------------------------- + * + * XExpansion -- + * + * Given a list of packed slaves, the first of which is packed + * on the left or right and is expandable, compute how much to + * expand the child. + * + * Results: + * The return value is the number of additional pixels to give to + * the child. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +XExpansion(slavePtr, cavityWidth) + register Packer *slavePtr; /* First in list of remaining + * slaves. */ + int cavityWidth; /* Horizontal space left for all + * remaining slaves. */ +{ + int numExpand, minExpand, curExpand; + int childWidth; + + /* + * This procedure is tricky because windows packed top or bottom can + * be interspersed among expandable windows packed left or right. + * Scan through the list, keeping a running sum of the widths of + * all left and right windows (actually, count the cavity space not + * allocated) and a running count of all expandable left and right + * windows. At each top or bottom window, and at the end of the + * list, compute the expansion factor that seems reasonable at that + * point. Return the smallest factor seen at any of these points. + */ + + minExpand = cavityWidth; + numExpand = 0; + for ( ; slavePtr != NULL; slavePtr = slavePtr->nextPtr) { + childWidth = Tk_ReqWidth(slavePtr->tkwin) + slavePtr->doubleBw + + slavePtr->padX + slavePtr->iPadX; + if ((slavePtr->side == TOP) || (slavePtr->side == BOTTOM)) { + curExpand = (cavityWidth - childWidth)/numExpand; + if (curExpand < minExpand) { + minExpand = curExpand; + } + } else { + cavityWidth -= childWidth; + if (slavePtr->flags & EXPAND) { + numExpand++; + } + } + } + curExpand = cavityWidth/numExpand; + if (curExpand < minExpand) { + minExpand = curExpand; + } + return (minExpand < 0) ? 0 : minExpand; +} + +/* + *---------------------------------------------------------------------- + * + * YExpansion -- + * + * Given a list of packed slaves, the first of which is packed + * on the top or bottom and is expandable, compute how much to + * expand the child. + * + * Results: + * The return value is the number of additional pixels to give to + * the child. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +YExpansion(slavePtr, cavityHeight) + register Packer *slavePtr; /* First in list of remaining + * slaves. */ + int cavityHeight; /* Vertical space left for all + * remaining slaves. */ +{ + int numExpand, minExpand, curExpand; + int childHeight; + + /* + * See comments for XExpansion. + */ + + minExpand = cavityHeight; + numExpand = 0; + for ( ; slavePtr != NULL; slavePtr = slavePtr->nextPtr) { + childHeight = Tk_ReqHeight(slavePtr->tkwin) + slavePtr->doubleBw + + slavePtr->padY + slavePtr->iPadY; + if ((slavePtr->side == LEFT) || (slavePtr->side == RIGHT)) { + curExpand = (cavityHeight - childHeight)/numExpand; + if (curExpand < minExpand) { + minExpand = curExpand; + } + } else { + cavityHeight -= childHeight; + if (slavePtr->flags & EXPAND) { + numExpand++; + } + } + } + curExpand = cavityHeight/numExpand; + if (curExpand < minExpand) { + minExpand = curExpand; + } + return (minExpand < 0) ? 0 : minExpand; +} + +/* + *-------------------------------------------------------------- + * + * GetPacker -- + * + * This internal procedure is used to locate a Packer + * structure for a given window, creating one if one + * doesn't exist already. + * + * Results: + * The return value is a pointer to the Packer structure + * corresponding to tkwin. + * + * Side effects: + * A new packer structure may be created. If so, then + * a callback is set up to clean things up when the + * window is deleted. + * + *-------------------------------------------------------------- + */ + +static Packer * +GetPacker(tkwin) + Tk_Window tkwin; /* Token for window for which + * packer structure is desired. */ +{ + register Packer *packPtr; + Tcl_HashEntry *hPtr; + int new; + + if (!initialized) { + initialized = 1; + Tcl_InitHashTable(&packerHashTable, TCL_ONE_WORD_KEYS); + } + + /* + * See if there's already packer for this window. If not, + * then create a new one. + */ + + hPtr = Tcl_CreateHashEntry(&packerHashTable, (char *) tkwin, &new); + if (!new) { + return (Packer *) Tcl_GetHashValue(hPtr); + } + packPtr = (Packer *) ckalloc(sizeof(Packer)); + packPtr->tkwin = tkwin; + packPtr->masterPtr = NULL; + packPtr->nextPtr = NULL; + packPtr->slavePtr = NULL; + packPtr->side = TOP; + packPtr->anchor = TK_ANCHOR_CENTER; + packPtr->padX = packPtr->padY = 0; + packPtr->iPadX = packPtr->iPadY = 0; + packPtr->doubleBw = 2*Tk_Changes(tkwin)->border_width; + packPtr->abortPtr = NULL; + packPtr->flags = 0; + Tcl_SetHashValue(hPtr, packPtr); + Tk_CreateEventHandler(tkwin, StructureNotifyMask, + PackStructureProc, (ClientData) packPtr); + return packPtr; +} + +/* + *-------------------------------------------------------------- + * + * PackAfter -- + * + * This procedure does most of the real work of adding + * one or more windows into the packing order for its parent. + * + * Results: + * A standard Tcl return value. + * + * Side effects: + * The geometry of the specified windows may change, both now and + * again in the future. + * + *-------------------------------------------------------------- + */ + +static int +PackAfter(interp, prevPtr, masterPtr, argc, argv) + Tcl_Interp *interp; /* Interpreter for error reporting. */ + Packer *prevPtr; /* Pack windows in argv just after this + * window; NULL means pack as first + * child of masterPtr. */ + Packer *masterPtr; /* Master in which to pack windows. */ + int argc; /* Number of elements in argv. */ + char **argv; /* Array of lists, each containing 2 + * elements: window name and side + * against which to pack. */ +{ + register Packer *packPtr; + Tk_Window tkwin, ancestor, parent; + size_t length; + char **options; + int index, tmp, optionCount, c; + + /* + * Iterate over all of the window specifiers, each consisting of + * two arguments. The first argument contains the window name and + * the additional arguments contain options such as "top" or + * "padx 20". + */ + + for ( ; argc > 0; argc -= 2, argv += 2, prevPtr = packPtr) { + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: window \"", + argv[0], "\" should be followed by options", + (char *) NULL); + return TCL_ERROR; + } + + /* + * Find the packer for the window to be packed, and make sure + * that the window in which it will be packed is either its + * or a descendant of its parent. + */ + + tkwin = Tk_NameToWindow(interp, argv[0], masterPtr->tkwin); + if (tkwin == NULL) { + return TCL_ERROR; + } + + parent = Tk_Parent(tkwin); + for (ancestor = masterPtr->tkwin; ; ancestor = Tk_Parent(ancestor)) { + if (ancestor == parent) { + break; + } + if (((Tk_FakeWin *) (ancestor))->flags & TK_TOP_LEVEL) { + badWindow: + Tcl_AppendResult(interp, "can't pack ", argv[0], + " inside ", Tk_PathName(masterPtr->tkwin), + (char *) NULL); + return TCL_ERROR; + } + } + if (((Tk_FakeWin *) (tkwin))->flags & TK_TOP_LEVEL) { + goto badWindow; + } + if (tkwin == masterPtr->tkwin) { + goto badWindow; + } + packPtr = GetPacker(tkwin); + + /* + * Process options for this window. + */ + + if (Tcl_SplitList(interp, argv[1], &optionCount, &options) != TCL_OK) { + return TCL_ERROR; + } + packPtr->side = TOP; + packPtr->anchor = TK_ANCHOR_CENTER; + packPtr->padX = packPtr->padY = 0; + packPtr->iPadX = packPtr->iPadY = 0; + packPtr->flags &= ~(FILLX|FILLY|EXPAND); + packPtr->flags |= OLD_STYLE; + for (index = 0 ; index < optionCount; index++) { + char *curOpt = options[index]; + + c = curOpt[0]; + length = strlen(curOpt); + + if ((c == 't') + && (strncmp(curOpt, "top", length)) == 0) { + packPtr->side = TOP; + } else if ((c == 'b') + && (strncmp(curOpt, "bottom", length)) == 0) { + packPtr->side = BOTTOM; + } else if ((c == 'l') + && (strncmp(curOpt, "left", length)) == 0) { + packPtr->side = LEFT; + } else if ((c == 'r') + && (strncmp(curOpt, "right", length)) == 0) { + packPtr->side = RIGHT; + } else if ((c == 'e') + && (strncmp(curOpt, "expand", length)) == 0) { + packPtr->flags |= EXPAND; + } else if ((c == 'f') + && (strcmp(curOpt, "fill")) == 0) { + packPtr->flags |= FILLX|FILLY; + } else if ((length == 5) && (strcmp(curOpt, "fillx")) == 0) { + packPtr->flags |= FILLX; + } else if ((length == 5) && (strcmp(curOpt, "filly")) == 0) { + packPtr->flags |= FILLY; + } else if ((c == 'p') && (strcmp(curOpt, "padx")) == 0) { + if (optionCount < (index+2)) { + missingPad: + Tcl_AppendResult(interp, "wrong # args: \"", curOpt, + "\" option must be followed by screen distance", + (char *) NULL); + goto error; + } + if ((Tk_GetPixels(interp, tkwin, options[index+1], &tmp) + != TCL_OK) || (tmp < 0)) { + badPad: + Tcl_AppendResult(interp, "bad pad value \"", + options[index+1], + "\": must be positive screen distance", + (char *) NULL); + goto error; + } + packPtr->padX = tmp; + packPtr->iPadX = 0; + index++; + } else if ((c == 'p') && (strcmp(curOpt, "pady")) == 0) { + if (optionCount < (index+2)) { + goto missingPad; + } + if ((Tk_GetPixels(interp, tkwin, options[index+1], &tmp) + != TCL_OK) || (tmp < 0)) { + goto badPad; + } + packPtr->padY = tmp; + packPtr->iPadY = 0; + index++; + } else if ((c == 'f') && (length > 1) + && (strncmp(curOpt, "frame", length) == 0)) { + if (optionCount < (index+2)) { + Tcl_AppendResult(interp, "wrong # args: \"frame\" ", + "option must be followed by anchor point", + (char *) NULL); + goto error; + } + if (Tk_GetAnchor(interp, options[index+1], + &packPtr->anchor) != TCL_OK) { + goto error; + } + index++; + } else { + Tcl_AppendResult(interp, "bad option \"", curOpt, + "\": should be top, bottom, left, right, ", + "expand, fill, fillx, filly, padx, pady, or frame", + (char *) NULL); + goto error; + } + } + + if (packPtr != prevPtr) { + + /* + * Unpack this window if it's currently packed. + */ + + if (packPtr->masterPtr != NULL) { + if ((packPtr->masterPtr != masterPtr) && + (packPtr->masterPtr->tkwin + != Tk_Parent(packPtr->tkwin))) { + Tk_UnmaintainGeometry(packPtr->tkwin, + packPtr->masterPtr->tkwin); + } + Unlink(packPtr); + } + + /* + * Add the window in the correct place in its parent's + * packing order, then make sure that the window is + * managed by us. + */ + + packPtr->masterPtr = masterPtr; + if (prevPtr == NULL) { + packPtr->nextPtr = masterPtr->slavePtr; + masterPtr->slavePtr = packPtr; + } else { + packPtr->nextPtr = prevPtr->nextPtr; + prevPtr->nextPtr = packPtr; + } + Tk_ManageGeometry(tkwin, &packerType, (ClientData) packPtr); + } + ckfree((char *) options); + } + + /* + * Arrange for the parent to be re-packed at the first + * idle moment. + */ + + if (masterPtr->abortPtr != NULL) { + *masterPtr->abortPtr = 1; + } + if (!(masterPtr->flags & REQUESTED_REPACK)) { + masterPtr->flags |= REQUESTED_REPACK; + Tcl_DoWhenIdle(ArrangePacking, (ClientData) masterPtr); + } + return TCL_OK; + + error: + ckfree((char *) options); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * Unlink -- + * + * Remove a packer from its parent's list of slaves. + * + * Results: + * None. + * + * Side effects: + * The parent will be scheduled for repacking. + * + *---------------------------------------------------------------------- + */ + +static void +Unlink(packPtr) + register Packer *packPtr; /* Window to unlink. */ +{ + register Packer *masterPtr, *packPtr2; + + masterPtr = packPtr->masterPtr; + if (masterPtr == NULL) { + return; + } + if (masterPtr->slavePtr == packPtr) { + masterPtr->slavePtr = packPtr->nextPtr; + } else { + for (packPtr2 = masterPtr->slavePtr; ; packPtr2 = packPtr2->nextPtr) { + if (packPtr2 == NULL) { + panic("Unlink couldn't find previous window"); + } + if (packPtr2->nextPtr == packPtr) { + packPtr2->nextPtr = packPtr->nextPtr; + break; + } + } + } + if (!(masterPtr->flags & REQUESTED_REPACK)) { + masterPtr->flags |= REQUESTED_REPACK; + Tcl_DoWhenIdle(ArrangePacking, (ClientData) masterPtr); + } + if (masterPtr->abortPtr != NULL) { + *masterPtr->abortPtr = 1; + } + + packPtr->masterPtr = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * DestroyPacker -- + * + * This procedure is invoked by Tcl_EventuallyFree or Tcl_Release + * to clean up the internal structure of a packer at a safe time + * (when no-one is using it anymore). + * + * Results: + * None. + * + * Side effects: + * Everything associated with the packer is freed up. + * + *---------------------------------------------------------------------- + */ + +static void +DestroyPacker(memPtr) + char *memPtr; /* Info about packed window that + * is now dead. */ +{ + register Packer *packPtr = (Packer *) memPtr; + ckfree((char *) packPtr); +} + +/* + *---------------------------------------------------------------------- + * + * PackStructureProc -- + * + * This procedure is invoked by the Tk event dispatcher in response + * to StructureNotify events. + * + * Results: + * None. + * + * Side effects: + * If a window was just deleted, clean up all its packer-related + * information. If it was just resized, repack its slaves, if + * any. + * + *---------------------------------------------------------------------- + */ + +static void +PackStructureProc(clientData, eventPtr) + ClientData clientData; /* Our information about window + * referred to by eventPtr. */ + XEvent *eventPtr; /* Describes what just happened. */ +{ + register Packer *packPtr = (Packer *) clientData; + if (eventPtr->type == ConfigureNotify) { + if ((packPtr->slavePtr != NULL) + && !(packPtr->flags & REQUESTED_REPACK)) { + packPtr->flags |= REQUESTED_REPACK; + Tcl_DoWhenIdle(ArrangePacking, (ClientData) packPtr); + } + if (packPtr->doubleBw != 2*Tk_Changes(packPtr->tkwin)->border_width) { + if ((packPtr->masterPtr != NULL) + && !(packPtr->masterPtr->flags & REQUESTED_REPACK)) { + packPtr->doubleBw = 2*Tk_Changes(packPtr->tkwin)->border_width; + packPtr->masterPtr->flags |= REQUESTED_REPACK; + Tcl_DoWhenIdle(ArrangePacking, (ClientData) packPtr->masterPtr); + } + } + } else if (eventPtr->type == DestroyNotify) { + register Packer *slavePtr, *nextPtr; + + if (packPtr->masterPtr != NULL) { + Unlink(packPtr); + } + for (slavePtr = packPtr->slavePtr; slavePtr != NULL; + slavePtr = nextPtr) { + Tk_ManageGeometry(slavePtr->tkwin, (Tk_GeomMgr *) NULL, + (ClientData) NULL); + Tk_UnmapWindow(slavePtr->tkwin); + slavePtr->masterPtr = NULL; + nextPtr = slavePtr->nextPtr; + slavePtr->nextPtr = NULL; + } + Tcl_DeleteHashEntry(Tcl_FindHashEntry(&packerHashTable, + (char *) packPtr->tkwin)); + if (packPtr->flags & REQUESTED_REPACK) { + Tcl_CancelIdleCall(ArrangePacking, (ClientData) packPtr); + } + packPtr->tkwin = NULL; + Tcl_EventuallyFree((ClientData) packPtr, DestroyPacker); + } else if (eventPtr->type == MapNotify) { + /* + * When a master gets mapped, must redo the geometry computation + * so that all of its slaves get remapped. + */ + + if ((packPtr->slavePtr != NULL) + && !(packPtr->flags & REQUESTED_REPACK)) { + packPtr->flags |= REQUESTED_REPACK; + Tcl_DoWhenIdle(ArrangePacking, (ClientData) packPtr); + } + } else if (eventPtr->type == UnmapNotify) { + Packer *packPtr2; + + /* + * Unmap all of the slaves when the master gets unmapped, + * so that they don't bother to keep redisplaying + * themselves. + */ + + for (packPtr2 = packPtr->slavePtr; packPtr2 != NULL; + packPtr2 = packPtr2->nextPtr) { + Tk_UnmapWindow(packPtr2->tkwin); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * ConfigureSlaves -- + * + * This implements the guts of the "pack configure" command. Given + * a list of slaves and configuration options, it arranges for the + * packer to manage the slaves and sets the specified options. + * + * Results: + * TCL_OK is returned if all went well. Otherwise, TCL_ERROR is + * returned and interp->result is set to contain an error message. + * + * Side effects: + * Slave windows get taken over by the packer. + * + *---------------------------------------------------------------------- + */ + +static int +ConfigureSlaves(interp, tkwin, argc, argv) + Tcl_Interp *interp; /* Interpreter for error reporting. */ + Tk_Window tkwin; /* Any window in application containing + * slaves. Used to look up slave names. */ + int argc; /* Number of elements in argv. */ + char *argv[]; /* Argument strings: contains one or more + * window names followed by any number + * of "option value" pairs. Caller must + * make sure that there is at least one + * window name. */ +{ + Packer *masterPtr, *slavePtr, *prevPtr, *otherPtr; + Tk_Window other, slave, parent, ancestor; + int i, j, numWindows, c, tmp, positionGiven; + size_t length; + + /* + * Find out how many windows are specified. + */ + + for (numWindows = 0; numWindows < argc; numWindows++) { + if (argv[numWindows][0] != '.') { + break; + } + } + + /* + * Iterate over all of the slave windows, parsing the configuration + * options for each slave. It's a bit wasteful to re-parse the + * options for each slave, but things get too messy if we try to + * parse the arguments just once at the beginning. For example, + * if a slave already is packed we want to just change a few + * existing values without resetting everything. If there are + * multiple windows, the -after, -before, and -in options only + * get processed for the first window. + */ + + masterPtr = NULL; + prevPtr = NULL; + positionGiven = 0; + for (j = 0; j < numWindows; j++) { + slave = Tk_NameToWindow(interp, argv[j], tkwin); + if (slave == NULL) { + return TCL_ERROR; + } + if (Tk_IsTopLevel(slave)) { + Tcl_AppendResult(interp, "can't pack \"", argv[j], + "\": it's a top-level window", (char *) NULL); + return TCL_ERROR; + } + slavePtr = GetPacker(slave); + slavePtr->flags &= ~OLD_STYLE; + + /* + * If the slave isn't currently packed, reset all of its + * configuration information to default values (there could + * be old values left from a previous packing). + */ + + if (slavePtr->masterPtr == NULL) { + slavePtr->side = TOP; + slavePtr->anchor = TK_ANCHOR_CENTER; + slavePtr->padX = slavePtr->padY = 0; + slavePtr->iPadX = slavePtr->iPadY = 0; + slavePtr->flags &= ~(FILLX|FILLY|EXPAND); + } + + for (i = numWindows; i < argc; i+=2) { + if ((i+2) > argc) { + Tcl_AppendResult(interp, "extra option \"", argv[i], + "\" (option with no value?)", (char *) NULL); + return TCL_ERROR; + } + length = strlen(argv[i]); + if (length < 2) { + goto badOption; + } + c = argv[i][1]; + if ((c == 'a') && (strncmp(argv[i], "-after", length) == 0) + && (length >= 2)) { + if (j == 0) { + other = Tk_NameToWindow(interp, argv[i+1], tkwin); + if (other == NULL) { + return TCL_ERROR; + } + prevPtr = GetPacker(other); + if (prevPtr->masterPtr == NULL) { + notPacked: + Tcl_AppendResult(interp, "window \"", argv[i+1], + "\" isn't packed", (char *) NULL); + return TCL_ERROR; + } + masterPtr = prevPtr->masterPtr; + positionGiven = 1; + } + } else if ((c == 'a') && (strncmp(argv[i], "-anchor", length) == 0) + && (length >= 2)) { + if (Tk_GetAnchor(interp, argv[i+1], &slavePtr->anchor) + != TCL_OK) { + return TCL_ERROR; + } + } else if ((c == 'b') + && (strncmp(argv[i], "-before", length) == 0)) { + if (j == 0) { + other = Tk_NameToWindow(interp, argv[i+1], tkwin); + if (other == NULL) { + return TCL_ERROR; + } + otherPtr = GetPacker(other); + if (otherPtr->masterPtr == NULL) { + goto notPacked; + } + masterPtr = otherPtr->masterPtr; + prevPtr = masterPtr->slavePtr; + if (prevPtr == otherPtr) { + prevPtr = NULL; + } else { + while (prevPtr->nextPtr != otherPtr) { + prevPtr = prevPtr->nextPtr; + } + } + positionGiven = 1; + } + } else if ((c == 'e') + && (strncmp(argv[i], "-expand", length) == 0)) { + if (Tcl_GetBoolean(interp, argv[i+1], &tmp) != TCL_OK) { + return TCL_ERROR; + } + slavePtr->flags &= ~EXPAND; + if (tmp) { + slavePtr->flags |= EXPAND; + } + } else if ((c == 'f') && (strncmp(argv[i], "-fill", length) == 0)) { + if (strcmp(argv[i+1], "none") == 0) { + slavePtr->flags &= ~(FILLX|FILLY); + } else if (strcmp(argv[i+1], "x") == 0) { + slavePtr->flags = (slavePtr->flags & ~FILLY) | FILLX; + } else if (strcmp(argv[i+1], "y") == 0) { + slavePtr->flags = (slavePtr->flags & ~FILLX) | FILLY; + } else if (strcmp(argv[i+1], "both") == 0) { + slavePtr->flags |= FILLX|FILLY; + } else { + Tcl_AppendResult(interp, "bad fill style \"", argv[i+1], + "\": must be none, x, y, or both", (char *) NULL); + return TCL_ERROR; + } + } else if ((c == 'i') && (strcmp(argv[i], "-in") == 0)) { + if (j == 0) { + other = Tk_NameToWindow(interp, argv[i+1], tkwin); + if (other == NULL) { + return TCL_ERROR; + } + masterPtr = GetPacker(other); + prevPtr = masterPtr->slavePtr; + if (prevPtr != NULL) { + while (prevPtr->nextPtr != NULL) { + prevPtr = prevPtr->nextPtr; + } + } + positionGiven = 1; + } + } else if ((c == 'i') && (strcmp(argv[i], "-ipadx") == 0)) { + if ((Tk_GetPixels(interp, slave, argv[i+1], &tmp) != TCL_OK) + || (tmp < 0)) { + badPad: + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad pad value \"", argv[i+1], + "\": must be positive screen distance", + (char *) NULL); + return TCL_ERROR; + } + slavePtr->iPadX = tmp*2; + } else if ((c == 'i') && (strcmp(argv[i], "-ipady") == 0)) { + if ((Tk_GetPixels(interp, slave, argv[i+1], &tmp) != TCL_OK) + || (tmp< 0)) { + goto badPad; + } + slavePtr->iPadY = tmp*2; + } else if ((c == 'p') && (strcmp(argv[i], "-padx") == 0)) { + if ((Tk_GetPixels(interp, slave, argv[i+1], &tmp) != TCL_OK) + || (tmp< 0)) { + goto badPad; + } + slavePtr->padX = tmp*2; + } else if ((c == 'p') && (strcmp(argv[i], "-pady") == 0)) { + if ((Tk_GetPixels(interp, slave, argv[i+1], &tmp) != TCL_OK) + || (tmp< 0)) { + goto badPad; + } + slavePtr->padY = tmp*2; + } else if ((c == 's') && (strncmp(argv[i], "-side", length) == 0)) { + c = argv[i+1][0]; + if ((c == 't') && (strcmp(argv[i+1], "top") == 0)) { + slavePtr->side = TOP; + } else if ((c == 'b') && (strcmp(argv[i+1], "bottom") == 0)) { + slavePtr->side = BOTTOM; + } else if ((c == 'l') && (strcmp(argv[i+1], "left") == 0)) { + slavePtr->side = LEFT; + } else if ((c == 'r') && (strcmp(argv[i+1], "right") == 0)) { + slavePtr->side = RIGHT; + } else { + Tcl_AppendResult(interp, "bad side \"", argv[i+1], + "\": must be top, bottom, left, or right", + (char *) NULL); + return TCL_ERROR; + } + } else { + badOption: + Tcl_AppendResult(interp, "unknown or ambiguous option \"", + argv[i], "\": must be -after, -anchor, -before, ", + "-expand, -fill, -in, -ipadx, -ipady, -padx, ", + "-pady, or -side", (char *) NULL); + return TCL_ERROR; + } + } + + /* + * If no position in a packing list was specified and the slave + * is already packed, then leave it in its current location in + * its current packing list. + */ + + if (!positionGiven && (slavePtr->masterPtr != NULL)) { + masterPtr = slavePtr->masterPtr; + goto scheduleLayout; + } + + /* + * If the slave is going to be put back after itself then + * skip the whole operation, since it won't work anyway. + */ + + if (prevPtr == slavePtr) { + masterPtr = slavePtr->masterPtr; + goto scheduleLayout; + } + + /* + * If none of the "-in", "-before", or "-after" options has + * been specified, arrange for the slave to go at the end of + * the order for its parent. + */ + + if (!positionGiven) { + masterPtr = GetPacker(Tk_Parent(slave)); + prevPtr = masterPtr->slavePtr; + if (prevPtr != NULL) { + while (prevPtr->nextPtr != NULL) { + prevPtr = prevPtr->nextPtr; + } + } + } + + /* + * Make sure that the slave's parent is either the master or + * an ancestor of the master, and that the master and slave + * aren't the same. + */ + + parent = Tk_Parent(slave); + for (ancestor = masterPtr->tkwin; ; ancestor = Tk_Parent(ancestor)) { + if (ancestor == parent) { + break; + } + if (Tk_IsTopLevel(ancestor)) { + Tcl_AppendResult(interp, "can't pack ", argv[j], + " inside ", Tk_PathName(masterPtr->tkwin), + (char *) NULL); + return TCL_ERROR; + } + } + if (slave == masterPtr->tkwin) { + Tcl_AppendResult(interp, "can't pack ", argv[j], + " inside itself", (char *) NULL); + return TCL_ERROR; + } + + /* + * Unpack the slave if it's currently packed, then position it + * after prevPtr. + */ + + if (slavePtr->masterPtr != NULL) { + if ((slavePtr->masterPtr != masterPtr) && + (slavePtr->masterPtr->tkwin + != Tk_Parent(slavePtr->tkwin))) { + Tk_UnmaintainGeometry(slavePtr->tkwin, + slavePtr->masterPtr->tkwin); + } + Unlink(slavePtr); + } + slavePtr->masterPtr = masterPtr; + if (prevPtr == NULL) { + slavePtr->nextPtr = masterPtr->slavePtr; + masterPtr->slavePtr = slavePtr; + } else { + slavePtr->nextPtr = prevPtr->nextPtr; + prevPtr->nextPtr = slavePtr; + } + Tk_ManageGeometry(slave, &packerType, (ClientData) slavePtr); + prevPtr = slavePtr; + + /* + * Arrange for the parent to be re-packed at the first + * idle moment. + */ + + scheduleLayout: + if (masterPtr->abortPtr != NULL) { + *masterPtr->abortPtr = 1; + } + if (!(masterPtr->flags & REQUESTED_REPACK)) { + masterPtr->flags |= REQUESTED_REPACK; + Tcl_DoWhenIdle(ArrangePacking, (ClientData) masterPtr); + } + } + return TCL_OK; +} diff --git a/generic/tkPlace.c b/generic/tkPlace.c new file mode 100644 index 0000000..15ddcef --- /dev/null +++ b/generic/tkPlace.c @@ -0,0 +1,1060 @@ +/* + * tkPlace.c -- + * + * This file contains code to implement a simple geometry manager + * 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. + * + * 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 + */ + +#include "tkPort.h" +#include "tkInt.h" + +/* + * Border modes for relative placement: + * + * BM_INSIDE: relative distances computed using area inside + * all borders of master window. + * BM_OUTSIDE: relative distances computed using outside area + * that includes all borders of master. + * BM_IGNORE: border issues are ignored: place relative to + * master's actual window size. + */ + +typedef enum {BM_INSIDE, BM_OUTSIDE, BM_IGNORE} BorderMode; + +/* + * For each window whose geometry is managed by the placer there is + * a structure of the following type: + */ + +typedef struct Slave { + Tk_Window tkwin; /* Tk's token for window. */ + struct Master *masterPtr; /* Pointer to information for window + * relative to which tkwin is placed. + * This isn't necessarily the logical + * parent of tkwin. NULL means the + * master was deleted or never assigned. */ + struct Slave *nextPtr; /* Next in list of windows placed relative + * to same master (NULL for end of list). */ + + /* + * Geometry information for window; where there are both relative + * and absolute values for the same attribute (e.g. x and relX) only + * one of them is actually used, depending on flags. + */ + + int x, y; /* X and Y pixel coordinates for tkwin. */ + float relX, relY; /* X and Y coordinates relative to size of + * master. */ + int width, height; /* Absolute dimensions for tkwin. */ + float relWidth, relHeight; /* Dimensions for tkwin relative to size of + * master. */ + Tk_Anchor anchor; /* Which point on tkwin is placed at the + * given position. */ + BorderMode borderMode; /* How to treat borders of master window. */ + int flags; /* Various flags; see below for bit + * definitions. */ +} Slave; + +/* + * Flag definitions for Slave structures: + * + * CHILD_WIDTH - 1 means -width was specified; + * CHILD_REL_WIDTH - 1 means -relwidth was specified. + * CHILD_HEIGHT - 1 means -height was specified; + * CHILD_REL_HEIGHT - 1 means -relheight was specified. + */ + +#define CHILD_WIDTH 1 +#define CHILD_REL_WIDTH 2 +#define CHILD_HEIGHT 4 +#define CHILD_REL_HEIGHT 8 + +/* + * For each master window that has a slave managed by the placer there + * is a structure of the following form: + */ + +typedef struct Master { + Tk_Window tkwin; /* Tk's token for master window. */ + struct Slave *slavePtr; /* First in linked list of slaves + * placed relative to this master. */ + int flags; /* See below for bit definitions. */ +} Master; + +/* + * Flag definitions for masters: + * + * PARENT_RECONFIG_PENDING - 1 means that a call to RecomputePlacement + * is already pending via a Do_When_Idle handler. + */ + +#define PARENT_RECONFIG_PENDING 1 + +/* + * The hash tables below both use Tk_Window tokens as keys. They map + * from Tk_Windows to Slave and Master structures for windows, if they + * exist. + */ + +static int initialized = 0; +static Tcl_HashTable masterTable; +static Tcl_HashTable slaveTable; +/* + * The following structure is the official type record for the + * placer: + */ + +static void PlaceRequestProc _ANSI_ARGS_((ClientData clientData, + Tk_Window tkwin)); +static void PlaceLostSlaveProc _ANSI_ARGS_((ClientData clientData, + Tk_Window tkwin)); + +static Tk_GeomMgr placerType = { + "place", /* name */ + PlaceRequestProc, /* requestProc */ + PlaceLostSlaveProc, /* lostSlaveProc */ +}; + +/* + * Forward declarations for procedures defined later in this file: + */ + +static void SlaveStructureProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +static int ConfigureSlave _ANSI_ARGS_((Tcl_Interp *interp, + Slave *slavePtr, int argc, char **argv)); +static Slave * FindSlave _ANSI_ARGS_((Tk_Window tkwin)); +static Master * FindMaster _ANSI_ARGS_((Tk_Window tkwin)); +static void MasterStructureProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +static void RecomputePlacement _ANSI_ARGS_((ClientData clientData)); +static void UnlinkSlave _ANSI_ARGS_((Slave *slavePtr)); + +/* + *-------------------------------------------------------------- + * + * Tk_PlaceCmd -- + * + * This procedure is invoked to process the "place" Tcl + * commands. See the user documentation for details on + * what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +int +Tk_PlaceCmd(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; + Slave *slavePtr; + Tcl_HashEntry *hPtr; + size_t length; + int c; + + /* + * Initialize, if that hasn't been done yet. + */ + + if (!initialized) { + Tcl_InitHashTable(&masterTable, TCL_ONE_WORD_KEYS); + Tcl_InitHashTable(&slaveTable, TCL_ONE_WORD_KEYS); + initialized = 1; + } + + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " option|pathName args", (char *) NULL); + return TCL_ERROR; + } + c = argv[1][0]; + length = strlen(argv[1]); + + /* + * Handle special shortcut where window name is first argument. + */ + + if (c == '.') { + tkwin = Tk_NameToWindow(interp, argv[1], (Tk_Window) clientData); + if (tkwin == NULL) { + return TCL_ERROR; + } + slavePtr = FindSlave(tkwin); + return ConfigureSlave(interp, slavePtr, argc-2, argv+2); + } + + /* + * Handle more general case of option followed by window name followed + * by possible additional arguments. + */ + + tkwin = Tk_NameToWindow(interp, argv[2], (Tk_Window) clientData); + if (tkwin == NULL) { + return TCL_ERROR; + } + if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0)) { + if (argc < 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], + " configure pathName option value ?option value ...?\"", + (char *) NULL); + return TCL_ERROR; + } + slavePtr = FindSlave(tkwin); + return ConfigureSlave(interp, slavePtr, argc-3, argv+3); + } else if ((c == 'f') && (strncmp(argv[1], "forget", length) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " forget pathName\"", (char *) NULL); + return TCL_ERROR; + } + hPtr = Tcl_FindHashEntry(&slaveTable, (char *) tkwin); + if (hPtr == NULL) { + return TCL_OK; + } + slavePtr = (Slave *) Tcl_GetHashValue(hPtr); + if ((slavePtr->masterPtr != NULL) && + (slavePtr->masterPtr->tkwin != Tk_Parent(slavePtr->tkwin))) { + Tk_UnmaintainGeometry(slavePtr->tkwin, + slavePtr->masterPtr->tkwin); + } + UnlinkSlave(slavePtr); + Tcl_DeleteHashEntry(hPtr); + Tk_DeleteEventHandler(tkwin, StructureNotifyMask, SlaveStructureProc, + (ClientData) slavePtr); + Tk_ManageGeometry(tkwin, (Tk_GeomMgr *) NULL, (ClientData) NULL); + Tk_UnmapWindow(tkwin); + ckfree((char *) slavePtr); + } else if ((c == 'i') && (strncmp(argv[1], "info", length) == 0)) { + char buffer[50]; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " info pathName\"", (char *) NULL); + return TCL_ERROR; + } + hPtr = Tcl_FindHashEntry(&slaveTable, (char *) tkwin); + if (hPtr == NULL) { + return TCL_OK; + } + slavePtr = (Slave *) Tcl_GetHashValue(hPtr); + sprintf(buffer, "-x %d", slavePtr->x); + Tcl_AppendResult(interp, buffer, (char *) NULL); + sprintf(buffer, " -relx %.4g", slavePtr->relX); + Tcl_AppendResult(interp, buffer, (char *) NULL); + sprintf(buffer, " -y %d", slavePtr->y); + Tcl_AppendResult(interp, buffer, (char *) NULL); + sprintf(buffer, " -rely %.4g", slavePtr->relY); + Tcl_AppendResult(interp, buffer, (char *) NULL); + if (slavePtr->flags & CHILD_WIDTH) { + sprintf(buffer, " -width %d", slavePtr->width); + Tcl_AppendResult(interp, buffer, (char *) NULL); + } else { + Tcl_AppendResult(interp, " -width {}", (char *) NULL); + } + if (slavePtr->flags & CHILD_REL_WIDTH) { + sprintf(buffer, " -relwidth %.4g", slavePtr->relWidth); + Tcl_AppendResult(interp, buffer, (char *) NULL); + } else { + Tcl_AppendResult(interp, " -relwidth {}", (char *) NULL); + } + if (slavePtr->flags & CHILD_HEIGHT) { + sprintf(buffer, " -height %d", slavePtr->height); + Tcl_AppendResult(interp, buffer, (char *) NULL); + } else { + Tcl_AppendResult(interp, " -height {}", (char *) NULL); + } + if (slavePtr->flags & CHILD_REL_HEIGHT) { + sprintf(buffer, " -relheight %.4g", slavePtr->relHeight); + Tcl_AppendResult(interp, buffer, (char *) NULL); + } else { + Tcl_AppendResult(interp, " -relheight {}", (char *) NULL); + } + + Tcl_AppendResult(interp, " -anchor ", Tk_NameOfAnchor(slavePtr->anchor), + (char *) NULL); + if (slavePtr->borderMode == BM_OUTSIDE) { + Tcl_AppendResult(interp, " -bordermode outside", (char *) NULL); + } else if (slavePtr->borderMode == BM_IGNORE) { + Tcl_AppendResult(interp, " -bordermode ignore", (char *) NULL); + } + if ((slavePtr->masterPtr != NULL) + && (slavePtr->masterPtr->tkwin != Tk_Parent(slavePtr->tkwin))) { + Tcl_AppendResult(interp, " -in ", + Tk_PathName(slavePtr->masterPtr->tkwin), (char *) NULL); + } + } else if ((c == 's') && (strncmp(argv[1], "slaves", length) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " slaves pathName\"", (char *) NULL); + return TCL_ERROR; + } + hPtr = Tcl_FindHashEntry(&masterTable, (char *) tkwin); + if (hPtr != NULL) { + Master *masterPtr; + masterPtr = (Master *) Tcl_GetHashValue(hPtr); + for (slavePtr = masterPtr->slavePtr; slavePtr != NULL; + slavePtr = slavePtr->nextPtr) { + Tcl_AppendElement(interp, Tk_PathName(slavePtr->tkwin)); + } + } + } else { + Tcl_AppendResult(interp, "unknown or ambiguous option \"", argv[1], + "\": must be configure, forget, info, or slaves", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FindSlave -- + * + * Given a Tk_Window token, find the Slave structure corresponding + * to that token (making a new one if necessary). + * + * Results: + * None. + * + * Side effects: + * A new Slave structure may be created. + * + *---------------------------------------------------------------------- + */ + +static Slave * +FindSlave(tkwin) + Tk_Window tkwin; /* Token for desired slave. */ +{ + Tcl_HashEntry *hPtr; + register Slave *slavePtr; + int new; + + hPtr = Tcl_CreateHashEntry(&slaveTable, (char *) tkwin, &new); + if (new) { + slavePtr = (Slave *) ckalloc(sizeof(Slave)); + slavePtr->tkwin = tkwin; + slavePtr->masterPtr = NULL; + slavePtr->nextPtr = NULL; + slavePtr->x = slavePtr->y = 0; + slavePtr->relX = slavePtr->relY = (float) 0.0; + slavePtr->width = slavePtr->height = 0; + slavePtr->relWidth = slavePtr->relHeight = (float) 0.0; + slavePtr->anchor = TK_ANCHOR_NW; + slavePtr->borderMode = BM_INSIDE; + slavePtr->flags = 0; + Tcl_SetHashValue(hPtr, slavePtr); + Tk_CreateEventHandler(tkwin, StructureNotifyMask, SlaveStructureProc, + (ClientData) slavePtr); + Tk_ManageGeometry(tkwin, &placerType, (ClientData) slavePtr); + } else { + slavePtr = (Slave *) Tcl_GetHashValue(hPtr); + } + return slavePtr; +} + +/* + *---------------------------------------------------------------------- + * + * UnlinkSlave -- + * + * This procedure removes a slave window from the chain of slaves + * in its master. + * + * Results: + * None. + * + * Side effects: + * The slave list of slavePtr's master changes. + * + *---------------------------------------------------------------------- + */ + +static void +UnlinkSlave(slavePtr) + Slave *slavePtr; /* Slave structure to be unlinked. */ +{ + register Master *masterPtr; + register Slave *prevPtr; + + masterPtr = slavePtr->masterPtr; + if (masterPtr == NULL) { + return; + } + if (masterPtr->slavePtr == slavePtr) { + masterPtr->slavePtr = slavePtr->nextPtr; + } else { + for (prevPtr = masterPtr->slavePtr; ; + prevPtr = prevPtr->nextPtr) { + if (prevPtr == NULL) { + panic("UnlinkSlave couldn't find slave to unlink"); + } + if (prevPtr->nextPtr == slavePtr) { + prevPtr->nextPtr = slavePtr->nextPtr; + break; + } + } + } + slavePtr->masterPtr = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * FindMaster -- + * + * Given a Tk_Window token, find the Master structure corresponding + * to that token (making a new one if necessary). + * + * Results: + * None. + * + * Side effects: + * A new Master structure may be created. + * + *---------------------------------------------------------------------- + */ + +static Master * +FindMaster(tkwin) + Tk_Window tkwin; /* Token for desired master. */ +{ + Tcl_HashEntry *hPtr; + register Master *masterPtr; + int new; + + hPtr = Tcl_CreateHashEntry(&masterTable, (char *) tkwin, &new); + if (new) { + masterPtr = (Master *) ckalloc(sizeof(Master)); + masterPtr->tkwin = tkwin; + masterPtr->slavePtr = NULL; + masterPtr->flags = 0; + Tcl_SetHashValue(hPtr, masterPtr); + Tk_CreateEventHandler(masterPtr->tkwin, StructureNotifyMask, + MasterStructureProc, (ClientData) masterPtr); + } else { + masterPtr = (Master *) Tcl_GetHashValue(hPtr); + } + return masterPtr; +} + +/* + *---------------------------------------------------------------------- + * + * ConfigureSlave -- + * + * This procedure is called to process an argv/argc list to + * reconfigure the placement of a window. + * + * Results: + * A standard Tcl result. If an error occurs then a message is + * left in interp->result. + * + * Side effects: + * Information in slavePtr may change, and slavePtr's master is + * scheduled for reconfiguration. + * + *---------------------------------------------------------------------- + */ + +static int +ConfigureSlave(interp, slavePtr, argc, argv) + Tcl_Interp *interp; /* Used for error reporting. */ + Slave *slavePtr; /* Pointer to current information + * about slave. */ + int argc; /* Number of config arguments. */ + char **argv; /* String values for arguments. */ +{ + register Master *masterPtr; + int c, result; + size_t length; + double d; + + result = TCL_OK; + if (Tk_IsTopLevel(slavePtr->tkwin)) { + Tcl_AppendResult(interp, "can't use placer on top-level window \"", + Tk_PathName(slavePtr->tkwin), "\"; use wm command instead", + (char *) NULL); + return TCL_ERROR; + } + for ( ; argc > 0; argc -= 2, argv += 2) { + if (argc < 2) { + Tcl_AppendResult(interp, "extra option \"", argv[0], + "\" (option with no value?)", (char *) NULL); + result = TCL_ERROR; + goto done; + } + length = strlen(argv[0]); + c = argv[0][1]; + if ((c == 'a') && (strncmp(argv[0], "-anchor", length) == 0)) { + if (Tk_GetAnchor(interp, argv[1], &slavePtr->anchor) != TCL_OK) { + result = TCL_ERROR; + goto done; + } + } else if ((c == 'b') + && (strncmp(argv[0], "-bordermode", length) == 0)) { + c = argv[1][0]; + length = strlen(argv[1]); + if ((c == 'i') && (strncmp(argv[1], "ignore", length) == 0) + && (length >= 2)) { + slavePtr->borderMode = BM_IGNORE; + } else if ((c == 'i') && (strncmp(argv[1], "inside", length) == 0) + && (length >= 2)) { + slavePtr->borderMode = BM_INSIDE; + } else if ((c == 'o') + && (strncmp(argv[1], "outside", length) == 0)) { + slavePtr->borderMode = BM_OUTSIDE; + } else { + Tcl_AppendResult(interp, "bad border mode \"", argv[1], + "\": must be ignore, inside, or outside", + (char *) NULL); + result = TCL_ERROR; + goto done; + } + } else if ((c == 'h') && (strncmp(argv[0], "-height", length) == 0)) { + if (argv[1][0] == 0) { + slavePtr->flags &= ~CHILD_HEIGHT; + } else { + if (Tk_GetPixels(interp, slavePtr->tkwin, argv[1], + &slavePtr->height) != TCL_OK) { + result = TCL_ERROR; + goto done; + } + slavePtr->flags |= CHILD_HEIGHT; + } + } else if ((c == 'i') && (strncmp(argv[0], "-in", length) == 0)) { + Tk_Window tkwin; + Tk_Window ancestor; + + tkwin = Tk_NameToWindow(interp, argv[1], slavePtr->tkwin); + if (tkwin == NULL) { + result = TCL_ERROR; + goto done; + } + + /* + * Make sure that the new master is either the logical parent + * of the slave or a descendant of that window, and that the + * master and slave aren't the same. + */ + + for (ancestor = tkwin; ; ancestor = Tk_Parent(ancestor)) { + if (ancestor == Tk_Parent(slavePtr->tkwin)) { + break; + } + if (Tk_IsTopLevel(ancestor)) { + Tcl_AppendResult(interp, "can't place ", + Tk_PathName(slavePtr->tkwin), " relative to ", + Tk_PathName(tkwin), (char *) NULL); + result = TCL_ERROR; + goto done; + } + } + if (slavePtr->tkwin == tkwin) { + Tcl_AppendResult(interp, "can't place ", + Tk_PathName(slavePtr->tkwin), " relative to itself", + (char *) NULL); + result = TCL_ERROR; + goto done; + } + if ((slavePtr->masterPtr != NULL) + && (slavePtr->masterPtr->tkwin == tkwin)) { + /* + * Re-using same old master. Nothing to do. + */ + } else { + if ((slavePtr->masterPtr != NULL) + && (slavePtr->masterPtr->tkwin + != Tk_Parent(slavePtr->tkwin))) { + Tk_UnmaintainGeometry(slavePtr->tkwin, + slavePtr->masterPtr->tkwin); + } + UnlinkSlave(slavePtr); + slavePtr->masterPtr = FindMaster(tkwin); + slavePtr->nextPtr = slavePtr->masterPtr->slavePtr; + slavePtr->masterPtr->slavePtr = slavePtr; + } + } else if ((c == 'r') && (strncmp(argv[0], "-relheight", length) == 0) + && (length >= 5)) { + if (argv[1][0] == 0) { + slavePtr->flags &= ~CHILD_REL_HEIGHT; + } else { + if (Tcl_GetDouble(interp, argv[1], &d) != TCL_OK) { + result = TCL_ERROR; + goto done; + } + slavePtr->relHeight = (float) d; + slavePtr->flags |= CHILD_REL_HEIGHT; + } + } else if ((c == 'r') && (strncmp(argv[0], "-relwidth", length) == 0) + && (length >= 5)) { + if (argv[1][0] == 0) { + slavePtr->flags &= ~CHILD_REL_WIDTH; + } else { + if (Tcl_GetDouble(interp, argv[1], &d) != TCL_OK) { + result = TCL_ERROR; + goto done; + } + slavePtr->relWidth = (float) d; + slavePtr->flags |= CHILD_REL_WIDTH; + } + } else if ((c == 'r') && (strncmp(argv[0], "-relx", length) == 0) + && (length >= 5)) { + if (Tcl_GetDouble(interp, argv[1], &d) != TCL_OK) { + result = TCL_ERROR; + goto done; + } + slavePtr->relX = (float) d; + } else if ((c == 'r') && (strncmp(argv[0], "-rely", length) == 0) + && (length >= 5)) { + if (Tcl_GetDouble(interp, argv[1], &d) != TCL_OK) { + result = TCL_ERROR; + goto done; + } + slavePtr->relY = (float) d; + } else if ((c == 'w') && (strncmp(argv[0], "-width", length) == 0)) { + if (argv[1][0] == 0) { + slavePtr->flags &= ~CHILD_WIDTH; + } else { + if (Tk_GetPixels(interp, slavePtr->tkwin, argv[1], + &slavePtr->width) != TCL_OK) { + result = TCL_ERROR; + goto done; + } + slavePtr->flags |= CHILD_WIDTH; + } + } else if ((c == 'x') && (strncmp(argv[0], "-x", length) == 0)) { + if (Tk_GetPixels(interp, slavePtr->tkwin, argv[1], + &slavePtr->x) != TCL_OK) { + result = TCL_ERROR; + goto done; + } + } else if ((c == 'y') && (strncmp(argv[0], "-y", length) == 0)) { + if (Tk_GetPixels(interp, slavePtr->tkwin, argv[1], + &slavePtr->y) != TCL_OK) { + result = TCL_ERROR; + goto done; + } + } else { + Tcl_AppendResult(interp, "unknown or ambiguous option \"", + argv[0], "\": must be -anchor, -bordermode, -height, ", + "-in, -relheight, -relwidth, -relx, -rely, -width, ", + "-x, or -y", (char *) NULL); + result = TCL_ERROR; + goto done; + } + } + + /* + * If there's no master specified for this slave, use its Tk_Parent. + * Then arrange for a placement recalculation in the master. + */ + + done: + masterPtr = slavePtr->masterPtr; + if (masterPtr == NULL) { + masterPtr = FindMaster(Tk_Parent(slavePtr->tkwin)); + slavePtr->masterPtr = masterPtr; + slavePtr->nextPtr = masterPtr->slavePtr; + masterPtr->slavePtr = slavePtr; + } + if (!(masterPtr->flags & PARENT_RECONFIG_PENDING)) { + masterPtr->flags |= PARENT_RECONFIG_PENDING; + Tcl_DoWhenIdle(RecomputePlacement, (ClientData) masterPtr); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * RecomputePlacement -- + * + * This procedure is called as a when-idle handler. It recomputes + * the geometries of all the slaves of a given master. + * + * Results: + * None. + * + * Side effects: + * Windows may change size or shape. + * + *---------------------------------------------------------------------- + */ + +static void +RecomputePlacement(clientData) + ClientData clientData; /* Pointer to Master record. */ +{ + register Master *masterPtr = (Master *) clientData; + register Slave *slavePtr; + int x, y, width, height, tmp; + int masterWidth, masterHeight, masterBW; + double x1, y1, x2, y2; + + masterPtr->flags &= ~PARENT_RECONFIG_PENDING; + + /* + * Iterate over all the slaves for the master. Each slave's + * geometry can be computed independently of the other slaves. + */ + + for (slavePtr = masterPtr->slavePtr; slavePtr != NULL; + slavePtr = slavePtr->nextPtr) { + /* + * Step 1: compute size and borderwidth of master, taking into + * account desired border mode. + */ + + masterBW = 0; + masterWidth = Tk_Width(masterPtr->tkwin); + masterHeight = Tk_Height(masterPtr->tkwin); + if (slavePtr->borderMode == BM_INSIDE) { + masterBW = Tk_InternalBorderWidth(masterPtr->tkwin); + } else if (slavePtr->borderMode == BM_OUTSIDE) { + masterBW = -Tk_Changes(masterPtr->tkwin)->border_width; + } + masterWidth -= 2*masterBW; + masterHeight -= 2*masterBW; + + /* + * Step 2: compute size of slave (outside dimensions including + * border) and location of anchor point within master. + */ + + x1 = slavePtr->x + masterBW + (slavePtr->relX*masterWidth); + x = (int) (x1 + ((x1 > 0) ? 0.5 : -0.5)); + y1 = slavePtr->y + masterBW + (slavePtr->relY*masterHeight); + y = (int) (y1 + ((y1 > 0) ? 0.5 : -0.5)); + if (slavePtr->flags & (CHILD_WIDTH|CHILD_REL_WIDTH)) { + width = 0; + if (slavePtr->flags & CHILD_WIDTH) { + width += slavePtr->width; + } + if (slavePtr->flags & CHILD_REL_WIDTH) { + /* + * The code below is a bit tricky. In order to round + * correctly when both relX and relWidth are specified, + * compute the location of the right edge and round that, + * then compute width. If we compute the width and round + * it, rounding errors in relX and relWidth accumulate. + */ + + x2 = x1 + (slavePtr->relWidth*masterWidth); + tmp = (int) (x2 + ((x2 > 0) ? 0.5 : -0.5)); + width += tmp - x; + } + } else { + width = Tk_ReqWidth(slavePtr->tkwin) + + 2*Tk_Changes(slavePtr->tkwin)->border_width; + } + if (slavePtr->flags & (CHILD_HEIGHT|CHILD_REL_HEIGHT)) { + height = 0; + if (slavePtr->flags & CHILD_HEIGHT) { + height += slavePtr->height; + } + if (slavePtr->flags & CHILD_REL_HEIGHT) { + /* + * See note above for rounding errors in width computation. + */ + + y2 = y1 + (slavePtr->relHeight*masterHeight); + tmp = (int) (y2 + ((y2 > 0) ? 0.5 : -0.5)); + height += tmp - y; + } + } else { + height = Tk_ReqHeight(slavePtr->tkwin) + + 2*Tk_Changes(slavePtr->tkwin)->border_width; + } + + /* + * Step 3: adjust the x and y positions so that the desired + * anchor point on the slave appears at that position. Also + * adjust for the border mode and master's border. + */ + + switch (slavePtr->anchor) { + case TK_ANCHOR_N: + x -= width/2; + break; + case TK_ANCHOR_NE: + x -= width; + break; + case TK_ANCHOR_E: + x -= width; + y -= height/2; + break; + case TK_ANCHOR_SE: + x -= width; + y -= height; + break; + case TK_ANCHOR_S: + x -= width/2; + y -= height; + break; + case TK_ANCHOR_SW: + y -= height; + break; + case TK_ANCHOR_W: + y -= height/2; + break; + case TK_ANCHOR_NW: + break; + case TK_ANCHOR_CENTER: + x -= width/2; + y -= height/2; + break; + } + + /* + * Step 4: adjust width and height again to reflect inside dimensions + * of window rather than outside. Also make sure that the width and + * height aren't zero. + */ + + width -= 2*Tk_Changes(slavePtr->tkwin)->border_width; + height -= 2*Tk_Changes(slavePtr->tkwin)->border_width; + if (width <= 0) { + width = 1; + } + if (height <= 0) { + height = 1; + } + + /* + * Step 5: reconfigure the window and map it if needed. If the + * slave is a child of the master, we do this ourselves. If the + * slave isn't a child of the master, let Tk_MaintainWindow do + * the work (it will re-adjust things as relevant windows map, + * unmap, and move). + */ + + if (masterPtr->tkwin == Tk_Parent(slavePtr->tkwin)) { + if ((x != Tk_X(slavePtr->tkwin)) + || (y != Tk_Y(slavePtr->tkwin)) + || (width != Tk_Width(slavePtr->tkwin)) + || (height != Tk_Height(slavePtr->tkwin))) { + Tk_MoveResizeWindow(slavePtr->tkwin, x, y, width, height); + } + + /* + * Don't map the slave unless the master is mapped: the slave + * will get mapped later, when the master is mapped. + */ + + if (Tk_IsMapped(masterPtr->tkwin)) { + Tk_MapWindow(slavePtr->tkwin); + } + } else { + if ((width <= 0) || (height <= 0)) { + Tk_UnmaintainGeometry(slavePtr->tkwin, masterPtr->tkwin); + Tk_UnmapWindow(slavePtr->tkwin); + } else { + Tk_MaintainGeometry(slavePtr->tkwin, masterPtr->tkwin, + x, y, width, height); + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * MasterStructureProc -- + * + * This procedure is invoked by the Tk event handler when + * StructureNotify events occur for a master window. + * + * Results: + * None. + * + * Side effects: + * Structures get cleaned up if the window was deleted. If the + * window was resized then slave geometries get recomputed. + * + *---------------------------------------------------------------------- + */ + +static void +MasterStructureProc(clientData, eventPtr) + ClientData clientData; /* Pointer to Master structure for window + * referred to by eventPtr. */ + XEvent *eventPtr; /* Describes what just happened. */ +{ + register Master *masterPtr = (Master *) clientData; + register Slave *slavePtr, *nextPtr; + + if (eventPtr->type == ConfigureNotify) { + if ((masterPtr->slavePtr != NULL) + && !(masterPtr->flags & PARENT_RECONFIG_PENDING)) { + masterPtr->flags |= PARENT_RECONFIG_PENDING; + Tcl_DoWhenIdle(RecomputePlacement, (ClientData) masterPtr); + } + } else if (eventPtr->type == DestroyNotify) { + for (slavePtr = masterPtr->slavePtr; slavePtr != NULL; + slavePtr = nextPtr) { + slavePtr->masterPtr = NULL; + nextPtr = slavePtr->nextPtr; + slavePtr->nextPtr = NULL; + } + Tcl_DeleteHashEntry(Tcl_FindHashEntry(&masterTable, + (char *) masterPtr->tkwin)); + if (masterPtr->flags & PARENT_RECONFIG_PENDING) { + Tcl_CancelIdleCall(RecomputePlacement, (ClientData) masterPtr); + } + masterPtr->tkwin = NULL; + ckfree((char *) masterPtr); + } else if (eventPtr->type == MapNotify) { + /* + * When a master gets mapped, must redo the geometry computation + * so that all of its slaves get remapped. + */ + + if ((masterPtr->slavePtr != NULL) + && !(masterPtr->flags & PARENT_RECONFIG_PENDING)) { + masterPtr->flags |= PARENT_RECONFIG_PENDING; + Tcl_DoWhenIdle(RecomputePlacement, (ClientData) masterPtr); + } + } else if (eventPtr->type == UnmapNotify) { + /* + * Unmap all of the slaves when the master gets unmapped, + * so that they don't keep redisplaying themselves. + */ + + for (slavePtr = masterPtr->slavePtr; slavePtr != NULL; + slavePtr = slavePtr->nextPtr) { + Tk_UnmapWindow(slavePtr->tkwin); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * SlaveStructureProc -- + * + * This procedure is invoked by the Tk event handler when + * StructureNotify events occur for a slave window. + * + * Results: + * None. + * + * Side effects: + * Structures get cleaned up if the window was deleted. + * + *---------------------------------------------------------------------- + */ + +static void +SlaveStructureProc(clientData, eventPtr) + ClientData clientData; /* Pointer to Slave structure for window + * referred to by eventPtr. */ + XEvent *eventPtr; /* Describes what just happened. */ +{ + register Slave *slavePtr = (Slave *) clientData; + + if (eventPtr->type == DestroyNotify) { + UnlinkSlave(slavePtr); + Tcl_DeleteHashEntry(Tcl_FindHashEntry(&slaveTable, + (char *) slavePtr->tkwin)); + ckfree((char *) slavePtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * PlaceRequestProc -- + * + * This procedure is invoked by Tk whenever a slave managed by us + * changes its requested geometry. + * + * Results: + * None. + * + * Side effects: + * The window will get relayed out, if its requested size has + * anything to do with its actual size. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +PlaceRequestProc(clientData, tkwin) + ClientData clientData; /* Pointer to our record for slave. */ + Tk_Window tkwin; /* Window that changed its desired + * size. */ +{ + Slave *slavePtr = (Slave *) clientData; + Master *masterPtr; + + if (((slavePtr->flags & (CHILD_WIDTH|CHILD_REL_WIDTH)) != 0) + && ((slavePtr->flags & (CHILD_HEIGHT|CHILD_REL_HEIGHT)) != 0)) { + return; + } + masterPtr = slavePtr->masterPtr; + if (masterPtr == NULL) { + return; + } + if (!(masterPtr->flags & PARENT_RECONFIG_PENDING)) { + masterPtr->flags |= PARENT_RECONFIG_PENDING; + Tcl_DoWhenIdle(RecomputePlacement, (ClientData) masterPtr); + } +} + +/* + *-------------------------------------------------------------- + * + * PlaceLostSlaveProc -- + * + * This procedure is invoked by Tk whenever some other geometry + * claims control over a slave that used to be managed by us. + * + * Results: + * None. + * + * Side effects: + * Forgets all placer-related information about the slave. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +PlaceLostSlaveProc(clientData, tkwin) + ClientData clientData; /* Slave structure for slave window that + * was stolen away. */ + Tk_Window tkwin; /* Tk's handle for the slave window. */ +{ + register Slave *slavePtr = (Slave *) clientData; + + if (slavePtr->masterPtr->tkwin != Tk_Parent(slavePtr->tkwin)) { + Tk_UnmaintainGeometry(slavePtr->tkwin, slavePtr->masterPtr->tkwin); + } + Tk_UnmapWindow(tkwin); + UnlinkSlave(slavePtr); + Tcl_DeleteHashEntry(Tcl_FindHashEntry(&slaveTable, (char *) tkwin)); + Tk_DeleteEventHandler(tkwin, StructureNotifyMask, SlaveStructureProc, + (ClientData) slavePtr); + ckfree((char *) slavePtr); +} diff --git a/generic/tkPointer.c b/generic/tkPointer.c new file mode 100644 index 0000000..36814bf --- /dev/null +++ b/generic/tkPointer.c @@ -0,0 +1,623 @@ +/* + * tkPointer.c -- + * + * This file contains functions for emulating the X server + * pointer and grab state machine. This file is used by the + * Mac and Windows platforms to generate appropriate enter/leave + * events, and to update the global grab window information. + * + * Copyright (c) 1996 by Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkPointer.c 1.12 97/10/31 17:06:24 + */ + +#include "tkInt.h" + +#ifdef MAC_TCL +#define Cursor XCursor +#endif + +/* + * Mask that selects any of the state bits corresponding to buttons, + * plus masks that select individual buttons' bits: + */ + +#define ALL_BUTTONS \ + (Button1Mask|Button2Mask|Button3Mask|Button4Mask|Button5Mask) +static unsigned int buttonMasks[] = { + Button1Mask, Button2Mask, Button3Mask, Button4Mask, Button5Mask +}; +#define ButtonMask(b) (buttonMasks[(b)-Button1]) + +/* + * Declarations of static variables used in the pointer module. + */ + +static TkWindow *cursorWinPtr = NULL; /* Window that is currently + * controlling the global cursor. */ +static TkWindow *grabWinPtr = NULL; /* Window that defines the top of the + * grab tree in a global grab. */ +static XPoint lastPos = { 0, 0}; /* Last reported mouse position. */ +static int lastState = 0; /* Last known state flags. */ +static TkWindow *lastWinPtr = NULL; /* Last reported mouse window. */ +static TkWindow *restrictWinPtr = NULL; /* Window to which all mouse events + * will be reported. */ + +/* + * Forward declarations of procedures used in this file. + */ + +static int GenerateEnterLeave _ANSI_ARGS_((TkWindow *winPtr, + int x, int y, int state)); +static void InitializeEvent _ANSI_ARGS_((XEvent* eventPtr, + TkWindow *winPtr, int type, int x, int y, + int state, int detail)); +static void UpdateCursor _ANSI_ARGS_((TkWindow *winPtr)); + +/* + *---------------------------------------------------------------------- + * + * InitializeEvent -- + * + * Initializes the common fields for several X events. + * + * Results: + * None. + * + * Side effects: + * Fills in the specified event structure. + * + *---------------------------------------------------------------------- + */ + +static void +InitializeEvent(eventPtr, winPtr, type, x, y, state, detail) + XEvent* eventPtr; /* Event structure to initialize. */ + TkWindow *winPtr; /* Window to make event relative to. */ + int type; /* Message type. */ + int x, y; /* Root coords of event. */ + int state; /* State flags. */ + int detail; /* Detail value. */ +{ + eventPtr->type = type; + eventPtr->xany.serial = LastKnownRequestProcessed(winPtr->display); + eventPtr->xany.send_event = False; + eventPtr->xany.display = winPtr->display; + + eventPtr->xcrossing.root = RootWindow(winPtr->display, winPtr->screenNum); + eventPtr->xcrossing.time = TkpGetMS(); + eventPtr->xcrossing.x_root = x; + eventPtr->xcrossing.y_root = y; + + switch (type) { + case EnterNotify: + case LeaveNotify: + eventPtr->xcrossing.mode = NotifyNormal; + eventPtr->xcrossing.state = state; + eventPtr->xcrossing.detail = detail; + eventPtr->xcrossing.focus = False; + break; + case MotionNotify: + eventPtr->xmotion.state = state; + eventPtr->xmotion.is_hint = detail; + break; + case ButtonPress: + case ButtonRelease: + eventPtr->xbutton.state = state; + eventPtr->xbutton.button = detail; + break; + } + TkChangeEventWindow(eventPtr, winPtr); +} + +/* + *---------------------------------------------------------------------- + * + * GenerateEnterLeave -- + * + * Update the current mouse window and position, and generate + * any enter/leave events that are needed. + * + * Results: + * Returns 1 if enter/leave events were generated. + * + * Side effects: + * May insert events into the Tk event queue. + * + *---------------------------------------------------------------------- + */ + +static int +GenerateEnterLeave(winPtr, x, y, state) + TkWindow *winPtr; /* Current Tk window (or NULL). */ + int x,y; /* Current mouse position in root coords. */ + int state; /* State flags. */ +{ + int crossed = 0; /* 1 if mouse crossed a window boundary */ + + if (winPtr != lastWinPtr) { + if (restrictWinPtr) { + int newPos, oldPos; + + newPos = TkPositionInTree(winPtr, restrictWinPtr); + oldPos = TkPositionInTree(lastWinPtr, restrictWinPtr); + + /* + * Check if the mouse crossed into or out of the restrict + * window. If so, we need to generate an Enter or Leave event. + */ + + if ((newPos != oldPos) && ((newPos == TK_GRAB_IN_TREE) + || (oldPos == TK_GRAB_IN_TREE))) { + XEvent event; + int type, detail; + + if (newPos == TK_GRAB_IN_TREE) { + type = EnterNotify; + } else { + type = LeaveNotify; + } + if ((oldPos == TK_GRAB_ANCESTOR) + || (newPos == TK_GRAB_ANCESTOR)) { + detail = NotifyAncestor; + } else { + detail = NotifyVirtual; + } + InitializeEvent(&event, restrictWinPtr, type, x, y, + state, detail); + Tk_QueueWindowEvent(&event, TCL_QUEUE_TAIL); + } + + } else { + TkWindow *targetPtr; + + if ((lastWinPtr == NULL) + || (lastWinPtr->window == None)) { + targetPtr = winPtr; + } else { + targetPtr = lastWinPtr; + } + + if (targetPtr && (targetPtr->window != None)) { + XEvent event; + + /* + * Generate appropriate Enter/Leave events. + */ + + InitializeEvent(&event, targetPtr, LeaveNotify, x, y, state, + NotifyNormal); + + TkInOutEvents(&event, lastWinPtr, winPtr, LeaveNotify, + EnterNotify, TCL_QUEUE_TAIL); + crossed = 1; + } + } + lastWinPtr = winPtr; + } + + return crossed; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_UpdatePointer -- + * + * This function updates the pointer state machine given an + * the current window, position and modifier state. + * + * Results: + * None. + * + * Side effects: + * May queue new events and update the grab state. + * + *---------------------------------------------------------------------- + */ + +void +Tk_UpdatePointer(tkwin, x, y, state) + Tk_Window tkwin; /* Window to which pointer event + * is reported. May be NULL. */ + int x, y; /* Pointer location in root coords. */ + int state; /* Modifier state mask. */ +{ + TkWindow *winPtr = (TkWindow *)tkwin; + TkWindow *targetWinPtr; + XPoint pos; + XEvent event; + int changes = (state ^ lastState) & ALL_BUTTONS; + int type, b, mask; + + pos.x = x; + pos.y = y; + + /* + * Use the current keyboard state, but the old mouse button + * state since we haven't generated the button events yet. + */ + + lastState = (state & ~ALL_BUTTONS) | (lastState & ALL_BUTTONS); + + /* + * Generate Enter/Leave events. If the pointer has crossed window + * boundaries, update the current mouse position so we don't generate + * redundant motion events. + */ + + if (GenerateEnterLeave(winPtr, x, y, lastState)) { + lastPos = pos; + } + + /* + * Generate ButtonPress/ButtonRelease events based on the differences + * between the current button state and the last known button state. + */ + + for (b = Button1; b <= Button3; b++) { + mask = ButtonMask(b); + if (changes & mask) { + if (state & mask) { + type = ButtonPress; + + /* + * ButtonPress - Set restrict window if we aren't grabbed, or + * if this is the first button down. + */ + + if (!restrictWinPtr) { + if (!grabWinPtr) { + + /* + * Mouse is not grabbed, so set a button grab. + */ + + restrictWinPtr = winPtr; + TkpSetCapture(restrictWinPtr); + + } else if ((lastState & ALL_BUTTONS) == 0) { + + /* + * Mouse is in a non-button grab, so ensure + * the button grab is inside the grab tree. + */ + + if (TkPositionInTree(winPtr, grabWinPtr) + == TK_GRAB_IN_TREE) { + restrictWinPtr = winPtr; + } else { + restrictWinPtr = grabWinPtr; + } + TkpSetCapture(restrictWinPtr); + } + } + + } else { + type = ButtonRelease; + + /* + * ButtonRelease - Release the mouse capture and clear the + * restrict window when the last button is released and we + * aren't in a global grab. + */ + + if ((lastState & ALL_BUTTONS) == mask) { + if (!grabWinPtr) { + TkpSetCapture(NULL); + } + } + + /* + * If we are releasing a restrict window, then we need + * to send the button event followed by mouse motion from + * the restrict window to the current mouse position. + */ + + if (restrictWinPtr) { + InitializeEvent(&event, restrictWinPtr, type, x, y, + lastState, b); + Tk_QueueWindowEvent(&event, TCL_QUEUE_TAIL); + lastState &= ~mask; + lastWinPtr = restrictWinPtr; + restrictWinPtr = NULL; + + GenerateEnterLeave(winPtr, x, y, lastState); + lastPos = pos; + continue; + } + } + + /* + * If a restrict window is set, make sure the pointer event + * is reported relative to that window. Otherwise, if a + * global grab is in effect then events outside of windows + * managed by Tk should be reported to the grab window. + */ + + if (restrictWinPtr) { + targetWinPtr = restrictWinPtr; + } else if (grabWinPtr && !winPtr) { + targetWinPtr = grabWinPtr; + } else { + targetWinPtr = winPtr; + } + + /* + * If we still have a target window, send the event. + */ + + if (winPtr != NULL) { + InitializeEvent(&event, targetWinPtr, type, x, y, + lastState, b); + Tk_QueueWindowEvent(&event, TCL_QUEUE_TAIL); + } + + /* + * Update the state for the next iteration. + */ + + lastState = (type == ButtonPress) + ? (lastState | mask) : (lastState & ~mask); + lastPos = pos; + } + } + + /* + * Make sure the cursor window is up to date. + */ + + if (restrictWinPtr) { + targetWinPtr = restrictWinPtr; + } else if (grabWinPtr) { + targetWinPtr = (TkPositionInTree(winPtr, grabWinPtr) + == TK_GRAB_IN_TREE) ? winPtr : grabWinPtr; + } else { + targetWinPtr = winPtr; + } + UpdateCursor(targetWinPtr); + + /* + * If no other events caused the position to be updated, + * generate a motion event. + */ + + if (lastPos.x != pos.x || lastPos.y != pos.y) { + if (restrictWinPtr) { + targetWinPtr = restrictWinPtr; + } else if (grabWinPtr && !winPtr) { + targetWinPtr = grabWinPtr; + } + + if (targetWinPtr != NULL) { + InitializeEvent(&event, targetWinPtr, MotionNotify, x, y, + lastState, NotifyNormal); + Tk_QueueWindowEvent(&event, TCL_QUEUE_TAIL); + } + lastPos = pos; + } +} + +/* + *---------------------------------------------------------------------- + * + * XGrabPointer -- + * + * Capture the mouse so event are reported outside of toplevels. + * Note that this is a very limited implementation that only + * supports GrabModeAsync and owner_events True. + * + * Results: + * Always returns GrabSuccess. + * + * Side effects: + * Turns on mouse capture, sets the global grab pointer, and + * clears any window restrictions. + * + *---------------------------------------------------------------------- + */ + +int +XGrabPointer(display, grab_window, owner_events, event_mask, pointer_mode, + keyboard_mode, confine_to, cursor, time) + Display* display; + Window grab_window; + Bool owner_events; + unsigned int event_mask; + int pointer_mode; + int keyboard_mode; + Window confine_to; + Cursor cursor; + Time time; +{ + display->request++; + grabWinPtr = (TkWindow *) Tk_IdToWindow(display, grab_window); + restrictWinPtr = NULL; + TkpSetCapture(grabWinPtr); + if (TkPositionInTree(lastWinPtr, grabWinPtr) != TK_GRAB_IN_TREE) { + UpdateCursor(grabWinPtr); + } + return GrabSuccess; +} + +/* + *---------------------------------------------------------------------- + * + * XUngrabPointer -- + * + * Release the current grab. + * + * Results: + * None. + * + * Side effects: + * Releases the mouse capture. + * + *---------------------------------------------------------------------- + */ + +void +XUngrabPointer(display, time) + Display* display; + Time time; +{ + display->request++; + grabWinPtr = NULL; + restrictWinPtr = NULL; + TkpSetCapture(NULL); + UpdateCursor(lastWinPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TkPointerDeadWindow -- + * + * Clean up pointer module state when a window is destroyed. + * + * Results: + * None. + * + * Side effects: + * May release the current capture window. + * + *---------------------------------------------------------------------- + */ + +void +TkPointerDeadWindow(winPtr) + TkWindow *winPtr; +{ + if (winPtr == lastWinPtr) { + lastWinPtr = NULL; + } + if (winPtr == grabWinPtr) { + grabWinPtr = NULL; + } + if (winPtr == restrictWinPtr) { + restrictWinPtr = NULL; + } + if (!(restrictWinPtr || grabWinPtr)) { + TkpSetCapture(NULL); + } +} + +/* + *---------------------------------------------------------------------- + * + * UpdateCursor -- + * + * Set the windows global cursor to the cursor associated with + * the given Tk window. + * + * Results: + * None. + * + * Side effects: + * Changes the mouse cursor. + * + *---------------------------------------------------------------------- + */ + +static void +UpdateCursor(winPtr) + TkWindow *winPtr; +{ + Cursor cursor = None; + + /* + * A window inherits its cursor from its parent if it doesn't + * have one of its own. Top level windows inherit the default + * cursor. + */ + + cursorWinPtr = winPtr; + while (winPtr != NULL) { + if (winPtr->atts.cursor != None) { + cursor = winPtr->atts.cursor; + break; + } else if (winPtr->flags & TK_TOP_LEVEL) { + break; + } + winPtr = winPtr->parentPtr; + } + TkpSetCursor((TkpCursor) cursor); +} + +/* + *---------------------------------------------------------------------- + * + * XDefineCursor -- + * + * This function is called to update the cursor on a window. + * Since the mouse might be in the specified window, we need to + * check the specified window against the current mouse position + * and grab state. + * + * Results: + * None. + * + * Side effects: + * May update the cursor. + * + *---------------------------------------------------------------------- + */ + +void +XDefineCursor(display, w, cursor) + Display* display; + Window w; + Cursor cursor; +{ + TkWindow *winPtr = (TkWindow *)Tk_IdToWindow(display, w); + + if (cursorWinPtr == winPtr) { + UpdateCursor(winPtr); + } + display->request++; +} + +/* + *---------------------------------------------------------------------- + * + * TkGenerateActivateEvents -- + * + * This function is called by the Mac and Windows window manager + * routines when a toplevel window is activated or deactivated. + * Activate/Deactivate events will be sent to every subwindow of + * the toplevel followed by a FocusIn/FocusOut message. + * + * Results: + * None. + * + * Side effects: + * Generates X events. + * + *---------------------------------------------------------------------- + */ + +void +TkGenerateActivateEvents(winPtr, active) + TkWindow *winPtr; /* Toplevel to activate. */ + int active; /* Non-zero if the window is being + * activated, else 0.*/ +{ + XEvent event; + + /* + * Generate Activate and Deactivate events. This event + * is sent to every subwindow in a toplevel window. + */ + + event.xany.serial = winPtr->display->request++; + event.xany.send_event = False; + event.xany.display = winPtr->display; + event.xany.window = winPtr->window; + + event.xany.type = active ? ActivateNotify : DeactivateNotify; + TkQueueEventForAllChildren(winPtr, &event); + +} diff --git a/generic/tkPort.h b/generic/tkPort.h new file mode 100644 index 0000000..7051aa0 --- /dev/null +++ b/generic/tkPort.h @@ -0,0 +1,36 @@ +/* + * tkPort.h -- + * + * This header file handles porting issues that occur because of + * differences between systems. It reads in platform specific + * portability files. + * + * Copyright (c) 1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkPort.h 1.7 96/02/11 16:42:10 + */ + +#ifndef _TKPORT +#define _TKPORT + +#ifndef _TK +#include "tk.h" +#endif +#ifndef _TCL +#include "tcl.h" +#endif + +#if defined(__WIN32__) || defined(_WIN32) +# include "tkWinPort.h" +#else +# if defined(MAC_TCL) +# include "tkMacPort.h" +# else +# include "../unix/tkUnixPort.h" +# endif +#endif + +#endif /* _TKPORT */ diff --git a/generic/tkRectOval.c b/generic/tkRectOval.c new file mode 100644 index 0000000..d1ba71c --- /dev/null +++ b/generic/tkRectOval.c @@ -0,0 +1,1030 @@ +/* + * tkRectOval.c -- + * + * This file implements rectangle and oval items for canvas + * widgets. + * + * Copyright (c) 1991-1994 The Regents of the University of California. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkRectOval.c 1.40 96/05/03 10:52:21 + */ + +#include +#include "tk.h" +#include "tkInt.h" +#include "tkPort.h" + +/* + * The structure below defines the record for each rectangle/oval item. + */ + +typedef struct RectOvalItem { + Tk_Item header; /* Generic stuff that's the same for all + * types. MUST BE FIRST IN STRUCTURE. */ + double bbox[4]; /* Coordinates of bounding box for rectangle + * or oval (x1, y1, x2, y2). Item includes + * x1 and x2 but not y1 and y2. */ + int width; /* Width of outline. */ + XColor *outlineColor; /* Color for outline. */ + XColor *fillColor; /* Color for filling rectangle/oval. */ + Pixmap fillStipple; /* Stipple bitmap for filling item. */ + GC outlineGC; /* Graphics context for outline. */ + GC fillGC; /* Graphics context for filling item. */ +} RectOvalItem; + +/* + * Information used for parsing configuration specs: + */ + +static Tk_CustomOption tagsOption = {Tk_CanvasTagsParseProc, + Tk_CanvasTagsPrintProc, (ClientData) NULL +}; + +static Tk_ConfigSpec configSpecs[] = { + {TK_CONFIG_COLOR, "-fill", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(RectOvalItem, fillColor), TK_CONFIG_NULL_OK}, + {TK_CONFIG_COLOR, "-outline", (char *) NULL, (char *) NULL, + "black", Tk_Offset(RectOvalItem, outlineColor), TK_CONFIG_NULL_OK}, + {TK_CONFIG_BITMAP, "-stipple", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(RectOvalItem, fillStipple), TK_CONFIG_NULL_OK}, + {TK_CONFIG_CUSTOM, "-tags", (char *) NULL, (char *) NULL, + (char *) NULL, 0, TK_CONFIG_NULL_OK, &tagsOption}, + {TK_CONFIG_PIXELS, "-width", (char *) NULL, (char *) NULL, + "1", Tk_Offset(RectOvalItem, width), TK_CONFIG_DONT_SET_DEFAULT}, + {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, 0} +}; + +/* + * Prototypes for procedures defined in this file: + */ + +static void ComputeRectOvalBbox _ANSI_ARGS_((Tk_Canvas canvas, + RectOvalItem *rectOvalPtr)); +static int ConfigureRectOval _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int argc, + char **argv, int flags)); +static int CreateRectOval _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, struct Tk_Item *itemPtr, + int argc, char **argv)); +static void DeleteRectOval _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, Display *display)); +static void DisplayRectOval _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, Display *display, Drawable dst, + int x, int y, int width, int height)); +static int OvalToArea _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double *areaPtr)); +static double OvalToPoint _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double *pointPtr)); +static int RectOvalCoords _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int argc, + char **argv)); +static int RectOvalToPostscript _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Canvas canvas, Tk_Item *itemPtr, int prepass)); +static int RectToArea _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double *areaPtr)); +static double RectToPoint _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double *pointPtr)); +static void ScaleRectOval _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double originX, double originY, + double scaleX, double scaleY)); +static void TranslateRectOval _ANSI_ARGS_((Tk_Canvas canvas, + Tk_Item *itemPtr, double deltaX, double deltaY)); + +/* + * The structures below defines the rectangle and oval item types + * by means of procedures that can be invoked by generic item code. + */ + +Tk_ItemType tkRectangleType = { + "rectangle", /* name */ + sizeof(RectOvalItem), /* itemSize */ + CreateRectOval, /* createProc */ + configSpecs, /* configSpecs */ + ConfigureRectOval, /* configureProc */ + RectOvalCoords, /* coordProc */ + DeleteRectOval, /* deleteProc */ + DisplayRectOval, /* displayProc */ + 0, /* alwaysRedraw */ + RectToPoint, /* pointProc */ + RectToArea, /* areaProc */ + RectOvalToPostscript, /* postscriptProc */ + ScaleRectOval, /* scaleProc */ + TranslateRectOval, /* translateProc */ + (Tk_ItemIndexProc *) NULL, /* indexProc */ + (Tk_ItemCursorProc *) NULL, /* icursorProc */ + (Tk_ItemSelectionProc *) NULL, /* selectionProc */ + (Tk_ItemInsertProc *) NULL, /* insertProc */ + (Tk_ItemDCharsProc *) NULL, /* dTextProc */ + (Tk_ItemType *) NULL /* nextPtr */ +}; + +Tk_ItemType tkOvalType = { + "oval", /* name */ + sizeof(RectOvalItem), /* itemSize */ + CreateRectOval, /* createProc */ + configSpecs, /* configSpecs */ + ConfigureRectOval, /* configureProc */ + RectOvalCoords, /* coordProc */ + DeleteRectOval, /* deleteProc */ + DisplayRectOval, /* displayProc */ + 0, /* alwaysRedraw */ + OvalToPoint, /* pointProc */ + OvalToArea, /* areaProc */ + RectOvalToPostscript, /* postscriptProc */ + ScaleRectOval, /* scaleProc */ + TranslateRectOval, /* translateProc */ + (Tk_ItemIndexProc *) NULL, /* indexProc */ + (Tk_ItemCursorProc *) NULL, /* cursorProc */ + (Tk_ItemSelectionProc *) NULL, /* selectionProc */ + (Tk_ItemInsertProc *) NULL, /* insertProc */ + (Tk_ItemDCharsProc *) NULL, /* dTextProc */ + (Tk_ItemType *) NULL /* nextPtr */ +}; + +/* + *-------------------------------------------------------------- + * + * CreateRectOval -- + * + * This procedure is invoked to create a new rectangle + * or oval item in a canvas. + * + * 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, + * so it can be safely freed by the caller. + * + * Side effects: + * A new rectangle or oval item is created. + * + *-------------------------------------------------------------- + */ + +static int +CreateRectOval(interp, canvas, itemPtr, argc, argv) + Tcl_Interp *interp; /* 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. */ +{ + RectOvalItem *rectOvalPtr = (RectOvalItem *) itemPtr; + + if (argc < 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + Tk_PathName(Tk_CanvasTkwin(canvas)), " create ", + itemPtr->typePtr->name, " x1 y1 x2 y2 ?options?\"", + (char *) NULL); + return TCL_ERROR; + } + + /* + * Carry out initialization that is needed in order to clean + * up after errors during the the remainder of this procedure. + */ + + rectOvalPtr->width = 1; + rectOvalPtr->outlineColor = NULL; + rectOvalPtr->fillColor = NULL; + rectOvalPtr->fillStipple = None; + rectOvalPtr->outlineGC = None; + rectOvalPtr->fillGC = None; + + /* + * Process the arguments to fill in the item record. + */ + + if ((Tk_CanvasGetCoord(interp, canvas, argv[0], + &rectOvalPtr->bbox[0]) != TCL_OK) + || (Tk_CanvasGetCoord(interp, canvas, argv[1], + &rectOvalPtr->bbox[1]) != TCL_OK) + || (Tk_CanvasGetCoord(interp, canvas, argv[2], + &rectOvalPtr->bbox[2]) != TCL_OK) + || (Tk_CanvasGetCoord(interp, canvas, argv[3], + &rectOvalPtr->bbox[3]) != TCL_OK)) { + return TCL_ERROR; + } + + if (ConfigureRectOval(interp, canvas, itemPtr, argc-4, argv+4, 0) + != TCL_OK) { + DeleteRectOval(canvas, itemPtr, Tk_Display(Tk_CanvasTkwin(canvas))); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * RectOvalCoords -- + * + * This procedure is invoked to process the "coords" widget + * command on rectangles and ovals. See the user documentation + * for details on what it does. + * + * Results: + * Returns TCL_OK or TCL_ERROR, and sets interp->result. + * + * Side effects: + * The coordinates for the given item may be changed. + * + *-------------------------------------------------------------- + */ + +static int +RectOvalCoords(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, ... */ +{ + RectOvalItem *rectOvalPtr = (RectOvalItem *) itemPtr; + char c0[TCL_DOUBLE_SPACE], c1[TCL_DOUBLE_SPACE]; + char c2[TCL_DOUBLE_SPACE], c3[TCL_DOUBLE_SPACE]; + + if (argc == 0) { + Tcl_PrintDouble(interp, rectOvalPtr->bbox[0], c0); + Tcl_PrintDouble(interp, rectOvalPtr->bbox[1], c1); + Tcl_PrintDouble(interp, rectOvalPtr->bbox[2], c2); + Tcl_PrintDouble(interp, rectOvalPtr->bbox[3], c3); + Tcl_AppendResult(interp, c0, " ", c1, " ", c2, " ", c3, + (char *) NULL); + } else if (argc == 4) { + if ((Tk_CanvasGetCoord(interp, canvas, argv[0], + &rectOvalPtr->bbox[0]) != TCL_OK) + || (Tk_CanvasGetCoord(interp, canvas, argv[1], + &rectOvalPtr->bbox[1]) != TCL_OK) + || (Tk_CanvasGetCoord(interp, canvas, argv[2], + &rectOvalPtr->bbox[2]) != TCL_OK) + || (Tk_CanvasGetCoord(interp, canvas, argv[3], + &rectOvalPtr->bbox[3]) != TCL_OK)) { + return TCL_ERROR; + } + ComputeRectOvalBbox(canvas, rectOvalPtr); + } else { + sprintf(interp->result, + "wrong # coordinates: expected 0 or 4, got %d", + argc); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * ConfigureRectOval -- + * + * This procedure is invoked to configure various aspects + * of a rectangle or oval item, such as its border and + * background colors. + * + * Results: + * A standard Tcl result code. If an error occurs, then + * an error message is left in interp->result. + * + * Side effects: + * Configuration information, such as colors and stipple + * patterns, may be set for itemPtr. + * + *-------------------------------------------------------------- + */ + +static int +ConfigureRectOval(interp, canvas, itemPtr, argc, argv, flags) + Tcl_Interp *interp; /* Used for error reporting. */ + Tk_Canvas canvas; /* Canvas containing itemPtr. */ + Tk_Item *itemPtr; /* Rectangle item to reconfigure. */ + int argc; /* Number of elements in argv. */ + char **argv; /* Arguments describing things to configure. */ + int flags; /* Flags to pass to Tk_ConfigureWidget. */ +{ + RectOvalItem *rectOvalPtr = (RectOvalItem *) itemPtr; + XGCValues gcValues; + GC newGC; + unsigned long mask; + Tk_Window tkwin; + + tkwin = Tk_CanvasTkwin(canvas); + if (Tk_ConfigureWidget(interp, tkwin, configSpecs, argc, argv, + (char *) rectOvalPtr, flags) != TCL_OK) { + return TCL_ERROR; + } + + /* + * A few of the options require additional processing, such as + * graphics contexts. + */ + + if (rectOvalPtr->width < 1) { + rectOvalPtr->width = 1; + } + if (rectOvalPtr->outlineColor == NULL) { + newGC = None; + } else { + gcValues.foreground = rectOvalPtr->outlineColor->pixel; + gcValues.cap_style = CapProjecting; + gcValues.line_width = rectOvalPtr->width; + mask = GCForeground|GCCapStyle|GCLineWidth; + newGC = Tk_GetGC(tkwin, mask, &gcValues); + } + if (rectOvalPtr->outlineGC != None) { + Tk_FreeGC(Tk_Display(tkwin), rectOvalPtr->outlineGC); + } + rectOvalPtr->outlineGC = newGC; + + if (rectOvalPtr->fillColor == NULL) { + newGC = None; + } else { + gcValues.foreground = rectOvalPtr->fillColor->pixel; + if (rectOvalPtr->fillStipple != None) { + gcValues.stipple = rectOvalPtr->fillStipple; + gcValues.fill_style = FillStippled; + mask = GCForeground|GCStipple|GCFillStyle; + } else { + mask = GCForeground; + } + newGC = Tk_GetGC(tkwin, mask, &gcValues); + } + if (rectOvalPtr->fillGC != None) { + Tk_FreeGC(Tk_Display(tkwin), rectOvalPtr->fillGC); + } + rectOvalPtr->fillGC = newGC; + ComputeRectOvalBbox(canvas, rectOvalPtr); + + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * DeleteRectOval -- + * + * This procedure is called to clean up the data structure + * associated with a rectangle or oval item. + * + * Results: + * None. + * + * Side effects: + * Resources associated with itemPtr are released. + * + *-------------------------------------------------------------- + */ + +static void +DeleteRectOval(canvas, itemPtr, display) + Tk_Canvas canvas; /* Info about overall widget. */ + Tk_Item *itemPtr; /* Item that is being deleted. */ + Display *display; /* Display containing window for + * canvas. */ +{ + RectOvalItem *rectOvalPtr = (RectOvalItem *) itemPtr; + + if (rectOvalPtr->outlineColor != NULL) { + Tk_FreeColor(rectOvalPtr->outlineColor); + } + if (rectOvalPtr->fillColor != NULL) { + Tk_FreeColor(rectOvalPtr->fillColor); + } + if (rectOvalPtr->fillStipple != None) { + Tk_FreeBitmap(display, rectOvalPtr->fillStipple); + } + if (rectOvalPtr->outlineGC != None) { + Tk_FreeGC(display, rectOvalPtr->outlineGC); + } + if (rectOvalPtr->fillGC != None) { + Tk_FreeGC(display, rectOvalPtr->fillGC); + } +} + +/* + *-------------------------------------------------------------- + * + * ComputeRectOvalBbox -- + * + * This procedure is invoked to compute the bounding box of + * all the pixels that may be drawn as part of a rectangle + * or oval. + * + * Results: + * None. + * + * Side effects: + * The fields x1, y1, x2, and y2 are updated in the header + * for itemPtr. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +ComputeRectOvalBbox(canvas, rectOvalPtr) + Tk_Canvas canvas; /* Canvas that contains item. */ + RectOvalItem *rectOvalPtr; /* Item whose bbox is to be + * recomputed. */ +{ + int bloat, tmp; + double dtmp; + + /* + * Make sure that the first coordinates are the lowest ones. + */ + + if (rectOvalPtr->bbox[1] > rectOvalPtr->bbox[3]) { + double tmp; + tmp = rectOvalPtr->bbox[3]; + rectOvalPtr->bbox[3] = rectOvalPtr->bbox[1]; + rectOvalPtr->bbox[1] = tmp; + } + if (rectOvalPtr->bbox[0] > rectOvalPtr->bbox[2]) { + double tmp; + tmp = rectOvalPtr->bbox[2]; + rectOvalPtr->bbox[2] = rectOvalPtr->bbox[0]; + rectOvalPtr->bbox[0] = tmp; + } + + if (rectOvalPtr->outlineColor == NULL) { + bloat = 0; + } else { + bloat = (rectOvalPtr->width+1)/2; + } + + /* + * Special note: the rectangle is always drawn at least 1x1 in + * size, so round up the upper coordinates to be at least 1 unit + * greater than the lower ones. + */ + + tmp = (int) ((rectOvalPtr->bbox[0] >= 0) ? rectOvalPtr->bbox[0] + .5 + : rectOvalPtr->bbox[0] - .5); + rectOvalPtr->header.x1 = tmp - bloat; + tmp = (int) ((rectOvalPtr->bbox[1] >= 0) ? rectOvalPtr->bbox[1] + .5 + : rectOvalPtr->bbox[1] - .5); + rectOvalPtr->header.y1 = tmp - bloat; + dtmp = rectOvalPtr->bbox[2]; + if (dtmp < (rectOvalPtr->bbox[0] + 1)) { + dtmp = rectOvalPtr->bbox[0] + 1; + } + tmp = (int) ((dtmp >= 0) ? dtmp + .5 : dtmp - .5); + rectOvalPtr->header.x2 = tmp + bloat; + dtmp = rectOvalPtr->bbox[3]; + if (dtmp < (rectOvalPtr->bbox[1] + 1)) { + dtmp = rectOvalPtr->bbox[1] + 1; + } + tmp = (int) ((dtmp >= 0) ? dtmp + .5 : dtmp - .5); + rectOvalPtr->header.y2 = tmp + bloat; +} + +/* + *-------------------------------------------------------------- + * + * DisplayRectOval -- + * + * This procedure is invoked to draw a rectangle or oval + * item in a given drawable. + * + * Results: + * None. + * + * Side effects: + * ItemPtr is drawn in drawable using the transformation + * information in canvas. + * + *-------------------------------------------------------------- + */ + +static void +DisplayRectOval(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). */ +{ + RectOvalItem *rectOvalPtr = (RectOvalItem *) itemPtr; + short x1, y1, x2, y2; + + /* + * Compute the screen coordinates of the bounding box for the item. + * Make sure that the bbox is at least one pixel large, since some + * X servers will die if it isn't. + */ + + Tk_CanvasDrawableCoords(canvas, rectOvalPtr->bbox[0], rectOvalPtr->bbox[1], + &x1, &y1); + Tk_CanvasDrawableCoords(canvas, rectOvalPtr->bbox[2], rectOvalPtr->bbox[3], + &x2, &y2); + if (x2 <= x1) { + x2 = x1+1; + } + if (y2 <= y1) { + y2 = y1+1; + } + + /* + * Display filled part first (if wanted), then outline. If we're + * stippling, then modify the stipple offset in the GC. Be sure to + * reset the offset when done, since the GC is supposed to be + * read-only. + */ + + if (rectOvalPtr->fillGC != None) { + if (rectOvalPtr->fillStipple != None) { + Tk_CanvasSetStippleOrigin(canvas, rectOvalPtr->fillGC); + } + if (rectOvalPtr->header.typePtr == &tkRectangleType) { + XFillRectangle(display, drawable, rectOvalPtr->fillGC, + x1, y1, (unsigned int) (x2-x1), (unsigned int) (y2-y1)); + } else { + XFillArc(display, drawable, rectOvalPtr->fillGC, + x1, y1, (unsigned) (x2-x1), (unsigned) (y2-y1), + 0, 360*64); + } + if (rectOvalPtr->fillStipple != None) { + XSetTSOrigin(display, rectOvalPtr->fillGC, 0, 0); + } + } + if (rectOvalPtr->outlineGC != None) { + if (rectOvalPtr->header.typePtr == &tkRectangleType) { + XDrawRectangle(display, drawable, rectOvalPtr->outlineGC, + x1, y1, (unsigned) (x2-x1), (unsigned) (y2-y1)); + } else { + XDrawArc(display, drawable, rectOvalPtr->outlineGC, + x1, y1, (unsigned) (x2-x1), (unsigned) (y2-y1), 0, 360*64); + } + } +} + +/* + *-------------------------------------------------------------- + * + * RectToPoint -- + * + * Computes the distance from a given point to a given + * rectangle, in canvas units. + * + * Results: + * The return value is 0 if the point whose x and y coordinates + * are coordPtr[0] and coordPtr[1] is inside the rectangle. If the + * point isn't inside the rectangle then the return value is the + * distance from the point to the rectangle. If itemPtr is filled, + * then anywhere in the interior is considered "inside"; if + * itemPtr isn't filled, then "inside" means only the area + * occupied by the outline. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static double +RectToPoint(canvas, itemPtr, pointPtr) + Tk_Canvas canvas; /* Canvas containing item. */ + Tk_Item *itemPtr; /* Item to check against point. */ + double *pointPtr; /* Pointer to x and y coordinates. */ +{ + RectOvalItem *rectPtr = (RectOvalItem *) itemPtr; + double xDiff, yDiff, x1, y1, x2, y2, inc, tmp; + + /* + * Generate a new larger rectangle that includes the border + * width, if there is one. + */ + + x1 = rectPtr->bbox[0]; + y1 = rectPtr->bbox[1]; + x2 = rectPtr->bbox[2]; + y2 = rectPtr->bbox[3]; + if (rectPtr->outlineGC != None) { + inc = rectPtr->width/2.0; + x1 -= inc; + y1 -= inc; + x2 += inc; + y2 += inc; + } + + /* + * If the point is inside the rectangle, handle specially: + * distance is 0 if rectangle is filled, otherwise compute + * distance to nearest edge of rectangle and subtract width + * of edge. + */ + + if ((pointPtr[0] >= x1) && (pointPtr[0] < x2) + && (pointPtr[1] >= y1) && (pointPtr[1] < y2)) { + if ((rectPtr->fillGC != None) || (rectPtr->outlineGC == None)) { + return 0.0; + } + xDiff = pointPtr[0] - x1; + tmp = x2 - pointPtr[0]; + if (tmp < xDiff) { + xDiff = tmp; + } + yDiff = pointPtr[1] - y1; + tmp = y2 - pointPtr[1]; + if (tmp < yDiff) { + yDiff = tmp; + } + if (yDiff < xDiff) { + xDiff = yDiff; + } + xDiff -= rectPtr->width; + if (xDiff < 0.0) { + return 0.0; + } + return xDiff; + } + + /* + * Point is outside rectangle. + */ + + if (pointPtr[0] < x1) { + xDiff = x1 - pointPtr[0]; + } else if (pointPtr[0] > x2) { + xDiff = pointPtr[0] - x2; + } else { + xDiff = 0; + } + + if (pointPtr[1] < y1) { + yDiff = y1 - pointPtr[1]; + } else if (pointPtr[1] > y2) { + yDiff = pointPtr[1] - y2; + } else { + yDiff = 0; + } + + return hypot(xDiff, yDiff); +} + +/* + *-------------------------------------------------------------- + * + * OvalToPoint -- + * + * Computes the distance from a given point to a given + * oval, in canvas units. + * + * Results: + * The return value is 0 if the point whose x and y coordinates + * are coordPtr[0] and coordPtr[1] is inside the oval. If the + * point isn't inside the oval then the return value is the + * distance from the point to the oval. If itemPtr is filled, + * then anywhere in the interior is considered "inside"; if + * itemPtr isn't filled, then "inside" means only the area + * occupied by the outline. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static double +OvalToPoint(canvas, itemPtr, pointPtr) + Tk_Canvas canvas; /* Canvas containing item. */ + Tk_Item *itemPtr; /* Item to check against point. */ + double *pointPtr; /* Pointer to x and y coordinates. */ +{ + RectOvalItem *ovalPtr = (RectOvalItem *) itemPtr; + double width; + int filled; + + width = ovalPtr->width; + filled = ovalPtr->fillGC != None; + if (ovalPtr->outlineGC == None) { + width = 0.0; + filled = 1; + } + return TkOvalToPoint(ovalPtr->bbox, width, filled, pointPtr); +} + +/* + *-------------------------------------------------------------- + * + * RectToArea -- + * + * This procedure is called to determine whether an item + * lies entirely inside, entirely outside, or overlapping + * a given rectangle. + * + * Results: + * -1 is returned if the item is entirely outside the area + * given by rectPtr, 0 if it overlaps, and 1 if it is entirely + * inside the given area. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +RectToArea(canvas, itemPtr, areaPtr) + Tk_Canvas canvas; /* Canvas containing item. */ + Tk_Item *itemPtr; /* Item to check against rectangle. */ + double *areaPtr; /* Pointer to array of four coordinates + * (x1, y1, x2, y2) describing rectangular + * area. */ +{ + RectOvalItem *rectPtr = (RectOvalItem *) itemPtr; + double halfWidth; + + halfWidth = rectPtr->width/2.0; + if (rectPtr->outlineGC == None) { + halfWidth = 0.0; + } + + if ((areaPtr[2] <= (rectPtr->bbox[0] - halfWidth)) + || (areaPtr[0] >= (rectPtr->bbox[2] + halfWidth)) + || (areaPtr[3] <= (rectPtr->bbox[1] - halfWidth)) + || (areaPtr[1] >= (rectPtr->bbox[3] + halfWidth))) { + return -1; + } + if ((rectPtr->fillGC == None) && (rectPtr->outlineGC != None) + && (areaPtr[0] >= (rectPtr->bbox[0] + halfWidth)) + && (areaPtr[1] >= (rectPtr->bbox[1] + halfWidth)) + && (areaPtr[2] <= (rectPtr->bbox[2] - halfWidth)) + && (areaPtr[3] <= (rectPtr->bbox[3] - halfWidth))) { + return -1; + } + if ((areaPtr[0] <= (rectPtr->bbox[0] - halfWidth)) + && (areaPtr[1] <= (rectPtr->bbox[1] - halfWidth)) + && (areaPtr[2] >= (rectPtr->bbox[2] + halfWidth)) + && (areaPtr[3] >= (rectPtr->bbox[3] + halfWidth))) { + return 1; + } + return 0; +} + +/* + *-------------------------------------------------------------- + * + * OvalToArea -- + * + * This procedure is called to determine whether an item + * lies entirely inside, entirely outside, or overlapping + * a given rectangular area. + * + * Results: + * -1 is returned if the item is entirely outside the area + * given by rectPtr, 0 if it overlaps, and 1 if it is entirely + * inside the given area. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +OvalToArea(canvas, itemPtr, areaPtr) + Tk_Canvas canvas; /* Canvas containing item. */ + Tk_Item *itemPtr; /* Item to check against oval. */ + double *areaPtr; /* Pointer to array of four coordinates + * (x1, y1, x2, y2) describing rectangular + * area. */ +{ + RectOvalItem *ovalPtr = (RectOvalItem *) itemPtr; + double oval[4], halfWidth; + int result; + + /* + * Expand the oval to include the width of the outline, if any. + */ + + halfWidth = ovalPtr->width/2.0; + if (ovalPtr->outlineGC == None) { + halfWidth = 0.0; + } + oval[0] = ovalPtr->bbox[0] - halfWidth; + oval[1] = ovalPtr->bbox[1] - halfWidth; + oval[2] = ovalPtr->bbox[2] + halfWidth; + oval[3] = ovalPtr->bbox[3] + halfWidth; + + result = TkOvalToArea(oval, areaPtr); + + /* + * If the rectangle appears to overlap the oval and the oval + * isn't filled, do one more check to see if perhaps all four + * of the rectangle's corners are totally inside the oval's + * unfilled center, in which case we should return "outside". + */ + + if ((result == 0) && (ovalPtr->outlineGC != None) + && (ovalPtr->fillGC == None)) { + double centerX, centerY, width, height; + double xDelta1, yDelta1, xDelta2, yDelta2; + + centerX = (ovalPtr->bbox[0] + ovalPtr->bbox[2])/2.0; + centerY = (ovalPtr->bbox[1] + ovalPtr->bbox[3])/2.0; + width = (ovalPtr->bbox[2] - ovalPtr->bbox[0])/2.0 - halfWidth; + height = (ovalPtr->bbox[3] - ovalPtr->bbox[1])/2.0 - halfWidth; + xDelta1 = (areaPtr[0] - centerX)/width; + xDelta1 *= xDelta1; + yDelta1 = (areaPtr[1] - centerY)/height; + yDelta1 *= yDelta1; + xDelta2 = (areaPtr[2] - centerX)/width; + xDelta2 *= xDelta2; + yDelta2 = (areaPtr[3] - centerY)/height; + yDelta2 *= yDelta2; + if (((xDelta1 + yDelta1) < 1.0) + && ((xDelta1 + yDelta2) < 1.0) + && ((xDelta2 + yDelta1) < 1.0) + && ((xDelta2 + yDelta2) < 1.0)) { + return -1; + } + } + return result; +} + +/* + *-------------------------------------------------------------- + * + * ScaleRectOval -- + * + * This procedure is invoked to rescale a rectangle or oval + * item. + * + * Results: + * None. + * + * Side effects: + * The rectangle or oval referred to by itemPtr is rescaled + * so that the following transformation is applied to all + * point coordinates: + * x' = originX + scaleX*(x-originX) + * y' = originY + scaleY*(y-originY) + * + *-------------------------------------------------------------- + */ + +static void +ScaleRectOval(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. */ +{ + RectOvalItem *rectOvalPtr = (RectOvalItem *) itemPtr; + + rectOvalPtr->bbox[0] = originX + scaleX*(rectOvalPtr->bbox[0] - originX); + rectOvalPtr->bbox[1] = originY + scaleY*(rectOvalPtr->bbox[1] - originY); + rectOvalPtr->bbox[2] = originX + scaleX*(rectOvalPtr->bbox[2] - originX); + rectOvalPtr->bbox[3] = originY + scaleY*(rectOvalPtr->bbox[3] - originY); + ComputeRectOvalBbox(canvas, rectOvalPtr); +} + +/* + *-------------------------------------------------------------- + * + * TranslateRectOval -- + * + * This procedure is called to move a rectangle or oval by a + * given amount. + * + * Results: + * None. + * + * Side effects: + * The position of the rectangle or oval is offset by + * (xDelta, yDelta), and the bounding box is updated in the + * generic part of the item structure. + * + *-------------------------------------------------------------- + */ + +static void +TranslateRectOval(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. */ +{ + RectOvalItem *rectOvalPtr = (RectOvalItem *) itemPtr; + + rectOvalPtr->bbox[0] += deltaX; + rectOvalPtr->bbox[1] += deltaY; + rectOvalPtr->bbox[2] += deltaX; + rectOvalPtr->bbox[3] += deltaY; + ComputeRectOvalBbox(canvas, rectOvalPtr); +} + +/* + *-------------------------------------------------------------- + * + * RectOvalToPostscript -- + * + * This procedure is called to generate Postscript for + * rectangle and oval items. + * + * 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. + * If no error occurs, then Postscript for the rectangle is + * appended to the result. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static int +RectOvalToPostscript(interp, canvas, itemPtr, prepass) + Tcl_Interp *interp; /* Interpreter for error reporting. */ + 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. */ +{ + char pathCmd[500], string[100]; + RectOvalItem *rectOvalPtr = (RectOvalItem *) itemPtr; + double y1, y2; + + y1 = Tk_CanvasPsY(canvas, rectOvalPtr->bbox[1]); + y2 = Tk_CanvasPsY(canvas, rectOvalPtr->bbox[3]); + + /* + * Generate a string that creates a path for the rectangle or oval. + * This is the only part of the procedure's code that is type- + * specific. + */ + + + if (rectOvalPtr->header.typePtr == &tkRectangleType) { + sprintf(pathCmd, "%.15g %.15g moveto %.15g 0 rlineto 0 %.15g rlineto %.15g 0 rlineto closepath\n", + rectOvalPtr->bbox[0], y1, + rectOvalPtr->bbox[2]-rectOvalPtr->bbox[0], y2-y1, + rectOvalPtr->bbox[0]-rectOvalPtr->bbox[2]); + } else { + sprintf(pathCmd, "matrix currentmatrix\n%.15g %.15g translate %.15g %.15g scale 1 0 moveto 0 0 1 0 360 arc\nsetmatrix\n", + (rectOvalPtr->bbox[0] + rectOvalPtr->bbox[2])/2, (y1 + y2)/2, + (rectOvalPtr->bbox[2] - rectOvalPtr->bbox[0])/2, (y1 - y2)/2); + } + + /* + * First draw the filled area of the rectangle. + */ + + if (rectOvalPtr->fillColor != NULL) { + Tcl_AppendResult(interp, pathCmd, (char *) NULL); + if (Tk_CanvasPsColor(interp, canvas, rectOvalPtr->fillColor) + != TCL_OK) { + return TCL_ERROR; + } + if (rectOvalPtr->fillStipple != None) { + Tcl_AppendResult(interp, "clip ", (char *) NULL); + if (Tk_CanvasPsStipple(interp, canvas, rectOvalPtr->fillStipple) + != TCL_OK) { + return TCL_ERROR; + } + if (rectOvalPtr->outlineColor != NULL) { + Tcl_AppendResult(interp, "grestore gsave\n", (char *) NULL); + } + } else { + Tcl_AppendResult(interp, "fill\n", (char *) NULL); + } + } + + /* + * Now draw the outline, if there is one. + */ + + if (rectOvalPtr->outlineColor != NULL) { + Tcl_AppendResult(interp, pathCmd, (char *) NULL); + sprintf(string, "%d setlinewidth", rectOvalPtr->width); + Tcl_AppendResult(interp, string, + " 0 setlinejoin 2 setlinecap\n", (char *) NULL); + if (Tk_CanvasPsColor(interp, canvas, rectOvalPtr->outlineColor) + != TCL_OK) { + return TCL_ERROR; + } + Tcl_AppendResult(interp, "stroke\n", (char *) NULL); + } + return TCL_OK; +} diff --git a/generic/tkScale.c b/generic/tkScale.c new file mode 100644 index 0000000..6c78150 --- /dev/null +++ b/generic/tkScale.c @@ -0,0 +1,1143 @@ +/* + * tkScale.c -- + * + * This module implements a scale widgets for the Tk toolkit. + * A scale displays a slider that can be adjusted to change a + * value; it also displays numeric labels and a textual label, + * if desired. + * + * The modifications to use floating-point values are based on + * an implementation by Paul Mackerras. The -variable option + * is due to Henning Schulzrinne. All of these are used with + * permission. + * + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkScale.c 1.88 97/07/31 09:11:57 + */ + +#include "tkPort.h" +#include "default.h" +#include "tkInt.h" +#include "tclMath.h" +#include "tkScale.h" + +static Tk_ConfigSpec configSpecs[] = { + {TK_CONFIG_BORDER, "-activebackground", "activeBackground", "Foreground", + DEF_SCALE_ACTIVE_BG_COLOR, Tk_Offset(TkScale, activeBorder), + TK_CONFIG_COLOR_ONLY}, + {TK_CONFIG_BORDER, "-activebackground", "activeBackground", "Foreground", + DEF_SCALE_ACTIVE_BG_MONO, Tk_Offset(TkScale, activeBorder), + TK_CONFIG_MONO_ONLY}, + {TK_CONFIG_BORDER, "-background", "background", "Background", + DEF_SCALE_BG_COLOR, Tk_Offset(TkScale, bgBorder), + TK_CONFIG_COLOR_ONLY}, + {TK_CONFIG_BORDER, "-background", "background", "Background", + DEF_SCALE_BG_MONO, Tk_Offset(TkScale, bgBorder), + TK_CONFIG_MONO_ONLY}, + {TK_CONFIG_DOUBLE, "-bigincrement", "bigIncrement", "BigIncrement", + DEF_SCALE_BIG_INCREMENT, Tk_Offset(TkScale, bigIncrement), 0}, + {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_SCALE_BORDER_WIDTH, Tk_Offset(TkScale, borderWidth), 0}, + {TK_CONFIG_STRING, "-command", "command", "Command", + DEF_SCALE_COMMAND, Tk_Offset(TkScale, command), TK_CONFIG_NULL_OK}, + {TK_CONFIG_ACTIVE_CURSOR, "-cursor", "cursor", "Cursor", + DEF_SCALE_CURSOR, Tk_Offset(TkScale, cursor), TK_CONFIG_NULL_OK}, + {TK_CONFIG_INT, "-digits", "digits", "Digits", + DEF_SCALE_DIGITS, Tk_Offset(TkScale, digits), 0}, + {TK_CONFIG_SYNONYM, "-fg", "foreground", (char *) NULL, + (char *) NULL, 0, 0}, + {TK_CONFIG_FONT, "-font", "font", "Font", + DEF_SCALE_FONT, Tk_Offset(TkScale, tkfont), + 0}, + {TK_CONFIG_COLOR, "-foreground", "foreground", "Foreground", + DEF_SCALE_FG_COLOR, Tk_Offset(TkScale, textColorPtr), + TK_CONFIG_COLOR_ONLY}, + {TK_CONFIG_COLOR, "-foreground", "foreground", "Foreground", + DEF_SCALE_FG_MONO, Tk_Offset(TkScale, textColorPtr), + TK_CONFIG_MONO_ONLY}, + {TK_CONFIG_DOUBLE, "-from", "from", "From", + DEF_SCALE_FROM, Tk_Offset(TkScale, fromValue), 0}, + {TK_CONFIG_COLOR, "-highlightbackground", "highlightBackground", + "HighlightBackground", DEF_SCALE_HIGHLIGHT_BG, + Tk_Offset(TkScale, highlightBgColorPtr), 0}, + {TK_CONFIG_COLOR, "-highlightcolor", "highlightColor", "HighlightColor", + DEF_SCALE_HIGHLIGHT, Tk_Offset(TkScale, highlightColorPtr), 0}, + {TK_CONFIG_PIXELS, "-highlightthickness", "highlightThickness", + "HighlightThickness", + DEF_SCALE_HIGHLIGHT_WIDTH, Tk_Offset(TkScale, highlightWidth), 0}, + {TK_CONFIG_STRING, "-label", "label", "Label", + DEF_SCALE_LABEL, Tk_Offset(TkScale, label), TK_CONFIG_NULL_OK}, + {TK_CONFIG_PIXELS, "-length", "length", "Length", + DEF_SCALE_LENGTH, Tk_Offset(TkScale, length), 0}, + {TK_CONFIG_UID, "-orient", "orient", "Orient", + DEF_SCALE_ORIENT, Tk_Offset(TkScale, orientUid), 0}, + {TK_CONFIG_RELIEF, "-relief", "relief", "Relief", + DEF_SCALE_RELIEF, Tk_Offset(TkScale, relief), 0}, + {TK_CONFIG_INT, "-repeatdelay", "repeatDelay", "RepeatDelay", + DEF_SCALE_REPEAT_DELAY, Tk_Offset(TkScale, repeatDelay), 0}, + {TK_CONFIG_INT, "-repeatinterval", "repeatInterval", "RepeatInterval", + DEF_SCALE_REPEAT_INTERVAL, Tk_Offset(TkScale, repeatInterval), 0}, + {TK_CONFIG_DOUBLE, "-resolution", "resolution", "Resolution", + DEF_SCALE_RESOLUTION, Tk_Offset(TkScale, resolution), 0}, + {TK_CONFIG_BOOLEAN, "-showvalue", "showValue", "ShowValue", + DEF_SCALE_SHOW_VALUE, Tk_Offset(TkScale, showValue), 0}, + {TK_CONFIG_PIXELS, "-sliderlength", "sliderLength", "SliderLength", + DEF_SCALE_SLIDER_LENGTH, Tk_Offset(TkScale, sliderLength), 0}, + {TK_CONFIG_RELIEF, "-sliderrelief", "sliderRelief", "SliderRelief", + DEF_SCALE_SLIDER_RELIEF, Tk_Offset(TkScale, sliderRelief), + TK_CONFIG_DONT_SET_DEFAULT}, + {TK_CONFIG_UID, "-state", "state", "State", + DEF_SCALE_STATE, Tk_Offset(TkScale, state), 0}, + {TK_CONFIG_STRING, "-takefocus", "takeFocus", "TakeFocus", + DEF_SCALE_TAKE_FOCUS, Tk_Offset(TkScale, takeFocus), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_DOUBLE, "-tickinterval", "tickInterval", "TickInterval", + DEF_SCALE_TICK_INTERVAL, Tk_Offset(TkScale, tickInterval), 0}, + {TK_CONFIG_DOUBLE, "-to", "to", "To", + DEF_SCALE_TO, Tk_Offset(TkScale, toValue), 0}, + {TK_CONFIG_COLOR, "-troughcolor", "troughColor", "Background", + DEF_SCALE_TROUGH_COLOR, Tk_Offset(TkScale, troughColorPtr), + TK_CONFIG_COLOR_ONLY}, + {TK_CONFIG_COLOR, "-troughcolor", "troughColor", "Background", + DEF_SCALE_TROUGH_MONO, Tk_Offset(TkScale, troughColorPtr), + TK_CONFIG_MONO_ONLY}, + {TK_CONFIG_STRING, "-variable", "variable", "Variable", + DEF_SCALE_VARIABLE, Tk_Offset(TkScale, varName), TK_CONFIG_NULL_OK}, + {TK_CONFIG_PIXELS, "-width", "width", "Width", + DEF_SCALE_WIDTH, Tk_Offset(TkScale, width), 0}, + {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, 0} +}; + +/* + * Forward declarations for procedures defined later in this file: + */ + +static void ComputeFormat _ANSI_ARGS_((TkScale *scalePtr)); +static void ComputeScaleGeometry _ANSI_ARGS_((TkScale *scalePtr)); +static int ConfigureScale _ANSI_ARGS_((Tcl_Interp *interp, + TkScale *scalePtr, int argc, char **argv, + int flags)); +static void DestroyScale _ANSI_ARGS_((char *memPtr)); +static void ScaleCmdDeletedProc _ANSI_ARGS_(( + ClientData clientData)); +static void ScaleEventProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +static char * ScaleVarProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, char *name1, char *name2, + int flags)); +static int ScaleWidgetCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static void ScaleWorldChanged _ANSI_ARGS_(( + ClientData instanceData)); + +/* + * The structure below defines scale class behavior by means of procedures + * that can be invoked from generic window code. + */ + +static TkClassProcs scaleClass = { + NULL, /* createProc. */ + ScaleWorldChanged, /* geometryProc. */ + NULL /* modalProc. */ +}; + + +/* + *-------------------------------------------------------------- + * + * Tk_ScaleCmd -- + * + * This procedure is invoked to process the "scale" 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_ScaleCmd(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; + register TkScale *scalePtr; + Tk_Window new; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " pathName ?options?\"", (char *) NULL); + return TCL_ERROR; + } + + new = Tk_CreateWindowFromPath(interp, tkwin, argv[1], (char *) NULL); + if (new == NULL) { + return TCL_ERROR; + } + scalePtr = TkpCreateScale(new); + + /* + * Initialize fields that won't be initialized by ConfigureScale, + * or which ConfigureScale expects to have reasonable values + * (e.g. resource pointers). + */ + + scalePtr->tkwin = new; + scalePtr->display = Tk_Display(new); + scalePtr->interp = interp; + scalePtr->widgetCmd = Tcl_CreateCommand(interp, + Tk_PathName(scalePtr->tkwin), ScaleWidgetCmd, + (ClientData) scalePtr, ScaleCmdDeletedProc); + scalePtr->orientUid = NULL; + scalePtr->vertical = 0; + scalePtr->width = 0; + scalePtr->length = 0; + scalePtr->value = 0; + scalePtr->varName = NULL; + scalePtr->fromValue = 0; + scalePtr->toValue = 0; + scalePtr->tickInterval = 0; + scalePtr->resolution = 1; + scalePtr->bigIncrement = 0.0; + scalePtr->command = NULL; + scalePtr->repeatDelay = 0; + scalePtr->repeatInterval = 0; + scalePtr->label = NULL; + scalePtr->labelLength = 0; + scalePtr->state = tkNormalUid; + scalePtr->borderWidth = 0; + scalePtr->bgBorder = NULL; + scalePtr->activeBorder = NULL; + scalePtr->sliderRelief = TK_RELIEF_RAISED; + scalePtr->troughColorPtr = NULL; + scalePtr->troughGC = None; + scalePtr->copyGC = None; + scalePtr->tkfont = NULL; + scalePtr->textColorPtr = NULL; + scalePtr->textGC = None; + scalePtr->relief = TK_RELIEF_FLAT; + scalePtr->highlightWidth = 0; + scalePtr->highlightBgColorPtr = NULL; + scalePtr->highlightColorPtr = NULL; + scalePtr->inset = 0; + scalePtr->sliderLength = 0; + scalePtr->showValue = 0; + scalePtr->horizLabelY = 0; + scalePtr->horizValueY = 0; + scalePtr->horizTroughY = 0; + scalePtr->horizTickY = 0; + scalePtr->vertTickRightX = 0; + scalePtr->vertValueRightX = 0; + scalePtr->vertTroughX = 0; + scalePtr->vertLabelX = 0; + scalePtr->cursor = None; + scalePtr->takeFocus = NULL; + scalePtr->flags = NEVER_SET; + + Tk_SetClass(scalePtr->tkwin, "Scale"); + TkSetClassProcs(scalePtr->tkwin, &scaleClass, (ClientData) scalePtr); + Tk_CreateEventHandler(scalePtr->tkwin, + ExposureMask|StructureNotifyMask|FocusChangeMask, + ScaleEventProc, (ClientData) scalePtr); + if (ConfigureScale(interp, scalePtr, argc-2, argv+2, 0) != TCL_OK) { + goto error; + } + + interp->result = Tk_PathName(scalePtr->tkwin); + return TCL_OK; + + error: + Tk_DestroyWindow(scalePtr->tkwin); + return TCL_ERROR; +} + +/* + *-------------------------------------------------------------- + * + * ScaleWidgetCmd -- + * + * This procedure is invoked to process the Tcl command + * that corresponds to a widget managed by this module. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +static int +ScaleWidgetCmd(clientData, interp, argc, argv) + ClientData clientData; /* Information about scale + * widget. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + register TkScale *scalePtr = (TkScale *) clientData; + int result = TCL_OK; + size_t length; + int c; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " option ?arg arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_Preserve((ClientData) scalePtr); + 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, scalePtr->tkwin, configSpecs, + (char *) scalePtr, argv[2], 0); + } else if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0) + && (length >= 3)) { + if (argc == 2) { + result = Tk_ConfigureInfo(interp, scalePtr->tkwin, configSpecs, + (char *) scalePtr, (char *) NULL, 0); + } else if (argc == 3) { + result = Tk_ConfigureInfo(interp, scalePtr->tkwin, configSpecs, + (char *) scalePtr, argv[2], 0); + } else { + result = ConfigureScale(interp, scalePtr, argc-2, argv+2, + TK_CONFIG_ARGV_ONLY); + } + } else if ((c == 'c') && (strncmp(argv[1], "coords", length) == 0) + && (length >= 3)) { + int x, y ; + double value; + + if ((argc != 2) && (argc != 3)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " coords ?value?\"", (char *) NULL); + goto error; + } + if (argc == 3) { + if (Tcl_GetDouble(interp, argv[2], &value) != TCL_OK) { + goto error; + } + } else { + value = scalePtr->value; + } + if (scalePtr->vertical) { + x = scalePtr->vertTroughX + scalePtr->width/2 + + scalePtr->borderWidth; + y = TkpValueToPixel(scalePtr, value); + } else { + x = TkpValueToPixel(scalePtr, value); + y = scalePtr->horizTroughY + scalePtr->width/2 + + scalePtr->borderWidth; + } + sprintf(interp->result, "%d %d", x, y); + } else if ((c == 'g') && (strncmp(argv[1], "get", length) == 0)) { + double value; + int x, y; + + if ((argc != 2) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " get ?x y?\"", (char *) NULL); + goto error; + } + if (argc == 2) { + value = scalePtr->value; + } else { + if ((Tcl_GetInt(interp, argv[2], &x) != TCL_OK) + || (Tcl_GetInt(interp, argv[3], &y) != TCL_OK)) { + goto error; + } + value = TkpPixelToValue(scalePtr, x, y); + } + sprintf(interp->result, scalePtr->format, value); + } else if ((c == 'i') && (strncmp(argv[1], "identify", length) == 0)) { + int x, y, thing; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " identify 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; + } + 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; + } + } else if ((c == 's') && (strncmp(argv[1], "set", length) == 0)) { + double value; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " set value\"", (char *) NULL); + goto error; + } + if (Tcl_GetDouble(interp, argv[2], &value) != TCL_OK) { + goto error; + } + if (scalePtr->state != tkDisabledUid) { + TkpSetScaleValue(scalePtr, value, 1, 1); + } + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be cget, configure, coords, get, identify, or set", + (char *) NULL); + goto error; + } + Tcl_Release((ClientData) scalePtr); + return result; + + error: + Tcl_Release((ClientData) scalePtr); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * DestroyScale -- + * + * 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). + * + * Results: + * None. + * + * Side effects: + * Everything associated with the scale is freed up. + * + *---------------------------------------------------------------------- + */ + +static void +DestroyScale(memPtr) + char *memPtr; /* Info about scale widget. */ +{ + register TkScale *scalePtr = (TkScale *) memPtr; + + /* + * Free up all the stuff that requires special handling, then + * let Tk_FreeOptions handle all the standard option-related + * stuff. + */ + + if (scalePtr->varName != NULL) { + Tcl_UntraceVar(scalePtr->interp, scalePtr->varName, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + ScaleVarProc, (ClientData) scalePtr); + } + if (scalePtr->troughGC != None) { + Tk_FreeGC(scalePtr->display, scalePtr->troughGC); + } + if (scalePtr->copyGC != None) { + Tk_FreeGC(scalePtr->display, scalePtr->copyGC); + } + if (scalePtr->textGC != None) { + Tk_FreeGC(scalePtr->display, scalePtr->textGC); + } + Tk_FreeOptions(configSpecs, (char *) scalePtr, scalePtr->display, 0); + TkpDestroyScale(scalePtr); +} + +/* + *---------------------------------------------------------------------- + * + * ConfigureScale -- + * + * This procedure is called to process an argv/argc list, plus + * the Tk option database, in order to configure (or + * reconfigure) a scale widget. + * + * Results: + * The return value is a standard Tcl result. If TCL_ERROR is + * returned, then interp->result contains an error message. + * + * Side effects: + * Configuration information, such as colors, border width, + * etc. get set for scalePtr; old resources get freed, + * if there were any. + * + *---------------------------------------------------------------------- + */ + +static int +ConfigureScale(interp, scalePtr, argc, argv, flags) + Tcl_Interp *interp; /* Used for error reporting. */ + register TkScale *scalePtr; /* 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. */ +{ + size_t length; + + /* + * Eliminate any existing trace on a variable monitored by the scale. + */ + + if (scalePtr->varName != NULL) { + Tcl_UntraceVar(interp, scalePtr->varName, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + ScaleVarProc, (ClientData) scalePtr); + } + + if (Tk_ConfigureWidget(interp, scalePtr->tkwin, configSpecs, + argc, argv, (char *) scalePtr, flags) != TCL_OK) { + return TCL_ERROR; + } + + /* + * If the scale is tied to the value of a variable, then set up + * a trace on the variable's value and set the scale's value from + * the value of the variable, if it exists. + */ + + if (scalePtr->varName != NULL) { + char *stringValue, *end; + double value; + + stringValue = Tcl_GetVar(interp, scalePtr->varName, TCL_GLOBAL_ONLY); + if (stringValue != NULL) { + value = strtod(stringValue, &end); + if ((end != stringValue) && (*end == 0)) { + scalePtr->value = TkRoundToResolution(scalePtr, value); + } + } + Tcl_TraceVar(interp, scalePtr->varName, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + ScaleVarProc, (ClientData) scalePtr); + } + + /* + * Several options need special processing, such as parsing the + * orientation and creating GCs. + */ + + length = strlen(scalePtr->orientUid); + if (strncmp(scalePtr->orientUid, "vertical", length) == 0) { + scalePtr->vertical = 1; + } else if (strncmp(scalePtr->orientUid, "horizontal", length) == 0) { + scalePtr->vertical = 0; + } else { + Tcl_AppendResult(interp, "bad orientation \"", scalePtr->orientUid, + "\": must be vertical or horizontal", (char *) NULL); + return TCL_ERROR; + } + + scalePtr->fromValue = TkRoundToResolution(scalePtr, scalePtr->fromValue); + scalePtr->toValue = TkRoundToResolution(scalePtr, scalePtr->toValue); + scalePtr->tickInterval = TkRoundToResolution(scalePtr, + scalePtr->tickInterval); + + /* + * Make sure that the tick interval has the right sign so that + * addition moves from fromValue to toValue. + */ + + if ((scalePtr->tickInterval < 0) + ^ ((scalePtr->toValue - scalePtr->fromValue) < 0)) { + scalePtr->tickInterval = -scalePtr->tickInterval; + } + + /* + * Set the scale value to itself; all this does is to make sure + * that the scale's value is within the new acceptable range for + * the scale and reflect the value in the associated variable, + * if any. + */ + + ComputeFormat(scalePtr); + TkpSetScaleValue(scalePtr, scalePtr->value, 1, 1); + + if (scalePtr->label != NULL) { + scalePtr->labelLength = strlen(scalePtr->label); + } else { + scalePtr->labelLength = 0; + } + + if ((scalePtr->state != tkNormalUid) + && (scalePtr->state != tkDisabledUid) + && (scalePtr->state != tkActiveUid)) { + Tcl_AppendResult(interp, "bad state value \"", scalePtr->state, + "\": must be normal, active, or disabled", (char *) NULL); + scalePtr->state = tkNormalUid; + return TCL_ERROR; + } + + Tk_SetBackgroundFromBorder(scalePtr->tkwin, scalePtr->bgBorder); + + if (scalePtr->highlightWidth < 0) { + scalePtr->highlightWidth = 0; + } + scalePtr->inset = scalePtr->highlightWidth + scalePtr->borderWidth; + + ScaleWorldChanged((ClientData) scalePtr); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * ScaleWorldChanged -- + * + * This procedure is called when the world has changed in some + * way and the widget needs to recompute all its graphics contexts + * and determine its new geometry. + * + * Results: + * None. + * + * Side effects: + * Scale will be relayed out and redisplayed. + * + *--------------------------------------------------------------------------- + */ + +static void +ScaleWorldChanged(instanceData) + ClientData instanceData; /* Information about widget. */ +{ + XGCValues gcValues; + GC gc; + TkScale *scalePtr; + + scalePtr = (TkScale *) instanceData; + + gcValues.foreground = scalePtr->troughColorPtr->pixel; + gc = Tk_GetGC(scalePtr->tkwin, GCForeground, &gcValues); + if (scalePtr->troughGC != None) { + Tk_FreeGC(scalePtr->display, scalePtr->troughGC); + } + scalePtr->troughGC = gc; + + gcValues.font = Tk_FontId(scalePtr->tkfont); + gcValues.foreground = scalePtr->textColorPtr->pixel; + gc = Tk_GetGC(scalePtr->tkwin, GCForeground | GCFont, &gcValues); + if (scalePtr->textGC != None) { + Tk_FreeGC(scalePtr->display, scalePtr->textGC); + } + scalePtr->textGC = gc; + + if (scalePtr->copyGC == None) { + gcValues.graphics_exposures = False; + scalePtr->copyGC = Tk_GetGC(scalePtr->tkwin, GCGraphicsExposures, + &gcValues); + } + scalePtr->inset = scalePtr->highlightWidth + scalePtr->borderWidth; + + /* + * Recompute display-related information, and let the geometry + * manager know how much space is needed now. + */ + + ComputeScaleGeometry(scalePtr); + + TkEventuallyRedrawScale(scalePtr, REDRAW_ALL); +} + +/* + *---------------------------------------------------------------------- + * + * ComputeFormat -- + * + * This procedure is invoked to recompute the "format" field + * of a scale's widget record, which determines how the value + * of the scale is converted to a string. + * + * Results: + * None. + * + * Side effects: + * The format field of scalePtr is modified. + * + *---------------------------------------------------------------------- + */ + +static void +ComputeFormat(scalePtr) + TkScale *scalePtr; /* Information about scale widget. */ +{ + double maxValue, x; + int mostSigDigit, numDigits, leastSigDigit, afterDecimal; + int eDigits, fDigits; + + /* + * Compute the displacement from the decimal of the most significant + * digit required for any number in the scale's range. + */ + + maxValue = fabs(scalePtr->fromValue); + x = fabs(scalePtr->toValue); + if (x > maxValue) { + maxValue = x; + } + if (maxValue == 0) { + maxValue = 1; + } + mostSigDigit = (int) floor(log10(maxValue)); + + /* + * If the number of significant digits wasn't specified explicitly, + * compute it. It's the difference between the most significant + * digit needed to represent any number on the scale and the + * most significant digit of the smallest difference between + * numbers on the scale. In other words, display enough digits so + * that at least one digit will be different between any two adjacent + * positions of the scale. + */ + + numDigits = scalePtr->digits; + if (numDigits <= 0) { + if (scalePtr->resolution > 0) { + /* + * A resolution was specified for the scale, so just use it. + */ + + leastSigDigit = (int) floor(log10(scalePtr->resolution)); + } else { + /* + * No resolution was specified, so compute the difference + * in value between adjacent pixels and use it for the least + * significant digit. + */ + + x = fabs(scalePtr->fromValue - scalePtr->toValue); + if (scalePtr->length > 0) { + x /= scalePtr->length; + } + if (x > 0){ + leastSigDigit = (int) floor(log10(x)); + } else { + leastSigDigit = 0; + } + } + numDigits = mostSigDigit - leastSigDigit + 1; + if (numDigits < 1) { + numDigits = 1; + } + } + + /* + * Compute the number of characters required using "e" format and + * "f" format, and then choose whichever one takes fewer characters. + */ + + eDigits = numDigits + 4; + if (numDigits > 1) { + eDigits++; /* Decimal point. */ + } + afterDecimal = numDigits - mostSigDigit - 1; + if (afterDecimal < 0) { + afterDecimal = 0; + } + fDigits = (mostSigDigit >= 0) ? mostSigDigit + afterDecimal : afterDecimal; + if (afterDecimal > 0) { + fDigits++; /* Decimal point. */ + } + if (mostSigDigit < 0) { + fDigits++; /* Zero to left of decimal point. */ + } + if (fDigits <= eDigits) { + sprintf(scalePtr->format, "%%.%df", afterDecimal); + } else { + sprintf(scalePtr->format, "%%.%de", numDigits-1); + } +} + +/* + *---------------------------------------------------------------------- + * + * ComputeScaleGeometry -- + * + * This procedure is called to compute various geometrical + * information for a scale, such as where various things get + * displayed. It's called when the window is reconfigured. + * + * Results: + * None. + * + * Side effects: + * Display-related numbers get changed in *scalePtr. The + * geometry manager gets told about the window's preferred size. + * + *---------------------------------------------------------------------- + */ + +static void +ComputeScaleGeometry(scalePtr) + register TkScale *scalePtr; /* Information about widget. */ +{ + char valueString[PRINT_CHARS]; + int tmp, valuePixels, x, y, extraSpace; + Tk_FontMetrics fm; + + /* + * Horizontal scales are simpler than vertical ones because + * all sizes are the same (the height of a line of text); + * handle them first and then quit. + */ + + Tk_GetFontMetrics(scalePtr->tkfont, &fm); + if (!scalePtr->vertical) { + y = scalePtr->inset; + extraSpace = 0; + if (scalePtr->labelLength != 0) { + scalePtr->horizLabelY = y + SPACING; + y += fm.linespace + SPACING; + extraSpace = SPACING; + } + if (scalePtr->showValue) { + scalePtr->horizValueY = y + SPACING; + y += fm.linespace + SPACING; + extraSpace = SPACING; + } else { + scalePtr->horizValueY = y; + } + y += extraSpace; + scalePtr->horizTroughY = y; + y += scalePtr->width + 2*scalePtr->borderWidth; + if (scalePtr->tickInterval != 0) { + scalePtr->horizTickY = y + SPACING; + y += fm.linespace + 2*SPACING; + } + Tk_GeometryRequest(scalePtr->tkwin, + scalePtr->length + 2*scalePtr->inset, y + scalePtr->inset); + Tk_SetInternalBorder(scalePtr->tkwin, scalePtr->inset); + return; + } + + /* + * Vertical scale: compute the amount of space needed to display + * the scales value by formatting strings for the two end points; + * use whichever length is longer. + */ + + sprintf(valueString, scalePtr->format, scalePtr->fromValue); + valuePixels = Tk_TextWidth(scalePtr->tkfont, valueString, -1); + + sprintf(valueString, scalePtr->format, scalePtr->toValue); + tmp = Tk_TextWidth(scalePtr->tkfont, valueString, -1); + if (valuePixels < tmp) { + valuePixels = tmp; + } + + /* + * Assign x-locations to the elements of the scale, working from + * left to right. + */ + + x = scalePtr->inset; + if ((scalePtr->tickInterval != 0) && (scalePtr->showValue)) { + scalePtr->vertTickRightX = x + SPACING + valuePixels; + scalePtr->vertValueRightX = scalePtr->vertTickRightX + valuePixels + + fm.ascent/2; + x = scalePtr->vertValueRightX + SPACING; + } else if (scalePtr->tickInterval != 0) { + scalePtr->vertTickRightX = x + SPACING + valuePixels; + scalePtr->vertValueRightX = scalePtr->vertTickRightX; + x = scalePtr->vertTickRightX + SPACING; + } else if (scalePtr->showValue) { + scalePtr->vertTickRightX = x; + scalePtr->vertValueRightX = x + SPACING + valuePixels; + x = scalePtr->vertValueRightX + SPACING; + } else { + scalePtr->vertTickRightX = x; + scalePtr->vertValueRightX = x; + } + scalePtr->vertTroughX = x; + x += 2*scalePtr->borderWidth + scalePtr->width; + if (scalePtr->labelLength == 0) { + scalePtr->vertLabelX = 0; + } else { + scalePtr->vertLabelX = x + fm.ascent/2; + x = scalePtr->vertLabelX + fm.ascent/2 + + Tk_TextWidth(scalePtr->tkfont, scalePtr->label, + scalePtr->labelLength); + } + Tk_GeometryRequest(scalePtr->tkwin, x + scalePtr->inset, + scalePtr->length + 2*scalePtr->inset); + Tk_SetInternalBorder(scalePtr->tkwin, scalePtr->inset); +} + +/* + *-------------------------------------------------------------- + * + * ScaleEventProc -- + * + * This procedure is invoked by the Tk dispatcher for various + * events on scales. + * + * Results: + * None. + * + * Side effects: + * When the window gets deleted, internal structures get + * cleaned up. When it gets exposed, it is redisplayed. + * + *-------------------------------------------------------------- + */ + +static void +ScaleEventProc(clientData, eventPtr) + ClientData clientData; /* Information about window. */ + XEvent *eventPtr; /* Information about event. */ +{ + TkScale *scalePtr = (TkScale *) clientData; + + if ((eventPtr->type == Expose) && (eventPtr->xexpose.count == 0)) { + TkEventuallyRedrawScale(scalePtr, REDRAW_ALL); + } else if (eventPtr->type == DestroyNotify) { + if (scalePtr->tkwin != NULL) { + scalePtr->tkwin = NULL; + Tcl_DeleteCommandFromToken(scalePtr->interp, scalePtr->widgetCmd); + } + if (scalePtr->flags & REDRAW_ALL) { + Tcl_CancelIdleCall(TkpDisplayScale, (ClientData) scalePtr); + } + Tcl_EventuallyFree((ClientData) scalePtr, DestroyScale); + } else if (eventPtr->type == ConfigureNotify) { + ComputeScaleGeometry(scalePtr); + TkEventuallyRedrawScale(scalePtr, REDRAW_ALL); + } else if (eventPtr->type == FocusIn) { + if (eventPtr->xfocus.detail != NotifyInferior) { + scalePtr->flags |= GOT_FOCUS; + if (scalePtr->highlightWidth > 0) { + TkEventuallyRedrawScale(scalePtr, REDRAW_ALL); + } + } + } else if (eventPtr->type == FocusOut) { + if (eventPtr->xfocus.detail != NotifyInferior) { + scalePtr->flags &= ~GOT_FOCUS; + if (scalePtr->highlightWidth > 0) { + TkEventuallyRedrawScale(scalePtr, REDRAW_ALL); + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * ScaleCmdDeletedProc -- + * + * 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 +ScaleCmdDeletedProc(clientData) + ClientData clientData; /* Pointer to widget record for widget. */ +{ + TkScale *scalePtr = (TkScale *) clientData; + Tk_Window tkwin = scalePtr->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. + */ + + if (tkwin != NULL) { + scalePtr->tkwin = NULL; + Tk_DestroyWindow(tkwin); + } +} + +/* + *-------------------------------------------------------------- + * + * TkEventuallyRedrawScale -- + * + * Arrange for part or all of a scale widget to redrawn at + * the next convenient time in the future. + * + * Results: + * None. + * + * Side effects: + * If "what" is REDRAW_SLIDER then just the slider and the + * value readout will be redrawn; if "what" is REDRAW_ALL + * then the entire widget will be redrawn. + * + *-------------------------------------------------------------- + */ + +void +TkEventuallyRedrawScale(scalePtr, what) + register TkScale *scalePtr; /* Information about widget. */ + int what; /* What to redraw: REDRAW_SLIDER + * or REDRAW_ALL. */ +{ + if ((what == 0) || (scalePtr->tkwin == NULL) + || !Tk_IsMapped(scalePtr->tkwin)) { + return; + } + if ((scalePtr->flags & REDRAW_ALL) == 0) { + Tcl_DoWhenIdle(TkpDisplayScale, (ClientData) scalePtr); + } + scalePtr->flags |= what; +} + +/* + *-------------------------------------------------------------- + * + * TkRoundToResolution -- + * + * Round a given floating-point value to the nearest multiple + * of the scale's resolution. + * + * Results: + * The return value is the rounded result. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +double +TkRoundToResolution(scalePtr, value) + TkScale *scalePtr; /* Information about scale widget. */ + double value; /* Value to round. */ +{ + double rem, new; + + if (scalePtr->resolution <= 0) { + return value; + } + new = scalePtr->resolution * floor(value/scalePtr->resolution); + rem = value - new; + if (rem < 0) { + if (rem <= -scalePtr->resolution/2) { + new -= scalePtr->resolution; + } + } else { + if (rem >= scalePtr->resolution/2) { + new += scalePtr->resolution; + } + } + return new; +} + +/* + *---------------------------------------------------------------------- + * + * ScaleVarProc -- + * + * This procedure is invoked by Tcl whenever someone modifies a + * variable associated with a scale widget. + * + * Results: + * NULL is always returned. + * + * Side effects: + * The value displayed in the scale will change to match the + * variable's new value. If the variable has a bogus value then + * it is reset to the value of the scale. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static char * +ScaleVarProc(clientData, interp, name1, name2, flags) + ClientData clientData; /* Information about button. */ + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *name1; /* Name of variable. */ + char *name2; /* Second part of variable name. */ + int flags; /* Information about what happened. */ +{ + register TkScale *scalePtr = (TkScale *) clientData; + char *stringValue, *end, *result; + double value; + + /* + * If the variable is unset, then immediately recreate it unless + * the whole interpreter is going away. + */ + + if (flags & TCL_TRACE_UNSETS) { + if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) { + Tcl_TraceVar(interp, scalePtr->varName, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + ScaleVarProc, clientData); + scalePtr->flags |= NEVER_SET; + TkpSetScaleValue(scalePtr, scalePtr->value, 1, 0); + } + return (char *) NULL; + } + + /* + * If we came here because we updated the variable (in TkpSetScaleValue), + * then ignore the trace. Otherwise update the scale with the value + * of the variable. + */ + + if (scalePtr->flags & SETTING_VAR) { + return (char *) NULL; + } + result = NULL; + stringValue = Tcl_GetVar(interp, scalePtr->varName, TCL_GLOBAL_ONLY); + if (stringValue != NULL) { + value = strtod(stringValue, &end); + if ((end == stringValue) || (*end != 0)) { + result = "can't assign non-numeric value to scale variable"; + } else { + scalePtr->value = TkRoundToResolution(scalePtr, value); + } + + /* + * This code is a bit tricky because it sets the scale's value before + * calling TkpSetScaleValue. This way, TkpSetScaleValue won't bother + * to set the variable again or to invoke the -command. However, it + * also won't redisplay the scale, so we have to ask for that + * explicitly. + */ + + TkpSetScaleValue(scalePtr, scalePtr->value, 1, 0); + TkEventuallyRedrawScale(scalePtr, REDRAW_SLIDER); + } + + return result; +} diff --git a/generic/tkScale.h b/generic/tkScale.h new file mode 100644 index 0000000..dba6f68 --- /dev/null +++ b/generic/tkScale.h @@ -0,0 +1,225 @@ +/* + * tkScale.h -- + * + * Declarations of types and functions used to implement + * the scale widget. + * + * Copyright (c) 1996 by Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkScale.h 1.5 96/07/08 12:56:56 + */ + +#ifndef _TKSCALE +#define _TKSCALE + +#ifndef _TK +#include "tk.h" +#endif + +/* + * A data structure of the following type is kept for each scale + * widget managed by this file: + */ + +typedef struct TkScale { + Tk_Window tkwin; /* Window that embodies the scale. NULL + * means that the window has been destroyed + * but the data structures haven't yet been + * cleaned up.*/ + Display *display; /* Display containing widget. Used, among + * other things, so that resources can be + * freed even after tkwin has gone away. */ + Tcl_Interp *interp; /* Interpreter associated with scale. */ + Tcl_Command widgetCmd; /* Token for scale's widget command. */ + Tk_Uid orientUid; /* Orientation for window ("vertical" or + * "horizontal"). */ + int vertical; /* Non-zero means vertical orientation, + * zero means horizontal. */ + int width; /* Desired narrow dimension of scale, + * in pixels. */ + int length; /* Desired long dimension of scale, + * in pixels. */ + double value; /* Current value of scale. */ + char *varName; /* Name of variable (malloc'ed) or NULL. + * If non-NULL, scale's value tracks + * the contents of this variable and + * vice versa. */ + double fromValue; /* Value corresponding to left or top of + * scale. */ + double toValue; /* Value corresponding to right or bottom + * of scale. */ + double tickInterval; /* Distance between tick marks; 0 means + * don't display any tick marks. */ + double resolution; /* If > 0, all values are rounded to an + * even multiple of this value. */ + int digits; /* Number of significant digits to print + * in values. 0 means we get to choose the + * number based on resolution and/or the + * range of the scale. */ + char format[10]; /* Sprintf conversion specifier computed from + * digits and other information. */ + double bigIncrement; /* Amount to use for large increments to + * scale value. (0 means we pick a value). */ + char *command; /* Command prefix to use when invoking Tcl + * commands because the scale value changed. + * NULL means don't invoke commands. + * Malloc'ed. */ + int repeatDelay; /* How long to wait before auto-repeating + * on scrolling actions (in ms). */ + int repeatInterval; /* Interval between autorepeats (in ms). */ + char *label; /* Label to display above or to right of + * scale; NULL means don't display a + * label. Malloc'ed. */ + int labelLength; /* Number of non-NULL chars. in label. */ + Tk_Uid state; /* Normal or disabled. Value cannot be + * changed when scale is disabled. */ + + /* + * Information used when displaying widget: + */ + + int borderWidth; /* Width of 3-D border around window. */ + Tk_3DBorder bgBorder; /* Used for drawing slider and other + * background areas. */ + Tk_3DBorder activeBorder; /* For drawing the slider when active. */ + int sliderRelief; /* Is slider to be drawn raised, sunken, etc. */ + XColor *troughColorPtr; /* Color for drawing trough. */ + GC troughGC; /* For drawing trough. */ + GC copyGC; /* Used for copying from pixmap onto screen. */ + Tk_Font tkfont; /* Information about text font, or NULL. */ + XColor *textColorPtr; /* Color for drawing text. */ + GC textGC; /* GC for drawing text in normal mode. */ + int relief; /* Indicates whether window as a whole is + * raised, sunken, or flat. */ + int highlightWidth; /* Width in pixels of highlight to draw + * around widget when it has the focus. + * <= 0 means don't draw a highlight. */ + XColor *highlightBgColorPtr; + /* Color for drawing traversal highlight + * area when highlight is off. */ + XColor *highlightColorPtr; /* 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. */ + int sliderLength; /* Length of slider, measured in pixels along + * long dimension of scale. */ + int showValue; /* Non-zero means to display the scale value + * below or to the left of the slider; zero + * means don't display the value. */ + + /* + * Layout information for horizontal scales, assuming that window + * gets the size it requested: + */ + + int horizLabelY; /* Y-coord at which to draw label. */ + int horizValueY; /* Y-coord at which to draw value text. */ + int horizTroughY; /* Y-coord of top of slider trough. */ + int horizTickY; /* Y-coord at which to draw tick text. */ + /* + * Layout information for vertical scales, assuming that window + * gets the size it requested: + */ + + int vertTickRightX; /* X-location of right side of tick-marks. */ + int vertValueRightX; /* X-location of right side of value string. */ + int vertTroughX; /* X-location of scale's slider trough. */ + int vertLabelX; /* X-location of origin of label. */ + + /* + * Miscellaneous information: + */ + + Tk_Cursor cursor; /* Current cursor for window, or None. */ + char *takeFocus; /* Value of -takefocus option; not used in + * the C code, but used by keyboard traversal + * scripts. Malloc'ed, but may be NULL. */ + int flags; /* Various flags; see below for + * definitions. */ +} TkScale; + +/* + * Flag bits for scales: + * + * REDRAW_SLIDER - 1 means slider (and numerical readout) need + * to be redrawn. + * REDRAW_OTHER - 1 means other stuff besides slider and value + * need to be redrawn. + * REDRAW_ALL - 1 means the entire widget needs to be redrawn. + * ACTIVE - 1 means the widget is active (the mouse is + * in its window). + * INVOKE_COMMAND - 1 means the scale's command needs to be + * invoked during the next redisplay (the + * value of the scale has changed since the + * last time the command was invoked). + * SETTING_VAR - 1 means that the associated variable is + * being set by us, so there's no need for + * ScaleVarProc to do anything. + * NEVER_SET - 1 means that the scale's value has never + * been set before (so must invoke -command and + * set associated variable even if the value + * doesn't appear to have changed). + * GOT_FOCUS - 1 means that the focus is currently in + * this widget. + */ + +#define REDRAW_SLIDER 1 +#define REDRAW_OTHER 2 +#define REDRAW_ALL 3 +#define ACTIVE 4 +#define INVOKE_COMMAND 0x10 +#define SETTING_VAR 0x20 +#define NEVER_SET 0x40 +#define GOT_FOCUS 0x80 + +/* + * Symbolic values for the active parts of a slider. These are + * the values that may be returned by the ScaleElement procedure. + */ + +#define OTHER 0 +#define TROUGH1 1 +#define SLIDER 2 +#define TROUGH2 3 + +/* + * Space to leave between scale area and text, and between text and + * edge of window. + */ + +#define SPACING 2 + +/* + * How many characters of space to provide when formatting the + * scale's value: + */ + +#define PRINT_CHARS 150 + +/* + * Declaration of procedures used in the implementation of the scrollbar + * widget. + */ + +EXTERN void TkEventuallyRedrawScale _ANSI_ARGS_((TkScale *scalePtr, + int what)); +EXTERN double TkRoundToResolution _ANSI_ARGS_((TkScale *scalePtr, + double value)); +EXTERN TkScale * TkpCreateScale _ANSI_ARGS_((Tk_Window tkwin)); +EXTERN void TkpDestroyScale _ANSI_ARGS_((TkScale *scalePtr)); +EXTERN void TkpDisplayScale _ANSI_ARGS_((ClientData clientData)); +EXTERN double TkpPixelToValue _ANSI_ARGS_((TkScale *scalePtr, + int x, int y)); +EXTERN int TkpScaleElement _ANSI_ARGS_((TkScale *scalePtr, + int x, int y)); +EXTERN void TkpSetScaleValue _ANSI_ARGS_((TkScale *scalePtr, + double value, int setVar, int invokeCommand)); +EXTERN int TkpValueToPixel _ANSI_ARGS_((TkScale *scalePtr, + double value)); + +#endif /* _TKSCALE */ diff --git a/generic/tkScrollbar.c b/generic/tkScrollbar.c new file mode 100644 index 0000000..3025a78 --- /dev/null +++ b/generic/tkScrollbar.c @@ -0,0 +1,691 @@ +/* + * tkScrollbar.c -- + * + * This module implements a scrollbar widgets for the Tk + * toolkit. A scrollbar displays a slider and two arrows; + * mouse clicks on features within the scrollbar cause + * scrolling commands to be invoked. + * + * 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: @(#) tkScrollbar.c 1.94 97/07/31 09:12:44 + */ + +#include "tkPort.h" +#include "tkScrollbar.h" +#include "default.h" + +/* + * Information used for argv parsing. + */ + +Tk_ConfigSpec tkpScrollbarConfigSpecs[] = { + {TK_CONFIG_BORDER, "-activebackground", "activeBackground", "Foreground", + DEF_SCROLLBAR_ACTIVE_BG_COLOR, Tk_Offset(TkScrollbar, activeBorder), + TK_CONFIG_COLOR_ONLY}, + {TK_CONFIG_BORDER, "-activebackground", "activeBackground", "Foreground", + DEF_SCROLLBAR_ACTIVE_BG_MONO, Tk_Offset(TkScrollbar, activeBorder), + TK_CONFIG_MONO_ONLY}, + {TK_CONFIG_RELIEF, "-activerelief", "activeRelief", "Relief", + DEF_SCROLLBAR_ACTIVE_RELIEF, Tk_Offset(TkScrollbar, activeRelief), 0}, + {TK_CONFIG_BORDER, "-background", "background", "Background", + DEF_SCROLLBAR_BG_COLOR, Tk_Offset(TkScrollbar, bgBorder), + TK_CONFIG_COLOR_ONLY}, + {TK_CONFIG_BORDER, "-background", "background", "Background", + DEF_SCROLLBAR_BG_MONO, Tk_Offset(TkScrollbar, 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", + DEF_SCROLLBAR_BORDER_WIDTH, Tk_Offset(TkScrollbar, borderWidth), 0}, + {TK_CONFIG_STRING, "-command", "command", "Command", + DEF_SCROLLBAR_COMMAND, Tk_Offset(TkScrollbar, command), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_ACTIVE_CURSOR, "-cursor", "cursor", "Cursor", + DEF_SCROLLBAR_CURSOR, Tk_Offset(TkScrollbar, cursor), TK_CONFIG_NULL_OK}, + {TK_CONFIG_PIXELS, "-elementborderwidth", "elementBorderWidth", + "BorderWidth", DEF_SCROLLBAR_EL_BORDER_WIDTH, + Tk_Offset(TkScrollbar, elementBorderWidth), 0}, + {TK_CONFIG_COLOR, "-highlightbackground", "highlightBackground", + "HighlightBackground", DEF_SCROLLBAR_HIGHLIGHT_BG, + Tk_Offset(TkScrollbar, highlightBgColorPtr), 0}, + {TK_CONFIG_COLOR, "-highlightcolor", "highlightColor", "HighlightColor", + DEF_SCROLLBAR_HIGHLIGHT, + Tk_Offset(TkScrollbar, highlightColorPtr), 0}, + {TK_CONFIG_PIXELS, "-highlightthickness", "highlightThickness", + "HighlightThickness", + DEF_SCROLLBAR_HIGHLIGHT_WIDTH, Tk_Offset(TkScrollbar, highlightWidth), 0}, + {TK_CONFIG_BOOLEAN, "-jump", "jump", "Jump", + DEF_SCROLLBAR_JUMP, Tk_Offset(TkScrollbar, jump), 0}, + {TK_CONFIG_UID, "-orient", "orient", "Orient", + DEF_SCROLLBAR_ORIENT, Tk_Offset(TkScrollbar, orientUid), 0}, + {TK_CONFIG_RELIEF, "-relief", "relief", "Relief", + DEF_SCROLLBAR_RELIEF, Tk_Offset(TkScrollbar, relief), 0}, + {TK_CONFIG_INT, "-repeatdelay", "repeatDelay", "RepeatDelay", + DEF_SCROLLBAR_REPEAT_DELAY, Tk_Offset(TkScrollbar, repeatDelay), 0}, + {TK_CONFIG_INT, "-repeatinterval", "repeatInterval", "RepeatInterval", + DEF_SCROLLBAR_REPEAT_INTERVAL, Tk_Offset(TkScrollbar, repeatInterval), 0}, + {TK_CONFIG_STRING, "-takefocus", "takeFocus", "TakeFocus", + DEF_SCROLLBAR_TAKE_FOCUS, Tk_Offset(TkScrollbar, takeFocus), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_COLOR, "-troughcolor", "troughColor", "Background", + DEF_SCROLLBAR_TROUGH_COLOR, Tk_Offset(TkScrollbar, troughColorPtr), + TK_CONFIG_COLOR_ONLY}, + {TK_CONFIG_COLOR, "-troughcolor", "troughColor", "Background", + DEF_SCROLLBAR_TROUGH_MONO, Tk_Offset(TkScrollbar, troughColorPtr), + TK_CONFIG_MONO_ONLY}, + {TK_CONFIG_PIXELS, "-width", "width", "Width", + DEF_SCROLLBAR_WIDTH, Tk_Offset(TkScrollbar, width), 0}, + {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, 0} +}; + +/* + * Forward declarations for procedures defined later in this file: + */ + +static int ConfigureScrollbar _ANSI_ARGS_((Tcl_Interp *interp, + TkScrollbar *scrollPtr, int argc, char **argv, + int flags)); +static void ScrollbarCmdDeletedProc _ANSI_ARGS_(( + ClientData clientData)); +static int ScrollbarWidgetCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *, int argc, char **argv)); + +/* + *-------------------------------------------------------------- + * + * Tk_ScrollbarCmd -- + * + * This procedure is invoked to process the "scrollbar" 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_ScrollbarCmd(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; + register TkScrollbar *scrollPtr; + Tk_Window new; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " pathName ?options?\"", (char *) NULL); + return TCL_ERROR; + } + + new = Tk_CreateWindowFromPath(interp, tkwin, argv[1], (char *) NULL); + if (new == NULL) { + return TCL_ERROR; + } + + Tk_SetClass(new, "Scrollbar"); + scrollPtr = TkpCreateScrollbar(new); + + TkSetClassProcs(new, &tkpScrollbarProcs, (ClientData) scrollPtr); + + /* + * Initialize fields that won't be initialized by ConfigureScrollbar, + * or which ConfigureScrollbar expects to have reasonable values + * (e.g. resource pointers). + */ + + scrollPtr->tkwin = new; + scrollPtr->display = Tk_Display(new); + scrollPtr->interp = interp; + scrollPtr->widgetCmd = Tcl_CreateCommand(interp, + Tk_PathName(scrollPtr->tkwin), ScrollbarWidgetCmd, + (ClientData) scrollPtr, ScrollbarCmdDeletedProc); + scrollPtr->orientUid = NULL; + scrollPtr->vertical = 0; + scrollPtr->width = 0; + scrollPtr->command = NULL; + scrollPtr->commandSize = 0; + scrollPtr->repeatDelay = 0; + scrollPtr->repeatInterval = 0; + scrollPtr->borderWidth = 0; + scrollPtr->bgBorder = NULL; + scrollPtr->activeBorder = NULL; + scrollPtr->troughColorPtr = NULL; + scrollPtr->relief = TK_RELIEF_FLAT; + scrollPtr->highlightWidth = 0; + scrollPtr->highlightBgColorPtr = NULL; + scrollPtr->highlightColorPtr = NULL; + scrollPtr->inset = 0; + scrollPtr->elementBorderWidth = -1; + scrollPtr->arrowLength = 0; + scrollPtr->sliderFirst = 0; + scrollPtr->sliderLast = 0; + scrollPtr->activeField = 0; + scrollPtr->activeRelief = TK_RELIEF_RAISED; + scrollPtr->totalUnits = 0; + scrollPtr->windowUnits = 0; + scrollPtr->firstUnit = 0; + scrollPtr->lastUnit = 0; + scrollPtr->firstFraction = 0.0; + scrollPtr->lastFraction = 0.0; + scrollPtr->cursor = None; + scrollPtr->takeFocus = NULL; + scrollPtr->flags = 0; + + if (ConfigureScrollbar(interp, scrollPtr, argc-2, argv+2, 0) != TCL_OK) { + Tk_DestroyWindow(scrollPtr->tkwin); + return TCL_ERROR; + } + + interp->result = Tk_PathName(scrollPtr->tkwin); + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * ScrollbarWidgetCmd -- + * + * This procedure is invoked to process the Tcl command + * that corresponds to a widget managed by this module. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +static int +ScrollbarWidgetCmd(clientData, interp, argc, argv) + ClientData clientData; /* Information about scrollbar + * widget. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + register TkScrollbar *scrollPtr = (TkScrollbar *) clientData; + int result = TCL_OK; + size_t length; + int c; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " option ?arg arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_Preserve((ClientData) scrollPtr); + c = argv[1][0]; + length = strlen(argv[1]); + if ((c == 'a') && (strncmp(argv[1], "activate", length) == 0)) { + 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; + } + goto done; + } + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " activate element\"", (char *) NULL); + goto error; + } + c = argv[2][0]; + length = strlen(argv[2]); + oldActiveField = scrollPtr->activeField; + if ((c == 'a') && (strcmp(argv[2], "arrow1") == 0)) { + scrollPtr->activeField = TOP_ARROW; + } else if ((c == 'a') && (strcmp(argv[2], "arrow2") == 0)) { + scrollPtr->activeField = BOTTOM_ARROW; + } else if ((c == 's') && (strncmp(argv[2], "slider", length) == 0)) { + scrollPtr->activeField = SLIDER; + } else { + scrollPtr->activeField = OUTSIDE; + } + if (oldActiveField != scrollPtr->activeField) { + TkScrollbarEventuallyRedraw(scrollPtr); + } + } 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; + } + result = Tk_ConfigureValue(interp, scrollPtr->tkwin, + tkpScrollbarConfigSpecs, (char *) scrollPtr, argv[2], 0); + } else if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0) + && (length >= 2)) { + if (argc == 2) { + result = Tk_ConfigureInfo(interp, scrollPtr->tkwin, + tkpScrollbarConfigSpecs, (char *) scrollPtr, + (char *) NULL, 0); + } else if (argc == 3) { + result = Tk_ConfigureInfo(interp, scrollPtr->tkwin, + tkpScrollbarConfigSpecs, (char *) scrollPtr, argv[2], 0); + } else { + result = ConfigureScrollbar(interp, scrollPtr, argc-2, argv+2, + TK_CONFIG_ARGV_ONLY); + } + } else if ((c == 'd') && (strncmp(argv[1], "delta", length) == 0)) { + int xDelta, yDelta, pixels, length; + double fraction; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " delta xDelta yDelta\"", (char *) NULL); + goto error; + } + if ((Tcl_GetInt(interp, argv[2], &xDelta) != TCL_OK) + || (Tcl_GetInt(interp, argv[3], &yDelta) != TCL_OK)) { + goto error; + } + if (scrollPtr->vertical) { + pixels = yDelta; + length = Tk_Height(scrollPtr->tkwin) - 1 + - 2*(scrollPtr->arrowLength + scrollPtr->inset); + } else { + pixels = xDelta; + length = Tk_Width(scrollPtr->tkwin) - 1 + - 2*(scrollPtr->arrowLength + scrollPtr->inset); + } + if (length == 0) { + fraction = 0.0; + } else { + fraction = ((double) pixels / (double) length); + } + sprintf(interp->result, "%g", fraction); + } else if ((c == 'f') && (strncmp(argv[1], "fraction", length) == 0)) { + int x, y, pos, length; + double fraction; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " fraction 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 (scrollPtr->vertical) { + pos = y - (scrollPtr->arrowLength + scrollPtr->inset); + length = Tk_Height(scrollPtr->tkwin) - 1 + - 2*(scrollPtr->arrowLength + scrollPtr->inset); + } else { + pos = x - (scrollPtr->arrowLength + scrollPtr->inset); + length = Tk_Width(scrollPtr->tkwin) - 1 + - 2*(scrollPtr->arrowLength + scrollPtr->inset); + } + if (length == 0) { + fraction = 0.0; + } else { + fraction = ((double) pos / (double) length); + } + if (fraction < 0) { + fraction = 0; + } else if (fraction > 1.0) { + fraction = 1.0; + } + sprintf(interp->result, "%g", fraction); + } else if ((c == 'g') && (strncmp(argv[1], "get", length) == 0)) { + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " get\"", (char *) NULL); + goto error; + } + if (scrollPtr->flags & NEW_STYLE_COMMANDS) { + char first[TCL_DOUBLE_SPACE], last[TCL_DOUBLE_SPACE]; + + Tcl_PrintDouble(interp, scrollPtr->firstFraction, first); + Tcl_PrintDouble(interp, scrollPtr->lastFraction, last); + Tcl_AppendResult(interp, first, " ", last, (char *) NULL); + } else { + sprintf(interp->result, "%d %d %d %d", scrollPtr->totalUnits, + scrollPtr->windowUnits, scrollPtr->firstUnit, + scrollPtr->lastUnit); + } + } else if ((c == 'i') && (strncmp(argv[1], "identify", length) == 0)) { + int x, y, thing; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " identify 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; + } + 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; + } + } else if ((c == 's') && (strncmp(argv[1], "set", length) == 0)) { + int totalUnits, windowUnits, firstUnit, lastUnit; + + if (argc == 4) { + double first, last; + + if (Tcl_GetDouble(interp, argv[2], &first) != TCL_OK) { + goto error; + } + if (Tcl_GetDouble(interp, argv[3], &last) != TCL_OK) { + goto error; + } + if (first < 0) { + scrollPtr->firstFraction = 0; + } else if (first > 1.0) { + scrollPtr->firstFraction = 1.0; + } else { + scrollPtr->firstFraction = first; + } + if (last < scrollPtr->firstFraction) { + scrollPtr->lastFraction = scrollPtr->firstFraction; + } else if (last > 1.0) { + scrollPtr->lastFraction = 1.0; + } else { + scrollPtr->lastFraction = last; + } + scrollPtr->flags |= NEW_STYLE_COMMANDS; + } else if (argc == 6) { + if (Tcl_GetInt(interp, argv[2], &totalUnits) != TCL_OK) { + goto error; + } + if (totalUnits < 0) { + totalUnits = 0; + } + if (Tcl_GetInt(interp, argv[3], &windowUnits) != TCL_OK) { + goto error; + } + if (windowUnits < 0) { + windowUnits = 0; + } + if (Tcl_GetInt(interp, argv[4], &firstUnit) != TCL_OK) { + goto error; + } + if (Tcl_GetInt(interp, argv[5], &lastUnit) != TCL_OK) { + goto error; + } + if (totalUnits > 0) { + if (lastUnit < firstUnit) { + lastUnit = firstUnit; + } + } else { + firstUnit = lastUnit = 0; + } + scrollPtr->totalUnits = totalUnits; + scrollPtr->windowUnits = windowUnits; + scrollPtr->firstUnit = firstUnit; + scrollPtr->lastUnit = lastUnit; + if (scrollPtr->totalUnits == 0) { + scrollPtr->firstFraction = 0.0; + scrollPtr->lastFraction = 1.0; + } else { + scrollPtr->firstFraction = ((double) firstUnit)/totalUnits; + scrollPtr->lastFraction = ((double) (lastUnit+1))/totalUnits; + } + scrollPtr->flags &= ~NEW_STYLE_COMMANDS; + } else { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " set firstFraction lastFraction\" or \"", + argv[0], + " set totalUnits windowUnits firstUnit lastUnit\"", + (char *) NULL); + goto error; + } + TkpComputeScrollbarGeometry(scrollPtr); + TkScrollbarEventuallyRedraw(scrollPtr); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be activate, cget, configure, delta, fraction, ", + "get, identify, or set", (char *) NULL); + goto error; + } + done: + Tcl_Release((ClientData) scrollPtr); + return result; + + error: + Tcl_Release((ClientData) scrollPtr); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * ConfigureScrollbar -- + * + * This procedure is called to process an argv/argc list, plus + * the Tk option database, in order to configure (or + * reconfigure) a scrollbar widget. + * + * Results: + * The return value is a standard Tcl result. If TCL_ERROR is + * returned, then interp->result contains an error message. + * + * Side effects: + * Configuration information, such as colors, border width, + * etc. get set for scrollPtr; old resources get freed, + * if there were any. + * + *---------------------------------------------------------------------- + */ + +static int +ConfigureScrollbar(interp, scrollPtr, argc, argv, flags) + Tcl_Interp *interp; /* Used for error reporting. */ + register TkScrollbar *scrollPtr; /* 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. */ +{ + size_t length; + + if (Tk_ConfigureWidget(interp, scrollPtr->tkwin, tkpScrollbarConfigSpecs, + argc, argv, (char *) scrollPtr, flags) != TCL_OK) { + return TCL_ERROR; + } + + /* + * A few options need special processing, such as parsing the + * orientation or setting the background from a 3-D border. + */ + + length = strlen(scrollPtr->orientUid); + if (strncmp(scrollPtr->orientUid, "vertical", length) == 0) { + scrollPtr->vertical = 1; + } else if (strncmp(scrollPtr->orientUid, "horizontal", length) == 0) { + scrollPtr->vertical = 0; + } else { + Tcl_AppendResult(interp, "bad orientation \"", scrollPtr->orientUid, + "\": must be vertical or horizontal", (char *) NULL); + return TCL_ERROR; + } + + if (scrollPtr->command != NULL) { + scrollPtr->commandSize = strlen(scrollPtr->command); + } else { + scrollPtr->commandSize = 0; + } + + /* + * Configure platform specific options. + */ + + TkpConfigureScrollbar(scrollPtr); + + /* + * Register the desired geometry for the window (leave enough space + * for the two arrows plus a minimum-size slider, plus border around + * the whole window, if any). Then arrange for the window to be + * redisplayed. + */ + + TkpComputeScrollbarGeometry(scrollPtr); + TkScrollbarEventuallyRedraw(scrollPtr); + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * TkScrollbarEventProc -- + * + * This procedure is invoked by the Tk dispatcher for various + * events on scrollbars. + * + * Results: + * None. + * + * Side effects: + * When the window gets deleted, internal structures get + * cleaned up. When it gets exposed, it is redisplayed. + * + *-------------------------------------------------------------- + */ + +void +TkScrollbarEventProc(clientData, eventPtr) + ClientData clientData; /* Information about window. */ + XEvent *eventPtr; /* Information about event. */ +{ + TkScrollbar *scrollPtr = (TkScrollbar *) clientData; + + if ((eventPtr->type == Expose) && (eventPtr->xexpose.count == 0)) { + TkScrollbarEventuallyRedraw(scrollPtr); + } else if (eventPtr->type == DestroyNotify) { + TkpDestroyScrollbar(scrollPtr); + if (scrollPtr->tkwin != NULL) { + scrollPtr->tkwin = NULL; + Tcl_DeleteCommandFromToken(scrollPtr->interp, + scrollPtr->widgetCmd); + } + if (scrollPtr->flags & REDRAW_PENDING) { + Tcl_CancelIdleCall(TkpDisplayScrollbar, (ClientData) scrollPtr); + } + /* + * Free up all the stuff that requires special handling, then + * let Tk_FreeOptions handle all the standard option-related + * stuff. + */ + + Tk_FreeOptions(tkpScrollbarConfigSpecs, (char *) scrollPtr, + scrollPtr->display, 0); + Tcl_EventuallyFree((ClientData) scrollPtr, TCL_DYNAMIC); + } else if (eventPtr->type == ConfigureNotify) { + TkpComputeScrollbarGeometry(scrollPtr); + TkScrollbarEventuallyRedraw(scrollPtr); + } else if (eventPtr->type == FocusIn) { + if (eventPtr->xfocus.detail != NotifyInferior) { + scrollPtr->flags |= GOT_FOCUS; + if (scrollPtr->highlightWidth > 0) { + TkScrollbarEventuallyRedraw(scrollPtr); + } + } + } else if (eventPtr->type == FocusOut) { + if (eventPtr->xfocus.detail != NotifyInferior) { + scrollPtr->flags &= ~GOT_FOCUS; + if (scrollPtr->highlightWidth > 0) { + TkScrollbarEventuallyRedraw(scrollPtr); + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * ScrollbarCmdDeletedProc -- + * + * 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 +ScrollbarCmdDeletedProc(clientData) + ClientData clientData; /* Pointer to widget record for widget. */ +{ + TkScrollbar *scrollPtr = (TkScrollbar *) clientData; + Tk_Window tkwin = scrollPtr->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. + */ + + if (tkwin != NULL) { + scrollPtr->tkwin = NULL; + Tk_DestroyWindow(tkwin); + } +} + +/* + *-------------------------------------------------------------- + * + * TkScrollbarEventuallyRedraw -- + * + * Arrange for one or more of the fields of a scrollbar + * to be redrawn. + * + * Results: + * None. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +void +TkScrollbarEventuallyRedraw(scrollPtr) + register TkScrollbar *scrollPtr; /* Information about widget. */ +{ + if ((scrollPtr->tkwin == NULL) || (!Tk_IsMapped(scrollPtr->tkwin))) { + return; + } + if ((scrollPtr->flags & REDRAW_PENDING) == 0) { + Tcl_DoWhenIdle(TkpDisplayScrollbar, (ClientData) scrollPtr); + scrollPtr->flags |= REDRAW_PENDING; + } +} diff --git a/generic/tkScrollbar.h b/generic/tkScrollbar.h new file mode 100644 index 0000000..48296a2 --- /dev/null +++ b/generic/tkScrollbar.h @@ -0,0 +1,200 @@ +/* + * tkScrollbar.h -- + * + * Declarations of types and functions used to implement + * the scrollbar widget. + * + * Copyright (c) 1996 by Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkScrollbar.h 1.8 96/11/05 11:34:58 + */ + +#ifndef _TKSCROLLBAR +#define _TKSCROLLBAR + +#ifndef _TKINT +#include "tkInt.h" +#endif + +/* + * A data structure of the following type is kept for each scrollbar + * widget. + */ + +typedef struct TkScrollbar { + Tk_Window tkwin; /* Window that embodies the scrollbar. NULL + * means that the window has been destroyed + * but the data structures haven't yet been + * cleaned up.*/ + Display *display; /* Display containing widget. Used, among + * other things, so that resources can be + * freed even after tkwin has gone away. */ + Tcl_Interp *interp; /* Interpreter associated with scrollbar. */ + Tcl_Command widgetCmd; /* Token for scrollbar's widget command. */ + Tk_Uid orientUid; /* Orientation for window ("vertical" or + * "horizontal"). */ + int vertical; /* Non-zero means vertical orientation + * requested, zero means horizontal. */ + int width; /* Desired narrow dimension of scrollbar, + * in pixels. */ + char *command; /* Command prefix to use when invoking + * scrolling commands. NULL means don't + * invoke commands. Malloc'ed. */ + int commandSize; /* Number of non-NULL bytes in command. */ + int repeatDelay; /* How long to wait before auto-repeating + * on scrolling actions (in ms). */ + int repeatInterval; /* Interval between autorepeats (in ms). */ + int jump; /* Value of -jump option. */ + + /* + * Information used when displaying widget: + */ + + int borderWidth; /* Width of 3-D borders. */ + Tk_3DBorder bgBorder; /* Used for drawing background (all flat + * surfaces except for trough). */ + Tk_3DBorder activeBorder; /* For drawing backgrounds when active (i.e. + * when mouse is positioned over element). */ + XColor *troughColorPtr; /* Color for drawing trough. */ + int relief; /* Indicates whether window as a whole is + * raised, sunken, or flat. */ + int highlightWidth; /* Width in pixels of highlight to draw + * around widget when it has the focus. + * <= 0 means don't draw a highlight. */ + XColor *highlightBgColorPtr; + /* Color for drawing traversal highlight + * area when highlight is off. */ + XColor *highlightColorPtr; /* 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. */ + int elementBorderWidth; /* Width of border to draw around elements + * inside scrollbar (arrows and slider). + * -1 means use borderWidth. */ + int arrowLength; /* Length of arrows along long dimension of + * scrollbar, including space for a small gap + * between the arrow and the slider. + * Recomputed on window size changes. */ + int sliderFirst; /* Pixel coordinate of top or left edge + * of slider area, including border. */ + int sliderLast; /* Coordinate of pixel just after bottom + * or right edge of slider area, including + * border. */ + int activeField; /* Names field to be displayed in active + * colors, such as TOP_ARROW, or 0 for + * no field. */ + int activeRelief; /* Value of -activeRelief option: relief + * to use for active element. */ + + /* + * Information describing the application related to the scrollbar. + * This information is provided by the application by invoking the + * "set" widget command. This information can now be provided in + * two ways: the "old" form (totalUnits, windowUnits, firstUnit, + * and lastUnit), or the "new" form (firstFraction and lastFraction). + * FirstFraction and lastFraction will always be valid, but + * the old-style information is only valid if the NEW_STYLE_COMMANDS + * flag is 0. + */ + + int totalUnits; /* Total dimension of application, in + * units. Valid only if the NEW_STYLE_COMMANDS + * flag isn't set. */ + int windowUnits; /* Maximum number of units that can be + * displayed in the window at once. Valid + * only if the NEW_STYLE_COMMANDS flag isn't + * set. */ + int firstUnit; /* Number of last unit visible in + * application's window. Valid only if the + * NEW_STYLE_COMMANDS flag isn't set. */ + int lastUnit; /* Index of last unit visible in window. + * Valid only if the NEW_STYLE_COMMANDS + * flag isn't set. */ + double firstFraction; /* Position of first visible thing in window, + * specified as a fraction between 0 and + * 1.0. */ + double lastFraction; /* Position of last visible thing in window, + * specified as a fraction between 0 and + * 1.0. */ + + /* + * Miscellaneous information: + */ + + Tk_Cursor cursor; /* Current cursor for window, or None. */ + char *takeFocus; /* Value of -takefocus option; not used in + * the C code, but used by keyboard traversal + * scripts. Malloc'ed, but may be NULL. */ + int flags; /* Various flags; see below for + * definitions. */ +} TkScrollbar; + +/* + * Legal values for "activeField" field of Scrollbar structures. These + * are also the return values from the ScrollbarPosition procedure. + */ + +#define OUTSIDE 0 +#define TOP_ARROW 1 +#define TOP_GAP 2 +#define SLIDER 3 +#define BOTTOM_GAP 4 +#define BOTTOM_ARROW 5 + +/* + * Flag bits for scrollbars: + * + * REDRAW_PENDING: Non-zero means a DoWhenIdle handler + * has already been queued to redraw + * this window. + * NEW_STYLE_COMMANDS: Non-zero means the new style of commands + * should be used to communicate with the + * widget: ".t yview scroll 2 lines", instead + * of ".t yview 40", for example. + * GOT_FOCUS: Non-zero means this window has the input + * focus. + */ + +#define REDRAW_PENDING 1 +#define NEW_STYLE_COMMANDS 2 +#define GOT_FOCUS 4 + +/* + * Declaration of scrollbar class procedures structure. + */ + +extern TkClassProcs tkpScrollbarProcs; + +/* + * Declaration of scrollbar configuration options. + */ + +extern Tk_ConfigSpec tkpScrollbarConfigSpecs[]; + +/* + * Declaration of procedures used in the implementation of the scrollbar + * widget. + */ + +EXTERN void TkScrollbarEventProc _ANSI_ARGS_(( + ClientData clientData, XEvent *eventPtr)); +EXTERN void TkScrollbarEventuallyRedraw _ANSI_ARGS_(( + TkScrollbar *scrollPtr)); +EXTERN void TkpComputeScrollbarGeometry _ANSI_ARGS_(( + TkScrollbar *scrollPtr)); +EXTERN TkScrollbar * TkpCreateScrollbar _ANSI_ARGS_((Tk_Window tkwin)); +EXTERN void TkpDestroyScrollbar _ANSI_ARGS_(( + TkScrollbar *scrollPtr)); +EXTERN void TkpDisplayScrollbar _ANSI_ARGS_(( + ClientData clientData)); +EXTERN void TkpConfigureScrollbar _ANSI_ARGS_(( + TkScrollbar *scrollPtr)); +EXTERN int TkpScrollbarPosition _ANSI_ARGS_(( + TkScrollbar *scrollPtr, int x, int y)); + +#endif /* _TKSCROLLBAR */ diff --git a/generic/tkSelect.c b/generic/tkSelect.c new file mode 100644 index 0000000..7263e30 --- /dev/null +++ b/generic/tkSelect.c @@ -0,0 +1,1341 @@ +/* + * tkSelect.c -- + * + * This file manages the selection for the Tk toolkit, + * translating between the standard X ICCCM conventions + * and Tcl commands. + * + * Copyright (c) 1990-1993 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkSelect.c 1.57 96/05/03 10:52:40 + */ + +#include "tkInt.h" +#include "tkSelect.h" + +/* + * When a selection handler is set up by invoking "selection handle", + * one of the following data structures is set up to hold information + * about the command to invoke and its interpreter. + */ + +typedef struct { + Tcl_Interp *interp; /* Interpreter in which to invoke command. */ + int cmdLength; /* # of non-NULL bytes in command. */ + char command[4]; /* Command to invoke. Actual space is + * allocated as large as necessary. This + * must be the last entry in the structure. */ +} CommandInfo; + +/* + * When selection ownership is claimed with the "selection own" Tcl command, + * one of the following structures is created to record the Tcl command + * to be executed when the selection is lost again. + */ + +typedef struct LostCommand { + Tcl_Interp *interp; /* Interpreter in which to invoke command. */ + char command[4]; /* Command to invoke. Actual space is + * allocated as large as necessary. This + * must be the last entry in the structure. */ +} LostCommand; + +/* + * Shared variables: + */ + +TkSelInProgress *pendingPtr = NULL; + /* Topmost search in progress, or + * NULL if none. */ + +/* + * Forward declarations for procedures defined in this file: + */ + +static int HandleTclCommand _ANSI_ARGS_((ClientData clientData, + int offset, char *buffer, int maxBytes)); +static void LostSelection _ANSI_ARGS_((ClientData clientData)); +static int SelGetProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, char *portion)); + +/* + *-------------------------------------------------------------- + * + * Tk_CreateSelHandler -- + * + * This procedure is called to register a procedure + * as the handler for selection requests of a particular + * target type on a particular window for a particular + * selection. + * + * Results: + * None. + * + * Side effects: + * In the future, whenever the selection is in tkwin's + * window and someone requests the selection in the + * form given by target, proc will be invoked to provide + * part or all of the selection in the given form. If + * there was already a handler declared for the given + * window, target and selection type, then it is replaced. + * Proc should have the following form: + * + * int + * proc(clientData, offset, buffer, maxBytes) + * ClientData clientData; + * int offset; + * char *buffer; + * int maxBytes; + * { + * } + * + * The clientData argument to proc will be the same as + * the clientData argument to this procedure. The offset + * argument indicates which portion of the selection to + * return: skip the first offset bytes. Buffer is a + * pointer to an area in which to place the converted + * selection, and maxBytes gives the number of bytes + * available at buffer. Proc should place the selection + * in buffer as a string, and return a count of the number + * of bytes of selection actually placed in buffer (not + * including the terminating NULL character). If the + * return value equals maxBytes, this is a sign that there + * is probably still more selection information available. + * + *-------------------------------------------------------------- + */ + +void +Tk_CreateSelHandler(tkwin, selection, target, proc, clientData, format) + Tk_Window tkwin; /* Token for window. */ + Atom selection; /* Selection to be handled. */ + Atom target; /* The kind of selection conversions + * that can be handled by proc, + * e.g. TARGETS or STRING. */ + Tk_SelectionProc *proc; /* Procedure to invoke to convert + * selection to type "target". */ + ClientData clientData; /* Value to pass to proc. */ + Atom format; /* Format in which the selection + * information should be returned to + * the requestor. XA_STRING is best by + * far, but anything listed in the ICCCM + * will be tolerated (blech). */ +{ + register TkSelHandler *selPtr; + TkWindow *winPtr = (TkWindow *) tkwin; + + if (winPtr->dispPtr->multipleAtom == None) { + TkSelInit(tkwin); + } + + /* + * See if there's already a handler for this target and selection on + * this window. If so, re-use it. If not, create a new one. + */ + + for (selPtr = winPtr->selHandlerList; ; selPtr = selPtr->nextPtr) { + if (selPtr == NULL) { + selPtr = (TkSelHandler *) ckalloc(sizeof(TkSelHandler)); + selPtr->nextPtr = winPtr->selHandlerList; + winPtr->selHandlerList = selPtr; + break; + } + if ((selPtr->selection == selection) && (selPtr->target == target)) { + + /* + * Special case: when replacing handler created by + * "selection handle", free up memory. Should there be a + * callback to allow other clients to do this too? + */ + + if (selPtr->proc == HandleTclCommand) { + ckfree((char *) selPtr->clientData); + } + break; + } + } + selPtr->selection = selection; + selPtr->target = target; + selPtr->format = format; + selPtr->proc = proc; + selPtr->clientData = clientData; + if (format == XA_STRING) { + selPtr->size = 8; + } else { + selPtr->size = 32; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tk_DeleteSelHandler -- + * + * Remove the selection handler for a given window, target, and + * selection, if it exists. + * + * Results: + * None. + * + * Side effects: + * The selection handler for tkwin and target is removed. If there + * is no such handler then nothing happens. + * + *---------------------------------------------------------------------- + */ + +void +Tk_DeleteSelHandler(tkwin, selection, target) + Tk_Window tkwin; /* Token for window. */ + Atom selection; /* The selection whose handler + * is to be removed. */ + Atom target; /* The target whose selection + * handler is to be removed. */ +{ + TkWindow *winPtr = (TkWindow *) tkwin; + register TkSelHandler *selPtr, *prevPtr; + register TkSelInProgress *ipPtr; + + /* + * Find the selection handler to be deleted, or return if it doesn't + * exist. + */ + + for (selPtr = winPtr->selHandlerList, prevPtr = NULL; ; + prevPtr = selPtr, selPtr = selPtr->nextPtr) { + if (selPtr == NULL) { + return; + } + if ((selPtr->selection == selection) && (selPtr->target == target)) { + break; + } + } + + /* + * If ConvertSelection is processing this handler, tell it that the + * handler is dead. + */ + + for (ipPtr = pendingPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { + if (ipPtr->selPtr == selPtr) { + ipPtr->selPtr = NULL; + } + } + + /* + * Free resources associated with the handler. + */ + + if (prevPtr == NULL) { + winPtr->selHandlerList = selPtr->nextPtr; + } else { + prevPtr->nextPtr = selPtr->nextPtr; + } + if (selPtr->proc == HandleTclCommand) { + ckfree((char *) selPtr->clientData); + } + ckfree((char *) selPtr); +} + +/* + *-------------------------------------------------------------- + * + * Tk_OwnSelection -- + * + * Arrange for tkwin to become the owner of a selection. + * + * Results: + * None. + * + * Side effects: + * From now on, requests for the selection will be directed + * to procedures associated with tkwin (they must have been + * declared with calls to Tk_CreateSelHandler). When the + * selection is lost by this window, proc will be invoked + * (see the manual entry for details). This procedure may + * invoke callbacks, including Tcl scripts, so any calling + * function should be reentrant at the point where + * Tk_OwnSelection is invoked. + * + *-------------------------------------------------------------- + */ + +void +Tk_OwnSelection(tkwin, selection, proc, clientData) + Tk_Window tkwin; /* Window to become new selection + * owner. */ + Atom selection; /* Selection that window should own. */ + Tk_LostSelProc *proc; /* Procedure to call when selection + * is taken away from tkwin. */ + ClientData clientData; /* Arbitrary one-word argument to + * pass to proc. */ +{ + register TkWindow *winPtr = (TkWindow *) tkwin; + TkDisplay *dispPtr = winPtr->dispPtr; + TkSelectionInfo *infoPtr; + Tk_LostSelProc *clearProc = NULL; + ClientData clearData = NULL; /* Initialization needed only to + * prevent compiler warning. */ + + + if (dispPtr->multipleAtom == None) { + TkSelInit(tkwin); + } + Tk_MakeWindowExist(tkwin); + + /* + * This code is somewhat tricky. First, we find the specified selection + * on the selection list. If the previous owner is in this process, and + * is a different window, then we need to invoke the clearProc. However, + * it's dangerous to call the clearProc right now, because it could + * invoke a Tcl script that wrecks the current state (e.g. it could + * delete the window). To be safe, defer the call until the end of the + * procedure when we no longer care about the state. + */ + + for (infoPtr = dispPtr->selectionInfoPtr; infoPtr != NULL; + infoPtr = infoPtr->nextPtr) { + if (infoPtr->selection == selection) { + break; + } + } + if (infoPtr == NULL) { + infoPtr = (TkSelectionInfo*) ckalloc(sizeof(TkSelectionInfo)); + infoPtr->selection = selection; + infoPtr->nextPtr = dispPtr->selectionInfoPtr; + dispPtr->selectionInfoPtr = infoPtr; + } else if (infoPtr->clearProc != NULL) { + if (infoPtr->owner != tkwin) { + clearProc = infoPtr->clearProc; + clearData = infoPtr->clearData; + } else if (infoPtr->clearProc == LostSelection) { + /* + * If the selection handler is one created by "selection own", + * be sure to free the record for it; otherwise there will be + * a memory leak. + */ + + ckfree((char *) infoPtr->clearData); + } + } + + infoPtr->owner = tkwin; + infoPtr->serial = NextRequest(winPtr->display); + infoPtr->clearProc = proc; + infoPtr->clearData = clientData; + + /* + * Note that we are using CurrentTime, even though ICCCM recommends against + * this practice (the problem is that we don't necessarily have a valid + * time to use). We will not be able to retrieve a useful timestamp for + * the TIMESTAMP target later. + */ + + infoPtr->time = CurrentTime; + + /* + * Note that we are not checking to see if the selection claim succeeded. + * If the ownership does not change, then the clearProc may never be + * invoked, and we will return incorrect information when queried for the + * current selection owner. + */ + + XSetSelectionOwner(winPtr->display, infoPtr->selection, winPtr->window, + infoPtr->time); + + /* + * Now that we are done, we can invoke clearProc without running into + * reentrancy problems. + */ + + if (clearProc != NULL) { + (*clearProc)(clearData); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tk_ClearSelection -- + * + * Eliminate the specified selection on tkwin's display, if there is one. + * + * Results: + * None. + * + * Side effects: + * The specified selection is cleared, so that future requests to retrieve + * it will fail until some application owns it again. This procedure + * invokes callbacks, possibly including Tcl scripts, so any calling + * function should be reentrant at the point Tk_ClearSelection is invoked. + * + *---------------------------------------------------------------------- + */ + +void +Tk_ClearSelection(tkwin, selection) + Tk_Window tkwin; /* Window that selects a display. */ + Atom selection; /* Selection to be cancelled. */ +{ + register TkWindow *winPtr = (TkWindow *) tkwin; + TkDisplay *dispPtr = winPtr->dispPtr; + TkSelectionInfo *infoPtr; + TkSelectionInfo *prevPtr; + TkSelectionInfo *nextPtr; + Tk_LostSelProc *clearProc = NULL; + ClientData clearData = NULL; /* Initialization needed only to + * prevent compiler warning. */ + + if (dispPtr->multipleAtom == None) { + TkSelInit(tkwin); + } + + for (infoPtr = dispPtr->selectionInfoPtr, prevPtr = NULL; + infoPtr != NULL; infoPtr = nextPtr) { + nextPtr = infoPtr->nextPtr; + if (infoPtr->selection == selection) { + if (prevPtr == NULL) { + dispPtr->selectionInfoPtr = nextPtr; + } else { + prevPtr->nextPtr = nextPtr; + } + break; + } + prevPtr = infoPtr; + } + + if (infoPtr != NULL) { + clearProc = infoPtr->clearProc; + clearData = infoPtr->clearData; + ckfree((char *) infoPtr); + } + XSetSelectionOwner(winPtr->display, selection, None, CurrentTime); + + if (clearProc != NULL) { + (*clearProc)(clearData); + } +} + +/* + *-------------------------------------------------------------- + * + * Tk_GetSelection -- + * + * Retrieve the value of a selection and pass it off (in + * pieces, possibly) to a given procedure. + * + * 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. + * + * Side effects: + * The standard X11 protocols are used to retrieve the + * selection. When it arrives, it is passed to proc. If + * the selection is very large, it will be passed to proc + * in several pieces. Proc should have the following + * structure: + * + * int + * proc(clientData, interp, portion) + * ClientData clientData; + * Tcl_Interp *interp; + * char *portion; + * { + * } + * + * The interp and clientData arguments to proc will be the + * same as the corresponding arguments to Tk_GetSelection. + * The portion argument points to a character string + * containing part of the selection, and numBytes indicates + * the length of the portion, not including the terminating + * NULL character. If the selection arrives in several pieces, + * 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 + * remainder of the selection retrieval will be aborted. + * + *-------------------------------------------------------------- + */ + +int +Tk_GetSelection(interp, tkwin, selection, target, proc, clientData) + Tcl_Interp *interp; /* Interpreter to use for reporting + * errors. */ + Tk_Window tkwin; /* Window on whose behalf to retrieve + * the selection (determines display + * from which to retrieve). */ + Atom selection; /* Selection to retrieve. */ + Atom target; /* Desired form in which selection + * is to be returned. */ + Tk_GetSelProc *proc; /* Procedure to call to process the + * selection, once it has been retrieved. */ + ClientData clientData; /* Arbitrary value to pass to proc. */ +{ + TkWindow *winPtr = (TkWindow *) tkwin; + TkDisplay *dispPtr = winPtr->dispPtr; + TkSelectionInfo *infoPtr; + + if (dispPtr->multipleAtom == None) { + TkSelInit(tkwin); + } + + /* + * If the selection is owned by a window managed by this + * process, then call the retrieval procedure directly, + * rather than going through the X server (it's dangerous + * to go through the X server in this case because it could + * result in deadlock if an INCR-style selection results). + */ + + for (infoPtr = dispPtr->selectionInfoPtr; infoPtr != NULL; + infoPtr = infoPtr->nextPtr) { + if (infoPtr->selection == selection) + break; + } + if (infoPtr != NULL) { + register TkSelHandler *selPtr; + int offset, result, count; + char buffer[TK_SEL_BYTES_AT_ONCE+1]; + TkSelInProgress ip; + + for (selPtr = ((TkWindow *) infoPtr->owner)->selHandlerList; + selPtr != NULL; selPtr = selPtr->nextPtr) { + if ((selPtr->target == target) + && (selPtr->selection == selection)) { + break; + } + } + if (selPtr == NULL) { + Atom type; + + count = TkSelDefaultSelection(infoPtr, target, buffer, + TK_SEL_BYTES_AT_ONCE, &type); + if (count > TK_SEL_BYTES_AT_ONCE) { + panic("selection handler returned too many bytes"); + } + if (count < 0) { + goto cantget; + } + buffer[count] = 0; + result = (*proc)(clientData, interp, buffer); + } else { + offset = 0; + result = TCL_OK; + ip.selPtr = selPtr; + ip.nextPtr = pendingPtr; + pendingPtr = &ip; + while (1) { + count = (selPtr->proc)(selPtr->clientData, offset, buffer, + TK_SEL_BYTES_AT_ONCE); + if ((count < 0) || (ip.selPtr == NULL)) { + pendingPtr = ip.nextPtr; + goto cantget; + } + if (count > TK_SEL_BYTES_AT_ONCE) { + panic("selection handler returned too many bytes"); + } + buffer[count] = '\0'; + result = (*proc)(clientData, interp, buffer); + if ((result != TCL_OK) || (count < TK_SEL_BYTES_AT_ONCE) + || (ip.selPtr == NULL)) { + break; + } + offset += count; + } + pendingPtr = ip.nextPtr; + } + return result; + } + + /* + * The selection is owned by some other process. + */ + + return TkSelGetSelection(interp, tkwin, selection, target, proc, + clientData); + + cantget: + Tcl_AppendResult(interp, Tk_GetAtomName(tkwin, selection), + " selection doesn't exist or form \"", Tk_GetAtomName(tkwin, target), + "\" not defined", (char *) NULL); + return TCL_ERROR; +} + +/* + *-------------------------------------------------------------- + * + * Tk_SelectionCmd -- + * + * This procedure is invoked to process the "selection" 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_SelectionCmd(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; + char *path = NULL; + Atom selection; + char *selName = NULL; + int c, count; + size_t length; + char **args; + + if (argc < 2) { + sprintf(interp->result, + "wrong # args: should be \"%.50s option ?arg arg ...?\"", + argv[0]); + return TCL_ERROR; + } + c = argv[1][0]; + length = strlen(argv[1]); + if ((c == 'c') && (strncmp(argv[1], "clear", length) == 0)) { + for (count = argc-2, args = argv+2; count > 0; count -= 2, args += 2) { + if (args[0][0] != '-') { + break; + } + if (count < 2) { + Tcl_AppendResult(interp, "value for \"", *args, + "\" missing", (char *) NULL); + return TCL_ERROR; + } + c = args[0][1]; + length = strlen(args[0]); + if ((c == 'd') && (strncmp(args[0], "-displayof", length) == 0)) { + path = args[1]; + } else if ((c == 's') + && (strncmp(args[0], "-selection", length) == 0)) { + selName = args[1]; + } else { + Tcl_AppendResult(interp, "unknown option \"", args[0], + "\"", (char *) NULL); + return TCL_ERROR; + } + } + if (count == 1) { + path = args[0]; + } else if (count > 1) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " clear ?options?\"", (char *) NULL); + return TCL_ERROR; + } + if (path != NULL) { + tkwin = Tk_NameToWindow(interp, path, tkwin); + } + if (tkwin == NULL) { + return TCL_ERROR; + } + if (selName != NULL) { + selection = Tk_InternAtom(tkwin, selName); + } else { + selection = XA_PRIMARY; + } + + Tk_ClearSelection(tkwin, selection); + return TCL_OK; + } else if ((c == 'g') && (strncmp(argv[1], "get", length) == 0)) { + Atom target; + char *targetName = NULL; + Tcl_DString selBytes; + int result; + + for (count = argc-2, args = argv+2; count > 0; count -= 2, args += 2) { + if (args[0][0] != '-') { + break; + } + if (count < 2) { + Tcl_AppendResult(interp, "value for \"", *args, + "\" missing", (char *) NULL); + return TCL_ERROR; + } + c = args[0][1]; + length = strlen(args[0]); + if ((c == 'd') && (strncmp(args[0], "-displayof", length) == 0)) { + path = args[1]; + } else if ((c == 's') + && (strncmp(args[0], "-selection", length) == 0)) { + selName = args[1]; + } else if ((c == 't') + && (strncmp(args[0], "-type", length) == 0)) { + targetName = args[1]; + } else { + Tcl_AppendResult(interp, "unknown option \"", args[0], + "\"", (char *) NULL); + return TCL_ERROR; + } + } + if (path != NULL) { + tkwin = Tk_NameToWindow(interp, path, tkwin); + } + if (tkwin == NULL) { + return TCL_ERROR; + } + if (selName != NULL) { + selection = Tk_InternAtom(tkwin, selName); + } else { + selection = XA_PRIMARY; + } + if (count > 1) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " get ?options?\"", (char *) NULL); + return TCL_ERROR; + } else if (count == 1) { + target = Tk_InternAtom(tkwin, args[0]); + } else if (targetName != NULL) { + target = Tk_InternAtom(tkwin, targetName); + } else { + target = XA_STRING; + } + + Tcl_DStringInit(&selBytes); + result = Tk_GetSelection(interp, tkwin, selection, target, SelGetProc, + (ClientData) &selBytes); + if (result == TCL_OK) { + Tcl_DStringResult(interp, &selBytes); + } else { + Tcl_DStringFree(&selBytes); + } + return result; + } else if ((c == 'h') && (strncmp(argv[1], "handle", length) == 0)) { + Atom target, format; + char *targetName = NULL; + char *formatName = NULL; + register CommandInfo *cmdInfoPtr; + int cmdLength; + + for (count = argc-2, args = argv+2; count > 0; count -= 2, args += 2) { + if (args[0][0] != '-') { + break; + } + if (count < 2) { + Tcl_AppendResult(interp, "value for \"", *args, + "\" missing", (char *) NULL); + return TCL_ERROR; + } + c = args[0][1]; + length = strlen(args[0]); + if ((c == 'f') && (strncmp(args[0], "-format", length) == 0)) { + formatName = args[1]; + } else if ((c == 's') + && (strncmp(args[0], "-selection", length) == 0)) { + selName = args[1]; + } else if ((c == 't') + && (strncmp(args[0], "-type", length) == 0)) { + targetName = args[1]; + } else { + Tcl_AppendResult(interp, "unknown option \"", args[0], + "\"", (char *) NULL); + return TCL_ERROR; + } + } + + if ((count < 2) || (count > 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " handle ?options? window command\"", (char *) NULL); + return TCL_ERROR; + } + tkwin = Tk_NameToWindow(interp, args[0], tkwin); + if (tkwin == NULL) { + return TCL_ERROR; + } + if (selName != NULL) { + selection = Tk_InternAtom(tkwin, selName); + } else { + selection = XA_PRIMARY; + } + + if (count > 2) { + target = Tk_InternAtom(tkwin, args[2]); + } else if (targetName != NULL) { + target = Tk_InternAtom(tkwin, targetName); + } else { + target = XA_STRING; + } + if (count > 3) { + format = Tk_InternAtom(tkwin, args[3]); + } else if (formatName != NULL) { + format = Tk_InternAtom(tkwin, formatName); + } else { + format = XA_STRING; + } + cmdLength = strlen(args[1]); + if (cmdLength == 0) { + Tk_DeleteSelHandler(tkwin, selection, target); + } else { + cmdInfoPtr = (CommandInfo *) ckalloc((unsigned) ( + sizeof(CommandInfo) - 3 + cmdLength)); + cmdInfoPtr->interp = interp; + cmdInfoPtr->cmdLength = cmdLength; + strcpy(cmdInfoPtr->command, args[1]); + Tk_CreateSelHandler(tkwin, selection, target, HandleTclCommand, + (ClientData) cmdInfoPtr, format); + } + return TCL_OK; + } else if ((c == 'o') && (strncmp(argv[1], "own", length) == 0)) { + register LostCommand *lostPtr; + char *script = NULL; + int cmdLength; + + for (count = argc-2, args = argv+2; count > 0; count -= 2, args += 2) { + if (args[0][0] != '-') { + break; + } + if (count < 2) { + Tcl_AppendResult(interp, "value for \"", *args, + "\" missing", (char *) NULL); + return TCL_ERROR; + } + c = args[0][1]; + length = strlen(args[0]); + if ((c == 'c') && (strncmp(args[0], "-command", length) == 0)) { + script = args[1]; + } else if ((c == 'd') + && (strncmp(args[0], "-displayof", length) == 0)) { + path = args[1]; + } else if ((c == 's') + && (strncmp(args[0], "-selection", length) == 0)) { + selName = args[1]; + } else { + Tcl_AppendResult(interp, "unknown option \"", args[0], + "\"", (char *) NULL); + return TCL_ERROR; + } + } + + if (count > 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " own ?options? ?window?\"", (char *) NULL); + return TCL_ERROR; + } + if (selName != NULL) { + selection = Tk_InternAtom(tkwin, selName); + } else { + selection = XA_PRIMARY; + } + if (count == 0) { + TkSelectionInfo *infoPtr; + TkWindow *winPtr; + if (path != NULL) { + tkwin = Tk_NameToWindow(interp, path, tkwin); + } + if (tkwin == NULL) { + return TCL_ERROR; + } + winPtr = (TkWindow *)tkwin; + for (infoPtr = winPtr->dispPtr->selectionInfoPtr; infoPtr != NULL; + infoPtr = infoPtr->nextPtr) { + if (infoPtr->selection == selection) + break; + } + + /* + * Ignore the internal clipboard window. + */ + + if ((infoPtr != NULL) + && (infoPtr->owner != winPtr->dispPtr->clipWindow)) { + interp->result = Tk_PathName(infoPtr->owner); + } + return TCL_OK; + } + tkwin = Tk_NameToWindow(interp, args[0], tkwin); + if (tkwin == NULL) { + return TCL_ERROR; + } + if (count == 2) { + script = args[1]; + } + if (script == NULL) { + Tk_OwnSelection(tkwin, selection, (Tk_LostSelProc *) NULL, + (ClientData) NULL); + return TCL_OK; + } + cmdLength = strlen(script); + lostPtr = (LostCommand *) ckalloc((unsigned) (sizeof(LostCommand) + -3 + cmdLength)); + lostPtr->interp = interp; + strcpy(lostPtr->command, script); + 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]); + return TCL_ERROR; + } +} + +/* + *---------------------------------------------------------------------- + * + * TkSelDeadWindow -- + * + * This procedure is invoked just before a TkWindow is deleted. + * It performs selection-related cleanup. + * + * Results: + * None. + * + * Side effects: + * Frees up memory associated with the selection. + * + *---------------------------------------------------------------------- + */ + +void +TkSelDeadWindow(winPtr) + register TkWindow *winPtr; /* Window that's being deleted. */ +{ + register TkSelHandler *selPtr; + register TkSelInProgress *ipPtr; + TkSelectionInfo *infoPtr, *prevPtr, *nextPtr; + + /* + * While deleting all the handlers, be careful to check whether + * ConvertSelection or TkSelPropProc are about to process one of the + * deleted handlers. + */ + + while (winPtr->selHandlerList != NULL) { + selPtr = winPtr->selHandlerList; + winPtr->selHandlerList = selPtr->nextPtr; + for (ipPtr = pendingPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { + if (ipPtr->selPtr == selPtr) { + ipPtr->selPtr = NULL; + } + } + if (selPtr->proc == HandleTclCommand) { + ckfree((char *) selPtr->clientData); + } + ckfree((char *) selPtr); + } + + /* + * Remove selections owned by window being deleted. + */ + + for (infoPtr = winPtr->dispPtr->selectionInfoPtr, prevPtr = NULL; + infoPtr != NULL; infoPtr = nextPtr) { + nextPtr = infoPtr->nextPtr; + if (infoPtr->owner == (Tk_Window) winPtr) { + if (infoPtr->clearProc == LostSelection) { + ckfree((char *) infoPtr->clearData); + } + ckfree((char *) infoPtr); + infoPtr = prevPtr; + if (prevPtr == NULL) { + winPtr->dispPtr->selectionInfoPtr = nextPtr; + } else { + prevPtr->nextPtr = nextPtr; + } + } + prevPtr = infoPtr; + } +} + +/* + *---------------------------------------------------------------------- + * + * TkSelInit -- + * + * Initialize selection-related information for a display. + * + * Results: + * None. + * + * Side effects: + * Selection-related information is initialized. + * + *---------------------------------------------------------------------- + */ + +void +TkSelInit(tkwin) + Tk_Window tkwin; /* Window token (used to find + * display to initialize). */ +{ + register TkDisplay *dispPtr = ((TkWindow *) tkwin)->dispPtr; + + /* + * Fetch commonly-used atoms. + */ + + dispPtr->multipleAtom = Tk_InternAtom(tkwin, "MULTIPLE"); + dispPtr->incrAtom = Tk_InternAtom(tkwin, "INCR"); + dispPtr->targetsAtom = Tk_InternAtom(tkwin, "TARGETS"); + dispPtr->timestampAtom = Tk_InternAtom(tkwin, "TIMESTAMP"); + dispPtr->textAtom = Tk_InternAtom(tkwin, "TEXT"); + dispPtr->compoundTextAtom = Tk_InternAtom(tkwin, "COMPOUND_TEXT"); + dispPtr->applicationAtom = Tk_InternAtom(tkwin, "TK_APPLICATION"); + dispPtr->windowAtom = Tk_InternAtom(tkwin, "TK_WINDOW"); + dispPtr->clipboardAtom = Tk_InternAtom(tkwin, "CLIPBOARD"); +} + +/* + *---------------------------------------------------------------------- + * + * TkSelClearSelection -- + * + * This procedure is invoked to process a SelectionClear event. + * + * Results: + * None. + * + * Side effects: + * Invokes the clear procedure for the window which lost the + * selection. + * + *---------------------------------------------------------------------- + */ + +void +TkSelClearSelection(tkwin, eventPtr) + Tk_Window tkwin; /* Window for which event was targeted. */ + register XEvent *eventPtr; /* X SelectionClear event. */ +{ + register TkWindow *winPtr = (TkWindow *) tkwin; + TkDisplay *dispPtr = winPtr->dispPtr; + TkSelectionInfo *infoPtr; + TkSelectionInfo *prevPtr; + + /* + * Invoke clear procedure for window that just lost the selection. This + * code is a bit tricky, because any callbacks due to selection changes + * between windows managed by the process have already been made. Thus, + * ignore the event unless it refers to the window that's currently the + * selection owner and the event was generated after the server saw the + * SetSelectionOwner request. + */ + + for (infoPtr = dispPtr->selectionInfoPtr, prevPtr = NULL; + infoPtr != NULL; infoPtr = infoPtr->nextPtr) { + if (infoPtr->selection == eventPtr->xselectionclear.selection) { + break; + } + prevPtr = infoPtr; + } + + if (infoPtr != NULL && (infoPtr->owner == tkwin) + && (eventPtr->xselectionclear.serial >= (unsigned) infoPtr->serial)) { + if (prevPtr == NULL) { + dispPtr->selectionInfoPtr = infoPtr->nextPtr; + } else { + prevPtr->nextPtr = infoPtr->nextPtr; + } + + /* + * Because of reentrancy problems, calling clearProc must be done + * after the infoPtr has been removed from the selectionInfoPtr + * list (clearProc could modify the list, e.g. by creating + * a new selection). + */ + + if (infoPtr->clearProc != NULL) { + (*infoPtr->clearProc)(infoPtr->clearData); + } + ckfree((char *) infoPtr); + } +} + +/* + *-------------------------------------------------------------- + * + * SelGetProc -- + * + * This procedure is invoked to process pieces of the selection + * as they arrive during "selection get" commands. + * + * Results: + * Always returns TCL_OK. + * + * Side effects: + * Bytes get appended to the dynamic string pointed to by the + * clientData argument. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +SelGetProc(clientData, interp, portion) + ClientData clientData; /* Dynamic string holding partially + * assembled selection. */ + Tcl_Interp *interp; /* Interpreter used for error + * reporting (not used). */ + char *portion; /* New information to be appended. */ +{ + Tcl_DStringAppend((Tcl_DString *) clientData, portion, -1); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * HandleTclCommand -- + * + * This procedure acts as selection handler for handlers created + * by the "selection handle" command. It invokes a Tcl command to + * retrieve the selection. + * + * Results: + * The return value is a count of the number of bytes actually + * stored at buffer, or -1 if an error occurs while executing + * the Tcl command to retrieve the selection. + * + * Side effects: + * None except for things done by the Tcl command. + * + *---------------------------------------------------------------------- + */ + +static int +HandleTclCommand(clientData, offset, buffer, maxBytes) + ClientData clientData; /* Information about command to execute. */ + int offset; /* Return selection bytes starting at this + * offset. */ + char *buffer; /* Place to store converted selection. */ + int maxBytes; /* Maximum # of bytes to store at buffer. */ +{ + CommandInfo *cmdInfoPtr = (CommandInfo *) clientData; + int spaceNeeded, length; +#define MAX_STATIC_SIZE 100 + char staticSpace[MAX_STATIC_SIZE]; + char *command; + Tcl_Interp *interp; + Tcl_DString oldResult; + + /* + * We must copy the interpreter pointer from CommandInfo because the + * command could delete the handler, freeing the CommandInfo data before we + * are done using it. We must also protect the interpreter from being + * deleted too soo. + */ + + interp = cmdInfoPtr->interp; + Tcl_Preserve((ClientData) interp); + + /* + * First, generate a command by taking the command string + * and appending the offset and maximum # of bytes. + */ + + spaceNeeded = cmdInfoPtr->cmdLength + 30; + if (spaceNeeded < MAX_STATIC_SIZE) { + command = staticSpace; + } else { + command = (char *) ckalloc((unsigned) spaceNeeded); + } + sprintf(command, "%s %d %d", cmdInfoPtr->command, offset, maxBytes); + + /* + * Execute the command. Be sure to restore the state of the + * interpreter after executing the command. + */ + + Tcl_DStringInit(&oldResult); + Tcl_DStringGetResult(interp, &oldResult); + if (TkCopyAndGlobalEval(interp, command) == TCL_OK) { + length = strlen(interp->result); + if (length > maxBytes) { + length = maxBytes; + } + memcpy((VOID *) buffer, (VOID *) interp->result, (size_t) length); + buffer[length] = '\0'; + } else { + length = -1; + } + Tcl_DStringResult(interp, &oldResult); + + if (command != staticSpace) { + ckfree(command); + } + + Tcl_Release((ClientData) interp); + return length; +} + +/* + *---------------------------------------------------------------------- + * + * TkSelDefaultSelection -- + * + * This procedure is called to generate selection information + * for a few standard targets such as TIMESTAMP and TARGETS. + * It is invoked only if no handler has been declared by the + * application. + * + * Results: + * If "target" is a standard target understood by this procedure, + * the selection is converted to that form and stored as a + * character string in buffer. The type of the selection (e.g. + * STRING or ATOM) is stored in *typePtr, and the return value is + * a count of the # of non-NULL bytes at buffer. If the target + * wasn't understood, or if there isn't enough space at buffer + * to hold the entire selection (no INCR-mode transfers for this + * stuff!), then -1 is returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TkSelDefaultSelection(infoPtr, target, buffer, maxBytes, typePtr) + TkSelectionInfo *infoPtr; /* Info about selection being retrieved. */ + Atom target; /* Desired form of selection. */ + char *buffer; /* Place to put selection characters. */ + int maxBytes; /* Maximum # of bytes to store at buffer. */ + Atom *typePtr; /* Store here the type of the selection, + * for use in converting to proper X format. */ +{ + register TkWindow *winPtr = (TkWindow *) infoPtr->owner; + TkDisplay *dispPtr = winPtr->dispPtr; + + if (target == dispPtr->timestampAtom) { + if (maxBytes < 20) { + return -1; + } + sprintf(buffer, "0x%x", (unsigned int) infoPtr->time); + *typePtr = XA_INTEGER; + return strlen(buffer); + } + + if (target == dispPtr->targetsAtom) { + register TkSelHandler *selPtr; + char *atomString; + int length, atomLength; + + if (maxBytes < 50) { + return -1; + } + strcpy(buffer, "MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW"); + length = strlen(buffer); + for (selPtr = winPtr->selHandlerList; selPtr != NULL; + selPtr = selPtr->nextPtr) { + if ((selPtr->selection == infoPtr->selection) + && (selPtr->target != dispPtr->applicationAtom) + && (selPtr->target != dispPtr->windowAtom)) { + atomString = Tk_GetAtomName((Tk_Window) winPtr, + selPtr->target); + atomLength = strlen(atomString) + 1; + if ((length + atomLength) >= maxBytes) { + return -1; + } + sprintf(buffer+length, " %s", atomString); + length += atomLength; + } + } + *typePtr = XA_ATOM; + return length; + } + + if (target == dispPtr->applicationAtom) { + int length; + char *name = winPtr->mainPtr->winPtr->nameUid; + + length = strlen(name); + if (maxBytes <= length) { + return -1; + } + strcpy(buffer, name); + *typePtr = XA_STRING; + return length; + } + + if (target == dispPtr->windowAtom) { + int length; + char *name = winPtr->pathName; + + length = strlen(name); + if (maxBytes <= length) { + return -1; + } + strcpy(buffer, name); + *typePtr = XA_STRING; + return length; + } + + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * LostSelection -- + * + * This procedure is invoked when a window has lost ownership of + * the selection and the ownership was claimed with the command + * "selection own". + * + * Results: + * None. + * + * Side effects: + * A Tcl script is executed; it can do almost anything. + * + *---------------------------------------------------------------------- + */ + +static void +LostSelection(clientData) + ClientData clientData; /* Pointer to CommandInfo structure. */ +{ + LostCommand *lostPtr = (LostCommand *) clientData; + char *oldResultString; + Tcl_FreeProc *oldFreeProc; + Tcl_Interp *interp; + + interp = lostPtr->interp; + Tcl_Preserve((ClientData) interp); + + /* + * Execute the command. Save the interpreter's result, if any, and + * 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; + if (TkCopyAndGlobalEval(interp, lostPtr->command) != TCL_OK) { + Tcl_BackgroundError(interp); + } + Tcl_FreeResult(interp); + interp->result = oldResultString; + interp->freeProc = oldFreeProc; + + Tcl_Release((ClientData) interp); + + /* + * Free the storage for the command, since we're done with it now. + */ + + ckfree((char *) lostPtr); +} diff --git a/generic/tkSelect.h b/generic/tkSelect.h new file mode 100644 index 0000000..8595599 --- /dev/null +++ b/generic/tkSelect.h @@ -0,0 +1,184 @@ +/* + * tkSelect.h -- + * + * Declarations of types shared among the files that implement + * selection support. + * + * Copyright (c) 1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkSelect.h 1.4 95/11/03 13:22:41 + */ + +#ifndef _TKSELECT +#define _TKSELECT + +/* + * When a selection is owned by a window on a given display, one of the + * following structures is present on a list of current selections in the + * display structure. The structure is used to record the current owner of + * a selection for use in later retrieval requests. There is a list of + * such structures because a display can have multiple different selections + * active at the same time. + */ + +typedef struct TkSelectionInfo { + Atom selection; /* Selection name, e.g. XA_PRIMARY. */ + Tk_Window owner; /* Current owner of this selection. */ + int serial; /* Serial number of last XSelectionSetOwner + * request made to server for this + * selection (used to filter out redundant + * SelectionClear events). */ + Time time; /* Timestamp used to acquire selection. */ + Tk_LostSelProc *clearProc; /* Procedure to call when owner loses + * selection. */ + ClientData clearData; /* Info to pass to clearProc. */ + struct TkSelectionInfo *nextPtr; + /* Next in list of current selections on + * this display. NULL means end of list */ +} TkSelectionInfo; + +/* + * One of the following structures exists for each selection handler + * created for a window by calling Tk_CreateSelHandler. The handlers + * are linked in a list rooted in the TkWindow structure. + */ + +typedef struct TkSelHandler { + Atom selection; /* Selection name, e.g. XA_PRIMARY */ + Atom target; /* Target type for selection + * conversion, such as TARGETS or + * STRING. */ + Atom format; /* Format in which selection + * info will be returned, such + * as STRING or ATOM. */ + Tk_SelectionProc *proc; /* Procedure to generate selection + * in this format. */ + ClientData clientData; /* Argument to pass to proc. */ + int size; /* Size of units returned by proc + * (8 for STRING, 32 for almost + * anything else). */ + struct TkSelHandler *nextPtr; + /* Next selection handler associated + * with same window (NULL for end of + * list). */ +} TkSelHandler; + +/* + * When the selection is being retrieved, one of the following + * structures is present on a list of pending selection retrievals. + * The structure is used to communicate between the background + * procedure that requests the selection and the foreground + * event handler that processes the events in which the selection + * is returned. There is a list of such structures so that there + * can be multiple simultaneous selection retrievals (e.g. on + * different displays). + */ + +typedef struct TkSelRetrievalInfo { + Tcl_Interp *interp; /* Interpreter for error reporting. */ + TkWindow *winPtr; /* Window used as requestor for + * selection. */ + Atom selection; /* Selection being requested. */ + Atom property; /* Property where selection will appear. */ + Atom target; /* Desired form for selection. */ + int (*proc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, + char *portion)); /* Procedure to call to handle pieces + * of selection. */ + ClientData clientData; /* Argument for proc. */ + int result; /* Initially -1. Set to a Tcl + * return value once the selection + * has been retrieved. */ + Tcl_TimerToken timeout; /* Token for current timeout procedure. */ + int idleTime; /* Number of seconds that have gone by + * without hearing anything from the + * selection owner. */ + struct TkSelRetrievalInfo *nextPtr; + /* Next in list of all pending + * selection retrievals. NULL means + * end of list. */ +} TkSelRetrievalInfo; + +/* + * The clipboard contains a list of buffers of various types and formats. + * All of the buffers of a given type will be returned in sequence when the + * CLIPBOARD selection is retrieved. All buffers of a given type on the + * same clipboard must have the same format. The TkClipboardTarget structure + * is used to record the information about a chain of buffers of the same + * type. + */ + +typedef struct TkClipboardBuffer { + char *buffer; /* Null terminated data buffer. */ + long length; /* Length of string in buffer. */ + struct TkClipboardBuffer *nextPtr; /* Next in list of buffers. NULL + * means end of list . */ +} TkClipboardBuffer; + +typedef struct TkClipboardTarget { + Atom type; /* Type conversion supported. */ + Atom format; /* Representation used for data. */ + TkClipboardBuffer *firstBufferPtr; /* First in list of data buffers. */ + TkClipboardBuffer *lastBufferPtr; /* Last in list of clipboard buffers. + * Used to speed up appends. */ + struct TkClipboardTarget *nextPtr; /* Next in list of targets on + * clipboard. NULL means end of + * list. */ +} TkClipboardTarget; + +/* + * It is possible for a Tk_SelectionProc to delete the handler that it + * represents. If this happens, the code that is retrieving the selection + * needs to know about it so it doesn't use the now-defunct handler + * structure. One structure of the following form is created for each + * retrieval in progress, so that the retriever can find out if its + * handler is deleted. All of the pending retrievals (if there are more + * than one) are linked into a list. + */ + +typedef struct TkSelInProgress { + TkSelHandler *selPtr; /* Handler being executed. If this handler + * is deleted, the field is set to NULL. */ + struct TkSelInProgress *nextPtr; + /* Next higher nested search. */ +} TkSelInProgress; + +/* + * Declarations for variables shared among the selection-related files: + */ + +extern TkSelInProgress *pendingPtr; + /* Topmost search in progress, or + * NULL if none. */ + +/* + * Chunk size for retrieving selection. It's defined both in + * words and in bytes; the word size is used to allocate + * buffer space that's guaranteed to be word-aligned and that + * has an extra character for the terminating NULL. + */ + +#define TK_SEL_BYTES_AT_ONCE 4000 +#define TK_SEL_WORDS_AT_ONCE 1001 + +/* + * Declarations for procedures that are used by the selection-related files + * but shouldn't be used anywhere else in Tk (or by Tk clients): + */ + +extern void TkSelClearSelection _ANSI_ARGS_((Tk_Window tkwin, + XEvent *eventPtr)); +extern int TkSelDefaultSelection _ANSI_ARGS_(( + TkSelectionInfo *infoPtr, Atom target, + char *buffer, int maxBytes, Atom *typePtr)); +extern int TkSelGetSelection _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window tkwin, Atom selection, Atom target, + Tk_GetSelProc *proc, ClientData clientData)); +#ifndef TkSelUpdateClipboard +extern void TkSelUpdateClipboard _ANSI_ARGS_((TkWindow *winPtr, + TkClipboardTarget *targetPtr)); +#endif + +#endif /* _TKSELECT */ diff --git a/generic/tkSquare.c b/generic/tkSquare.c new file mode 100644 index 0000000..eff8181 --- /dev/null +++ b/generic/tkSquare.c @@ -0,0 +1,587 @@ +/* + * 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 + * 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. + * + * 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 + */ + +#include "tkPort.h" +#include "tk.h" + +/* + * A data structure of the following type is kept for each square + * widget managed by this file: + */ + +typedef struct { + Tk_Window tkwin; /* Window that embodies the square. NULL + * means window has been deleted but + * widget record hasn't been cleaned up yet. */ + 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 + * within widget. */ + int size; /* 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. */ + GC gc; /* Graphics context for copying from + * off-screen pixmap onto screen. */ + int doubleBuffer; /* Non-zero means double-buffer redisplay + * with pixmap; zero means draw straight + * onto the display. */ + int updatePending; /* Non-zero means a call to SquareDisplay + * has already been scheduled. */ +} Square; + +/* + * 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} +}; + +/* + * 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_(( + ClientData clientData)); +static int SquareConfigure _ANSI_ARGS_((Tcl_Interp *interp, + Square *squarePtr, int argc, char **argv, + int flags)); +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, + XEvent *eventPtr)); +static int SquareWidgetCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *, int argc, char **argv)); + +/* + *-------------------------------------------------------------- + * + * SquareCmd -- + * + * This procedure is invoked to process the "square" Tcl + * command. It creates a new "square" widget. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * A new widget is created and configured. + * + *-------------------------------------------------------------- + */ + +int +SquareCmd(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 main = (Tk_Window) clientData; + Square *squarePtr; + Tk_Window tkwin; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " pathName ?options?\"", (char *) NULL); + return TCL_ERROR; + } + + tkwin = Tk_CreateWindowFromPath(interp, main, argv[1], (char *) NULL); + if (tkwin == NULL) { + return TCL_ERROR; + } + Tk_SetClass(tkwin, "Square"); + + /* + * Allocate and initialize the widget record. + */ + + squarePtr = (Square *) ckalloc(sizeof(Square)); + squarePtr->tkwin = tkwin; + squarePtr->display = Tk_Display(tkwin); + squarePtr->interp = interp; + squarePtr->widgetCmd = Tcl_CreateCommand(interp, + Tk_PathName(squarePtr->tkwin), SquareWidgetCmd, + (ClientData) squarePtr, SquareCmdDeletedProc); + squarePtr->x = 0; + squarePtr->y = 0; + squarePtr->size = 20; + squarePtr->borderWidth = 0; + squarePtr->bgBorder = NULL; + squarePtr->fgBorder = NULL; + squarePtr->relief = TK_RELIEF_FLAT; + squarePtr->gc = None; + squarePtr->doubleBuffer = 1; + squarePtr->updatePending = 0; + + Tk_CreateEventHandler(squarePtr->tkwin, ExposureMask|StructureNotifyMask, + SquareEventProc, (ClientData) squarePtr); + if (SquareConfigure(interp, squarePtr, argc-2, argv+2, 0) != TCL_OK) { + Tk_DestroyWindow(squarePtr->tkwin); + return TCL_ERROR; + } + + interp->result = Tk_PathName(squarePtr->tkwin); + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * SquareWidgetCmd -- + * + * This procedure is invoked to process the Tcl command + * that corresponds to a widget managed by this module. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +static int +SquareWidgetCmd(clientData, interp, argc, argv) + ClientData clientData; /* Information about square widget. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Square *squarePtr = (Square *) clientData; + int result = TCL_OK; + size_t length; + char c; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " option ?arg arg ...?\"", (char *) NULL); + 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)) { + 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; + } + if (argc == 3) { + int i; + + if (Tk_GetPixels(interp, squarePtr->tkwin, argv[2], &i) != TCL_OK) { + goto error; + } + if ((i <= 0) || (i > 100)) { + Tcl_AppendResult(interp, "bad size \"", argv[2], + "\"", (char *) NULL); + goto error; + } + 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; + + error: + Tcl_Release((ClientData) squarePtr); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * SquareConfigure -- + * + * This procedure is called to process an argv/argc list in + * conjunction with the Tk option database to configure (or + * reconfigure) a square widget. + * + * Results: + * The return value is a standard Tcl result. If TCL_ERROR is + * returned, then interp->result contains an error message. + * + * Side effects: + * Configuration information, such as colors, border width, + * etc. get set for squarePtr; old resources get freed, + * if there were any. + * + *---------------------------------------------------------------------- + */ + +static int +SquareConfigure(interp, squarePtr, argc, argv, flags) + 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; + } + + /* + * Set the background for the window and create a graphics context + * for use during redisplay. + */ + + Tk_SetWindowBackground(squarePtr->tkwin, + Tk_3DBorderColor(squarePtr->bgBorder)->pixel); + if ((squarePtr->gc == None) && (squarePtr->doubleBuffer)) { + XGCValues gcValues; + gcValues.function = GXcopy; + gcValues.graphics_exposures = False; + squarePtr->gc = Tk_GetGC(squarePtr->tkwin, + GCFunction|GCGraphicsExposures, &gcValues); + } + + /* + * Register the desired geometry for the window. Then arrange for + * the window to be redisplayed. + */ + + Tk_GeometryRequest(squarePtr->tkwin, 200, 150); + Tk_SetInternalBorder(squarePtr->tkwin, squarePtr->borderWidth); + if (!squarePtr->updatePending) { + Tcl_DoWhenIdle(SquareDisplay, (ClientData) squarePtr); + squarePtr->updatePending = 1; + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * SquareEventProc -- + * + * This procedure is invoked by the Tk dispatcher for various + * events on squares. + * + * Results: + * None. + * + * Side effects: + * When the window gets deleted, internal structures get + * cleaned up. When it gets exposed, it is redisplayed. + * + *-------------------------------------------------------------- + */ + +static void +SquareEventProc(clientData, eventPtr) + ClientData clientData; /* Information about window. */ + XEvent *eventPtr; /* Information about event. */ +{ + Square *squarePtr = (Square *) clientData; + + if (eventPtr->type == Expose) { + if (!squarePtr->updatePending) { + Tcl_DoWhenIdle(SquareDisplay, (ClientData) squarePtr); + squarePtr->updatePending = 1; + } + } else if (eventPtr->type == ConfigureNotify) { + KeepInWindow(squarePtr); + if (!squarePtr->updatePending) { + Tcl_DoWhenIdle(SquareDisplay, (ClientData) squarePtr); + squarePtr->updatePending = 1; + } + } else if (eventPtr->type == DestroyNotify) { + if (squarePtr->tkwin != NULL) { + squarePtr->tkwin = NULL; + Tcl_DeleteCommandFromToken(squarePtr->interp, + squarePtr->widgetCmd); + } + if (squarePtr->updatePending) { + Tcl_CancelIdleCall(SquareDisplay, (ClientData) squarePtr); + } + Tcl_EventuallyFree((ClientData) squarePtr, SquareDestroy); + } +} + +/* + *---------------------------------------------------------------------- + * + * SquareCmdDeletedProc -- + * + * 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 +SquareCmdDeletedProc(clientData) + ClientData clientData; /* Pointer to widget record for widget. */ +{ + Square *squarePtr = (Square *) clientData; + Tk_Window tkwin = squarePtr->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. + */ + + if (tkwin != NULL) { + squarePtr->tkwin = NULL; + Tk_DestroyWindow(tkwin); + } +} + +/* + *-------------------------------------------------------------- + * + * SquareDisplay -- + * + * This procedure redraws the contents of a square window. + * It is invoked as a do-when-idle handler, so it only runs + * when there's nothing else for the application to do. + * + * Results: + * None. + * + * Side effects: + * Information appears on the screen. + * + *-------------------------------------------------------------- + */ + +static void +SquareDisplay(clientData) + ClientData clientData; /* Information about window. */ +{ + Square *squarePtr = (Square *) clientData; + Tk_Window tkwin = squarePtr->tkwin; + Pixmap pm = None; + Drawable d; + + squarePtr->updatePending = 0; + if (!Tk_IsMapped(tkwin)) { + return; + } + + /* + * Create a pixmap for double-buffering, if necessary. + */ + + if (squarePtr->doubleBuffer) { + pm = Tk_GetPixmap(Tk_Display(tkwin), Tk_WindowId(tkwin), + Tk_Width(tkwin), Tk_Height(tkwin), + DefaultDepthOfScreen(Tk_Screen(tkwin))); + d = pm; + } else { + d = Tk_WindowId(tkwin); + } + + /* + * 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); + + /* + * Display the square. + */ + + Tk_Fill3DRectangle(tkwin, d, squarePtr->fgBorder, squarePtr->x, + squarePtr->y, squarePtr->size, squarePtr->size, + squarePtr->borderWidth, TK_RELIEF_RAISED); + + /* + * If double-buffered, copy to the screen and release the pixmap. + */ + + if (squarePtr->doubleBuffer) { + XCopyArea(Tk_Display(tkwin), pm, Tk_WindowId(tkwin), squarePtr->gc, + 0, 0, (unsigned) Tk_Width(tkwin), (unsigned) Tk_Height(tkwin), + 0, 0); + Tk_FreePixmap(Tk_Display(tkwin), pm); + } +} + +/* + *---------------------------------------------------------------------- + * + * SquareDestroy -- + * + * This procedure is invoked by Tcl_EventuallyFree or Tcl_Release + * to clean up the internal structure of a square at a safe time + * (when no-one is using it anymore). + * + * Results: + * None. + * + * Side effects: + * Everything associated with the square is freed up. + * + *---------------------------------------------------------------------- + */ + +static void +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); +} + +/* + *---------------------------------------------------------------------- + * + * KeepInWindow -- + * + * Adjust the position of the square if necessary to keep it in + * the widget's window. + * + * Results: + * None. + * + * Side effects: + * The x and y position of the square are adjusted if necessary + * to keep the square in the window. + * + *---------------------------------------------------------------------- + */ + +static void +KeepInWindow(squarePtr) + register Square *squarePtr; /* Pointer to widget record. */ +{ + int i, bd; + bd = 0; + if (squarePtr->relief != TK_RELIEF_FLAT) { + bd = squarePtr->borderWidth; + } + i = (Tk_Width(squarePtr->tkwin) - bd) - (squarePtr->x + squarePtr->size); + if (i < 0) { + squarePtr->x += i; + } + i = (Tk_Height(squarePtr->tkwin) - bd) - (squarePtr->y + squarePtr->size); + if (i < 0) { + squarePtr->y += i; + } + if (squarePtr->x < bd) { + squarePtr->x = bd; + } + if (squarePtr->y < bd) { + squarePtr->y = bd; + } +} diff --git a/generic/tkTest.c b/generic/tkTest.c new file mode 100644 index 0000000..dab43d0 --- /dev/null +++ b/generic/tkTest.c @@ -0,0 +1,1134 @@ +/* + * tkTest.c -- + * + * This file contains C command procedures for a bunch of additional + * Tcl commands that are used for testing out Tcl's C interfaces. + * These commands are not normally included in Tcl applications; + * they're only used for testing. + * + * Copyright (c) 1993-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: @(#) tkTest.c 1.50 97/11/06 16:56:32 + */ + +#include "tkInt.h" +#include "tkPort.h" + +#ifdef __WIN32__ +#include "tkWinInt.h" +#endif + +#ifdef MAC_TCL +#include "tkScrollbar.h" +#endif + +#ifdef __UNIX__ +#include "tkUnixInt.h" +#endif + +/* + * The following data structure represents the master for a test + * image: + */ + +typedef struct TImageMaster { + Tk_ImageMaster master; /* Tk's token for image master. */ + Tcl_Interp *interp; /* Interpreter for application. */ + int width, height; /* Dimensions of image. */ + char *imageName; /* Name of image (malloc-ed). */ + char *varName; /* Name of variable in which to log + * events for image (malloc-ed). */ +} TImageMaster; + +/* + * The following data structure represents a particular use of a + * particular test image. + */ + +typedef struct TImageInstance { + TImageMaster *masterPtr; /* Pointer to master for image. */ + XColor *fg; /* Foreground color for drawing in image. */ + GC gc; /* Graphics context for drawing in image. */ +} TImageInstance; + +/* + * The type record for test images: + */ + +static int ImageCreate _ANSI_ARGS_((Tcl_Interp *interp, + char *name, int argc, char **argv, + Tk_ImageType *typePtr, Tk_ImageMaster master, + ClientData *clientDataPtr)); +static ClientData ImageGet _ANSI_ARGS_((Tk_Window tkwin, + ClientData clientData)); +static void ImageDisplay _ANSI_ARGS_((ClientData clientData, + Display *display, Drawable drawable, + int imageX, int imageY, int width, + int height, int drawableX, + int drawableY)); +static void ImageFree _ANSI_ARGS_((ClientData clientData, + Display *display)); +static void ImageDelete _ANSI_ARGS_((ClientData clientData)); + +static Tk_ImageType imageType = { + "test", /* name */ + ImageCreate, /* createProc */ + ImageGet, /* getProc */ + ImageDisplay, /* displayProc */ + ImageFree, /* freeProc */ + ImageDelete, /* deleteProc */ + (Tk_ImageType *) NULL /* nextPtr */ +}; + +/* + * One of the following structures describes each of the interpreters + * created by the "testnewapp" command. This information is used by + * the "testdeleteinterps" command to destroy all of those interpreters. + */ + +typedef struct NewApp { + Tcl_Interp *interp; /* Token for interpreter. */ + struct NewApp *nextPtr; /* Next in list of new interpreters. */ +} NewApp; + +static NewApp *newAppPtr = NULL; + /* First in list of all new interpreters. */ + +/* + * Declaration for the square widget's class command procedure: + */ + +extern int SquareCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char *argv[])); + +typedef struct CBinding { + Tcl_Interp *interp; + char *command; + char *delete; +} CBinding; + +/* + * Forward declarations for procedures defined later in this file: + */ + +static int CBindingEvalProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, XEvent *eventPtr, + Tk_Window tkwin, KeySym keySym)); +static void CBindingFreeProc _ANSI_ARGS_((ClientData clientData)); +int Tktest_Init _ANSI_ARGS_((Tcl_Interp *interp)); +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 TestdeleteappsCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestmakeexistCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestmenubarCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +#if defined(__WIN32__) || defined(MAC_TCL) +static int TestmetricsCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +#endif +static int TestsendCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestpropCmd _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 + +/* + * External (platform specific) initialization routine: + */ + +EXTERN int TkplatformtestInit _ANSI_ARGS_(( + Tcl_Interp *interp)); +#ifndef MAC_TCL +#define TkplatformtestInit(x) TCL_OK +#endif + +/* + *---------------------------------------------------------------------- + * + * Tktest_Init -- + * + * This procedure performs intialization for the Tk test + * suite exensions. + * + * Results: + * Returns a standard Tcl completion code, and leaves an error + * message in interp->result if an error occurs. + * + * Side effects: + * Creates several test commands. + * + *---------------------------------------------------------------------- + */ + +int +Tktest_Init(interp) + Tcl_Interp *interp; /* Interpreter for application. */ +{ + static int initialized = 0; + + /* + * Create additional commands for testing Tk. + */ + + if (Tcl_PkgProvide(interp, "Tktest", TK_VERSION) == TCL_ERROR) { + return TCL_ERROR; + } + + Tcl_CreateCommand(interp, "square", SquareCmd, + (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL); +#ifdef __WIN32__ + Tcl_CreateCommand(interp, "testclipboard", TestclipboardCmd, + (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL); +#endif + Tcl_CreateCommand(interp, "testcbind", TestcbindCmd, + (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_CreateCommand(interp, "testmakeexist", TestmakeexistCmd, + (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testmenubar", TestmenubarCmd, + (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL); +#if defined(__WIN32__) || defined(MAC_TCL) + Tcl_CreateCommand(interp, "testmetrics", TestmetricsCmd, + (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL); +#endif + Tcl_CreateCommand(interp, "testprop", TestpropCmd, + (ClientData) Tk_MainWindow(interp), (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testsend", TestsendCmd, + (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); +#endif + +/* + * Create test image type. + */ + + if (!initialized) { + initialized = 1; + Tk_CreateImageType(&imageType); + } + + /* + * And finally add any platform specific test commands. + */ + + return TkplatformtestInit(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 + * a set of functions for testing C bindings in tkBind.c. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Depends on option; see below. + * + *---------------------------------------------------------------------- + */ + +static int +TestcbindCmd(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; + Tk_Window tkwin; + ClientData object; + CBinding *cbindPtr; + + + if (argc < 4 || argc > 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " bindtag pattern command ?deletecommand?", (char *) NULL); + return TCL_ERROR; + } + + tkwin = (Tk_Window) clientData; + + if (argv[1][0] == '.') { + winPtr = (TkWindow *) Tk_NameToWindow(interp, argv[1], tkwin); + if (winPtr == NULL) { + return TCL_ERROR; + } + object = (ClientData) winPtr->pathName; + } else { + winPtr = (TkWindow *) clientData; + object = (ClientData) Tk_GetUid(argv[1]); + } + + if (argv[3][0] == '\0') { + return Tk_DeleteBinding(interp, winPtr->mainPtr->bindingTable, + object, argv[2]); + } + + cbindPtr = (CBinding *) ckalloc(sizeof(CBinding)); + cbindPtr->interp = interp; + cbindPtr->command = + strcpy((char *) ckalloc(strlen(argv[3]) + 1), argv[3]); + if (argc == 4) { + cbindPtr->delete = NULL; + } else { + cbindPtr->delete = + strcpy((char *) ckalloc(strlen(argv[4]) + 1), argv[4]); + } + + if (TkCreateBindingProcedure(interp, winPtr->mainPtr->bindingTable, + object, argv[2], CBindingEvalProc, CBindingFreeProc, + (ClientData) cbindPtr) == 0) { + ckfree((char *) cbindPtr->command); + if (cbindPtr->delete != NULL) { + ckfree((char *) cbindPtr->delete); + } + ckfree((char *) cbindPtr); + return TCL_ERROR; + } + return TCL_OK; +} + +static int +CBindingEvalProc(clientData, interp, eventPtr, tkwin, keySym) + ClientData clientData; + Tcl_Interp *interp; + XEvent *eventPtr; + Tk_Window tkwin; + KeySym keySym; +{ + CBinding *cbindPtr; + + cbindPtr = (CBinding *) clientData; + + return Tcl_GlobalEval(interp, cbindPtr->command); +} + +static void +CBindingFreeProc(clientData) + ClientData clientData; +{ + CBinding *cbindPtr = (CBinding *) clientData; + + if (cbindPtr->delete != NULL) { + Tcl_GlobalEval(cbindPtr->interp, cbindPtr->delete); + ckfree((char *) cbindPtr->delete); + } + ckfree((char *) cbindPtr->command); + ckfree((char *) cbindPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TestdeleteappsCmd -- + * + * This procedure implements the "testdeleteapps" command. It cleans + * up all the interpreters left behind by the "testnewapp" command. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * All the intepreters created by previous calls to "testnewapp" + * get deleted. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestdeleteappsCmd(clientData, interp, argc, argv) + ClientData clientData; /* Main window for application. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + NewApp *nextPtr; + + while (newAppPtr != NULL) { + nextPtr = newAppPtr->nextPtr; + Tcl_DeleteInterp(newAppPtr->interp); + ckfree((char *) newAppPtr); + newAppPtr = nextPtr; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ImageCreate -- + * + * This procedure is called by the Tk image code to create "test" + * images. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * The data structure for a new image is allocated. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +ImageCreate(interp, name, argc, argv, typePtr, master, clientDataPtr) + Tcl_Interp *interp; /* Interpreter for application containing + * image. */ + char *name; /* Name to use for image. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings for options (doesn't + * include image name or type). */ + Tk_ImageType *typePtr; /* Pointer to our type record (not used). */ + Tk_ImageMaster master; /* Token for image, to be used by us in + * later callbacks. */ + ClientData *clientDataPtr; /* Store manager's token for image here; + * it will be returned in later callbacks. */ +{ + TImageMaster *timPtr; + char *varName; + int i; + + varName = "log"; + for (i = 0; i < argc; i += 2) { + if (strcmp(argv[i], "-variable") != 0) { + Tcl_AppendResult(interp, "bad option name \"", argv[i], + "\"", (char *) NULL); + return TCL_ERROR; + } + if ((i+1) == argc) { + Tcl_AppendResult(interp, "no value given for \"", argv[i], + "\" option", (char *) NULL); + return TCL_ERROR; + } + varName = argv[i+1]; + } + timPtr = (TImageMaster *) ckalloc(sizeof(TImageMaster)); + timPtr->master = master; + timPtr->interp = interp; + timPtr->width = 30; + timPtr->height = 15; + timPtr->imageName = (char *) ckalloc((unsigned) (strlen(name) + 1)); + strcpy(timPtr->imageName, name); + timPtr->varName = (char *) ckalloc((unsigned) (strlen(varName) + 1)); + strcpy(timPtr->varName, varName); + Tcl_CreateCommand(interp, name, ImageCmd, (ClientData) timPtr, + (Tcl_CmdDeleteProc *) NULL); + *clientDataPtr = (ClientData) timPtr; + Tk_ImageChanged(master, 0, 0, 30, 15, 30, 15); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ImageCmd -- + * + * This procedure implements the commands corresponding to individual + * images. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Forces windows to be created. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +ImageCmd(clientData, interp, argc, argv) + ClientData clientData; /* Main window for application. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + TImageMaster *timPtr = (TImageMaster *) clientData; + int x, y, width, height; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], "option ?arg arg ...?", (char *) NULL); + return TCL_ERROR; + } + 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", + (char *) NULL); + return TCL_ERROR; + } + if ((Tcl_GetInt(interp, argv[2], &x) != TCL_OK) + || (Tcl_GetInt(interp, argv[3], &y) != TCL_OK) + || (Tcl_GetInt(interp, argv[4], &width) != TCL_OK) + || (Tcl_GetInt(interp, argv[5], &height) != TCL_OK) + || (Tcl_GetInt(interp, argv[6], &timPtr->width) != TCL_OK) + || (Tcl_GetInt(interp, argv[7], &timPtr->height) != TCL_OK)) { + return TCL_ERROR; + } + Tk_ImageChanged(timPtr->master, x, y, width, height, timPtr->width, + timPtr->height); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be changed", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ImageGet -- + * + * This procedure is called by Tk to set things up for using a + * test image in a particular widget. + * + * Results: + * The return value is a token for the image instance, which is + * used in future callbacks to ImageDisplay and ImageFree. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static ClientData +ImageGet(tkwin, clientData) + Tk_Window tkwin; /* Token for window in which image will + * be used. */ + ClientData clientData; /* Pointer to TImageMaster for image. */ +{ + TImageMaster *timPtr = (TImageMaster *) clientData; + TImageInstance *instPtr; + char buffer[100]; + XGCValues gcValues; + + sprintf(buffer, "%s get", timPtr->imageName); + Tcl_SetVar(timPtr->interp, timPtr->varName, buffer, + TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT); + + instPtr = (TImageInstance *) ckalloc(sizeof(TImageInstance)); + instPtr->masterPtr = timPtr; + instPtr->fg = Tk_GetColor(timPtr->interp, tkwin, "#ff0000"); + gcValues.foreground = instPtr->fg->pixel; + instPtr->gc = Tk_GetGC(tkwin, GCForeground, &gcValues); + return (ClientData) instPtr; +} + +/* + *---------------------------------------------------------------------- + * + * ImageDisplay -- + * + * This procedure is invoked to redisplay part or all of an + * image in a given drawable. + * + * Results: + * None. + * + * Side effects: + * The image gets partially redrawn, as an "X" that shows the + * exact redraw area. + * + *---------------------------------------------------------------------- + */ + +static void +ImageDisplay(clientData, display, drawable, imageX, imageY, width, height, + drawableX, drawableY) + ClientData clientData; /* Pointer to TImageInstance for image. */ + Display *display; /* Display to use for drawing. */ + Drawable drawable; /* Where to redraw image. */ + int imageX, imageY; /* Origin of area to redraw, relative to + * origin of image. */ + int width, height; /* Dimensions of area to redraw. */ + int drawableX, drawableY; /* Coordinates in drawable corresponding to + * imageX and imageY. */ +{ + TImageInstance *instPtr = (TImageInstance *) clientData; + char buffer[200]; + + sprintf(buffer, "%s display %d %d %d %d %d %d", + instPtr->masterPtr->imageName, imageX, imageY, width, height, + drawableX, drawableY); + Tcl_SetVar(instPtr->masterPtr->interp, instPtr->masterPtr->varName, buffer, + TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT); + if (width > (instPtr->masterPtr->width - imageX)) { + width = instPtr->masterPtr->width - imageX; + } + if (height > (instPtr->masterPtr->height - imageY)) { + height = instPtr->masterPtr->height - imageY; + } + XDrawRectangle(display, drawable, instPtr->gc, drawableX, drawableY, + (unsigned) (width-1), (unsigned) (height-1)); + XDrawLine(display, drawable, instPtr->gc, drawableX, drawableY, + (int) (drawableX + width - 1), (int) (drawableY + height - 1)); + XDrawLine(display, drawable, instPtr->gc, drawableX, + (int) (drawableY + height - 1), + (int) (drawableX + width - 1), drawableY); +} + +/* + *---------------------------------------------------------------------- + * + * ImageFree -- + * + * This procedure is called when an instance of an image is + * no longer used. + * + * Results: + * None. + * + * Side effects: + * Information related to the instance is freed. + * + *---------------------------------------------------------------------- + */ + +static void +ImageFree(clientData, display) + ClientData clientData; /* Pointer to TImageInstance for instance. */ + Display *display; /* Display where image was to be drawn. */ +{ + TImageInstance *instPtr = (TImageInstance *) clientData; + char buffer[200]; + + sprintf(buffer, "%s free", instPtr->masterPtr->imageName); + Tcl_SetVar(instPtr->masterPtr->interp, instPtr->masterPtr->varName, buffer, + TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT); + Tk_FreeColor(instPtr->fg); + Tk_FreeGC(display, instPtr->gc); + ckfree((char *) instPtr); +} + +/* + *---------------------------------------------------------------------- + * + * ImageDelete -- + * + * This procedure is called to clean up a test image when + * an application goes away. + * + * Results: + * None. + * + * Side effects: + * Information about the image is deleted. + * + *---------------------------------------------------------------------- + */ + +static void +ImageDelete(clientData) + ClientData clientData; /* Pointer to TImageMaster for image. When + * this procedure is called, no more + * instances exist. */ +{ + TImageMaster *timPtr = (TImageMaster *) clientData; + char buffer[100]; + + sprintf(buffer, "%s delete", timPtr->imageName); + Tcl_SetVar(timPtr->interp, timPtr->varName, buffer, + TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT); + + Tcl_DeleteCommand(timPtr->interp, timPtr->imageName); + ckfree(timPtr->imageName); + ckfree(timPtr->varName); + ckfree((char *) timPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TestmakeexistCmd -- + * + * This procedure implements the "testmakeexist" command. It calls + * Tk_MakeWindowExist on each of its arguments to force the windows + * to be created. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Forces windows to be created. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestmakeexistCmd(clientData, interp, argc, argv) + ClientData clientData; /* Main window for application. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tk_Window main = (Tk_Window) clientData; + int i; + Tk_Window tkwin; + + for (i = 1; i < argc; i++) { + tkwin = Tk_NameToWindow(interp, argv[i], main); + if (tkwin == NULL) { + return TCL_ERROR; + } + Tk_MakeWindowExist(tkwin); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestmenubarCmd -- + * + * This procedure implements the "testmenubar" command. It is used + * to test the Unix facilities for creating space above a toplevel + * window for a menubar. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Changes menubar related stuff. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestmenubarCmd(clientData, interp, argc, argv) + ClientData clientData; /* Main window for application. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ +#ifdef __UNIX__ + Tk_Window main = (Tk_Window) clientData; + Tk_Window tkwin, menubar; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args; must be \"", argv[0], + " option ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + + if (strcmp(argv[1], "window") == 0) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args; must be \"", argv[0], + "window toplevel menubar\"", (char *) NULL); + return TCL_ERROR; + } + tkwin = Tk_NameToWindow(interp, argv[2], main); + if (tkwin == NULL) { + return TCL_ERROR; + } + if (argv[3][0] == 0) { + TkUnixSetMenubar(tkwin, NULL); + } else { + menubar = Tk_NameToWindow(interp, argv[3], main); + if (menubar == NULL) { + return TCL_ERROR; + } + TkUnixSetMenubar(tkwin, menubar); + } + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be window", (char *) NULL); + return TCL_ERROR; + } + + return TCL_OK; +#else + interp->result = "testmenubar is supported only under Unix"; + return TCL_ERROR; +#endif +} + +/* + *---------------------------------------------------------------------- + * + * TestmetricsCmd -- + * + * This procedure implements the testmetrics command. It provides + * a way to determine the size of various widget components. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#ifdef __WIN32__ +static int +TestmetricsCmd(clientData, interp, argc, argv) + ClientData clientData; /* Main window for application. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + char buf[200]; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args; must be \"", argv[0], + " option ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + + if (strcmp(argv[1], "cyvscroll") == 0) { + sprintf(buf, "%d", GetSystemMetrics(SM_CYVSCROLL)); + Tcl_AppendResult(interp, buf, (char *) NULL); + } else if (strcmp(argv[1], "cxhscroll") == 0) { + sprintf(buf, "%d", GetSystemMetrics(SM_CXHSCROLL)); + Tcl_AppendResult(interp, buf, (char *) NULL); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be cxhscroll or cyvscroll", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} +#endif +#ifdef MAC_TCL +static int +TestmetricsCmd(clientData, interp, argc, argv) + ClientData clientData; /* Main window for application. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tk_Window tkwin = (Tk_Window) clientData; + TkWindow *winPtr; + char buf[200]; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args; must be \"", argv[0], + " option window\"", (char *) NULL); + return TCL_ERROR; + } + + winPtr = (TkWindow *) Tk_NameToWindow(interp, argv[2], tkwin); + if (winPtr == NULL) { + return TCL_ERROR; + } + + if (strcmp(argv[1], "cyvscroll") == 0) { + sprintf(buf, "%d", ((TkScrollbar *) winPtr->instanceData)->width); + Tcl_AppendResult(interp, buf, (char *) NULL); + } else if (strcmp(argv[1], "cxhscroll") == 0) { + sprintf(buf, "%d", ((TkScrollbar *) winPtr->instanceData)->width); + Tcl_AppendResult(interp, buf, (char *) NULL); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be cxhscroll or cyvscroll", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} +#endif + +/* + *---------------------------------------------------------------------- + * + * TestpropCmd -- + * + * This procedure implements the "testprop" command. It fetches + * and prints the value of a property on a window. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestpropCmd(clientData, interp, argc, argv) + ClientData clientData; /* Main window for application. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tk_Window main = (Tk_Window) clientData; + int result, actualFormat; + unsigned long bytesAfter, length, value; + Atom actualType, propName; + char *property, *p, *end; + Window w; + char buffer[30]; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args; must be \"", argv[0], + " window property\"", (char *) NULL); + return TCL_ERROR; + } + + w = strtoul(argv[1], &end, 0); + propName = Tk_InternAtom(main, argv[2]); + property = NULL; + result = XGetWindowProperty(Tk_Display(main), + w, propName, 0, 100000, False, AnyPropertyType, + &actualType, &actualFormat, &length, + &bytesAfter, (unsigned char **) &property); + if ((result == Success) && (actualType != None)) { + if ((actualFormat == 8) && (actualType == XA_STRING)) { + for (p = property; ((unsigned long)(p-property)) < length; p++) { + if (*p == 0) { + *p = '\n'; + } + } + Tcl_SetResult(interp, property, TCL_VOLATILE); + } else { + for (p = property; length > 0; length--) { + if (actualFormat == 32) { + value = *((long *) p); + p += sizeof(long); + } else if (actualFormat == 16) { + value = 0xffff & (*((short *) p)); + p += sizeof(short); + } else { + value = 0xff & *p; + p += 1; + } + sprintf(buffer, "0x%lx", value); + Tcl_AppendElement(interp, buffer); + } + } + } + if (property != NULL) { + XFree(property); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestsendCmd -- + * + * This procedure implements the "testsend" command. It provides + * a set of functions for testing the "send" command and support + * procedure in tkSend.c. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Depends on option; see below. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestsendCmd(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; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args; must be \"", argv[0], + " option ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + +#if !(defined(__WIN32__) || defined(MAC_TCL)) + if (strcmp(argv[1], "bogus") == 0) { + XChangeProperty(winPtr->dispPtr->display, + RootWindow(winPtr->dispPtr->display, 0), + winPtr->dispPtr->registryProperty, XA_INTEGER, 32, + PropModeReplace, + (unsigned char *) "This is bogus information", 6); + } else if (strcmp(argv[1], "prop") == 0) { + int result, actualFormat; + unsigned long length, bytesAfter; + Atom actualType, propName; + char *property, *p, *end; + Window w; + + if ((argc != 4) && (argc != 5)) { + Tcl_AppendResult(interp, "wrong # args; must be \"", argv[0], + " prop window name ?value ?\"", (char *) NULL); + return TCL_ERROR; + } + if (strcmp(argv[2], "root") == 0) { + w = RootWindow(winPtr->dispPtr->display, 0); + } else if (strcmp(argv[2], "comm") == 0) { + w = Tk_WindowId(winPtr->dispPtr->commTkwin); + } else { + w = strtoul(argv[2], &end, 0); + } + propName = Tk_InternAtom((Tk_Window) winPtr, argv[3]); + if (argc == 4) { + property = NULL; + result = XGetWindowProperty(winPtr->dispPtr->display, + w, propName, 0, 100000, False, XA_STRING, + &actualType, &actualFormat, &length, + &bytesAfter, (unsigned char **) &property); + if ((result == Success) && (actualType != None) + && (actualFormat == 8) && (actualType == XA_STRING)) { + for (p = property; (p-property) < length; p++) { + if (*p == 0) { + *p = '\n'; + } + } + Tcl_SetResult(interp, property, TCL_VOLATILE); + } + if (property != NULL) { + XFree(property); + } + } else { + if (argv[4][0] == 0) { + XDeleteProperty(winPtr->dispPtr->display, w, propName); + } else { + for (p = argv[4]; *p != 0; p++) { + if (*p == '\n') { + *p = 0; + } + } + XChangeProperty(winPtr->dispPtr->display, + w, propName, XA_STRING, 8, PropModeReplace, + (unsigned char *) argv[4], p-argv[4]); + } + } + } else if (strcmp(argv[1], "serial") == 0) { + sprintf(interp->result, "%d", tkSendSerial+1); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be bogus, prop, or serial", (char *) NULL); + return TCL_ERROR; + } +#endif + return TCL_OK; +} + +#if !(defined(__WIN32__) || defined(MAC_TCL)) +/* + *---------------------------------------------------------------------- + * + * TestwrapperCmd -- + * + * This procedure implements the "testwrapper" command. It + * provides a way from Tcl to determine the extra window Tk adds + * in between the toplevel window and the window decorations. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestwrapperCmd(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, *wrapperPtr; + Tk_Window tkwin; + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args; must be \"", argv[0], + " window\"", (char *) NULL); + return TCL_ERROR; + } + + tkwin = (Tk_Window) clientData; + winPtr = (TkWindow *) Tk_NameToWindow(interp, argv[1], tkwin); + if (winPtr == NULL) { + return TCL_ERROR; + } + + wrapperPtr = TkpGetWrapperWindow(winPtr); + if (wrapperPtr != NULL) { + TkpPrintWindowId(interp->result, Tk_WindowId(wrapperPtr)); + } + return TCL_OK; +} +#endif diff --git a/generic/tkText.c b/generic/tkText.c new file mode 100644 index 0000000..643aea0 --- /dev/null +++ b/generic/tkText.c @@ -0,0 +1,2264 @@ +/* + * tkText.c -- + * + * This module provides a big chunk of the implementation of + * multi-line editable text widgets for Tk. Among other things, + * it provides the Tcl command interfaces to text widgets and + * the display code. The B-tree representation of text is + * implemented elsewhere. + * + * Copyright (c) 1992-1994 The Regents of the University of California. + * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkText.c 1.104 97/10/13 15:18:24 + */ + +#include "default.h" +#include "tkPort.h" +#include "tkInt.h" + +#ifdef MAC_TCL +#define Style TkStyle +#define DInfo TkDInfo +#endif + +#include "tkText.h" + +/* + * Information used to parse text configuration options: + */ + +static Tk_ConfigSpec configSpecs[] = { + {TK_CONFIG_BORDER, "-background", "background", "Background", + DEF_TEXT_BG_COLOR, Tk_Offset(TkText, border), TK_CONFIG_COLOR_ONLY}, + {TK_CONFIG_BORDER, "-background", "background", "Background", + DEF_TEXT_BG_MONO, Tk_Offset(TkText, 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_TEXT_BORDER_WIDTH, Tk_Offset(TkText, borderWidth), 0}, + {TK_CONFIG_ACTIVE_CURSOR, "-cursor", "cursor", "Cursor", + DEF_TEXT_CURSOR, Tk_Offset(TkText, cursor), TK_CONFIG_NULL_OK}, + {TK_CONFIG_BOOLEAN, "-exportselection", "exportSelection", + "ExportSelection", DEF_TEXT_EXPORT_SELECTION, + Tk_Offset(TkText, exportSelection), 0}, + {TK_CONFIG_SYNONYM, "-fg", "foreground", (char *) NULL, + (char *) NULL, 0, 0}, + {TK_CONFIG_FONT, "-font", "font", "Font", + DEF_TEXT_FONT, Tk_Offset(TkText, tkfont), 0}, + {TK_CONFIG_COLOR, "-foreground", "foreground", "Foreground", + DEF_TEXT_FG, Tk_Offset(TkText, fgColor), 0}, + {TK_CONFIG_PIXELS, "-height", "height", "Height", + DEF_TEXT_HEIGHT, Tk_Offset(TkText, height), 0}, + {TK_CONFIG_COLOR, "-highlightbackground", "highlightBackground", + "HighlightBackground", DEF_TEXT_HIGHLIGHT_BG, + Tk_Offset(TkText, highlightBgColorPtr), 0}, + {TK_CONFIG_COLOR, "-highlightcolor", "highlightColor", "HighlightColor", + DEF_TEXT_HIGHLIGHT, Tk_Offset(TkText, highlightColorPtr), 0}, + {TK_CONFIG_PIXELS, "-highlightthickness", "highlightThickness", + "HighlightThickness", + DEF_TEXT_HIGHLIGHT_WIDTH, Tk_Offset(TkText, highlightWidth), 0}, + {TK_CONFIG_BORDER, "-insertbackground", "insertBackground", "Foreground", + DEF_TEXT_INSERT_BG, Tk_Offset(TkText, insertBorder), 0}, + {TK_CONFIG_PIXELS, "-insertborderwidth", "insertBorderWidth", "BorderWidth", + DEF_TEXT_INSERT_BD_COLOR, Tk_Offset(TkText, insertBorderWidth), + TK_CONFIG_COLOR_ONLY}, + {TK_CONFIG_PIXELS, "-insertborderwidth", "insertBorderWidth", "BorderWidth", + DEF_TEXT_INSERT_BD_MONO, Tk_Offset(TkText, insertBorderWidth), + TK_CONFIG_MONO_ONLY}, + {TK_CONFIG_INT, "-insertofftime", "insertOffTime", "OffTime", + DEF_TEXT_INSERT_OFF_TIME, Tk_Offset(TkText, insertOffTime), 0}, + {TK_CONFIG_INT, "-insertontime", "insertOnTime", "OnTime", + DEF_TEXT_INSERT_ON_TIME, Tk_Offset(TkText, insertOnTime), 0}, + {TK_CONFIG_PIXELS, "-insertwidth", "insertWidth", "InsertWidth", + DEF_TEXT_INSERT_WIDTH, Tk_Offset(TkText, insertWidth), 0}, + {TK_CONFIG_PIXELS, "-padx", "padX", "Pad", + DEF_TEXT_PADX, Tk_Offset(TkText, padX), 0}, + {TK_CONFIG_PIXELS, "-pady", "padY", "Pad", + DEF_TEXT_PADY, Tk_Offset(TkText, padY), 0}, + {TK_CONFIG_RELIEF, "-relief", "relief", "Relief", + DEF_TEXT_RELIEF, Tk_Offset(TkText, relief), 0}, + {TK_CONFIG_BORDER, "-selectbackground", "selectBackground", "Foreground", + DEF_TEXT_SELECT_COLOR, Tk_Offset(TkText, selBorder), + TK_CONFIG_COLOR_ONLY}, + {TK_CONFIG_BORDER, "-selectbackground", "selectBackground", "Foreground", + DEF_TEXT_SELECT_MONO, Tk_Offset(TkText, selBorder), + TK_CONFIG_MONO_ONLY}, + {TK_CONFIG_STRING, "-selectborderwidth", "selectBorderWidth", "BorderWidth", + DEF_TEXT_SELECT_BD_COLOR, Tk_Offset(TkText, selBdString), + TK_CONFIG_COLOR_ONLY|TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-selectborderwidth", "selectBorderWidth", "BorderWidth", + DEF_TEXT_SELECT_BD_MONO, Tk_Offset(TkText, selBdString), + TK_CONFIG_MONO_ONLY|TK_CONFIG_NULL_OK}, + {TK_CONFIG_COLOR, "-selectforeground", "selectForeground", "Background", + DEF_TEXT_SELECT_FG_COLOR, Tk_Offset(TkText, selFgColorPtr), + TK_CONFIG_COLOR_ONLY}, + {TK_CONFIG_COLOR, "-selectforeground", "selectForeground", "Background", + DEF_TEXT_SELECT_FG_MONO, Tk_Offset(TkText, selFgColorPtr), + TK_CONFIG_MONO_ONLY}, + {TK_CONFIG_BOOLEAN, "-setgrid", "setGrid", "SetGrid", + DEF_TEXT_SET_GRID, Tk_Offset(TkText, setGrid), 0}, + {TK_CONFIG_PIXELS, "-spacing1", "spacing1", "Spacing", + DEF_TEXT_SPACING1, Tk_Offset(TkText, spacing1), + TK_CONFIG_DONT_SET_DEFAULT}, + {TK_CONFIG_PIXELS, "-spacing2", "spacing2", "Spacing", + DEF_TEXT_SPACING2, Tk_Offset(TkText, spacing2), + TK_CONFIG_DONT_SET_DEFAULT}, + {TK_CONFIG_PIXELS, "-spacing3", "spacing3", "Spacing", + DEF_TEXT_SPACING3, Tk_Offset(TkText, spacing3), + TK_CONFIG_DONT_SET_DEFAULT}, + {TK_CONFIG_UID, "-state", "state", "State", + DEF_TEXT_STATE, Tk_Offset(TkText, state), 0}, + {TK_CONFIG_STRING, "-tabs", "tabs", "Tabs", + DEF_TEXT_TABS, Tk_Offset(TkText, tabOptionString), TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-takefocus", "takeFocus", "TakeFocus", + DEF_TEXT_TAKE_FOCUS, Tk_Offset(TkText, takeFocus), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_INT, "-width", "width", "Width", + DEF_TEXT_WIDTH, Tk_Offset(TkText, width), 0}, + {TK_CONFIG_UID, "-wrap", "wrap", "Wrap", + DEF_TEXT_WRAP, Tk_Offset(TkText, wrapMode), 0}, + {TK_CONFIG_STRING, "-xscrollcommand", "xScrollCommand", "ScrollCommand", + DEF_TEXT_XSCROLL_COMMAND, Tk_Offset(TkText, xScrollCmd), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-yscrollcommand", "yScrollCommand", "ScrollCommand", + DEF_TEXT_YSCROLL_COMMAND, Tk_Offset(TkText, yScrollCmd), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, 0} +}; + +/* + * Tk_Uid's used to represent text states: + */ + +Tk_Uid tkTextCharUid = NULL; +Tk_Uid tkTextDisabledUid = NULL; +Tk_Uid tkTextNoneUid = NULL; +Tk_Uid tkTextNormalUid = NULL; +Tk_Uid tkTextWordUid = NULL; + +/* + * Boolean variable indicating whether or not special debugging code + * should be executed. + */ + +int tkTextDebug = 0; + +/* + * Forward declarations for procedures defined later in this file: + */ + +static int ConfigureText _ANSI_ARGS_((Tcl_Interp *interp, + TkText *textPtr, int argc, char **argv, int flags)); +static int DeleteChars _ANSI_ARGS_((TkText *textPtr, + char *index1String, char *index2String)); +static void DestroyText _ANSI_ARGS_((char *memPtr)); +static void InsertChars _ANSI_ARGS_((TkText *textPtr, + TkTextIndex *indexPtr, char *string)); +static void TextBlinkProc _ANSI_ARGS_((ClientData clientData)); +static void TextCmdDeletedProc _ANSI_ARGS_(( + ClientData clientData)); +static void TextEventProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +static int TextFetchSelection _ANSI_ARGS_((ClientData clientData, + int offset, char *buffer, int maxBytes)); +static int TextSearchCmd _ANSI_ARGS_((TkText *textPtr, + Tcl_Interp *interp, int argc, char **argv)); +static int TextWidgetCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static void TextWorldChanged _ANSI_ARGS_(( + ClientData instanceData)); +static int TextDumpCmd _ANSI_ARGS_((TkText *textPtr, + Tcl_Interp *interp, int argc, char **argv)); +static void DumpLine _ANSI_ARGS_((Tcl_Interp *interp, + TkText *textPtr, int what, TkTextLine *linePtr, + int start, int end, int lineno, char *command)); +static int DumpSegment _ANSI_ARGS_((Tcl_Interp *interp, char *key, + char *value, char * command, int lineno, int offset, + int what)); + +/* + * The structure below defines text class behavior by means of procedures + * that can be invoked from generic window code. + */ + +static TkClassProcs textClass = { + NULL, /* createProc. */ + TextWorldChanged, /* geometryProc. */ + NULL /* modalProc. */ +}; + + +/* + *-------------------------------------------------------------- + * + * Tk_TextCmd -- + * + * This procedure is invoked to process the "text" 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_TextCmd(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; + Tk_Window new; + register TkText *textPtr; + TkTextIndex startIndex; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " pathName ?options?\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * Perform once-only initialization: + */ + + if (tkTextNormalUid == NULL) { + tkTextCharUid = Tk_GetUid("char"); + tkTextDisabledUid = Tk_GetUid("disabled"); + tkTextNoneUid = Tk_GetUid("none"); + tkTextNormalUid = Tk_GetUid("normal"); + tkTextWordUid = Tk_GetUid("word"); + } + + /* + * Create the window. + */ + + new = Tk_CreateWindowFromPath(interp, tkwin, argv[1], (char *) NULL); + if (new == NULL) { + return TCL_ERROR; + } + + textPtr = (TkText *) ckalloc(sizeof(TkText)); + textPtr->tkwin = new; + textPtr->display = Tk_Display(new); + textPtr->interp = interp; + textPtr->widgetCmd = Tcl_CreateCommand(interp, + Tk_PathName(textPtr->tkwin), TextWidgetCmd, + (ClientData) textPtr, TextCmdDeletedProc); + textPtr->tree = TkBTreeCreate(textPtr); + Tcl_InitHashTable(&textPtr->tagTable, TCL_STRING_KEYS); + textPtr->numTags = 0; + Tcl_InitHashTable(&textPtr->markTable, TCL_STRING_KEYS); + Tcl_InitHashTable(&textPtr->windowTable, TCL_STRING_KEYS); + Tcl_InitHashTable(&textPtr->imageTable, TCL_STRING_KEYS); + textPtr->state = tkTextNormalUid; + textPtr->border = NULL; + textPtr->borderWidth = 0; + textPtr->padX = 0; + textPtr->padY = 0; + textPtr->relief = TK_RELIEF_FLAT; + textPtr->highlightWidth = 0; + textPtr->highlightBgColorPtr = NULL; + textPtr->highlightColorPtr = NULL; + textPtr->cursor = None; + textPtr->fgColor = NULL; + textPtr->tkfont = NULL; + textPtr->charWidth = 1; + textPtr->spacing1 = 0; + textPtr->spacing2 = 0; + textPtr->spacing3 = 0; + textPtr->tabOptionString = NULL; + textPtr->tabArrayPtr = NULL; + textPtr->wrapMode = tkTextCharUid; + textPtr->width = 0; + textPtr->height = 0; + textPtr->setGrid = 0; + textPtr->prevWidth = Tk_Width(new); + textPtr->prevHeight = Tk_Height(new); + TkTextCreateDInfo(textPtr); + TkTextMakeIndex(textPtr->tree, 0, 0, &startIndex); + TkTextSetYView(textPtr, &startIndex, 0); + textPtr->selTagPtr = NULL; + textPtr->selBorder = NULL; + textPtr->selBdString = NULL; + textPtr->selFgColorPtr = NULL; + textPtr->exportSelection = 1; + textPtr->abortSelections = 0; + textPtr->insertMarkPtr = NULL; + textPtr->insertBorder = NULL; + textPtr->insertWidth = 0; + textPtr->insertBorderWidth = 0; + textPtr->insertOnTime = 0; + textPtr->insertOffTime = 0; + textPtr->insertBlinkHandler = (Tcl_TimerToken) NULL; + textPtr->bindingTable = NULL; + textPtr->currentMarkPtr = NULL; + textPtr->pickEvent.type = LeaveNotify; + textPtr->pickEvent.xcrossing.x = 0; + textPtr->pickEvent.xcrossing.y = 0; + textPtr->numCurTags = 0; + textPtr->curTagArrayPtr = NULL; + textPtr->takeFocus = NULL; + textPtr->xScrollCmd = NULL; + textPtr->yScrollCmd = NULL; + textPtr->flags = 0; + + /* + * Create the "sel" tag and the "current" and "insert" marks. + */ + + textPtr->selTagPtr = TkTextCreateTag(textPtr, "sel"); + textPtr->selTagPtr->reliefString = (char *) ckalloc(7); + strcpy(textPtr->selTagPtr->reliefString, DEF_TEXT_SELECT_RELIEF); + textPtr->selTagPtr->relief = TK_RELIEF_RAISED; + textPtr->currentMarkPtr = TkTextSetMark(textPtr, "current", &startIndex); + textPtr->insertMarkPtr = TkTextSetMark(textPtr, "insert", &startIndex); + + Tk_SetClass(textPtr->tkwin, "Text"); + TkSetClassProcs(textPtr->tkwin, &textClass, (ClientData) textPtr); + Tk_CreateEventHandler(textPtr->tkwin, + ExposureMask|StructureNotifyMask|FocusChangeMask, + TextEventProc, (ClientData) textPtr); + Tk_CreateEventHandler(textPtr->tkwin, KeyPressMask|KeyReleaseMask + |ButtonPressMask|ButtonReleaseMask|EnterWindowMask + |LeaveWindowMask|PointerMotionMask|VirtualEventMask, + TkTextBindProc, (ClientData) textPtr); + Tk_CreateSelHandler(textPtr->tkwin, XA_PRIMARY, XA_STRING, + TextFetchSelection, (ClientData) textPtr, XA_STRING); + if (ConfigureText(interp, textPtr, argc-2, argv+2, 0) != TCL_OK) { + Tk_DestroyWindow(textPtr->tkwin); + return TCL_ERROR; + } + interp->result = Tk_PathName(textPtr->tkwin); + + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * TextWidgetCmd -- + * + * This procedure is invoked to process the Tcl command + * that corresponds to a text widget. See the user + * documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +static int +TextWidgetCmd(clientData, interp, argc, argv) + ClientData clientData; /* Information about text widget. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + register TkText *textPtr = (TkText *) clientData; + int result = TCL_OK; + size_t length; + int c; + TkTextIndex index1, index2; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " option ?arg arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_Preserve((ClientData) textPtr); + c = argv[1][0]; + length = strlen(argv[1]); + if ((c == 'b') && (strncmp(argv[1], "bbox", length) == 0)) { + int x, y, width, height; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " bbox index\"", (char *) NULL); + result = TCL_ERROR; + goto done; + } + if (TkTextGetIndex(interp, textPtr, argv[2], &index1) != TCL_OK) { + result = TCL_ERROR; + goto done; + } + if (TkTextCharBbox(textPtr, &index1, &x, &y, &width, &height) == 0) { + sprintf(interp->result, "%d %d %d %d", x, y, width, height); + } + } 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); + result = TCL_ERROR; + goto done; + } + result = Tk_ConfigureValue(interp, textPtr->tkwin, configSpecs, + (char *) textPtr, argv[2], 0); + } else if ((c == 'c') && (strncmp(argv[1], "compare", length) == 0) + && (length >= 3)) { + int relation, value; + char *p; + + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " compare index1 op index2\"", (char *) NULL); + result = TCL_ERROR; + goto done; + } + if ((TkTextGetIndex(interp, textPtr, argv[2], &index1) != TCL_OK) + || (TkTextGetIndex(interp, textPtr, argv[4], &index2) + != TCL_OK)) { + result = TCL_ERROR; + goto done; + } + relation = TkTextIndexCmp(&index1, &index2); + p = argv[3]; + if (p[0] == '<') { + value = (relation < 0); + if ((p[1] == '=') && (p[2] == 0)) { + value = (relation <= 0); + } else if (p[1] != 0) { + compareError: + Tcl_AppendResult(interp, "bad comparison operator \"", + argv[3], "\": must be <, <=, ==, >=, >, or !=", + (char *) NULL); + result = TCL_ERROR; + goto done; + } + } else if (p[0] == '>') { + value = (relation > 0); + if ((p[1] == '=') && (p[2] == 0)) { + value = (relation >= 0); + } else if (p[1] != 0) { + goto compareError; + } + } else if ((p[0] == '=') && (p[1] == '=') && (p[2] == 0)) { + value = (relation == 0); + } else if ((p[0] == '!') && (p[1] == '=') && (p[2] == 0)) { + value = (relation != 0); + } else { + goto compareError; + } + interp->result = (value) ? "1" : "0"; + } else if ((c == 'c') && (strncmp(argv[1], "configure", length) == 0) + && (length >= 3)) { + if (argc == 2) { + result = Tk_ConfigureInfo(interp, textPtr->tkwin, configSpecs, + (char *) textPtr, (char *) NULL, 0); + } else if (argc == 3) { + result = Tk_ConfigureInfo(interp, textPtr->tkwin, configSpecs, + (char *) textPtr, argv[2], 0); + } else { + result = ConfigureText(interp, textPtr, argc-2, argv+2, + TK_CONFIG_ARGV_ONLY); + } + } else if ((c == 'd') && (strncmp(argv[1], "debug", length) == 0) + && (length >= 3)) { + if (argc > 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " debug boolean\"", (char *) NULL); + result = TCL_ERROR; + goto done; + } + if (argc == 2) { + interp->result = (tkBTreeDebug) ? "1" : "0"; + } else { + if (Tcl_GetBoolean(interp, argv[2], &tkBTreeDebug) != TCL_OK) { + result = TCL_ERROR; + goto done; + } + tkTextDebug = tkBTreeDebug; + } + } else if ((c == 'd') && (strncmp(argv[1], "delete", length) == 0) + && (length >= 3)) { + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " delete index1 ?index2?\"", (char *) NULL); + result = TCL_ERROR; + goto done; + } + if (textPtr->state == tkTextNormalUid) { + result = DeleteChars(textPtr, argv[2], + (argc == 4) ? argv[3] : (char *) NULL); + } + } else if ((c == 'd') && (strncmp(argv[1], "dlineinfo", length) == 0) + && (length >= 2)) { + int x, y, width, height, base; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " dlineinfo index\"", (char *) NULL); + result = TCL_ERROR; + goto done; + } + if (TkTextGetIndex(interp, textPtr, argv[2], &index1) != TCL_OK) { + result = TCL_ERROR; + goto done; + } + if (TkTextDLineInfo(textPtr, &index1, &x, &y, &width, &height, &base) + == 0) { + sprintf(interp->result, "%d %d %d %d %d", x, y, width, + height, base); + } + } else if ((c == 'g') && (strncmp(argv[1], "get", length) == 0)) { + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " get index1 ?index2?\"", (char *) NULL); + result = TCL_ERROR; + goto done; + } + if (TkTextGetIndex(interp, textPtr, argv[2], &index1) != TCL_OK) { + result = TCL_ERROR; + goto done; + } + if (argc == 3) { + index2 = index1; + TkTextIndexForwChars(&index2, 1, &index2); + } else if (TkTextGetIndex(interp, textPtr, argv[3], &index2) + != TCL_OK) { + result = TCL_ERROR; + goto done; + } + if (TkTextIndexCmp(&index1, &index2) >= 0) { + goto done; + } + while (1) { + int offset, last, savedChar; + TkTextSegment *segPtr; + + segPtr = TkTextIndexToSeg(&index1, &offset); + last = segPtr->size; + if (index1.linePtr == index2.linePtr) { + int last2; + + if (index2.charIndex == index1.charIndex) { + break; + } + last2 = index2.charIndex - index1.charIndex + offset; + if (last2 < last) { + last = last2; + } + } + if (segPtr->typePtr == &tkTextCharType) { + savedChar = segPtr->body.chars[last]; + segPtr->body.chars[last] = 0; + Tcl_AppendResult(interp, segPtr->body.chars + offset, + (char *) NULL); + segPtr->body.chars[last] = savedChar; + } + TkTextIndexForwChars(&index1, last-offset, &index1); + } + } else if ((c == 'i') && (strncmp(argv[1], "index", length) == 0) + && (length >= 3)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " index index\"", + (char *) NULL); + result = TCL_ERROR; + goto done; + } + if (TkTextGetIndex(interp, textPtr, argv[2], &index1) != TCL_OK) { + result = TCL_ERROR; + goto done; + } + TkTextPrintIndex(&index1, interp->result); + } else if ((c == 'i') && (strncmp(argv[1], "insert", length) == 0) + && (length >= 3)) { + int i, j, numTags; + char **tagNames; + TkTextTag **oldTagArrayPtr; + + if (argc < 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], + " insert index chars ?tagList chars tagList ...?\"", + (char *) NULL); + result = TCL_ERROR; + goto done; + } + if (TkTextGetIndex(interp, textPtr, argv[2], &index1) != TCL_OK) { + result = TCL_ERROR; + goto done; + } + if (textPtr->state == tkTextNormalUid) { + for (j = 3; j < argc; j += 2) { + InsertChars(textPtr, &index1, argv[j]); + if (argc > (j+1)) { + TkTextIndexForwChars(&index1, (int) strlen(argv[j]), + &index2); + oldTagArrayPtr = TkBTreeGetTags(&index1, &numTags); + if (oldTagArrayPtr != NULL) { + for (i = 0; i < numTags; i++) { + TkBTreeTag(&index1, &index2, oldTagArrayPtr[i], 0); + } + ckfree((char *) oldTagArrayPtr); + } + if (Tcl_SplitList(interp, argv[j+1], &numTags, &tagNames) + != TCL_OK) { + result = TCL_ERROR; + goto done; + } + for (i = 0; i < numTags; i++) { + TkBTreeTag(&index1, &index2, + TkTextCreateTag(textPtr, tagNames[i]), 1); + } + ckfree((char *) tagNames); + index1 = index2; + } + } + } + } else if ((c == 'd') && (strncmp(argv[1], "dump", length) == 0)) { + result = TextDumpCmd(textPtr, interp, argc, argv); + } else if ((c == 'i') && (strncmp(argv[1], "image", length) == 0)) { + result = TkTextImageCmd(textPtr, interp, argc, argv); + } else if ((c == 'm') && (strncmp(argv[1], "mark", length) == 0)) { + result = TkTextMarkCmd(textPtr, interp, argc, argv); + } else if ((c == 's') && (strcmp(argv[1], "scan") == 0) && (length >= 2)) { + result = TkTextScanCmd(textPtr, interp, argc, argv); + } else if ((c == 's') && (strcmp(argv[1], "search") == 0) + && (length >= 3)) { + result = TextSearchCmd(textPtr, interp, argc, argv); + } else if ((c == 's') && (strcmp(argv[1], "see") == 0) && (length >= 3)) { + result = TkTextSeeCmd(textPtr, interp, argc, argv); + } else if ((c == 't') && (strcmp(argv[1], "tag") == 0)) { + result = TkTextTagCmd(textPtr, interp, argc, argv); + } else if ((c == 'w') && (strncmp(argv[1], "window", length) == 0)) { + result = TkTextWindowCmd(textPtr, interp, argc, argv); + } else if ((c == 'x') && (strncmp(argv[1], "xview", length) == 0)) { + result = TkTextXviewCmd(textPtr, interp, argc, argv); + } else if ((c == 'y') && (strncmp(argv[1], "yview", length) == 0) + && (length >= 2)) { + result = TkTextYviewCmd(textPtr, interp, argc, argv); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be bbox, cget, compare, configure, debug, delete, ", + "dlineinfo, get, image, index, insert, mark, scan, search, see, ", + "tag, window, xview, or yview", + (char *) NULL); + result = TCL_ERROR; + } + + done: + Tcl_Release((ClientData) textPtr); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * DestroyText -- + * + * This procedure is invoked by Tcl_EventuallyFree or Tcl_Release + * to clean up the internal structure of a text at a safe time + * (when no-one is using it anymore). + * + * Results: + * None. + * + * Side effects: + * Everything associated with the text is freed up. + * + *---------------------------------------------------------------------- + */ + +static void +DestroyText(memPtr) + char *memPtr; /* Info about text widget. */ +{ + register TkText *textPtr = (TkText *) memPtr; + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; + TkTextTag *tagPtr; + + /* + * Free up all the stuff that requires special handling, then + * let Tk_FreeOptions handle all the standard option-related + * stuff. Special note: free up display-related information + * before deleting the B-tree, since display-related stuff + * may refer to stuff in the B-tree. + */ + + TkTextFreeDInfo(textPtr); + TkBTreeDestroy(textPtr->tree); + for (hPtr = Tcl_FirstHashEntry(&textPtr->tagTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + tagPtr = (TkTextTag *) Tcl_GetHashValue(hPtr); + TkTextFreeTag(textPtr, tagPtr); + } + Tcl_DeleteHashTable(&textPtr->tagTable); + for (hPtr = Tcl_FirstHashEntry(&textPtr->markTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + ckfree((char *) Tcl_GetHashValue(hPtr)); + } + Tcl_DeleteHashTable(&textPtr->markTable); + if (textPtr->tabArrayPtr != NULL) { + ckfree((char *) textPtr->tabArrayPtr); + } + if (textPtr->insertBlinkHandler != NULL) { + Tcl_DeleteTimerHandler(textPtr->insertBlinkHandler); + } + if (textPtr->bindingTable != NULL) { + Tk_DeleteBindingTable(textPtr->bindingTable); + } + + /* + * NOTE: do NOT free up selBorder, selBdString, or selFgColorPtr: + * they are duplicates of information in the "sel" tag, which was + * freed up as part of deleting the tags above. + */ + + textPtr->selBorder = NULL; + textPtr->selBdString = NULL; + textPtr->selFgColorPtr = NULL; + Tk_FreeOptions(configSpecs, (char *) textPtr, textPtr->display, 0); + ckfree((char *) textPtr); +} + +/* + *---------------------------------------------------------------------- + * + * ConfigureText -- + * + * This procedure is called to process an argv/argc list, plus + * the Tk option database, in order to configure (or + * reconfigure) a text widget. + * + * Results: + * The return value is a standard Tcl result. If TCL_ERROR is + * returned, then interp->result contains an error message. + * + * Side effects: + * Configuration information, such as text string, colors, font, + * etc. get set for textPtr; old resources get freed, if there + * were any. + * + *---------------------------------------------------------------------- + */ + +static int +ConfigureText(interp, textPtr, argc, argv, flags) + Tcl_Interp *interp; /* Used for error reporting. */ + register TkText *textPtr; /* 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 oldExport = textPtr->exportSelection; + + if (Tk_ConfigureWidget(interp, textPtr->tkwin, configSpecs, + argc, argv, (char *) textPtr, flags) != TCL_OK) { + return TCL_ERROR; + } + + /* + * A few other options also need special processing, such as parsing + * the geometry and setting the background from a 3-D border. + */ + + if ((textPtr->state != tkTextNormalUid) + && (textPtr->state != tkTextDisabledUid)) { + Tcl_AppendResult(interp, "bad state value \"", textPtr->state, + "\": must be normal or disabled", (char *) NULL); + textPtr->state = tkTextNormalUid; + return TCL_ERROR; + } + + if ((textPtr->wrapMode != tkTextCharUid) + && (textPtr->wrapMode != tkTextNoneUid) + && (textPtr->wrapMode != tkTextWordUid)) { + Tcl_AppendResult(interp, "bad wrap mode \"", textPtr->wrapMode, + "\": must be char, none, or word", (char *) NULL); + textPtr->wrapMode = tkTextCharUid; + return TCL_ERROR; + } + + Tk_SetBackgroundFromBorder(textPtr->tkwin, textPtr->border); + + /* + * Don't allow negative spacings. + */ + + if (textPtr->spacing1 < 0) { + textPtr->spacing1 = 0; + } + if (textPtr->spacing2 < 0) { + textPtr->spacing2 = 0; + } + if (textPtr->spacing3 < 0) { + textPtr->spacing3 = 0; + } + + /* + * Parse tab stops. + */ + + if (textPtr->tabArrayPtr != NULL) { + ckfree((char *) textPtr->tabArrayPtr); + textPtr->tabArrayPtr = NULL; + } + if (textPtr->tabOptionString != NULL) { + textPtr->tabArrayPtr = TkTextGetTabs(interp, textPtr->tkwin, + textPtr->tabOptionString); + if (textPtr->tabArrayPtr == NULL) { + Tcl_AddErrorInfo(interp,"\n (while processing -tabs option)"); + return TCL_ERROR; + } + } + + /* + * Make sure that configuration options are properly mirrored + * between the widget record and the "sel" tags. NOTE: we don't + * have to free up information during the mirroring; old + * information was freed when it was replaced in the widget + * record. + */ + + textPtr->selTagPtr->border = textPtr->selBorder; + if (textPtr->selTagPtr->bdString != textPtr->selBdString) { + textPtr->selTagPtr->bdString = textPtr->selBdString; + if (textPtr->selBdString != NULL) { + if (Tk_GetPixels(interp, textPtr->tkwin, textPtr->selBdString, + &textPtr->selTagPtr->borderWidth) != TCL_OK) { + return TCL_ERROR; + } + if (textPtr->selTagPtr->borderWidth < 0) { + textPtr->selTagPtr->borderWidth = 0; + } + } + } + textPtr->selTagPtr->fgColor = textPtr->selFgColorPtr; + textPtr->selTagPtr->affectsDisplay = 0; + if ((textPtr->selTagPtr->border != NULL) + || (textPtr->selTagPtr->bdString != NULL) + || (textPtr->selTagPtr->reliefString != NULL) + || (textPtr->selTagPtr->bgStipple != None) + || (textPtr->selTagPtr->fgColor != NULL) + || (textPtr->selTagPtr->tkfont != None) + || (textPtr->selTagPtr->fgStipple != None) + || (textPtr->selTagPtr->justifyString != NULL) + || (textPtr->selTagPtr->lMargin1String != NULL) + || (textPtr->selTagPtr->lMargin2String != NULL) + || (textPtr->selTagPtr->offsetString != NULL) + || (textPtr->selTagPtr->overstrikeString != NULL) + || (textPtr->selTagPtr->rMarginString != NULL) + || (textPtr->selTagPtr->spacing1String != NULL) + || (textPtr->selTagPtr->spacing2String != NULL) + || (textPtr->selTagPtr->spacing3String != NULL) + || (textPtr->selTagPtr->tabString != NULL) + || (textPtr->selTagPtr->underlineString != NULL) + || (textPtr->selTagPtr->wrapMode != NULL)) { + textPtr->selTagPtr->affectsDisplay = 1; + } + TkTextRedrawTag(textPtr, (TkTextIndex *) NULL, (TkTextIndex *) NULL, + textPtr->selTagPtr, 1); + + /* + * Claim the selection if we've suddenly started exporting it and there + * are tagged characters. + */ + + if (textPtr->exportSelection && (!oldExport)) { + TkTextSearch search; + TkTextIndex first, last; + + TkTextMakeIndex(textPtr->tree, 0, 0, &first); + TkTextMakeIndex(textPtr->tree, + TkBTreeNumLines(textPtr->tree), 0, &last); + TkBTreeStartSearch(&first, &last, textPtr->selTagPtr, &search); + if (TkBTreeCharTagged(&first, textPtr->selTagPtr) + || TkBTreeNextTag(&search)) { + Tk_OwnSelection(textPtr->tkwin, XA_PRIMARY, TkTextLostSelection, + (ClientData) textPtr); + textPtr->flags |= GOT_SELECTION; + } + } + + /* + * Register the desired geometry for the window, and arrange for + * the window to be redisplayed. + */ + + if (textPtr->width <= 0) { + textPtr->width = 1; + } + if (textPtr->height <= 0) { + textPtr->height = 1; + } + TextWorldChanged((ClientData) textPtr); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * TextWorldChanged -- + * + * This procedure is called when the world has changed in some + * way and the widget needs to recompute all its graphics contexts + * and determine its new geometry. + * + * Results: + * None. + * + * Side effects: + * Configures all tags in the Text with a empty argc/argv, for + * the side effect of causing all the items to recompute their + * geometry and to be redisplayed. + * + *--------------------------------------------------------------------------- + */ + +static void +TextWorldChanged(instanceData) + ClientData instanceData; /* Information about widget. */ +{ + TkText *textPtr; + Tk_FontMetrics fm; + + textPtr = (TkText *) instanceData; + + textPtr->charWidth = Tk_TextWidth(textPtr->tkfont, "0", 1); + if (textPtr->charWidth <= 0) { + textPtr->charWidth = 1; + } + Tk_GetFontMetrics(textPtr->tkfont, &fm); + Tk_GeometryRequest(textPtr->tkwin, + textPtr->width * textPtr->charWidth + 2*textPtr->borderWidth + + 2*textPtr->padX + 2*textPtr->highlightWidth, + textPtr->height * (fm.linespace + textPtr->spacing1 + + textPtr->spacing3) + 2*textPtr->borderWidth + + 2*textPtr->padY + 2*textPtr->highlightWidth); + Tk_SetInternalBorder(textPtr->tkwin, + textPtr->borderWidth + textPtr->highlightWidth); + if (textPtr->setGrid) { + Tk_SetGrid(textPtr->tkwin, textPtr->width, textPtr->height, + textPtr->charWidth, fm.linespace); + } else { + Tk_UnsetGrid(textPtr->tkwin); + } + + TkTextRelayoutWindow(textPtr); +} + +/* + *-------------------------------------------------------------- + * + * TextEventProc -- + * + * This procedure is invoked by the Tk dispatcher on + * structure changes to a text. For texts with 3D + * borders, this procedure is also invoked for exposures. + * + * Results: + * None. + * + * Side effects: + * When the window gets deleted, internal structures get + * cleaned up. When it gets exposed, it is redisplayed. + * + *-------------------------------------------------------------- + */ + +static void +TextEventProc(clientData, eventPtr) + ClientData clientData; /* Information about window. */ + register XEvent *eventPtr; /* Information about event. */ +{ + register TkText *textPtr = (TkText *) clientData; + TkTextIndex index, index2; + + if (eventPtr->type == Expose) { + TkTextRedrawRegion(textPtr, eventPtr->xexpose.x, + eventPtr->xexpose.y, eventPtr->xexpose.width, + eventPtr->xexpose.height); + } else if (eventPtr->type == ConfigureNotify) { + if ((textPtr->prevWidth != Tk_Width(textPtr->tkwin)) + || (textPtr->prevHeight != Tk_Height(textPtr->tkwin))) { + TkTextRelayoutWindow(textPtr); + textPtr->prevWidth = Tk_Width(textPtr->tkwin); + textPtr->prevHeight = Tk_Height(textPtr->tkwin); + } + } else if (eventPtr->type == DestroyNotify) { + if (textPtr->tkwin != NULL) { + if (textPtr->setGrid) { + Tk_UnsetGrid(textPtr->tkwin); + } + textPtr->tkwin = NULL; + Tcl_DeleteCommandFromToken(textPtr->interp, + textPtr->widgetCmd); + } + Tcl_EventuallyFree((ClientData) textPtr, DestroyText); + } else if ((eventPtr->type == FocusIn) || (eventPtr->type == FocusOut)) { + if (eventPtr->xfocus.detail != NotifyInferior) { + Tcl_DeleteTimerHandler(textPtr->insertBlinkHandler); + if (eventPtr->type == FocusIn) { + textPtr->flags |= GOT_FOCUS | INSERT_ON; + if (textPtr->insertOffTime != 0) { + textPtr->insertBlinkHandler = Tcl_CreateTimerHandler( + textPtr->insertOnTime, TextBlinkProc, + (ClientData) textPtr); + } + } else { + textPtr->flags &= ~(GOT_FOCUS | INSERT_ON); + textPtr->insertBlinkHandler = (Tcl_TimerToken) NULL; + } +#ifndef ALWAYS_SHOW_SELECTION + TkTextRedrawTag(textPtr, NULL, NULL, textPtr->selTagPtr, 1); +#endif + TkTextMarkSegToIndex(textPtr, textPtr->insertMarkPtr, &index); + TkTextIndexForwChars(&index, 1, &index2); + TkTextChanged(textPtr, &index, &index2); + if (textPtr->highlightWidth > 0) { + TkTextRedrawRegion(textPtr, 0, 0, textPtr->highlightWidth, + textPtr->highlightWidth); + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TextCmdDeletedProc -- + * + * 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 +TextCmdDeletedProc(clientData) + ClientData clientData; /* Pointer to widget record for widget. */ +{ + TkText *textPtr = (TkText *) clientData; + Tk_Window tkwin = textPtr->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. + */ + + if (tkwin != NULL) { + if (textPtr->setGrid) { + Tk_UnsetGrid(textPtr->tkwin); + } + textPtr->tkwin = NULL; + Tk_DestroyWindow(tkwin); + } +} + +/* + *---------------------------------------------------------------------- + * + * InsertChars -- + * + * This procedure implements most of the functionality of the + * "insert" widget command. + * + * Results: + * None. + * + * Side effects: + * The characters in "string" get added to the text just before + * the character indicated by "indexPtr". + * + *---------------------------------------------------------------------- + */ + +static void +InsertChars(textPtr, indexPtr, string) + TkText *textPtr; /* Overall information about text widget. */ + TkTextIndex *indexPtr; /* Where to insert new characters. May be + * modified and/or invalidated. */ + char *string; /* Null-terminated string containing new + * information to add to text. */ +{ + int lineIndex, resetView, offset; + TkTextIndex newTop; + + /* + * Don't allow insertions on the last (dummy) line of the text. + */ + + lineIndex = TkBTreeLineIndex(indexPtr->linePtr); + if (lineIndex == TkBTreeNumLines(textPtr->tree)) { + lineIndex--; + TkTextMakeIndex(textPtr->tree, lineIndex, 1000000, indexPtr); + } + + /* + * Notify the display module that lines are about to change, then do + * the insertion. If the insertion occurs on the top line of the + * widget (textPtr->topIndex), then we have to recompute topIndex + * after the insertion, since the insertion could invalidate it. + */ + + resetView = offset = 0; + if (indexPtr->linePtr == textPtr->topIndex.linePtr) { + resetView = 1; + offset = textPtr->topIndex.charIndex; + if (offset > indexPtr->charIndex) { + offset += strlen(string); + } + } + TkTextChanged(textPtr, indexPtr, indexPtr); + TkBTreeInsertChars(indexPtr, string); + if (resetView) { + TkTextMakeIndex(textPtr->tree, lineIndex, 0, &newTop); + TkTextIndexForwChars(&newTop, offset, &newTop); + TkTextSetYView(textPtr, &newTop, 0); + } + + /* + * Invalidate any selection retrievals in progress. + */ + + textPtr->abortSelections = 1; +} + +/* + *---------------------------------------------------------------------- + * + * DeleteChars -- + * + * This procedure implements most of the functionality of the + * "delete" widget command. + * + * Results: + * Returns a standard Tcl result, and leaves an error message + * in textPtr->interp if there is an error. + * + * Side effects: + * Characters get deleted from the text. + * + *---------------------------------------------------------------------- + */ + +static int +DeleteChars(textPtr, index1String, index2String) + TkText *textPtr; /* Overall information about text widget. */ + char *index1String; /* String describing location of first + * character to delete. */ + char *index2String; /* String describing location of last + * character to delete. NULL means just + * delete the one character given by + * index1String. */ +{ + int line1, line2, line, charIndex, resetView; + TkTextIndex index1, index2; + + /* + * Parse the starting and stopping indices. + */ + + if (TkTextGetIndex(textPtr->interp, textPtr, index1String, &index1) + != TCL_OK) { + return TCL_ERROR; + } + if (index2String != NULL) { + if (TkTextGetIndex(textPtr->interp, textPtr, index2String, &index2) + != TCL_OK) { + return TCL_ERROR; + } + } else { + index2 = index1; + TkTextIndexForwChars(&index2, 1, &index2); + } + + /* + * Make sure there's really something to delete. + */ + + if (TkTextIndexCmp(&index1, &index2) >= 0) { + return TCL_OK; + } + + /* + * The code below is ugly, but it's needed to make sure there + * is always a dummy empty line at the end of the text. If the + * final newline of the file (just before the dummy line) is being + * deleted, then back up index to just before the newline. If + * there is a newline just before the first character being deleted, + * then back up the first index too, so that an even number of lines + * gets deleted. Furthermore, remove any tags that are present on + * the newline that isn't going to be deleted after all (this simulates + * deleting the newline and then adding a "clean" one back again). + */ + + line1 = TkBTreeLineIndex(index1.linePtr); + line2 = TkBTreeLineIndex(index2.linePtr); + if (line2 == TkBTreeNumLines(textPtr->tree)) { + TkTextTag **arrayPtr; + int arraySize, i; + TkTextIndex oldIndex2; + + oldIndex2 = index2; + TkTextIndexBackChars(&oldIndex2, 1, &index2); + line2--; + if ((index1.charIndex == 0) && (line1 != 0)) { + TkTextIndexBackChars(&index1, 1, &index1); + line1--; + } + arrayPtr = TkBTreeGetTags(&index2, &arraySize); + if (arrayPtr != NULL) { + for (i = 0; i < arraySize; i++) { + TkBTreeTag(&index2, &oldIndex2, arrayPtr[i], 0); + } + ckfree((char *) arrayPtr); + } + } + + /* + * Tell the display what's about to happen so it can discard + * obsolete display information, then do the deletion. Also, + * if the deletion involves the top line on the screen, then + * we have to reset the view (the deletion will invalidate + * textPtr->topIndex). Compute what the new first character + * will be, then do the deletion, then reset the view. + */ + + TkTextChanged(textPtr, &index1, &index2); + resetView = line = charIndex = 0; + if (TkTextIndexCmp(&index2, &textPtr->topIndex) >= 0) { + if (TkTextIndexCmp(&index1, &textPtr->topIndex) <= 0) { + /* + * Deletion range straddles topIndex: use the beginning + * of the range as the new topIndex. + */ + + resetView = 1; + line = line1; + charIndex = index1.charIndex; + } else if (index1.linePtr == textPtr->topIndex.linePtr) { + /* + * Deletion range starts on top line but after topIndex. + * Use the current topIndex as the new one. + */ + + resetView = 1; + line = line1; + charIndex = textPtr->topIndex.charIndex; + } + } else if (index2.linePtr == textPtr->topIndex.linePtr) { + /* + * Deletion range ends on top line but before topIndex. + * Figure out what will be the new character index for + * the character currently pointed to by topIndex. + */ + + resetView = 1; + line = line2; + charIndex = textPtr->topIndex.charIndex; + if (index1.linePtr != index2.linePtr) { + charIndex -= index2.charIndex; + } else { + charIndex -= (index2.charIndex - index1.charIndex); + } + } + TkBTreeDeleteChars(&index1, &index2); + if (resetView) { + TkTextMakeIndex(textPtr->tree, line, charIndex, &index1); + TkTextSetYView(textPtr, &index1, 0); + } + + /* + * Invalidate any selection retrievals in progress. + */ + + textPtr->abortSelections = 1; + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TextFetchSelection -- + * + * This procedure is called back by Tk when the selection is + * requested by someone. It returns part or all of the selection + * in a buffer provided by the caller. + * + * Results: + * The return value is the number of non-NULL bytes stored + * at buffer. Buffer is filled (or partially filled) with a + * NULL-terminated string containing part or all of the selection, + * as given by offset and maxBytes. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TextFetchSelection(clientData, offset, buffer, maxBytes) + ClientData clientData; /* Information about text 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. */ +{ + register TkText *textPtr = (TkText *) clientData; + TkTextIndex eof; + int count, chunkSize, offsetInSeg; + TkTextSearch search; + TkTextSegment *segPtr; + + if (!textPtr->exportSelection) { + return -1; + } + + /* + * Find the beginning of the next range of selected text. Note: if + * the selection is being retrieved in multiple pieces (offset != 0) + * and some modification has been made to the text that affects the + * selection then reject the selection request (make 'em start over + * again). + */ + + if (offset == 0) { + TkTextMakeIndex(textPtr->tree, 0, 0, &textPtr->selIndex); + textPtr->abortSelections = 0; + } else if (textPtr->abortSelections) { + return 0; + } + TkTextMakeIndex(textPtr->tree, TkBTreeNumLines(textPtr->tree), 0, &eof); + TkBTreeStartSearch(&textPtr->selIndex, &eof, textPtr->selTagPtr, &search); + if (!TkBTreeCharTagged(&textPtr->selIndex, textPtr->selTagPtr)) { + if (!TkBTreeNextTag(&search)) { + if (offset == 0) { + return -1; + } else { + return 0; + } + } + textPtr->selIndex = search.curIndex; + } + + /* + * Each iteration through the outer loop below scans one selected range. + * Each iteration through the inner loop scans one segment in the + * selected range. + */ + + count = 0; + while (1) { + /* + * Find the end of the current range of selected text. + */ + + if (!TkBTreeNextTag(&search)) { + panic("TextFetchSelection couldn't find end of range"); + } + + /* + * Copy information from character segments into the buffer + * until either we run out of space in the buffer or we get + * to the end of this range of text. + */ + + while (1) { + if (maxBytes == 0) { + goto done; + } + segPtr = TkTextIndexToSeg(&textPtr->selIndex, &offsetInSeg); + chunkSize = segPtr->size - offsetInSeg; + if (chunkSize > maxBytes) { + chunkSize = maxBytes; + } + if (textPtr->selIndex.linePtr == search.curIndex.linePtr) { + int leftInRange; + + leftInRange = search.curIndex.charIndex + - textPtr->selIndex.charIndex; + if (leftInRange < chunkSize) { + chunkSize = leftInRange; + if (chunkSize <= 0) { + break; + } + } + } + if (segPtr->typePtr == &tkTextCharType) { + memcpy((VOID *) buffer, (VOID *) (segPtr->body.chars + + offsetInSeg), (size_t) chunkSize); + buffer += chunkSize; + maxBytes -= chunkSize; + count += chunkSize; + } + TkTextIndexForwChars(&textPtr->selIndex, chunkSize, + &textPtr->selIndex); + } + + /* + * Find the beginning of the next range of selected text. + */ + + if (!TkBTreeNextTag(&search)) { + break; + } + textPtr->selIndex = search.curIndex; + } + + done: + *buffer = 0; + return count; +} + +/* + *---------------------------------------------------------------------- + * + * TkTextLostSelection -- + * + * This procedure is called back by Tk when the selection is + * grabbed away from a text widget. On Windows and Mac systems, we + * want to remember the selection for the next time the focus + * enters the window. On Unix, just remove the "sel" tag from + * everything in the widget. + * + * Results: + * None. + * + * Side effects: + * The "sel" tag is cleared from the window. + * + *---------------------------------------------------------------------- + */ + +void +TkTextLostSelection(clientData) + ClientData clientData; /* Information about text widget. */ +{ + register TkText *textPtr = (TkText *) clientData; +#ifdef ALWAYS_SHOW_SELECTION + TkTextIndex start, end; + + if (!textPtr->exportSelection) { + return; + } + + /* + * On Windows and Mac systems, we want to remember the selection + * for the next time the focus enters the window. On Unix, + * just remove the "sel" tag from everything in the widget. + */ + + TkTextMakeIndex(textPtr->tree, 0, 0, &start); + TkTextMakeIndex(textPtr->tree, TkBTreeNumLines(textPtr->tree), 0, &end); + TkTextRedrawTag(textPtr, &start, &end, textPtr->selTagPtr, 1); + TkBTreeTag(&start, &end, textPtr->selTagPtr, 0); +#endif + textPtr->flags &= ~GOT_SELECTION; +} + +/* + *---------------------------------------------------------------------- + * + * TextBlinkProc -- + * + * This procedure is called as a timer handler to blink the + * insertion cursor off and on. + * + * Results: + * None. + * + * Side effects: + * The cursor gets turned on or off, redisplay gets invoked, + * and this procedure reschedules itself. + * + *---------------------------------------------------------------------- + */ + +static void +TextBlinkProc(clientData) + ClientData clientData; /* Pointer to record describing text. */ +{ + register TkText *textPtr = (TkText *) clientData; + TkTextIndex index; + int x, y, w, h; + + if (!(textPtr->flags & GOT_FOCUS) || (textPtr->insertOffTime == 0)) { + return; + } + if (textPtr->flags & INSERT_ON) { + textPtr->flags &= ~INSERT_ON; + textPtr->insertBlinkHandler = Tcl_CreateTimerHandler( + textPtr->insertOffTime, TextBlinkProc, (ClientData) textPtr); + } else { + textPtr->flags |= INSERT_ON; + textPtr->insertBlinkHandler = Tcl_CreateTimerHandler( + textPtr->insertOnTime, TextBlinkProc, (ClientData) textPtr); + } + TkTextMarkSegToIndex(textPtr, textPtr->insertMarkPtr, &index); + TkTextCharBbox(textPtr, &index, &x, &y, &w, &h); + TkTextRedrawRegion(textPtr, x - textPtr->insertWidth / 2, y, + textPtr->insertWidth, h); +} + +/* + *---------------------------------------------------------------------- + * + * TextSearchCmd -- + * + * This procedure is invoked to process the "search" widget command + * for text widgets. See the user documentation for details on what + * it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +TextSearchCmd(textPtr, interp, argc, argv) + TkText *textPtr; /* Information about text widget. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + 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 patLength; + char *arg, *pattern, *varName, *p, *startOfLine; + char buffer[20]; + TkTextIndex index, stopIndex; + Tcl_DString line, patDString; + TkTextSegment *segPtr; + TkTextLine *linePtr; + Tcl_RegExp regexp = NULL; /* Initialization needed only to + * prevent compiler warning. */ + + /* + * Parse switches and other arguments. + */ + + exact = 1; + backwards = 0; + noCase = 0; + varName = NULL; + for (i = 2; i < argc; i++) { + arg = argv[i]; + if (arg[0] != '-') { + break; + } + length = strlen(arg); + if (length < 2) { + badSwitch: + Tcl_AppendResult(interp, "bad switch \"", arg, + "\": must be -forward, -backward, -exact, -regexp, ", + "-nocase, -count, or --", (char *) NULL); + return TCL_ERROR; + } + c = arg[1]; + if ((c == 'b') && (strncmp(argv[i], "-backwards", length) == 0)) { + backwards = 1; + } else if ((c == 'c') && (strncmp(argv[i], "-count", length) == 0)) { + if (i >= (argc-1)) { + interp->result = "no value given for \"-count\" option"; + return TCL_ERROR; + } + i++; + varName = argv[i]; + } else if ((c == 'e') && (strncmp(argv[i], "-exact", length) == 0)) { + exact = 1; + } else if ((c == 'f') && (strncmp(argv[i], "-forwards", length) == 0)) { + backwards = 0; + } else if ((c == 'n') && (strncmp(argv[i], "-nocase", length) == 0)) { + noCase = 1; + } else if ((c == 'r') && (strncmp(argv[i], "-regexp", length) == 0)) { + exact = 0; + } else if ((c == '-') && (strncmp(argv[i], "--", length) == 0)) { + i++; + break; + } else { + goto badSwitch; + } + } + argsLeft = argc - (i+2); + if ((argsLeft != 0) && (argsLeft != 1)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " search ?switches? pattern index ?stopIndex?", + (char *) NULL); + return TCL_ERROR; + } + pattern = argv[i]; + + /* + * Convert the pattern to lower-case if we're supposed to ignore case. + */ + + if (noCase) { + 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)); + } + } + } + + if (TkTextGetIndex(interp, textPtr, argv[i+1], &index) != TCL_OK) { + return TCL_ERROR; + } + numLines = TkBTreeNumLines(textPtr->tree); + startingLine = TkBTreeLineIndex(index.linePtr); + startingChar = index.charIndex; + if (startingLine >= numLines) { + if (backwards) { + startingLine = TkBTreeNumLines(textPtr->tree) - 1; + startingChar = TkBTreeCharsInLine(TkBTreeFindLine(textPtr->tree, + startingLine)); + } else { + startingLine = 0; + startingChar = 0; + } + } + if (argsLeft == 1) { + if (TkTextGetIndex(interp, textPtr, argv[i+2], &stopIndex) != TCL_OK) { + return TCL_ERROR; + } + stopLine = TkBTreeLineIndex(stopIndex.linePtr); + if (!backwards && (stopLine == numLines)) { + stopLine = numLines-1; + } + searchWholeText = 0; + } else { + stopLine = 0; + searchWholeText = 1; + } + + /* + * Scan through all of the lines of the text circularly, starting + * at the given index. + */ + + matchLength = patLength = 0; /* Only needed to prevent compiler + * warnings. */ + if (exact) { + patLength = strlen(pattern); + } else { + regexp = Tcl_RegExpCompile(interp, pattern); + if (regexp == NULL) { + return TCL_ERROR; + } + } + lineNum = startingLine; + code = TCL_OK; + Tcl_DStringInit(&line); + for (passes = 0; passes < 2; ) { + if (lineNum >= numLines) { + /* + * Don't search the dummy last line of the text. + */ + + goto nextLine; + } + + /* + * Extract the text from the line. If we're doing regular + * expression matching, drop the newline from the line, so + * that "$" can be used to match the end of the line. + */ + + linePtr = TkBTreeFindLine(textPtr->tree, lineNum); + for (segPtr = linePtr->segPtr; segPtr != NULL; + segPtr = segPtr->nextPtr) { + if (segPtr->typePtr != &tkTextCharType) { + continue; + } + Tcl_DStringAppend(&line, segPtr->body.chars, segPtr->size); + } + if (!exact) { + Tcl_DStringSetLength(&line, Tcl_DStringLength(&line)-1); + } + startOfLine = Tcl_DStringValue(&line); + + /* + * If we're ignoring case, convert the line to lower case. + */ + + if (noCase) { + for (p = Tcl_DStringValue(&line); *p != 0; p++) { + if (isupper(UCHAR(*p))) { + *p = tolower(UCHAR(*p)); + } + } + } + + /* + * Check for matches within the current line. If so, and if we're + * searching backwards, repeat the search to find the last match + * in the line. + */ + + matchChar = -1; + firstChar = 0; + lastChar = INT_MAX; + if (lineNum == startingLine) { + int indexInDString; + + /* + * The starting line is tricky: the first time we see it + * we check one part of the line, and the second pass through + * we check the other part of the line. We have to be very + * careful here because there could be embedded windows or + * other things that are not in the extracted line. Rescan + * the original line to compute the index in it of the first + * character. + */ + + indexInDString = startingChar; + for (segPtr = linePtr->segPtr, leftToScan = startingChar; + leftToScan > 0; segPtr = segPtr->nextPtr) { + if (segPtr->typePtr != &tkTextCharType) { + indexInDString -= segPtr->size; + } + leftToScan -= segPtr->size; + } + + passes++; + if ((passes == 1) ^ backwards) { + /* + * Only use the last part of the line. + */ + + firstChar = indexInDString; + if (firstChar >= Tcl_DStringLength(&line)) { + goto nextLine; + } + } else { + /* + * Use only the first part of the line. + */ + + lastChar = indexInDString; + } + } + do { + int thisLength; + if (exact) { + p = strstr(startOfLine + firstChar, pattern); + if (p == NULL) { + break; + } + i = p - startOfLine; + thisLength = patLength; + } else { + char *start, *end; + int match; + + match = Tcl_RegExpExec(interp, regexp, + startOfLine + firstChar, startOfLine); + if (match < 0) { + code = TCL_ERROR; + goto done; + } + if (!match) { + break; + } + Tcl_RegExpRange(regexp, 0, &start, &end); + i = start - startOfLine; + thisLength = end - start; + } + if (i >= lastChar) { + break; + } + matchChar = i; + matchLength = thisLength; + firstChar = matchChar+1; + } while (backwards); + + /* + * If we found a match then we're done. Make sure that + * the match occurred before the stopping index, if one was + * specified. + */ + + if (matchChar >= 0) { + /* + * The index information returned by the regular expression + * parser only considers textual information: it doesn't + * account for embedded windows or any other non-textual info. + * Scan through the line's segments again to adjust both + * matchChar and matchCount. + */ + + for (segPtr = linePtr->segPtr, leftToScan = matchChar; + leftToScan >= 0; segPtr = segPtr->nextPtr) { + if (segPtr->typePtr != &tkTextCharType) { + matchChar += segPtr->size; + continue; + } + leftToScan -= segPtr->size; + } + for (leftToScan += matchLength; leftToScan > 0; + segPtr = segPtr->nextPtr) { + if (segPtr->typePtr != &tkTextCharType) { + matchLength += segPtr->size; + continue; + } + leftToScan -= segPtr->size; + } + TkTextMakeIndex(textPtr->tree, lineNum, matchChar, &index); + if (!searchWholeText) { + if (!backwards && (TkTextIndexCmp(&index, &stopIndex) >= 0)) { + goto done; + } + if (backwards && (TkTextIndexCmp(&index, &stopIndex) < 0)) { + goto done; + } + } + if (varName != NULL) { + sprintf(buffer, "%d", matchLength); + if (Tcl_SetVar(interp, varName, buffer, TCL_LEAVE_ERR_MSG) + == NULL) { + code = TCL_ERROR; + goto done; + } + } + TkTextPrintIndex(&index, interp->result); + goto done; + } + + /* + * Go to the next (or previous) line; + */ + + nextLine: + if (backwards) { + lineNum--; + if (!searchWholeText) { + if (lineNum < stopLine) { + break; + } + } else if (lineNum < 0) { + lineNum = numLines-1; + } + } else { + lineNum++; + if (!searchWholeText) { + if (lineNum > stopLine) { + break; + } + } else if (lineNum >= numLines) { + lineNum = 0; + } + } + Tcl_DStringSetLength(&line, 0); + } + done: + Tcl_DStringFree(&line); + if (noCase) { + Tcl_DStringFree(&patDString); + } + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TkTextGetTabs -- + * + * Parses a string description of a set of tab stops. + * + * Results: + * 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. + * + * Side effects: + * Memory is allocated for the structure that is returned. It is + * up to the caller to free this structure when it is no longer + * needed. + * + *---------------------------------------------------------------------- + */ + +TkTextTabArray * +TkTextGetTabs(interp, tkwin, string) + Tcl_Interp *interp; /* Used for error reporting. */ + Tk_Window tkwin; /* Window in which the tabs will be + * used. */ + char *string; /* Description of the tab stops. See + * the text manual entry for details. */ +{ + int argc, i, count, c; + char **argv; + TkTextTabArray *tabArrayPtr; + TkTextTab *tabPtr; + + if (Tcl_SplitList(interp, string, &argc, &argv) != TCL_OK) { + return NULL; + } + + /* + * First find out how many entries we need to allocate in the + * tab array. + */ + + count = 0; + for (i = 0; i < argc; i++) { + c = argv[i][0]; + if ((c != 'l') && (c != 'r') && (c != 'c') && (c != 'n')) { + count++; + } + } + + /* + * Parse the elements of the list one at a time to fill in the + * array. + */ + + tabArrayPtr = (TkTextTabArray *) ckalloc((unsigned) + (sizeof(TkTextTabArray) + (count-1)*sizeof(TkTextTab))); + tabArrayPtr->numTabs = 0; + for (i = 0, tabPtr = &tabArrayPtr->tabs[0]; i < argc; i++, tabPtr++) { + if (Tk_GetPixels(interp, tkwin, argv[i], &tabPtr->location) + != TCL_OK) { + goto error; + } + tabArrayPtr->numTabs++; + + /* + * See if there is an explicit alignment in the next list + * element. Otherwise just use "left". + */ + + tabPtr->alignment = LEFT; + if ((i+1) == argc) { + continue; + } + c = UCHAR(argv[i+1][0]); + if (!isalpha(c)) { + continue; + } + i += 1; + if ((c == 'l') && (strncmp(argv[i], "left", + strlen(argv[i])) == 0)) { + tabPtr->alignment = LEFT; + } else if ((c == 'r') && (strncmp(argv[i], "right", + strlen(argv[i])) == 0)) { + tabPtr->alignment = RIGHT; + } else if ((c == 'c') && (strncmp(argv[i], "center", + strlen(argv[i])) == 0)) { + tabPtr->alignment = CENTER; + } else if ((c == 'n') && (strncmp(argv[i], + "numeric", strlen(argv[i])) == 0)) { + tabPtr->alignment = NUMERIC; + } else { + Tcl_AppendResult(interp, "bad tab alignment \"", + argv[i], "\": must be left, right, center, or numeric", + (char *) NULL); + goto error; + } + } + ckfree((char *) argv); + return tabArrayPtr; + + error: + ckfree((char *) tabArrayPtr); + ckfree((char *) argv); + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * TextDumpCmd -- + * + * Return information about the text, tags, marks, and embedded windows + * and images in a text widget. See the man page for the description + * of the text dump operation for all the details. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Memory is allocated for the result, if needed (standard Tcl result + * side effects). + * + *---------------------------------------------------------------------- + */ + +static int +TextDumpCmd(textPtr, interp, argc, argv) + register TkText *textPtr; /* Information about text widget. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. Someone else has already + * parsed this command enough to know that + * argv[1] is "dump". */ +{ + TkTextIndex index1, index2; + int arg; + int lineno; /* Current line number */ + int what = 0; /* bitfield to select segment types */ + int atEnd; /* True if dumping up to logical end */ + TkTextLine *linePtr; + char *command = NULL; /* Script callback to apply to segments */ +#define TK_DUMP_TEXT 0x1 +#define TK_DUMP_MARK 0x2 +#define TK_DUMP_TAG 0x4 +#define TK_DUMP_WIN 0x8 +#define TK_DUMP_IMG 0x10 +#define TK_DUMP_ALL (TK_DUMP_TEXT|TK_DUMP_MARK|TK_DUMP_TAG| \ + TK_DUMP_WIN|TK_DUMP_IMG) + + for (arg=2 ; argv[arg] != (char *) NULL ; arg++) { + size_t len; + if (argv[arg][0] != '-') { + break; + } + len = strlen(argv[arg]); + if (strncmp("-all", argv[arg], len) == 0) { + what = TK_DUMP_ALL; + } else if (strncmp("-text", argv[arg], len) == 0) { + what |= TK_DUMP_TEXT; + } else if (strncmp("-tag", argv[arg], len) == 0) { + what |= TK_DUMP_TAG; + } else if (strncmp("-mark", argv[arg], len) == 0) { + what |= TK_DUMP_MARK; + } else if (strncmp("-image", argv[arg], len) == 0) { + what |= TK_DUMP_IMG; + } else if (strncmp("-window", argv[arg], len) == 0) { + what |= TK_DUMP_WIN; + } else if (strncmp("-command", argv[arg], len) == 0) { + arg++; + if (arg >= argc) { + Tcl_AppendResult(interp, "Usage: ", argv[0], " dump ?-all -image -text -mark -tag -window? ?-command script? index ?index2?", NULL); + return TCL_ERROR; + } + command = argv[arg]; + } else { + Tcl_AppendResult(interp, "Usage: ", argv[0], " dump ?-all -image -text -mark -tag -window? ?-command script? index ?index2?", NULL); + return TCL_ERROR; + } + } + if (arg >= argc) { + Tcl_AppendResult(interp, "Usage: ", argv[0], " dump ?-all -image -text -mark -tag -window? ?-command script? index ?index2?", NULL); + return TCL_ERROR; + } + if (what == 0) { + what = TK_DUMP_ALL; + } + if (TkTextGetIndex(interp, textPtr, argv[arg], &index1) != TCL_OK) { + return TCL_ERROR; + } + lineno = TkBTreeLineIndex(index1.linePtr) + 1; + arg++; + atEnd = 0; + if (argc == arg) { + TkTextIndexForwChars(&index1, 1, &index2); + } else { + if (TkTextGetIndex(interp, textPtr, argv[arg], &index2) != TCL_OK) { + return TCL_ERROR; + } + if (strncmp(argv[arg], "end", strlen(argv[arg])) == 0) { + atEnd = 1; + } + } + if (TkTextIndexCmp(&index1, &index2) >= 0) { + return TCL_OK; + } + if (index1.linePtr == index2.linePtr) { + DumpLine(interp, textPtr, what, index1.linePtr, + index1.charIndex, index2.charIndex, lineno, command); + } else { + DumpLine(interp, textPtr, what, index1.linePtr, + index1.charIndex, 32000000, lineno, command); + linePtr = index1.linePtr; + while ((linePtr = TkBTreeNextLine(linePtr)) != (TkTextLine *)NULL) { + lineno++; + if (linePtr == index2.linePtr) { + break; + } + DumpLine(interp, textPtr, what, linePtr, 0, 32000000, + lineno, command); + } + DumpLine(interp, textPtr, what, index2.linePtr, 0, + index2.charIndex, 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); + + } + return TCL_OK; +} + +/* + * DumpLine + * Return information about a given text line from character + * position "start" up to, but not including, "end". + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None, but see DumpSegment. + */ +static void +DumpLine(interp, textPtr, what, linePtr, start, end, 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 lineno; /* Line number for indices dump */ + char *command; /* Script to apply to the segment */ +{ + int offset; + TkTextSegment *segPtr; + /* + * Must loop through line looking at its segments. + * character + * toggleOn, toggleOff + * mark + * image + * window + */ + for (offset = 0, segPtr = linePtr->segPtr ; + (offset < end) && (segPtr != (TkTextSegment *)NULL) ; + offset += segPtr->size, segPtr = segPtr->nextPtr) { + if ((what & TK_DUMP_TEXT) && (segPtr->typePtr == &tkTextCharType) && + (offset + segPtr->size > start)) { + 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 (start > offset) { + first = start - 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)) { + if ((what & TK_DUMP_MARK) && (segPtr->typePtr->name[0] == 'm')) { + TkTextMark *markPtr = (TkTextMark *)&segPtr->body; + char *name = Tcl_GetHashKey(&textPtr->markTable, markPtr->hPtr); + DumpSegment(interp, "mark", name, + command, lineno, offset, what); + } else if ((what & TK_DUMP_TAG) && + (segPtr->typePtr == &tkTextToggleOnType)) { + DumpSegment(interp, "tagon", + segPtr->body.toggle.tagPtr->name, + command, lineno, offset, what); + } else if ((what & TK_DUMP_TAG) && + (segPtr->typePtr == &tkTextToggleOffType)) { + DumpSegment(interp, "tagoff", + segPtr->body.toggle.tagPtr->name, + command, lineno, offset, what); + } else if ((what & TK_DUMP_IMG) && + (segPtr->typePtr->name[0] == 'i')) { + TkTextEmbImage *eiPtr = (TkTextEmbImage *)&segPtr->body; + char *name = (eiPtr->name == NULL) ? "" : eiPtr->name; + DumpSegment(interp, "image", name, + command, lineno, offset, what); + } else if ((what & TK_DUMP_WIN) && + (segPtr->typePtr->name[0] == 'w')) { + TkTextEmbWindow *ewPtr = (TkTextEmbWindow *)&segPtr->body; + char *pathname; + if (ewPtr->tkwin == (Tk_Window) NULL) { + pathname = ""; + } else { + pathname = Tk_PathName(ewPtr->tkwin); + } + DumpSegment(interp, "window", pathname, + command, lineno, offset, what); + } + } + } +} + +/* + * DumpSegment + * Either append information about the current segment to the result, + * or make a script callback with that information as arguments. + * + * Results: + * None + * + * Side effects: + * Either evals the callback or appends elements to the result string. + */ +static int +DumpSegment(interp, key, value, command, lineno, offset, what) + Tcl_Interp *interp; + char *key; /* Segment type key */ + char *value; /* Segment value */ + char *command; /* Script callback */ + int lineno; /* Line number for indices dump */ + int offset; /* Character position */ + int what; /* Look for TK_DUMP_INDEX bit */ +{ + char buffer[30]; + sprintf(buffer, "%d.%d", lineno, offset); + if (command == (char *) NULL) { + Tcl_AppendElement(interp, key); + Tcl_AppendElement(interp, value); + Tcl_AppendElement(interp, buffer); + return TCL_OK; + } else { + char *argv[4]; + char *list; + int result; + argv[0] = key; + argv[1] = value; + argv[2] = buffer; + argv[3] = (char *) NULL; + list = Tcl_Merge(3, argv); + result = Tcl_VarEval(interp, command, " ", list, (char *) NULL); + ckfree(list); + return result; + } +} + diff --git a/generic/tkText.h b/generic/tkText.h new file mode 100644 index 0000000..a7999d2 --- /dev/null +++ b/generic/tkText.h @@ -0,0 +1,848 @@ +/* + * tkText.h -- + * + * Declarations shared among the files that implement text + * widgets. + * + * Copyright (c) 1992-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkText.h 1.46 96/11/25 11:26:12 + */ + +#ifndef _TKTEXT +#define _TKTEXT + +#ifndef _TK +#include "tk.h" +#endif + +/* + * Opaque types for structures whose guts are only needed by a single + * file: + */ + +typedef struct TkTextBTree *TkTextBTree; + +/* + * The data structure below defines a single line of text (from newline + * to newline, not necessarily what appears on one line of the screen). + */ + +typedef struct TkTextLine { + struct Node *parentPtr; /* Pointer to parent node containing + * line. */ + struct TkTextLine *nextPtr; /* Next in linked list of lines with + * same parent node in B-tree. NULL + * means end of list. */ + struct TkTextSegment *segPtr; /* First in ordered list of segments + * that make up the line. */ +} TkTextLine; + +/* + * ----------------------------------------------------------------------- + * Segments: each line is divided into one or more segments, where each + * segment is one of several things, such as a group of characters, a + * tag toggle, a mark, or an embedded widget. Each segment starts with + * a standard header followed by a body that varies from type to type. + * ----------------------------------------------------------------------- + */ + +/* + * The data structure below defines the body of a segment that represents + * a tag toggle. There is one of these structures at both the beginning + * and end of each tagged range. + */ + +typedef struct TkTextToggle { + struct TkTextTag *tagPtr; /* Tag that starts or ends here. */ + int inNodeCounts; /* 1 means this toggle has been + * accounted for in node toggle + * counts; 0 means it hasn't, yet. */ +} TkTextToggle; + +/* + * The data structure below defines line segments that represent + * marks. There is one of these for each mark in the text. + */ + +typedef struct TkTextMark { + struct TkText *textPtr; /* Overall information about text + * widget. */ + TkTextLine *linePtr; /* Line structure that contains the + * segment. */ + Tcl_HashEntry *hPtr; /* Pointer to hash table entry for mark + * (in textPtr->markTable). */ +} TkTextMark; + +/* + * A structure of the following type holds information for each window + * embedded in a text widget. This information is only used by the + * file tkTextWind.c + */ + +typedef struct TkTextEmbWindow { + struct TkText *textPtr; /* Information about the overall text + * widget. */ + TkTextLine *linePtr; /* Line structure that contains this + * window. */ + Tk_Window tkwin; /* Window for this segment. NULL + * means that the window hasn't + * been created yet. */ + char *create; /* Script to create window on-demand. + * NULL means no such script. + * Malloc-ed. */ + int align; /* How to align window in vertical + * space. See definitions in + * tkTextWind.c. */ + int padX, padY; /* Padding to leave around each side + * of window, in pixels. */ + int stretch; /* Should window stretch to fill + * vertical space of line (except for + * pady)? 0 or 1. */ + int chunkCount; /* Number of display chunks that + * refer to this window. */ + int displayed; /* Non-zero means that the window + * has been displayed on the screen + * recently. */ +} TkTextEmbWindow; + +/* + * A structure of the following type holds information for each image + * embedded in a text widget. This information is only used by the + * file tkTextImage.c + */ + +typedef struct TkTextEmbImage { + struct TkText *textPtr; /* Information about the overall text + * widget. */ + TkTextLine *linePtr; /* Line structure that contains this + * image. */ + char *imageString; /* Name of the image for this segment */ + char *imageName; /* Name used by text widget to identify + * this image. May be unique-ified */ + char *name; /* Name used in the hash table. + * used by "image names" to identify + * this instance of the image */ + Tk_Image image; /* Image for this segment. NULL + * means that the image hasn't + * been created yet. */ + int align; /* How to align image in vertical + * space. See definitions in + * tkTextImage.c. */ + int padX, padY; /* Padding to leave around each side + * of image, in pixels. */ + int chunkCount; /* Number of display chunks that + * refer to this image. */ +} TkTextEmbImage; + +/* + * The data structure below defines line segments. + */ + +typedef struct TkTextSegment { + struct Tk_SegType *typePtr; /* Pointer to record describing + * segment's type. */ + struct TkTextSegment *nextPtr; /* Next in list of segments for this + * line, or NULL for end of list. */ + int size; /* Size of this segment (# of bytes + * of index space it occupies). */ + union { + char chars[4]; /* Characters that make up character + * info. Actual length varies to + * hold as many characters as needed.*/ + TkTextToggle toggle; /* Information about tag toggle. */ + TkTextMark mark; /* Information about mark. */ + TkTextEmbWindow ew; /* Information about embedded + * window. */ + TkTextEmbImage ei; /* Information about embedded + * image. */ + } body; +} TkTextSegment; + +/* + * Data structures of the type defined below are used during the + * execution of Tcl commands to keep track of various interesting + * places in a text. An index is only valid up until the next + * modification to the character structure of the b-tree so they + * can't be retained across Tcl commands. However, mods to marks + * or tags don't invalidate indices. + */ + +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 + * character (0 means first one). */ +} TkTextIndex; + +/* + * Types for procedure pointers stored in TkTextDispChunk strutures: + */ + +typedef struct TkTextDispChunk TkTextDispChunk; + +typedef void Tk_ChunkDisplayProc _ANSI_ARGS_(( + TkTextDispChunk *chunkPtr, int x, int y, + int height, int baseline, Display *display, + Drawable dst, int screenY)); +typedef void Tk_ChunkUndisplayProc _ANSI_ARGS_(( + struct TkText *textPtr, + TkTextDispChunk *chunkPtr)); +typedef int Tk_ChunkMeasureProc _ANSI_ARGS_(( + TkTextDispChunk *chunkPtr, int x)); +typedef void Tk_ChunkBboxProc _ANSI_ARGS_(( + TkTextDispChunk *chunkPtr, int index, int y, + int lineHeight, int baseline, int *xPtr, + int *yPtr, int *widthPtr, int *heightPtr)); + +/* + * The structure below represents a chunk of stuff that is displayed + * together on the screen. This structure is allocated and freed by + * generic display code but most of its fields are filled in by + * segment-type-specific code. + */ + +struct TkTextDispChunk { + /* + * The fields below are set by the type-independent code before + * calling the segment-type-specific layoutProc. They should not + * be modified by segment-type-specific code. + */ + + int x; /* X position of chunk, in pixels. + * This position is measured from the + * left edge of the logical line, + * not from the left edge of the + * window (i.e. it doesn't change + * under horizontal scrolling). */ + struct TkTextDispChunk *nextPtr; /* Next chunk in the display line + * or NULL for the end of the list. */ + struct TextStyle *stylePtr; /* Display information, known only + * to tkTextDisp.c. */ + + /* + * The fields below are set by the layoutProc that creates the + * chunk. + */ + + Tk_ChunkDisplayProc *displayProc; /* Procedure to invoke to draw this + * chunk on the display or an + * off-screen pixmap. */ + Tk_ChunkUndisplayProc *undisplayProc; + /* Procedure to invoke when segment + * ceases to be displayed on screen + * anymore. */ + Tk_ChunkMeasureProc *measureProc; /* Procedure to find character under + * a given x-location. */ + Tk_ChunkBboxProc *bboxProc; /* Procedure to find bounding box + * of character in chunk. */ + int numChars; /* Number of characters that will be + * displayed in the chunk. */ + int minAscent; /* Minimum space above the baseline + * needed by this chunk. */ + int minDescent; /* Minimum space below the baseline + * needed by this chunk. */ + int minHeight; /* Minimum total line height needed + * by this chunk. */ + int width; /* Width of this chunk, in pixels. + * Initially set by chunk-specific + * code, but may be increased to + * include tab or extra space at end + * of line. */ + int breakIndex; /* Index within chunk of last + * acceptable position for a line + * (break just before this character). + * <= 0 means don't break during or + * immediately after this chunk. */ + ClientData clientData; /* Additional information for use + * of displayProc and undisplayProc. */ +}; + +/* + * One data structure of the following type is used for each tag in a + * text widget. These structures are kept in textPtr->tagTable and + * referred to in other structures. + */ + +typedef struct TkTextTag { + char *name; /* Name of this tag. This field is actually + * a pointer to the key from the entry in + * textPtr->tagTable, so it needn't be freed + * explicitly. */ + int priority; /* Priority of this tag within widget. 0 + * means lowest priority. Exactly one tag + * has each integer value between 0 and + * numTags-1. */ + struct Node *tagRootPtr; /* Pointer into the B-Tree at the lowest + * node that completely dominates the ranges + * of text occupied by the tag. At this + * node there is no information about the + * tag. One or more children of the node + * do contain information about the tag. */ + int toggleCount; /* Total number of tag toggles */ + + /* + * Information for displaying text with this tag. The information + * belows acts as an override on information specified by lower-priority + * tags. If no value is specified, then the next-lower-priority tag + * on the text determins the value. The text widget itself provides + * defaults if no tag specifies an override. + */ + + Tk_3DBorder border; /* Used for drawing background. NULL means + * no value specified here. */ + char *bdString; /* -borderwidth option string (malloc-ed). + * NULL means option not specified. */ + int borderWidth; /* Width of 3-D border for background. */ + char *reliefString; /* -relief option string (malloc-ed). + * NULL means option not specified. */ + int relief; /* 3-D relief for background. */ + Pixmap bgStipple; /* Stipple bitmap for background. None + * means no value specified here. */ + XColor *fgColor; /* Foreground color for text. NULL means + * no value specified here. */ + Tk_Font tkfont; /* Font for displaying text. NULL means + * no value specified here. */ + Pixmap fgStipple; /* Stipple bitmap for text and other + * foreground stuff. None means no value + * specified here.*/ + char *justifyString; /* -justify option string (malloc-ed). + * NULL means option not specified. */ + Tk_Justify justify; /* How to justify text: TK_JUSTIFY_LEFT, + * TK_JUSTIFY_RIGHT, or TK_JUSTIFY_CENTER. + * Only valid if justifyString is non-NULL. */ + char *lMargin1String; /* -lmargin1 option string (malloc-ed). + * NULL means option not specified. */ + int lMargin1; /* Left margin for first display line of + * each text line, in pixels. Only valid + * if lMargin1String is non-NULL. */ + char *lMargin2String; /* -lmargin2 option string (malloc-ed). + * NULL means option not specified. */ + int lMargin2; /* Left margin for second and later display + * lines of each text line, in pixels. Only + * valid if lMargin2String is non-NULL. */ + char *offsetString; /* -offset option string (malloc-ed). + * NULL means option not specified. */ + int offset; /* Vertical offset of text's baseline from + * baseline of line. Used for superscripts + * and subscripts. Only valid if + * offsetString is non-NULL. */ + char *overstrikeString; /* -overstrike option string (malloc-ed). + * NULL means option not specified. */ + int overstrike; /* Non-zero means draw horizontal line through + * middle of text. Only valid if + * overstrikeString is non-NULL. */ + char *rMarginString; /* -rmargin option string (malloc-ed). + * NULL means option not specified. */ + int rMargin; /* Right margin for text, in pixels. Only + * valid if rMarginString is non-NULL. */ + char *spacing1String; /* -spacing1 option string (malloc-ed). + * NULL means option not specified. */ + int spacing1; /* Extra spacing above first display + * line for text line. Only valid if + * spacing1String is non-NULL. */ + char *spacing2String; /* -spacing2 option string (malloc-ed). + * NULL means option not specified. */ + int spacing2; /* Extra spacing between display + * lines for the same text line. Only valid + * if spacing2String is non-NULL. */ + char *spacing3String; /* -spacing2 option string (malloc-ed). + * NULL means option not specified. */ + int spacing3; /* Extra spacing below last display + * line for text line. Only valid if + * spacing3String is non-NULL. */ + char *tabString; /* -tabs option string (malloc-ed). + * NULL means option not specified. */ + struct TkTextTabArray *tabArrayPtr; + /* Info about tabs for tag (malloc-ed) + * or NULL. Corresponds to tabString. */ + char *underlineString; /* -underline option string (malloc-ed). + * NULL means option not specified. */ + int underline; /* Non-zero means draw underline underneath + * text. Only valid if underlineString is + * non-NULL. */ + Tk_Uid wrapMode; /* How to handle wrap-around for this tag. + * Must be tkTextCharUid, tkTextNoneUid, + * tkTextWordUid, or NULL to use wrapMode + * for whole widget. */ + int affectsDisplay; /* Non-zero means that this tag affects the + * way information is displayed on the screen + * (so need to redisplay if tag changes). */ +} TkTextTag; + +#define TK_TAG_AFFECTS_DISPLAY 0x1 +#define TK_TAG_UNDERLINE 0x2 +#define TK_TAG_JUSTIFY 0x4 +#define TK_TAG_OFFSET 0x10 + +/* + * The data structure below is used for searching a B-tree for transitions + * on a single tag (or for all tag transitions). No code outside of + * tkTextBTree.c should ever modify any of the fields in these structures, + * but it's OK to use them for read-only information. + */ + +typedef struct TkTextSearch { + TkTextIndex curIndex; /* Position of last tag transition + * returned by TkBTreeNextTag, or + * index of start of segment + * containing starting position for + * search if TkBTreeNextTag hasn't + * been called yet, or same as + * stopIndex if search is over. */ + TkTextSegment *segPtr; /* Actual tag segment returned by last + * call to TkBTreeNextTag, or NULL if + * TkBTreeNextTag hasn't returned + * anything yet. */ + TkTextSegment *nextPtr; /* Where to resume search in next + * call to TkBTreeNextTag. */ + TkTextSegment *lastPtr; /* Stop search before just before + * considering this segment. */ + TkTextTag *tagPtr; /* Tag to search for (or tag found, if + * allTags is non-zero). */ + int linesLeft; /* Lines left to search (including + * curIndex and stopIndex). When + * this becomes <= 0 the search is + * over. */ + int allTags; /* Non-zero means ignore tag check: + * search for transitions on all + * tags. */ +} TkTextSearch; + +/* + * The following data structure describes a single tab stop. + */ + +typedef enum {LEFT, RIGHT, CENTER, NUMERIC} TkTextTabAlign; + +typedef struct TkTextTab { + int location; /* Offset in pixels of this tab stop + * from the left margin (lmargin2) of + * the text. */ + TkTextTabAlign alignment; /* Where the tab stop appears relative + * to the text. */ +} TkTextTab; + +typedef struct TkTextTabArray { + int numTabs; /* Number of tab stops. */ + TkTextTab tabs[1]; /* Array of tabs. The actual size + * will be numTabs. THIS FIELD MUST + * BE THE LAST IN THE STRUCTURE. */ +} TkTextTabArray; + +/* + * A data structure of the following type is kept for each text widget that + * currently exists for this process: + */ + +typedef struct TkText { + Tk_Window tkwin; /* Window that embodies the text. NULL + * means that the window has been destroyed + * but the data structures haven't yet been + * cleaned up.*/ + Display *display; /* Display for widget. Needed, among other + * things, to allow resources to be freed + * even after tkwin has gone away. */ + Tcl_Interp *interp; /* Interpreter associated with widget. Used + * to delete widget command. */ + Tcl_Command widgetCmd; /* Token for text's widget command. */ + TkTextBTree tree; /* B-tree representation of text and tags for + * widget. */ + Tcl_HashTable tagTable; /* Hash table that maps from tag names to + * pointers to TkTextTag structures. */ + int numTags; /* Number of tags currently defined for + * widget; needed to keep track of + * priorities. */ + Tcl_HashTable markTable; /* Hash table that maps from mark names to + * pointers to mark segments. */ + Tcl_HashTable windowTable; /* Hash table that maps from window names + * to pointers to window segments. If a + * window segment doesn't yet have an + * associated window, there is no entry for + * it here. */ + Tcl_HashTable imageTable; /* Hash table that maps from image names + * to pointers to image segments. If an + * image segment doesn't yet have an + * associated image, there is no entry for + * it here. */ + Tk_Uid state; /* Normal or disabled. Text is read-only + * when disabled. */ + + /* + * Default information for displaying (may be overridden by tags + * applied to ranges of characters). + */ + + Tk_3DBorder border; /* Structure used to draw 3-D border and + * default background. */ + int borderWidth; /* Width of 3-D border to draw around entire + * widget. */ + int padX, padY; /* Padding between text and window border. */ + int relief; /* 3-d effect for border around entire + * widget: TK_RELIEF_RAISED etc. */ + int highlightWidth; /* Width in pixels of highlight to draw + * around widget when it has the focus. + * <= 0 means don't draw a highlight. */ + XColor *highlightBgColorPtr; + /* Color for drawing traversal highlight + * area when highlight is off. */ + XColor *highlightColorPtr; /* Color for drawing traversal highlight. */ + Tk_Cursor cursor; /* Current cursor for window, or None. */ + XColor *fgColor; /* Default foreground color for text. */ + Tk_Font tkfont; /* Default font for displaying text. */ + int charWidth; /* Width of average character in default + * font. */ + int spacing1; /* Default extra spacing above first display + * line for each text line. */ + int spacing2; /* Default extra spacing between display lines + * for the same text line. */ + int spacing3; /* Default extra spacing below last display + * line for each text line. */ + char *tabOptionString; /* Value of -tabs option string (malloc'ed). */ + TkTextTabArray *tabArrayPtr; + /* Information about tab stops (malloc'ed). + * NULL means perform default tabbing + * behavior. */ + + /* + * Additional information used for displaying: + */ + + Tk_Uid wrapMode; /* How to handle wrap-around. Must be + * tkTextCharUid, tkTextNoneUid, or + * tkTextWordUid. */ + int width, height; /* Desired dimensions for window, measured + * in characters. */ + int setGrid; /* Non-zero means pass gridding information + * to window manager. */ + int prevWidth, prevHeight; /* Last known dimensions of window; used to + * detect changes in size. */ + TkTextIndex topIndex; /* Identifies first character in top display + * line of window. */ + struct TextDInfo *dInfoPtr; /* Information maintained by tkTextDisp.c. */ + + /* + * Information related to selection. + */ + + TkTextTag *selTagPtr; /* Pointer to "sel" tag. Used to tell when + * a new selection has been made. */ + Tk_3DBorder selBorder; /* Border and background for selected + * characters. This is a copy of information + * in *cursorTagPtr, so it shouldn't be + * explicitly freed. */ + char *selBdString; /* Value of -selectborderwidth option, or NULL + * if not specified (malloc'ed). */ + XColor *selFgColorPtr; /* Foreground color for selected text. + * This is a copy of information in + * *cursorTagPtr, so it shouldn't be + * explicitly freed. */ + int exportSelection; /* Non-zero means tie "sel" tag to X + * selection. */ + TkTextIndex selIndex; /* Used during multi-pass selection retrievals. + * This index identifies the next character + * to be returned from the selection. */ + int abortSelections; /* Set to 1 whenever the text is modified + * in a way that interferes with selection + * retrieval: used to abort incremental + * selection retrievals. */ + int selOffset; /* Offset in selection corresponding to + * selLine and selCh. -1 means neither + * this information nor selIndex is of any + * use. */ + + /* + * Information related to insertion cursor: + */ + + TkTextSegment *insertMarkPtr; + /* Points to segment for "insert" mark. */ + Tk_3DBorder insertBorder; /* Used to draw vertical bar for insertion + * cursor. */ + int insertWidth; /* Total width of insert cursor. */ + int insertBorderWidth; /* Width of 3-D border around insert cursor. */ + int insertOnTime; /* Number of milliseconds cursor should spend + * in "on" state for each blink. */ + int insertOffTime; /* Number of milliseconds cursor should spend + * in "off" state for each blink. */ + Tcl_TimerToken insertBlinkHandler; + /* Timer handler used to blink cursor on and + * off. */ + + /* + * Information used for event bindings associated with tags: + */ + + Tk_BindingTable bindingTable; + /* Table of all bindings currently defined + * for this widget. NULL means that no + * bindings exist, so the table hasn't been + * created. Each "object" used for this + * table is the address of a tag. */ + TkTextSegment *currentMarkPtr; + /* Pointer to segment for "current" mark, + * or NULL if none. */ + XEvent pickEvent; /* The event from which the current character + * was chosen. Must be saved so that we + * can repick after modifications to the + * text. */ + int numCurTags; /* Number of tags associated with character + * at current mark. */ + TkTextTag **curTagArrayPtr; /* Pointer to array of tags for current + * mark, or NULL if none. */ + + /* + * Miscellaneous additional information: + */ + + char *takeFocus; /* Value of -takeFocus option; not used in + * the C code, but used by keyboard traversal + * scripts. Malloc'ed, but may be NULL. */ + char *xScrollCmd; /* Prefix of command to issue to update + * horizontal scrollbar when view changes. */ + char *yScrollCmd; /* Prefix of command to issue to update + * vertical scrollbar when view changes. */ + int flags; /* Miscellaneous flags; see below for + * definitions. */ +} TkText; + +/* + * Flag values for TkText records: + * + * GOT_SELECTION: Non-zero means we've already claimed the + * selection. + * INSERT_ON: Non-zero means insertion cursor should be + * displayed on screen. + * GOT_FOCUS: Non-zero means this window has the input + * focus. + * BUTTON_DOWN: 1 means that a mouse button is currently + * down; this is used to implement grabs + * for the duration of button presses. + * UPDATE_SCROLLBARS: Non-zero means scrollbar(s) should be updated + * during next redisplay operation. + */ + +#define GOT_SELECTION 1 +#define INSERT_ON 2 +#define GOT_FOCUS 4 +#define BUTTON_DOWN 8 +#define UPDATE_SCROLLBARS 0x10 +#define NEED_REPICK 0x20 + +/* + * Records of the following type define segment types in terms of + * a collection of procedures that may be called to manipulate + * segments of that type. + */ + +typedef TkTextSegment * Tk_SegSplitProc _ANSI_ARGS_(( + struct TkTextSegment *segPtr, int index)); +typedef int Tk_SegDeleteProc _ANSI_ARGS_(( + struct TkTextSegment *segPtr, + TkTextLine *linePtr, int treeGone)); +typedef TkTextSegment * Tk_SegCleanupProc _ANSI_ARGS_(( + struct TkTextSegment *segPtr, TkTextLine *linePtr)); +typedef void Tk_SegLineChangeProc _ANSI_ARGS_(( + struct TkTextSegment *segPtr, TkTextLine *linePtr)); +typedef int Tk_SegLayoutProc _ANSI_ARGS_((struct TkText *textPtr, + struct TkTextIndex *indexPtr, TkTextSegment *segPtr, + int offset, int maxX, int maxChars, + int noCharsYet, Tk_Uid wrapMode, + struct TkTextDispChunk *chunkPtr)); +typedef void Tk_SegCheckProc _ANSI_ARGS_((TkTextSegment *segPtr, + TkTextLine *linePtr)); + +typedef struct Tk_SegType { + char *name; /* Name of this kind of segment. */ + int leftGravity; /* If a segment has zero size (e.g. a + * mark or tag toggle), does it + * attach to character to its left + * or right? 1 means left, 0 means + * right. */ + Tk_SegSplitProc *splitProc; /* Procedure to split large segment + * into two smaller ones. */ + Tk_SegDeleteProc *deleteProc; /* Procedure to call to delete + * segment. */ + Tk_SegCleanupProc *cleanupProc; /* After any change to a line, this + * procedure is invoked for all + * segments left in the line to + * perform any cleanup they wish + * (e.g. joining neighboring + * segments). */ + Tk_SegLineChangeProc *lineChangeProc; + /* Invoked when a segment is about + * to be moved from its current line + * to an earlier line because of + * a deletion. The linePtr is that + * for the segment's old line. + * CleanupProc will be invoked after + * the deletion is finished. */ + Tk_SegLayoutProc *layoutProc; /* Returns size information when + * figuring out what to display in + * window. */ + Tk_SegCheckProc *checkProc; /* Called during consistency checks + * to check internal consistency of + * segment. */ +} Tk_SegType; + +/* + * The constant below is used to specify a line when what is really + * wanted is the entire text. For now, just use a very big number. + */ + +#define TK_END_OF_TEXT 1000000 + +/* + * The following definition specifies the maximum number of characters + * needed in a string to hold a position specifier. + */ + +#define TK_POS_CHARS 30 + +/* + * Declarations for variables shared among the text-related files: + */ + +extern int tkBTreeDebug; +extern int tkTextDebug; +extern Tk_SegType tkTextCharType; +extern Tk_Uid tkTextCharUid; +extern Tk_Uid tkTextDisabledUid; +extern Tk_SegType tkTextLeftMarkType; +extern Tk_Uid tkTextNoneUid; +extern Tk_Uid tkTextNormalUid; +extern Tk_SegType tkTextRightMarkType; +extern Tk_SegType tkTextToggleOnType; +extern Tk_SegType tkTextToggleOffType; +extern Tk_Uid tkTextWordUid; + +/* + * Declarations for procedures that are used by the text-related files + * but shouldn't be used anywhere else in Tk (or by Tk clients): + */ + +extern int TkBTreeCharTagged _ANSI_ARGS_((TkTextIndex *indexPtr, + TkTextTag *tagPtr)); +extern void TkBTreeCheck _ANSI_ARGS_((TkTextBTree tree)); +extern int TkBTreeCharsInLine _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, + TkTextIndex *index2Ptr)); +extern TkTextLine * TkBTreeFindLine _ANSI_ARGS_((TkTextBTree tree, + int line)); +extern TkTextTag ** TkBTreeGetTags _ANSI_ARGS_((TkTextIndex *indexPtr, + int *numTagsPtr)); +extern void TkBTreeInsertChars _ANSI_ARGS_((TkTextIndex *indexPtr, + char *string)); +extern int TkBTreeLineIndex _ANSI_ARGS_((TkTextLine *linePtr)); +extern void TkBTreeLinkSegment _ANSI_ARGS_((TkTextSegment *segPtr, + TkTextIndex *indexPtr)); +extern TkTextLine * TkBTreeNextLine _ANSI_ARGS_((TkTextLine *linePtr)); +extern int TkBTreeNextTag _ANSI_ARGS_((TkTextSearch *searchPtr)); +extern int TkBTreeNumLines _ANSI_ARGS_((TkTextBTree tree)); +extern TkTextLine * TkBTreePreviousLine _ANSI_ARGS_((TkTextLine *linePtr)); +extern int TkBTreePrevTag _ANSI_ARGS_((TkTextSearch *searchPtr)); +extern void TkBTreeStartSearch _ANSI_ARGS_((TkTextIndex *index1Ptr, + TkTextIndex *index2Ptr, TkTextTag *tagPtr, + TkTextSearch *searchPtr)); +extern void TkBTreeStartSearchBack _ANSI_ARGS_((TkTextIndex *index1Ptr, + TkTextIndex *index2Ptr, TkTextTag *tagPtr, + TkTextSearch *searchPtr)); +extern void TkBTreeTag _ANSI_ARGS_((TkTextIndex *index1Ptr, + TkTextIndex *index2Ptr, TkTextTag *tagPtr, + int add)); +extern void TkBTreeUnlinkSegment _ANSI_ARGS_((TkTextBTree tree, + TkTextSegment *segPtr, TkTextLine *linePtr)); +extern void TkTextBindProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +extern void TkTextChanged _ANSI_ARGS_((TkText *textPtr, + TkTextIndex *index1Ptr, TkTextIndex *index2Ptr)); +extern int TkTextCharBbox _ANSI_ARGS_((TkText *textPtr, + TkTextIndex *indexPtr, int *xPtr, int *yPtr, + int *widthPtr, int *heightPtr)); +extern int TkTextCharLayoutProc _ANSI_ARGS_((TkText *textPtr, + TkTextIndex *indexPtr, TkTextSegment *segPtr, + int offset, int maxX, int maxChars, int noBreakYet, + Tk_Uid wrapMode, TkTextDispChunk *chunkPtr)); +extern void TkTextCreateDInfo _ANSI_ARGS_((TkText *textPtr)); +extern int TkTextDLineInfo _ANSI_ARGS_((TkText *textPtr, + TkTextIndex *indexPtr, int *xPtr, int *yPtr, + int *widthPtr, int *heightPtr, int *basePtr)); +extern TkTextTag * TkTextCreateTag _ANSI_ARGS_((TkText *textPtr, + char *tagName)); +extern void TkTextFreeDInfo _ANSI_ARGS_((TkText *textPtr)); +extern void TkTextFreeTag _ANSI_ARGS_((TkText *textPtr, + TkTextTag *tagPtr)); +extern int TkTextGetIndex _ANSI_ARGS_((Tcl_Interp *interp, + TkText *textPtr, char *string, + 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 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, + int lineIndex, int charIndex, + TkTextIndex *indexPtr)); +extern int TkTextMarkCmd _ANSI_ARGS_((TkText *textPtr, + Tcl_Interp *interp, int argc, char **argv)); +extern int TkTextMarkNameToIndex _ANSI_ARGS_((TkText *textPtr, + char *name, TkTextIndex *indexPtr)); +extern void TkTextMarkSegToIndex _ANSI_ARGS_((TkText *textPtr, + TkTextSegment *markPtr, TkTextIndex *indexPtr)); +extern void TkTextEventuallyRepick _ANSI_ARGS_((TkText *textPtr)); +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 TkTextRedrawRegion _ANSI_ARGS_((TkText *textPtr, + int x, int y, int width, int height)); +extern void TkTextRedrawTag _ANSI_ARGS_((TkText *textPtr, + TkTextIndex *index1Ptr, TkTextIndex *index2Ptr, + TkTextTag *tagPtr, int withTag)); +extern void TkTextRelayoutWindow _ANSI_ARGS_((TkText *textPtr)); +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 TkTextSegment * TkTextSetMark _ANSI_ARGS_((TkText *textPtr, char *name, + TkTextIndex *indexPtr)); +extern void TkTextSetYView _ANSI_ARGS_((TkText *textPtr, + TkTextIndex *indexPtr, int pickPlace)); +extern int TkTextTagCmd _ANSI_ARGS_((TkText *textPtr, + Tcl_Interp *interp, int argc, char **argv)); +extern int TkTextImageCmd _ANSI_ARGS_((TkText *textPtr, + Tcl_Interp *interp, int argc, char **argv)); +extern int TkTextImageIndex _ANSI_ARGS_((TkText *textPtr, + char *name, TkTextIndex *indexPtr)); +extern int TkTextWindowCmd _ANSI_ARGS_((TkText *textPtr, + Tcl_Interp *interp, int argc, char **argv)); +extern int TkTextWindowIndex _ANSI_ARGS_((TkText *textPtr, + char *name, TkTextIndex *indexPtr)); +extern int TkTextXviewCmd _ANSI_ARGS_((TkText *textPtr, + Tcl_Interp *interp, int argc, char **argv)); +extern int TkTextYviewCmd _ANSI_ARGS_((TkText *textPtr, + Tcl_Interp *interp, int argc, char **argv)); + +#endif /* _TKTEXT */ diff --git a/generic/tkTextBTree.c b/generic/tkTextBTree.c new file mode 100644 index 0000000..2fd7deb --- /dev/null +++ b/generic/tkTextBTree.c @@ -0,0 +1,3594 @@ +/* + * tkTextBTree.c -- + * + * This file contains code that manages the B-tree representation + * of text for Tk's text widget and implements character and + * toggle segment types. + * + * Copyright (c) 1992-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkTextBTree.c 1.37 97/04/25 16:52:00 + */ + +#include "tkInt.h" +#include "tkPort.h" +#include "tkText.h" + +/* + * The data structure below keeps summary information about one tag as part + * of the tag information in a node. + */ + +typedef struct Summary { + TkTextTag *tagPtr; /* Handle for tag. */ + int toggleCount; /* Number of transitions into or + * out of this tag that occur in + * the subtree rooted at this node. */ + struct Summary *nextPtr; /* Next in list of all tags for same + * node, or NULL if at end of list. */ +} Summary; + +/* + * The data structure below defines a node in the B-tree. + */ + +typedef struct Node { + struct Node *parentPtr; /* Pointer to parent node, or NULL if + * this is the root. */ + struct Node *nextPtr; /* Next in list of siblings with the + * same parent node, or NULL for end + * of list. */ + Summary *summaryPtr; /* First in malloc-ed list of info + * about tags in this subtree (NULL if + * no tag info in the subtree). */ + int level; /* Level of this node in the B-tree. + * 0 refers to the bottom of the tree + * (children are lines, not nodes). */ + union { /* First in linked list of children. */ + struct Node *nodePtr; /* Used if level > 0. */ + TkTextLine *linePtr; /* Used if level == 0. */ + } children; + int numChildren; /* Number of children of this node. */ + int numLines; /* Total number of lines (leaves) in + * the subtree rooted here. */ +} Node; + +/* + * Upper and lower bounds on how many children a node may have: + * rebalance when either of these limits is exceeded. MAX_CHILDREN + * should be twice MIN_CHILDREN and MIN_CHILDREN must be >= 2. + */ + +#define MAX_CHILDREN 12 +#define MIN_CHILDREN 6 + +/* + * The data structure below defines an entire B-tree. + */ + +typedef struct BTree { + Node *rootPtr; /* Pointer to root of B-tree. */ + TkText *textPtr; /* Used to find tagTable in consistency + * checking code */ +} BTree; + +/* + * The structure below is used to pass information between + * TkBTreeGetTags and IncCount: + */ + +typedef struct TagInfo { + int numTags; /* Number of tags for which there + * is currently information in + * tags and counts. */ + int arraySize; /* Number of entries allocated for + * tags and counts. */ + TkTextTag **tagPtrs; /* Array of tags seen so far. + * Malloc-ed. */ + int *counts; /* Toggle count (so far) for each + * entry in tags. Malloc-ed. */ +} TagInfo; + +/* + * Variable that indicates whether to enable consistency checks for + * debugging. + */ + +int tkBTreeDebug = 0; + +/* + * Macros that determine how much space to allocate for new segments: + */ + +#define CSEG_SIZE(chars) ((unsigned) (Tk_Offset(TkTextSegment, body) \ + + 1 + (chars))) +#define TSEG_SIZE ((unsigned) (Tk_Offset(TkTextSegment, body) \ + + sizeof(TkTextToggle))) + +/* + * Forward declarations for procedures defined in this file: + */ + +static void ChangeNodeToggleCount _ANSI_ARGS_((Node *nodePtr, + TkTextTag *tagPtr, int delta)); +static void CharCheckProc _ANSI_ARGS_((TkTextSegment *segPtr, + TkTextLine *linePtr)); +static int CharDeleteProc _ANSI_ARGS_((TkTextSegment *segPtr, + TkTextLine *linePtr, int treeGone)); +static TkTextSegment * CharCleanupProc _ANSI_ARGS_((TkTextSegment *segPtr, + TkTextLine *linePtr)); +static TkTextSegment * CharSplitProc _ANSI_ARGS_((TkTextSegment *segPtr, + int index)); +static void CheckNodeConsistency _ANSI_ARGS_((Node *nodePtr)); +static void CleanupLine _ANSI_ARGS_((TkTextLine *linePtr)); +static void DeleteSummaries _ANSI_ARGS_((Summary *tagPtr)); +static void DestroyNode _ANSI_ARGS_((Node *nodePtr)); +static TkTextSegment * FindTagEnd _ANSI_ARGS_((TkTextBTree tree, + TkTextTag *tagPtr, TkTextIndex *indexPtr)); +static void IncCount _ANSI_ARGS_((TkTextTag *tagPtr, int inc, + TagInfo *tagInfoPtr)); +static void Rebalance _ANSI_ARGS_((BTree *treePtr, Node *nodePtr)); +static void RecomputeNodeCounts _ANSI_ARGS_((Node *nodePtr)); +static TkTextSegment * SplitSeg _ANSI_ARGS_((TkTextIndex *indexPtr)); +static void ToggleCheckProc _ANSI_ARGS_((TkTextSegment *segPtr, + TkTextLine *linePtr)); +static TkTextSegment * ToggleCleanupProc _ANSI_ARGS_((TkTextSegment *segPtr, + TkTextLine *linePtr)); +static int ToggleDeleteProc _ANSI_ARGS_((TkTextSegment *segPtr, + TkTextLine *linePtr, int treeGone)); +static void ToggleLineChangeProc _ANSI_ARGS_((TkTextSegment *segPtr, + TkTextLine *linePtr)); +static TkTextSegment * FindTagStart _ANSI_ARGS_((TkTextBTree tree, + TkTextTag *tagPtr, TkTextIndex *indexPtr)); + +/* + * Type record for character segments: + */ + +Tk_SegType tkTextCharType = { + "character", /* name */ + 0, /* leftGravity */ + CharSplitProc, /* splitProc */ + CharDeleteProc, /* deleteProc */ + CharCleanupProc, /* cleanupProc */ + (Tk_SegLineChangeProc *) NULL, /* lineChangeProc */ + TkTextCharLayoutProc, /* layoutProc */ + CharCheckProc /* checkProc */ +}; + +/* + * Type record for segments marking the beginning of a tagged + * range: + */ + +Tk_SegType tkTextToggleOnType = { + "toggleOn", /* name */ + 0, /* leftGravity */ + (Tk_SegSplitProc *) NULL, /* splitProc */ + ToggleDeleteProc, /* deleteProc */ + ToggleCleanupProc, /* cleanupProc */ + ToggleLineChangeProc, /* lineChangeProc */ + (Tk_SegLayoutProc *) NULL, /* layoutProc */ + ToggleCheckProc /* checkProc */ +}; + +/* + * Type record for segments marking the end of a tagged + * range: + */ + +Tk_SegType tkTextToggleOffType = { + "toggleOff", /* name */ + 1, /* leftGravity */ + (Tk_SegSplitProc *) NULL, /* splitProc */ + ToggleDeleteProc, /* deleteProc */ + ToggleCleanupProc, /* cleanupProc */ + ToggleLineChangeProc, /* lineChangeProc */ + (Tk_SegLayoutProc *) NULL, /* layoutProc */ + ToggleCheckProc /* checkProc */ +}; + +/* + *---------------------------------------------------------------------- + * + * TkBTreeCreate -- + * + * This procedure is called to create a new text B-tree. + * + * Results: + * The return value is a pointer to a new B-tree containing + * one line with nothing but a newline character. + * + * Side effects: + * Memory is allocated and initialized. + * + *---------------------------------------------------------------------- + */ + +TkTextBTree +TkBTreeCreate(textPtr) + TkText *textPtr; +{ + register BTree *treePtr; + register Node *rootPtr; + register TkTextLine *linePtr, *linePtr2; + register TkTextSegment *segPtr; + + /* + * The tree will initially have two empty lines. The second line + * isn't actually part of the tree's contents, but its presence + * makes several operations easier. The tree will have one node, + * which is also the root of the tree. + */ + + rootPtr = (Node *) ckalloc(sizeof(Node)); + linePtr = (TkTextLine *) ckalloc(sizeof(TkTextLine)); + linePtr2 = (TkTextLine *) ckalloc(sizeof(TkTextLine)); + rootPtr->parentPtr = NULL; + rootPtr->nextPtr = NULL; + rootPtr->summaryPtr = NULL; + rootPtr->level = 0; + rootPtr->children.linePtr = linePtr; + rootPtr->numChildren = 2; + rootPtr->numLines = 2; + + linePtr->parentPtr = rootPtr; + linePtr->nextPtr = linePtr2; + segPtr = (TkTextSegment *) ckalloc(CSEG_SIZE(1)); + linePtr->segPtr = segPtr; + segPtr->typePtr = &tkTextCharType; + segPtr->nextPtr = NULL; + segPtr->size = 1; + segPtr->body.chars[0] = '\n'; + segPtr->body.chars[1] = 0; + + linePtr2->parentPtr = rootPtr; + linePtr2->nextPtr = NULL; + segPtr = (TkTextSegment *) ckalloc(CSEG_SIZE(1)); + linePtr2->segPtr = segPtr; + segPtr->typePtr = &tkTextCharType; + segPtr->nextPtr = NULL; + segPtr->size = 1; + segPtr->body.chars[0] = '\n'; + segPtr->body.chars[1] = 0; + + treePtr = (BTree *) ckalloc(sizeof(BTree)); + treePtr->rootPtr = rootPtr; + treePtr->textPtr = textPtr; + + return (TkTextBTree) treePtr; +} + +/* + *---------------------------------------------------------------------- + * + * TkBTreeDestroy -- + * + * Delete a B-tree, recycling all of the storage it contains. + * + * Results: + * The tree given by treePtr is deleted. TreePtr should never + * again be used. + * + * Side effects: + * Memory is freed. + * + *---------------------------------------------------------------------- + */ + +void +TkBTreeDestroy(tree) + TkTextBTree tree; /* Pointer to tree to delete. */ +{ + BTree *treePtr = (BTree *) tree; + + DestroyNode(treePtr->rootPtr); + ckfree((char *) treePtr); +} + +/* + *---------------------------------------------------------------------- + * + * DestroyNode -- + * + * This is a recursive utility procedure used during the deletion + * of a B-tree. + * + * Results: + * None. + * + * Side effects: + * All the storage for nodePtr and its descendants is freed. + * + *---------------------------------------------------------------------- + */ + +static void +DestroyNode(nodePtr) + register Node *nodePtr; +{ + if (nodePtr->level == 0) { + TkTextLine *linePtr; + TkTextSegment *segPtr; + + while (nodePtr->children.linePtr != NULL) { + linePtr = nodePtr->children.linePtr; + nodePtr->children.linePtr = linePtr->nextPtr; + while (linePtr->segPtr != NULL) { + segPtr = linePtr->segPtr; + linePtr->segPtr = segPtr->nextPtr; + (*segPtr->typePtr->deleteProc)(segPtr, linePtr, 1); + } + ckfree((char *) linePtr); + } + } else { + register Node *childPtr; + + while (nodePtr->children.nodePtr != NULL) { + childPtr = nodePtr->children.nodePtr; + nodePtr->children.nodePtr = childPtr->nextPtr; + DestroyNode(childPtr); + } + } + DeleteSummaries(nodePtr->summaryPtr); + ckfree((char *) nodePtr); +} + +/* + *---------------------------------------------------------------------- + * + * DeleteSummaries -- + * + * Free up all of the memory in a list of tag summaries associated + * with a node. + * + * Results: + * None. + * + * Side effects: + * Storage is released. + * + *---------------------------------------------------------------------- + */ + +static void +DeleteSummaries(summaryPtr) + register Summary *summaryPtr; /* First in list of node's tag + * summaries. */ +{ + register Summary *nextPtr; + while (summaryPtr != NULL) { + nextPtr = summaryPtr->nextPtr; + ckfree((char *) summaryPtr); + summaryPtr = nextPtr; + } +} + +/* + *---------------------------------------------------------------------- + * + * TkBTreeInsertChars -- + * + * Insert characters at a given position in a B-tree. + * + * Results: + * None. + * + * Side effects: + * Characters are added to the B-tree at the given position. + * If the string contains newlines, new lines will be added, + * which could cause the structure of the B-tree to change. + * + *---------------------------------------------------------------------- + */ + +void +TkBTreeInsertChars(indexPtr, string) + register TkTextIndex *indexPtr; /* Indicates where to insert text. + * When the procedure returns, this + * index is no longer valid because + * of changes to the segment + * structure. */ + char *string; /* Pointer to bytes to insert (may + * contain newlines, must be null- + * terminated). */ +{ + register Node *nodePtr; + register TkTextSegment *prevPtr; /* The segment just before the first + * new segment (NULL means new segment + * is at beginning of line). */ + TkTextSegment *curPtr; /* Current segment; new characters + * are inserted just after this one. + * NULL means insert at beginning of + * line. */ + TkTextLine *linePtr; /* Current line (new segments are + * added to this line). */ + register TkTextSegment *segPtr; + TkTextLine *newLinePtr; + int chunkSize; /* # characters in current chunk. */ + register char *eol; /* Pointer to character just after last + * one in current chunk. */ + int changeToLineCount; /* Counts change to total number of + * lines in file. */ + + prevPtr = SplitSeg(indexPtr); + linePtr = indexPtr->linePtr; + curPtr = prevPtr; + + /* + * Chop the string up into lines and create a new segment for + * each line, plus a new line for the leftovers from the + * previous line. + */ + + changeToLineCount = 0; + while (*string != 0) { + for (eol = string; *eol != 0; eol++) { + if (*eol == '\n') { + eol++; + break; + } + } + chunkSize = eol-string; + segPtr = (TkTextSegment *) ckalloc(CSEG_SIZE(chunkSize)); + segPtr->typePtr = &tkTextCharType; + if (curPtr == NULL) { + segPtr->nextPtr = linePtr->segPtr; + linePtr->segPtr = segPtr; + } else { + segPtr->nextPtr = curPtr->nextPtr; + curPtr->nextPtr = segPtr; + } + segPtr->size = chunkSize; + strncpy(segPtr->body.chars, string, (size_t) chunkSize); + segPtr->body.chars[chunkSize] = 0; + + if (eol[-1] != '\n') { + break; + } + + /* + * The chunk ended with a newline, so create a new TkTextLine + * and move the remainder of the old line to it. + */ + + newLinePtr = (TkTextLine *) ckalloc(sizeof(TkTextLine)); + newLinePtr->parentPtr = linePtr->parentPtr; + newLinePtr->nextPtr = linePtr->nextPtr; + linePtr->nextPtr = newLinePtr; + newLinePtr->segPtr = segPtr->nextPtr; + segPtr->nextPtr = NULL; + linePtr = newLinePtr; + curPtr = NULL; + changeToLineCount++; + + string = eol; + } + + /* + * Cleanup the starting line for the insertion, plus the ending + * line if it's different. + */ + + CleanupLine(indexPtr->linePtr); + if (linePtr != indexPtr->linePtr) { + CleanupLine(linePtr); + } + + /* + * Increment the line counts in all the parent nodes of the insertion + * point, then rebalance the tree if necessary. + */ + + for (nodePtr = linePtr->parentPtr ; nodePtr != NULL; + nodePtr = nodePtr->parentPtr) { + nodePtr->numLines += changeToLineCount; + } + nodePtr = linePtr->parentPtr; + nodePtr->numChildren += changeToLineCount; + if (nodePtr->numChildren > MAX_CHILDREN) { + Rebalance((BTree *) indexPtr->tree, nodePtr); + } + + if (tkBTreeDebug) { + TkBTreeCheck(indexPtr->tree); + } +} + +/* + *-------------------------------------------------------------- + * + * SplitSeg -- + * + * This procedure is called before adding or deleting + * segments. It does three things: (a) it finds the segment + * containing indexPtr; (b) if there are several such + * segments (because some segments have zero length) then + * it picks the first segment that does not have left + * gravity; (c) if the index refers to the middle of + * a segment then it splits the segment so that the + * index now refers to the beginning of a segment. + * + * Results: + * The return value is a pointer to the segment just + * before the segment corresponding to indexPtr (as + * described above). If the segment corresponding to + * indexPtr is the first in its line then the return + * value is NULL. + * + * Side effects: + * The segment referred to by indexPtr is split unless + * indexPtr refers to its first character. + * + *-------------------------------------------------------------- + */ + +static TkTextSegment * +SplitSeg(indexPtr) + TkTextIndex *indexPtr; /* Index identifying position + * at which to split a segment. */ +{ + TkTextSegment *prevPtr, *segPtr; + int count; + + for (count = indexPtr->charIndex, prevPtr = NULL, + segPtr = indexPtr->linePtr->segPtr; segPtr != NULL; + count -= segPtr->size, prevPtr = segPtr, segPtr = segPtr->nextPtr) { + if (segPtr->size > count) { + if (count == 0) { + return prevPtr; + } + segPtr = (*segPtr->typePtr->splitProc)(segPtr, count); + if (prevPtr == NULL) { + indexPtr->linePtr->segPtr = segPtr; + } else { + prevPtr->nextPtr = segPtr; + } + return segPtr; + } else if ((segPtr->size == 0) && (count == 0) + && !segPtr->typePtr->leftGravity) { + return prevPtr; + } + } + panic("SplitSeg reached end of line!"); + return NULL; +} + +/* + *-------------------------------------------------------------- + * + * CleanupLine -- + * + * This procedure is called after modifications have been + * made to a line. It scans over all of the segments in + * the line, giving each a chance to clean itself up, e.g. + * by merging with the following segments, updating internal + * information, etc. + * + * Results: + * None. + * + * Side effects: + * Depends on what the segment-specific cleanup procedures do. + * + *-------------------------------------------------------------- + */ + +static void +CleanupLine(linePtr) + TkTextLine *linePtr; /* Line to be cleaned up. */ +{ + TkTextSegment *segPtr, **prevPtrPtr; + int anyChanges; + + /* + * Make a pass over all of the segments in the line, giving each + * a chance to clean itself up. This could potentially change + * the structure of the line, e.g. by merging two segments + * together or having two segments cancel themselves; if so, + * then repeat the whole process again, since the first structure + * change might make other structure changes possible. Repeat + * until eventually there are no changes. + */ + + while (1) { + anyChanges = 0; + for (prevPtrPtr = &linePtr->segPtr, segPtr = *prevPtrPtr; + segPtr != NULL; + prevPtrPtr = &(*prevPtrPtr)->nextPtr, segPtr = *prevPtrPtr) { + if (segPtr->typePtr->cleanupProc != NULL) { + *prevPtrPtr = (*segPtr->typePtr->cleanupProc)(segPtr, linePtr); + if (segPtr != *prevPtrPtr) { + anyChanges = 1; + } + } + } + if (!anyChanges) { + break; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TkBTreeDeleteChars -- + * + * Delete a range of characters from a B-tree. The caller + * must make sure that the final newline of the B-tree is + * never deleted. + * + * Results: + * None. + * + * Side effects: + * Information is deleted from the B-tree. This can cause the + * internal structure of the B-tree to change. Note: because + * of changes to the B-tree structure, the indices pointed + * to by index1Ptr and index2Ptr should not be used after this + * procedure returns. + * + *---------------------------------------------------------------------- + */ + +void +TkBTreeDeleteChars(index1Ptr, index2Ptr) + register TkTextIndex *index1Ptr; /* Indicates first character that is + * to be deleted. */ + register TkTextIndex *index2Ptr; /* Indicates character just after the + * last one that is to be deleted. */ +{ + TkTextSegment *prevPtr; /* The segment just before the start + * of the deletion range. */ + TkTextSegment *lastPtr; /* The segment just after the end + * of the deletion range. */ + TkTextSegment *segPtr, *nextPtr; + TkTextLine *curLinePtr; + Node *curNodePtr, *nodePtr; + + /* + * Tricky point: split at index2Ptr first; otherwise the split + * at index2Ptr may invalidate segPtr and/or prevPtr. + */ + + lastPtr = SplitSeg(index2Ptr); + if (lastPtr != NULL) { + lastPtr = lastPtr->nextPtr; + } else { + lastPtr = index2Ptr->linePtr->segPtr; + } + prevPtr = SplitSeg(index1Ptr); + if (prevPtr != NULL) { + segPtr = prevPtr->nextPtr; + prevPtr->nextPtr = lastPtr; + } else { + segPtr = index1Ptr->linePtr->segPtr; + index1Ptr->linePtr->segPtr = lastPtr; + } + + /* + * Delete all of the segments between prevPtr and lastPtr. + */ + + curLinePtr = index1Ptr->linePtr; + curNodePtr = curLinePtr->parentPtr; + while (segPtr != lastPtr) { + if (segPtr == NULL) { + TkTextLine *nextLinePtr; + + /* + * We just ran off the end of a line. First find the + * next line, then go back to the old line and delete it + * (unless it's the starting line for the range). + */ + + nextLinePtr = TkBTreeNextLine(curLinePtr); + if (curLinePtr != index1Ptr->linePtr) { + if (curNodePtr == index1Ptr->linePtr->parentPtr) { + index1Ptr->linePtr->nextPtr = curLinePtr->nextPtr; + } else { + curNodePtr->children.linePtr = curLinePtr->nextPtr; + } + for (nodePtr = curNodePtr; nodePtr != NULL; + nodePtr = nodePtr->parentPtr) { + nodePtr->numLines--; + } + curNodePtr->numChildren--; + ckfree((char *) curLinePtr); + } + curLinePtr = nextLinePtr; + segPtr = curLinePtr->segPtr; + + /* + * If the node is empty then delete it and its parents, + * recursively upwards until a non-empty node is found. + */ + + while (curNodePtr->numChildren == 0) { + Node *parentPtr; + + parentPtr = curNodePtr->parentPtr; + if (parentPtr->children.nodePtr == curNodePtr) { + parentPtr->children.nodePtr = curNodePtr->nextPtr; + } else { + Node *prevNodePtr = parentPtr->children.nodePtr; + while (prevNodePtr->nextPtr != curNodePtr) { + prevNodePtr = prevNodePtr->nextPtr; + } + prevNodePtr->nextPtr = curNodePtr->nextPtr; + } + parentPtr->numChildren--; + ckfree((char *) curNodePtr); + curNodePtr = parentPtr; + } + curNodePtr = curLinePtr->parentPtr; + continue; + } + + nextPtr = segPtr->nextPtr; + if ((*segPtr->typePtr->deleteProc)(segPtr, curLinePtr, 0) != 0) { + /* + * This segment refuses to die. Move it to prevPtr and + * advance prevPtr if the segment has left gravity. + */ + + if (prevPtr == NULL) { + segPtr->nextPtr = index1Ptr->linePtr->segPtr; + index1Ptr->linePtr->segPtr = segPtr; + } else { + segPtr->nextPtr = prevPtr->nextPtr; + prevPtr->nextPtr = segPtr; + } + if (segPtr->typePtr->leftGravity) { + prevPtr = segPtr; + } + } + segPtr = nextPtr; + } + + /* + * If the beginning and end of the deletion range are in different + * lines, join the two lines together and discard the ending line. + */ + + if (index1Ptr->linePtr != index2Ptr->linePtr) { + TkTextLine *prevLinePtr; + + for (segPtr = lastPtr; segPtr != NULL; + segPtr = segPtr->nextPtr) { + if (segPtr->typePtr->lineChangeProc != NULL) { + (*segPtr->typePtr->lineChangeProc)(segPtr, index2Ptr->linePtr); + } + } + curNodePtr = index2Ptr->linePtr->parentPtr; + for (nodePtr = curNodePtr; nodePtr != NULL; + nodePtr = nodePtr->parentPtr) { + nodePtr->numLines--; + } + curNodePtr->numChildren--; + prevLinePtr = curNodePtr->children.linePtr; + if (prevLinePtr == index2Ptr->linePtr) { + curNodePtr->children.linePtr = index2Ptr->linePtr->nextPtr; + } else { + while (prevLinePtr->nextPtr != index2Ptr->linePtr) { + prevLinePtr = prevLinePtr->nextPtr; + } + prevLinePtr->nextPtr = index2Ptr->linePtr->nextPtr; + } + ckfree((char *) index2Ptr->linePtr); + Rebalance((BTree *) index2Ptr->tree, curNodePtr); + } + + /* + * Cleanup the segments in the new line. + */ + + CleanupLine(index1Ptr->linePtr); + + /* + * Lastly, rebalance the first node of the range. + */ + + Rebalance((BTree *) index1Ptr->tree, index1Ptr->linePtr->parentPtr); + if (tkBTreeDebug) { + TkBTreeCheck(index1Ptr->tree); + } +} + +/* + *---------------------------------------------------------------------- + * + * TkBTreeFindLine -- + * + * Find a particular line in a B-tree based on its line number. + * + * Results: + * The return value is a pointer to the line structure for the + * line whose index is "line", or NULL if no such line exists. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +TkTextLine * +TkBTreeFindLine(tree, line) + TkTextBTree tree; /* B-tree in which to find line. */ + int line; /* Index of desired line. */ +{ + BTree *treePtr = (BTree *) tree; + register Node *nodePtr; + register TkTextLine *linePtr; + int linesLeft; + + nodePtr = treePtr->rootPtr; + linesLeft = line; + if ((line < 0) || (line >= nodePtr->numLines)) { + return NULL; + } + + /* + * Work down through levels of the tree until a node is found at + * level 0. + */ + + while (nodePtr->level != 0) { + for (nodePtr = nodePtr->children.nodePtr; + nodePtr->numLines <= linesLeft; + nodePtr = nodePtr->nextPtr) { + if (nodePtr == NULL) { + panic("TkBTreeFindLine ran out of nodes"); + } + linesLeft -= nodePtr->numLines; + } + } + + /* + * Work through the lines attached to the level-0 node. + */ + + for (linePtr = nodePtr->children.linePtr; linesLeft > 0; + linePtr = linePtr->nextPtr) { + if (linePtr == NULL) { + panic("TkBTreeFindLine ran out of lines"); + } + linesLeft -= 1; + } + return linePtr; +} + +/* + *---------------------------------------------------------------------- + * + * TkBTreeNextLine -- + * + * Given an existing line in a B-tree, this procedure locates the + * next line in the B-tree. This procedure is used for scanning + * through the B-tree. + * + * Results: + * The return value is a pointer to the line that immediately + * follows linePtr, or NULL if there is no such line. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +TkTextLine * +TkBTreeNextLine(linePtr) + register TkTextLine *linePtr; /* Pointer to existing line in + * B-tree. */ +{ + register Node *nodePtr; + + if (linePtr->nextPtr != NULL) { + return linePtr->nextPtr; + } + + /* + * This was the last line associated with the particular parent node. + * Search up the tree for the next node, then search down from that + * node to find the first line. + */ + + for (nodePtr = linePtr->parentPtr; ; nodePtr = nodePtr->parentPtr) { + if (nodePtr->nextPtr != NULL) { + nodePtr = nodePtr->nextPtr; + break; + } + if (nodePtr->parentPtr == NULL) { + return (TkTextLine *) NULL; + } + } + while (nodePtr->level > 0) { + nodePtr = nodePtr->children.nodePtr; + } + return nodePtr->children.linePtr; +} + +/* + *---------------------------------------------------------------------- + * + * TkBTreePreviousLine -- + * + * Given an existing line in a B-tree, this procedure locates the + * previous line in the B-tree. This procedure is used for scanning + * through the B-tree in the reverse direction. + * + * Results: + * The return value is a pointer to the line that immediately + * preceeds linePtr, or NULL if there is no such line. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +TkTextLine * +TkBTreePreviousLine(linePtr) + register TkTextLine *linePtr; /* Pointer to existing line in + * B-tree. */ +{ + register Node *nodePtr; + register Node *node2Ptr; + register TkTextLine *prevPtr; + + /* + * Find the line under this node just before the starting line. + */ + prevPtr = linePtr->parentPtr->children.linePtr; /* First line at leaf */ + while (prevPtr != linePtr) { + if (prevPtr->nextPtr == linePtr) { + return prevPtr; + } + prevPtr = prevPtr->nextPtr; + if (prevPtr == (TkTextLine *) NULL) { + panic("TkBTreePreviousLine ran out of lines"); + } + } + + /* + * This was the first line associated with the particular parent node. + * Search up the tree for the previous node, then search down from that + * node to find its last line. + */ + for (nodePtr = linePtr->parentPtr; ; nodePtr = nodePtr->parentPtr) { + if (nodePtr == (Node *) NULL || nodePtr->parentPtr == (Node *) NULL) { + return (TkTextLine *) NULL; + } + if (nodePtr != nodePtr->parentPtr->children.nodePtr) { + break; + } + } + for (node2Ptr = nodePtr->parentPtr->children.nodePtr; ; + node2Ptr = node2Ptr->children.nodePtr) { + while (node2Ptr->nextPtr != nodePtr) { + node2Ptr = node2Ptr->nextPtr; + } + if (node2Ptr->level == 0) { + break; + } + nodePtr = (Node *)NULL; + } + for (prevPtr = node2Ptr->children.linePtr ; ; prevPtr = prevPtr->nextPtr) { + if (prevPtr->nextPtr == (TkTextLine *) NULL) { + return prevPtr; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TkBTreeLineIndex -- + * + * Given a pointer to a line in a B-tree, return the numerical + * index of that line. + * + * Results: + * The result is the index of linePtr within the tree, where 0 + * corresponds to the first line in the tree. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TkBTreeLineIndex(linePtr) + TkTextLine *linePtr; /* Pointer to existing line in + * B-tree. */ +{ + register TkTextLine *linePtr2; + register Node *nodePtr, *parentPtr, *nodePtr2; + int index; + + /* + * First count how many lines precede this one in its level-0 + * node. + */ + + nodePtr = linePtr->parentPtr; + index = 0; + for (linePtr2 = nodePtr->children.linePtr; linePtr2 != linePtr; + linePtr2 = linePtr2->nextPtr) { + if (linePtr2 == NULL) { + panic("TkBTreeLineIndex couldn't find line"); + } + index += 1; + } + + /* + * Now work up through the levels of the tree one at a time, + * counting how many lines are in nodes preceding the current + * node. + */ + + for (parentPtr = nodePtr->parentPtr ; parentPtr != NULL; + nodePtr = parentPtr, parentPtr = parentPtr->parentPtr) { + for (nodePtr2 = parentPtr->children.nodePtr; nodePtr2 != nodePtr; + nodePtr2 = nodePtr2->nextPtr) { + if (nodePtr2 == NULL) { + panic("TkBTreeLineIndex couldn't find node"); + } + index += nodePtr2->numLines; + } + } + return index; +} + +/* + *---------------------------------------------------------------------- + * + * TkBTreeLinkSegment -- + * + * This procedure adds a new segment to a B-tree at a given + * location. + * + * Results: + * None. + * + * Side effects: + * SegPtr will be linked into its tree. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +void +TkBTreeLinkSegment(segPtr, indexPtr) + TkTextSegment *segPtr; /* Pointer to new segment to be added to + * B-tree. Should be completely initialized + * by caller except for nextPtr field. */ + TkTextIndex *indexPtr; /* Where to add segment: it gets linked + * in just before the segment indicated + * here. */ +{ + register TkTextSegment *prevPtr; + + prevPtr = SplitSeg(indexPtr); + if (prevPtr == NULL) { + segPtr->nextPtr = indexPtr->linePtr->segPtr; + indexPtr->linePtr->segPtr = segPtr; + } else { + segPtr->nextPtr = prevPtr->nextPtr; + prevPtr->nextPtr = segPtr; + } + CleanupLine(indexPtr->linePtr); + if (tkBTreeDebug) { + TkBTreeCheck(indexPtr->tree); + } +} + +/* + *---------------------------------------------------------------------- + * + * TkBTreeUnlinkSegment -- + * + * This procedure unlinks a segment from its line in a B-tree. + * + * Results: + * None. + * + * Side effects: + * SegPtr will be unlinked from linePtr. The segment itself + * isn't modified by this procedure. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +void +TkBTreeUnlinkSegment(tree, segPtr, linePtr) + TkTextBTree tree; /* Tree containing segment. */ + TkTextSegment *segPtr; /* Segment to be unlinked. */ + TkTextLine *linePtr; /* Line that currently contains + * segment. */ +{ + register TkTextSegment *prevPtr; + + if (linePtr->segPtr == segPtr) { + linePtr->segPtr = segPtr->nextPtr; + } else { + for (prevPtr = linePtr->segPtr; prevPtr->nextPtr != segPtr; + prevPtr = prevPtr->nextPtr) { + /* Empty loop body. */ + } + prevPtr->nextPtr = segPtr->nextPtr; + } + CleanupLine(linePtr); +} + +/* + *---------------------------------------------------------------------- + * + * TkBTreeTag -- + * + * Turn a given tag on or off for a given range of characters in + * a B-tree of text. + * + * Results: + * None. + * + * Side effects: + * The given tag is added to the given range of characters + * in the tree or removed from all those characters, depending + * on the "add" argument. The structure of the btree is modified + * enough that index1Ptr and index2Ptr are no longer valid after + * this procedure returns, and the indexes may be modified by + * this procedure. + * + *---------------------------------------------------------------------- + */ + +void +TkBTreeTag(index1Ptr, index2Ptr, tagPtr, add) + register TkTextIndex *index1Ptr; /* Indicates first character in + * range. */ + register TkTextIndex *index2Ptr; /* Indicates character just after the + * last one in range. */ + TkTextTag *tagPtr; /* Tag to add or remove. */ + int add; /* One means add tag to the given + * range of characters; zero means + * remove the tag from the range. */ +{ + TkTextSegment *segPtr, *prevPtr; + TkTextSearch search; + TkTextLine *cleanupLinePtr; + int oldState; + int changed; + + /* + * See whether the tag is present at the start of the range. If + * the state doesn't already match what we want then add a toggle + * there. + */ + + oldState = TkBTreeCharTagged(index1Ptr, tagPtr); + if ((add != 0) ^ oldState) { + segPtr = (TkTextSegment *) ckalloc(TSEG_SIZE); + segPtr->typePtr = (add) ? &tkTextToggleOnType : &tkTextToggleOffType; + prevPtr = SplitSeg(index1Ptr); + if (prevPtr == NULL) { + segPtr->nextPtr = index1Ptr->linePtr->segPtr; + index1Ptr->linePtr->segPtr = segPtr; + } else { + segPtr->nextPtr = prevPtr->nextPtr; + prevPtr->nextPtr = segPtr; + } + segPtr->size = 0; + segPtr->body.toggle.tagPtr = tagPtr; + segPtr->body.toggle.inNodeCounts = 0; + } + + /* + * Scan the range of characters and delete any internal tag + * transitions. Keep track of what the old state was at the end + * of the range, and add a toggle there if it's needed. + */ + + TkBTreeStartSearch(index1Ptr, index2Ptr, tagPtr, &search); + cleanupLinePtr = index1Ptr->linePtr; + while (TkBTreeNextTag(&search)) { + oldState ^= 1; + segPtr = search.segPtr; + prevPtr = search.curIndex.linePtr->segPtr; + if (prevPtr == segPtr) { + search.curIndex.linePtr->segPtr = segPtr->nextPtr; + } else { + while (prevPtr->nextPtr != segPtr) { + prevPtr = prevPtr->nextPtr; + } + prevPtr->nextPtr = segPtr->nextPtr; + } + if (segPtr->body.toggle.inNodeCounts) { + ChangeNodeToggleCount(search.curIndex.linePtr->parentPtr, + segPtr->body.toggle.tagPtr, -1); + segPtr->body.toggle.inNodeCounts = 0; + changed = 1; + } else { + changed = 0; + } + ckfree((char *) segPtr); + + /* + * The code below is a bit tricky. After deleting a toggle + * we eventually have to call CleanupLine, in order to allow + * character segments to be merged together. To do this, we + * remember in cleanupLinePtr a line that needs to be + * cleaned up, but we don't clean it up until we've moved + * on to a different line. That way the cleanup process + * won't goof up segPtr. + */ + + if (cleanupLinePtr != search.curIndex.linePtr) { + CleanupLine(cleanupLinePtr); + cleanupLinePtr = search.curIndex.linePtr; + } + /* + * Quick hack. ChangeNodeToggleCount may move the tag's root + * location around and leave the search in the void. This resets + * the search. + */ + if (changed) { + TkBTreeStartSearch(index1Ptr, index2Ptr, tagPtr, &search); + } + } + if ((add != 0) ^ oldState) { + segPtr = (TkTextSegment *) ckalloc(TSEG_SIZE); + segPtr->typePtr = (add) ? &tkTextToggleOffType : &tkTextToggleOnType; + prevPtr = SplitSeg(index2Ptr); + if (prevPtr == NULL) { + segPtr->nextPtr = index2Ptr->linePtr->segPtr; + index2Ptr->linePtr->segPtr = segPtr; + } else { + segPtr->nextPtr = prevPtr->nextPtr; + prevPtr->nextPtr = segPtr; + } + segPtr->size = 0; + segPtr->body.toggle.tagPtr = tagPtr; + segPtr->body.toggle.inNodeCounts = 0; + } + + /* + * Cleanup cleanupLinePtr and the last line of the range, if + * these are different. + */ + + CleanupLine(cleanupLinePtr); + if (cleanupLinePtr != index2Ptr->linePtr) { + CleanupLine(index2Ptr->linePtr); + } + + if (tkBTreeDebug) { + TkBTreeCheck(index1Ptr->tree); + } +} + +/* + *---------------------------------------------------------------------- + * + * ChangeNodeToggleCount -- + * + * This procedure increments or decrements the toggle count for + * a particular tag in a particular node and all its ancestors + * up to the per-tag root node. + * + * Results: + * None. + * + * Side effects: + * The toggle count for tag is adjusted up or down by "delta" in + * nodePtr. This routine maintains the tagRootPtr that identifies + * the root node for the tag, moving it up or down the tree as needed. + * + *---------------------------------------------------------------------- + */ + +static void +ChangeNodeToggleCount(nodePtr, tagPtr, delta) + register Node *nodePtr; /* Node whose toggle count for a tag + * must be changed. */ + TkTextTag *tagPtr; /* Information about tag. */ + int delta; /* Amount to add to current toggle + * count for tag (may be negative). */ +{ + register Summary *summaryPtr, *prevPtr; + register Node *node2Ptr; + int rootLevel; /* Level of original tag root */ + + tagPtr->toggleCount += delta; + if (tagPtr->tagRootPtr == (Node *) NULL) { + tagPtr->tagRootPtr = nodePtr; + return; + } + + /* + * Note the level of the existing root for the tag so we can detect + * if it needs to be moved because of the toggle count change. + */ + + rootLevel = tagPtr->tagRootPtr->level; + + /* + * Iterate over the node and its ancestors up to the tag root, adjusting + * summary counts at each node and moving the tag's root upwards if + * necessary. + */ + + for ( ; nodePtr != tagPtr->tagRootPtr; nodePtr = nodePtr->parentPtr) { + /* + * See if there's already an entry for this tag for this node. If so, + * perhaps all we have to do is adjust its count. + */ + + for (prevPtr = NULL, summaryPtr = nodePtr->summaryPtr; + summaryPtr != NULL; + prevPtr = summaryPtr, summaryPtr = summaryPtr->nextPtr) { + if (summaryPtr->tagPtr == tagPtr) { + break; + } + } + if (summaryPtr != NULL) { + summaryPtr->toggleCount += delta; + if (summaryPtr->toggleCount > 0 && + summaryPtr->toggleCount < tagPtr->toggleCount) { + continue; + } + if (summaryPtr->toggleCount != 0) { + /* + * Should never find a node with max toggle count at this + * point (there shouldn't have been a summary entry in the + * first place). + */ + + panic("ChangeNodeToggleCount: bad toggle count (%d) max (%d)", + summaryPtr->toggleCount, tagPtr->toggleCount); + } + + /* + * Zero toggle count; must remove this tag from the list. + */ + + if (prevPtr == NULL) { + nodePtr->summaryPtr = summaryPtr->nextPtr; + } else { + prevPtr->nextPtr = summaryPtr->nextPtr; + } + ckfree((char *) summaryPtr); + } else { + /* + * This tag isn't currently in the summary information list. + */ + + if (rootLevel == nodePtr->level) { + + /* + * The old tag root is at the same level in the tree as this + * node, but it isn't at this node. Move the tag root up + * a level, in the hopes that it will now cover this node + * as well as the old root (if not, we'll move it up again + * the next time through the loop). To push it up one level + * we copy the original toggle count into the summary + * information at the old root and change the root to its + * parent node. + */ + + Node *rootNodePtr = tagPtr->tagRootPtr; + summaryPtr = (Summary *) ckalloc(sizeof(Summary)); + summaryPtr->tagPtr = tagPtr; + summaryPtr->toggleCount = tagPtr->toggleCount - delta; + summaryPtr->nextPtr = rootNodePtr->summaryPtr; + rootNodePtr->summaryPtr = summaryPtr; + rootNodePtr = rootNodePtr->parentPtr; + rootLevel = rootNodePtr->level; + tagPtr->tagRootPtr = rootNodePtr; + } + summaryPtr = (Summary *) ckalloc(sizeof(Summary)); + summaryPtr->tagPtr = tagPtr; + summaryPtr->toggleCount = delta; + summaryPtr->nextPtr = nodePtr->summaryPtr; + nodePtr->summaryPtr = summaryPtr; + } + } + + /* + * If we've decremented the toggle count, then it may be necessary + * to push the tag root down one or more levels. + */ + + if (delta >= 0) { + return; + } + if (tagPtr->toggleCount == 0) { + tagPtr->tagRootPtr = (Node *) NULL; + return; + } + nodePtr = tagPtr->tagRootPtr; + while (nodePtr->level > 0) { + /* + * See if a single child node accounts for all of the tag's + * toggles. If so, push the root down one level. + */ + + for (node2Ptr = nodePtr->children.nodePtr; + node2Ptr != (Node *)NULL ; + node2Ptr = node2Ptr->nextPtr) { + for (prevPtr = NULL, summaryPtr = node2Ptr->summaryPtr; + summaryPtr != NULL; + prevPtr = summaryPtr, summaryPtr = summaryPtr->nextPtr) { + if (summaryPtr->tagPtr == tagPtr) { + break; + } + } + if (summaryPtr == NULL) { + continue; + } + if (summaryPtr->toggleCount != tagPtr->toggleCount) { + /* + * No node has all toggles, so the root is still valid. + */ + + return; + } + + /* + * This node has all the toggles, so push down the root. + */ + + if (prevPtr == NULL) { + node2Ptr->summaryPtr = summaryPtr->nextPtr; + } else { + prevPtr->nextPtr = summaryPtr->nextPtr; + } + ckfree((char *) summaryPtr); + tagPtr->tagRootPtr = node2Ptr; + break; + } + nodePtr = tagPtr->tagRootPtr; + } +} + +/* + *---------------------------------------------------------------------- + * + * FindTagStart -- + * + * Find the start of the first range of a tag. + * + * Results: + * The return value is a pointer to the first tag toggle segment + * for the tag. This can be either a tagon or tagoff segments because + * of the way TkBTreeAdd removes a tag. + * Sets *indexPtr to be the index of the tag toggle. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static TkTextSegment * +FindTagStart(tree, tagPtr, indexPtr) + TkTextBTree tree; /* Tree to search within */ + TkTextTag *tagPtr; /* Tag to search for. */ + TkTextIndex *indexPtr; /* Return - index information */ +{ + register Node *nodePtr; + register TkTextLine *linePtr; + register TkTextSegment *segPtr; + register Summary *summaryPtr; + int offset; + + nodePtr = tagPtr->tagRootPtr; + if (nodePtr == (Node *) NULL) { + return NULL; + } + + /* + * Search from the root of the subtree that contains the tag down + * to the level 0 node. + */ + + while (nodePtr->level > 0) { + for (nodePtr = nodePtr->children.nodePtr ; nodePtr != (Node *) NULL; + nodePtr = nodePtr->nextPtr) { + for (summaryPtr = nodePtr->summaryPtr ; summaryPtr != NULL; + summaryPtr = summaryPtr->nextPtr) { + if (summaryPtr->tagPtr == tagPtr) { + goto gotNodeWithTag; + } + } + } + gotNodeWithTag: + continue; + } + + /* + * Work through the lines attached to the level-0 node. + */ + + for (linePtr = nodePtr->children.linePtr; linePtr != (TkTextLine *) NULL; + linePtr = linePtr->nextPtr) { + for (offset = 0, segPtr = linePtr->segPtr ; segPtr != NULL; + offset += segPtr->size, segPtr = segPtr->nextPtr) { + if (((segPtr->typePtr == &tkTextToggleOnType) + || (segPtr->typePtr == &tkTextToggleOffType)) + && (segPtr->body.toggle.tagPtr == tagPtr)) { + /* + * It is possible that this is a tagoff tag, but that + * gets cleaned up later. + */ + indexPtr->tree = tree; + indexPtr->linePtr = linePtr; + indexPtr->charIndex = offset; + return segPtr; + } + } + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * FindTagEnd -- + * + * Find the end of the last range of a tag. + * + * Results: + * The return value is a pointer to the last tag toggle segment + * for the tag. This can be either a tagon or tagoff segments because + * of the way TkBTreeAdd removes a tag. + * Sets *indexPtr to be the index of the tag toggle. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static TkTextSegment * +FindTagEnd(tree, tagPtr, indexPtr) + TkTextBTree tree; /* Tree to search within */ + TkTextTag *tagPtr; /* Tag to search for. */ + TkTextIndex *indexPtr; /* Return - index information */ +{ + register Node *nodePtr, *lastNodePtr; + register TkTextLine *linePtr ,*lastLinePtr; + register TkTextSegment *segPtr, *lastSegPtr, *last2SegPtr; + register Summary *summaryPtr; + int lastoffset, lastoffset2, offset; + + nodePtr = tagPtr->tagRootPtr; + if (nodePtr == (Node *) NULL) { + return NULL; + } + + /* + * Search from the root of the subtree that contains the tag down + * to the level 0 node. + */ + + while (nodePtr->level > 0) { + for (lastNodePtr = NULL, nodePtr = nodePtr->children.nodePtr ; + nodePtr != (Node *) NULL; nodePtr = nodePtr->nextPtr) { + for (summaryPtr = nodePtr->summaryPtr ; summaryPtr != NULL; + summaryPtr = summaryPtr->nextPtr) { + if (summaryPtr->tagPtr == tagPtr) { + lastNodePtr = nodePtr; + break; + } + } + } + nodePtr = lastNodePtr; + } + + /* + * Work through the lines attached to the level-0 node. + */ + last2SegPtr = NULL; + lastoffset2 = 0; + lastoffset = 0; + for (lastLinePtr = NULL, linePtr = nodePtr->children.linePtr; + linePtr != (TkTextLine *) NULL; linePtr = linePtr->nextPtr) { + for (offset = 0, lastSegPtr = NULL, segPtr = linePtr->segPtr ; + segPtr != NULL; + offset += segPtr->size, segPtr = segPtr->nextPtr) { + if (((segPtr->typePtr == &tkTextToggleOnType) + || (segPtr->typePtr == &tkTextToggleOffType)) + && (segPtr->body.toggle.tagPtr == tagPtr)) { + lastSegPtr = segPtr; + lastoffset = offset; + } + } + if (lastSegPtr != NULL) { + lastLinePtr = linePtr; + last2SegPtr = lastSegPtr; + lastoffset2 = lastoffset; + } + } + indexPtr->tree = tree; + indexPtr->linePtr = lastLinePtr; + indexPtr->charIndex = lastoffset2; + return last2SegPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TkBTreeStartSearch -- + * + * This procedure sets up a search for tag transitions involving + * a given tag (or all tags) in a given range of the text. + * + * Results: + * None. + * + * Side effects: + * The information at *searchPtr is set up so that subsequent calls + * to TkBTreeNextTag or TkBTreePrevTag will return information about the + * locations of tag transitions. Note that TkBTreeNextTag or + * TkBTreePrevTag must be called to get the first transition. + * Note: unlike TkBTreeNextTag and TkBTreePrevTag, this routine does not + * guarantee that searchPtr->curIndex is equal to *index1Ptr. It may be + * greater than that if *index1Ptr is less than the first tag transition. + * + *---------------------------------------------------------------------- + */ + +void +TkBTreeStartSearch(index1Ptr, index2Ptr, tagPtr, searchPtr) + TkTextIndex *index1Ptr; /* Search starts here. Tag toggles + * at this position will not be + * returned. */ + TkTextIndex *index2Ptr; /* Search stops here. Tag toggles + * at this position *will* be + * returned. */ + TkTextTag *tagPtr; /* Tag to search for. NULL means + * search for any tag. */ + register TkTextSearch *searchPtr; /* Where to store information about + * search's progress. */ +{ + int offset; + TkTextIndex index0; /* First index of the tag */ + TkTextSegment *seg0Ptr; /* First segment of the tag */ + + /* + * Find the segment that contains the first toggle for the tag. This + * may become the starting point in the search. + */ + + seg0Ptr = FindTagStart(index1Ptr->tree, tagPtr, &index0); + if (seg0Ptr == (TkTextSegment *) NULL) { + /* + * Even though there are no toggles, the display code still + * uses the search curIndex, so initialize that anyway. + */ + + searchPtr->linesLeft = 0; + searchPtr->curIndex = *index1Ptr; + searchPtr->segPtr = NULL; + searchPtr->nextPtr = NULL; + return; + } + if (TkTextIndexCmp(index1Ptr, &index0) < 0) { + /* + * Adjust start of search up to the first range of the tag + */ + + searchPtr->curIndex = index0; + searchPtr->segPtr = NULL; + searchPtr->nextPtr = seg0Ptr; /* Will be returned by NextTag */ + index1Ptr = &index0; + } else { + searchPtr->curIndex = *index1Ptr; + searchPtr->segPtr = NULL; + searchPtr->nextPtr = TkTextIndexToSeg(index1Ptr, &offset); + searchPtr->curIndex.charIndex -= offset; + } + searchPtr->lastPtr = TkTextIndexToSeg(index2Ptr, (int *) NULL); + searchPtr->tagPtr = tagPtr; + searchPtr->linesLeft = TkBTreeLineIndex(index2Ptr->linePtr) + 1 + - TkBTreeLineIndex(index1Ptr->linePtr); + searchPtr->allTags = (tagPtr == NULL); + if (searchPtr->linesLeft == 1) { + /* + * Starting and stopping segments are in the same line; mark the + * search as over immediately if the second segment is before the + * first. A search does not return a toggle at the very start of + * the range, unless the range is artificially moved up to index0. + */ + if (((index1Ptr == &index0) && + (index1Ptr->charIndex > index2Ptr->charIndex)) || + ((index1Ptr != &index0) && + (index1Ptr->charIndex >= index2Ptr->charIndex))) { + searchPtr->linesLeft = 0; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TkBTreeStartSearchBack -- + * + * This procedure sets up a search backwards for tag transitions involving + * a given tag (or all tags) in a given range of the text. In the + * normal case the first index (*index1Ptr) is beyond the second + * index (*index2Ptr). + * + * + * Results: + * None. + * + * Side effects: + * The information at *searchPtr is set up so that subsequent calls + * to TkBTreePrevTag will return information about the + * locations of tag transitions. Note that TkBTreePrevTag must be called + * to get the first transition. + * Note: unlike TkBTreeNextTag and TkBTreePrevTag, this routine does not + * guarantee that searchPtr->curIndex is equal to *index1Ptr. It may be + * less than that if *index1Ptr is greater than the last tag transition. + * + *---------------------------------------------------------------------- + */ + +void +TkBTreeStartSearchBack(index1Ptr, index2Ptr, tagPtr, searchPtr) + TkTextIndex *index1Ptr; /* Search starts here. Tag toggles + * at this position will not be + * returned. */ + TkTextIndex *index2Ptr; /* Search stops here. Tag toggles + * at this position *will* be + * returned. */ + TkTextTag *tagPtr; /* Tag to search for. NULL means + * search for any tag. */ + register TkTextSearch *searchPtr; /* Where to store information about + * search's progress. */ +{ + int offset; + TkTextIndex index0; /* Last index of the tag */ + TkTextIndex backOne; /* One character before starting index */ + TkTextSegment *seg0Ptr; /* Last segment of the tag */ + + /* + * Find the segment that contains the last toggle for the tag. This + * may become the starting point in the search. + */ + + seg0Ptr = FindTagEnd(index1Ptr->tree, tagPtr, &index0); + if (seg0Ptr == (TkTextSegment *) NULL) { + /* + * Even though there are no toggles, the display code still + * uses the search curIndex, so initialize that anyway. + */ + + searchPtr->linesLeft = 0; + searchPtr->curIndex = *index1Ptr; + searchPtr->segPtr = NULL; + searchPtr->nextPtr = NULL; + return; + } + + /* + * Adjust the start of the search so it doesn't find any tag toggles + * that are right at the index specified by the user. + */ + + if (TkTextIndexCmp(index1Ptr, &index0) > 0) { + searchPtr->curIndex = index0; + index1Ptr = &index0; + } else { + TkTextIndexBackChars(index1Ptr, 1, &searchPtr->curIndex); + } + searchPtr->segPtr = NULL; + searchPtr->nextPtr = TkTextIndexToSeg(&searchPtr->curIndex, &offset); + searchPtr->curIndex.charIndex -= offset; + + /* + * Adjust the end of the search so it does find toggles that are right + * at the second index specified by the user. + */ + + if ((TkBTreeLineIndex(index2Ptr->linePtr) == 0) && + (index2Ptr->charIndex == 0)) { + backOne = *index2Ptr; + searchPtr->lastPtr = NULL; /* Signals special case for 1.0 */ + } else { + TkTextIndexBackChars(index2Ptr, 1, &backOne); + searchPtr->lastPtr = TkTextIndexToSeg(&backOne, (int *) NULL); + } + searchPtr->tagPtr = tagPtr; + searchPtr->linesLeft = TkBTreeLineIndex(index1Ptr->linePtr) + 1 + - TkBTreeLineIndex(backOne.linePtr); + searchPtr->allTags = (tagPtr == NULL); + if (searchPtr->linesLeft == 1) { + /* + * Starting and stopping segments are in the same line; mark the + * search as over immediately if the second segment is after the + * first. + */ + + if (index1Ptr->charIndex <= backOne.charIndex) { + searchPtr->linesLeft = 0; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TkBTreeNextTag -- + * + * Once a tag search has begun, successive calls to this procedure + * return successive tag toggles. Note: it is NOT SAFE to call this + * procedure if characters have been inserted into or deleted from + * the B-tree since the call to TkBTreeStartSearch. + * + * Results: + * The return value is 1 if another toggle was found that met the + * criteria specified in the call to TkBTreeStartSearch; in this + * case searchPtr->curIndex gives the toggle's position and + * searchPtr->curTagPtr points to its segment. 0 is returned if + * no more matching tag transitions were found; in this case + * searchPtr->curIndex is the same as searchPtr->stopIndex. + * + * Side effects: + * Information in *searchPtr is modified to update the state of the + * search and indicate where the next tag toggle is located. + * + *---------------------------------------------------------------------- + */ + +int +TkBTreeNextTag(searchPtr) + register TkTextSearch *searchPtr; /* Information about search in + * progress; must have been set up by + * call to TkBTreeStartSearch. */ +{ + register TkTextSegment *segPtr; + register Node *nodePtr; + register Summary *summaryPtr; + + if (searchPtr->linesLeft <= 0) { + goto searchOver; + } + + /* + * The outermost loop iterates over lines that may potentially contain + * a relevant tag transition, starting from the current segment in + * the current line. + */ + + segPtr = searchPtr->nextPtr; + while (1) { + /* + * Check for more tags on the current line. + */ + + for ( ; segPtr != NULL; segPtr = segPtr->nextPtr) { + if (segPtr == searchPtr->lastPtr) { + goto searchOver; + } + if (((segPtr->typePtr == &tkTextToggleOnType) + || (segPtr->typePtr == &tkTextToggleOffType)) + && (searchPtr->allTags + || (segPtr->body.toggle.tagPtr == searchPtr->tagPtr))) { + searchPtr->segPtr = segPtr; + searchPtr->nextPtr = segPtr->nextPtr; + searchPtr->tagPtr = segPtr->body.toggle.tagPtr; + return 1; + } + searchPtr->curIndex.charIndex += segPtr->size; + } + + /* + * See if there are more lines associated with the current parent + * node. If so, go back to the top of the loop to search the next + * one. + */ + + nodePtr = searchPtr->curIndex.linePtr->parentPtr; + searchPtr->curIndex.linePtr = searchPtr->curIndex.linePtr->nextPtr; + searchPtr->linesLeft--; + if (searchPtr->linesLeft <= 0) { + goto searchOver; + } + if (searchPtr->curIndex.linePtr != NULL) { + segPtr = searchPtr->curIndex.linePtr->segPtr; + searchPtr->curIndex.charIndex = 0; + continue; + } + if (nodePtr == searchPtr->tagPtr->tagRootPtr) { + goto searchOver; + } + + /* + * Search across and up through the B-tree's node hierarchy looking + * for the next node that has a relevant tag transition somewhere in + * its subtree. Be sure to update linesLeft as we skip over large + * chunks of lines. + */ + + while (1) { + while (nodePtr->nextPtr == NULL) { + if (nodePtr->parentPtr == NULL || + nodePtr->parentPtr == searchPtr->tagPtr->tagRootPtr) { + goto searchOver; + } + nodePtr = nodePtr->parentPtr; + } + nodePtr = nodePtr->nextPtr; + for (summaryPtr = nodePtr->summaryPtr; summaryPtr != NULL; + summaryPtr = summaryPtr->nextPtr) { + if ((searchPtr->allTags) || + (summaryPtr->tagPtr == searchPtr->tagPtr)) { + goto gotNodeWithTag; + } + } + searchPtr->linesLeft -= nodePtr->numLines; + } + + /* + * At this point we've found a subtree that has a relevant tag + * transition. Now search down (and across) through that subtree + * to find the first level-0 node that has a relevant tag transition. + */ + + gotNodeWithTag: + while (nodePtr->level > 0) { + for (nodePtr = nodePtr->children.nodePtr; ; + nodePtr = nodePtr->nextPtr) { + for (summaryPtr = nodePtr->summaryPtr; summaryPtr != NULL; + summaryPtr = summaryPtr->nextPtr) { + if ((searchPtr->allTags) + || (summaryPtr->tagPtr == searchPtr->tagPtr)) { + goto nextChild; + } + } + searchPtr->linesLeft -= nodePtr->numLines; + if (nodePtr->nextPtr == NULL) { + panic("TkBTreeNextTag found incorrect tag summary info."); + } + } + nextChild: + continue; + } + + /* + * Now we're down to a level-0 node that contains a line that contains + * a relevant tag transition. Set up line information and go back to + * the beginning of the loop to search through lines. + */ + + searchPtr->curIndex.linePtr = nodePtr->children.linePtr; + searchPtr->curIndex.charIndex = 0; + segPtr = searchPtr->curIndex.linePtr->segPtr; + if (searchPtr->linesLeft <= 0) { + goto searchOver; + } + continue; + } + + searchOver: + searchPtr->linesLeft = 0; + searchPtr->segPtr = NULL; + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * TkBTreePrevTag -- + * + * Once a tag search has begun, successive calls to this procedure + * return successive tag toggles in the reverse direction. + * Note: it is NOT SAFE to call this + * procedure if characters have been inserted into or deleted from + * the B-tree since the call to TkBTreeStartSearch. + * + * Results: + * The return value is 1 if another toggle was found that met the + * criteria specified in the call to TkBTreeStartSearch; in this + * case searchPtr->curIndex gives the toggle's position and + * searchPtr->curTagPtr points to its segment. 0 is returned if + * no more matching tag transitions were found; in this case + * searchPtr->curIndex is the same as searchPtr->stopIndex. + * + * Side effects: + * Information in *searchPtr is modified to update the state of the + * search and indicate where the next tag toggle is located. + * + *---------------------------------------------------------------------- + */ + +int +TkBTreePrevTag(searchPtr) + register TkTextSearch *searchPtr; /* Information about search in + * progress; must have been set up by + * call to TkBTreeStartSearch. */ +{ + register TkTextSegment *segPtr, *prevPtr; + register TkTextLine *linePtr, *prevLinePtr; + register Node *nodePtr, *node2Ptr, *prevNodePtr; + register Summary *summaryPtr; + int charIndex; + int pastLast; /* Saw last marker during scan */ + int linesSkipped; + + if (searchPtr->linesLeft <= 0) { + goto searchOver; + } + + /* + * The outermost loop iterates over lines that may potentially contain + * a relevant tag transition, starting from the current segment in + * the current line. "nextPtr" is maintained as the last segment in + * a line that we can look at. + */ + + while (1) { + /* + * Check for the last toggle before the current segment on this line. + */ + charIndex = 0; + if (searchPtr->lastPtr == NULL) { + /* + * Search back to the very beginning, so pastLast is irrelevent. + */ + pastLast = 1; + } else { + pastLast = 0; + } + for (prevPtr = NULL, segPtr = searchPtr->curIndex.linePtr->segPtr ; + segPtr != NULL && segPtr != searchPtr->nextPtr; + segPtr = segPtr->nextPtr) { + if (((segPtr->typePtr == &tkTextToggleOnType) + || (segPtr->typePtr == &tkTextToggleOffType)) + && (searchPtr->allTags + || (segPtr->body.toggle.tagPtr == searchPtr->tagPtr))) { + prevPtr = segPtr; + searchPtr->curIndex.charIndex = charIndex; + } + if (segPtr == searchPtr->lastPtr) { + prevPtr = NULL; /* Segments earlier than last don't count */ + pastLast = 1; + } + charIndex += segPtr->size; + } + if (prevPtr != NULL) { + if (searchPtr->linesLeft == 1 && !pastLast) { + /* + * We found a segment that is before the stopping index. + * Note that it is OK if prevPtr == lastPtr. + */ + goto searchOver; + } + searchPtr->segPtr = prevPtr; + searchPtr->nextPtr = prevPtr; + searchPtr->tagPtr = prevPtr->body.toggle.tagPtr; + return 1; + } + + searchPtr->linesLeft--; + if (searchPtr->linesLeft <= 0) { + goto searchOver; + } + + /* + * See if there are more lines associated with the current parent + * node. If so, go back to the top of the loop to search the previous + * one. + */ + + nodePtr = searchPtr->curIndex.linePtr->parentPtr; + for (prevLinePtr = NULL, linePtr = nodePtr->children.linePtr; + linePtr != NULL && linePtr != searchPtr->curIndex.linePtr; + prevLinePtr = linePtr, linePtr = linePtr->nextPtr) { + /* empty loop body */ ; + } + if (prevLinePtr != NULL) { + searchPtr->curIndex.linePtr = prevLinePtr; + searchPtr->nextPtr = NULL; + continue; + } + if (nodePtr == searchPtr->tagPtr->tagRootPtr) { + goto searchOver; + } + + /* + * Search across and up through the B-tree's node hierarchy looking + * for the previous node that has a relevant tag transition somewhere in + * its subtree. The search and line counting is trickier with/out + * back pointers. We'll scan all the nodes under a parent up to + * the current node, searching all of them for tag state. The last + * one we find, if any, is recorded in prevNodePtr, and any nodes + * past prevNodePtr that don't have tag state increment linesSkipped. + */ + + while (1) { + for (prevNodePtr = NULL, linesSkipped = 0, + node2Ptr = nodePtr->parentPtr->children.nodePtr ; + node2Ptr != nodePtr; node2Ptr = node2Ptr->nextPtr) { + for (summaryPtr = node2Ptr->summaryPtr; summaryPtr != NULL; + summaryPtr = summaryPtr->nextPtr) { + if ((searchPtr->allTags) || + (summaryPtr->tagPtr == searchPtr->tagPtr)) { + prevNodePtr = node2Ptr; + linesSkipped = 0; + goto keepLooking; + } + } + linesSkipped += node2Ptr->numLines; + + keepLooking: + continue; + } + if (prevNodePtr != NULL) { + nodePtr = prevNodePtr; + searchPtr->linesLeft -= linesSkipped; + goto gotNodeWithTag; + } + nodePtr = nodePtr->parentPtr; + if (nodePtr->parentPtr == NULL || + nodePtr == searchPtr->tagPtr->tagRootPtr) { + goto searchOver; + } + } + + /* + * At this point we've found a subtree that has a relevant tag + * transition. Now search down (and across) through that subtree + * to find the last level-0 node that has a relevant tag transition. + */ + + gotNodeWithTag: + while (nodePtr->level > 0) { + for (linesSkipped = 0, prevNodePtr = NULL, + nodePtr = nodePtr->children.nodePtr; nodePtr != NULL ; + nodePtr = nodePtr->nextPtr) { + for (summaryPtr = nodePtr->summaryPtr; summaryPtr != NULL; + summaryPtr = summaryPtr->nextPtr) { + if ((searchPtr->allTags) + || (summaryPtr->tagPtr == searchPtr->tagPtr)) { + prevNodePtr = nodePtr; + linesSkipped = 0; + goto keepLooking2; + } + } + linesSkipped += nodePtr->numLines; + + keepLooking2: + continue; + } + if (prevNodePtr == NULL) { + panic("TkBTreePrevTag found incorrect tag summary info."); + } + searchPtr->linesLeft -= linesSkipped; + nodePtr = prevNodePtr; + } + + /* + * Now we're down to a level-0 node that contains a line that contains + * a relevant tag transition. Set up line information and go back to + * the beginning of the loop to search through lines. We start with + * the last line below the node. + */ + + for (prevLinePtr = NULL, linePtr = nodePtr->children.linePtr; + linePtr != NULL ; + prevLinePtr = linePtr, linePtr = linePtr->nextPtr) { + /* empty loop body */ ; + } + searchPtr->curIndex.linePtr = prevLinePtr; + searchPtr->curIndex.charIndex = 0; + if (searchPtr->linesLeft <= 0) { + goto searchOver; + } + continue; + } + + searchOver: + searchPtr->linesLeft = 0; + searchPtr->segPtr = NULL; + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * TkBTreeCharTagged -- + * + * Determine whether a particular character has a particular tag. + * + * Results: + * The return value is 1 if the given tag is in effect at the + * character given by linePtr and ch, and 0 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TkBTreeCharTagged(indexPtr, tagPtr) + TkTextIndex *indexPtr; /* Indicates a character position at + * which to check for a tag. */ + TkTextTag *tagPtr; /* Tag of interest. */ +{ + register Node *nodePtr; + register TkTextLine *siblingLinePtr; + register TkTextSegment *segPtr; + TkTextSegment *toggleSegPtr; + int toggles, index; + + /* + * Check for toggles for the tag in indexPtr's line but before + * indexPtr. If there is one, its type indicates whether or + * not the character is tagged. + */ + + toggleSegPtr = NULL; + for (index = 0, segPtr = indexPtr->linePtr->segPtr; + (index + segPtr->size) <= indexPtr->charIndex; + index += segPtr->size, segPtr = segPtr->nextPtr) { + if (((segPtr->typePtr == &tkTextToggleOnType) + || (segPtr->typePtr == &tkTextToggleOffType)) + && (segPtr->body.toggle.tagPtr == tagPtr)) { + toggleSegPtr = segPtr; + } + } + if (toggleSegPtr != NULL) { + return (toggleSegPtr->typePtr == &tkTextToggleOnType); + } + + /* + * No toggle in this line. Look for toggles for the tag in lines + * that are predecessors of indexPtr->linePtr but under the same + * level-0 node. + */ + + for (siblingLinePtr = indexPtr->linePtr->parentPtr->children.linePtr; + siblingLinePtr != indexPtr->linePtr; + siblingLinePtr = siblingLinePtr->nextPtr) { + for (segPtr = siblingLinePtr->segPtr; segPtr != NULL; + segPtr = segPtr->nextPtr) { + if (((segPtr->typePtr == &tkTextToggleOnType) + || (segPtr->typePtr == &tkTextToggleOffType)) + && (segPtr->body.toggle.tagPtr == tagPtr)) { + toggleSegPtr = segPtr; + } + } + } + if (toggleSegPtr != NULL) { + return (toggleSegPtr->typePtr == &tkTextToggleOnType); + } + + /* + * No toggle in this node. Scan upwards through the ancestors of + * this node, counting the number of toggles of the given tag in + * siblings that precede that node. + */ + + toggles = 0; + for (nodePtr = indexPtr->linePtr->parentPtr; nodePtr->parentPtr != NULL; + nodePtr = nodePtr->parentPtr) { + register Node *siblingPtr; + register Summary *summaryPtr; + + for (siblingPtr = nodePtr->parentPtr->children.nodePtr; + siblingPtr != nodePtr; siblingPtr = siblingPtr->nextPtr) { + for (summaryPtr = siblingPtr->summaryPtr; summaryPtr != NULL; + summaryPtr = summaryPtr->nextPtr) { + if (summaryPtr->tagPtr == tagPtr) { + toggles += summaryPtr->toggleCount; + } + } + } + if (nodePtr == tagPtr->tagRootPtr) { + break; + } + } + + /* + * An odd number of toggles means that the tag is present at the + * given point. + */ + + return toggles & 1; +} + +/* + *---------------------------------------------------------------------- + * + * TkBTreeGetTags -- + * + * Return information about all of the tags that are associated + * with a particular character in a B-tree of text. + * + * Results: + * The return value is a malloc-ed array containing pointers to + * information for each of the tags that is associated with + * the character at the position given by linePtr and ch. The + * word at *numTagsPtr is filled in with the number of pointers + * in the array. It is up to the caller to free the array by + * passing it to free. If there are no tags at the given character + * then a NULL pointer is returned and *numTagsPtr will be set to 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +TkTextTag ** +TkBTreeGetTags(indexPtr, numTagsPtr) + TkTextIndex *indexPtr; /* Indicates a particular position in + * the B-tree. */ + int *numTagsPtr; /* Store number of tags found at this + * location. */ +{ + register Node *nodePtr; + register TkTextLine *siblingLinePtr; + register TkTextSegment *segPtr; + int src, dst, index; + TagInfo tagInfo; +#define NUM_TAG_INFOS 10 + + tagInfo.numTags = 0; + tagInfo.arraySize = NUM_TAG_INFOS; + tagInfo.tagPtrs = (TkTextTag **) ckalloc((unsigned) + NUM_TAG_INFOS*sizeof(TkTextTag *)); + tagInfo.counts = (int *) ckalloc((unsigned) + NUM_TAG_INFOS*sizeof(int)); + + /* + * Record tag toggles within the line of indexPtr but preceding + * indexPtr. + */ + + for (index = 0, segPtr = indexPtr->linePtr->segPtr; + (index + segPtr->size) <= indexPtr->charIndex; + index += segPtr->size, segPtr = segPtr->nextPtr) { + if ((segPtr->typePtr == &tkTextToggleOnType) + || (segPtr->typePtr == &tkTextToggleOffType)) { + IncCount(segPtr->body.toggle.tagPtr, 1, &tagInfo); + } + } + + /* + * Record toggles for tags in lines that are predecessors of + * indexPtr->linePtr but under the same level-0 node. + */ + + for (siblingLinePtr = indexPtr->linePtr->parentPtr->children.linePtr; + siblingLinePtr != indexPtr->linePtr; + siblingLinePtr = siblingLinePtr->nextPtr) { + for (segPtr = siblingLinePtr->segPtr; segPtr != NULL; + segPtr = segPtr->nextPtr) { + if ((segPtr->typePtr == &tkTextToggleOnType) + || (segPtr->typePtr == &tkTextToggleOffType)) { + IncCount(segPtr->body.toggle.tagPtr, 1, &tagInfo); + } + } + } + + /* + * For each node in the ancestry of this line, record tag toggles + * for all siblings that precede that node. + */ + + for (nodePtr = indexPtr->linePtr->parentPtr; nodePtr->parentPtr != NULL; + nodePtr = nodePtr->parentPtr) { + register Node *siblingPtr; + register Summary *summaryPtr; + + for (siblingPtr = nodePtr->parentPtr->children.nodePtr; + siblingPtr != nodePtr; siblingPtr = siblingPtr->nextPtr) { + for (summaryPtr = siblingPtr->summaryPtr; summaryPtr != NULL; + summaryPtr = summaryPtr->nextPtr) { + if (summaryPtr->toggleCount & 1) { + IncCount(summaryPtr->tagPtr, summaryPtr->toggleCount, + &tagInfo); + } + } + } + } + + /* + * Go through the tag information and squash out all of the tags + * that have even toggle counts (these tags exist before the point + * of interest, but not at the desired character itself). + */ + + for (src = 0, dst = 0; src < tagInfo.numTags; src++) { + if (tagInfo.counts[src] & 1) { + tagInfo.tagPtrs[dst] = tagInfo.tagPtrs[src]; + dst++; + } + } + *numTagsPtr = dst; + ckfree((char *) tagInfo.counts); + if (dst == 0) { + ckfree((char *) tagInfo.tagPtrs); + return NULL; + } + return tagInfo.tagPtrs; +} + +/* + *---------------------------------------------------------------------- + * + * IncCount -- + * + * This is a utility procedure used by TkBTreeGetTags. It + * increments the count for a particular tag, adding a new + * entry for that tag if there wasn't one previously. + * + * Results: + * None. + * + * Side effects: + * The information at *tagInfoPtr may be modified, and the arrays + * may be reallocated to make them larger. + * + *---------------------------------------------------------------------- + */ + +static void +IncCount(tagPtr, inc, tagInfoPtr) + TkTextTag *tagPtr; /* Handle for tag. */ + int inc; /* Amount by which to increment tag count. */ + TagInfo *tagInfoPtr; /* Holds cumulative information about tags; + * increment count here. */ +{ + register TkTextTag **tagPtrPtr; + int count; + + for (tagPtrPtr = tagInfoPtr->tagPtrs, count = tagInfoPtr->numTags; + count > 0; tagPtrPtr++, count--) { + if (*tagPtrPtr == tagPtr) { + tagInfoPtr->counts[tagInfoPtr->numTags-count] += inc; + return; + } + } + + /* + * There isn't currently an entry for this tag, so we have to + * make a new one. If the arrays are full, then enlarge the + * arrays first. + */ + + if (tagInfoPtr->numTags == tagInfoPtr->arraySize) { + TkTextTag **newTags; + int *newCounts, newSize; + + newSize = 2*tagInfoPtr->arraySize; + newTags = (TkTextTag **) ckalloc((unsigned) + (newSize*sizeof(TkTextTag *))); + memcpy((VOID *) newTags, (VOID *) tagInfoPtr->tagPtrs, + tagInfoPtr->arraySize * sizeof(TkTextTag *)); + ckfree((char *) tagInfoPtr->tagPtrs); + tagInfoPtr->tagPtrs = newTags; + newCounts = (int *) ckalloc((unsigned) (newSize*sizeof(int))); + memcpy((VOID *) newCounts, (VOID *) tagInfoPtr->counts, + tagInfoPtr->arraySize * sizeof(int)); + ckfree((char *) tagInfoPtr->counts); + tagInfoPtr->counts = newCounts; + tagInfoPtr->arraySize = newSize; + } + + tagInfoPtr->tagPtrs[tagInfoPtr->numTags] = tagPtr; + tagInfoPtr->counts[tagInfoPtr->numTags] = inc; + tagInfoPtr->numTags++; +} + +/* + *---------------------------------------------------------------------- + * + * TkBTreeCheck -- + * + * This procedure runs a set of consistency checks over a B-tree + * and panics if any inconsistencies are found. + * + * Results: + * None. + * + * Side effects: + * If a structural defect is found, the procedure panics with an + * error message. + * + *---------------------------------------------------------------------- + */ + +void +TkBTreeCheck(tree) + TkTextBTree tree; /* Tree to check. */ +{ + BTree *treePtr = (BTree *) tree; + register Summary *summaryPtr; + register Node *nodePtr; + register TkTextLine *linePtr; + register TkTextSegment *segPtr; + register TkTextTag *tagPtr; + Tcl_HashEntry *entryPtr; + Tcl_HashSearch search; + int count; + + /* + * Make sure that the tag toggle counts and the tag root pointers are OK. + */ + for (entryPtr = Tcl_FirstHashEntry(&treePtr->textPtr->tagTable, &search); + entryPtr != NULL ; entryPtr = Tcl_NextHashEntry(&search)) { + tagPtr = (TkTextTag *) Tcl_GetHashValue(entryPtr); + nodePtr = tagPtr->tagRootPtr; + if (nodePtr == (Node *) NULL) { + if (tagPtr->toggleCount != 0) { + panic("TkBTreeCheck found \"%s\" with toggles (%d) but no root", + tagPtr->name, tagPtr->toggleCount); + } + continue; /* no ranges for the tag */ + } else if (tagPtr->toggleCount == 0) { + panic("TkBTreeCheck found root for \"%s\" with no toggles", + tagPtr->name); + } else if (tagPtr->toggleCount & 1) { + panic("TkBTreeCheck found odd toggle count for \"%s\" (%d)", + tagPtr->name, tagPtr->toggleCount); + } + for (summaryPtr = nodePtr->summaryPtr; summaryPtr != NULL; + summaryPtr = summaryPtr->nextPtr) { + if (summaryPtr->tagPtr == tagPtr) { + panic("TkBTreeCheck found root node with summary info"); + } + } + count = 0; + if (nodePtr->level > 0) { + for (nodePtr = nodePtr->children.nodePtr ; nodePtr != NULL ; + nodePtr = nodePtr->nextPtr) { + for (summaryPtr = nodePtr->summaryPtr; summaryPtr != NULL; + summaryPtr = summaryPtr->nextPtr) { + if (summaryPtr->tagPtr == tagPtr) { + count += summaryPtr->toggleCount; + } + } + } + } else { + for (linePtr = nodePtr->children.linePtr ; linePtr != NULL ; + linePtr = linePtr->nextPtr) { + for (segPtr = linePtr->segPtr; segPtr != NULL; + segPtr = segPtr->nextPtr) { + if ((segPtr->typePtr == &tkTextToggleOnType || + segPtr->typePtr == &tkTextToggleOffType) && + segPtr->body.toggle.tagPtr == tagPtr) { + count++; + } + } + } + } + if (count != tagPtr->toggleCount) { + panic("TkBTreeCheck toggleCount (%d) wrong for \"%s\" should be (%d)", + tagPtr->toggleCount, tagPtr->name, count); + } + } + + /* + * Call a recursive procedure to do the main body of checks. + */ + + nodePtr = treePtr->rootPtr; + CheckNodeConsistency(treePtr->rootPtr); + + /* + * Make sure that there are at least two lines in the text and + * that the last line has no characters except a newline. + */ + + if (nodePtr->numLines < 2) { + panic("TkBTreeCheck: less than 2 lines in tree"); + } + while (nodePtr->level > 0) { + nodePtr = nodePtr->children.nodePtr; + while (nodePtr->nextPtr != NULL) { + nodePtr = nodePtr->nextPtr; + } + } + linePtr = nodePtr->children.linePtr; + while (linePtr->nextPtr != NULL) { + linePtr = linePtr->nextPtr; + } + segPtr = linePtr->segPtr; + while ((segPtr->typePtr == &tkTextToggleOffType) + || (segPtr->typePtr == &tkTextRightMarkType) + || (segPtr->typePtr == &tkTextLeftMarkType)) { + /* + * It's OK to toggle a tag off in the last line, but + * not to start a new range. It's also OK to have marks + * in the last line. + */ + + segPtr = segPtr->nextPtr; + } + if (segPtr->typePtr != &tkTextCharType) { + panic("TkBTreeCheck: last line has bogus segment type"); + } + if (segPtr->nextPtr != NULL) { + panic("TkBTreeCheck: last line has too many segments"); + } + if (segPtr->size != 1) { + panic("TkBTreeCheck: last line has wrong # characters: %d", + segPtr->size); + } + if ((segPtr->body.chars[0] != '\n') || (segPtr->body.chars[1] != 0)) { + panic("TkBTreeCheck: last line had bad value: %s", + segPtr->body.chars); + } +} + +/* + *---------------------------------------------------------------------- + * + * CheckNodeConsistency -- + * + * This procedure is called as part of consistency checking for + * B-trees: it checks several aspects of a node and also runs + * checks recursively on the node's children. + * + * Results: + * None. + * + * Side effects: + * If anything suspicious is found in the tree structure, the + * procedure panics. + * + *---------------------------------------------------------------------- + */ + +static void +CheckNodeConsistency(nodePtr) + register Node *nodePtr; /* Node whose subtree should be + * checked. */ +{ + register Node *childNodePtr; + register Summary *summaryPtr, *summaryPtr2; + register TkTextLine *linePtr; + register TkTextSegment *segPtr; + int numChildren, numLines, toggleCount, minChildren; + + if (nodePtr->parentPtr != NULL) { + minChildren = MIN_CHILDREN; + } else if (nodePtr->level > 0) { + minChildren = 2; + } else { + minChildren = 1; + } + if ((nodePtr->numChildren < minChildren) + || (nodePtr->numChildren > MAX_CHILDREN)) { + panic("CheckNodeConsistency: bad child count (%d)", + nodePtr->numChildren); + } + + numChildren = 0; + numLines = 0; + if (nodePtr->level == 0) { + for (linePtr = nodePtr->children.linePtr; linePtr != NULL; + linePtr = linePtr->nextPtr) { + if (linePtr->parentPtr != nodePtr) { + panic("CheckNodeConsistency: line doesn't point to parent"); + } + if (linePtr->segPtr == NULL) { + panic("CheckNodeConsistency: line has no segments"); + } + for (segPtr = linePtr->segPtr; segPtr != NULL; + segPtr = segPtr->nextPtr) { + if (segPtr->typePtr->checkProc != NULL) { + (*segPtr->typePtr->checkProc)(segPtr, linePtr); + } + if ((segPtr->size == 0) && (!segPtr->typePtr->leftGravity) + && (segPtr->nextPtr != NULL) + && (segPtr->nextPtr->size == 0) + && (segPtr->nextPtr->typePtr->leftGravity)) { + panic("CheckNodeConsistency: wrong segment order for gravity"); + } + if ((segPtr->nextPtr == NULL) + && (segPtr->typePtr != &tkTextCharType)) { + panic("CheckNodeConsistency: line ended with wrong type"); + } + } + numChildren++; + numLines++; + } + } else { + for (childNodePtr = nodePtr->children.nodePtr; childNodePtr != NULL; + childNodePtr = childNodePtr->nextPtr) { + if (childNodePtr->parentPtr != nodePtr) { + panic("CheckNodeConsistency: node doesn't point to parent"); + } + if (childNodePtr->level != (nodePtr->level-1)) { + panic("CheckNodeConsistency: level mismatch (%d %d)", + nodePtr->level, childNodePtr->level); + } + CheckNodeConsistency(childNodePtr); + for (summaryPtr = childNodePtr->summaryPtr; summaryPtr != NULL; + summaryPtr = summaryPtr->nextPtr) { + for (summaryPtr2 = nodePtr->summaryPtr; ; + summaryPtr2 = summaryPtr2->nextPtr) { + if (summaryPtr2 == NULL) { + if (summaryPtr->tagPtr->tagRootPtr == nodePtr) { + break; + } + panic("CheckNodeConsistency: node tag \"%s\" not %s", + summaryPtr->tagPtr->name, + "present in parent summaries"); + } + if (summaryPtr->tagPtr == summaryPtr2->tagPtr) { + break; + } + } + } + numChildren++; + numLines += childNodePtr->numLines; + } + } + if (numChildren != nodePtr->numChildren) { + panic("CheckNodeConsistency: mismatch in numChildren (%d %d)", + numChildren, nodePtr->numChildren); + } + if (numLines != nodePtr->numLines) { + panic("CheckNodeConsistency: mismatch in numLines (%d %d)", + numLines, nodePtr->numLines); + } + + for (summaryPtr = nodePtr->summaryPtr; summaryPtr != NULL; + summaryPtr = summaryPtr->nextPtr) { + if (summaryPtr->tagPtr->toggleCount == summaryPtr->toggleCount) { + panic("CheckNodeConsistency: found unpruned root for \"%s\"", + summaryPtr->tagPtr->name); + } + toggleCount = 0; + if (nodePtr->level == 0) { + for (linePtr = nodePtr->children.linePtr; linePtr != NULL; + linePtr = linePtr->nextPtr) { + for (segPtr = linePtr->segPtr; segPtr != NULL; + segPtr = segPtr->nextPtr) { + if ((segPtr->typePtr != &tkTextToggleOnType) + && (segPtr->typePtr != &tkTextToggleOffType)) { + continue; + } + if (segPtr->body.toggle.tagPtr == summaryPtr->tagPtr) { + toggleCount ++; + } + } + } + } else { + for (childNodePtr = nodePtr->children.nodePtr; + childNodePtr != NULL; + childNodePtr = childNodePtr->nextPtr) { + for (summaryPtr2 = childNodePtr->summaryPtr; + summaryPtr2 != NULL; + summaryPtr2 = summaryPtr2->nextPtr) { + if (summaryPtr2->tagPtr == summaryPtr->tagPtr) { + toggleCount += summaryPtr2->toggleCount; + } + } + } + } + if (toggleCount != summaryPtr->toggleCount) { + panic("CheckNodeConsistency: mismatch in toggleCount (%d %d)", + toggleCount, summaryPtr->toggleCount); + } + for (summaryPtr2 = summaryPtr->nextPtr; summaryPtr2 != NULL; + summaryPtr2 = summaryPtr2->nextPtr) { + if (summaryPtr2->tagPtr == summaryPtr->tagPtr) { + panic("CheckNodeConsistency: duplicated node tag: %s", + summaryPtr->tagPtr->name); + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Rebalance -- + * + * This procedure is called when a node of a B-tree appears to be + * out of balance (too many children, or too few). It rebalances + * that node and all of its ancestors in the tree. + * + * Results: + * None. + * + * Side effects: + * The internal structure of treePtr may change. + * + *---------------------------------------------------------------------- + */ + +static void +Rebalance(treePtr, nodePtr) + BTree *treePtr; /* Tree that is being rebalanced. */ + register Node *nodePtr; /* Node that may be out of balance. */ +{ + /* + * Loop over the entire ancestral chain of the node, working up + * through the tree one node at a time until the root node has + * been processed. + */ + + for ( ; nodePtr != NULL; nodePtr = nodePtr->parentPtr) { + register Node *newPtr, *childPtr; + register TkTextLine *linePtr; + int i; + + /* + * Check to see if the node has too many children. If it does, + * then split off all but the first MIN_CHILDREN into a separate + * node following the original one. Then repeat until the + * node has a decent size. + */ + + if (nodePtr->numChildren > MAX_CHILDREN) { + while (1) { + /* + * If the node being split is the root node, then make a + * new root node above it first. + */ + + if (nodePtr->parentPtr == NULL) { + newPtr = (Node *) ckalloc(sizeof(Node)); + newPtr->parentPtr = NULL; + newPtr->nextPtr = NULL; + newPtr->summaryPtr = NULL; + newPtr->level = nodePtr->level + 1; + newPtr->children.nodePtr = nodePtr; + newPtr->numChildren = 1; + newPtr->numLines = nodePtr->numLines; + RecomputeNodeCounts(newPtr); + treePtr->rootPtr = newPtr; + } + newPtr = (Node *) ckalloc(sizeof(Node)); + newPtr->parentPtr = nodePtr->parentPtr; + newPtr->nextPtr = nodePtr->nextPtr; + nodePtr->nextPtr = newPtr; + newPtr->summaryPtr = NULL; + newPtr->level = nodePtr->level; + newPtr->numChildren = nodePtr->numChildren - MIN_CHILDREN; + if (nodePtr->level == 0) { + for (i = MIN_CHILDREN-1, + linePtr = nodePtr->children.linePtr; + i > 0; i--, linePtr = linePtr->nextPtr) { + /* Empty loop body. */ + } + newPtr->children.linePtr = linePtr->nextPtr; + linePtr->nextPtr = NULL; + } else { + for (i = MIN_CHILDREN-1, + childPtr = nodePtr->children.nodePtr; + i > 0; i--, childPtr = childPtr->nextPtr) { + /* Empty loop body. */ + } + newPtr->children.nodePtr = childPtr->nextPtr; + childPtr->nextPtr = NULL; + } + RecomputeNodeCounts(nodePtr); + nodePtr->parentPtr->numChildren++; + nodePtr = newPtr; + if (nodePtr->numChildren <= MAX_CHILDREN) { + RecomputeNodeCounts(nodePtr); + break; + } + } + } + + while (nodePtr->numChildren < MIN_CHILDREN) { + register Node *otherPtr; + Node *halfwayNodePtr = NULL; /* Initialization needed only */ + TkTextLine *halfwayLinePtr = NULL; /* to prevent cc warnings. */ + int totalChildren, firstChildren, i; + + /* + * Too few children for this node. If this is the root then, + * it's OK for it to have less than MIN_CHILDREN children + * as long as it's got at least two. If it has only one + * (and isn't at level 0), then chop the root node out of + * the tree and use its child as the new root. + */ + + if (nodePtr->parentPtr == NULL) { + if ((nodePtr->numChildren == 1) && (nodePtr->level > 0)) { + treePtr->rootPtr = nodePtr->children.nodePtr; + treePtr->rootPtr->parentPtr = NULL; + DeleteSummaries(nodePtr->summaryPtr); + ckfree((char *) nodePtr); + } + return; + } + + /* + * Not the root. Make sure that there are siblings to + * balance with. + */ + + if (nodePtr->parentPtr->numChildren < 2) { + Rebalance(treePtr, nodePtr->parentPtr); + continue; + } + + /* + * Find a sibling neighbor to borrow from, and arrange for + * nodePtr to be the earlier of the pair. + */ + + if (nodePtr->nextPtr == NULL) { + for (otherPtr = nodePtr->parentPtr->children.nodePtr; + otherPtr->nextPtr != nodePtr; + otherPtr = otherPtr->nextPtr) { + /* Empty loop body. */ + } + nodePtr = otherPtr; + } + otherPtr = nodePtr->nextPtr; + + /* + * We're going to either merge the two siblings together + * into one node or redivide the children among them to + * balance their loads. As preparation, join their two + * child lists into a single list and remember the half-way + * point in the list. + */ + + totalChildren = nodePtr->numChildren + otherPtr->numChildren; + firstChildren = totalChildren/2; + if (nodePtr->children.nodePtr == NULL) { + nodePtr->children = otherPtr->children; + otherPtr->children.nodePtr = NULL; + otherPtr->children.linePtr = NULL; + } + if (nodePtr->level == 0) { + register TkTextLine *linePtr; + + for (linePtr = nodePtr->children.linePtr, i = 1; + linePtr->nextPtr != NULL; + linePtr = linePtr->nextPtr, i++) { + if (i == firstChildren) { + halfwayLinePtr = linePtr; + } + } + linePtr->nextPtr = otherPtr->children.linePtr; + while (i <= firstChildren) { + halfwayLinePtr = linePtr; + linePtr = linePtr->nextPtr; + i++; + } + } else { + register Node *childPtr; + + for (childPtr = nodePtr->children.nodePtr, i = 1; + childPtr->nextPtr != NULL; + childPtr = childPtr->nextPtr, i++) { + if (i <= firstChildren) { + if (i == firstChildren) { + halfwayNodePtr = childPtr; + } + } + } + childPtr->nextPtr = otherPtr->children.nodePtr; + while (i <= firstChildren) { + halfwayNodePtr = childPtr; + childPtr = childPtr->nextPtr; + i++; + } + } + + /* + * If the two siblings can simply be merged together, do it. + */ + + if (totalChildren <= MAX_CHILDREN) { + RecomputeNodeCounts(nodePtr); + nodePtr->nextPtr = otherPtr->nextPtr; + nodePtr->parentPtr->numChildren--; + DeleteSummaries(otherPtr->summaryPtr); + ckfree((char *) otherPtr); + continue; + } + + /* + * The siblings can't be merged, so just divide their + * children evenly between them. + */ + + if (nodePtr->level == 0) { + otherPtr->children.linePtr = halfwayLinePtr->nextPtr; + halfwayLinePtr->nextPtr = NULL; + } else { + otherPtr->children.nodePtr = halfwayNodePtr->nextPtr; + halfwayNodePtr->nextPtr = NULL; + } + RecomputeNodeCounts(nodePtr); + RecomputeNodeCounts(otherPtr); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * RecomputeNodeCounts -- + * + * This procedure is called to recompute all the counts in a node + * (tags, child information, etc.) by scanning the information in + * its descendants. This procedure is called during rebalancing + * when a node's child structure has changed. + * + * Results: + * None. + * + * Side effects: + * The tag counts for nodePtr are modified to reflect its current + * child structure, as are its numChildren and numLines fields. + * Also, all of the childrens' parentPtr fields are made to point + * to nodePtr. + * + *---------------------------------------------------------------------- + */ + +static void +RecomputeNodeCounts(nodePtr) + register Node *nodePtr; /* Node whose tag summary information + * must be recomputed. */ +{ + register Summary *summaryPtr, *summaryPtr2; + register Node *childPtr; + register TkTextLine *linePtr; + register TkTextSegment *segPtr; + TkTextTag *tagPtr; + + /* + * Zero out all the existing counts for the node, but don't delete + * the existing Summary records (most of them will probably be reused). + */ + + for (summaryPtr = nodePtr->summaryPtr; summaryPtr != NULL; + summaryPtr = summaryPtr->nextPtr) { + summaryPtr->toggleCount = 0; + } + nodePtr->numChildren = 0; + nodePtr->numLines = 0; + + /* + * Scan through the children, adding the childrens' tag counts into + * the node's tag counts and adding new Summary structures if + * necessary. + */ + + if (nodePtr->level == 0) { + for (linePtr = nodePtr->children.linePtr; linePtr != NULL; + linePtr = linePtr->nextPtr) { + nodePtr->numChildren++; + nodePtr->numLines++; + linePtr->parentPtr = nodePtr; + for (segPtr = linePtr->segPtr; segPtr != NULL; + segPtr = segPtr->nextPtr) { + if (((segPtr->typePtr != &tkTextToggleOnType) + && (segPtr->typePtr != &tkTextToggleOffType)) + || !(segPtr->body.toggle.inNodeCounts)) { + continue; + } + tagPtr = segPtr->body.toggle.tagPtr; + for (summaryPtr = nodePtr->summaryPtr; ; + summaryPtr = summaryPtr->nextPtr) { + if (summaryPtr == NULL) { + summaryPtr = (Summary *) ckalloc(sizeof(Summary)); + summaryPtr->tagPtr = tagPtr; + summaryPtr->toggleCount = 1; + summaryPtr->nextPtr = nodePtr->summaryPtr; + nodePtr->summaryPtr = summaryPtr; + break; + } + if (summaryPtr->tagPtr == tagPtr) { + summaryPtr->toggleCount++; + break; + } + } + } + } + } else { + for (childPtr = nodePtr->children.nodePtr; childPtr != NULL; + childPtr = childPtr->nextPtr) { + nodePtr->numChildren++; + nodePtr->numLines += childPtr->numLines; + childPtr->parentPtr = nodePtr; + for (summaryPtr2 = childPtr->summaryPtr; summaryPtr2 != NULL; + summaryPtr2 = summaryPtr2->nextPtr) { + for (summaryPtr = nodePtr->summaryPtr; ; + summaryPtr = summaryPtr->nextPtr) { + if (summaryPtr == NULL) { + summaryPtr = (Summary *) ckalloc(sizeof(Summary)); + summaryPtr->tagPtr = summaryPtr2->tagPtr; + summaryPtr->toggleCount = summaryPtr2->toggleCount; + summaryPtr->nextPtr = nodePtr->summaryPtr; + nodePtr->summaryPtr = summaryPtr; + break; + } + if (summaryPtr->tagPtr == summaryPtr2->tagPtr) { + summaryPtr->toggleCount += summaryPtr2->toggleCount; + break; + } + } + } + } + } + + /* + * Scan through the node's tag records again and delete any Summary + * records that still have a zero count, or that have all the toggles. + * The node with the children that account for all the tags toggles + * have no summary information, and they become the tagRootPtr for the tag. + */ + + summaryPtr2 = NULL; + for (summaryPtr = nodePtr->summaryPtr; summaryPtr != NULL; ) { + if (summaryPtr->toggleCount > 0 && + summaryPtr->toggleCount < summaryPtr->tagPtr->toggleCount) { + if (nodePtr->level == summaryPtr->tagPtr->tagRootPtr->level) { + /* + * The tag's root node split and some toggles left. + * The tag root must move up a level. + */ + summaryPtr->tagPtr->tagRootPtr = nodePtr->parentPtr; + } + summaryPtr2 = summaryPtr; + summaryPtr = summaryPtr->nextPtr; + continue; + } + if (summaryPtr->toggleCount == summaryPtr->tagPtr->toggleCount) { + /* + * A node merge has collected all the toggles under one node. + * Push the root down to this level. + */ + summaryPtr->tagPtr->tagRootPtr = nodePtr; + } + if (summaryPtr2 != NULL) { + summaryPtr2->nextPtr = summaryPtr->nextPtr; + ckfree((char *) summaryPtr); + summaryPtr = summaryPtr2->nextPtr; + } else { + nodePtr->summaryPtr = summaryPtr->nextPtr; + ckfree((char *) summaryPtr); + summaryPtr = nodePtr->summaryPtr; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TkBTreeNumLines -- + * + * This procedure returns a count of the number of lines of + * text present in a given B-tree. + * + * Results: + * The return value is a count of the number of usable lines + * in tree (i.e. it doesn't include the dummy line that is just + * used to mark the end of the tree). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TkBTreeNumLines(tree) + TkTextBTree tree; /* Information about tree. */ +{ + BTree *treePtr = (BTree *) tree; + return treePtr->rootPtr->numLines - 1; +} + +/* + *-------------------------------------------------------------- + * + * CharSplitProc -- + * + * This procedure implements splitting for character segments. + * + * Results: + * The return value is a pointer to a chain of two segments + * that have the same characters as segPtr except split + * among the two segments. + * + * Side effects: + * Storage for segPtr is freed. + * + *-------------------------------------------------------------- + */ + +static TkTextSegment * +CharSplitProc(segPtr, index) + TkTextSegment *segPtr; /* Pointer to segment to split. */ + int index; /* Position within segment at which + * to split. */ +{ + TkTextSegment *newPtr1, *newPtr2; + + newPtr1 = (TkTextSegment *) ckalloc(CSEG_SIZE(index)); + newPtr2 = (TkTextSegment *) ckalloc( + CSEG_SIZE(segPtr->size - index)); + newPtr1->typePtr = &tkTextCharType; + newPtr1->nextPtr = newPtr2; + newPtr1->size = index; + strncpy(newPtr1->body.chars, segPtr->body.chars, (size_t) index); + newPtr1->body.chars[index] = 0; + newPtr2->typePtr = &tkTextCharType; + newPtr2->nextPtr = segPtr->nextPtr; + newPtr2->size = segPtr->size - index; + strcpy(newPtr2->body.chars, segPtr->body.chars + index); + ckfree((char*) segPtr); + return newPtr1; +} + +/* + *-------------------------------------------------------------- + * + * CharCleanupProc -- + * + * This procedure merges adjacent character segments into + * a single character segment, if possible. + * + * Results: + * The return value is a pointer to the first segment in + * the (new) list of segments that used to start with segPtr. + * + * Side effects: + * Storage for the segments may be allocated and freed. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static TkTextSegment * +CharCleanupProc(segPtr, linePtr) + TkTextSegment *segPtr; /* Pointer to first of two adjacent + * segments to join. */ + TkTextLine *linePtr; /* Line containing segments (not + * used). */ +{ + TkTextSegment *segPtr2, *newPtr; + + segPtr2 = segPtr->nextPtr; + if ((segPtr2 == NULL) || (segPtr2->typePtr != &tkTextCharType)) { + return segPtr; + } + newPtr = (TkTextSegment *) ckalloc(CSEG_SIZE( + segPtr->size + segPtr2->size)); + newPtr->typePtr = &tkTextCharType; + newPtr->nextPtr = segPtr2->nextPtr; + newPtr->size = segPtr->size + segPtr2->size; + strcpy(newPtr->body.chars, segPtr->body.chars); + strcpy(newPtr->body.chars + segPtr->size, segPtr2->body.chars); + ckfree((char*) segPtr); + ckfree((char*) segPtr2); + return newPtr; +} + +/* + *-------------------------------------------------------------- + * + * CharDeleteProc -- + * + * This procedure is invoked to delete a character segment. + * + * Results: + * Always returns 0 to indicate that the segment was deleted. + * + * Side effects: + * Storage for the segment is freed. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +CharDeleteProc(segPtr, linePtr, treeGone) + TkTextSegment *segPtr; /* Segment to delete. */ + TkTextLine *linePtr; /* Line containing segment. */ + int treeGone; /* Non-zero means the entire tree is + * being deleted, so everything must + * get cleaned up. */ +{ + ckfree((char*) segPtr); + return 0; +} + +/* + *-------------------------------------------------------------- + * + * CharCheckProc -- + * + * This procedure is invoked to perform consistency checks + * on character segments. + * + * Results: + * None. + * + * Side effects: + * If the segment isn't inconsistent then the procedure + * panics. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +CharCheckProc(segPtr, linePtr) + TkTextSegment *segPtr; /* Segment to check. */ + TkTextLine *linePtr; /* Line containing segment. */ +{ + /* + * Make sure that the segment contains the number of + * characters indicated by its header, and that the last + * segment in a line ends in a newline. Also make sure + * that there aren't ever two character segments adjacent + * to each other: they should be merged together. + */ + + if (segPtr->size <= 0) { + panic("CharCheckProc: segment has size <= 0"); + } + if (strlen(segPtr->body.chars) != (size_t) segPtr->size) { + panic("CharCheckProc: segment has wrong size"); + } + if (segPtr->nextPtr == NULL) { + if (segPtr->body.chars[segPtr->size-1] != '\n') { + panic("CharCheckProc: line doesn't end with newline"); + } + } else { + if (segPtr->nextPtr->typePtr == &tkTextCharType) { + panic("CharCheckProc: adjacent character segments weren't merged"); + } + } +} + +/* + *-------------------------------------------------------------- + * + * ToggleDeleteProc -- + * + * This procedure is invoked to delete toggle segments. + * + * Results: + * Returns 1 to indicate that the segment may not be deleted, + * unless the entire B-tree is going away. + * + * Side effects: + * If the tree is going away then the toggle's memory is + * freed; otherwise the toggle counts in nodes above the + * segment get updated. + * + *-------------------------------------------------------------- + */ + +static int +ToggleDeleteProc(segPtr, linePtr, treeGone) + TkTextSegment *segPtr; /* Segment to check. */ + TkTextLine *linePtr; /* Line containing segment. */ + int treeGone; /* Non-zero means the entire tree is + * being deleted, so everything must + * get cleaned up. */ +{ + if (treeGone) { + ckfree((char *) segPtr); + return 0; + } + + /* + * This toggle is in the middle of a range of characters that's + * being deleted. Refuse to die. We'll be moved to the end of + * the deleted range and our cleanup procedure will be called + * later. Decrement node toggle counts here, and set a flag + * so we'll re-increment them in the cleanup procedure. + */ + + if (segPtr->body.toggle.inNodeCounts) { + ChangeNodeToggleCount(linePtr->parentPtr, + segPtr->body.toggle.tagPtr, -1); + segPtr->body.toggle.inNodeCounts = 0; + } + return 1; +} + +/* + *-------------------------------------------------------------- + * + * ToggleCleanupProc -- + * + * This procedure is called when a toggle is part of a line that's + * been modified in some way. It's invoked after the + * modifications are complete. + * + * Results: + * The return value is the head segment in a new list + * that is to replace the tail of the line that used to + * start at segPtr. This allows the procedure to delete + * or modify segPtr. + * + * Side effects: + * Toggle counts in the nodes above the new line will be + * updated if they're not already. Toggles may be collapsed + * if there are duplicate toggles at the same position. + * + *-------------------------------------------------------------- + */ + +static TkTextSegment * +ToggleCleanupProc(segPtr, linePtr) + TkTextSegment *segPtr; /* Segment to check. */ + TkTextLine *linePtr; /* Line that now contains segment. */ +{ + TkTextSegment *segPtr2, *prevPtr; + int counts; + + /* + * If this is a toggle-off segment, look ahead through the next + * segments to see if there's a toggle-on segment for the same tag + * before any segments with non-zero size. If so then the two + * toggles cancel each other; remove them both. + */ + + if (segPtr->typePtr == &tkTextToggleOffType) { + for (prevPtr = segPtr, segPtr2 = prevPtr->nextPtr; + (segPtr2 != NULL) && (segPtr2->size == 0); + prevPtr = segPtr2, segPtr2 = prevPtr->nextPtr) { + if (segPtr2->typePtr != &tkTextToggleOnType) { + continue; + } + if (segPtr2->body.toggle.tagPtr != segPtr->body.toggle.tagPtr) { + continue; + } + counts = segPtr->body.toggle.inNodeCounts + + segPtr2->body.toggle.inNodeCounts; + if (counts != 0) { + ChangeNodeToggleCount(linePtr->parentPtr, + segPtr->body.toggle.tagPtr, -counts); + } + prevPtr->nextPtr = segPtr2->nextPtr; + ckfree((char *) segPtr2); + segPtr2 = segPtr->nextPtr; + ckfree((char *) segPtr); + return segPtr2; + } + } + + if (!segPtr->body.toggle.inNodeCounts) { + ChangeNodeToggleCount(linePtr->parentPtr, + segPtr->body.toggle.tagPtr, 1); + segPtr->body.toggle.inNodeCounts = 1; + } + return segPtr; +} + +/* + *-------------------------------------------------------------- + * + * ToggleLineChangeProc -- + * + * This procedure is invoked when a toggle segment is about + * to move from one line to another. + * + * Results: + * None. + * + * Side effects: + * Toggle counts are decremented in the nodes above the line. + * + *-------------------------------------------------------------- + */ + +static void +ToggleLineChangeProc(segPtr, linePtr) + TkTextSegment *segPtr; /* Segment to check. */ + TkTextLine *linePtr; /* Line that used to contain segment. */ +{ + if (segPtr->body.toggle.inNodeCounts) { + ChangeNodeToggleCount(linePtr->parentPtr, + segPtr->body.toggle.tagPtr, -1); + segPtr->body.toggle.inNodeCounts = 0; + } +} + +/* + *-------------------------------------------------------------- + * + * ToggleCheckProc -- + * + * This procedure is invoked to perform consistency checks + * on toggle segments. + * + * Results: + * None. + * + * Side effects: + * If a consistency problem is found the procedure panics. + * + *-------------------------------------------------------------- + */ + +static void +ToggleCheckProc(segPtr, linePtr) + TkTextSegment *segPtr; /* Segment to check. */ + TkTextLine *linePtr; /* Line containing segment. */ +{ + register Summary *summaryPtr; + int needSummary; + + if (segPtr->size != 0) { + panic("ToggleCheckProc: segment had non-zero size"); + } + if (!segPtr->body.toggle.inNodeCounts) { + panic("ToggleCheckProc: toggle counts not updated in nodes"); + } + needSummary = (segPtr->body.toggle.tagPtr->tagRootPtr != linePtr->parentPtr); + for (summaryPtr = linePtr->parentPtr->summaryPtr; ; + summaryPtr = summaryPtr->nextPtr) { + if (summaryPtr == NULL) { + if (needSummary) { + panic("ToggleCheckProc: tag not present in node"); + } else { + break; + } + } + if (summaryPtr->tagPtr == segPtr->body.toggle.tagPtr) { + if (!needSummary) { + panic("ToggleCheckProc: tag present in root node summary"); + } + break; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TkBTreeCharsInLine -- + * + * This procedure returns a count of the number of characters + * in a given line. + * + * Results: + * The return value is the character count for linePtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TkBTreeCharsInLine(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 new file mode 100644 index 0000000..8d9c022 --- /dev/null +++ b/generic/tkTextDisp.c @@ -0,0 +1,5015 @@ +/* + * tkTextDisp.c -- + * + * This module provides facilities to display text widgets. It is + * the only place where information is kept about the screen layout + * of text widgets. + * + * Copyright (c) 1992-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: @(#) tkTextDisp.c 1.124 97/07/11 18:01:03 + */ + +#include "tkPort.h" +#include "tkInt.h" +#include "tkText.h" + +/* + * The following structure describes how to display a range of characters. + * The information is generated by scanning all of the tags associated + * with the characters and combining that with default information for + * the overall widget. These structures form the hash keys for + * dInfoPtr->styleTable. + */ + +typedef struct StyleValues { + Tk_3DBorder border; /* Used for drawing background under text. + * NULL means use widget background. */ + int borderWidth; /* Width of 3-D border for background. */ + int relief; /* 3-D relief for background. */ + Pixmap bgStipple; /* Stipple bitmap for background. None + * means draw solid. */ + XColor *fgColor; /* Foreground color for text. */ + Tk_Font tkfont; /* Font for displaying text. */ + Pixmap fgStipple; /* Stipple bitmap for text and other + * foreground stuff. None means draw + * solid.*/ + int justify; /* Justification style for text. */ + int lMargin1; /* Left margin, in pixels, for first display + * line of each text line. */ + int lMargin2; /* Left margin, in pixels, for second and + * later display lines of each text line. */ + int offset; /* Offset in pixels of baseline, relative to + * baseline of line. */ + int overstrike; /* Non-zero means draw overstrike through + * text. */ + int rMargin; /* Right margin, in pixels. */ + int spacing1; /* Spacing above first dline in text line. */ + int spacing2; /* Spacing between lines of dline. */ + int spacing3; /* Spacing below last dline in text line. */ + TkTextTabArray *tabArrayPtr;/* Locations and types of tab stops (may + * be NULL). */ + int underline; /* Non-zero means draw underline underneath + * text. */ + Tk_Uid wrapMode; /* How to handle wrap-around for this tag. + * One of tkTextCharUid, tkTextNoneUid, + * or tkTextWordUid. */ +} StyleValues; + +/* + * The following structure extends the StyleValues structure above with + * graphics contexts used to actually draw the characters. The entries + * in dInfoPtr->styleTable point to structures of this type. + */ + +typedef struct TextStyle { + int refCount; /* Number of times this structure is + * referenced in Chunks. */ + GC bgGC; /* Graphics context for background. None + * means use widget background. */ + GC fgGC; /* Graphics context for foreground. */ + StyleValues *sValuePtr; /* Raw information from which GCs were + * derived. */ + Tcl_HashEntry *hPtr; /* Pointer to entry in styleTable. Used + * to delete entry. */ +} TextStyle; + +/* + * The following macro determines whether two styles have the same + * background so that, for example, no beveled border should be drawn + * between them. + */ + +#define SAME_BACKGROUND(s1, s2) \ + (((s1)->sValuePtr->border == (s2)->sValuePtr->border) \ + && ((s1)->sValuePtr->borderWidth == (s2)->sValuePtr->borderWidth) \ + && ((s1)->sValuePtr->relief == (s2)->sValuePtr->relief) \ + && ((s1)->sValuePtr->bgStipple == (s2)->sValuePtr->bgStipple)) + +/* + * The following structure describes one line of the display, which may + * be either part or all of one line of the text. + */ + +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 + * display line, including a trailing space + * or newline that isn't actually displayed. */ + int y; /* Y-position at which line is supposed to + * be drawn (topmost pixel of rectangular + * area occupied by line). */ + int oldY; /* Y-position at which line currently + * appears on display. -1 means line isn't + * currently visible on display and must be + * redrawn. This is used to move lines by + * scrolling rather than re-drawing. */ + int height; /* Height of line, in pixels. */ + int baseline; /* Offset of text baseline from y, in + * pixels. */ + int spaceAbove; /* How much extra space was added to the + * top of the line because of spacing + * options. This is included in height + * and baseline. */ + int spaceBelow; /* How much extra space was added to the + * bottom of the line because of spacing + * options. This is included in height. */ + int length; /* Total length of line, in pixels. */ + TkTextDispChunk *chunkPtr; /* Pointer to first chunk in list of all + * of those that are displayed on this + * line of the screen. */ + struct DLine *nextPtr; /* Next in list of all display lines for + * this window. The list is sorted in + * order from top to bottom. Note: the + * next DLine doesn't always correspond + * to the next line of text: (a) can have + * multiple DLines for one text line, and + * (b) can have gaps where DLine's have been + * deleted because they're out of date. */ + int flags; /* Various flag bits: see below for values. */ +} DLine; + +/* + * Flag bits for DLine structures: + * + * HAS_3D_BORDER - Non-zero means that at least one of the + * chunks in this line has a 3D border, so + * it potentially interacts with 3D borders + * in neighboring lines (see + * DisplayLineBackground). + * NEW_LAYOUT - Non-zero means that the line has been + * re-layed out since the last time the + * display was updated. + * TOP_LINE - Non-zero means that this was the top line + * in the window the last time that the window + * was laid out. This is important because + * a line may be displayed differently if its + * at the top or bottom than if it's in the + * middle (e.g. beveled edges aren't displayed + * for middle lines if the adjacent line has + * a similar background). + * BOTTOM_LINE - Non-zero means that this was the bottom line + * in the window the last time that the window + * was laid out. + */ + +#define HAS_3D_BORDER 1 +#define NEW_LAYOUT 2 +#define TOP_LINE 4 +#define BOTTOM_LINE 8 + +/* + * Overall display information for a text widget: + */ + +typedef struct TextDInfo { + Tcl_HashTable styleTable; /* Hash table that maps from StyleValues + * to TextStyles for this widget. */ + DLine *dLinePtr; /* First in list of all display lines for + * this widget, in order from top to bottom. */ + GC copyGC; /* Graphics context for copying from off- + * screen pixmaps onto screen. */ + GC scrollGC; /* Graphics context for copying from one place + * in the window to another (scrolling): + * differs from copyGC in that we need to get + * GraphicsExpose events. */ + int x; /* First x-coordinate that may be used for + * actually displaying line information. + * Leaves space for border, etc. */ + int y; /* First y-coordinate that may be used for + * actually displaying line information. + * Leaves space for border, etc. */ + int maxX; /* First x-coordinate to right of available + * space for displaying lines. */ + int maxY; /* First y-coordinate below available + * space for displaying lines. */ + int topOfEof; /* Top-most pixel (lowest y-value) that has + * been drawn in the appropriate fashion for + * the portion of the window after the last + * line of the text. This field is used to + * figure out when to redraw part or all of + * the eof field. */ + + /* + * Information used for scrolling: + */ + + int newCharOffset; /* Desired x scroll position, measured as the + * number of average-size characters off-screen + * to the left for a line with no left + * margin. */ + int curPixelOffset; /* Actual x scroll position, measured as the + * number of pixels off-screen to the left. */ + int maxLength; /* Length in pixels of longest line that's + * visible in window (length may exceed window + * size). If there's no wrapping, this will + * be zero. */ + double xScrollFirst, xScrollLast; + /* Most recent values reported to horizontal + * scrollbar; used to eliminate unnecessary + * reports. */ + double yScrollFirst, yScrollLast; + /* Most recent values reported to vertical + * scrollbar; used to eliminate unnecessary + * reports. */ + + /* + * 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 scanMarkX; /* X-position of mouse at time scan started. */ + int scanTotalScroll; /* Total scrolling (in screen lines) that has + * occurred since scanMarkY was set. */ + int scanMarkY; /* Y-position of mouse at time scan started. */ + + /* + * Miscellaneous information: + */ + + int dLinesInvalidated; /* This value is set to 1 whenever something + * happens that invalidates information in + * DLine structures; if a redisplay + * is in progress, it will see this and + * abort the redisplay. This is needed + * because, for example, an embedded window + * could change its size when it is first + * displayed, invalidating the DLine that + * is currently being displayed. If redisplay + * continues, it will use freed memory and + * could dump core. */ + int flags; /* Various flag values: see below for + * definitions. */ +} TextDInfo; + +/* + * In TkTextDispChunk structures for character segments, the clientData + * field points to one of the following structures: + */ + +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 + * THE LAST FIELD IN THE STRUCTURE. */ +} CharInfo; + +/* + * Flag values for TextDInfo structures: + * + * DINFO_OUT_OF_DATE: Non-zero means that the DLine structures + * for this window are partially or completely + * out of date and need to be recomputed. + * REDRAW_PENDING: Means that a when-idle handler has been + * scheduled to update the display. + * REDRAW_BORDERS: Means window border or pad area has + * potentially been damaged and must be redrawn. + * REPICK_NEEDED: 1 means that the widget has been modified + * in a way that could change the current + * character (a different character might be + * under the mouse cursor now). Need to + * recompute the current character before + * the next redisplay. + */ + +#define DINFO_OUT_OF_DATE 1 +#define REDRAW_PENDING 2 +#define REDRAW_BORDERS 4 +#define REPICK_NEEDED 8 + +/* + * The following counters keep statistics about redisplay that can be + * checked to see how clever this code is at reducing redisplays. + */ + +static int numRedisplays; /* Number of calls to DisplayText. */ +static int linesRedrawn; /* Number of calls to DisplayDLine. */ +static int numCopies; /* Number of calls to XCopyArea to copy part + * of the screen. */ + +/* + * Forward declarations for procedures defined later in this file: + */ + +static void AdjustForTab _ANSI_ARGS_((TkText *textPtr, + TkTextTabArray *tabArrayPtr, int index, + TkTextDispChunk *chunkPtr)); +static void CharBboxProc _ANSI_ARGS_((TkTextDispChunk *chunkPtr, + int index, int y, int lineHeight, int baseline, + int *xPtr, int *yPtr, int *widthPtr, + int *heightPtr)); +static void CharDisplayProc _ANSI_ARGS_((TkTextDispChunk *chunkPtr, + int x, int y, int height, int baseline, + Display *display, Drawable dst, int screenY)); +static int CharMeasureProc _ANSI_ARGS_((TkTextDispChunk *chunkPtr, + int x)); +static void CharUndisplayProc _ANSI_ARGS_((TkText *textPtr, + TkTextDispChunk *chunkPtr)); +static void DisplayDLine _ANSI_ARGS_((TkText *textPtr, + DLine *dlPtr, DLine *prevPtr, Pixmap pixmap)); +static void DisplayLineBackground _ANSI_ARGS_((TkText *textPtr, + DLine *dlPtr, DLine *prevPtr, Pixmap pixmap)); +static void DisplayText _ANSI_ARGS_((ClientData clientData)); +static DLine * FindDLine _ANSI_ARGS_((DLine *dlPtr, + TkTextIndex *indexPtr)); +static void FreeDLines _ANSI_ARGS_((TkText *textPtr, + DLine *firstPtr, DLine *lastPtr, int unlink)); +static void FreeStyle _ANSI_ARGS_((TkText *textPtr, + TextStyle *stylePtr)); +static TextStyle * GetStyle _ANSI_ARGS_((TkText *textPtr, + TkTextIndex *indexPtr)); +static void GetXView _ANSI_ARGS_((Tcl_Interp *interp, + TkText *textPtr, int report)); +static void GetYView _ANSI_ARGS_((Tcl_Interp *interp, + TkText *textPtr, int report)); +static DLine * LayoutDLine _ANSI_ARGS_((TkText *textPtr, + TkTextIndex *indexPtr)); +static int MeasureChars _ANSI_ARGS_((Tk_Font tkfont, + CONST char *source, int maxChars, int startX, + int maxX, int tabOrigin, int *nextXPtr)); +static void MeasureUp _ANSI_ARGS_((TkText *textPtr, + TkTextIndex *srcPtr, int distance, + TkTextIndex *dstPtr)); +static int NextTabStop _ANSI_ARGS_((Tk_Font tkfont, int x, + int tabOrigin)); +static void UpdateDisplayInfo _ANSI_ARGS_((TkText *textPtr)); +static void ScrollByLines _ANSI_ARGS_((TkText *textPtr, + int offset)); +static int SizeOfTab _ANSI_ARGS_((TkText *textPtr, + TkTextTabArray *tabArrayPtr, int index, int x, + int maxX)); +static void TextInvalidateRegion _ANSI_ARGS_((TkText *textPtr, + TkRegion region)); + + +/* + *---------------------------------------------------------------------- + * + * TkTextCreateDInfo -- + * + * This procedure is called when a new text widget is created. + * Its job is to set up display-related information for the widget. + * + * Results: + * None. + * + * Side effects: + * A TextDInfo data structure is allocated and initialized and attached + * to textPtr. + * + *---------------------------------------------------------------------- + */ + +void +TkTextCreateDInfo(textPtr) + TkText *textPtr; /* Overall information for text widget. */ +{ + register TextDInfo *dInfoPtr; + XGCValues gcValues; + + dInfoPtr = (TextDInfo *) ckalloc(sizeof(TextDInfo)); + Tcl_InitHashTable(&dInfoPtr->styleTable, sizeof(StyleValues)/sizeof(int)); + dInfoPtr->dLinePtr = NULL; + dInfoPtr->copyGC = None; + gcValues.graphics_exposures = True; + dInfoPtr->scrollGC = Tk_GetGC(textPtr->tkwin, GCGraphicsExposures, + &gcValues); + dInfoPtr->topOfEof = 0; + dInfoPtr->newCharOffset = 0; + dInfoPtr->curPixelOffset = 0; + dInfoPtr->maxLength = 0; + dInfoPtr->xScrollFirst = -1; + dInfoPtr->xScrollLast = -1; + dInfoPtr->yScrollFirst = -1; + dInfoPtr->yScrollLast = -1; + dInfoPtr->scanMarkChar = 0; + dInfoPtr->scanMarkX = 0; + dInfoPtr->scanTotalScroll = 0; + dInfoPtr->scanMarkY = 0; + dInfoPtr->dLinesInvalidated = 0; + dInfoPtr->flags = DINFO_OUT_OF_DATE; + textPtr->dInfoPtr = dInfoPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TkTextFreeDInfo -- + * + * This procedure is called to free up all of the private display + * information kept by this file for a text widget. + * + * Results: + * None. + * + * Side effects: + * Lots of resources get freed. + * + *---------------------------------------------------------------------- + */ + +void +TkTextFreeDInfo(textPtr) + TkText *textPtr; /* Overall information for text widget. */ +{ + register TextDInfo *dInfoPtr = textPtr->dInfoPtr; + + /* + * Be careful to free up styleTable *after* freeing up all the + * DLines, so that the hash table is still intact to free up the + * style-related information from the lines. Once the lines are + * all free then styleTable will be empty. + */ + + FreeDLines(textPtr, dInfoPtr->dLinePtr, (DLine *) NULL, 1); + Tcl_DeleteHashTable(&dInfoPtr->styleTable); + if (dInfoPtr->copyGC != None) { + Tk_FreeGC(textPtr->display, dInfoPtr->copyGC); + } + Tk_FreeGC(textPtr->display, dInfoPtr->scrollGC); + if (dInfoPtr->flags & REDRAW_PENDING) { + Tcl_CancelIdleCall(DisplayText, (ClientData) textPtr); + } + ckfree((char *) dInfoPtr); +} + +/* + *---------------------------------------------------------------------- + * + * GetStyle -- + * + * This procedure creates all the information needed to display + * text at a particular location. + * + * Results: + * The return value is a pointer to a TextStyle structure that + * corresponds to *sValuePtr. + * + * Side effects: + * A new entry may be created in the style table for the widget. + * + *---------------------------------------------------------------------- + */ + +static TextStyle * +GetStyle(textPtr, indexPtr) + TkText *textPtr; /* Overall information about text widget. */ + TkTextIndex *indexPtr; /* The character in the text for which + * display information is wanted. */ +{ + TkTextTag **tagPtrs; + register TkTextTag *tagPtr; + StyleValues styleValues; + TextStyle *stylePtr; + Tcl_HashEntry *hPtr; + int numTags, new, i; + XGCValues gcValues; + unsigned long mask; + + /* + * The variables below keep track of the highest-priority specification + * that has occurred for each of the various fields of the StyleValues. + */ + + int borderPrio, borderWidthPrio, reliefPrio, bgStipplePrio; + int fgPrio, fontPrio, fgStipplePrio; + int underlinePrio, justifyPrio, offsetPrio; + int lMargin1Prio, lMargin2Prio, rMarginPrio; + int spacing1Prio, spacing2Prio, spacing3Prio; + int overstrikePrio, tabPrio, wrapPrio; + + /* + * Find out what tags are present for the character, then compute + * a StyleValues structure corresponding to those tags (scan + * through all of the tags, saving information for the highest- + * priority tag). + */ + + tagPtrs = TkBTreeGetTags(indexPtr, &numTags); + borderPrio = borderWidthPrio = reliefPrio = bgStipplePrio = -1; + fgPrio = fontPrio = fgStipplePrio = -1; + underlinePrio = justifyPrio = offsetPrio = -1; + lMargin1Prio = lMargin2Prio = rMarginPrio = -1; + spacing1Prio = spacing2Prio = spacing3Prio = -1; + overstrikePrio = tabPrio = wrapPrio = -1; + memset((VOID *) &styleValues, 0, sizeof(StyleValues)); + styleValues.relief = TK_RELIEF_FLAT; + styleValues.fgColor = textPtr->fgColor; + styleValues.tkfont = textPtr->tkfont; + styleValues.justify = TK_JUSTIFY_LEFT; + styleValues.spacing1 = textPtr->spacing1; + styleValues.spacing2 = textPtr->spacing2; + styleValues.spacing3 = textPtr->spacing3; + styleValues.tabArrayPtr = textPtr->tabArrayPtr; + styleValues.wrapMode = textPtr->wrapMode; + for (i = 0 ; i < numTags; i++) { + tagPtr = tagPtrs[i]; + + /* + * On Windows and Mac, we need to skip the selection tag if + * we don't have focus. + */ + +#ifndef ALWAYS_SHOW_SELECTION + if ((tagPtr == textPtr->selTagPtr) && !(textPtr->flags & GOT_FOCUS)) { + continue; + } +#endif + + if ((tagPtr->border != NULL) && (tagPtr->priority > borderPrio)) { + styleValues.border = tagPtr->border; + borderPrio = tagPtr->priority; + } + if ((tagPtr->bdString != NULL) + && (tagPtr->priority > borderWidthPrio)) { + styleValues.borderWidth = tagPtr->borderWidth; + borderWidthPrio = tagPtr->priority; + } + if ((tagPtr->reliefString != NULL) + && (tagPtr->priority > reliefPrio)) { + if (styleValues.border == NULL) { + styleValues.border = textPtr->border; + } + styleValues.relief = tagPtr->relief; + reliefPrio = tagPtr->priority; + } + if ((tagPtr->bgStipple != None) + && (tagPtr->priority > bgStipplePrio)) { + styleValues.bgStipple = tagPtr->bgStipple; + bgStipplePrio = tagPtr->priority; + } + if ((tagPtr->fgColor != None) && (tagPtr->priority > fgPrio)) { + styleValues.fgColor = tagPtr->fgColor; + fgPrio = tagPtr->priority; + } + if ((tagPtr->tkfont != None) && (tagPtr->priority > fontPrio)) { + styleValues.tkfont = tagPtr->tkfont; + fontPrio = tagPtr->priority; + } + if ((tagPtr->fgStipple != None) + && (tagPtr->priority > fgStipplePrio)) { + styleValues.fgStipple = tagPtr->fgStipple; + fgStipplePrio = tagPtr->priority; + } + if ((tagPtr->justifyString != NULL) + && (tagPtr->priority > justifyPrio)) { + styleValues.justify = tagPtr->justify; + justifyPrio = tagPtr->priority; + } + if ((tagPtr->lMargin1String != NULL) + && (tagPtr->priority > lMargin1Prio)) { + styleValues.lMargin1 = tagPtr->lMargin1; + lMargin1Prio = tagPtr->priority; + } + if ((tagPtr->lMargin2String != NULL) + && (tagPtr->priority > lMargin2Prio)) { + styleValues.lMargin2 = tagPtr->lMargin2; + lMargin2Prio = tagPtr->priority; + } + if ((tagPtr->offsetString != NULL) + && (tagPtr->priority > offsetPrio)) { + styleValues.offset = tagPtr->offset; + offsetPrio = tagPtr->priority; + } + if ((tagPtr->overstrikeString != NULL) + && (tagPtr->priority > overstrikePrio)) { + styleValues.overstrike = tagPtr->overstrike; + overstrikePrio = tagPtr->priority; + } + if ((tagPtr->rMarginString != NULL) + && (tagPtr->priority > rMarginPrio)) { + styleValues.rMargin = tagPtr->rMargin; + rMarginPrio = tagPtr->priority; + } + if ((tagPtr->spacing1String != NULL) + && (tagPtr->priority > spacing1Prio)) { + styleValues.spacing1 = tagPtr->spacing1; + spacing1Prio = tagPtr->priority; + } + if ((tagPtr->spacing2String != NULL) + && (tagPtr->priority > spacing2Prio)) { + styleValues.spacing2 = tagPtr->spacing2; + spacing2Prio = tagPtr->priority; + } + if ((tagPtr->spacing3String != NULL) + && (tagPtr->priority > spacing3Prio)) { + styleValues.spacing3 = tagPtr->spacing3; + spacing3Prio = tagPtr->priority; + } + if ((tagPtr->tabString != NULL) + && (tagPtr->priority > tabPrio)) { + styleValues.tabArrayPtr = tagPtr->tabArrayPtr; + tabPrio = tagPtr->priority; + } + if ((tagPtr->underlineString != NULL) + && (tagPtr->priority > underlinePrio)) { + styleValues.underline = tagPtr->underline; + underlinePrio = tagPtr->priority; + } + if ((tagPtr->wrapMode != NULL) + && (tagPtr->priority > wrapPrio)) { + styleValues.wrapMode = tagPtr->wrapMode; + wrapPrio = tagPtr->priority; + } + } + if (tagPtrs != NULL) { + ckfree((char *) tagPtrs); + } + + /* + * Use an existing style if there's one around that matches. + */ + + hPtr = Tcl_CreateHashEntry(&textPtr->dInfoPtr->styleTable, + (char *) &styleValues, &new); + if (!new) { + stylePtr = (TextStyle *) Tcl_GetHashValue(hPtr); + stylePtr->refCount++; + return stylePtr; + } + + /* + * No existing style matched. Make a new one. + */ + + stylePtr = (TextStyle *) ckalloc(sizeof(TextStyle)); + stylePtr->refCount = 1; + if (styleValues.border != NULL) { + gcValues.foreground = Tk_3DBorderColor(styleValues.border)->pixel; + mask = GCForeground; + if (styleValues.bgStipple != None) { + gcValues.stipple = styleValues.bgStipple; + gcValues.fill_style = FillStippled; + mask |= GCStipple|GCFillStyle; + } + stylePtr->bgGC = Tk_GetGC(textPtr->tkwin, mask, &gcValues); + } else { + stylePtr->bgGC = None; + } + mask = GCForeground|GCFont; + gcValues.foreground = styleValues.fgColor->pixel; + gcValues.font = Tk_FontId(styleValues.tkfont); + if (styleValues.fgStipple != None) { + gcValues.stipple = styleValues.fgStipple; + gcValues.fill_style = FillStippled; + mask |= GCStipple|GCFillStyle; + } + stylePtr->fgGC = Tk_GetGC(textPtr->tkwin, mask, &gcValues); + stylePtr->sValuePtr = (StyleValues *) + Tcl_GetHashKey(&textPtr->dInfoPtr->styleTable, hPtr); + stylePtr->hPtr = hPtr; + Tcl_SetHashValue(hPtr, stylePtr); + return stylePtr; +} + +/* + *---------------------------------------------------------------------- + * + * FreeStyle -- + * + * This procedure is called when a TextStyle structure is no longer + * needed. It decrements the reference count and frees up the + * space for the style structure if the reference count is 0. + * + * Results: + * None. + * + * Side effects: + * The storage and other resources associated with the style + * are freed up if no-one's still using it. + * + *---------------------------------------------------------------------- + */ + +static void +FreeStyle(textPtr, stylePtr) + TkText *textPtr; /* Information about overall widget. */ + register TextStyle *stylePtr; /* Information about style to free. */ + +{ + stylePtr->refCount--; + if (stylePtr->refCount == 0) { + if (stylePtr->bgGC != None) { + Tk_FreeGC(textPtr->display, stylePtr->bgGC); + } + Tk_FreeGC(textPtr->display, stylePtr->fgGC); + Tcl_DeleteHashEntry(stylePtr->hPtr); + ckfree((char *) stylePtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * LayoutDLine -- + * + * This procedure generates a single DLine structure for a display + * line whose leftmost character is given by indexPtr. + * + * Results: + * The return value is a pointer to a DLine structure desribing the + * display line. All fields are filled in and correct except for + * y and nextPtr. + * + * Side effects: + * Storage is allocated for the new DLine. + * + *---------------------------------------------------------------------- + */ + +static DLine * +LayoutDLine(textPtr, indexPtr) + TkText *textPtr; /* Overall information about text widget. */ + TkTextIndex *indexPtr; /* Beginning of display line. May not + * necessarily point to a character segment. */ +{ + register DLine *dlPtr; /* New display line. */ + TkTextSegment *segPtr; /* Current segment in text. */ + TkTextDispChunk *lastChunkPtr; /* Last chunk allocated so far + * for line. */ + TkTextDispChunk *chunkPtr; /* Current chunk. */ + TkTextIndex curIndex; + TkTextDispChunk *breakChunkPtr; /* Chunk containing best word break + * point, if any. */ + TkTextIndex breakIndex; /* Index of first character in + * breakChunkPtr. */ + int breakCharOffset; /* 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. */ + int jIndent; /* Additional indentation (beyond + * margins) due to justification. */ + int rMargin; /* Right margin width for line. */ + Tk_Uid wrapMode; /* Wrap mode to use for this line. */ + int x = 0, maxX = 0; /* Initializations needed only to + * stop compiler warnings. */ + int wholeLine; /* Non-zero means this display line + * runs to the end of the text line. */ + int tabIndex; /* Index of the current tab stop. */ + int gotTab; /* Non-zero means the current chunk + * contains a tab. */ + TkTextDispChunk *tabChunkPtr; /* Pointer to the chunk containing + * the previous tab stop. */ + int maxChars; /* Maximum number of characters to + * include in this chunk. */ + TkTextTabArray *tabArrayPtr; /* Tab stops for line; taken from + * style for 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 + * drop 0-sized chunks from the end + * of the line. */ + int offset, ascent, descent, code; + StyleValues *sValuePtr; + + /* + * Create and initialize a new DLine structure. + */ + + dlPtr = (DLine *) ckalloc(sizeof(DLine)); + dlPtr->index = *indexPtr; + dlPtr->count = 0; + dlPtr->y = 0; + dlPtr->oldY = -1; + dlPtr->height = 0; + dlPtr->baseline = 0; + dlPtr->chunkPtr = NULL; + dlPtr->nextPtr = NULL; + dlPtr->flags = NEW_LAYOUT; + + /* + * Each iteration of the loop below creates one TkTextDispChunk for + * the new display line. The line will always have at least one + * chunk (for the newline character at the end, if there's nothing + * else available). + */ + + curIndex = *indexPtr; + lastChunkPtr = NULL; + chunkPtr = NULL; + noCharsYet = 1; + breakChunkPtr = NULL; + breakCharOffset = 0; + justify = TK_JUSTIFY_LEFT; + tabIndex = -1; + tabChunkPtr = NULL; + tabArrayPtr = NULL; + rMargin = 0; + wrapMode = tkTextCharUid; + tabSize = 0; + lastCharChunkPtr = NULL; + + /* + * Find the first segment to consider for the line. Can't call + * TkTextIndexToSeg for this because it won't return a segment + * 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) { + /* Empty loop body. */ + } + + while (segPtr != NULL) { + if (segPtr->typePtr->layoutProc == NULL) { + segPtr = segPtr->nextPtr; + offset = 0; + continue; + } + if (chunkPtr == NULL) { + chunkPtr = (TkTextDispChunk *) ckalloc(sizeof(TkTextDispChunk)); + chunkPtr->nextPtr = NULL; + } + chunkPtr->stylePtr = GetStyle(textPtr, &curIndex); + + /* + * Save style information such as justification and indentation, + * up until the first character is encountered, then retain that + * information for the rest of the line. + */ + + if (noCharsYet) { + tabArrayPtr = chunkPtr->stylePtr->sValuePtr->tabArrayPtr; + justify = chunkPtr->stylePtr->sValuePtr->justify; + rMargin = chunkPtr->stylePtr->sValuePtr->rMargin; + wrapMode = chunkPtr->stylePtr->sValuePtr->wrapMode; + x = ((curIndex.charIndex == 0) + ? chunkPtr->stylePtr->sValuePtr->lMargin1 + : chunkPtr->stylePtr->sValuePtr->lMargin2); + if (wrapMode == tkTextNoneUid) { + maxX = INT_MAX; + } else { + maxX = textPtr->dInfoPtr->maxX - textPtr->dInfoPtr->x + - rMargin; + if (maxX < x) { + maxX = x; + } + } + } + + /* + * See if there is a tab in the current chunk; if so, only + * layout characters up to (and including) the tab. + */ + + gotTab = 0; + maxChars = segPtr->size - offset; + if (justify == TK_JUSTIFY_LEFT) { + if (segPtr->typePtr == &tkTextCharType) { + char *p; + + for (p = segPtr->body.chars + offset; *p != 0; p++) { + if (*p == '\t') { + maxChars = (p + 1 - segPtr->body.chars) - offset; + gotTab = 1; + break; + } + } + } + } + + chunkPtr->x = x; + code = (*segPtr->typePtr->layoutProc)(textPtr, &curIndex, segPtr, + offset, maxX-tabSize, maxChars, noCharsYet, wrapMode, + chunkPtr); + if (code <= 0) { + FreeStyle(textPtr, chunkPtr->stylePtr); + if (code < 0) { + /* + * This segment doesn't wish to display itself (e.g. most + * marks). + */ + + segPtr = segPtr->nextPtr; + offset = 0; + continue; + } + + /* + * No characters from this segment fit in the window: this + * means we're at the end of the display line. + */ + + if (chunkPtr != NULL) { + ckfree((char *) chunkPtr); + } + break; + } + if (chunkPtr->numChars > 0) { + noCharsYet = 0; + lastCharChunkPtr = chunkPtr; + } + if (lastChunkPtr == NULL) { + dlPtr->chunkPtr = chunkPtr; + } else { + lastChunkPtr->nextPtr = chunkPtr; + } + lastChunkPtr = chunkPtr; + x += chunkPtr->width; + if (chunkPtr->breakIndex > 0) { + breakCharOffset = chunkPtr->breakIndex; + breakIndex = curIndex; + breakChunkPtr = chunkPtr; + } + if (chunkPtr->numChars != maxChars) { + break; + } + + /* + * If we're at a new tab, adjust the layout for all the chunks + * pertaining to the previous tab. Also adjust the amount of + * space left in the line to account for space that will be eaten + * up by the tab. + */ + + if (gotTab) { + if (tabIndex >= 0) { + AdjustForTab(textPtr, tabArrayPtr, tabIndex, tabChunkPtr); + x = chunkPtr->x + chunkPtr->width; + } + tabIndex++; + tabChunkPtr = chunkPtr; + tabSize = SizeOfTab(textPtr, tabArrayPtr, tabIndex, x, maxX); + if (tabSize >= (maxX - x)) { + break; + } + } + curIndex.charIndex += chunkPtr->numChars; + offset += chunkPtr->numChars; + if (offset >= segPtr->size) { + offset = 0; + segPtr = segPtr->nextPtr; + } + chunkPtr = NULL; + } + if (noCharsYet) { + panic("LayoutDLine couldn't place any characters on a line"); + } + wholeLine = (segPtr == NULL); + + /* + * We're at the end of the display line. Throw away everything + * after the most recent word break, if there is one; this may + * potentially require the last chunk to be layed out again. + */ + + if (breakChunkPtr == NULL) { + /* + * This code makes sure that we don't accidentally display + * chunks with no characters at the end of the line (such as + * the insertion cursor). These chunks belong on the next + * line. So, throw away everything after the last chunk that + * has characters in it. + */ + + breakChunkPtr = lastCharChunkPtr; + breakCharOffset = breakChunkPtr->numChars; + } + if ((breakChunkPtr != NULL) && ((lastChunkPtr != breakChunkPtr) + || (breakCharOffset != lastChunkPtr->numChars))) { + while (1) { + chunkPtr = breakChunkPtr->nextPtr; + if (chunkPtr == NULL) { + break; + } + FreeStyle(textPtr, chunkPtr->stylePtr); + breakChunkPtr->nextPtr = chunkPtr->nextPtr; + (*chunkPtr->undisplayProc)(textPtr, chunkPtr); + ckfree((char *) chunkPtr); + } + if (breakCharOffset != breakChunkPtr->numChars) { + (*breakChunkPtr->undisplayProc)(textPtr, breakChunkPtr); + segPtr = TkTextIndexToSeg(&breakIndex, &offset); + (*segPtr->typePtr->layoutProc)(textPtr, &breakIndex, + segPtr, offset, maxX, breakCharOffset, 0, + wrapMode, breakChunkPtr); + } + lastChunkPtr = breakChunkPtr; + wholeLine = 0; + } + + /* + * Make tab adjustments for the last tab stop, if there is one. + */ + + if ((tabIndex >= 0) && (tabChunkPtr != NULL)) { + AdjustForTab(textPtr, tabArrayPtr, tabIndex, tabChunkPtr); + } + + /* + * Make one more pass over the line to recompute various things + * like its height, length, and total number of characters. 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, + * for purposes of justification, be (a) the window width, (b) + * the length of the longest line in the window, or (c) the length + * of the longest line in the text? (c) isn't available, (b) seems + * weird, since it can change with vertical scrolling, so (a) is + * what is implemented below. + */ + + if (wrapMode == tkTextNoneUid) { + maxX = textPtr->dInfoPtr->maxX - textPtr->dInfoPtr->x - rMargin; + } + dlPtr->length = lastChunkPtr->x + lastChunkPtr->width; + if (justify == TK_JUSTIFY_LEFT) { + jIndent = 0; + } else if (justify == TK_JUSTIFY_RIGHT) { + jIndent = maxX - dlPtr->length; + } else { + jIndent = (maxX - dlPtr->length)/2; + } + ascent = descent = 0; + for (chunkPtr = dlPtr->chunkPtr; chunkPtr != NULL; + chunkPtr = chunkPtr->nextPtr) { + chunkPtr->x += jIndent; + dlPtr->count += chunkPtr->numChars; + if (chunkPtr->minAscent > ascent) { + ascent = chunkPtr->minAscent; + } + if (chunkPtr->minDescent > descent) { + descent = chunkPtr->minDescent; + } + if (chunkPtr->minHeight > dlPtr->height) { + dlPtr->height = chunkPtr->minHeight; + } + sValuePtr = chunkPtr->stylePtr->sValuePtr; + if ((sValuePtr->borderWidth > 0) + && (sValuePtr->relief != TK_RELIEF_FLAT)) { + dlPtr->flags |= HAS_3D_BORDER; + } + } + if (dlPtr->height < (ascent + descent)) { + dlPtr->height = ascent + descent; + dlPtr->baseline = ascent; + } else { + dlPtr->baseline = ascent + (dlPtr->height - ascent - descent)/2; + } + sValuePtr = dlPtr->chunkPtr->stylePtr->sValuePtr; + if (dlPtr->index.charIndex == 0) { + dlPtr->spaceAbove = sValuePtr->spacing1; + } else { + dlPtr->spaceAbove = sValuePtr->spacing2 - sValuePtr->spacing2/2; + } + if (wholeLine) { + dlPtr->spaceBelow = sValuePtr->spacing3; + } else { + dlPtr->spaceBelow = sValuePtr->spacing2/2; + } + dlPtr->height += dlPtr->spaceAbove + dlPtr->spaceBelow; + dlPtr->baseline += dlPtr->spaceAbove; + + /* + * Recompute line length: may have changed because of justification. + */ + + dlPtr->length = lastChunkPtr->x + lastChunkPtr->width; + return dlPtr; +} + +/* + *---------------------------------------------------------------------- + * + * UpdateDisplayInfo -- + * + * This procedure is invoked to recompute some or all of the + * DLine structures for a text widget. At the time it is called + * the DLine structures still left in the widget are guaranteed + * to be correct except that (a) the y-coordinates aren't + * necessarily correct, (b) there may be missing structures + * (the DLine structures get removed as soon as they are potentially + * out-of-date), and (c) DLine structures that don't start at the + * beginning of a line may be incorrect if previous information in + * the same line changed size in a way that moved a line boundary + * (DLines for any info that changed will have been deleted, but + * not DLines for unchanged info in the same text line). + * + * Results: + * None. + * + * Side effects: + * Upon return, the DLine information for textPtr correctly reflects + * the positions where characters will be displayed. However, this + * procedure doesn't actually bring the display up-to-date. + * + *---------------------------------------------------------------------- + */ + +static void +UpdateDisplayInfo(textPtr) + TkText *textPtr; /* Text widget to update. */ +{ + register TextDInfo *dInfoPtr = textPtr->dInfoPtr; + register DLine *dlPtr, *prevPtr; + TkTextIndex index; + TkTextLine *lastLinePtr; + int y, maxY, pixelOffset, maxOffset; + + if (!(dInfoPtr->flags & DINFO_OUT_OF_DATE)) { + return; + } + dInfoPtr->flags &= ~DINFO_OUT_OF_DATE; + + /* + * Delete any DLines that are now above the top of the window. + */ + + index = textPtr->topIndex; + dlPtr = FindDLine(dInfoPtr->dLinePtr, &index); + if ((dlPtr != NULL) && (dlPtr != dInfoPtr->dLinePtr)) { + FreeDLines(textPtr, dInfoPtr->dLinePtr, dlPtr, 1); + } + + /* + *-------------------------------------------------------------- + * Scan through the contents of the window from top to bottom, + * recomputing information for lines that are missing. + *-------------------------------------------------------------- + */ + + lastLinePtr = TkBTreeFindLine(textPtr->tree, + TkBTreeNumLines(textPtr->tree)); + dlPtr = dInfoPtr->dLinePtr; + prevPtr = NULL; + y = dInfoPtr->y; + maxY = dInfoPtr->maxY; + while (1) { + register DLine *newPtr; + + if (index.linePtr == lastLinePtr) { + break; + } + + /* + * There are three possibilities right now: + * (a) the next DLine (dlPtr) corresponds exactly to the next + * information we want to display: just use it as-is. + * (b) the next DLine corresponds to a different line, or to + * a segment that will be coming later in the same line: + * leave this DLine alone in the hopes that we'll be able + * to use it later, then create a new DLine in front of + * it. + * (c) the next DLine corresponds to a segment in the line we + * want, but it's a segment that has already been processed + * or will never be processed. Delete the DLine and try + * again. + * + * One other twist on all this. It's possible for 3D borders + * to interact between lines (see DisplayLineBackground) so if + * a line is relayed out and has styles with 3D borders, its + * neighbors have to be redrawn if they have 3D borders too, + * since the interactions could have changed (the neighbors + * don't have to be relayed out, just redrawn). + */ + + if ((dlPtr == NULL) || (dlPtr->index.linePtr != index.linePtr)) { + /* + * Case (b) -- must make new DLine. + */ + + makeNewDLine: + if (tkTextDebug) { + char string[TK_POS_CHARS]; + + /* + * Debugging is enabled, so keep a log of all the lines + * that were re-layed out. The test suite uses this + * information. + */ + + TkTextPrintIndex(&index, string); + Tcl_SetVar2(textPtr->interp, "tk_textRelayout", (char *) NULL, + string, + TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT); + } + newPtr = LayoutDLine(textPtr, &index); + if (prevPtr == NULL) { + dInfoPtr->dLinePtr = newPtr; + } else { + prevPtr->nextPtr = newPtr; + if (prevPtr->flags & HAS_3D_BORDER) { + prevPtr->oldY = -1; + } + } + newPtr->nextPtr = dlPtr; + dlPtr = newPtr; + } else { + /* + * DlPtr refers to the line we want. Next check the + * index within the line. + */ + + if (index.charIndex == dlPtr->index.charIndex) { + /* + * Case (a) -- can use existing display line as-is. + */ + + if ((dlPtr->flags & HAS_3D_BORDER) && (prevPtr != NULL) + && (prevPtr->flags & (NEW_LAYOUT))) { + dlPtr->oldY = -1; + } + goto lineOK; + } + if (index.charIndex < dlPtr->index.charIndex) { + goto makeNewDLine; + } + + /* + * Case (c) -- dlPtr is useless. Discard it and start + * again with the next display line. + */ + + newPtr = dlPtr->nextPtr; + FreeDLines(textPtr, dlPtr, newPtr, 0); + dlPtr = newPtr; + if (prevPtr != NULL) { + prevPtr->nextPtr = newPtr; + } else { + dInfoPtr->dLinePtr = newPtr; + } + continue; + } + + /* + * Advance to the start of the next line. + */ + + lineOK: + dlPtr->y = y; + y += dlPtr->height; + TkTextIndexForwChars(&index, dlPtr->count, &index); + prevPtr = dlPtr; + dlPtr = dlPtr->nextPtr; + + /* + * If we switched text lines, delete any DLines left for the + * old text line. + */ + + if (index.linePtr != prevPtr->index.linePtr) { + register DLine *nextPtr; + + nextPtr = dlPtr; + while ((nextPtr != NULL) + && (nextPtr->index.linePtr == prevPtr->index.linePtr)) { + nextPtr = nextPtr->nextPtr; + } + if (nextPtr != dlPtr) { + FreeDLines(textPtr, dlPtr, nextPtr, 0); + prevPtr->nextPtr = nextPtr; + dlPtr = nextPtr; + } + } + + /* + * It's important to have the following check here rather than in + * the while statement for the loop, so that there's always at least + * one DLine generated, regardless of how small the window is. This + * keeps a lot of other code from breaking. + */ + + if (y >= maxY) { + break; + } + } + + /* + * Delete any DLine structures that don't fit on the screen. + */ + + FreeDLines(textPtr, dlPtr, (DLine *) NULL, 1); + + /* + *-------------------------------------------------------------- + * If there is extra space at the bottom of the window (because + * we've hit the end of the text), then bring in more lines at + * the top of the window, if there are any, to fill in the view. + *-------------------------------------------------------------- + */ + + if (y < maxY) { + int lineNum, spaceLeft, charsToCount; + DLine *lowestPtr; + + /* + * Layout an entire text line (potentially > 1 display line), + * then link in as many display lines as fit without moving + * the bottom line out of the window. Repeat this until + * all the extra space has been used up or we've reached the + * beginning of the text. + */ + + spaceLeft = maxY - y; + lineNum = TkBTreeLineIndex(dInfoPtr->dLinePtr->index.linePtr); + charsToCount = dInfoPtr->dLinePtr->index.charIndex; + if (charsToCount == 0) { + charsToCount = INT_MAX; + lineNum--; + } + for ( ; (lineNum >= 0) && (spaceLeft > 0); lineNum--) { + index.linePtr = TkBTreeFindLine(textPtr->tree, lineNum); + index.charIndex = 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 == lowestPtr->index.linePtr)); + + /* + * Scan through the display lines from the bottom one up to + * the top one. + */ + + while (lowestPtr != NULL) { + dlPtr = lowestPtr; + spaceLeft -= dlPtr->height; + if (spaceLeft < 0) { + break; + } + lowestPtr = dlPtr->nextPtr; + dlPtr->nextPtr = dInfoPtr->dLinePtr; + dInfoPtr->dLinePtr = dlPtr; + if (tkTextDebug) { + char string[TK_POS_CHARS]; + + TkTextPrintIndex(&dlPtr->index, string); + Tcl_SetVar2(textPtr->interp, "tk_textRelayout", + (char *) NULL, string, + TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT); + } + } + FreeDLines(textPtr, lowestPtr, (DLine *) NULL, 0); + charsToCount = INT_MAX; + } + + /* + * Now we're all done except that the y-coordinates in all the + * DLines are wrong and the top index for the text is wrong. + * Update them. + */ + + textPtr->topIndex = dInfoPtr->dLinePtr->index; + y = dInfoPtr->y; + for (dlPtr = dInfoPtr->dLinePtr; dlPtr != NULL; + dlPtr = dlPtr->nextPtr) { + if (y > dInfoPtr->maxY) { + panic("Added too many new lines in UpdateDisplayInfo"); + } + dlPtr->y = y; + y += dlPtr->height; + } + } + + /* + *-------------------------------------------------------------- + * If the old top or bottom line has scrolled elsewhere on the + * screen, we may not be able to re-use its old contents by + * copying bits (e.g., a beveled edge that was drawn when it was + * at the top or bottom won't be drawn when the line is in the + * middle and its neighbor has a matching background). Similarly, + * if the new top or bottom line came from somewhere else on the + * screen, we may not be able to copy the old bits. + *-------------------------------------------------------------- + */ + + dlPtr = dInfoPtr->dLinePtr; + if ((dlPtr->flags & HAS_3D_BORDER) && !(dlPtr->flags & TOP_LINE)) { + dlPtr->oldY = -1; + } + while (1) { + if ((dlPtr->flags & TOP_LINE) && (dlPtr != dInfoPtr->dLinePtr) + && (dlPtr->flags & HAS_3D_BORDER)) { + dlPtr->oldY = -1; + } + if ((dlPtr->flags & BOTTOM_LINE) && (dlPtr->nextPtr != NULL) + && (dlPtr->flags & HAS_3D_BORDER)) { + dlPtr->oldY = -1; + } + if (dlPtr->nextPtr == NULL) { + if ((dlPtr->flags & HAS_3D_BORDER) + && !(dlPtr->flags & BOTTOM_LINE)) { + dlPtr->oldY = -1; + } + dlPtr->flags &= ~TOP_LINE; + dlPtr->flags |= BOTTOM_LINE; + break; + } + dlPtr->flags &= ~(TOP_LINE|BOTTOM_LINE); + dlPtr = dlPtr->nextPtr; + } + dInfoPtr->dLinePtr->flags |= TOP_LINE; + + /* + * Arrange for scrollbars to be updated. + */ + + textPtr->flags |= UPDATE_SCROLLBARS; + + /* + *-------------------------------------------------------------- + * Deal with horizontal scrolling: + * 1. If there's empty space to the right of the longest line, + * shift the screen to the right to fill in the empty space. + * 2. If the desired horizontal scroll position has changed, + * force a full redisplay of all the lines in the widget. + * 3. If the wrap mode isn't "none" then re-scroll to the base + * position. + *-------------------------------------------------------------- + */ + + dInfoPtr->maxLength = 0; + for (dlPtr = dInfoPtr->dLinePtr; dlPtr != NULL; + dlPtr = dlPtr->nextPtr) { + if (dlPtr->length > dInfoPtr->maxLength) { + dInfoPtr->maxLength = dlPtr->length; + } + } + maxOffset = (dInfoPtr->maxLength - (dInfoPtr->maxX - dInfoPtr->x) + + textPtr->charWidth - 1)/textPtr->charWidth; + if (dInfoPtr->newCharOffset > maxOffset) { + dInfoPtr->newCharOffset = maxOffset; + } + if (dInfoPtr->newCharOffset < 0) { + dInfoPtr->newCharOffset = 0; + } + pixelOffset = dInfoPtr->newCharOffset * textPtr->charWidth; + if (pixelOffset != dInfoPtr->curPixelOffset) { + dInfoPtr->curPixelOffset = pixelOffset; + for (dlPtr = dInfoPtr->dLinePtr; dlPtr != NULL; + dlPtr = dlPtr->nextPtr) { + dlPtr->oldY = -1; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * FreeDLines -- + * + * This procedure is called to free up all of the resources + * associated with one or more DLine structures. + * + * Results: + * None. + * + * Side effects: + * Memory gets freed and various other resources are released. + * + *---------------------------------------------------------------------- + */ + +static void +FreeDLines(textPtr, firstPtr, lastPtr, unlink) + TkText *textPtr; /* Information about overall text + * widget. */ + register DLine *firstPtr; /* Pointer to first DLine to free up. */ + DLine *lastPtr; /* Pointer to DLine just after last + * one to free (NULL means everything + * starting with firstPtr). */ + int unlink; /* 1 means DLines are currently linked + * into the list rooted at + * textPtr->dInfoPtr->dLinePtr and + * they have to be unlinked. 0 means + * just free without unlinking. */ +{ + register TkTextDispChunk *chunkPtr, *nextChunkPtr; + register DLine *nextDLinePtr; + + if (unlink) { + if (textPtr->dInfoPtr->dLinePtr == firstPtr) { + textPtr->dInfoPtr->dLinePtr = lastPtr; + } else { + register DLine *prevPtr; + for (prevPtr = textPtr->dInfoPtr->dLinePtr; + prevPtr->nextPtr != firstPtr; prevPtr = prevPtr->nextPtr) { + /* Empty loop body. */ + } + prevPtr->nextPtr = lastPtr; + } + } + while (firstPtr != lastPtr) { + nextDLinePtr = firstPtr->nextPtr; + for (chunkPtr = firstPtr->chunkPtr; chunkPtr != NULL; + chunkPtr = nextChunkPtr) { + if (chunkPtr->undisplayProc != NULL) { + (*chunkPtr->undisplayProc)(textPtr, chunkPtr); + } + FreeStyle(textPtr, chunkPtr->stylePtr); + nextChunkPtr = chunkPtr->nextPtr; + ckfree((char *) chunkPtr); + } + ckfree((char *) firstPtr); + firstPtr = nextDLinePtr; + } + textPtr->dInfoPtr->dLinesInvalidated = 1; +} + +/* + *---------------------------------------------------------------------- + * + * DisplayDLine -- + * + * This procedure is invoked to draw a single line on the + * screen. + * + * Results: + * None. + * + * Side effects: + * The line given by dlPtr is drawn at its correct position in + * textPtr's window. Note that this is one *display* line, not + * one *text* line. + * + *---------------------------------------------------------------------- + */ + +static void +DisplayDLine(textPtr, dlPtr, prevPtr, pixmap) + TkText *textPtr; /* Text widget in which to draw line. */ + register DLine *dlPtr; /* Information about line to draw. */ + DLine *prevPtr; /* Line just before one to draw, or NULL + * if dlPtr is the top line. */ + Pixmap pixmap; /* Pixmap to use for double-buffering. + * Caller must make sure it's large enough + * to hold line. */ +{ + register TkTextDispChunk *chunkPtr; + TextDInfo *dInfoPtr = textPtr->dInfoPtr; + Display *display; + int height, x; + + /* + * First, clear the area of the line to the background color for the + * text widget. + */ + + display = Tk_Display(textPtr->tkwin); + Tk_Fill3DRectangle(textPtr->tkwin, pixmap, textPtr->border, 0, 0, + Tk_Width(textPtr->tkwin), dlPtr->height, 0, TK_RELIEF_FLAT); + + /* + * Next, draw background information for the whole line. + */ + + DisplayLineBackground(textPtr, dlPtr, prevPtr, pixmap); + + /* + * Make another pass through all of the chunks to redraw the + * insertion cursor, if it is visible on this line. Must do + * it here rather than in the foreground pass below because + * otherwise a wide insertion cursor will obscure the character + * to its left. + */ + + if (textPtr->state == tkNormalUid) { + for (chunkPtr = dlPtr->chunkPtr; (chunkPtr != NULL); + chunkPtr = chunkPtr->nextPtr) { + x = chunkPtr->x + dInfoPtr->x - dInfoPtr->curPixelOffset; + if (chunkPtr->displayProc == TkTextInsertDisplayProc) { + (*chunkPtr->displayProc)(chunkPtr, x, dlPtr->spaceAbove, + dlPtr->height - dlPtr->spaceAbove - dlPtr->spaceBelow, + dlPtr->baseline - dlPtr->spaceAbove, display, pixmap, + dlPtr->y + dlPtr->spaceAbove); + } + } + } + + /* + * Make yet another pass through all of the chunks to redraw all of + * foreground information. Note: we have to call the displayProc + * even for chunks that are off-screen. This is needed, for + * example, so that embedded windows can be unmapped in this case. + * Conve + */ + + for (chunkPtr = dlPtr->chunkPtr; (chunkPtr != NULL); + chunkPtr = chunkPtr->nextPtr) { + if (chunkPtr->displayProc == TkTextInsertDisplayProc) { + /* + * Already displayed the insertion cursor above. Don't + * do it again here. + */ + + continue; + } + x = chunkPtr->x + dInfoPtr->x - dInfoPtr->curPixelOffset; + if ((x + chunkPtr->width <= 0) || (x >= dInfoPtr->maxX)) { + /* + * Note: we have to call the displayProc even for chunks + * that are off-screen. This is needed, for example, so + * that embedded windows can be unmapped in this case. + * Display the chunk at a coordinate that can be clearly + * identified by the displayProc as being off-screen to + * the left (the displayProc may not be able to tell if + * something is off to the right). + */ + + (*chunkPtr->displayProc)(chunkPtr, -chunkPtr->width, + dlPtr->spaceAbove, + dlPtr->height - dlPtr->spaceAbove - dlPtr->spaceBelow, + dlPtr->baseline - dlPtr->spaceAbove, display, pixmap, + dlPtr->y + dlPtr->spaceAbove); + } else { + (*chunkPtr->displayProc)(chunkPtr, x, dlPtr->spaceAbove, + dlPtr->height - dlPtr->spaceAbove - dlPtr->spaceBelow, + dlPtr->baseline - dlPtr->spaceAbove, display, pixmap, + dlPtr->y + dlPtr->spaceAbove); + } + if (dInfoPtr->dLinesInvalidated) { + return; + } + } + + /* + * Copy the pixmap onto the screen. If this is the last line on + * the screen then copy a piece of the line, so that it doesn't + * overflow into the border area. Another special trick: copy the + * padding area to the left of the line; this is because the + * insertion cursor sometimes overflows onto that area and we want + * to get as much of the cursor as possible. + */ + + height = dlPtr->height; + if ((height + dlPtr->y) > dInfoPtr->maxY) { + height = dInfoPtr->maxY - dlPtr->y; + } + XCopyArea(display, pixmap, Tk_WindowId(textPtr->tkwin), dInfoPtr->copyGC, + dInfoPtr->x, 0, (unsigned) (dInfoPtr->maxX - dInfoPtr->x), + (unsigned) height, dInfoPtr->x, dlPtr->y); + linesRedrawn++; +} + +/* + *-------------------------------------------------------------- + * + * DisplayLineBackground -- + * + * This procedure is called to fill in the background for + * a display line. It draws 3D borders cleverly so that + * adjacent chunks with the same style (whether on the same + * line or different lines) have a single 3D border around + * the whole region. + * + * Results: + * There is no return value. Pixmap is filled in with background + * information for dlPtr. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static void +DisplayLineBackground(textPtr, dlPtr, prevPtr, pixmap) + TkText *textPtr; /* Text widget containing line. */ + register DLine *dlPtr; /* Information about line to draw. */ + DLine *prevPtr; /* Line just above dlPtr, or NULL if dlPtr + * is the top-most line in the window. */ + Pixmap pixmap; /* Pixmap to use for double-buffering. + * Caller must make sure it's large enough + * to hold line. Caller must also have + * filled it with the background color for + * the widget. */ +{ + TextDInfo *dInfoPtr = textPtr->dInfoPtr; + TkTextDispChunk *chunkPtr; /* Pointer to chunk in the current line. */ + TkTextDispChunk *chunkPtr2; /* Pointer to chunk in the line above or + * below the current one. NULL if we're to + * the left of or to the right of the chunks + * in the line. */ + TkTextDispChunk *nextPtr2; /* Next chunk after chunkPtr2 (it's not the + * same as chunkPtr2->nextPtr in the case + * where chunkPtr2 is NULL because the line + * is indented). */ + int leftX; /* The left edge of the region we're + * currently working on. */ + int leftXIn; /* 1 means beveled edge at leftX slopes right + * as it goes down, 0 means it slopes left + * as it goes down. */ + int rightX; /* Right edge of chunkPtr. */ + int rightX2; /* Right edge of chunkPtr2. */ + int matchLeft; /* Does the style of this line match that + * of its neighbor just to the left of + * the current x coordinate? */ + int matchRight; /* Does line's style match its neighbor + * just to the right of the current x-coord? */ + int minX, maxX, xOffset; + StyleValues *sValuePtr; + Display *display; + + /* + * Pass 1: scan through dlPtr from left to right. For each range of + * chunks with the same style, draw the main background for the style + * plus the vertical parts of the 3D borders (the left and right + * edges). + */ + + display = Tk_Display(textPtr->tkwin); + minX = dInfoPtr->curPixelOffset; + xOffset = dInfoPtr->x - minX; + maxX = minX + dInfoPtr->maxX - dInfoPtr->x; + chunkPtr = dlPtr->chunkPtr; + + /* + * Note A: in the following statement, and a few others later in + * this file marked with "See Note A above", the right side of the + * assignment was replaced with 0 on 6/18/97. This has the effect + * of highlighting the empty space to the left of a line whenever + * the leftmost character of the line is highlighted. This way, + * multi-line highlights always line up along their left edges. + * However, this may look funny in the case where a single word is + * highlighted. To undo the change, replace "leftX = 0" with "leftX + * = chunkPtr->x" and "rightX2 = 0" with "rightX2 = nextPtr2->x" + * here and at all the marked points below. This restores the old + * behavior where empty space to the left of a line is not + * highlighted, leaving a ragged left edge for multi-line + * highlights. + */ + + leftX = 0; + for (; leftX < maxX; chunkPtr = chunkPtr->nextPtr) { + if ((chunkPtr->nextPtr != NULL) + && SAME_BACKGROUND(chunkPtr->nextPtr->stylePtr, + chunkPtr->stylePtr)) { + continue; + } + sValuePtr = chunkPtr->stylePtr->sValuePtr; + rightX = chunkPtr->x + chunkPtr->width; + if ((chunkPtr->nextPtr == NULL) && (rightX < maxX)) { + rightX = maxX; + } + if (chunkPtr->stylePtr->bgGC != None) { + XFillRectangle(display, pixmap, chunkPtr->stylePtr->bgGC, + leftX + xOffset, 0, (unsigned int) (rightX - leftX), + (unsigned int) dlPtr->height); + if (sValuePtr->relief != TK_RELIEF_FLAT) { + Tk_3DVerticalBevel(textPtr->tkwin, pixmap, sValuePtr->border, + leftX + xOffset, 0, sValuePtr->borderWidth, + dlPtr->height, 1, sValuePtr->relief); + Tk_3DVerticalBevel(textPtr->tkwin, pixmap, sValuePtr->border, + rightX - sValuePtr->borderWidth + xOffset, + 0, sValuePtr->borderWidth, dlPtr->height, 0, + sValuePtr->relief); + } + } + leftX = rightX; + } + + /* + * Pass 2: draw the horizontal bevels along the top of the line. To + * do this, scan through dlPtr from left to right while simultaneously + * scanning through the line just above dlPtr. ChunkPtr2 and nextPtr2 + * refer to two adjacent chunks in the line above. + */ + + chunkPtr = dlPtr->chunkPtr; + leftX = 0; /* See Note A above. */ + leftXIn = 1; + rightX = chunkPtr->x + chunkPtr->width; + if ((chunkPtr->nextPtr == NULL) && (rightX < maxX)) { + rightX = maxX; + } + chunkPtr2 = NULL; + if (prevPtr != NULL) { + /* + * Find the chunk in the previous line that covers leftX. + */ + + nextPtr2 = prevPtr->chunkPtr; + rightX2 = 0; /* See Note A above. */ + while (rightX2 <= leftX) { + chunkPtr2 = nextPtr2; + if (chunkPtr2 == NULL) { + break; + } + nextPtr2 = chunkPtr2->nextPtr; + rightX2 = chunkPtr2->x + chunkPtr2->width; + if (nextPtr2 == NULL) { + rightX2 = INT_MAX; + } + } + } else { + nextPtr2 = NULL; + rightX2 = INT_MAX; + } + + while (leftX < maxX) { + matchLeft = (chunkPtr2 != NULL) + && SAME_BACKGROUND(chunkPtr2->stylePtr, chunkPtr->stylePtr); + sValuePtr = chunkPtr->stylePtr->sValuePtr; + if (rightX <= rightX2) { + /* + * The chunk in our line is about to end. If its style + * changes then draw the bevel for the current style. + */ + + if ((chunkPtr->nextPtr == NULL) + || !SAME_BACKGROUND(chunkPtr->stylePtr, + chunkPtr->nextPtr->stylePtr)) { + if (!matchLeft && (sValuePtr->relief != TK_RELIEF_FLAT)) { + Tk_3DHorizontalBevel(textPtr->tkwin, pixmap, + sValuePtr->border, leftX + xOffset, 0, + rightX - leftX, sValuePtr->borderWidth, leftXIn, + 1, 1, sValuePtr->relief); + } + leftX = rightX; + leftXIn = 1; + + /* + * If the chunk in the line above is also ending at + * the same point then advance to the next chunk in + * that line. + */ + + if ((rightX == rightX2) && (chunkPtr2 != NULL)) { + goto nextChunk2; + } + } + chunkPtr = chunkPtr->nextPtr; + if (chunkPtr == NULL) { + break; + } + rightX = chunkPtr->x + chunkPtr->width; + if ((chunkPtr->nextPtr == NULL) && (rightX < maxX)) { + rightX = maxX; + } + continue; + } + + /* + * The chunk in the line above is ending at an x-position where + * there is no change in the style of the current line. If the + * style above matches the current line on one side of the change + * but not on the other, we have to draw an L-shaped piece of + * bevel. + */ + + matchRight = (nextPtr2 != NULL) + && SAME_BACKGROUND(nextPtr2->stylePtr, chunkPtr->stylePtr); + if (matchLeft && !matchRight) { + if (sValuePtr->relief != TK_RELIEF_FLAT) { + Tk_3DVerticalBevel(textPtr->tkwin, pixmap, sValuePtr->border, + rightX2 - sValuePtr->borderWidth + xOffset, 0, + sValuePtr->borderWidth, sValuePtr->borderWidth, 0, + sValuePtr->relief); + } + leftX = rightX2 - sValuePtr->borderWidth; + leftXIn = 0; + } else if (!matchLeft && matchRight + && (sValuePtr->relief != TK_RELIEF_FLAT)) { + Tk_3DVerticalBevel(textPtr->tkwin, pixmap, sValuePtr->border, + rightX2 + xOffset, 0, sValuePtr->borderWidth, + sValuePtr->borderWidth, 1, sValuePtr->relief); + Tk_3DHorizontalBevel(textPtr->tkwin, pixmap, sValuePtr->border, + leftX + xOffset, 0, rightX2 + sValuePtr->borderWidth -leftX, + sValuePtr->borderWidth, leftXIn, 0, 1, + sValuePtr->relief); + } + + nextChunk2: + chunkPtr2 = nextPtr2; + if (chunkPtr2 == NULL) { + rightX2 = INT_MAX; + } else { + nextPtr2 = chunkPtr2->nextPtr; + rightX2 = chunkPtr2->x + chunkPtr2->width; + if (nextPtr2 == NULL) { + rightX2 = INT_MAX; + } + } + } + /* + * Pass 3: draw the horizontal bevels along the bottom of the line. + * This uses the same approach as pass 2. + */ + + chunkPtr = dlPtr->chunkPtr; + leftX = 0; /* See Note A above. */ + leftXIn = 0; + rightX = chunkPtr->x + chunkPtr->width; + if ((chunkPtr->nextPtr == NULL) && (rightX < maxX)) { + rightX = maxX; + } + chunkPtr2 = NULL; + if (dlPtr->nextPtr != NULL) { + /* + * Find the chunk in the previous line that covers leftX. + */ + + nextPtr2 = dlPtr->nextPtr->chunkPtr; + rightX2 = 0; /* See Note A above. */ + while (rightX2 <= leftX) { + chunkPtr2 = nextPtr2; + if (chunkPtr2 == NULL) { + break; + } + nextPtr2 = chunkPtr2->nextPtr; + rightX2 = chunkPtr2->x + chunkPtr2->width; + if (nextPtr2 == NULL) { + rightX2 = INT_MAX; + } + } + } else { + nextPtr2 = NULL; + rightX2 = INT_MAX; + } + + while (leftX < maxX) { + matchLeft = (chunkPtr2 != NULL) + && SAME_BACKGROUND(chunkPtr2->stylePtr, chunkPtr->stylePtr); + sValuePtr = chunkPtr->stylePtr->sValuePtr; + if (rightX <= rightX2) { + if ((chunkPtr->nextPtr == NULL) + || !SAME_BACKGROUND(chunkPtr->stylePtr, + chunkPtr->nextPtr->stylePtr)) { + if (!matchLeft && (sValuePtr->relief != TK_RELIEF_FLAT)) { + Tk_3DHorizontalBevel(textPtr->tkwin, pixmap, + sValuePtr->border, leftX + xOffset, + dlPtr->height - sValuePtr->borderWidth, + rightX - leftX, sValuePtr->borderWidth, leftXIn, + 0, 0, sValuePtr->relief); + } + leftX = rightX; + leftXIn = 0; + if ((rightX == rightX2) && (chunkPtr2 != NULL)) { + goto nextChunk2b; + } + } + chunkPtr = chunkPtr->nextPtr; + if (chunkPtr == NULL) { + break; + } + rightX = chunkPtr->x + chunkPtr->width; + if ((chunkPtr->nextPtr == NULL) && (rightX < maxX)) { + rightX = maxX; + } + continue; + } + + matchRight = (nextPtr2 != NULL) + && SAME_BACKGROUND(nextPtr2->stylePtr, chunkPtr->stylePtr); + if (matchLeft && !matchRight) { + if (sValuePtr->relief != TK_RELIEF_FLAT) { + Tk_3DVerticalBevel(textPtr->tkwin, pixmap, sValuePtr->border, + rightX2 - sValuePtr->borderWidth + xOffset, + dlPtr->height - sValuePtr->borderWidth, + sValuePtr->borderWidth, sValuePtr->borderWidth, 0, + sValuePtr->relief); + } + leftX = rightX2 - sValuePtr->borderWidth; + leftXIn = 1; + } else if (!matchLeft && matchRight + && (sValuePtr->relief != TK_RELIEF_FLAT)) { + Tk_3DVerticalBevel(textPtr->tkwin, pixmap, sValuePtr->border, + rightX2 + xOffset, dlPtr->height - sValuePtr->borderWidth, + sValuePtr->borderWidth, sValuePtr->borderWidth, + 1, sValuePtr->relief); + Tk_3DHorizontalBevel(textPtr->tkwin, pixmap, sValuePtr->border, + leftX + xOffset, dlPtr->height - sValuePtr->borderWidth, + rightX2 + sValuePtr->borderWidth - leftX, + sValuePtr->borderWidth, leftXIn, 1, 0, sValuePtr->relief); + } + + nextChunk2b: + chunkPtr2 = nextPtr2; + if (chunkPtr2 == NULL) { + rightX2 = INT_MAX; + } else { + nextPtr2 = chunkPtr2->nextPtr; + rightX2 = chunkPtr2->x + chunkPtr2->width; + if (nextPtr2 == NULL) { + rightX2 = INT_MAX; + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * DisplayText -- + * + * This procedure is invoked as a when-idle handler to update the + * display. It only redisplays the parts of the text widget that + * are out of date. + * + * Results: + * None. + * + * Side effects: + * Information is redrawn on the screen. + * + *---------------------------------------------------------------------- + */ + +static void +DisplayText(clientData) + ClientData clientData; /* Information about widget. */ +{ + register TkText *textPtr = (TkText *) clientData; + TextDInfo *dInfoPtr = textPtr->dInfoPtr; + Tk_Window tkwin; + register DLine *dlPtr; + DLine *prevPtr; + Pixmap pixmap; + int maxHeight, borders; + int bottomY = 0; /* Initialization needed only to stop + * compiler warnings. */ + Tcl_Interp *interp; + + if (textPtr->tkwin == NULL) { + + /* + * The widget has been deleted. Don't do anything. + */ + + return; + } + + interp = textPtr->interp; + Tcl_Preserve((ClientData) interp); + + if (tkTextDebug) { + Tcl_SetVar2(interp, "tk_textRelayout", (char *) NULL, "", + TCL_GLOBAL_ONLY); + } + + if (textPtr->tkwin == NULL) { + + /* + * The widget has been deleted. Don't do anything. + */ + + goto end; + } + + if (!Tk_IsMapped(textPtr->tkwin) || (dInfoPtr->maxX <= dInfoPtr->x) + || (dInfoPtr->maxY <= dInfoPtr->y)) { + UpdateDisplayInfo(textPtr); + dInfoPtr->flags &= ~REDRAW_PENDING; + goto doScrollbars; + } + numRedisplays++; + if (tkTextDebug) { + Tcl_SetVar2(interp, "tk_textRedraw", (char *) NULL, "", + TCL_GLOBAL_ONLY); + } + + if (textPtr->tkwin == NULL) { + + /* + * The widget has been deleted. Don't do anything. + */ + + goto end; + } + + /* + * Choose a new current item if that is needed (this could cause + * event handlers to be invoked, hence the preserve/release calls + * and the loop, since the handlers could conceivably necessitate + * yet another current item calculation). The tkwin check is because + * the whole window could go away in the Tcl_Release call. + */ + + while (dInfoPtr->flags & REPICK_NEEDED) { + Tcl_Preserve((ClientData) textPtr); + dInfoPtr->flags &= ~REPICK_NEEDED; + TkTextPickCurrent(textPtr, &textPtr->pickEvent); + tkwin = textPtr->tkwin; + Tcl_Release((ClientData) textPtr); + if (tkwin == NULL) { + goto end; + } + } + + /* + * First recompute what's supposed to be displayed. + */ + + UpdateDisplayInfo(textPtr); + dInfoPtr->dLinesInvalidated = 0; + + /* + * See if it's possible to bring some parts of the screen up-to-date + * by scrolling (copying from other parts of the screen). + */ + + for (dlPtr = dInfoPtr->dLinePtr; dlPtr != NULL; dlPtr = dlPtr->nextPtr) { + register DLine *dlPtr2; + int offset, height, y, oldY; + TkRegion damageRgn; + + if ((dlPtr->oldY == -1) || (dlPtr->y == dlPtr->oldY) + || ((dlPtr->oldY + dlPtr->height) > dInfoPtr->maxY)) { + continue; + } + + /* + * This line is already drawn somewhere in the window so it only + * needs to be copied to its new location. See if there's a group + * of lines that can all be copied together. + */ + + offset = dlPtr->y - dlPtr->oldY; + height = dlPtr->height; + y = dlPtr->y; + for (dlPtr2 = dlPtr->nextPtr; dlPtr2 != NULL; + dlPtr2 = dlPtr2->nextPtr) { + if ((dlPtr2->oldY == -1) + || ((dlPtr2->oldY + offset) != dlPtr2->y) + || ((dlPtr2->oldY + dlPtr2->height) > dInfoPtr->maxY)) { + break; + } + height += dlPtr2->height; + } + + /* + * Reduce the height of the area being copied if necessary to + * avoid overwriting the border area. + */ + + if ((y + height) > dInfoPtr->maxY) { + height = dInfoPtr->maxY -y; + } + oldY = dlPtr->oldY; + + /* + * Update the lines we are going to scroll to show that they + * have been copied. + */ + + while (1) { + dlPtr->oldY = dlPtr->y; + if (dlPtr->nextPtr == dlPtr2) { + break; + } + dlPtr = dlPtr->nextPtr; + } + + /* + * Scan through the lines following the copied ones to see if + * we are going to overwrite them with the copy operation. + * If so, mark them for redisplay. + */ + + for ( ; dlPtr2 != NULL; dlPtr2 = dlPtr2->nextPtr) { + if ((dlPtr2->oldY != -1) + && ((dlPtr2->oldY + dlPtr2->height) > y) + && (dlPtr2->oldY < (y + height))) { + dlPtr2->oldY = -1; + } + } + + /* + * Now scroll the lines. This may generate damage which we + * handle by calling TextInvalidateRegion to mark the display + * blocks as stale. + */ + + damageRgn = TkCreateRegion(); + if (TkScrollWindow(textPtr->tkwin, dInfoPtr->scrollGC, + dInfoPtr->x, oldY, + (dInfoPtr->maxX - dInfoPtr->x), height, + 0, y - oldY, damageRgn)) { + TextInvalidateRegion(textPtr, damageRgn); + } + numCopies++; + TkDestroyRegion(damageRgn); + } + + /* + * Clear the REDRAW_PENDING flag here. This is actually pretty + * tricky. We want to wait until *after* doing the scrolling, + * since that could generate more areas to redraw and don't + * want to reschedule a redisplay for them. On the other hand, + * we can't wait until after all the redisplaying, because the + * act of redisplaying could actually generate more redisplays + * (e.g. in the case of a nested window with event bindings triggered + * by redisplay). + */ + + dInfoPtr->flags &= ~REDRAW_PENDING; + + /* + * Redraw the borders if that's needed. + */ + + if (dInfoPtr->flags & REDRAW_BORDERS) { + if (tkTextDebug) { + Tcl_SetVar2(interp, "tk_textRedraw", (char *) NULL, "borders", + TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT); + } + + if (textPtr->tkwin == NULL) { + + /* + * The widget has been deleted. Don't do anything. + */ + + goto end; + } + + Tk_Draw3DRectangle(textPtr->tkwin, Tk_WindowId(textPtr->tkwin), + textPtr->border, textPtr->highlightWidth, + textPtr->highlightWidth, + Tk_Width(textPtr->tkwin) - 2*textPtr->highlightWidth, + Tk_Height(textPtr->tkwin) - 2*textPtr->highlightWidth, + textPtr->borderWidth, textPtr->relief); + if (textPtr->highlightWidth != 0) { + GC gc; + + if (textPtr->flags & GOT_FOCUS) { + gc = Tk_GCForColor(textPtr->highlightColorPtr, + Tk_WindowId(textPtr->tkwin)); + } else { + gc = Tk_GCForColor(textPtr->highlightBgColorPtr, + Tk_WindowId(textPtr->tkwin)); + } + Tk_DrawFocusHighlight(textPtr->tkwin, gc, textPtr->highlightWidth, + Tk_WindowId(textPtr->tkwin)); + } + borders = textPtr->borderWidth + textPtr->highlightWidth; + if (textPtr->padY > 0) { + Tk_Fill3DRectangle(textPtr->tkwin, Tk_WindowId(textPtr->tkwin), + textPtr->border, borders, borders, + Tk_Width(textPtr->tkwin) - 2*borders, textPtr->padY, + 0, TK_RELIEF_FLAT); + Tk_Fill3DRectangle(textPtr->tkwin, Tk_WindowId(textPtr->tkwin), + textPtr->border, borders, + Tk_Height(textPtr->tkwin) - borders - textPtr->padY, + Tk_Width(textPtr->tkwin) - 2*borders, + textPtr->padY, 0, TK_RELIEF_FLAT); + } + if (textPtr->padX > 0) { + Tk_Fill3DRectangle(textPtr->tkwin, Tk_WindowId(textPtr->tkwin), + textPtr->border, borders, borders + textPtr->padY, + textPtr->padX, + Tk_Height(textPtr->tkwin) - 2*borders -2*textPtr->padY, + 0, TK_RELIEF_FLAT); + Tk_Fill3DRectangle(textPtr->tkwin, Tk_WindowId(textPtr->tkwin), + textPtr->border, + Tk_Width(textPtr->tkwin) - borders - textPtr->padX, + borders + textPtr->padY, textPtr->padX, + Tk_Height(textPtr->tkwin) - 2*borders -2*textPtr->padY, + 0, TK_RELIEF_FLAT); + } + dInfoPtr->flags &= ~REDRAW_BORDERS; + } + + /* + * Now we have to redraw the lines that couldn't be updated by + * scrolling. First, compute the height of the largest line and + * allocate an off-screen pixmap to use for double-buffered + * displays. + */ + + maxHeight = -1; + for (dlPtr = dInfoPtr->dLinePtr; dlPtr != NULL; + dlPtr = dlPtr->nextPtr) { + if ((dlPtr->height > maxHeight) && (dlPtr->oldY != dlPtr->y)) { + maxHeight = dlPtr->height; + } + bottomY = dlPtr->y + dlPtr->height; + } + if (maxHeight > dInfoPtr->maxY) { + maxHeight = dInfoPtr->maxY; + } + if (maxHeight > 0) { + pixmap = Tk_GetPixmap(Tk_Display(textPtr->tkwin), + Tk_WindowId(textPtr->tkwin), Tk_Width(textPtr->tkwin), + maxHeight, Tk_Depth(textPtr->tkwin)); + for (prevPtr = NULL, dlPtr = textPtr->dInfoPtr->dLinePtr; + (dlPtr != NULL) && (dlPtr->y < dInfoPtr->maxY); + prevPtr = dlPtr, dlPtr = dlPtr->nextPtr) { + if (dlPtr->oldY != dlPtr->y) { + if (tkTextDebug) { + char string[TK_POS_CHARS]; + TkTextPrintIndex(&dlPtr->index, string); + Tcl_SetVar2(textPtr->interp, "tk_textRedraw", + (char *) NULL, string, + TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT); + } + DisplayDLine(textPtr, dlPtr, prevPtr, pixmap); + if (dInfoPtr->dLinesInvalidated) { + Tk_FreePixmap(Tk_Display(textPtr->tkwin), pixmap); + return; + } + dlPtr->oldY = dlPtr->y; + dlPtr->flags &= ~NEW_LAYOUT; + } + } + Tk_FreePixmap(Tk_Display(textPtr->tkwin), pixmap); + } + + /* + * See if we need to refresh the part of the window below the + * last line of text (if there is any such area). Refresh the + * padding area on the left too, since the insertion cursor might + * have been displayed there previously). + */ + + if (dInfoPtr->topOfEof > dInfoPtr->maxY) { + dInfoPtr->topOfEof = dInfoPtr->maxY; + } + if (bottomY < dInfoPtr->topOfEof) { + if (tkTextDebug) { + Tcl_SetVar2(textPtr->interp, "tk_textRedraw", + (char *) NULL, "eof", + TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT); + } + + if (textPtr->tkwin == NULL) { + + /* + * The widget has been deleted. Don't do anything. + */ + + goto end; + } + + Tk_Fill3DRectangle(textPtr->tkwin, Tk_WindowId(textPtr->tkwin), + textPtr->border, dInfoPtr->x - textPtr->padX, bottomY, + dInfoPtr->maxX - (dInfoPtr->x - textPtr->padX), + dInfoPtr->topOfEof-bottomY, 0, TK_RELIEF_FLAT); + } + dInfoPtr->topOfEof = bottomY; + + doScrollbars: + + /* + * Update the vertical scrollbar, if there is one. Note: it's + * important to clear REDRAW_PENDING here, just in case the + * scroll procedure does something that requires redisplay. + */ + + if (textPtr->flags & UPDATE_SCROLLBARS) { + textPtr->flags &= ~UPDATE_SCROLLBARS; + if (textPtr->yScrollCmd != NULL) { + GetYView(textPtr->interp, textPtr, 1); + } + + if (textPtr->tkwin == NULL) { + + /* + * The widget has been deleted. Don't do anything. + */ + + goto end; + } + + /* + * Update the horizontal scrollbar, if any. + */ + + if (textPtr->xScrollCmd != NULL) { + GetXView(textPtr->interp, textPtr, 1); + } + } + +end: + Tcl_Release((ClientData) interp); +} + +/* + *---------------------------------------------------------------------- + * + * TkTextEventuallyRepick -- + * + * This procedure is invoked whenever something happens that + * could change the current character or the tags associated + * with it. + * + * Results: + * None. + * + * Side effects: + * A repick is scheduled as an idle handler. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +void +TkTextEventuallyRepick(textPtr) + TkText *textPtr; /* Widget record for text widget. */ +{ + TextDInfo *dInfoPtr = textPtr->dInfoPtr; + + dInfoPtr->flags |= REPICK_NEEDED; + if (!(dInfoPtr->flags & REDRAW_PENDING)) { + dInfoPtr->flags |= REDRAW_PENDING; + Tcl_DoWhenIdle(DisplayText, (ClientData) textPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * TkTextRedrawRegion -- + * + * This procedure is invoked to schedule a redisplay for a given + * region of a text widget. The redisplay itself may not occur + * immediately: it's scheduled as a when-idle handler. + * + * Results: + * None. + * + * Side effects: + * Information will eventually be redrawn on the screen. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +void +TkTextRedrawRegion(textPtr, x, y, width, height) + TkText *textPtr; /* Widget record for text widget. */ + int x, y; /* Coordinates of upper-left corner of area + * to be redrawn, in pixels relative to + * textPtr's window. */ + int width, height; /* Width and height of area to be redrawn. */ +{ + TextDInfo *dInfoPtr = textPtr->dInfoPtr; + TkRegion damageRgn = TkCreateRegion(); + XRectangle rect; + + rect.x = x; + rect.y = y; + rect.width = width; + rect.height = height; + TkUnionRectWithRegion(&rect, damageRgn, damageRgn); + + TextInvalidateRegion(textPtr, damageRgn); + + if (!(dInfoPtr->flags & REDRAW_PENDING)) { + dInfoPtr->flags |= REDRAW_PENDING; + Tcl_DoWhenIdle(DisplayText, (ClientData) textPtr); + } + TkDestroyRegion(damageRgn); +} + +/* + *---------------------------------------------------------------------- + * + * TextInvalidateRegion -- + * + * Mark a region of text as invalid. + * + * Results: + * None. + * + * Side effects: + * Updates the display information for the text widget. + * + *---------------------------------------------------------------------- + */ + +static void +TextInvalidateRegion(textPtr, region) + TkText *textPtr; /* Widget record for text widget. */ + TkRegion region; /* Region of area to redraw. */ +{ + register DLine *dlPtr; + TextDInfo *dInfoPtr = textPtr->dInfoPtr; + int maxY, inset; + XRectangle rect; + + /* + * Find all lines that overlap the given region and mark them for + * redisplay. + */ + + TkClipBox(region, &rect); + maxY = rect.y + rect.height; + for (dlPtr = dInfoPtr->dLinePtr; dlPtr != NULL; + dlPtr = dlPtr->nextPtr) { + if ((dlPtr->oldY != -1) && (TkRectInRegion(region, rect.x, dlPtr->y, + rect.width, (unsigned int) dlPtr->height) != RectangleOut)) { + dlPtr->oldY = -1; + } + } + if (dInfoPtr->topOfEof < maxY) { + dInfoPtr->topOfEof = maxY; + } + + /* + * Schedule the redisplay operation if there isn't one already + * scheduled. + */ + + inset = textPtr->borderWidth + textPtr->highlightWidth; + if ((rect.x < (inset + textPtr->padX)) + || (rect.y < (inset + textPtr->padY)) + || ((int) (rect.x + rect.width) > (Tk_Width(textPtr->tkwin) + - inset - textPtr->padX)) + || (maxY > (Tk_Height(textPtr->tkwin) - inset - textPtr->padY))) { + dInfoPtr->flags |= REDRAW_BORDERS; + } +} + +/* + *---------------------------------------------------------------------- + * + * TkTextChanged -- + * + * This procedure is invoked when info in a text widget is about + * to be modified in a way that changes how it is displayed (e.g. + * characters were inserted or deleted, or tag information was + * changed). This procedure must be called *before* a change is + * made, so that indexes in the display information are still + * valid. + * + * Results: + * None. + * + * Side effects: + * The range of character between index1Ptr (inclusive) and + * index2Ptr (exclusive) will be redisplayed at some point in the + * future (the actual redisplay is scheduled as a when-idle handler). + * + *---------------------------------------------------------------------- + */ + +void +TkTextChanged(textPtr, index1Ptr, index2Ptr) + TkText *textPtr; /* Widget record for text widget. */ + TkTextIndex *index1Ptr; /* Index of first character to redisplay. */ + TkTextIndex *index2Ptr; /* Index of character just after last one + * to redisplay. */ +{ + TextDInfo *dInfoPtr = textPtr->dInfoPtr; + DLine *firstPtr, *lastPtr; + TkTextIndex rounded; + + /* + * Schedule both a redisplay and a recomputation of display information. + * It's done here rather than the end of the procedure for two reasons: + * + * 1. If there are no display lines to update we'll want to return + * immediately, well before the end of the procedure. + * 2. It's important to arrange for the redisplay BEFORE calling + * FreeDLines. The reason for this is subtle and has to do with + * embedded windows. The chunk delete procedure for an embedded + * window will schedule an idle handler to unmap the window. + * However, we want the idle handler for redisplay to be called + * first, so that it can put the embedded window back on the screen + * again (if appropriate). This will prevent the window from ever + * being unmapped, and thereby avoid flashing. + */ + + if (!(dInfoPtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(DisplayText, (ClientData) textPtr); + } + dInfoPtr->flags |= REDRAW_PENDING|DINFO_OUT_OF_DATE|REPICK_NEEDED; + + /* + * Find the DLines corresponding to index1Ptr and index2Ptr. There + * is one tricky thing here, which is that we have to relayout in + * units of whole text lines: round index1Ptr back to the beginning + * of its text line, and include all the display lines after index2, + * up to the end of its text line. This is necessary because the + * indices stored in the display lines will no longer be valid. It's + * also needed because any edit could change the way lines wrap. + */ + + rounded = *index1Ptr; + rounded.charIndex = 0; + firstPtr = FindDLine(dInfoPtr->dLinePtr, &rounded); + if (firstPtr == NULL) { + return; + } + lastPtr = FindDLine(dInfoPtr->dLinePtr, index2Ptr); + while ((lastPtr != NULL) + && (lastPtr->index.linePtr == index2Ptr->linePtr)) { + lastPtr = lastPtr->nextPtr; + } + + /* + * Delete all the DLines from firstPtr up to but not including lastPtr. + */ + + FreeDLines(textPtr, firstPtr, lastPtr, 1); +} + +/* + *---------------------------------------------------------------------- + * + * TkTextRedrawTag -- + * + * This procedure is invoked to request a redraw of all characters + * in a given range that have a particular tag on or off. It's + * called, for example, when tag options change. + * + * Results: + * None. + * + * Side effects: + * Information on the screen may be redrawn, and the layout of + * the screen may change. + * + *---------------------------------------------------------------------- + */ + +void +TkTextRedrawTag(textPtr, index1Ptr, index2Ptr, tagPtr, withTag) + TkText *textPtr; /* Widget record for text widget. */ + TkTextIndex *index1Ptr; /* First character in range to consider + * for redisplay. NULL means start at + * beginning of text. */ + TkTextIndex *index2Ptr; /* Character just after last one to consider + * for redisplay. NULL means process all + * the characters in the text. */ + TkTextTag *tagPtr; /* Information about tag. */ + int withTag; /* 1 means redraw characters that have the + * tag, 0 means redraw those without. */ +{ + register DLine *dlPtr; + DLine *endPtr; + int tagOn; + TkTextSearch search; + TextDInfo *dInfoPtr = textPtr->dInfoPtr; + TkTextIndex *curIndexPtr; + TkTextIndex endOfText, *endIndexPtr; + + /* + * Round up the starting position if it's before the first line + * visible on the screen (we only care about what's on the screen). + */ + + dlPtr = dInfoPtr->dLinePtr; + if (dlPtr == NULL) { + return; + } + if ((index1Ptr == NULL) || (TkTextIndexCmp(&dlPtr->index, index1Ptr) > 0)) { + index1Ptr = &dlPtr->index; + } + + /* + * Set the stopping position if it wasn't specified. + */ + + if (index2Ptr == NULL) { + index2Ptr = TkTextMakeIndex(textPtr->tree, + TkBTreeNumLines(textPtr->tree), 0, &endOfText); + } + + /* + * Initialize a search through all transitions on the tag, starting + * with the first transition where the tag's current state is different + * from what it will eventually be. + */ + + TkBTreeStartSearch(index1Ptr, index2Ptr, tagPtr, &search); + /* + * Make our own curIndex because at this point search.curIndex + * may not equal index1Ptr->curIndex in the case the first tag toggle + * comes after index1Ptr (See the use of FindTagStart in TkBTreeStartSearch) + */ + curIndexPtr = index1Ptr; + tagOn = TkBTreeCharTagged(index1Ptr, tagPtr); + if (tagOn != withTag) { + if (!TkBTreeNextTag(&search)) { + return; + } + curIndexPtr = &search.curIndex; + } + + /* + * Schedule a redisplay and layout recalculation if they aren't + * already pending. This has to be done before calling FreeDLines, + * for the reason given in TkTextChanged. + */ + + if (!(dInfoPtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(DisplayText, (ClientData) textPtr); + } + dInfoPtr->flags |= REDRAW_PENDING|DINFO_OUT_OF_DATE|REPICK_NEEDED; + + /* + * Each loop through the loop below is for one range of characters + * where the tag's current state is different than its eventual + * state. At the top of the loop, search contains information about + * the first character in the range. + */ + + while (1) { + /* + * Find the first DLine structure in the range. Note: if the + * desired character isn't the first in its text line, then look + * for the character just before it instead. This is needed to + * handle the case where the first character of a wrapped + * display line just got smaller, so that it now fits on the + * line before: need to relayout the line containing the + * previous character. + */ + + if (curIndexPtr->charIndex == 0) { + dlPtr = FindDLine(dlPtr, curIndexPtr); + } else { + TkTextIndex tmp; + + tmp = *curIndexPtr; + tmp.charIndex -= 1; + dlPtr = FindDLine(dlPtr, &tmp); + } + if (dlPtr == NULL) { + break; + } + + /* + * Find the first DLine structure that's past the end of the range. + */ + + if (!TkBTreeNextTag(&search)) { + endIndexPtr = index2Ptr; + } else { + curIndexPtr = &search.curIndex; + endIndexPtr = curIndexPtr; + } + endPtr = FindDLine(dlPtr, endIndexPtr); + if ((endPtr != NULL) && (endPtr->index.linePtr == endIndexPtr->linePtr) + && (endPtr->index.charIndex < endIndexPtr->charIndex)) { + endPtr = endPtr->nextPtr; + } + + /* + * Delete all of the display lines in the range, so that they'll + * be re-layed out and redrawn. + */ + + FreeDLines(textPtr, dlPtr, endPtr, 1); + dlPtr = endPtr; + + /* + * Find the first text line in the next range. + */ + + if (!TkBTreeNextTag(&search)) { + break; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TkTextRelayoutWindow -- + * + * This procedure is called when something has happened that + * invalidates the whole layout of characters on the screen, such + * as a change in a configuration option for the overall text + * widget or a change in the window size. It causes all display + * information to be recomputed and the window to be redrawn. + * + * Results: + * None. + * + * Side effects: + * All the display information will be recomputed for the window + * and the window will be redrawn. + * + *---------------------------------------------------------------------- + */ + +void +TkTextRelayoutWindow(textPtr) + TkText *textPtr; /* Widget record for text widget. */ +{ + TextDInfo *dInfoPtr = textPtr->dInfoPtr; + GC new; + XGCValues gcValues; + + /* + * Schedule the window redisplay. See TkTextChanged for the + * reason why this has to be done before any calls to FreeDLines. + */ + + if (!(dInfoPtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(DisplayText, (ClientData) textPtr); + } + dInfoPtr->flags |= REDRAW_PENDING|REDRAW_BORDERS|DINFO_OUT_OF_DATE + |REPICK_NEEDED; + + /* + * (Re-)create the graphics context for drawing the traversal + * highlight. + */ + + gcValues.graphics_exposures = False; + new = Tk_GetGC(textPtr->tkwin, GCGraphicsExposures, &gcValues); + if (dInfoPtr->copyGC != None) { + Tk_FreeGC(textPtr->display, dInfoPtr->copyGC); + } + dInfoPtr->copyGC = new; + + /* + * Throw away all the current layout information. + */ + + FreeDLines(textPtr, dInfoPtr->dLinePtr, (DLine *) NULL, 1); + dInfoPtr->dLinePtr = NULL; + + /* + * Recompute some overall things for the layout. Even if the + * window gets very small, pretend that there's at least one + * pixel of drawing space in it. + */ + + if (textPtr->highlightWidth < 0) { + textPtr->highlightWidth = 0; + } + dInfoPtr->x = textPtr->highlightWidth + textPtr->borderWidth + + textPtr->padX; + dInfoPtr->y = textPtr->highlightWidth + textPtr->borderWidth + + textPtr->padY; + dInfoPtr->maxX = Tk_Width(textPtr->tkwin) - textPtr->highlightWidth + - textPtr->borderWidth - textPtr->padX; + if (dInfoPtr->maxX <= dInfoPtr->x) { + dInfoPtr->maxX = dInfoPtr->x + 1; + } + dInfoPtr->maxY = Tk_Height(textPtr->tkwin) - textPtr->highlightWidth + - textPtr->borderWidth - textPtr->padY; + if (dInfoPtr->maxY <= dInfoPtr->y) { + dInfoPtr->maxY = dInfoPtr->y + 1; + } + dInfoPtr->topOfEof = dInfoPtr->maxY; + + /* + * If the upper-left character isn't the first in a line, recompute + * it. This is necessary because a change in the window's size + * or options could change the way lines wrap. + */ + + if (textPtr->topIndex.charIndex != 0) { + MeasureUp(textPtr, &textPtr->topIndex, 0, &textPtr->topIndex); + } + + /* + * Invalidate cached scrollbar positions, so that scrollbars + * sliders will be udpated. + */ + + dInfoPtr->xScrollFirst = dInfoPtr->xScrollLast = -1; + dInfoPtr->yScrollFirst = dInfoPtr->yScrollLast = -1; +} + +/* + *---------------------------------------------------------------------- + * + * TkTextSetYView -- + * + * This procedure is called to specify what lines are to be + * displayed in a text widget. + * + * Results: + * None. + * + * Side effects: + * The display will (eventually) be updated so that the position + * given by "indexPtr" is visible on the screen at the position + * determined by "pickPlace". + * + *---------------------------------------------------------------------- + */ + +void +TkTextSetYView(textPtr, indexPtr, pickPlace) + TkText *textPtr; /* Widget record for text widget. */ + TkTextIndex *indexPtr; /* Position that is to appear somewhere + * in the view. */ + int pickPlace; /* 0 means topLine must appear at top of + * screen. 1 means we get to pick where it + * appears: minimize screen motion or else + * display line at center of screen. */ +{ + TextDInfo *dInfoPtr = textPtr->dInfoPtr; + register DLine *dlPtr; + int bottomY, close, lineIndex; + TkTextIndex tmpIndex, rounded; + Tk_FontMetrics fm; + + /* + * If the specified position is the extra line at the end of the + * text, round it back to the last real line. + */ + + lineIndex = TkBTreeLineIndex(indexPtr->linePtr); + if (lineIndex == TkBTreeNumLines(indexPtr->tree)) { + TkTextIndexBackChars(indexPtr, 1, &rounded); + indexPtr = &rounded; + } + + if (!pickPlace) { + /* + * The specified position must go at the top of the screen. + * Just leave all the DLine's alone: we may be able to reuse + * some of the information that's currently on the screen + * without redisplaying it all. + */ + + if (indexPtr->charIndex == 0) { + textPtr->topIndex = *indexPtr; + } else { + MeasureUp(textPtr, indexPtr, 0, &textPtr->topIndex); + } + goto scheduleUpdate; + } + + /* + * We have to pick where to display the index. First, bring + * the display information up to date and see if the index will be + * completely visible in the current screen configuration. If so + * then there's nothing to do. + */ + + if (dInfoPtr->flags & DINFO_OUT_OF_DATE) { + UpdateDisplayInfo(textPtr); + } + dlPtr = FindDLine(dInfoPtr->dLinePtr, indexPtr); + if (dlPtr != NULL) { + if ((dlPtr->y + dlPtr->height) > dInfoPtr->maxY) { + /* + * Part of the line hangs off the bottom of the screen; + * pretend the whole line is off-screen. + */ + + dlPtr = NULL; + } else if ((dlPtr->index.linePtr == indexPtr->linePtr) + && (dlPtr->index.charIndex <= indexPtr->charIndex)) { + return; + } + } + + /* + * The desired line isn't already on-screen. Figure out what + * it means to be "close" to the top or bottom of the screen. + * Close means within 1/3 of the screen height or within three + * lines, whichever is greater. Add one extra line also, to + * account for the way MeasureUp rounds. + */ + + Tk_GetFontMetrics(textPtr->tkfont, &fm); + bottomY = (dInfoPtr->y + dInfoPtr->maxY + fm.linespace)/2; + close = (dInfoPtr->maxY - dInfoPtr->y)/3; + if (close < 3*fm.linespace) { + close = 3*fm.linespace; + } + close += fm.linespace; + if (dlPtr != NULL) { + /* + * The desired line is above the top of screen. If it is + * "close" to the top of the window then make it the top + * line on the screen. + */ + + MeasureUp(textPtr, &textPtr->topIndex, close, &tmpIndex); + if (TkTextIndexCmp(&tmpIndex, indexPtr) <= 0) { + MeasureUp(textPtr, indexPtr, 0, &textPtr->topIndex); + goto scheduleUpdate; + } + } else { + /* + * The desired line is below the bottom of the screen. If it is + * "close" to the bottom of the screen then position it at the + * bottom of the screen. + */ + + MeasureUp(textPtr, indexPtr, close, &tmpIndex); + if (FindDLine(dInfoPtr->dLinePtr, &tmpIndex) != NULL) { + bottomY = dInfoPtr->maxY - dInfoPtr->y; + } + } + + /* + * Our job now is to arrange the display so that indexPtr appears + * as low on the screen as possible but with its bottom no lower + * than bottomY. BottomY is the bottom of the window if the + * desired line is just below the current screen, otherwise it + * is a half-line lower than the center of the window. + */ + + MeasureUp(textPtr, indexPtr, bottomY, &textPtr->topIndex); + + scheduleUpdate: + if (!(dInfoPtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(DisplayText, (ClientData) textPtr); + } + dInfoPtr->flags |= REDRAW_PENDING|DINFO_OUT_OF_DATE|REPICK_NEEDED; +} + +/* + *-------------------------------------------------------------- + * + * MeasureUp -- + * + * Given one index, find the index of the first character + * on the highest display line that would be displayed no more + * than "distance" pixels above the given index. + * + * Results: + * *dstPtr is filled in with the index of the first character + * on a display line. The display line is found by measuring + * up "distance" pixels above the pixel just below an imaginary + * display line that contains srcPtr. If the display line + * that covers this coordinate actually extends above the + * coordinate, then return the index of the next lower line + * instead (i.e. the returned index will be completely visible + * at or below the given y-coordinate). + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static void +MeasureUp(textPtr, srcPtr, distance, dstPtr) + TkText *textPtr; /* Text widget in which to measure. */ + TkTextIndex *srcPtr; /* Index of character from which to start + * measuring. */ + int distance; /* Vertical distance in pixels measured + * from the pixel just below the lowest + * one in srcPtr's line. */ + 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. */ + 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; + 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 + * 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; + 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)); + + /* + * Scan through the display lines to see if we've covered enough + * vertical distance. If so, save the starting index for the + * line at the desired location. + */ + + for (dlPtr = lowestPtr; dlPtr != NULL; dlPtr = dlPtr->nextPtr) { + distance -= dlPtr->height; + if (distance < 0) { + *dstPtr = (noBestYet) ? dlPtr->index : bestIndex; + break; + } + bestIndex = dlPtr->index; + noBestYet = 0; + } + + /* + * Discard the display lines, then either return or prepare + * for the next display line to lay out. + */ + + FreeDLines(textPtr, lowestPtr, (DLine *) NULL, 0); + if (distance < 0) { + return; + } + charsToCount = INT_MAX; /* Consider all chars. in next line. */ + } + + /* + * Ran off the beginning of the text. Return the first character + * in the text. + */ + + TkTextMakeIndex(textPtr->tree, 0, 0, dstPtr); +} + +/* + *-------------------------------------------------------------- + * + * TkTextSeeCmd -- + * + * This procedure is invoked to process the "see" option for + * the widget command for text widgets. See the user documentation + * for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +int +TkTextSeeCmd(textPtr, interp, argc, argv) + TkText *textPtr; /* Information about text widget. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. Someone else has already + * parsed this command enough to know that + * argv[1] is "see". */ +{ + TextDInfo *dInfoPtr = textPtr->dInfoPtr; + TkTextIndex index; + int x, y, width, height, lineWidth, charCount, oneThird, delta; + DLine *dlPtr; + TkTextDispChunk *chunkPtr; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " see index\"", (char *) NULL); + return TCL_ERROR; + } + if (TkTextGetIndex(interp, textPtr, argv[2], &index) != TCL_OK) { + return TCL_ERROR; + } + + /* + * If the specified position is the extra line at the end of the + * text, round it back to the last real line. + */ + + if (TkBTreeLineIndex(index.linePtr) == TkBTreeNumLines(index.tree)) { + TkTextIndexBackChars(&index, 1, &index); + } + + /* + * First get the desired position into the vertical range of the window. + */ + + TkTextSetYView(textPtr, &index, 1); + + /* + * Now make sure that the character is in view horizontally. + */ + + if (dInfoPtr->flags & DINFO_OUT_OF_DATE) { + UpdateDisplayInfo(textPtr); + } + lineWidth = dInfoPtr->maxX - dInfoPtr->x; + if (dInfoPtr->maxLength < lineWidth) { + return TCL_OK; + } + + /* + * Find the chunk that contains the desired index. + */ + + dlPtr = FindDLine(dInfoPtr->dLinePtr, &index); + charCount = index.charIndex - dlPtr->index.charIndex; + for (chunkPtr = dlPtr->chunkPtr; ; chunkPtr = chunkPtr->nextPtr) { + if (charCount < chunkPtr->numChars) { + break; + } + charCount -= chunkPtr->numChars; + } + + /* + * Call a chunk-specific procedure to find the horizontal range of + * the character within the chunk. + */ + + (*chunkPtr->bboxProc)(chunkPtr, charCount, dlPtr->y + dlPtr->spaceAbove, + dlPtr->height - dlPtr->spaceAbove - dlPtr->spaceBelow, + dlPtr->baseline - dlPtr->spaceAbove, &x, &y, &width, + &height); + delta = x - dInfoPtr->curPixelOffset; + oneThird = lineWidth/3; + if (delta < 0) { + if (delta < -oneThird) { + dInfoPtr->newCharOffset = (x - lineWidth/2)/textPtr->charWidth; + } else { + dInfoPtr->newCharOffset -= ((-delta) + textPtr->charWidth - 1) + / textPtr->charWidth; + } + } else { + delta -= (lineWidth - width); + if (delta > 0) { + if (delta > oneThird) { + dInfoPtr->newCharOffset = (x - lineWidth/2)/textPtr->charWidth; + } else { + dInfoPtr->newCharOffset += (delta + textPtr->charWidth - 1) + / textPtr->charWidth; + } + } else { + return TCL_OK; + } + } + dInfoPtr->flags |= DINFO_OUT_OF_DATE; + if (!(dInfoPtr->flags & REDRAW_PENDING)) { + dInfoPtr->flags |= REDRAW_PENDING; + Tcl_DoWhenIdle(DisplayText, (ClientData) textPtr); + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * TkTextXviewCmd -- + * + * This procedure is invoked to process the "xview" option for + * the widget command for text widgets. See the user documentation + * for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +int +TkTextXviewCmd(textPtr, interp, argc, argv) + TkText *textPtr; /* Information about text widget. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. Someone else has already + * parsed this command enough to know that + * argv[1] is "xview". */ +{ + TextDInfo *dInfoPtr = textPtr->dInfoPtr; + int type, charsPerPage, count, newOffset; + double fraction; + + if (dInfoPtr->flags & DINFO_OUT_OF_DATE) { + UpdateDisplayInfo(textPtr); + } + + if (argc == 2) { + GetXView(interp, textPtr, 0); + return TCL_OK; + } + + newOffset = dInfoPtr->newCharOffset; + type = Tk_GetScrollInfo(interp, argc, argv, &fraction, &count); + switch (type) { + case TK_SCROLL_ERROR: + return TCL_ERROR; + case TK_SCROLL_MOVETO: + if (fraction > 1.0) { + fraction = 1.0; + } + if (fraction < 0) { + fraction = 0; + } + newOffset = (int) (((fraction * dInfoPtr->maxLength) / textPtr->charWidth) + + 0.5); + break; + case TK_SCROLL_PAGES: + charsPerPage = ((dInfoPtr->maxX - dInfoPtr->x) / textPtr->charWidth) + - 2; + if (charsPerPage < 1) { + charsPerPage = 1; + } + newOffset += charsPerPage*count; + break; + case TK_SCROLL_UNITS: + newOffset += count; + break; + } + + dInfoPtr->newCharOffset = newOffset; + dInfoPtr->flags |= DINFO_OUT_OF_DATE; + if (!(dInfoPtr->flags & REDRAW_PENDING)) { + dInfoPtr->flags |= REDRAW_PENDING; + Tcl_DoWhenIdle(DisplayText, (ClientData) textPtr); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ScrollByLines -- + * + * This procedure is called to scroll a text widget up or down + * by a given number of lines. + * + * Results: + * None. + * + * Side effects: + * The view in textPtr's window changes to reflect the value + * of "offset". + * + *---------------------------------------------------------------------- + */ + +static void +ScrollByLines(textPtr, offset) + TkText *textPtr; /* Widget to scroll. */ + int offset; /* Amount by which to scroll, in *screen* + * lines. Positive means that information + * later in text becomes visible, negative + * means that information earlier in the + * text becomes visible. */ +{ + int i, charsToCount, lineNum; + TkTextIndex new, index; + TkTextLine *lastLinePtr; + TextDInfo *dInfoPtr = textPtr->dInfoPtr; + DLine *dlPtr, *lowestPtr; + + if (offset < 0) { + /* + * Must scroll up (to show earlier information in the text). + * The code below is similar to that in MeasureUp, except that + * it counts lines instead of pixels. + */ + + charsToCount = textPtr->topIndex.charIndex + 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; + 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)); + + for (dlPtr = lowestPtr; dlPtr != NULL; dlPtr = dlPtr->nextPtr) { + offset++; + if (offset == 0) { + textPtr->topIndex = dlPtr->index; + break; + } + } + + /* + * Discard the display lines, then either return or prepare + * for the next display line to lay out. + */ + + FreeDLines(textPtr, lowestPtr, (DLine *) NULL, 0); + if (offset >= 0) { + goto scheduleUpdate; + } + charsToCount = INT_MAX; + } + + /* + * Ran off the beginning of the text. Return the first character + * in the text. + */ + + TkTextMakeIndex(textPtr->tree, 0, 0, &textPtr->topIndex); + } else { + /* + * Scrolling down, to show later information in the text. + * Just count lines from the current top of the window. + */ + + lastLinePtr = TkBTreeFindLine(textPtr->tree, + TkBTreeNumLines(textPtr->tree)); + for (i = 0; i < offset; i++) { + dlPtr = LayoutDLine(textPtr, &textPtr->topIndex); + dlPtr->nextPtr = NULL; + TkTextIndexForwChars(&textPtr->topIndex, dlPtr->count, &new); + FreeDLines(textPtr, dlPtr, (DLine *) NULL, 0); + if (new.linePtr == lastLinePtr) { + break; + } + textPtr->topIndex = new; + } + } + + scheduleUpdate: + if (!(dInfoPtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(DisplayText, (ClientData) textPtr); + } + dInfoPtr->flags |= REDRAW_PENDING|DINFO_OUT_OF_DATE|REPICK_NEEDED; +} + +/* + *-------------------------------------------------------------- + * + * TkTextYviewCmd -- + * + * This procedure is invoked to process the "yview" option for + * the widget command for text widgets. See the user documentation + * for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +int +TkTextYviewCmd(textPtr, interp, argc, argv) + TkText *textPtr; /* Information about text widget. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. Someone else has already + * parsed this command enough to know that + * argv[1] is "yview". */ +{ + TextDInfo *dInfoPtr = textPtr->dInfoPtr; + int pickPlace, lineNum, type, charsInLine; + Tk_FontMetrics fm; + int pixels, count; + size_t switchLength; + double fraction; + TkTextIndex index, new; + TkTextLine *lastLinePtr; + DLine *dlPtr; + + if (dInfoPtr->flags & DINFO_OUT_OF_DATE) { + UpdateDisplayInfo(textPtr); + } + + if (argc == 2) { + GetYView(interp, textPtr, 0); + return TCL_OK; + } + + /* + * Next, handle the old syntax: "pathName yview ?-pickplace? where" + */ + + pickPlace = 0; + if (argv[2][0] == '-') { + switchLength = strlen(argv[2]); + if ((switchLength >= 2) + && (strncmp(argv[2], "-pickplace", switchLength) == 0)) { + pickPlace = 1; + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " yview -pickplace lineNum|index\"", + (char *) NULL); + return TCL_ERROR; + } + } + } + if ((argc == 3) || pickPlace) { + if (Tcl_GetInt(interp, argv[2+pickPlace], &lineNum) == TCL_OK) { + TkTextMakeIndex(textPtr->tree, lineNum, 0, &index); + TkTextSetYView(textPtr, &index, 0); + return TCL_OK; + } + + /* + * The argument must be a regular text index. + */ + + Tcl_ResetResult(interp); + if (TkTextGetIndex(interp, textPtr, argv[2+pickPlace], + &index) != TCL_OK) { + return TCL_ERROR; + } + TkTextSetYView(textPtr, &index, pickPlace); + return TCL_OK; + } + + /* + * New syntax: dispatch based on argv[2]. + */ + + type = Tk_GetScrollInfo(interp, argc, argv, &fraction, &count); + switch (type) { + case TK_SCROLL_ERROR: + return TCL_ERROR; + case TK_SCROLL_MOVETO: + if (fraction > 1.0) { + fraction = 1.0; + } + if (fraction < 0) { + fraction = 0; + } + 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); + } + TkTextSetYView(textPtr, &index, 0); + break; + case TK_SCROLL_PAGES: + /* + * Scroll up or down by screenfuls. Actually, use the + * window height minus two lines, so that there's some + * overlap between adjacent pages. + */ + + Tk_GetFontMetrics(textPtr->tkfont, &fm); + if (count < 0) { + pixels = (dInfoPtr->maxY - 2*fm.linespace - dInfoPtr->y)*(-count) + + fm.linespace; + MeasureUp(textPtr, &textPtr->topIndex, pixels, &new); + if (TkTextIndexCmp(&textPtr->topIndex, &new) == 0) { + /* + * A page of scrolling ended up being less than one line. + * Scroll one line anyway. + */ + + count = -1; + goto scrollByLines; + } + textPtr->topIndex = new; + } else { + /* + * Scrolling down by pages. Layout lines starting at the + * top index and count through the desired vertical distance. + */ + + pixels = (dInfoPtr->maxY - 2*fm.linespace - dInfoPtr->y)*count; + lastLinePtr = TkBTreeFindLine(textPtr->tree, + TkBTreeNumLines(textPtr->tree)); + do { + dlPtr = LayoutDLine(textPtr, &textPtr->topIndex); + dlPtr->nextPtr = NULL; + TkTextIndexForwChars(&textPtr->topIndex, dlPtr->count, + &new); + pixels -= dlPtr->height; + FreeDLines(textPtr, dlPtr, (DLine *) NULL, 0); + if (new.linePtr == lastLinePtr) { + break; + } + textPtr->topIndex = new; + } while (pixels > 0); + } + if (!(dInfoPtr->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(DisplayText, (ClientData) textPtr); + } + dInfoPtr->flags |= REDRAW_PENDING|DINFO_OUT_OF_DATE|REPICK_NEEDED; + break; + case TK_SCROLL_UNITS: + scrollByLines: + ScrollByLines(textPtr, count); + break; + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * TkTextScanCmd -- + * + * This procedure is invoked to process the "scan" option for + * the widget command for text widgets. See the user documentation + * for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +int +TkTextScanCmd(textPtr, interp, argc, argv) + register TkText *textPtr; /* Information about text widget. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. Someone else has already + * parsed this command enough to know that + * argv[1] is "scan". */ +{ + TextDInfo *dInfoPtr = textPtr->dInfoPtr; + TkTextIndex index; + int c, x, y, totalScroll, newChar, maxChar; + Tk_FontMetrics fm; + size_t length; + + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " scan mark|dragto x y\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[3], &x) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[4], &y) != TCL_OK) { + return TCL_ERROR; + } + c = argv[2][0]; + length = strlen(argv[2]); + if ((c == 'd') && (strncmp(argv[2], "dragto", length) == 0)) { + /* + * Amplify the difference between the current position and the + * mark position to compute how much the view should shift, then + * update the mark position to correspond to the new view. If we + * run off the edge of the text, reset the mark point so that the + * current position continues to correspond to the edge of the + * window. This means that the picture will start dragging as + * soon as the mouse reverses direction (without this reset, might + * have to slide mouse a long ways back before the picture starts + * moving again). + */ + + newChar = dInfoPtr->scanMarkChar + (10*(dInfoPtr->scanMarkX - x)) + / (textPtr->charWidth); + maxChar = 1 + (dInfoPtr->maxLength - (dInfoPtr->maxX - dInfoPtr->x) + + textPtr->charWidth - 1)/textPtr->charWidth; + if (newChar < 0) { + dInfoPtr->scanMarkChar = newChar = 0; + dInfoPtr->scanMarkX = x; + } else if (newChar > maxChar) { + dInfoPtr->scanMarkChar = newChar = maxChar; + dInfoPtr->scanMarkX = x; + } + dInfoPtr->newCharOffset = newChar; + + Tk_GetFontMetrics(textPtr->tkfont, &fm); + totalScroll = (10*(dInfoPtr->scanMarkY - y)) / fm.linespace; + if (totalScroll != dInfoPtr->scanTotalScroll) { + index = textPtr->topIndex; + ScrollByLines(textPtr, totalScroll-dInfoPtr->scanTotalScroll); + dInfoPtr->scanTotalScroll = totalScroll; + if ((index.linePtr == textPtr->topIndex.linePtr) && + (index.charIndex == textPtr->topIndex.charIndex)) { + dInfoPtr->scanTotalScroll = 0; + dInfoPtr->scanMarkY = y; + } + } + } else if ((c == 'm') && (strncmp(argv[2], "mark", length) == 0)) { + dInfoPtr->scanMarkChar = dInfoPtr->newCharOffset; + dInfoPtr->scanMarkX = x; + dInfoPtr->scanTotalScroll = 0; + dInfoPtr->scanMarkY = y; + } else { + Tcl_AppendResult(interp, "bad scan option \"", argv[2], + "\": must be mark or dragto", (char *) NULL); + return TCL_ERROR; + } + dInfoPtr->flags |= DINFO_OUT_OF_DATE; + if (!(dInfoPtr->flags & REDRAW_PENDING)) { + dInfoPtr->flags |= REDRAW_PENDING; + Tcl_DoWhenIdle(DisplayText, (ClientData) textPtr); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * GetXView -- + * + * This procedure computes the fractions that indicate what's + * visible in a text window and, optionally, evaluates a + * Tcl script to report them to the text's associated scrollbar. + * + * Results: + * If report is zero, then interp->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 + * 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). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +GetXView(interp, textPtr, report) + Tcl_Interp *interp; /* If "report" is FALSE, string + * describing visible range gets + * stored in interp->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]; + double first, last; + int code; + + if (dInfoPtr->maxLength > 0) { + first = ((double) dInfoPtr->curPixelOffset) + / dInfoPtr->maxLength; + last = first + ((double) (dInfoPtr->maxX - dInfoPtr->x)) + / dInfoPtr->maxLength; + if (last > 1.0) { + last = 1.0; + } + } else { + first = 0; + last = 1.0; + } + if (!report) { + sprintf(interp->result, "%g %g", first, last); + return; + } + if ((first == dInfoPtr->xScrollFirst) && (last == dInfoPtr->xScrollLast)) { + return; + } + dInfoPtr->xScrollFirst = first; + dInfoPtr->xScrollLast = last; + sprintf(buffer, " %g %g", first, last); + code = Tcl_VarEval(interp, textPtr->xScrollCmd, + buffer, (char *) NULL); + if (code != TCL_OK) { + Tcl_AddErrorInfo(interp, + "\n (horizontal scrolling command executed by text)"); + Tcl_BackgroundError(interp); + } +} + +/* + *---------------------------------------------------------------------- + * + * GetYView -- + * + * This procedure computes the fractions that indicate what's + * visible in a text window and, optionally, evaluates a + * Tcl script to report them to the text's associated scrollbar. + * + * Results: + * If report is zero, then interp->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, + * 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). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +GetYView(interp, textPtr, report) + Tcl_Interp *interp; /* If "report" is FALSE, string + * describing visible range gets + * stored in interp->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]; + 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 /= totalLines; + while (1) { + if ((dlPtr->y + dlPtr->height) > dInfoPtr->maxY) { + /* + * The last line is only partially visible, so don't + * count its characters in what's visible. + */ + count = 0; + break; + } + if (dlPtr->nextPtr == NULL) { + count = dlPtr->count; + break; + } + dlPtr = dlPtr->nextPtr; + } + last = ((double) TkBTreeLineIndex(dlPtr->index.linePtr)) + + ((double) (dlPtr->index.charIndex + count)) + / (TkBTreeCharsInLine(dlPtr->index.linePtr)); + last /= totalLines; + if (!report) { + sprintf(interp->result, "%g %g", first, last); + return; + } + if ((first == dInfoPtr->yScrollFirst) && (last == dInfoPtr->yScrollLast)) { + return; + } + dInfoPtr->yScrollFirst = first; + dInfoPtr->yScrollLast = last; + sprintf(buffer, " %g %g", first, last); + code = Tcl_VarEval(interp, textPtr->yScrollCmd, + buffer, (char *) NULL); + if (code != TCL_OK) { + Tcl_AddErrorInfo(interp, + "\n (vertical scrolling command executed by text)"); + Tcl_BackgroundError(interp); + } +} + +/* + *---------------------------------------------------------------------- + * + * FindDLine -- + * + * This procedure is called to find the DLine corresponding to a + * given text index. + * + * Results: + * The return value is a pointer to the first DLine found in the + * list headed by dlPtr that displays information at or after the + * specified position. If there is no such line in the list then + * NULL is returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static DLine * +FindDLine(dlPtr, indexPtr) + register DLine *dlPtr; /* Pointer to first in list of DLines + * to search. */ + TkTextIndex *indexPtr; /* Index of desired character. */ +{ + TkTextLine *linePtr; + + if (dlPtr == NULL) { + return NULL; + } + if (TkBTreeLineIndex(indexPtr->linePtr) + < TkBTreeLineIndex(dlPtr->index.linePtr)) { + /* + * The first display line is already past the desired line. + */ + return dlPtr; + } + + /* + * Find the first display line that covers the desired text line. + */ + + linePtr = dlPtr->index.linePtr; + while (linePtr != indexPtr->linePtr) { + while (dlPtr->index.linePtr == linePtr) { + dlPtr = dlPtr->nextPtr; + if (dlPtr == NULL) { + return NULL; + } + } + linePtr = TkBTreeNextLine(linePtr); + if (linePtr == NULL) { + panic("FindDLine reached end of text"); + } + } + if (indexPtr->linePtr != dlPtr->index.linePtr) { + return dlPtr; + } + + /* + * Now get to the right position within the text line. + */ + + while (indexPtr->charIndex >= (dlPtr->index.charIndex + dlPtr->count)) { + dlPtr = dlPtr->nextPtr; + if ((dlPtr == NULL) || (dlPtr->index.linePtr != indexPtr->linePtr)) { + break; + } + } + return dlPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TkTextPixelIndex -- + * + * Given an (x,y) coordinate on the screen, find the location of + * the character closest to that location. + * + * Results: + * The index at *indexPtr is modified to refer to the character + * on the display that is closest to (x,y). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TkTextPixelIndex(textPtr, x, y, indexPtr) + TkText *textPtr; /* Widget record for text widget. */ + int x, y; /* Pixel coordinates of point in widget's + * window. */ + TkTextIndex *indexPtr; /* This index gets filled in with the + * index of the character nearest to (x,y). */ +{ + TextDInfo *dInfoPtr = textPtr->dInfoPtr; + register DLine *dlPtr; + register TkTextDispChunk *chunkPtr; + + /* + * Make sure that all of the layout information about what's + * displayed where on the screen is up-to-date. + */ + + if (dInfoPtr->flags & DINFO_OUT_OF_DATE) { + UpdateDisplayInfo(textPtr); + } + + /* + * If the coordinates are above the top of the window, then adjust + * them to refer to the upper-right corner of the window. If they're + * off to one side or the other, then adjust to the closest side. + */ + + if (y < dInfoPtr->y) { + y = dInfoPtr->y; + x = dInfoPtr->x; + } + if (x >= dInfoPtr->maxX) { + x = dInfoPtr->maxX - 1; + } + if (x < dInfoPtr->x) { + x = dInfoPtr->x; + } + + /* + * Find the display line containing the desired y-coordinate. + */ + + for (dlPtr = dInfoPtr->dLinePtr; y >= (dlPtr->y + dlPtr->height); + dlPtr = dlPtr->nextPtr) { + if (dlPtr->nextPtr == NULL) { + /* + * Y-coordinate is off the bottom of the displayed text. + * Use the last character on the last line. + */ + + x = dInfoPtr->maxX - 1; + break; + } + } + + /* + * Scan through the line's chunks to find the one that contains + * the desired x-coordinate. Before doing this, translate the + * x-coordinate from the coordinate system of the window to the + * coordinate system of the line (to take account of x-scrolling). + */ + + *indexPtr = dlPtr->index; + x = x - dInfoPtr->x + dInfoPtr->curPixelOffset; + for (chunkPtr = dlPtr->chunkPtr; x >= (chunkPtr->x + chunkPtr->width); + indexPtr->charIndex += chunkPtr->numChars, + chunkPtr = chunkPtr->nextPtr) { + if (chunkPtr->nextPtr == NULL) { + indexPtr->charIndex += chunkPtr->numChars - 1; + return; + } + } + + /* + * If the chunk has more than one character in it, ask it which + * character is at the desired location. + */ + + if (chunkPtr->numChars > 1) { + indexPtr->charIndex += (*chunkPtr->measureProc)(chunkPtr, x); + } +} + +/* + *---------------------------------------------------------------------- + * + * TkTextCharBbox -- + * + * Given an index, find the bounding box of the screen area + * occupied by that character. + * + * Results: + * Zero is returned if the character is on the screen. -1 + * means the character isn't on the screen. If the return value + * is 0, then the bounding box of the part of the character that's + * visible on the screen is returned to *xPtr, *yPtr, *widthPtr, + * and *heightPtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TkTextCharBbox(textPtr, indexPtr, xPtr, yPtr, widthPtr, heightPtr) + TkText *textPtr; /* Widget record for text widget. */ + TkTextIndex *indexPtr; /* Index of character whose bounding + * box is desired. */ + int *xPtr, *yPtr; /* Filled with character's upper-left + * coordinate. */ + int *widthPtr, *heightPtr; /* Filled in with character's dimensions. */ +{ + TextDInfo *dInfoPtr = textPtr->dInfoPtr; + DLine *dlPtr; + register TkTextDispChunk *chunkPtr; + int index; + + /* + * Make sure that all of the screen layout information is up to date. + */ + + if (dInfoPtr->flags & DINFO_OUT_OF_DATE) { + UpdateDisplayInfo(textPtr); + } + + /* + * Find the display line containing the desired index. + */ + + dlPtr = FindDLine(dInfoPtr->dLinePtr, indexPtr); + if ((dlPtr == NULL) || (TkTextIndexCmp(&dlPtr->index, indexPtr) > 0)) { + return -1; + } + + /* + * Find the chunk within the line that contains the desired + * index. + */ + + index = indexPtr->charIndex - dlPtr->index.charIndex; + for (chunkPtr = dlPtr->chunkPtr; ; chunkPtr = chunkPtr->nextPtr) { + if (chunkPtr == NULL) { + return -1; + } + if (index < chunkPtr->numChars) { + break; + } + index -= chunkPtr->numChars; + } + + /* + * Call a chunk-specific procedure to find the horizontal range of + * the character within the chunk, then fill in the vertical range. + * The x-coordinate returned by bboxProc is a coordinate within a + * line, not a coordinate on the screen. Translate it to reflect + * horizontal scrolling. + */ + + (*chunkPtr->bboxProc)(chunkPtr, index, 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)) { + /* + * Last character in display line. Give it all the space up to + * the line. + */ + + if (*xPtr > dInfoPtr->maxX) { + *xPtr = dInfoPtr->maxX; + } + *widthPtr = dInfoPtr->maxX - *xPtr; + } + if ((*xPtr + *widthPtr) <= dInfoPtr->x) { + return -1; + } + if ((*xPtr + *widthPtr) > dInfoPtr->maxX) { + *widthPtr = dInfoPtr->maxX - *xPtr; + if (*widthPtr <= 0) { + return -1; + } + } + if ((*yPtr + *heightPtr) > dInfoPtr->maxY) { + *heightPtr = dInfoPtr->maxY - *yPtr; + if (*heightPtr <= 0) { + return -1; + } + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * TkTextDLineInfo -- + * + * Given an index, return information about the display line + * containing that character. + * + * Results: + * Zero is returned if the character is on the screen. -1 + * means the character isn't on the screen. If the return value + * is 0, then information is returned in the variables pointed + * to by xPtr, yPtr, widthPtr, heightPtr, and basePtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TkTextDLineInfo(textPtr, indexPtr, xPtr, yPtr, widthPtr, heightPtr, basePtr) + TkText *textPtr; /* Widget record for text widget. */ + TkTextIndex *indexPtr; /* Index of character whose bounding + * box is desired. */ + int *xPtr, *yPtr; /* Filled with line's upper-left + * coordinate. */ + int *widthPtr, *heightPtr; /* Filled in with line's dimensions. */ + int *basePtr; /* Filled in with the baseline position, + * measured as an offset down from *yPtr. */ +{ + TextDInfo *dInfoPtr = textPtr->dInfoPtr; + DLine *dlPtr; + + /* + * Make sure that all of the screen layout information is up to date. + */ + + if (dInfoPtr->flags & DINFO_OUT_OF_DATE) { + UpdateDisplayInfo(textPtr); + } + + /* + * Find the display line containing the desired index. + */ + + dlPtr = FindDLine(dInfoPtr->dLinePtr, indexPtr); + if ((dlPtr == NULL) || (TkTextIndexCmp(&dlPtr->index, indexPtr) > 0)) { + return -1; + } + + *xPtr = dInfoPtr->x - dInfoPtr->curPixelOffset + dlPtr->chunkPtr->x; + *widthPtr = dlPtr->length - dlPtr->chunkPtr->x; + *yPtr = dlPtr->y; + if ((dlPtr->y + dlPtr->height) > dInfoPtr->maxY) { + *heightPtr = dInfoPtr->maxY - dlPtr->y; + } else { + *heightPtr = dlPtr->height; + } + *basePtr = dlPtr->baseline; + return 0; +} + +/* + *-------------------------------------------------------------- + * + * TkTextCharLayoutProc -- + * + * This procedure is the "layoutProc" for character segments. + * + * 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 + * in tkText.h for details). If zero is returned it means + * that no characters from this chunk fit in the window. + * If -1 is returned it means that this segment just doesn't + * need to be displayed (never happens for text). + * + * Side effects: + * Memory is allocated to hold additional information about + * the chunk. + * + *-------------------------------------------------------------- + */ + +int +TkTextCharLayoutProc(textPtr, indexPtr, segPtr, offset, maxX, maxChars, + 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 maxX; /* Chunk must not occupy pixels at this + * position or higher. */ + int maxChars; /* Chunk must not include more than this + * many characters. */ + int noCharsYet; /* Non-zero means no characters have been + * assigned to this display line yet. */ + Tk_Uid wrapMode; /* How to handle line wrapping: tkTextCharUid, + * tkTextNoneUid, or tkTextWordUid. */ + register TkTextDispChunk *chunkPtr; + /* Structure to fill in with information + * about this chunk. The x field has already + * been set by the caller. */ +{ + Tk_Font tkfont; + int nextX, charsThatFit, count; + CharInfo *ciPtr; + char *p; + TkTextSegment *nextPtr; + Tk_FontMetrics fm; + + /* + * Figure out how many characters will fit in the space we've got. + * Include the next character, even though it won't fit completely, + * if any of the following is true: + * (a) the chunk contains no characters and the display line contains + * no characters yet (i.e. the line isn't wide enough to hold + * even a single character). + * (b) at least one pixel of the character is visible, we haven't + * already exceeded the character limit, and the next character + * is a white space character. + */ + + p = segPtr->body.chars + offset; + tkfont = chunkPtr->stylePtr->sValuePtr->tkfont; + charsThatFit = MeasureChars(tkfont, p, maxChars, 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 ((nextX < maxX) && ((p[charsThatFit] == ' ') + || (p[charsThatFit] == '\t'))) { + /* + * Space characters are funny, in that they are considered + * to fit if there is at least one pixel of space left on the + * line. Just give the space character whatever space is left. + */ + + nextX = maxX; + charsThatFit++; + } + if (p[charsThatFit] == '\n') { + /* + * A newline character takes up no space, so if the previous + * character fits then so does the newline. + */ + + charsThatFit++; + } + if (charsThatFit == 0) { + return 0; + } + } + + Tk_GetFontMetrics(tkfont, &fm); + + /* + * Fill in the chunk structure and allocate and initialize a + * CharInfo structure. If the last character is a newline + * then don't bother to display it. + */ + + chunkPtr->displayProc = CharDisplayProc; + chunkPtr->undisplayProc = CharUndisplayProc; + chunkPtr->measureProc = CharMeasureProc; + chunkPtr->bboxProc = CharBboxProc; + chunkPtr->numChars = charsThatFit; + 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)); + chunkPtr->clientData = (ClientData) ciPtr; + ciPtr->numChars = charsThatFit; + strncpy(ciPtr->chars, p, (size_t) charsThatFit); + if (p[charsThatFit-1] == '\n') { + ciPtr->numChars--; + } + + /* + * Compute a break location. If we're in word wrap mode, a + * break can occur after any space character, or at the end of + * the chunk if the next segment (ignoring those with zero size) + * is not a character segment. + */ + + if (wrapMode != tkTextWordUid) { + chunkPtr->breakIndex = chunkPtr->numChars; + } else { + for (count = charsThatFit, p += charsThatFit-1; count > 0; + count--, p--) { + if (isspace(UCHAR(*p))) { + chunkPtr->breakIndex = count; + break; + } + } + if ((charsThatFit+offset) == segPtr->size) { + for (nextPtr = segPtr->nextPtr; nextPtr != NULL; + nextPtr = nextPtr->nextPtr) { + if (nextPtr->size != 0) { + if (nextPtr->typePtr != &tkTextCharType) { + chunkPtr->breakIndex = chunkPtr->numChars; + } + break; + } + } + } + } + return 1; +} + +/* + *-------------------------------------------------------------- + * + * CharDisplayProc -- + * + * This procedure is called to display a character chunk on + * the screen or in an off-screen pixmap. + * + * Results: + * None. + * + * Side effects: + * Graphics are drawn. + * + *-------------------------------------------------------------- + */ + +static void +CharDisplayProc(chunkPtr, x, y, height, baseline, display, dst, screenY) + TkTextDispChunk *chunkPtr; /* Chunk that is to be drawn. */ + int x; /* X-position in dst at which to + * draw this chunk (may differ from + * the x-position in the chunk because + * of scrolling). */ + int y; /* Y-position at which to draw this + * chunk in dst. */ + int height; /* Total height of line. */ + int baseline; /* Offset of baseline from y. */ + Display *display; /* Display to use for drawing. */ + Drawable dst; /* Pixmap or window in which to draw + * chunk. */ + int screenY; /* Y-coordinate in text window that + * corresponds to y. */ +{ + CharInfo *ciPtr = (CharInfo *) chunkPtr->clientData; + TextStyle *stylePtr; + StyleValues *sValuePtr; + int offsetChars, offsetX; + + if ((x + chunkPtr->width) <= 0) { + /* + * The chunk is off-screen. + */ + + return; + } + + stylePtr = chunkPtr->stylePtr; + sValuePtr = stylePtr->sValuePtr; + + /* + * If the text sticks out way to the left of the window, skip + * over the characters that aren't in the visible part of the + * window. This is essential if x is very negative (such as + * less than 32K); otherwise overflow problems will occur + * in servers that use 16-bit arithmetic, like X. + */ + + offsetX = x; + offsetChars = 0; + if (x < 0) { + offsetChars = MeasureChars(sValuePtr->tkfont, ciPtr->chars, + ciPtr->numChars, 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 ((numChars > 0) && (string[numChars - 1] == '\t')) { + numChars--; + } + Tk_DrawChars(display, dst, stylePtr->fgGC, sValuePtr->tkfont, string, + numChars, 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); + + } + if (sValuePtr->overstrike) { + Tk_FontMetrics fm; + + Tk_GetFontMetrics(sValuePtr->tkfont, &fm); + Tk_UnderlineChars(display, dst, stylePtr->fgGC, sValuePtr->tkfont, + ciPtr->chars + offsetChars, offsetX, + y + baseline - sValuePtr->offset + - fm.descent - (fm.ascent * 3) / 10, + 0, numChars); + } + } +} + +/* + *-------------------------------------------------------------- + * + * CharUndisplayProc -- + * + * This procedure is called when a character chunk is no + * longer going to be displayed. It frees up resources + * that were allocated to display the chunk. + * + * Results: + * None. + * + * Side effects: + * Memory and other resources get freed. + * + *-------------------------------------------------------------- + */ + +static void +CharUndisplayProc(textPtr, chunkPtr) + TkText *textPtr; /* Overall information about text + * widget. */ + TkTextDispChunk *chunkPtr; /* Chunk that is about to be freed. */ +{ + CharInfo *ciPtr = (CharInfo *) chunkPtr->clientData; + + ckfree((char *) ciPtr); +} + +/* + *-------------------------------------------------------------- + * + * CharMeasureProc -- + * + * This procedure is called to determine which character in + * a character chunk lies over a given x-coordinate. + * + * Results: + * The return value is the index *within the chunk* of the + * character that covers the position given by "x". + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static int +CharMeasureProc(chunkPtr, x) + TkTextDispChunk *chunkPtr; /* Chunk containing desired coord. */ + int x; /* X-coordinate, in same coordinate + * system as chunkPtr->x. */ +{ + CharInfo *ciPtr = (CharInfo *) chunkPtr->clientData; + int endX; + + return MeasureChars(chunkPtr->stylePtr->sValuePtr->tkfont, ciPtr->chars, + chunkPtr->numChars-1, chunkPtr->x, x, 0, &endX); +} + +/* + *-------------------------------------------------------------- + * + * CharBboxProc -- + * + * This procedure is called to compute the bounding box of + * the area occupied by a single character. + * + * Results: + * There is no return value. *xPtr and *yPtr are filled in + * with the coordinates of the upper left corner of the + * character, and *widthPtr and *heightPtr are filled in with + * the dimensions of the character in pixels. Note: not all + * of the returned bbox is necessarily visible on the screen + * (the rightmost part might be off-screen to the right, + * and the bottommost part might be off-screen to the bottom). + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static void +CharBboxProc(chunkPtr, index, y, lineHeight, baseline, xPtr, yPtr, + widthPtr, heightPtr) + TkTextDispChunk *chunkPtr; /* Chunk containing desired char. */ + int index; /* Index of desired character within + * the chunk. */ + int y; /* Topmost pixel in area allocated + * for this line. */ + int lineHeight; /* Height of line, in pixels. */ + int baseline; /* Location of line's baseline, in + * pixels measured down from y. */ + int *xPtr, *yPtr; /* Gets filled in with coords of + * character's upper-left pixel. + * X-coord is in same coordinate + * system as chunkPtr->x. */ + int *widthPtr; /* Gets filled in with width of + * character, in pixels. */ + int *heightPtr; /* Gets filled in with height of + * character, in pixels. */ +{ + CharInfo *ciPtr = (CharInfo *) chunkPtr->clientData; + int maxX; + + maxX = chunkPtr->width + chunkPtr->x; + MeasureChars(chunkPtr->stylePtr->sValuePtr->tkfont, ciPtr->chars, index, + chunkPtr->x, 1000000, 0, xPtr); + + if (index == ciPtr->numChars) { + /* + * This situation only happens if the last character in a line + * is a space character, in which case it absorbs all of the + * extra space in the line (see TkTextCharLayoutProc). + */ + + *widthPtr = maxX - *xPtr; + } else if ((ciPtr->chars[index] == '\t') + && (index == (ciPtr->numChars-1))) { + /* + * The desired character is a tab character that terminates a + * chunk; give it all the space left in the chunk. + */ + + *widthPtr = maxX - *xPtr; + } else { + MeasureChars(chunkPtr->stylePtr->sValuePtr->tkfont, + ciPtr->chars + index, 1, *xPtr, 1000000, 0, widthPtr); + if (*widthPtr > maxX) { + *widthPtr = maxX - *xPtr; + } else { + *widthPtr -= *xPtr; + } + } + *yPtr = y + baseline - chunkPtr->minAscent; + *heightPtr = chunkPtr->minAscent + chunkPtr->minDescent; +} + +/* + *---------------------------------------------------------------------- + * + * AdjustForTab -- + * + * This procedure is called to move a series of chunks right + * in order to align them with a tab stop. + * + * Results: + * None. + * + * Side effects: + * The width of chunkPtr gets adjusted so that it absorbs the + * extra space due to the tab. The x locations in all the chunks + * after chunkPtr are adjusted rightward to align with the tab + * stop given by tabArrayPtr and index. + * + *---------------------------------------------------------------------- + */ + +static void +AdjustForTab(textPtr, tabArrayPtr, index, chunkPtr) + TkText *textPtr; /* Information about the text widget as + * a whole. */ + TkTextTabArray *tabArrayPtr; /* Information about the tab stops + * that apply to this line. May be + * NULL to indicate default tabbing + * (every 8 chars). */ + int index; /* Index of current tab stop. */ + TkTextDispChunk *chunkPtr; /* Chunk whose last character is + * the tab; the following chunks + * contain information to be shifted + * right. */ + +{ + int x, desired, delta, width, decimal, i, gotDigit; + TkTextDispChunk *chunkPtr2, *decimalChunkPtr; + CharInfo *ciPtr; + int tabX, prev, spaceWidth; + char *p; + TkTextTabAlign alignment; + + if (chunkPtr->nextPtr == NULL) { + /* + * Nothing after the actual tab; just return. + */ + + return; + } + + /* + * If no tab information has been given, do the usual thing: + * round up to the next boundary of 8 average-sized characters. + */ + + x = chunkPtr->nextPtr->x; + if ((tabArrayPtr == NULL) || (tabArrayPtr->numTabs == 0)) { + /* + * No tab information has been given, so use the default + * interpretation of tabs. + */ + + desired = NextTabStop(textPtr->tkfont, x, 0); + goto update; + } + + if (index < tabArrayPtr->numTabs) { + alignment = tabArrayPtr->tabs[index].alignment; + tabX = tabArrayPtr->tabs[index].location; + } else { + /* + * Ran out of tab stops; compute a tab position by extrapolating + * from the last two tab positions. + */ + + if (tabArrayPtr->numTabs > 1) { + prev = tabArrayPtr->tabs[tabArrayPtr->numTabs-2].location; + } else { + prev = 0; + } + alignment = tabArrayPtr->tabs[tabArrayPtr->numTabs-1].alignment; + tabX = tabArrayPtr->tabs[tabArrayPtr->numTabs-1].location + + (index + 1 - tabArrayPtr->numTabs) + * (tabArrayPtr->tabs[tabArrayPtr->numTabs-1].location - prev); + } + + if (alignment == LEFT) { + desired = tabX; + goto update; + } + + if ((alignment == CENTER) || (alignment == RIGHT)) { + /* + * Compute the width of all the information in the tab group, + * then use it to pick a desired location. + */ + + width = 0; + for (chunkPtr2 = chunkPtr->nextPtr; chunkPtr2 != NULL; + chunkPtr2 = chunkPtr2->nextPtr) { + width += chunkPtr2->width; + } + if (alignment == CENTER) { + desired = tabX - width/2; + } else { + desired = tabX - width; + } + goto update; + } + + /* + * Must be numeric alignment. Search through the text to be + * tabbed, looking for the last , or . before the first character + * that isn't a number, comma, period, or sign. + */ + + decimalChunkPtr = NULL; + decimal = gotDigit = 0; + for (chunkPtr2 = chunkPtr->nextPtr; chunkPtr2 != NULL; + chunkPtr2 = chunkPtr2->nextPtr) { + if (chunkPtr2->displayProc != CharDisplayProc) { + continue; + } + ciPtr = (CharInfo *) chunkPtr2->clientData; + for (p = ciPtr->chars, i = 0; i < ciPtr->numChars; p++, i++) { + if (isdigit(UCHAR(*p))) { + gotDigit = 1; + } else if ((*p == '.') || (*p == ',')) { + decimal = p-ciPtr->chars; + decimalChunkPtr = chunkPtr2; + } else if (gotDigit) { + if (decimalChunkPtr == NULL) { + decimal = p-ciPtr->chars; + decimalChunkPtr = chunkPtr2; + } + goto endOfNumber; + } + } + } + endOfNumber: + if (decimalChunkPtr != NULL) { + int curX; + + ciPtr = (CharInfo *) decimalChunkPtr->clientData; + MeasureChars(decimalChunkPtr->stylePtr->sValuePtr->tkfont, + ciPtr->chars, decimal, decimalChunkPtr->x, 1000000, 0, &curX); + desired = tabX - (curX - x); + goto update; + } else { + /* + * There wasn't a decimal point. Right justify the text. + */ + + width = 0; + for (chunkPtr2 = chunkPtr->nextPtr; chunkPtr2 != NULL; + chunkPtr2 = chunkPtr2->nextPtr) { + width += chunkPtr2->width; + } + desired = tabX - width; + } + + /* + * Shift all of the chunks to the right so that the left edge is + * at the desired location, then expand the chunk containing the + * tab. Be sure that the tab occupies at least the width of a + * space character. + */ + + update: + delta = desired - x; + MeasureChars(textPtr->tkfont, " ", 1, 0, INT_MAX, 0, &spaceWidth); + if (delta < spaceWidth) { + delta = spaceWidth; + } + for (chunkPtr2 = chunkPtr->nextPtr; chunkPtr2 != NULL; + chunkPtr2 = chunkPtr2->nextPtr) { + chunkPtr2->x += delta; + } + chunkPtr->width += delta; +} + +/* + *---------------------------------------------------------------------- + * + * SizeOfTab -- + * + * This returns an estimate of the amount of white space that will + * be consumed by a tab. + * + * Results: + * The return value is the minimum number of pixels that will + * be occupied by the index'th tab of tabArrayPtr, assuming that + * the current position on the line is x and the end of the + * line is maxX. For numeric tabs, this is a conservative + * estimate. The return value is always >= 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +SizeOfTab(textPtr, tabArrayPtr, index, x, maxX) + TkText *textPtr; /* Information about the text widget as + * a whole. */ + TkTextTabArray *tabArrayPtr; /* Information about the tab stops + * that apply to this line. NULL + * means use default tabbing (every + * 8 chars.) */ + int index; /* Index of current tab stop. */ + int x; /* Current x-location in line. Only + * used if tabArrayPtr == NULL. */ + int maxX; /* X-location of pixel just past the + * right edge of the line. */ +{ + int tabX, prev, result, spaceWidth; + TkTextTabAlign alignment; + + if ((tabArrayPtr == NULL) || (tabArrayPtr->numTabs == 0)) { + tabX = NextTabStop(textPtr->tkfont, x, 0); + return tabX - x; + } + if (index < tabArrayPtr->numTabs) { + tabX = tabArrayPtr->tabs[index].location; + alignment = tabArrayPtr->tabs[index].alignment; + } else { + /* + * Ran out of tab stops; compute a tab position by extrapolating + * from the last two tab positions. + */ + + if (tabArrayPtr->numTabs > 1) { + prev = tabArrayPtr->tabs[tabArrayPtr->numTabs-2].location; + } else { + prev = 0; + } + tabX = tabArrayPtr->tabs[tabArrayPtr->numTabs-1].location + + (index + 1 - tabArrayPtr->numTabs) + * (tabArrayPtr->tabs[tabArrayPtr->numTabs-1].location - prev); + alignment = tabArrayPtr->tabs[tabArrayPtr->numTabs-1].alignment; + } + if (alignment == CENTER) { + /* + * Be very careful in the arithmetic below, because maxX may + * be the largest positive number: watch out for integer + * overflow. + */ + + if ((maxX-tabX) < (tabX - x)) { + result = (maxX - x) - 2*(maxX - tabX); + } else { + result = 0; + } + goto done; + } + if (alignment == RIGHT) { + result = 0; + goto done; + } + + /* + * Note: this treats NUMERIC alignment the same as LEFT + * alignment, which is somewhat conservative. However, it's + * pretty tricky at this point to figure out exactly where + * the damn decimal point will be. + */ + + if (tabX > x) { + result = tabX - x; + } else { + result = 0; + } + + done: + MeasureChars(textPtr->tkfont, " ", 1, 0, INT_MAX, 0, &spaceWidth); + if (result < spaceWidth) { + result = spaceWidth; + } + return result; +} + +/* + *--------------------------------------------------------------------------- + * + * NextTabStop -- + * + * Given the current position, determine where the next default + * tab stop would be located. This procedure is called when the + * current chunk in the text has no tabs defined and so the default + * tab spacing for the font should be used. + * + * Results: + * The location in pixels of the next tab stop. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +static int +NextTabStop(tkfont, x, tabOrigin) + Tk_Font tkfont; /* Font in which chunk that contains tab + * stop will be drawn. */ + int x; /* X-position in pixels where last + * character was drawn. The next tab stop + * occurs somewhere after this location. */ + int tabOrigin; /* The origin for tab stops. May be + * non-zero if text has been scrolled. */ +{ + int tabWidth, rem; + + tabWidth = Tk_TextWidth(tkfont, "0", 1) * 8; + if (tabWidth == 0) { + tabWidth = 1; + } + + x += tabWidth; + rem = (x - tabOrigin) % tabWidth; + if (rem < 0) { + rem += tabWidth; + } + x -= rem; + return x; +} + +/* + *--------------------------------------------------------------------------- + * + * MeasureChars -- + * + * Determine the number of characters from the string that will fit + * in the given horizontal span. The measurement is done under the + * assumption that Tk_DisplayChars will be used to actually display + * the characters. + * + * If tabs are encountered in the string, they will be expanded + * to the next tab stop, unless the TK_IGNORE_TABS flag is specified. + * + * If a newline is encountered in the string, the line will be + * broken at that point, unless the TK_NEWSLINES_NOT_SPECIAL flag + * is specified. + * + * Results: + * The return value is the number of characters 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 + * be drawn. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static int +MeasureChars(tkfont, source, maxChars, 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 + * source. */ + int startX; /* X-position at which first character will + * be drawn. */ + int maxX; /* Don't consider any character that would + * cross this x-position. */ + int tabOrigin; /* X-location that serves as "origin" for + * tab stops. */ + int *nextXPtr; /* Return x-position of terminating + * character here. */ +{ + int curX, width, ch; + CONST char *special, *end, *start; + + ch = 0; /* lint. */ + curX = startX; + special = source; + end = source + maxChars; + for (start = source; start < end; ) { + if (start >= special) { + /* + * Find the next special character in the string. + */ + + for (special = start; special < end; special++) { + ch = *special; + if ((ch == '\t') || (ch == '\n')) { + break; + } + } + } + + /* + * Special points at the next special character (or the end of the + * string). Process characters between start and special. + */ + + if (curX >= maxX) { + break; + } + start += Tk_MeasureChars(tkfont, start, special - start, maxX - curX, + 0, &width); + curX += width; + if (start < special) { + /* + * No more chars fit in line. + */ + + break; + } + if (special < end) { + if (ch == '\t') { + start++; + } else { + break; + } + } + } + + *nextXPtr = curX; + return start - source; +} diff --git a/generic/tkTextImage.c b/generic/tkTextImage.c new file mode 100644 index 0000000..b5e363f --- /dev/null +++ b/generic/tkTextImage.c @@ -0,0 +1,898 @@ +/* + * tkImage.c -- + * + * This file contains code that allows images to be + * nested inside text widgets. It also implements the "image" + * widget command for texts. + * + * 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: @(#) tkTextImage.c 1.7 97/08/25 15:47:27 + */ + +#include "tk.h" +#include "tkText.h" +#include "tkPort.h" + +/* + * Definitions for alignment values: + */ + +#define ALIGN_BOTTOM 0 +#define ALIGN_CENTER 1 +#define ALIGN_TOP 2 +#define ALIGN_BASELINE 3 + +/* + * Macro that determines the size of an embedded image segment: + */ + +#define EI_SEG_SIZE ((unsigned) (Tk_Offset(TkTextSegment, body) \ + + sizeof(TkTextEmbImage))) + +/* + * Prototypes for procedures defined in this file: + */ + +static int AlignParseProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, Tk_Window tkwin, char *value, + char *widgRec, int offset)); +static char * AlignPrintProc _ANSI_ARGS_((ClientData clientData, + Tk_Window tkwin, char *widgRec, int offset, + Tcl_FreeProc **freeProcPtr)); +static TkTextSegment * EmbImageCleanupProc _ANSI_ARGS_((TkTextSegment *segPtr, + TkTextLine *linePtr)); +static void EmbImageCheckProc _ANSI_ARGS_((TkTextSegment *segPtr, + TkTextLine *linePtr)); +static void EmbImageBboxProc _ANSI_ARGS_((TkTextDispChunk *chunkPtr, + int index, int y, int lineHeight, int baseline, + int *xPtr, int *yPtr, int *widthPtr, + int *heightPtr)); +static int EmbImageConfigure _ANSI_ARGS_((TkText *textPtr, + TkTextSegment *eiPtr, int argc, char **argv)); +static int EmbImageDeleteProc _ANSI_ARGS_((TkTextSegment *segPtr, + TkTextLine *linePtr, int treeGone)); +static void EmbImageDisplayProc _ANSI_ARGS_(( + TkTextDispChunk *chunkPtr, int x, int y, + int lineHeight, int baseline, Display *display, + Drawable dst, int screenY)); +static int EmbImageLayoutProc _ANSI_ARGS_((TkText *textPtr, + TkTextIndex *indexPtr, TkTextSegment *segPtr, + int offset, int maxX, int maxChars, + int noCharsYet, Tk_Uid wrapMode, + TkTextDispChunk *chunkPtr)); +static void EmbImageProc _ANSI_ARGS_((ClientData clientData, + int x, int y, int width, int height, + int imageWidth, int imageHeight)); + +/* + * The following structure declares the "embedded image" segment type. + */ + +static Tk_SegType tkTextEmbImageType = { + "image", /* name */ + 0, /* leftGravity */ + (Tk_SegSplitProc *) NULL, /* splitProc */ + EmbImageDeleteProc, /* deleteProc */ + EmbImageCleanupProc, /* cleanupProc */ + (Tk_SegLineChangeProc *) NULL, /* lineChangeProc */ + EmbImageLayoutProc, /* layoutProc */ + EmbImageCheckProc /* checkProc */ +}; + +/* + * Information used for parsing image configuration options: + */ + +static Tk_CustomOption alignOption = {AlignParseProc, AlignPrintProc, + (ClientData) NULL}; + +static Tk_ConfigSpec configSpecs[] = { + {TK_CONFIG_CUSTOM, "-align", (char *) NULL, (char *) NULL, + "center", 0, TK_CONFIG_DONT_SET_DEFAULT, &alignOption}, + {TK_CONFIG_PIXELS, "-padx", (char *) NULL, (char *) NULL, + "0", Tk_Offset(TkTextEmbImage, padX), + TK_CONFIG_DONT_SET_DEFAULT}, + {TK_CONFIG_PIXELS, "-pady", (char *) NULL, (char *) NULL, + "0", Tk_Offset(TkTextEmbImage, padY), + TK_CONFIG_DONT_SET_DEFAULT}, + {TK_CONFIG_STRING, "-image", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(TkTextEmbImage, imageString), + TK_CONFIG_DONT_SET_DEFAULT|TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-name", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(TkTextEmbImage, imageName), + TK_CONFIG_DONT_SET_DEFAULT|TK_CONFIG_NULL_OK}, + {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, 0} +}; + +/* + *-------------------------------------------------------------- + * + * TkTextImageCmd -- + * + * This procedure implements the "image" widget command + * for text widgets. See the user documentation for details + * on what it does. + * + * Results: + * A standard Tcl result or error. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +int +TkTextImageCmd(textPtr, interp, argc, argv) + register TkText *textPtr; /* Information about text widget. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. Someone else has already + * parsed this command enough to know that + * argv[1] is "image". */ +{ + size_t length; + register TkTextSegment *eiPtr; + + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " image option ?arg arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + length = strlen(argv[2]); + if ((strncmp(argv[2], "cget", length) == 0) && (length >= 2)) { + TkTextIndex index; + TkTextSegment *eiPtr; + + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " image cget index option\"", + (char *) NULL); + return TCL_ERROR; + } + if (TkTextGetIndex(interp, textPtr, argv[3], &index) != TCL_OK) { + return TCL_ERROR; + } + eiPtr = TkTextIndexToSeg(&index, (int *) NULL); + if (eiPtr->typePtr != &tkTextEmbImageType) { + Tcl_AppendResult(interp, "no embedded image at index \"", + argv[3], "\"", (char *) NULL); + return TCL_ERROR; + } + return Tk_ConfigureValue(interp, textPtr->tkwin, configSpecs, + (char *) &eiPtr->body.ei, argv[4], 0); + } else if ((strncmp(argv[2], "configure", length) == 0) && (length >= 2)) { + TkTextIndex index; + TkTextSegment *eiPtr; + + if (argc < 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " image configure index ?option value ...?\"", + (char *) NULL); + return TCL_ERROR; + } + if (TkTextGetIndex(interp, textPtr, argv[3], &index) != TCL_OK) { + return TCL_ERROR; + } + eiPtr = TkTextIndexToSeg(&index, (int *) NULL); + if (eiPtr->typePtr != &tkTextEmbImageType) { + Tcl_AppendResult(interp, "no embedded image at index \"", + argv[3], "\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 4) { + return Tk_ConfigureInfo(interp, textPtr->tkwin, configSpecs, + (char *) &eiPtr->body.ei, (char *) NULL, 0); + } else if (argc == 5) { + return Tk_ConfigureInfo(interp, textPtr->tkwin, configSpecs, + (char *) &eiPtr->body.ei, argv[4], 0); + } else { + TkTextChanged(textPtr, &index, &index); + return EmbImageConfigure(textPtr, eiPtr, argc-4, argv+4); + } + } else if ((strncmp(argv[2], "create", length) == 0) && (length >= 2)) { + TkTextIndex index; + int lineIndex; + + /* + * Add a new image. Find where to put the new image, and + * mark that position for redisplay. + */ + + if (argc < 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " image create index ?option value ...?\"", + (char *) NULL); + return TCL_ERROR; + } + if (TkTextGetIndex(interp, textPtr, argv[3], &index) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Don't allow insertions on the last (dummy) line of the text. + */ + + lineIndex = TkBTreeLineIndex(index.linePtr); + if (lineIndex == TkBTreeNumLines(textPtr->tree)) { + lineIndex--; + TkTextMakeIndex(textPtr->tree, lineIndex, 1000000, &index); + } + + /* + * Create the new image segment and initialize it. + */ + + eiPtr = (TkTextSegment *) ckalloc(EI_SEG_SIZE); + eiPtr->typePtr = &tkTextEmbImageType; + eiPtr->size = 1; + eiPtr->body.ei.textPtr = textPtr; + eiPtr->body.ei.linePtr = NULL; + eiPtr->body.ei.imageName = NULL; + eiPtr->body.ei.imageString = NULL; + eiPtr->body.ei.name = NULL; + eiPtr->body.ei.image = NULL; + eiPtr->body.ei.align = ALIGN_CENTER; + eiPtr->body.ei.padX = eiPtr->body.ei.padY = 0; + eiPtr->body.ei.chunkCount = 0; + + /* + * Link the segment into the text widget, then configure it (delete + * it again if the configuration fails). + */ + + TkTextChanged(textPtr, &index, &index); + TkBTreeLinkSegment(eiPtr, &index); + if (EmbImageConfigure(textPtr, eiPtr, argc-4, argv+4) != TCL_OK) { + TkTextIndex index2; + + TkTextIndexForwChars(&index, 1, &index2); + TkBTreeDeleteChars(&index, &index2); + return TCL_ERROR; + } + } else if (strncmp(argv[2], "names", length) == 0) { + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " image names\"", (char *) NULL); + return TCL_ERROR; + } + for (hPtr = Tcl_FirstHashEntry(&textPtr->imageTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + Tcl_AppendElement(interp, + Tcl_GetHashKey(&textPtr->markTable, hPtr)); + } + } else { + Tcl_AppendResult(interp, "bad image option \"", argv[2], + "\": must be cget, configure, create, or names", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * EmbImageConfigure -- + * + * This procedure is called to handle configuration options + * for an embedded image, using an argc/argv list. + * + * Results: + * The return value is a standard Tcl result. If TCL_ERROR is + * returned, then interp->result contains an error message.. + * + * Side effects: + * Configuration information for the embedded image changes, + * such as alignment, or name of the image. + * + *-------------------------------------------------------------- + */ + +static int +EmbImageConfigure(textPtr, eiPtr, argc, argv) + TkText *textPtr; /* Information about text widget that + * contains embedded image. */ + TkTextSegment *eiPtr; /* Embedded image to be configured. */ + int argc; /* Number of strings in argv. */ + char **argv; /* Array of strings describing configuration + * options. */ +{ + Tk_Image image; + Tcl_DString newName; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + int new; + char *name; + int count = 0; /* The counter for picking a unique name */ + int conflict = 0; /* True if we have a name conflict */ + unsigned int len; /* length of image name */ + + if (Tk_ConfigureWidget(textPtr->interp, textPtr->tkwin, configSpecs, + argc, argv, (char *) &eiPtr->body.ei,TK_CONFIG_ARGV_ONLY) + != TCL_OK) { + return TCL_ERROR; + } + + /* + * Create the image. Save the old image around and don't free it + * until after the new one is allocated. This keeps the reference + * count from going to zero so the image doesn't have to be recreated + * if it hasn't changed. + */ + + if (eiPtr->body.ei.imageString != NULL) { + image = Tk_GetImage(textPtr->interp, textPtr->tkwin, eiPtr->body.ei.imageString, + EmbImageProc, (ClientData) eiPtr); + if (image == NULL) { + return TCL_ERROR; + } + } else { + image = NULL; + } + if (eiPtr->body.ei.image != NULL) { + Tk_FreeImage(eiPtr->body.ei.image); + } + eiPtr->body.ei.image = image; + + if (eiPtr->body.ei.name != NULL) { + return TCL_OK; + } + + /* + * Find a unique name for this image. Use imageName (or imageString) + * if available, otherwise tack on a #nn and use it. If a name is already + * associated with this image, delete the name. + */ + + name = eiPtr->body.ei.imageName; + if (name == NULL) { + name = eiPtr->body.ei.imageString; + } + if (name == NULL) { + Tcl_AppendResult(textPtr->interp,"Either a \"-name\" ", + "or a \"-image\" argument must be provided ", + "to the \"image create\" subcommand.", + (char *) NULL); + return TCL_ERROR; + } + len = strlen(name); + for (hPtr = Tcl_FirstHashEntry(&textPtr->imageTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + char *haveName = Tcl_GetHashKey(&textPtr->imageTable, hPtr); + if (strncmp(name, haveName, len) == 0) { + new = 0; + sscanf(haveName+len,"#%d",&new); + if (new > count) { + count = new; + } + if (len == (int) strlen(haveName)) { + conflict = 1; + } + } + } + + Tcl_DStringInit(&newName); + Tcl_DStringAppend(&newName,name, -1); + + if (conflict) { + char buf[10]; + sprintf(buf, "#%d",count+1); + Tcl_DStringAppend(&newName,buf, -1); + } + name = Tcl_DStringValue(&newName); + hPtr = Tcl_CreateHashEntry(&textPtr->imageTable, name, &new); + Tcl_SetHashValue(hPtr, eiPtr); + Tcl_AppendResult(textPtr->interp, name , (char *) NULL); + eiPtr->body.ei.name = ckalloc((unsigned) Tcl_DStringLength(&newName)+1); + strcpy(eiPtr->body.ei.name,name); + Tcl_DStringFree(&newName); + + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * AlignParseProc -- + * + * This procedure is invoked by Tk_ConfigureWidget during + * option processing to handle "-align" options for embedded + * images. + * + * Results: + * A standard Tcl return value. + * + * Side effects: + * The alignment for the embedded image may change. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +AlignParseProc(clientData, interp, tkwin, value, widgRec, offset) + ClientData clientData; /* Not used.*/ + Tcl_Interp *interp; /* Used for reporting errors. */ + Tk_Window tkwin; /* Window for text widget. */ + char *value; /* Value of option. */ + char *widgRec; /* Pointer to TkTextEmbWindow + * structure. */ + int offset; /* Offset into item (ignored). */ +{ + register TkTextEmbImage *embPtr = (TkTextEmbImage *) widgRec; + + if (strcmp(value, "baseline") == 0) { + embPtr->align = ALIGN_BASELINE; + } else if (strcmp(value, "bottom") == 0) { + embPtr->align = ALIGN_BOTTOM; + } else if (strcmp(value, "center") == 0) { + embPtr->align = ALIGN_CENTER; + } else if (strcmp(value, "top") == 0) { + embPtr->align = ALIGN_TOP; + } else { + Tcl_AppendResult(interp, "bad alignment \"", value, + "\": must be baseline, bottom, center, or top", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * AlignPrintProc -- + * + * This procedure is invoked by the Tk configuration code + * to produce a printable string for the "-align" configuration + * option for embedded images. + * + * Results: + * The return value is a string describing the embedded + * images's current alignment. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static char * +AlignPrintProc(clientData, tkwin, widgRec, offset, freeProcPtr) + ClientData clientData; /* Ignored. */ + Tk_Window tkwin; /* Window for text widget. */ + char *widgRec; /* Pointer to TkTextEmbImage + * structure. */ + int offset; /* Ignored. */ + Tcl_FreeProc **freeProcPtr; /* Pointer to variable to fill in with + * information about how to reclaim + * storage for return string. */ +{ + switch (((TkTextEmbImage *) widgRec)->align) { + case ALIGN_BASELINE: + return "baseline"; + case ALIGN_BOTTOM: + return "bottom"; + case ALIGN_CENTER: + return "center"; + case ALIGN_TOP: + return "top"; + default: + return "??"; + } +} + +/* + *-------------------------------------------------------------- + * + * EmbImageDeleteProc -- + * + * This procedure is invoked by the text B-tree code whenever + * an embedded image lies in a range of characters being deleted. + * + * Results: + * Returns 0 to indicate that the deletion has been accepted. + * + * Side effects: + * The embedded image is deleted, if it exists, and any resources + * associated with it are released. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +EmbImageDeleteProc(eiPtr, linePtr, treeGone) + TkTextSegment *eiPtr; /* Segment being deleted. */ + TkTextLine *linePtr; /* Line containing segment. */ + int treeGone; /* Non-zero means the entire tree is + * being deleted, so everything must + * get cleaned up. */ +{ + Tcl_HashEntry *hPtr; + + if (eiPtr->body.ei.image != NULL) { + hPtr = Tcl_FindHashEntry(&eiPtr->body.ei.textPtr->imageTable, + eiPtr->body.ei.name); + if (hPtr != NULL) { + /* + * (It's possible for there to be no hash table entry for this + * image, if an error occurred while creating the image segment + * but before the image got added to the table) + */ + + Tcl_DeleteHashEntry(hPtr); + } + Tk_FreeImage(eiPtr->body.ei.image); + } + Tk_FreeOptions(configSpecs, (char *) &eiPtr->body.ei, + eiPtr->body.ei.textPtr->display, 0); + if (eiPtr->body.ei.name != NULL) { + ckfree(eiPtr->body.ei.name); + } + ckfree((char *) eiPtr); + return 0; +} + +/* + *-------------------------------------------------------------- + * + * EmbImageCleanupProc -- + * + * This procedure is invoked by the B-tree code whenever a + * segment containing an embedded image is moved from one + * line to another. + * + * Results: + * None. + * + * Side effects: + * The linePtr field of the segment gets updated. + * + *-------------------------------------------------------------- + */ + +static TkTextSegment * +EmbImageCleanupProc(eiPtr, linePtr) + TkTextSegment *eiPtr; /* Mark segment that's being moved. */ + TkTextLine *linePtr; /* Line that now contains segment. */ +{ + eiPtr->body.ei.linePtr = linePtr; + return eiPtr; +} + +/* + *-------------------------------------------------------------- + * + * EmbImageLayoutProc -- + * + * This procedure is the "layoutProc" for embedded image + * segments. + * + * Results: + * 1 is returned to indicate that the segment should be + * displayed. The chunkPtr structure is filled in. + * + * Side effects: + * None, except for filling in chunkPtr. + * + *-------------------------------------------------------------- + */ + + /*ARGSUSED*/ +static int +EmbImageLayoutProc(textPtr, indexPtr, eiPtr, offset, maxX, maxChars, + noCharsYet, wrapMode, chunkPtr) + TkText *textPtr; /* Text widget being layed out. */ + TkTextIndex *indexPtr; /* Identifies first character in chunk. */ + TkTextSegment *eiPtr; /* Segment corresponding to indexPtr. */ + int offset; /* Offset within segPtr corresponding to + * indexPtr (always 0). */ + int maxX; /* Chunk must not occupy pixels at this + * position or higher. */ + int maxChars; /* Chunk must not include more than this + * many characters. */ + int noCharsYet; /* Non-zero means no characters have been + * assigned to this line yet. */ + Tk_Uid wrapMode; /* Wrap mode to use for line: tkTextCharUid, + * tkTextNoneUid, or tkTextWordUid. */ + register TkTextDispChunk *chunkPtr; + /* Structure to fill in with information + * about this chunk. The x field has already + * been set by the caller. */ +{ + int width, height; + + if (offset != 0) { + panic("Non-zero offset in EmbImageLayoutProc"); + } + + /* + * See if there's room for this image on this line. + */ + + if (eiPtr->body.ei.image == NULL) { + width = 0; + height = 0; + } else { + Tk_SizeOfImage(eiPtr->body.ei.image, &width, &height); + width += 2*eiPtr->body.ei.padX; + height += 2*eiPtr->body.ei.padY; + } + if ((width > (maxX - chunkPtr->x)) + && !noCharsYet && (textPtr->wrapMode != tkTextNoneUid)) { + return 0; + } + + /* + * Fill in the chunk structure. + */ + + chunkPtr->displayProc = EmbImageDisplayProc; + chunkPtr->undisplayProc = (Tk_ChunkUndisplayProc *) NULL; + chunkPtr->measureProc = (Tk_ChunkMeasureProc *) NULL; + chunkPtr->bboxProc = EmbImageBboxProc; + chunkPtr->numChars = 1; + if (eiPtr->body.ei.align == ALIGN_BASELINE) { + chunkPtr->minAscent = height - eiPtr->body.ei.padY; + chunkPtr->minDescent = eiPtr->body.ei.padY; + chunkPtr->minHeight = 0; + } else { + chunkPtr->minAscent = 0; + chunkPtr->minDescent = 0; + chunkPtr->minHeight = height; + } + chunkPtr->width = width; + chunkPtr->breakIndex = -1; + chunkPtr->breakIndex = 1; + chunkPtr->clientData = (ClientData) eiPtr; + eiPtr->body.ei.chunkCount += 1; + return 1; +} + +/* + *-------------------------------------------------------------- + * + * EmbImageCheckProc -- + * + * This procedure is invoked by the B-tree code to perform + * consistency checks on embedded images. + * + * Results: + * None. + * + * Side effects: + * The procedure panics if it detects anything wrong with + * the embedded image. + * + *-------------------------------------------------------------- + */ + +static void +EmbImageCheckProc(eiPtr, linePtr) + TkTextSegment *eiPtr; /* Segment to check. */ + TkTextLine *linePtr; /* Line containing segment. */ +{ + if (eiPtr->nextPtr == NULL) { + panic("EmbImageCheckProc: embedded image is last segment in line"); + } + if (eiPtr->size != 1) { + panic("EmbImageCheckProc: embedded image has size %d", eiPtr->size); + } +} + +/* + *-------------------------------------------------------------- + * + * EmbImageDisplayProc -- + * + * This procedure is invoked by the text displaying code + * when it is time to actually draw an embedded image + * chunk on the screen. + * + * Results: + * None. + * + * Side effects: + * The embedded image gets moved to the correct location + * and drawn onto the display. + * + *-------------------------------------------------------------- + */ + +static void +EmbImageDisplayProc(chunkPtr, x, y, lineHeight, baseline, display, dst, screenY) + TkTextDispChunk *chunkPtr; /* Chunk that is to be drawn. */ + int x; /* X-position in dst at which to + * draw this chunk (differs from + * the x-position in the chunk because + * of scrolling). */ + int y; /* Top of rectangular bounding box + * for line: tells where to draw this + * chunk in dst (x-position is in + * the chunk itself). */ + int lineHeight; /* Total height of line. */ + int baseline; /* Offset of baseline from y. */ + Display *display; /* Display to use for drawing. */ + Drawable dst; /* Pixmap or window in which to draw */ + int screenY; /* Y-coordinate in text window that + * corresponds to y. */ +{ + TkTextSegment *eiPtr = (TkTextSegment *) chunkPtr->clientData; + int lineX, imageX, imageY, width, height; + Tk_Image image; + + image = eiPtr->body.ei.image; + if (image == NULL) { + return; + } + if ((x + chunkPtr->width) <= 0) { + return; + } + + /* + * Compute the image's location and size in the text widget, taking + * into account the align value for the image. + */ + + EmbImageBboxProc(chunkPtr, 0, y, lineHeight, baseline, &lineX, + &imageY, &width, &height); + imageX = lineX - chunkPtr->x + x; + + Tk_RedrawImage(image, 0, 0, width, height, dst, + imageX, imageY); +} + +/* + *-------------------------------------------------------------- + * + * EmbImageBboxProc -- + * + * This procedure is called to compute the bounding box of + * the area occupied by an embedded image. + * + * Results: + * There is no return value. *xPtr and *yPtr are filled in + * with the coordinates of the upper left corner of the + * image, and *widthPtr and *heightPtr are filled in with + * the dimensions of the image in pixels. Note: not all + * of the returned bbox is necessarily visible on the screen + * (the rightmost part might be off-screen to the right, + * and the bottommost part might be off-screen to the bottom). + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static void +EmbImageBboxProc(chunkPtr, index, y, lineHeight, baseline, xPtr, yPtr, + widthPtr, heightPtr) + TkTextDispChunk *chunkPtr; /* Chunk containing desired char. */ + int index; /* Index of desired character within + * the chunk. */ + int y; /* Topmost pixel in area allocated + * for this line. */ + int lineHeight; /* Total height of line. */ + int baseline; /* Location of line's baseline, in + * pixels measured down from y. */ + int *xPtr, *yPtr; /* Gets filled in with coords of + * character's upper-left pixel. */ + int *widthPtr; /* Gets filled in with width of + * character, in pixels. */ + int *heightPtr; /* Gets filled in with height of + * character, in pixels. */ +{ + TkTextSegment *eiPtr = (TkTextSegment *) chunkPtr->clientData; + Tk_Image image; + + image = eiPtr->body.ei.image; + if (image != NULL) { + Tk_SizeOfImage(image, widthPtr, heightPtr); + } else { + *widthPtr = 0; + *heightPtr = 0; + } + *xPtr = chunkPtr->x + eiPtr->body.ei.padX; + switch (eiPtr->body.ei.align) { + case ALIGN_BOTTOM: + *yPtr = y + (lineHeight - *heightPtr - eiPtr->body.ei.padY); + break; + case ALIGN_CENTER: + *yPtr = y + (lineHeight - *heightPtr)/2; + break; + case ALIGN_TOP: + *yPtr = y + eiPtr->body.ei.padY; + break; + case ALIGN_BASELINE: + *yPtr = y + (baseline - *heightPtr); + break; + } +} + +/* + *-------------------------------------------------------------- + * + * TkTextImageIndex -- + * + * Given the name of an embedded image within a text widget, + * returns an index corresponding to the image's position + * in the text. + * + * Results: + * The return value is 1 if there is an embedded image by + * the given name in the text widget, 0 otherwise. If the + * image exists, *indexPtr is filled in with its index. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +int +TkTextImageIndex(textPtr, name, indexPtr) + TkText *textPtr; /* Text widget containing image. */ + char *name; /* Name of image. */ + TkTextIndex *indexPtr; /* Index information gets stored here. */ +{ + Tcl_HashEntry *hPtr; + TkTextSegment *eiPtr; + + hPtr = Tcl_FindHashEntry(&textPtr->imageTable, name); + if (hPtr == NULL) { + return 0; + } + eiPtr = (TkTextSegment *) Tcl_GetHashValue(hPtr); + indexPtr->tree = textPtr->tree; + indexPtr->linePtr = eiPtr->body.ei.linePtr; + indexPtr->charIndex = TkTextSegToOffset(eiPtr, indexPtr->linePtr); + return 1; +} + +/* + *-------------------------------------------------------------- + * + * EmbImageProc -- + * + * This procedure is called by the image code whenever an + * image or its contents changes. + * + * Results: + * None. + * + * Side effects: + * The image will be redisplayed. + * + *-------------------------------------------------------------- + */ + +static void +EmbImageProc(clientData, x, y, width, height, imgWidth, imgHeight) + ClientData clientData; /* Pointer to widget record. */ + int x, y; /* Upper left pixel (within image) + * that must be redisplayed. */ + int width, height; /* Dimensions of area to redisplay + * (may be <= 0). */ + int imgWidth, imgHeight; /* New dimensions of image. */ + +{ + TkTextSegment *eiPtr = (TkTextSegment *) clientData; + TkTextIndex index; + + index.tree = eiPtr->body.ei.textPtr->tree; + index.linePtr = eiPtr->body.ei.linePtr; + index.charIndex = TkTextSegToOffset(eiPtr, eiPtr->body.ei.linePtr); + TkTextChanged(eiPtr->body.ei.textPtr, &index, &index); +} diff --git a/generic/tkTextIndex.c b/generic/tkTextIndex.c new file mode 100644 index 0000000..d88d88a --- /dev/null +++ b/generic/tkTextIndex.c @@ -0,0 +1,840 @@ +/* + * tkTextIndex.c -- + * + * This module provides procedures that manipulate indices for + * text widgets. + * + * Copyright (c) 1992-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkTextIndex.c 1.15 97/06/17 17:49:24 + */ + +#include "default.h" +#include "tkPort.h" +#include "tkInt.h" +#include "tkText.h" + +/* + * Index to use to select last character in line (very large integer): + */ + +#define LAST_CHAR 1000000 + +/* + * Forward declarations for procedures defined later in this file: + */ + +static char * ForwBack _ANSI_ARGS_((char *string, + TkTextIndex *indexPtr)); +static char * StartEnd _ANSI_ARGS_(( char *string, + TkTextIndex *indexPtr)); + +/* + *-------------------------------------------------------------- + * + * TkTextMakeIndex -- + * + * 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 * +TkTextMakeIndex(tree, lineIndex, charIndex, indexPtr) + TkTextBTree tree; /* Tree that lineIndex and charIndex refer + * to. */ + int lineIndex; /* Index of desired line (0 means first + * line of text). */ + int charIndex; /* Index of desired character. */ + TkTextIndex *indexPtr; /* Structure to fill in. */ +{ + register TkTextSegment *segPtr; + int index; + + indexPtr->tree = tree; + if (lineIndex < 0) { + lineIndex = 0; + charIndex = 0; + } + if (charIndex < 0) { + charIndex = 0; + } + indexPtr->linePtr = TkBTreeFindLine(tree, lineIndex); + if (indexPtr->linePtr == NULL) { + indexPtr->linePtr = TkBTreeFindLine(tree, TkBTreeNumLines(tree)); + charIndex = 0; + } + + /* + * Verify that the index is within the range of the line. + * If not, just use the index of the last character in the line. + */ + + for (index = 0, segPtr = indexPtr->linePtr->segPtr; ; + segPtr = segPtr->nextPtr) { + if (segPtr == NULL) { + indexPtr->charIndex = index-1; + break; + } + index += segPtr->size; + if (index > charIndex) { + indexPtr->charIndex = charIndex; + break; + } + } + return indexPtr; +} + +/* + *-------------------------------------------------------------- + * + * TkTextIndexToSeg -- + * + * 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. + * + * 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. */ +{ + register TkTextSegment *segPtr; + int offset; + + for (offset = indexPtr->charIndex, segPtr = indexPtr->linePtr->segPtr; + offset >= segPtr->size; + offset -= segPtr->size, segPtr = segPtr->nextPtr) { + /* Empty loop body. */ + } + if (offsetPtr != NULL) { + *offsetPtr = offset; + } + return segPtr; +} + +/* + *-------------------------------------------------------------- + * + * TkTextSegToOffset -- + * + * 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. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +int +TkTextSegToOffset(segPtr, linePtr) + TkTextSegment *segPtr; /* Segment whose offset is desired. */ + TkTextLine *linePtr; /* Line containing segPtr. */ +{ + TkTextSegment *segPtr2; + int offset; + + offset = 0; + for (segPtr2 = linePtr->segPtr; segPtr2 != segPtr; + segPtr2 = segPtr2->nextPtr) { + offset += segPtr2->size; + } + return offset; +} + +/* + *---------------------------------------------------------------------- + * + * TkTextGetIndex -- + * + * Given a string, return the line and character indices that + * it describes. + * + * 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. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TkTextGetIndex(interp, textPtr, string, indexPtr) + Tcl_Interp *interp; /* Use this for error reporting. */ + TkText *textPtr; /* Information about text widget. */ + char *string; /* Textual description of position. */ + TkTextIndex *indexPtr; /* Index structure to fill in. */ +{ + register char *p; + char *end, *endOfBase; + Tcl_HashEntry *hPtr; + TkTextTag *tagPtr; + TkTextSearch search; + TkTextIndex first, last; + int wantLast, result; + char c; + + /* + *--------------------------------------------------------------------- + * Stage 1: check to see if the index consists of nothing but a mark + * name. We do this check now even though it's also done later, in + * order to allow mark names that include funny characters such as + * spaces or "+1c". + *--------------------------------------------------------------------- + */ + + if (TkTextMarkNameToIndex(textPtr, string, indexPtr) == TCL_OK) { + return TCL_OK; + } + + /* + *------------------------------------------------ + * Stage 2: start again by parsing the base index. + *------------------------------------------------ + */ + + indexPtr->tree = textPtr->tree; + + /* + * First look for the form "tag.first" or "tag.last" where "tag" + * is the name of a valid tag. Try to use up as much as possible + * of the string in this check (strrchr instead of strchr below). + * Doing the check now, and in this way, allows tag names to include + * funny characters like "@" or "+1c". + */ + + p = strrchr(string, '.'); + if (p != NULL) { + if ((p[1] == 'f') && (strncmp(p+1, "first", 5) == 0)) { + wantLast = 0; + endOfBase = p+6; + } else if ((p[1] == 'l') && (strncmp(p+1, "last", 4) == 0)) { + wantLast = 1; + endOfBase = p+5; + } else { + goto tryxy; + } + *p = 0; + hPtr = Tcl_FindHashEntry(&textPtr->tagTable, string); + *p = '.'; + if (hPtr == NULL) { + goto tryxy; + } + tagPtr = (TkTextTag *) Tcl_GetHashValue(hPtr); + TkTextMakeIndex(textPtr->tree, 0, 0, &first); + TkTextMakeIndex(textPtr->tree, TkBTreeNumLines(textPtr->tree), 0, + &last); + TkBTreeStartSearch(&first, &last, tagPtr, &search); + if (!TkBTreeCharTagged(&first, tagPtr) && !TkBTreeNextTag(&search)) { + Tcl_AppendResult(interp, + "text doesn't contain any characters tagged with \"", + Tcl_GetHashKey(&textPtr->tagTable, hPtr), "\"", + (char *) NULL); + return TCL_ERROR; + } + *indexPtr = search.curIndex; + if (wantLast) { + while (TkBTreeNextTag(&search)) { + *indexPtr = search.curIndex; + } + } + goto gotBase; + } + + tryxy: + if (string[0] == '@') { + /* + * Find character at a given x,y location in the window. + */ + + int x, y; + + p = string+1; + x = strtol(p, &end, 0); + if ((end == p) || (*end != ',')) { + goto error; + } + p = end+1; + y = strtol(p, &end, 0); + if (end == p) { + goto error; + } + TkTextPixelIndex(textPtr, x, y, indexPtr); + endOfBase = end; + goto gotBase; + } + + if (isdigit(UCHAR(string[0])) || (string[0] == '-')) { + int lineIndex, charIndex; + + /* + * Base is identified with line and character indices. + */ + + lineIndex = strtol(string, &end, 0) - 1; + if ((end == string) || (*end != '.')) { + goto error; + } + p = end+1; + if ((*p == 'e') && (strncmp(p, "end", 3) == 0)) { + charIndex = LAST_CHAR; + endOfBase = p+3; + } else { + charIndex = strtol(p, &end, 0); + if (end == p) { + goto error; + } + endOfBase = end; + } + TkTextMakeIndex(textPtr->tree, lineIndex, charIndex, indexPtr); + goto gotBase; + } + + for (p = string; *p != 0; p++) { + if (isspace(UCHAR(*p)) || (*p == '+') || (*p == '-')) { + break; + } + } + endOfBase = p; + if (string[0] == '.') { + /* + * See if the base position is the name of an embedded window. + */ + + c = *endOfBase; + *endOfBase = 0; + result = TkTextWindowIndex(textPtr, string, indexPtr); + *endOfBase = c; + if (result != 0) { + goto gotBase; + } + } + if ((string[0] == 'e') + && (strncmp(string, "end", (size_t) (endOfBase-string)) == 0)) { + /* + * Base position is end of text. + */ + + TkTextMakeIndex(textPtr->tree, TkBTreeNumLines(textPtr->tree), + 0, indexPtr); + goto gotBase; + } else { + /* + * See if the base position is the name of a mark. + */ + + c = *endOfBase; + *endOfBase = 0; + result = TkTextMarkNameToIndex(textPtr, string, indexPtr); + *endOfBase = c; + if (result == TCL_OK) { + goto gotBase; + } + + /* + * See if the base position is the name of an embedded image + */ + + c = *endOfBase; + *endOfBase = 0; + result = TkTextImageIndex(textPtr, string, indexPtr); + *endOfBase = c; + if (result != 0) { + goto gotBase; + } + } + goto error; + + /* + *------------------------------------------------------------------- + * Stage 3: process zero or more modifiers. Each modifier is either + * a keyword like "wordend" or "linestart", or it has the form + * "op count units" where op is + or -, count is a number, and units + * is "chars" or "lines". + *------------------------------------------------------------------- + */ + + gotBase: + p = endOfBase; + while (1) { + while (isspace(UCHAR(*p))) { + p++; + } + if (*p == 0) { + break; + } + + if ((*p == '+') || (*p == '-')) { + p = ForwBack(p, indexPtr); + } else { + p = StartEnd(p, indexPtr); + } + if (p == NULL) { + goto error; + } + } + return TCL_OK; + + error: + Tcl_AppendResult(interp, "bad text index \"", string, "\"", + (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * TkTextPrintIndex -- + * + * + * This procedure generates a string description of an index, + * suitable for reading in again later. + * + * Results: + * The characters pointed to by string are modified. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TkTextPrintIndex(indexPtr, string) + TkTextIndex *indexPtr; /* Pointer to index. */ + char *string; /* Place to store the position. Must have + * at least TK_POS_CHARS characters. */ +{ + sprintf(string, "%d.%d", TkBTreeLineIndex(indexPtr->linePtr) + 1, + indexPtr->charIndex); +} + +/* + *-------------------------------------------------------------- + * + * TkTextIndexCmp -- + * + * 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. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +int +TkTextIndexCmp(index1Ptr, index2Ptr) + TkTextIndex *index1Ptr; /* First index. */ + TkTextIndex *index2Ptr; /* Second index. */ +{ + int line1, line2; + + if (index1Ptr->linePtr == index2Ptr->linePtr) { + if (index1Ptr->charIndex < index2Ptr->charIndex) { + return -1; + } else if (index1Ptr->charIndex > index2Ptr->charIndex) { + return 1; + } else { + return 0; + } + } + line1 = TkBTreeLineIndex(index1Ptr->linePtr); + line2 = TkBTreeLineIndex(index2Ptr->linePtr); + if (line1 < line2) { + return -1; + } + if (line1 > line2) { + return 1; + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * ForwBack -- + * + * 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. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static char * +ForwBack(string, indexPtr) + char *string; /* String to parse for additional info + * about modifier (count and units). + * Points to "+" or "-" that starts + * modifier. */ + TkTextIndex *indexPtr; /* Index to update as specified in string. */ +{ + register char *p; + char *end, *units; + int count, lineIndex; + size_t length; + + /* + * Get the count (how many units forward or backward). + */ + + p = string+1; + while (isspace(UCHAR(*p))) { + p++; + } + count = strtol(p, &end, 0); + if (end == p) { + return NULL; + } + p = end; + while (isspace(UCHAR(*p))) { + p++; + } + + /* + * Find the end of this modifier (next space or + or - character), + * then parse the unit specifier and update the position + * accordingly. + */ + + units = p; + while ((*p != 0) && !isspace(UCHAR(*p)) && (*p != '+') && (*p != '-')) { + p++; + } + length = p - units; + if ((*units == 'c') && (strncmp(units, "chars", length) == 0)) { + if (*string == '+') { + TkTextIndexForwChars(indexPtr, count, indexPtr); + } else { + TkTextIndexBackChars(indexPtr, count, indexPtr); + } + } else if ((*units == 'l') && (strncmp(units, "lines", length) == 0)) { + lineIndex = TkBTreeLineIndex(indexPtr->linePtr); + if (*string == '+') { + lineIndex += count; + } else { + lineIndex -= count; + + /* + * The check below retains the character position, even + * if the line runs off the start of the file. Without + * it, the character position will get reset to 0 by + * TkTextMakeIndex. + */ + + if (lineIndex < 0) { + lineIndex = 0; + } + } + TkTextMakeIndex(indexPtr->tree, lineIndex, indexPtr->charIndex, + indexPtr); + } else { + return NULL; + } + return p; +} + +/* + *---------------------------------------------------------------------- + * + * TkTextIndexForwChars -- + * + * 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 + * after srcPtr, or to the last character in the file if there aren't + * "count" characters left in the file. + * + * 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. */ +{ + TkTextLine *linePtr; + TkTextSegment *segPtr; + int lineLength; + + if (count < 0) { + TkTextIndexBackChars(srcPtr, -count, dstPtr); + return; + } + + *dstPtr = *srcPtr; + dstPtr->charIndex += count; + while (1) { + /* + * Compute the length of the current line. + */ + + lineLength = 0; + for (segPtr = dstPtr->linePtr->segPtr; segPtr != NULL; + segPtr = segPtr->nextPtr) { + lineLength += segPtr->size; + } + + /* + * If the new index is in the same line then we're done. + * Otherwise go on to the next line. + */ + + if (dstPtr->charIndex < lineLength) { + return; + } + dstPtr->charIndex -= lineLength; + linePtr = TkBTreeNextLine(dstPtr->linePtr); + if (linePtr == NULL) { + dstPtr->charIndex = lineLength - 1; + return; + } + dstPtr->linePtr = linePtr; + } +} + +/* + *---------------------------------------------------------------------- + * + * 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, count, dstPtr) + TkTextIndex *srcPtr; /* Source index. */ + int count; /* How many characters backward to + * move. May be negative. */ + TkTextIndex *dstPtr; /* Destination index: gets modified. */ +{ + TkTextSegment *segPtr; + int lineIndex; + + if (count < 0) { + TkTextIndexForwChars(srcPtr, -count, dstPtr); + return; + } + + *dstPtr = *srcPtr; + dstPtr->charIndex -= count; + lineIndex = -1; + while (dstPtr->charIndex < 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. + */ + + if (lineIndex < 0) { + lineIndex = TkBTreeLineIndex(dstPtr->linePtr); + } + if (lineIndex == 0) { + dstPtr->charIndex = 0; + return; + } + lineIndex--; + dstPtr->linePtr = TkBTreeFindLine(dstPtr->tree, lineIndex); + + /* + * Compute the length of the line and add that to dstPtr->charIndex. + */ + + for (segPtr = dstPtr->linePtr->segPtr; segPtr != NULL; + segPtr = segPtr->nextPtr) { + dstPtr->charIndex += segPtr->size; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * StartEnd -- + * + * This procedure handles modifiers like "wordstart" and "lineend" + * to adjust indices forwards or backwards. + * + * Results: + * If the modifier 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 * +StartEnd(string, indexPtr) + char *string; /* String to parse for additional info + * about modifier (count and units). + * Points to first character of modifer + * word. */ + TkTextIndex *indexPtr; /* Index to mdoify based on string. */ +{ + char *p; + int c, offset; + size_t length; + register TkTextSegment *segPtr; + + /* + * Find the end of the modifier word. + */ + + for (p = string; isalnum(UCHAR(*p)); p++) { + /* Empty loop body. */ + } + length = p-string; + if ((*string == 'l') && (strncmp(string, "lineend", length) == 0) + && (length >= 5)) { + indexPtr->charIndex = 0; + for (segPtr = indexPtr->linePtr->segPtr; segPtr != NULL; + segPtr = segPtr->nextPtr) { + indexPtr->charIndex += segPtr->size; + } + indexPtr->charIndex -= 1; + } else if ((*string == 'l') && (strncmp(string, "linestart", length) == 0) + && (length >= 5)) { + indexPtr->charIndex = 0; + } else if ((*string == 'w') && (strncmp(string, "wordend", length) == 0) + && (length >= 5)) { + int firstChar = 1; + + /* + * If the current character isn't part of a word then just move + * forward one character. Otherwise move forward until finding + * a character that isn't part of a word and stop there. + */ + + segPtr = TkTextIndexToSeg(indexPtr, &offset); + while (1) { + if (segPtr->typePtr == &tkTextCharType) { + c = segPtr->body.chars[offset]; + if (!isalnum(UCHAR(c)) && (c != '_')) { + break; + } + firstChar = 0; + } + offset += 1; + indexPtr->charIndex += 1; + if (offset >= segPtr->size) { + segPtr = TkTextIndexToSeg(indexPtr, &offset); + } + } + if (firstChar) { + TkTextIndexForwChars(indexPtr, 1, indexPtr); + } + } else if ((*string == 'w') && (strncmp(string, "wordstart", length) == 0) + && (length >= 5)) { + int firstChar = 1; + + /* + * Starting with the current character, look for one that's not + * part of a word and keep moving backward until you find one. + * Then if the character found wasn't the first one, move forward + * again one position. + */ + + segPtr = TkTextIndexToSeg(indexPtr, &offset); + while (1) { + if (segPtr->typePtr == &tkTextCharType) { + c = segPtr->body.chars[offset]; + if (!isalnum(UCHAR(c)) && (c != '_')) { + break; + } + firstChar = 0; + } + offset -= 1; + indexPtr->charIndex -= 1; + if (offset < 0) { + if (indexPtr->charIndex < 0) { + indexPtr->charIndex = 0; + goto done; + } + segPtr = TkTextIndexToSeg(indexPtr, &offset); + } + } + if (!firstChar) { + TkTextIndexForwChars(indexPtr, 1, indexPtr); + } + } else { + return NULL; + } + done: + return p; +} diff --git a/generic/tkTextMark.c b/generic/tkTextMark.c new file mode 100644 index 0000000..0d12c98 --- /dev/null +++ b/generic/tkTextMark.c @@ -0,0 +1,775 @@ +/* + * tkTextMark.c -- + * + * This file contains the procedure that implement marks for + * text widgets. + * + * Copyright (c) 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: @(#) tkTextMark.c 1.18 97/10/20 11:12:50 + */ + +#include "tkInt.h" +#include "tkText.h" +#include "tkPort.h" + +/* + * Macro that determines the size of a mark segment: + */ + +#define MSEG_SIZE ((unsigned) (Tk_Offset(TkTextSegment, body) \ + + sizeof(TkTextMark))) + +/* + * Forward references for procedures defined in this file: + */ + +static void InsertUndisplayProc _ANSI_ARGS_((TkText *textPtr, + TkTextDispChunk *chunkPtr)); +static int MarkDeleteProc _ANSI_ARGS_((TkTextSegment *segPtr, + TkTextLine *linePtr, int treeGone)); +static TkTextSegment * MarkCleanupProc _ANSI_ARGS_((TkTextSegment *segPtr, + TkTextLine *linePtr)); +static void MarkCheckProc _ANSI_ARGS_((TkTextSegment *segPtr, + TkTextLine *linePtr)); +static int MarkLayoutProc _ANSI_ARGS_((TkText *textPtr, + TkTextIndex *indexPtr, TkTextSegment *segPtr, + int offset, int maxX, int maxChars, + int noCharsYet, Tk_Uid wrapMode, + TkTextDispChunk *chunkPtr)); +static int MarkFindNext _ANSI_ARGS_((Tcl_Interp *interp, + TkText *textPtr, char *markName)); +static int MarkFindPrev _ANSI_ARGS_((Tcl_Interp *interp, + TkText *textPtr, char *markName)); + + +/* + * The following structures declare the "mark" segment types. + * There are actually two types for marks, one with left gravity + * and one with right gravity. They are identical except for + * their gravity property. + */ + +Tk_SegType tkTextRightMarkType = { + "mark", /* name */ + 0, /* leftGravity */ + (Tk_SegSplitProc *) NULL, /* splitProc */ + MarkDeleteProc, /* deleteProc */ + MarkCleanupProc, /* cleanupProc */ + (Tk_SegLineChangeProc *) NULL, /* lineChangeProc */ + MarkLayoutProc, /* layoutProc */ + MarkCheckProc /* checkProc */ +}; + +Tk_SegType tkTextLeftMarkType = { + "mark", /* name */ + 1, /* leftGravity */ + (Tk_SegSplitProc *) NULL, /* splitProc */ + MarkDeleteProc, /* deleteProc */ + MarkCleanupProc, /* cleanupProc */ + (Tk_SegLineChangeProc *) NULL, /* lineChangeProc */ + MarkLayoutProc, /* layoutProc */ + MarkCheckProc /* checkProc */ +}; + +/* + *-------------------------------------------------------------- + * + * TkTextMarkCmd -- + * + * This procedure is invoked to process the "mark" options of + * the widget command for text widgets. See the user documentation + * for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +int +TkTextMarkCmd(textPtr, interp, argc, argv) + register TkText *textPtr; /* Information about text widget. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. Someone else has already + * parsed this command enough to know that + * argv[1] is "mark". */ +{ + int c, i; + size_t length; + Tcl_HashEntry *hPtr; + TkTextSegment *markPtr; + Tcl_HashSearch search; + TkTextIndex index; + Tk_SegType *newTypePtr; + + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " mark option ?arg arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + c = argv[2][0]; + length = strlen(argv[2]); + if ((c == 'g') && (strncmp(argv[2], "gravity", length) == 0)) { + if (argc < 4 || argc > 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " mark gravity markName ?gravity?\"", + (char *) NULL); + return TCL_ERROR; + } + hPtr = Tcl_FindHashEntry(&textPtr->markTable, argv[3]); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "there is no mark named \"", + argv[3], "\"", (char *) NULL); + return TCL_ERROR; + } + markPtr = (TkTextSegment *) Tcl_GetHashValue(hPtr); + if (argc == 4) { + if (markPtr->typePtr == &tkTextRightMarkType) { + interp->result = "right"; + } else { + interp->result = "left"; + } + return TCL_OK; + } + length = strlen(argv[4]); + c = argv[4][0]; + if ((c == 'l') && (strncmp(argv[4], "left", length) == 0)) { + newTypePtr = &tkTextLeftMarkType; + } else if ((c == 'r') && (strncmp(argv[4], "right", length) == 0)) { + newTypePtr = &tkTextRightMarkType; + } else { + Tcl_AppendResult(interp, "bad mark gravity \"", + argv[4], "\": must be left or right", (char *) NULL); + return TCL_ERROR; + } + TkTextMarkSegToIndex(textPtr, markPtr, &index); + TkBTreeUnlinkSegment(textPtr->tree, markPtr, + markPtr->body.mark.linePtr); + markPtr->typePtr = newTypePtr; + TkBTreeLinkSegment(markPtr, &index); + } else if ((c == 'n') && (strncmp(argv[2], "names", length) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " mark names\"", (char *) NULL); + return TCL_ERROR; + } + for (hPtr = Tcl_FirstHashEntry(&textPtr->markTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + Tcl_AppendElement(interp, + Tcl_GetHashKey(&textPtr->markTable, hPtr)); + } + } else if ((c == 'n') && (strncmp(argv[2], "next", length) == 0)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " mark next index\"", (char *) NULL); + return TCL_ERROR; + } + return MarkFindNext(interp, textPtr, argv[3]); + } else if ((c == 'p') && (strncmp(argv[2], "previous", length) == 0)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " mark previous index\"", (char *) NULL); + return TCL_ERROR; + } + return MarkFindPrev(interp, textPtr, argv[3]); + } else if ((c == 's') && (strncmp(argv[2], "set", length) == 0)) { + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " mark set markName index\"", (char *) NULL); + return TCL_ERROR; + } + if (TkTextGetIndex(interp, textPtr, argv[4], &index) != TCL_OK) { + return TCL_ERROR; + } + TkTextSetMark(textPtr, argv[3], &index); + } else if ((c == 'u') && (strncmp(argv[2], "unset", length) == 0)) { + for (i = 3; i < argc; i++) { + hPtr = Tcl_FindHashEntry(&textPtr->markTable, argv[i]); + if (hPtr != NULL) { + markPtr = (TkTextSegment *) Tcl_GetHashValue(hPtr); + if ((markPtr == textPtr->insertMarkPtr) + || (markPtr == textPtr->currentMarkPtr)) { + continue; + } + TkBTreeUnlinkSegment(textPtr->tree, markPtr, + markPtr->body.mark.linePtr); + Tcl_DeleteHashEntry(hPtr); + ckfree((char *) markPtr); + } + } + } else { + Tcl_AppendResult(interp, "bad mark option \"", argv[2], + "\": must be gravity, names, next, previous, set, or unset", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TkTextSetMark -- + * + * Set a mark to a particular position, creating a new mark if + * one doesn't already exist. + * + * Results: + * The return value is a pointer to the mark that was just set. + * + * Side effects: + * A new mark is created, or an existing mark is moved. + * + *---------------------------------------------------------------------- + */ + +TkTextSegment * +TkTextSetMark(textPtr, name, indexPtr) + TkText *textPtr; /* Text widget in which to create mark. */ + char *name; /* Name of mark to set. */ + TkTextIndex *indexPtr; /* Where to set mark. */ +{ + Tcl_HashEntry *hPtr; + TkTextSegment *markPtr; + TkTextIndex insertIndex; + int new; + + hPtr = Tcl_CreateHashEntry(&textPtr->markTable, name, &new); + markPtr = (TkTextSegment *) Tcl_GetHashValue(hPtr); + if (!new) { + /* + * If this is the insertion point that's being moved, be sure + * to force a display update at the old position. Also, don't + * let the insertion cursor be after the final newline of the + * file. + */ + + if (markPtr == textPtr->insertMarkPtr) { + TkTextIndex index, index2; + TkTextMarkSegToIndex(textPtr, textPtr->insertMarkPtr, &index); + TkTextIndexForwChars(&index, 1, &index2); + TkTextChanged(textPtr, &index, &index2); + if (TkBTreeLineIndex(indexPtr->linePtr) + == TkBTreeNumLines(textPtr->tree)) { + TkTextIndexBackChars(indexPtr, 1, &insertIndex); + indexPtr = &insertIndex; + } + } + TkBTreeUnlinkSegment(textPtr->tree, markPtr, + markPtr->body.mark.linePtr); + } else { + markPtr = (TkTextSegment *) ckalloc(MSEG_SIZE); + markPtr->typePtr = &tkTextRightMarkType; + markPtr->size = 0; + markPtr->body.mark.textPtr = textPtr; + markPtr->body.mark.linePtr = indexPtr->linePtr; + markPtr->body.mark.hPtr = hPtr; + Tcl_SetHashValue(hPtr, markPtr); + } + TkBTreeLinkSegment(markPtr, indexPtr); + + /* + * If the mark is the insertion cursor, then update the screen at the + * mark's new location. + */ + + if (markPtr == textPtr->insertMarkPtr) { + TkTextIndex index2; + + TkTextIndexForwChars(indexPtr, 1, &index2); + TkTextChanged(textPtr, indexPtr, &index2); + } + return markPtr; +} + +/* + *-------------------------------------------------------------- + * + * TkTextMarkSegToIndex -- + * + * Given a segment that is a mark, create an index that + * refers to the next text character (or other text segment + * with non-zero size) after the mark. + * + * Results: + * *IndexPtr is filled in with index information. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +void +TkTextMarkSegToIndex(textPtr, markPtr, indexPtr) + TkText *textPtr; /* Text widget containing mark. */ + TkTextSegment *markPtr; /* Mark segment. */ + TkTextIndex *indexPtr; /* Index information gets stored here. */ +{ + TkTextSegment *segPtr; + + indexPtr->tree = textPtr->tree; + indexPtr->linePtr = markPtr->body.mark.linePtr; + indexPtr->charIndex = 0; + for (segPtr = indexPtr->linePtr->segPtr; segPtr != markPtr; + segPtr = segPtr->nextPtr) { + indexPtr->charIndex += segPtr->size; + } +} + +/* + *-------------------------------------------------------------- + * + * TkTextMarkNameToIndex -- + * + * Given the name of a mark, return an index corresponding + * to the mark name. + * + * Results: + * The return value is TCL_OK if "name" exists as a mark in + * the text widget. In this case *indexPtr is filled in with + * the next segment whose after the mark whose size is + * non-zero. TCL_ERROR is returned if the mark doesn't exist + * in the text widget. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +int +TkTextMarkNameToIndex(textPtr, name, indexPtr) + TkText *textPtr; /* Text widget containing mark. */ + char *name; /* Name of mark. */ + TkTextIndex *indexPtr; /* Index information gets stored here. */ +{ + Tcl_HashEntry *hPtr; + + hPtr = Tcl_FindHashEntry(&textPtr->markTable, name); + if (hPtr == NULL) { + return TCL_ERROR; + } + TkTextMarkSegToIndex(textPtr, (TkTextSegment *) Tcl_GetHashValue(hPtr), + indexPtr); + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * MarkDeleteProc -- + * + * This procedure is invoked by the text B-tree code whenever + * a mark lies in a range of characters being deleted. + * + * Results: + * Returns 1 to indicate that deletion has been rejected. + * + * Side effects: + * None (even if the whole tree is being deleted we don't + * free up the mark; it will be done elsewhere). + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +MarkDeleteProc(segPtr, linePtr, treeGone) + TkTextSegment *segPtr; /* Segment being deleted. */ + TkTextLine *linePtr; /* Line containing segment. */ + int treeGone; /* Non-zero means the entire tree is + * being deleted, so everything must + * get cleaned up. */ +{ + return 1; +} + +/* + *-------------------------------------------------------------- + * + * MarkCleanupProc -- + * + * This procedure is invoked by the B-tree code whenever a + * mark segment is moved from one line to another. + * + * Results: + * None. + * + * Side effects: + * The linePtr field of the segment gets updated. + * + *-------------------------------------------------------------- + */ + +static TkTextSegment * +MarkCleanupProc(markPtr, linePtr) + TkTextSegment *markPtr; /* Mark segment that's being moved. */ + TkTextLine *linePtr; /* Line that now contains segment. */ +{ + markPtr->body.mark.linePtr = linePtr; + return markPtr; +} + +/* + *-------------------------------------------------------------- + * + * MarkLayoutProc -- + * + * This procedure is the "layoutProc" for mark segments. + * + * Results: + * If the mark isn't the insertion cursor then the return + * value is -1 to indicate that this segment shouldn't be + * displayed. If the mark is the insertion character then + * 1 is returned and the chunkPtr structure is filled in. + * + * Side effects: + * None, except for filling in chunkPtr. + * + *-------------------------------------------------------------- + */ + + /*ARGSUSED*/ +static int +MarkLayoutProc(textPtr, indexPtr, segPtr, offset, maxX, maxChars, + noCharsYet, wrapMode, chunkPtr) + TkText *textPtr; /* Text widget being layed out. */ + TkTextIndex *indexPtr; /* Identifies first character in chunk. */ + TkTextSegment *segPtr; /* Segment corresponding to indexPtr. */ + int offset; /* Offset within segPtr corresponding to + * indexPtr (always 0). */ + int maxX; /* Chunk must not occupy pixels at this + * position or higher. */ + int maxChars; /* Chunk must not include more than this + * many characters. */ + int noCharsYet; /* Non-zero means no characters have been + * assigned to this line yet. */ + Tk_Uid wrapMode; /* Not used. */ + register TkTextDispChunk *chunkPtr; + /* Structure to fill in with information + * about this chunk. The x field has already + * been set by the caller. */ +{ + if (segPtr != textPtr->insertMarkPtr) { + return -1; + } + + chunkPtr->displayProc = TkTextInsertDisplayProc; + chunkPtr->undisplayProc = InsertUndisplayProc; + chunkPtr->measureProc = (Tk_ChunkMeasureProc *) NULL; + chunkPtr->bboxProc = (Tk_ChunkBboxProc *) NULL; + chunkPtr->numChars = 0; + chunkPtr->minAscent = 0; + chunkPtr->minDescent = 0; + chunkPtr->minHeight = 0; + chunkPtr->width = 0; + + /* + * Note: can't break a line after the insertion cursor: this + * prevents the insertion cursor from being stranded at the end + * of a line. + */ + + chunkPtr->breakIndex = -1; + chunkPtr->clientData = (ClientData) textPtr; + return 1; +} + +/* + *-------------------------------------------------------------- + * + * TkTextInsertDisplayProc -- + * + * This procedure is called to display the insertion + * cursor. + * + * Results: + * None. + * + * Side effects: + * Graphics are drawn. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +void +TkTextInsertDisplayProc(chunkPtr, x, y, height, baseline, display, dst, screenY) + TkTextDispChunk *chunkPtr; /* Chunk that is to be drawn. */ + int x; /* X-position in dst at which to + * draw this chunk (may differ from + * the x-position in the chunk because + * of scrolling). */ + int y; /* Y-position at which to draw this + * chunk in dst (x-position is in + * the chunk itself). */ + int height; /* Total height of line. */ + int baseline; /* Offset of baseline from y. */ + Display *display; /* Display to use for drawing. */ + Drawable dst; /* Pixmap or window in which to draw + * chunk. */ + int screenY; /* Y-coordinate in text window that + * corresponds to y. */ +{ + TkText *textPtr = (TkText *) chunkPtr->clientData; + int halfWidth = textPtr->insertWidth/2; + + if ((x + halfWidth) < 0) { + /* + * The insertion cursor is off-screen. Just return. + */ + + return; + } + + /* + * As a special hack to keep the cursor visible on mono displays + * (or anywhere else that the selection and insertion cursors + * have the same color) write the default background in the cursor + * area (instead of nothing) when the cursor isn't on. Otherwise + * the selection might hide the cursor. + */ + + if (textPtr->flags & INSERT_ON) { + Tk_Fill3DRectangle(textPtr->tkwin, dst, textPtr->insertBorder, + x - textPtr->insertWidth/2, y, textPtr->insertWidth, + height, textPtr->insertBorderWidth, TK_RELIEF_RAISED); + } else if (textPtr->selBorder == textPtr->insertBorder) { + Tk_Fill3DRectangle(textPtr->tkwin, dst, textPtr->border, + x - textPtr->insertWidth/2, y, textPtr->insertWidth, + height, 0, TK_RELIEF_FLAT); + } +} + +/* + *-------------------------------------------------------------- + * + * InsertUndisplayProc -- + * + * This procedure is called when the insertion cursor is no + * longer at a visible point on the display. It does nothing + * right now. + * + * Results: + * None. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +InsertUndisplayProc(textPtr, chunkPtr) + TkText *textPtr; /* Overall information about text + * widget. */ + TkTextDispChunk *chunkPtr; /* Chunk that is about to be freed. */ +{ + return; +} + +/* + *-------------------------------------------------------------- + * + * MarkCheckProc -- + * + * This procedure is invoked by the B-tree code to perform + * consistency checks on mark segments. + * + * Results: + * None. + * + * Side effects: + * The procedure panics if it detects anything wrong with + * the mark. + * + *-------------------------------------------------------------- + */ + +static void +MarkCheckProc(markPtr, linePtr) + TkTextSegment *markPtr; /* Segment to check. */ + TkTextLine *linePtr; /* Line containing segment. */ +{ + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; + + if (markPtr->body.mark.linePtr != linePtr) { + panic("MarkCheckProc: markPtr->body.mark.linePtr bogus"); + } + + /* + * Make sure that the mark is still present in the text's mark + * hash table. + */ + + for (hPtr = Tcl_FirstHashEntry(&markPtr->body.mark.textPtr->markTable, + &search); hPtr != markPtr->body.mark.hPtr; + hPtr = Tcl_NextHashEntry(&search)) { + if (hPtr == NULL) { + panic("MarkCheckProc couldn't find hash table entry for mark"); + } + } +} + +/* + *-------------------------------------------------------------- + * + * MarkFindNext -- + * + * This procedure searches forward for the next mark. + * + * Results: + * A standard Tcl result, which is a mark name or an empty string. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static int +MarkFindNext(interp, textPtr, string) + Tcl_Interp *interp; /* For error reporting */ + TkText *textPtr; /* The widget */ + char *string; /* The starting index or mark name */ +{ + TkTextIndex index; + Tcl_HashEntry *hPtr; + register TkTextSegment *segPtr; + int offset; + + + hPtr = Tcl_FindHashEntry(&textPtr->markTable, string); + if (hPtr != NULL) { + /* + * If given a mark name, return the next mark in the list of + * segments, even if it happens to be at the same character position. + */ + segPtr = (TkTextSegment *) Tcl_GetHashValue(hPtr); + TkTextMarkSegToIndex(textPtr, segPtr, &index); + segPtr = segPtr->nextPtr; + } else { + /* + * For non-mark name indices we want to return any marks that + * are right at the index. + */ + if (TkTextGetIndex(interp, textPtr, string, &index) != TCL_OK) { + return TCL_ERROR; + } + for (offset = 0, segPtr = index.linePtr->segPtr; + segPtr != NULL && offset < index.charIndex; + offset += segPtr->size, segPtr = segPtr->nextPtr) { + /* Empty loop body */ ; + } + } + while (1) { + /* + * segPtr points at the first possible candidate, + * or NULL if we ran off the end of the line. + */ + for ( ; segPtr != NULL ; segPtr = segPtr->nextPtr) { + if (segPtr->typePtr == &tkTextRightMarkType || + segPtr->typePtr == &tkTextLeftMarkType) { + Tcl_SetResult(interp, + Tcl_GetHashKey(&textPtr->markTable, segPtr->body.mark.hPtr), + TCL_STATIC); + return TCL_OK; + } + } + index.linePtr = TkBTreeNextLine(index.linePtr); + if (index.linePtr == (TkTextLine *) NULL) { + return TCL_OK; + } + index.charIndex = 0; + segPtr = index.linePtr->segPtr; + } +} + +/* + *-------------------------------------------------------------- + * + * MarkFindPrev -- + * + * This procedure searches backwards for the previous mark. + * + * Results: + * A standard Tcl result, which is a mark name or an empty string. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static int +MarkFindPrev(interp, textPtr, string) + Tcl_Interp *interp; /* For error reporting */ + TkText *textPtr; /* The widget */ + char *string; /* The starting index or mark name */ +{ + TkTextIndex index; + Tcl_HashEntry *hPtr; + register TkTextSegment *segPtr, *seg2Ptr, *prevPtr; + int offset; + + + hPtr = Tcl_FindHashEntry(&textPtr->markTable, string); + if (hPtr != NULL) { + /* + * If given a mark name, return the previous mark in the list of + * segments, even if it happens to be at the same character position. + */ + segPtr = (TkTextSegment *) Tcl_GetHashValue(hPtr); + TkTextMarkSegToIndex(textPtr, segPtr, &index); + } else { + /* + * For non-mark name indices we do not return any marks that + * are right at the index. + */ + if (TkTextGetIndex(interp, textPtr, string, &index) != TCL_OK) { + return TCL_ERROR; + } + for (offset = 0, segPtr = index.linePtr->segPtr; + segPtr != NULL && offset < index.charIndex; + offset += segPtr->size, segPtr = segPtr->nextPtr) { + /* Empty loop body */ ; + } + } + while (1) { + /* + * segPtr points just past the first possible candidate, + * or at the begining of the line. + */ + for (prevPtr = NULL, seg2Ptr = index.linePtr->segPtr; + seg2Ptr != NULL && seg2Ptr != segPtr; + seg2Ptr = seg2Ptr->nextPtr) { + if (seg2Ptr->typePtr == &tkTextRightMarkType || + seg2Ptr->typePtr == &tkTextLeftMarkType) { + prevPtr = seg2Ptr; + } + } + if (prevPtr != NULL) { + Tcl_SetResult(interp, + Tcl_GetHashKey(&textPtr->markTable, prevPtr->body.mark.hPtr), + TCL_STATIC); + return TCL_OK; + } + index.linePtr = TkBTreePreviousLine(index.linePtr); + if (index.linePtr == (TkTextLine *) NULL) { + return TCL_OK; + } + segPtr = NULL; + } +} diff --git a/generic/tkTextTag.c b/generic/tkTextTag.c new file mode 100644 index 0000000..b5b04be --- /dev/null +++ b/generic/tkTextTag.c @@ -0,0 +1,1376 @@ +/* + * tkTextTag.c -- + * + * This module implements the "tag" subcommand of the widget command + * for text widgets, plus most of the other high-level functions + * related to tags. + * + * Copyright (c) 1992-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkTextTag.c 1.39 97/02/07 13:51:52 + */ + +#include "default.h" +#include "tkPort.h" +#include "tk.h" +#include "tkText.h" + +/* + * Information used for parsing tag configuration information: + */ + +static Tk_ConfigSpec tagConfigSpecs[] = { + {TK_CONFIG_BORDER, "-background", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(TkTextTag, border), TK_CONFIG_NULL_OK}, + {TK_CONFIG_BITMAP, "-bgstipple", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(TkTextTag, bgStipple), TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-borderwidth", (char *) NULL, (char *) NULL, + "0", Tk_Offset(TkTextTag, bdString), + TK_CONFIG_DONT_SET_DEFAULT|TK_CONFIG_NULL_OK}, + {TK_CONFIG_BITMAP, "-fgstipple", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(TkTextTag, fgStipple), TK_CONFIG_NULL_OK}, + {TK_CONFIG_FONT, "-font", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(TkTextTag, tkfont), TK_CONFIG_NULL_OK}, + {TK_CONFIG_COLOR, "-foreground", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(TkTextTag, fgColor), TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-justify", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(TkTextTag, justifyString), TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-lmargin1", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(TkTextTag, lMargin1String), TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-lmargin2", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(TkTextTag, lMargin2String), TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-offset", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(TkTextTag, offsetString), TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-overstrike", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(TkTextTag, overstrikeString), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-relief", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(TkTextTag, reliefString), TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-rmargin", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(TkTextTag, rMarginString), TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-spacing1", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(TkTextTag, spacing1String), TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-spacing2", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(TkTextTag, spacing2String), TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-spacing3", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(TkTextTag, spacing3String), TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-tabs", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(TkTextTag, tabString), TK_CONFIG_NULL_OK}, + {TK_CONFIG_STRING, "-underline", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(TkTextTag, underlineString), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_UID, "-wrap", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(TkTextTag, wrapMode), + TK_CONFIG_NULL_OK}, + {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, 0} +}; + +/* + * Forward declarations for procedures defined later in this file: + */ + +static void ChangeTagPriority _ANSI_ARGS_((TkText *textPtr, + TkTextTag *tagPtr, int prio)); +static TkTextTag * FindTag _ANSI_ARGS_((Tcl_Interp *interp, + TkText *textPtr, char *tagName)); +static void SortTags _ANSI_ARGS_((int numTags, + TkTextTag **tagArrayPtr)); +static int TagSortProc _ANSI_ARGS_((CONST VOID *first, + CONST VOID *second)); + +/* + *-------------------------------------------------------------- + * + * TkTextTagCmd -- + * + * This procedure is invoked to process the "tag" options of + * the widget command for text widgets. See the user documentation + * for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +int +TkTextTagCmd(textPtr, interp, argc, argv) + register TkText *textPtr; /* Information about text widget. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. Someone else has already + * parsed this command enough to know that + * argv[1] is "tag". */ +{ + int c, i, addTag; + size_t length; + char *fullOption; + register TkTextTag *tagPtr; + TkTextIndex first, last, index1, index2; + + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " tag option ?arg arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + c = argv[2][0]; + length = strlen(argv[2]); + if ((c == 'a') && (strncmp(argv[2], "add", length) == 0)) { + fullOption = "add"; + addTag = 1; + + addAndRemove: + if (argc < 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " tag ", fullOption, + " tagName index1 ?index2 index1 index2 ...?\"", + (char *) NULL); + return TCL_ERROR; + } + tagPtr = TkTextCreateTag(textPtr, argv[3]); + for (i = 4; i < argc; i += 2) { + if (TkTextGetIndex(interp, textPtr, argv[i], &index1) != TCL_OK) { + return TCL_ERROR; + } + if (argc > (i+1)) { + if (TkTextGetIndex(interp, textPtr, argv[i+1], &index2) + != TCL_OK) { + return TCL_ERROR; + } + if (TkTextIndexCmp(&index1, &index2) >= 0) { + return TCL_OK; + } + } else { + index2 = index1; + TkTextIndexForwChars(&index2, 1, &index2); + } + + if (tagPtr->affectsDisplay) { + TkTextRedrawTag(textPtr, &index1, &index2, tagPtr, !addTag); + } else { + /* + * Still need to trigger enter/leave events on tags that + * have changed. + */ + + TkTextEventuallyRepick(textPtr); + } + TkBTreeTag(&index1, &index2, tagPtr, addTag); + + /* + * If the tag is "sel" then grab the selection if we're supposed + * to export it and don't already have it. Also, invalidate + * partially-completed selection retrievals. + */ + + if (tagPtr == textPtr->selTagPtr) { + if (addTag && textPtr->exportSelection + && !(textPtr->flags & GOT_SELECTION)) { + Tk_OwnSelection(textPtr->tkwin, XA_PRIMARY, + TkTextLostSelection, (ClientData) textPtr); + textPtr->flags |= GOT_SELECTION; + } + textPtr->abortSelections = 1; + } + } + } else if ((c == 'b') && (strncmp(argv[2], "bind", length) == 0)) { + if ((argc < 4) || (argc > 6)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " tag bind tagName ?sequence? ?command?\"", + (char *) NULL); + return TCL_ERROR; + } + tagPtr = TkTextCreateTag(textPtr, argv[3]); + + /* + * Make a binding table if the widget doesn't already have + * one. + */ + + if (textPtr->bindingTable == NULL) { + textPtr->bindingTable = Tk_CreateBindingTable(interp); + } + + if (argc == 6) { + int append = 0; + unsigned long mask; + + if (argv[5][0] == 0) { + return Tk_DeleteBinding(interp, textPtr->bindingTable, + (ClientData) tagPtr, argv[4]); + } + if (argv[5][0] == '+') { + argv[5]++; + append = 1; + } + mask = Tk_CreateBinding(interp, textPtr->bindingTable, + (ClientData) tagPtr, argv[4], argv[5], append); + if (mask == 0) { + return TCL_ERROR; + } + if (mask & (unsigned) ~(ButtonMotionMask|Button1MotionMask + |Button2MotionMask|Button3MotionMask|Button4MotionMask + |Button5MotionMask|ButtonPressMask|ButtonReleaseMask + |EnterWindowMask|LeaveWindowMask|KeyPressMask + |KeyReleaseMask|PointerMotionMask|VirtualEventMask)) { + Tk_DeleteBinding(interp, textPtr->bindingTable, + (ClientData) tagPtr, argv[4]); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "requested illegal events; ", + "only key, button, motion, enter, leave, and virtual ", + "events may be used", (char *) NULL); + return TCL_ERROR; + } + } else if (argc == 5) { + char *command; + + command = Tk_GetBinding(interp, textPtr->bindingTable, + (ClientData) tagPtr, argv[4]); + if (command == NULL) { + return TCL_ERROR; + } + interp->result = command; + } else { + Tk_GetAllBindings(interp, textPtr->bindingTable, + (ClientData) tagPtr); + } + } else if ((c == 'c') && (strncmp(argv[2], "cget", length) == 0) + && (length >= 2)) { + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " tag cget tagName option\"", + (char *) NULL); + return TCL_ERROR; + } + tagPtr = FindTag(interp, textPtr, argv[3]); + if (tagPtr == NULL) { + return TCL_ERROR; + } + return Tk_ConfigureValue(interp, textPtr->tkwin, tagConfigSpecs, + (char *) tagPtr, argv[4], 0); + } else if ((c == 'c') && (strncmp(argv[2], "configure", length) == 0) + && (length >= 2)) { + if (argc < 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " tag configure tagName ?option? ?value? ", + "?option value ...?\"", (char *) NULL); + return TCL_ERROR; + } + tagPtr = TkTextCreateTag(textPtr, argv[3]); + if (argc == 4) { + return Tk_ConfigureInfo(interp, textPtr->tkwin, tagConfigSpecs, + (char *) tagPtr, (char *) NULL, 0); + } else if (argc == 5) { + return Tk_ConfigureInfo(interp, textPtr->tkwin, tagConfigSpecs, + (char *) tagPtr, argv[4], 0); + } else { + int result; + + result = Tk_ConfigureWidget(interp, textPtr->tkwin, tagConfigSpecs, + argc-4, argv+4, (char *) tagPtr, 0); + /* + * Some of the configuration options, like -underline + * and -justify, require additional translation (this is + * needed because we need to distinguish a particular value + * of an option from "unspecified"). + */ + + if (tagPtr->bdString != NULL) { + if (Tk_GetPixels(interp, textPtr->tkwin, tagPtr->bdString, + &tagPtr->borderWidth) != TCL_OK) { + return TCL_ERROR; + } + if (tagPtr->borderWidth < 0) { + tagPtr->borderWidth = 0; + } + } + if (tagPtr->reliefString != NULL) { + if (Tk_GetRelief(interp, tagPtr->reliefString, + &tagPtr->relief) != TCL_OK) { + return TCL_ERROR; + } + } + if (tagPtr->justifyString != NULL) { + if (Tk_GetJustify(interp, tagPtr->justifyString, + &tagPtr->justify) != TCL_OK) { + return TCL_ERROR; + } + } + if (tagPtr->lMargin1String != NULL) { + if (Tk_GetPixels(interp, textPtr->tkwin, + tagPtr->lMargin1String, &tagPtr->lMargin1) != TCL_OK) { + return TCL_ERROR; + } + } + if (tagPtr->lMargin2String != NULL) { + if (Tk_GetPixels(interp, textPtr->tkwin, + tagPtr->lMargin2String, &tagPtr->lMargin2) != TCL_OK) { + return TCL_ERROR; + } + } + if (tagPtr->offsetString != NULL) { + if (Tk_GetPixels(interp, textPtr->tkwin, tagPtr->offsetString, + &tagPtr->offset) != TCL_OK) { + return TCL_ERROR; + } + } + if (tagPtr->overstrikeString != NULL) { + if (Tcl_GetBoolean(interp, tagPtr->overstrikeString, + &tagPtr->overstrike) != TCL_OK) { + return TCL_ERROR; + } + } + if (tagPtr->rMarginString != NULL) { + if (Tk_GetPixels(interp, textPtr->tkwin, + tagPtr->rMarginString, &tagPtr->rMargin) != TCL_OK) { + return TCL_ERROR; + } + } + if (tagPtr->spacing1String != NULL) { + if (Tk_GetPixels(interp, textPtr->tkwin, + tagPtr->spacing1String, &tagPtr->spacing1) != TCL_OK) { + return TCL_ERROR; + } + if (tagPtr->spacing1 < 0) { + tagPtr->spacing1 = 0; + } + } + if (tagPtr->spacing2String != NULL) { + if (Tk_GetPixels(interp, textPtr->tkwin, + tagPtr->spacing2String, &tagPtr->spacing2) != TCL_OK) { + return TCL_ERROR; + } + if (tagPtr->spacing2 < 0) { + tagPtr->spacing2 = 0; + } + } + if (tagPtr->spacing3String != NULL) { + if (Tk_GetPixels(interp, textPtr->tkwin, + tagPtr->spacing3String, &tagPtr->spacing3) != TCL_OK) { + return TCL_ERROR; + } + if (tagPtr->spacing3 < 0) { + tagPtr->spacing3 = 0; + } + } + if (tagPtr->tabArrayPtr != NULL) { + ckfree((char *) tagPtr->tabArrayPtr); + tagPtr->tabArrayPtr = NULL; + } + if (tagPtr->tabString != NULL) { + tagPtr->tabArrayPtr = TkTextGetTabs(interp, textPtr->tkwin, + tagPtr->tabString); + if (tagPtr->tabArrayPtr == NULL) { + return TCL_ERROR; + } + } + if (tagPtr->underlineString != NULL) { + if (Tcl_GetBoolean(interp, tagPtr->underlineString, + &tagPtr->underline) != TCL_OK) { + return TCL_ERROR; + } + } + if ((tagPtr->wrapMode != NULL) + && (tagPtr->wrapMode != tkTextCharUid) + && (tagPtr->wrapMode != tkTextNoneUid) + && (tagPtr->wrapMode != tkTextWordUid)) { + Tcl_AppendResult(interp, "bad wrap mode \"", tagPtr->wrapMode, + "\": must be char, none, or word", (char *) NULL); + tagPtr->wrapMode = NULL; + return TCL_ERROR; + } + + /* + * If the "sel" tag was changed, be sure to mirror information + * from the tag back into the text widget record. NOTE: we + * don't have to free up information in the widget record + * before overwriting it, because it was mirrored in the tag + * and hence freed when the tag field was overwritten. + */ + + if (tagPtr == textPtr->selTagPtr) { + textPtr->selBorder = tagPtr->border; + textPtr->selBdString = tagPtr->bdString; + textPtr->selFgColorPtr = tagPtr->fgColor; + } + tagPtr->affectsDisplay = 0; + if ((tagPtr->border != NULL) + || (tagPtr->bdString != NULL) + || (tagPtr->reliefString != NULL) + || (tagPtr->bgStipple != None) + || (tagPtr->fgColor != NULL) || (tagPtr->tkfont != None) + || (tagPtr->fgStipple != None) + || (tagPtr->justifyString != NULL) + || (tagPtr->lMargin1String != NULL) + || (tagPtr->lMargin2String != NULL) + || (tagPtr->offsetString != NULL) + || (tagPtr->overstrikeString != NULL) + || (tagPtr->rMarginString != NULL) + || (tagPtr->spacing1String != NULL) + || (tagPtr->spacing2String != NULL) + || (tagPtr->spacing3String != NULL) + || (tagPtr->tabString != NULL) + || (tagPtr->underlineString != NULL) + || (tagPtr->wrapMode != NULL)) { + tagPtr->affectsDisplay = 1; + } + TkTextRedrawTag(textPtr, (TkTextIndex *) NULL, + (TkTextIndex *) NULL, tagPtr, 1); + return result; + } + } else if ((c == 'd') && (strncmp(argv[2], "delete", length) == 0)) { + Tcl_HashEntry *hPtr; + + if (argc < 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " tag delete tagName tagName ...\"", + (char *) NULL); + return TCL_ERROR; + } + for (i = 3; i < argc; i++) { + hPtr = Tcl_FindHashEntry(&textPtr->tagTable, argv[i]); + if (hPtr == NULL) { + continue; + } + tagPtr = (TkTextTag *) Tcl_GetHashValue(hPtr); + if (tagPtr == textPtr->selTagPtr) { + continue; + } + if (tagPtr->affectsDisplay) { + 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); + Tcl_DeleteHashEntry(hPtr); + if (textPtr->bindingTable != NULL) { + Tk_DeleteAllBindings(textPtr->bindingTable, + (ClientData) tagPtr); + } + + /* + * Update the tag priorities to reflect the deletion of this tag. + */ + + ChangeTagPriority(textPtr, tagPtr, textPtr->numTags-1); + textPtr->numTags -= 1; + TkTextFreeTag(textPtr, tagPtr); + } + } else if ((c == 'l') && (strncmp(argv[2], "lower", length) == 0)) { + TkTextTag *tagPtr2; + int prio; + + if ((argc != 4) && (argc != 5)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " tag lower tagName ?belowThis?\"", + (char *) NULL); + return TCL_ERROR; + } + tagPtr = FindTag(interp, textPtr, argv[3]); + if (tagPtr == NULL) { + return TCL_ERROR; + } + if (argc == 5) { + tagPtr2 = FindTag(interp, textPtr, argv[4]); + if (tagPtr2 == NULL) { + return TCL_ERROR; + } + if (tagPtr->priority < tagPtr2->priority) { + prio = tagPtr2->priority - 1; + } else { + prio = tagPtr2->priority; + } + } else { + prio = 0; + } + ChangeTagPriority(textPtr, tagPtr, prio); + TkTextRedrawTag(textPtr, (TkTextIndex *) NULL, (TkTextIndex *) NULL, + tagPtr, 1); + } else if ((c == 'n') && (strncmp(argv[2], "names", length) == 0) + && (length >= 2)) { + TkTextTag **arrayPtr; + int arraySize; + + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " tag names ?index?\"", + (char *) NULL); + return TCL_ERROR; + } + if (argc == 3) { + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; + + arrayPtr = (TkTextTag **) ckalloc((unsigned) + (textPtr->numTags * sizeof(TkTextTag *))); + for (i = 0, hPtr = Tcl_FirstHashEntry(&textPtr->tagTable, &search); + hPtr != NULL; i++, hPtr = Tcl_NextHashEntry(&search)) { + arrayPtr[i] = (TkTextTag *) Tcl_GetHashValue(hPtr); + } + arraySize = textPtr->numTags; + } else { + if (TkTextGetIndex(interp, textPtr, argv[3], &index1) + != TCL_OK) { + return TCL_ERROR; + } + arrayPtr = TkBTreeGetTags(&index1, &arraySize); + if (arrayPtr == NULL) { + return TCL_OK; + } + } + SortTags(arraySize, arrayPtr); + for (i = 0; i < arraySize; i++) { + tagPtr = arrayPtr[i]; + Tcl_AppendElement(interp, tagPtr->name); + } + ckfree((char *) arrayPtr); + } else if ((c == 'n') && (strncmp(argv[2], "nextrange", length) == 0) + && (length >= 2)) { + TkTextSearch tSearch; + char position[TK_POS_CHARS]; + + if ((argc != 5) && (argc != 6)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " tag nextrange tagName index1 ?index2?\"", + (char *) NULL); + return TCL_ERROR; + } + tagPtr = FindTag((Tcl_Interp *) NULL, textPtr, argv[3]); + if (tagPtr == NULL) { + return TCL_OK; + } + if (TkTextGetIndex(interp, textPtr, argv[4], &index1) != TCL_OK) { + return TCL_ERROR; + } + TkTextMakeIndex(textPtr->tree, TkBTreeNumLines(textPtr->tree), + 0, &last); + if (argc == 5) { + index2 = last; + } else if (TkTextGetIndex(interp, textPtr, argv[5], &index2) + != TCL_OK) { + return TCL_ERROR; + } + + /* + * The search below is a bit tricky. Rather than use the B-tree + * facilities to stop the search at index2, let it search up + * until the end of the file but check for a position past index2 + * ourselves. The reason for doing it this way is that we only + * care whether the *start* of the range is before index2; once + * we find the start, we don't want TkBTreeNextTag to abort the + * search because the end of the range is after index2. + */ + + TkBTreeStartSearch(&index1, &last, tagPtr, &tSearch); + if (TkBTreeCharTagged(&index1, tagPtr)) { + TkTextSegment *segPtr; + int offset; + + /* + * The first character is tagged. See if there is an + * on-toggle just before the character. If not, then + * skip to the end of this tagged range. + */ + + for (segPtr = index1.linePtr->segPtr, offset = index1.charIndex; + offset >= 0; + offset -= segPtr->size, segPtr = segPtr->nextPtr) { + if ((offset == 0) && (segPtr->typePtr == &tkTextToggleOnType) + && (segPtr->body.toggle.tagPtr == tagPtr)) { + goto gotStart; + } + } + if (!TkBTreeNextTag(&tSearch)) { + return TCL_OK; + } + } + + /* + * Find the start of the tagged range. + */ + + if (!TkBTreeNextTag(&tSearch)) { + return TCL_OK; + } + gotStart: + if (TkTextIndexCmp(&tSearch.curIndex, &index2) >= 0) { + return TCL_OK; + } + TkTextPrintIndex(&tSearch.curIndex, position); + Tcl_AppendElement(interp, position); + TkBTreeNextTag(&tSearch); + TkTextPrintIndex(&tSearch.curIndex, position); + Tcl_AppendElement(interp, position); + } else if ((c == 'p') && (strncmp(argv[2], "prevrange", length) == 0) + && (length >= 2)) { + TkTextSearch tSearch; + char position1[TK_POS_CHARS]; + char position2[TK_POS_CHARS]; + + if ((argc != 5) && (argc != 6)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " tag prevrange tagName index1 ?index2?\"", + (char *) NULL); + return TCL_ERROR; + } + tagPtr = FindTag((Tcl_Interp *) NULL, textPtr, argv[3]); + if (tagPtr == NULL) { + return TCL_OK; + } + if (TkTextGetIndex(interp, textPtr, argv[4], &index1) != TCL_OK) { + return TCL_ERROR; + } + if (argc == 5) { + TkTextMakeIndex(textPtr->tree, 0, 0, &index2); + } else if (TkTextGetIndex(interp, textPtr, argv[5], &index2) + != TCL_OK) { + return TCL_ERROR; + } + + /* + * The search below is a bit weird. The previous toggle can be + * either an on or off toggle. If it is an on toggle, then we + * need to turn around and search forward for the end toggle. + * Otherwise we keep searching backwards. + */ + + TkBTreeStartSearchBack(&index1, &index2, tagPtr, &tSearch); + + if (!TkBTreePrevTag(&tSearch)) { + return TCL_OK; + } + if (tSearch.segPtr->typePtr == &tkTextToggleOnType) { + TkTextPrintIndex(&tSearch.curIndex, position1); + TkTextMakeIndex(textPtr->tree, TkBTreeNumLines(textPtr->tree), + 0, &last); + TkBTreeStartSearch(&tSearch.curIndex, &last, tagPtr, &tSearch); + TkBTreeNextTag(&tSearch); + TkTextPrintIndex(&tSearch.curIndex, position2); + } else { + TkTextPrintIndex(&tSearch.curIndex, position2); + TkBTreePrevTag(&tSearch); + if (TkTextIndexCmp(&tSearch.curIndex, &index2) < 0) { + return TCL_OK; + } + TkTextPrintIndex(&tSearch.curIndex, position1); + } + Tcl_AppendElement(interp, position1); + Tcl_AppendElement(interp, position2); + } else if ((c == 'r') && (strncmp(argv[2], "raise", length) == 0) + && (length >= 3)) { + TkTextTag *tagPtr2; + int prio; + + if ((argc != 4) && (argc != 5)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " tag raise tagName ?aboveThis?\"", + (char *) NULL); + return TCL_ERROR; + } + tagPtr = FindTag(interp, textPtr, argv[3]); + if (tagPtr == NULL) { + return TCL_ERROR; + } + if (argc == 5) { + tagPtr2 = FindTag(interp, textPtr, argv[4]); + if (tagPtr2 == NULL) { + return TCL_ERROR; + } + if (tagPtr->priority <= tagPtr2->priority) { + prio = tagPtr2->priority; + } else { + prio = tagPtr2->priority + 1; + } + } else { + prio = textPtr->numTags-1; + } + ChangeTagPriority(textPtr, tagPtr, prio); + TkTextRedrawTag(textPtr, (TkTextIndex *) NULL, (TkTextIndex *) NULL, + tagPtr, 1); + } else if ((c == 'r') && (strncmp(argv[2], "ranges", length) == 0) + && (length >= 3)) { + TkTextSearch tSearch; + char position[TK_POS_CHARS]; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " tag ranges tagName\"", (char *) NULL); + return TCL_ERROR; + } + tagPtr = FindTag((Tcl_Interp *) NULL, textPtr, argv[3]); + if (tagPtr == NULL) { + return TCL_OK; + } + TkTextMakeIndex(textPtr->tree, 0, 0, &first); + TkTextMakeIndex(textPtr->tree, TkBTreeNumLines(textPtr->tree), + 0, &last); + TkBTreeStartSearch(&first, &last, tagPtr, &tSearch); + if (TkBTreeCharTagged(&first, tagPtr)) { + TkTextPrintIndex(&first, position); + Tcl_AppendElement(interp, position); + } + while (TkBTreeNextTag(&tSearch)) { + TkTextPrintIndex(&tSearch.curIndex, position); + Tcl_AppendElement(interp, position); + } + } else if ((c == 'r') && (strncmp(argv[2], "remove", length) == 0) + && (length >= 2)) { + fullOption = "remove"; + addTag = 0; + goto addAndRemove; + } else { + Tcl_AppendResult(interp, "bad tag option \"", argv[2], + "\": must be add, bind, cget, configure, delete, lower, ", + "names, nextrange, raise, ranges, or remove", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TkTextCreateTag -- + * + * Find the record describing a tag within a given text widget, + * creating a new record if one doesn't already exist. + * + * Results: + * The return value is a pointer to the TkTextTag record for tagName. + * + * Side effects: + * A new tag record is created if there isn't one already defined + * for tagName. + * + *---------------------------------------------------------------------- + */ + +TkTextTag * +TkTextCreateTag(textPtr, tagName) + TkText *textPtr; /* Widget in which tag is being used. */ + char *tagName; /* Name of desired tag. */ +{ + register TkTextTag *tagPtr; + Tcl_HashEntry *hPtr; + int new; + + hPtr = Tcl_CreateHashEntry(&textPtr->tagTable, tagName, &new); + if (!new) { + return (TkTextTag *) Tcl_GetHashValue(hPtr); + } + + /* + * No existing entry. Create a new one, initialize it, and add a + * pointer to it to the hash table entry. + */ + + tagPtr = (TkTextTag *) ckalloc(sizeof(TkTextTag)); + tagPtr->name = Tcl_GetHashKey(&textPtr->tagTable, hPtr); + tagPtr->toggleCount = 0; + tagPtr->tagRootPtr = NULL; + tagPtr->priority = textPtr->numTags; + tagPtr->border = NULL; + tagPtr->bdString = NULL; + tagPtr->borderWidth = 0; + tagPtr->reliefString = NULL; + tagPtr->relief = TK_RELIEF_FLAT; + tagPtr->bgStipple = None; + tagPtr->fgColor = NULL; + tagPtr->tkfont = NULL; + tagPtr->fgStipple = None; + tagPtr->justifyString = NULL; + tagPtr->justify = TK_JUSTIFY_LEFT; + tagPtr->lMargin1String = NULL; + tagPtr->lMargin1 = 0; + tagPtr->lMargin2String = NULL; + tagPtr->lMargin2 = 0; + tagPtr->offsetString = NULL; + tagPtr->offset = 0; + tagPtr->overstrikeString = NULL; + tagPtr->overstrike = 0; + tagPtr->rMarginString = NULL; + tagPtr->rMargin = 0; + tagPtr->spacing1String = NULL; + tagPtr->spacing1 = 0; + tagPtr->spacing2String = NULL; + tagPtr->spacing2 = 0; + tagPtr->spacing3String = NULL; + tagPtr->spacing3 = 0; + tagPtr->tabString = NULL; + tagPtr->tabArrayPtr = NULL; + tagPtr->underlineString = NULL; + tagPtr->underline = 0; + tagPtr->wrapMode = NULL; + tagPtr->affectsDisplay = 0; + textPtr->numTags++; + Tcl_SetHashValue(hPtr, tagPtr); + return tagPtr; +} + +/* + *---------------------------------------------------------------------- + * + * FindTag -- + * + * See if tag is defined for a given widget. + * + * 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 + * is NULL. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static TkTextTag * +FindTag(interp, textPtr, tagName) + Tcl_Interp *interp; /* Interpreter to use for error message; + * if NULL, then don't record an error + * message. */ + TkText *textPtr; /* Widget in which tag is being used. */ + char *tagName; /* Name of desired tag. */ +{ + Tcl_HashEntry *hPtr; + + hPtr = Tcl_FindHashEntry(&textPtr->tagTable, tagName); + if (hPtr != NULL) { + return (TkTextTag *) Tcl_GetHashValue(hPtr); + } + if (interp != NULL) { + Tcl_AppendResult(interp, "tag \"", tagName, + "\" isn't defined in text widget", (char *) NULL); + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * TkTextFreeTag -- + * + * This procedure is called when a tag is deleted to free up the + * memory and other resources associated with the tag. + * + * Results: + * None. + * + * Side effects: + * Memory and other resources are freed. + * + *---------------------------------------------------------------------- + */ + +void +TkTextFreeTag(textPtr, tagPtr) + TkText *textPtr; /* Info about overall widget. */ + register TkTextTag *tagPtr; /* Tag being deleted. */ +{ + if (tagPtr->border != None) { + Tk_Free3DBorder(tagPtr->border); + } + if (tagPtr->bdString != NULL) { + ckfree(tagPtr->bdString); + } + if (tagPtr->reliefString != NULL) { + ckfree(tagPtr->reliefString); + } + if (tagPtr->bgStipple != None) { + Tk_FreeBitmap(textPtr->display, tagPtr->bgStipple); + } + if (tagPtr->fgColor != None) { + Tk_FreeColor(tagPtr->fgColor); + } + Tk_FreeFont(tagPtr->tkfont); + if (tagPtr->fgStipple != None) { + Tk_FreeBitmap(textPtr->display, tagPtr->fgStipple); + } + if (tagPtr->justifyString != NULL) { + ckfree(tagPtr->justifyString); + } + if (tagPtr->lMargin1String != NULL) { + ckfree(tagPtr->lMargin1String); + } + if (tagPtr->lMargin2String != NULL) { + ckfree(tagPtr->lMargin2String); + } + if (tagPtr->offsetString != NULL) { + ckfree(tagPtr->offsetString); + } + if (tagPtr->overstrikeString != NULL) { + ckfree(tagPtr->overstrikeString); + } + if (tagPtr->rMarginString != NULL) { + ckfree(tagPtr->rMarginString); + } + if (tagPtr->spacing1String != NULL) { + ckfree(tagPtr->spacing1String); + } + if (tagPtr->spacing2String != NULL) { + ckfree(tagPtr->spacing2String); + } + if (tagPtr->spacing3String != NULL) { + ckfree(tagPtr->spacing3String); + } + if (tagPtr->tabString != NULL) { + ckfree(tagPtr->tabString); + } + if (tagPtr->tabArrayPtr != NULL) { + ckfree((char *) tagPtr->tabArrayPtr); + } + if (tagPtr->underlineString != NULL) { + ckfree(tagPtr->underlineString); + } + ckfree((char *) tagPtr); +} + +/* + *---------------------------------------------------------------------- + * + * SortTags -- + * + * This procedure sorts an array of tag pointers in increasing + * order of priority, optimizing for the common case where the + * array is small. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +SortTags(numTags, tagArrayPtr) + int numTags; /* Number of tag pointers at *tagArrayPtr. */ + TkTextTag **tagArrayPtr; /* Pointer to array of pointers. */ +{ + int i, j, prio; + register TkTextTag **tagPtrPtr; + TkTextTag **maxPtrPtr, *tmp; + + if (numTags < 2) { + return; + } + if (numTags < 20) { + for (i = numTags-1; i > 0; i--, tagArrayPtr++) { + maxPtrPtr = tagPtrPtr = tagArrayPtr; + prio = tagPtrPtr[0]->priority; + for (j = i, tagPtrPtr++; j > 0; j--, tagPtrPtr++) { + if (tagPtrPtr[0]->priority < prio) { + prio = tagPtrPtr[0]->priority; + maxPtrPtr = tagPtrPtr; + } + } + tmp = *maxPtrPtr; + *maxPtrPtr = *tagArrayPtr; + *tagArrayPtr = tmp; + } + } else { + qsort((VOID *) tagArrayPtr, (unsigned) numTags, sizeof (TkTextTag *), + TagSortProc); + } +} + +/* + *---------------------------------------------------------------------- + * + * TagSortProc -- + * + * This procedure is called by qsort when sorting an array of + * tags in priority order. + * + * Results: + * The return value is -1 if the first argument should be before + * the second element (i.e. it has lower priority), 0 if it's + * equivalent (this should never happen!), and 1 if it should be + * after the second element. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TagSortProc(first, second) + CONST VOID *first, *second; /* Elements to be compared. */ +{ + TkTextTag *tagPtr1, *tagPtr2; + + tagPtr1 = * (TkTextTag **) first; + tagPtr2 = * (TkTextTag **) second; + return tagPtr1->priority - tagPtr2->priority; +} + +/* + *---------------------------------------------------------------------- + * + * ChangeTagPriority -- + * + * This procedure changes the priority of a tag by modifying + * its priority and the priorities of other tags that are affected + * by the change. + * + * Results: + * None. + * + * Side effects: + * Priorities may be changed for some or all of the tags in + * textPtr. The tags will be arranged so that there is exactly + * one tag at each priority level between 0 and textPtr->numTags-1, + * with tagPtr at priority "prio". + * + *---------------------------------------------------------------------- + */ + +static void +ChangeTagPriority(textPtr, tagPtr, prio) + TkText *textPtr; /* Information about text widget. */ + TkTextTag *tagPtr; /* Tag whose priority is to be + * changed. */ + int prio; /* New priority for tag. */ +{ + int low, high, delta; + register TkTextTag *tagPtr2; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + + if (prio < 0) { + prio = 0; + } + if (prio >= textPtr->numTags) { + prio = textPtr->numTags-1; + } + if (prio == tagPtr->priority) { + return; + } else if (prio < tagPtr->priority) { + low = prio; + high = tagPtr->priority-1; + delta = 1; + } else { + low = tagPtr->priority+1; + high = prio; + delta = -1; + } + for (hPtr = Tcl_FirstHashEntry(&textPtr->tagTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + tagPtr2 = (TkTextTag *) Tcl_GetHashValue(hPtr); + if ((tagPtr2->priority >= low) && (tagPtr2->priority <= high)) { + tagPtr2->priority += delta; + } + } + tagPtr->priority = prio; +} + +/* + *-------------------------------------------------------------- + * + * TkTextBindProc -- + * + * This procedure is invoked by the Tk dispatcher to handle + * events associated with bindings on items. + * + * Results: + * None. + * + * Side effects: + * Depends on the command invoked as part of the binding + * (if there was any). + * + *-------------------------------------------------------------- + */ + +void +TkTextBindProc(clientData, eventPtr) + ClientData clientData; /* Pointer to canvas structure. */ + XEvent *eventPtr; /* Pointer to X event that just + * happened. */ +{ + TkText *textPtr = (TkText *) clientData; + int repick = 0; + +# define AnyButtonMask (Button1Mask|Button2Mask|Button3Mask\ + |Button4Mask|Button5Mask) + + Tcl_Preserve((ClientData) textPtr); + + /* + * This code simulates grabs for mouse buttons by keeping track + * of whether a button is pressed and refusing to pick a new current + * character while a button is pressed. + */ + + if (eventPtr->type == ButtonPress) { + textPtr->flags |= BUTTON_DOWN; + } else if (eventPtr->type == ButtonRelease) { + int mask; + + switch (eventPtr->xbutton.button) { + case Button1: + mask = Button1Mask; + break; + case Button2: + mask = Button2Mask; + break; + case Button3: + mask = Button3Mask; + break; + case Button4: + mask = Button4Mask; + break; + case Button5: + mask = Button5Mask; + break; + default: + mask = 0; + break; + } + if ((eventPtr->xbutton.state & AnyButtonMask) == (unsigned) mask) { + textPtr->flags &= ~BUTTON_DOWN; + repick = 1; + } + } else if ((eventPtr->type == EnterNotify) + || (eventPtr->type == LeaveNotify)) { + if (eventPtr->xcrossing.state & AnyButtonMask) { + textPtr->flags |= BUTTON_DOWN; + } else { + textPtr->flags &= ~BUTTON_DOWN; + } + TkTextPickCurrent(textPtr, eventPtr); + goto done; + } else if (eventPtr->type == MotionNotify) { + if (eventPtr->xmotion.state & AnyButtonMask) { + textPtr->flags |= BUTTON_DOWN; + } else { + textPtr->flags &= ~BUTTON_DOWN; + } + TkTextPickCurrent(textPtr, eventPtr); + } + if ((textPtr->numCurTags > 0) && (textPtr->bindingTable != NULL) + && (textPtr->tkwin != NULL)) { + Tk_BindEvent(textPtr->bindingTable, eventPtr, textPtr->tkwin, + textPtr->numCurTags, (ClientData *) textPtr->curTagArrayPtr); + } + if (repick) { + unsigned int oldState; + + oldState = eventPtr->xbutton.state; + eventPtr->xbutton.state &= ~(Button1Mask|Button2Mask + |Button3Mask|Button4Mask|Button5Mask); + TkTextPickCurrent(textPtr, eventPtr); + eventPtr->xbutton.state = oldState; + } + + done: + Tcl_Release((ClientData) textPtr); +} + +/* + *-------------------------------------------------------------- + * + * TkTextPickCurrent -- + * + * Find the character containing the coordinates in an event + * and place the "current" mark on that character. If the + * "current" mark has moved then generate a fake leave event + * on the old current character and a fake enter event on the new + * current character. + * + * Results: + * None. + * + * Side effects: + * The current mark for textPtr may change. If it does, + * then the commands associated with character entry and leave + * could do just about anything. For example, the text widget + * might be deleted. It is up to the caller to protect itself + * with calls to Tcl_Preserve and Tcl_Release. + * + *-------------------------------------------------------------- + */ + +void +TkTextPickCurrent(textPtr, eventPtr) + register TkText *textPtr; /* Text widget in which to select + * current character. */ + XEvent *eventPtr; /* Event describing location of + * mouse cursor. Must be EnterWindow, + * LeaveWindow, ButtonRelease, or + * MotionNotify. */ +{ + TkTextIndex index; + TkTextTag **oldArrayPtr, **newArrayPtr; + TkTextTag **copyArrayPtr = NULL; /* Initialization needed to prevent + * compiler warning. */ + + int numOldTags, numNewTags, i, j, size; + XEvent event; + + /* + * If a button is down, then don't do anything at all; we'll be + * called again when all buttons are up, and we can repick then. + * This implements a form of mouse grabbing. + */ + + if (textPtr->flags & BUTTON_DOWN) { + if (((eventPtr->type == EnterNotify) || (eventPtr->type == LeaveNotify)) + && ((eventPtr->xcrossing.mode == NotifyGrab) + || (eventPtr->xcrossing.mode == NotifyUngrab))) { + /* + * Special case: the window is being entered or left because + * of a grab or ungrab. In this case, repick after all. + * Furthermore, clear BUTTON_DOWN to release the simulated + * grab. + */ + + textPtr->flags &= ~BUTTON_DOWN; + } else { + return; + } + } + + /* + * Save information about this event in the widget in case we have + * to synthesize more enter and leave events later (e.g. because a + * character was deleted, causing a new character to be underneath + * the mouse cursor). Also translate MotionNotify events into + * EnterNotify events, since that's what gets reported to event + * handlers when the current character changes. + */ + + if (eventPtr != &textPtr->pickEvent) { + if ((eventPtr->type == MotionNotify) + || (eventPtr->type == ButtonRelease)) { + textPtr->pickEvent.xcrossing.type = EnterNotify; + textPtr->pickEvent.xcrossing.serial = eventPtr->xmotion.serial; + textPtr->pickEvent.xcrossing.send_event + = eventPtr->xmotion.send_event; + textPtr->pickEvent.xcrossing.display = eventPtr->xmotion.display; + textPtr->pickEvent.xcrossing.window = eventPtr->xmotion.window; + textPtr->pickEvent.xcrossing.root = eventPtr->xmotion.root; + textPtr->pickEvent.xcrossing.subwindow = None; + textPtr->pickEvent.xcrossing.time = eventPtr->xmotion.time; + textPtr->pickEvent.xcrossing.x = eventPtr->xmotion.x; + textPtr->pickEvent.xcrossing.y = eventPtr->xmotion.y; + textPtr->pickEvent.xcrossing.x_root = eventPtr->xmotion.x_root; + textPtr->pickEvent.xcrossing.y_root = eventPtr->xmotion.y_root; + textPtr->pickEvent.xcrossing.mode = NotifyNormal; + textPtr->pickEvent.xcrossing.detail = NotifyNonlinear; + textPtr->pickEvent.xcrossing.same_screen + = eventPtr->xmotion.same_screen; + textPtr->pickEvent.xcrossing.focus = False; + textPtr->pickEvent.xcrossing.state = eventPtr->xmotion.state; + } else { + textPtr->pickEvent = *eventPtr; + } + } + + /* + * Find the new current character, then find and sort all of the + * tags associated with it. + */ + + if (textPtr->pickEvent.type != LeaveNotify) { + TkTextPixelIndex(textPtr, textPtr->pickEvent.xcrossing.x, + textPtr->pickEvent.xcrossing.y, &index); + newArrayPtr = TkBTreeGetTags(&index, &numNewTags); + SortTags(numNewTags, newArrayPtr); + } else { + newArrayPtr = NULL; + numNewTags = 0; + } + + /* + * Resort the tags associated with the previous marked character + * (the priorities might have changed), then make a copy of the + * new tags, and compare the old tags to the copy, nullifying + * any tags that are present in both groups (i.e. the tags that + * haven't changed). + */ + + SortTags(textPtr->numCurTags, textPtr->curTagArrayPtr); + if (numNewTags > 0) { + size = numNewTags * sizeof(TkTextTag *); + copyArrayPtr = (TkTextTag **) ckalloc((unsigned) size); + memcpy((VOID *) copyArrayPtr, (VOID *) newArrayPtr, (size_t) size); + for (i = 0; i < textPtr->numCurTags; i++) { + for (j = 0; j < numNewTags; j++) { + if (textPtr->curTagArrayPtr[i] == copyArrayPtr[j]) { + textPtr->curTagArrayPtr[i] = NULL; + copyArrayPtr[j] = NULL; + break; + } + } + } + } + + /* + * Invoke the binding system with a LeaveNotify event for all of + * the tags that have gone away. We have to be careful here, + * because it's possible that the binding could do something + * (like calling tkwait) that eventually modifies + * textPtr->curTagArrayPtr. To avoid problems in situations like + * this, update curTagArrayPtr to its new value before invoking + * any bindings, and don't use it any more here. + */ + + numOldTags = textPtr->numCurTags; + textPtr->numCurTags = numNewTags; + oldArrayPtr = textPtr->curTagArrayPtr; + textPtr->curTagArrayPtr = newArrayPtr; + if (numOldTags != 0) { + if ((textPtr->bindingTable != NULL) && (textPtr->tkwin != NULL)) { + event = textPtr->pickEvent; + event.type = LeaveNotify; + + /* + * Always use a detail of NotifyAncestor. Besides being + * consistent, this avoids problems where the binding code + * will discard NotifyInferior events. + */ + + event.xcrossing.detail = NotifyAncestor; + Tk_BindEvent(textPtr->bindingTable, &event, textPtr->tkwin, + numOldTags, (ClientData *) oldArrayPtr); + } + ckfree((char *) oldArrayPtr); + } + + /* + * Reset the "current" mark (be careful to recompute its location, + * since it might have changed during an event binding). Then + * invoke the binding system with an EnterNotify event for all of + * the tags that have just appeared. + */ + + TkTextPixelIndex(textPtr, textPtr->pickEvent.xcrossing.x, + textPtr->pickEvent.xcrossing.y, &index); + TkTextSetMark(textPtr, "current", &index); + if (numNewTags != 0) { + if ((textPtr->bindingTable != NULL) && (textPtr->tkwin != NULL)) { + event = textPtr->pickEvent; + event.type = EnterNotify; + event.xcrossing.detail = NotifyAncestor; + Tk_BindEvent(textPtr->bindingTable, &event, textPtr->tkwin, + numNewTags, (ClientData *) copyArrayPtr); + } + ckfree((char *) copyArrayPtr); + } +} diff --git a/generic/tkTextWind.c b/generic/tkTextWind.c new file mode 100644 index 0000000..6452d13 --- /dev/null +++ b/generic/tkTextWind.c @@ -0,0 +1,1176 @@ +/* + * tkTextWind.c -- + * + * This file contains code that allows arbitrary windows to be + * nested inside text widgets. It also implements the "window" + * widget command for texts. + * + * Copyright (c) 1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkTextWind.c 1.14 97/04/25 16:52:09 + */ + +#include "tk.h" +#include "tkText.h" +#include "tkPort.h" + +/* + * The following structure is the official type record for the + * embedded window geometry manager: + */ + +static void EmbWinRequestProc _ANSI_ARGS_((ClientData clientData, + Tk_Window tkwin)); +static void EmbWinLostSlaveProc _ANSI_ARGS_((ClientData clientData, + Tk_Window tkwin)); + +static Tk_GeomMgr textGeomType = { + "text", /* name */ + EmbWinRequestProc, /* requestProc */ + EmbWinLostSlaveProc, /* lostSlaveProc */ +}; + +/* + * Definitions for alignment values: + */ + +#define ALIGN_BOTTOM 0 +#define ALIGN_CENTER 1 +#define ALIGN_TOP 2 +#define ALIGN_BASELINE 3 + +/* + * Macro that determines the size of an embedded window segment: + */ + +#define EW_SEG_SIZE ((unsigned) (Tk_Offset(TkTextSegment, body) \ + + sizeof(TkTextEmbWindow))) + +/* + * Prototypes for procedures defined in this file: + */ + +static int AlignParseProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, Tk_Window tkwin, char *value, + char *widgRec, int offset)); +static char * AlignPrintProc _ANSI_ARGS_((ClientData clientData, + Tk_Window tkwin, char *widgRec, int offset, + Tcl_FreeProc **freeProcPtr)); +static TkTextSegment * EmbWinCleanupProc _ANSI_ARGS_((TkTextSegment *segPtr, + TkTextLine *linePtr)); +static void EmbWinCheckProc _ANSI_ARGS_((TkTextSegment *segPtr, + TkTextLine *linePtr)); +static void EmbWinBboxProc _ANSI_ARGS_((TkTextDispChunk *chunkPtr, + int index, int y, int lineHeight, int baseline, + int *xPtr, int *yPtr, int *widthPtr, + int *heightPtr)); +static int EmbWinConfigure _ANSI_ARGS_((TkText *textPtr, + TkTextSegment *ewPtr, int argc, char **argv)); +static void EmbWinDelayedUnmap _ANSI_ARGS_(( + ClientData clientData)); +static int EmbWinDeleteProc _ANSI_ARGS_((TkTextSegment *segPtr, + TkTextLine *linePtr, int treeGone)); +static void EmbWinDisplayProc _ANSI_ARGS_(( + TkTextDispChunk *chunkPtr, int x, int y, + int lineHeight, int baseline, Display *display, + Drawable dst, int screenY)); +static int EmbWinLayoutProc _ANSI_ARGS_((TkText *textPtr, + TkTextIndex *indexPtr, TkTextSegment *segPtr, + int offset, int maxX, int maxChars, + int noCharsYet, Tk_Uid wrapMode, + TkTextDispChunk *chunkPtr)); +static void EmbWinStructureProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +static void EmbWinUndisplayProc _ANSI_ARGS_((TkText *textPtr, + TkTextDispChunk *chunkPtr)); + +/* + * The following structure declares the "embedded window" segment type. + */ + +static Tk_SegType tkTextEmbWindowType = { + "window", /* name */ + 0, /* leftGravity */ + (Tk_SegSplitProc *) NULL, /* splitProc */ + EmbWinDeleteProc, /* deleteProc */ + EmbWinCleanupProc, /* cleanupProc */ + (Tk_SegLineChangeProc *) NULL, /* lineChangeProc */ + EmbWinLayoutProc, /* layoutProc */ + EmbWinCheckProc /* checkProc */ +}; + +/* + * Information used for parsing window configuration options: + */ + +static Tk_CustomOption alignOption = {AlignParseProc, AlignPrintProc, + (ClientData) NULL}; + +static Tk_ConfigSpec configSpecs[] = { + {TK_CONFIG_CUSTOM, "-align", (char *) NULL, (char *) NULL, + "center", 0, TK_CONFIG_DONT_SET_DEFAULT, &alignOption}, + {TK_CONFIG_STRING, "-create", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(TkTextEmbWindow, create), + TK_CONFIG_DONT_SET_DEFAULT|TK_CONFIG_NULL_OK}, + {TK_CONFIG_INT, "-padx", (char *) NULL, (char *) NULL, + "0", Tk_Offset(TkTextEmbWindow, padX), + TK_CONFIG_DONT_SET_DEFAULT}, + {TK_CONFIG_INT, "-pady", (char *) NULL, (char *) NULL, + "0", Tk_Offset(TkTextEmbWindow, padY), + TK_CONFIG_DONT_SET_DEFAULT}, + {TK_CONFIG_BOOLEAN, "-stretch", (char *) NULL, (char *) NULL, + "0", Tk_Offset(TkTextEmbWindow, stretch), + TK_CONFIG_DONT_SET_DEFAULT}, + {TK_CONFIG_WINDOW, "-window", (char *) NULL, (char *) NULL, + (char *) NULL, Tk_Offset(TkTextEmbWindow, tkwin), + TK_CONFIG_DONT_SET_DEFAULT|TK_CONFIG_NULL_OK}, + {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, 0} +}; + +/* + *-------------------------------------------------------------- + * + * TkTextWindowCmd -- + * + * This procedure implements the "window" widget command + * for text widgets. See the user documentation for details + * on what it does. + * + * Results: + * A standard Tcl result or error. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +int +TkTextWindowCmd(textPtr, interp, argc, argv) + register TkText *textPtr; /* Information about text widget. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. Someone else has already + * parsed this command enough to know that + * argv[1] is "window". */ +{ + size_t length; + register TkTextSegment *ewPtr; + + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " window option ?arg arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + length = strlen(argv[2]); + if ((strncmp(argv[2], "cget", length) == 0) && (length >= 2)) { + TkTextIndex index; + TkTextSegment *ewPtr; + + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " window cget index option\"", + (char *) NULL); + return TCL_ERROR; + } + if (TkTextGetIndex(interp, textPtr, argv[3], &index) != TCL_OK) { + return TCL_ERROR; + } + ewPtr = TkTextIndexToSeg(&index, (int *) NULL); + if (ewPtr->typePtr != &tkTextEmbWindowType) { + Tcl_AppendResult(interp, "no embedded window at index \"", + argv[3], "\"", (char *) NULL); + return TCL_ERROR; + } + return Tk_ConfigureValue(interp, textPtr->tkwin, configSpecs, + (char *) &ewPtr->body.ew, argv[4], 0); + } else if ((strncmp(argv[2], "configure", length) == 0) && (length >= 2)) { + TkTextIndex index; + TkTextSegment *ewPtr; + + if (argc < 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " window configure index ?option value ...?\"", + (char *) NULL); + return TCL_ERROR; + } + if (TkTextGetIndex(interp, textPtr, argv[3], &index) != TCL_OK) { + return TCL_ERROR; + } + ewPtr = TkTextIndexToSeg(&index, (int *) NULL); + if (ewPtr->typePtr != &tkTextEmbWindowType) { + Tcl_AppendResult(interp, "no embedded window at index \"", + argv[3], "\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 4) { + return Tk_ConfigureInfo(interp, textPtr->tkwin, configSpecs, + (char *) &ewPtr->body.ew, (char *) NULL, 0); + } else if (argc == 5) { + return Tk_ConfigureInfo(interp, textPtr->tkwin, configSpecs, + (char *) &ewPtr->body.ew, argv[4], 0); + } else { + TkTextChanged(textPtr, &index, &index); + return EmbWinConfigure(textPtr, ewPtr, argc-4, argv+4); + } + } else if ((strncmp(argv[2], "create", length) == 0) && (length >= 2)) { + TkTextIndex index; + int lineIndex; + + /* + * Add a new window. Find where to put the new window, and + * mark that position for redisplay. + */ + + if (argc < 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " window create index ?option value ...?\"", + (char *) NULL); + return TCL_ERROR; + } + if (TkTextGetIndex(interp, textPtr, argv[3], &index) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Don't allow insertions on the last (dummy) line of the text. + */ + + lineIndex = TkBTreeLineIndex(index.linePtr); + if (lineIndex == TkBTreeNumLines(textPtr->tree)) { + lineIndex--; + TkTextMakeIndex(textPtr->tree, lineIndex, 1000000, &index); + } + + /* + * Create the new window segment and initialize it. + */ + + ewPtr = (TkTextSegment *) ckalloc(EW_SEG_SIZE); + ewPtr->typePtr = &tkTextEmbWindowType; + ewPtr->size = 1; + ewPtr->body.ew.textPtr = textPtr; + ewPtr->body.ew.linePtr = NULL; + ewPtr->body.ew.tkwin = NULL; + ewPtr->body.ew.create = NULL; + ewPtr->body.ew.align = ALIGN_CENTER; + ewPtr->body.ew.padX = ewPtr->body.ew.padY = 0; + ewPtr->body.ew.stretch = 0; + ewPtr->body.ew.chunkCount = 0; + ewPtr->body.ew.displayed = 0; + + /* + * Link the segment into the text widget, then configure it (delete + * it again if the configuration fails). + */ + + TkTextChanged(textPtr, &index, &index); + TkBTreeLinkSegment(ewPtr, &index); + if (EmbWinConfigure(textPtr, ewPtr, argc-4, argv+4) != TCL_OK) { + TkTextIndex index2; + + TkTextIndexForwChars(&index, 1, &index2); + TkBTreeDeleteChars(&index, &index2); + return TCL_ERROR; + } + } else if (strncmp(argv[2], "names", length) == 0) { + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " window names\"", (char *) NULL); + return TCL_ERROR; + } + for (hPtr = Tcl_FirstHashEntry(&textPtr->windowTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + Tcl_AppendElement(interp, + Tcl_GetHashKey(&textPtr->markTable, hPtr)); + } + } else { + Tcl_AppendResult(interp, "bad window option \"", argv[2], + "\": must be cget, configure, create, or names", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * EmbWinConfigure -- + * + * This procedure is called to handle configuration options + * for an embedded window, using an argc/argv list. + * + * Results: + * The return value is a standard Tcl result. If TCL_ERROR is + * returned, then interp->result contains an error message.. + * + * Side effects: + * Configuration information for the embedded window changes, + * such as alignment, stretching, or name of the embedded + * window. + * + *-------------------------------------------------------------- + */ + +static int +EmbWinConfigure(textPtr, ewPtr, argc, argv) + TkText *textPtr; /* Information about text widget that + * contains embedded window. */ + TkTextSegment *ewPtr; /* Embedded window to be configured. */ + int argc; /* Number of strings in argv. */ + char **argv; /* Array of strings describing configuration + * options. */ +{ + Tk_Window oldWindow; + Tcl_HashEntry *hPtr; + int new; + + oldWindow = ewPtr->body.ew.tkwin; + if (Tk_ConfigureWidget(textPtr->interp, textPtr->tkwin, configSpecs, + argc, argv, (char *) &ewPtr->body.ew, TK_CONFIG_ARGV_ONLY) + != TCL_OK) { + return TCL_ERROR; + } + if (oldWindow != ewPtr->body.ew.tkwin) { + if (oldWindow != NULL) { + Tcl_DeleteHashEntry(Tcl_FindHashEntry(&textPtr->windowTable, + Tk_PathName(oldWindow))); + Tk_DeleteEventHandler(oldWindow, StructureNotifyMask, + EmbWinStructureProc, (ClientData) ewPtr); + Tk_ManageGeometry(oldWindow, (Tk_GeomMgr *) NULL, + (ClientData) NULL); + if (textPtr->tkwin != Tk_Parent(oldWindow)) { + Tk_UnmaintainGeometry(oldWindow, textPtr->tkwin); + } else { + Tk_UnmapWindow(oldWindow); + } + } + if (ewPtr->body.ew.tkwin != NULL) { + Tk_Window ancestor, parent; + + /* + * Make sure that the text is either the parent of the + * embedded window or a descendant of that parent. Also, + * don't allow a top-level window to be managed inside + * a text. + */ + + parent = Tk_Parent(ewPtr->body.ew.tkwin); + for (ancestor = textPtr->tkwin; ; + ancestor = Tk_Parent(ancestor)) { + if (ancestor == parent) { + break; + } + if (Tk_IsTopLevel(ancestor)) { + badMaster: + Tcl_AppendResult(textPtr->interp, "can't embed ", + Tk_PathName(ewPtr->body.ew.tkwin), " in ", + Tk_PathName(textPtr->tkwin), (char *) NULL); + ewPtr->body.ew.tkwin = NULL; + return TCL_ERROR; + } + } + if (Tk_IsTopLevel(ewPtr->body.ew.tkwin) + || (ewPtr->body.ew.tkwin == textPtr->tkwin)) { + goto badMaster; + } + + /* + * Take over geometry management for the window, plus create + * an event handler to find out when it is deleted. + */ + + Tk_ManageGeometry(ewPtr->body.ew.tkwin, &textGeomType, + (ClientData) ewPtr); + Tk_CreateEventHandler(ewPtr->body.ew.tkwin, StructureNotifyMask, + EmbWinStructureProc, (ClientData) ewPtr); + + /* + * Special trick! Must enter into the hash table *after* + * calling Tk_ManageGeometry: if the window was already managed + * elsewhere in this text, the Tk_ManageGeometry call will cause + * the entry to be removed, which could potentially lose the new + * entry. + */ + + hPtr = Tcl_CreateHashEntry(&textPtr->windowTable, + Tk_PathName(ewPtr->body.ew.tkwin), &new); + Tcl_SetHashValue(hPtr, ewPtr); + + } + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * AlignParseProc -- + * + * This procedure is invoked by Tk_ConfigureWidget during + * option processing to handle "-align" options for embedded + * windows. + * + * Results: + * A standard Tcl return value. + * + * Side effects: + * The alignment for the embedded window may change. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +AlignParseProc(clientData, interp, tkwin, value, widgRec, offset) + ClientData clientData; /* Not used.*/ + Tcl_Interp *interp; /* Used for reporting errors. */ + Tk_Window tkwin; /* Window for text widget. */ + char *value; /* Value of option. */ + char *widgRec; /* Pointer to TkTextEmbWindow + * structure. */ + int offset; /* Offset into item (ignored). */ +{ + register TkTextEmbWindow *embPtr = (TkTextEmbWindow *) widgRec; + + if (strcmp(value, "baseline") == 0) { + embPtr->align = ALIGN_BASELINE; + } else if (strcmp(value, "bottom") == 0) { + embPtr->align = ALIGN_BOTTOM; + } else if (strcmp(value, "center") == 0) { + embPtr->align = ALIGN_CENTER; + } else if (strcmp(value, "top") == 0) { + embPtr->align = ALIGN_TOP; + } else { + Tcl_AppendResult(interp, "bad alignment \"", value, + "\": must be baseline, bottom, center, or top", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * AlignPrintProc -- + * + * This procedure is invoked by the Tk configuration code + * to produce a printable string for the "-align" configuration + * option for embedded windows. + * + * Results: + * The return value is a string describing the embedded + * window's current alignment. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static char * +AlignPrintProc(clientData, tkwin, widgRec, offset, freeProcPtr) + ClientData clientData; /* Ignored. */ + Tk_Window tkwin; /* Window for text widget. */ + char *widgRec; /* Pointer to TkTextEmbWindow + * structure. */ + int offset; /* Ignored. */ + Tcl_FreeProc **freeProcPtr; /* Pointer to variable to fill in with + * information about how to reclaim + * storage for return string. */ +{ + switch (((TkTextEmbWindow *) widgRec)->align) { + case ALIGN_BASELINE: + return "baseline"; + case ALIGN_BOTTOM: + return "bottom"; + case ALIGN_CENTER: + return "center"; + case ALIGN_TOP: + return "top"; + default: + return "??"; + } +} + +/* + *-------------------------------------------------------------- + * + * EmbWinStructureProc -- + * + * This procedure is invoked by the Tk event loop whenever + * StructureNotify events occur for a window that's embedded + * in a text widget. This procedure's only purpose is to + * clean up when windows are deleted. + * + * Results: + * None. + * + * Side effects: + * The window is disassociated from the window segment, and + * the portion of the text is redisplayed. + * + *-------------------------------------------------------------- + */ + +static void +EmbWinStructureProc(clientData, eventPtr) + ClientData clientData; /* Pointer to record describing window item. */ + XEvent *eventPtr; /* Describes what just happened. */ +{ + register TkTextSegment *ewPtr = (TkTextSegment *) clientData; + TkTextIndex index; + + if (eventPtr->type != DestroyNotify) { + return; + } + + Tcl_DeleteHashEntry(Tcl_FindHashEntry(&ewPtr->body.ew.textPtr->windowTable, + Tk_PathName(ewPtr->body.ew.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); + TkTextChanged(ewPtr->body.ew.textPtr, &index, &index); +} + +/* + *-------------------------------------------------------------- + * + * EmbWinRequestProc -- + * + * This procedure is invoked whenever a window that's associated + * with a window canvas item changes its requested dimensions. + * + * Results: + * None. + * + * Side effects: + * The size and location on the screen of the window may change, + * depending on the options specified for the window item. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +EmbWinRequestProc(clientData, tkwin) + ClientData clientData; /* Pointer to record for window item. */ + Tk_Window tkwin; /* Window that changed its desired + * size. */ +{ + TkTextSegment *ewPtr = (TkTextSegment *) clientData; + TkTextIndex index; + + index.tree = ewPtr->body.ew.textPtr->tree; + index.linePtr = ewPtr->body.ew.linePtr; + index.charIndex = TkTextSegToOffset(ewPtr, ewPtr->body.ew.linePtr); + TkTextChanged(ewPtr->body.ew.textPtr, &index, &index); +} + +/* + *-------------------------------------------------------------- + * + * EmbWinLostSlaveProc -- + * + * This procedure is invoked by the Tk geometry manager when + * a slave window managed by a text widget is claimed away + * by another geometry manager. + * + * Results: + * None. + * + * Side effects: + * The window is disassociated from the window segment, and + * the portion of the text is redisplayed. + * + *-------------------------------------------------------------- + */ + +static void +EmbWinLostSlaveProc(clientData, tkwin) + ClientData clientData; /* Pointer to record describing window item. */ + Tk_Window tkwin; /* Window that was claimed away by another + * geometry manager. */ +{ + register TkTextSegment *ewPtr = (TkTextSegment *) clientData; + TkTextIndex index; + + Tk_DeleteEventHandler(ewPtr->body.ew.tkwin, StructureNotifyMask, + EmbWinStructureProc, (ClientData) ewPtr); + Tcl_CancelIdleCall(EmbWinDelayedUnmap, (ClientData) ewPtr); + if (ewPtr->body.ew.textPtr->tkwin != Tk_Parent(tkwin)) { + Tk_UnmaintainGeometry(tkwin, ewPtr->body.ew.textPtr->tkwin); + } else { + Tk_UnmapWindow(tkwin); + } + Tcl_DeleteHashEntry(Tcl_FindHashEntry(&ewPtr->body.ew.textPtr->windowTable, + Tk_PathName(ewPtr->body.ew.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); + TkTextChanged(ewPtr->body.ew.textPtr, &index, &index); +} + +/* + *-------------------------------------------------------------- + * + * EmbWinDeleteProc -- + * + * This procedure is invoked by the text B-tree code whenever + * an embedded window lies in a range of characters being deleted. + * + * Results: + * Returns 0 to indicate that the deletion has been accepted. + * + * Side effects: + * The embedded window is deleted, if it exists, and any resources + * associated with it are released. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +EmbWinDeleteProc(ewPtr, linePtr, treeGone) + TkTextSegment *ewPtr; /* Segment being deleted. */ + TkTextLine *linePtr; /* Line containing segment. */ + int treeGone; /* Non-zero means the entire tree is + * being deleted, so everything must + * get cleaned up. */ +{ + Tcl_HashEntry *hPtr; + + if (ewPtr->body.ew.tkwin != NULL) { + hPtr = Tcl_FindHashEntry(&ewPtr->body.ew.textPtr->windowTable, + Tk_PathName(ewPtr->body.ew.tkwin)); + if (hPtr != NULL) { + /* + * (It's possible for there to be no hash table entry for this + * window, if an error occurred while creating the window segment + * but before the window got added to the table) + */ + + Tcl_DeleteHashEntry(hPtr); + } + + /* + * Delete the event handler for the window before destroying + * the window, so that EmbWinStructureProc doesn't get called + * (we'll already do everything that it would have done, and + * it will just get confused). + */ + + Tk_DeleteEventHandler(ewPtr->body.ew.tkwin, StructureNotifyMask, + EmbWinStructureProc, (ClientData) ewPtr); + Tk_DestroyWindow(ewPtr->body.ew.tkwin); + } + Tcl_CancelIdleCall(EmbWinDelayedUnmap, (ClientData) ewPtr); + Tk_FreeOptions(configSpecs, (char *) &ewPtr->body.ew, + ewPtr->body.ew.textPtr->display, 0); + ckfree((char *) ewPtr); + return 0; +} + +/* + *-------------------------------------------------------------- + * + * EmbWinCleanupProc -- + * + * This procedure is invoked by the B-tree code whenever a + * segment containing an embedded window is moved from one + * line to another. + * + * Results: + * None. + * + * Side effects: + * The linePtr field of the segment gets updated. + * + *-------------------------------------------------------------- + */ + +static TkTextSegment * +EmbWinCleanupProc(ewPtr, linePtr) + TkTextSegment *ewPtr; /* Mark segment that's being moved. */ + TkTextLine *linePtr; /* Line that now contains segment. */ +{ + ewPtr->body.ew.linePtr = linePtr; + return ewPtr; +} + +/* + *-------------------------------------------------------------- + * + * EmbWinLayoutProc -- + * + * This procedure is the "layoutProc" for embedded window + * segments. + * + * Results: + * 1 is returned to indicate that the segment should be + * displayed. The chunkPtr structure is filled in. + * + * Side effects: + * None, except for filling in chunkPtr. + * + *-------------------------------------------------------------- + */ + + /*ARGSUSED*/ +static int +EmbWinLayoutProc(textPtr, indexPtr, ewPtr, offset, maxX, maxChars, + noCharsYet, wrapMode, chunkPtr) + TkText *textPtr; /* Text widget being layed out. */ + TkTextIndex *indexPtr; /* Identifies first character in chunk. */ + TkTextSegment *ewPtr; /* Segment corresponding to indexPtr. */ + int offset; /* Offset within segPtr corresponding to + * indexPtr (always 0). */ + int maxX; /* Chunk must not occupy pixels at this + * position or higher. */ + int maxChars; /* Chunk must not include more than this + * many characters. */ + int noCharsYet; /* Non-zero means no characters have been + * assigned to this line yet. */ + Tk_Uid wrapMode; /* Wrap mode to use for line: tkTextCharUid, + * tkTextNoneUid, or tkTextWordUid. */ + register TkTextDispChunk *chunkPtr; + /* Structure to fill in with information + * about this chunk. The x field has already + * been set by the caller. */ +{ + int width, height; + + if (offset != 0) { + panic("Non-zero offset in EmbWinLayoutProc"); + } + + if ((ewPtr->body.ew.tkwin == NULL) && (ewPtr->body.ew.create != NULL)) { + int code, new; + Tcl_DString name; + Tk_Window ancestor; + Tcl_HashEntry *hPtr; + + /* + * The window doesn't currently exist. Create it by evaluating + * the creation script. The script must return the window's + * path name: look up that name to get back to the window + * token. Then register ourselves as the geometry manager for + * the window. + */ + + code = Tcl_GlobalEval(textPtr->interp, ewPtr->body.ew.create); + if (code != TCL_OK) { + createError: + Tcl_BackgroundError(textPtr->interp); + goto gotWindow; + } + Tcl_DStringInit(&name); + Tcl_DStringAppend(&name, textPtr->interp->result, -1); + Tcl_ResetResult(textPtr->interp); + ewPtr->body.ew.tkwin = Tk_NameToWindow(textPtr->interp, + Tcl_DStringValue(&name), textPtr->tkwin); + if (ewPtr->body.ew.tkwin == NULL) { + goto createError; + } + for (ancestor = textPtr->tkwin; ; + ancestor = Tk_Parent(ancestor)) { + if (ancestor == Tk_Parent(ewPtr->body.ew.tkwin)) { + break; + } + if (Tk_IsTopLevel(ancestor)) { + badMaster: + Tcl_AppendResult(textPtr->interp, "can't embed ", + Tk_PathName(ewPtr->body.ew.tkwin), " relative to ", + Tk_PathName(textPtr->tkwin), (char *) NULL); + Tcl_BackgroundError(textPtr->interp); + ewPtr->body.ew.tkwin = NULL; + goto gotWindow; + } + } + if (Tk_IsTopLevel(ewPtr->body.ew.tkwin) + || (textPtr->tkwin == ewPtr->body.ew.tkwin)) { + goto badMaster; + } + Tk_ManageGeometry(ewPtr->body.ew.tkwin, &textGeomType, + (ClientData) ewPtr); + Tk_CreateEventHandler(ewPtr->body.ew.tkwin, StructureNotifyMask, + EmbWinStructureProc, (ClientData) ewPtr); + + /* + * Special trick! Must enter into the hash table *after* + * calling Tk_ManageGeometry: if the window was already managed + * elsewhere in this text, the Tk_ManageGeometry call will cause + * the entry to be removed, which could potentially lose the new + * entry. + */ + + hPtr = Tcl_CreateHashEntry(&textPtr->windowTable, + Tk_PathName(ewPtr->body.ew.tkwin), &new); + Tcl_SetHashValue(hPtr, ewPtr); + } + + /* + * See if there's room for this window on this line. + */ + + gotWindow: + if (ewPtr->body.ew.tkwin == NULL) { + width = 0; + height = 0; + } else { + width = Tk_ReqWidth(ewPtr->body.ew.tkwin) + 2*ewPtr->body.ew.padX; + height = Tk_ReqHeight(ewPtr->body.ew.tkwin) + 2*ewPtr->body.ew.padY; + } + if ((width > (maxX - chunkPtr->x)) + && !noCharsYet && (textPtr->wrapMode != tkTextNoneUid)) { + return 0; + } + + /* + * Fill in the chunk structure. + */ + + chunkPtr->displayProc = EmbWinDisplayProc; + chunkPtr->undisplayProc = EmbWinUndisplayProc; + chunkPtr->measureProc = (Tk_ChunkMeasureProc *) NULL; + chunkPtr->bboxProc = EmbWinBboxProc; + chunkPtr->numChars = 1; + if (ewPtr->body.ew.align == ALIGN_BASELINE) { + chunkPtr->minAscent = height - ewPtr->body.ew.padY; + chunkPtr->minDescent = ewPtr->body.ew.padY; + chunkPtr->minHeight = 0; + } else { + chunkPtr->minAscent = 0; + chunkPtr->minDescent = 0; + chunkPtr->minHeight = height; + } + chunkPtr->width = width; + chunkPtr->breakIndex = -1; + chunkPtr->breakIndex = 1; + chunkPtr->clientData = (ClientData) ewPtr; + ewPtr->body.ew.chunkCount += 1; + return 1; +} + +/* + *-------------------------------------------------------------- + * + * EmbWinCheckProc -- + * + * This procedure is invoked by the B-tree code to perform + * consistency checks on embedded windows. + * + * Results: + * None. + * + * Side effects: + * The procedure panics if it detects anything wrong with + * the embedded window. + * + *-------------------------------------------------------------- + */ + +static void +EmbWinCheckProc(ewPtr, linePtr) + TkTextSegment *ewPtr; /* Segment to check. */ + TkTextLine *linePtr; /* Line containing segment. */ +{ + if (ewPtr->nextPtr == NULL) { + panic("EmbWinCheckProc: embedded window is last segment in line"); + } + if (ewPtr->size != 1) { + panic("EmbWinCheckProc: embedded window has size %d", ewPtr->size); + } +} + +/* + *-------------------------------------------------------------- + * + * EmbWinDisplayProc -- + * + * This procedure is invoked by the text displaying code + * when it is time to actually draw an embedded window + * chunk on the screen. + * + * Results: + * None. + * + * Side effects: + * The embedded window gets moved to the correct location + * and mapped onto the screen. + * + *-------------------------------------------------------------- + */ + +static void +EmbWinDisplayProc(chunkPtr, x, y, lineHeight, baseline, display, dst, screenY) + TkTextDispChunk *chunkPtr; /* Chunk that is to be drawn. */ + int x; /* X-position in dst at which to + * draw this chunk (differs from + * the x-position in the chunk because + * of scrolling). */ + int y; /* Top of rectangular bounding box + * for line: tells where to draw this + * chunk in dst (x-position is in + * the chunk itself). */ + int lineHeight; /* Total height of line. */ + int baseline; /* Offset of baseline from y. */ + Display *display; /* Display to use for drawing. */ + Drawable dst; /* Pixmap or window in which to draw */ + int screenY; /* Y-coordinate in text window that + * corresponds to y. */ +{ + TkTextSegment *ewPtr = (TkTextSegment *) chunkPtr->clientData; + int lineX, windowX, windowY, width, height; + Tk_Window tkwin; + + tkwin = ewPtr->body.ew.tkwin; + if (tkwin == NULL) { + return; + } + if ((x + chunkPtr->width) <= 0) { + /* + * The window is off-screen; just unmap it. + */ + + if (ewPtr->body.ew.textPtr->tkwin != Tk_Parent(tkwin)) { + Tk_UnmaintainGeometry(tkwin, ewPtr->body.ew.textPtr->tkwin); + } else { + Tk_UnmapWindow(tkwin); + } + return; + } + + /* + * Compute the window's location and size in the text widget, taking + * into account the align and stretch values for the window. + */ + + EmbWinBboxProc(chunkPtr, 0, screenY, lineHeight, baseline, &lineX, + &windowY, &width, &height); + windowX = lineX - chunkPtr->x + x; + + if (ewPtr->body.ew.textPtr->tkwin == Tk_Parent(tkwin)) { + if ((windowX != Tk_X(tkwin)) || (windowY != Tk_Y(tkwin)) + || (Tk_ReqWidth(tkwin) != Tk_Width(tkwin)) + || (height != Tk_Height(tkwin))) { + Tk_MoveResizeWindow(tkwin, windowX, windowY, width, height); + } + Tk_MapWindow(tkwin); + } else { + Tk_MaintainGeometry(tkwin, ewPtr->body.ew.textPtr->tkwin, + windowX, windowY, width, height); + } + + /* + * Mark the window as displayed so that it won't get unmapped. + */ + + ewPtr->body.ew.displayed = 1; +} + +/* + *-------------------------------------------------------------- + * + * EmbWinUndisplayProc -- + * + * This procedure is called when the chunk for an embedded + * window is no longer going to be displayed. It arranges + * for the window associated with the chunk to be unmapped. + * + * Results: + * None. + * + * Side effects: + * The window is scheduled for unmapping. + * + *-------------------------------------------------------------- + */ + +static void +EmbWinUndisplayProc(textPtr, chunkPtr) + TkText *textPtr; /* Overall information about text + * widget. */ + TkTextDispChunk *chunkPtr; /* Chunk that is about to be freed. */ +{ + TkTextSegment *ewPtr = (TkTextSegment *) chunkPtr->clientData; + + ewPtr->body.ew.chunkCount--; + if (ewPtr->body.ew.chunkCount == 0) { + /* + * Don't unmap the window immediately, since there's a good chance + * that it will immediately be redisplayed, perhaps even in the + * same place. Instead, schedule the window to be unmapped later; + * the call to EmbWinDelayedUnmap will be cancelled in the likely + * event that the unmap becomes unnecessary. + */ + + ewPtr->body.ew.displayed = 0; + Tcl_DoWhenIdle(EmbWinDelayedUnmap, (ClientData) ewPtr); + } +} + +/* + *-------------------------------------------------------------- + * + * EmbWinBboxProc -- + * + * This procedure is called to compute the bounding box of + * the area occupied by an embedded window. + * + * Results: + * There is no return value. *xPtr and *yPtr are filled in + * with the coordinates of the upper left corner of the + * window, and *widthPtr and *heightPtr are filled in with + * the dimensions of the window in pixels. Note: not all + * of the returned bbox is necessarily visible on the screen + * (the rightmost part might be off-screen to the right, + * and the bottommost part might be off-screen to the bottom). + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static void +EmbWinBboxProc(chunkPtr, index, y, lineHeight, baseline, xPtr, yPtr, + widthPtr, heightPtr) + TkTextDispChunk *chunkPtr; /* Chunk containing desired char. */ + int index; /* Index of desired character within + * the chunk. */ + int y; /* Topmost pixel in area allocated + * for this line. */ + int lineHeight; /* Total height of line. */ + int baseline; /* Location of line's baseline, in + * pixels measured down from y. */ + int *xPtr, *yPtr; /* Gets filled in with coords of + * character's upper-left pixel. */ + int *widthPtr; /* Gets filled in with width of + * character, in pixels. */ + int *heightPtr; /* Gets filled in with height of + * character, in pixels. */ +{ + TkTextSegment *ewPtr = (TkTextSegment *) chunkPtr->clientData; + Tk_Window tkwin; + + tkwin = ewPtr->body.ew.tkwin; + if (tkwin != NULL) { + *widthPtr = Tk_ReqWidth(tkwin); + *heightPtr = Tk_ReqHeight(tkwin); + } else { + *widthPtr = 0; + *heightPtr = 0; + } + *xPtr = chunkPtr->x + ewPtr->body.ew.padX; + if (ewPtr->body.ew.stretch) { + if (ewPtr->body.ew.align == ALIGN_BASELINE) { + *heightPtr = baseline - ewPtr->body.ew.padY; + } else { + *heightPtr = lineHeight - 2*ewPtr->body.ew.padY; + } + } + switch (ewPtr->body.ew.align) { + case ALIGN_BOTTOM: + *yPtr = y + (lineHeight - *heightPtr - ewPtr->body.ew.padY); + break; + case ALIGN_CENTER: + *yPtr = y + (lineHeight - *heightPtr)/2; + break; + case ALIGN_TOP: + *yPtr = y + ewPtr->body.ew.padY; + break; + case ALIGN_BASELINE: + *yPtr = y + (baseline - *heightPtr); + break; + } +} + +/* + *-------------------------------------------------------------- + * + * EmbWinDelayedUnmap -- + * + * This procedure is an idle handler that does the actual + * work of unmapping an embedded window. See the comment + * in EmbWinUndisplayProc for details. + * + * Results: + * None. + * + * Side effects: + * The window gets unmapped, unless its chunk reference count + * has become non-zero again. + * + *-------------------------------------------------------------- + */ + +static void +EmbWinDelayedUnmap(clientData) + ClientData clientData; /* Token for the window to + * be unmapped. */ +{ + TkTextSegment *ewPtr = (TkTextSegment *) clientData; + + if (!ewPtr->body.ew.displayed && (ewPtr->body.ew.tkwin != NULL)) { + if (ewPtr->body.ew.textPtr->tkwin != Tk_Parent(ewPtr->body.ew.tkwin)) { + Tk_UnmaintainGeometry(ewPtr->body.ew.tkwin, + ewPtr->body.ew.textPtr->tkwin); + } else { + Tk_UnmapWindow(ewPtr->body.ew.tkwin); + } + } +} + +/* + *-------------------------------------------------------------- + * + * TkTextWindowIndex -- + * + * Given the name of an embedded window within a text widget, + * returns an index corresponding to the window's position + * in the text. + * + * Results: + * The return value is 1 if there is an embedded window by + * the given name in the text widget, 0 otherwise. If the + * window exists, *indexPtr is filled in with its index. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +int +TkTextWindowIndex(textPtr, name, indexPtr) + TkText *textPtr; /* Text widget containing window. */ + char *name; /* Name of window. */ + TkTextIndex *indexPtr; /* Index information gets stored here. */ +{ + Tcl_HashEntry *hPtr; + TkTextSegment *ewPtr; + + hPtr = Tcl_FindHashEntry(&textPtr->windowTable, name); + if (hPtr == NULL) { + return 0; + } + ewPtr = (TkTextSegment *) Tcl_GetHashValue(hPtr); + indexPtr->tree = textPtr->tree; + indexPtr->linePtr = ewPtr->body.ew.linePtr; + indexPtr->charIndex = TkTextSegToOffset(ewPtr, indexPtr->linePtr); + return 1; +} diff --git a/generic/tkTrig.c b/generic/tkTrig.c new file mode 100644 index 0000000..52dd8ba --- /dev/null +++ b/generic/tkTrig.c @@ -0,0 +1,1467 @@ +/* + * tkTrig.c -- + * + * This file contains a collection of trigonometry utility + * routines that are used by Tk and in particular by the + * canvas code. It also has miscellaneous geometry functions + * used by canvases. + * + * Copyright (c) 1992-1994 The Regents of the University of California. + * Copyright (c) 1994 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 + */ + +#include +#include "tkInt.h" +#include "tkPort.h" +#include "tkCanvas.h" + +#undef MIN +#define MIN(a,b) (((a) < (b)) ? (a) : (b)) +#undef MAX +#define MAX(a,b) (((a) > (b)) ? (a) : (b)) +#ifndef PI +# define PI 3.14159265358979323846 +#endif /* PI */ + +/* + *-------------------------------------------------------------- + * + * TkLineToPoint -- + * + * Compute the distance from a point to a finite line segment. + * + * Results: + * The return value is the distance from the line segment + * whose end-points are *end1Ptr and *end2Ptr to the point + * given by *pointPtr. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +double +TkLineToPoint(end1Ptr, end2Ptr, pointPtr) + double end1Ptr[2]; /* Coordinates of first end-point of line. */ + double end2Ptr[2]; /* Coordinates of second end-point of line. */ + double pointPtr[2]; /* Points to coords for point. */ +{ + double x, y; + + /* + * Compute the point on the line that is closest to the + * point. This must be done separately for vertical edges, + * horizontal edges, and other edges. + */ + + if (end1Ptr[0] == end2Ptr[0]) { + + /* + * Vertical edge. + */ + + x = end1Ptr[0]; + if (end1Ptr[1] >= end2Ptr[1]) { + y = MIN(end1Ptr[1], pointPtr[1]); + y = MAX(y, end2Ptr[1]); + } else { + y = MIN(end2Ptr[1], pointPtr[1]); + y = MAX(y, end1Ptr[1]); + } + } else if (end1Ptr[1] == end2Ptr[1]) { + + /* + * Horizontal edge. + */ + + y = end1Ptr[1]; + if (end1Ptr[0] >= end2Ptr[0]) { + x = MIN(end1Ptr[0], pointPtr[0]); + x = MAX(x, end2Ptr[0]); + } else { + x = MIN(end2Ptr[0], pointPtr[0]); + x = MAX(x, end1Ptr[0]); + } + } else { + double m1, b1, m2, b2; + + /* + * The edge is neither horizontal nor vertical. Convert the + * edge to a line equation of the form y = m1*x + b1. Then + * compute a line perpendicular to this edge but passing + * through the point, also in the form y = m2*x + b2. + */ + + m1 = (end2Ptr[1] - end1Ptr[1])/(end2Ptr[0] - end1Ptr[0]); + b1 = end1Ptr[1] - m1*end1Ptr[0]; + m2 = -1.0/m1; + b2 = pointPtr[1] - m2*pointPtr[0]; + x = (b2 - b1)/(m1 - m2); + y = m1*x + b1; + if (end1Ptr[0] > end2Ptr[0]) { + if (x > end1Ptr[0]) { + x = end1Ptr[0]; + y = end1Ptr[1]; + } else if (x < end2Ptr[0]) { + x = end2Ptr[0]; + y = end2Ptr[1]; + } + } else { + if (x > end2Ptr[0]) { + x = end2Ptr[0]; + y = end2Ptr[1]; + } else if (x < end1Ptr[0]) { + x = end1Ptr[0]; + y = end1Ptr[1]; + } + } + } + + /* + * Compute the distance to the closest point. + */ + + return hypot(pointPtr[0] - x, pointPtr[1] - y); +} + +/* + *-------------------------------------------------------------- + * + * TkLineToArea -- + * + * Determine whether a line lies entirely inside, entirely + * outside, or overlapping a given rectangular area. + * + * Results: + * -1 is returned if the line given by end1Ptr and end2Ptr + * is entirely outside the rectangle given by rectPtr. 0 is + * returned if the polygon overlaps the rectangle, and 1 is + * returned if the polygon is entirely inside the rectangle. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +int +TkLineToArea(end1Ptr, end2Ptr, rectPtr) + double end1Ptr[2]; /* X and y coordinates for one endpoint + * of line. */ + double end2Ptr[2]; /* X and y coordinates for other endpoint + * of line. */ + double rectPtr[4]; /* Points to coords for rectangle, in the + * order x1, y1, x2, y2. X1 must be no + * larger than x2, and y1 no larger than y2. */ +{ + int inside1, inside2; + + /* + * First check the two points individually to see whether they + * are inside the rectangle or not. + */ + + inside1 = (end1Ptr[0] >= rectPtr[0]) && (end1Ptr[0] <= rectPtr[2]) + && (end1Ptr[1] >= rectPtr[1]) && (end1Ptr[1] <= rectPtr[3]); + inside2 = (end2Ptr[0] >= rectPtr[0]) && (end2Ptr[0] <= rectPtr[2]) + && (end2Ptr[1] >= rectPtr[1]) && (end2Ptr[1] <= rectPtr[3]); + if (inside1 != inside2) { + return 0; + } + if (inside1 & inside2) { + return 1; + } + + /* + * Both points are outside the rectangle, but still need to check + * for intersections between the line and the rectangle. Horizontal + * and vertical lines are particularly easy, so handle them + * separately. + */ + + if (end1Ptr[0] == end2Ptr[0]) { + /* + * Vertical line. + */ + + if (((end1Ptr[1] >= rectPtr[1]) ^ (end2Ptr[1] >= rectPtr[1])) + && (end1Ptr[0] >= rectPtr[0]) + && (end1Ptr[0] <= rectPtr[2])) { + return 0; + } + } else if (end1Ptr[1] == end2Ptr[1]) { + /* + * Horizontal line. + */ + + if (((end1Ptr[0] >= rectPtr[0]) ^ (end2Ptr[0] >= rectPtr[0])) + && (end1Ptr[1] >= rectPtr[1]) + && (end1Ptr[1] <= rectPtr[3])) { + return 0; + } + } else { + double m, x, y, low, high; + + /* + * Diagonal line. Compute slope of line and use + * for intersection checks against each of the + * sides of the rectangle: left, right, bottom, top. + */ + + m = (end2Ptr[1] - end1Ptr[1])/(end2Ptr[0] - end1Ptr[0]); + if (end1Ptr[0] < end2Ptr[0]) { + low = end1Ptr[0]; high = end2Ptr[0]; + } else { + low = end2Ptr[0]; high = end1Ptr[0]; + } + + /* + * Left edge. + */ + + y = end1Ptr[1] + (rectPtr[0] - end1Ptr[0])*m; + if ((rectPtr[0] >= low) && (rectPtr[0] <= high) + && (y >= rectPtr[1]) && (y <= rectPtr[3])) { + return 0; + } + + /* + * Right edge. + */ + + y += (rectPtr[2] - rectPtr[0])*m; + if ((y >= rectPtr[1]) && (y <= rectPtr[3]) + && (rectPtr[2] >= low) && (rectPtr[2] <= high)) { + return 0; + } + + /* + * Bottom edge. + */ + + if (end1Ptr[1] < end2Ptr[1]) { + low = end1Ptr[1]; high = end2Ptr[1]; + } else { + low = end2Ptr[1]; high = end1Ptr[1]; + } + x = end1Ptr[0] + (rectPtr[1] - end1Ptr[1])/m; + if ((x >= rectPtr[0]) && (x <= rectPtr[2]) + && (rectPtr[1] >= low) && (rectPtr[1] <= high)) { + return 0; + } + + /* + * Top edge. + */ + + x += (rectPtr[3] - rectPtr[1])/m; + if ((x >= rectPtr[0]) && (x <= rectPtr[2]) + && (rectPtr[3] >= low) && (rectPtr[3] <= high)) { + return 0; + } + } + return -1; +} + +/* + *-------------------------------------------------------------- + * + * TkThickPolyLineToArea -- + * + * This procedure is called to determine whether a connected + * series of line segments lies entirely inside, entirely + * outside, or overlapping a given rectangular area. + * + * Results: + * -1 is returned if the lines are entirely outside the area, + * 0 if they overlap, and 1 if they are entirely inside the + * given area. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +TkThickPolyLineToArea(coordPtr, numPoints, width, capStyle, joinStyle, rectPtr) + double *coordPtr; /* Points to an array of coordinates for + * the polyline: x0, y0, x1, y1, ... */ + int numPoints; /* Total number of points at *coordPtr. */ + double width; /* Width of each line segment. */ + int capStyle; /* How are end-points of polyline drawn? + * CapRound, CapButt, or CapProjecting. */ + int joinStyle; /* How are joints in polyline drawn? + * JoinMiter, JoinRound, or JoinBevel. */ + double *rectPtr; /* Rectangular area to check against. */ +{ + double radius, poly[10]; + int count; + int changedMiterToBevel; /* Non-zero means that a mitered corner + * had to be treated as beveled after all + * because the angle was < 11 degrees. */ + int inside; /* Tentative guess about what to return, + * based on all points seen so far: one + * means everything seen so far was + * inside the area; -1 means everything + * was outside the area. 0 means overlap + * has been found. */ + + radius = width/2.0; + inside = -1; + + if ((coordPtr[0] >= rectPtr[0]) && (coordPtr[0] <= rectPtr[2]) + && (coordPtr[1] >= rectPtr[1]) && (coordPtr[1] <= rectPtr[3])) { + inside = 1; + } + + /* + * Iterate through all of the edges of the line, computing a polygon + * for each edge and testing the area against that polygon. In + * addition, there are additional tests to deal with rounded joints + * and caps. + */ + + changedMiterToBevel = 0; + for (count = numPoints; count >= 2; count--, coordPtr += 2) { + + /* + * If rounding is done around the first point of the edge + * then test a circular region around the point with the + * area. + */ + + if (((capStyle == CapRound) && (count == numPoints)) + || ((joinStyle == JoinRound) && (count != numPoints))) { + poly[0] = coordPtr[0] - radius; + poly[1] = coordPtr[1] - radius; + poly[2] = coordPtr[0] + radius; + poly[3] = coordPtr[1] + radius; + if (TkOvalToArea(poly, rectPtr) != inside) { + return 0; + } + } + + /* + * Compute the polygonal shape corresponding to this edge, + * consisting of two points for the first point of the edge + * and two points for the last point of the edge. + */ + + if (count == numPoints) { + TkGetButtPoints(coordPtr+2, coordPtr, width, + capStyle == CapProjecting, poly, poly+2); + } else if ((joinStyle == JoinMiter) && !changedMiterToBevel) { + poly[0] = poly[6]; + poly[1] = poly[7]; + poly[2] = poly[4]; + poly[3] = poly[5]; + } else { + TkGetButtPoints(coordPtr+2, coordPtr, width, 0, poly, poly+2); + + /* + * If the last joint was beveled, then also check a + * polygon comprising the last two points of the previous + * polygon and the first two from this polygon; this checks + * the wedges that fill the beveled joint. + */ + + if ((joinStyle == JoinBevel) || changedMiterToBevel) { + poly[8] = poly[0]; + poly[9] = poly[1]; + if (TkPolygonToArea(poly, 5, rectPtr) != inside) { + return 0; + } + changedMiterToBevel = 0; + } + } + if (count == 2) { + TkGetButtPoints(coordPtr, coordPtr+2, width, + capStyle == CapProjecting, poly+4, poly+6); + } else if (joinStyle == JoinMiter) { + if (TkGetMiterPoints(coordPtr, coordPtr+2, coordPtr+4, + (double) width, poly+4, poly+6) == 0) { + changedMiterToBevel = 1; + TkGetButtPoints(coordPtr, coordPtr+2, width, 0, poly+4, + poly+6); + } + } else { + TkGetButtPoints(coordPtr, coordPtr+2, width, 0, poly+4, poly+6); + } + poly[8] = poly[0]; + poly[9] = poly[1]; + if (TkPolygonToArea(poly, 5, rectPtr) != inside) { + return 0; + } + } + + /* + * If caps are rounded, check the cap around the final point + * of the line. + */ + + if (capStyle == CapRound) { + poly[0] = coordPtr[0] - radius; + poly[1] = coordPtr[1] - radius; + poly[2] = coordPtr[0] + radius; + poly[3] = coordPtr[1] + radius; + if (TkOvalToArea(poly, rectPtr) != inside) { + return 0; + } + } + + return inside; +} + +/* + *-------------------------------------------------------------- + * + * TkPolygonToPoint -- + * + * Compute the distance from a point to a polygon. + * + * Results: + * The return value is 0.0 if the point referred to by + * pointPtr is within the polygon referred to by polyPtr + * and numPoints. Otherwise the return value is the + * distance of the point from the polygon. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +double +TkPolygonToPoint(polyPtr, numPoints, pointPtr) + double *polyPtr; /* Points to an array coordinates for + * closed polygon: x0, y0, x1, y1, ... + * The polygon may be self-intersecting. */ + int numPoints; /* Total number of points at *polyPtr. */ + double *pointPtr; /* Points to coords for point. */ +{ + double bestDist; /* Closest distance between point and + * any edge in polygon. */ + int intersections; /* Number of edges in the polygon that + * intersect a ray extending vertically + * upwards from the point to infinity. */ + int count; + register double *pPtr; + + /* + * Iterate through all of the edges in the polygon, updating + * bestDist and intersections. + * + * TRICKY POINT: when computing intersections, include left + * x-coordinate of line within its range, but not y-coordinate. + * Otherwise if the point lies exactly below a vertex we'll + * count it as two intersections. + */ + + bestDist = 1.0e36; + intersections = 0; + + for (count = numPoints, pPtr = polyPtr; count > 1; count--, pPtr += 2) { + double x, y, dist; + + /* + * Compute the point on the current edge closest to the point + * and update the intersection count. This must be done + * separately for vertical edges, horizontal edges, and + * other edges. + */ + + if (pPtr[2] == pPtr[0]) { + + /* + * Vertical edge. + */ + + x = pPtr[0]; + if (pPtr[1] >= pPtr[3]) { + y = MIN(pPtr[1], pointPtr[1]); + y = MAX(y, pPtr[3]); + } else { + y = MIN(pPtr[3], pointPtr[1]); + y = MAX(y, pPtr[1]); + } + } else if (pPtr[3] == pPtr[1]) { + + /* + * Horizontal edge. + */ + + y = pPtr[1]; + if (pPtr[0] >= pPtr[2]) { + x = MIN(pPtr[0], pointPtr[0]); + x = MAX(x, pPtr[2]); + if ((pointPtr[1] < y) && (pointPtr[0] < pPtr[0]) + && (pointPtr[0] >= pPtr[2])) { + intersections++; + } + } else { + x = MIN(pPtr[2], pointPtr[0]); + x = MAX(x, pPtr[0]); + if ((pointPtr[1] < y) && (pointPtr[0] < pPtr[2]) + && (pointPtr[0] >= pPtr[0])) { + intersections++; + } + } + } else { + double m1, b1, m2, b2; + int lower; /* Non-zero means point below line. */ + + /* + * The edge is neither horizontal nor vertical. Convert the + * edge to a line equation of the form y = m1*x + b1. Then + * compute a line perpendicular to this edge but passing + * through the point, also in the form y = m2*x + b2. + */ + + m1 = (pPtr[3] - pPtr[1])/(pPtr[2] - pPtr[0]); + b1 = pPtr[1] - m1*pPtr[0]; + m2 = -1.0/m1; + b2 = pointPtr[1] - m2*pointPtr[0]; + x = (b2 - b1)/(m1 - m2); + y = m1*x + b1; + if (pPtr[0] > pPtr[2]) { + if (x > pPtr[0]) { + x = pPtr[0]; + y = pPtr[1]; + } else if (x < pPtr[2]) { + x = pPtr[2]; + y = pPtr[3]; + } + } else { + if (x > pPtr[2]) { + x = pPtr[2]; + y = pPtr[3]; + } else if (x < pPtr[0]) { + x = pPtr[0]; + y = pPtr[1]; + } + } + lower = (m1*pointPtr[0] + b1) > pointPtr[1]; + if (lower && (pointPtr[0] >= MIN(pPtr[0], pPtr[2])) + && (pointPtr[0] < MAX(pPtr[0], pPtr[2]))) { + intersections++; + } + } + + /* + * Compute the distance to the closest point, and see if that + * is the best distance seen so far. + */ + + dist = hypot(pointPtr[0] - x, pointPtr[1] - y); + if (dist < bestDist) { + bestDist = dist; + } + } + + /* + * We've processed all of the points. If the number of intersections + * is odd, the point is inside the polygon. + */ + + if (intersections & 0x1) { + return 0.0; + } + return bestDist; +} + +/* + *-------------------------------------------------------------- + * + * TkPolygonToArea -- + * + * Determine whether a polygon lies entirely inside, entirely + * outside, or overlapping a given rectangular area. + * + * Results: + * -1 is returned if the polygon given by polyPtr and numPoints + * is entirely outside the rectangle given by rectPtr. 0 is + * returned if the polygon overlaps the rectangle, and 1 is + * returned if the polygon is entirely inside the rectangle. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +int +TkPolygonToArea(polyPtr, numPoints, rectPtr) + double *polyPtr; /* Points to an array coordinates for + * closed polygon: x0, y0, x1, y1, ... + * The polygon may be self-intersecting. */ + int numPoints; /* Total number of points at *polyPtr. */ + register double *rectPtr; /* Points to coords for rectangle, in the + * order x1, y1, x2, y2. X1 and y1 must + * be lower-left corner. */ +{ + int state; /* State of all edges seen so far (-1 means + * outside, 1 means inside, won't ever be + * 0). */ + int count; + register double *pPtr; + + /* + * Iterate over all of the edges of the polygon and test them + * against the rectangle. Can quit as soon as the state becomes + * "intersecting". + */ + + state = TkLineToArea(polyPtr, polyPtr+2, rectPtr); + if (state == 0) { + return 0; + } + for (pPtr = polyPtr+2, count = numPoints-1; count >= 2; + pPtr += 2, count--) { + if (TkLineToArea(pPtr, pPtr+2, rectPtr) != state) { + return 0; + } + } + + /* + * If all of the edges were inside the rectangle we're done. + * If all of the edges were outside, then the rectangle could + * still intersect the polygon (if it's entirely enclosed). + * Call TkPolygonToPoint to figure this out. + */ + + if (state == 1) { + return 1; + } + if (TkPolygonToPoint(polyPtr, numPoints, rectPtr) == 0.0) { + return 0; + } + return -1; +} + +/* + *-------------------------------------------------------------- + * + * TkOvalToPoint -- + * + * Computes the distance from a given point to a given + * oval, in canvas units. + * + * Results: + * The return value is 0 if the point given by *pointPtr is + * inside the oval. If the point isn't inside the + * oval then the return value is approximately the distance + * from the point to the oval. If the oval is filled, then + * anywhere in the interior is considered "inside"; if + * the oval isn't filled, then "inside" means only the area + * occupied by the outline. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +double +TkOvalToPoint(ovalPtr, width, filled, pointPtr) + double ovalPtr[4]; /* Pointer to array of four coordinates + * (x1, y1, x2, y2) defining oval's bounding + * box. */ + double width; /* Width of outline for oval. */ + int filled; /* Non-zero means oval should be treated as + * filled; zero means only consider outline. */ + double pointPtr[2]; /* Coordinates of point. */ +{ + double xDelta, yDelta, scaledDistance, distToOutline, distToCenter; + double xDiam, yDiam; + + /* + * Compute the distance between the center of the oval and the + * point in question, using a coordinate system where the oval + * has been transformed to a circle with unit radius. + */ + + xDelta = (pointPtr[0] - (ovalPtr[0] + ovalPtr[2])/2.0); + yDelta = (pointPtr[1] - (ovalPtr[1] + ovalPtr[3])/2.0); + distToCenter = hypot(xDelta, yDelta); + scaledDistance = hypot(xDelta / ((ovalPtr[2] + width - ovalPtr[0])/2.0), + yDelta / ((ovalPtr[3] + width - ovalPtr[1])/2.0)); + + + /* + * If the scaled distance is greater than 1 then it means no + * hit. Compute the distance from the point to the edge of + * the circle, then scale this distance back to the original + * coordinate system. + * + * Note: this distance isn't completely accurate. It's only + * an approximation, and it can overestimate the correct + * distance when the oval is eccentric. + */ + + if (scaledDistance > 1.0) { + return (distToCenter/scaledDistance) * (scaledDistance - 1.0); + } + + /* + * Scaled distance less than 1 means the point is inside the + * outer edge of the oval. If this is a filled oval, then we + * have a hit. Otherwise, do the same computation as above + * (scale back to original coordinate system), but also check + * to see if the point is within the width of the outline. + */ + + if (filled) { + return 0.0; + } + if (scaledDistance > 1E-10) { + distToOutline = (distToCenter/scaledDistance) * (1.0 - scaledDistance) + - width; + } else { + /* + * Avoid dividing by a very small number (it could cause an + * arithmetic overflow). This problem occurs if the point is + * very close to the center of the oval. + */ + + xDiam = ovalPtr[2] - ovalPtr[0]; + yDiam = ovalPtr[3] - ovalPtr[1]; + if (xDiam < yDiam) { + distToOutline = (xDiam - width)/2; + } else { + distToOutline = (yDiam - width)/2; + } + } + + if (distToOutline < 0.0) { + return 0.0; + } + return distToOutline; +} + +/* + *-------------------------------------------------------------- + * + * TkOvalToArea -- + * + * Determine whether an oval lies entirely inside, entirely + * outside, or overlapping a given rectangular area. + * + * Results: + * -1 is returned if the oval described by ovalPtr is entirely + * outside the rectangle given by rectPtr. 0 is returned if the + * oval overlaps the rectangle, and 1 is returned if the oval + * is entirely inside the rectangle. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +int +TkOvalToArea(ovalPtr, rectPtr) + register double *ovalPtr; /* Points to coordinates definining the + * bounding rectangle for the oval: x1, y1, + * x2, y2. X1 must be less than x2 and y1 + * less than y2. */ + register double *rectPtr; /* Points to coords for rectangle, in the + * order x1, y1, x2, y2. X1 and y1 must + * be lower-left corner. */ +{ + double centerX, centerY, radX, radY, deltaX, deltaY; + + /* + * First, see if oval is entirely inside rectangle or entirely + * outside rectangle. + */ + + if ((rectPtr[0] <= ovalPtr[0]) && (rectPtr[2] >= ovalPtr[2]) + && (rectPtr[1] <= ovalPtr[1]) && (rectPtr[3] >= ovalPtr[3])) { + return 1; + } + if ((rectPtr[2] < ovalPtr[0]) || (rectPtr[0] > ovalPtr[2]) + || (rectPtr[3] < ovalPtr[1]) || (rectPtr[1] > ovalPtr[3])) { + return -1; + } + + /* + * Next, go through the rectangle side by side. For each side + * of the rectangle, find the point on the side that is closest + * to the oval's center, and see if that point is inside the + * oval. If at least one such point is inside the oval, then + * the rectangle intersects the oval. + */ + + centerX = (ovalPtr[0] + ovalPtr[2])/2; + centerY = (ovalPtr[1] + ovalPtr[3])/2; + radX = (ovalPtr[2] - ovalPtr[0])/2; + radY = (ovalPtr[3] - ovalPtr[1])/2; + + deltaY = rectPtr[1] - centerY; + if (deltaY < 0.0) { + deltaY = centerY - rectPtr[3]; + if (deltaY < 0.0) { + deltaY = 0; + } + } + deltaY /= radY; + deltaY *= deltaY; + + /* + * Left side: + */ + + deltaX = (rectPtr[0] - centerX)/radX; + deltaX *= deltaX; + if ((deltaX + deltaY) <= 1.0) { + return 0; + } + + /* + * Right side: + */ + + deltaX = (rectPtr[2] - centerX)/radX; + deltaX *= deltaX; + if ((deltaX + deltaY) <= 1.0) { + return 0; + } + + deltaX = rectPtr[0] - centerX; + if (deltaX < 0.0) { + deltaX = centerX - rectPtr[2]; + if (deltaX < 0.0) { + deltaX = 0; + } + } + deltaX /= radX; + deltaX *= deltaX; + + /* + * Bottom side: + */ + + deltaY = (rectPtr[1] - centerY)/radY; + deltaY *= deltaY; + if ((deltaX + deltaY) < 1.0) { + return 0; + } + + /* + * Top side: + */ + + deltaY = (rectPtr[3] - centerY)/radY; + deltaY *= deltaY; + if ((deltaX + deltaY) < 1.0) { + return 0; + } + + return -1; +} + +/* + *-------------------------------------------------------------- + * + * TkIncludePoint -- + * + * Given a point and a generic canvas item header, expand + * the item's bounding box if needed to include the point. + * + * Results: + * None. + * + * Side effects: + * The boudn. + * + *-------------------------------------------------------------- + */ + + /* ARGSUSED */ +void +TkIncludePoint(itemPtr, pointPtr) + register Tk_Item *itemPtr; /* Item whose bounding box is + * being calculated. */ + double *pointPtr; /* Address of two doubles giving + * x and y coordinates of point. */ +{ + int tmp; + + tmp = (int) (pointPtr[0] + 0.5); + if (tmp < itemPtr->x1) { + itemPtr->x1 = tmp; + } + if (tmp > itemPtr->x2) { + itemPtr->x2 = tmp; + } + tmp = (int) (pointPtr[1] + 0.5); + if (tmp < itemPtr->y1) { + itemPtr->y1 = tmp; + } + if (tmp > itemPtr->y2) { + itemPtr->y2 = tmp; + } +} + +/* + *-------------------------------------------------------------- + * + * TkBezierScreenPoints -- + * + * Given four control points, create a larger set of XPoints + * for a Bezier spline based on the points. + * + * Results: + * The array at *xPointPtr gets filled in with numSteps XPoints + * corresponding to the Bezier spline defined by the four + * control points. Note: no output point is generated for the + * first input point, but an output point *is* generated for + * the last input point. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +void +TkBezierScreenPoints(canvas, control, numSteps, xPointPtr) + Tk_Canvas canvas; /* Canvas in which curve is to be + * drawn. */ + double control[]; /* Array of coordinates for four + * control points: x0, y0, x1, y1, + * ... x3 y3. */ + int numSteps; /* Number of curve points to + * generate. */ + register XPoint *xPointPtr; /* Where to put new points. */ +{ + int i; + double u, u2, u3, t, t2, t3; + + for (i = 1; i <= numSteps; i++, xPointPtr++) { + t = ((double) i)/((double) numSteps); + t2 = t*t; + t3 = t2*t; + u = 1.0 - t; + u2 = u*u; + u3 = u2*u; + Tk_CanvasDrawableCoords(canvas, + (control[0]*u3 + 3.0 * (control[2]*t*u2 + control[4]*t2*u) + + control[6]*t3), + (control[1]*u3 + 3.0 * (control[3]*t*u2 + control[5]*t2*u) + + control[7]*t3), + &xPointPtr->x, &xPointPtr->y); + } +} + +/* + *-------------------------------------------------------------- + * + * TkBezierPoints -- + * + * Given four control points, create a larger set of points + * for a Bezier spline based on the points. + * + * Results: + * The array at *coordPtr gets filled in with 2*numSteps + * coordinates, which correspond to the Bezier spline defined + * by the four control points. Note: no output point is + * generated for the first input point, but an output point + * *is* generated for the last input point. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +void +TkBezierPoints(control, numSteps, coordPtr) + double control[]; /* Array of coordinates for four + * control points: x0, y0, x1, y1, + * ... x3 y3. */ + int numSteps; /* Number of curve points to + * generate. */ + register double *coordPtr; /* Where to put new points. */ +{ + int i; + double u, u2, u3, t, t2, t3; + + for (i = 1; i <= numSteps; i++, coordPtr += 2) { + t = ((double) i)/((double) numSteps); + t2 = t*t; + t3 = t2*t; + u = 1.0 - t; + u2 = u*u; + u3 = u2*u; + coordPtr[0] = control[0]*u3 + + 3.0 * (control[2]*t*u2 + control[4]*t2*u) + control[6]*t3; + coordPtr[1] = control[1]*u3 + + 3.0 * (control[3]*t*u2 + control[5]*t2*u) + control[7]*t3; + } +} + +/* + *-------------------------------------------------------------- + * + * TkMakeBezierCurve -- + * + * Given a set of points, create a new set of points that fit + * parabolic splines to the line segments connecting the original + * points. Produces output points in either of two forms. + * + * Note: in spite of this procedure's name, it does *not* generate + * Bezier curves. Since only three control points are used for + * each curve segment, not four, the curves are actually just + * parabolic. + * + * Results: + * Either or both of the xPoints or dblPoints arrays are filled + * in. The return value is the number of points placed in the + * arrays. Note: if the first and last points are the same, then + * a closed curve is generated. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +int +TkMakeBezierCurve(canvas, pointPtr, numPoints, numSteps, xPoints, dblPoints) + Tk_Canvas canvas; /* Canvas in which curve is to be + * drawn. */ + double *pointPtr; /* Array of input coordinates: x0, + * y0, x1, y1, etc.. */ + int numPoints; /* Number of points at pointPtr. */ + int numSteps; /* Number of steps to use for each + * spline segments (determines + * smoothness of curve). */ + XPoint xPoints[]; /* Array of XPoints to fill in (e.g. + * for display. NULL means don't + * fill in any XPoints. */ + double dblPoints[]; /* Array of points to fill in as + * doubles, in the form x0, y0, + * x1, y1, .... NULL means don't + * fill in anything in this form. + * Caller must make sure that this + * array has enough space. */ +{ + int closed, outputPoints, i; + int numCoords = numPoints*2; + double control[8]; + + /* + * If the curve is a closed one then generate a special spline + * that spans the last points and the first ones. Otherwise + * just put the first point into the output. + */ + + outputPoints = 0; + if ((pointPtr[0] == pointPtr[numCoords-2]) + && (pointPtr[1] == pointPtr[numCoords-1])) { + closed = 1; + control[0] = 0.5*pointPtr[numCoords-4] + 0.5*pointPtr[0]; + control[1] = 0.5*pointPtr[numCoords-3] + 0.5*pointPtr[1]; + control[2] = 0.167*pointPtr[numCoords-4] + 0.833*pointPtr[0]; + control[3] = 0.167*pointPtr[numCoords-3] + 0.833*pointPtr[1]; + control[4] = 0.833*pointPtr[0] + 0.167*pointPtr[2]; + control[5] = 0.833*pointPtr[1] + 0.167*pointPtr[3]; + control[6] = 0.5*pointPtr[0] + 0.5*pointPtr[2]; + control[7] = 0.5*pointPtr[1] + 0.5*pointPtr[3]; + if (xPoints != NULL) { + Tk_CanvasDrawableCoords(canvas, control[0], control[1], + &xPoints->x, &xPoints->y); + TkBezierScreenPoints(canvas, control, numSteps, xPoints+1); + xPoints += numSteps+1; + } + if (dblPoints != NULL) { + dblPoints[0] = control[0]; + dblPoints[1] = control[1]; + TkBezierPoints(control, numSteps, dblPoints+2); + dblPoints += 2*(numSteps+1); + } + outputPoints += numSteps+1; + } else { + closed = 0; + if (xPoints != NULL) { + Tk_CanvasDrawableCoords(canvas, pointPtr[0], pointPtr[1], + &xPoints->x, &xPoints->y); + xPoints += 1; + } + if (dblPoints != NULL) { + dblPoints[0] = pointPtr[0]; + dblPoints[1] = pointPtr[1]; + dblPoints += 2; + } + outputPoints += 1; + } + + for (i = 2; i < numPoints; i++, pointPtr += 2) { + /* + * Set up the first two control points. This is done + * differently for the first spline of an open curve + * than for other cases. + */ + + if ((i == 2) && !closed) { + control[0] = pointPtr[0]; + control[1] = pointPtr[1]; + control[2] = 0.333*pointPtr[0] + 0.667*pointPtr[2]; + control[3] = 0.333*pointPtr[1] + 0.667*pointPtr[3]; + } else { + control[0] = 0.5*pointPtr[0] + 0.5*pointPtr[2]; + control[1] = 0.5*pointPtr[1] + 0.5*pointPtr[3]; + control[2] = 0.167*pointPtr[0] + 0.833*pointPtr[2]; + control[3] = 0.167*pointPtr[1] + 0.833*pointPtr[3]; + } + + /* + * Set up the last two control points. This is done + * differently for the last spline of an open curve + * than for other cases. + */ + + if ((i == (numPoints-1)) && !closed) { + control[4] = .667*pointPtr[2] + .333*pointPtr[4]; + control[5] = .667*pointPtr[3] + .333*pointPtr[5]; + control[6] = pointPtr[4]; + control[7] = pointPtr[5]; + } else { + control[4] = .833*pointPtr[2] + .167*pointPtr[4]; + control[5] = .833*pointPtr[3] + .167*pointPtr[5]; + control[6] = 0.5*pointPtr[2] + 0.5*pointPtr[4]; + control[7] = 0.5*pointPtr[3] + 0.5*pointPtr[5]; + } + + /* + * If the first two points coincide, or if the last + * two points coincide, then generate a single + * straight-line segment by outputting the last control + * point. + */ + + if (((pointPtr[0] == pointPtr[2]) && (pointPtr[1] == pointPtr[3])) + || ((pointPtr[2] == pointPtr[4]) + && (pointPtr[3] == pointPtr[5]))) { + if (xPoints != NULL) { + Tk_CanvasDrawableCoords(canvas, control[6], control[7], + &xPoints[0].x, &xPoints[0].y); + xPoints++; + } + if (dblPoints != NULL) { + dblPoints[0] = control[6]; + dblPoints[1] = control[7]; + dblPoints += 2; + } + outputPoints += 1; + continue; + } + + /* + * Generate a Bezier spline using the control points. + */ + + + if (xPoints != NULL) { + TkBezierScreenPoints(canvas, control, numSteps, xPoints); + xPoints += numSteps; + } + if (dblPoints != NULL) { + TkBezierPoints(control, numSteps, dblPoints); + dblPoints += 2*numSteps; + } + outputPoints += numSteps; + } + return outputPoints; +} + +/* + *-------------------------------------------------------------- + * + * TkMakeBezierPostscript -- + * + * This procedure generates Postscript commands that create + * a path corresponding to a given Bezier curve. + * + * Results: + * None. Postscript commands to generate the path are appended + * to interp->result. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +void +TkMakeBezierPostscript(interp, canvas, pointPtr, numPoints) + Tcl_Interp *interp; /* Interpreter in whose result the + * Postscript is to be stored. */ + Tk_Canvas canvas; /* Canvas widget for which the + * Postscript is being generated. */ + double *pointPtr; /* Array of input coordinates: x0, + * y0, x1, y1, etc.. */ + int numPoints; /* Number of points at pointPtr. */ +{ + int closed, i; + int numCoords = numPoints*2; + double control[8]; + char buffer[200]; + + /* + * If the curve is a closed one then generate a special spline + * that spans the last points and the first ones. Otherwise + * just put the first point into the path. + */ + + if ((pointPtr[0] == pointPtr[numCoords-2]) + && (pointPtr[1] == pointPtr[numCoords-1])) { + closed = 1; + control[0] = 0.5*pointPtr[numCoords-4] + 0.5*pointPtr[0]; + control[1] = 0.5*pointPtr[numCoords-3] + 0.5*pointPtr[1]; + control[2] = 0.167*pointPtr[numCoords-4] + 0.833*pointPtr[0]; + control[3] = 0.167*pointPtr[numCoords-3] + 0.833*pointPtr[1]; + control[4] = 0.833*pointPtr[0] + 0.167*pointPtr[2]; + control[5] = 0.833*pointPtr[1] + 0.167*pointPtr[3]; + control[6] = 0.5*pointPtr[0] + 0.5*pointPtr[2]; + control[7] = 0.5*pointPtr[1] + 0.5*pointPtr[3]; + sprintf(buffer, "%.15g %.15g moveto\n%.15g %.15g %.15g %.15g %.15g %.15g curveto\n", + control[0], Tk_CanvasPsY(canvas, control[1]), + control[2], Tk_CanvasPsY(canvas, control[3]), + control[4], Tk_CanvasPsY(canvas, control[5]), + control[6], Tk_CanvasPsY(canvas, control[7])); + } else { + closed = 0; + control[6] = pointPtr[0]; + control[7] = pointPtr[1]; + sprintf(buffer, "%.15g %.15g moveto\n", + control[6], Tk_CanvasPsY(canvas, control[7])); + } + Tcl_AppendResult(interp, buffer, (char *) NULL); + + /* + * Cycle through all the remaining points in the curve, generating + * a curve section for each vertex in the linear path. + */ + + for (i = numPoints-2, pointPtr += 2; i > 0; i--, pointPtr += 2) { + control[2] = 0.333*control[6] + 0.667*pointPtr[0]; + control[3] = 0.333*control[7] + 0.667*pointPtr[1]; + + /* + * Set up the last two control points. This is done + * differently for the last spline of an open curve + * than for other cases. + */ + + if ((i == 1) && !closed) { + control[6] = pointPtr[2]; + control[7] = pointPtr[3]; + } else { + control[6] = 0.5*pointPtr[0] + 0.5*pointPtr[2]; + control[7] = 0.5*pointPtr[1] + 0.5*pointPtr[3]; + } + control[4] = 0.333*control[6] + 0.667*pointPtr[0]; + control[5] = 0.333*control[7] + 0.667*pointPtr[1]; + + sprintf(buffer, "%.15g %.15g %.15g %.15g %.15g %.15g curveto\n", + control[2], Tk_CanvasPsY(canvas, control[3]), + control[4], Tk_CanvasPsY(canvas, control[5]), + control[6], Tk_CanvasPsY(canvas, control[7])); + Tcl_AppendResult(interp, buffer, (char *) NULL); + } +} + +/* + *-------------------------------------------------------------- + * + * TkGetMiterPoints -- + * + * Given three points forming an angle, compute the + * coordinates of the inside and outside points of + * the mitered corner formed by a line of a given + * width at that angle. + * + * Results: + * If the angle formed by the three points is less than + * 11 degrees then 0 is returned and m1 and m2 aren't + * modified. Otherwise 1 is returned and the points at + * m1 and m2 are filled in with the positions of the points + * of the mitered corner. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +int +TkGetMiterPoints(p1, p2, p3, width, m1, m2) + double p1[]; /* Points to x- and y-coordinates of point + * before vertex. */ + double p2[]; /* Points to x- and y-coordinates of vertex + * for mitered joint. */ + double p3[]; /* Points to x- and y-coordinates of point + * after vertex. */ + double width; /* Width of line. */ + double m1[]; /* Points to place to put "left" vertex + * point (see as you face from p1 to p2). */ + double m2[]; /* Points to place to put "right" vertex + * point. */ +{ + double theta1; /* Angle of segment p2-p1. */ + double theta2; /* Angle of segment p2-p3. */ + double theta; /* Angle between line segments (angle + * of joint). */ + double theta3; /* Angle that bisects theta1 and + * theta2 and points to m1. */ + double dist; /* Distance of miter points from p2. */ + double deltaX, deltaY; /* X and y offsets cooresponding to + * dist (fudge factors for bounding + * box). */ + double p1x, p1y, p2x, p2y, p3x, p3y; + static double elevenDegrees = (11.0*2.0*PI)/360.0; + + /* + * Round the coordinates to integers to mimic what happens when the + * line segments are displayed; without this code, the bounding box + * of a mitered line can be miscomputed greatly. + */ + + p1x = floor(p1[0]+0.5); + p1y = floor(p1[1]+0.5); + p2x = floor(p2[0]+0.5); + p2y = floor(p2[1]+0.5); + p3x = floor(p3[0]+0.5); + p3y = floor(p3[1]+0.5); + + if (p2y == p1y) { + theta1 = (p2x < p1x) ? 0 : PI; + } else if (p2x == p1x) { + theta1 = (p2y < p1y) ? PI/2.0 : -PI/2.0; + } else { + theta1 = atan2(p1y - p2y, p1x - p2x); + } + if (p3y == p2y) { + theta2 = (p3x > p2x) ? 0 : PI; + } else if (p3x == p2x) { + theta2 = (p3y > p2y) ? PI/2.0 : -PI/2.0; + } else { + theta2 = atan2(p3y - p2y, p3x - p2x); + } + theta = theta1 - theta2; + if (theta > PI) { + theta -= 2*PI; + } else if (theta < -PI) { + theta += 2*PI; + } + if ((theta < elevenDegrees) && (theta > -elevenDegrees)) { + return 0; + } + dist = 0.5*width/sin(0.5*theta); + if (dist < 0.0) { + dist = -dist; + } + + /* + * Compute theta3 (make sure that it points to the left when + * looking from p1 to p2). + */ + + theta3 = (theta1 + theta2)/2.0; + if (sin(theta3 - (theta1 + PI)) < 0.0) { + theta3 += PI; + } + deltaX = dist*cos(theta3); + m1[0] = p2x + deltaX; + m2[0] = p2x - deltaX; + deltaY = dist*sin(theta3); + m1[1] = p2y + deltaY; + m2[1] = p2y - deltaY; + return 1; +} + +/* + *-------------------------------------------------------------- + * + * TkGetButtPoints -- + * + * Given two points forming a line segment, compute the + * coordinates of two endpoints of a rectangle formed by + * bloating the line segment until it is width units wide. + * + * Results: + * There is no return value. M1 and m2 are filled in to + * correspond to m1 and m2 in the diagram below: + * + * ----------------* m1 + * | + * p1 *---------------* p2 + * | + * ----------------* m2 + * + * M1 and m2 will be W units apart, with p2 centered between + * them and m1-m2 perpendicular to p1-p2. However, if + * "project" is true then m1 and m2 will be as follows: + * + * -------------------* m1 + * p2 | + * p1 *---------------* | + * | + * -------------------* m2 + * + * In this case p2 will be width/2 units from the segment m1-m2. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +void +TkGetButtPoints(p1, p2, width, project, m1, m2) + double p1[]; /* Points to x- and y-coordinates of point + * before vertex. */ + double p2[]; /* Points to x- and y-coordinates of vertex + * for mitered joint. */ + double width; /* Width of line. */ + int project; /* Non-zero means project p2 by an additional + * width/2 before computing m1 and m2. */ + double m1[]; /* Points to place to put "left" result + * point, as you face from p1 to p2. */ + double m2[]; /* Points to place to put "right" result + * point. */ +{ + double length; /* Length of p1-p2 segment. */ + double deltaX, deltaY; /* Increments in coords. */ + + width *= 0.5; + length = hypot(p2[0] - p1[0], p2[1] - p1[1]); + if (length == 0.0) { + m1[0] = m2[0] = p2[0]; + m1[1] = m2[1] = p2[1]; + } else { + deltaX = -width * (p2[1] - p1[1]) / length; + deltaY = width * (p2[0] - p1[0]) / length; + m1[0] = p2[0] + deltaX; + m2[0] = p2[0] - deltaX; + m1[1] = p2[1] + deltaY; + m2[1] = p2[1] - deltaY; + if (project) { + m1[0] += deltaY; + m2[0] += deltaY; + m1[1] -= deltaX; + m2[1] -= deltaX; + } + } +} diff --git a/generic/tkUtil.c b/generic/tkUtil.c new file mode 100644 index 0000000..ddb3db0 --- /dev/null +++ b/generic/tkUtil.c @@ -0,0 +1,348 @@ +/* + * tkUtil.c -- + * + * This file contains miscellaneous utility procedures that + * are used by the rest of Tk, such as a procedure for drawing + * a focus highlight. + * + * Copyright (c) 1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkUtil.c 1.13 97/06/06 11:16:22 + */ + +#include "tkInt.h" +#include "tkPort.h" + +/* + *---------------------------------------------------------------------- + * + * TkDrawInsetFocusHighlight -- + * + * This procedure draws a rectangular ring around the outside of + * a widget to indicate that it has received the input focus. It + * takes an additional padding argument that specifies how much + * padding is present outside th widget. + * + * Results: + * None. + * + * Side effects: + * A rectangle "width" pixels wide is drawn in "drawable", + * corresponding to the outer area of "tkwin". + * + *---------------------------------------------------------------------- + */ + +void +TkDrawInsetFocusHighlight(tkwin, gc, width, drawable, padding) + Tk_Window tkwin; /* Window whose focus highlight ring is + * to be drawn. */ + GC gc; /* Graphics context to use for drawing + * the highlight ring. */ + int width; /* Width of the highlight ring, in pixels. */ + Drawable drawable; /* Where to draw the ring (typically a + * pixmap for double buffering). */ + int padding; /* Width of padding outside of widget. */ +{ + XRectangle rects[4]; + + /* + * On the Macintosh the highlight ring needs to be "padded" + * out by one pixel. Unfortunantly, none of the Tk widgets + * had a notion of padding between the focus ring and the + * widget. So we add this padding here. This introduces + * two things to worry about: + * + * 1) The widget must draw the background color covering + * the focus ring area before calling Tk_DrawFocus. + * 2) It is impossible to draw a focus ring of width 1. + * (For the Macintosh Look & Feel use width of 3) + */ +#ifdef MAC_TCL + width--; +#endif + + rects[0].x = padding; + rects[0].y = padding; + rects[0].width = Tk_Width(tkwin) - (2 * padding); + rects[0].height = width; + rects[1].x = padding; + rects[1].y = Tk_Height(tkwin) - width - padding; + rects[1].width = Tk_Width(tkwin) - (2 * padding); + rects[1].height = width; + rects[2].x = padding; + rects[2].y = width + padding; + rects[2].width = width; + rects[2].height = Tk_Height(tkwin) - 2*width - 2*padding; + rects[3].x = Tk_Width(tkwin) - width - padding; + rects[3].y = rects[2].y; + rects[3].width = width; + rects[3].height = rects[2].height; + XFillRectangles(Tk_Display(tkwin), drawable, gc, rects, 4); +} + +/* + *---------------------------------------------------------------------- + * + * Tk_DrawFocusHighlight -- + * + * This procedure draws a rectangular ring around the outside of + * a widget to indicate that it has received the input focus. + * + * Results: + * None. + * + * Side effects: + * A rectangle "width" pixels wide is drawn in "drawable", + * corresponding to the outer area of "tkwin". + * + *---------------------------------------------------------------------- + */ + +void +Tk_DrawFocusHighlight(tkwin, gc, width, drawable) + Tk_Window tkwin; /* Window whose focus highlight ring is + * to be drawn. */ + GC gc; /* Graphics context to use for drawing + * the highlight ring. */ + int width; /* Width of the highlight ring, in pixels. */ + Drawable drawable; /* Where to draw the ring (typically a + * pixmap for double buffering). */ +{ + TkDrawInsetFocusHighlight(tkwin, gc, width, drawable, 0); +} + +/* + *---------------------------------------------------------------------- + * + * Tk_GetScrollInfo -- + * + * This procedure is invoked to parse "xview" and "yview" + * scrolling commands for widgets using the new scrolling + * command syntax ("moveto" or "scroll" options). + * + * Results: + * The return value is either TK_SCROLL_MOVETO, TK_SCROLL_PAGES, + * TK_SCROLL_UNITS, or TK_SCROLL_ERROR. This indicates whether + * the command was successfully parsed and what form the command + * 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 + * error message. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tk_GetScrollInfo(interp, argc, argv, dblPtr, intPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + int argc; /* # arguments for command. */ + char **argv; /* Arguments for command. */ + double *dblPtr; /* Filled in with argument "moveto" + * option, if any. */ + int *intPtr; /* Filled in with number of pages + * or lines to scroll, if any. */ +{ + int c; + size_t length; + + length = strlen(argv[2]); + c = argv[2][0]; + if ((c == 'm') && (strncmp(argv[2], "moveto", length) == 0)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " ", argv[1], " moveto fraction\"", + (char *) NULL); + return TK_SCROLL_ERROR; + } + if (Tcl_GetDouble(interp, argv[3], dblPtr) != TCL_OK) { + return TK_SCROLL_ERROR; + } + return TK_SCROLL_MOVETO; + } else if ((c == 's') + && (strncmp(argv[2], "scroll", length) == 0)) { + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " ", argv[1], " scroll number units|pages\"", + (char *) NULL); + return TK_SCROLL_ERROR; + } + if (Tcl_GetInt(interp, argv[3], intPtr) != TCL_OK) { + return TK_SCROLL_ERROR; + } + length = strlen(argv[4]); + c = argv[4][0]; + if ((c == 'p') && (strncmp(argv[4], "pages", length) == 0)) { + return TK_SCROLL_PAGES; + } else if ((c == 'u') + && (strncmp(argv[4], "units", length) == 0)) { + return TK_SCROLL_UNITS; + } else { + Tcl_AppendResult(interp, "bad argument \"", argv[4], + "\": must be units or pages", (char *) NULL); + return TK_SCROLL_ERROR; + } + } + Tcl_AppendResult(interp, "unknown option \"", argv[2], + "\": must be moveto or scroll", (char *) NULL); + return TK_SCROLL_ERROR; +} + +/* + *--------------------------------------------------------------------------- + * + * TkComputeAnchor -- + * + * Determine where to place a rectangle so that it will be properly + * anchored with respect to the given window. Used by widgets + * to align a box of text inside a window. When anchoring with + * respect to one of the sides, the rectangle be placed inside of + * the internal border of the window. + * + * Results: + * *xPtr and *yPtr set to the upper-left corner of the rectangle + * anchored in the window. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ +void +TkComputeAnchor(anchor, tkwin, padX, padY, innerWidth, innerHeight, xPtr, yPtr) + Tk_Anchor anchor; /* Desired anchor. */ + Tk_Window tkwin; /* Anchored with respect to this window. */ + int padX, padY; /* Use this extra padding inside window, in + * addition to the internal border. */ + int innerWidth, innerHeight;/* Size of rectangle to anchor in window. */ + int *xPtr, *yPtr; /* Returns upper-left corner of anchored + * rectangle. */ +{ + switch (anchor) { + case TK_ANCHOR_NW: + case TK_ANCHOR_W: + case TK_ANCHOR_SW: + *xPtr = Tk_InternalBorderWidth(tkwin) + padX; + break; + + case TK_ANCHOR_N: + case TK_ANCHOR_CENTER: + case TK_ANCHOR_S: + *xPtr = (Tk_Width(tkwin) - innerWidth) / 2; + break; + + default: + *xPtr = Tk_Width(tkwin) - (Tk_InternalBorderWidth(tkwin) + padX) + - innerWidth; + break; + } + + switch (anchor) { + case TK_ANCHOR_NW: + case TK_ANCHOR_N: + case TK_ANCHOR_NE: + *yPtr = Tk_InternalBorderWidth(tkwin) + padY; + break; + + case TK_ANCHOR_W: + case TK_ANCHOR_CENTER: + case TK_ANCHOR_E: + *yPtr = (Tk_Height(tkwin) - innerHeight) / 2; + break; + + default: + *yPtr = Tk_Height(tkwin) - Tk_InternalBorderWidth(tkwin) - padY + - innerHeight; + break; + } +} + +/* + *--------------------------------------------------------------------------- + * + * TkFindStateString -- + * + * Given a lookup table, map a number to a string in the table. + * + * Results: + * If numKey was equal to the numeric key of one of the elements + * in the table, returns the string key of that element. + * Returns NULL if numKey was not equal to any of the numeric keys + * in the table. + * + * Side effects. + * None. + * + *--------------------------------------------------------------------------- + */ + +char * +TkFindStateString(mapPtr, numKey) + CONST TkStateMap *mapPtr; /* The state table. */ + int numKey; /* The key to try to find in the table. */ +{ + for ( ; mapPtr->strKey != NULL; mapPtr++) { + if (numKey == mapPtr->numKey) { + return mapPtr->strKey; + } + } + return NULL; +} + +/* + *--------------------------------------------------------------------------- + * + * TkFindStateNum -- + * + * Given a lookup table, map a string to a number in the table. + * + * Results: + * If strKey was equal to the string keys of one of the elements + * in the table, returns the numeric key of that element. + * 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). + * + * Side effects. + * None. + * + *--------------------------------------------------------------------------- + */ + +int +TkFindStateNum(interp, field, mapPtr, strKey) + Tcl_Interp *interp; /* Interp for error reporting. */ + CONST char *field; /* 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 ", field, " value \"", strKey, + "\": must be ", mPtr->strKey, (char *) NULL); + for (mPtr++; mPtr->strKey != NULL; mPtr++) { + Tcl_AppendResult(interp, ", ", mPtr->strKey, (char *) NULL); + } + } + return mPtr->numKey; +} diff --git a/generic/tkVisual.c b/generic/tkVisual.c new file mode 100644 index 0000000..207b905 --- /dev/null +++ b/generic/tkVisual.c @@ -0,0 +1,540 @@ +/* + * tkVisual.c -- + * + * This file contains library procedures for allocating and + * freeing visuals and colormaps. This code is based on a + * prototype implementation by Paul Mackerras. + * + * Copyright (c) 1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tkVisual.c 1.19 97/04/25 16:52:17 + */ + +#include "tkInt.h" +#include "tkPort.h" + +/* + * The table below maps from symbolic names for visual classes + * to the associated X class symbols. + */ + +typedef struct VisualDictionary { + char *name; /* Textual name of class. */ + int minLength; /* Minimum # characters that must be + * specified for an unambiguous match. */ + int class; /* X symbol for class. */ +} VisualDictionary; +static VisualDictionary visualNames[] = { + {"best", 1, 0}, + {"directcolor", 2, DirectColor}, + {"grayscale", 1, GrayScale}, + {"greyscale", 1, GrayScale}, + {"pseudocolor", 1, PseudoColor}, + {"staticcolor", 7, StaticColor}, + {"staticgray", 7, StaticGray}, + {"staticgrey", 7, StaticGray}, + {"truecolor", 1, TrueColor}, + {NULL, 0, 0}, +}; + +/* + * One of the following structures exists for each distinct non-default + * colormap allocated for a display by Tk_GetColormap. + */ + +struct TkColormap { + Colormap colormap; /* X's identifier for the colormap. */ + Visual *visual; /* Visual for which colormap was + * allocated. */ + int refCount; /* How many uses of the colormap are still + * outstanding (calls to Tk_GetColormap + * minus calls to Tk_FreeColormap). */ + int shareable; /* 0 means this colormap was allocated by + * a call to Tk_GetColormap with "new", + * implying that the window wants it all + * for itself. 1 means that the colormap + * was allocated as a default for a particular + * visual, so it can be shared. */ + struct TkColormap *nextPtr; /* Next in list of colormaps for this display, + * or NULL for end of list. */ +}; + +/* + *---------------------------------------------------------------------- + * + * Tk_GetVisual -- + * + * Given a string identifying a particular kind of visual, this + * procedure returns a visual and depth that matches the specification. + * + * 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 + * 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 + * returns that colormap in *colormapPtr unless an error occurs. + * + * Side effects: + * A new colormap may be allocated. + * + *---------------------------------------------------------------------- + */ + +Visual * +Tk_GetVisual(interp, tkwin, string, depthPtr, colormapPtr) + Tcl_Interp *interp; /* Interpreter to use for error + * reporting. */ + Tk_Window tkwin; /* Window in which visual will be + * used. */ + char *string; /* String describing visual. See + * manual entry for details. */ + int *depthPtr; /* The depth of the returned visual + * is stored here. */ + Colormap *colormapPtr; /* If non-NULL, then a suitable + * colormap for visual is placed here. + * This colormap must eventually be + * freed by calling Tk_FreeColormap. */ +{ + Tk_Window tkwin2; + XVisualInfo template, *visInfoList, *bestPtr; + long mask; + Visual *visual; + int length, c, numVisuals, prio, bestPrio, i; + char *p; + VisualDictionary *dictPtr; + TkColormap *cmapPtr; + TkDisplay *dispPtr = ((TkWindow *) tkwin)->dispPtr; + + /* + * Parse string and set up a template for use in searching for + * an appropriate visual. + */ + + c = string[0]; + if (c == '.') { + /* + * The string must be a window name. If the window is on the + * same screen as tkwin, then just use its visual. Otherwise + * use the information about the visual as a template for the + * search. + */ + + tkwin2 = Tk_NameToWindow(interp, string, tkwin); + if (tkwin2 == NULL) { + return NULL; + } + visual = Tk_Visual(tkwin2); + if (Tk_Screen(tkwin) == Tk_Screen(tkwin2)) { + *depthPtr = Tk_Depth(tkwin2); + if (colormapPtr != NULL) { + /* + * Use the colormap from the other window too (but be sure + * to increment its reference count if it's one of the ones + * allocated here). + */ + + *colormapPtr = Tk_Colormap(tkwin2); + for (cmapPtr = dispPtr->cmapPtr; cmapPtr != NULL; + cmapPtr = cmapPtr->nextPtr) { + if (cmapPtr->colormap == *colormapPtr) { + cmapPtr->refCount += 1; + break; + } + } + } + return visual; + } + template.depth = Tk_Depth(tkwin2); + template.class = visual->class; + template.red_mask = visual->red_mask; + template.green_mask = visual->green_mask; + template.blue_mask = visual->blue_mask; + template.colormap_size = visual->map_entries; + template.bits_per_rgb = visual->bits_per_rgb; + mask = VisualDepthMask|VisualClassMask|VisualRedMaskMask + |VisualGreenMaskMask|VisualBlueMaskMask|VisualColormapSizeMask + |VisualBitsPerRGBMask; + } else if ((c == 0) || ((c == 'd') && (string[1] != 0) + && (strncmp(string, "default", strlen(string)) == 0))) { + /* + * Use the default visual for the window's screen. + */ + + if (colormapPtr != NULL) { + *colormapPtr = DefaultColormapOfScreen(Tk_Screen(tkwin)); + } + *depthPtr = DefaultDepthOfScreen(Tk_Screen(tkwin)); + return DefaultVisualOfScreen(Tk_Screen(tkwin)); + } else if (isdigit(UCHAR(c))) { + int visualId; + + /* + * This is a visual ID. + */ + + if (Tcl_GetInt(interp, string, &visualId) == TCL_ERROR) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad X identifier for visual: ", + string, "\"", (char *) NULL); + return NULL; + } + template.visualid = visualId; + mask = VisualIDMask; + } else { + /* + * Parse the string into a class name (or "best") optionally + * followed by whitespace and a depth. + */ + + for (p = string; *p != 0; p++) { + if (isspace(UCHAR(*p)) || isdigit(UCHAR(*p))) { + break; + } + } + length = p - string; + template.class = -1; + for (dictPtr = visualNames; dictPtr->name != NULL; dictPtr++) { + if ((dictPtr->name[0] == c) && (length >= dictPtr->minLength) + && (strncmp(string, dictPtr->name, + (size_t) length) == 0)) { + template.class = dictPtr->class; + break; + } + } + if (template.class == -1) { + Tcl_AppendResult(interp, "unknown or ambiguous visual name \"", + string, "\": class must be ", (char *) NULL); + for (dictPtr = visualNames; dictPtr->name != NULL; dictPtr++) { + Tcl_AppendResult(interp, dictPtr->name, ", ", (char *) NULL); + } + Tcl_AppendResult(interp, "or default", (char *) NULL); + return NULL; + } + while (isspace(UCHAR(*p))) { + p++; + } + if (*p == 0) { + template.depth = 10000; + } else { + if (Tcl_GetInt(interp, p, &template.depth) != TCL_OK) { + return NULL; + } + } + if (c == 'b') { + mask = 0; + } else { + mask = VisualClassMask; + } + } + + /* + * Find all visuals that match the template we've just created, + * and return an error if there are none that match. + */ + + template.screen = Tk_ScreenNumber(tkwin); + mask |= VisualScreenMask; + visInfoList = XGetVisualInfo(Tk_Display(tkwin), mask, &template, + &numVisuals); + if (visInfoList == NULL) { + interp->result = "couldn't find an appropriate visual"; + return NULL; + } + + /* + * Search through the visuals that were returned to find the best + * one. The choice is based on the following criteria, in decreasing + * order of importance: + * + * 1. Depth: choose a visual with exactly the desired depth, + * else one with more bits than requested but as few bits + * as possible, else one with fewer bits but as many as + * possible. + * 2. Class: some visual classes are more desirable than others; + * pick the visual with the most desirable class. + * 3. Default: the default visual for the screen gets preference + * over other visuals, all else being equal. + */ + + bestPrio = 0; + bestPtr = NULL; + for (i = 0; i < numVisuals; i++) { + switch (visInfoList[i].class) { + case DirectColor: prio = 5; break; + case GrayScale: prio = 1; break; + case PseudoColor: prio = 7; break; + case StaticColor: prio = 3; break; + case StaticGray: prio = 1; break; + case TrueColor: prio = 5; break; + default: prio = 0; break; + } + if (visInfoList[i].visual + == DefaultVisualOfScreen(Tk_Screen(tkwin))) { + prio++; + } + if (bestPtr == NULL) { + goto newBest; + } + if (visInfoList[i].depth < bestPtr->depth) { + if (visInfoList[i].depth >= template.depth) { + goto newBest; + } + } else if (visInfoList[i].depth > bestPtr->depth) { + if (bestPtr->depth < template.depth) { + goto newBest; + } + } else { + if (prio > bestPrio) { + goto newBest; + } + } + continue; + + newBest: + bestPtr = &visInfoList[i]; + bestPrio = prio; + } + *depthPtr = bestPtr->depth; + visual = bestPtr->visual; + XFree((char *) visInfoList); + + /* + * If we need to find a colormap for this visual, do it now. + * If the visual is the default visual for the screen, then + * use the default colormap. Otherwise search for an existing + * colormap that's shareable. If all else fails, create a new + * colormap. + */ + + if (colormapPtr != NULL) { + if (visual == DefaultVisualOfScreen(Tk_Screen(tkwin))) { + *colormapPtr = DefaultColormapOfScreen(Tk_Screen(tkwin)); + } else { + for (cmapPtr = dispPtr->cmapPtr; cmapPtr != NULL; + cmapPtr = cmapPtr->nextPtr) { + if (cmapPtr->shareable && (cmapPtr->visual == visual)) { + *colormapPtr = cmapPtr->colormap; + cmapPtr->refCount += 1; + goto done; + } + } + cmapPtr = (TkColormap *) ckalloc(sizeof(TkColormap)); + cmapPtr->colormap = XCreateColormap(Tk_Display(tkwin), + RootWindowOfScreen(Tk_Screen(tkwin)), visual, + AllocNone); + cmapPtr->visual = visual; + cmapPtr->refCount = 1; + cmapPtr->shareable = 1; + cmapPtr->nextPtr = dispPtr->cmapPtr; + dispPtr->cmapPtr = cmapPtr; + *colormapPtr = cmapPtr->colormap; + } + } + + done: + return visual; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_GetColormap -- + * + * Given a string identifying a colormap, this procedure finds + * an appropriate colormap. + * + * 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. + * + * Side effects: + * A reference count is incremented for the colormap, so + * Tk_FreeColormap must eventually be called exactly once for + * each call to Tk_GetColormap. + * + *---------------------------------------------------------------------- + */ + +Colormap +Tk_GetColormap(interp, tkwin, string) + Tcl_Interp *interp; /* Interpreter to use for error + * reporting. */ + Tk_Window tkwin; /* Window where colormap will be + * used. */ + char *string; /* String that identifies colormap: + * either "new" or the name of + * another window. */ +{ + Colormap colormap; + TkColormap *cmapPtr; + TkDisplay *dispPtr = ((TkWindow *) tkwin)->dispPtr; + Tk_Window other; + + /* + * Allocate a new colormap, if that's what is wanted. + */ + + if (strcmp(string, "new") == 0) { + cmapPtr = (TkColormap *) ckalloc(sizeof(TkColormap)); + cmapPtr->colormap = XCreateColormap(Tk_Display(tkwin), + RootWindowOfScreen(Tk_Screen(tkwin)), Tk_Visual(tkwin), + AllocNone); + cmapPtr->visual = Tk_Visual(tkwin); + cmapPtr->refCount = 1; + cmapPtr->shareable = 0; + cmapPtr->nextPtr = dispPtr->cmapPtr; + dispPtr->cmapPtr = cmapPtr; + return cmapPtr->colormap; + } + + /* + * Use a colormap from an existing window. It must have the same + * visual as tkwin (which means, among other things, that the + * other window must be on the same screen). + */ + + other = Tk_NameToWindow(interp, string, tkwin); + if (other == NULL) { + return None; + } + if (Tk_Screen(other) != Tk_Screen(tkwin)) { + Tcl_AppendResult(interp, "can't use colormap for ", string, + ": not on same screen", (char *) NULL); + return None; + } + if (Tk_Visual(other) != Tk_Visual(tkwin)) { + Tcl_AppendResult(interp, "can't use colormap for ", string, + ": incompatible visuals", (char *) NULL); + return None; + } + colormap = Tk_Colormap(other); + + /* + * If the colormap was a special one allocated by code in this file, + * increment its reference count. + */ + + for (cmapPtr = dispPtr->cmapPtr; cmapPtr != NULL; + cmapPtr = cmapPtr->nextPtr) { + if (cmapPtr->colormap == colormap) { + cmapPtr->refCount += 1; + } + } + return colormap; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_FreeColormap -- + * + * This procedure is called to release a colormap that was + * previously allocated by Tk_GetColormap. + * + * Results: + * None. + * + * Side effects: + * The colormap's reference count is decremented. If this was the + * last reference to the colormap, then the colormap is freed. + * + *---------------------------------------------------------------------- + */ + +void +Tk_FreeColormap(display, colormap) + Display *display; /* Display for which colormap was + * allocated. */ + Colormap colormap; /* Colormap that is no longer needed. + * Must have been returned by previous + * call to Tk_GetColormap, or + * preserved by a previous call to + * Tk_PreserveColormap. */ +{ + TkDisplay *dispPtr; + TkColormap *cmapPtr, *prevPtr; + + /* + * Find Tk's information about the display, then see if this + * colormap is a non-default one (if it's a default one, there + * won't be an entry for it in the display's list). + */ + + dispPtr = TkGetDisplay(display); + if (dispPtr == NULL) { + panic("unknown display passed to Tk_FreeColormap"); + } + for (prevPtr = NULL, cmapPtr = dispPtr->cmapPtr; cmapPtr != NULL; + prevPtr = cmapPtr, cmapPtr = cmapPtr->nextPtr) { + if (cmapPtr->colormap == colormap) { + cmapPtr->refCount -= 1; + if (cmapPtr->refCount == 0) { + XFreeColormap(display, colormap); + if (prevPtr == NULL) { + dispPtr->cmapPtr = cmapPtr->nextPtr; + } else { + prevPtr->nextPtr = cmapPtr->nextPtr; + } + ckfree((char *) cmapPtr); + } + return; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tk_PreserveColormap -- + * + * This procedure is called to indicate to Tk that the specified + * colormap is being referenced from another location and should + * not be freed until all extra references are eliminated. The + * colormap must have been returned by Tk_GetColormap. + * + * Results: + * None. + * + * Side effects: + * The colormap's reference count is incremented, so + * Tk_FreeColormap must eventually be called exactly once for + * each call to Tk_PreserveColormap. + * + *---------------------------------------------------------------------- + */ + +void +Tk_PreserveColormap(display, colormap) + Display *display; /* Display for which colormap was + * allocated. */ + Colormap colormap; /* Colormap that should be + * preserved. */ +{ + TkDisplay *dispPtr; + TkColormap *cmapPtr; + + /* + * Find Tk's information about the display, then see if this + * colormap is a non-default one (if it's a default one, there + * won't be an entry for it in the display's list). + */ + + dispPtr = TkGetDisplay(display); + if (dispPtr == NULL) { + panic("unknown display passed to Tk_PreserveColormap"); + } + for (cmapPtr = dispPtr->cmapPtr; cmapPtr != NULL; + cmapPtr = cmapPtr->nextPtr) { + if (cmapPtr->colormap == colormap) { + cmapPtr->refCount += 1; + return; + } + } +} diff --git a/generic/tkWindow.c b/generic/tkWindow.c new file mode 100644 index 0000000..fc9060a --- /dev/null +++ b/generic/tkWindow.c @@ -0,0 +1,2763 @@ +/* + * tkWindow.c -- + * + * This file provides basic window-manipulation procedures, + * which are equivalent to procedures in Xlib (and even + * invoke them) but also maintain the local Tk_Window + * structure. + * + * Copyright (c) 1989-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: @(#) tkWindow.c 1.233 97/10/31 09:55:23 + */ + +#include "tkPort.h" +#include "tkInt.h" + +/* + * Count of number of main windows currently open in this process. + */ + +static int numMainWindows; + +/* + * First in list of all main windows managed by this process. + */ + +TkMainInfo *tkMainWindowList = NULL; + +/* + * List of all displays currently in use. + */ + +TkDisplay *tkDisplayList = NULL; + +/* + * Have statics in this module been initialized? + */ + +static int initialized = 0; + +/* + * The variables below hold several uid's that are used in many places + * in the toolkit. + */ + +Tk_Uid tkDisabledUid = NULL; +Tk_Uid tkActiveUid = NULL; +Tk_Uid tkNormalUid = NULL; + +/* + * Default values for "changes" and "atts" fields of TkWindows. Note + * that Tk always requests all events for all windows, except StructureNotify + * events on internal windows: these events are generated internally. + */ + +static XWindowChanges defChanges = { + 0, 0, 1, 1, 0, 0, Above +}; +#define ALL_EVENTS_MASK \ + KeyPressMask|KeyReleaseMask|ButtonPressMask|ButtonReleaseMask| \ + EnterWindowMask|LeaveWindowMask|PointerMotionMask|ExposureMask| \ + VisibilityChangeMask|PropertyChangeMask|ColormapChangeMask +static XSetWindowAttributes defAtts= { + None, /* background_pixmap */ + 0, /* background_pixel */ + CopyFromParent, /* border_pixmap */ + 0, /* border_pixel */ + NorthWestGravity, /* bit_gravity */ + NorthWestGravity, /* win_gravity */ + NotUseful, /* backing_store */ + (unsigned) ~0, /* backing_planes */ + 0, /* backing_pixel */ + False, /* save_under */ + ALL_EVENTS_MASK, /* event_mask */ + 0, /* do_not_propagate_mask */ + False, /* override_redirect */ + CopyFromParent, /* colormap */ + None /* cursor */ +}; + +/* + * The following structure defines all of the commands supported by + * Tk, and the C procedures that execute them. + */ + +typedef struct { + char *name; /* Name of command. */ + Tcl_CmdProc *cmdProc; /* Command's string-based procedure. */ + Tcl_ObjCmdProc *objProc; /* Command's object-based procedure. */ + int isSafe; /* If !0, this command will be exposed in + * a safe interpreter. Otherwise it will be + * hidden in a safe interpreter. */ +} TkCmd; + +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}, + + /* + * 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}, + + /* + * Misc. + */ + +#ifdef MAC_TCL + {"unsupported1", TkUnsupported1Cmd, NULL, 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. + */ + +static int synchronize = 0; +static char *name = NULL; +static char *display = NULL; +static char *geometry = NULL; +static char *colormap = NULL; +static char *use = NULL; +static char *visual = NULL; +static int rest = 0; + +static Tk_ArgvInfo argTable[] = { + {"-colormap", TK_ARGV_STRING, (char *) NULL, (char *) &colormap, + "Colormap for main window"}, + {"-display", TK_ARGV_STRING, (char *) NULL, (char *) &display, + "Display to use"}, + {"-geometry", TK_ARGV_STRING, (char *) NULL, (char *) &geometry, + "Initial geometry for window"}, + {"-name", TK_ARGV_STRING, (char *) NULL, (char *) &name, + "Name to use for application"}, + {"-sync", TK_ARGV_CONSTANT, (char *) 1, (char *) &synchronize, + "Use synchronous mode for display server"}, + {"-visual", TK_ARGV_STRING, (char *) NULL, (char *) &visual, + "Visual for main window"}, + {"-use", TK_ARGV_STRING, (char *) NULL, (char *) &use, + "Id of window in which to embed application"}, + {"--", TK_ARGV_REST, (char *) 1, (char *) &rest, + "Pass all remaining arguments through to script"}, + {(char *) NULL, TK_ARGV_END, (char *) NULL, (char *) NULL, + (char *) NULL} +}; + +/* + * Forward declarations to procedures defined later in this file: + */ + +static Tk_Window CreateTopLevelWindow _ANSI_ARGS_((Tcl_Interp *interp, + Tk_Window parent, char *name, char *screenName)); +static void DeleteWindowsExitProc _ANSI_ARGS_(( + ClientData clientData)); +static TkDisplay * GetScreen _ANSI_ARGS_((Tcl_Interp *interp, + char *screenName, int *screenPtr)); +static int Initialize _ANSI_ARGS_((Tcl_Interp *interp)); +static int NameWindow _ANSI_ARGS_((Tcl_Interp *interp, + TkWindow *winPtr, TkWindow *parentPtr, + char *name)); +static void OpenIM _ANSI_ARGS_((TkDisplay *dispPtr)); +static void UnlinkWindow _ANSI_ARGS_((TkWindow *winPtr)); + +/* + *---------------------------------------------------------------------- + * + * CreateTopLevelWindow -- + * + * Make a new window that will be at top-level (its parent will + * be the root window of a screen). + * + * Results: + * 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. + * + * Side effects: + * A new window structure is allocated locally. An X + * window is NOT initially created, but will be created + * the first time the window is mapped. + * + *---------------------------------------------------------------------- + */ + +static Tk_Window +CreateTopLevelWindow(interp, parent, name, screenName) + Tcl_Interp *interp; /* Interpreter to use for error reporting. */ + Tk_Window parent; /* Token for logical parent of new window + * (used for naming, options, etc.). May + * be NULL. */ + char *name; /* Name for new window; if parent is + * non-NULL, must be unique among parent's + * children. */ + char *screenName; /* Name of screen on which to create + * window. NULL means use DISPLAY environment + * variable to determine. Empty string means + * use parent's screen, or DISPLAY if no + * parent. */ +{ + register TkWindow *winPtr; + register TkDisplay *dispPtr; + int screenId; + + if (!initialized) { + initialized = 1; + tkActiveUid = Tk_GetUid("active"); + tkDisabledUid = Tk_GetUid("disabled"); + tkNormalUid = Tk_GetUid("normal"); + + /* + * Create built-in image types. + */ + + Tk_CreateImageType(&tkBitmapImageType); + Tk_CreateImageType(&tkPhotoImageType); + + /* + * Create built-in photo image formats. + */ + + Tk_CreatePhotoImageFormat(&tkImgFmtGIF); + Tk_CreatePhotoImageFormat(&tkImgFmtPPM); + + /* + * Create exit handler to delete all windows when the application + * exits. + */ + + Tcl_CreateExitHandler(DeleteWindowsExitProc, (ClientData) NULL); + } + + if ((parent != NULL) && (screenName != NULL) && (screenName[0] == '\0')) { + dispPtr = ((TkWindow *) parent)->dispPtr; + screenId = Tk_ScreenNumber(parent); + } else { + dispPtr = GetScreen(interp, screenName, &screenId); + if (dispPtr == NULL) { + return (Tk_Window) NULL; + } + } + + winPtr = TkAllocWindow(dispPtr, screenId, (TkWindow *) parent); + + /* + * Force the window to use a border pixel instead of border pixmap. + * This is needed for the case where the window doesn't use the + * default visual. In this case, the default border is a pixmap + * inherited from the root window, which won't work because it will + * have the wrong visual. + */ + + winPtr->dirtyAtts |= CWBorderPixel; + + /* + * (Need to set the TK_TOP_LEVEL flag immediately here; otherwise + * Tk_DestroyWindow will core dump if it is called before the flag + * has been set.) + */ + + winPtr->flags |= TK_TOP_LEVEL; + + if (parent != NULL) { + if (NameWindow(interp, winPtr, (TkWindow *) parent, name) != TCL_OK) { + Tk_DestroyWindow((Tk_Window) winPtr); + return (Tk_Window) NULL; + } + } + TkWmNewWindow(winPtr); + + return (Tk_Window) winPtr; +} + +/* + *---------------------------------------------------------------------- + * + * GetScreen -- + * + * Given a string name for a display-plus-screen, find the + * TkDisplay structure for the display and return the screen + * number too. + * + * 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 + * *screenPtr is overwritten with the screen number parsed from + * screenName. + * + * Side effects: + * A new connection is opened to the display if there is no + * connection already. A new TkDisplay data structure is also + * setup, if necessary. + * + *---------------------------------------------------------------------- + */ + +static TkDisplay * +GetScreen(interp, screenName, screenPtr) + Tcl_Interp *interp; /* Place to leave error message. */ + char *screenName; /* Name for screen. NULL or empty means + * use DISPLAY envariable. */ + int *screenPtr; /* Where to store screen number. */ +{ + register TkDisplay *dispPtr; + char *p; + int screenId; + size_t length; + + /* + * Separate the screen number from the rest of the display + * name. ScreenName is assumed to have the syntax + * . with the dot and the screen being + * optional. + */ + + screenName = TkGetDefaultScreenName(interp, screenName); + if (screenName == NULL) { + interp->result = + "no display name and no $DISPLAY environment variable"; + return (TkDisplay *) NULL; + } + length = strlen(screenName); + screenId = 0; + p = screenName+length-1; + while (isdigit(UCHAR(*p)) && (p != screenName)) { + p--; + } + if ((*p == '.') && (p[1] != '\0')) { + length = p - screenName; + screenId = strtoul(p+1, (char **) NULL, 10); + } + + /* + * See if we already have a connection to this display. If not, + * then open a new connection. + */ + + for (dispPtr = tkDisplayList; ; dispPtr = dispPtr->nextPtr) { + if (dispPtr == NULL) { + dispPtr = TkpOpenDisplay(screenName); + if (dispPtr == NULL) { + Tcl_AppendResult(interp, "couldn't connect to display \"", + screenName, "\"", (char *) NULL); + return (TkDisplay *) NULL; + } + dispPtr->nextPtr = tkDisplayList; + dispPtr->name = (char *) ckalloc((unsigned) (length+1)); + dispPtr->lastEventTime = CurrentTime; + strncpy(dispPtr->name, screenName, length); + dispPtr->name[length] = '\0'; + dispPtr->bindInfoStale = 1; + dispPtr->modeModMask = 0; + dispPtr->metaModMask = 0; + dispPtr->altModMask = 0; + dispPtr->numModKeyCodes = 0; + dispPtr->modKeyCodes = NULL; + OpenIM(dispPtr); + dispPtr->errorPtr = NULL; + dispPtr->deleteCount = 0; + dispPtr->commTkwin = NULL; + dispPtr->selectionInfoPtr = NULL; + dispPtr->multipleAtom = None; + dispPtr->clipWindow = NULL; + dispPtr->clipboardActive = 0; + dispPtr->clipboardAppPtr = NULL; + dispPtr->clipTargetPtr = NULL; + dispPtr->atomInit = 0; + dispPtr->cursorFont = None; + dispPtr->grabWinPtr = NULL; + dispPtr->eventualGrabWinPtr = NULL; + dispPtr->buttonWinPtr = NULL; + dispPtr->serverWinPtr = NULL; + dispPtr->firstGrabEventPtr = NULL; + dispPtr->lastGrabEventPtr = NULL; + dispPtr->grabFlags = 0; + TkInitXId(dispPtr); + dispPtr->destroyCount = 0; + dispPtr->lastDestroyRequest = 0; + dispPtr->cmapPtr = NULL; + dispPtr->implicitWinPtr = NULL; + dispPtr->focusPtr = NULL; + dispPtr->stressPtr = NULL; + dispPtr->delayedMotionPtr = NULL; + Tcl_InitHashTable(&dispPtr->winTable, TCL_ONE_WORD_KEYS); + dispPtr->refCount = 0; + + tkDisplayList = dispPtr; + break; + } + if ((strncmp(dispPtr->name, screenName, length) == 0) + && (dispPtr->name[length] == '\0')) { + break; + } + } + if (screenId >= ScreenCount(dispPtr->display)) { + sprintf(interp->result, "bad screen number \"%d\"", screenId); + return (TkDisplay *) NULL; + } + *screenPtr = screenId; + return dispPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TkGetDisplay -- + * + * Given an X display, TkGetDisplay returns the TkDisplay + * structure for the display. + * + * Results: + * The return value is a pointer to information about the display, + * or NULL if the display did not have a TkDisplay structure. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +TkDisplay * +TkGetDisplay(display) + Display *display; /* X's display pointer */ +{ + TkDisplay *dispPtr; + + for (dispPtr = tkDisplayList; dispPtr != NULL; + dispPtr = dispPtr->nextPtr) { + if (dispPtr->display == display) { + break; + } + } + return dispPtr; +} + +/* + *-------------------------------------------------------------- + * + * TkAllocWindow -- + * + * This procedure creates and initializes a TkWindow structure. + * + * Results: + * The return value is a pointer to the new window. + * + * Side effects: + * A new window structure is allocated and all its fields are + * initialized. + * + *-------------------------------------------------------------- + */ + +TkWindow * +TkAllocWindow(dispPtr, screenNum, parentPtr) + TkDisplay *dispPtr; /* Display associated with new window. */ + int screenNum; /* Index of screen for new window. */ + TkWindow *parentPtr; /* Parent from which this window should + * inherit visual information. NULL means + * use screen defaults instead of + * inheriting. */ +{ + register TkWindow *winPtr; + + winPtr = (TkWindow *) ckalloc(sizeof(TkWindow)); + winPtr->display = dispPtr->display; + winPtr->dispPtr = dispPtr; + winPtr->screenNum = screenNum; + if ((parentPtr != NULL) && (parentPtr->display == winPtr->display) + && (parentPtr->screenNum == winPtr->screenNum)) { + winPtr->visual = parentPtr->visual; + winPtr->depth = parentPtr->depth; + } else { + winPtr->visual = DefaultVisual(dispPtr->display, screenNum); + winPtr->depth = DefaultDepth(dispPtr->display, screenNum); + } + winPtr->window = None; + winPtr->childList = NULL; + winPtr->lastChildPtr = NULL; + winPtr->parentPtr = NULL; + winPtr->nextPtr = NULL; + winPtr->mainPtr = NULL; + winPtr->pathName = NULL; + winPtr->nameUid = NULL; + winPtr->classUid = NULL; + winPtr->changes = defChanges; + winPtr->dirtyChanges = CWX|CWY|CWWidth|CWHeight|CWBorderWidth; + winPtr->atts = defAtts; + if ((parentPtr != NULL) && (parentPtr->display == winPtr->display) + && (parentPtr->screenNum == winPtr->screenNum)) { + winPtr->atts.colormap = parentPtr->atts.colormap; + } else { + winPtr->atts.colormap = DefaultColormap(dispPtr->display, screenNum); + } + winPtr->dirtyAtts = CWEventMask|CWColormap|CWBitGravity; + winPtr->flags = 0; + winPtr->handlerList = NULL; +#ifdef TK_USE_INPUT_METHODS + winPtr->inputContext = NULL; +#endif /* TK_USE_INPUT_METHODS */ + winPtr->tagPtr = NULL; + winPtr->numTags = 0; + winPtr->optionLevel = -1; + winPtr->selHandlerList = NULL; + winPtr->geomMgrPtr = NULL; + winPtr->geomData = NULL; + winPtr->reqWidth = winPtr->reqHeight = 1; + winPtr->internalBorderWidth = 0; + winPtr->wmInfoPtr = NULL; + winPtr->classProcsPtr = NULL; + winPtr->instanceData = NULL; + winPtr->privatePtr = NULL; + + return winPtr; +} + +/* + *---------------------------------------------------------------------- + * + * NameWindow -- + * + * This procedure is invoked to give a window a name and insert + * the window into the hierarchy associated with a particular + * application. + * + * Results: + * A standard Tcl return value. + * + * Side effects: + * See above. + * + *---------------------------------------------------------------------- + */ + +static int +NameWindow(interp, winPtr, parentPtr, name) + Tcl_Interp *interp; /* Interpreter to use for error reporting. */ + register TkWindow *winPtr; /* Window that is to be named and inserted. */ + TkWindow *parentPtr; /* Pointer to logical parent for winPtr + * (used for naming, options, etc.). */ + char *name; /* Name for winPtr; must be unique among + * parentPtr's children. */ +{ +#define FIXED_SIZE 200 + char staticSpace[FIXED_SIZE]; + char *pathName; + int new; + Tcl_HashEntry *hPtr; + int length1, length2; + + /* + * Setup all the stuff except name right away, then do the name stuff + * last. This is so that if the name stuff fails, everything else + * will be properly initialized (needed to destroy the window cleanly + * after the naming failure). + */ + winPtr->parentPtr = parentPtr; + winPtr->nextPtr = NULL; + if (parentPtr->childList == NULL) { + parentPtr->childList = winPtr; + } else { + parentPtr->lastChildPtr->nextPtr = winPtr; + } + parentPtr->lastChildPtr = winPtr; + winPtr->mainPtr = parentPtr->mainPtr; + winPtr->mainPtr->refCount++; + winPtr->nameUid = Tk_GetUid(name); + + /* + * Don't permit names that start with an upper-case letter: this + * will just cause confusion with class names in the option database. + */ + + if (isupper(UCHAR(name[0]))) { + Tcl_AppendResult(interp, + "window name starts with an upper-case letter: \"", + name, "\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * To permit names of arbitrary length, must be prepared to malloc + * a buffer to hold the new path name. To run fast in the common + * case where names are short, use a fixed-size buffer on the + * stack. + */ + + length1 = strlen(parentPtr->pathName); + length2 = strlen(name); + if ((length1+length2+2) <= FIXED_SIZE) { + pathName = staticSpace; + } else { + pathName = (char *) ckalloc((unsigned) (length1+length2+2)); + } + if (length1 == 1) { + pathName[0] = '.'; + strcpy(pathName+1, name); + } else { + strcpy(pathName, parentPtr->pathName); + pathName[length1] = '.'; + strcpy(pathName+length1+1, name); + } + hPtr = Tcl_CreateHashEntry(&parentPtr->mainPtr->nameTable, pathName, &new); + if (pathName != staticSpace) { + ckfree(pathName); + } + if (!new) { + Tcl_AppendResult(interp, "window name \"", name, + "\" already exists in parent", (char *) NULL); + return TCL_ERROR; + } + Tcl_SetHashValue(hPtr, winPtr); + winPtr->pathName = Tcl_GetHashKey(&parentPtr->mainPtr->nameTable, hPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TkCreateMainWindow -- + * + * Make a new main window. A main window is a special kind of + * top-level window used as the outermost window in an + * application. + * + * Results: + * 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. + * + * Side effects: + * A new window structure is allocated locally; "interp" is + * associated with the window and registered for "send" commands + * under "baseName". BaseName may be extended with an instance + * number in the form "#2" if necessary to make it globally + * unique. Tk-related commands are bound into interp. + * + *---------------------------------------------------------------------- + */ + +Tk_Window +TkCreateMainWindow(interp, screenName, baseName) + Tcl_Interp *interp; /* Interpreter to use for error reporting. */ + char *screenName; /* Name of screen on which to create + * window. Empty or NULL string means + * use DISPLAY environment variable. */ + char *baseName; /* Base name for application; usually of the + * form "prog instance". */ +{ + Tk_Window tkwin; + int dummy; + int isSafe; + Tcl_HashEntry *hPtr; + register TkMainInfo *mainPtr; + register TkWindow *winPtr; + register TkCmd *cmdPtr; + + /* + * Panic if someone updated the TkWindow structure without + * also updating the Tk_FakeWin structure (or vice versa). + */ + + if (sizeof(TkWindow) != sizeof(Tk_FakeWin)) { + panic("TkWindow and Tk_FakeWin are not the same size"); + } + + /* + * Create the basic TkWindow structure. + */ + + tkwin = CreateTopLevelWindow(interp, (Tk_Window) NULL, baseName, + screenName); + if (tkwin == NULL) { + return NULL; + } + + /* + * Create the TkMainInfo structure for this application, and set + * up name-related information for the new window. + */ + + winPtr = (TkWindow *) tkwin; + mainPtr = (TkMainInfo *) ckalloc(sizeof(TkMainInfo)); + mainPtr->winPtr = winPtr; + mainPtr->refCount = 1; + mainPtr->interp = interp; + Tcl_InitHashTable(&mainPtr->nameTable, TCL_STRING_KEYS); + TkBindInit(mainPtr); + TkFontPkgInit(mainPtr); + mainPtr->tlFocusPtr = NULL; + mainPtr->displayFocusPtr = NULL; + mainPtr->optionRootPtr = NULL; + Tcl_InitHashTable(&mainPtr->imageTable, TCL_STRING_KEYS); + mainPtr->strictMotif = 0; + if (Tcl_LinkVar(interp, "tk_strictMotif", (char *) &mainPtr->strictMotif, + TCL_LINK_BOOLEAN) != TCL_OK) { + Tcl_ResetResult(interp); + } + mainPtr->nextPtr = tkMainWindowList; + tkMainWindowList = mainPtr; + winPtr->mainPtr = mainPtr; + hPtr = Tcl_CreateHashEntry(&mainPtr->nameTable, ".", &dummy); + Tcl_SetHashValue(hPtr, winPtr); + winPtr->pathName = Tcl_GetHashKey(&mainPtr->nameTable, hPtr); + + /* + * We have just created another Tk application; increment the refcount + * on the display pointer. + */ + + winPtr->dispPtr->refCount++; + + /* + * Register the interpreter for "send" purposes. + */ + + winPtr->nameUid = Tk_GetUid(Tk_SetAppName(tkwin, baseName)); + + /* + * Bind in Tk's commands. + */ + + isSafe = Tcl_IsSafe(interp); + for (cmdPtr = commands; cmdPtr->name != NULL; cmdPtr++) { + if ((cmdPtr->cmdProc == NULL) && (cmdPtr->objProc == NULL)) { + panic("TkCreateMainWindow: builtin command with NULL string and object procs"); + } + if (cmdPtr->cmdProc != NULL) { + Tcl_CreateCommand(interp, cmdPtr->name, cmdPtr->cmdProc, + (ClientData) tkwin, (void (*) _ANSI_ARGS_((ClientData))) NULL); + } else { + Tcl_CreateObjCommand(interp, cmdPtr->name, cmdPtr->objProc, + (ClientData) tkwin, NULL); + } + if (isSafe) { + if (!(cmdPtr->isSafe)) { + Tcl_HideCommand(interp, cmdPtr->name, cmdPtr->name); + } + } + } + + /* + * Set variables for the intepreter. + */ + + Tcl_SetVar(interp, "tk_patchLevel", TK_PATCH_LEVEL, TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "tk_version", TK_VERSION, TCL_GLOBAL_ONLY); + + numMainWindows++; + return tkwin; +} + +/* + *-------------------------------------------------------------- + * + * Tk_CreateWindow -- + * + * Create a new internal or top-level window as a child of an + * existing window. + * + * Results: + * 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 + * NULL is returned. + * + * Side effects: + * A new window structure is allocated locally. An X + * window is not initially created, but will be created + * the first time the window is mapped. + * + *-------------------------------------------------------------- + */ + +Tk_Window +Tk_CreateWindow(interp, parent, name, screenName) + Tcl_Interp *interp; /* Interpreter to use for error reporting. + * Interp->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 + * among parent's children. */ + char *screenName; /* If NULL, new window will be internal on + * same screen as its parent. If non-NULL, + * gives name of screen on which to create + * new window; window will be a top-level + * window. */ +{ + TkWindow *parentPtr = (TkWindow *) parent; + TkWindow *winPtr; + + if ((parentPtr != NULL) && (parentPtr->flags & TK_ALREADY_DEAD)) { + Tcl_AppendResult(interp, + "can't create window: parent has been destroyed", + (char *) NULL); + return NULL; + } else if ((parentPtr != NULL) && + (parentPtr->flags & TK_CONTAINER)) { + Tcl_AppendResult(interp, + "can't create window: its parent has -container = yes", + (char *) NULL); + return NULL; + } + if (screenName == NULL) { + winPtr = TkAllocWindow(parentPtr->dispPtr, parentPtr->screenNum, + parentPtr); + if (NameWindow(interp, winPtr, parentPtr, name) != TCL_OK) { + Tk_DestroyWindow((Tk_Window) winPtr); + return NULL; + } else { + return (Tk_Window) winPtr; + } + } else { + return CreateTopLevelWindow(interp, parent, name, screenName); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tk_CreateWindowFromPath -- + * + * This procedure is similar to Tk_CreateWindow except that + * it uses a path name to create the window, rather than a + * parent and a child name. + * + * Results: + * 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 + * NULL is returned. + * + * Side effects: + * A new window structure is allocated locally. An X + * window is not initially created, but will be created + * the first time the window is mapped. + * + *---------------------------------------------------------------------- + */ + +Tk_Window +Tk_CreateWindowFromPath(interp, tkwin, pathName, screenName) + Tcl_Interp *interp; /* Interpreter to use for error reporting. + * Interp->result is assumed to be + * initialized by the caller. */ + Tk_Window tkwin; /* Token for any window in application + * that is to contain new window. */ + char *pathName; /* Path name for new window within the + * application of tkwin. The parent of + * this window must already exist, but + * the window itself must not exist. */ + char *screenName; /* If NULL, new window will be on same + * screen as its parent. If non-NULL, + * gives name of screen on which to create + * new window; window will be a top-level + * window. */ +{ +#define FIXED_SPACE 5 + char fixedSpace[FIXED_SPACE+1]; + char *p; + Tk_Window parent; + int numChars; + + /* + * Strip the parent's name out of pathName (it's everything up + * to the last dot). There are two tricky parts: (a) must + * copy the parent's name somewhere else to avoid modifying + * the pathName string (for large names, space for the copy + * will have to be malloc'ed); (b) must special-case the + * situation where the parent is ".". + */ + + p = strrchr(pathName, '.'); + if (p == NULL) { + Tcl_AppendResult(interp, "bad window path name \"", pathName, + "\"", (char *) NULL); + return NULL; + } + numChars = p-pathName; + if (numChars > FIXED_SPACE) { + p = (char *) ckalloc((unsigned) (numChars+1)); + } else { + p = fixedSpace; + } + if (numChars == 0) { + *p = '.'; + p[1] = '\0'; + } else { + strncpy(p, pathName, (size_t) numChars); + p[numChars] = '\0'; + } + + /* + * Find the parent window. + */ + + parent = Tk_NameToWindow(interp, p, tkwin); + if (p != fixedSpace) { + ckfree(p); + } + if (parent == NULL) { + return NULL; + } + if (((TkWindow *) parent)->flags & TK_ALREADY_DEAD) { + Tcl_AppendResult(interp, + "can't create window: parent has been destroyed", (char *) NULL); + return NULL; + } else if (((TkWindow *) parent)->flags & TK_CONTAINER) { + Tcl_AppendResult(interp, + "can't create window: its parent has -container = yes", + (char *) NULL); + return NULL; + } + + /* + * Create the window. + */ + + if (screenName == NULL) { + TkWindow *parentPtr = (TkWindow *) parent; + TkWindow *winPtr; + + winPtr = TkAllocWindow(parentPtr->dispPtr, parentPtr->screenNum, + parentPtr); + if (NameWindow(interp, winPtr, parentPtr, pathName+numChars+1) + != TCL_OK) { + Tk_DestroyWindow((Tk_Window) winPtr); + return NULL; + } else { + return (Tk_Window) winPtr; + } + } else { + return CreateTopLevelWindow(interp, parent, pathName+numChars+1, + screenName); + } +} + +/* + *-------------------------------------------------------------- + * + * Tk_DestroyWindow -- + * + * Destroy an existing window. After this call, the caller + * should never again use the token. + * + * Results: + * None. + * + * Side effects: + * The window is deleted, along with all of its children. + * Relevant callback procedures are invoked. + * + *-------------------------------------------------------------- + */ + +void +Tk_DestroyWindow(tkwin) + Tk_Window tkwin; /* Window to destroy. */ +{ + TkWindow *winPtr = (TkWindow *) tkwin; + TkDisplay *dispPtr = winPtr->dispPtr; + XEvent event; + + if (winPtr->flags & TK_ALREADY_DEAD) { + /* + * A destroy event binding caused the window to be destroyed + * again. Ignore the request. + */ + + return; + } + winPtr->flags |= TK_ALREADY_DEAD; + + /* + * Some cleanup needs to be done immediately, rather than later, + * because it needs information that will be destoyed before we + * get to the main cleanup point. For example, TkFocusDeadWindow + * needs to access the parentPtr field from a window, but if + * a Destroy event handler deletes the window's parent this + * field will be NULL before the main cleanup point is reached. + */ + + TkFocusDeadWindow(winPtr); + + /* + * If this is a main window, remove it from the list of main + * windows. This needs to be done now (rather than later with + * all the other main window cleanup) to handle situations where + * a destroy binding for a window calls "exit". In this case + * the child window cleanup isn't complete when exit is called, + * so the reference count of its application doesn't go to zero + * when exit calls Tk_DestroyWindow on ".", so the main window + * doesn't get removed from the list and exit loops infinitely. + * Even worse, if "destroy ." is called by the destroy binding + * before calling "exit", "exit" will attempt to destroy + * mainPtr->winPtr, which no longer exists, and there may be a + * core dump. + * + * Also decrement the display refcount so that if this is the + * last Tk application in this process on this display, the display + * can be closed and its data structures deleted. + */ + + if (winPtr->mainPtr->winPtr == winPtr) { + dispPtr->refCount--; + if (tkMainWindowList == winPtr->mainPtr) { + tkMainWindowList = winPtr->mainPtr->nextPtr; + } else { + TkMainInfo *prevPtr; + + for (prevPtr = tkMainWindowList; + prevPtr->nextPtr != winPtr->mainPtr; + prevPtr = prevPtr->nextPtr) { + /* Empty loop body. */ + } + prevPtr->nextPtr = winPtr->mainPtr->nextPtr; + } + numMainWindows--; + } + + /* + * Recursively destroy children. + */ + + dispPtr->destroyCount++; + while (winPtr->childList != NULL) { + TkWindow *childPtr; + childPtr = winPtr->childList; + childPtr->flags |= TK_DONT_DESTROY_WINDOW; + Tk_DestroyWindow((Tk_Window) childPtr); + if (winPtr->childList == childPtr) { + /* + * The child didn't remove itself from the child list, so + * let's remove it here. This can happen in some strange + * conditions, such as when a Delete event handler for a + * window deletes the window's parent. + */ + + winPtr->childList = childPtr->nextPtr; + childPtr->parentPtr = NULL; + } + } + if ((winPtr->flags & (TK_CONTAINER|TK_BOTH_HALVES)) + == (TK_CONTAINER|TK_BOTH_HALVES)) { + /* + * This is the container for an embedded application, and + * the embedded application is also in this process. Delete + * the embedded window in-line here, for the same reasons we + * delete children in-line (otherwise, for example, the Tk + * window may appear to exist even though its X window is + * gone; this could cause errors). Special note: it's possible + * that the embedded window has already been deleted, in which + * case TkpGetOtherWindow will return NULL. + */ + + TkWindow *childPtr; + childPtr = TkpGetOtherWindow(winPtr); + if (childPtr != NULL) { + childPtr->flags |= TK_DONT_DESTROY_WINDOW; + Tk_DestroyWindow((Tk_Window) childPtr); + } + } + + /* + * Generate a DestroyNotify event. In order for the DestroyNotify + * event to be processed correctly, need to make sure the window + * exists. This is a bit of a kludge, and may be unnecessarily + * expensive, but without it no event handlers will get called for + * windows that don't exist yet. + * + * Note: if the window's pathName is NULL it means that the window + * was not successfully initialized in the first place, so we should + * not make the window exist or generate the event. + */ + + if (winPtr->pathName != NULL) { + if (winPtr->window == None) { + Tk_MakeWindowExist(tkwin); + } + event.type = DestroyNotify; + event.xdestroywindow.serial = + LastKnownRequestProcessed(winPtr->display); + event.xdestroywindow.send_event = False; + event.xdestroywindow.display = winPtr->display; + event.xdestroywindow.event = winPtr->window; + event.xdestroywindow.window = winPtr->window; + Tk_HandleEvent(&event); + } + + /* + * Cleanup the data structures associated with this window. + */ + + if (winPtr->flags & TK_TOP_LEVEL) { + TkWmDeadWindow(winPtr); + } else if (winPtr->flags & TK_WM_COLORMAP_WINDOW) { + TkWmRemoveFromColormapWindows(winPtr); + } + if (winPtr->window != None) { +#if defined(MAC_TCL) || defined(__WIN32__) + XDestroyWindow(winPtr->display, winPtr->window); +#else + if ((winPtr->flags & TK_TOP_LEVEL) + || !(winPtr->flags & TK_DONT_DESTROY_WINDOW)) { + /* + * The parent has already been destroyed and this isn't + * a top-level window, so this window will be destroyed + * implicitly when the parent's X window is destroyed; + * it's much faster not to do an explicit destroy of this + * X window. + */ + + dispPtr->lastDestroyRequest = NextRequest(winPtr->display); + XDestroyWindow(winPtr->display, winPtr->window); + } +#endif + TkFreeWindowId(dispPtr, winPtr->window); + Tcl_DeleteHashEntry(Tcl_FindHashEntry(&dispPtr->winTable, + (char *) winPtr->window)); + winPtr->window = None; + } + dispPtr->destroyCount--; + UnlinkWindow(winPtr); + TkEventDeadWindow(winPtr); + TkBindDeadWindow(winPtr); +#ifdef TK_USE_INPUT_METHODS + if (winPtr->inputContext != NULL) { + XDestroyIC(winPtr->inputContext); + } +#endif /* TK_USE_INPUT_METHODS */ + if (winPtr->tagPtr != NULL) { + TkFreeBindingTags(winPtr); + } + TkOptionDeadWindow(winPtr); + TkSelDeadWindow(winPtr); + TkGrabDeadWindow(winPtr); + if (winPtr->mainPtr != NULL) { + if (winPtr->pathName != NULL) { + Tk_DeleteAllBindings(winPtr->mainPtr->bindingTable, + (ClientData) winPtr->pathName); + Tcl_DeleteHashEntry(Tcl_FindHashEntry(&winPtr->mainPtr->nameTable, + winPtr->pathName)); + } + winPtr->mainPtr->refCount--; + if (winPtr->mainPtr->refCount == 0) { + register TkCmd *cmdPtr; + + /* + * We just deleted the last window in the application. Delete + * the TkMainInfo structure too and replace all of Tk's commands + * with dummy commands that return errors. Also delete the + * "send" command to unregister the interpreter. + * + * NOTE: Only replace the commands it if the interpreter is + * not being deleted. If it *is*, the interpreter cleanup will + * do all the needed work. + */ + + if ((winPtr->mainPtr->interp != NULL) && + (!Tcl_InterpDeleted(winPtr->mainPtr->interp))) { + for (cmdPtr = commands; cmdPtr->name != NULL; cmdPtr++) { + Tcl_CreateCommand(winPtr->mainPtr->interp, cmdPtr->name, + TkDeadAppCmd, (ClientData) NULL, + (void (*) _ANSI_ARGS_((ClientData))) NULL); + } + Tcl_CreateCommand(winPtr->mainPtr->interp, "send", + TkDeadAppCmd, (ClientData) NULL, + (void (*) _ANSI_ARGS_((ClientData))) NULL); + Tcl_UnlinkVar(winPtr->mainPtr->interp, "tk_strictMotif"); + } + + Tcl_DeleteHashTable(&winPtr->mainPtr->nameTable); + TkBindFree(winPtr->mainPtr); + TkFontPkgFree(winPtr->mainPtr); + TkDeleteAllImages(winPtr->mainPtr); + + /* + * When embedding Tk into other applications, make sure + * that all destroy events reach the server. Otherwise + * the embedding application may also attempt to destroy + * the windows, resulting in an X error + */ + + if (winPtr->flags & TK_EMBEDDED) { + XSync(winPtr->display,False) ; + } + ckfree((char *) winPtr->mainPtr); + + /* + * If no other applications are using the display, close the + * display now and relinquish its data structures. + */ + + if (dispPtr->refCount <= 0) { +#ifdef NOT_YET + /* + * I have disabled this code because on Windows there are + * still order dependencies in close-down. All displays + * and resources will get closed down properly anyway at + * exit, through the exit handler. + */ + + TkDisplay *theDispPtr, *backDispPtr; + + /* + * Splice this display out of the list of displays. + */ + + for (theDispPtr = tkDisplayList, backDispPtr = NULL; + (theDispPtr != winPtr->dispPtr) && + (theDispPtr != NULL); + theDispPtr = theDispPtr->nextPtr) { + backDispPtr = theDispPtr; + } + if (theDispPtr == NULL) { + panic("could not find display to close!"); + } + if (backDispPtr == NULL) { + tkDisplayList = theDispPtr->nextPtr; + } else { + backDispPtr->nextPtr = theDispPtr->nextPtr; + } + + /* + * Found and spliced it out, now actually do the cleanup. + */ + + if (dispPtr->name != NULL) { + ckfree(dispPtr->name); + } + + Tcl_DeleteHashTable(&(dispPtr->winTable)); + + /* + * Cannot yet close the display because we still have + * order of deletion problems. Defer until exit handling + * instead. At that time, the display will cleanly shut + * down (hopefully..). (JYL) + */ + + TkpCloseDisplay(dispPtr); + + /* + * There is lots more to clean up, we leave it at this for + * the time being. + */ +#endif + } + } + } + ckfree((char *) winPtr); +} + +/* + *-------------------------------------------------------------- + * + * Tk_MapWindow -- + * + * Map a window within its parent. This may require the + * window and/or its parents to actually be created. + * + * Results: + * None. + * + * Side effects: + * The given window will be mapped. Windows may also + * be created. + * + *-------------------------------------------------------------- + */ + +void +Tk_MapWindow(tkwin) + Tk_Window tkwin; /* Token for window to map. */ +{ + register TkWindow *winPtr = (TkWindow *) tkwin; + XEvent event; + + if (winPtr->flags & TK_MAPPED) { + return; + } + if (winPtr->window == None) { + Tk_MakeWindowExist(tkwin); + } + if (winPtr->flags & TK_TOP_LEVEL) { + /* + * Lots of special processing has to be done for top-level + * windows. Let tkWm.c handle everything itself. + */ + + TkWmMapWindow(winPtr); + return; + } + winPtr->flags |= TK_MAPPED; + XMapWindow(winPtr->display, winPtr->window); + event.type = MapNotify; + event.xmap.serial = LastKnownRequestProcessed(winPtr->display); + event.xmap.send_event = False; + event.xmap.display = winPtr->display; + event.xmap.event = winPtr->window; + event.xmap.window = winPtr->window; + event.xmap.override_redirect = winPtr->atts.override_redirect; + Tk_HandleEvent(&event); +} + +/* + *-------------------------------------------------------------- + * + * Tk_MakeWindowExist -- + * + * Ensure that a particular window actually exists. This + * procedure shouldn't normally need to be invoked from + * outside the Tk package, but may be needed if someone + * wants to manipulate a window before mapping it. + * + * Results: + * None. + * + * Side effects: + * When the procedure returns, the X window associated with + * tkwin is guaranteed to exist. This may require the + * window's ancestors to be created also. + * + *-------------------------------------------------------------- + */ + +void +Tk_MakeWindowExist(tkwin) + Tk_Window tkwin; /* Token for window. */ +{ + register TkWindow *winPtr = (TkWindow *) tkwin; + TkWindow *winPtr2; + Window parent; + Tcl_HashEntry *hPtr; + int new; + + if (winPtr->window != None) { + return; + } + + if ((winPtr->parentPtr == NULL) || (winPtr->flags & TK_TOP_LEVEL)) { + parent = XRootWindow(winPtr->display, winPtr->screenNum); + } else { + if (winPtr->parentPtr->window == None) { + Tk_MakeWindowExist((Tk_Window) winPtr->parentPtr); + } + parent = winPtr->parentPtr->window; + } + + if (winPtr->classProcsPtr != NULL + && winPtr->classProcsPtr->createProc != NULL) { + winPtr->window = (*winPtr->classProcsPtr->createProc)(tkwin, parent, + winPtr->instanceData); + } else { + winPtr->window = TkpMakeWindow(winPtr, parent); + } + + hPtr = Tcl_CreateHashEntry(&winPtr->dispPtr->winTable, + (char *) winPtr->window, &new); + Tcl_SetHashValue(hPtr, winPtr); + winPtr->dirtyAtts = 0; + winPtr->dirtyChanges = 0; +#ifdef TK_USE_INPUT_METHODS + winPtr->inputContext = NULL; +#endif /* TK_USE_INPUT_METHODS */ + + if (!(winPtr->flags & TK_TOP_LEVEL)) { + /* + * If any siblings higher up in the stacking order have already + * been created then move this window to its rightful position + * in the stacking order. + * + * NOTE: this code ignores any changes anyone might have made + * to the sibling and stack_mode field of the window's attributes, + * so it really isn't safe for these to be manipulated except + * by calling Tk_RestackWindow. + */ + + for (winPtr2 = winPtr->nextPtr; winPtr2 != NULL; + winPtr2 = winPtr2->nextPtr) { + if ((winPtr2->window != None) + && !(winPtr2->flags & (TK_TOP_LEVEL|TK_REPARENTED))) { + XWindowChanges changes; + changes.sibling = winPtr2->window; + changes.stack_mode = Below; + XConfigureWindow(winPtr->display, winPtr->window, + CWSibling|CWStackMode, &changes); + break; + } + } + + /* + * If this window has a different colormap than its parent, add + * the window to the WM_COLORMAP_WINDOWS property for its top-level. + */ + + if ((winPtr->parentPtr != NULL) && + (winPtr->atts.colormap != winPtr->parentPtr->atts.colormap)) { + TkWmAddToColormapWindows(winPtr); + winPtr->flags |= TK_WM_COLORMAP_WINDOW; + } + } + + /* + * Issue a ConfigureNotify event if there were deferred configuration + * changes (but skip it if the window is being deleted; the + * ConfigureNotify event could cause problems if we're being called + * from Tk_DestroyWindow under some conditions). + */ + + if ((winPtr->flags & TK_NEED_CONFIG_NOTIFY) + && !(winPtr->flags & TK_ALREADY_DEAD)){ + winPtr->flags &= ~TK_NEED_CONFIG_NOTIFY; + TkDoConfigureNotify(winPtr); + } +} + +/* + *-------------------------------------------------------------- + * + * Tk_UnmapWindow, etc. -- + * + * There are several procedures under here, each of which + * mirrors an existing X procedure. In addition to performing + * the functions of the corresponding procedure, each + * procedure also updates the local window structure and + * synthesizes an X event (if the window's structure is being + * managed internally). + * + * Results: + * See the manual entries. + * + * Side effects: + * See the manual entries. + * + *-------------------------------------------------------------- + */ + +void +Tk_UnmapWindow(tkwin) + Tk_Window tkwin; /* Token for window to unmap. */ +{ + register TkWindow *winPtr = (TkWindow *) tkwin; + + if (!(winPtr->flags & TK_MAPPED) || (winPtr->flags & TK_ALREADY_DEAD)) { + return; + } + if (winPtr->flags & TK_TOP_LEVEL) { + /* + * Special processing has to be done for top-level windows. Let + * tkWm.c handle everything itself. + */ + + TkWmUnmapWindow(winPtr); + return; + } + winPtr->flags &= ~TK_MAPPED; + XUnmapWindow(winPtr->display, winPtr->window); + if (!(winPtr->flags & TK_TOP_LEVEL)) { + XEvent event; + + event.type = UnmapNotify; + event.xunmap.serial = LastKnownRequestProcessed(winPtr->display); + event.xunmap.send_event = False; + event.xunmap.display = winPtr->display; + event.xunmap.event = winPtr->window; + event.xunmap.window = winPtr->window; + event.xunmap.from_configure = False; + Tk_HandleEvent(&event); + } +} + +void +Tk_ConfigureWindow(tkwin, valueMask, valuePtr) + Tk_Window tkwin; /* Window to re-configure. */ + unsigned int valueMask; /* Mask indicating which parts of + * *valuePtr are to be used. */ + XWindowChanges *valuePtr; /* New values. */ +{ + register TkWindow *winPtr = (TkWindow *) tkwin; + + if (valueMask & CWX) { + winPtr->changes.x = valuePtr->x; + } + if (valueMask & CWY) { + winPtr->changes.y = valuePtr->y; + } + if (valueMask & CWWidth) { + winPtr->changes.width = valuePtr->width; + } + if (valueMask & CWHeight) { + winPtr->changes.height = valuePtr->height; + } + if (valueMask & CWBorderWidth) { + winPtr->changes.border_width = valuePtr->border_width; + } + if (valueMask & (CWSibling|CWStackMode)) { + panic("Can't set sibling or stack mode from Tk_ConfigureWindow."); + } + + if (winPtr->window != None) { + XConfigureWindow(winPtr->display, winPtr->window, + valueMask, valuePtr); + TkDoConfigureNotify(winPtr); + } else { + winPtr->dirtyChanges |= valueMask; + winPtr->flags |= TK_NEED_CONFIG_NOTIFY; + } +} + +void +Tk_MoveWindow(tkwin, x, y) + Tk_Window tkwin; /* Window to move. */ + int x, y; /* New location for window (within + * parent). */ +{ + register TkWindow *winPtr = (TkWindow *) tkwin; + + winPtr->changes.x = x; + winPtr->changes.y = y; + if (winPtr->window != None) { + XMoveWindow(winPtr->display, winPtr->window, x, y); + TkDoConfigureNotify(winPtr); + } else { + winPtr->dirtyChanges |= CWX|CWY; + winPtr->flags |= TK_NEED_CONFIG_NOTIFY; + } +} + +void +Tk_ResizeWindow(tkwin, width, height) + Tk_Window tkwin; /* Window to resize. */ + int width, height; /* New dimensions for window. */ +{ + register TkWindow *winPtr = (TkWindow *) tkwin; + + winPtr->changes.width = (unsigned) width; + winPtr->changes.height = (unsigned) height; + if (winPtr->window != None) { + XResizeWindow(winPtr->display, winPtr->window, (unsigned) width, + (unsigned) height); + TkDoConfigureNotify(winPtr); + } else { + winPtr->dirtyChanges |= CWWidth|CWHeight; + winPtr->flags |= TK_NEED_CONFIG_NOTIFY; + } +} + +void +Tk_MoveResizeWindow(tkwin, x, y, width, height) + Tk_Window tkwin; /* Window to move and resize. */ + int x, y; /* New location for window (within + * parent). */ + int width, height; /* New dimensions for window. */ +{ + register TkWindow *winPtr = (TkWindow *) tkwin; + + winPtr->changes.x = x; + winPtr->changes.y = y; + winPtr->changes.width = (unsigned) width; + winPtr->changes.height = (unsigned) height; + if (winPtr->window != None) { + XMoveResizeWindow(winPtr->display, winPtr->window, x, y, + (unsigned) width, (unsigned) height); + TkDoConfigureNotify(winPtr); + } else { + winPtr->dirtyChanges |= CWX|CWY|CWWidth|CWHeight; + winPtr->flags |= TK_NEED_CONFIG_NOTIFY; + } +} + +void +Tk_SetWindowBorderWidth(tkwin, width) + Tk_Window tkwin; /* Window to modify. */ + int width; /* New border width for window. */ +{ + register TkWindow *winPtr = (TkWindow *) tkwin; + + winPtr->changes.border_width = width; + if (winPtr->window != None) { + XSetWindowBorderWidth(winPtr->display, winPtr->window, + (unsigned) width); + TkDoConfigureNotify(winPtr); + } else { + winPtr->dirtyChanges |= CWBorderWidth; + winPtr->flags |= TK_NEED_CONFIG_NOTIFY; + } +} + +void +Tk_ChangeWindowAttributes(tkwin, valueMask, attsPtr) + Tk_Window tkwin; /* Window to manipulate. */ + unsigned long valueMask; /* OR'ed combination of bits, + * indicating which fields of + * *attsPtr are to be used. */ + register XSetWindowAttributes *attsPtr; + /* New values for some attributes. */ +{ + register TkWindow *winPtr = (TkWindow *) tkwin; + + if (valueMask & CWBackPixmap) { + winPtr->atts.background_pixmap = attsPtr->background_pixmap; + } + if (valueMask & CWBackPixel) { + winPtr->atts.background_pixel = attsPtr->background_pixel; + } + if (valueMask & CWBorderPixmap) { + winPtr->atts.border_pixmap = attsPtr->border_pixmap; + } + if (valueMask & CWBorderPixel) { + winPtr->atts.border_pixel = attsPtr->border_pixel; + } + if (valueMask & CWBitGravity) { + winPtr->atts.bit_gravity = attsPtr->bit_gravity; + } + if (valueMask & CWWinGravity) { + winPtr->atts.win_gravity = attsPtr->win_gravity; + } + if (valueMask & CWBackingStore) { + winPtr->atts.backing_store = attsPtr->backing_store; + } + if (valueMask & CWBackingPlanes) { + winPtr->atts.backing_planes = attsPtr->backing_planes; + } + if (valueMask & CWBackingPixel) { + winPtr->atts.backing_pixel = attsPtr->backing_pixel; + } + if (valueMask & CWOverrideRedirect) { + winPtr->atts.override_redirect = attsPtr->override_redirect; + } + if (valueMask & CWSaveUnder) { + winPtr->atts.save_under = attsPtr->save_under; + } + if (valueMask & CWEventMask) { + winPtr->atts.event_mask = attsPtr->event_mask; + } + if (valueMask & CWDontPropagate) { + winPtr->atts.do_not_propagate_mask + = attsPtr->do_not_propagate_mask; + } + if (valueMask & CWColormap) { + winPtr->atts.colormap = attsPtr->colormap; + } + if (valueMask & CWCursor) { + winPtr->atts.cursor = attsPtr->cursor; + } + + if (winPtr->window != None) { + XChangeWindowAttributes(winPtr->display, winPtr->window, + valueMask, attsPtr); + } else { + winPtr->dirtyAtts |= valueMask; + } +} + +void +Tk_SetWindowBackground(tkwin, pixel) + Tk_Window tkwin; /* Window to manipulate. */ + unsigned long pixel; /* Pixel value to use for + * window's background. */ +{ + register TkWindow *winPtr = (TkWindow *) tkwin; + + winPtr->atts.background_pixel = pixel; + + if (winPtr->window != None) { + XSetWindowBackground(winPtr->display, winPtr->window, pixel); + } else { + winPtr->dirtyAtts = (winPtr->dirtyAtts & (unsigned) ~CWBackPixmap) + | CWBackPixel; + } +} + +void +Tk_SetWindowBackgroundPixmap(tkwin, pixmap) + Tk_Window tkwin; /* Window to manipulate. */ + Pixmap pixmap; /* Pixmap to use for window's + * background. */ +{ + register TkWindow *winPtr = (TkWindow *) tkwin; + + winPtr->atts.background_pixmap = pixmap; + + if (winPtr->window != None) { + XSetWindowBackgroundPixmap(winPtr->display, + winPtr->window, pixmap); + } else { + winPtr->dirtyAtts = (winPtr->dirtyAtts & (unsigned) ~CWBackPixel) + | CWBackPixmap; + } +} + +void +Tk_SetWindowBorder(tkwin, pixel) + Tk_Window tkwin; /* Window to manipulate. */ + unsigned long pixel; /* Pixel value to use for + * window's border. */ +{ + register TkWindow *winPtr = (TkWindow *) tkwin; + + winPtr->atts.border_pixel = pixel; + + if (winPtr->window != None) { + XSetWindowBorder(winPtr->display, winPtr->window, pixel); + } else { + winPtr->dirtyAtts = (winPtr->dirtyAtts & (unsigned) ~CWBorderPixmap) + | CWBorderPixel; + } +} + +void +Tk_SetWindowBorderPixmap(tkwin, pixmap) + Tk_Window tkwin; /* Window to manipulate. */ + Pixmap pixmap; /* Pixmap to use for window's + * border. */ +{ + register TkWindow *winPtr = (TkWindow *) tkwin; + + winPtr->atts.border_pixmap = pixmap; + + if (winPtr->window != None) { + XSetWindowBorderPixmap(winPtr->display, + winPtr->window, pixmap); + } else { + winPtr->dirtyAtts = (winPtr->dirtyAtts & (unsigned) ~CWBorderPixel) + | CWBorderPixmap; + } +} + +void +Tk_DefineCursor(tkwin, cursor) + Tk_Window tkwin; /* Window to manipulate. */ + Tk_Cursor cursor; /* Cursor to use for window (may be None). */ +{ + register TkWindow *winPtr = (TkWindow *) tkwin; + +#ifdef MAC_TCL + winPtr->atts.cursor = (XCursor) cursor; +#else + winPtr->atts.cursor = (Cursor) cursor; +#endif + + if (winPtr->window != None) { + XDefineCursor(winPtr->display, winPtr->window, winPtr->atts.cursor); + } else { + winPtr->dirtyAtts = winPtr->dirtyAtts | CWCursor; + } +} + +void +Tk_UndefineCursor(tkwin) + Tk_Window tkwin; /* Window to manipulate. */ +{ + Tk_DefineCursor(tkwin, None); +} + +void +Tk_SetWindowColormap(tkwin, colormap) + Tk_Window tkwin; /* Window to manipulate. */ + Colormap colormap; /* Colormap to use for window. */ +{ + register TkWindow *winPtr = (TkWindow *) tkwin; + + winPtr->atts.colormap = colormap; + + if (winPtr->window != None) { + XSetWindowColormap(winPtr->display, winPtr->window, colormap); + if (!(winPtr->flags & TK_TOP_LEVEL)) { + TkWmAddToColormapWindows(winPtr); + winPtr->flags |= TK_WM_COLORMAP_WINDOW; + } + } else { + winPtr->dirtyAtts |= CWColormap; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tk_SetWindowVisual -- + * + * This procedure is called to specify a visual to be used + * for a Tk window when it is created. This procedure, if + * called at all, must be called before the X window is created + * (i.e. before Tk_MakeWindowExist is called). + * + * Results: + * The return value is 1 if successful, or 0 if the X window has + * been already created. + * + * Side effects: + * The information given is stored for when the window is created. + * + *---------------------------------------------------------------------- + */ + +int +Tk_SetWindowVisual(tkwin, visual, depth, colormap) + Tk_Window tkwin; /* Window to manipulate. */ + Visual *visual; /* New visual for window. */ + int depth; /* New depth for window. */ + Colormap colormap; /* An appropriate colormap for the visual. */ +{ + register TkWindow *winPtr = (TkWindow *) tkwin; + + if( winPtr->window != None ){ + /* Too late! */ + return 0; + } + + winPtr->visual = visual; + winPtr->depth = depth; + winPtr->atts.colormap = colormap; + winPtr->dirtyAtts |= CWColormap; + + /* + * The following code is needed to make sure that the window doesn't + * inherit the parent's border pixmap, which would result in a BadMatch + * error. + */ + + if (!(winPtr->dirtyAtts & CWBorderPixmap)) { + winPtr->dirtyAtts |= CWBorderPixel; + } + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * TkDoConfigureNotify -- + * + * Generate a ConfigureNotify event describing the current + * configuration of a window. + * + * Results: + * None. + * + * Side effects: + * An event is generated and processed by Tk_HandleEvent. + * + *---------------------------------------------------------------------- + */ + +void +TkDoConfigureNotify(winPtr) + register TkWindow *winPtr; /* Window whose configuration + * was just changed. */ +{ + XEvent event; + + event.type = ConfigureNotify; + event.xconfigure.serial = LastKnownRequestProcessed(winPtr->display); + event.xconfigure.send_event = False; + event.xconfigure.display = winPtr->display; + event.xconfigure.event = winPtr->window; + event.xconfigure.window = winPtr->window; + event.xconfigure.x = winPtr->changes.x; + event.xconfigure.y = winPtr->changes.y; + event.xconfigure.width = winPtr->changes.width; + event.xconfigure.height = winPtr->changes.height; + event.xconfigure.border_width = winPtr->changes.border_width; + if (winPtr->changes.stack_mode == Above) { + event.xconfigure.above = winPtr->changes.sibling; + } else { + event.xconfigure.above = None; + } + event.xconfigure.override_redirect = winPtr->atts.override_redirect; + Tk_HandleEvent(&event); +} + +/* + *---------------------------------------------------------------------- + * + * Tk_SetClass -- + * + * This procedure is used to give a window a class. + * + * Results: + * None. + * + * Side effects: + * A new class is stored for tkwin, replacing any existing + * class for it. + * + *---------------------------------------------------------------------- + */ + +void +Tk_SetClass(tkwin, className) + Tk_Window tkwin; /* Token for window to assign class. */ + char *className; /* New class for tkwin. */ +{ + register TkWindow *winPtr = (TkWindow *) tkwin; + + winPtr->classUid = Tk_GetUid(className); + if (winPtr->flags & TK_TOP_LEVEL) { + TkWmSetClass(winPtr); + } + TkOptionClassChanged(winPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TkSetClassProcs -- + * + * This procedure is used to set the class procedures and + * instance data for a window. + * + * Results: + * None. + * + * Side effects: + * A new set of class procedures and instance data is stored + * for tkwin, replacing any existing values. + * + *---------------------------------------------------------------------- + */ + +void +TkSetClassProcs(tkwin, procs, instanceData) + Tk_Window tkwin; /* Token for window to modify. */ + TkClassProcs *procs; /* Class procs structure. */ + ClientData instanceData; /* Data to be passed to class procedures. */ +{ + register TkWindow *winPtr = (TkWindow *) tkwin; + + winPtr->classProcsPtr = procs; + winPtr->instanceData = instanceData; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_NameToWindow -- + * + * Given a string name for a window, this procedure + * returns the token for the window, if there exists a + * window corresponding to the given name. + * + * 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. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tk_Window +Tk_NameToWindow(interp, pathName, tkwin) + Tcl_Interp *interp; /* Where to report errors. */ + char *pathName; /* Path name of window. */ + Tk_Window tkwin; /* Token for window: name is assumed to + * belong to the same main window as tkwin. */ +{ + Tcl_HashEntry *hPtr; + + hPtr = Tcl_FindHashEntry(&((TkWindow *) tkwin)->mainPtr->nameTable, + pathName); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "bad window path name \"", + pathName, "\"", (char *) NULL); + return NULL; + } + return (Tk_Window) Tcl_GetHashValue(hPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tk_IdToWindow -- + * + * Given an X display and window ID, this procedure returns the + * Tk token for the window, if there exists a Tk window corresponding + * to the given ID. + * + * Results: + * The return result is either a token for the window corresponding + * to the given X id, or else NULL to indicate that there is no such + * window. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tk_Window +Tk_IdToWindow(display, window) + Display *display; /* X display containing the window. */ + Window window; /* X window window id. */ +{ + TkDisplay *dispPtr; + Tcl_HashEntry *hPtr; + + for (dispPtr = tkDisplayList; ; dispPtr = dispPtr->nextPtr) { + if (dispPtr == NULL) { + return NULL; + } + if (dispPtr->display == display) { + break; + } + } + + hPtr = Tcl_FindHashEntry(&dispPtr->winTable, (char *) window); + if (hPtr == NULL) { + return NULL; + } + return (Tk_Window) Tcl_GetHashValue(hPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tk_DisplayName -- + * + * Return the textual name of a window's display. + * + * Results: + * The return value is the string name of the display associated + * with tkwin. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tk_DisplayName(tkwin) + Tk_Window tkwin; /* Window whose display name is desired. */ +{ + return ((TkWindow *) tkwin)->dispPtr->name; +} + +/* + *---------------------------------------------------------------------- + * + * UnlinkWindow -- + * + * This procedure removes a window from the childList of its + * parent. + * + * Results: + * None. + * + * Side effects: + * The window is unlinked from its childList. + * + *---------------------------------------------------------------------- + */ + +static void +UnlinkWindow(winPtr) + TkWindow *winPtr; /* Child window to be unlinked. */ +{ + TkWindow *prevPtr; + + if (winPtr->parentPtr == NULL) { + return; + } + prevPtr = winPtr->parentPtr->childList; + if (prevPtr == winPtr) { + winPtr->parentPtr->childList = winPtr->nextPtr; + if (winPtr->nextPtr == NULL) { + winPtr->parentPtr->lastChildPtr = NULL; + } + } else { + while (prevPtr->nextPtr != winPtr) { + prevPtr = prevPtr->nextPtr; + if (prevPtr == NULL) { + panic("UnlinkWindow couldn't find child in parent"); + } + } + prevPtr->nextPtr = winPtr->nextPtr; + if (winPtr->nextPtr == NULL) { + winPtr->parentPtr->lastChildPtr = prevPtr; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tk_RestackWindow -- + * + * Change a window's position in the stacking order. + * + * Results: + * TCL_OK is normally returned. If other is not a descendant + * of tkwin's parent then TCL_ERROR is returned and tkwin is + * not repositioned. + * + * Side effects: + * Tkwin is repositioned in the stacking order. + * + *---------------------------------------------------------------------- + */ + +int +Tk_RestackWindow(tkwin, aboveBelow, other) + Tk_Window tkwin; /* Token for window whose position in + * the stacking order is to change. */ + int aboveBelow; /* Indicates new position of tkwin relative + * to other; must be Above or Below. */ + Tk_Window other; /* Tkwin will be moved to a position that + * puts it just above or below this window. + * If NULL then tkwin goes above or below + * all windows in the same parent. */ +{ + TkWindow *winPtr = (TkWindow *) tkwin; + TkWindow *otherPtr = (TkWindow *) other; + XWindowChanges changes; + unsigned int mask; + + + /* + * Special case: if winPtr is a top-level window then just find + * the top-level ancestor of otherPtr and restack winPtr above + * otherPtr without changing any of Tk's childLists. + */ + + changes.stack_mode = aboveBelow; + mask = CWStackMode; + if (winPtr->flags & TK_TOP_LEVEL) { + while ((otherPtr != NULL) && !(otherPtr->flags & TK_TOP_LEVEL)) { + otherPtr = otherPtr->parentPtr; + } + TkWmRestackToplevel(winPtr, aboveBelow, otherPtr); + return TCL_OK; + } + + /* + * Find an ancestor of otherPtr that is a sibling of winPtr. + */ + + if (winPtr->parentPtr == NULL) { + /* + * Window is going to be deleted shortly; don't do anything. + */ + + return TCL_OK; + } + if (otherPtr == NULL) { + if (aboveBelow == Above) { + otherPtr = winPtr->parentPtr->lastChildPtr; + } else { + otherPtr = winPtr->parentPtr->childList; + } + } else { + while (winPtr->parentPtr != otherPtr->parentPtr) { + if ((otherPtr == NULL) || (otherPtr->flags & TK_TOP_LEVEL)) { + return TCL_ERROR; + } + otherPtr = otherPtr->parentPtr; + } + } + if (otherPtr == winPtr) { + return TCL_OK; + } + + /* + * Reposition winPtr in the stacking order. + */ + + UnlinkWindow(winPtr); + if (aboveBelow == Above) { + winPtr->nextPtr = otherPtr->nextPtr; + if (winPtr->nextPtr == NULL) { + winPtr->parentPtr->lastChildPtr = winPtr; + } + otherPtr->nextPtr = winPtr; + } else { + TkWindow *prevPtr; + + prevPtr = winPtr->parentPtr->childList; + if (prevPtr == otherPtr) { + winPtr->parentPtr->childList = winPtr; + } else { + while (prevPtr->nextPtr != otherPtr) { + prevPtr = prevPtr->nextPtr; + } + prevPtr->nextPtr = winPtr; + } + winPtr->nextPtr = otherPtr; + } + + /* + * Notify the X server of the change. If winPtr hasn't yet been + * created then there's no need to tell the X server now, since + * the stacking order will be handled properly when the window + * is finally created. + */ + + if (winPtr->window != None) { + changes.stack_mode = Above; + for (otherPtr = winPtr->nextPtr; otherPtr != NULL; + otherPtr = otherPtr->nextPtr) { + if ((otherPtr->window != None) + && !(otherPtr->flags & (TK_TOP_LEVEL|TK_REPARENTED))){ + changes.sibling = otherPtr->window; + changes.stack_mode = Below; + mask = CWStackMode|CWSibling; + break; + } + } + XConfigureWindow(winPtr->display, winPtr->window, mask, &changes); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_MainWindow -- + * + * Returns the main window for an application. + * + * 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. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tk_Window +Tk_MainWindow(interp) + Tcl_Interp *interp; /* Interpreter that embodies the + * application. Used for error + * reporting also. */ +{ + TkMainInfo *mainPtr; + + for (mainPtr = tkMainWindowList; mainPtr != NULL; + mainPtr = mainPtr->nextPtr) { + if (mainPtr->interp == interp) { + return (Tk_Window) mainPtr->winPtr; + } + } + interp->result = "this isn't a Tk application"; + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_StrictMotif -- + * + * Indicates whether strict Motif compliance has been specified + * for the given window. + * + * Results: + * The return value is 1 if strict Motif compliance has been + * requested for tkwin's application by setting the tk_strictMotif + * variable in its interpreter to a true value. 0 is returned + * if tk_strictMotif has a false value. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tk_StrictMotif(tkwin) + Tk_Window tkwin; /* Window whose application is + * to be checked. */ +{ + return ((TkWindow *) tkwin)->mainPtr->strictMotif; +} + +/* + *-------------------------------------------------------------- + * + * OpenIM -- + * + * Tries to open an X input method, associated with the + * given display. Right now we can only deal with a bare-bones + * input style: no preedit, and no status. + * + * Results: + * Stores the input method in dispPtr->inputMethod; if there isn't + * a suitable input method, then NULL is stored in dispPtr->inputMethod. + * + * Side effects: + * An input method gets opened. + * + *-------------------------------------------------------------- + */ + +static void +OpenIM(dispPtr) + TkDisplay *dispPtr; /* Tk's structure for the display. */ +{ +#ifndef TK_USE_INPUT_METHODS + return; +#else + unsigned short i; + XIMStyles *stylePtr; + + dispPtr->inputMethod = XOpenIM(dispPtr->display, NULL, NULL, NULL); + if (dispPtr->inputMethod == NULL) { + return; + } + + if ((XGetIMValues(dispPtr->inputMethod, XNQueryInputStyle, &stylePtr, + NULL) != NULL) || (stylePtr == NULL)) { + goto error; + } + for (i = 0; i < stylePtr->count_styles; i++) { + if (stylePtr->supported_styles[i] + == (XIMPreeditNothing|XIMStatusNothing)) { + XFree(stylePtr); + return; + } + } + XFree(stylePtr); + + error: + + /* + * Should close the input method, but this causes core dumps on some + * systems (e.g. Solaris 2.3 as of 1/6/95). + * XCloseIM(dispPtr->inputMethod); + */ + dispPtr->inputMethod = NULL; + return; +#endif /* TK_USE_INPUT_METHODS */ +} + +/* + *---------------------------------------------------------------------- + * + * Tk_GetNumMainWindows -- + * + * This procedure returns the number of main windows currently + * open in this process. + * + * Results: + * The number of main windows open in this process. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tk_GetNumMainWindows() +{ + return numMainWindows; +} + +/* + *---------------------------------------------------------------------- + * + * DeleteWindowsExitProc -- + * + * This procedure is invoked as an exit handler. It deletes all + * of the main windows in the process. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +DeleteWindowsExitProc(clientData) + ClientData clientData; /* Not used. */ +{ + TkDisplay *displayPtr, *nextPtr; + Tcl_Interp *interp; + + while (tkMainWindowList != NULL) { + /* + * We must protect the interpreter while deleting the window, + * because of bindings which could destroy the interpreter + * while the window is being deleted. This would leave frames on + * the call stack pointing at deleted memory, causing core dumps. + */ + + interp = tkMainWindowList->winPtr->mainPtr->interp; + Tcl_Preserve((ClientData) interp); + Tk_DestroyWindow((Tk_Window) tkMainWindowList->winPtr); + Tcl_Release((ClientData) interp); + } + + displayPtr = tkDisplayList; + tkDisplayList = NULL; + + /* + * Iterate destroying the displays until no more displays remain. + * It is possible for displays to get recreated during exit by any + * code that calls GetScreen, so we must destroy these new displays + * as well as the old ones. + */ + + for (displayPtr = tkDisplayList; + displayPtr != NULL; + displayPtr = tkDisplayList) { + + /* + * Now iterate over the current list of open displays, and first + * set the global pointer to NULL so we will be able to notice if + * any new displays got created during deletion of the current set. + * We must also do this to ensure that Tk_IdToWindow does not find + * the old display as it is being destroyed, when it wants to see + * if it needs to dispatch a message. + */ + + for (tkDisplayList = NULL; displayPtr != NULL; displayPtr = nextPtr) { + nextPtr = displayPtr->nextPtr; + if (displayPtr->name != (char *) NULL) { + ckfree(displayPtr->name); + } + Tcl_DeleteHashTable(&(displayPtr->winTable)); + TkpCloseDisplay(displayPtr); + } + } + + numMainWindows = 0; + tkMainWindowList = NULL; + initialized = 0; + tkDisabledUid = NULL; + tkActiveUid = NULL; + tkNormalUid = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tk_Init -- + * + * This procedure is invoked to add Tk to an interpreter. It + * incorporates all of Tk's commands into the interpreter and + * creates the main window for a new Tk application. If the + * interpreter contains a variable "argv", this procedure + * extracts several arguments from that variable, uses them + * to configure the main window, and modifies argv to exclude + * the arguments (see the "wish" documentation for a list of + * the arguments that are extracted). + * + * Results: + * Returns a standard Tcl completion code and sets interp->result + * if there is an error. + * + * Side effects: + * Depends on various initialization scripts that get invoked. + * + *---------------------------------------------------------------------- + */ + +int +Tk_Init(interp) + Tcl_Interp *interp; /* Interpreter to initialize. */ +{ + return Initialize(interp); +} + +/* + *---------------------------------------------------------------------- + * + * Tk_SafeInit -- + * + * This procedure is invoked to add Tk to a safe interpreter. It + * invokes the internal procedure that does the real work. + * + * Results: + * Returns a standard Tcl completion code and sets interp->result + * if there is an error. + * + * Side effects: + * Depends on various initialization scripts that are invoked. + * + *---------------------------------------------------------------------- + */ + +int +Tk_SafeInit(interp) + Tcl_Interp *interp; /* Interpreter to initialize. */ +{ + /* + * Initialize the interpreter with Tk, safely. This removes + * all the Tk commands that are unsafe. + * + * Rationale: + * + * - Toplevel and menu are unsafe because they can be used to cover + * the entire screen and to steal input from the user. + * - Continuous ringing of the bell is a nuisance. + * - Cannot allow access to the clipboard because a malicious script + * can replace the contents with the string "rm -r *" and lead to + * surprises when the contents of the clipboard are pasted. We do + * not currently hide the selection command.. Should we? + * - Cannot allow send because it can be used to cause unsafe + * interpreters to execute commands. The tk command recreates the + * send command, so that too must be hidden. + * - Focus can be used to grab the focus away from another window, + * in effect stealing user input. Cannot allow that. + * NOTE: We currently do *not* hide focus as it would make it + * impossible to provide keyboard input to Tk in a safe interpreter. + * - Grab can be used to block the user from using any other apps + * on the screen. + * - Tkwait can block the containing process forever. Use bindings, + * fileevents and split the protocol into before-the-wait and + * after-the-wait parts. More work but necessary. + * - Wm is unsafe because (if toplevels are allowed, in the future) + * it can be used to remove decorations, move windows around, cover + * the entire screen etc etc. + * + * Current risks: + * + * - No CPU time limit, no memory allocation limits, no color limits. + * + * The actual code called is the same as Tk_Init but Tcl_IsSafe() + * is checked at several places to differentiate the two initialisations. + */ + + return Initialize(interp); +} + +/* + *---------------------------------------------------------------------- + * + * Initialize -- + * + * + * Results: + * A standard Tcl result. Also leaves an error message in interp->result + * if there was an error. + * + * Side effects: + * Depends on the initialization scripts that are invoked. + * + *---------------------------------------------------------------------- + */ + +static int +Initialize(interp) + Tcl_Interp *interp; /* Interpreter to initialize. */ +{ + char *p; + int argc, code; + char **argv, *args[20]; + Tcl_DString class; + char buffer[30]; + + /* + * Start by initializing all the static variables to default acceptable + * values so that no information is leaked from a previous run of this + * code. + */ + + synchronize = 0; + name = NULL; + display = NULL; + geometry = NULL; + colormap = NULL; + use = NULL; + visual = NULL; + 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. + */ + + p = Tcl_GetVar2(interp, "argv", (char *) NULL, TCL_GLOBAL_ONLY); + argv = NULL; + if (p != NULL) { + if (Tcl_SplitList(interp, p, &argc, &argv) != TCL_OK) { + argError: + Tcl_AddErrorInfo(interp, + "\n (processing arguments in argv variable)"); + return TCL_ERROR; + } + if (Tk_ParseArgv(interp, (Tk_Window) NULL, &argc, argv, + argTable, TK_ARGV_DONT_SKIP_FIRST_ARG|TK_ARGV_NO_DEFAULTS) + != TCL_OK) { + ckfree((char *) argv); + goto argError; + } + p = Tcl_Merge(argc, argv); + Tcl_SetVar2(interp, "argv", (char *) NULL, p, TCL_GLOBAL_ONLY); + sprintf(buffer, "%d", argc); + Tcl_SetVar2(interp, "argc", (char *) NULL, buffer, TCL_GLOBAL_ONLY); + ckfree(p); + } + + /* + * Figure out the application's name and class. + */ + + Tcl_DStringInit(&class); + if (name == NULL) { + int offset; + TkpGetAppName(interp, &class); + offset = Tcl_DStringLength(&class)+1; + Tcl_DStringSetLength(&class, offset); + Tcl_DStringAppend(&class, Tcl_DStringValue(&class), offset-1); + name = Tcl_DStringValue(&class) + offset; + } else { + Tcl_DStringAppend(&class, name, -1); + } + + p = Tcl_DStringValue(&class); + if (islower(UCHAR(*p))) { + *p = toupper(UCHAR(*p)); + } + + /* + * Create an argument list for creating the top-level window, + * using the information parsed from argv, if any. + */ + + args[0] = "toplevel"; + args[1] = "."; + args[2] = "-class"; + args[3] = Tcl_DStringValue(&class); + argc = 4; + if (display != NULL) { + args[argc] = "-screen"; + args[argc+1] = display; + argc += 2; + + /* + * If this is the first application for this process, save + * the display name in the DISPLAY environment variable so + * that it will be available to subprocesses created by us. + */ + + if (numMainWindows == 0) { + Tcl_SetVar2(interp, "env", "DISPLAY", display, TCL_GLOBAL_ONLY); + } + } + if (colormap != NULL) { + args[argc] = "-colormap"; + args[argc+1] = colormap; + argc += 2; + colormap = NULL; + } + if (use != NULL) { + args[argc] = "-use"; + args[argc+1] = use; + argc += 2; + use = NULL; + } + if (visual != NULL) { + args[argc] = "-visual"; + args[argc+1] = visual; + argc += 2; + visual = NULL; + } + args[argc] = NULL; + code = TkCreateFrame((ClientData) NULL, interp, argc, args, 1, name); + + Tcl_DStringFree(&class); + if (code != TCL_OK) { + goto done; + } + Tcl_ResetResult(interp); + if (synchronize) { + XSynchronize(Tk_Display(Tk_MainWindow(interp)), True); + } + + /* + * Set the geometry of the main window, if requested. Put the + * requested geometry into the "geometry" variable. + */ + + if (geometry != NULL) { + Tcl_SetVar(interp, "geometry", geometry, TCL_GLOBAL_ONLY); + code = Tcl_VarEval(interp, "wm geometry . ", geometry, (char *) NULL); + if (code != TCL_OK) { + goto done; + } + geometry = NULL; + } + if (Tcl_PkgRequire(interp, "Tcl", TCL_VERSION, 1) == NULL) { + code = TCL_ERROR; + goto done; + } + code = Tcl_PkgProvide(interp, "Tk", TK_VERSION); + if (code != TCL_OK) { + goto done; + } + + /* + * Invoke platform-specific initialization. + */ + + code = TkpInit(interp); + + done: + if (argv != NULL) { + ckfree((char *) argv); + } + return code; +} diff --git a/library/bgerror.tcl b/library/bgerror.tcl new file mode 100644 index 0000000..d2b1cdc --- /dev/null +++ b/library/bgerror.tcl @@ -0,0 +1,99 @@ +# bgerror.tcl -- +# +# This file contains a default version of the bgerror procedure. It +# 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 +# +# Copyright (c) 1992-1994 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + + +# bgerror -- +# This is the default version of bgerror. +# It tries to execute tkerror, if that fails it posts a dialog box containing +# the error message and gives the user a chance to ask to see a stack +# trace. +# Arguments: +# err - The error message. + +proc bgerror err { + global errorInfo tcl_platform + + # save errorInfo which would be erased in the catch below otherwise. + set info $errorInfo ; + + # For backward compatibility : + # Let's try to execute "tkerror" (using catch {tkerror ...} + # instead of searching it with info procs so the application gets + # a chance to auto load it using its favorite "unknown" mecanism. + # (we do the default dialog only if we get a TCL_ERROR (=1) return + # code from the tkerror trial, other ret codes are passed back + # to our caller (tcl background error handler) so the called "tkerror" + # can still use return -code break, to skip remaining messages + # in the error queue for instance) -- dl + set ret [catch {tkerror $err} msg]; + if {$ret != 1} {return -code $ret $msg} + + # Ok the application's tkerror either failed or was not found + # we use the default dialog then : + if {$tcl_platform(platform) == "macintosh"} { + set ok Ok + } else { + set ok OK + } + set button [tk_dialog .bgerrorDialog "Error in Tcl Script" \ + "Error: $err" error 0 $ok "Skip Messages" "Stack Trace"] + if {$button == 0} { + return + } elseif {$button == 1} { + return -code break + } + + set w .bgerrorTrace + catch {destroy $w} + toplevel $w -class ErrorTrace + wm minsize $w 1 1 + wm title $w "Stack Trace for Error" + wm iconname $w "Stack Trace" + button $w.ok -text OK -command "destroy $w" -default active + if {$tcl_platform(platform) == "macintosh"} { + text $w.text -relief flat -bd 2 -highlightthickness 0 -setgrid true \ + -yscrollcommand "$w.scroll set" -width 60 -height 20 + } else { + text $w.text -relief sunken -bd 2 -yscrollcommand "$w.scroll set" \ + -setgrid true -width 60 -height 20 + } + scrollbar $w.scroll -relief sunken -command "$w.text yview" + pack $w.ok -side bottom -padx 3m -pady 2m + pack $w.scroll -side right -fill y + pack $w.text -side left -expand yes -fill both + $w.text insert 0.0 $info + $w.text mark set insert 0.0 + + bind $w "destroy $w" + bind $w.text "destroy $w; break" + + # Center the window on the screen. + + 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]]] + wm geom $w +$x+$y + wm deiconify $w + + # Be sure to release any grabs that might be present on the + # screen, since they could make it impossible for the user + # to interact with the stack trace. + + if {[grab current .] != ""} { + grab release [grab current .] + } +} diff --git a/library/button.tcl b/library/button.tcl new file mode 100644 index 0000000..b017b80 --- /dev/null +++ b/library/button.tcl @@ -0,0 +1,456 @@ +# button.tcl -- +# +# This file defines the default bindings for Tk label, button, +# checkbutton, and radiobutton widgets and provides procedures +# that help in implementing those bindings. +# +# SCCS: @(#) button.tcl 1.22 96/11/14 14:49:11 +# +# Copyright (c) 1992-1994 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +#------------------------------------------------------------------------- +# The code below creates the default class bindings for buttons. +#------------------------------------------------------------------------- + +if {$tcl_platform(platform) == "macintosh"} { + bind Radiobutton { + tkButtonEnter %W + } + bind Radiobutton <1> { + tkButtonDown %W + } + bind Radiobutton { + tkButtonUp %W + } + bind Checkbutton { + tkButtonEnter %W + } + bind Checkbutton <1> { + tkButtonDown %W + } + bind Checkbutton { + tkButtonUp %W + } +} +if {$tcl_platform(platform) == "windows"} { + bind Checkbutton { + tkCheckRadioInvoke %W select + } + bind Checkbutton { + tkCheckRadioInvoke %W select + } + bind Checkbutton { + tkCheckRadioInvoke %W deselect + } + bind Checkbutton <1> { + tkCheckRadioDown %W + } + bind Checkbutton { + tkButtonUp %W + } + bind Checkbutton { + tkCheckRadioEnter %W + } + + bind Radiobutton <1> { + tkCheckRadioDown %W + } + bind Radiobutton { + tkButtonUp %W + } + bind Radiobutton { + tkCheckRadioEnter %W + } +} +if {$tcl_platform(platform) == "unix"} { + bind Checkbutton { + if !$tk_strictMotif { + tkCheckRadioInvoke %W + } + } + bind Radiobutton { + if !$tk_strictMotif { + tkCheckRadioInvoke %W + } + } + bind Checkbutton <1> { + tkCheckRadioInvoke %W + } + bind Radiobutton <1> { + tkCheckRadioInvoke %W + } + bind Checkbutton { + tkButtonEnter %W + } + bind Radiobutton { + tkButtonEnter %W + } +} + +bind Button { + tkButtonInvoke %W +} +bind Checkbutton { + tkCheckRadioInvoke %W +} +bind Radiobutton { + tkCheckRadioInvoke %W +} + +bind Button {} +bind Button { + tkButtonEnter %W +} +bind Button { + tkButtonLeave %W +} +bind Button <1> { + tkButtonDown %W +} +bind Button { + tkButtonUp %W +} + +bind Checkbutton {} +bind Checkbutton { + tkButtonLeave %W +} + +bind Radiobutton {} +bind Radiobutton { + tkButtonLeave %W +} + +if {$tcl_platform(platform) == "windows"} { + +######################### +# Windows implementation +######################### + +# tkButtonEnter -- +# The procedure below is invoked when the mouse pointer enters a +# button widget. It records the button we're in and changes the +# state of the button to active unless the button is disabled. +# +# Arguments: +# w - The name of the widget. + +proc tkButtonEnter w { + global tkPriv + if {[$w cget -state] != "disabled"} { + if {$tkPriv(buttonWindow) == $w} { + $w configure -state active -relief sunken + } + } + set tkPriv(window) $w +} + +# tkButtonLeave -- +# The procedure below is invoked when the mouse pointer leaves a +# button widget. It changes the state of the button back to +# inactive. If we're leaving the button window with a mouse button +# pressed (tkPriv(buttonWindow) == $w), restore the relief of the +# button too. +# +# Arguments: +# w - The name of the widget. + +proc tkButtonLeave w { + global tkPriv + if {[$w cget -state] != "disabled"} { + $w config -state normal + } + if {$w == $tkPriv(buttonWindow)} { + $w configure -relief $tkPriv(relief) + } + set tkPriv(window) "" +} + +# tkCheckRadioEnter -- +# The procedure below is invoked when the mouse pointer enters a +# checkbutton or radiobutton widget. It records the button we're in +# and changes the state of the button to active unless the button is +# disabled. +# +# Arguments: +# w - The name of the widget. + +proc tkCheckRadioEnter w { + global tkPriv + if {[$w cget -state] != "disabled"} { + if {$tkPriv(buttonWindow) == $w} { + $w configure -state active + } + } + set tkPriv(window) $w +} + +# tkButtonDown -- +# The procedure below is invoked when the mouse button is pressed in +# a button widget. It records the fact that the mouse is in the button, +# saves the button's relief so it can be restored later, and changes +# the relief to sunken. +# +# Arguments: +# w - The name of the widget. + +proc tkButtonDown w { + global tkPriv + set tkPriv(relief) [lindex [$w conf -relief] 4] + if {[$w cget -state] != "disabled"} { + set tkPriv(buttonWindow) $w + $w config -relief sunken -state active + } +} + +# tkCheckRadioDown -- +# The procedure below is invoked when the mouse button is pressed in +# a button widget. It records the fact that the mouse is in the button, +# saves the button's relief so it can be restored later, and changes +# the relief to sunken. +# +# Arguments: +# w - The name of the widget. + +proc tkCheckRadioDown w { + global tkPriv + set tkPriv(relief) [lindex [$w conf -relief] 4] + if {[$w cget -state] != "disabled"} { + set tkPriv(buttonWindow) $w + $w config -state active + } +} + +# tkButtonUp -- +# The procedure below is invoked when the mouse button is released +# in a button widget. It restores the button's relief and invokes +# the command as long as the mouse hasn't left the button. +# +# Arguments: +# w - The name of the widget. + +proc tkButtonUp w { + global tkPriv + if {$w == $tkPriv(buttonWindow)} { + set tkPriv(buttonWindow) "" + if {($w == $tkPriv(window)) + && ([$w cget -state] != "disabled")} { + $w config -relief $tkPriv(relief) -state normal + uplevel #0 [list $w invoke] + } + } +} + +} + +if {$tcl_platform(platform) == "unix"} { + +##################### +# Unix implementation +##################### + +# tkButtonEnter -- +# The procedure below is invoked when the mouse pointer enters a +# button widget. It records the button we're in and changes the +# state of the button to active unless the button is disabled. +# +# Arguments: +# w - The name of the widget. + +proc tkButtonEnter {w} { + global tkPriv + if {[$w cget -state] != "disabled"} { + $w config -state active + if {$tkPriv(buttonWindow) == $w} { + $w configure -state active -relief sunken + } + } + set tkPriv(window) $w +} + +# tkButtonLeave -- +# The procedure below is invoked when the mouse pointer leaves a +# button widget. It changes the state of the button back to +# inactive. If we're leaving the button window with a mouse button +# pressed (tkPriv(buttonWindow) == $w), restore the relief of the +# button too. +# +# Arguments: +# w - The name of the widget. + +proc tkButtonLeave w { + global tkPriv + if {[$w cget -state] != "disabled"} { + $w config -state normal + } + if {$w == $tkPriv(buttonWindow)} { + $w configure -relief $tkPriv(relief) + } + set tkPriv(window) "" +} + +# tkButtonDown -- +# The procedure below is invoked when the mouse button is pressed in +# a button widget. It records the fact that the mouse is in the button, +# saves the button's relief so it can be restored later, and changes +# the relief to sunken. +# +# Arguments: +# w - The name of the widget. + +proc tkButtonDown w { + global tkPriv + set tkPriv(relief) [lindex [$w config -relief] 4] + if {[$w cget -state] != "disabled"} { + set tkPriv(buttonWindow) $w + $w config -relief sunken + } +} + +# tkButtonUp -- +# The procedure below is invoked when the mouse button is released +# in a button widget. It restores the button's relief and invokes +# the command as long as the mouse hasn't left the button. +# +# Arguments: +# w - The name of the widget. + +proc tkButtonUp w { + global tkPriv + if {$w == $tkPriv(buttonWindow)} { + set tkPriv(buttonWindow) "" + $w config -relief $tkPriv(relief) + if {($w == $tkPriv(window)) + && ([$w cget -state] != "disabled")} { + uplevel #0 [list $w invoke] + } + } +} + +} + +if {$tcl_platform(platform) == "macintosh"} { + +#################### +# Mac implementation +#################### + +# tkButtonEnter -- +# The procedure below is invoked when the mouse pointer enters a +# button widget. It records the button we're in and changes the +# state of the button to active unless the button is disabled. +# +# Arguments: +# w - The name of the widget. + +proc tkButtonEnter {w} { + global tkPriv + if {[$w cget -state] != "disabled"} { + if {$tkPriv(buttonWindow) == $w} { + $w configure -state active + } + } + set tkPriv(window) $w +} + +# tkButtonLeave -- +# The procedure below is invoked when the mouse pointer leaves a +# button widget. It changes the state of the button back to +# inactive. If we're leaving the button window with a mouse button +# pressed (tkPriv(buttonWindow) == $w), restore the relief of the +# button too. +# +# Arguments: +# w - The name of the widget. + +proc tkButtonLeave w { + global tkPriv + if {$w == $tkPriv(buttonWindow)} { + $w configure -state normal + } + set tkPriv(window) "" +} + +# tkButtonDown -- +# The procedure below is invoked when the mouse button is pressed in +# a button widget. It records the fact that the mouse is in the button, +# saves the button's relief so it can be restored later, and changes +# the relief to sunken. +# +# Arguments: +# w - The name of the widget. + +proc tkButtonDown w { + global tkPriv + if {[$w cget -state] != "disabled"} { + set tkPriv(buttonWindow) $w + $w config -state active + } +} + +# tkButtonUp -- +# The procedure below is invoked when the mouse button is released +# in a button widget. It restores the button's relief and invokes +# the command as long as the mouse hasn't left the button. +# +# Arguments: +# w - The name of the widget. + +proc tkButtonUp w { + global tkPriv + if {$w == $tkPriv(buttonWindow)} { + $w config -state normal + set tkPriv(buttonWindow) "" + if {($w == $tkPriv(window)) + && ([$w cget -state] != "disabled")} { + uplevel #0 [list $w invoke] + } + } +} + +} + +################## +# Shared routines +################## + +# tkButtonInvoke -- +# The procedure below is called when a button is invoked through +# the keyboard. It simulate a press of the button via the mouse. +# +# Arguments: +# w - The name of the widget. + +proc tkButtonInvoke w { + if {[$w cget -state] != "disabled"} { + set oldRelief [$w cget -relief] + set oldState [$w cget -state] + $w configure -state active -relief sunken + update idletasks + after 100 + $w configure -state $oldState -relief $oldRelief + uplevel #0 [list $w invoke] + } +} + +# tkCheckRadioInvoke -- +# The procedure below is invoked when the mouse button is pressed in +# a checkbutton or radiobutton widget, or when the widget is invoked +# through the keyboard. It invokes the widget if it +# isn't disabled. +# +# Arguments: +# w - The name of the widget. +# cmd - The subcommand to invoke (one of invoke, select, or deselect). + +proc tkCheckRadioInvoke {w {cmd invoke}} { + if {[$w cget -state] != "disabled"} { + uplevel #0 [list $w $cmd] + } +} + diff --git a/library/clrpick.tcl b/library/clrpick.tcl new file mode 100644 index 0000000..af5f980 --- /dev/null +++ b/library/clrpick.tcl @@ -0,0 +1,691 @@ +# clrpick.tcl -- +# +# 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 +# +# 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. +# +# ToDo: +# +# (1): Find out how many free colors are left in the colormap and +# don't allocate too many colors. +# (2): Implement HSV color selection. +# + +# tkColorDialog -- +# +# Create a color dialog and let the user choose a color. This function +# should not be called directly. It is called by the tk_chooseColor +# function when a native color selector widget does not exist +# +proc tkColorDialog {args} { + global tkPriv + set w .__tk__color + upvar #0 $w data + + # The lines variables track the start and end indices of the line + # elements in the colorbar canvases. + set data(lines,red,start) 0 + set data(lines,red,last) -1 + set data(lines,green,start) 0 + set data(lines,green,last) -1 + set data(lines,blue,start) 0 + set data(lines,blue,last) -1 + + # This is the actual number of lines that are drawn in each color strip. + # Note that the bars may be of any width. + # However, NUM_COLORBARS must be a number that evenly divides 256. + # Such as 256, 128, 64, etc. + set data(NUM_COLORBARS) 8 + + # BARS_WIDTH is the number of pixels wide the color bar portion of the + # canvas is. This number must be a multiple of NUM_COLORBARS + set data(BARS_WIDTH) 128 + + # PLGN_WIDTH is the number of pixels wide of the triangular selection + # polygon. This also results in the definition of the padding on the + # left and right sides which is half of PLGN_WIDTH. Make this number even. + set data(PLGN_HEIGHT) 10 + + # PLGN_HEIGHT is the height of the selection polygon and the height of the + # selection rectangle at the bottom of the color bar. No restrictions. + set data(PLGN_WIDTH) 10 + + tkColorDialog_Config $w $args + tkColorDialog_InitValues $w + + if ![winfo exists $w] { + toplevel $w -class tkColorDialog + tkColorDialog_BuildDialog $w + } + wm transient $w $data(-parent) + + + # 5. 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]]] + wm geom $w +$x+$y + 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(okBtn) + + # 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(selectColor) + catch {focus $oldFocus} + grab release $w + destroy $w + unset data + if {$oldGrab != ""} { + if {$grabStatus == "global"} { + grab -global $oldGrab + } else { + grab $oldGrab + } + } + return $tkPriv(selectColor) +} + +# tkColorDialog_InitValues -- +# +# Get called during initialization or when user resets NUM_COLORBARS +# +proc tkColorDialog_InitValues {w} { + upvar #0 $w data + + # IntensityIncr is the difference in color intensity between a colorbar + # and its neighbors. + 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)] + + # 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(colorPad) 2 + set data(selPad) [expr $data(PLGN_WIDTH) / 2] + + # + # minX is the x coordinate of the first colorbar + # + set data(minX) $data(indent) + + # + # maxX is the x coordinate of the last colorbar + # + 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 the initial color, specified by -initialcolor, or the + # color chosen by the user the last time. + set data(selection) $data(-initialcolor) + 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] +} + +# tkColorDialog_Config -- +# +# Parses the command line arguments to tk_chooseColor +# +proc tkColorDialog_Config {w argList} { + global tkPriv + upvar #0 $w data + + # 1: the configuration specs + # + set specs { + {-initialcolor "" "" ""} + {-parent "" "" "."} + {-title "" "" "Color"} + } + + # 2: parse the arguments + # + tclParseConfigSpec $w $specs "" $argList + + if ![string compare $data(-title) ""] { + set data(-title) " " + } + if ![string compare $data(-initialcolor) ""] { + if {[info exists tkPriv(selectColor)] && \ + [string compare $tkPriv(selectColor) ""]} { + set data(-initialcolor) $tkPriv(selectColor) + } else { + set data(-initialcolor) [. cget -background] + } + } else { + if [catch {winfo rgb . $data(-initialcolor)} err] { + error $err + } + } + + if ![winfo exists $data(-parent)] { + error "bad window path name \"$data(-parent)\"" + } +} + +# tkColorDialog_BuildDialog -- +# +# Build the dialog. +# +proc tkColorDialog_BuildDialog {w} { + upvar #0 $w data + + # TopFrame contains the color strips and the color selection + # + set topFrame [frame $w.top -relief raised -bd 1] + + # StripsFrame contains the colorstrips and the individual RGB entries + set stripsFrame [frame $topFrame.colorStrip] + + foreach c { Red Green Blue } { + set color [string tolower $c] + + # each f frame contains an [R|G|B] entry and the equiv. color strip. + set f [frame $stripsFrame.$color] + + # The box frame contains the label and entry widget for an [R|G|B] + set box [frame $f.box] + + label $box.label -text $c: -width 6 -under 0 -anchor ne + entry $box.entry -textvariable [format %s $w]($color,intensity) \ + -width 4 + pack $box.label -side left -fill y -padx 2 -pady 3 + pack $box.entry -side left -anchor n -pady 0 + pack $box -side left -fill both + + set height [expr \ + [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 + canvas $f.sel -height $data(PLGN_HEIGHT) \ + -width $data(canvasWidth) -highlightthickness 0 + pack $f.color -expand yes -fill both + pack $f.sel -expand yes -fill both + + pack $f -side top -fill x -padx 0 -pady 2 + + set data($color,entry) $box.entry + set data($color,col) $f.color + set data($color,sel) $f.sel + + bind $data($color,col) \ + "tkColorDialog_DrawColorScale $w $color 1" + bind $data($color,col) \ + "tkColorDialog_EnterColorBar $w $color" + bind $data($color,col) \ + "tkColorDialog_LeaveColorBar $w $color" + + bind $data($color,sel) \ + "tkColorDialog_EnterColorBar $w $color" + bind $data($color,sel) \ + "tkColorDialog_LeaveColorBar $w $color" + + bind $box.entry "tkColorDialog_HandleRGBEntry $w" + } + + pack $stripsFrame -side left -fill both -padx 4 -pady 10 + + # The selFrame contains a frame that demonstrates the currently + # selected color + # + set selFrame [frame $topFrame.sel] + set lab [label $selFrame.lab -text "Selection:" -under 0 -anchor sw] + set ent [entry $selFrame.ent -textvariable [format %s $w](selection) \ + -width 16] + set f1 [frame $selFrame.f1 -relief sunken -bd 2] + set data(finalCanvas) [frame $f1.demo -bd 0 -width 100 -height 70] + + pack $lab $ent -side top -fill x -padx 4 -pady 2 + pack $f1 -expand yes -anchor nw -fill both -padx 6 -pady 10 + pack $data(finalCanvas) -expand yes -fill both + + bind $ent "tkColorDialog_HandleSelEntry $w" + + pack $selFrame -side left -fill none -anchor nw + pack $topFrame -side top -expand yes -fill both -anchor nw + + # the botFrame frame contains the buttons + # + set botFrame [frame $w.bot -relief raised -bd 1] + button $botFrame.ok -text OK -width 8 -under 0 \ + -command "tkColorDialog_OkCmd $w" + button $botFrame.cancel -text Cancel -width 8 -under 0 \ + -command "tkColorDialog_CancelCmd $w" + + set data(okBtn) $botFrame.ok + set data(cancelBtn) $botFrame.cancel + + pack $botFrame.ok $botFrame.cancel \ + -padx 10 -pady 10 -expand yes -side left + pack $botFrame -side bottom -fill x + + + # Accelerator bindings + + bind $w "focus $data(red,entry)" + bind $w "focus $data(green,entry)" + bind $w "focus $data(blue,entry)" + bind $w "focus $ent" + bind $w "tkButtonInvoke $data(cancelBtn)" + bind $w "tkButtonInvoke $data(cancelBtn)" + bind $w "tkButtonInvoke $data(okBtn)" + + wm protocol $w WM_DELETE_WINDOW "tkColorDialog_CancelCmd $w" +} + +# tkColorDialog_SetRGBValue -- +# +# Sets the current selection of the dialog box +# +proc tkColorDialog_SetRGBValue {w color} { + upvar #0 $w data + + set data(red,intensity) [lindex $color 0] + set data(green,intensity) [lindex $color 1] + set data(blue,intensity) [lindex $color 2] + + tkColorDialog_RedrawColorBars $w all + + # Now compute the new x value of each colorbars pointer polygon + foreach color { red green blue } { + set x [tkColorDialog_RgbToX $w $data($color,intensity)] + tkColorDialog_MoveSelector $w $data($color,sel) $color $x 0 + } +} + +# tkColorDialog_XToRgb -- +# +# Converts a screen coordinate to intensity +# +proc tkColorDialog_XToRgb {w x} { + upvar #0 $w data + + return [expr ($x * $data(intensityIncr))/ $data(colorbarWidth)] +} + +# tkColorDialog_RgbToX +# +# Converts an intensity to screen coordinate. +# +proc tkColorDialog_RgbToX {w color} { + upvar #0 $w data + + return [expr ($color * $data(colorbarWidth)/ $data(intensityIncr))] +} + + +# tkColorDialog_DrawColorScale -- +# +# Draw color scale is called whenever the size of one of the color +# scale canvases is changed. +# +proc tkColorDialog_DrawColorScale {w c {create 0}} { + global lines + upvar #0 $w data + + # col: color bar canvas + # sel: selector canvas + set col $data($c,col) + set sel $data($c,sel) + + # First handle the case that we are creating everything for the first time. + 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)} \ + {$i <= $data(lines,$c,last)} { incr i} { + $sel delete $i + } + } + # Delete the selector if it exists + if [info exists data($c,index)] { + $sel delete $data($c,index) + } + + # Draw the selection polygons + tkColorDialog_CreateSelector $w $sel $c + $sel bind $data($c,index) \ + "tkColorDialog_StartMove $w $sel $c %x $data(selPad) 1" + $sel bind $data($c,index) \ + "tkColorDialog_MoveSelector $w $sel $c %x $data(selPad)" + $sel bind $data($c,index) \ + "tkColorDialog_ReleaseMouse $w $sel $c %x $data(selPad)" + + set height [winfo height $col] + # Create an invisible region under the colorstrip to catch mouse clicks + # that aren't on the selector. + set data($c,clickRegion) [$sel create rectangle 0 0 \ + $data(canvasWidth) $height -fill {} -outline {}] + + bind $col \ + "tkColorDialog_StartMove $w $sel $c %x $data(colorPad)" + bind $col \ + "tkColorDialog_MoveSelector $w $sel $c %x $data(colorPad)" + bind $col \ + "tkColorDialog_ReleaseMouse $w $sel $c %x $data(colorPad)" + + $sel bind $data($c,clickRegion) \ + "tkColorDialog_StartMove $w $sel $c %x $data(selPad)" + $sel bind $data($c,clickRegion) \ + "tkColorDialog_MoveSelector $w $sel $c %x $data(selPad)" + $sel bind $data($c,clickRegion) \ + "tkColorDialog_ReleaseMouse $w $sel $c %x $data(selPad)" + } else { + # l is the canvas index of the first colorbar. + set l $data(lines,$c,start) + } + + # Draw the color bars. + set highlightW [expr \ + [$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] + if { $c == "red" } { + set color [format "#%02x%02x%02x" \ + $intensity \ + $data(green,intensity) \ + $data(blue,intensity)] + } elseif { $c == "green" } { + set color [format "#%02x%02x%02x" \ + $data(red,intensity) \ + $intensity \ + $data(blue,intensity)] + } else { + set color [format "#%02x%02x%02x" \ + $data(red,intensity) \ + $data(green,intensity) \ + $intensity] + } + + if $create { + set index [$col create rect $startx $highlightW \ + [expr $startx +$data(colorbarWidth)] \ + [expr [winfo height $col] + $highlightW]\ + -fill $color -outline $color] + } else { + $col itemconf $l -fill $color -outline $color + incr l + } + } + $sel raise $data($c,index) + + if $create { + set data(lines,$c,last) $index + set data(lines,$c,start) [expr $index - $data(NUM_COLORBARS) + 1 ] + } + + tkColorDialog_RedrawFinalColor $w +} + +# tkColorDialog_CreateSelector -- +# +# Creates and draws the selector polygon at the position +# $data($c,intensity). +# +proc tkColorDialog_CreateSelector {w sel c } { + upvar #0 $w data + set data($c,index) [$sel create polygon \ + 0 $data(PLGN_HEIGHT) \ + $data(PLGN_WIDTH) $data(PLGN_HEIGHT) \ + $data(indent) 0] + set data($c,x) [tkColorDialog_RgbToX $w $data($c,intensity)] + $sel move $data($c,index) $data($c,x) 0 +} + +# tkColorDialog_RedrawFinalColor +# +# Combines the intensities of the three colors into the final color +# +proc tkColorDialog_RedrawFinalColor {w} { + upvar #0 $w data + + set color [format "#%02x%02x%02x" $data(red,intensity) \ + $data(green,intensity) $data(blue,intensity)] + + $data(finalCanvas) conf -bg $color + set data(finalColor) $color + set data(selection) $color + set data(finalRGB) [list \ + $data(red,intensity) \ + $data(green,intensity) \ + $data(blue,intensity)] +} + +# tkColorDialog_RedrawColorBars -- +# +# Only redraws the colors on the color strips that were not manipulated. +# Params: color of colorstrip that changed. If color is not [red|green|blue] +# Then all colorstrips will be updated +# +proc tkColorDialog_RedrawColorBars {w colorChanged} { + upvar #0 $w data + + switch $colorChanged { + red { + tkColorDialog_DrawColorScale $w green + tkColorDialog_DrawColorScale $w blue + } + green { + tkColorDialog_DrawColorScale $w red + tkColorDialog_DrawColorScale $w blue + } + blue { + tkColorDialog_DrawColorScale $w red + tkColorDialog_DrawColorScale $w green + } + default { + tkColorDialog_DrawColorScale $w red + tkColorDialog_DrawColorScale $w green + tkColorDialog_DrawColorScale $w blue + } + } + tkColorDialog_RedrawFinalColor $w +} + +#---------------------------------------------------------------------- +# Event handlers +#---------------------------------------------------------------------- + +# tkColorDialog_StartMove -- +# +# Handles a mousedown button event over the selector polygon. +# Adds the bindings for moving the mouse while the button is +# pressed. Sets the binding for the button-release event. +# +# Params: sel is the selector canvas window, color is the color of the strip. +# +proc tkColorDialog_StartMove {w sel color x delta {dontMove 0}} { + upvar #0 $w data + + if !$dontMove { + tkColorDialog_MoveSelector $w $sel $color $x $delta + } +} + +# tkColorDialog_MoveSelector -- +# +# Moves the polygon selector so that its middle point has the same +# x value as the specified x. If x is outside the bounds [0,255], +# the selector is set to the closest endpoint. +# +# Params: sel is the selector canvas, c is [red|green|blue] +# x is a x-coordinate. +# +proc tkColorDialog_MoveSelector {w sel color x delta} { + upvar #0 $w data + + incr x -$delta + + if { $x < 0 } { + set x 0 + } elseif { $x >= $data(BARS_WIDTH)} { + set x [expr $data(BARS_WIDTH) - 1] + } + set diff [expr $x - $data($color,x)] + $sel move $data($color,index) $diff 0 + set data($color,x) [expr $data($color,x) + $diff] + + # Return the x value that it was actually set at + return $x +} + +# tkColorDialog_ReleaseMouse +# +# Removes mouse tracking bindings, updates the colorbars. +# +# Params: sel is the selector canvas, color is the color of the strip, +# x is the x-coord of the mouse. +# +proc tkColorDialog_ReleaseMouse {w sel color x delta} { + upvar #0 $w data + + set x [tkColorDialog_MoveSelector $w $sel $color $x $delta] + + # Determine exactly what color we are looking at. + set data($color,intensity) [tkColorDialog_XToRgb $w $x] + + tkColorDialog_RedrawColorBars $w $color +} + +# tkColorDialog_ResizeColorbars -- +# +# Completely redraws the colorbars, including resizing the +# colorstrips +# +proc tkColorDialog_ResizeColorBars {w} { + upvar #0 $w data + + if { ($data(BARS_WIDTH) < $data(NUM_COLORBARS)) || + (($data(BARS_WIDTH) % $data(NUM_COLORBARS)) != 0)} { + set data(BARS_WIDTH) $data(NUM_COLORBARS) + } + tkColorDialog_InitValues $w + foreach color { red green blue } { + $data($color,col) conf -width $data(canvasWidth) + tkColorDialog_DrawColorScale $w $color 1 + } +} + +# tkColorDialog_HandleSelEntry -- +# +# Handles the return keypress event in the "Selection:" entry +# +proc tkColorDialog_HandleSelEntry {w} { + upvar #0 $w data + + set text [string trim $data(selection)] + # Check to make sure that the color is valid + 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] + + tkColorDialog_SetRGBValue $w "$R $G $B" + set data(selection) $text +} + +# tkColorDialog_HandleRGBEntry -- +# +# Handles the return keypress event in the R, G or B entry +# +proc tkColorDialog_HandleRGBEntry {w} { + upvar #0 $w data + + foreach c {red green blue} { + if [catch { + set data($c,intensity) [expr int($data($c,intensity))] + }] { + set data($c,intensity) 0 + } + + if {$data($c,intensity) < 0} { + set data($c,intensity) 0 + } + if {$data($c,intensity) > 255} { + set data($c,intensity) 255 + } + } + + tkColorDialog_SetRGBValue $w "$data(red,intensity) $data(green,intensity) \ + $data(blue,intensity)" +} + +# mouse cursor enters a color bar +# +proc tkColorDialog_EnterColorBar {w color} { + upvar #0 $w data + + $data($color,sel) itemconfig $data($color,index) -fill red +} + +# mouse leaves enters a color bar +# +proc tkColorDialog_LeaveColorBar {w color} { + upvar #0 $w data + + $data($color,sel) itemconfig $data($color,index) -fill black +} + +# user hits OK button +# +proc tkColorDialog_OkCmd {w} { + global tkPriv + upvar #0 $w data + + set tkPriv(selectColor) $data(finalColor) +} + +# user hits Cancel button +# +proc tkColorDialog_CancelCmd {w} { + global tkPriv + + set tkPriv(selectColor) "" +} + diff --git a/library/comdlg.tcl b/library/comdlg.tcl new file mode 100644 index 0000000..4f00217 --- /dev/null +++ b/library/comdlg.tcl @@ -0,0 +1,308 @@ +# comdlg.tcl -- +# +# 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 +# +# 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. +# + +# tclParseConfigSpec -- +# +# Parses a list of "-option value" pairs. If all options and +# values are legal, the values are stored in +# $data($option). Otherwise an error message is returned. When +# an error happens, the data() array may have been partially +# modified, but all the modified members of the data(0 array are +# guaranteed to have valid values. This is different than +# Tk_ConfigureWidget() which does not modify the value of a +# widget record if any error occurs. +# +# Arguments: +# +# w = widget record to modify. Must be the pathname of a widget. +# +# specs = { +# {-commandlineswitch resourceName ResourceClass defaultValue verifier} +# {....} +# } +# +# flags = currently unused. +# +# argList = The list of "-option value" pairs. +# +proc tclParseConfigSpec {w specs flags argList} { + upvar #0 $w data + + # 1: Put the specs in associative arrays for faster access + # + foreach spec $specs { + if {[llength $spec] < 4} { + error "\"spec\" should contain 5 or 4 elements" + } + set cmdsw [lindex $spec 0] + set cmd($cmdsw) "" + set rname($cmdsw) [lindex $spec 1] + set rclass($cmdsw) [lindex $spec 2] + set def($cmdsw) [lindex $spec 3] + 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]" + } + } + error "value for \"[lindex $argList end]\" missing" + } + + # 2: set the default values + # + foreach cmdsw [array names cmd] { + set data($cmdsw) $def($cmdsw) + } + + # 3: parse the argument list + # + foreach {cmdsw value} $argList { + if ![info exists cmd($cmdsw)] { + error "unknown option \"$cmdsw\", must be [tclListValidFlags cmd]" + } + set data($cmdsw) $value + } + + # Done! +} + +proc tclListValidFlags {v} { + upvar $v cmd + + set len [llength [array names cmd]] + set i 1 + set separator "" + set errormsg "" + foreach cmdsw [lsort [array names cmd]] { + append errormsg "$separator$cmdsw" + incr i + if {$i == $len} { + set separator " or " + } else { + set separator ", " + } + } + return $errormsg +} + +# This procedure is used to sort strings in a case-insenstive mode. +# +proc tclSortNoCase {str1 str2} { + return [string compare [string toupper $str1] [string toupper $str2]] +} + + +# Gives an error if the string does not contain a valid integer +# number +# +proc tclVerifyInteger {string} { + lindex {1 2 3} $string +} + + +#---------------------------------------------------------------------- +# +# Focus Group +# +# Focus groups are used to handle the user's focusing actions inside a +# toplevel. +# +# One example of using focus groups is: when the user focuses on an +# entry, the text in the entry is highlighted and the cursor is put to +# the end of the text. When the user changes focus to another widget, +# the text in the previously focused entry is validated. +# +#---------------------------------------------------------------------- + + +# tkFocusGroup_Create -- +# +# Create a focus group. All the widgets in a focus group must be +# within the same focus toplevel. Each toplevel can have only +# one focus group, which is identified by the name of the +# toplevel widget. +# +proc tkFocusGroup_Create {t} { + global tkPriv + if [string compare [winfo toplevel $t] $t] { + error "$t is not a toplevel window" + } + if ![info exists tkPriv(fg,$t)] { + set tkPriv(fg,$t) 1 + set tkPriv(focus,$t) "" + bind $t "tkFocusGroup_In $t %W %d" + bind $t "tkFocusGroup_Out $t %W %d" + bind $t "tkFocusGroup_Destroy $t %W" + } +} + +# tkFocusGroup_BindIn -- +# +# Add a widget into the "FocusIn" list of the focus group. The $cmd will be +# called when the widget is focused on by the user. +# +proc tkFocusGroup_BindIn {t w cmd} { + global tkFocusIn tkPriv + if ![info exists tkPriv(fg,$t)] { + error "focus group \"$t\" doesn't exist" + } + set tkFocusIn($t,$w) $cmd +} + + +# tkFocusGroup_BindOut -- +# +# Add a widget into the "FocusOut" list of the focus group. The +# $cmd will be called when the widget loses the focus (User +# types Tab or click on another widget). +# +proc tkFocusGroup_BindOut {t w cmd} { + global tkFocusOut tkPriv + if ![info exists tkPriv(fg,$t)] { + error "focus group \"$t\" doesn't exist" + } + set tkFocusOut($t,$w) $cmd +} + +# tkFocusGroup_Destroy -- +# +# Cleans up when members of the focus group is deleted, or when the +# toplevel itself gets deleted. +# +proc tkFocusGroup_Destroy {t w} { + global tkPriv tkFocusIn tkFocusOut + + if ![string compare $t $w] { + unset tkPriv(fg,$t) + unset tkPriv(focus,$t) + + foreach name [array names tkFocusIn $t,*] { + unset tkFocusIn($name) + } + foreach name [array names tkFocusOut $t,*] { + unset tkFocusOut($name) + } + } else { + if [info exists tkPriv(focus,$t)] { + if ![string compare $tkPriv(focus,$t) $w] { + set tkPriv(focus,$t) "" + } + } + catch { + unset tkFocusIn($t,$w) + } + catch { + unset tkFocusOut($t,$w) + } + } +} + +# tkFocusGroup_In -- +# +# Handles the event. Calls the FocusIn command for the newly +# focused widget in the focus group. +# +proc tkFocusGroup_In {t w detail} { + global tkPriv tkFocusIn + + if ![info exists tkFocusIn($t,$w)] { + set tkFocusIn($t,$w) "" + return + } + if ![info exists tkPriv(focus,$t)] { + return + } + if ![string compare $tkPriv(focus,$t) $w] { + # This is already in focus + # + return + } else { + set tkPriv(focus,$t) $w + eval $tkFocusIn($t,$w) + } +} + +# tkFocusGroup_Out -- +# +# Handles the event. Checks if this is really a lose +# focus event, not one generated by the mouse moving out of the +# toplevel window. Calls the FocusOut command for the widget +# who loses its focus. +# +proc tkFocusGroup_Out {t w detail} { + global tkPriv tkFocusOut + + if {[string compare $detail NotifyNonlinear] && + [string compare $detail NotifyNonlinearVirtual]} { + # This is caused by mouse moving out of the window + return + } + if ![info exists tkPriv(focus,$t)] { + return + } + if ![info exists tkFocusOut($t,$w)] { + return + } else { + eval $tkFocusOut($t,$w) + set tkPriv(focus,$t) "" + } +} + +# tkFDGetFileTypes -- +# +# Process the string given by the -filetypes option of the file +# dialogs. Similar to the C function TkGetFileFilters() on the Mac +# and Windows platform. +# +proc tkFDGetFileTypes {string} { + foreach t $string { + if {[llength $t] < 2 || [llength $t] > 3} { + error "bad file type \"$t\", should be \"typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?\"" + } + eval lappend [list fileTypes([lindex $t 0])] [lindex $t 1] + } + + set types {} + foreach t $string { + set label [lindex $t 0] + set exts {} + + if [info exists hasDoneType($label)] { + continue + } + + set name "$label (" + set sep "" + foreach ext $fileTypes($label) { + if ![string compare $ext ""] { + continue + } + regsub {^[.]} $ext "*." ext + if ![info exists hasGotExt($label,$ext)] { + append name $sep$ext + lappend exts $ext + set hasGotExt($label,$ext) 1 + } + set sep , + } + append name ")" + lappend types [list $name $exts] + + set hasDoneType($label) 1 + } + + return $types +} diff --git a/library/console.tcl b/library/console.tcl new file mode 100644 index 0000000..d2c28b2 --- /dev/null +++ b/library/console.tcl @@ -0,0 +1,481 @@ +# console.tcl -- +# +# This code constructs the console window for an application. It +# 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 +# +# 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. +# + +# TODO: history - remember partially written command + +# tkConsoleInit -- +# This procedure constructs and configures the console windows. +# +# Arguments: +# None. + +proc tkConsoleInit {} { + global tcl_platform + + if {! [consoleinterp eval {set tcl_interactive}]} { + wm withdraw . + } + + if {"$tcl_platform(platform)" == "macintosh"} { + set mod "Cmd" + } else { + set mod "Ctrl" + } + + menu .menubar + .menubar add cascade -label File -menu .menubar.file -underline 0 + .menubar add cascade -label Edit -menu .menubar.edit -underline 0 + + menu .menubar.file -tearoff 0 + .menubar.file add command -label "Source..." -underline 0 \ + -command tkConsoleSource + .menubar.file add command -label "Hide Console" -underline 0 \ + -command {wm withdraw .} + if {"$tcl_platform(platform)" == "macintosh"} { + .menubar.file add command -label "Quit" -command exit -accel Cmd-Q + } else { + .menubar.file add command -label "Exit" -underline 1 -command exit + } + + menu .menubar.edit -tearoff 0 + .menubar.edit add command -label "Cut" -underline 2 \ + -command { event generate .console <> } -accel "$mod+X" + .menubar.edit add command -label "Copy" -underline 0 \ + -command { event generate .console <> } -accel "$mod+C" + .menubar.edit add command -label "Paste" -underline 1 \ + -command { event generate .console <> } -accel "$mod+V" + + if {"$tcl_platform(platform)" == "windows"} { + .menubar.edit add command -label "Delete" -underline 0 \ + -command { event generate .console <> } -accel "Del" + + .menubar add cascade -label Help -menu .menubar.help -underline 0 + menu .menubar.help -tearoff 0 + .menubar.help add command -label "About..." -underline 0 \ + -command tkConsoleAbout + } else { + .menubar.edit add command -label "Clear" -underline 2 \ + -command { event generate .console <> } + } + + . conf -menu .menubar + + text .console -yscrollcommand ".sb set" -setgrid true + scrollbar .sb -command ".console yview" + pack .sb -side right -fill both + pack .console -fill both -expand 1 -side left + if {$tcl_platform(platform) == "macintosh"} { + .console configure -font {Monaco 9 normal} -highlightthickness 0 + } + + tkConsoleBind .console + + .console tag configure stderr -foreground red + .console tag configure stdin -foreground blue + + focus .console + + wm protocol . WM_DELETE_WINDOW { wm withdraw . } + wm title . "Console" + flush stdout + .console mark set output [.console index "end - 1 char"] + tkTextSetCursor .console end + .console mark set promptEnd insert + .console mark gravity promptEnd left +} + +# tkConsoleSource -- +# +# Prompts the user for a file to source in the main interpreter. +# +# Arguments: +# None. + +proc tkConsoleSource {} { + set filename [tk_getOpenFile -defaultextension .tcl -parent . \ + -title "Select a file to source" \ + -filetypes {{"Tcl Scripts" .tcl} {"All Files" *}}] + if {"$filename" != ""} { + set cmd [list source $filename] + if [catch {consoleinterp eval $cmd} result] { + tkConsoleOutput stderr "$result\n" + } + } +} + +# tkConsoleInvoke -- +# Processes the command line input. If the command is complete it +# is evaled in the main interpreter. Otherwise, the continuation +# prompt is added and more input may be added. +# +# Arguments: +# None. + +proc tkConsoleInvoke {args} { + set ranges [.console tag ranges input] + set cmd "" + if {$ranges != ""} { + set pos 0 + while {[lindex $ranges $pos] != ""} { + set start [lindex $ranges $pos] + set end [lindex $ranges [incr pos]] + append cmd [.console get $start $end] + incr pos + } + } + if {$cmd == ""} { + tkConsolePrompt + } 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" + } + tkConsoleHistory reset + tkConsolePrompt + } else { + tkConsolePrompt partial + } + .console yview -pickplace insert +} + +# tkConsoleHistory -- +# This procedure implements command line history for the +# console. In general is evals the history command in the +# main interpreter to obtain the history. The global variable +# histNum is used to store the current location in the history. +# +# Arguments: +# cmd - Which action to take: prev, next, reset. + +set histNum 1 +proc tkConsoleHistory {cmd} { + global histNum + + switch $cmd { + prev { + incr histNum -1 + if {$histNum == 0} { + set cmd {history event [expr [history nextid] -1]} + } else { + set cmd "history event $histNum" + } + if {[catch {consoleinterp eval $cmd} cmd]} { + incr histNum + return + } + .console delete promptEnd end + .console insert promptEnd $cmd {input stdin} + } + next { + incr histNum + if {$histNum == 0} { + set cmd {history event [expr [history nextid] -1]} + } elseif {$histNum > 0} { + set cmd "" + set histNum 1 + } else { + set cmd "history event $histNum" + } + if {$cmd != ""} { + catch {consoleinterp eval $cmd} cmd + } + .console delete promptEnd end + .console insert promptEnd $cmd {input stdin} + } + reset { + set histNum 1 + } + } +} + +# tkConsolePrompt -- +# This procedure draws the prompt. If tcl_prompt1 or tcl_prompt2 +# exists in the main interpreter it will be called to generate the +# prompt. Otherwise, a hard coded default prompt is printed. +# +# Arguments: +# partial - Flag to specify which prompt to print. + +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"] { + consoleinterp eval "eval \[set tcl_prompt1\]" + } else { + puts -nonewline "% " + } + } else { + set temp [.console index output] + .console mark set output end + if [consoleinterp eval "info exists tcl_prompt2"] { + consoleinterp eval "eval \[set tcl_prompt2\]" + } else { + puts -nonewline "> " + } + } + flush stdout + .console mark set output $temp + tkTextSetCursor .console end + .console mark set promptEnd insert + .console mark gravity promptEnd left +} + +# tkConsoleBind -- +# This procedure first ensures that the default bindings for the Text +# class have been defined. Then certain bindings are overridden for +# the class. +# +# Arguments: +# None. + +proc tkConsoleBind {win} { + bindtags $win "$win Text . all" + + # Ignore all Alt, Meta, and Control keypresses unless explicitly bound. + # Otherwise, if a widget binding for one of these is defined, the + # class binding will also fire and insert the character, + # which is wrong. Ditto for . + + bind $win {# nothing } + bind $win {# nothing} + bind $win {# nothing} + bind $win {# nothing} + bind $win {# nothing} + + bind $win { + tkConsoleInsert %W \t + focus %W + break + } + bind $win { + %W mark set insert {end - 1c} + tkConsoleInsert %W "\n" + tkConsoleInvoke + break + } + bind $win { + if {[%W tag nextrange sel 1.0 end] != ""} { + %W tag remove sel sel.first promptEnd + } else { + if [%W compare insert < promptEnd] { + break + } + } + } + bind $win { + if {[%W tag nextrange sel 1.0 end] != ""} { + %W tag remove sel sel.first promptEnd + } else { + if [%W compare insert <= promptEnd] { + break + } + } + } + foreach left {Control-a Home} { + bind $win <$left> { + if [%W compare insert < promptEnd] { + tkTextSetCursor %W {insert linestart} + } else { + tkTextSetCursor %W promptEnd + } + break + } + } + foreach right {Control-e End} { + bind $win <$right> { + tkTextSetCursor %W {insert lineend} + break + } + } + bind $win { + if [%W compare insert < promptEnd] { + break + } + } + bind $win { + if [%W compare insert < promptEnd] { + %W mark set insert promptEnd + } + } + bind $win { + if [%W compare insert < promptEnd] { + break + } + } + bind $win { + if [%W compare insert < promptEnd] { + break + } + } + bind $win { + if [%W compare insert <= promptEnd] { + break + } + } + bind $win { + if [%W compare insert <= promptEnd] { + break + } + } + foreach prev {Control-p Up} { + bind $win <$prev> { + tkConsoleHistory prev + break + } + } + foreach prev {Control-n Down} { + bind $win <$prev> { + tkConsoleHistory next + break + } + } + bind $win { + catch {tkConsoleInsert %W [selection get -displayof %W]} + break + } + bind $win { + tkConsoleInsert %W %A + break + } + foreach left {Control-b Left} { + bind $win <$left> { + if [%W compare insert == promptEnd] { + break + } + tkTextSetCursor %W insert-1c + break + } + } + foreach right {Control-f Right} { + bind $win <$right> { + tkTextSetCursor %W insert+1c + break + } + } + bind $win { + eval destroy [winfo child .] + if {$tcl_platform(platform) == "macintosh"} { + source -rsrc Console + } else { + source [file join $tk_library console.tcl] + } + } + bind $win <> { + # Same as the copy event + if {![catch {set data [%W get sel.first sel.last]}]} { + clipboard clear -displayof %W + clipboard append -displayof %W $data + } + break + } + bind $win <> { + if {![catch {set data [%W get sel.first sel.last]}]} { + clipboard clear -displayof %W + clipboard append -displayof %W $data + } + break + } + bind $win <> { + catch { + set clip [selection get -displayof %W -selection CLIPBOARD] + set list [split $clip \n\r] + tkConsoleInsert %W [lindex $list 0] + foreach x [lrange $list 1 end] { + %W mark set insert {end - 1c} + tkConsoleInsert %W "\n" + tkConsoleInvoke + tkConsoleInsert %W $x + } + } + break + } +} + +# tkConsoleInsert -- +# Insert a string into a text at the point of the insertion cursor. +# If there is a selection in the text, and it covers the point of the +# insertion cursor, then delete the selection before inserting. Insertion +# is restricted to the prompt area. +# +# Arguments: +# w - The text window in which to insert the string +# s - The string to insert (usually just a single character) + +proc tkConsoleInsert {w s} { + if {$s == ""} { + return + } + catch { + if {[$w compare sel.first <= insert] + && [$w compare sel.last >= insert]} { + $w tag remove sel sel.first promptEnd + $w delete sel.first sel.last + } + } + if {[$w compare insert < promptEnd]} { + $w mark set insert end + } + $w insert insert $s {input stdin} + $w see insert +} + +# tkConsoleOutput -- +# +# This routine is called directly by ConsolePutsCmd to cause a string +# to be displayed in the console. +# +# Arguments: +# dest - The output tag to be used: either "stderr" or "stdout". +# string - The string to be displayed. + +proc tkConsoleOutput {dest string} { + .console insert output $string $dest + .console see insert +} + +# tkConsoleExit -- +# +# This routine is called by ConsoleEventProc when the main window of +# the application is destroyed. Don't call exit - that probably already +# happened. Just delete our window. +# +# Arguments: +# None. + +proc tkConsoleExit {} { + destroy . +} + +# tkConsoleAbout -- +# +# This routine displays an About box to show Tcl/Tk version info. +# +# Arguments: +# None. + +proc tkConsoleAbout {} { + global tk_patchLevel + tk_messageBox -type ok -message "Tcl for Windows +Copyright \251 1996 Sun Microsystems, Inc. + +Tcl [info patchlevel] +Tk $tk_patchLevel" +} + +# now initialize the console + +tkConsoleInit diff --git a/library/demos/README b/library/demos/README new file mode 100644 index 0000000..c71f977 --- /dev/null +++ b/library/demos/README @@ -0,0 +1,46 @@ +This directory contains a collection of programs to demonstrate +the features of the Tk toolkit. The programs are all scripts for +"wish", a windowing shell. If wish has been installed in /usr/local +then you can invoke any of the programs in this directory just +by typing its file name to your command shell. Otherwise invoke +wish with the file as its first argument, e.g., "wish hello". +The rest of this file contains a brief description of each program. +Files with names ending in ".tcl" are procedure packages used by one +or more of the demo programs; they can't be used as programs by +themselves so they aren't described below. + +hello - Creates a single button; if you click on it, a message + is typed and the application terminates. + +widget - Contains a collection of demonstrations of the widgets + currently available in the Tk library. Most of the .tcl + files are scripts for individual demos available through + the "widget" program. + +ixset - A simple Tk-based wrapper for the "xset" program, which + allows you to interactively query and set various X options + such as mouse acceleration and bell volume. Thanks to + Pierre David for contributing this example. + +rolodex - A mock-up of a simple rolodex application. It has much of + the user interface for such an application but no back-end + database. This program was written in response to Tom + LaStrange's toolkit benchmark challenge. + +tcolor - A color editor. Allows you to edit colors in several + different ways, and will also perform automatic updates + using "send". + +rmt - Allows you to "hook-up" remotely to any Tk application + on the display. Select an application with the menu, + then just type commands: they'll go to that application. + +timer - Displays a seconds timer with start and stop buttons. + Control-c and control-q cause it to exit. + +browse - A simple directory browser. Invoke it with and argument + giving the name of the directory you'd like to browse. + Double-click on files or subdirectories to browse them. + Control-c and control-q cause the program to exit. + +sccs id = SCCS: @(#) README 1.3 96/02/16 10:49:14 diff --git a/library/demos/arrow.tcl b/library/demos/arrow.tcl new file mode 100644 index 0000000..126c179 --- /dev/null +++ b/library/demos/arrow.tcl @@ -0,0 +1,238 @@ +# arrow.tcl -- +# +# This demonstration script creates a canvas widget that displays a +# large line with an arrowhead whose shape can be edited interactively. +# +# SCCS: @(#) arrow.tcl 1.8 97/03/02 16:18:20 + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +# arrowSetup -- +# This procedure regenerates all the text and graphics in the canvas +# window. It's called when the canvas is initially created, and also +# whenever any of the parameters of the arrow head are changed +# interactively. +# +# Arguments: +# c - Name of the canvas widget. + +proc arrowSetup c { + upvar #0 demo_arrowInfo v + + # Remember the current box, if there is one. + + set tags [$c gettags current] + if {$tags != ""} { + set cur [lindex $tags [lsearch -glob $tags box?]] + } else { + set cur "" + } + + # Create the arrow and outline. + + $c delete all + eval "$c create line $v(x1) $v(y) $v(x2) $v(y) -width [expr 10*$v(width)] \ + -arrowshape {[expr 10*$v(a)] [expr 10*$v(b)] [expr 10*$v(c)]} \ + -arrow last $v(bigLineStyle)" + set xtip [expr $v(x2)-10*$v(b)] + set deltaY [expr 10*$v(c)+5*$v(width)] + $c create line $v(x2) $v(y) $xtip [expr $v(y)+$deltaY] \ + [expr $v(x2)-10*$v(a)] $v(y) $xtip [expr $v(y)-$deltaY] \ + $v(x2) $v(y) -width 2 -capstyle round -joinstyle round + + # Create the boxes for reshaping the line and arrowhead. + + eval "$c create rect [expr $v(x2)-10*$v(a)-5] [expr $v(y)-5] \ + [expr $v(x2)-10*$v(a)+5] [expr $v(y)+5] $v(boxStyle) \ + -tags {box1 box}" + eval "$c create rect [expr $xtip-5] [expr $v(y)-$deltaY-5] \ + [expr $xtip+5] [expr $v(y)-$deltaY+5] $v(boxStyle) \ + -tags {box2 box}" + eval "$c create rect [expr $v(x1)-5] [expr $v(y)-5*$v(width)-5] \ + [expr $v(x1)+5] [expr $v(y)-5*$v(width)+5] $v(boxStyle) \ + -tags {box3 box}" + if {$cur != ""} { + eval $c itemconfigure $cur $v(activeStyle) + } + + # Create three arrows in actual size with the same parameters + + $c create line [expr $v(x2)+50] 0 [expr $v(x2)+50] 1000 \ + -width 2 + set tmp [expr $v(x2)+100] + $c create line $tmp [expr $v(y)-125] $tmp [expr $v(y)-75] \ + -width $v(width) \ + -arrow both -arrowshape "$v(a) $v(b) $v(c)" + $c create line [expr $tmp-25] $v(y) [expr $tmp+25] $v(y) \ + -width $v(width) \ + -arrow both -arrowshape "$v(a) $v(b) $v(c)" + $c create line [expr $tmp-25] [expr $v(y)+75] [expr $tmp+25] \ + [expr $v(y)+125] -width $v(width) \ + -arrow both -arrowshape "$v(a) $v(b) $v(c)" + + # Create a bunch of other arrows and text items showing the + # current dimensions. + + set tmp [expr $v(x2)+10] + $c create line $tmp [expr $v(y)-5*$v(width)] \ + $tmp [expr $v(y)-$deltaY] \ + -arrow both -arrowshape $v(smallTips) + $c create text [expr $v(x2)+15] [expr $v(y)-$deltaY+5*$v(c)] \ + -text $v(c) -anchor w + set tmp [expr $v(x1)-10] + $c create line $tmp [expr $v(y)-5*$v(width)] \ + $tmp [expr $v(y)+5*$v(width)] \ + -arrow both -arrowshape $v(smallTips) + $c create text [expr $v(x1)-15] $v(y) -text $v(width) -anchor e + set tmp [expr $v(y)+5*$v(width)+10*$v(c)+10] + $c create line [expr $v(x2)-10*$v(a)] $tmp $v(x2) $tmp \ + -arrow both -arrowshape $v(smallTips) + $c create text [expr $v(x2)-5*$v(a)] [expr $tmp+5] \ + -text $v(a) -anchor n + set tmp [expr $tmp+25] + $c create line [expr $v(x2)-10*$v(b)] $tmp $v(x2) $tmp \ + -arrow both -arrowshape $v(smallTips) + $c create text [expr $v(x2)-5*$v(b)] [expr $tmp+5] \ + -text $v(b) -anchor n + + $c create text $v(x1) 310 -text "-width $v(width)" \ + -anchor w -font {Helvetica 18} + $c create text $v(x1) 330 -text "-arrowshape {$v(a) $v(b) $v(c)}" \ + -anchor w -font {Helvetica 18} + + incr v(count) +} + +set w .arrow +global tk_library +catch {destroy $w} +toplevel $w +wm title $w "Arrowhead Editor Demonstration" +wm iconname $w "arrow" +positionWindow $w +set c $w.c + +label $w.msg -font $font -wraplength 5i -justify left -text "This widget allows you to experiment with different widths and arrowhead shapes for lines in canvases. To change the line width or the shape of the arrowhead, drag any of the three boxes attached to the oversized arrow. The arrows on the right give examples at normal scale. The text at the bottom shows the configuration options as you'd enter them for a canvas line item." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +canvas $c -width 500 -height 350 -relief sunken -borderwidth 2 +pack $c -expand yes -fill both + +set demo_arrowInfo(a) 8 +set demo_arrowInfo(b) 10 +set demo_arrowInfo(c) 3 +set demo_arrowInfo(width) 2 +set demo_arrowInfo(motionProc) arrowMoveNull +set demo_arrowInfo(x1) 40 +set demo_arrowInfo(x2) 350 +set demo_arrowInfo(y) 150 +set demo_arrowInfo(smallTips) {5 5 2} +set demo_arrowInfo(count) 0 +if {[winfo depth $c] > 1} { + set demo_arrowInfo(bigLineStyle) "-fill SkyBlue1" + set demo_arrowInfo(boxStyle) "-fill {} -outline black -width 1" + set demo_arrowInfo(activeStyle) "-fill red -outline black -width 1" +} else { + set demo_arrowInfo(bigLineStyle) "-fill black \ + -stipple @[file join $tk_library demos images grey.25]" + set demo_arrowInfo(boxStyle) "-fill {} -outline black -width 1" + set demo_arrowInfo(activeStyle) "-fill black -outline black -width 1" +} +arrowSetup $c +$c bind box "$c itemconfigure current $demo_arrowInfo(activeStyle)" +$c bind box "$c itemconfigure current $demo_arrowInfo(boxStyle)" +$c bind box " " +$c bind box " " +$c bind box1 <1> {set demo_arrowInfo(motionProc) arrowMove1} +$c bind box2 <1> {set demo_arrowInfo(motionProc) arrowMove2} +$c bind box3 <1> {set demo_arrowInfo(motionProc) arrowMove3} +$c bind box "\$demo_arrowInfo(motionProc) $c %x %y" +bind $c "arrowSetup $c" + +# arrowMove1 -- +# This procedure is called for each mouse motion event on box1 (the +# one at the vertex of the arrow). It updates the controlling parameters +# for the line and arrowhead. +# +# Arguments: +# c - The name of the canvas window. +# x, y - The coordinates of the mouse. + +proc arrowMove1 {c x y} { + upvar #0 demo_arrowInfo v + set newA [expr ($v(x2)+5-round([$c canvasx $x]))/10] + if {$newA < 0} { + set newA 0 + } + if {$newA > 25} { + set newA 25 + } + if {$newA != $v(a)} { + $c move box1 [expr 10*($v(a)-$newA)] 0 + set v(a) $newA + } +} + +# arrowMove2 -- +# This procedure is called for each mouse motion event on box2 (the +# one at the trailing tip of the arrowhead). It updates the controlling +# parameters for the line and arrowhead. +# +# Arguments: +# c - The name of the canvas window. +# x, y - The coordinates of the mouse. + +proc arrowMove2 {c x y} { + upvar #0 demo_arrowInfo v + set newB [expr ($v(x2)+5-round([$c canvasx $x]))/10] + if {$newB < 0} { + set newB 0 + } + if {$newB > 25} { + set newB 25 + } + set newC [expr ($v(y)+5-round([$c canvasy $y])-5*$v(width))/10] + if {$newC < 0} { + set newC 0 + } + if {$newC > 20} { + set newC 20 + } + if {($newB != $v(b)) || ($newC != $v(c))} { + $c move box2 [expr 10*($v(b)-$newB)] [expr 10*($v(c)-$newC)] + set v(b) $newB + set v(c) $newC + } +} + +# arrowMove3 -- +# This procedure is called for each mouse motion event on box3 (the +# one that controls the thickness of the line). It updates the +# controlling parameters for the line and arrowhead. +# +# Arguments: +# c - The name of the canvas window. +# x, y - The coordinates of the mouse. + +proc arrowMove3 {c x y} { + upvar #0 demo_arrowInfo v + set newWidth [expr ($v(y)+2-round([$c canvasy $y]))/5] + if {$newWidth < 0} { + set newWidth 0 + } + if {$newWidth > 20} { + set newWidth 20 + } + if {$newWidth != $v(width)} { + $c move box3 0 [expr 5*($v(width)-$newWidth)] + set v(width) $newWidth + } +} diff --git a/library/demos/bind.tcl b/library/demos/bind.tcl new file mode 100644 index 0000000..175be10 --- /dev/null +++ b/library/demos/bind.tcl @@ -0,0 +1,79 @@ +# bind.tcl -- +# +# This demonstration script creates a text widget with bindings set +# up for hypertext-like effects. +# +# SCCS: @(#) bind.tcl 1.6 97/03/02 16:19:01 + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +set w .bind +catch {destroy $w} +toplevel $w +wm title $w "Text Demonstration - Tag Bindings" +wm iconname $w "bind" +positionWindow $w + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +text $w.text -yscrollcommand "$w.scroll set" -setgrid true \ + -width 60 -height 24 -font $font -wrap word +scrollbar $w.scroll -command "$w.text yview" +pack $w.scroll -side right -fill y +pack $w.text -expand yes -fill both + +# Set up display styles. + +if {[winfo depth $w] > 1} { + set bold "-background #43ce80 -relief raised -borderwidth 1" + set normal "-background {} -relief flat" +} else { + set bold "-foreground white -background black" + set normal "-foreground {} -background {}" +} + +# Add text to widget. + +$w.text insert 0.0 {\ +The same tag mechanism that controls display styles in text widgets can also be used to associate Tcl commands with regions of text, so that mouse or keyboard actions on the text cause particular Tcl commands to be invoked. For example, in the text below the descriptions of the canvas demonstrations have been tagged. When you move the mouse over a demo description the description lights up, and when you press button 1 over a description then that particular demonstration is invoked. + +} +$w.text insert end \ +{1. Samples of all the different types of items that can be created in canvas widgets.} d1 +$w.text insert end \n\n +$w.text insert end \ +{2. A simple two-dimensional plot that allows you to adjust the positions of the data points.} d2 +$w.text insert end \n\n +$w.text insert end \ +{3. Anchoring and justification modes for text items.} d3 +$w.text insert end \n\n +$w.text insert end \ +{4. An editor for arrow-head shapes for line items.} d4 +$w.text insert end \n\n +$w.text insert end \ +{5. A ruler with facilities for editing tab stops.} d5 +$w.text insert end \n\n +$w.text insert end \ +{6. A grid that demonstrates how canvases can be scrolled.} d6 + +# Create bindings for tags. + +foreach tag {d1 d2 d3 d4 d5 d6} { + $w.text tag bind $tag "$w.text tag configure $tag $bold" + $w.text tag bind $tag "$w.text tag configure $tag $normal" +} +$w.text tag bind d1 <1> {source [file join $tk_library demos items.tcl]} +$w.text tag bind d2 <1> {source [file join $tk_library demos plot.tcl]} +$w.text tag bind d3 <1> {source [file join $tk_library demos ctext.tcl]} +$w.text tag bind d4 <1> {source [file join $tk_library demos arrow.tcl]} +$w.text tag bind d5 <1> {source [file join $tk_library demos ruler.tcl]} +$w.text tag bind d6 <1> {source [file join $tk_library demos cscroll.tcl]} + +$w.text mark set insert 0.0 +$w.text configure -state disabled diff --git a/library/demos/bitmap.tcl b/library/demos/bitmap.tcl new file mode 100644 index 0000000..55f9e73 --- /dev/null +++ b/library/demos/bitmap.tcl @@ -0,0 +1,55 @@ +# bitmap.tcl -- +# +# This demonstration script creates a toplevel window that displays +# all of Tk's built-in bitmaps. +# +# SCCS: @(#) bitmap.tcl 1.6 97/03/02 16:19:20 + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +# bitmapRow -- +# Create a row of bitmap items in a window. +# +# Arguments: +# w - The window that is to contain the row. +# args - The names of one or more bitmaps, which will be displayed +# in a new row across the bottom of w along with their +# names. + +proc bitmapRow {w args} { + frame $w + pack $w -side top -fill both + set i 0 + foreach bitmap $args { + frame $w.$i + pack $w.$i -side left -fill both -pady .25c -padx .25c + label $w.$i.bitmap -bitmap $bitmap + label $w.$i.label -text $bitmap -width 9 + pack $w.$i.label $w.$i.bitmap -side bottom + incr i + } +} + +set w .bitmap +global tk_library +catch {destroy $w} +toplevel $w +wm title $w "Bitmap Demonstration" +wm iconname $w "bitmap" +positionWindow $w + +label $w.msg -font $font -wraplength 4i -justify left -text "This window displays all of Tk's built-in bitmaps, along with the names you can use for them in Tcl scripts." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +frame $w.frame +bitmapRow $w.frame.0 error gray12 gray25 gray50 gray75 +bitmapRow $w.frame.1 hourglass info question questhead warning +pack $w.frame -side top -expand yes -fill both diff --git a/library/demos/browse b/library/demos/browse new file mode 100644 index 0000000..46f6532 --- /dev/null +++ b/library/demos/browse @@ -0,0 +1,56 @@ +#!/bin/sh +# the next line restarts using wish \ +exec wish "$0" "$@" + +# browse -- +# This script generates a directory browser, which lists the working +# directory and allows you to open files or subdirectories by +# double-clicking. +# +# SCCS: @(#) browse 1.8 96/02/16 10:49:18 + +# Create a scrollbar on the right side of the main window and a listbox +# on the left side. + +scrollbar .scroll -command ".list yview" +pack .scroll -side right -fill y +listbox .list -yscroll ".scroll set" -relief sunken -width 20 -height 20 \ + -setgrid yes +pack .list -side left -fill both -expand yes +wm minsize . 1 1 + +# The procedure below is invoked to open a browser on a given file; if the +# file is a directory then another instance of this program is invoked; if +# the file is a regular file then the Mx editor is invoked to display +# the file. + +proc browse {dir file} { + global env + if {[string compare $dir "."] != 0} {set file $dir/$file} + if [file isdirectory $file] { + exec browse $file & + } else { + if [file isfile $file] { + if [info exists env(EDITOR)] { + eval exec $env(EDITOR) $file & + } else { + exec xedit $file & + } + } else { + puts stdout "\"$file\" isn't a directory or regular file" + } + } +} + +# Fill the listbox with a list of all the files in the directory (run +# the "ls" command to get that information). + +if $argc>0 {set dir [lindex $argv 0]} else {set dir "."} +foreach i [exec ls -a $dir] { + .list insert end $i +} + +# Set up bindings for the browser. + +bind all {destroy .} +bind .list {foreach i [selection get] {browse $dir $i}} diff --git a/library/demos/button.tcl b/library/demos/button.tcl new file mode 100644 index 0000000..8569b1d --- /dev/null +++ b/library/demos/button.tcl @@ -0,0 +1,36 @@ +# button.tcl -- +# +# This demonstration script creates a toplevel window containing +# several button widgets. +# +# SCCS: @(#) button.tcl 1.5 97/03/02 16:19:39 + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +set w .button +catch {destroy $w} +toplevel $w +wm title $w "Button Demonstration" +wm iconname $w "button" +positionWindow $w + +label $w.msg -font $font -wraplength 4i -justify left -text "If you click on any of the four buttons below, the background of the button area will change to the color indicated in the button. You can press Tab to move among the buttons, then press Space to invoke the current button." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +button $w.b1 -text "Peach Puff" -width 10 \ + -command "$w config -bg PeachPuff1; $w.buttons config -bg PeachPuff1" +button $w.b2 -text "Light Blue" -width 10 \ + -command "$w config -bg LightBlue1; $w.buttons config -bg LightBlue1" +button $w.b3 -text "Sea Green" -width 10 \ + -command "$w config -bg SeaGreen2; $w.buttons config -bg SeaGreen2" +button $w.b4 -text "Yellow" -width 10 \ + -command "$w config -bg Yellow1; $w.buttons config -bg Yellow1" +pack $w.b1 $w.b2 $w.b3 $w.b4 -side top -expand yes -pady 2 diff --git a/library/demos/check.tcl b/library/demos/check.tcl new file mode 100644 index 0000000..46e21b3 --- /dev/null +++ b/library/demos/check.tcl @@ -0,0 +1,33 @@ +# check.tcl -- +# +# This demonstration script creates a toplevel window containing +# several checkbuttons. +# +# SCCS: @(#) check.tcl 1.4 97/03/02 16:19:57 + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +set w .check +catch {destroy $w} +toplevel $w +wm title $w "Checkbutton Demonstration" +wm iconname $w "check" +positionWindow $w + +label $w.msg -font $font -wraplength 4i -justify left -text "Three checkbuttons are displayed below. If you click on a button, it will toggle the button's selection state and set a Tcl variable to a value indicating the state of the checkbutton. Click the \"See Variables\" button to see the current values of the variables." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +button $w.buttons.vars -text "See Variables" \ + -command "showVars $w.dialog wipers brakes sober" +pack $w.buttons.dismiss $w.buttons.code $w.buttons.vars -side left -expand 1 + +checkbutton $w.b1 -text "Wipers OK" -variable wipers -relief flat +checkbutton $w.b2 -text "Brakes OK" -variable brakes -relief flat +checkbutton $w.b3 -text "Driver Sober" -variable sober -relief flat +pack $w.b1 $w.b2 $w.b3 -side top -pady 2 -anchor w diff --git a/library/demos/clrpick.tcl b/library/demos/clrpick.tcl new file mode 100644 index 0000000..757e0b8 --- /dev/null +++ b/library/demos/clrpick.tcl @@ -0,0 +1,56 @@ +# clrpick.tcl -- +# +# This demonstration script prompts the user to select a color. +# +# SCCS: @(#) clrpick.tcl 1.3 97/03/02 16:20:12 + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +set w .clrpick +catch {destroy $w} +toplevel $w +wm title $w "Color Selection Dialog" +wm iconname $w "colors" +positionWindow $w + +label $w.msg -font $font -wraplength 4i -justify left -text "Press the buttons below to choose the foreground and background colors for the widgets in this window." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +button $w.back -text "Set background color ..." \ + -command \ + "setColor $w $w.back background {-background -highlightbackground}" +button $w.fore -text "Set foreground color ..." \ + -command \ + "setColor $w $w.back foreground -foreground" + +pack $w.back $w.fore -side top -anchor c -pady 2m + +proc setColor {w button name options} { + grab $w + set initialColor [$button cget -$name] + set color [tk_chooseColor -title "Choose a $name color" -parent $w \ + -initialcolor $initialColor] + if [string compare $color ""] { + setColor_helper $w $options $color + } + grab release $w +} + +proc setColor_helper {w options color} { + foreach option $options { + catch { + $w config $option $color + } + } + foreach child [winfo children $w] { + setColor_helper $child $options $color + } +} diff --git a/library/demos/colors.tcl b/library/demos/colors.tcl new file mode 100644 index 0000000..e95c21c --- /dev/null +++ b/library/demos/colors.tcl @@ -0,0 +1,101 @@ +# colors.tcl -- +# +# This demonstration script creates a listbox widget that displays +# many of the colors from the X color database. You can click on +# a color to change the application's palette. +# +# SCCS: @(#) colors.tcl 1.4 97/03/02 16:20:29 + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +set w .colors +catch {destroy $w} +toplevel $w +wm title $w "Listbox Demonstration (colors)" +wm iconname $w "Listbox" +positionWindow $w + +label $w.msg -font $font -wraplength 4i -justify left -text "A listbox containing several color names is displayed below, along with a scrollbar. You can scan the list either using the scrollbar or by dragging in the listbox window with button 2 pressed. If you double-click button 1 on a color, then the application's color palette will be set to match that color" +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +frame $w.frame -borderwidth 10 +pack $w.frame -side top -expand yes -fill y + +scrollbar $w.frame.scroll -command "$w.frame.list yview" +listbox $w.frame.list -yscroll "$w.frame.scroll set" \ + -width 20 -height 16 -setgrid 1 +pack $w.frame.list $w.frame.scroll -side left -fill y -expand 1 + +bind $w.frame.list { + tk_setPalette [selection get] +} +$w.frame.list insert 0 gray60 gray70 gray80 gray85 gray90 gray95 \ + snow1 snow2 snow3 snow4 seashell1 seashell2 \ + seashell3 seashell4 AntiqueWhite1 AntiqueWhite2 AntiqueWhite3 \ + AntiqueWhite4 bisque1 bisque2 bisque3 bisque4 PeachPuff1 \ + PeachPuff2 PeachPuff3 PeachPuff4 NavajoWhite1 NavajoWhite2 \ + NavajoWhite3 NavajoWhite4 LemonChiffon1 LemonChiffon2 \ + LemonChiffon3 LemonChiffon4 cornsilk1 cornsilk2 cornsilk3 \ + cornsilk4 ivory1 ivory2 ivory3 ivory4 honeydew1 honeydew2 \ + honeydew3 honeydew4 LavenderBlush1 LavenderBlush2 \ + LavenderBlush3 LavenderBlush4 MistyRose1 MistyRose2 \ + MistyRose3 MistyRose4 azure1 azure2 azure3 azure4 \ + SlateBlue1 SlateBlue2 SlateBlue3 SlateBlue4 RoyalBlue1 \ + RoyalBlue2 RoyalBlue3 RoyalBlue4 blue1 blue2 blue3 blue4 \ + DodgerBlue1 DodgerBlue2 DodgerBlue3 DodgerBlue4 SteelBlue1 \ + SteelBlue2 SteelBlue3 SteelBlue4 DeepSkyBlue1 DeepSkyBlue2 \ + DeepSkyBlue3 DeepSkyBlue4 SkyBlue1 SkyBlue2 SkyBlue3 \ + SkyBlue4 LightSkyBlue1 LightSkyBlue2 LightSkyBlue3 \ + LightSkyBlue4 SlateGray1 SlateGray2 SlateGray3 SlateGray4 \ + LightSteelBlue1 LightSteelBlue2 LightSteelBlue3 \ + LightSteelBlue4 LightBlue1 LightBlue2 LightBlue3 \ + LightBlue4 LightCyan1 LightCyan2 LightCyan3 LightCyan4 \ + PaleTurquoise1 PaleTurquoise2 PaleTurquoise3 PaleTurquoise4 \ + CadetBlue1 CadetBlue2 CadetBlue3 CadetBlue4 turquoise1 \ + turquoise2 turquoise3 turquoise4 cyan1 cyan2 cyan3 cyan4 \ + DarkSlateGray1 DarkSlateGray2 DarkSlateGray3 \ + DarkSlateGray4 aquamarine1 aquamarine2 aquamarine3 \ + aquamarine4 DarkSeaGreen1 DarkSeaGreen2 DarkSeaGreen3 \ + DarkSeaGreen4 SeaGreen1 SeaGreen2 SeaGreen3 SeaGreen4 \ + PaleGreen1 PaleGreen2 PaleGreen3 PaleGreen4 SpringGreen1 \ + SpringGreen2 SpringGreen3 SpringGreen4 green1 green2 \ + green3 green4 chartreuse1 chartreuse2 chartreuse3 \ + chartreuse4 OliveDrab1 OliveDrab2 OliveDrab3 OliveDrab4 \ + DarkOliveGreen1 DarkOliveGreen2 DarkOliveGreen3 \ + DarkOliveGreen4 khaki1 khaki2 khaki3 khaki4 \ + LightGoldenrod1 LightGoldenrod2 LightGoldenrod3 \ + LightGoldenrod4 LightYellow1 LightYellow2 LightYellow3 \ + LightYellow4 yellow1 yellow2 yellow3 yellow4 gold1 gold2 \ + gold3 gold4 goldenrod1 goldenrod2 goldenrod3 goldenrod4 \ + DarkGoldenrod1 DarkGoldenrod2 DarkGoldenrod3 DarkGoldenrod4 \ + RosyBrown1 RosyBrown2 RosyBrown3 RosyBrown4 IndianRed1 \ + IndianRed2 IndianRed3 IndianRed4 sienna1 sienna2 sienna3 \ + sienna4 burlywood1 burlywood2 burlywood3 burlywood4 wheat1 \ + wheat2 wheat3 wheat4 tan1 tan2 tan3 tan4 chocolate1 \ + chocolate2 chocolate3 chocolate4 firebrick1 firebrick2 \ + firebrick3 firebrick4 brown1 brown2 brown3 brown4 salmon1 \ + salmon2 salmon3 salmon4 LightSalmon1 LightSalmon2 \ + LightSalmon3 LightSalmon4 orange1 orange2 orange3 orange4 \ + DarkOrange1 DarkOrange2 DarkOrange3 DarkOrange4 coral1 \ + coral2 coral3 coral4 tomato1 tomato2 tomato3 tomato4 \ + OrangeRed1 OrangeRed2 OrangeRed3 OrangeRed4 red1 red2 red3 \ + red4 DeepPink1 DeepPink2 DeepPink3 DeepPink4 HotPink1 \ + HotPink2 HotPink3 HotPink4 pink1 pink2 pink3 pink4 \ + LightPink1 LightPink2 LightPink3 LightPink4 PaleVioletRed1 \ + PaleVioletRed2 PaleVioletRed3 PaleVioletRed4 maroon1 \ + maroon2 maroon3 maroon4 VioletRed1 VioletRed2 VioletRed3 \ + VioletRed4 magenta1 magenta2 magenta3 magenta4 orchid1 \ + orchid2 orchid3 orchid4 plum1 plum2 plum3 plum4 \ + MediumOrchid1 MediumOrchid2 MediumOrchid3 MediumOrchid4 \ + DarkOrchid1 DarkOrchid2 DarkOrchid3 DarkOrchid4 purple1 \ + purple2 purple3 purple4 MediumPurple1 MediumPurple2 \ + MediumPurple3 MediumPurple4 thistle1 thistle2 thistle3 \ + thistle4 diff --git a/library/demos/cscroll.tcl b/library/demos/cscroll.tcl new file mode 100644 index 0000000..78f99fa --- /dev/null +++ b/library/demos/cscroll.tcl @@ -0,0 +1,96 @@ +# cscroll.tcl -- +# +# This demonstration script creates a simple canvas that can be +# scrolled in two dimensions. +# +# SCCS: @(#) cscroll.tcl 1.6 97/03/02 16:20:45 + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +set w .cscroll +catch {destroy $w} +toplevel $w +wm title $w "Scrollable Canvas Demonstration" +wm iconname $w "cscroll" +positionWindow $w +set c $w.c + +label $w.msg -font $font -wraplength 4i -justify left -text "This window displays a canvas widget that can be scrolled either using the scrollbars or by dragging with button 2 in the canvas. If you click button 1 on one of the rectangles, its indices will be printed on stdout." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +frame $w.grid +scrollbar $w.hscroll -orient horiz -command "$c xview" +scrollbar $w.vscroll -command "$c yview" +canvas $c -relief sunken -borderwidth 2 -scrollregion {-11c -11c 50c 20c} \ + -xscrollcommand "$w.hscroll set" \ + -yscrollcommand "$w.vscroll set" +pack $w.grid -expand yes -fill both -padx 1 -pady 1 +grid rowconfig $w.grid 0 -weight 1 -minsize 0 +grid columnconfig $w.grid 0 -weight 1 -minsize 0 + +grid $c -padx 1 -in $w.grid -pady 1 \ + -row 0 -column 0 -rowspan 1 -columnspan 1 -sticky news +grid $w.vscroll -in $w.grid -padx 1 -pady 1 \ + -row 0 -column 1 -rowspan 1 -columnspan 1 -sticky news +grid $w.hscroll -in $w.grid -padx 1 -pady 1 \ + -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news + + +set bg [lindex [$c config -bg] 4] +for {set i 0} {$i < 20} {incr i} { + set x [expr {-10 + 3*$i}] + for {set j 0; set y -10} {$j < 10} {incr j; incr y 3} { + $c create rect ${x}c ${y}c [expr $x+2]c [expr $y+2]c \ + -outline black -fill $bg -tags rect + $c create text [expr $x+1]c [expr $y+1]c -text "$i,$j" \ + -anchor center -tags text + } +} + +$c bind all "scrollEnter $c" +$c bind all "scrollLeave $c" +$c bind all <1> "scrollButton $c" +bind $c <2> "$c scan mark %x %y" +bind $c "$c scan dragto %x %y" + +proc scrollEnter canvas { + global oldFill + set id [$canvas find withtag current] + if {[lsearch [$canvas gettags current] text] >= 0} { + set id [expr $id-1] + } + set oldFill [lindex [$canvas itemconfig $id -fill] 4] + if {[winfo depth $canvas] > 1} { + $canvas itemconfigure $id -fill SeaGreen1 + } else { + $canvas itemconfigure $id -fill black + $canvas itemconfigure [expr $id+1] -fill white + } +} + +proc scrollLeave canvas { + global oldFill + set id [$canvas find withtag current] + if {[lsearch [$canvas gettags current] text] >= 0} { + set id [expr $id-1] + } + $canvas itemconfigure $id -fill $oldFill + $canvas itemconfigure [expr $id+1] -fill black +} + +proc scrollButton canvas { + global oldFill + set id [$canvas find withtag current] + if {[lsearch [$canvas gettags current] text] < 0} { + set id [expr $id+1] + } + puts stdout "You buttoned at [lindex [$canvas itemconf $id -text] 4]" +} diff --git a/library/demos/ctext.tcl b/library/demos/ctext.tcl new file mode 100644 index 0000000..fdd3f79 --- /dev/null +++ b/library/demos/ctext.tcl @@ -0,0 +1,146 @@ +# ctext.tcl -- +# +# This demonstration script creates a canvas widget with a text +# item that can be edited and reconfigured in various ways. +# +# SCCS: @(#) ctext.tcl 1.6 97/03/02 16:21:02 + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +set w .ctext +catch {destroy $w} +toplevel $w +wm title $w "Canvas Text Demonstration" +wm iconname $w "Text" +positionWindow $w +set c $w.c + +label $w.msg -font $font -wraplength 5i -justify left -text "This window displays a string of text to demonstrate the text facilities of canvas widgets. You can click in the boxes to adjust the position of the text relative to its positioning point or change its justification. The text also supports the following simple bindings for editing: + 1. You can point, click, and type. + 2. You can also select with button 1. + 3. You can copy the selection to the mouse position with button 2. + 4. Backspace and Control+h delete the selection if there is one; + otherwise they delete the character just before the insertion cursor. + 5. Delete deletes the selection if there is one; otherwise it deletes + the character just after the insertion cursor." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +canvas $c -relief flat -borderwidth 0 -width 500 -height 350 +pack $w.c -side top -expand yes -fill both + +set textFont {Helvetica 24} + +$c create rectangle 245 195 255 205 -outline black -fill red + +# First, create the text item and give it bindings so it can be edited. + +$c addtag text withtag [$c create text 250 200 -text "This is just a string of text to demonstrate the text facilities of canvas widgets. Bindings have been been defined to support editing (see above)." -width 440 -anchor n -font {Helvetica 24} -justify left] +$c bind text <1> "textB1Press $c %x %y" +$c bind text "textB1Move $c %x %y" +$c bind text "$c select adjust current @%x,%y" +$c bind text "textB1Move $c %x %y" +$c bind text "textInsert $c %A" +$c bind text "textInsert $c \\n" +$c bind text "textBs $c" +$c bind text "textBs $c" +$c bind text "textDel $c" +$c bind text <2> "textPaste $c @%x,%y" + +# Next, create some items that allow the text's anchor position +# to be edited. + +proc mkTextConfig {w x y option value color} { + set item [$w create rect [expr $x] [expr $y] [expr $x+30] [expr $y+30] \ + -outline black -fill $color -width 1] + $w bind $item <1> "$w itemconf text $option $value" + $w addtag config withtag $item +} + +set x 50 +set y 50 +set color LightSkyBlue1 +mkTextConfig $c $x $y -anchor se $color +mkTextConfig $c [expr $x+30] [expr $y] -anchor s $color +mkTextConfig $c [expr $x+60] [expr $y] -anchor sw $color +mkTextConfig $c [expr $x] [expr $y+30] -anchor e $color +mkTextConfig $c [expr $x+30] [expr $y+30] -anchor center $color +mkTextConfig $c [expr $x+60] [expr $y+30] -anchor w $color +mkTextConfig $c [expr $x] [expr $y+60] -anchor ne $color +mkTextConfig $c [expr $x+30] [expr $y+60] -anchor n $color +mkTextConfig $c [expr $x+60] [expr $y+60] -anchor nw $color +set item [$c create rect [expr $x+40] [expr $y+40] [expr $x+50] [expr $y+50] \ + -outline black -fill red] +$c bind $item <1> "$c itemconf text -anchor center" +$c create text [expr $x+45] [expr $y-5] -text {Text Position} -anchor s \ + -font {Times 24} -fill brown + +# Lastly, create some items that allow the text's justification to be +# changed. + +set x 350 +set y 50 +set color SeaGreen2 +mkTextConfig $c $x $y -justify left $color +mkTextConfig $c [expr $x+30] [expr $y] -justify center $color +mkTextConfig $c [expr $x+60] [expr $y] -justify right $color +$c create text [expr $x+45] [expr $y-5] -text {Justification} -anchor s \ + -font {Times 24} -fill brown + +$c bind config "textEnter $c" +$c bind config "$c itemconf current -fill \$textConfigFill" + +set textConfigFill {} + +proc textEnter {w} { + global textConfigFill + set textConfigFill [lindex [$w itemconfig current -fill] 4] + $w itemconfig current -fill black +} + +proc textInsert {w string} { + if {$string == ""} { + return + } + catch {$w dchars text sel.first sel.last} + $w insert text insert $string +} + +proc textPaste {w pos} { + catch { + $w insert text $pos [selection get] + } +} + +proc textB1Press {w x y} { + $w icursor current @$x,$y + $w focus current + focus $w + $w select from current @$x,$y +} + +proc textB1Move {w x y} { + $w select to current @$x,$y +} + +proc textBs {w} { + if ![catch {$w dchars text sel.first sel.last}] { + return + } + set char [expr {[$w index text insert] - 1}] + if {$char >= 0} {$w dchar text $char} +} + +proc textDel {w} { + if ![catch {$w dchars text sel.first sel.last}] { + return + } + $w dchars text insert +} diff --git a/library/demos/dialog1.tcl b/library/demos/dialog1.tcl new file mode 100644 index 0000000..e221beb --- /dev/null +++ b/library/demos/dialog1.tcl @@ -0,0 +1,15 @@ +# dialog1.tcl -- +# +# This demonstration script creates a dialog box with a local grab. +# +# SCCS: @(#) dialog1.tcl 1.2 96/02/16 10:49:52 + +after idle {.dialog1.msg configure -wraplength 4i} +set i [tk_dialog .dialog1 "Dialog with local grab" {This is a modal dialog box. It uses Tk's "grab" command to create a "local grab" on the dialog box. The grab prevents any pointer-related events from getting to any other windows in the application until you have answered the dialog by invoking one of the buttons below. However, you can still interact with other applications.} \ +info 0 OK Cancel {Show Code}] + +switch $i { + 0 {puts "You pressed OK"} + 1 {puts "You pressed Cancel"} + 2 {showCode .dialog1} +} diff --git a/library/demos/dialog2.tcl b/library/demos/dialog2.tcl new file mode 100644 index 0000000..0cc3bb6 --- /dev/null +++ b/library/demos/dialog2.tcl @@ -0,0 +1,19 @@ +# dialog2.tcl -- +# +# This demonstration script creates a dialog box with a global grab. +# +# SCCS: @(#) dialog2.tcl 1.2 96/02/16 10:49:53 + +after idle { + .dialog2.msg configure -wraplength 4i +} +after 100 { + grab -global .dialog2 +} +set i [tk_dialog .dialog2 "Dialog with local grab" {This dialog box uses a global grab, so it prevents you from interacting with anything on your display until you invoke one of the buttons below. Global grabs are almost always a bad idea; don't use them unless you're truly desperate.} warning 0 OK Cancel {Show Code}] + +switch $i { + 0 {puts "You pressed OK"} + 1 {puts "You pressed Cancel"} + 2 {showCode .dialog2} +} diff --git a/library/demos/entry1.tcl b/library/demos/entry1.tcl new file mode 100644 index 0000000..0b68b68 --- /dev/null +++ b/library/demos/entry1.tcl @@ -0,0 +1,36 @@ +# entry1.tcl -- +# +# This demonstration script creates several entry widgets without +# scrollbars. +# +# SCCS: @(#) entry1.tcl 1.5 97/03/02 16:22:10 + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +set w .entry1 +catch {destroy $w} +toplevel $w +wm title $w "Entry Demonstration (no scrollbars)" +wm iconname $w "entry1" +positionWindow $w + +label $w.msg -font $font -wraplength 5i -justify left -text "Three different entries are displayed below. You can add characters by pointing, clicking and typing. The normal Motif editing characters are supported, along with many Emacs bindings. For example, Backspace and Control-h delete the character to the left of the insertion cursor and Delete and Control-d delete the chararacter to the right of the insertion cursor. For entries that are too large to fit in the window all at once, you can scan through the entries by dragging with mouse button2 pressed." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +entry $w.e1 +entry $w.e2 +entry $w.e3 +pack $w.e1 $w.e2 $w.e3 -side top -pady 5 -padx 10 -fill x + +$w.e1 insert 0 "Initial value" +$w.e2 insert end "This entry contains a long value, much too long " +$w.e2 insert end "to fit in the window at one time, so long in fact " +$w.e2 insert end "that you'll have to scan or scroll to see the end." diff --git a/library/demos/entry2.tcl b/library/demos/entry2.tcl new file mode 100644 index 0000000..d9b67cd --- /dev/null +++ b/library/demos/entry2.tcl @@ -0,0 +1,48 @@ +# entry2.tcl -- +# +# This demonstration script is the same as the entry1.tcl script +# except that it creates scrollbars for the entries. +# +# SCCS: @(#) entry2.tcl 1.5 97/03/02 16:22:24 + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +set w .entry2 +catch {destroy $w} +toplevel $w +wm title $w "Entry Demonstration (with scrollbars)" +wm iconname $w "entry2" +positionWindow $w + +label $w.msg -font $font -wraplength 5i -justify left -text "Three different entries are displayed below, with a scrollbar for each entry. You can add characters by pointing, clicking and typing. The normal Motif editing characters are supported, along with many Emacs bindings. For example, Backspace and Control-h delete the character to the left of the insertion cursor and Delete and Control-d delete the chararacter to the right of the insertion cursor. For entries that are too large to fit in the window all at once, you can scan through the entries with the scrollbars, or by dragging with mouse button2 pressed." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +frame $w.frame -borderwidth 10 +pack $w.frame -side top -fill x -expand 1 + +entry $w.frame.e1 -xscrollcommand "$w.frame.s1 set" +scrollbar $w.frame.s1 -relief sunken -orient horiz -command \ + "$w.frame.e1 xview" +frame $w.frame.spacer1 -width 20 -height 10 +entry $w.frame.e2 -xscrollcommand "$w.frame.s2 set" +scrollbar $w.frame.s2 -relief sunken -orient horiz -command \ + "$w.frame.e2 xview" +frame $w.frame.spacer2 -width 20 -height 10 +entry $w.frame.e3 -xscrollcommand "$w.frame.s3 set" +scrollbar $w.frame.s3 -relief sunken -orient horiz -command \ + "$w.frame.e3 xview" +pack $w.frame.e1 $w.frame.s1 $w.frame.spacer1 $w.frame.e2 $w.frame.s2 \ + $w.frame.spacer2 $w.frame.e3 $w.frame.s3 -side top -fill x + +$w.frame.e1 insert 0 "Initial value" +$w.frame.e2 insert end "This entry contains a long value, much too long " +$w.frame.e2 insert end "to fit in the window at one time, so long in fact " +$w.frame.e2 insert end "that you'll have to scan or scroll to see the end." diff --git a/library/demos/filebox.tcl b/library/demos/filebox.tcl new file mode 100644 index 0000000..83eeacc --- /dev/null +++ b/library/demos/filebox.tcl @@ -0,0 +1,70 @@ +# filebox.tcl -- +# +# This demonstration script prompts the user to select a file. +# +# SCCS: @(#) filebox.tcl 1.3 97/03/02 16:22:36 + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +set w .filebox +catch {destroy $w} +toplevel $w +wm title $w "File Selection Dialogs" +wm iconname $w "filebox" +positionWindow $w + +label $w.msg -font $font -wraplength 4i -justify left -text "Enter a file name in the entry box or click on the \"Browse\" buttons to select a file name using the file selection dialog." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +foreach i {open save} { + set f [frame $w.$i] + label $f.lab -text "Select a file to $i: " -anchor e + entry $f.ent -width 20 + button $f.but -text "Browse ..." -command "fileDialog $w $f.ent $i" + pack $f.lab -side left + pack $f.ent -side left -expand yes -fill x + pack $f.but -side left + pack $f -fill x -padx 1c -pady 3 +} + +if ![string compare $tcl_platform(platform) unix] { + checkbutton $w.strict -text "Use Motif Style Dialog" \ + -variable tk_strictMotif -onvalue 1 -offvalue 0 + pack $w.strict -anchor c +} + +proc fileDialog {w ent operation} { + # Type names Extension(s) Mac File Type(s) + # + #--------------------------------------------------------- + set types { + {"Text files" {.txt .doc} } + {"Text files" {} TEXT} + {"Tcl Scripts" {.tcl} TEXT} + {"C Source Files" {.c .h} } + {"All Source Files" {.tcl .c .h} } + {"Image Files" {.gif} } + {"Image Files" {.jpeg .jpg} } + {"Image Files" "" {GIFF JPEG}} + {"All files" *} + } + if {$operation == "open"} { + set file [tk_getOpenFile -filetypes $types -parent $w] + } else { + set file [tk_getSaveFile -filetypes $types -parent $w \ + -initialfile Untitled -defaultextension .txt] + } + if [string compare $file ""] { + $ent delete 0 end + $ent insert 0 $file + $ent xview end + } +} diff --git a/library/demos/floor.tcl b/library/demos/floor.tcl new file mode 100644 index 0000000..30b62da --- /dev/null +++ b/library/demos/floor.tcl @@ -0,0 +1,1370 @@ +# floor.tcl -- +# +# This demonstration script creates a canvas widet that displays the +# floorplan for DEC's Western Research Laboratory. +# +# SCCS: @(#) floor.tcl 1.6 97/03/02 16:23:32 + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +# floorDisplay -- +# Recreate the floorplan display in the canvas given by "w". The +# floor given by "active" is displayed on top with its office structure +# visible. +# +# Arguments: +# w - Name of the canvas window. +# active - Number of active floor (1, 2, or 3). + +proc floorDisplay {w active} { + global floorLabels floorItems colors activeFloor + + if {$activeFloor == $active} { + return + } + + $w delete all + set activeFloor $active + + # First go through the three floors, displaying the backgrounds for + # each floor. + + bg1 $w $colors(bg1) $colors(outline1) + bg2 $w $colors(bg2) $colors(outline2) + bg3 $w $colors(bg3) $colors(outline3) + + # Raise the background for the active floor so that it's on top. + + $w raise floor$active + + # Create a dummy item just to mark this point in the display list, + # so we can insert highlights here. + + $w create rect 0 100 1 101 -fill {} -outline {} -tags marker + + # Add the walls and labels for the active floor, along with + # transparent polygons that define the rooms on the floor. + # Make sure that the room polygons are on top. + + catch {unset floorLabels} + catch {unset floorItems} + fg$active $w $colors(offices) + $w raise room + + # Offset the floors diagonally from each other. + + $w move floor1 2c 2c + $w move floor2 1c 1c + + # Create items for the room entry and its label. + + $w create window 600 100 -anchor w -window $w.entry + $w create text 600 100 -anchor e -text "Room: " + $w config -scrollregion [$w bbox all] +} + +# newRoom -- +# This procedure is invoked whenever the mouse enters a room +# in the floorplan. It changes tags so that the current room is +# highlighted. +# +# Arguments: +# w - The name of the canvas window. + +proc newRoom w { + global currentRoom floorLabels + + set id [$w find withtag current] + if {$id != ""} { + set currentRoom $floorLabels($id) + } + update idletasks +} + +# roomChanged -- +# This procedure is invoked whenever the currentRoom variable changes. +# It highlights the current room and unhighlights any previous room. +# +# Arguments: +# w - The canvas window displaying the floorplan. +# args - Not used. + +proc roomChanged {w args} { + global currentRoom floorItems colors + $w delete highlight + if [catch {set item $floorItems($currentRoom)}] { + return + } + set new [eval \ + "$w create polygon [$w coords $item] -fill $colors(active) \ + -tags highlight"] + $w raise $new marker +} + +# bg1 -- +# This procedure represents part of the floorplan database. When +# invoked, it instantiates the background information for the first +# floor. +# +# Arguments: +# w - The canvas window. +# fill - Fill color to use for the floor's background. +# outline - Color to use for the floor's outline. + +proc bg1 {w fill outline} { + $w create poly 347 80 349 82 351 84 353 85 363 92 375 99 386 104 \ + 386 129 398 129 398 162 484 162 484 129 559 129 559 133 725 \ + 133 725 129 802 129 802 389 644 389 644 391 559 391 559 327 \ + 508 327 508 311 484 311 484 278 395 278 395 288 400 288 404 \ + 288 409 290 413 292 418 297 421 302 422 309 421 318 417 325 \ + 411 330 405 332 397 333 344 333 340 334 336 336 335 338 332 \ + 342 331 347 332 351 334 354 336 357 341 359 340 360 335 363 \ + 331 365 326 366 304 366 304 355 258 355 258 387 60 387 60 391 \ + 0 391 0 337 3 337 3 114 8 114 8 25 30 25 30 5 93 5 98 5 104 7 \ + 110 10 116 16 119 20 122 28 123 32 123 68 220 68 220 34 221 \ + 22 223 17 227 13 231 8 236 4 242 2 246 0 260 0 283 1 300 5 \ + 321 14 335 22 348 25 365 29 363 39 358 48 352 56 337 70 \ + 344 76 347 80 \ + -tags {floor1 bg} -fill $fill + $w create line 386 129 398 129 -fill $outline -tags {floor1 bg} + $w create line 258 355 258 387 -fill $outline -tags {floor1 bg} + $w create line 60 387 60 391 -fill $outline -tags {floor1 bg} + $w create line 0 337 0 391 -fill $outline -tags {floor1 bg} + $w create line 60 391 0 391 -fill $outline -tags {floor1 bg} + $w create line 3 114 3 337 -fill $outline -tags {floor1 bg} + $w create line 258 387 60 387 -fill $outline -tags {floor1 bg} + $w create line 484 162 398 162 -fill $outline -tags {floor1 bg} + $w create line 398 162 398 129 -fill $outline -tags {floor1 bg} + $w create line 484 278 484 311 -fill $outline -tags {floor1 bg} + $w create line 484 311 508 311 -fill $outline -tags {floor1 bg} + $w create line 508 327 508 311 -fill $outline -tags {floor1 bg} + $w create line 559 327 508 327 -fill $outline -tags {floor1 bg} + $w create line 644 391 559 391 -fill $outline -tags {floor1 bg} + $w create line 644 389 644 391 -fill $outline -tags {floor1 bg} + $w create line 559 129 484 129 -fill $outline -tags {floor1 bg} + $w create line 484 162 484 129 -fill $outline -tags {floor1 bg} + $w create line 725 133 559 133 -fill $outline -tags {floor1 bg} + $w create line 559 129 559 133 -fill $outline -tags {floor1 bg} + $w create line 725 129 802 129 -fill $outline -tags {floor1 bg} + $w create line 802 389 802 129 -fill $outline -tags {floor1 bg} + $w create line 3 337 0 337 -fill $outline -tags {floor1 bg} + $w create line 559 391 559 327 -fill $outline -tags {floor1 bg} + $w create line 802 389 644 389 -fill $outline -tags {floor1 bg} + $w create line 725 133 725 129 -fill $outline -tags {floor1 bg} + $w create line 8 25 8 114 -fill $outline -tags {floor1 bg} + $w create line 8 114 3 114 -fill $outline -tags {floor1 bg} + $w create line 30 25 8 25 -fill $outline -tags {floor1 bg} + $w create line 484 278 395 278 -fill $outline -tags {floor1 bg} + $w create line 30 25 30 5 -fill $outline -tags {floor1 bg} + $w create line 93 5 30 5 -fill $outline -tags {floor1 bg} + $w create line 98 5 93 5 -fill $outline -tags {floor1 bg} + $w create line 104 7 98 5 -fill $outline -tags {floor1 bg} + $w create line 110 10 104 7 -fill $outline -tags {floor1 bg} + $w create line 116 16 110 10 -fill $outline -tags {floor1 bg} + $w create line 119 20 116 16 -fill $outline -tags {floor1 bg} + $w create line 122 28 119 20 -fill $outline -tags {floor1 bg} + $w create line 123 32 122 28 -fill $outline -tags {floor1 bg} + $w create line 123 68 123 32 -fill $outline -tags {floor1 bg} + $w create line 220 68 123 68 -fill $outline -tags {floor1 bg} + $w create line 386 129 386 104 -fill $outline -tags {floor1 bg} + $w create line 386 104 375 99 -fill $outline -tags {floor1 bg} + $w create line 375 99 363 92 -fill $outline -tags {floor1 bg} + $w create line 353 85 363 92 -fill $outline -tags {floor1 bg} + $w create line 220 68 220 34 -fill $outline -tags {floor1 bg} + $w create line 337 70 352 56 -fill $outline -tags {floor1 bg} + $w create line 352 56 358 48 -fill $outline -tags {floor1 bg} + $w create line 358 48 363 39 -fill $outline -tags {floor1 bg} + $w create line 363 39 365 29 -fill $outline -tags {floor1 bg} + $w create line 365 29 348 25 -fill $outline -tags {floor1 bg} + $w create line 348 25 335 22 -fill $outline -tags {floor1 bg} + $w create line 335 22 321 14 -fill $outline -tags {floor1 bg} + $w create line 321 14 300 5 -fill $outline -tags {floor1 bg} + $w create line 300 5 283 1 -fill $outline -tags {floor1 bg} + $w create line 283 1 260 0 -fill $outline -tags {floor1 bg} + $w create line 260 0 246 0 -fill $outline -tags {floor1 bg} + $w create line 246 0 242 2 -fill $outline -tags {floor1 bg} + $w create line 242 2 236 4 -fill $outline -tags {floor1 bg} + $w create line 236 4 231 8 -fill $outline -tags {floor1 bg} + $w create line 231 8 227 13 -fill $outline -tags {floor1 bg} + $w create line 223 17 227 13 -fill $outline -tags {floor1 bg} + $w create line 221 22 223 17 -fill $outline -tags {floor1 bg} + $w create line 220 34 221 22 -fill $outline -tags {floor1 bg} + $w create line 340 360 335 363 -fill $outline -tags {floor1 bg} + $w create line 335 363 331 365 -fill $outline -tags {floor1 bg} + $w create line 331 365 326 366 -fill $outline -tags {floor1 bg} + $w create line 326 366 304 366 -fill $outline -tags {floor1 bg} + $w create line 304 355 304 366 -fill $outline -tags {floor1 bg} + $w create line 395 288 400 288 -fill $outline -tags {floor1 bg} + $w create line 404 288 400 288 -fill $outline -tags {floor1 bg} + $w create line 409 290 404 288 -fill $outline -tags {floor1 bg} + $w create line 413 292 409 290 -fill $outline -tags {floor1 bg} + $w create line 418 297 413 292 -fill $outline -tags {floor1 bg} + $w create line 421 302 418 297 -fill $outline -tags {floor1 bg} + $w create line 422 309 421 302 -fill $outline -tags {floor1 bg} + $w create line 421 318 422 309 -fill $outline -tags {floor1 bg} + $w create line 421 318 417 325 -fill $outline -tags {floor1 bg} + $w create line 417 325 411 330 -fill $outline -tags {floor1 bg} + $w create line 411 330 405 332 -fill $outline -tags {floor1 bg} + $w create line 405 332 397 333 -fill $outline -tags {floor1 bg} + $w create line 397 333 344 333 -fill $outline -tags {floor1 bg} + $w create line 344 333 340 334 -fill $outline -tags {floor1 bg} + $w create line 340 334 336 336 -fill $outline -tags {floor1 bg} + $w create line 336 336 335 338 -fill $outline -tags {floor1 bg} + $w create line 335 338 332 342 -fill $outline -tags {floor1 bg} + $w create line 331 347 332 342 -fill $outline -tags {floor1 bg} + $w create line 332 351 331 347 -fill $outline -tags {floor1 bg} + $w create line 334 354 332 351 -fill $outline -tags {floor1 bg} + $w create line 336 357 334 354 -fill $outline -tags {floor1 bg} + $w create line 341 359 336 357 -fill $outline -tags {floor1 bg} + $w create line 341 359 340 360 -fill $outline -tags {floor1 bg} + $w create line 395 288 395 278 -fill $outline -tags {floor1 bg} + $w create line 304 355 258 355 -fill $outline -tags {floor1 bg} + $w create line 347 80 344 76 -fill $outline -tags {floor1 bg} + $w create line 344 76 337 70 -fill $outline -tags {floor1 bg} + $w create line 349 82 347 80 -fill $outline -tags {floor1 bg} + $w create line 351 84 349 82 -fill $outline -tags {floor1 bg} + $w create line 353 85 351 84 -fill $outline -tags {floor1 bg} +} + +# bg2 -- +# This procedure represents part of the floorplan database. When +# invoked, it instantiates the background information for the second +# floor. +# +# Arguments: +# w - The canvas window. +# fill - Fill color to use for the floor's background. +# outline - Color to use for the floor's outline. + +proc bg2 {w fill outline} { + $w create poly 559 129 484 129 484 162 398 162 398 129 315 129 \ + 315 133 176 133 176 129 96 129 96 133 3 133 3 339 0 339 0 391 \ + 60 391 60 387 258 387 258 329 350 329 350 311 395 311 395 280 \ + 484 280 484 311 508 311 508 327 558 327 558 391 644 391 644 \ + 367 802 367 802 129 725 129 725 133 559 133 559 129 \ + -tags {floor2 bg} -fill $fill + $w create line 350 311 350 329 -fill $outline -tags {floor2 bg} + $w create line 398 129 398 162 -fill $outline -tags {floor2 bg} + $w create line 802 367 802 129 -fill $outline -tags {floor2 bg} + $w create line 802 129 725 129 -fill $outline -tags {floor2 bg} + $w create line 725 133 725 129 -fill $outline -tags {floor2 bg} + $w create line 559 129 559 133 -fill $outline -tags {floor2 bg} + $w create line 559 133 725 133 -fill $outline -tags {floor2 bg} + $w create line 484 162 484 129 -fill $outline -tags {floor2 bg} + $w create line 559 129 484 129 -fill $outline -tags {floor2 bg} + $w create line 802 367 644 367 -fill $outline -tags {floor2 bg} + $w create line 644 367 644 391 -fill $outline -tags {floor2 bg} + $w create line 644 391 558 391 -fill $outline -tags {floor2 bg} + $w create line 558 327 558 391 -fill $outline -tags {floor2 bg} + $w create line 558 327 508 327 -fill $outline -tags {floor2 bg} + $w create line 508 327 508 311 -fill $outline -tags {floor2 bg} + $w create line 484 311 508 311 -fill $outline -tags {floor2 bg} + $w create line 484 280 484 311 -fill $outline -tags {floor2 bg} + $w create line 398 162 484 162 -fill $outline -tags {floor2 bg} + $w create line 484 280 395 280 -fill $outline -tags {floor2 bg} + $w create line 395 280 395 311 -fill $outline -tags {floor2 bg} + $w create line 258 387 60 387 -fill $outline -tags {floor2 bg} + $w create line 3 133 3 339 -fill $outline -tags {floor2 bg} + $w create line 3 339 0 339 -fill $outline -tags {floor2 bg} + $w create line 60 391 0 391 -fill $outline -tags {floor2 bg} + $w create line 0 339 0 391 -fill $outline -tags {floor2 bg} + $w create line 60 387 60 391 -fill $outline -tags {floor2 bg} + $w create line 258 329 258 387 -fill $outline -tags {floor2 bg} + $w create line 350 329 258 329 -fill $outline -tags {floor2 bg} + $w create line 395 311 350 311 -fill $outline -tags {floor2 bg} + $w create line 398 129 315 129 -fill $outline -tags {floor2 bg} + $w create line 176 133 315 133 -fill $outline -tags {floor2 bg} + $w create line 176 129 96 129 -fill $outline -tags {floor2 bg} + $w create line 3 133 96 133 -fill $outline -tags {floor2 bg} + $w create line 315 133 315 129 -fill $outline -tags {floor2 bg} + $w create line 176 133 176 129 -fill $outline -tags {floor2 bg} + $w create line 96 133 96 129 -fill $outline -tags {floor2 bg} +} + +# bg3 -- +# This procedure represents part of the floorplan database. When +# invoked, it instantiates the background information for the third +# floor. +# +# Arguments: +# w - The canvas window. +# fill - Fill color to use for the floor's background. +# outline - Color to use for the floor's outline. + +proc bg3 {w fill outline} { + $w create poly 159 300 107 300 107 248 159 248 159 129 96 129 96 \ + 133 21 133 21 331 0 331 0 391 60 391 60 370 159 370 159 300 \ + -tags {floor3 bg} -fill $fill + $w create poly 258 370 258 329 350 329 350 311 399 311 399 129 \ + 315 129 315 133 176 133 176 129 159 129 159 370 258 370 \ + -tags {floor3 bg} -fill $fill + $w create line 96 133 96 129 -fill $outline -tags {floor3 bg} + $w create line 176 129 96 129 -fill $outline -tags {floor3 bg} + $w create line 176 129 176 133 -fill $outline -tags {floor3 bg} + $w create line 315 133 176 133 -fill $outline -tags {floor3 bg} + $w create line 315 133 315 129 -fill $outline -tags {floor3 bg} + $w create line 399 129 315 129 -fill $outline -tags {floor3 bg} + $w create line 399 311 399 129 -fill $outline -tags {floor3 bg} + $w create line 399 311 350 311 -fill $outline -tags {floor3 bg} + $w create line 350 329 350 311 -fill $outline -tags {floor3 bg} + $w create line 350 329 258 329 -fill $outline -tags {floor3 bg} + $w create line 258 370 258 329 -fill $outline -tags {floor3 bg} + $w create line 60 370 258 370 -fill $outline -tags {floor3 bg} + $w create line 60 370 60 391 -fill $outline -tags {floor3 bg} + $w create line 60 391 0 391 -fill $outline -tags {floor3 bg} + $w create line 0 391 0 331 -fill $outline -tags {floor3 bg} + $w create line 21 331 0 331 -fill $outline -tags {floor3 bg} + $w create line 21 331 21 133 -fill $outline -tags {floor3 bg} + $w create line 96 133 21 133 -fill $outline -tags {floor3 bg} + $w create line 107 300 159 300 159 248 107 248 107 300 \ + -fill $outline -tags {floor3 bg} +} + +# fg1 -- +# This procedure represents part of the floorplan database. When +# invoked, it instantiates the foreground information for the first +# floor (office outlines and numbers). +# +# Arguments: +# w - The canvas window. +# color - Color to use for drawing foreground information. + +proc fg1 {w color} { + global floorLabels floorItems + set i [$w create polygon 375 246 375 172 341 172 341 246 -fill {} -tags {floor1 room}] + set floorLabels($i) 101 + set {floorItems(101)} $i + $w create text 358 209 -text 101 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 307 240 339 240 339 206 307 206 -fill {} -tags {floor1 room}] + set floorLabels($i) {Pub Lift1} + set {floorItems(Pub Lift1)} $i + $w create text 323 223 -text {Pub Lift1} -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 339 205 307 205 307 171 339 171 -fill {} -tags {floor1 room}] + set floorLabels($i) {Priv Lift1} + set {floorItems(Priv Lift1)} $i + $w create text 323 188 -text {Priv Lift1} -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 42 389 42 337 1 337 1 389 -fill {} -tags {floor1 room}] + set floorLabels($i) 110 + set {floorItems(110)} $i + $w create text 21.5 363 -text 110 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 59 389 59 385 90 385 90 337 44 337 44 389 -fill {} -tags {floor1 room}] + set floorLabels($i) 109 + set {floorItems(109)} $i + $w create text 67 363 -text 109 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 51 300 51 253 6 253 6 300 -fill {} -tags {floor1 room}] + set floorLabels($i) 111 + set {floorItems(111)} $i + $w create text 28.5 276.5 -text 111 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 98 248 98 309 79 309 79 248 -fill {} -tags {floor1 room}] + set floorLabels($i) 117B + set {floorItems(117B)} $i + $w create text 88.5 278.5 -text 117B -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 51 251 51 204 6 204 6 251 -fill {} -tags {floor1 room}] + set floorLabels($i) 112 + set {floorItems(112)} $i + $w create text 28.5 227.5 -text 112 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 6 156 51 156 51 203 6 203 -fill {} -tags {floor1 room}] + set floorLabels($i) 113 + set {floorItems(113)} $i + $w create text 28.5 179.5 -text 113 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 85 169 79 169 79 192 85 192 -fill {} -tags {floor1 room}] + set floorLabels($i) 117A + set {floorItems(117A)} $i + $w create text 82 180.5 -text 117A -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 77 302 77 168 53 168 53 302 -fill {} -tags {floor1 room}] + set floorLabels($i) 117 + set {floorItems(117)} $i + $w create text 65 235 -text 117 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 51 155 51 115 6 115 6 155 -fill {} -tags {floor1 room}] + set floorLabels($i) 114 + set {floorItems(114)} $i + $w create text 28.5 135 -text 114 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 95 115 53 115 53 168 95 168 -fill {} -tags {floor1 room}] + set floorLabels($i) 115 + set {floorItems(115)} $i + $w create text 74 141.5 -text 115 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 87 113 87 27 10 27 10 113 -fill {} -tags {floor1 room}] + set floorLabels($i) 116 + set {floorItems(116)} $i + $w create text 48.5 70 -text 116 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 89 91 128 91 128 113 89 113 -fill {} -tags {floor1 room}] + set floorLabels($i) 118 + set {floorItems(118)} $i + $w create text 108.5 102 -text 118 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 178 128 178 132 216 132 216 91 163 91 163 112 149 112 149 128 -fill {} -tags {floor1 room}] + set floorLabels($i) 120 + set {floorItems(120)} $i + $w create text 189.5 111.5 -text 120 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 79 193 87 193 87 169 136 169 136 192 156 192 156 169 175 169 175 246 79 246 -fill {} -tags {floor1 room}] + set floorLabels($i) 122 + set {floorItems(122)} $i + $w create text 131 207.5 -text 122 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 138 169 154 169 154 191 138 191 -fill {} -tags {floor1 room}] + set floorLabels($i) 121 + set {floorItems(121)} $i + $w create text 146 180 -text 121 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 99 300 126 300 126 309 99 309 -fill {} -tags {floor1 room}] + set floorLabels($i) 106A + set {floorItems(106A)} $i + $w create text 112.5 304.5 -text 106A -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 128 299 128 309 150 309 150 248 99 248 99 299 -fill {} -tags {floor1 room}] + set floorLabels($i) 105 + set {floorItems(105)} $i + $w create text 124.5 278.5 -text 105 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 174 309 174 300 152 300 152 309 -fill {} -tags {floor1 room}] + set floorLabels($i) 106B + set {floorItems(106B)} $i + $w create text 163 304.5 -text 106B -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 176 299 176 309 216 309 216 248 152 248 152 299 -fill {} -tags {floor1 room}] + set floorLabels($i) 104 + set {floorItems(104)} $i + $w create text 184 278.5 -text 104 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 138 385 138 337 91 337 91 385 -fill {} -tags {floor1 room}] + set floorLabels($i) 108 + set {floorItems(108)} $i + $w create text 114.5 361 -text 108 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 256 337 140 337 140 385 256 385 -fill {} -tags {floor1 room}] + set floorLabels($i) 107 + set {floorItems(107)} $i + $w create text 198 361 -text 107 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 300 353 300 329 260 329 260 353 -fill {} -tags {floor1 room}] + set floorLabels($i) Smoking + set {floorItems(Smoking)} $i + $w create text 280 341 -text Smoking -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 314 135 314 170 306 170 306 246 177 246 177 135 -fill {} -tags {floor1 room}] + set floorLabels($i) 123 + set {floorItems(123)} $i + $w create text 245.5 190.5 -text 123 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 217 248 301 248 301 326 257 326 257 310 217 310 -fill {} -tags {floor1 room}] + set floorLabels($i) 103 + set {floorItems(103)} $i + $w create text 259 287 -text 103 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 396 188 377 188 377 169 316 169 316 131 396 131 -fill {} -tags {floor1 room}] + set floorLabels($i) 124 + set {floorItems(124)} $i + $w create text 356 150 -text 124 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 397 226 407 226 407 189 377 189 377 246 397 246 -fill {} -tags {floor1 room}] + set floorLabels($i) 125 + set {floorItems(125)} $i + $w create text 392 217.5 -text 125 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 399 187 409 187 409 207 474 207 474 164 399 164 -fill {} -tags {floor1 room}] + set floorLabels($i) 126 + set {floorItems(126)} $i + $w create text 436.5 185.5 -text 126 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 409 209 409 229 399 229 399 253 486 253 486 239 474 239 474 209 -fill {} -tags {floor1 room}] + set floorLabels($i) 127 + set {floorItems(127)} $i + $w create text 436.5 231 -text 127 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 501 164 501 174 495 174 495 188 490 188 490 204 476 204 476 164 -fill {} -tags {floor1 room}] + set floorLabels($i) MShower + set {floorItems(MShower)} $i + $w create text 488.5 184 -text MShower -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 497 176 513 176 513 204 492 204 492 190 497 190 -fill {} -tags {floor1 room}] + set floorLabels($i) Closet + set {floorItems(Closet)} $i + $w create text 502.5 190 -text Closet -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 476 237 476 206 513 206 513 254 488 254 488 237 -fill {} -tags {floor1 room}] + set floorLabels($i) WShower + set {floorItems(WShower)} $i + $w create text 494.5 230 -text WShower -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 486 131 558 131 558 135 724 135 724 166 697 166 697 275 553 275 531 254 515 254 515 174 503 174 503 161 486 161 -fill {} -tags {floor1 room}] + set floorLabels($i) 130 + set {floorItems(130)} $i + $w create text 638.5 205 -text 130 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 308 242 339 242 339 248 342 248 342 246 397 246 397 276 393 276 393 309 300 309 300 248 308 248 -fill {} -tags {floor1 room}] + set floorLabels($i) 102 + set {floorItems(102)} $i + $w create text 367.5 278.5 -text 102 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 397 255 486 255 486 276 397 276 -fill {} -tags {floor1 room}] + set floorLabels($i) 128 + set {floorItems(128)} $i + $w create text 441.5 265.5 -text 128 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 510 309 486 309 486 255 530 255 552 277 561 277 561 325 510 325 -fill {} -tags {floor1 room}] + set floorLabels($i) 129 + set {floorItems(129)} $i + $w create text 535.5 293 -text 129 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 696 281 740 281 740 387 642 387 642 389 561 389 561 277 696 277 -fill {} -tags {floor1 room}] + set floorLabels($i) 133 + set {floorItems(133)} $i + $w create text 628.5 335 -text 133 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 742 387 742 281 800 281 800 387 -fill {} -tags {floor1 room}] + set floorLabels($i) 132 + set {floorItems(132)} $i + $w create text 771 334 -text 132 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 800 168 800 280 699 280 699 168 -fill {} -tags {floor1 room}] + set floorLabels($i) 134 + set {floorItems(134)} $i + $w create text 749.5 224 -text 134 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 726 131 726 166 800 166 800 131 -fill {} -tags {floor1 room}] + set floorLabels($i) 135 + set {floorItems(135)} $i + $w create text 763 148.5 -text 135 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 340 360 335 363 331 365 326 366 304 366 304 312 396 312 396 288 400 288 404 288 409 290 413 292 418 297 421 302 422 309 421 318 417 325 411 330 405 332 397 333 344 333 340 334 336 336 335 338 332 342 331 347 332 351 334 354 336 357 341 359 -fill {} -tags {floor1 room}] + set floorLabels($i) {Ramona Stair} + set {floorItems(Ramona Stair)} $i + $w create text 368 323 -text {Ramona Stair} -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 30 23 30 5 93 5 98 5 104 7 110 10 116 16 119 20 122 28 123 32 123 68 220 68 220 87 90 87 90 23 -fill {} -tags {floor1 room}] + set floorLabels($i) {University Stair} + set {floorItems(University Stair)} $i + $w create text 155 77.5 -text {University Stair} -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 282 37 295 40 312 49 323 56 337 70 352 56 358 48 363 39 365 29 348 25 335 22 321 14 300 5 283 1 260 0 246 0 242 2 236 4 231 8 227 13 223 17 221 22 220 34 260 34 -fill {} -tags {floor1 room}] + set floorLabels($i) {Plaza Stair} + set {floorItems(Plaza Stair)} $i + $w create text 317.5 28.5 -text {Plaza Stair} -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 220 34 260 34 282 37 295 40 312 49 323 56 337 70 350 83 365 94 377 100 386 104 386 128 220 128 -fill {} -tags {floor1 room}] + set floorLabels($i) {Plaza Deck} + set {floorItems(Plaza Deck)} $i + $w create text 303 81 -text {Plaza Deck} -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 257 336 77 336 6 336 6 301 77 301 77 310 257 310 -fill {} -tags {floor1 room}] + set floorLabels($i) 106 + set {floorItems(106)} $i + $w create text 131.5 318.5 -text 106 -fill $color -anchor c -tags {floor1 label} + set i [$w create polygon 146 110 162 110 162 91 130 91 130 115 95 115 95 128 114 128 114 151 157 151 157 153 112 153 112 130 97 130 97 168 175 168 175 131 146 131 -fill {} -tags {floor1 room}] + set floorLabels($i) 119 + set {floorItems(119)} $i + $w create text 143.5 133 -text 119 -fill $color -anchor c -tags {floor1 label} + $w create line 155 191 155 189 -fill $color -tags {floor1 wall} + $w create line 155 177 155 169 -fill $color -tags {floor1 wall} + $w create line 96 129 96 169 -fill $color -tags {floor1 wall} + $w create line 78 169 176 169 -fill $color -tags {floor1 wall} + $w create line 176 247 176 129 -fill $color -tags {floor1 wall} + $w create line 340 206 307 206 -fill $color -tags {floor1 wall} + $w create line 340 187 340 170 -fill $color -tags {floor1 wall} + $w create line 340 210 340 201 -fill $color -tags {floor1 wall} + $w create line 340 247 340 224 -fill $color -tags {floor1 wall} + $w create line 340 241 307 241 -fill $color -tags {floor1 wall} + $w create line 376 246 376 170 -fill $color -tags {floor1 wall} + $w create line 307 247 307 170 -fill $color -tags {floor1 wall} + $w create line 376 170 307 170 -fill $color -tags {floor1 wall} + $w create line 315 129 315 170 -fill $color -tags {floor1 wall} + $w create line 147 129 176 129 -fill $color -tags {floor1 wall} + $w create line 202 133 176 133 -fill $color -tags {floor1 wall} + $w create line 398 129 315 129 -fill $color -tags {floor1 wall} + $w create line 258 352 258 387 -fill $color -tags {floor1 wall} + $w create line 60 387 60 391 -fill $color -tags {floor1 wall} + $w create line 0 337 0 391 -fill $color -tags {floor1 wall} + $w create line 60 391 0 391 -fill $color -tags {floor1 wall} + $w create line 3 114 3 337 -fill $color -tags {floor1 wall} + $w create line 258 387 60 387 -fill $color -tags {floor1 wall} + $w create line 52 237 52 273 -fill $color -tags {floor1 wall} + $w create line 52 189 52 225 -fill $color -tags {floor1 wall} + $w create line 52 140 52 177 -fill $color -tags {floor1 wall} + $w create line 395 306 395 311 -fill $color -tags {floor1 wall} + $w create line 531 254 398 254 -fill $color -tags {floor1 wall} + $w create line 475 178 475 238 -fill $color -tags {floor1 wall} + $w create line 502 162 398 162 -fill $color -tags {floor1 wall} + $w create line 398 129 398 188 -fill $color -tags {floor1 wall} + $w create line 383 188 376 188 -fill $color -tags {floor1 wall} + $w create line 408 188 408 194 -fill $color -tags {floor1 wall} + $w create line 398 227 398 254 -fill $color -tags {floor1 wall} + $w create line 408 227 398 227 -fill $color -tags {floor1 wall} + $w create line 408 222 408 227 -fill $color -tags {floor1 wall} + $w create line 408 206 408 210 -fill $color -tags {floor1 wall} + $w create line 408 208 475 208 -fill $color -tags {floor1 wall} + $w create line 484 278 484 311 -fill $color -tags {floor1 wall} + $w create line 484 311 508 311 -fill $color -tags {floor1 wall} + $w create line 508 327 508 311 -fill $color -tags {floor1 wall} + $w create line 559 327 508 327 -fill $color -tags {floor1 wall} + $w create line 644 391 559 391 -fill $color -tags {floor1 wall} + $w create line 644 389 644 391 -fill $color -tags {floor1 wall} + $w create line 514 205 475 205 -fill $color -tags {floor1 wall} + $w create line 496 189 496 187 -fill $color -tags {floor1 wall} + $w create line 559 129 484 129 -fill $color -tags {floor1 wall} + $w create line 484 162 484 129 -fill $color -tags {floor1 wall} + $w create line 725 133 559 133 -fill $color -tags {floor1 wall} + $w create line 559 129 559 133 -fill $color -tags {floor1 wall} + $w create line 725 149 725 167 -fill $color -tags {floor1 wall} + $w create line 725 129 802 129 -fill $color -tags {floor1 wall} + $w create line 802 389 802 129 -fill $color -tags {floor1 wall} + $w create line 739 167 802 167 -fill $color -tags {floor1 wall} + $w create line 396 188 408 188 -fill $color -tags {floor1 wall} + $w create line 0 337 9 337 -fill $color -tags {floor1 wall} + $w create line 58 337 21 337 -fill $color -tags {floor1 wall} + $w create line 43 391 43 337 -fill $color -tags {floor1 wall} + $w create line 105 337 75 337 -fill $color -tags {floor1 wall} + $w create line 91 387 91 337 -fill $color -tags {floor1 wall} + $w create line 154 337 117 337 -fill $color -tags {floor1 wall} + $w create line 139 387 139 337 -fill $color -tags {floor1 wall} + $w create line 227 337 166 337 -fill $color -tags {floor1 wall} + $w create line 258 337 251 337 -fill $color -tags {floor1 wall} + $w create line 258 328 302 328 -fill $color -tags {floor1 wall} + $w create line 302 355 302 311 -fill $color -tags {floor1 wall} + $w create line 395 311 302 311 -fill $color -tags {floor1 wall} + $w create line 484 278 395 278 -fill $color -tags {floor1 wall} + $w create line 395 294 395 278 -fill $color -tags {floor1 wall} + $w create line 473 278 473 275 -fill $color -tags {floor1 wall} + $w create line 473 256 473 254 -fill $color -tags {floor1 wall} + $w create line 533 257 531 254 -fill $color -tags {floor1 wall} + $w create line 553 276 551 274 -fill $color -tags {floor1 wall} + $w create line 698 276 553 276 -fill $color -tags {floor1 wall} + $w create line 559 391 559 327 -fill $color -tags {floor1 wall} + $w create line 802 389 644 389 -fill $color -tags {floor1 wall} + $w create line 741 314 741 389 -fill $color -tags {floor1 wall} + $w create line 698 280 698 167 -fill $color -tags {floor1 wall} + $w create line 707 280 698 280 -fill $color -tags {floor1 wall} + $w create line 802 280 731 280 -fill $color -tags {floor1 wall} + $w create line 741 280 741 302 -fill $color -tags {floor1 wall} + $w create line 698 167 727 167 -fill $color -tags {floor1 wall} + $w create line 725 137 725 129 -fill $color -tags {floor1 wall} + $w create line 514 254 514 175 -fill $color -tags {floor1 wall} + $w create line 496 175 514 175 -fill $color -tags {floor1 wall} + $w create line 502 175 502 162 -fill $color -tags {floor1 wall} + $w create line 475 166 475 162 -fill $color -tags {floor1 wall} + $w create line 496 176 496 175 -fill $color -tags {floor1 wall} + $w create line 491 189 496 189 -fill $color -tags {floor1 wall} + $w create line 491 205 491 189 -fill $color -tags {floor1 wall} + $w create line 487 238 475 238 -fill $color -tags {floor1 wall} + $w create line 487 240 487 238 -fill $color -tags {floor1 wall} + $w create line 487 252 487 254 -fill $color -tags {floor1 wall} + $w create line 315 133 304 133 -fill $color -tags {floor1 wall} + $w create line 256 133 280 133 -fill $color -tags {floor1 wall} + $w create line 78 247 270 247 -fill $color -tags {floor1 wall} + $w create line 307 247 294 247 -fill $color -tags {floor1 wall} + $w create line 214 133 232 133 -fill $color -tags {floor1 wall} + $w create line 217 247 217 266 -fill $color -tags {floor1 wall} + $w create line 217 309 217 291 -fill $color -tags {floor1 wall} + $w create line 217 309 172 309 -fill $color -tags {floor1 wall} + $w create line 154 309 148 309 -fill $color -tags {floor1 wall} + $w create line 175 300 175 309 -fill $color -tags {floor1 wall} + $w create line 151 300 175 300 -fill $color -tags {floor1 wall} + $w create line 151 247 151 309 -fill $color -tags {floor1 wall} + $w create line 78 237 78 265 -fill $color -tags {floor1 wall} + $w create line 78 286 78 309 -fill $color -tags {floor1 wall} + $w create line 106 309 78 309 -fill $color -tags {floor1 wall} + $w create line 130 309 125 309 -fill $color -tags {floor1 wall} + $w create line 99 309 99 247 -fill $color -tags {floor1 wall} + $w create line 127 299 99 299 -fill $color -tags {floor1 wall} + $w create line 127 309 127 299 -fill $color -tags {floor1 wall} + $w create line 155 191 137 191 -fill $color -tags {floor1 wall} + $w create line 137 169 137 191 -fill $color -tags {floor1 wall} + $w create line 78 171 78 169 -fill $color -tags {floor1 wall} + $w create line 78 190 78 218 -fill $color -tags {floor1 wall} + $w create line 86 192 86 169 -fill $color -tags {floor1 wall} + $w create line 86 192 78 192 -fill $color -tags {floor1 wall} + $w create line 52 301 3 301 -fill $color -tags {floor1 wall} + $w create line 52 286 52 301 -fill $color -tags {floor1 wall} + $w create line 52 252 3 252 -fill $color -tags {floor1 wall} + $w create line 52 203 3 203 -fill $color -tags {floor1 wall} + $w create line 3 156 52 156 -fill $color -tags {floor1 wall} + $w create line 8 25 8 114 -fill $color -tags {floor1 wall} + $w create line 63 114 3 114 -fill $color -tags {floor1 wall} + $w create line 75 114 97 114 -fill $color -tags {floor1 wall} + $w create line 108 114 129 114 -fill $color -tags {floor1 wall} + $w create line 129 114 129 89 -fill $color -tags {floor1 wall} + $w create line 52 114 52 128 -fill $color -tags {floor1 wall} + $w create line 132 89 88 89 -fill $color -tags {floor1 wall} + $w create line 88 25 88 89 -fill $color -tags {floor1 wall} + $w create line 88 114 88 89 -fill $color -tags {floor1 wall} + $w create line 218 89 144 89 -fill $color -tags {floor1 wall} + $w create line 147 111 147 129 -fill $color -tags {floor1 wall} + $w create line 162 111 147 111 -fill $color -tags {floor1 wall} + $w create line 162 109 162 111 -fill $color -tags {floor1 wall} + $w create line 162 96 162 89 -fill $color -tags {floor1 wall} + $w create line 218 89 218 94 -fill $color -tags {floor1 wall} + $w create line 218 89 218 119 -fill $color -tags {floor1 wall} + $w create line 8 25 88 25 -fill $color -tags {floor1 wall} + $w create line 258 337 258 328 -fill $color -tags {floor1 wall} + $w create line 113 129 96 129 -fill $color -tags {floor1 wall} + $w create line 302 355 258 355 -fill $color -tags {floor1 wall} + $w create line 386 104 386 129 -fill $color -tags {floor1 wall} + $w create line 377 100 386 104 -fill $color -tags {floor1 wall} + $w create line 365 94 377 100 -fill $color -tags {floor1 wall} + $w create line 350 83 365 94 -fill $color -tags {floor1 wall} + $w create line 337 70 350 83 -fill $color -tags {floor1 wall} + $w create line 337 70 323 56 -fill $color -tags {floor1 wall} + $w create line 312 49 323 56 -fill $color -tags {floor1 wall} + $w create line 295 40 312 49 -fill $color -tags {floor1 wall} + $w create line 282 37 295 40 -fill $color -tags {floor1 wall} + $w create line 260 34 282 37 -fill $color -tags {floor1 wall} + $w create line 253 34 260 34 -fill $color -tags {floor1 wall} + $w create line 386 128 386 104 -fill $color -tags {floor1 wall} + $w create line 113 152 156 152 -fill $color -tags {floor1 wall} + $w create line 113 152 156 152 -fill $color -tags {floor1 wall} + $w create line 113 152 113 129 -fill $color -tags {floor1 wall} +} + +# fg2 -- +# This procedure represents part of the floorplan database. When +# invoked, it instantiates the foreground information for the second +# floor (office outlines and numbers). +# +# Arguments: +# w - The canvas window. +# color - Color to use for drawing foreground information. + +proc fg2 {w color} { + global floorLabels floorItems + set i [$w create polygon 748 188 755 188 755 205 758 205 758 222 800 222 800 168 748 168 -fill {} -tags {floor2 room}] + set floorLabels($i) 238 + set {floorItems(238)} $i + $w create text 774 195 -text 238 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 726 188 746 188 746 166 800 166 800 131 726 131 -fill {} -tags {floor2 room}] + set floorLabels($i) 237 + set {floorItems(237)} $i + $w create text 763 148.5 -text 237 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 497 187 497 204 559 204 559 324 641 324 643 324 643 291 641 291 641 205 696 205 696 291 694 291 694 314 715 314 715 291 715 205 755 205 755 190 724 190 724 187 -fill {} -tags {floor2 room}] + set floorLabels($i) 246 + set {floorItems(246)} $i + $w create text 600 264 -text 246 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 694 279 643 279 643 314 694 314 -fill {} -tags {floor2 room}] + set floorLabels($i) 247 + set {floorItems(247)} $i + $w create text 668.5 296.5 -text 247 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 232 250 308 250 308 242 339 242 339 246 397 246 397 255 476 255 476 250 482 250 559 250 559 274 482 274 482 278 396 278 396 274 232 274 -fill {} -tags {floor2 room}] + set floorLabels($i) 202 + set {floorItems(202)} $i + $w create text 285.5 260 -text 202 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 53 228 53 338 176 338 233 338 233 196 306 196 306 180 175 180 175 169 156 169 156 196 176 196 176 228 -fill {} -tags {floor2 room}] + set floorLabels($i) 206 + set {floorItems(206)} $i + $w create text 143 267 -text 206 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 51 277 6 277 6 338 51 338 -fill {} -tags {floor2 room}] + set floorLabels($i) 212 + set {floorItems(212)} $i + $w create text 28.5 307.5 -text 212 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 557 276 486 276 486 309 510 309 510 325 557 325 -fill {} -tags {floor2 room}] + set floorLabels($i) 245 + set {floorItems(245)} $i + $w create text 521.5 300.5 -text 245 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 560 389 599 389 599 326 560 326 -fill {} -tags {floor2 room}] + set floorLabels($i) 244 + set {floorItems(244)} $i + $w create text 579.5 357.5 -text 244 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 601 389 601 326 643 326 643 389 -fill {} -tags {floor2 room}] + set floorLabels($i) 243 + set {floorItems(243)} $i + $w create text 622 357.5 -text 243 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 688 316 645 316 645 365 688 365 -fill {} -tags {floor2 room}] + set floorLabels($i) 242 + set {floorItems(242)} $i + $w create text 666.5 340.5 -text 242 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 802 367 759 367 759 226 802 226 -fill {} -tags {floor2 room}] + set floorLabels($i) {Barbecue Deck} + set {floorItems(Barbecue Deck)} $i + $w create text 780.5 296.5 -text {Barbecue Deck} -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 755 262 755 314 717 314 717 262 -fill {} -tags {floor2 room}] + set floorLabels($i) 240 + set {floorItems(240)} $i + $w create text 736 288 -text 240 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 755 316 689 316 689 365 755 365 -fill {} -tags {floor2 room}] + set floorLabels($i) 241 + set {floorItems(241)} $i + $w create text 722 340.5 -text 241 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 755 206 717 206 717 261 755 261 -fill {} -tags {floor2 room}] + set floorLabels($i) 239 + set {floorItems(239)} $i + $w create text 736 233.5 -text 239 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 695 277 643 277 643 206 695 206 -fill {} -tags {floor2 room}] + set floorLabels($i) 248 + set {floorItems(248)} $i + $w create text 669 241.5 -text 248 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 676 135 676 185 724 185 724 135 -fill {} -tags {floor2 room}] + set floorLabels($i) 236 + set {floorItems(236)} $i + $w create text 700 160 -text 236 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 675 135 635 135 635 145 628 145 628 185 675 185 -fill {} -tags {floor2 room}] + set floorLabels($i) 235 + set {floorItems(235)} $i + $w create text 651.5 160 -text 235 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 626 143 633 143 633 135 572 135 572 143 579 143 579 185 626 185 -fill {} -tags {floor2 room}] + set floorLabels($i) 234 + set {floorItems(234)} $i + $w create text 606 160 -text 234 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 557 135 571 135 571 145 578 145 578 185 527 185 527 131 557 131 -fill {} -tags {floor2 room}] + set floorLabels($i) 233 + set {floorItems(233)} $i + $w create text 552.5 158 -text 233 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 476 249 557 249 557 205 476 205 -fill {} -tags {floor2 room}] + set floorLabels($i) 230 + set {floorItems(230)} $i + $w create text 516.5 227 -text 230 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 476 164 486 164 486 131 525 131 525 185 476 185 -fill {} -tags {floor2 room}] + set floorLabels($i) 232 + set {floorItems(232)} $i + $w create text 500.5 158 -text 232 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 476 186 495 186 495 204 476 204 -fill {} -tags {floor2 room}] + set floorLabels($i) 229 + set {floorItems(229)} $i + $w create text 485.5 195 -text 229 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 474 207 409 207 409 187 399 187 399 164 474 164 -fill {} -tags {floor2 room}] + set floorLabels($i) 227 + set {floorItems(227)} $i + $w create text 436.5 185.5 -text 227 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 399 228 399 253 474 253 474 209 409 209 409 228 -fill {} -tags {floor2 room}] + set floorLabels($i) 228 + set {floorItems(228)} $i + $w create text 436.5 231 -text 228 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 397 246 397 226 407 226 407 189 377 189 377 246 -fill {} -tags {floor2 room}] + set floorLabels($i) 226 + set {floorItems(226)} $i + $w create text 392 217.5 -text 226 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 377 169 316 169 316 131 397 131 397 188 377 188 -fill {} -tags {floor2 room}] + set floorLabels($i) 225 + set {floorItems(225)} $i + $w create text 356.5 150 -text 225 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 234 198 306 198 306 249 234 249 -fill {} -tags {floor2 room}] + set floorLabels($i) 224 + set {floorItems(224)} $i + $w create text 270 223.5 -text 224 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 270 179 306 179 306 170 314 170 314 135 270 135 -fill {} -tags {floor2 room}] + set floorLabels($i) 223 + set {floorItems(223)} $i + $w create text 292 157 -text 223 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 268 179 221 179 221 135 268 135 -fill {} -tags {floor2 room}] + set floorLabels($i) 222 + set {floorItems(222)} $i + $w create text 244.5 157 -text 222 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 177 179 219 179 219 135 177 135 -fill {} -tags {floor2 room}] + set floorLabels($i) 221 + set {floorItems(221)} $i + $w create text 198 157 -text 221 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 299 327 349 327 349 284 341 284 341 276 299 276 -fill {} -tags {floor2 room}] + set floorLabels($i) 204 + set {floorItems(204)} $i + $w create text 324 301.5 -text 204 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 234 276 297 276 297 327 257 327 257 338 234 338 -fill {} -tags {floor2 room}] + set floorLabels($i) 205 + set {floorItems(205)} $i + $w create text 265.5 307 -text 205 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 256 385 256 340 212 340 212 385 -fill {} -tags {floor2 room}] + set floorLabels($i) 207 + set {floorItems(207)} $i + $w create text 234 362.5 -text 207 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 210 340 164 340 164 385 210 385 -fill {} -tags {floor2 room}] + set floorLabels($i) 208 + set {floorItems(208)} $i + $w create text 187 362.5 -text 208 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 115 340 162 340 162 385 115 385 -fill {} -tags {floor2 room}] + set floorLabels($i) 209 + set {floorItems(209)} $i + $w create text 138.5 362.5 -text 209 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 89 228 89 156 53 156 53 228 -fill {} -tags {floor2 room}] + set floorLabels($i) 217 + set {floorItems(217)} $i + $w create text 71 192 -text 217 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 89 169 97 169 97 190 89 190 -fill {} -tags {floor2 room}] + set floorLabels($i) 217A + set {floorItems(217A)} $i + $w create text 93 179.5 -text 217A -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 89 156 89 168 95 168 95 135 53 135 53 156 -fill {} -tags {floor2 room}] + set floorLabels($i) 216 + set {floorItems(216)} $i + $w create text 71 145.5 -text 216 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 51 179 51 135 6 135 6 179 -fill {} -tags {floor2 room}] + set floorLabels($i) 215 + set {floorItems(215)} $i + $w create text 28.5 157 -text 215 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 51 227 6 227 6 180 51 180 -fill {} -tags {floor2 room}] + set floorLabels($i) 214 + set {floorItems(214)} $i + $w create text 28.5 203.5 -text 214 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 51 275 6 275 6 229 51 229 -fill {} -tags {floor2 room}] + set floorLabels($i) 213 + set {floorItems(213)} $i + $w create text 28.5 252 -text 213 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 114 340 67 340 67 385 114 385 -fill {} -tags {floor2 room}] + set floorLabels($i) 210 + set {floorItems(210)} $i + $w create text 90.5 362.5 -text 210 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 59 389 59 385 65 385 65 340 1 340 1 389 -fill {} -tags {floor2 room}] + set floorLabels($i) 211 + set {floorItems(211)} $i + $w create text 33 364.5 -text 211 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 393 309 350 309 350 282 342 282 342 276 393 276 -fill {} -tags {floor2 room}] + set floorLabels($i) 203 + set {floorItems(203)} $i + $w create text 367.5 292.5 -text 203 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 99 191 91 191 91 226 174 226 174 198 154 198 154 192 109 192 109 169 99 169 -fill {} -tags {floor2 room}] + set floorLabels($i) 220 + set {floorItems(220)} $i + $w create text 132.5 208.5 -text 220 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 339 205 307 205 307 171 339 171 -fill {} -tags {floor2 room}] + set floorLabels($i) {Priv Lift2} + set {floorItems(Priv Lift2)} $i + $w create text 323 188 -text {Priv Lift2} -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 307 240 339 240 339 206 307 206 -fill {} -tags {floor2 room}] + set floorLabels($i) {Pub Lift 2} + set {floorItems(Pub Lift 2)} $i + $w create text 323 223 -text {Pub Lift 2} -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 175 168 97 168 97 131 175 131 -fill {} -tags {floor2 room}] + set floorLabels($i) 218 + set {floorItems(218)} $i + $w create text 136 149.5 -text 218 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 154 191 111 191 111 169 154 169 -fill {} -tags {floor2 room}] + set floorLabels($i) 219 + set {floorItems(219)} $i + $w create text 132.5 180 -text 219 -fill $color -anchor c -tags {floor2 label} + set i [$w create polygon 375 246 375 172 341 172 341 246 -fill {} -tags {floor2 room}] + set floorLabels($i) 201 + set {floorItems(201)} $i + $w create text 358 209 -text 201 -fill $color -anchor c -tags {floor2 label} + $w create line 641 186 678 186 -fill $color -tags {floor2 wall} + $w create line 757 350 757 367 -fill $color -tags {floor2 wall} + $w create line 634 133 634 144 -fill $color -tags {floor2 wall} + $w create line 634 144 627 144 -fill $color -tags {floor2 wall} + $w create line 572 133 572 144 -fill $color -tags {floor2 wall} + $w create line 572 144 579 144 -fill $color -tags {floor2 wall} + $w create line 398 129 398 162 -fill $color -tags {floor2 wall} + $w create line 174 197 175 197 -fill $color -tags {floor2 wall} + $w create line 175 197 175 227 -fill $color -tags {floor2 wall} + $w create line 757 206 757 221 -fill $color -tags {floor2 wall} + $w create line 396 188 408 188 -fill $color -tags {floor2 wall} + $w create line 727 189 725 189 -fill $color -tags {floor2 wall} + $w create line 747 167 802 167 -fill $color -tags {floor2 wall} + $w create line 747 167 747 189 -fill $color -tags {floor2 wall} + $w create line 755 189 739 189 -fill $color -tags {floor2 wall} + $w create line 769 224 757 224 -fill $color -tags {floor2 wall} + $w create line 802 224 802 129 -fill $color -tags {floor2 wall} + $w create line 802 129 725 129 -fill $color -tags {floor2 wall} + $w create line 725 189 725 129 -fill $color -tags {floor2 wall} + $w create line 725 186 690 186 -fill $color -tags {floor2 wall} + $w create line 676 133 676 186 -fill $color -tags {floor2 wall} + $w create line 627 144 627 186 -fill $color -tags {floor2 wall} + $w create line 629 186 593 186 -fill $color -tags {floor2 wall} + $w create line 579 144 579 186 -fill $color -tags {floor2 wall} + $w create line 559 129 559 133 -fill $color -tags {floor2 wall} + $w create line 725 133 559 133 -fill $color -tags {floor2 wall} + $w create line 484 162 484 129 -fill $color -tags {floor2 wall} + $w create line 559 129 484 129 -fill $color -tags {floor2 wall} + $w create line 526 129 526 186 -fill $color -tags {floor2 wall} + $w create line 540 186 581 186 -fill $color -tags {floor2 wall} + $w create line 528 186 523 186 -fill $color -tags {floor2 wall} + $w create line 511 186 475 186 -fill $color -tags {floor2 wall} + $w create line 496 190 496 186 -fill $color -tags {floor2 wall} + $w create line 496 205 496 202 -fill $color -tags {floor2 wall} + $w create line 475 205 527 205 -fill $color -tags {floor2 wall} + $w create line 558 205 539 205 -fill $color -tags {floor2 wall} + $w create line 558 205 558 249 -fill $color -tags {floor2 wall} + $w create line 558 249 475 249 -fill $color -tags {floor2 wall} + $w create line 662 206 642 206 -fill $color -tags {floor2 wall} + $w create line 695 206 675 206 -fill $color -tags {floor2 wall} + $w create line 695 278 642 278 -fill $color -tags {floor2 wall} + $w create line 642 291 642 206 -fill $color -tags {floor2 wall} + $w create line 695 291 695 206 -fill $color -tags {floor2 wall} + $w create line 716 208 716 206 -fill $color -tags {floor2 wall} + $w create line 757 206 716 206 -fill $color -tags {floor2 wall} + $w create line 757 221 757 224 -fill $color -tags {floor2 wall} + $w create line 793 224 802 224 -fill $color -tags {floor2 wall} + $w create line 757 262 716 262 -fill $color -tags {floor2 wall} + $w create line 716 220 716 264 -fill $color -tags {floor2 wall} + $w create line 716 315 716 276 -fill $color -tags {floor2 wall} + $w create line 757 315 703 315 -fill $color -tags {floor2 wall} + $w create line 757 325 757 224 -fill $color -tags {floor2 wall} + $w create line 757 367 644 367 -fill $color -tags {floor2 wall} + $w create line 689 367 689 315 -fill $color -tags {floor2 wall} + $w create line 647 315 644 315 -fill $color -tags {floor2 wall} + $w create line 659 315 691 315 -fill $color -tags {floor2 wall} + $w create line 600 325 600 391 -fill $color -tags {floor2 wall} + $w create line 627 325 644 325 -fill $color -tags {floor2 wall} + $w create line 644 391 644 315 -fill $color -tags {floor2 wall} + $w create line 615 325 575 325 -fill $color -tags {floor2 wall} + $w create line 644 391 558 391 -fill $color -tags {floor2 wall} + $w create line 563 325 558 325 -fill $color -tags {floor2 wall} + $w create line 558 391 558 314 -fill $color -tags {floor2 wall} + $w create line 558 327 508 327 -fill $color -tags {floor2 wall} + $w create line 558 275 484 275 -fill $color -tags {floor2 wall} + $w create line 558 302 558 275 -fill $color -tags {floor2 wall} + $w create line 508 327 508 311 -fill $color -tags {floor2 wall} + $w create line 484 311 508 311 -fill $color -tags {floor2 wall} + $w create line 484 275 484 311 -fill $color -tags {floor2 wall} + $w create line 475 208 408 208 -fill $color -tags {floor2 wall} + $w create line 408 206 408 210 -fill $color -tags {floor2 wall} + $w create line 408 222 408 227 -fill $color -tags {floor2 wall} + $w create line 408 227 398 227 -fill $color -tags {floor2 wall} + $w create line 398 227 398 254 -fill $color -tags {floor2 wall} + $w create line 408 188 408 194 -fill $color -tags {floor2 wall} + $w create line 383 188 376 188 -fill $color -tags {floor2 wall} + $w create line 398 188 398 162 -fill $color -tags {floor2 wall} + $w create line 398 162 484 162 -fill $color -tags {floor2 wall} + $w create line 475 162 475 254 -fill $color -tags {floor2 wall} + $w create line 398 254 475 254 -fill $color -tags {floor2 wall} + $w create line 484 280 395 280 -fill $color -tags {floor2 wall} + $w create line 395 311 395 275 -fill $color -tags {floor2 wall} + $w create line 307 197 293 197 -fill $color -tags {floor2 wall} + $w create line 278 197 233 197 -fill $color -tags {floor2 wall} + $w create line 233 197 233 249 -fill $color -tags {floor2 wall} + $w create line 307 179 284 179 -fill $color -tags {floor2 wall} + $w create line 233 249 278 249 -fill $color -tags {floor2 wall} + $w create line 269 179 269 133 -fill $color -tags {floor2 wall} + $w create line 220 179 220 133 -fill $color -tags {floor2 wall} + $w create line 155 191 110 191 -fill $color -tags {floor2 wall} + $w create line 90 190 98 190 -fill $color -tags {floor2 wall} + $w create line 98 169 98 190 -fill $color -tags {floor2 wall} + $w create line 52 133 52 165 -fill $color -tags {floor2 wall} + $w create line 52 214 52 177 -fill $color -tags {floor2 wall} + $w create line 52 226 52 262 -fill $color -tags {floor2 wall} + $w create line 52 274 52 276 -fill $color -tags {floor2 wall} + $w create line 234 275 234 339 -fill $color -tags {floor2 wall} + $w create line 226 339 258 339 -fill $color -tags {floor2 wall} + $w create line 211 387 211 339 -fill $color -tags {floor2 wall} + $w create line 214 339 177 339 -fill $color -tags {floor2 wall} + $w create line 258 387 60 387 -fill $color -tags {floor2 wall} + $w create line 3 133 3 339 -fill $color -tags {floor2 wall} + $w create line 165 339 129 339 -fill $color -tags {floor2 wall} + $w create line 117 339 80 339 -fill $color -tags {floor2 wall} + $w create line 68 339 59 339 -fill $color -tags {floor2 wall} + $w create line 0 339 46 339 -fill $color -tags {floor2 wall} + $w create line 60 391 0 391 -fill $color -tags {floor2 wall} + $w create line 0 339 0 391 -fill $color -tags {floor2 wall} + $w create line 60 387 60 391 -fill $color -tags {floor2 wall} + $w create line 258 329 258 387 -fill $color -tags {floor2 wall} + $w create line 350 329 258 329 -fill $color -tags {floor2 wall} + $w create line 395 311 350 311 -fill $color -tags {floor2 wall} + $w create line 398 129 315 129 -fill $color -tags {floor2 wall} + $w create line 176 133 315 133 -fill $color -tags {floor2 wall} + $w create line 176 129 96 129 -fill $color -tags {floor2 wall} + $w create line 3 133 96 133 -fill $color -tags {floor2 wall} + $w create line 66 387 66 339 -fill $color -tags {floor2 wall} + $w create line 115 387 115 339 -fill $color -tags {floor2 wall} + $w create line 163 387 163 339 -fill $color -tags {floor2 wall} + $w create line 234 275 276 275 -fill $color -tags {floor2 wall} + $w create line 288 275 309 275 -fill $color -tags {floor2 wall} + $w create line 298 275 298 329 -fill $color -tags {floor2 wall} + $w create line 341 283 350 283 -fill $color -tags {floor2 wall} + $w create line 321 275 341 275 -fill $color -tags {floor2 wall} + $w create line 375 275 395 275 -fill $color -tags {floor2 wall} + $w create line 315 129 315 170 -fill $color -tags {floor2 wall} + $w create line 376 170 307 170 -fill $color -tags {floor2 wall} + $w create line 307 250 307 170 -fill $color -tags {floor2 wall} + $w create line 376 245 376 170 -fill $color -tags {floor2 wall} + $w create line 340 241 307 241 -fill $color -tags {floor2 wall} + $w create line 340 245 340 224 -fill $color -tags {floor2 wall} + $w create line 340 210 340 201 -fill $color -tags {floor2 wall} + $w create line 340 187 340 170 -fill $color -tags {floor2 wall} + $w create line 340 206 307 206 -fill $color -tags {floor2 wall} + $w create line 293 250 307 250 -fill $color -tags {floor2 wall} + $w create line 271 179 238 179 -fill $color -tags {floor2 wall} + $w create line 226 179 195 179 -fill $color -tags {floor2 wall} + $w create line 176 129 176 179 -fill $color -tags {floor2 wall} + $w create line 182 179 176 179 -fill $color -tags {floor2 wall} + $w create line 174 169 176 169 -fill $color -tags {floor2 wall} + $w create line 162 169 90 169 -fill $color -tags {floor2 wall} + $w create line 96 169 96 129 -fill $color -tags {floor2 wall} + $w create line 175 227 90 227 -fill $color -tags {floor2 wall} + $w create line 90 190 90 227 -fill $color -tags {floor2 wall} + $w create line 52 179 3 179 -fill $color -tags {floor2 wall} + $w create line 52 228 3 228 -fill $color -tags {floor2 wall} + $w create line 52 276 3 276 -fill $color -tags {floor2 wall} + $w create line 155 177 155 169 -fill $color -tags {floor2 wall} + $w create line 110 191 110 169 -fill $color -tags {floor2 wall} + $w create line 155 189 155 197 -fill $color -tags {floor2 wall} + $w create line 350 283 350 329 -fill $color -tags {floor2 wall} + $w create line 162 197 155 197 -fill $color -tags {floor2 wall} + $w create line 341 275 341 283 -fill $color -tags {floor2 wall} +} + +# fg3 -- +# This procedure represents part of the floorplan database. When +# invoked, it instantiates the foreground information for the third +# floor (office outlines and numbers). +# +# Arguments: +# w - The canvas window. +# color - Color to use for drawing foreground information. + +proc fg3 {w color} { + global floorLabels floorItems + set i [$w create polygon 89 228 89 180 70 180 70 228 -fill {} -tags {floor3 room}] + set floorLabels($i) 316 + set {floorItems(316)} $i + $w create text 79.5 204 -text 316 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 115 368 162 368 162 323 115 323 -fill {} -tags {floor3 room}] + set floorLabels($i) 309 + set {floorItems(309)} $i + $w create text 138.5 345.5 -text 309 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 164 323 164 368 211 368 211 323 -fill {} -tags {floor3 room}] + set floorLabels($i) 308 + set {floorItems(308)} $i + $w create text 187.5 345.5 -text 308 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 256 368 212 368 212 323 256 323 -fill {} -tags {floor3 room}] + set floorLabels($i) 307 + set {floorItems(307)} $i + $w create text 234 345.5 -text 307 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 244 276 297 276 297 327 260 327 260 321 244 321 -fill {} -tags {floor3 room}] + set floorLabels($i) 305 + set {floorItems(305)} $i + $w create text 270.5 301.5 -text 305 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 251 219 251 203 244 203 244 219 -fill {} -tags {floor3 room}] + set floorLabels($i) 324B + set {floorItems(324B)} $i + $w create text 247.5 211 -text 324B -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 251 249 244 249 244 232 251 232 -fill {} -tags {floor3 room}] + set floorLabels($i) 324A + set {floorItems(324A)} $i + $w create text 247.5 240.5 -text 324A -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 223 135 223 179 177 179 177 135 -fill {} -tags {floor3 room}] + set floorLabels($i) 320 + set {floorItems(320)} $i + $w create text 200 157 -text 320 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 114 368 114 323 67 323 67 368 -fill {} -tags {floor3 room}] + set floorLabels($i) 310 + set {floorItems(310)} $i + $w create text 90.5 345.5 -text 310 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 23 277 23 321 68 321 68 277 -fill {} -tags {floor3 room}] + set floorLabels($i) 312 + set {floorItems(312)} $i + $w create text 45.5 299 -text 312 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 23 229 68 229 68 275 23 275 -fill {} -tags {floor3 room}] + set floorLabels($i) 313 + set {floorItems(313)} $i + $w create text 45.5 252 -text 313 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 68 227 23 227 23 180 68 180 -fill {} -tags {floor3 room}] + set floorLabels($i) 314 + set {floorItems(314)} $i + $w create text 45.5 203.5 -text 314 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 95 179 95 135 23 135 23 179 -fill {} -tags {floor3 room}] + set floorLabels($i) 315 + set {floorItems(315)} $i + $w create text 59 157 -text 315 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 99 226 99 204 91 204 91 226 -fill {} -tags {floor3 room}] + set floorLabels($i) 316B + set {floorItems(316B)} $i + $w create text 95 215 -text 316B -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 91 202 99 202 99 180 91 180 -fill {} -tags {floor3 room}] + set floorLabels($i) 316A + set {floorItems(316A)} $i + $w create text 95 191 -text 316A -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 97 169 109 169 109 192 154 192 154 198 174 198 174 226 101 226 101 179 97 179 -fill {} -tags {floor3 room}] + set floorLabels($i) 319 + set {floorItems(319)} $i + $w create text 141.5 209 -text 319 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 65 368 58 368 58 389 1 389 1 333 23 333 23 323 65 323 -fill {} -tags {floor3 room}] + set floorLabels($i) 311 + set {floorItems(311)} $i + $w create text 29.5 361 -text 311 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 154 191 111 191 111 169 154 169 -fill {} -tags {floor3 room}] + set floorLabels($i) 318 + set {floorItems(318)} $i + $w create text 132.5 180 -text 318 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 175 168 97 168 97 131 175 131 -fill {} -tags {floor3 room}] + set floorLabels($i) 317 + set {floorItems(317)} $i + $w create text 136 149.5 -text 317 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 274 194 274 221 306 221 306 194 -fill {} -tags {floor3 room}] + set floorLabels($i) 323 + set {floorItems(323)} $i + $w create text 290 207.5 -text 323 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 306 222 274 222 274 249 306 249 -fill {} -tags {floor3 room}] + set floorLabels($i) 325 + set {floorItems(325)} $i + $w create text 290 235.5 -text 325 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 263 179 224 179 224 135 263 135 -fill {} -tags {floor3 room}] + set floorLabels($i) 321 + set {floorItems(321)} $i + $w create text 243.5 157 -text 321 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 314 169 306 169 306 192 273 192 264 181 264 135 314 135 -fill {} -tags {floor3 room}] + set floorLabels($i) 322 + set {floorItems(322)} $i + $w create text 293.5 163.5 -text 322 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 307 240 339 240 339 206 307 206 -fill {} -tags {floor3 room}] + set floorLabels($i) {Pub Lift3} + set {floorItems(Pub Lift3)} $i + $w create text 323 223 -text {Pub Lift3} -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 339 205 307 205 307 171 339 171 -fill {} -tags {floor3 room}] + set floorLabels($i) {Priv Lift3} + set {floorItems(Priv Lift3)} $i + $w create text 323 188 -text {Priv Lift3} -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 350 284 376 284 376 276 397 276 397 309 350 309 -fill {} -tags {floor3 room}] + set floorLabels($i) 303 + set {floorItems(303)} $i + $w create text 373.5 292.5 -text 303 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 272 203 272 249 252 249 252 230 244 230 244 221 252 221 252 203 -fill {} -tags {floor3 room}] + set floorLabels($i) 324 + set {floorItems(324)} $i + $w create text 262 226 -text 324 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 299 276 299 327 349 327 349 284 341 284 341 276 -fill {} -tags {floor3 room}] + set floorLabels($i) 304 + set {floorItems(304)} $i + $w create text 324 301.5 -text 304 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 375 246 375 172 341 172 341 246 -fill {} -tags {floor3 room}] + set floorLabels($i) 301 + set {floorItems(301)} $i + $w create text 358 209 -text 301 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 397 246 377 246 377 185 397 185 -fill {} -tags {floor3 room}] + set floorLabels($i) 327 + set {floorItems(327)} $i + $w create text 387 215.5 -text 327 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 316 131 316 169 377 169 377 185 397 185 397 131 -fill {} -tags {floor3 room}] + set floorLabels($i) 326 + set {floorItems(326)} $i + $w create text 356.5 150 -text 326 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 308 251 242 251 242 274 342 274 342 282 375 282 375 274 397 274 397 248 339 248 339 242 308 242 -fill {} -tags {floor3 room}] + set floorLabels($i) 302 + set {floorItems(302)} $i + $w create text 319.5 261 -text 302 -fill $color -anchor c -tags {floor3 label} + set i [$w create polygon 70 321 242 321 242 200 259 200 259 203 272 203 272 193 263 180 242 180 175 180 175 169 156 169 156 196 177 196 177 228 107 228 70 228 70 275 107 275 107 248 160 248 160 301 107 301 107 275 70 275 -fill {} -tags {floor3 room}] + set floorLabels($i) 306 + set {floorItems(306)} $i + $w create text 200.5 284.5 -text 306 -fill $color -anchor c -tags {floor3 label} + $w create line 341 275 341 283 -fill $color -tags {floor3 wall} + $w create line 162 197 155 197 -fill $color -tags {floor3 wall} + $w create line 396 247 399 247 -fill $color -tags {floor3 wall} + $w create line 399 129 399 311 -fill $color -tags {floor3 wall} + $w create line 258 202 243 202 -fill $color -tags {floor3 wall} + $w create line 350 283 350 329 -fill $color -tags {floor3 wall} + $w create line 251 231 243 231 -fill $color -tags {floor3 wall} + $w create line 243 220 251 220 -fill $color -tags {floor3 wall} + $w create line 243 250 243 202 -fill $color -tags {floor3 wall} + $w create line 155 197 155 190 -fill $color -tags {floor3 wall} + $w create line 110 192 110 169 -fill $color -tags {floor3 wall} + $w create line 155 192 110 192 -fill $color -tags {floor3 wall} + $w create line 155 177 155 169 -fill $color -tags {floor3 wall} + $w create line 176 197 176 227 -fill $color -tags {floor3 wall} + $w create line 69 280 69 274 -fill $color -tags {floor3 wall} + $w create line 21 276 69 276 -fill $color -tags {floor3 wall} + $w create line 69 262 69 226 -fill $color -tags {floor3 wall} + $w create line 21 228 69 228 -fill $color -tags {floor3 wall} + $w create line 21 179 75 179 -fill $color -tags {floor3 wall} + $w create line 69 179 69 214 -fill $color -tags {floor3 wall} + $w create line 90 220 90 227 -fill $color -tags {floor3 wall} + $w create line 90 204 90 202 -fill $color -tags {floor3 wall} + $w create line 90 203 100 203 -fill $color -tags {floor3 wall} + $w create line 90 187 90 179 -fill $color -tags {floor3 wall} + $w create line 90 227 176 227 -fill $color -tags {floor3 wall} + $w create line 100 179 100 227 -fill $color -tags {floor3 wall} + $w create line 100 179 87 179 -fill $color -tags {floor3 wall} + $w create line 96 179 96 129 -fill $color -tags {floor3 wall} + $w create line 162 169 96 169 -fill $color -tags {floor3 wall} + $w create line 173 169 176 169 -fill $color -tags {floor3 wall} + $w create line 182 179 176 179 -fill $color -tags {floor3 wall} + $w create line 176 129 176 179 -fill $color -tags {floor3 wall} + $w create line 195 179 226 179 -fill $color -tags {floor3 wall} + $w create line 224 133 224 179 -fill $color -tags {floor3 wall} + $w create line 264 179 264 133 -fill $color -tags {floor3 wall} + $w create line 238 179 264 179 -fill $color -tags {floor3 wall} + $w create line 273 207 273 193 -fill $color -tags {floor3 wall} + $w create line 273 235 273 250 -fill $color -tags {floor3 wall} + $w create line 273 224 273 219 -fill $color -tags {floor3 wall} + $w create line 273 193 307 193 -fill $color -tags {floor3 wall} + $w create line 273 222 307 222 -fill $color -tags {floor3 wall} + $w create line 273 250 307 250 -fill $color -tags {floor3 wall} + $w create line 384 247 376 247 -fill $color -tags {floor3 wall} + $w create line 340 206 307 206 -fill $color -tags {floor3 wall} + $w create line 340 187 340 170 -fill $color -tags {floor3 wall} + $w create line 340 210 340 201 -fill $color -tags {floor3 wall} + $w create line 340 247 340 224 -fill $color -tags {floor3 wall} + $w create line 340 241 307 241 -fill $color -tags {floor3 wall} + $w create line 376 247 376 170 -fill $color -tags {floor3 wall} + $w create line 307 250 307 170 -fill $color -tags {floor3 wall} + $w create line 376 170 307 170 -fill $color -tags {floor3 wall} + $w create line 315 129 315 170 -fill $color -tags {floor3 wall} + $w create line 376 283 366 283 -fill $color -tags {floor3 wall} + $w create line 376 283 376 275 -fill $color -tags {floor3 wall} + $w create line 399 275 376 275 -fill $color -tags {floor3 wall} + $w create line 341 275 320 275 -fill $color -tags {floor3 wall} + $w create line 341 283 350 283 -fill $color -tags {floor3 wall} + $w create line 298 275 298 329 -fill $color -tags {floor3 wall} + $w create line 308 275 298 275 -fill $color -tags {floor3 wall} + $w create line 243 322 243 275 -fill $color -tags {floor3 wall} + $w create line 243 275 284 275 -fill $color -tags {floor3 wall} + $w create line 258 322 226 322 -fill $color -tags {floor3 wall} + $w create line 212 370 212 322 -fill $color -tags {floor3 wall} + $w create line 214 322 177 322 -fill $color -tags {floor3 wall} + $w create line 163 370 163 322 -fill $color -tags {floor3 wall} + $w create line 165 322 129 322 -fill $color -tags {floor3 wall} + $w create line 84 322 117 322 -fill $color -tags {floor3 wall} + $w create line 71 322 64 322 -fill $color -tags {floor3 wall} + $w create line 115 322 115 370 -fill $color -tags {floor3 wall} + $w create line 66 322 66 370 -fill $color -tags {floor3 wall} + $w create line 52 322 21 322 -fill $color -tags {floor3 wall} + $w create line 21 331 0 331 -fill $color -tags {floor3 wall} + $w create line 21 331 21 133 -fill $color -tags {floor3 wall} + $w create line 96 133 21 133 -fill $color -tags {floor3 wall} + $w create line 176 129 96 129 -fill $color -tags {floor3 wall} + $w create line 315 133 176 133 -fill $color -tags {floor3 wall} + $w create line 315 129 399 129 -fill $color -tags {floor3 wall} + $w create line 399 311 350 311 -fill $color -tags {floor3 wall} + $w create line 350 329 258 329 -fill $color -tags {floor3 wall} + $w create line 258 322 258 370 -fill $color -tags {floor3 wall} + $w create line 60 370 258 370 -fill $color -tags {floor3 wall} + $w create line 60 370 60 391 -fill $color -tags {floor3 wall} + $w create line 0 391 0 331 -fill $color -tags {floor3 wall} + $w create line 60 391 0 391 -fill $color -tags {floor3 wall} + $w create line 307 250 307 242 -fill $color -tags {floor3 wall} + $w create line 273 250 307 250 -fill $color -tags {floor3 wall} + $w create line 258 250 243 250 -fill $color -tags {floor3 wall} +} + +# Below is the "main program" that creates the floorplan demonstration. + +set w .floor +global c tk_library currentRoom colors activeFloor +catch {destroy $w} +toplevel $w +wm title $w "Floorplan Canvas Demonstration" +wm iconname $w "Floorplan" +wm geometry $w +20+20 +wm minsize $w 100 100 + +label $w.msg -font $font -wraplength 8i -justify left -text "This window contains a canvas widget showing the floorplan of Digital Equipment Corporation's Western Research Laboratory. It has three levels. At any given time one of the levels is active, meaning that you can see its room structure. To activate a level, click the left mouse button anywhere on it. As the mouse moves over the active level, the room under the mouse lights up and its room number appears in the \"Room:\" entry. You can also type a room number in the entry and the room will light up." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +set f [frame $w.frame] +pack $f -side top -fill both -expand yes +set h [scrollbar $f.hscroll -highlightthickness 0 -orient horizontal] +set v [scrollbar $f.vscroll -highlightthickness 0 -orient vertical] +set f1 [frame $f.f1 -bd 2 -relief sunken] +set c [canvas $f1.c -width 900 -height 500 -borderwidth 0 \ + -highlightthickness 0 -xscrollcommand "$h set" -yscrollcommand "$v set"] +pack $c -expand yes -fill both +grid $f1 -padx 1 -pady 1 \ + -row 0 -column 0 -rowspan 1 -columnspan 1 -sticky news +grid $v -padx 1 -pady 1 \ + -row 0 -column 1 -rowspan 1 -columnspan 1 -sticky news +grid $h -padx 1 -pady 1 \ + -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news +grid rowconfig $f 0 -weight 1 -minsize 0 +grid columnconfig $f 0 -weight 1 -minsize 0 +pack $f -expand yes -fill both -padx 1 -pady 1 + +$v config -command "$c yview" +$h config -command "$c xview" + +# Create an entry for displaying and typing in current room. + +entry $c.entry -width 10 -relief sunken -bd 2 -textvariable currentRoom + +# Choose colors, then fill in the floorplan. + +if {[winfo depth $c] > 1} { + set colors(bg1) #a9c1da + set colors(outline1) #77889a + set colors(bg2) #9ab0c6 + set colors(outline2) #687786 + set colors(bg3) #8ba0b3 + set colors(outline3) #596673 + set colors(offices) Black + set colors(active) #c4d1df +} else { + set colors(bg1) white + set colors(outline1) black + set colors(bg2) white + set colors(outline2) black + set colors(bg3) white + set colors(outline3) black + set colors(offices) Black + set colors(active) black +} +set activeFloor "" +floorDisplay $c 3 + +# Set up event bindings for canvas: + +$c bind floor1 <1> "floorDisplay $c 1" +$c bind floor2 <1> "floorDisplay $c 2" +$c bind floor3 <1> "floorDisplay $c 3" +$c bind room "newRoom $c" +$c bind room {set currentRoom ""} +bind $c <2> "$c scan mark %x %y" +bind $c "$c scan dragto %x %y" +bind $c "unset currentRoom" +set currentRoom "" +trace variable currentRoom w "roomChanged $c" diff --git a/library/demos/form.tcl b/library/demos/form.tcl new file mode 100644 index 0000000..3c43497 --- /dev/null +++ b/library/demos/form.tcl @@ -0,0 +1,40 @@ +# form.tcl -- +# +# This demonstration script creates a simple form with a bunch +# of entry widgets. +# +# SCCS: @(#) form.tcl 1.5 97/03/02 16:23:48 + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +set w .form +catch {destroy $w} +toplevel $w +wm title $w "Form Demonstration" +wm iconname $w "form" +positionWindow $w + +label $w.msg -font $font -wraplength 4i -justify left -text "This window contains a simple form where you can type in the various entries and use tabs to move circularly between the entries." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +foreach i {f1 f2 f3 f4 f5} { + frame $w.$i -bd 2 + entry $w.$i.entry -relief sunken -width 40 + label $w.$i.label + pack $w.$i.entry -side right + pack $w.$i.label -side left +} +$w.f1.label config -text Name: +$w.f2.label config -text Address: +$w.f5.label config -text Phone: +pack $w.msg $w.f1 $w.f2 $w.f3 $w.f4 $w.f5 -side top -fill x +bind $w "destroy $w" +focus $w.f1.entry diff --git a/library/demos/hello b/library/demos/hello new file mode 100644 index 0000000..0fa5d05 --- /dev/null +++ b/library/demos/hello @@ -0,0 +1,18 @@ +#!/bin/sh +# the next line restarts using wish \ +exec wish "$0" "$@" + +# hello -- +# Simple Tk script to create a button that prints "Hello, world". +# Click on the button to terminate the program. +# +# SCCS: @(#) hello 1.6 96/02/16 10:49:18 +# +# The first line below creates the button, and the second line +# asks the packer to shrink-wrap the application's main window +# around the button. + +button .hello -text "Hello, world" -command { + puts stdout "Hello, world"; destroy . +} +pack .hello diff --git a/library/demos/hscale.tcl b/library/demos/hscale.tcl new file mode 100644 index 0000000..a760586 --- /dev/null +++ b/library/demos/hscale.tcl @@ -0,0 +1,47 @@ +# hscale.tcl -- +# +# This demonstration script shows an example with a horizontal scale. +# +# SCCS: @(#) hscale.tcl 1.4 97/03/02 16:24:01 + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +set w .hscale +catch {destroy $w} +toplevel $w +wm title $w "Horizontal Scale Demonstration" +wm iconname $w "hscale" +positionWindow $w + +label $w.msg -font $font -wraplength 3.5i -justify left -text "An arrow and a horizontal scale are displayed below. If you click or drag mouse button 1 in the scale, you can change the length of the arrow." +pack $w.msg -side top -padx .5c + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +frame $w.frame -borderwidth 10 +pack $w.frame -side top -fill x + +canvas $w.frame.canvas -width 50 -height 50 -bd 0 -highlightthickness 0 +$w.frame.canvas create polygon 0 0 1 1 2 2 -fill DeepSkyBlue3 -tags poly +$w.frame.canvas create line 0 0 1 1 2 2 0 0 -fill black -tags line +scale $w.frame.scale -orient horizontal -length 284 -from 0 -to 250 \ + -command "setWidth $w.frame.canvas" -tickinterval 50 +pack $w.frame.canvas -side top -expand yes -anchor s -fill x -padx 15 +pack $w.frame.scale -side bottom -expand yes -anchor n +$w.frame.scale set 75 + +proc setWidth {w width} { + incr width 21 + set x2 [expr $width - 30] + if {$x2 < 21} { + set x2 21 + } + $w coords poly 20 15 20 35 $x2 35 $x2 45 $width 25 $x2 5 $x2 15 20 15 + $w coords line 20 15 20 35 $x2 35 $x2 45 $width 25 $x2 5 $x2 15 20 15 +} diff --git a/library/demos/icon.tcl b/library/demos/icon.tcl new file mode 100644 index 0000000..1c98fd4 --- /dev/null +++ b/library/demos/icon.tcl @@ -0,0 +1,52 @@ +# icon.tcl -- +# +# This demonstration script creates a toplevel window containing +# buttons that display bitmaps instead of text. +# +# SCCS: @(#) icon.tcl 1.8 97/03/02 16:24:19 + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +set w .icon +catch {destroy $w} +toplevel $w +wm title $w "Iconic Button Demonstration" +wm iconname $w "icon" +positionWindow $w + +label $w.msg -font $font -wraplength 5i -justify left -text "This window shows three ways of using bitmaps or images in radiobuttons and checkbuttons. On the left are two radiobuttons, each of which displays a bitmap and an indicator. In the middle is a checkbutton that displays a different image depending on whether it is selected or not. On the right is a checkbutton that displays a single bitmap but changes its background color to indicate whether or not it is selected." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +image create bitmap flagup \ + -file [file join $tk_library demos images flagup.bmp] \ + -maskfile [file join $tk_library demos images flagup.bmp] +image create bitmap flagdown \ + -file [file join $tk_library demos images flagdown.bmp] \ + -maskfile [file join $tk_library demos images flagdown.bmp] +frame $w.frame -borderwidth 10 +pack $w.frame -side top + +checkbutton $w.frame.b1 -image flagdown -selectimage flagup \ + -indicatoron 0 +$w.frame.b1 configure -selectcolor [$w.frame.b1 cget -background] +checkbutton $w.frame.b2 \ + -bitmap @[file join $tk_library demos images letters.bmp] \ + -indicatoron 0 -selectcolor SeaGreen1 +frame $w.frame.left +pack $w.frame.left $w.frame.b1 $w.frame.b2 -side left -expand yes -padx 5m + +radiobutton $w.frame.left.b3 \ + -bitmap @[file join $tk_library demos images letters.bmp] \ + -variable letters -value full +radiobutton $w.frame.left.b4 \ + -bitmap @[file join $tk_library demos images noletter.bmp] \ + -variable letters -value empty +pack $w.frame.left.b3 $w.frame.left.b4 -side top -expand yes diff --git a/library/demos/image1.tcl b/library/demos/image1.tcl new file mode 100644 index 0000000..a3b78db --- /dev/null +++ b/library/demos/image1.tcl @@ -0,0 +1,36 @@ +# image1.tcl -- +# +# This demonstration script displays two image widgets. +# +# SCCS: @(#) image1.tcl 1.6 97/03/02 16:24:35 + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +set w .image1 +catch {destroy $w} +toplevel $w +wm title $w "Image Demonstration #1" +wm iconname $w "Image1" +positionWindow $w + +label $w.msg -font $font -wraplength 4i -justify left -text "This demonstration displays two images, each in a separate label widget." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +catch {image delete image1a} +image create photo image1a -file [file join $tk_library demos images earth.gif] +label $w.l1 -image image1a -bd 1 -relief sunken + +catch {image delete image1b} +image create photo image1b \ + -file [file join $tk_library demos images earthris.gif] +label $w.l2 -image image1b -bd 1 -relief sunken + +pack $w.l1 $w.l2 -side top -padx .5m -pady .5m diff --git a/library/demos/image2.tcl b/library/demos/image2.tcl new file mode 100644 index 0000000..badea14 --- /dev/null +++ b/library/demos/image2.tcl @@ -0,0 +1,80 @@ +# image2.tcl -- +# +# This demonstration script creates a simple collection of widgets +# that allow you to select and view images in a Tk label. +# +# SCCS: @(#) image2.tcl 1.9 97/03/02 16:24:48 + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +# loadDir -- +# This procedure reloads the directory listbox from the directory +# named in the demo's entry. +# +# Arguments: +# w - Name of the toplevel window of the demo. + +proc loadDir w { + global dirName + + $w.f.list delete 0 end + foreach i [lsort [glob [file join $dirName *]]] { + $w.f.list insert end [file tail $i] + } +} + +# loadImage -- +# Given the name of the toplevel window of the demo and the mouse +# position, extracts the directory entry under the mouse and loads +# that file into a photo image for display. +# +# Arguments: +# w - Name of the toplevel window of the demo. +# x, y- Mouse position within the listbox. + +proc loadImage {w x y} { + global dirName + + set file [file join $dirName [$w.f.list get @$x,$y]] + image2a configure -file $file +} + +set w .image2 +catch {destroy $w} +toplevel $w +wm title $w "Image Demonstration #2" +wm iconname $w "Image2" +positionWindow $w + +label $w.msg -font $font -wraplength 4i -justify left -text "This demonstration allows you to view images using a Tk \"photo\" image. First type a directory name in the listbox, then type Return to load the directory into the listbox. Then double-click on a file name in the listbox to see that image." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +label $w.dirLabel -text "Directory:" +set dirName [file join $tk_library demos images] +entry $w.dirName -width 30 -textvariable dirName +bind $w.dirName "loadDir $w" +frame $w.spacer1 -height 3m -width 20 +label $w.fileLabel -text "File:" +frame $w.f +pack $w.dirLabel $w.dirName $w.spacer1 $w.fileLabel $w.f -side top -anchor w + +listbox $w.f.list -width 20 -height 10 -yscrollcommand "$w.f.scroll set" +scrollbar $w.f.scroll -command "$w.f.list yview" +pack $w.f.list $w.f.scroll -side left -fill y -expand 1 +$w.f.list insert 0 earth.gif earthris.gif teapot.ppm +bind $w.f.list "loadImage $w %x %y" + +catch {image delete image2a} +image create photo image2a +frame $w.spacer2 -height 3m -width 20 +label $w.imageLabel -text "Image:" +label $w.image -image image2a +pack $w.spacer2 $w.imageLabel $w.image -side top -anchor w diff --git a/library/demos/images/earth.gif b/library/demos/images/earth.gif new file mode 100644 index 0000000..32d1328 --- /dev/null +++ b/library/demos/images/earth.gif @@ -0,0 +1,350 @@ +GIF87a@        ( (( 00(88(88(@80@@0@H0@H8@80H@0HH0H88H@8HH8HP8HX8HH@HP@HX@H`@H80P@0P88P@8PH8PP8P@@PH@PP@PX@P`@PPHPXHP`HPhHP88X@8XH8XP8X@@XH@XP@XX@XHHXPHXXHX`HXhHXXPX`PXhPXpPXhXX@@`H@`P@`HH`PH`XH``H`PP`XP``P`hP`pP``X`hX`pX`xX`p``x``H@hHHhPHhXHh`HhPPhXPh`PhhPhpPhXXh`XhhXhpXhxXhh`hp`hx`h`hxhhhhhhPPpXPp`PpXXp`XphXppXph`pp`px`p`pphpxhphphphpppppppppxpxpPPxXXx`XxhXxh`xp`xx`xphxxhxhxhxxpxpxpxpxpxxxxxxxxxxxxxh`phxhxpppxxxxxxxxȨȰȨȰаиȰȸиȸȸи,@0X@ 4@B :<  D|HAC+~l8`cń D"GZ X/s+Z̘ٯ_xS`Uy괩0H|3 +η P6gN.0 &]v]t:F6mo +&lAe 0\Hhi1DCb5 4`A9< 3JN,XC" H'$4|>9cx# +P1֫/IIJ/UU},Ք|ҋ+P $xEevYN,fq ESc$*Wc!vtمVaT]TZeڐflm@kepE)5g%q9\KTDx9\Ids$0%vY +$'i@ yB00#58+XJ% ,03#}25\C}X5 +dvigݨ`n)_l㉍@.ZEcZ4֕lXZh+dZk$٤oR. $x5DqyQṯTfC+UWM$ӹk҄/h 465B%'dB!dq,-t 0D6`L0̼bU~R/aXZ8[;KXdg@kqXKu|l1tZhZUAҖmoq +ed/Qo/@MJ"x$Pax 3TLL3M43i+L+\q#~(|2,RL5洓8h8g383 0p!^@:QI4oU_MH۔V^]ELָRV,j)lӆ-Jr+e0Kblrg_9@SI.%PUF9Aq@5AX` +a FNu8L'шD|B0G9a;qpw&3l<,z +^P <@O +/ hU5-G + +%ZK͐3X lD[x7tL9J7`$59Np ~! U +XP0^XAxbH#Rw~, n17[ 8fYZfM3uq^( F1Z3O}tϤI.!O6ԪMْR"UAD<- ܚ- 6JUbP0 _ĢC >a m2?Q5y@fz +d&"HF:q i8Q n|f,Ђ8p F-miJ|M{˭~WFDhtk;AU5F4YMl4?QQK:&"u-H-ы] +9er@ "\+AO1h OX` G8EtOqql>COC2i5-H$lSz!b ,g.A@Z/0 Ap nWU eKtP| f^Fvq`b`Culf  Y ֠ +3 +0 +` cF@Y dQij#>*Op+BE*`x7,!oOs>,G"?iI?P-"I +%T,WQncj\rIqHa7/@ +` p +0gh{]^7|DT`FpavmC|0 ` < +P gP< & 7OgX= _m`f=oh,- y$?q0ZHjzFbZ)jRc t@U(|Og WˆC7TcG0G`CBTUfeNG}KpTy0 +`@@`0  3VgS#;gvv3t1Gi!,B!"?wHy58.Q1crE/vrqA[b +` HeX ?tӇ7Ąm@EZ]v0نtMԷ] 0 HD 3?) _Q4r#"Jsptd۹*gb{ypi-"6rGH" &bE7j"''e7Gs/ + 8fu?X|[e EIerg0LLTŔְ@ζ]Rh W P@D & 033VTOQ5KWF,Dz}hw7G=U$-a6.fTa&b[mz𲇣/ r!! c@ڡ{ `:}cF0EXuf E { 1 +Ъ`SP 27 + +3ZW!OO$b#`1#va=;aXr*I#s?j#%^2)Rr#'sj8q3w +ӥ]sx0,`>B-Պ5e6aT&L%9zފ%/) İ6 ;ʩs]]%aBT؛FPTPePg`Tlz +Pż[X ` '[+Xq8aSL"qƺduX[G;N‘,b"bgIaj3w4d) 4<Ч; cPa`ѦP +yxllr]Cpd R0UePS`^L\̒𾨀 ' J +niAbTulq}!L*Pvau!OfiYS-;YȈQc% ꘉII!k7A" ^P  ޖdg;Oѩ|Lm P  3L]> m`XPFPT`V@S0e@U˾,f +} +KP Jƪc͓Nl5ԏWX;[Gƞ!sq$ +hb!z :'TR1Q*#0 3LÓ]{I'=ʃ]:p p1XWK`S }PmfdW~@ kƌ + ۨD H0!jrq6bl!GOA/kϽG`ay %ZJbܚr8:A[8 ŰϦ9a=]> ;pu:eLBFZE~yppT`k˽|@  +}< ۈ PADLygRnhk܄,ĝ"~hz] YyAY~zJ. 9]7u]ucp +Ђ]LP]0LxӵlP +X7pS0K`g@~gP |p[pװ +,>  `4 +BogYmsE'AȲ`>Fd^aq +Aar/f4!Q0 +Ġ.X`+.a-]oP.uN0v u'S`WfPYoi0p  +JWlۓ +` Ple |WK>г#3ٙ`8B@fPQǀ`s`hyޗb( Q sizR +  UK a`]~^>Pp]R:| HPoonjjоj +UHH*Oʹ;wתUx2J D^xA"M(LBʙ%DfMxT&"1i N3p!Lxa]0lX.(Ye:V-2`PR%Vuaĉ/nqS5_B)Dz' `&XЂ Fʀ0JP.+D+XD0k, &dd˂. ;̘SF>#2̘`2J4auטx +GJa0%FF"+R1&8?(+?8yN 7ԀKC4;bH@rنsRύϿn৮`u ^UNWa5 XʦdЩ/TV 4`F|ˁJ,*ZE,jGQh`H#<ߚ,J)Ev4&R̉sh-MFYn10aSLI1* 5d7" 9Ta ?">Š4@ 꾋DDMFqlSS1˯&X6d Qil[`l 0¥,lC jKķNE߲ p_ꀒ^melC7D"{mzK}a`З|xR1v#<M>yLSdiY;VL(c +)X6@Ʉ +F>c5PC 5Ï?Œ4= გIalaцR7(>=Bh$V '&1ت?  Y`KR! E*ph-M- +\% .|1KdDx@pF68kHHyHl*Aa`|sAa~t:]4ц0ĢSz26B"ЈGbbLј@F/h! Z7o |á (=AD&A=0<xxF0a>)}6 +@ JB6MW2OJf^AzJTvh\Bny!a]Hj(. +QYHB<`nE37'"#1 3% ,` +V/t-q=\t! BPf#!49-0ƝF12a +UB&ha o)ꔁ jJDJBh}!! u#; _DEQ9k] W5 eN~VL`nR)EC" "@Z]QWX$YHE3q$~l$;l2PA6x +N@t>C' 0`F>*b4cExpo`aŌK5X0%0a@aXhH 8;2i¶&ˑ\Y :s"[JBpF@ !h*#8P3pj@f8+70>1P49>؃?M3spu`Y kH5@T&]s 8;X9i ˝@ƾ4 ++1 1Yp,i;jyx TOd"1.pCF]F)qePs0nh\O8E@RB6h6OgO[ QPX848I,H7YZ`2@@ O`mWˈ#A$H|V"ѬQډ dT\ۉA + cڊȌ0iql,L"E4 sqgp[HL`68 z8;0M] }(ksX[p`ȄE0NQ1#MOȄ6hCRhMdXynpX䍃F3eHISXmIHOp*h*G$ ,p"Dz&P38+H8bebK83(KBЄWhfk]XF$ %}-  pK `+M  skh+Rċ;XaX NL#86>N X F`NXsRhbdDdHM(tpp%8!P0M F|xk@r1hRX3BhD(upeu{%/%$!1\03 *)Z#p؋C<*D3aa9Іfy؇{xmX@=(5䐄AhWi؆qpaTUPU(8%Y"^+RƲb XlJlٛHL;f TȪVZC.`.GZ\a8Qdh[pYFp1p4+9P[X#:`G{Ȇ|SK=u]@&)kp]X|?4X:0:`+H$Kj(*0A'g-@:(_A/p/(:x7(@/Єi}|_q48MVPM` .:% p% r];2W2606Ѹײ +R,b,9!\NK@P/IƃC8`E@iXXЅj0Ƴ]xHiЅ#kMDD@fi{HdHfe-h|}[Pe>kHSsQXnX{Kx-й-p'ԄEPXz[8PbmJXfAkixzY'8@Hjއ}("v5?UIPahTTA$ Z9^580Aa QiWdi6 GK, HD$ 5Uj@A@h6<ȅv ZGzYh;jpub0b(]p{@jaHPqpyP +bɃ=k(6RxMȁ/8-D8ȄLGC(zip,8U9r`qOmtw}Phxs@m(D0x}FWh|9NnIOK؈km5TC 7H_t㟛X j3. +b1Y^ ؋n  4 0I@[?1oXEol%G8tO ,Rh嚇{؇yPzxLPx1 Gn \rKs % 9r & /L^! uфI(L$K1U@M,%ԑ0=]Y>@_M`VUau&hejuW!z|HRK4dB%׆!p.R !ʂ#L02| )i7TC<1vxI8눳888c)tu#O>ݠ!& 5А(篿Q/g2%N1 ̼KE[Q<CBI'BL0Ŵ7+\*UJ* Q7t@N1DH-~$FԤ%eJ,l+W+ B5xAV0 B |Bp" vmX8Jug# DeXCx-!jc=R"xDpnV,dwt08J7}c ]#8! +*E7̑X M"(1Jcyw@`" +SHB*`8APqѝ_!6gC &a Y\_%藊bNX .,HY0',9RN^@H "DJj3a)KD O1mIhy8H b@Ca؇8,"CAEጵ"́Yà1:`ְC O٨F<1c$?-v!j N7i`OP:! Q+4 q;'[jG V9$rx/ {G3"8O E0ΰ"H +p;xtF-BAN G9b?!lPT9=Lx%N/L² Z6@-ɍ +f.jUR}tVݮ  /֗H@(6 8AlXh g G4wpG!HG:t|27M|J g$C bb *$p-a9ZCۉ6 h" Q[h8ġ}  s#ǐY@ؐ+L WB`)1@9YmP(<ÎK +_tĉ觊K QJfrkb@W,ANx\w&KT3 2WYr $ + кj 3p "~.ޡ [4#H%:x= @p!UqQx$"H=aPF3qO$p2zZ(Ƹ!GbM6 qHCPF<s5ȃ0,1M +l0 NAJpT>Qh8Cg%p9 +TPXXx5^ĂF;ށao$ a̠$TU 2I? 6z8e"Ŭ&Jٓ"La1KY̲/eILn Z]¤=aG&!w /$6t9ʡ$ G#xD)oXp:q`¡1,{ +y"Gz#!x 1牂1o*`* U@0DDp5H'`B 0;1O Ђ+B]Y/\B%(AdϹNqSۅ p%TTS\[Et}Wɖ0p@1UP@vuD C%tg6E"%Tx.ф@=|:8=ĊT:сBH=s["-Pp'2;ܑ5:̞>Ð};hB(`!A8|5><&B5غHC7p3PpTALT\A4p C:t|.%<-D=u>G5܂!.Ș (x68pe eC.h1# <؃9X +=cLM8MWpuI$LڡLn@DZ 278h$&B%HIA!Be{ H!7P=,M;`1A80 C5CBAC6T$E/ʺl$pTrxytu]089>//90CiFP9B49`%/Ђ(&zn\ (7d7:#$~;<+!2Ȇ)CTC=X-!5:IG=B88.|c^B,_>Tsf+5pݸ=f.mz+LYBC xf޾8x7oÙ>|p+m XX3Xp#w9 +O~B^1 T6ᅏKemzsI" +(8fLYC- +3c㖔iFƘDd1n9)E]z|wyyRGqdcS +ḵFeɁ #$qxK&<ǝ|)XX # %/3@"8#=8È4`` y%/8+JLH%`|qFvqǜkCI@eA<Ȁk~mC7a>b{@;0=*k>5<΁{` 6?VXQeNz`Dad50 +) #hhgz Ċΰ3#Xkrf{9qiezT]l%]QǞ}'|nn(c e2*iQRJJ #~CvaC Y'fşb e*RڕME,↿(Oc̊yf4c!ÑXy L9Pd֙uEIdLD:]9f\?8k- &Po.=v=8fWJhYE>*<@a)ȘB Ez)"Ei@-c-`"(k22dF cB <.x$,Oa}0'J S(C(F)d O6<X)!xtCN +"pXbbCKdhA?E +p F/ j`, @5!  x1^:d E sC]1><&358Ig0:t{4La eXi]|"F.ȁ(Ѻ(yBqdpg(І<"Ip0 A B! J#/V68 t`.BZ/[8Co7.! @&Vy':V^1ϲ%#p>QS = # .ps\.%Z t G9lv8 |Q%pD(`A x@:QUE!8Q(dNSHOc'XG7aOyجHF#*j`)Phhwdc\8CMpEP 8!5 C* +SHE+h!Zp/ + 3h? t(2_<эrb&0@a >Ё6` +<Yp0`7鎲 +;-5' L:(rqKP>ΒlƼRQIT;Qf0+A Ӹ+Z0gC5f 418Ghxn19ßF͠{H+hn*x-jaD ]x4V[.1>1B-:t >xa`94( oPM'$PVB0"DQjP_GY 0| Ar  F.J"|`YYʽ֪rX +ְh9;@ʣ;<X`5u'yϑI r@E`lȆ1 @ ԠKX +jhEhF,X5FэmL'6 +F(FhPf +](؉vk(P4Q*b q#A;PeiJaeTCNAmhco݄?!.u*$1B4 2 < @aD` u34 #lD|X沏Gy|#$8T8:d; r<*`#\̄[ʣ8ZG`xPX!PP g + @@B` +l``6d +4 `d€ʫG!Jjft JMj! ڀ`aސO@ j ` JAA @!& @  +/  + `A v h  䙞<`c#Z> T)X^(+Zn'\==EC< .RARj)s| @|`aPz{@>qO `a!hAn `$PF I!JfHl !%F! @r  hJ`#n! h"$ VlAjvJ +hbJ @ +t \ AZA @ d1GA,-~WYv#;w˺C˰.)k=qlX72 zARA^؁Π f +@@0!t +@aʡ: h| Ut d tDdG Fa>aKaJJҟ"&A&oFBMFA` g 4fOd@1, x @!SfQ @ @A0& $d +`TBqAPca +6aB尒7FS\Rvvv#(<KC xQLEiLQ:`ʁx!XRT!2 @ Ё!@0Ajhp@` d&@*@nu$B*vd*R2%kfiԁ>F @ ` |* v`a +`:D!lA`O .q +}s + + + }  v(L 8a2A!0F `4´O{ujZ>s: 91;().]* [4̃7?@TAh2(aaAl!!& : h ! *wr w mWOnod"%D(dL=w@*m ` ` ؠ@d@| \BaР pC!` +`  B L@yO +`.zؕ `2¬@ ڵ >a!h:Asdϭ:m6YTXhL(`^g8fn*ɒ=:i=#|ni? ZHVAz$,~a衶2b aܸA +ޠ2h`P|uWW׈"?yde$KuW * ٖV 88o@7*l!lApal4 +!` `  +0S +` !rA!{ČBct8נ{dW8%[NA1qw + +TZ ԧ8~pAn   aO" $ f/ @ + " Jl`@߸3n!naMfRa2G rJ#Y.vV9{C*9;04,8)#{{c\zcDp# *A(R 4A`j`HwDh eڠ۠zB|{Wp + `$sb!Ϊ@|pIrp`Ңap Q@X@!ja 8`/1Ǵ t n@@ 8a |~ ja~a:B*@ z@J@7.3]*:𑐅vy0㮁O@tǏ. ,32bam2aAʡ QC + |eZfYbYK>`X_^Y }e_ (/9`bX$B#%$l/RI0cN6,A>D +nd' "1Pc 8S.X#qő)Bt^"P01^\h[PDDPA EAlSg;[G-̑DCZAǀ$AFgaZe(AFO{D$,I"%JJUYV_cW^K $U,WOօ(U]65y/rPFh +f"6K +lxoІ6 Xd"pF3`A kCG76qCPp𞼍*>?`8G< qNA Ql\sfрoap0 G]9Y78 B^Hlx&F`# b)b!w_;Bpbz Ԡ4 +\%(Q ҂x ߔrTLKXv$PYb3$f^X  *&aL̸+! gQ8,C#;F8 b'`v8x#rNq7!2Xks~E;Tn xC6( X|"91?ސ@EGM, SD! +& g#bB)$ +bp`7ZU @ Lo 6X{@ U`BqB +Fii}$Ā|Wڙ1Zh({]b$` _X4q #;tÛ͘3q% +Ԁ;Q sXG;;YDʎqEKfF/&Kj* +80$$H ,2`$tdIr!wp02!A| +grPQz˽']1 +@!!:q`*L+@Kdݠ!ϊ.6`Dp-(~x" ĿxqH+4 d6`uX| 0ԁ ,\ G, +ApFL"03n uD_+80B0KA E؉J '!d@ (hX+8;\41 -rX H[Y]V.X@ +sAL2.UKG}ɮB:\C*Ș"Rq@$~W- Lb4/R%& Q nRЄ4A;48aЧ8y6FsU q1:(qTtWFJP5R7`EFr8Fג-\@ ,? ]H/Pw +g@Je $QlU0 Ir +h=g[P(syEB"ze'#$S>< b.bK`zpD +`I4Q lT !aRe1g.QRB05 Nmp9ϵ'p*7` Q~Pap*]LdslgPS+ 8VpGEERHE%U@}qp|A9? ؐ.bp15 Jp"vw;w^ `B@#z@4}={Cw%nne>axq%AG@U?3.#?HBK!2o obrt! TW|@(20fe\vH1B@&hЋ)P8iC?p +q` p +` 9ҡL_ ` ct\t;"8UBEp14Vo QSեht@@Qc:= +`X + %Qp_ogfs +0 s`yX{fWp(I? .3jy~Q&\AX!KZ2jgb\AXa9c%n}aT$r 0MӒ#"3.Vkf19ẑD`7659P` `r1*` `   4w:\` tPWoIp80.gЋ¨/ZWZHM~ 9ҢGzt1 !w @҈:c 0 h{ bjafcZC>`qJ &q@33@X>zWBI[XIaXP VXZҒ2Q])pG`FGy .ga J93 x ]8C\s JF ZE0ג[op`,-3) uR"-B8@cI0p +P +_d  h wu@f + ob`og}aj`)`Jhb?ge3J?_x%dsV*|tc9KGh; +&d + + +@l=hxp +"Fp@ h0'axH-gd&p>iJ =C.(gO gv M+l`_ DdA`"(Dl#%3,M-Rb4R9 -CpMP,` +@p 3pt +[c[ 0 fP + +iPwŻrp {y$p%>npqVwj@]ACsunCbn**KBbц{ +ap j@ 0t {  ` @ `02`!`)#=G]Pe 藠ñʰpgyb0u Krښf’EEPRR H`A.5R9p ]uԐ $ ' ~}]z7Hjp PX3 ;Q@.}wf̦I2V˧%Vg9KVӨ%&cQͽq>dmֻp p @؜ `%( 2;<NpHrPfI)y `p maq ( +>(X`U[98PALҢoY I,^ #bu,%P9%P@? @p ׂ\_ +נ +R|;HV;3<[`%>KԅC o|PhԄ2S[8Vy)"`e fzٮ@ q@t + 0 +9[@l'FB`!,+p/: *Jɫ%l ` +Sc@ +\L` OJ0S@\(EH@o}^M: B@E)#."(УA`970Ҷu +bx /fYknCVA=VYBԖ729[XA&FYfV3֖LsK `Z 0p  p IV:BPW&A) @Ycs7rp +~~P aP F 9o +jk-Ac^)9XIl:IA‚ @W` +53Rd)3a*R,RRF?oq7g$"\2`̄`A <`g?LX`g +B{4 R,fNEt3 +>I/^FI.5{ⲉ*f:QtY0KkW[w)Ep`%H!I)R#E5 EK (N'ouHJ$ 'bdi“MV:Pɗ5'! *Vz4AC +"E!"Sf̈ 3pA$ "( ^x#2Cuyf(1p@@"4 +-ԘȨb*أ,E8XC+p!B릖2-n +i'*Ǚ&I)tJ*'%( + rҀVET$уT&HÏEd?fZ9$d1g{|raA&<6%tX0898DtvbSulu}ǝOD08OpF[&xVA%rA;V"p@/=o $P(" " h0ta{V @H +,I 04. #8Ը"<')j,(JG(d|*0[ +( +KtKj ̜ W~iI#?(88$LIPc?,שǞzࡧo{xAgqmahj&s5qE{G|nGeYƑR1$PiE(BɃE F(cN(ˆzH!rx읡P @hx -ap!18DdpCD+C"%H@B +)C*c T0 Aa JAR=@zԊ %J +p3E,VOҔ2= U!`&H+YĀGD@R%pE%PX0VI@#t=ⱏ}Qp:gdG9-СơA jPP=Hk(Ҩh{f5@ g0K1B FxPD,A wpDzP8 22JPlAA D 8{Rp3h Bh@ M|`>DvP HAD9E4JA"YC*`@P gp@@A FAvĬjf S§%K9YS΂&A%eʘ\2tKAKHăoXEJk/1q`$0WP WAX0h;{(,dh) a X6`4Q:u#p$a+INrt#tDXF:A8xBA( OآFq Q9( M 2 U"PjV3B&2UнjF>&&Q"CbRX0 , j*5hjP)QIH!jĂH:QOB'P)S*}i8Jrhcz g@C8r4͸+=!#+X! vH;1x,@G,a Db@'@4V?8\vzCEmj:\5jXꔱщ2RPH0=\DdB 3\ }4&(9DK$']zJ);OlĴhG\ +p=D* !k 8Qr @qAFKB+7ܱ8%`Ll"DDc@'0GcCt[=p(Ht&|>dB(;  -B s$:8Eh !>! bȄ!HA>ڡ.ڢ90 P%[)h ^!p +<(+$Lᕲ;)>2j/Gʂl,)B >"`5I<c9ڡ f T68 X%#+q0)^Ú`3:<ࠪ9bX fr^s`_w0whfLf8) $Ђ$u&t`q[؆qhA"C :X1%00$@hȁX(HDjK|;ӇK?\i#{1C+1@]%P@hp-0X@g,R"er+$P,(Iߚ4H4x ? 讖óX&ԑ̳ ᙫ¨x< "̳( +Yk_@`Tpv*V`!7X4XE0n׾o|S"DD"T"ʘ(bbc*Y-XB=.;iإkSr?9F .Ʈ_4pHU!ERAFUl2 E`4RJRdD90TF*5GF!/5cL8SHAO H"rPJ"ŴS=4 +3쐓$Vt%tD'%>I%а b! t0-h#Ps(V A#.sH'T22"x". ":X<*o裪ocM#c82PO0}x,27TKa6|"(xRL5|2+1&) Z :aC~QDAhSTaf|A$~A |pFAL4JethQFXTM]dN7Gs>fnݖz| q\뚇tXW8mȃw7ĊVA Qm]%IБ!w#1&h8P26UGA1qPtLpx,X9M1Б- l.XA  i$:{U=8:Ʃw|\ypD8A h*ei\c`D'A n p#G9ѹ\" +xp`!<`uRP#4^KLbAjPЄ=A +f@5yHZ v~k5b?arz8jF +Tʎ"H;&}_dr\X zA +ِ"XQ +@Ca+h J"@0!=m'x >P6d[`>Gj.P4w{h)W׾(1!*pZ02`(a.pT@ O6(A RB"ucԠF(V<3%0kЄ>ATÀ҅ HDOX ֥@HGqJ8N\M;M7 X4UPO$KI >\/$/-VC9"`C +3`,l|́A^l=[-(|;Ai@,!U-$C,$܃:(ΫFoFm:5B.K;C:;K" hR&|A.|6 @<@ Fv g3LF0LDhЇ, <#XpR/V #sUZJ#@©/T;DqE6B+A.''/"t-D0 pd6|C6T7pKg49T![}σ:5B"_"h($]98.u"DAZ@hB0G-  @: 4-8BX)DTDC3B,'0"Љ7h65<6(5410010/+B!3hAA +57R6gDmrGԦT35F$mÅ8lDHԣ:CH* mD(L8=k*7D,p8xgxB)6'(BFƆB+x0B"p@ }C 8A28.C1k9tk΃Y|'kq3m @,7< +R =/>:: (@ +8t+Ⱥ kځnP @PIkfmq&jVL袓hƕ:ŽCꀣ9]yz)Z8Śr҉fhL%ej&sIP:_!\miDbZgBEd[B1D.@c\xBÃDDhLz8PT<i&>phRBi~Fhf_ &\( "QPA8 Ɠ/=r(yu+O3v x`<c/?{%Xb*2?w!xUC01v8F +@ 5Z t QMġy5aya XJ(F-ta c$CE:asE(F)rQjP#!Q +SԈ2opI9 CK"<)A +х"!@` X! bl!/#Q^@ R"4` ] c;Cr1a Rt^y|-X@|Oxp ~y޻  #geh8PW0 uAҏC) C@xq@c`6! hB +J@RÜ`Zb(5lzC*/G;!e#c(DA +A +bXamd)dXBϐQ +OB7xXBQB@D \x  +xh"( +<$p|t+!W?U dl -@S&@A@ZCŀ\]zŏ]g<@gyyמdZ&0" JDa<D !AH3!`D(+arxC8  +-^.b((0vzs!E$@7x b!w8bXCtF1rh +[|h#~]@KF3p: P0"@( uX$ R,$(a !@%@r8;~!>&1hAZw,9`8,l`@ lxpsG0,X疼tycc@ "AP5WBr!:AȀ$Rq`&, bHv̈lp:,BhF,ᎁC*HG;1 DxP7э-΢M)N eps5Z#j,x#J1c [hF.ZQWt) & bQ Qa : BTR 8!@ + `@  d4n LqZ@:!H`y\v]#f;/}$fDK4F"`Cf@N4ɔ~@xA0zADcZ!2r!`!<ࡻAAdj!D~nalAl:F! 3 !Av <\*a !`!Al (@** \ E H` p ,`@H@*1y +,+\! I˺l`.E;KJ?81%8SeeL!`+>@hV- +w6f)SaZ HJF! lf +U$nAa! rpa5 +`PBa' E@H@Wwu@@a|pv` <Zr 48` +@ uyb`w2 THI2 ~`c 0> 1 @eDa": *\KVV @8h3FNa4 >` p"#nӔaF J ai. @a ! r! !oBY9'[@!` `-;C!@a^ + pf@R` +`qX/]βvpT\"Y?/zl1;l}lBG3$^}(_' h& h:p!!!cd'ߠ` >A h:DN t<*JAX8'BAs4ta`pFСa PEa5A `YQG-?,gB:1f,{.`hg @cZsBC/'y#˨ҲT$L$ ZacgC@AEc Zed@fi@ + |8:OɈ7VT@@p Y 1n:A%al! +Na&Ӂk;aR xfA).n #!9Y zR&t 8 A@:I|\D.sP`` +@ N`Cyˌ> +`${q0Ga pi0rl%dan}F}b$|1d5V`”L; @ +80 +x!;فJDj@j3s4-p<9-Z! a| D!ȋWaA5D. +`@E@(  ` 8h9fAs jव; 腠B`E{>~yCbۛg0\cye` )| J#~׹q > PT9ņ{ r'! +4h!Z t!jT!آ`=`~A +?Fhuh'Q~7bAH @ .ΣkiI a m: j n\sI[Oާ + ($8aC :p.X+0 S0t:]FK%$vB-$xL6/D%9R E"\B%%**( +^B^ f Ac5ɀ6lx,Q׿+@8 +; jJp4 oDG-LA<3>3{?g {53 +EF+Y`4& VeRE,tCSKP"h7h +R889y `-}"~9o9 1AQCt7:Vˣyo:$A.IXH&4Xxb9_o`2RG8G6qH(TaaiȅL1םQD ;U8aJ6A`h\#W#ԌMf(B(0xZE%Y,+έBa0%.>o+ goEz~T]VDؕnq +@C d?b](R6E&b)#7SD-:E'S\L"&0. ZLFgA(rh!.Rʑff6b C`L51p0Sjf:2tCiǦ6fE7(4464-:Ym"%@7xVBRd]]xz*jjhrDžVӔL  p pw'L,{l&Z<4:Xau/B`p?7 +? +[jPU!0QŭR^QTsϫEY-A^ bgyG"a05x)4/n +`f +ٷN>FQ؜A~D _L7*L) }ҝA0੬7xĐNi + V[kN{U,S Q9^ꥢcpp QF\'d|ly;x[;H2i*A0e!3F" (g沰5 ГWi= GȖtؐpu$[X vB?#J7  Mx p +P EVBњH<ͬW:yQϼ1ogu,"=a;0!I86ўc31]rnЄ'Fs8ARp0_Yg` iC LlÊ  IL71ʘXmNiM?FN6< ۻ BeD[4K|OmԣܣI)D.̵N̓یriuTRGS"=ec/!1R5''#RBr&W6P݃LT" ɐa Am@K $y4 sANDN 0 շZKJͻ`z#V\:P\ +Q[A){ԓ|30pK/0HK`B~9s _ov@T € 8 ; 㫰ekQy?T 1#LiUp/\U"c[-5EKr`*U= 0cGɎ'SNեqt,q 0n =0cTps lzF`m oj^`/M=)C딏p  +gO4TTxp$N@"?'b$/"\b\)1H1F&Y>XQ d`8X>:+WL pnQ0Y:2j+0f%3&fÆC4l؜=3mE6Z4hJmXf̈+FLXf|k&>1-Z^bʼnUN0UǏ+fсĻ;H`ƞPv䇱}G5Ri#13(M$2!{` (#40BK +jAP/@@) I(  4(IE^~h `aT{&)i4$Mff˒Kb" &a F(2k XzqETdM8J@$!8 $R@Z≢#+ƻ/M"'og- bd`K\]R +j[ŚyBQ[0 LB !(R #8Yd']D |A eI+xV`D*B7 !P3UZŸ*@>y^6G=Zh OP H! ٷ懽D)PyR!\qY(˂2Խ+F@QRшFC2l(Gi@26@܆.WB0x ` ] rqv!arJ-Qa+V ͥ@$L? F86p%TORhN#+IYG0Pl.i6&As\<{ObX ifӮxa=Yڲ:DN}YJY\!hjfˑf6AP1W| M(!Y@Q&3$9)_,\шus4H`fs٣)hҒADccQtI)L.KHdgF62XZbJ, L(+pա}(,uc&[nB׺fTGo0+ g)19AU,/Z D +O: +B %%P=Ag(CՁ TMG2Il2ah$S`~ȌI4_xD'ΐDC@yΪF%*[vOXBŮ(+dR K)= e B <:!h0 diff --git a/library/demos/images/earthris.gif b/library/demos/images/earthris.gif new file mode 100644 index 0000000..194ddb5 --- /dev/null +++ b/library/demos/images/earthris.gif @@ -0,0 +1,24 @@ +GIF87a@ȧI$ImI۶m۶m$ےےmm۶Im$$mIIm$mےm$mI$$mےI$ImI$mmIII$$۶mmI$$$Im$$IIے۶II۶I۶mmm۶mm$$m$mmےm$mmےII$ImIImے$I۶۶$Im$mIIImmmmm$I$III$$m$$$ImmmmmmmIے$mImm$$$I$$$$I$$m$II$mm$m$m$I$I$II$I$IIIIIIm$ImIIImm$mmImmmIm۶ImIےmmےIm۶m۶mےے۶$III$$I,@@H*\ȰÇ#JHŋ3jȱǏ CIɓ(S\ɲ˗0cʜI͛8sɳϟ@ +JѣH*]ʴ&H@WJׯ1P`PLt \A";_*KxSlWG޸VEj7 &t8ܣ o8` /;'YŸs A@\pPE2;,Nd2N6 4.K2,{TJI%0Pm~[Z9 a`RpR@h&nۀZh H (b2LCf6ڢd,14iP) + Àj}l}1lc6.\#Ĭ8}5,C2 <*x G:yu"PԺd-t Mcvbe7`N٠D[U$ڀ'7G.Wngwq_dM(PAX]Wa%;Wuy P*\fYg A +)Dy5AdduV}amr{-\M@!iFDc5j]/[m۾ 8 P(p!H1GY̠7z GF q*`R @.61(&@°*f.MzB7.iCvayYO@.Vإ&F!(B^* B$t F903:X5?hګ 0? +)!`b2U8prKFtY +z šmeZt jP*(z_%He 3C/f,GaC4 дR&5 Hִ~TfMl\@fv H;ٺy5TIКɫvjn 0ղe,`L 8PpEYaC ~h8Ё2 +p`QHiNBi_.K "D~P~%AN6P>t1Fi?˘&)nbj@g .fCAPU I5O'M6" Zs?#4#@1F0XNF&"٢MKl:u%IVm@8!>vQDٗuM@>d-*ͭnw pKMr:ЍtK0X +w''yƻL֭NR83u& ,$.ci'PH@8n:L{>xQ 0 Ypx(f(*O )Bp] ћ B0\08qQ(aRBdB)@:49VBgLx D&S {a]:ЂX џhҁѨ"w 9Rc X@=Œxu-z:o `4qbQָεw^MbN}P^A +:^&Y)%d0M DXrHt @}C,<4#Rn$8}!hb[FׂR?,RDJ cU1H EaBQLJe~t7Gn0$ϬTɓ(@s$ͪIv3"eDi]5OK g5F[x>TG U@O2A7 +B5A~> # z\0=h75+Kg\Pt.FH]YObd0 zg$JYTy: fЍS߶{07)PסXKQP4Qj0 c.8FPQ>Vlz˴y4eSՏlۊ?&֦b+jz~OrR>sdYP-iR7QG+wwA-u<Su2ofR`Sb1"TBC20(a|-.,K,(({(4C|@#@X3<3} C-'*XM.cP)'V*`}zȒ$G%ݢD7Gyj(6@y p#b#GZbS%8e7I +X!'{b/qn2S0ESF)1"51XUrKEFP8@1"!2 $Xr6W#CZ")WNs)6C#") M3".YEp5VV޴rv67$Fn-}%,Gm\%vVdY>MGF %Q"X.r6Yh`J(}&&_(K'5EVE0p25%p1oD#82 G *3MU5W%0"/91%M9S1VXU"#W)%"#M$2$1% X$XVMWD4(2u) SM#1y;NQ)FbZ;`;p54|ٗ~9Yy٘9Yyٙ9Yy'P)P p ] ;1^30#;uADEUb:@;@w1daE`ĩ^ +6Sp _`)b1`6cvePgi`f=46牞Tec1`e;S;}<9:aiO(fQ ds<B}aC<9A0-A6jI@EksNsdIII-D PR` 1c!0avH@h!d?00pkUc>>a~V>p>p1ߕq!Z gcy:֙3OpewA[a $}f?L@B;D[F{HJL۴I2XyPPT׳2FG +P 2[`"8v2 sU; rP ,`Vf%|Ixsp$,z㇡s..92$#CL2)15be)]FЇJ(qP09p{Wc,\4 +11U=Hw6Ifu#Hpk-Dy2bDh-HDzs)[GF)"`1U"B#4Y2}tt++t+HgyOI5h Խy臮8@ES]u!B)f$XrwdyNr+*g *;sX+qr$$x$Tb7r(]Sxr%PW%9EuC'5'LL`l1%M(*3%pQ+pr$GR*\%t;&Â,PNHM2JA(6t4j&TpȟDEG.GJ+8AeKAJBE 0rv'&YK+2ׄu N@Hrn41,QB.. ?8,%C2G*HrIHr,HrO7~cLpeOE' WQ4X'['{5H('X''w{e\#YC|(c+p@IM6„ī4PHC4%.+QԦs"I[+J\,I$RPtx<,Mz$ q&@S|-+,R(}r{/'J 1D:dVRkc})6 dClei}*B,$6^No͆j3IrGCg͗$m+eOr[Ǫ'%fxUJ,7-mtSB |88~-b É/"P0|)800LqtL0.0Kh9)(L(5@\G,so$TZnG=*fF~x 4ާ}%$qtR&xXYn5[R6vsPV Pp +0 +uB/G 0(}$u3Iog!$KCB#Y)!TK)(T2ǝNCweHnG*<R$3WOE E8BFFu츼M}Q5$wP @}x|zDJ',W/h'J=45PP$N$ 2|D24 ((4hW:4)AّgÓׂuN}lTR9%-ESmGL1Љ;12m" L8lnhCX)+^M#MkE"!Dcy%6*c`MhW#k6+gF`WN}+L 3AZ5N +`cYq%A7MId"իϏrEWUeGՆ!!F0o[˄7F`$c3&¯(/1է#rke0qTSr0+|ͤ"ʤyR)VS{02Y) +"Ve@TU=T2øu +++AFȮdOH=HD"cԪAkUg=Su׵,)Ԟ;`Է, }J йN> +"*ZX̯IF*(b>2 98sub9> >@ ;S9Yߖњ9X?Cʷ CzS䧹,Y^TgwIKF'~J!rӳ⛂`:Dg% #h9Y$U c ZHqC`9!znay0s@8˪BϢE!E@ V`DlRS+&)!̨)(:k b- #AdpG<K4@d-d!A#a9PVҼ%8\"0qٽqZ=B_8-w8}VL"`1Ej mŤ|3rrqJ',6M7<.*WP˗Ъ=ܼ_"<8̱nSh',Q@uct3<qWϼ9/GQۜ~9N~%DPMX53J4urB4XI =$W8@zx + fv'&# I9_,V_$YLu*V.9Ou-W,}%_I\B!826-9cd*gmGD#2DdD$%)IPf6 F < diff --git a/library/demos/images/teapot.ppm b/library/demos/images/teapot.ppm new file mode 100644 index 0000000..5a7a48c --- /dev/null +++ b/library/demos/images/teapot.ppm @@ -0,0 +1,30 @@ +P6 +256 256 +255 +\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ +j5 +h4 +g3 +5$D,K/b; h>"wM1tK.e="a<#cA,U8&E-<(9&.!a0 b1 c1     + ++3#@)46G<:HMCIXHK\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\U*vT~X{Yk+W&N$|> u: p8 k5 +f3 +a0 _/ ]. [- I\*_(LkRMmSMmSMnSMnSMD,R3W5mA"|O0|P1j?"c!a: X/K%&4$+2F=;HPEJL&\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\lRxTsTd)O$w; m6 +g3 +a0 Z- \/ T*Q(Hm8kRMmSMnTMoTMpTMpUM15G15G05G04G04GpUMpTM5^9 d!Y0W+]. s=M$dPlR\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\oTMoRdPvE"V+K%A 99F['qUMtVM99H:9H:9H:9H:9H:9H:9H:9H:9H:9H99H99H99H99H99H99H:9H;:H>;HB=HPDJ\JKmSMwXN|ZNy[ᦆ֘u{WyU]btUnRhQaO{ZNvWNtVMvXNwXNyYNzYN{ZN|ZN}[N}[N~[N~[N~[N~[N~[N~[N~[N}[N}[N{ZNzYNxXNL$f3 +I$L&P(U*\. J#\OjQ\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\kRaOo9 L&C!:4f3 +X&pUMuWMwXNxXN<:H<:H<:H<:H<;H<;H<;H<;H=;H=;H=;H=;H>;H>;H?HG@ILBIREJ[JKcNLjQLpRuTzU~VȁW˂X֎csҎe{VvTpSkRgQbP_O^O]O\O\O\O\O]O]O]O]O]O]O]O]O]O]O]O\O\O~\N}[N|ZNxXNT%H$G#K%Q(W+zG#nTMiQ\\\\\\\\\\\\dOLrUMuWNwXNyYN{ZN}[N{ZNwXNsVM \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\`OcPnA"M&@ 8F#m6 +W&rVMvWNyYNzYN|ZN}[N}[N>HE?IG@IIAIKBIODJSFJWHKhQlRpRb(i*n+|7|6r,q+p-l+g)b(sSpSlRiQgQePcPaPaO`O`O_O_O_O_O_O_O_O_O_O_O^O^O^O^O]O]O\O~[N{ZNT%F#B!Y,L&U*~I#^O`O\\\\cNLrUMzYN\O^O`ObPcPdPePfPfPfQfQfQePcPaP~[N\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\fPsVM^/ C!7 Q%tVMwXNzYN|ZN}[N\N\O\O]O]O]O]OA=HB=HB=HB>HC>HC>ID?IE?IF@IG@IIAIKBIcPdPePgQiQlRnR\'d)i*m+s/s/o+n+l*i*g)c(_(qSoRmRkQiQgQfPePdPcPbPbPbPaPaPaOaOaO`O`O`O`O`O`O_O_O^O^O]O\O}[NQD"?D"K%_/ kRLfPODJSFJ_ObPcPePfQgQiQjQkRlRmRnRnRoRoRoRnRmRlRiQeP_O\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\B+ePI#L&90y< PxXN{ZN}[N\N\O]O]O^O^O^O_O_O_O_O`O`O`O`OaOaPbPbPcPdPePfPgQhQiQkRmRZ'_(e)h)k*n,n,m*l*j*f)e)c(_(]'pRnRmRkRjQiQgQgQfPePdPdPdPcPcPcPbPbPbPbPbPaPaPaOaO`O`O_O_O^O]O_(@ B!I$B!N'w=eP`LKbNLeOLkRmRnRoRpSqSrSsStStStSuSuStStSsSrSpSmRjQbPjQL\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\bPpTME"5M$tVM{ZN}[N\O]O^O^O_O_O_O`O`O`O`OaOaPaPbPbPbPcPcPdPdPePfPgQhQiQjQkRlRmRZ'`(d)g)gj*j*i*i*g)d)c(a(_(\'pRoRnRmRkRjQiQiQhQgQgQfPePePePdPdPdPcPcPcPcPcPbPbPbPbPaPaO`O_O^O\NQ@ <G#_LKcPlSMnTMpUMsVMtSuTvTwTwTxTxTwTwTvTuTtSsSqSpSoRnRkRhQbPeOL\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\wXN\NJ%01JvWN}[N\O]O^O_O_O`O`O`OaOaPaPbPbPbPbPcPcPdPdPdPePePfQgQgQhQiQjQkQlRmRY&]'`(c(e)c\\\]]^a(`(^'['['oRnRmRlRkRkQjQiQiQhQgQgQgQfQfPePePePePdPdPdPdPdPcPcPcPbPbPaPaO`O]OOG#7F#uWM^OwXNxXNzYN{ZN|ZNyTyTxTwTuTsSpSmRjQgQdPbPaPaPbPcPePcP|ZN\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\[JKbP^/ 1 01|> wXN}[N]O^O_O`O`OaOaPaPbPbPbPcPcPcPcPdPdPdPePePfPfQgQgQhQhQiQjQkQkRlRmRY&]'`(b([gihfdecU_(]'['Z'nRnRmRmRlRkRkQjQjQiQiQhQhQgQgQgQfQfQfPfPePePe + +  +@%<-$G?@pfdNLuWM\NdNL\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\TFJvWNaP./01E}[N]O_O`OaPbPbPcPcPcPdPdPdPePePePePfPfQfQgQgQgQhQhQhQiQiQjQjQkQkRlRlRY&\'^'^bcei gcba`^]X['Z'Y&mRmRmRlRlRlRkRkQkQjQjQjQiQiQiQiQhQhQhQhQgQgQgQgQgQfQfQfQfPePePdPcPaPO`O`OoTMQEJC>IeZY638*  B\\\\\,  4 .G1!\TUrsVM{ZN`MK\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\[JKyYNbP/0N$]O_O`ObPbPcPcPdPdPdPePePePfPfPfQfQgQgQgQgQhQhQhQiQiQiQjQjQkQkRkRlROZ'\'^'Vabei!fba`_]\Z['Z'Y&QmRmRmRlRlRlRkRkRkQkQjQjQjQjQiQiQiQiQiQhQhQhQhQhQhQgQgQgQgQfQfPdPcPW&dPaPrUM + B\\\\\\\\\\%7!!C*F#P) {dYzep\OgPL\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\SFJ`LKvWNaPm6 + X,uWM]O`ObPcPdPdPdPePePfPfPfQfQgQgQgQgQgQhQhQhQiQiQiQiQjQjQjQkQkQkRlRlRZ'\']'_`abei"ea`__]\\YZ'Z'Z'mRmRmRlRlRlRlRlRkRkRkRkQkQjQjQjQjQjQjQiQiQiQiQiQiQiQhQhQhQgQgQfQdP_Oq8 gQ`OuWMT%\\\\\\\\\\ B B!!T,c5FT3ț~Ɠq^OfOL\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\XHK_LKsVM`OcP S%]ObPcPdPePePfPfQfQgQgQgQgQgQhQhQhQhQiQiQiQiQiQjQjQjQjQkQkRkRlRlRlR\']'^'V`abfi"ea`__]\\RZ'Z'['mRmRmRmRmRlRlRlRlRlRlRkRkRkRkRkQkQjQjQjQjQjQjQjQjQjQjQiQiQiQhQgQePSq8 aOgQ`OtVMX&\\\\\\\\\\ B B B l@!{AL$Y'afPaO]KK\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ODJ[JKaMKqUM\OcP^OvE"]OaPdPePfPfQgQgQgQhQhQhQhQhQiQiQiQiQiQjQjQjQjQjQkQkQkRkRkRlRlRlRlR^'^'_(Waacg i"ea`__^\\R['[']'mRmRmRmRmRmRmRlRlRlRlRlRlRlRlRlRlRkRkRkRkRkRkRkRkRkQkQkQjQjQiQhQePW&M&oTMiQeP_OtVMmSMdOL\\\\\\\\\ B B B JZ'_(kQiQ`OSFJ\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\TFJ\JKcNLlRMzYN`OePzZN \N`OdPfQgQgQhQhQhQiQiQiQiQiQiQjQjQjQjQjQjQkQkQkRkRkRlRlRlRlRlRlRmRa(`(`([abdh!i"da`__^]]S\']'_(nRmRmRmRmRmRmRmRmRmRmRmRmRmRmRmRlRlRlRlRlRlRlRlRlRlRlRlRlRkRkQiQePt: kQhQcP]OtVMlSMa2 \\\\\\\\\ B B +$5 `(e)nRjQ^OJAI\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\XIK^KKdNLhPLuWM]ObPfQeP m6 +`OcPfQhQhQiQiQjQjQjQjQjQjQjQkQkQkQkRkRkRkRlRlRlRlRlRlRlRmRmRmRmRg)c(c(b(Vcei!i!db``__^Q]'_(`(f)nRnRnRnRnRnRnRnRnRnRnRnRnRmRmRmRmRmRmRmRmRmRnRmRmRnRmRmRmRmRkRhQGa0 bPmRjQfQaP}[NrUMmSML$\\\\\\\\ B B #C, 8&H.Z7 pRjQ{ZN\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\QEJ[JK`LKdNLhQLqUM{ZN_OcPgQhQ +bPePhQiQjQjQkQkQkRkRkRlRlRlRlRlRlRlRlRlRlRmRmRmRmRmRmRmRmRmRnRnRj*g)e)d)dXghecbbbU`(a(a(c(i*oRoRnRnRnRnRnRnRnRnRnRnRnRnRnRnRnRoRoRoRoRoRoRoRoRoRoRoRoRnRmRjQQ%Z- jQnRlRhQdP_OuWMpTMnSMkRLa: \\\\\\\ B B&D2 @*S6#G@IPDJhQmSM\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\VGJ]KKbMLeOLiQLlRMvWN\OaOePhQjQgQoTMgQiQkQlRlRlRmRmRmRmRmRmRmRmRmRmRmRmRmRmRnRnRnRnRnRnRnRnRnRnRnRnRl*l+j+g)f)e)d)e)e)e)e)f)i*s0s.oRoRoRoRoRoRoRoRoRoRoRoRoRoRoRoRpRpRpRpRpRpSpSpSqSqSqSqSpSqSpSnRlRIhQpRoRmRiQePaP\OsVMpTMnTMlRMX)\\\\\\\ B%C)D$;J/[8"LBITGJYIKWHK\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\NCJYIK_LKcNLgPLjQLlRMpUMzYN^ObPePhQkQlRfQ- hQjQlRmRnRnRnRnRnRnRnRnRnRnRoRoRoRoRoRoRoRoRoRoRoRoRoRoRoRoRoRoRpRpRpRpy-w-w-y.{-upSpSpSpSpSpSpSpSpSpSpSpSpSpSpSqSqSqSqSqSqSqSqSqSrSrSrSrSrSrSrSsSrSqSoRiQiQqSqSpRmRjQgQcP_O{ZNtVMpUMoTMmSMjQL_9 \\\\\ B "C(D#*A$[<)dI\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\SFJ[JKaMKeOLhPLkRLmSMoTMuWM}[N_ObPePhQkRmRnRkR!-EkRmRnRoRpRpRpSpSpSpSpSpSpSpRpSpSpSpSpSpSpSpSpSpSpSpSpSpSpSpSpSpSqSqSqSqSqSqSqSqSqSqSqSqSqSqSqSqSqSqSrSrSrSrSrSrSrSrSrSrSsSsSsSsStStStStStSuStSsSrSnRoRsSsSrSpRmRjQgQdPaO\OyYNuWMqUMoTMnSMkRLo8 \\\\\ B'D+E$(1 J/jH1NCJUGJYIKUGJ\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\XHK]KKbNLfOLiQLkRMmSMoTMqUMxXN\N_ObPfPhQkQmRoRpSpRhQmRoRpSqSrSrSrSrSrSrSrSrSrSrSrSrSrSrSrSrSrSrSrSrSrSrSrSrSrSrSrSrSrSrSrSrSrSrSrSrSrSsSsSsSsSsSsSsSsSsSsSsSsStStStSuSuSuTuTuTuTuTvTwTvTvTuTtSmRtSuTuStSrSpRmRkQhQePaP^O\N{ZNvXNqUMpTMnSMlRMP%\\\\ B#C*E$.E- .!G$Y:%d<"SFJYIKZIKNCJ\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\PDJZIK_LKdNLgPLjQLlRMnSMpTMqUMuWMyYN\O`OcPfPhQjQmRoRqSrSrSrSmRrSsStStStStStStStStStStStStStStStSsSsSsSsSsSsSsSsSsStStStStStStStStStStStStStStStStSuS +!C+E'0F.4F7%8%U/lG.SFJZIK]KKZIKB=H\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\REJZJK`LKdNLgPLjQLlRMnSMpTMqUMtWMxXN{ZN~[N]O^O`OaObPdPgQiQkQlRnRpSrSsStTuTvTwTxTyTyTyTyTyTxTvTrSnRhQ|U|U|U|U|U|U|U|U|U|U|U|U|U|U}U}U}U}U}U}U}U~U~U~V~VVŀWƁXa(lRrSvTyTzU|U~VXƂ[Ɇ_΋dӑjԓmԓnБlʌhĆd_{[vWsUpSnRkRiQhQgQfQePdPbPaO_O^O\O|ZNxXNsVMpTMnTMmSMjQLC B)D&/F-3F47G6%>" Y7 kA$YIK]KK^KKSFJ\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\VGJ\KKbMLeOLhPLkRLmSMnTMpTMrUMuWNyYN|ZN\N]O_O`OaPbPcPePfPhQjQlRnRoSqTsTuUvUwVxVyVyUzUzU{U{U{U|U|U|U|U|U{U{U{UzUzTyTyTxTwTvTvTvTvTwTwTwTxTyTzTzU{U{U|U|U}UVŀWǂYɄ\͈_ьdٔlu|쩂ſt명榁ޟ{՗sˎl†d^yZuWqUoSlRkRjQiQhQgQfQePdPcPaP`O^O]O}[NyYNuWMpTMoTMmSMkRLgPL&D#.E,3F46G;'<(D"iB(VGJ]KK`LK[JKB>H\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\NCJYIK^LKcNLfOLiQLkRMmSMoTMqUMsVMvXNzYN}[N\O^O_O`OaPcPdPePfQgQhQiQkRmSoTrUtWwYzZ}\]^^^‚^\ZYX~W~W~V~V~V~V~U~U~U~UUUVVVVVƀVƀVǀWǁWȂXɃZ˅[͇^ЊaӍdؒiܗntz驅~֘vˏmÇf`z[vXrUpToSnSlRkRkRjQiQhQfQePdPcPbP`O_O]O~[NzYNvWNpTMoTMnSMkRMhQLo7 ,2F36G99HC+@ ]8 nA"\JK`ML_LKSFJ\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\SFJ[JK`LKdNLgPLjQLlRMnSMpTMqUMtVMwXNzZN}[N]O^O_OaObPcPdPePfQgQhQiQjRlRmSoUrWvZ{]afŊjˏnГqӕsՖsՖrՖqՔoӒmяjύg͊cˈaɆ^Ȅ\ǂ[ƁYŀXŀWWWVVWŀWƀWǁXȂYɃ[ʅ\͇_ϊaҍeՑhٕmݙqvz}꧀멃몄騃奀ߠ|ٛwӕȑmƉhc~^yZvXtWsVqUpToSnSmRlRkRjQiQhQgQfPePcPbPaO_O^O\N{ZNwXNsVMoTMnSMlRMiQL~I#26G99G?!]KKfQOgQN_LKD>I\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\iQtSyT{UYΌeרּ՗u|\Z'LD |> ePoRqSoRmRjQeP^OhPL\\\\\\\\\\\\\\\\\\\\\\\\\\\\\WHJ\KKaMLeOLhPLjQLlRMnSMpTMqUMtVMwXNzZN}[N]O^O_O`ObPcPdPePfQgQhQiQjRkRmSnTqVsXw[{_chČn˒tҙz؟ޥ㩉筍ꯎꯎꮍ竊䧆ߣ۞|՘vГpˎkljfÅb_\}Y{XzWyVxUxUxTxTxTxUxUxUxUyVyVzWzX{Y|Y|Z}[}[}\}\}\}\|\{[zZyZwYvXtWsVrUpToSnSmRlRkRjQiQhQgQfQePdPcPbP`O_O^O\N{ZNwXNsVMoTMnSMlRMiQLfOLJ(V.]KKePNkUQcNLQEJ\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\]OmRqSrStSvTwTxU{WĆbғqךxʏo +KrSvTwTvTuTsSqSnRkQgQ`OuWNY,\\\\\\\\\\\\\\\\\\\\\\\\\\NCJYIK^KKbNLfOLhQLkRLmSMoTMpUMrUMuWMxXN{ZN~[N]O^O_OaObPcPdPePfQgQhQiQjRkRmSoTqVtXw[|_diČn˓tҙz؟ޥ㩉笌鮎ꮎ魌檉㧅ߢڝ{՗uϒpˍjƈf…b^\|Y{XzVyVxUxUxTxTxTxUxUxUxUyVyVyWzW{X{Y|Z|Z|[}[}\}\|\|[{[zZxYwXvXtWsVrUpToSnSmRlRkRjQjQiQhQgQfPdPcPbPaO_O^O\O|ZNxXNtVMoTMnSMlRMjQLgPLzG#\JKcOMoXUgPMZIK\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\fPgQgQhQiQkQlRnRpRqSsStS:"r<zYNsSyT|U~WƄ^ˊeˋgƈeaz[tVpSmRkQgQbPzYNkRL\\\\\\\\\\\\\\\\\\\\\\\\\RFJZJK`LKcNLfPLiQLkRMmSMoTMqUMrVMvWNyYN|ZN\N]O^O`OaObPcPdPePfQgQhQiQjRlRmSoUqVtYx\|`diōo˓uҙ{ٟޥ㩉笌鮍鮍謋婈⦄ޡٜzԗtϑoʌjƈe„a^~[|Y{XzVyVxUxUxTxTxTxTxUxUxUxVyVyWzWzX{Y{Y|Z|Z|[|[|[|[{[z[yZxYwXvWtWsVrUpToSnSmRlRkRkRjQiQhQgQfPePdPbPaP`O^O]O}[NyYNuWNqUMnSMlSMkRLhPLcNLbNLpYVlUP`LK>;H\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\jQ`O{ZN^'^'`(e)h)k*o+b(nRyT~UǁXҍdw詅ݟ}Ԙvȍme}_x[y\x[tWqTmRjQgQbP}[NlRM\\\\\\\\\\\\\\\\\\\\\\\\VGJ\JKaMKdNLgPLjQLlRMnSMpTMqUMsVMvXNzYN|[N\O]O_O`OaPbPcPdPePfQgQhQiQjRlSmSoUrWuYx\|`djōo̓uҚ{٠ޥ㩉欋譍譌竊婇᥃ݠ~؛yӖtΑoʌjňe„a^~[|Y{WzVyVxUxUxTxTxTxTxUxUxUxUxVyVyWzXzX{Y{Z{Z|Z|[|[{[{[zZyZxYwXuWtVsVrUpToSnSmRlRkRkRjQiQhQgQfQePdPcPaP`O^O]O~[NzYNvWNrUMnSMmSMkRLiQLeOLoXUu]XdOLKBI\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\:9H\NhQ}\uUsTtTtSqSnRnRnRlRjQiQhQhQgQfQePePhQkRmSpUtXuYsWqUmSjQgQBS%jQL\\\\\\\\\\\\\\\\\\\\\\LBIXHK^KKbMLeOLhPLjRLlSMnSMpTMqUMtVMwXNzYN}[N\O^O_O`OaPbPcPePfPfQgQhQiRkRlSnTpUrWuYy]}`ejŎp̔vӚ{٠ޤ⨉櫋笌笋櫊䨆ंܟ~ךxҕsΐnɌiŇea^~[|Y{WyVyVxUxUxTwTwTwTxTxUxUxUxVyVyWzWzXzY{Y{Z{Z{Z{Z{ZzZyZyYxYvXuWtVsUrUpToSnSmRlRlRkRjQiQhQgQfQePdPcPaP`O_O]O\N{ZNwXNsVMnSMmSMkRMiQLfOL_LKhQMUGJ\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ (6BFP>=DKHMqjktrwf`~kcndqesete{w`v[\N_OcPfPiQjRlSoTqVqVoTlRiQ^`OQ%hPL\\\\\\\\\\\\\\\\\\\\\QEJZIK_LKcNLfOLiQLkRLmSMoTMpUMrUMuWMxXN{ZN~[N]O^O_O`OaPcPdPePfPgQhQiQjRkRlSnTpUrWuZy]}aekƎp̔vӚ{ٟޤ⨈媊櫋櫊婈⦅ߣ۞}֚xѕr͐mȋićda]~[|YzWyVyUxUxUwTwTwTwTwTxUxUxUxUxVyVyWzXzXzYzY{Y{Z{ZzZzZyYxYwXvXuWtVsUrUpToSnSmSmRlRkRjQiQhQgQfQePdPcPbP`O_O]O\O|ZNxXNtVMoTMmSMlRMjQLgPLbML[JK\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\%5 (6$/79CEEKjgkrc_{uf{w_q]O`OcPfQhQjRlRnToTnTkRhQdP]'Q%\\\\\\\\\\\\\\\\\\\\\UGJ[JK`MKdNLgPLiQLkRMmSMoTMqUMrUMuWNxXN{ZN~[N]O + &3#.$-% .% .& /&!,#,#@70A71XNHXNHWNHWNHZRLYQLYQLXQLWQLWPLUOLSNLQMKOLJMJJ0//.-.,,-&(+"(!' 15;6CT37=MMMKMP^ad_enY`hNZlNZlU\dV\eDQbDQbDQbDQbDQbMUcyl|oiKoኯኯኯኯኯኯዯዯዯዯዯዯዯዯዯKoKoKoKoKoKoKoKpKpKpKpKpKpKpKpKpKpKpKpKpKpKpKp⋯⋯⋯LpLpLpLpLpLpLpLpLpLpLpLpLpLpLpLpLpLpLpLpLpڄڄڄڄڄۄۄۄۄۄۄۄۄۄۅۅۅۅۅۅGkGkGkGkGkGkGkGkGkۅ܅܅܅܅܅܅܅܅܅܅܅܆܆܆܆܆HlHlHlHlHlHlHlHlHlHlHlHlHl'K}'K}'K}'K}'K}'K}'K}'K}'K}HO\=J[=J[=J[ -> ,> ,>(.7#)2#)2(.7(.7(.7#)2(.7(.7(/7(/7)/8/28114H7,99@.05&,5$&)$$$######"""(((8888888888888884"nO9gXjZE/ (-" diff --git a/library/demos/items.tcl b/library/demos/items.tcl new file mode 100644 index 0000000..83e6033 --- /dev/null +++ b/library/demos/items.tcl @@ -0,0 +1,285 @@ +# items.tcl -- +# +# This demonstration script creates a canvas that displays the +# canvas item types. +# +# SCCS: @(#) items.tcl 1.16 97/03/02 16:25:05 + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +set w .items +catch {destroy $w} +toplevel $w +wm title $w "Canvas Item Demonstration" +wm iconname $w "Items" +positionWindow $w +set c $w.frame.c + +label $w.msg -font $font -wraplength 5i -justify left -text "This window contains a canvas widget with examples of the various kinds of items supported by canvases. The following operations are supported:\n Button-1 drag:\tmoves item under pointer.\n Button-2 drag:\trepositions view.\n Button-3 drag:\tstrokes out area.\n Ctrl+f:\t\tprints items under area." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +frame $w.frame +pack $w.frame -side top -fill both -expand yes + +canvas $c -scrollregion {0c 0c 30c 24c} -width 15c -height 10c \ + -relief sunken -borderwidth 2 \ + -xscrollcommand "$w.frame.hscroll set" \ + -yscrollcommand "$w.frame.vscroll set" +scrollbar $w.frame.vscroll -command "$c yview" +scrollbar $w.frame.hscroll -orient horiz -command "$c xview" + +grid $c -in $w.frame \ + -row 0 -column 0 -rowspan 1 -columnspan 1 -sticky news +grid $w.frame.vscroll \ + -row 0 -column 1 -rowspan 1 -columnspan 1 -sticky news +grid $w.frame.hscroll \ + -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news +grid rowconfig $w.frame 0 -weight 1 -minsize 0 +grid columnconfig $w.frame 0 -weight 1 -minsize 0 + +# Display a 3x3 rectangular grid. + +$c create rect 0c 0c 30c 24c -width 2 +$c create line 0c 8c 30c 8c -width 2 +$c create line 0c 16c 30c 16c -width 2 +$c create line 10c 0c 10c 24c -width 2 +$c create line 20c 0c 20c 24c -width 2 + +set font1 {Helvetica 12} +set font2 {Helvetica 24 bold} +if {[winfo depth $c] > 1} { + set blue DeepSkyBlue3 + set red red + set bisque bisque3 + set green SeaGreen3 +} else { + set blue black + set red black + set bisque black + set green black +} + +# Set up demos within each of the areas of the grid. + +$c create text 5c .2c -text Lines -anchor n +$c create line 1c 1c 3c 1c 1c 4c 3c 4c -width 2m -fill $blue \ + -cap butt -join miter -tags item +$c create line 4.67c 1c 4.67c 4c -arrow last -tags item +$c create line 6.33c 1c 6.33c 4c -arrow both -tags item +$c create line 5c 6c 9c 6c 9c 1c 8c 1c 8c 4.8c 8.8c 4.8c 8.8c 1.2c \ + 8.2c 1.2c 8.2c 4.6c 8.6c 4.6c 8.6c 1.4c 8.4c 1.4c 8.4c 4.4c \ + -width 3 -fill $red -tags item +$c create line 1c 5c 7c 5c 7c 7c 9c 7c -width .5c \ + -stipple @[file join $tk_library demos images gray25.bmp] \ + -arrow both -arrowshape {15 15 7} -tags item +$c create line 1c 7c 1.75c 5.8c 2.5c 7c 3.25c 5.8c 4c 7c -width .5c \ + -cap round -join round -tags item + +$c create text 15c .2c -text "Curves (smoothed lines)" -anchor n +$c create line 11c 4c 11.5c 1c 13.5c 1c 14c 4c -smooth on \ + -fill $blue -tags item +$c create line 15.5c 1c 19.5c 1.5c 15.5c 4.5c 19.5c 4c -smooth on \ + -arrow both -width 3 -tags item +$c create line 12c 6c 13.5c 4.5c 16.5c 7.5c 18c 6c \ + 16.5c 4.5c 13.5c 7.5c 12c 6c -smooth on -width 3m -cap round \ + -stipple @[file join $tk_library demos images gray25.bmp] \ + -fill $red -tags item + +$c create text 25c .2c -text Polygons -anchor n +$c create polygon 21c 1.0c 22.5c 1.75c 24c 1.0c 23.25c 2.5c \ + 24c 4.0c 22.5c 3.25c 21c 4.0c 21.75c 2.5c -fill $green \ + -outline black -width 4 -tags item +$c create polygon 25c 4c 25c 4c 25c 1c 26c 1c 27c 4c 28c 1c \ + 29c 1c 29c 4c 29c 4c -fill $red -smooth on -tags item +$c create polygon 22c 4.5c 25c 4.5c 25c 6.75c 28c 6.75c \ + 28c 5.25c 24c 5.25c 24c 6.0c 26c 6c 26c 7.5c 22c 7.5c \ + -stipple @[file join $tk_library demos images gray25.bmp] \ + -outline black -tags item + +$c create text 5c 8.2c -text Rectangles -anchor n +$c create rectangle 1c 9.5c 4c 12.5c -outline $red -width 3m -tags item +$c create rectangle 0.5c 13.5c 4.5c 15.5c -fill $green -tags item +$c create rectangle 6c 10c 9c 15c -outline {} \ + -stipple @[file join $tk_library demos images gray25.bmp] \ + -fill $blue -tags item + +$c create text 15c 8.2c -text Ovals -anchor n +$c create oval 11c 9.5c 14c 12.5c -outline $red -width 3m -tags item +$c create oval 10.5c 13.5c 14.5c 15.5c -fill $green -tags item +$c create oval 16c 10c 19c 15c -outline {} \ + -stipple @[file join $tk_library demos images gray25.bmp] \ + -fill $blue -tags item + +$c create text 25c 8.2c -text Text -anchor n +$c create rectangle 22.4c 8.9c 22.6c 9.1c +$c create text 22.5c 9c -anchor n -font $font1 -width 4c \ + -text "A short string of text, word-wrapped, justified left, and anchored north (at the top). The rectangles show the anchor points for each piece of text." -tags item +$c create rectangle 25.4c 10.9c 25.6c 11.1c +$c create text 25.5c 11c -anchor w -font $font1 -fill $blue \ + -text "Several lines,\n each centered\nindividually,\nand all anchored\nat the left edge." \ + -justify center -tags item +$c create rectangle 24.9c 13.9c 25.1c 14.1c +$c create text 25c 14c -font $font2 -anchor c -fill $red -stipple gray50 \ + -text "Stippled characters" -tags item + +$c create text 5c 16.2c -text Arcs -anchor n +$c create arc 0.5c 17c 7c 20c -fill $green -outline black \ + -start 45 -extent 270 -style pieslice -tags item +$c create arc 6.5c 17c 9.5c 20c -width 4m -style arc \ + -outline $blue -start -135 -extent 270 -tags item \ + -outlinestipple @[file join $tk_library demos images gray25.bmp] +$c create arc 0.5c 20c 9.5c 24c -width 4m -style pieslice \ + -fill {} -outline $red -start 225 -extent -90 -tags item +$c create arc 5.5c 20.5c 9.5c 23.5c -width 4m -style chord \ + -fill $blue -outline {} -start 45 -extent 270 -tags item + +$c create text 15c 16.2c -text Bitmaps -anchor n +$c create bitmap 13c 20c -tags item \ + -bitmap @[file join $tk_library demos images face.bmp] +$c create bitmap 17c 18.5c -tags item \ + -bitmap @[file join $tk_library demos images noletter.bmp] +$c create bitmap 17c 21.5c -tags item \ + -bitmap @[file join $tk_library demos images letters.bmp] + +$c create text 25c 16.2c -text Windows -anchor n +button $c.button -text "Press Me" -command "butPress $c $red" +$c create window 21c 18c -window $c.button -anchor nw -tags item +entry $c.entry -width 20 -relief sunken +$c.entry insert end "Edit this text" +$c create window 21c 21c -window $c.entry -anchor nw -tags item +scale $c.scale -from 0 -to 100 -length 6c -sliderlength .4c \ + -width .5c -tickinterval 0 +$c create window 28.5c 17.5c -window $c.scale -anchor n -tags item +$c create text 21c 17.9c -text Button: -anchor sw +$c create text 21c 20.9c -text Entry: -anchor sw +$c create text 28.5c 17.4c -text Scale: -anchor s + +# Set up event bindings for canvas: + +$c bind item "itemEnter $c" +$c bind item "itemLeave $c" +bind $c <2> "$c scan mark %x %y" +bind $c "$c scan dragto %x %y" +bind $c <3> "itemMark $c %x %y" +bind $c "itemStroke $c %x %y" +bind $c "itemsUnderArea $c" +bind $c <1> "itemStartDrag $c %x %y" +bind $c "itemDrag $c %x %y" + +# Utility procedures for highlighting the item under the pointer: + +proc itemEnter {c} { + global restoreCmd + + if {[winfo depth $c] == 1} { + set restoreCmd {} + return + } + set type [$c type current] + if {$type == "window"} { + set restoreCmd {} + return + } + if {$type == "bitmap"} { + set bg [lindex [$c itemconf current -background] 4] + set restoreCmd [list $c itemconfig current -background $bg] + $c itemconfig current -background SteelBlue2 + return + } + set fill [lindex [$c itemconfig current -fill] 4] + if {(($type == "rectangle") || ($type == "oval") || ($type == "arc")) + && ($fill == "")} { + set outline [lindex [$c itemconfig current -outline] 4] + set restoreCmd "$c itemconfig current -outline $outline" + $c itemconfig current -outline SteelBlue2 + } else { + set restoreCmd "$c itemconfig current -fill $fill" + $c itemconfig current -fill SteelBlue2 + } +} + +proc itemLeave {c} { + global restoreCmd + + eval $restoreCmd +} + +# Utility procedures for stroking out a rectangle and printing what's +# underneath the rectangle's area. + +proc itemMark {c x y} { + global areaX1 areaY1 + set areaX1 [$c canvasx $x] + set areaY1 [$c canvasy $y] + $c delete area +} + +proc itemStroke {c x y} { + global areaX1 areaY1 areaX2 areaY2 + set x [$c canvasx $x] + set y [$c canvasy $y] + if {($areaX1 != $x) && ($areaY1 != $y)} { + $c delete area + $c addtag area withtag [$c create rect $areaX1 $areaY1 $x $y \ + -outline black] + set areaX2 $x + set areaY2 $y + } +} + +proc itemsUnderArea {c} { + global areaX1 areaY1 areaX2 areaY2 + set area [$c find withtag area] + set items "" + foreach i [$c find enclosed $areaX1 $areaY1 $areaX2 $areaY2] { + if {[lsearch [$c gettags $i] item] != -1} { + lappend items $i + } + } + puts stdout "Items enclosed by area: $items" + set items "" + foreach i [$c find overlapping $areaX1 $areaY1 $areaX2 $areaY2] { + if {[lsearch [$c gettags $i] item] != -1} { + lappend items $i + } + } + puts stdout "Items overlapping area: $items" +} + +set areaX1 0 +set areaY1 0 +set areaX2 0 +set areaY2 0 + +# Utility procedures to support dragging of items. + +proc itemStartDrag {c x y} { + global lastX lastY + set lastX [$c canvasx $x] + set lastY [$c canvasy $y] +} + +proc itemDrag {c x y} { + global lastX lastY + set x [$c canvasx $x] + set y [$c canvasy $y] + $c move current [expr $x-$lastX] [expr $y-$lastY] + set lastX $x + set lastY $y +} + +# Procedure that's invoked when the button embedded in the canvas +# is invoked. + +proc butPress {w color} { + set i [$w create text 25c 18.1c -text "Ouch!!" -fill $color -anchor n] + after 500 "$w delete $i" +} diff --git a/library/demos/ixset b/library/demos/ixset new file mode 100644 index 0000000..dcde75d --- /dev/null +++ b/library/demos/ixset @@ -0,0 +1,312 @@ +#!/bin/sh +# the next line restarts using wish \ +exec wish "$0" "$@" + +# ixset -- +# A nice interface to "xset" to change X server settings +# +# History : +# 91/11/23 : pda@masi.ibp.fr, jt@ratp.fr : design +# 92/08/01 : pda@masi.ibp.fr : cleaning +# +# SCCS: @(#) ixset 1.7 96/02/16 10:49:19 + +# +# Button actions +# + +proc quit {} { + destroy . +} + +proc ok {} { + writesettings + quit +} + +proc cancel {} { + readsettings + dispsettings +} + +# apply is just "writesettings" + + +# +# Read current settings +# + +proc readsettings {} { + global kbdrep ; set kbdrep "on" + global kbdcli ; set kbdcli 0 + global bellvol ; set bellvol 100 + global bellpit ; set bellpit 440 + global belldur ; set belldur 100 + global mouseacc ; set mouseacc "3/1" + global mousethr ; set mousethr 4 + global screenbla ; set screenbla "blank" + global screentim ; set screentim 600 + global screencyc ; set screencyc 600 + + set xfd [open "|xset q" r] + while {[gets $xfd line] > -1} { + set kw [lindex $line 0] + + case $kw in { + {auto} + { + set rpt [lindex $line 1] + if {[expr "{$rpt} == {repeat:}"]} then { + set kbdrep [lindex $line 2] + set kbdcli [lindex $line 6] + } + } + {bell} + { + set bellvol [lindex $line 2] + set bellpit [lindex $line 5] + set belldur [lindex $line 8] + } + {acceleration:} + { + set mouseacc [lindex $line 1] + set mousethr [lindex $line 3] + } + {prefer} + { + set bla [lindex $line 2] + set screenbla [expr "{$bla} == {yes} ? {blank} : {noblank}"] + } + {timeout:} + { + set screentim [lindex $line 1] + set screencyc [lindex $line 3] + } + } + } + close $xfd + + # puts stdout [format "Key REPEAT = %s\n" $kbdrep] + # puts stdout [format "Key CLICK = %s\n" $kbdcli] + # puts stdout [format "Bell VOLUME = %s\n" $bellvol] + # puts stdout [format "Bell PITCH = %s\n" $bellpit] + # puts stdout [format "Bell DURATION = %s\n" $belldur] + # puts stdout [format "Mouse ACCELERATION = %s\n" $mouseacc] + # puts stdout [format "Mouse THRESHOLD = %s\n" $mousethr] + # puts stdout [format "Screen BLANCK = %s\n" $screenbla] + # puts stdout [format "Screen TIMEOUT = %s\n" $screentim] + # puts stdout [format "Screen CYCLE = %s\n" $screencyc] +} + + +# +# Write settings into the X server +# + +proc writesettings {} { + global kbdrep kbdcli bellvol bellpit belldur + global mouseacc mousethr screenbla screentim screencyc + + set bellvol [.bell.vol get] + set bellpit [.bell.val.pit.entry get] + set belldur [.bell.val.dur.entry get] + + if {[expr "{$kbdrep} == {on}"]} then { + set kbdcli [.kbd.val.cli get] + } else { + set kbdcli "off" + } + + set mouseacc [.mouse.hor.acc.entry get] + set mousethr [.mouse.hor.thr.entry get] + + set screentim [.screen.val.le.tim.entry get] + set screencyc [.screen.val.le.cyc.entry get] + + exec xset \ + b $bellvol $bellpit $belldur \ + c $kbdcli \ + r $kbdrep \ + m $mouseacc $mousethr \ + s $screentim $screencyc \ + s $screenbla +} + + +# +# Sends all settings to the window +# + +proc dispsettings {} { + global kbdrep kbdcli bellvol bellpit belldur + global mouseacc mousethr screenbla screentim screencyc + + .bell.vol set $bellvol + .bell.val.pit.entry delete 0 end + .bell.val.pit.entry insert 0 $bellpit + .bell.val.dur.entry delete 0 end + .bell.val.dur.entry insert 0 $belldur + + .kbd.val.onoff [expr "{$kbdrep} == {on} ? {select} : {deselect}"] + .kbd.val.cli set $kbdcli + + .mouse.hor.acc.entry delete 0 end + .mouse.hor.acc.entry insert 0 $mouseacc + .mouse.hor.thr.entry delete 0 end + .mouse.hor.thr.entry insert 0 $mousethr + + .screen.val.rb.blank [expr "{$screenbla}=={blank} ? {select} : {deselect}"] + .screen.val.rb.pat [expr "{$screenbla}!={blank} ? {select} : {deselect}"] + .screen.val.le.tim.entry delete 0 end + .screen.val.le.tim.entry insert 0 $screentim + .screen.val.le.cyc.entry delete 0 end + .screen.val.le.cyc.entry insert 0 $screencyc +} + + +# +# Create all windows, and pack them +# + +proc labelentry {path text length} { + frame $path + label $path.label -text $text + entry $path.entry -width $length -relief sunken + pack $path.label -side left -expand y + pack $path.entry -side right -expand y +} + +proc createwindows {} { + # + # Buttons + # + + frame .buttons + button .buttons.ok -command "ok" -text "Ok" + button .buttons.apply -command "writesettings" -text "Apply" + button .buttons.cancel -command "cancel" -text "Cancel" + button .buttons.quit -command "quit" -text "Quit" + + pack .buttons.ok .buttons.apply .buttons.cancel .buttons.quit \ + -side left -expand yes -pady 5 + + # + # Bell settings + # + + frame .bell -relief raised -borderwidth 2 + label .bell.label -text "Bell Settings" + scale .bell.vol \ + -from 0 -to 100 -length 200 -tickinterval 20 \ + -label "Volume (%)" -orient horizontal + + frame .bell.val + labelentry .bell.val.pit "Pitch (Hz)" 6 + labelentry .bell.val.dur "Duration (ms)" 6 + pack .bell.val.pit -side left -padx 5 + pack .bell.val.dur -side right -padx 5 + pack .bell.label .bell.vol .bell.val -side top -expand yes + + # + # Keyboard settings + # + + frame .kbd -relief raised -borderwidth 2 + + label .kbd.label -text "Keyboard Repeat Settings" + + frame .kbd.val + checkbutton .kbd.val.onoff \ + -text "On" \ + -onvalue "on" -offvalue "off" -variable kbdrep \ + -relief flat + scale .kbd.val.cli \ + -from 0 -to 100 -length 200 -tickinterval 20 \ + -label "Click Volume (%)" -orient horizontal + pack .kbd.val.onoff -side left -expand yes -fill both + pack .kbd.val.cli -side left -expand yes + + pack .kbd.label -side top -expand yes + pack .kbd.val -side top -expand yes -pady 2 -fill x + + # + # Mouse settings + # + + frame .mouse -relief raised -borderwidth 2 + + label .mouse.label -text "Mouse Settings" + frame .mouse.hor + labelentry .mouse.hor.acc "Acceleration" 3 + labelentry .mouse.hor.thr "Threshold (pixels)" 3 + + pack .mouse.hor.acc -side left + pack .mouse.hor.thr -side right + + pack .mouse.label -side top + pack .mouse.hor -side top -expand yes + + # + # Screen Saver settings + # + + frame .screen -relief raised -borderwidth 2 + + label .screen.label -text "Screen-saver Settings" + frame .screen.val + + frame .screen.val.rb + radiobutton .screen.val.rb.blank \ + -variable screenblank -text "Blank" -relief flat \ + -value "blank" -variable screenbla + radiobutton .screen.val.rb.pat \ + -variable screenblank -text "Pattern" -relief flat \ + -value "noblank" -variable screenbla + pack .screen.val.rb.blank .screen.val.rb.pat -side top -pady 2 -anchor w + frame .screen.val.le + labelentry .screen.val.le.tim "Timeout (s)" 5 + labelentry .screen.val.le.cyc "Cycle (s)" 5 + pack .screen.val.le.tim .screen.val.le.cyc -side top -pady 2 -anchor e + + pack .screen.val.rb .screen.val.le -side left + + pack .screen.label -side top + pack .screen.val -side top -expand y + + # + # Main window + # + + pack .buttons -side top -fill both + pack .bell .kbd .mouse .screen -side top -fill both -ipady 5 -expand yes + + # + # Let the user resize our window + # + wm minsize . 10 10 +} + +############################################################################## +# Main program + +# +# Listen what "xset" tells us... +# + +readsettings + +# +# Create all windows +# + +createwindows + +# +# Write xset parameters +# + +dispsettings + +# +# Now, wait for user actions... +# diff --git a/library/demos/label.tcl b/library/demos/label.tcl new file mode 100644 index 0000000..2e0b027 --- /dev/null +++ b/library/demos/label.tcl @@ -0,0 +1,40 @@ +# label.tcl -- +# +# This demonstration script creates a toplevel window containing +# several label widgets. +# +# SCCS: @(#) label.tcl 1.7 97/03/02 16:25:27 + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +set w .label +catch {destroy $w} +toplevel $w +wm title $w "Label Demonstration" +wm iconname $w "label" +positionWindow $w + +label $w.msg -font $font -wraplength 4i -justify left -text "Five labels are displayed below: three textual ones on the left, and a bitmap label and a text label on the right. Labels are pretty boring because you can't do anything with them." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +frame $w.left +frame $w.right +pack $w.left $w.right -side left -expand yes -padx 10 -pady 10 -fill both + +label $w.left.l1 -text "First label" +label $w.left.l2 -text "Second label, raised" -relief raised +label $w.left.l3 -text "Third label, sunken" -relief sunken +pack $w.left.l1 $w.left.l2 $w.left.l3 -side top -expand yes -pady 2 -anchor w + +label $w.right.bitmap -borderwidth 2 -relief sunken \ + -bitmap @[file join $tk_library demos images face.bmp] +label $w.right.caption -text "Tcl/Tk Proprietor" +pack $w.right.bitmap $w.right.caption -side top diff --git a/library/demos/menu.tcl b/library/demos/menu.tcl new file mode 100644 index 0000000..78ec625 --- /dev/null +++ b/library/demos/menu.tcl @@ -0,0 +1,152 @@ +# menu.tcl -- +# +# This demonstration script creates a window with a bunch of menus +# and cascaded menus using menubars. +# +# SCCS: @(#) menu.tcl 1.17 97/06/26 15:45:04 + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +set w .menu +catch {destroy $w} +toplevel $w +wm title $w "Menu Demonstration" +wm iconname $w "menu" +positionWindow $w + +label $w.msg -font $font -wraplength 4i -justify left +if {$tcl_platform(platform) == "macintosh"} { + $w.msg configure -text "This window contains a menubar with cascaded menus. You can invoke entries with an accelerator by typing Command+x, where \"x\" is the character next to the command key symbol. The rightmost menu can be torn off into a palette by dragging outside of its bounds and releasing the mouse." +} else { + $w.msg configure -text "This window contains a menubar with cascaded menus. You can post a menu from the keyboard by typing Alt+x, where \"x\" is the character underlined on the menu. You can then traverse among the menus using the arrow keys. When a menu is posted, you can invoke the current entry by typing space, or you can invoke any entry by typing its underlined character. If a menu entry has an accelerator, you can invoke the entry without posting the menu just by typing the accelerator. The rightmost menu can be torn off into a palette by selecting the first item in the menu." +} +pack $w.msg -side top + +set menustatus " " +frame $w.statusBar +label $w.statusBar.label -textvariable menustatus -relief sunken -bd 1 -font "Helvetica 10" -anchor w +pack $w.statusBar.label -side left -padx 2 -expand yes -fill both +pack $w.statusBar -side bottom -fill x -pady 2 + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +menu $w.menu -tearoff 0 + +set m $w.menu.file +menu $m -tearoff 0 +$w.menu add cascade -label "File" -menu $m -underline 0 +$m add command -label "Open..." -command {error "this is just a demo: no action has been defined for the \"Open...\" entry"} +$m add command -label "New" -command {error "this is just a demo: no action has been defined for the \"New\" entry"} +$m add command -label "Save" -command {error "this is just a demo: no action has been defined for the \"Save\" entry"} +$m add command -label "Save As..." -command {error "this is just a demo: no action has been defined for the \"Save As...\" entry"} +$m add separator +$m add command -label "Print Setup..." -command {error "this is just a demo: no action has been defined for the \"Print Setup...\" entry"} +$m add command -label "Print..." -command {error "this is just a demo: no action has been defined for the \"Print...\" entry"} +$m add separator +$m add command -label "Dismiss Menus Demo" -command "destroy $w" + +set m $w.menu.basic +$w.menu add cascade -label "Basic" -menu $m -underline 0 +menu $m -tearoff 0 +$m add command -label "Long entry that does nothing" +if {$tcl_platform(platform) == "macintosh"} { + set modifier Command +} elseif {$tcl_platform(platform) == "windows"} { + set modifier Control +} else { + set modifier Meta +} +foreach i {A B C D E F} { + $m add command -label "Print letter \"$i\"" -underline 14 \ + -accelerator Meta+$i -command "puts $i" -accelerator $modifier+$i + bind $w <$modifier-[string tolower $i]> "puts $i" +} + +set m $w.menu.cascade +$w.menu add cascade -label "Cascades" -menu $m -underline 0 +menu $m -tearoff 0 +$m add command -label "Print hello" \ + -command {puts stdout "Hello"} -accelerator $modifier+H -underline 6 +bind $w <$modifier-h> {puts stdout "Hello"} +$m add command -label "Print goodbye" -command {\ + puts stdout "Goodbye"} -accelerator $modifier+G -underline 6 +bind $w <$modifier-g> {puts stdout "Goodbye"} +$m add cascade -label "Check buttons" \ + -menu $w.menu.cascade.check -underline 0 +$m add cascade -label "Radio buttons" \ + -menu $w.menu.cascade.radio -underline 0 + +set m $w.menu.cascade.check +menu $m -tearoff 0 +$m add check -label "Oil checked" -variable oil +$m add check -label "Transmission checked" -variable trans +$m add check -label "Brakes checked" -variable brakes +$m add check -label "Lights checked" -variable lights +$m add separator +$m add command -label "Show current values" \ + -command "showVars $w.menu.cascade.dialog oil trans brakes lights" +$m invoke 1 +$m invoke 3 + +set m $w.menu.cascade.radio +menu $m -tearoff 0 +$m add radio -label "10 point" -variable pointSize -value 10 +$m add radio -label "14 point" -variable pointSize -value 14 +$m add radio -label "18 point" -variable pointSize -value 18 +$m add radio -label "24 point" -variable pointSize -value 24 +$m add radio -label "32 point" -variable pointSize -value 32 +$m add sep +$m add radio -label "Roman" -variable style -value roman +$m add radio -label "Bold" -variable style -value bold +$m add radio -label "Italic" -variable style -value italic +$m add sep +$m add command -label "Show current values" \ + -command "showVars $w.menu.cascade.dialog pointSize style" +$m invoke 1 +$m invoke 7 + +set m $w.menu.icon +$w.menu add cascade -label "Icons" -menu $m -underline 0 +menu $m -tearoff 0 +$m add command \ + -bitmap @[file join $tk_library demos images pattern.bmp] \ + -hidemargin 1 \ + -command { + tk_dialog .pattern {Bitmap Menu Entry} {The menu entry you invoked displays a bitmap rather than a text string. Other than this, it is just like any other menu entry.} {} 0 OK +} +foreach i {info questhead error} { + $m add command -bitmap $i -command "puts {You invoked the $i bitmap}" -hidemargin 1 +} +$m entryconfigure 2 -columnbreak 1 + +set m $w.menu.more +$w.menu add cascade -label "More" -menu $m -underline 0 +menu $m -tearoff 0 +foreach i {{An entry} {Another entry} {Does nothing} {Does almost nothing} {Make life meaningful}} { + $m add command -label $i -command [list puts "You invoked \"$i\""] +} + +set m $w.menu.colors +$w.menu add cascade -label "Colors" -menu $m -underline 1 +menu $m +foreach i {red orange yellow green blue} { + $m add command -label $i -background $i \ + -command [list puts "You invoked \"$i\""] +} + +$w configure -menu $w.menu + +bind Menu <> { + global $menustatus + if {[catch {%W entrycget active -label} label]} { + set label " " + } + set menustatus $label + update idletasks +} diff --git a/library/demos/menubu.tcl b/library/demos/menubu.tcl new file mode 100644 index 0000000..2a76e30 --- /dev/null +++ b/library/demos/menubu.tcl @@ -0,0 +1,93 @@ +# menubutton.tcl -- +# +# This demonstration script creates a window with a bunch of menus +# and cascaded menus using menubuttons. +# +# # SCCS: @(#) menubu.tcl 1.9 97/06/19 18:11:06 + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +set w .menubutton +catch {destroy $w} +toplevel $w +wm title $w "Menu Button Demonstration" +wm iconname $w "menubutton" +positionWindow $w + + +frame $w.body +pack $w.body -expand 1 -fill both + +menubutton $w.body.below -text "Below" -underline 0 -direction below -menu $w.body.below.m -relief raised +menu $w.body.below.m -tearoff 0 +$w.body.below.m add command -label "Below menu: first item" -command "puts \"You have selected the first item from the Below menu.\"" +$w.body.below.m add command -label "Below menu: second item" -command "puts \"You have selected the second item from the Below menu.\"" +grid $w.body.below -row 0 -column 1 -sticky n +menubutton $w.body.right -text "Right" -underline 0 -direction right -menu $w.body.right.m -relief raised +menu $w.body.right.m -tearoff 0 +$w.body.right.m add command -label "Right menu: first item" -command "puts \"You have selected the first item from the Right menu.\"" +$w.body.right.m add command -label "Right menu: second item" -command "puts \"You have selected the second item from the Right menu.\"" +frame $w.body.center +menubutton $w.body.left -text "Left" -underline 0 -direction left -menu $w.body.left.m -relief raised +menu $w.body.left.m -tearoff 0 +$w.body.left.m add command -label "Left menu: first item" -command "puts \"You have selected the first item from the Left menu.\"" +$w.body.left.m add command -label "Left menu: second item" -command "puts \"You have selected the second item from the Left menu.\"" +grid $w.body.right -row 1 -column 0 -sticky w +grid $w.body.center -row 1 -column 1 -sticky news +grid $w.body.left -row 1 -column 2 -sticky e +menubutton $w.body.above -text "Above" -underline 0 -direction above -menu $w.body.above.m -relief raised +menu $w.body.above.m -tearoff 0 +$w.body.above.m add command -label "Above menu: first item" -command "puts \"You have selected the first item from the Above menu.\"" +$w.body.above.m add command -label "Above menu: second item" -command "puts \"You have selected the second item from the Above menu.\"" +grid $w.body.above -row 2 -column 1 -sticky s + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode .menubu" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +set body $w.body.center +label $body.label -wraplength 300 -font "Helvetica 14" -justify left -text "This is a demonstration of menubuttons. The \"Below\" menubutton pops its menu below the button; the \"Right\" button pops to the right, etc. There are two option menus directly below this text; one is just a standard menu and the other is a 16-color palette." +pack $body.label -side top -padx 25 -pady 25 +frame $body.buttons +pack $body.buttons -padx 25 -pady 25 +tk_optionMenu $body.buttons.options menubuttonoptions one two three +pack $body.buttons.options -side left -padx 25 -pady 25 +set m [tk_optionMenu $body.buttons.colors paletteColor Black red4 DarkGreen NavyBlue gray75 Red Green Blue gray50 Yellow Cyan Magenta White Brown DarkSeaGreen DarkViolet] +if {$tcl_platform(platform) == "macintosh"} { + set topBorderColor Black + set bottomBorderColor Black +} else { + set topBorderColor gray50 + set bottomBorderColor gray75 +} +for {set i 0} {$i <= [$m index last]} {incr i} { + set name [$m entrycget $i -label] + image create photo image_$name -height 16 -width 16 + image_$name put $topBorderColor -to 0 0 16 1 + image_$name put $topBorderColor -to 0 1 1 16 + image_$name put $bottomBorderColor -to 0 15 16 16 + image_$name put $bottomBorderColor -to 15 1 16 16 + image_$name put $name -to 1 1 15 15 + + image create photo image_${name}_s -height 16 -width 16 + image_${name}_s put Black -to 0 0 16 2 + image_${name}_s put Black -to 0 2 2 16 + image_${name}_s put Black -to 2 14 16 16 + image_${name}_s put Black -to 14 2 16 14 + image_${name}_s put $name -to 2 2 14 14 + + $m entryconfigure $i -image image_$name -selectimage image_${name}_s -hidemargin 1 +} +$m configure -tearoff 1 +foreach i {Black gray75 gray50 White} { + $m entryconfigure $i -columnbreak 1 +} + +pack $body.buttons.colors -side left -padx 25 -pady 25 + + + diff --git a/library/demos/msgbox.tcl b/library/demos/msgbox.tcl new file mode 100644 index 0000000..52b648f --- /dev/null +++ b/library/demos/msgbox.tcl @@ -0,0 +1,65 @@ +# msgbox.tcl -- +# +# This demonstration script creates message boxes of various type +# +# SCCS: @(#) msgbox.tcl 1.3 97/03/02 16:26:07 + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +set w .msgbox +catch {destroy $w} +toplevel $w +wm title $w "Message Box Demonstration" +wm iconname $w "messagebox" +positionWindow $w + +label $w.msg -font $font -wraplength 4i -justify left -text "Choose the icon and type option of the message box. Then press the \"Message Box\" button to see the message box." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +button $w.buttons.vars -text "Message Box" \ + -command "showMessageBox $w" +pack $w.buttons.dismiss $w.buttons.code $w.buttons.vars -side left -expand 1 + +frame $w.left +frame $w.right +pack $w.left $w.right -side left -expand yes -fill y -pady .5c -padx .5c + +label $w.left.label -text "Icon" +frame $w.left.sep -relief ridge -bd 1 -height 2 +pack $w.left.label -side top +pack $w.left.sep -side top -fill x -expand no + +set msgboxIcon info +foreach i {error info question warning} { + radiobutton $w.left.b$i -text $i -variable msgboxIcon \ + -relief flat -value $i -width 16 -anchor w + pack $w.left.b$i -side top -pady 2 -anchor w -fill x +} + +label $w.right.label -text "Type" +frame $w.right.sep -relief ridge -bd 1 -height 2 +pack $w.right.label -side top +pack $w.right.sep -side top -fill x -expand no + +set msgboxType ok +foreach t {abortretryignore ok okcancel retrycancel yesno yesnocancel} { + radiobutton $w.right.$t -text $t -variable msgboxType \ + -relief flat -value $t -width 16 -anchor w + pack $w.right.$t -side top -pady 2 -anchor w -fill x +} + +proc showMessageBox {w} { + global msgboxIcon msgboxType + set button [tk_messageBox -icon $msgboxIcon -type $msgboxType \ + -title Message -parent $w\ + -message "This is a \"$msgboxType\" type messagebox with the \"$msgboxIcon\" icon"] + + tk_messageBox -icon info -message "You have selected \"$button\"" -type ok\ + -parent $w +} diff --git a/library/demos/plot.tcl b/library/demos/plot.tcl new file mode 100644 index 0000000..6067979 --- /dev/null +++ b/library/demos/plot.tcl @@ -0,0 +1,98 @@ +# plot.tcl -- +# +# This demonstration script creates a canvas widget showing a 2-D +# plot with data points that can be dragged with the mouse. +# +# SCCS: @(#) plot.tcl 1.5 97/03/02 16:26:19 + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +set w .plot +catch {destroy $w} +toplevel $w +wm title $w "Plot Demonstration" +wm iconname $w "Plot" +positionWindow $w +set c $w.c + +label $w.msg -font $font -wraplength 4i -justify left -text "This window displays a canvas widget containing a simple 2-dimensional plot. You can doctor the data by dragging any of the points with mouse button 1." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +canvas $c -relief raised -width 450 -height 300 +pack $w.c -side top -fill x + +set plotFont {Helvetica 18} + +$c create line 100 250 400 250 -width 2 +$c create line 100 250 100 50 -width 2 +$c create text 225 20 -text "A Simple Plot" -font $plotFont -fill brown + +for {set i 0} {$i <= 10} {incr i} { + set x [expr {100 + ($i*30)}] + $c create line $x 250 $x 245 -width 2 + $c create text $x 254 -text [expr 10*$i] -anchor n -font $plotFont +} +for {set i 0} {$i <= 5} {incr i} { + set y [expr {250 - ($i*40)}] + $c create line 100 $y 105 $y -width 2 + $c create text 96 $y -text [expr $i*50].0 -anchor e -font $plotFont +} + +foreach point {{12 56} {20 94} {33 98} {32 120} {61 180} + {75 160} {98 223}} { + set x [expr {100 + (3*[lindex $point 0])}] + set y [expr {250 - (4*[lindex $point 1])/5}] + set item [$c create oval [expr $x-6] [expr $y-6] \ + [expr $x+6] [expr $y+6] -width 1 -outline black \ + -fill SkyBlue2] + $c addtag point withtag $item +} + +$c bind point "$c itemconfig current -fill red" +$c bind point "$c itemconfig current -fill SkyBlue2" +$c bind point <1> "plotDown $c %x %y" +$c bind point "$c dtag selected" +bind $c "plotMove $c %x %y" + +set plot(lastX) 0 +set plot(lastY) 0 + +# plotDown -- +# This procedure is invoked when the mouse is pressed over one of the +# data points. It sets up state to allow the point to be dragged. +# +# Arguments: +# w - The canvas window. +# x, y - The coordinates of the mouse press. + +proc plotDown {w x y} { + global plot + $w dtag selected + $w addtag selected withtag current + $w raise current + set plot(lastX) $x + set plot(lastY) $y +} + +# plotMove -- +# This procedure is invoked during mouse motion events. It drags the +# current item. +# +# Arguments: +# w - The canvas window. +# x, y - The coordinates of the mouse. + +proc plotMove {w x y} { + global plot + $w move selected [expr $x-$plot(lastX)] [expr $y-$plot(lastY)] + set plot(lastX) $x + set plot(lastY) $y +} diff --git a/library/demos/puzzle.tcl b/library/demos/puzzle.tcl new file mode 100644 index 0000000..7e3d9c8 --- /dev/null +++ b/library/demos/puzzle.tcl @@ -0,0 +1,73 @@ +# puzzle.tcl -- +# +# This demonstration script creates a 15-puzzle game using a collection +# of buttons. +# +# SCCS: @(#) puzzle.tcl 1.5 97/03/02 16:26:32 + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +# puzzleSwitch -- +# This procedure is invoked when the user clicks on a particular button; +# if the button is next to the empty space, it moves the button into th +# empty space. + +proc puzzleSwitch {w num} { + global xpos ypos + if {(($ypos($num) >= ($ypos(space) - .01)) + && ($ypos($num) <= ($ypos(space) + .01)) + && ($xpos($num) >= ($xpos(space) - .26)) + && ($xpos($num) <= ($xpos(space) + .26))) + || (($xpos($num) >= ($xpos(space) - .01)) + && ($xpos($num) <= ($xpos(space) + .01)) + && ($ypos($num) >= ($ypos(space) - .26)) + && ($ypos($num) <= ($ypos(space) + .26)))} { + set tmp $xpos(space) + set xpos(space) $xpos($num) + set xpos($num) $tmp + set tmp $ypos(space) + set ypos(space) $ypos($num) + set ypos($num) $tmp + place $w.frame.$num -relx $xpos($num) -rely $ypos($num) + } +} + +set w .puzzle +catch {destroy $w} +toplevel $w +wm title $w "15-Puzzle Demonstration" +wm iconname $w "15-Puzzle" +positionWindow $w + +label $w.msg -font $font -wraplength 4i -justify left -text "A 15-puzzle appears below as a collection of buttons. Click on any of the pieces next to the space, and that piece will slide over the space. Continue this until the pieces are arranged in numerical order from upper-left to lower-right." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +# Special trick: select a darker color for the space by creating a +# scrollbar widget and using its trough color. + +scrollbar $w.s +frame $w.frame -width 120 -height 120 -borderwidth 2 -relief sunken \ + -bg [$w.s cget -troughcolor] +pack $w.frame -side top -pady 1c -padx 1c +destroy $w.s + +set order {3 1 6 2 5 7 15 13 4 11 8 9 14 10 12} +for {set i 0} {$i < 15} {set i [expr $i+1]} { + set num [lindex $order $i] + set xpos($num) [expr ($i%4)*.25] + set ypos($num) [expr ($i/4)*.25] + button $w.frame.$num -relief raised -text $num -highlightthickness 0 \ + -command "puzzleSwitch $w $num" + place $w.frame.$num -relx $xpos($num) -rely $ypos($num) \ + -relwidth .25 -relheight .25 +} +set xpos(space) .75 +set ypos(space) .75 diff --git a/library/demos/radio.tcl b/library/demos/radio.tcl new file mode 100644 index 0000000..2b73739 --- /dev/null +++ b/library/demos/radio.tcl @@ -0,0 +1,44 @@ +# radio.tcl -- +# +# This demonstration script creates a toplevel window containing +# several radiobutton widgets. +# +# SCCS: @(#) radio.tcl 1.5 97/03/02 16:26:57 + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +set w .radio +catch {destroy $w} +toplevel $w +wm title $w "Radiobutton Demonstration" +wm iconname $w "radio" +positionWindow $w +label $w.msg -font $font -wraplength 5i -justify left -text "Two groups of radiobuttons are displayed below. If you click on a button then the button will become selected exclusively among all the buttons in its group. A Tcl variable is associated with each group to indicate which of the group's buttons is selected. Click the \"See Variables\" button to see the current values of the variables." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +button $w.buttons.vars -text "See Variables" \ + -command "showVars $w.dialog size color" +pack $w.buttons.dismiss $w.buttons.code $w.buttons.vars -side left -expand 1 + +frame $w.left +frame $w.right +pack $w.left $w.right -side left -expand yes -pady .5c -padx .5c + +foreach i {10 12 18 24} { + radiobutton $w.left.b$i -text "Point Size $i" -variable size \ + -relief flat -value $i + pack $w.left.b$i -side top -pady 2 -anchor w +} + +foreach color {Red Green Blue Yellow Orange Purple} { + set lower [string tolower $color] + radiobutton $w.right.$lower -text $color -variable color \ + -relief flat -value $lower + pack $w.right.$lower -side top -pady 2 -anchor w +} diff --git a/library/demos/rmt b/library/demos/rmt new file mode 100644 index 0000000..9310475 --- /dev/null +++ b/library/demos/rmt @@ -0,0 +1,205 @@ +#!/bin/sh +# the next line restarts using wish \ +exec wish "$0" "$@" + +# rmt -- +# This script implements a simple remote-control mechanism for +# Tk applications. It allows you to select an application and +# then type commands to that application. +# +# SCCS: @(#) rmt 1.10 96/06/24 16:42:38 + +wm title . "Tk Remote Controller" +wm iconname . "Tk Remote" +wm minsize . 1 1 + +# The global variable below keeps track of the remote application +# that we're sending to. If it's an empty string then we execute +# the commands locally. + +set app "local" + +# The global variable below keeps track of whether we're in the +# middle of executing a command entered via the text. + +set executing 0 + +# The global variable below keeps track of the last command executed, +# so it can be re-executed in response to !! commands. + +set lastCommand "" + +# Create menu bar. Arrange to recreate all the information in the +# applications sub-menu whenever it is cascaded to. + +frame .menu -relief raised -bd 2 +pack .menu -side top -fill x +menubutton .menu.file -text "File" -menu .menu.file.m -underline 0 +menu .menu.file.m +.menu.file.m add cascade -label "Select Application" \ + -menu .menu.file.m.apps -underline 0 +.menu.file.m add command -label "Quit" -command "destroy ." -underline 0 +menu .menu.file.m.apps -postcommand fillAppsMenu +pack .menu.file -side left + +# Create text window and scrollbar. + +text .t -relief sunken -bd 2 -yscrollcommand ".s set" -setgrid true +scrollbar .s -command ".t yview" +pack .s -side right -fill both +pack .t -side left + +# Create a binding to forward commands to the target application, +# plus modify many of the built-in bindings so that only information +# in the current command can be deleted (can still set the cursor +# earlier in the text and select and insert; just can't delete). + +bindtags .t {.t Text . all} +bind .t { + .t mark set insert {end - 1c} + .t insert insert \n + invoke + break +} +bind .t { + catch {.t tag remove sel sel.first promptEnd} + if {[.t tag nextrange sel 1.0 end] == ""} { + if [.t compare insert < promptEnd] { + break + } + } +} +bind .t { + catch {.t tag remove sel sel.first promptEnd} + if {[.t tag nextrange sel 1.0 end] == ""} { + if [.t compare insert <= promptEnd] { + break + } + } +} +bind .t { + if [.t compare insert < promptEnd] { + break + } +} +bind .t { + if [.t compare insert < promptEnd] { + .t mark set insert promptEnd + } +} +bind .t { + if [.t compare insert < promptEnd] { + break + } +} +bind .t { + if [.t compare insert < promptEnd] { + break + } +} +bind .t { + if [.t compare insert <= promptEnd] { + break + } +} +bind .t { + if [.t compare insert <= promptEnd] { + break + } +} +auto_load tkTextInsert +proc tkTextInsert {w s} { + if {$s == ""} { + return + } + catch { + if {[$w compare sel.first <= insert] + && [$w compare sel.last >= insert]} { + $w tag remove sel sel.first promptEnd + $w delete sel.first sel.last + } + } + $w insert insert $s + $w see insert +} + +.t tag configure bold -font {Courier 12 bold} + +# The procedure below is used to print out a prompt at the +# insertion point (which should be at the beginning of a line +# right now). + +proc prompt {} { + global app + .t insert insert "$app: " + .t mark set promptEnd {insert} + .t mark gravity promptEnd left + .t tag add bold {promptEnd linestart} promptEnd +} + +# The procedure below executes a command (it takes everything on the +# current line after the prompt and either sends it to the remote +# application or executes it locally, depending on "app". + +proc invoke {} { + global app executing lastCommand + set cmd [.t get promptEnd insert] + incr executing 1 + if [info complete $cmd] { + if {$cmd == "!!\n"} { + set cmd $lastCommand + } else { + set lastCommand $cmd + } + if {$app == "local"} { + set result [catch [list uplevel #0 $cmd] msg] + } else { + set result [catch [list send $app $cmd] msg] + } + if {$result != 0} { + .t insert insert "Error: $msg\n" + } else { + if {$msg != ""} { + .t insert insert $msg\n + } + } + prompt + .t mark set promptEnd insert + } + incr executing -1 + .t yview -pickplace insert +} + +# The following procedure is invoked to change the application that +# we're talking to. It also updates the prompt for the current +# command, unless we're in the middle of executing a command from +# the text item (in which case a new prompt is about to be output +# so there's no need to change the old one). + +proc newApp appName { + global app executing + set app $appName + if !$executing { + .t mark gravity promptEnd right + .t delete "promptEnd linestart" promptEnd + .t insert promptEnd "$appName: " + .t tag add bold "promptEnd linestart" promptEnd + .t mark gravity promptEnd left + } + return {} +} + +# The procedure below will fill in the applications sub-menu with a list +# of all the applications that currently exist. + +proc fillAppsMenu {} { + catch {.menu.file.m.apps delete 0 last} + foreach i [lsort [winfo interps]] { + .menu.file.m.apps add command -label $i -command [list newApp $i] + } + .menu.file.m.apps add command -label local -command {newApp local} +} + +set app [winfo name .] +prompt +focus .t diff --git a/library/demos/rolodex b/library/demos/rolodex new file mode 100644 index 0000000..e3e0e5a --- /dev/null +++ b/library/demos/rolodex @@ -0,0 +1,196 @@ +#!/bin/sh +# the next line restarts using wish \ +exec wish "$0" "$@" + +# rolodex -- +# This script was written as an entry in Tom LaStrange's rolodex +# benchmark. It creates something that has some of the look and +# feel of a rolodex program, although it's lifeless and doesn't +# actually do the rolodex application. +# +# SCCS: @(#) rolodex 1.7 96/02/16 10:49:23 + +foreach i [winfo child .] { + catch {destroy $i} +} + +#------------------------------------------ +# Phase 0: create the front end. +#------------------------------------------ + +frame .frame -relief flat +pack .frame -side top -fill y -anchor center + +set names {{} Name: Address: {} {} {Home Phone:} {Work Phone:} Fax:} +foreach i {1 2 3 4 5 6 7} { + frame .frame.$i + pack .frame.$i -side top -pady 2 -anchor e + + label .frame.$i.label -text [lindex $names $i] -anchor e + entry .frame.$i.entry -width 30 -relief sunken + pack .frame.$i.entry .frame.$i.label -side right +} + +frame .buttons +pack .buttons -side bottom -pady 2 -anchor center +button .buttons.clear -text Clear +button .buttons.add -text Add +button .buttons.search -text Search +button .buttons.delete -text "Delete ..." +pack .buttons.clear .buttons.add .buttons.search .buttons.delete \ + -side left -padx 2 + +#------------------------------------------ +# Phase 1: Add menus, dialog boxes +#------------------------------------------ + +frame .menu -relief raised -borderwidth 1 +pack .menu -before .frame -side top -fill x + +menubutton .menu.file -text "File" -menu .menu.file.m -underline 0 +menu .menu.file.m +.menu.file.m add command -label "Load ..." -command fileAction -underline 0 +.menu.file.m add command -label "Exit" -command {destroy .} -underline 0 +pack .menu.file -side left + +menubutton .menu.help -text "Help" -menu .menu.help.m -underline 0 +menu .menu.help.m +pack .menu.help -side right + +proc deleteAction {} { + if {[tk_dialog .delete {Confirm Action} {Are you sure?} {} 0 Cancel] + == 0} { + clearAction + } +} +.buttons.delete config -command deleteAction + +proc fileAction {} { + tk_dialog .fileSelection {File Selection} {This is a dummy file selection dialog box, which is used because there isn't a good file selection dialog built into Tk yet.} {} 0 OK + puts stderr {dummy file name} +} + +#------------------------------------------ +# Phase 3: Print contents of card +#------------------------------------------ + +proc addAction {} { + global names + foreach i {1 2 3 4 5 6 7} { + puts stderr [format "%-12s %s" [lindex $names $i] [.frame.$i.entry get]] + } +} +.buttons.add config -command addAction + +#------------------------------------------ +# Phase 4: Miscellaneous other actions +#------------------------------------------ + +proc clearAction {} { + foreach i {1 2 3 4 5 6 7} { + .frame.$i.entry delete 0 end + } +} +.buttons.clear config -command clearAction + +proc fillCard {} { + clearAction + .frame.1.entry insert 0 "John Ousterhout" + .frame.2.entry insert 0 "CS Division, Department of EECS" + .frame.3.entry insert 0 "University of California" + .frame.4.entry insert 0 "Berkeley, CA 94720" + .frame.5.entry insert 0 "private" + .frame.6.entry insert 0 "510-642-0865" + .frame.7.entry insert 0 "510-642-5775" +} +.buttons.search config -command "addAction; fillCard" + +#---------------------------------------------------- +# Phase 5: Accelerators, mnemonics, command-line info +#---------------------------------------------------- + +.buttons.clear config -text "Clear Ctrl+C" +bind . clearAction +.buttons.add config -text "Add Ctrl+A" +bind . addAction +.buttons.search config -text "Search Ctrl+S" +bind . "addAction; fillCard" +.buttons.delete config -text "Delete... Ctrl+D" +bind . deleteAction + +.menu.file.m entryconfig 1 -accel Ctrl+F +bind . fileAction +.menu.file.m entryconfig 2 -accel Ctrl+Q +bind . {destroy .} + +focus .frame.1.entry + +#---------------------------------------------------- +# Phase 6: help +#---------------------------------------------------- + +proc Help {topic {x 0} {y 0}} { + global helpTopics helpCmds + if {$topic == ""} return + while {[info exists helpCmds($topic)]} { + set topic [eval $helpCmds($topic)] + } + if [info exists helpTopics($topic)] { + set msg $helpTopics($topic) + } else { + set msg "Sorry, but no help is available for this topic" + } + tk_dialog .help {Rolodex Help} "Information on $topic:\n\n$msg" \ + {} 0 OK +} + +proc getMenuTopic {w x y} { + return $w.[$w index @[expr $y-[winfo rooty $w]]] +} + +bind . {Help [winfo containing %X %Y] %X %Y} +bind . {Help [winfo containing %X %Y] %X %Y} + +# Help text and commands follow: + +set helpTopics(.menu.file) {This is the "file" menu. It can be used to invoke some overall operations on the rolodex applications, such as loading a file or exiting.} + +set helpCmds(.menu.file.m) {getMenuTopic $topic $x $y} +set helpTopics(.menu.file.m.0) {The "Load" entry in the "File" menu posts a dialog box that you can use to select a rolodex file} +set helpTopics(.menu.file.m.1) {The "Exit" entry in the "File" menu causes the rolodex application to terminate} +set helpCmds(.menu.file.m.none) {set topic ".menu.file"} + +set helpTopics(.frame.1.entry) {In this field of the rolodex entry you should type the person's name} +set helpTopics(.frame.2.entry) {In this field of the rolodex entry you should type the first line of the person's address} +set helpTopics(.frame.3.entry) {In this field of the rolodex entry you should type the second line of the person's address} +set helpTopics(.frame.4.entry) {In this field of the rolodex entry you should type the third line of the person's address} +set helpTopics(.frame.5.entry) {In this field of the rolodex entry you should type the person's home phone number, or "private" if the person doesn't want his or her number publicized} +set helpTopics(.frame.6.entry) {In this field of the rolodex entry you should type the person's work phone number} +set helpTopics(.frame.7.entry) {In this field of the rolodex entry you should type the phone number for the person's FAX machine} + +set helpCmds(.frame.1.label) {set topic .frame.1.entry} +set helpCmds(.frame.2.label) {set topic .frame.2.entry} +set helpCmds(.frame.3.label) {set topic .frame.3.entry} +set helpCmds(.frame.4.label) {set topic .frame.4.entry} +set helpCmds(.frame.5.label) {set topic .frame.5.entry} +set helpCmds(.frame.6.label) {set topic .frame.6.entry} +set helpCmds(.frame.7.label) {set topic .frame.7.entry} + +set helpTopics(context) {Unfortunately, this application doesn't support context-sensitive help in the usual way, because when this demo was written Tk didn't have a grab mechanism and this is needed for context-sensitive help. Instead, you can achieve much the same effect by simply moving the mouse over the window you're curious about and pressing the Help or F1 keys. You can do this anytime.} +set helpTopics(help) {This application provides only very crude help. Besides the entries in this menu, you can get help on individual windows by moving the mouse cursor over the window and pressing the Help or F1 keys.} +set helpTopics(window) {This window is a dummy rolodex application created as part of Tom LaStrange's toolkit benchmark. It doesn't really do anything useful except to demonstrate a few features of the Tk toolkit.} +set helpTopics(keys) "The following accelerator keys are defined for this application (in addition to those already available for the entry windows):\n\nCtrl+A:\t\tAdd\nCtrl+C:\t\tClear\nCtrl+D:\t\tDelete\nCtrl+F:\t\tEnter file name\nCtrl+Q:\t\tExit application (quit)\nCtrl+S:\t\tSearch (dummy operation)" +set helpTopics(version) {This is version 1.0.} + +# Entries in "Help" menu + +.menu.help.m add command -label "On Context..." -command {Help context} \ + -underline 3 +.menu.help.m add command -label "On Help..." -command {Help help} \ + -underline 3 +.menu.help.m add command -label "On Window..." -command {Help window} \ + -underline 3 +.menu.help.m add command -label "On Keys..." -command {Help keys} \ + -underline 3 +.menu.help.m add command -label "On Version..." -command {Help version} \ + -underline 3 diff --git a/library/demos/ruler.tcl b/library/demos/ruler.tcl new file mode 100644 index 0000000..3c77c72 --- /dev/null +++ b/library/demos/ruler.tcl @@ -0,0 +1,173 @@ +# ruler.tcl -- +# +# This demonstration script creates a canvas widget that displays a ruler +# with tab stops that can be set, moved, and deleted. +# +# SCCS: @(#) ruler.tcl 1.9 97/03/02 16:17:33 + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +# rulerMkTab -- +# This procedure creates a new triangular polygon in a canvas to +# represent a tab stop. +# +# Arguments: +# c - The canvas window. +# x, y - Coordinates at which to create the tab stop. + +proc rulerMkTab {c x y} { + upvar #0 demo_rulerInfo v + $c create polygon $x $y [expr $x+$v(size)] [expr $y+$v(size)] \ + [expr $x-$v(size)] [expr $y+$v(size)] +} + +set w .ruler +global tk_library +catch {destroy $w} +toplevel $w +wm title $w "Ruler Demonstration" +wm iconname $w "ruler" +positionWindow $w +set c $w.c + +label $w.msg -font $font -wraplength 5i -justify left -text "This canvas widget shows a mock-up of a ruler. You can create tab stops by dragging them out of the well to the right of the ruler. You can also drag existing tab stops. If you drag a tab stop far enough up or down so that it turns dim, it will be deleted when you release the mouse button." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +canvas $c -width 14.8c -height 2.5c +pack $w.c -side top -fill x + +set demo_rulerInfo(grid) .25c +set demo_rulerInfo(left) [winfo fpixels $c 1c] +set demo_rulerInfo(right) [winfo fpixels $c 13c] +set demo_rulerInfo(top) [winfo fpixels $c 1c] +set demo_rulerInfo(bottom) [winfo fpixels $c 1.5c] +set demo_rulerInfo(size) [winfo fpixels $c .2c] +set demo_rulerInfo(normalStyle) "-fill black" +if {[winfo depth $c] > 1} { + set demo_rulerInfo(activeStyle) "-fill red -stipple {}" + set demo_rulerInfo(deleteStyle) [list -fill red \ + -stipple @[file join $tk_library demos images gray25.bmp]] +} else { + set demo_rulerInfo(activeStyle) "-fill black -stipple {}" + set demo_rulerInfo(deleteStyle) [list -fill black \ + -stipple @[file join $tk_library demos images gray25.bmp]] +} + +$c create line 1c 0.5c 1c 1c 13c 1c 13c 0.5c -width 1 +for {set i 0} {$i < 12} {incr i} { + set x [expr $i+1] + $c create line ${x}c 1c ${x}c 0.6c -width 1 + $c create line $x.25c 1c $x.25c 0.8c -width 1 + $c create line $x.5c 1c $x.5c 0.7c -width 1 + $c create line $x.75c 1c $x.75c 0.8c -width 1 + $c create text $x.15c .75c -text $i -anchor sw +} +$c addtag well withtag [$c create rect 13.2c 1c 13.8c 0.5c \ + -outline black -fill [lindex [$c config -bg] 4]] +$c addtag well withtag [rulerMkTab $c [winfo pixels $c 13.5c] \ + [winfo pixels $c .65c]] + +$c bind well <1> "rulerNewTab $c %x %y" +$c bind tab <1> "rulerSelectTab $c %x %y" +bind $c "rulerMoveTab $c %x %y" +bind $c "rulerReleaseTab $c" + +# rulerNewTab -- +# Does all the work of creating a tab stop, including creating the +# triangle object and adding tags to it to give it tab behavior. +# +# Arguments: +# c - The canvas window. +# x, y - The coordinates of the tab stop. + +proc rulerNewTab {c x y} { + upvar #0 demo_rulerInfo v + $c addtag active withtag [rulerMkTab $c $x $y] + $c addtag tab withtag active + set v(x) $x + set v(y) $y + rulerMoveTab $c $x $y +} + +# rulerSelectTab -- +# This procedure is invoked when mouse button 1 is pressed over +# a tab. It remembers information about the tab so that it can +# be dragged interactively. +# +# Arguments: +# c - The canvas widget. +# x, y - The coordinates of the mouse (identifies the point by +# which the tab was picked up for dragging). + +proc rulerSelectTab {c x y} { + upvar #0 demo_rulerInfo v + set v(x) [$c canvasx $x $v(grid)] + set v(y) [expr $v(top)+2] + $c addtag active withtag current + eval "$c itemconf active $v(activeStyle)" + $c raise active +} + +# rulerMoveTab -- +# This procedure is invoked during mouse motion events to drag a tab. +# It adjusts the position of the tab, and changes its appearance if +# it is about to be dragged out of the ruler. +# +# Arguments: +# c - The canvas widget. +# x, y - The coordinates of the mouse. + +proc rulerMoveTab {c x y} { + upvar #0 demo_rulerInfo v + if {[$c find withtag active] == ""} { + return + } + set cx [$c canvasx $x $v(grid)] + set cy [$c canvasy $y] + if {$cx < $v(left)} { + set cx $v(left) + } + if {$cx > $v(right)} { + set cx $v(right) + } + if {($cy >= $v(top)) && ($cy <= $v(bottom))} { + set cy [expr $v(top)+2] + eval "$c itemconf active $v(activeStyle)" + } else { + set cy [expr $cy-$v(size)-2] + eval "$c itemconf active $v(deleteStyle)" + } + $c move active [expr $cx-$v(x)] [expr $cy-$v(y)] + set v(x) $cx + set v(y) $cy +} + +# rulerReleaseTab -- +# This procedure is invoked during button release events that end +# a tab drag operation. It deselects the tab and deletes the tab if +# it was dragged out of the ruler. +# +# Arguments: +# c - The canvas widget. +# x, y - The coordinates of the mouse. + +proc rulerReleaseTab c { + upvar #0 demo_rulerInfo v + if {[$c find withtag active] == {}} { + return + } + if {$v(y) != [expr $v(top)+2]} { + $c delete active + } else { + eval "$c itemconf active $v(normalStyle)" + $c dtag active + } +} diff --git a/library/demos/sayings.tcl b/library/demos/sayings.tcl new file mode 100644 index 0000000..b4952c5 --- /dev/null +++ b/library/demos/sayings.tcl @@ -0,0 +1,46 @@ +# sayings.tcl -- +# +# This demonstration script creates a listbox that can be scrolled +# both horizontally and vertically. It displays a collection of +# well-known sayings. +# +# SCCS: @(#) sayings.tcl 1.7 97/03/02 16:27:10 + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +set w .sayings +catch {destroy $w} +toplevel $w +wm title $w "Listbox Demonstration (well-known sayings)" +wm iconname $w "sayings" +positionWindow $w + +label $w.msg -font $font -wraplength 4i -justify left -text "The listbox below contains a collection of well-known sayings. You can scan the list using either of the scrollbars or by dragging in the listbox window with button 2 pressed." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +frame $w.frame -borderwidth 10 +pack $w.frame -side top -expand yes -fill y + + +scrollbar $w.frame.yscroll -command "$w.frame.list yview" +scrollbar $w.frame.xscroll -orient horizontal \ + -command "$w.frame.list xview" +listbox $w.frame.list -width 20 -height 10 -setgrid 1 \ + -yscroll "$w.frame.yscroll set" -xscroll "$w.frame.xscroll set" + +grid $w.frame.list -row 0 -column 0 -rowspan 1 -columnspan 1 -sticky news +grid $w.frame.yscroll -row 0 -column 1 -rowspan 1 -columnspan 1 -sticky news +grid $w.frame.xscroll -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news +grid rowconfig $w.frame 0 -weight 1 -minsize 0 +grid columnconfig $w.frame 0 -weight 1 -minsize 0 + + +$w.frame.list insert 0 "Waste not, want not" "Early to bed and early to rise makes a man healthy, wealthy, and wise" "Ask not what your country can do for you, ask what you can do for your country" "I shall return" "NOT" "A picture is worth a thousand words" "User interfaces are hard to build" "Thou shalt not steal" "A penny for your thoughts" "Fool me once, shame on you; fool me twice, shame on me" "Every cloud has a silver lining" "Where there's smoke there's fire" "It takes one to know one" "Curiosity killed the cat" "Take this job and shove it" "Up a creek without a paddle" "I'm mad as hell and I'm not going to take it any more" "An apple a day keeps the doctor away" "Don't look a gift horse in the mouth" diff --git a/library/demos/search.tcl b/library/demos/search.tcl new file mode 100644 index 0000000..ffefd82 --- /dev/null +++ b/library/demos/search.tcl @@ -0,0 +1,141 @@ +# search.tcl -- +# +# This demonstration script creates a collection of widgets that +# allow you to load a file into a text widget, then perform searches +# on that file. +# +# SCCS: @(#) search.tcl 1.5 97/03/02 16:27:25 + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +# textLoadFile -- +# This procedure below loads a file into a text widget, discarding +# the previous contents of the widget. Tags for the old widget are +# not affected, however. +# +# Arguments: +# w - The window into which to load the file. Must be a +# text widget. +# file - The name of the file to load. Must be readable. + +proc textLoadFile {w file} { + set f [open $file] + $w delete 1.0 end + while {![eof $f]} { + $w insert end [read $f 10000] + } + close $f +} + +# textSearch -- +# Search for all instances of a given string in a text widget and +# apply a given tag to each instance found. +# +# Arguments: +# w - The window in which to search. Must be a text widget. +# string - The string to search for. The search is done using +# exact matching only; no special characters. +# tag - Tag to apply to each instance of a matching string. + +proc textSearch {w string tag} { + $w tag remove search 0.0 end + if {$string == ""} { + return + } + set cur 1.0 + while 1 { + set cur [$w search -count length $string $cur end] + if {$cur == ""} { + break + } + $w tag add $tag $cur "$cur + $length char" + set cur [$w index "$cur + $length char"] + } +} + +# textToggle -- +# This procedure is invoked repeatedly to invoke two commands at +# periodic intervals. It normally reschedules itself after each +# execution but if an error occurs (e.g. because the window was +# deleted) then it doesn't reschedule itself. +# +# Arguments: +# cmd1 - Command to execute when procedure is called. +# sleep1 - Ms to sleep after executing cmd1 before executing cmd2. +# cmd2 - Command to execute in the *next* invocation of this +# procedure. +# sleep2 - Ms to sleep after executing cmd2 before executing cmd1 again. + +proc textToggle {cmd1 sleep1 cmd2 sleep2} { + catch { + eval $cmd1 + after $sleep1 [list textToggle $cmd2 $sleep2 $cmd1 $sleep1] + } +} + +set w .search +catch {destroy $w} +toplevel $w +wm title $w "Text Demonstration - Search and Highlight" +wm iconname $w "search" +positionWindow $w + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +frame $w.file +label $w.file.label -text "File name:" -width 13 -anchor w +entry $w.file.entry -width 40 -textvariable fileName +button $w.file.button -text "Load File" \ + -command "textLoadFile $w.text \$fileName" +pack $w.file.label $w.file.entry -side left +pack $w.file.button -side left -pady 5 -padx 10 +bind $w.file.entry " + textLoadFile $w.text \$fileName + focus $w.string.entry +" +focus $w.file.entry + +frame $w.string +label $w.string.label -text "Search string:" -width 13 -anchor w +entry $w.string.entry -width 40 -textvariable searchString +button $w.string.button -text "Highlight" \ + -command "textSearch $w.text \$searchString search" +pack $w.string.label $w.string.entry -side left +pack $w.string.button -side left -pady 5 -padx 10 +bind $w.string.entry "textSearch $w.text \$searchString search" + +text $w.text -yscrollcommand "$w.scroll set" -setgrid true +scrollbar $w.scroll -command "$w.text yview" +pack $w.file $w.string -side top -fill x +pack $w.scroll -side right -fill y +pack $w.text -expand yes -fill both + +# Set up display styles for text highlighting. + +if {[winfo depth $w] > 1} { + textToggle "$w.text tag configure search -background \ + #ce5555 -foreground white" 800 "$w.text tag configure \ + search -background {} -foreground {}" 200 +} else { + textToggle "$w.text tag configure search -background \ + black -foreground white" 800 "$w.text tag configure \ + search -background {} -foreground {}" 200 +} +$w.text insert 1.0 \ +{This window demonstrates how to use the tagging facilities in text +widgets to implement a searching mechanism. First, type a file name +in the top entry, then type or click on "Load File". Then +type a string in the lower entry and type or click on +"Load File". This will cause all of the instances of the string to +be tagged with the tag "search", and it will arrange for the tag's +display attributes to change to make all of the strings blink.} +$w.text mark set insert 0.0 + +set fileName "" +set searchString "" diff --git a/library/demos/square b/library/demos/square new file mode 100644 index 0000000..743016f --- /dev/null +++ b/library/demos/square @@ -0,0 +1,55 @@ +#!/bin/sh +# the next line restarts using wish \ +exec wish "$0" "$@" + +# square -- +# This script generates a demo application containing only a "square" +# widget. It's only usable in the "tktest" application or if Tk has +# been compiled with tkSquare.c. This demo arranges the following +# bindings for the widget: +# +# Button-1 press/drag: moves square to mouse +# "a": toggle size animation on/off +# +# SCCS: @(#) square 1.7 97/02/24 16:42:31 + +square .s +pack .s -expand yes -fill both +wm minsize . 1 1 + +bind .s <1> {center %x %y} +bind .s {center %x %y} +bind .s a animate +focus .s + +# The procedure below centers the square on a given position. + +proc center {x y} { + set a [.s size] + .s position [expr $x-($a/2)] [expr $y-($a/2)] +} + +# The procedures below provide a simple form of animation where +# the box changes size in a pulsing pattern: larger, smaller, larger, +# and so on. + +set inc 0 +proc animate {} { + global inc + if {$inc == 0} { + set inc 3 + timer + } else { + set inc 0 + } +} + +proc timer {} { + global inc + set s [.s size] + if {$inc == 0} return + if {$s >= 40} {set inc -3} + if {$s <= 10} {set inc 3} + .s size [expr {$s+$inc}] + after 30 timer +} diff --git a/library/demos/states.tcl b/library/demos/states.tcl new file mode 100644 index 0000000..23905a2 --- /dev/null +++ b/library/demos/states.tcl @@ -0,0 +1,45 @@ +# states.tcl -- +# +# This demonstration script creates a listbox widget that displays +# the names of the 50 states in the United States of America. +# +# SCCS: @(#) states.tcl 1.4 97/03/02 16:27:37 + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +set w .states +catch {destroy $w} +toplevel $w +wm title $w "Listbox Demonstration (50 states)" +wm iconname $w "states" +positionWindow $w + +label $w.msg -font $font -wraplength 4i -justify left -text "A listbox containing the 50 states is displayed below, along with a scrollbar. You can scan the list either using the scrollbar or by scanning. To scan, press button 2 in the widget and drag up or down." +pack $w.msg -side top + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +frame $w.frame -borderwidth .5c +pack $w.frame -side top -expand yes -fill y + +scrollbar $w.frame.scroll -command "$w.frame.list yview" +listbox $w.frame.list -yscroll "$w.frame.scroll set" -setgrid 1 -height 12 +pack $w.frame.scroll -side right -fill y +pack $w.frame.list -side left -expand 1 -fill both + +$w.frame.list insert 0 Alabama Alaska Arizona Arkansas California \ + Colorado Connecticut Delaware Florida Georgia Hawaii Idaho Illinois \ + Indiana Iowa Kansas Kentucky Louisiana Maine Maryland \ + Massachusetts Michigan Minnesota Mississippi Missouri \ + Montana Nebraska Nevada "New Hampshire" "New Jersey" "New Mexico" \ + "New York" "North Carolina" "North Dakota" \ + Ohio Oklahoma Oregon Pennsylvania "Rhode Island" \ + "South Carolina" "South Dakota" \ + Tennessee Texas Utah Vermont Virginia Washington \ + "West Virginia" Wisconsin Wyoming diff --git a/library/demos/style.tcl b/library/demos/style.tcl new file mode 100644 index 0000000..6ed31f8 --- /dev/null +++ b/library/demos/style.tcl @@ -0,0 +1,152 @@ +# style.tcl -- +# +# 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 + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +set w .style +catch {destroy $w} +toplevel $w +wm title $w "Text Demonstration - Display Styles" +wm iconname $w "style" +positionWindow $w + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +text $w.text -yscrollcommand "$w.scroll set" -setgrid true \ + -width 70 -height 32 -wrap word +scrollbar $w.scroll -command "$w.text yview" +pack $w.scroll -side right -fill y +pack $w.text -expand yes -fill both + +# Set up display styles + +$w.text tag configure bold -font {Courier 12 bold italic} +$w.text tag configure big -font {Courier 14 bold} +$w.text tag configure verybig -font {Helvetica 24 bold} +if {[winfo depth $w] > 1} { + $w.text tag configure color1 -background #a0b7ce + $w.text tag configure color2 -foreground red + $w.text tag configure raised -relief raised -borderwidth 1 + $w.text tag configure sunken -relief sunken -borderwidth 1 +} else { + $w.text tag configure color1 -background black -foreground white + $w.text tag configure color2 -background black -foreground white + $w.text tag configure raised -background white -relief raised \ + -borderwidth 1 + $w.text tag configure sunken -background white -relief sunken \ + -borderwidth 1 +} +$w.text tag configure bgstipple -background black -borderwidth 0 \ + -bgstipple gray12 +$w.text tag configure fgstipple -fgstipple gray50 +$w.text tag configure underline -underline on +$w.text tag configure overstrike -overstrike on +$w.text tag configure right -justify right +$w.text tag configure center -justify center +$w.text tag configure super -offset 4p -font {Courier 10} +$w.text tag configure sub -offset -2p -font {Courier 10} +$w.text tag configure margins -lmargin1 12m -lmargin2 6m -rmargin 10m +$w.text tag configure spacing -spacing1 10p -spacing2 2p \ + -lmargin1 12m -lmargin2 6m -rmargin 10m + +$w.text insert end {Text widgets like this one allow you to display information in a +variety of styles. Display styles are controlled using a mechanism +called } +$w.text insert end tags bold +$w.text insert end {. Tags are just textual names that you can apply to one +or more ranges of characters within a text widget. You can configure +tags with various display styles. If you do this, then the tagged +characters will be displayed with the styles you chose. The +available display styles are: +} +$w.text insert end "\n1. Font." big +$w.text insert end " You can choose any X font, " +$w.text insert end large verybig +$w.text insert end " or " +$w.text insert end "small.\n" +$w.text insert end "\n2. Color." big +$w.text insert end " You can change either the " +$w.text insert end background color1 +$w.text insert end " or " +$w.text insert end foreground color2 +$w.text insert end "\ncolor, or " +$w.text insert end both {color1 color2} +$w.text insert end ".\n" +$w.text insert end "\n3. Stippling." big +$w.text insert end " You can cause either the " +$w.text insert end background bgstipple +$w.text insert end " or " +$w.text insert end foreground fgstipple +$w.text insert end { +information to be drawn with a stipple fill instead of a solid fill. +} +$w.text insert end "\n4. Underlining." big +$w.text insert end " You can " +$w.text insert end underline underline +$w.text insert end " ranges of text.\n" +$w.text insert end "\n5. Overstrikes." big +$w.text insert end " You can " +$w.text insert end "draw lines through" overstrike +$w.text insert end " ranges of text.\n" +$w.text insert end "\n6. 3-D effects." big +$w.text insert end { You can arrange for the background to be drawn +with a border that makes characters appear either } +$w.text insert end raised raised +$w.text insert end " or " +$w.text insert end sunken sunken +$w.text insert end ".\n" +$w.text insert end "\n7. Justification." big +$w.text insert end " You can arrange for lines to be displayed\n" +$w.text insert end "left-justified,\n" +$w.text insert end "right-justified, or\n" right +$w.text insert end "centered.\n" center +$w.text insert end "\n8. Superscripts and subscripts." big +$w.text insert end " You can control the vertical\n" +$w.text insert end "position of text to generate superscript effects like 10" +$w.text insert end "n" super +$w.text insert end " or\nsubscript effects like X" +$w.text insert end "i" sub +$w.text insert end ".\n" +$w.text insert end "\n9. Margins." big +$w.text insert end " You can control the amount of extra space left" +$w.text insert end " on\neach side of the text:\n" +$w.text insert end "This paragraph is an example of the use of " margins +$w.text insert end "margins. It consists of a single line of text " margins +$w.text insert end "that wraps around on the screen. There are two " margins +$w.text insert end "separate left margin values, one for the first " margins +$w.text insert end "display line associated with the text line, " margins +$w.text insert end "and one for the subsequent display lines, which " margins +$w.text insert end "occur because of wrapping. There is also a " margins +$w.text insert end "separate specification for the right margin, " margins +$w.text insert end "which is used to choose wrap points for lines.\n" margins +$w.text insert end "\n10. Spacing." big +$w.text insert end " You can control the spacing of lines with three\n" +$w.text insert end "separate parameters. \"Spacing1\" tells how much " +$w.text insert end "extra space to leave\nabove a line, \"spacing3\" " +$w.text insert end "tells how much space to leave below a line,\nand " +$w.text insert end "if a text line wraps, \"spacing2\" tells how much " +$w.text insert end "space to leave\nbetween the display lines that " +$w.text insert end "make up the text line.\n" +$w.text insert end "These indented paragraphs illustrate how spacing " spacing +$w.text insert end "can be used. Each paragraph is actually a " spacing +$w.text insert end "single line in the text widget, which is " spacing +$w.text insert end "word-wrapped by the widget.\n" spacing +$w.text insert end "Spacing1 is set to 10 points for this text, " spacing +$w.text insert end "which results in relatively large gaps between " spacing +$w.text insert end "the paragraphs. Spacing2 is set to 2 points, " spacing +$w.text insert end "which results in just a bit of extra space " spacing +$w.text insert end "within a pararaph. Spacing3 isn't used " spacing +$w.text insert end "in this example.\n" spacing +$w.text insert end "To see where the space is, select ranges of " spacing +$w.text insert end "text within these paragraphs. The selection " spacing +$w.text insert end "highlight will cover the extra space." spacing diff --git a/library/demos/tclIndex b/library/demos/tclIndex new file mode 100644 index 0000000..86a72e2 --- /dev/null +++ b/library/demos/tclIndex @@ -0,0 +1,67 @@ +# Tcl autoload index file, version 2.0 +# This file is generated by the "auto_mkindex" command +# and sourced to set up indexing information for one or +# more commands. Typically each line is a command that +# sets an element in the auto_index array, where the +# element name is the name of a command and the value is +# a script that loads the command. + +set auto_index(arrowSetup) [list source [file join $dir arrow.tcl]] +set auto_index(arrowMove1) [list source [file join $dir arrow.tcl]] +set auto_index(arrowMove2) [list source [file join $dir arrow.tcl]] +set auto_index(arrowMove3) [list source [file join $dir arrow.tcl]] +set auto_index(textLoadFile) [list source [file join $dir search.tcl]] +set auto_index(textSearch) [list source [file join $dir search.tcl]] +set auto_index(textToggle) [list source [file join $dir search.tcl]] +set auto_index(itemEnter) [list source [file join $dir items.tcl]] +set auto_index(itemLeave) [list source [file join $dir items.tcl]] +set auto_index(itemMark) [list source [file join $dir items.tcl]] +set auto_index(itemStroke) [list source [file join $dir items.tcl]] +set auto_index(itemsUnderArea) [list source [file join $dir items.tcl]] +set auto_index(itemStartDrag) [list source [file join $dir items.tcl]] +set auto_index(itemDrag) [list source [file join $dir items.tcl]] +set auto_index(butPress) [list source [file join $dir items.tcl]] +set auto_index(loadDir) [list source [file join $dir image2.tcl]] +set auto_index(loadImage) [list source [file join $dir image2.tcl]] +set auto_index(rulerMkTab) [list source [file join $dir ruler.tcl]] +set auto_index(rulerNewTab) [list source [file join $dir ruler.tcl]] +set auto_index(rulerSelectTab) [list source [file join $dir ruler.tcl]] +set auto_index(rulerMoveTab) [list source [file join $dir ruler.tcl]] +set auto_index(rulerReleaseTab) [list source [file join $dir ruler.tcl]] +set auto_index(mkTextConfig) [list source [file join $dir ctext.tcl]] +set auto_index(textEnter) [list source [file join $dir ctext.tcl]] +set auto_index(textInsert) [list source [file join $dir ctext.tcl]] +set auto_index(textPaste) [list source [file join $dir ctext.tcl]] +set auto_index(textB1Press) [list source [file join $dir ctext.tcl]] +set auto_index(textB1Move) [list source [file join $dir ctext.tcl]] +set auto_index(textBs) [list source [file join $dir ctext.tcl]] +set auto_index(textDel) [list source [file join $dir ctext.tcl]] +set auto_index(bitmapRow) [list source [file join $dir bitmap.tcl]] +set auto_index(scrollEnter) [list source [file join $dir cscroll.tcl]] +set auto_index(scrollLeave) [list source [file join $dir cscroll.tcl]] +set auto_index(scrollButton) [list source [file join $dir cscroll.tcl]] +set auto_index(textWindOn) [list source [file join $dir twind.tcl]] +set auto_index(textWindOff) [list source [file join $dir twind.tcl]] +set auto_index(textWindPlot) [list source [file join $dir twind.tcl]] +set auto_index(embPlotDown) [list source [file join $dir twind.tcl]] +set auto_index(embPlotMove) [list source [file join $dir twind.tcl]] +set auto_index(textWindDel) [list source [file join $dir twind.tcl]] +set auto_index(embDefBg) [list source [file join $dir twind.tcl]] +set auto_index(floorDisplay) [list source [file join $dir floor.tcl]] +set auto_index(newRoom) [list source [file join $dir floor.tcl]] +set auto_index(roomChanged) [list source [file join $dir floor.tcl]] +set auto_index(bg1) [list source [file join $dir floor.tcl]] +set auto_index(bg2) [list source [file join $dir floor.tcl]] +set auto_index(bg3) [list source [file join $dir floor.tcl]] +set auto_index(fg1) [list source [file join $dir floor.tcl]] +set auto_index(fg2) [list source [file join $dir floor.tcl]] +set auto_index(fg3) [list source [file join $dir floor.tcl]] +set auto_index(setWidth) [list source [file join $dir hscale.tcl]] +set auto_index(plotDown) [list source [file join $dir plot.tcl]] +set auto_index(plotMove) [list source [file join $dir plot.tcl]] +set auto_index(puzzleSwitch) [list source [file join $dir puzzle.tcl]] +set auto_index(setHeight) [list source [file join $dir vscale.tcl]] +set auto_index(showMessageBox) [list source [file join $dir msgbox.tcl]] +set auto_index(setColor) [list source [file join $dir clrpick.tcl]] +set auto_index(setColor_helper) [list source [file join $dir clrpick.tcl]] +set auto_index(fileDialog) [list source [file join $dir filebox.tcl]] diff --git a/library/demos/tcolor b/library/demos/tcolor new file mode 100644 index 0000000..50c0e68 --- /dev/null +++ b/library/demos/tcolor @@ -0,0 +1,358 @@ +#!/bin/sh +# the next line restarts using wish \ +exec wish "$0" "$@" + +# tcolor -- +# This script implements a simple color editor, where you can +# create colors using either the RGB, HSB, or CYM color spaces +# and apply the color to existing applications. +# +# SCCS: @(#) tcolor 1.11 96/06/24 16:43:11 + +wm title . "Color Editor" + +# Global variables that control the program: +# +# colorSpace - Color space currently being used for +# editing. Must be "rgb", "cmy", or "hsb". +# label1, label2, label3 - Labels for the scales. +# red, green, blue - Current color intensities in decimal +# on a scale of 0-65535. +# color - A string giving the current color value +# in the proper form for x: +# #RRRRGGGGBBBB +# updating - Non-zero means that we're in the middle of +# updating the scales to load a new color,so +# information shouldn't be propagating back +# from the scales to other elements of the +# program: this would make an infinite loop. +# command - Holds the command that has been typed +# into the "Command" entry. +# autoUpdate - 1 means execute the update command +# automatically whenever the color changes. +# name - Name for new color, typed into entry. + +set colorSpace hsb +set red 65535 +set green 0 +set blue 0 +set color #ffff00000000 +set updating 0 +set autoUpdate 1 +set name "" + +# Create the menu bar at the top of the window. + +frame .menu -relief raised -borderwidth 2 +pack .menu -side top -fill x +menubutton .menu.file -text File -menu .menu.file.m -underline 0 +menu .menu.file.m +.menu.file.m add radio -label "RGB color space" -variable colorSpace \ + -value rgb -underline 0 -command {changeColorSpace rgb} +.menu.file.m add radio -label "CMY color space" -variable colorSpace \ + -value cmy -underline 0 -command {changeColorSpace cmy} +.menu.file.m add radio -label "HSB color space" -variable colorSpace \ + -value hsb -underline 0 -command {changeColorSpace hsb} +.menu.file.m add separator +.menu.file.m add radio -label "Automatic updates" -variable autoUpdate \ + -value 1 -underline 0 +.menu.file.m add radio -label "Manual updates" -variable autoUpdate \ + -value 0 -underline 0 +.menu.file.m add separator +.menu.file.m add command -label "Exit program" -underline 0 \ + -command "destroy ." +pack .menu.file -side left + +# Create the command entry window at the bottom of the window, along +# with the update button. + +frame .bot -relief raised -borderwidth 2 +pack .bot -side bottom -fill x +label .commandLabel -text "Command:" +entry .command -relief sunken -borderwidth 2 -textvariable command \ + -font {Courier 12} +button .update -text Update -command doUpdate +pack .commandLabel -in .bot -side left +pack .update -in .bot -side right -pady .1c -padx .25c +pack .command -in .bot -expand yes -fill x -ipadx 0.25c + +# Create the listbox that holds all of the color names in rgb.txt, +# if an rgb.txt file can be found. + +frame .middle -relief raised -borderwidth 2 +pack .middle -side top -fill both +foreach i {/usr/local/lib/X11/rgb.txt /usr/lib/X11/rgb.txt + /X11/R5/lib/X11/rgb.txt /X11/R4/lib/rgb/rgb.txt + /usr/openwin/lib/X11/rgb.txt} { + if ![file readable $i] { + continue; + } + set f [open $i] + frame .middle.left + pack .middle.left -side left -padx .25c -pady .25c + listbox .names -width 20 -height 12 -yscrollcommand ".scroll set" \ + -relief sunken -borderwidth 2 -exportselection false + bind .names { + tc_loadNamedColor [.names get [.names curselection]] + } + scrollbar .scroll -orient vertical -command ".names yview" \ + -relief sunken -borderwidth 2 + pack .names -in .middle.left -side left + pack .scroll -in .middle.left -side right -fill y + while {[gets $f line] >= 0} { + if {[llength $line] == 4} { + .names insert end [lindex $line 3] + } + } + close $f + break +} + +# Create the three scales for editing the color, and the entry for +# typing in a color value. + +frame .middle.middle +pack .middle.middle -side left -expand yes -fill y +frame .middle.middle.1 +frame .middle.middle.2 +frame .middle.middle.3 +frame .middle.middle.4 +pack .middle.middle.1 .middle.middle.2 .middle.middle.3 -side top -expand yes +pack .middle.middle.4 -side top -expand yes -fill x +foreach i {1 2 3} { + label .label$i -textvariable label$i + scale .scale$i -from 0 -to 1000 -length 6c -orient horizontal \ + -command tc_scaleChanged + pack .scale$i .label$i -in .middle.middle.$i -side top -anchor w +} +label .nameLabel -text "Name:" +entry .name -relief sunken -borderwidth 2 -textvariable name -width 10 \ + -font {Courier 12} +pack .nameLabel -in .middle.middle.4 -side left +pack .name -in .middle.middle.4 -side right -expand 1 -fill x +bind .name {tc_loadNamedColor $name} + +# Create the color display swatch on the right side of the window. + +frame .middle.right +pack .middle.right -side left -pady .25c -padx .25c -anchor s +frame .swatch -width 2c -height 5c -background $color +label .value -textvariable color -width 13 -font {Courier 12} +pack .swatch -in .middle.right -side top -expand yes -fill both +pack .value -in .middle.right -side bottom -pady .25c + +# The procedure below is invoked when one of the scales is adjusted. +# It propagates color information from the current scale readings +# to everywhere else that it is used. + +proc tc_scaleChanged args { + global red green blue colorSpace color updating autoUpdate + if $updating { + return + } + if {$colorSpace == "rgb"} { + set red [format %.0f [expr [.scale1 get]*65.535]] + set green [format %.0f [expr [.scale2 get]*65.535]] + set blue [format %.0f [expr [.scale3 get]*65.535]] + } else { + if {$colorSpace == "cmy"} { + set red [format %.0f [expr {65535 - [.scale1 get]*65.535}]] + set green [format %.0f [expr {65535 - [.scale2 get]*65.535}]] + set blue [format %.0f [expr {65535 - [.scale3 get]*65.535}]] + } else { + set list [hsbToRgb [expr {[.scale1 get]/1000.0}] \ + [expr {[.scale2 get]/1000.0}] \ + [expr {[.scale3 get]/1000.0}]] + set red [lindex $list 0] + set green [lindex $list 1] + set blue [lindex $list 2] + } + } + set color [format "#%04x%04x%04x" $red $green $blue] + .swatch config -bg $color + if $autoUpdate doUpdate + update idletasks +} + +# The procedure below is invoked to update the scales from the +# current red, green, and blue intensities. It's invoked after +# a change in the color space and after a named color value has +# been loaded. + +proc tc_setScales {} { + global red green blue colorSpace updating + set updating 1 + if {$colorSpace == "rgb"} { + .scale1 set [format %.0f [expr $red/65.535]] + .scale2 set [format %.0f [expr $green/65.535]] + .scale3 set [format %.0f [expr $blue/65.535]] + } else { + if {$colorSpace == "cmy"} { + .scale1 set [format %.0f [expr (65535-$red)/65.535]] + .scale2 set [format %.0f [expr (65535-$green)/65.535]] + .scale3 set [format %.0f [expr (65535-$blue)/65.535]] + } else { + set list [rgbToHsv $red $green $blue] + .scale1 set [format %.0f [expr {[lindex $list 0] * 1000.0}]] + .scale2 set [format %.0f [expr {[lindex $list 1] * 1000.0}]] + .scale3 set [format %.0f [expr {[lindex $list 2] * 1000.0}]] + } + } + set updating 0 +} + +# The procedure below is invoked when a named color has been +# selected from the listbox or typed into the entry. It loads +# the color into the editor. + +proc tc_loadNamedColor name { + global red green blue color autoUpdate + + if {[string index $name 0] != "#"} { + set list [winfo rgb .swatch $name] + set red [lindex $list 0] + set green [lindex $list 1] + set blue [lindex $list 2] + } else { + case [string length $name] { + 4 {set format "#%1x%1x%1x"; set shift 12} + 7 {set format "#%2x%2x%2x"; set shift 8} + 10 {set format "#%3x%3x%3x"; set shift 4} + 13 {set format "#%4x%4x%4x"; set shift 0} + default {error "syntax error in color name \"$name\""} + } + if {[scan $name $format red green blue] != 3} { + error "syntax error in color name \"$name\"" + } + set red [expr $red<<$shift] + set green [expr $green<<$shift] + set blue [expr $blue<<$shift] + } + tc_setScales + set color [format "#%04x%04x%04x" $red $green $blue] + .swatch config -bg $color + if $autoUpdate doUpdate +} + +# The procedure below is invoked when a new color space is selected. +# It changes the labels on the scales and re-loads the scales with +# the appropriate values for the current color in the new color space + +proc changeColorSpace space { + global label1 label2 label3 + if {$space == "rgb"} { + set label1 Red + set label2 Green + set label3 Blue + tc_setScales + return + } + if {$space == "cmy"} { + set label1 Cyan + set label2 Magenta + set label3 Yellow + tc_setScales + return + } + if {$space == "hsb"} { + set label1 Hue + set label2 Saturation + set label3 Brightness + tc_setScales + return + } +} + +# The procedure below converts an RGB value to HSB. It takes red, green, +# and blue components (0-65535) as arguments, and returns a list containing +# HSB components (floating-point, 0-1) as result. The code here is a copy +# of the code on page 615 of "Fundamentals of Interactive Computer Graphics" +# by Foley and Van Dam. + +proc rgbToHsv {red green blue} { + if {$red > $green} { + set max $red.0 + set min $green.0 + } else { + set max $green.0 + set min $red.0 + } + if {$blue > $max} { + set max $blue.0 + } else { + if {$blue < $min} { + set min $blue.0 + } + } + set range [expr $max-$min] + if {$max == 0} { + set sat 0 + } else { + set sat [expr {($max-$min)/$max}] + } + if {$sat == 0} { + set hue 0 + } else { + set rc [expr {($max - $red)/$range}] + set gc [expr {($max - $green)/$range}] + set bc [expr {($max - $blue)/$range}] + if {$red == $max} { + set hue [expr {.166667*($bc - $gc)}] + } else { + if {$green == $max} { + set hue [expr {.166667*(2 + $rc - $bc)}] + } else { + set hue [expr {.166667*(4 + $gc - $rc)}] + } + } + if {$hue < 0.0} { + set hue [expr $hue + 1.0] + } + } + return [list $hue $sat [expr {$max/65535}]] +} + +# The procedure below converts an HSB value to RGB. It takes hue, saturation, +# and value components (floating-point, 0-1.0) as arguments, and returns a +# list containing RGB components (integers, 0-65535) as result. The code +# here is a copy of the code on page 616 of "Fundamentals of Interactive +# Computer Graphics" by Foley and Van Dam. + +proc hsbToRgb {hue sat value} { + set v [format %.0f [expr 65535.0*$value]] + if {$sat == 0} { + return "$v $v $v" + } else { + set hue [expr $hue*6.0] + if {$hue >= 6.0} { + set hue 0.0 + } + scan $hue. %d i + set f [expr $hue-$i] + set p [format %.0f [expr {65535.0*$value*(1 - $sat)}]] + set q [format %.0f [expr {65535.0*$value*(1 - ($sat*$f))}]] + set t [format %.0f [expr {65535.0*$value*(1 - ($sat*(1 - $f)))}]] + case $i \ + 0 {return "$v $t $p"} \ + 1 {return "$q $v $p"} \ + 2 {return "$p $v $t"} \ + 3 {return "$p $q $v"} \ + 4 {return "$t $p $v"} \ + 5 {return "$v $p $q"} + error "i value $i is out of range" + } +} + +# The procedure below is invoked when the "Update" button is pressed, +# and whenever the color changes if update mode is enabled. It +# propagates color information as determined by the command in the +# Command entry. + +proc doUpdate {} { + global color command + set newCmd $command + regsub -all %% $command $color newCmd + eval $newCmd +} + +changeColorSpace hsb diff --git a/library/demos/text.tcl b/library/demos/text.tcl new file mode 100644 index 0000000..97df780 --- /dev/null +++ b/library/demos/text.tcl @@ -0,0 +1,76 @@ +# text.tcl -- +# +# This demonstration script creates a text widget that describes +# the basic editing functions. +# +# SCCS: @(#) text.tcl 1.6 97/03/02 16:28:12 + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +set w .text +catch {destroy $w} +toplevel $w +wm title $w "Text Demonstration - Basic Facilities" +wm iconname $w "text" +positionWindow $w + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +text $w.text -relief sunken -bd 2 -yscrollcommand "$w.scroll set" -setgrid 1 \ + -height 30 +scrollbar $w.scroll -command "$w.text yview" +pack $w.scroll -side right -fill y +pack $w.text -expand yes -fill both +$w.text insert 0.0 \ +{This window is a text widget. It displays one or more lines of text +and allows you to edit the text. Here is a summary of the things you +can do to a text widget: + +1. Scrolling. Use the scrollbar to adjust the view in the text window. + +2. Scanning. Press mouse button 2 in the text window and drag up or down. +This will drag the text at high speed to allow you to scan its contents. + +3. Insert text. Press mouse button 1 to set the insertion cursor, then +type text. What you type will be added to the widget. + +4. Select. Press mouse button 1 and drag to select a range of characters. +Once you've released the button, you can adjust the selection by pressing +button 1 with the shift key down. This will reset the end of the +selection nearest the mouse cursor and you can drag that end of the +selection by dragging the mouse before releasing the mouse button. +You can double-click to select whole words or triple-click to select +whole lines. + +5. Delete and replace. To delete text, select the characters you'd like +to delete and type Backspace or Delete. Alternatively, you can type new +text, in which case it will replace the selected text. + +6. Copy the selection. To copy the selection into this window, select +what you want to copy (either here or in another application), then +click button 2 to copy the selection to the point of the mouse cursor. + +7. Edit. Text widgets support the standard Motif editing characters +plus many Emacs editing characters. Backspace and Control-h erase the +character to the left of the insertion cursor. Delete and Control-d +erase the character to the right of the insertion cursor. Meta-backspace +deletes the word to the left of the insertion cursor, and Meta-d deletes +the word to the right of the insertion cursor. Control-k deletes from +the insertion cursor to the end of the line, or it deletes the newline +character if that is the only thing left on the line. Control-o opens +a new line by inserting a newline character to the right of the insertion +cursor. Control-t transposes the two characters on either side of the +insertion cursor. + +7. Resize the window. This widget has been configured with the "setGrid" +option on, so that if you resize the window it will always resize to an +even number of characters high and wide. Also, if you make the window +narrow you can see that long lines automatically wrap around onto +additional lines so that all the information is always visible.} +$w.text mark set insert 0.0 diff --git a/library/demos/timer b/library/demos/timer new file mode 100644 index 0000000..b2edd11 --- /dev/null +++ b/library/demos/timer @@ -0,0 +1,40 @@ +#!/bin/sh +# the next line restarts using wish \ +exec wish "$0" "$@" + +# timer -- +# This script generates a counter with start and stop buttons. +# +# SCCS: @(#) timer 1.6 96/02/16 10:49:20 + +label .counter -text 0.00 -relief raised -width 10 +button .start -text Start -command { + if $stopped { + set stopped 0 + tick + } +} +button .stop -text Stop -command {set stopped 1} +pack .counter -side bottom -fill both +pack .start -side left -fill both -expand yes +pack .stop -side right -fill both -expand yes + +set seconds 0 +set hundredths 0 +set stopped 1 + +proc tick {} { + global seconds hundredths stopped + if $stopped return + after 50 tick + set hundredths [expr $hundredths+5] + if {$hundredths >= 100} { + set hundredths 0 + set seconds [expr $seconds+1] + } + .counter config -text [format "%d.%02d" $seconds $hundredths] +} + +bind . {destroy .} +bind . {destroy .} +focus . diff --git a/library/demos/twind.tcl b/library/demos/twind.tcl new file mode 100644 index 0000000..75e732c --- /dev/null +++ b/library/demos/twind.tcl @@ -0,0 +1,196 @@ +# twind.tcl -- +# +# This demonstration script creates a text widget with a bunch of +# embedded windows. +# +# SCCS: @(#) twind.tcl 1.7 97/03/02 16:28:22 + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +set w .twind +catch {destroy $w} +toplevel $w +wm title $w "Text Demonstration - Embedded Windows" +wm iconname $w "Embedded Windows" +positionWindow $w + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +frame $w.f -highlightthickness 2 -borderwidth 2 -relief sunken +set t $w.f.text +text $t -yscrollcommand "$w.scroll set" -setgrid true -font $font -width 70 \ + -height 35 -wrap word -highlightthickness 0 -borderwidth 0 +pack $t -expand yes -fill both +scrollbar $w.scroll -command "$t yview" +pack $w.scroll -side right -fill y +pack $w.f -expand yes -fill both +$t tag configure center -justify center -spacing1 5m -spacing3 5m +$t tag configure buttons -lmargin1 1c -lmargin2 1c -rmargin 1c \ + -spacing1 3m -spacing2 0 -spacing3 0 + +button $t.on -text "Turn On" -command "textWindOn $w" \ + -cursor top_left_arrow +button $t.off -text "Turn Off" -command "textWindOff $w" \ + -cursor top_left_arrow +button $t.click -text "Click Here" -command "textWindPlot $t" \ + -cursor top_left_arrow +button $t.delete -text "Delete" -command "textWindDel $w" \ + -cursor top_left_arrow + +$t insert end "A text widget can contain other widgets embedded " +$t insert end "it. These are called \"embedded windows\", " +$t insert end "and they can consist of arbitrary widgets. " +$t insert end "For example, here are two embedded button " +$t insert end "widgets. You can click on the first button to " +$t window create end -window $t.on +$t insert end " horizontal scrolling, which also turns off " +$t insert end "word wrapping. Or, you can click on the second " +$t insert end "button to\n" +$t window create end -window $t.off +$t insert end " horizontal scrolling and turn back on word wrapping.\n\n" + +$t insert end "Or, here is another example. If you " +$t window create end -window $t.click +$t insert end " a canvas displaying an x-y plot will appear right here." +$t mark set plot insert +$t mark gravity plot left +$t insert end " You can drag the data points around with the mouse, " +$t insert end "or you can click here to " +$t window create end -window $t.delete +$t insert end " the plot again.\n\n" + +$t insert end "You may also find it useful to put embedded windows in " +$t insert end "a text without any actual text. In this case the " +$t insert end "text widget acts like a geometry manager. For " +$t insert end "example, here is a collection of buttons laid out " +$t insert end "neatly into rows by the text widget. These buttons " +$t insert end "can be used to change the background color of the " +$t insert end "text widget (\"Default\" restores the color to " +$t insert end "its default). If you click on the button labeled " +$t insert end "\"Short\", it changes to a longer string so that " +$t insert end "you can see how the text widget automatically " +$t insert end "changes the layout. Click on the button again " +$t insert end "to restore the short string.\n" + +button $t.default -text Default -command "embDefBg $t" \ + -cursor top_left_arrow +$t window create end -window $t.default -padx 3 +global embToggle +set embToggle Short +checkbutton $t.toggle -textvariable embToggle -indicatoron 0 \ + -variable embToggle -onvalue "A much longer string" \ + -offvalue "Short" -cursor top_left_arrow -pady 5 -padx 2 +$t window create end -window $t.toggle -padx 3 -pady 2 +set i 1 +foreach color {AntiqueWhite3 Bisque1 Bisque2 Bisque3 Bisque4 + SlateBlue3 RoyalBlue1 SteelBlue2 DeepSkyBlue3 LightBlue1 + DarkSlateGray1 Aquamarine2 DarkSeaGreen2 SeaGreen1 + Yellow1 IndianRed1 IndianRed2 Tan1 Tan4} { + button $t.color$i -text $color -cursor top_left_arrow -command \ + "$t configure -bg $color" + $t window create end -window $t.color$i -padx 3 -pady 2 + incr i +} +$t tag add buttons $t.default end + +proc textWindOn w { + catch {destroy $w.scroll2} + set t $w.f.text + scrollbar $w.scroll2 -orient horizontal -command "$t xview" + pack $w.scroll2 -after $w.buttons -side bottom -fill x + $t configure -xscrollcommand "$w.scroll2 set" -wrap none +} + +proc textWindOff w { + catch {destroy $w.scroll2} + set t $w.f.text + $t configure -xscrollcommand {} -wrap word +} + +proc textWindPlot t { + set c $t.c + if [winfo exists $c] { + return + } + canvas $c -relief sunken -width 450 -height 300 -cursor top_left_arrow + + set font {Helvetica 18} + + $c create line 100 250 400 250 -width 2 + $c create line 100 250 100 50 -width 2 + $c create text 225 20 -text "A Simple Plot" -font $font -fill brown + + for {set i 0} {$i <= 10} {incr i} { + set x [expr {100 + ($i*30)}] + $c create line $x 250 $x 245 -width 2 + $c create text $x 254 -text [expr 10*$i] -anchor n -font $font + } + for {set i 0} {$i <= 5} {incr i} { + set y [expr {250 - ($i*40)}] + $c create line 100 $y 105 $y -width 2 + $c create text 96 $y -text [expr $i*50].0 -anchor e -font $font + } + + foreach point {{12 56} {20 94} {33 98} {32 120} {61 180} + {75 160} {98 223}} { + set x [expr {100 + (3*[lindex $point 0])}] + set y [expr {250 - (4*[lindex $point 1])/5}] + set item [$c create oval [expr $x-6] [expr $y-6] \ + [expr $x+6] [expr $y+6] -width 1 -outline black \ + -fill SkyBlue2] + $c addtag point withtag $item + } + + $c bind point "$c itemconfig current -fill red" + $c bind point "$c itemconfig current -fill SkyBlue2" + $c bind point <1> "embPlotDown $c %x %y" + $c bind point "$c dtag selected" + bind $c "embPlotMove $c %x %y" + while {[string first [$t get plot] " \t\n"] >= 0} { + $t delete plot + } + $t insert plot "\n" + $t window create plot -window $c + $t tag add center plot + $t insert plot "\n" +} + +set embPlot(lastX) 0 +set embPlot(lastY) 0 + +proc embPlotDown {w x y} { + global embPlot + $w dtag selected + $w addtag selected withtag current + $w raise current + set embPlot(lastX) $x + set embPlot(lastY) $y +} + +proc embPlotMove {w x y} { + global embPlot + $w move selected [expr $x-$embPlot(lastX)] [expr $y-$embPlot(lastY)] + set embPlot(lastX) $x + set embPlot(lastY) $y +} + +proc textWindDel w { + set t $w.f.text + if [winfo exists $t.c] { + $t delete $t.c + while {[string first [$t get plot] " \t\n"] >= 0} { + $t delete plot + } + $t insert plot " " + } +} + +proc embDefBg t { + $t configure -background [lindex [$t configure -background] 3] +} diff --git a/library/demos/vscale.tcl b/library/demos/vscale.tcl new file mode 100644 index 0000000..ed78ac0 --- /dev/null +++ b/library/demos/vscale.tcl @@ -0,0 +1,48 @@ +# vscale.tcl -- +# +# This demonstration script shows an example with a vertical scale. +# +# SCCS: @(#) vscale.tcl 1.4 97/03/02 16:28:34 + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +set w .vscale +catch {destroy $w} +toplevel $w +wm title $w "Vertical Scale Demonstration" +wm iconname $w "vscale" +positionWindow $w + +label $w.msg -font $font -wraplength 3.5i -justify left -text "An arrow and a vertical scale are displayed below. If you click or drag mouse button 1 in the scale, you can change the size of the arrow." +pack $w.msg -side top -padx .5c + +frame $w.buttons +pack $w.buttons -side bottom -fill x -pady 2m +button $w.buttons.dismiss -text Dismiss -command "destroy $w" +button $w.buttons.code -text "See Code" -command "showCode $w" +pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 + +frame $w.frame -borderwidth 10 +pack $w.frame + +scale $w.frame.scale -orient vertical -length 284 -from 0 -to 250 \ + -command "setHeight $w.frame.canvas" -tickinterval 50 +canvas $w.frame.canvas -width 50 -height 50 -bd 0 -highlightthickness 0 +$w.frame.canvas create polygon 0 0 1 1 2 2 -fill SeaGreen3 -tags poly +$w.frame.canvas create line 0 0 1 1 2 2 0 0 -fill black -tags line +frame $w.frame.right -borderwidth 15 +pack $w.frame.scale -side left -anchor ne +pack $w.frame.canvas -side left -anchor nw -fill y +$w.frame.scale set 75 + +proc setHeight {w height} { + incr height 21 + set y2 [expr $height - 30] + if {$y2 < 21} { + set y2 21 + } + $w coords poly 15 20 35 20 35 $y2 45 $y2 25 $height 5 $y2 15 $y2 15 20 + $w coords line 15 20 35 20 35 $y2 45 $y2 25 $height 5 $y2 15 $y2 15 20 +} diff --git a/library/demos/widget b/library/demos/widget new file mode 100644 index 0000000..05c89cd --- /dev/null +++ b/library/demos/widget @@ -0,0 +1,391 @@ +#!/bin/sh +# the next line restarts using wish \ +exec wish "$0" "$@" + +# widget -- +# This script demonstrates the various widgets provided by Tk, +# along with many of the features of the Tk toolkit. This file +# only contains code to generate the main window for the +# application, which invokes individual demonstrations. The +# code for the actual demonstrations is contained in separate +# ".tcl" files is this directory, which are sourced by this script +# as needed. +# +# SCCS: @(#) widget 1.35 97/07/19 15:42:22 + +eval destroy [winfo child .] +wm title . "Widget Demonstration" +set widgetDemo 1 + +#---------------------------------------------------------------- +# The code below create the main window, consisting of a menu bar +# and a text widget that explains how to use the program, plus lists +# all of the demos as hypertext items. +#---------------------------------------------------------------- + +set font {Helvetica 14} +menu .menuBar -tearoff 0 +.menuBar add cascade -menu .menuBar.file -label "File" -underline 0 +menu .menuBar.file -tearoff 0 + +# On the Mac use the specia .apple menu for the about item +if {$tcl_platform(platform) == "macintosh"} { + .menuBar add cascade -menu .menuBar.apple + menu .menuBar.apple -tearoff 0 + .menuBar.apple add command -label "About..." -command "aboutBox" +} else { + .menuBar.file add command -label "About..." -command "aboutBox" \ + -underline 0 -accelerator "" + .menuBar.file add sep +} + +.menuBar.file add command -label "Quit" -command "exit" -underline 0 \ + -accelerator "Meta-Q" +. configure -menu .menuBar +bind . aboutBox + +frame .statusBar +label .statusBar.lab -text " " -relief sunken -bd 1 \ + -font -*-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -anchor w +label .statusBar.foo -width 8 -relief sunken -bd 1 \ + -font -*-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* -anchor w +pack .statusBar.lab -side left -padx 2 -expand yes -fill both +pack .statusBar.foo -side left -padx 2 +pack .statusBar -side bottom -fill x -pady 2 + +frame .textFrame +scrollbar .s -orient vertical -command {.t yview} -highlightthickness 0 \ + -takefocus 1 +pack .s -in .textFrame -side right -fill y +text .t -yscrollcommand {.s set} -wrap word -width 60 -height 30 -font $font \ + -setgrid 1 -highlightthickness 0 -padx 4 -pady 2 -takefocus 0 +pack .t -in .textFrame -expand y -fill both -padx 1 +pack .textFrame -expand yes -fill both + +# Create a bunch of tags to use in the text widget, such as those for +# section titles and demo descriptions. Also define the bindings for +# tags. + +.t tag configure title -font {Helvetica 18 bold} + +# We put some "space" characters to the left and right of each demo description +# so that the descriptions are highlighted only when the mouse cursor +# is right over them (but not when the cursor is to their left or right) +# +.t tag configure demospace -lmargin1 1c -lmargin2 1c + + +if {[winfo depth .] == 1} { + .t tag configure demo -lmargin1 1c -lmargin2 1c \ + -underline 1 + .t tag configure visited -lmargin1 1c -lmargin2 1c \ + -underline 1 + .t tag configure hot -background black -foreground white +} else { + .t tag configure demo -lmargin1 1c -lmargin2 1c \ + -foreground blue -underline 1 + .t tag configure visited -lmargin1 1c -lmargin2 1c \ + -foreground #303080 -underline 1 + .t tag configure hot -foreground red -underline 1 +} +.t tag bind demo { + invoke [.t index {@%x,%y}] +} +set lastLine "" +.t tag bind demo { + set lastLine [.t index {@%x,%y linestart}] + .t tag add hot "$lastLine +1 chars" "$lastLine lineend -1 chars" + .t config -cursor hand2 + showStatus [.t index {@%x,%y}] +} +.t tag bind demo { + .t tag remove hot 1.0 end + .t config -cursor xterm + .statusBar.lab config -text "" +} +.t tag bind demo { + set newLine [.t index {@%x,%y linestart}] + if {[string compare $newLine $lastLine] != 0} { + .t tag remove hot 1.0 end + set lastLine $newLine + + set tags [.t tag names {@%x,%y}] + set i [lsearch -glob $tags demo-*] + if {$i >= 0} { + .t tag add hot "$lastLine +1 chars" "$lastLine lineend -1 chars" + } + } + showStatus [.t index {@%x,%y}] +} + +# Create the text for the text widget. + +.t insert end "Tk Widget Demonstrations\n" title +.t insert end { +This application provides a front end for several short scripts that demonstrate what you can do with Tk widgets. Each of the numbered lines below describes a demonstration; you can click on it to invoke the demonstration. Once the demonstration window appears, you can click the "See Code" button to see the Tcl/Tk code that created the demonstration. If you wish, you can edit the code and click the "Rerun Demo" button in the code window to reinvoke the demonstration with the modified code. + +} +.t insert end "Labels, buttons, checkbuttons, and radiobuttons" title +.t insert end " \n " {demospace} +.t insert end "1. Labels (text and bitmaps)." {demo demo-label} +.t insert end " \n " {demospace} +.t insert end "2. Buttons." {demo demo-button} +.t insert end " \n " {demospace} +.t insert end "3. Checkbuttons (select any of a group)." {demo demo-check} +.t insert end " \n " {demospace} +.t insert end "4. Radiobuttons (select one of a group)." {demo demo-radio} +.t insert end " \n " {demospace} +.t insert end "5. A 15-puzzle game made out of buttons." {demo demo-puzzle} +.t insert end " \n " {demospace} +.t insert end "6. Iconic buttons that use bitmaps." {demo demo-icon} +.t insert end " \n " {demospace} +.t insert end "7. Two labels displaying images." {demo demo-image1} +.t insert end " \n " {demospace} +.t insert end "8. A simple user interface for viewing images." \ + {demo demo-image2} +.t insert end " \n " {demospace} + +.t insert end \n {} "Listboxes" title +.t insert end " \n " {demospace} +.t insert end "1. 50 states." {demo demo-states} +.t insert end " \n " {demospace} +.t insert end "2. Colors: change the color scheme for the application." \ + {demo demo-colors} +.t insert end " \n " {demospace} +.t insert end "3. A collection of famous sayings." {demo demo-sayings} +.t insert end " \n " {demospace} + +.t insert end \n {} "Entries" title +.t insert end " \n " {demospace} +.t insert end "1. Without scrollbars." {demo demo-entry1} +.t insert end " \n " {demospace} +.t insert end "2. With scrollbars." {demo demo-entry2} +.t insert end " \n " {demospace} +.t insert end "3. Simple Rolodex-like form." {demo demo-form} +.t insert end " \n " {demospace} + +.t insert end \n {} "Text" title +.t insert end " \n " {demospace} +.t insert end "1. Basic editable text." {demo demo-text} +.t insert end " \n " {demospace} +.t insert end "2. Text display styles." {demo demo-style} +.t insert end " \n " {demospace} +.t insert end "3. Hypertext (tag bindings)." {demo demo-bind} +.t insert end " \n " {demospace} +.t insert end "4. A text widget with embedded windows." {demo demo-twind} +.t insert end " \n " {demospace} +.t insert end "5. A search tool built with a text widget." {demo demo-search} +.t insert end " \n " {demospace} + +.t insert end \n {} "Canvases" title +.t insert end " \n " {demospace} +.t insert end "1. The canvas item types." {demo demo-items} +.t insert end " \n " {demospace} +.t insert end "2. A simple 2-D plot." {demo demo-plot} +.t insert end " \n " {demospace} +.t insert end "3. Text items in canvases." {demo demo-ctext} +.t insert end " \n " {demospace} +.t insert end "4. An editor for arrowheads on canvas lines." {demo demo-arrow} +.t insert end " \n " {demospace} +.t insert end "5. A ruler with adjustable tab stops." {demo demo-ruler} +.t insert end " \n " {demospace} +.t insert end "6. A building floor plan." {demo demo-floor} +.t insert end " \n " {demospace} +.t insert end "7. A simple scrollable canvas." {demo demo-cscroll} +.t insert end " \n " {demospace} + +.t insert end \n {} "Scales" title +.t insert end " \n " {demospace} +.t insert end "1. Vertical scale." {demo demo-vscale} +.t insert end " \n " {demospace} +.t insert end "2. Horizontal scale." {demo demo-hscale} +.t insert end " \n " {demospace} + +.t insert end \n {} "Menus" title +.t insert end " \n " {demospace} +.t insert end "1. Menus and cascades." \ + {demo demo-menu} +.t insert end " \n " {demospace} +.t insert end "2. Menubuttons"\ + {demo demo-menubu} +.t insert end " \n " {demospace} + +.t insert end \n {} "Common Dialogs" title +.t insert end " \n " {demospace} +.t insert end "1. Message boxes." {demo demo-msgbox} +.t insert end " \n " {demospace} +.t insert end "2. File selection dialog." {demo demo-filebox} +.t insert end " \n " {demospace} +.t insert end "3. Color picker." {demo demo-clrpick} +.t insert end " \n " {demospace} + +.t insert end \n {} "Miscellaneous" title +.t insert end " \n " {demospace} +.t insert end "1. The built-in bitmaps." {demo demo-bitmap} +.t insert end " \n " {demospace} +.t insert end "2. A dialog box with a local grab." {demo demo-dialog1} +.t insert end " \n " {demospace} +.t insert end "3. A dialog box with a global grab." {demo demo-dialog2} +.t insert end " \n " {demospace} + +.t configure -state disabled +focus .s + +# positionWindow -- +# This procedure is invoked by most of the demos to position a +# new demo window. +# +# Arguments: +# w - The name of the window to position. + +proc positionWindow w { + wm geometry $w +300+300 +} + +# showVars -- +# Displays the values of one or more variables in a window, and +# updates the display whenever any of the variables changes. +# +# Arguments: +# w - Name of new window to create for display. +# args - Any number of names of variables. + +proc showVars {w args} { + catch {destroy $w} + toplevel $w + wm title $w "Variable values" + label $w.title -text "Variable values:" -width 20 -anchor center \ + -font {Helvetica 18} + pack $w.title -side top -fill x + set len 1 + foreach i $args { + if {[string length $i] > $len} { + set len [string length $i] + } + } + foreach i $args { + frame $w.$i + label $w.$i.name -text "$i: " -width [expr $len + 2] -anchor w + label $w.$i.value -textvar $i -anchor w + pack $w.$i.name -side left + pack $w.$i.value -side left -expand 1 -fill x + pack $w.$i -side top -anchor w -fill x + } + button $w.ok -text OK -command "destroy $w" -default active + bind $w "tkButtonInvoke $w.ok" + pack $w.ok -side bottom -pady 2 +} + +# invoke -- +# This procedure is called when the user clicks on a demo description. +# It is responsible for invoking the demonstration. +# +# Arguments: +# index - The index of the character that the user clicked on. + +proc invoke index { + global tk_library + set tags [.t tag names $index] + set i [lsearch -glob $tags demo-*] + if {$i < 0} { + return + } + set cursor [.t cget -cursor] + .t configure -cursor watch + update + set demo [string range [lindex $tags $i] 5 end] + uplevel [list source [file join $tk_library demos $demo.tcl]] + update + .t configure -cursor $cursor + + .t tag add visited "$index linestart +1 chars" "$index lineend -1 chars" +} + +# showStatus -- +# +# Show the name of the demo program in the status bar. This procedure +# is called when the user moves the cursor over a demo description. +# +proc showStatus index { + global tk_library + set tags [.t tag names $index] + set i [lsearch -glob $tags demo-*] + set cursor [.t cget -cursor] + if {$i < 0} { + .statusBar.lab config -text " " + set newcursor xterm + } else { + set demo [string range [lindex $tags $i] 5 end] + .statusBar.lab config -text "Run the \"$demo\" sample program" + set newcursor hand2 + } + if [string compare $cursor $newcursor] { + .t config -cursor $newcursor + } +} + + +# showCode -- +# This procedure creates a toplevel window that displays the code for +# a demonstration and allows it to be edited and reinvoked. +# +# Arguments: +# w - The name of the demonstration's window, which can be +# used to derive the name of the file containing its code. + +proc showCode w { + global tk_library + set file [string range $w 1 end].tcl + if ![winfo exists .code] { + toplevel .code + frame .code.buttons + pack .code.buttons -side bottom -fill x + button .code.buttons.dismiss -text Dismiss \ + -default active -command "destroy .code" + button .code.buttons.rerun -text "Rerun Demo" -command { + eval [.code.text get 1.0 end] + } + pack .code.buttons.dismiss .code.buttons.rerun -side left \ + -expand 1 -pady 2 + frame .code.frame + pack .code.frame -expand yes -fill both -padx 1 -pady 1 + text .code.text -height 40 -wrap word\ + -xscrollcommand ".code.xscroll set" \ + -yscrollcommand ".code.yscroll set" \ + -setgrid 1 -highlightthickness 0 -pady 2 -padx 3 + scrollbar .code.xscroll -command ".code.text xview" \ + -highlightthickness 0 -orient horizontal + scrollbar .code.yscroll -command ".code.text yview" \ + -highlightthickness 0 -orient vertical + + grid .code.text -in .code.frame -padx 1 -pady 1 \ + -row 0 -column 0 -rowspan 1 -columnspan 1 -sticky news + grid .code.yscroll -in .code.frame -padx 1 -pady 1 \ + -row 0 -column 1 -rowspan 1 -columnspan 1 -sticky news +# grid .code.xscroll -in .code.frame -padx 1 -pady 1 \ +# -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news + grid rowconfig .code.frame 0 -weight 1 -minsize 0 + grid columnconfig .code.frame 0 -weight 1 -minsize 0 + } else { + wm deiconify .code + raise .code + } + wm title .code "Demo code: [file join $tk_library demos $file]" + wm iconname .code $file + set id [open [file join $tk_library demos $file]] + .code.text delete 1.0 end + .code.text insert 1.0 [read $id] + .code.text mark set insert 1.0 + close $id +} + +# aboutBox -- +# +# Pops up a message box with an "about" message +# +proc aboutBox {} { + tk_messageBox -icon info -type ok -title "About Widget Demo" -message \ +"Tk widget demonstration\n\n\ +Copyright (c) 1996-1997 Sun Microsystems, Inc." +} + diff --git a/library/dialog.tcl b/library/dialog.tcl new file mode 100644 index 0000000..a9fcfa5 --- /dev/null +++ b/library/dialog.tcl @@ -0,0 +1,174 @@ +# dialog.tcl -- +# +# 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 +# +# Copyright (c) 1992-1993 The Regents of the University of California. +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +# +# tk_dialog: +# +# This procedure displays a dialog box, waits for a button in the dialog +# to be invoked, then returns the index of the selected button. If the +# dialog somehow gets destroyed, -1 is returned. +# +# Arguments: +# w - Window to use for dialog top-level. +# title - Title to display in dialog's decorative frame. +# text - Message to display in dialog. +# bitmap - Bitmap to display in dialog (empty string means none). +# default - Index of button that is to display the default ring +# (-1 means none). +# args - One or more strings to display in buttons across the +# bottom of the dialog box. + +proc tk_dialog {w title text bitmap default args} { + global tkPriv tcl_platform + + # 1. Create the top-level window and divide it into top + # and bottom parts. + + catch {destroy $w} + toplevel $w -class Dialog + wm title $w $title + wm iconname $w Dialog + wm protocol $w WM_DELETE_WINDOW { } + + # The following command means that the dialog won't be posted if + # [winfo parent $w] is iconified, but it's really needed; otherwise + # the dialog can become obscured by other windows in the application, + # even though its grab keeps the rest of the application from being used. + + wm transient $w [winfo toplevel [winfo parent $w]] + if {$tcl_platform(platform) == "macintosh"} { + unsupported1 style $w dBoxProc + } + + frame $w.bot + frame $w.top + if {$tcl_platform(platform) == "unix"} { + $w.bot configure -relief raised -bd 1 + $w.top configure -relief raised -bd 1 + } + pack $w.bot -side bottom -fill both + 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). + + option add *Dialog.msg.wrapLength 3i widgetDefault + label $w.msg -justify left -text $text + if {$tcl_platform(platform) == "macintosh"} { + $w.msg configure -font system + } else { + $w.msg configure -font {Times 18} + } + 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")} { + set bitmap "stop" + } + label $w.bitmap -bitmap $bitmap + pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m + } + + # 3. Create a row of buttons at the bottom of the dialog. + + set i 0 + foreach but $args { + button $w.button$i -text $but -command "set tkPriv(button) $i" + if {$i == $default} { + $w.button$i configure -default active + } else { + $w.button$i configure -default normal + } + grid $w.button$i -in $w.bot -column $i -row 0 -sticky ew -padx 10 + grid columnconfigure $w.bot $i + # We boost the size of some Mac buttons for l&f + if {$tcl_platform(platform) == "macintosh"} { + set tmp [string tolower $but] + if {($tmp == "ok") || ($tmp == "cancel")} { + grid columnconfigure $w.bot $i -minsize [expr 59 + 20] + } + } + incr i + } + + # 4. Create a binding for on the dialog if there is a + # default button. + + if {$default >= 0} { + bind $w " + $w.button$default configure -state active -relief sunken + update idletasks + after 100 + set tkPriv(button) $default + " + } + + # 5. Create a binding for the window that sets the + # button variable to -1; this is needed in case something happens + # that destroys the window, such as its parent window being destroyed. + + bind $w {set tkPriv(button) -1} + + # 6. 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]]] + wm geom $w +$x+$y + wm deiconify $w + + # 7. 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 + if {$default >= 0} { + focus $w.button$default + } else { + focus $w + } + + # 8. 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(button) + catch {focus $oldFocus} + catch { + # It's possible that the window has already been destroyed, + # hence this "catch". Delete the Destroy handler so that + # tkPriv(button) doesn't get reset by it. + + bind $w {} + destroy $w + } + if {$oldGrab != ""} { + if {$grabStatus == "global"} { + grab -global $oldGrab + } else { + grab $oldGrab + } + } + return $tkPriv(button) +} diff --git a/library/entry.tcl b/library/entry.tcl new file mode 100644 index 0000000..4a0b764 --- /dev/null +++ b/library/entry.tcl @@ -0,0 +1,607 @@ +# entry.tcl -- +# +# 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 +# +# Copyright (c) 1992-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. +# + +#------------------------------------------------------------------------- +# Elements of tkPriv that are used in this file: +# +# afterId - If non-null, it means that auto-scanning is underway +# and it gives the "after" id for the next auto-scan +# command to be executed. +# mouseMoved - Non-zero means the mouse has moved a significant +# amount since the button went down (so, for example, +# start dragging out a selection). +# pressX - X-coordinate at which the mouse button was pressed. +# selectMode - The style of selection currently underway: +# char, word, or line. +# x, y - Last known mouse coordinates for scanning +# and auto-scanning. +#------------------------------------------------------------------------- + +#------------------------------------------------------------------------- +# The code below creates the default class bindings for entries. +#------------------------------------------------------------------------- + +bind Entry <> { + if {![catch {set data [string range [%W get] [%W index sel.first]\ + [expr [%W index sel.last] - 1]]}]} { + clipboard clear -displayof %W + clipboard append -displayof %W $data + %W delete sel.first sel.last + } +} +bind Entry <> { + if {![catch {set data [string range [%W get] [%W index sel.first]\ + [expr [%W index sel.last] - 1]]}]} { + clipboard clear -displayof %W + clipboard append -displayof %W $data + } +} +bind Entry <> { + global tcl_platform + catch { + if {"$tcl_platform(platform)" != "unix"} { + catch { + %W delete sel.first sel.last + } + } + %W insert insert [selection get -displayof %W -selection CLIPBOARD] + tkEntrySeeInsert %W + } +} +bind Entry <> { + %W delete sel.first sel.last +} + +# Standard Motif bindings: + +bind Entry <1> { + tkEntryButton1 %W %x + %W selection clear +} +bind Entry { + set tkPriv(x) %x + tkEntryMouseSelect %W %x +} +bind Entry { + set tkPriv(selectMode) word + tkEntryMouseSelect %W %x + catch {%W icursor sel.first} +} +bind Entry { + set tkPriv(selectMode) line + tkEntryMouseSelect %W %x + %W icursor 0 +} +bind Entry { + set tkPriv(selectMode) char + %W selection adjust @%x +} +bind Entry { + set tkPriv(selectMode) word + tkEntryMouseSelect %W %x +} +bind Entry { + set tkPriv(selectMode) line + tkEntryMouseSelect %W %x +} +bind Entry { + set tkPriv(x) %x + tkEntryAutoScan %W +} +bind Entry { + tkCancelRepeat +} +bind Entry { + tkCancelRepeat +} +bind Entry { + %W icursor @%x +} +bind Entry { + if {!$tkPriv(mouseMoved) || $tk_strictMotif} { + tkEntryPaste %W %x + } +} + +bind Entry { + tkEntrySetCursor %W [expr [%W index insert] - 1] +} +bind Entry { + tkEntrySetCursor %W [expr [%W index insert] + 1] +} +bind Entry { + tkEntryKeySelect %W [expr [%W index insert] - 1] + tkEntrySeeInsert %W +} +bind Entry { + tkEntryKeySelect %W [expr [%W index insert] + 1] + tkEntrySeeInsert %W +} +bind Entry { + tkEntrySetCursor %W [tkEntryPreviousWord %W insert] +} +bind Entry { + tkEntrySetCursor %W [tkEntryNextWord %W insert] +} +bind Entry { + tkEntryKeySelect %W [tkEntryPreviousWord %W insert] + tkEntrySeeInsert %W +} +bind Entry { + tkEntryKeySelect %W [tkEntryNextWord %W insert] + tkEntrySeeInsert %W +} +bind Entry { + tkEntrySetCursor %W 0 +} +bind Entry { + tkEntryKeySelect %W 0 + tkEntrySeeInsert %W +} +bind Entry { + tkEntrySetCursor %W end +} +bind Entry { + tkEntryKeySelect %W end + tkEntrySeeInsert %W +} + +bind Entry { + if [%W selection present] { + %W delete sel.first sel.last + } else { + %W delete insert + } +} +bind Entry { + tkEntryBackspace %W +} + +bind Entry { + %W selection from insert +} +bind Entry { + tkListboxBeginSelect %W [%W index active] +} +bind Listbox { + tkListboxBeginExtend %W [%W index active] +} +bind Listbox { + tkListboxBeginExtend %W [%W index active] +} +bind Listbox { + tkListboxCancel %W +} +bind Listbox { + tkListboxSelectAll %W +} +bind Listbox { + if {[%W cget -selectmode] != "browse"} { + %W selection clear 0 end + } +} + +# Additional Tk bindings that aren't part of the Motif look and feel: + +bind Listbox <2> { + %W scan mark %x %y +} +bind Listbox { + %W scan dragto %x %y +} + +# tkListboxBeginSelect -- +# +# This procedure is typically invoked on button-1 presses. It begins +# the process of making a selection in the listbox. Its exact behavior +# depends on the selection mode currently in effect for the listbox; +# see the Motif documentation for details. +# +# Arguments: +# w - The listbox widget. +# el - The element for the selection operation (typically the +# one under the pointer). Must be in numerical form. + +proc tkListboxBeginSelect {w el} { + global tkPriv + if {[$w cget -selectmode] == "multiple"} { + if [$w selection includes $el] { + $w selection clear $el + } else { + $w selection set $el + } + } else { + $w selection clear 0 end + $w selection set $el + $w selection anchor $el + set tkPriv(listboxSelection) {} + set tkPriv(listboxPrev) $el + } +} + +# tkListboxMotion -- +# +# This procedure is called to process mouse motion events while +# button 1 is down. It may move or extend the selection, depending +# on the listbox's selection mode. +# +# Arguments: +# w - The listbox widget. +# el - The element under the pointer (must be a number). + +proc tkListboxMotion {w el} { + global tkPriv + if {$el == $tkPriv(listboxPrev)} { + return + } + set anchor [$w index anchor] + switch [$w cget -selectmode] { + browse { + $w selection clear 0 end + $w selection set $el + set tkPriv(listboxPrev) $el + } + extended { + set i $tkPriv(listboxPrev) + if [$w selection includes anchor] { + $w selection clear $i $el + $w selection set anchor $el + } else { + $w selection clear $i $el + $w selection clear anchor $el + } + while {($i < $el) && ($i < $anchor)} { + if {[lsearch $tkPriv(listboxSelection) $i] >= 0} { + $w selection set $i + } + incr i + } + while {($i > $el) && ($i > $anchor)} { + if {[lsearch $tkPriv(listboxSelection) $i] >= 0} { + $w selection set $i + } + incr i -1 + } + set tkPriv(listboxPrev) $el + } + } +} + +# tkListboxBeginExtend -- +# +# This procedure is typically invoked on shift-button-1 presses. It +# begins the process of extending a selection in the listbox. Its +# exact behavior depends on the selection mode currently in effect +# for the listbox; see the Motif documentation for details. +# +# Arguments: +# w - The listbox widget. +# el - The element for the selection operation (typically the +# one under the pointer). Must be in numerical form. + +proc tkListboxBeginExtend {w el} { + if {[$w cget -selectmode] == "extended"} { + if {[$w selection includes anchor]} { + tkListboxMotion $w $el + } else { + # No selection yet; simulate the begin-select operation. + + tkListboxBeginSelect $w $el + } + } +} + +# tkListboxBeginToggle -- +# +# This procedure is typically invoked on control-button-1 presses. It +# begins the process of toggling a selection in the listbox. Its +# exact behavior depends on the selection mode currently in effect +# for the listbox; see the Motif documentation for details. +# +# Arguments: +# w - The listbox widget. +# el - The element for the selection operation (typically the +# one under the pointer). Must be in numerical form. + +proc tkListboxBeginToggle {w el} { + global tkPriv + if {[$w cget -selectmode] == "extended"} { + set tkPriv(listboxSelection) [$w curselection] + set tkPriv(listboxPrev) $el + $w selection anchor $el + if [$w selection includes $el] { + $w selection clear $el + } else { + $w selection set $el + } + } +} + +# tkListboxAutoScan -- +# This procedure is invoked when the mouse leaves an entry window +# with button 1 down. It scrolls the window up, down, left, or +# right, depending on where the mouse left the window, and reschedules +# itself as an "after" command so that the window continues to scroll until +# the mouse moves back into the window or the mouse button is released. +# +# Arguments: +# w - The entry window. + +proc tkListboxAutoScan {w} { + global tkPriv + if {![winfo exists $w]} return + set x $tkPriv(x) + set y $tkPriv(y) + if {$y >= [winfo height $w]} { + $w yview scroll 1 units + } elseif {$y < 0} { + $w yview scroll -1 units + } elseif {$x >= [winfo width $w]} { + $w xview scroll 2 units + } elseif {$x < 0} { + $w xview scroll -2 units + } else { + return + } + tkListboxMotion $w [$w index @$x,$y] + set tkPriv(afterId) [after 50 tkListboxAutoScan $w] +} + +# tkListboxUpDown -- +# +# Moves the location cursor (active element) up or down by one element, +# and changes the selection if we're in browse or extended selection +# mode. +# +# Arguments: +# w - The listbox widget. +# amount - +1 to move down one item, -1 to move back one item. + +proc tkListboxUpDown {w amount} { + global tkPriv + $w activate [expr [$w index active] + $amount] + $w see active + switch [$w cget -selectmode] { + browse { + $w selection clear 0 end + $w selection set active + } + extended { + $w selection clear 0 end + $w selection set active + $w selection anchor active + set tkPriv(listboxPrev) [$w index active] + set tkPriv(listboxSelection) {} + } + } +} + +# tkListboxExtendUpDown -- +# +# Does nothing unless we're in extended selection mode; in this +# case it moves the location cursor (active element) up or down by +# one element, and extends the selection to that point. +# +# Arguments: +# w - The listbox widget. +# amount - +1 to move down one item, -1 to move back one item. + +proc tkListboxExtendUpDown {w amount} { + if {[$w cget -selectmode] != "extended"} { + return + } + $w activate [expr [$w index active] + $amount] + $w see active + tkListboxMotion $w [$w index active] +} + +# tkListboxDataExtend +# +# This procedure is called for key-presses such as Shift-KEndData. +# If the selection mode isn't multiple or extend then it does nothing. +# Otherwise it moves the active element to el and, if we're in +# extended mode, extends the selection to that point. +# +# Arguments: +# w - The listbox widget. +# el - An integer element number. + +proc tkListboxDataExtend {w el} { + set mode [$w cget -selectmode] + if {$mode == "extended"} { + $w activate $el + $w see $el + if [$w selection includes anchor] { + tkListboxMotion $w $el + } + } elseif {$mode == "multiple"} { + $w activate $el + $w see $el + } +} + +# tkListboxCancel +# +# This procedure is invoked to cancel an extended selection in +# progress. If there is an extended selection in progress, it +# restores all of the items between the active one and the anchor +# to their previous selection state. +# +# Arguments: +# w - The listbox widget. + +proc tkListboxCancel w { + global tkPriv + if {[$w cget -selectmode] != "extended"} { + return + } + set first [$w index anchor] + set last $tkPriv(listboxPrev) + if {$first > $last} { + set tmp $first + set first $last + set last $tmp + } + $w selection clear $first $last + while {$first <= $last} { + if {[lsearch $tkPriv(listboxSelection) $first] >= 0} { + $w selection set $first + } + incr first + } +} + +# tkListboxSelectAll +# +# This procedure is invoked to handle the "select all" operation. +# For single and browse mode, it just selects the active element. +# Otherwise it selects everything in the widget. +# +# Arguments: +# w - The listbox widget. + +proc tkListboxSelectAll w { + set mode [$w cget -selectmode] + if {($mode == "single") || ($mode == "browse")} { + $w selection clear 0 end + $w selection set active + } else { + $w selection set 0 end + } +} diff --git a/library/menu.tcl b/library/menu.tcl new file mode 100644 index 0000000..21b69d9 --- /dev/null +++ b/library/menu.tcl @@ -0,0 +1,1235 @@ +# menu.tcl -- +# +# This file defines the default bindings for Tk menus and menubuttons. +# 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 +# +# Copyright (c) 1992-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. +# + +#------------------------------------------------------------------------- +# Elements of tkPriv that are used in this file: +# +# cursor - Saves the -cursor option for the posted menubutton. +# focus - Saves the focus during a menu selection operation. +# Focus gets restored here when the menu is unposted. +# grabGlobal - Used in conjunction with tkPriv(oldGrab): if +# tkPriv(oldGrab) is non-empty, then tkPriv(grabGlobal) +# contains either an empty string or "-global" to +# indicate whether the old grab was a local one or +# a global one. +# inMenubutton - The name of the menubutton widget containing +# the mouse, or an empty string if the mouse is +# not over any menubutton. +# menuBar - The name of the menubar that is the root +# of the cascade hierarchy which is currently +# posted. This is null when there is no menu currently +# being pulled down from a menu bar. +# oldGrab - Window that had the grab before a menu was posted. +# Used to restore the grab state after the menu +# is unposted. Empty string means there was no +# grab previously set. +# popup - If a menu has been popped up via tk_popup, this +# gives the name of the menu. Otherwise this +# value is empty. +# postedMb - Name of the menubutton whose menu is currently +# posted, or an empty string if nothing is posted +# A grab is set on this widget. +# relief - Used to save the original relief of the current +# menubutton. +# window - When the mouse is over a menu, this holds the +# name of the menu; it's cleared when the mouse +# leaves the menu. +# tearoff - Whether the last menu posted was a tearoff or not. +# This is true always for unix, for tearoffs for Mac +# and Windows. +# activeMenu - This is the last active menu for use +# with the <> virtual event. +# activeItem - This is the last active menu item for +# use with the <> virtual event. +#------------------------------------------------------------------------- + +#------------------------------------------------------------------------- +# Overall note: +# This file is tricky because there are five different ways that menus +# can be used: +# +# 1. As a pulldown from a menubutton. In this style, the variable +# tkPriv(postedMb) identifies the posted menubutton. +# 2. As a torn-off menu copied from some other menu. In this style +# tkPriv(postedMb) is empty, and menu's type is "tearoff". +# 3. As an option menu, triggered from an option menubutton. In this +# style tkPriv(postedMb) identifies the posted menubutton. +# 4. As a popup menu. In this style tkPriv(postedMb) is empty and +# the top-level menu's type is "normal". +# 5. As a pulldown from a menubar. The variable tkPriv(menubar) has +# the owning menubar, and the menu itself is of type "normal". +# +# The various binding procedures use the state described above to +# distinguish the various cases and take different actions in each +# case. +#------------------------------------------------------------------------- + +#------------------------------------------------------------------------- +# The code below creates the default class bindings for menus +# and menubuttons. +#------------------------------------------------------------------------- + +bind Menubutton {} +bind Menubutton { + tkMbEnter %W +} +bind Menubutton { + tkMbLeave %W +} +bind Menubutton <1> { + if {$tkPriv(inMenubutton) != ""} { + tkMbPost $tkPriv(inMenubutton) %X %Y + } +} +bind Menubutton { + tkMbMotion %W up %X %Y +} +bind Menubutton { + tkMbMotion %W down %X %Y +} +bind Menubutton { + tkMbButtonUp %W +} +bind Menubutton { + tkMbPost %W + tkMenuFirstEntry [%W cget -menu] +} + +# Must set focus when mouse enters a menu, in order to allow +# mixed-mode processing using both the mouse and the keyboard. +# Don't set the focus if the event comes from a grab release, +# though: such an event can happen after as part of unposting +# a cascaded chain of menus, after the focus has already been +# restored to wherever it was before menu selection started. + +bind Menu {} + +bind Menu { + set tkPriv(window) %W + if {[%W cget -type] == "tearoff"} { + if {"%m" != "NotifyUngrab"} { + if {$tcl_platform(platform) == "unix"} { + tk_menuSetFocus %W + } + } + } + tkMenuMotion %W %x %y %s +} + +bind Menu { + tkMenuLeave %W %X %Y %s +} +bind Menu { + tkMenuMotion %W %x %y %s +} +bind Menu { + tkMenuButtonDown %W +} +bind Menu { + tkMenuInvoke %W 1 +} +bind Menu { + tkMenuInvoke %W 0 +} +bind Menu { + tkMenuInvoke %W 0 +} +bind Menu { + tkMenuEscape %W +} +bind Menu { + tkMenuLeftArrow %W +} +bind Menu { + tkMenuRightArrow %W +} +bind Menu { + tkMenuUpArrow %W +} +bind Menu { + tkMenuDownArrow %W +} +bind Menu { + tkTraverseWithinMenu %W %A +} + +# The following bindings apply to all windows, and are used to +# implement keyboard menu traversal. + +if {$tcl_platform(platform) == "unix"} { + bind all { + tkTraverseToMenu %W %A + } + + bind all { + tkFirstMenu %W + } +} else { + bind Menubutton { + tkTraverseToMenu %W %A + } + + bind Menubutton { + tkFirstMenu %W + } +} + +# tkMbEnter -- +# This procedure is invoked when the mouse enters a menubutton +# widget. It activates the widget unless it is disabled. Note: +# this procedure is only invoked when mouse button 1 is *not* down. +# The procedure tkMbB1Enter is invoked if the button is down. +# +# Arguments: +# w - The name of the widget. + +proc tkMbEnter w { + global tkPriv + + if {$tkPriv(inMenubutton) != ""} { + tkMbLeave $tkPriv(inMenubutton) + } + set tkPriv(inMenubutton) $w + if {[$w cget -state] != "disabled"} { + $w configure -state active + } +} + +# tkMbLeave -- +# This procedure is invoked when the mouse leaves a menubutton widget. +# It de-activates the widget, if the widget still exists. +# +# Arguments: +# w - The name of the widget. + +proc tkMbLeave w { + global tkPriv + + set tkPriv(inMenubutton) {} + if ![winfo exists $w] { + return + } + if {[$w cget -state] == "active"} { + $w configure -state normal + } +} + +# tkMbPost -- +# Given a menubutton, this procedure does all the work of posting +# its associated menu and unposting any other menu that is currently +# posted. +# +# Arguments: +# w - The name of the menubutton widget whose menu +# is to be posted. +# x, y - Root coordinates of cursor, used for positioning +# option menus. If not specified, then the center +# of the menubutton is used for an option menu. + +proc tkMbPost {w {x {}} {y {}}} { + global tkPriv errorInfo + global tcl_platform + + if {([$w cget -state] == "disabled") || ($w == $tkPriv(postedMb))} { + return + } + set menu [$w cget -menu] + if {$menu == ""} { + return + } + set tearoff [expr {($tcl_platform(platform) == "unix") \ + || ([$menu cget -type] == "tearoff")}] + if {[string first $w $menu] != 0} { + error "can't post $menu: it isn't a descendant of $w (this is a new requirement in Tk versions 3.0 and later)" + } + set cur $tkPriv(postedMb) + if {$cur != ""} { + tkMenuUnpost {} + } + set tkPriv(cursor) [$w cget -cursor] + set tkPriv(relief) [$w cget -relief] + $w configure -cursor arrow + $w configure -relief raised + + set tkPriv(postedMb) $w + set tkPriv(focus) [focus] + $menu activate none + tkGenerateMenuSelect $menu + + # If this looks like an option menubutton then post the menu so + # that the current entry is on top of the mouse. Otherwise post + # the menu just below the menubutton, as for a pull-down. + + update idletasks + if [catch { + switch [$w cget -direction] { + above { + set x [winfo rootx $w] + 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]] + $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 entry [tkMenuFindName $menu [$w cget -text]] + if [$w cget -indicatoron] { + if {$entry == [$menu index last]} { + incr y [expr -([$menu yposition $entry] \ + + [winfo reqheight $menu])/2] + } else { + incr y [expr -([$menu yposition $entry] \ + + [$menu yposition [expr $entry+1]])/2] + } + } + $menu post $x $y + if {($entry != {}) && ([$menu entrycget $entry -state] != "disabled")} { + $menu activate $entry + tkGenerateMenuSelect $menu + } + } + right { + 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 {$entry == [$menu index last]} { + incr y [expr -([$menu yposition $entry] \ + + [winfo reqheight $menu])/2] + } else { + incr y [expr -([$menu yposition $entry] \ + + [$menu yposition [expr $entry+1]])/2] + } + } + $menu post $x $y + if {($entry != {}) && ([$menu entrycget $entry -state] != "disabled")} { + $menu activate $entry + tkGenerateMenuSelect $menu + } + } + default { + 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] + } + tkPostOverPoint $menu $x $y [tkMenuFindName $menu [$w cget -text]] + } else { + $menu post [winfo rootx $w] [expr [winfo rooty $w]+[winfo height $w]] + } + } + } + } msg] { + # Error posting menu (e.g. bogus -postcommand). Unpost it and + # reflect the error. + + set savedInfo $errorInfo + tkMenuUnpost {} + error $msg $savedInfo + + } + + set tkPriv(tearoff) $tearoff + if {$tearoff != 0} { + focus $menu + tkSaveGrabInfo $w + grab -global $w + } +} + +# tkMenuUnpost -- +# This procedure unposts a given menu, plus all of its ancestors up +# to (and including) a menubutton, if any. It also restores various +# values to what they were before the menu was posted, and releases +# a grab if there's a menubutton involved. Special notes: +# 1. It's important to unpost all menus before releasing the grab, so +# that any Enter-Leave events (e.g. from menu back to main +# application) have mode NotifyGrab. +# 2. Be sure to enclose various groups of commands in "catch" so that +# the procedure will complete even if the menubutton or the menu +# or the grab window has been deleted. +# +# Arguments: +# menu - Name of a menu to unpost. Ignored if there +# is a posted menubutton. + +proc tkMenuUnpost menu { + global tcl_platform + global tkPriv + set mb $tkPriv(postedMb) + + # Restore focus right away (otherwise X will take focus away when + # the menu is unmapped and under some window managers (e.g. olvwm) + # we'll lose the focus completely). + + catch {focus $tkPriv(focus)} + set tkPriv(focus) "" + + # Unpost menu(s) and restore some stuff that's dependent on + # what was posted. + + catch { + if {$mb != ""} { + set menu [$mb cget -menu] + $menu unpost + set tkPriv(postedMb) {} + $mb configure -cursor $tkPriv(cursor) + $mb configure -relief $tkPriv(relief) + } elseif {$tkPriv(popup) != ""} { + $tkPriv(popup) unpost + set tkPriv(popup) {} + } elseif {(!([$menu cget -type] == "menubar") + && !([$menu cget -type] == "tearoff"))} { + # We're in a cascaded sub-menu from a torn-off menu or popup. + # Unpost all the menus up to the toplevel one (but not + # including the top-level torn-off one) and deactivate the + # top-level torn off menu if there is one. + + while 1 { + set parent [winfo parent $menu] + if {([winfo class $parent] != "Menu") + || ![winfo ismapped $parent]} { + break + } + $parent activate none + $parent postcascade none + tkGenerateMenuSelect $parent + set type [$parent cget -type] + if {($type == "menubar")|| ($type == "tearoff")} { + break + } + set menu $parent + } + if {[$menu cget -type] != "menubar"} { + $menu unpost + } + } + } + + if {($tkPriv(tearoff) != 0) || ($tkPriv(menuBar) != "")} { + # Release grab, if any, and restore the previous grab, if there + # was one. + + if {$menu != ""} { + set grab [grab current $menu] + if {$grab != ""} { + grab release $grab + } + } + tkRestoreOldGrab + if {$tkPriv(menuBar) != ""} { + $tkPriv(menuBar) configure -cursor $tkPriv(cursor) + set tkPriv(menuBar) {} + } + if {$tcl_platform(platform) != "unix"} { + set tkPriv(tearoff) 0 + } + } +} + +# tkMbMotion -- +# This procedure handles mouse motion events inside menubuttons, and +# also outside menubuttons when a menubutton has a grab (e.g. when a +# menu selection operation is in progress). +# +# Arguments: +# w - The name of the menubutton widget. +# upDown - "down" means button 1 is pressed, "up" means +# it isn't. +# rootx, rooty - Coordinates of mouse, in (virtual?) root window. + +proc tkMbMotion {w upDown rootx rooty} { + global tkPriv + + if {$tkPriv(inMenubutton) == $w} { + return + } + set new [winfo containing $rootx $rooty] + if {($new != $tkPriv(inMenubutton)) && (($new == "") + || ([winfo toplevel $new] == [winfo toplevel $w]))} { + if {$tkPriv(inMenubutton) != ""} { + tkMbLeave $tkPriv(inMenubutton) + } + if {($new != "") && ([winfo class $new] == "Menubutton") + && ([$new cget -indicatoron] == 0) + && ([$w cget -indicatoron] == 0)} { + if {$upDown == "down"} { + tkMbPost $new $rootx $rooty + } else { + tkMbEnter $new + } + } + } +} + +# tkMbButtonUp -- +# This procedure is invoked to handle button 1 releases for menubuttons. +# If the release happens inside the menubutton then leave its menu +# posted with element 0 activated. Otherwise, unpost the menu. +# +# Arguments: +# w - The name of the menubutton widget. + +proc tkMbButtonUp w { + global tkPriv + global tcl_platform + + set tearoff [expr {($tcl_platform(platform) == "unix") \ + || ([[$w cget -menu] cget -type] == "tearoff")}] + if {($tearoff != 0) && ($tkPriv(postedMb) == $w) + && ($tkPriv(inMenubutton) == $w)} { + tkMenuFirstEntry [$tkPriv(postedMb) cget -menu] + } else { + tkMenuUnpost {} + } +} + +# tkMenuMotion -- +# This procedure is called to handle mouse motion events for menus. +# It does two things. First, it resets the active element in the +# menu, if the mouse is over the menu. Second, if a mouse button +# is down, it posts and unposts cascade entries to match the mouse +# position. +# +# Arguments: +# menu - The menu window. +# x - The x position of the mouse. +# y - The y position of the mouse. +# state - Modifier state (tells whether buttons are down). + +proc tkMenuMotion {menu x y state} { + global tkPriv + if {$menu == $tkPriv(window)} { + if {[$menu cget -type] == "menubar"} { + if {[info exists tkPriv(focus)] && \ + ([string compare $menu $tkPriv(focus)] != 0)} { + $menu activate @$x,$y + tkGenerateMenuSelect $menu + } + } else { + $menu activate @$x,$y + tkGenerateMenuSelect $menu + } + } + if {($state & 0x1f00) != 0} { + $menu postcascade active + } +} + +# tkMenuButtonDown -- +# Handles button presses in menus. There are a couple of tricky things +# here: +# 1. Change the posted cascade entry (if any) to match the mouse position. +# 2. If there is a posted menubutton, must grab to the menubutton; this +# overrrides the implicit grab on button press, so that the menu +# button can track mouse motions over other menubuttons and change +# the posted menu. +# 3. If there's no posted menubutton (e.g. because we're a torn-off menu +# or one of its descendants) must grab to the top-level menu so that +# we can track mouse motions across the entire menu hierarchy. +# +# Arguments: +# menu - The menu window. + +proc tkMenuButtonDown menu { + global tkPriv + global tcl_platform + $menu postcascade active + if {$tkPriv(postedMb) != ""} { + grab -global $tkPriv(postedMb) + } else { + while {([$menu cget -type] == "normal") + && ([winfo class [winfo parent $menu]] == "Menu") + && [winfo ismapped [winfo parent $menu]]} { + set menu [winfo parent $menu] + } + + if {$tkPriv(menuBar) == {}} { + set tkPriv(menuBar) $menu + set tkPriv(cursor) [$menu cget -cursor] + $menu configure -cursor arrow + } + + # Don't update grab information if the grab window isn't changing. + # Otherwise, we'll get an error when we unpost the menus and + # restore the grab, since the old grab window will not be viewable + # anymore. + + if {$menu != [grab current $menu]} { + tkSaveGrabInfo $menu + } + + # Must re-grab even if the grab window hasn't changed, in order + # to release the implicit grab from the button press. + + if {$tcl_platform(platform) == "unix"} { + grab -global $menu + } + } +} + +# tkMenuLeave -- +# This procedure is invoked to handle Leave events for a menu. It +# deactivates everything unless the active element is a cascade element +# and the mouse is now over the submenu. +# +# Arguments: +# menu - The menu window. +# rootx, rooty - Root coordinates of mouse. +# state - Modifier state. + +proc tkMenuLeave {menu rootx rooty state} { + global tkPriv + set tkPriv(window) {} + if {[$menu index active] == "none"} { + return + } + if {([$menu type active] == "cascade") + && ([winfo containing $rootx $rooty] + == [$menu entrycget active -menu])} { + return + } + $menu activate none + tkGenerateMenuSelect $menu +} + +# tkMenuInvoke -- +# This procedure is invoked when button 1 is released over a menu. +# It invokes the appropriate menu action and unposts the menu if +# it came from a menubutton. +# +# Arguments: +# w - Name of the menu widget. +# buttonRelease - 1 means this procedure is called because of +# a button release; 0 means because of keystroke. + +proc tkMenuInvoke {w buttonRelease} { + global tkPriv + + if {$buttonRelease && ($tkPriv(window) == "")} { + # Mouse was pressed over a menu without a menu button, then + # dragged off the menu (possibly with a cascade posted) and + # released. Unpost everything and quit. + + $w postcascade none + $w activate none + event generate $w <> + tkMenuUnpost $w + return + } + if {[$w type active] == "cascade"} { + $w postcascade active + set menu [$w entrycget active -menu] + tkMenuFirstEntry $menu + } elseif {[$w type active] == "tearoff"} { + tkMenuUnpost $w + tkTearOffMenu $w + } elseif {[$w cget -type] == "menubar"} { + $w postcascade none + $w activate none + event generate $w <> + tkMenuUnpost $w + } else { + tkMenuUnpost $w + uplevel #0 [list $w invoke active] + } +} + +# tkMenuEscape -- +# This procedure is invoked for the Cancel (or Escape) key. It unposts +# the given menu and, if it is the top-level menu for a menu button, +# unposts the menu button as well. +# +# Arguments: +# menu - Name of the menu window. + +proc tkMenuEscape menu { + set parent [winfo parent $menu] + if {([winfo class $parent] != "Menu")} { + tkMenuUnpost $menu + } elseif {([$parent cget -type] == "menubar")} { + tkMenuUnpost $menu + tkRestoreOldGrab + } else { + tkMenuNextMenu $menu left + } +} + +# The following routines handle arrow keys. Arrow keys behave +# differently depending on whether the menu is a menu bar or not. + +proc tkMenuUpArrow {menu} { + if {[$menu cget -type] == "menubar"} { + tkMenuNextMenu $menu left + } else { + tkMenuNextEntry $menu -1 + } +} + +proc tkMenuDownArrow {menu} { + if {[$menu cget -type] == "menubar"} { + tkMenuNextMenu $menu right + } else { + tkMenuNextEntry $menu 1 + } +} + +proc tkMenuLeftArrow {menu} { + if {[$menu cget -type] == "menubar"} { + tkMenuNextEntry $menu -1 + } else { + tkMenuNextMenu $menu left + } +} + +proc tkMenuRightArrow {menu} { + if {[$menu cget -type] == "menubar"} { + tkMenuNextEntry $menu 1 + } else { + tkMenuNextMenu $menu right + } +} + +# tkMenuNextMenu -- +# This procedure is invoked to handle "left" and "right" traversal +# motions in menus. It traverses to the next menu in a menu bar, +# or into or out of a cascaded menu. +# +# Arguments: +# menu - The menu that received the keyboard +# event. +# direction - Direction in which to move: "left" or "right" + +proc tkMenuNextMenu {menu direction} { + global tkPriv + + # First handle traversals into and out of cascaded menus. + + if {$direction == "right"} { + set count 1 + set parent [winfo parent $menu] + set class [winfo class $parent] + if {[$menu type active] == "cascade"} { + $menu postcascade active + set m2 [$menu entrycget active -menu] + if {$m2 != ""} { + tkMenuFirstEntry $m2 + } + return + } else { + set parent [winfo parent $menu] + while {($parent != ".")} { + if {([winfo class $parent] == "Menu") + && ([$parent cget -type] == "menubar")} { + tk_menuSetFocus $parent + tkMenuNextEntry $parent 1 + return + } + set parent [winfo parent $parent] + } + } + } else { + set count -1 + set m2 [winfo parent $menu] + if {[winfo class $m2] == "Menu"} { + if {[$m2 cget -type] != "menubar"} { + $menu activate none + tkGenerateMenuSelect $menu + tk_menuSetFocus $m2 + + # This code unposts any posted submenu in the parent. + + set tmp [$m2 index active] + $m2 activate none + $m2 activate $tmp + return + } + } + } + + # Can't traverse into or out of a cascaded menu. Go to the next + # or previous menubutton, if that makes sense. + + set m2 [winfo parent $menu] + if {[winfo class $m2] == "Menu"} { + if {[$m2 cget -type] == "menubar"} { + tk_menuSetFocus $m2 + tkMenuNextEntry $m2 -1 + return + } + } + + set w $tkPriv(postedMb) + if {$w == ""} { + return + } + set buttons [winfo children [winfo parent $w]] + set length [llength $buttons] + set i [expr [lsearch -exact $buttons $w] + $count] + while 1 { + while {$i < 0} { + incr i $length + } + while {$i >= $length} { + incr i -$length + } + set mb [lindex $buttons $i] + if {([winfo class $mb] == "Menubutton") + && ([$mb cget -state] != "disabled") + && ([$mb cget -menu] != "") + && ([[$mb cget -menu] index last] != "none")} { + break + } + if {$mb == $w} { + return + } + incr i $count + } + tkMbPost $mb + tkMenuFirstEntry [$mb cget -menu] +} + +# tkMenuNextEntry -- +# Activate the next higher or lower entry in the posted menu, +# wrapping around at the ends. Disabled entries are skipped. +# +# Arguments: +# menu - Menu window that received the keystroke. +# count - 1 means go to the next lower entry, +# -1 means go to the next higher entry. + +proc tkMenuNextEntry {menu count} { + global tkPriv + + if {[$menu index last] == "none"} { + return + } + 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] + } + while 1 { + if {$quitAfter <= 0} { + # We've tried every entry in the menu. Either there are + # none, or they're all disabled. Just give up. + + return + } + while {$i < 0} { + incr i $length + } + while {$i >= $length} { + incr i -$length + } + if {[catch {$menu entrycget $i -state} state] == 0} { + if {$state != "disabled"} { + break + } + } + if {$i == $active} { + return + } + incr i $count + incr quitAfter -1 + } + $menu activate $i + tkGenerateMenuSelect $menu + if {[$menu type $i] == "cascade"} { + set cascade [$menu entrycget $i -menu] + if {[string compare $cascade ""] != 0} { + $menu postcascade $i + tkMenuFirstEntry $cascade + } + } +} + +# tkMenuFind -- +# This procedure searches the entire window hierarchy under w for +# a menubutton that isn't disabled and whose underlined character +# is "char" or an entry in a menubar that isn't disabled and whose +# underlined character is "char". +# It returns the name of that window, if found, or an +# empty string if no matching window was found. If "char" is an +# empty string then the procedure returns the name of the first +# menubutton found that isn't disabled. +# +# Arguments: +# w - Name of window where key was typed. +# char - Underlined character to search for; +# may be either upper or lower case, and +# will match either upper or lower case. + +proc tkMenuFind {w char} { + global tkPriv + set char [string tolower $char] + set windowlist [winfo child $w] + + foreach child $windowlist { + switch [winfo class $child] { + Menu { + if {[$child cget -type] == "menubar"} { + if {$char == ""} { + return $child + } + set last [$child index last] + for {set i [$child cget -tearoff]} {$i <= $last} {incr i} { + if {[$child type $i] == "separator"} { + continue + } + set char2 [string index [$child entrycget $i -label] \ + [$child entrycget $i -underline]] + if {([string compare $char [string tolower $char2]] \ + == 0) || ($char == "")} { + if {[$child entrycget $i -state] != "disabled"} { + return $child + } + } + } + } + } + } + } + + foreach child $windowlist { + switch [winfo class $child] { + Menubutton { + set char2 [string index [$child cget -text] \ + [$child cget -underline]] + if {([string compare $char [string tolower $char2]] == 0) + || ($char == "")} { + if {[$child cget -state] != "disabled"} { + return $child + } + } + } + + default { + set match [tkMenuFind $child $char] + if {$match != ""} { + return $match + } + } + } + } + return {} +} + +# tkTraverseToMenu -- +# This procedure implements keyboard traversal of menus. Given an +# ASCII character "char", it looks for a menubutton with that character +# underlined. If one is found, it posts the menubutton's menu +# +# Arguments: +# w - Window in which the key was typed (selects +# a toplevel window). +# char - Character that selects a menu. The case +# is ignored. If an empty string, nothing +# happens. + +proc tkTraverseToMenu {w char} { + global tkPriv + if {$char == ""} { + return + } + while {[winfo class $w] == "Menu"} { + if {([$w cget -type] != "menubar") && ($tkPriv(postedMb) == "")} { + return + } + if {[$w cget -type] == "menubar"} { + break + } + set w [winfo parent $w] + } + set w [tkMenuFind [winfo toplevel $w] $char] + if {$w != ""} { + if {[winfo class $w] == "Menu"} { + tk_menuSetFocus $w + set tkPriv(window) $w + tkSaveGrabInfo $w + grab -global $w + tkTraverseWithinMenu $w $char + } else { + tkMbPost $w + tkMenuFirstEntry [$w cget -menu] + } + } +} + +# tkFirstMenu -- +# This procedure traverses to the first menubutton in the toplevel +# for a given window, and posts that menubutton's menu. +# +# Arguments: +# w - Name of a window. Selects which toplevel +# to search for menubuttons. + +proc tkFirstMenu w { + set w [tkMenuFind [winfo toplevel $w] ""] + if {$w != ""} { + if {[winfo class $w] == "Menu"} { + tk_menuSetFocus $w + set tkPriv(window) $w + tkSaveGrabInfo $w + grab -global $w + tkMenuFirstEntry $w + } else { + tkMbPost $w + tkMenuFirstEntry [$w cget -menu] + } + } +} + +# tkTraverseWithinMenu +# This procedure implements keyboard traversal within a menu. It +# searches for an entry in the menu that has "char" underlined. If +# such an entry is found, it is invoked and the menu is unposted. +# +# Arguments: +# w - The name of the menu widget. +# char - The character to look for; case is +# ignored. If the string is empty then +# nothing happens. + +proc tkTraverseWithinMenu {w char} { + if {$char == ""} { + return + } + set char [string tolower $char] + set last [$w index last] + if {$last == "none"} { + return + } + for {set i 0} {$i <= $last} {incr i} { + if [catch {set char2 [string index \ + [$w entrycget $i -label] \ + [$w entrycget $i -underline]]}] { + continue + } + if {[string compare $char [string tolower $char2]] == 0} { + if {[$w type $i] == "cascade"} { + $w activate $i + $w postcascade active + event generate $w <> + set m2 [$w entrycget $i -menu] + if {$m2 != ""} { + tkMenuFirstEntry $m2 + } + } else { + tkMenuUnpost $w + uplevel #0 [list $w invoke $i] + } + return + } + } +} + +# tkMenuFirstEntry -- +# Given a menu, this procedure finds the first entry that isn't +# disabled or a tear-off or separator, and activates that entry. +# However, if there is already an active entry in the menu (e.g., +# because of a previous call to tkPostOverPoint) then the active +# entry isn't changed. This procedure also sets the input focus +# to the menu. +# +# Arguments: +# menu - Name of the menu window (possibly empty). + +proc tkMenuFirstEntry menu { + if {$menu == ""} { + return + } + tk_menuSetFocus $menu + if {[$menu index active] != "none"} { + return + } + set last [$menu index last] + if {$last == "none"} { + return + } + for {set i 0} {$i <= $last} {incr i} { + if {([catch {set state [$menu entrycget $i -state]}] == 0) + && ($state != "disabled") && ([$menu type $i] != "tearoff")} { + $menu activate $i + tkGenerateMenuSelect $menu + if {[$menu type $i] == "cascade"} { + set cascade [$menu entrycget $i -menu] + if {[string compare $cascade ""] != 0} { + $menu postcascade $i + tkMenuFirstEntry $cascade + } + } + return + } + } +} + +# tkMenuFindName -- +# Given a menu and a text string, return the index of the menu entry +# that displays the string as its label. If there is no such entry, +# return an empty string. This procedure is tricky because some names +# like "active" have a special meaning in menu commands, so we can't +# always use the "index" widget command. +# +# Arguments: +# menu - Name of the menu widget. +# s - String to look for. + +proc tkMenuFindName {menu s} { + set i "" + if {![regexp {^active$|^last$|^none$|^[0-9]|^@} $s]} { + catch {set i [$menu index $s]} + return $i + } + set last [$menu index last] + if {$last == "none"} { + return + } + for {set i 0} {$i <= $last} {incr i} { + if ![catch {$menu entrycget $i -label} label] { + if {$label == $s} { + return $i + } + } + } + return "" +} + +# tkPostOverPoint -- +# This procedure posts a given menu such that a given entry in the +# menu is centered over a given point in the root window. It also +# activates the given entry. +# +# Arguments: +# menu - Menu to post. +# x, y - Root coordinates of point. +# entry - Index of entry within menu to center over (x,y). +# If omitted or specified as {}, then the menu's +# upper-left corner goes at (x,y). + +proc tkPostOverPoint {menu x y {entry {}}} { + global tcl_platform + + if {$entry != {}} { + if {$entry == [$menu index last]} { + incr y [expr -([$menu yposition $entry] \ + + [winfo reqheight $menu])/2] + } else { + incr y [expr -([$menu yposition $entry] \ + + [$menu yposition [expr $entry+1]])/2] + } + incr x [expr -[winfo reqwidth $menu]/2] + } + $menu post $x $y + if {($entry != {}) && ([$menu entrycget $entry -state] != "disabled")} { + $menu activate $entry + tkGenerateMenuSelect $menu + } +} + +# tkSaveGrabInfo -- +# Sets the variables tkPriv(oldGrab) and tkPriv(grabStatus) to record +# the state of any existing grab on the w's display. +# +# Arguments: +# w - Name of a window; used to select the display +# whose grab information is to be recorded. + +proc tkSaveGrabInfo w { + global tkPriv + set tkPriv(oldGrab) [grab current $w] + if {$tkPriv(oldGrab) != ""} { + set tkPriv(grabStatus) [grab status $tkPriv(oldGrab)] + } +} + +# tkRestoreOldGrab -- +# Restores the grab to what it was before TkSaveGrabInfo was called. +# + +proc tkRestoreOldGrab {} { + global tkPriv + + if {$tkPriv(oldGrab) != ""} { + + # Be careful restoring the old grab, since it's window may not + # be visible anymore. + + catch { + if {$tkPriv(grabStatus) == "global"} { + grab set -global $tkPriv(oldGrab) + } else { + grab set $tkPriv(oldGrab) + } + } + set tkPriv(oldGrab) "" + } +} + +proc tk_menuSetFocus {menu} { + global tkPriv + if {![info exists tkPriv(focus)] || [string length $tkPriv(focus)] == 0} { + set tkPriv(focus) [focus] + } + focus $menu +} + +proc tkGenerateMenuSelect {menu} { + global tkPriv + + if {([string compare $tkPriv(activeMenu) $menu] == 0) \ + && ([string compare $tkPriv(activeItem) [$menu index active]] \ + == 0)} { + return + } + + set tkPriv(activeMenu) $menu + set tkPriv(activeItem) [$menu index active] + event generate $menu <> +} + +# tk_popup -- +# This procedure pops up a menu and sets things up for traversing +# the menu and its submenus. +# +# Arguments: +# menu - Name of the menu to be popped up. +# x, y - Root coordinates at which to pop up the +# menu. +# entry - Index of a menu entry to center over (x,y). +# If omitted or specified as {}, then menu's +# upper-left corner goes at (x,y). + +proc tk_popup {menu x y {entry {}}} { + global tkPriv + global tcl_platform + if {($tkPriv(popup) != "") || ($tkPriv(postedMb) != "")} { + tkMenuUnpost {} + } + tkPostOverPoint $menu $x $y $entry + if {$tcl_platform(platform) == "unix"} { + tkSaveGrabInfo $menu + grab -global $menu + set tkPriv(popup) $menu + tk_menuSetFocus $menu + } +} diff --git a/library/msgbox.tcl b/library/msgbox.tcl new file mode 100644 index 0000000..07df82b --- /dev/null +++ b/library/msgbox.tcl @@ -0,0 +1,257 @@ +# msgbox.tcl -- +# +# Implements messageboxes for platforms that do not have native +# messagebox support. +# +# SCCS: @(#) msgbox.tcl 1.8 97/07/28 17:20:01 +# +# 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. +# + + +# tkMessageBox -- +# +# Pops up a messagebox with an application-supplied message with +# an icon and a list of buttons. This procedure will be called +# by tk_messageBox if the platform does not have native +# messagebox support, or if the particular type of messagebox is +# not supported natively. +# +# This procedure is a private procedure shouldn't be called +# directly. Call tk_messageBox instead. +# +# See the user documentation for details on what tk_messageBox does. +# +proc tkMessageBox {args} { + global tkPriv tcl_platform + + set w tkPrivMsgBox + upvar #0 $w data + + # + # The default value of the title is space (" ") not the empty string + # because for some window managers, a + # wm title .foo "" + # causes the window title to be "foo" instead of the empty string. + # + set specs { + {-default "" "" ""} + {-icon "" "" "info"} + {-message "" "" ""} + {-parent "" "" .} + {-title "" "" " "} + {-type "" "" "ok"} + } + + 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" + } + if {$tcl_platform(platform) == "macintosh"} { + if {$data(-icon) == "error"} { + set data(-icon) "stop" + } elseif {$data(-icon) == "warning"} { + set data(-icon) "caution" + } elseif {$data(-icon) == "info"} { + set data(-icon) "note" + } + } + + if ![winfo exists $data(-parent)] { + error "bad window path name \"$data(-parent)\"" + } + + case $data(-type) { + abortretryignore { + set buttons { + {abort -width 6 -text Abort -under 0} + {retry -width 6 -text Retry -under 0} + {ignore -width 6 -text Ignore -under 0} + } + } + ok { + set buttons { + {ok -width 6 -text OK -under 0} + } + if {$data(-default) == ""} { + set data(-default) "ok" + } + } + okcancel { + set buttons { + {ok -width 6 -text OK -under 0} + {cancel -width 6 -text Cancel -under 0} + } + } + retrycancel { + set buttons { + {retry -width 6 -text Retry -under 0} + {cancel -width 6 -text Cancel -under 0} + } + } + yesno { + set buttons { + {yes -width 6 -text Yes -under 0} + {no -width 6 -text No -under 0} + } + } + yesnocancel { + set buttons { + {yes -width 6 -text Yes -under 0} + {no -width 6 -text No -under 0} + {cancel -width 6 -text Cancel -under 0} + } + } + default { + error "invalid message box type \"$data(-type)\", must be abortretryignore, ok, okcancel, retrycancel, yesno or yesnocancel" + } + } + + if [string compare $data(-default) ""] { + set valid 0 + foreach btn $buttons { + if ![string compare [lindex $btn 0] $data(-default)] { + set valid 1 + break + } + } + if !$valid { + error "invalid default button \"$data(-default)\"" + } + } + + # 2. Set the dialog to be a child window of $parent + # + # + if [string compare $data(-parent) .] { + set w $data(-parent).__tk__messagebox + } else { + set w .__tk__messagebox + } + + # 3. Create the top-level window and divide it into top + # and bottom parts. + + catch {destroy $w} + toplevel $w -class Dialog + wm title $w $data(-title) + wm iconname $w Dialog + wm protocol $w WM_DELETE_WINDOW { } + wm transient $w $data(-parent) + if {$tcl_platform(platform) == "macintosh"} { + unsupported1 style $w dBoxProc + } + + frame $w.bot + pack $w.bot -side bottom -fill both + frame $w.top + pack $w.top -side top -fill both -expand 1 + if {$tcl_platform(platform) != "macintosh"} { + $w.bot configure -relief raised -bd 1 + $w.top configure -relief raised -bd 1 + } + + # 4. Fill the top part with bitmap and message (use the option + # database for -wraplength so that it 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-*-*-*-*-*-* + } + 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) + pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m + } + + # 5. Create a row of buttons at the bottom of the dialog. + + set i 0 + foreach but $buttons { + set name [lindex $but 0] + set opts [lrange $but 1 end] + if ![string compare $opts {}] { + # Capitalize the first letter of $name + set capName \ + [string toupper \ + [string index $name 0]][string range $name 1 end] + set opts [list -text $capName] + } + + eval button $w.$name $opts -command [list "set tkPriv(button) $name"] + + if ![string compare $name $data(-default)] { + $w.$name configure -default active + } + pack $w.$name -in $w.bot -side left -expand 1 \ + -padx 3m -pady 2m + + # create the binding for the key accelerator, based on the underline + # + set underIdx [$w.$name cget -under] + if {$underIdx >= 0} { + set key [string index [$w.$name cget -text] $underIdx] + bind $w "$w.$name invoke" + bind $w "$w.$name invoke" + } + incr i + } + + # 6. Create a binding for on the dialog if there is a + # default button. + + if [string compare $data(-default) ""] { + bind $w "tkButtonInvoke $w.$data(-default)" + } + + # 7. 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]]] + wm geom $w +$x+$y + wm deiconify $w + + # 8. 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 + if [string compare $data(-default) ""] { + focus $w.$data(-default) + } else { + focus $w + } + + # 9. 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(button) + catch {focus $oldFocus} + destroy $w + if {$oldGrab != ""} { + if {$grabStatus == "global"} { + grab -global $oldGrab + } else { + grab $oldGrab + } + } + return $tkPriv(button) +} diff --git a/library/obsolete.tcl b/library/obsolete.tcl new file mode 100644 index 0000000..7fc1fb3 --- /dev/null +++ b/library/obsolete.tcl @@ -0,0 +1,21 @@ +# obsolete.tcl -- +# +# This file contains obsolete procedures that people really shouldn't +# be using anymore, but which are kept around for backward compatibility. +# +# SCCS: @(#) obsolete.tcl 1.3 96/02/16 10:48:19 +# +# Copyright (c) 1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +# The procedures below are here strictly for backward compatibility with +# Tk version 3.6 and earlier. The procedures are no longer needed, so +# they are no-ops. You should not use these procedures anymore, since +# they may be removed in some future release. + +proc tk_menuBar args {} +proc tk_bindForTraversal args {} diff --git a/library/optMenu.tcl b/library/optMenu.tcl new file mode 100644 index 0000000..32ca096c --- /dev/null +++ b/library/optMenu.tcl @@ -0,0 +1,45 @@ +# optMenu.tcl -- +# +# 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 +# +# Copyright (c) 1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +# tk_optionMenu -- +# This procedure creates an option button named $w and an associated +# menu. Together they provide the functionality of Motif option menus: +# they can be used to select one of many values, and the current value +# appears in the global variable varName, as well as in the text of +# the option menubutton. The name of the menu is returned as the +# procedure's result, so that the caller can use it to change configuration +# options on the menu or otherwise manipulate it. +# +# Arguments: +# w - The name to use for the menubutton. +# varName - Global variable to hold the currently selected value. +# firstValue - First of legal values for option (must be >= 1). +# args - Any number of additional values. + +proc tk_optionMenu {w varName firstValue args} { + upvar #0 $varName var + + if ![info exists var] { + set var $firstValue + } + menubutton $w -textvariable $varName -indicatoron 1 -menu $w.menu \ + -relief raised -bd 2 -highlightthickness 2 -anchor c \ + -direction flush + menu $w.menu -tearoff 0 + $w.menu add radiobutton -label $firstValue -variable $varName + foreach i $args { + $w.menu add radiobutton -label $i -variable $varName + } + return $w.menu +} diff --git a/library/palette.tcl b/library/palette.tcl new file mode 100644 index 0000000..5d5318e --- /dev/null +++ b/library/palette.tcl @@ -0,0 +1,222 @@ +# palette.tcl -- +# +# This file contains procedures that change the color palette used +# by Tk. +# +# SCCS: @(#) palette.tcl 1.11 97/06/23 20:35:44 +# +# 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. +# + +# tk_setPalette -- +# Changes the default color scheme for a Tk application by setting +# default colors in the option database and by modifying all of the +# color options for existing widgets that have the default value. +# +# Arguments: +# The arguments consist of either a single color name, which +# will be used as the new background color (all other colors will +# be computed from this) or an even number of values consisting of +# option names and values. The name for an option is the one used +# for the option database, such as activeForeground, not -activeforeground. + +proc tk_setPalette {args} { + global tkPalette + + # Create an array that has the complete new palette. If some colors + # aren't specified, compute them from other colors that are specified. + + if {[llength $args] == 1} { + set new(background) [lindex $args 0] + } else { + array set new $args + } + if ![info exists new(background)] { + error "must specify a background color" + } + 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]] + foreach i {activeForeground insertBackground selectForeground \ + highlightColor} { + if ![info exists new($i)] { + set new($i) $new(foreground) + } + } + 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]] + } + if ![info exists new(highlightBackground)] { + set new(highlightBackground) $new(background) + } + 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] + if {$inc1 > $inc2} { + incr light($i) $inc1 + } else { + incr light($i) $inc2 + } + if {$light($i) > 255} { + set light($i) 255 + } + } + set new(activeBackground) [format #%02x%02x%02x $light(0) \ + $light(1) $light(2)] + } + if ![info exists new(selectBackground)] { + set new(selectBackground) $darkerBg + } + if ![info exists new(troughColor)] { + set new(troughColor) $darkerBg + } + if ![info exists new(selectColor)] { + set new(selectColor) #b03060 + } + + # let's make one of each of the widgets so we know what the + # defaults are currently for this platform. + toplevel .___tk_set_palette + wm withdraw .___tk_set_palette + foreach q {button canvas checkbutton entry frame label listbox menubutton menu message \ + radiobutton scale scrollbar text} { + $q .___tk_set_palette.$q + } + + # Walk the widget hierarchy, recoloring all existing windows. + # The option database must be set according to what we do here, + # but it breaks things if we set things in the database while + # we are changing colors...so, tkRecolorTree now returns the + # option database changes that need to be made, and they + # need to be evalled here to take effect. + # We have to walk the whole widget tree instead of just + # relying on the widgets we've created above to do the work + # because different extensions may provide other kinds + # of widgets that we don't currently know about, so we'll + # walk the whole hierarchy just in case. + + eval [tkRecolorTree . new] + + catch {destroy .___tk_set_palette} + + # Change the option database so that future windows will get the + # same colors. + + foreach option [array names new] { + option add *$option $new($option) widgetDefault + } + + # Save the options in the global variable tkPalette, for use the + # next time we change the options. + + array set tkPalette [array get new] +} + +# tkRecolorTree -- +# This procedure changes the colors in a window and all of its +# descendants, according to information provided by the colors +# argument. This looks at the defaults provided by the option +# database, if it exists, and if not, then it looks at the default +# value of the widget itself. +# +# Arguments: +# w - The name of a window. This window and all its +# descendants are recolored. +# colors - The name of an array variable in the caller, +# which contains color information. Each element +# is named after a widget configuration option, and +# each value is the value for that option. + +proc tkRecolorTree {w colors} { + global tkPalette + upvar $colors c + set result {} + foreach dbOption [array names c] { + set option -[string tolower $dbOption] + if {![catch {$w config $option} value]} { + # if the option database has a preference for this + # dbOption, then use it, otherwise use the defaults + # for the widget. + set defaultcolor [option get $w $dbOption widgetDefault] + if {[string match {} $defaultcolor]} { + set defaultcolor [winfo rgb . [lindex $value 3]] + } else { + set defaultcolor [winfo rgb . $defaultcolor] + } + set chosencolor [winfo rgb . [lindex $value 4]] + if {[string match $defaultcolor $chosencolor]} { + # Change the option database so that future windows will get + # the same colors. + append result ";\noption add [list \ + *[winfo class $w].$dbOption $c($dbOption) 60]" + $w configure $option $c($dbOption) + } + } + } + foreach child [winfo children $w] { + append result ";\n[tkRecolorTree $child c]" + } + return $result +} + +# tkDarken -- +# Given a color name, computes a new color value that darkens (or +# brightens) the given color by a given percent. +# +# Arguments: +# color - Name of starting color. +# perecent - Integer telling how much to brighten or darken as a +# percent: 50 means darken by 50%, 110 means brighten +# by 10%. + +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] + if {$red > 255} { + set red 255 + } + set green [expr ($green*$percent)/100] + if {$green > 255} { + set green 255 + } + set blue [expr ($blue*$percent)/100] + if {$blue > 255} { + set blue 255 + } + format #%02x%02x%02x $red $green $blue +} + +# tk_bisque -- +# Reset the Tk color palette to the old "bisque" colors. +# +# Arguments: +# None. + +proc tk_bisque {} { + tk_setPalette activeBackground #e6ceb1 activeForeground black \ + background #ffe4c4 disabledForeground #b0b0b0 foreground black \ + highlightBackground #ffe4c4 highlightColor black \ + insertBackground black selectColor #b03060 \ + selectBackground #e6ceb1 selectForeground black \ + troughColor #cdb79e +} diff --git a/library/prolog.ps b/library/prolog.ps new file mode 100644 index 0000000..378d503 --- /dev/null +++ b/library/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/library/safetk.tcl b/library/safetk.tcl new file mode 100644 index 0000000..1cabcd5 --- /dev/null +++ b/library/safetk.tcl @@ -0,0 +1,148 @@ +# safetk.tcl -- +# +# Support procs to use Tk in safe interpreters. +# +# SCCS: @(#) safetk.tcl 1.8 97/10/29 14:59:16 +# +# 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. + +# see safetk.n for documentation + +# +# +# Note: It is UNSAFE to let any 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 +# + +# We use opt (optional arguments parsing) +package require opt 0.1; + +namespace eval ::safe { + + # counter for safe toplevels + variable tkSafeId 0; + + # + # tkInterpInit : prepare the slave interpreter for tk loading + # + # returns the slave name (tkInterpInit does) + # + proc ::safe::tkInterpInit {slave} { + global env tk_library + if {[info exists env(DISPLAY)]} { + $slave eval [list set env(DISPLAY) $env(DISPLAY)]; + } + # 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 + ::interp eval $slave [list set tk_library [::safe::interpAddToAccessPath $slave $tk_library]] + return $slave; + } + + +# tkInterpLoadTk : +# Do additional configuration as needed (calling tkInterpInit) +# and actually load Tk into the slave. +# +# Either contained in the specified windowId (-use) or +# creating a decorated toplevel for it. + +# empty definition for auto_mkIndex +proc ::safe::loadTk {} {} + + ::tcl::OptProc loadTk { + {slave -interp "name of the slave interpreter"} + {-use -windowId {} "window Id to use (new toplevel otherwise)"} + } { + if {![::tcl::OptProcArgGiven "-use"]} { + # create a decorated toplevel + ::tcl::Lassign [tkTopLevel $slave] w use; + # set our delete hook (slave arg is added by interpDelete) + Set [DeleteHookName $slave] [list tkDelete {} $w]; + } + tkInterpInit $slave; + ::interp eval $slave [list set argv [list "-use" $use]]; + ::interp eval $slave [list set argc 2]; + 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::tkDelete {W window slave} { + # we are going to be called for each widget... skip untill it's + # top level + Log $slave "Called tkDelete $W $window" NOTICE; + if {[::interp exists $slave]} { + if {[catch {::safe::interpDelete $slave} msg]} { + Log $slave "Deletion error : $msg"; + } + } + if {[winfo exists $window]} { + Log $slave "Destroy toplevel $window" NOTICE; + destroy $window; + } + } + +proc ::safe::tkTopLevel {slave} { + variable tkSafeId; + incr tkSafeId; + set w ".safe$tkSafeId"; + if {[catch {toplevel $w -class SafeTk} msg]} { + return -code error "Unable to create toplevel for\ + safe slave \"$slave\" ($msg)"; + } + Log $slave "New toplevel $w" NOTICE + + set msg "Untrusted Tcl applet ($slave)" + wm title $w $msg; + + # Control frame + set wc $w.fc + frame $wc -bg red -borderwidth 3 -relief ridge ; + + # We will destroy the interp when the window is destroyed + bindtags $wc [concat Safe$wc [bindtags $wc]] + bind Safe$wc [list ::safe::tkDelete %W $w $slave]; + + label $wc.l -text $msg \ + -padx 2 -pady 0 -anchor w; + + # We want the button to be the last visible item + # (so be packed first) and at the right and not resizing horizontally + + # frame the button so it does not expand horizontally + # but still have the default background instead of red one from the parent + frame $wc.fb -bd 0 ; + button $wc.fb.b -text "Delete" \ + -bd 1 -padx 2 -pady 0 -highlightthickness 0 \ + -command [list ::safe::tkDelete $w $w $slave] + pack $wc.fb.b -side right -fill both ; + pack $wc.fb -side right -fill both -expand 1; + pack $wc.l -side left -fill both -expand 1; + pack $wc -side bottom -fill x ; + + # Container frame + frame $w.c -container 1; + pack $w.c -fill both -expand 1; + + # return both the toplevel window name and the id to use for embedding + list $w [winfo id $w.c] ; +} + +} diff --git a/library/scale.tcl b/library/scale.tcl new file mode 100644 index 0000000..8e96176 --- /dev/null +++ b/library/scale.tcl @@ -0,0 +1,265 @@ +# scale.tcl -- +# +# 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 +# +# Copyright (c) 1994 The Regents of the University of California. +# Copyright (c) 1994-1995 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +#------------------------------------------------------------------------- +# The code below creates the default class bindings for entries. +#------------------------------------------------------------------------- + +# Standard Motif bindings: + +bind Scale { + if $tk_strictMotif { + set tkPriv(activeBg) [%W cget -activebackground] + %W config -activebackground [%W cget -background] + } + tkScaleActivate %W %x %y +} +bind Scale { + tkScaleActivate %W %x %y +} +bind Scale { + if $tk_strictMotif { + %W config -activebackground $tkPriv(activeBg) + } + if {[%W cget -state] == "active"} { + %W configure -state normal + } +} +bind Scale <1> { + tkScaleButtonDown %W %x %y +} +bind Scale { + tkScaleDrag %W %x %y +} +bind Scale { } +bind Scale { } +bind Scale { + tkCancelRepeat + tkScaleEndDrag %W + tkScaleActivate %W %x %y +} +bind Scale <2> { + tkScaleButton2Down %W %x %y +} +bind Scale { + tkScaleDrag %W %x %y +} +bind Scale { } +bind Scale { } +bind Scale { + tkCancelRepeat + tkScaleEndDrag %W + tkScaleActivate %W %x %y +} +bind Scale { + tkScaleControlPress %W %x %y +} +bind Scale { + tkScaleIncrement %W up little noRepeat +} +bind Scale { + tkScaleIncrement %W down little noRepeat +} +bind Scale { + tkScaleIncrement %W up little noRepeat +} +bind Scale { + tkScaleIncrement %W down little noRepeat +} +bind Scale { + tkScaleIncrement %W up big noRepeat +} +bind Scale { + tkScaleIncrement %W down big noRepeat +} +bind Scale { + tkScaleIncrement %W up big noRepeat +} +bind Scale { + tkScaleIncrement %W down big noRepeat +} +bind Scale { + %W set [%W cget -from] +} +bind Scale { + %W set [%W cget -to] +} + +# tkScaleActivate -- +# This procedure is invoked to check a given x-y position in the +# scale and activate the slider if the x-y position falls within +# the slider. +# +# Arguments: +# w - The scale widget. +# x, y - Mouse coordinates. + +proc tkScaleActivate {w x y} { + global tkPriv + if {[$w cget -state] == "disabled"} { + return; + } + if {[$w identify $x $y] == "slider"} { + $w configure -state active + } else { + $w configure -state normal + } +} + +# tkScaleButtonDown -- +# This procedure is invoked when a button is pressed in a scale. It +# takes different actions depending on where the button was pressed. +# +# Arguments: +# w - The scale widget. +# x, y - Mouse coordinates of button press. + +proc tkScaleButtonDown {w x y} { + global tkPriv + set tkPriv(dragging) 0 + set el [$w identify $x $y] + if {$el == "trough1"} { + tkScaleIncrement $w up little initial + } elseif {$el == "trough2"} { + tkScaleIncrement $w down little initial + } elseif {$el == "slider"} { + 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]] + $w configure -sliderrelief sunken + } +} + +# tkScaleDrag -- +# This procedure is called when the mouse is dragged with +# mouse button 1 down. If the drag started inside the slider +# (i.e. the scale is active) then the scale's value is adjusted +# to reflect the mouse's position. +# +# Arguments: +# w - The scale widget. +# x, y - Mouse coordinates. + +proc tkScaleDrag {w x y} { + global tkPriv + if !$tkPriv(dragging) { + return + } + $w set [$w get [expr $x - $tkPriv(deltaX)] \ + [expr $y - $tkPriv(deltaY)]] +} + +# tkScaleEndDrag -- +# This procedure is called to end an interactive drag of the +# slider. It just marks the drag as over. +# +# Arguments: +# w - The scale widget. + +proc tkScaleEndDrag {w} { + global tkPriv + set tkPriv(dragging) 0 + $w configure -sliderrelief raised +} + +# tkScaleIncrement -- +# This procedure is invoked to increment the value of a scale and +# to set up auto-repeating of the action if that is desired. The +# way the value is incremented depends on the "dir" and "big" +# arguments. +# +# Arguments: +# w - The scale widget. +# dir - "up" means move value towards -from, "down" means +# move towards -to. +# big - Size of increments: "big" or "little". +# repeat - Whether and how to auto-repeat the action: "noRepeat" +# means don't auto-repeat, "initial" means this is the +# first action in an auto-repeat sequence, and "again" +# means this is the second repetition or later. + +proc tkScaleIncrement {w dir big repeat} { + global tkPriv + if {![winfo exists $w]} return + if {$big == "big"} { + set inc [$w cget -bigincrement] + if {$inc == 0} { + set inc [expr abs([$w cget -to] - [$w cget -from])/10.0] + } + if {$inc < [$w cget -resolution]} { + set inc [$w cget -resolution] + } + } else { + set inc [$w cget -resolution] + } + if {([$w cget -from] > [$w cget -to]) ^ ($dir == "up")} { + set inc [expr -$inc] + } + $w set [expr [$w get] + $inc] + + if {$repeat == "again"} { + set tkPriv(afterId) [after [$w cget -repeatinterval] \ + tkScaleIncrement $w $dir $big again] + } elseif {$repeat == "initial"} { + set delay [$w cget -repeatdelay] + if {$delay > 0} { + set tkPriv(afterId) [after $delay \ + tkScaleIncrement $w $dir $big again] + } + } +} + +# tkScaleControlPress -- +# This procedure handles button presses that are made with the Control +# key down. Depending on the mouse position, it adjusts the scale +# value to one end of the range or the other. +# +# Arguments: +# w - The scale widget. +# x, y - Mouse coordinates where the button was pressed. + +proc tkScaleControlPress {w x y} { + set el [$w identify $x $y] + if {$el == "trough1"} { + $w set [$w cget -from] + } elseif {$el == "trough2"} { + $w set [$w cget -to] + } +} + +# tkScaleButton2Down +# This procedure is invoked when button 2 is pressed over a scale. +# It sets the value to correspond to the mouse position and starts +# a slider drag. +# +# Arguments: +# w - The scrollbar widget. +# x, y - Mouse coordinates within the widget. + +proc tkScaleButton2Down {w x y} { + global tkPriv + + if {[$w cget -state] == "disabled"} { + return; + } + $w configure -state active + $w set [$w get $x $y] + set tkPriv(dragging) 1 + set tkPriv(initValue) [$w get] + set coords "$x $y" + set tkPriv(deltaX) 0 + set tkPriv(deltaY) 0 +} diff --git a/library/scrlbar.tcl b/library/scrlbar.tcl new file mode 100644 index 0000000..e2b04b7 --- /dev/null +++ b/library/scrlbar.tcl @@ -0,0 +1,417 @@ +# scrlbar.tcl -- +# +# 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 +# +# Copyright (c) 1994 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +#------------------------------------------------------------------------- +# The code below creates the default class bindings for scrollbars. +#------------------------------------------------------------------------- + +# Standard Motif bindings: +if {($tcl_platform(platform) != "windows") && + ($tcl_platform(platform) != "macintosh")} { +bind Scrollbar { + if $tk_strictMotif { + set tkPriv(activeBg) [%W cget -activebackground] + %W config -activebackground [%W cget -background] + } + %W activate [%W identify %x %y] +} +bind Scrollbar { + %W activate [%W identify %x %y] +} + +# The "info exists" command in the following binding handles the +# situation where a Leave event occurs for a scrollbar without the Enter +# event. This seems to happen on some systems (such as Solaris 2.4) for +# unknown reasons. + +bind Scrollbar { + if {$tk_strictMotif && [info exists tkPriv(activeBg)]} { + %W config -activebackground $tkPriv(activeBg) + } + %W activate {} +} +bind Scrollbar <1> { + tkScrollButtonDown %W %x %y +} +bind Scrollbar { + tkScrollDrag %W %x %y +} +bind Scrollbar { + tkScrollDrag %W %x %y +} +bind Scrollbar { + tkScrollButtonUp %W %x %y +} +bind Scrollbar { + # Prevents binding from being invoked. +} +bind Scrollbar { + # Prevents binding from being invoked. +} +bind Scrollbar <2> { + tkScrollButton2Down %W %x %y +} +bind Scrollbar { + # Do nothing, since button 1 is already down. +} +bind Scrollbar { + # Do nothing, since button 2 is already down. +} +bind Scrollbar { + tkScrollDrag %W %x %y +} +bind Scrollbar { + tkScrollButtonUp %W %x %y +} +bind Scrollbar { + # Do nothing: B1 release will handle it. +} +bind Scrollbar { + # Do nothing: B2 release will handle it. +} +bind Scrollbar { + # Prevents binding from being invoked. +} +bind Scrollbar { + # Prevents binding from being invoked. +} +bind Scrollbar { + tkScrollTopBottom %W %x %y +} +bind Scrollbar { + tkScrollTopBottom %W %x %y +} + +bind Scrollbar { + tkScrollByUnits %W v -1 +} +bind Scrollbar { + tkScrollByUnits %W v 1 +} +bind Scrollbar { + tkScrollByPages %W v -1 +} +bind Scrollbar { + tkScrollByPages %W v 1 +} +bind Scrollbar { + tkScrollByUnits %W h -1 +} +bind Scrollbar { + tkScrollByUnits %W h 1 +} +bind Scrollbar { + tkScrollByPages %W h -1 +} +bind Scrollbar { + tkScrollByPages %W h 1 +} +bind Scrollbar { + tkScrollByPages %W hv -1 +} +bind Scrollbar { + tkScrollByPages %W hv 1 +} +bind Scrollbar { + tkScrollToPos %W 0 +} +bind Scrollbar { + tkScrollToPos %W 1 +} +} +# tkScrollButtonDown -- +# This procedure is invoked when a button is pressed in a scrollbar. +# It changes the way the scrollbar is displayed and takes actions +# depending on where the mouse is. +# +# Arguments: +# w - The scrollbar widget. +# x, y - Mouse coordinates. + +proc tkScrollButtonDown {w x y} { + global tkPriv + set tkPriv(relief) [$w cget -activerelief] + $w configure -activerelief sunken + set element [$w identify $x $y] + if {$element == "slider"} { + tkScrollStartDrag $w $x $y + } else { + tkScrollSelect $w $element initial + } +} + +# tkScrollButtonUp -- +# This procedure is invoked when a button is released in a scrollbar. +# It cancels scans and auto-repeats that were in progress, and restores +# the way the active element is displayed. +# +# Arguments: +# w - The scrollbar widget. +# x, y - Mouse coordinates. + +proc tkScrollButtonUp {w x y} { + global tkPriv + tkCancelRepeat + $w configure -activerelief $tkPriv(relief) + tkScrollEndDrag $w $x $y + $w activate [$w identify $x $y] +} + +# tkScrollSelect -- +# This procedure is invoked when a button is pressed over the scrollbar. +# It invokes one of several scrolling actions depending on where in +# the scrollbar the button was pressed. +# +# Arguments: +# w - The scrollbar widget. +# element - The element of the scrollbar that was selected, such +# as "arrow1" or "trough2". Shouldn't be "slider". +# repeat - Whether and how to auto-repeat the action: "noRepeat" +# means don't auto-repeat, "initial" means this is the +# first action in an auto-repeat sequence, and "again" +# means this is the second repetition or later. + +proc tkScrollSelect {w element repeat} { + global tkPriv + if {![winfo exists $w]} return + if {$element == "arrow1"} { + tkScrollByUnits $w hv -1 + } elseif {$element == "trough1"} { + tkScrollByPages $w hv -1 + } elseif {$element == "trough2"} { + tkScrollByPages $w hv 1 + } elseif {$element == "arrow2"} { + tkScrollByUnits $w hv 1 + } else { + return + } + if {$repeat == "again"} { + set tkPriv(afterId) [after [$w cget -repeatinterval] \ + tkScrollSelect $w $element again] + } elseif {$repeat == "initial"} { + set delay [$w cget -repeatdelay] + if {$delay > 0} { + set tkPriv(afterId) [after $delay tkScrollSelect $w $element again] + } + } +} + +# tkScrollStartDrag -- +# This procedure is called to initiate a drag of the slider. It just +# remembers the starting position of the mouse and slider. +# +# Arguments: +# w - The scrollbar widget. +# x, y - The mouse position at the start of the drag operation. + +proc tkScrollStartDrag {w x y} { + global tkPriv + + if {[$w cget -command] == ""} { + return + } + set tkPriv(pressX) $x + set tkPriv(pressY) $y + set tkPriv(initValues) [$w get] + set iv0 [lindex $tkPriv(initValues) 0] + if {[llength $tkPriv(initValues)] == 2} { + set tkPriv(initPos) $iv0 + } else { + if {$iv0 == 0} { + set tkPriv(initPos) 0.0 + } else { + set tkPriv(initPos) [expr (double([lindex $tkPriv(initValues) 2])) \ + / [lindex $tkPriv(initValues) 0]] + } + } +} + +# tkScrollDrag -- +# This procedure is called for each mouse motion even when the slider +# is being dragged. It notifies the associated widget if we're not +# jump scrolling, and it just updates the scrollbar if we are jump +# scrolling. +# +# Arguments: +# w - The scrollbar widget. +# x, y - The current mouse position. + +proc tkScrollDrag {w x y} { + global tkPriv + + if {$tkPriv(initPos) == ""} { + return + } + 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] + } else { + 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]] + } + } else { + tkScrollToPos $w [expr $tkPriv(initPos) + $delta] + } +} + +# tkScrollEndDrag -- +# This procedure is called to end an interactive drag of the slider. +# It scrolls the window if we're in jump mode, otherwise it does nothing. +# +# Arguments: +# w - The scrollbar widget. +# x, y - The mouse position at the end of the drag operation. + +proc tkScrollEndDrag {w x y} { + global tkPriv + + 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] + } + set tkPriv(initPos) "" +} + +# tkScrollByUnits -- +# This procedure tells the scrollbar's associated widget to scroll up +# or down by a given number of units. It notifies the associated widget +# in different ways for old and new command syntaxes. +# +# Arguments: +# w - The scrollbar widget. +# orient - Which kinds of scrollbars this applies to: "h" for +# horizontal, "v" for vertical, "hv" for both. +# amount - How many units to scroll: typically 1 or -1. + +proc tkScrollByUnits {w orient amount} { + set cmd [$w cget -command] + if {($cmd == "") || ([string first \ + [string index [$w cget -orient] 0] $orient] < 0)} { + return + } + set info [$w get] + if {[llength $info] == 2} { + uplevel #0 $cmd scroll $amount units + } else { + uplevel #0 $cmd [expr [lindex $info 2] + $amount] + } +} + +# tkScrollByPages -- +# This procedure tells the scrollbar's associated widget to scroll up +# or down by a given number of screenfuls. It notifies the associated +# widget in different ways for old and new command syntaxes. +# +# Arguments: +# w - The scrollbar widget. +# orient - Which kinds of scrollbars this applies to: "h" for +# horizontal, "v" for vertical, "hv" for both. +# amount - How many screens to scroll: typically 1 or -1. + +proc tkScrollByPages {w orient amount} { + set cmd [$w cget -command] + if {($cmd == "") || ([string first \ + [string index [$w cget -orient] 0] $orient] < 0)} { + return + } + set info [$w get] + if {[llength $info] == 2} { + uplevel #0 $cmd scroll $amount pages + } else { + uplevel #0 $cmd [expr [lindex $info 2] + $amount*([lindex $info 1] - 1)] + } +} + +# tkScrollToPos -- +# This procedure tells the scrollbar's associated widget to scroll to +# a particular location, given by a fraction between 0 and 1. It notifies +# the associated widget in different ways for old and new command syntaxes. +# +# Arguments: +# w - The scrollbar widget. +# pos - A fraction between 0 and 1 indicating a desired position +# in the document. + +proc tkScrollToPos {w pos} { + set cmd [$w cget -command] + if {($cmd == "")} { + return + } + set info [$w get] + if {[llength $info] == 2} { + uplevel #0 $cmd moveto $pos + } else { + uplevel #0 $cmd [expr round([lindex $info 0]*$pos)] + } +} + +# tkScrollTopBottom +# Scroll to the top or bottom of the document, depending on the mouse +# position. +# +# Arguments: +# w - The scrollbar widget. +# x, y - Mouse coordinates within the widget. + +proc tkScrollTopBottom {w x y} { + global tkPriv + set element [$w identify $x $y] + if [string match *1 $element] { + tkScrollToPos $w 0 + } elseif [string match *2 $element] { + tkScrollToPos $w 1 + } + + # Set tkPriv(relief), since it's needed by tkScrollButtonUp. + + set tkPriv(relief) [$w cget -activerelief] +} + +# tkScrollButton2Down +# This procedure is invoked when button 2 is pressed over a scrollbar. +# If the button is over the trough or slider, it sets the scrollbar to +# the mouse position and starts a slider drag. Otherwise it just +# behaves the same as button 1. +# +# Arguments: +# w - The scrollbar widget. +# x, y - Mouse coordinates within the widget. + +proc tkScrollButton2Down {w x y} { + global tkPriv + set element [$w identify $x $y] + if {($element == "arrow1") || ($element == "arrow2")} { + tkScrollButtonDown $w $x $y + return + } + tkScrollToPos $w [$w fraction $x $y] + set tkPriv(relief) [$w cget -activerelief] + + # Need the "update idletasks" below so that the widget calls us + # back to reset the actual scrollbar position before we start the + # slider drag. + + update idletasks + $w configure -activerelief sunken + $w activate slider + tkScrollStartDrag $w $x $y +} diff --git a/library/tclIndex b/library/tclIndex new file mode 100644 index 0000000..e65708e --- /dev/null +++ b/library/tclIndex @@ -0,0 +1,241 @@ +# Tcl autoload index file, version 2.0 +# This file is generated by the "auto_mkindex" command +# and sourced to set up indexing information for one or +# more commands. Typically each line is a command that +# sets an element in the auto_index array, where the +# element name is the name of a command and the value is +# a script that loads the command. + +set auto_index(tkButtonEnter) [list source [file join $dir button.tcl]] +set auto_index(tkButtonLeave) [list source [file join $dir button.tcl]] +set auto_index(tkCheckRadioEnter) [list source [file join $dir button.tcl]] +set auto_index(tkButtonDown) [list source [file join $dir button.tcl]] +set auto_index(tkCheckRadioDown) [list source [file join $dir button.tcl]] +set auto_index(tkButtonUp) [list source [file join $dir button.tcl]] +set auto_index(tkButtonEnter) [list source [file join $dir button.tcl]] +set auto_index(tkButtonLeave) [list source [file join $dir button.tcl]] +set auto_index(tkButtonDown) [list source [file join $dir button.tcl]] +set auto_index(tkButtonUp) [list source [file join $dir button.tcl]] +set auto_index(tkButtonEnter) [list source [file join $dir button.tcl]] +set auto_index(tkButtonLeave) [list source [file join $dir button.tcl]] +set auto_index(tkButtonDown) [list source [file join $dir button.tcl]] +set auto_index(tkButtonUp) [list source [file join $dir button.tcl]] +set auto_index(tkButtonInvoke) [list source [file join $dir button.tcl]] +set auto_index(tkCheckRadioInvoke) [list source [file join $dir button.tcl]] +set auto_index(tk_dialog) [list source [file join $dir dialog.tcl]] +set auto_index(tkEntryClosestGap) [list source [file join $dir entry.tcl]] +set auto_index(tkEntryButton1) [list source [file join $dir entry.tcl]] +set auto_index(tkEntryMouseSelect) [list source [file join $dir entry.tcl]] +set auto_index(tkEntryPaste) [list source [file join $dir entry.tcl]] +set auto_index(tkEntryAutoScan) [list source [file join $dir entry.tcl]] +set auto_index(tkEntryKeySelect) [list source [file join $dir entry.tcl]] +set auto_index(tkEntryInsert) [list source [file join $dir entry.tcl]] +set auto_index(tkEntryBackspace) [list source [file join $dir entry.tcl]] +set auto_index(tkEntrySeeInsert) [list source [file join $dir entry.tcl]] +set auto_index(tkEntrySetCursor) [list source [file join $dir entry.tcl]] +set auto_index(tkEntryTranspose) [list source [file join $dir entry.tcl]] +set auto_index(tkEntryPreviousWord) [list source [file join $dir entry.tcl]] +set auto_index(tkListboxBeginSelect) [list source [file join $dir listbox.tcl]] +set auto_index(tkListboxMotion) [list source [file join $dir listbox.tcl]] +set auto_index(tkListboxBeginExtend) [list source [file join $dir listbox.tcl]] +set auto_index(tkListboxBeginToggle) [list source [file join $dir listbox.tcl]] +set auto_index(tkListboxAutoScan) [list source [file join $dir listbox.tcl]] +set auto_index(tkListboxUpDown) [list source [file join $dir listbox.tcl]] +set auto_index(tkListboxExtendUpDown) [list source [file join $dir listbox.tcl]] +set auto_index(tkListboxDataExtend) [list source [file join $dir listbox.tcl]] +set auto_index(tkListboxCancel) [list source [file join $dir listbox.tcl]] +set auto_index(tkListboxSelectAll) [list source [file join $dir listbox.tcl]] +set auto_index(tkMbEnter) [list source [file join $dir menu.tcl]] +set auto_index(tkMbLeave) [list source [file join $dir menu.tcl]] +set auto_index(tkMbPost) [list source [file join $dir menu.tcl]] +set auto_index(tkMenuUnpost) [list source [file join $dir menu.tcl]] +set auto_index(tkMbMotion) [list source [file join $dir menu.tcl]] +set auto_index(tkMbButtonUp) [list source [file join $dir menu.tcl]] +set auto_index(tkMenuMotion) [list source [file join $dir menu.tcl]] +set auto_index(tkMenuButtonDown) [list source [file join $dir menu.tcl]] +set auto_index(tkMenuLeave) [list source [file join $dir menu.tcl]] +set auto_index(tkMenuInvoke) [list source [file join $dir menu.tcl]] +set auto_index(tkMenuEscape) [list source [file join $dir menu.tcl]] +set auto_index(tkMenuUpArrow) [list source [file join $dir menu.tcl]] +set auto_index(tkMenuDownArrow) [list source [file join $dir menu.tcl]] +set auto_index(tkMenuLeftArrow) [list source [file join $dir menu.tcl]] +set auto_index(tkMenuRightArrow) [list source [file join $dir menu.tcl]] +set auto_index(tkMenuNextMenu) [list source [file join $dir menu.tcl]] +set auto_index(tkMenuNextEntry) [list source [file join $dir menu.tcl]] +set auto_index(tkMenuFind) [list source [file join $dir menu.tcl]] +set auto_index(tkTraverseToMenu) [list source [file join $dir menu.tcl]] +set auto_index(tkFirstMenu) [list source [file join $dir menu.tcl]] +set auto_index(tkTraverseWithinMenu) [list source [file join $dir menu.tcl]] +set auto_index(tkMenuFirstEntry) [list source [file join $dir menu.tcl]] +set auto_index(tkMenuFindName) [list source [file join $dir menu.tcl]] +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(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]] +set auto_index(tkScrollSelect) [list source [file join $dir scrlbar.tcl]] +set auto_index(tkScrollStartDrag) [list source [file join $dir scrlbar.tcl]] +set auto_index(tkScrollDrag) [list source [file join $dir scrlbar.tcl]] +set auto_index(tkScrollEndDrag) [list source [file join $dir scrlbar.tcl]] +set auto_index(tkScrollByUnits) [list source [file join $dir scrlbar.tcl]] +set auto_index(tkScrollByPages) [list source [file join $dir scrlbar.tcl]] +set auto_index(tkScrollToPos) [list source [file join $dir scrlbar.tcl]] +set auto_index(tkScrollTopBottom) [list source [file join $dir scrlbar.tcl]] +set auto_index(tkScrollButton2Down) [list source [file join $dir scrlbar.tcl]] +set auto_index(tkTextClosestGap) [list source [file join $dir text.tcl]] +set auto_index(tkTextButton1) [list source [file join $dir text.tcl]] +set auto_index(tkTextSelectTo) [list source [file join $dir text.tcl]] +set auto_index(tkTextKeyExtend) [list source [file join $dir text.tcl]] +set auto_index(tkTextPaste) [list source [file join $dir text.tcl]] +set auto_index(tkTextAutoScan) [list source [file join $dir text.tcl]] +set auto_index(tkTextSetCursor) [list source [file join $dir text.tcl]] +set auto_index(tkTextKeySelect) [list source [file join $dir text.tcl]] +set auto_index(tkTextResetAnchor) [list source [file join $dir text.tcl]] +set auto_index(tkTextInsert) [list source [file join $dir text.tcl]] +set auto_index(tkTextUpDownLine) [list source [file join $dir text.tcl]] +set auto_index(tkTextPrevPara) [list source [file join $dir text.tcl]] +set auto_index(tkTextNextPara) [list source [file join $dir text.tcl]] +set auto_index(tkTextScrollPages) [list source [file join $dir text.tcl]] +set auto_index(tkTextTranspose) [list source [file join $dir text.tcl]] +set auto_index(tk_textCopy) [list source [file join $dir text.tcl]] +set auto_index(tk_textCut) [list source [file join $dir text.tcl]] +set auto_index(tk_textPaste) [list source [file join $dir text.tcl]] +set auto_index(tkTextNextPos) [list source [file join $dir text.tcl]] +set auto_index(tkTextPrevPos) [list source [file join $dir text.tcl]] +set auto_index(tkScreenChanged) [list source [file join $dir tk.tcl]] +set auto_index(tkEventMotifBindings) [list source [file join $dir tk.tcl]] +set auto_index(tkCancelRepeat) [list source [file join $dir tk.tcl]] +set auto_index(tkTabToWindow) [list source [file join $dir tk.tcl]] +set auto_index(bgerror) [list source [file join $dir bgerror.tcl]] +set auto_index(tkScaleActivate) [list source [file join $dir scale.tcl]] +set auto_index(tkScaleButtonDown) [list source [file join $dir scale.tcl]] +set auto_index(tkScaleDrag) [list source [file join $dir scale.tcl]] +set auto_index(tkScaleEndDrag) [list source [file join $dir scale.tcl]] +set auto_index(tkScaleIncrement) [list source [file join $dir scale.tcl]] +set auto_index(tkScaleControlPress) [list source [file join $dir scale.tcl]] +set auto_index(tkScaleButton2Down) [list source [file join $dir scale.tcl]] +set auto_index(tk_optionMenu) [list source [file join $dir optMenu.tcl]] +set auto_index(tkTearOffMenu) [list source [file join $dir tearoff.tcl]] +set auto_index(tkMenuDup) [list source [file join $dir tearoff.tcl]] +set auto_index(tk_menuBar) [list source [file join $dir obsolete.tcl]] +set auto_index(tk_bindForTraversal) [list source [file join $dir obsolete.tcl]] +set auto_index(tk_focusNext) [list source [file join $dir focus.tcl]] +set auto_index(tk_focusPrev) [list source [file join $dir focus.tcl]] +set auto_index(tkFocusOK) [list source [file join $dir focus.tcl]] +set auto_index(tk_focusFollowsMouse) [list source [file join $dir focus.tcl]] +set auto_index(tkConsoleInit) [list source [file join $dir console.tcl]] +set auto_index(tkConsoleSource) [list source [file join $dir console.tcl]] +set auto_index(tkConsoleInvoke) [list source [file join $dir console.tcl]] +set auto_index(tkConsoleHistory) [list source [file join $dir console.tcl]] +set auto_index(tkConsolePrompt) [list source [file join $dir console.tcl]] +set auto_index(tkConsoleBind) [list source [file join $dir console.tcl]] +set auto_index(tkConsoleInsert) [list source [file join $dir console.tcl]] +set auto_index(tkConsoleOutput) [list source [file join $dir console.tcl]] +set auto_index(tkConsoleExit) [list source [file join $dir console.tcl]] +set auto_index(tkConsoleAbout) [list source [file join $dir console.tcl]] +set auto_index(tk_setPalette) [list source [file join $dir palette.tcl]] +set auto_index(tkRecolorTree) [list source [file join $dir palette.tcl]] +set auto_index(tkDarken) [list source [file join $dir palette.tcl]] +set auto_index(tk_bisque) [list source [file join $dir palette.tcl]] +set auto_index(tkColorDialog) [list source [file join $dir clrpick.tcl]] +set auto_index(tkColorDialog_InitValues) [list source [file join $dir clrpick.tcl]] +set auto_index(tkColorDialog_Config) [list source [file join $dir clrpick.tcl]] +set auto_index(tkColorDialog_BuildDialog) [list source [file join $dir clrpick.tcl]] +set auto_index(tkColorDialog_SetRGBValue) [list source [file join $dir clrpick.tcl]] +set auto_index(tkColorDialog_XToRgb) [list source [file join $dir clrpick.tcl]] +set auto_index(tkColorDialog_RgbToX) [list source [file join $dir clrpick.tcl]] +set auto_index(tkColorDialog_DrawColorScale) [list source [file join $dir clrpick.tcl]] +set auto_index(tkColorDialog_CreateSelector) [list source [file join $dir clrpick.tcl]] +set auto_index(tkColorDialog_RedrawFinalColor) [list source [file join $dir clrpick.tcl]] +set auto_index(tkColorDialog_RedrawColorBars) [list source [file join $dir clrpick.tcl]] +set auto_index(tkColorDialog_StartMove) [list source [file join $dir clrpick.tcl]] +set auto_index(tkColorDialog_MoveSelector) [list source [file join $dir clrpick.tcl]] +set auto_index(tkColorDialog_ReleaseMouse) [list source [file join $dir clrpick.tcl]] +set auto_index(tkColorDialog_ResizeColorBars) [list source [file join $dir clrpick.tcl]] +set auto_index(tkColorDialog_HandleSelEntry) [list source [file join $dir clrpick.tcl]] +set auto_index(tkColorDialog_HandleRGBEntry) [list source [file join $dir clrpick.tcl]] +set auto_index(tkColorDialog_EnterColorBar) [list source [file join $dir clrpick.tcl]] +set auto_index(tkColorDialog_LeaveColorBar) [list source [file join $dir clrpick.tcl]] +set auto_index(tkColorDialog_OkCmd) [list source [file join $dir clrpick.tcl]] +set auto_index(tkColorDialog_CancelCmd) [list source [file join $dir clrpick.tcl]] +set auto_index(tclParseConfigSpec) [list source [file join $dir comdlg.tcl]] +set auto_index(tclListValidFlags) [list source [file join $dir comdlg.tcl]] +set auto_index(tclSortNoCase) [list source [file join $dir comdlg.tcl]] +set auto_index(tclVerifyInteger) [list source [file join $dir comdlg.tcl]] +set auto_index(tkFocusGroup_Create) [list source [file join $dir comdlg.tcl]] +set auto_index(tkFocusGroup_BindIn) [list source [file join $dir comdlg.tcl]] +set auto_index(tkFocusGroup_BindOut) [list source [file join $dir comdlg.tcl]] +set auto_index(tkFocusGroup_Destroy) [list source [file join $dir comdlg.tcl]] +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::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]] +set auto_index(tkIconList_Config) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_Create) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_AutoScan) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_DeleteAll) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_Add) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_Arrange) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_Invoke) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_See) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_SelectAtXY) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_Select) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_Unselect) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_Get) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_Btn1) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_Motion1) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_Double1) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_ReturnKey) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_Leave1) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_FocusIn) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_UpDown) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_LeftRight) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_KeyPress) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_Goto) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkIconList_Reset) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkFDialog) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkFDialog_Config) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkFDialog_Create) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkFDialog_UpdateWhenIdle) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkFDialog_Update) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkFDialog_SetPathSilently) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkFDialog_SetPath) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkFDialog_SetFilter) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkFDialogResolveFile) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkFDialog_EntFocusIn) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkFDialog_EntFocusOut) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkFDialog_ActivateEnt) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkFDialog_InvokeBtn) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkFDialog_UpDirCmd) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkFDialog_JoinFile) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkFDialog_OkCmd) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkFDialog_CancelCmd) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkFDialog_ListBrowse) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkFDialog_ListInvoke) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkFDialog_Done) [list source [file join $dir tkfbox.tcl]] +set auto_index(tkMotifFDialog) [list source [file join $dir xmfbox.tcl]] +set auto_index(tkMotifFDialog_Config) [list source [file join $dir xmfbox.tcl]] +set auto_index(tkMotifFDialog_Create) [list source [file join $dir xmfbox.tcl]] +set auto_index(tkMotifFDialog_MakeSList) [list source [file join $dir xmfbox.tcl]] +set auto_index(tkMotifFDialog_BrowseDList) [list source [file join $dir xmfbox.tcl]] +set auto_index(tkMotifFDialog_ActivateDList) [list source [file join $dir xmfbox.tcl]] +set auto_index(tkMotifFDialog_BrowseFList) [list source [file join $dir xmfbox.tcl]] +set auto_index(tkMotifFDialog_ActivateFList) [list source [file join $dir xmfbox.tcl]] +set auto_index(tkMotifFDialog_ActivateFEnt) [list source [file join $dir xmfbox.tcl]] +set auto_index(tkMotifFDialog_InterpFilter) [list source [file join $dir xmfbox.tcl]] +set auto_index(tkMotifFDialog_ActivateSEnt) [list source [file join $dir xmfbox.tcl]] +set auto_index(tkMotifFDialog_OkCmd) [list source [file join $dir xmfbox.tcl]] +set auto_index(tkMotifFDialog_FilterCmd) [list source [file join $dir xmfbox.tcl]] +set auto_index(tkMotifFDialog_CancelCmd) [list source [file join $dir xmfbox.tcl]] +set auto_index(tkMotifFDialog_Update) [list source [file join $dir xmfbox.tcl]] +set auto_index(tkMotifFDialog_LoadFiles) [list source [file join $dir xmfbox.tcl]] +set auto_index(tkListBoxKeyAccel_Set) [list source [file join $dir xmfbox.tcl]] +set auto_index(tkListBoxKeyAccel_Unset) [list source [file join $dir xmfbox.tcl]] +set auto_index(tkListBoxKeyAccel_Key) [list source [file join $dir xmfbox.tcl]] +set auto_index(tkListBoxKeyAccel_Goto) [list source [file join $dir xmfbox.tcl]] +set auto_index(tkListBoxKeyAccel_Reset) [list source [file join $dir xmfbox.tcl]] diff --git a/library/tearoff.tcl b/library/tearoff.tcl new file mode 100644 index 0000000..7cbe8e7 --- /dev/null +++ b/library/tearoff.tcl @@ -0,0 +1,145 @@ +# tearoff.tcl -- +# +# This file contains procedures that implement tear-off menus. +# +# SCCS: @(#) tearoff.tcl 1.20 97/08/21 14:49:27 +# +# Copyright (c) 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. +# + +# tkTearoffMenu -- +# Given the name of a menu, this procedure creates a torn-off menu +# that is identical to the given menu (including nested submenus). +# The new torn-off menu exists as a toplevel window managed by the +# window manager. The return value is the name of the new menu. +# The window is created at the point specified by x and y +# +# Arguments: +# w - The menu to be torn-off (duplicated). +# x - x coordinate where window is created +# y - y coordinate where window is created + +proc tkTearOffMenu {w {x 0} {y 0}} { + # Find a unique name to use for the torn-off menu. Find the first + # ancestor of w that is a toplevel but not a menu, and use this as + # the parent of the new menu. This guarantees that the torn off + # menu will be on the same screen as the original menu. By making + # it a child of the ancestor, rather than a child of the menu, it + # can continue to live even if the menu is deleted; it will go + # away when the toplevel goes away. + + if {$x == 0} { + set x [winfo rootx $w] + } + if {$y == 0} { + set y [winfo rooty $w] + } + + set parent [winfo parent $w] + while {([winfo toplevel $parent] != $parent) + || ([winfo class $parent] == "Menu")} { + set parent [winfo parent $parent] + } + if {$parent == "."} { + set parent "" + } + for {set i 1} 1 {incr i} { + set menu $parent.tearoff$i + if ![winfo exists $menu] { + break + } + } + + $w clone $menu tearoff + + # Pick a title for the new menu by looking at the parent of the + # original: if the parent is a menu, then use the text of the active + # entry. If it's a menubutton then use its text. + + set parent [winfo parent $w] + if {[$menu cget -title] != ""} { + wm title $menu [$menu cget -title] + } else { + switch [winfo class $parent] { + Menubutton { + wm title $menu [$parent cget -text] + } + Menu { + wm title $menu [$parent entrycget active -label] + } + } + } + + $menu post $x $y + + if {[winfo exists $menu] == 0} { + return "" + } + + # Set tkPriv(focus) on entry: otherwise the focus will get lost + # after keyboard invocation of a sub-menu (it will stay on the + # submenu). + + bind $menu { + set tkPriv(focus) %W + } + + # If there is a -tearoffcommand option for the menu, invoke it + # now. + + set cmd [$w cget -tearoffcommand] + if {$cmd != ""} { + uplevel #0 $cmd $w $menu + } + return $menu +} + +# tkMenuDup -- +# Given a menu (hierarchy), create a duplicate menu (hierarchy) +# in a given window. +# +# Arguments: +# src - Source window. Must be a menu. It and its +# menu descendants will be duplicated at dst. +# dst - Name to use for topmost menu in duplicate +# hierarchy. + +proc tkMenuDup {src dst type} { + set cmd [list menu $dst -type $type] + foreach option [$src configure] { + if {[llength $option] == 2} { + continue + } + if {[string compare [lindex $option 0] "-type"] == 0} { + continue + } + lappend cmd [lindex $option 0] [lindex $option 4] + } + eval $cmd + set last [$src index last] + if {$last == "none"} { + return + } + for {set i [$src cget -tearoff]} {$i <= $last} {incr i} { + set cmd [list $dst add [$src type $i]] + foreach option [$src entryconfigure $i] { + lappend cmd [lindex $option 0] [lindex $option 4] + } + eval $cmd + } + + # 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 + bindtags $dst $x + foreach event [bind $src] { + regsub -all $quotedSrc [bind $src $event] $dst x + bind $dst $event $x + } +} diff --git a/library/text.tcl b/library/text.tcl new file mode 100644 index 0000000..891a9ed --- /dev/null +++ b/library/text.tcl @@ -0,0 +1,1010 @@ +# text.tcl -- +# +# 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 +# +# Copyright (c) 1992-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. +# + +#------------------------------------------------------------------------- +# Elements of tkPriv that are used in this file: +# +# afterId - If non-null, it means that auto-scanning is underway +# and it gives the "after" id for the next auto-scan +# command to be executed. +# char - Character position on the line; kept in order +# to allow moving up or down past short lines while +# still remembering the desired position. +# mouseMoved - Non-zero means the mouse has moved a significant +# amount since the button went down (so, for example, +# start dragging out a selection). +# prevPos - Used when moving up or down lines via the keyboard. +# Keeps track of the previous insert position, so +# we can distinguish a series of ups and downs, all +# in a row, from a new up or down. +# selectMode - The style of selection currently underway: +# char, word, or line. +# x, y - Last known mouse coordinates for scanning +# and auto-scanning. +#------------------------------------------------------------------------- + +#------------------------------------------------------------------------- +# The code below creates the default class bindings for entries. +#------------------------------------------------------------------------- + +# Standard Motif bindings: + +bind Text <1> { + tkTextButton1 %W %x %y + %W tag remove sel 0.0 end +} +bind Text { + set tkPriv(x) %x + set tkPriv(y) %y + tkTextSelectTo %W %x %y +} +bind Text { + set tkPriv(selectMode) word + tkTextSelectTo %W %x %y + catch {%W mark set insert sel.first} +} +bind Text { + set tkPriv(selectMode) line + tkTextSelectTo %W %x %y + catch {%W mark set insert sel.first} +} +bind Text { + tkTextResetAnchor %W @%x,%y + set tkPriv(selectMode) char + tkTextSelectTo %W %x %y +} +bind Text { + set tkPriv(selectMode) word + tkTextSelectTo %W %x %y +} +bind Text { + set tkPriv(selectMode) line + tkTextSelectTo %W %x %y +} +bind Text { + set tkPriv(x) %x + set tkPriv(y) %y + tkTextAutoScan %W +} +bind Text { + tkCancelRepeat +} +bind Text { + tkCancelRepeat +} +bind Text { + %W mark set insert @%x,%y +} +bind Text { + if {!$tkPriv(mouseMoved) || $tk_strictMotif} { + tkTextPaste %W %x %y + } +} +bind Text { + tkTextSetCursor %W insert-1c +} +bind Text { + tkTextSetCursor %W insert+1c +} +bind Text { + tkTextSetCursor %W [tkTextUpDownLine %W -1] +} +bind Text { + tkTextSetCursor %W [tkTextUpDownLine %W 1] +} +bind Text { + tkTextKeySelect %W [%W index {insert - 1c}] +} +bind Text { + tkTextKeySelect %W [%W index {insert + 1c}] +} +bind Text { + tkTextKeySelect %W [tkTextUpDownLine %W -1] +} +bind Text { + tkTextKeySelect %W [tkTextUpDownLine %W 1] +} +bind Text { + tkTextSetCursor %W [tkTextPrevPos %W insert tcl_startOfPreviousWord] +} +bind Text { + tkTextSetCursor %W [tkTextNextWord %W insert] +} +bind Text { + tkTextSetCursor %W [tkTextPrevPara %W insert] +} +bind Text { + tkTextSetCursor %W [tkTextNextPara %W insert] +} +bind Text { + tkTextKeySelect %W [tkTextPrevPos %W insert tcl_startOfPreviousWord] +} +bind Text { + tkTextKeySelect %W [tkTextNextWord %W insert] +} +bind Text { + tkTextKeySelect %W [tkTextPrevPara %W insert] +} +bind Text { + tkTextKeySelect %W [tkTextNextPara %W insert] +} +bind Text { + tkTextSetCursor %W [tkTextScrollPages %W -1] +} +bind Text { + tkTextKeySelect %W [tkTextScrollPages %W -1] +} +bind Text { + tkTextSetCursor %W [tkTextScrollPages %W 1] +} +bind Text { + tkTextKeySelect %W [tkTextScrollPages %W 1] +} +bind Text { + %W xview scroll -1 page +} +bind Text { + %W xview scroll 1 page +} + +bind Text { + tkTextSetCursor %W {insert linestart} +} +bind Text { + tkTextKeySelect %W {insert linestart} +} +bind Text { + tkTextSetCursor %W {insert lineend} +} +bind Text { + tkTextKeySelect %W {insert lineend} +} +bind Text { + tkTextSetCursor %W 1.0 +} +bind Text { + tkTextKeySelect %W 1.0 +} +bind Text { + tkTextSetCursor %W {end - 1 char} +} +bind Text { + tkTextKeySelect %W {end - 1 char} +} + +bind Text { + tkTextInsert %W \t + focus %W + break +} +bind Text { + # Needed only to keep binding from triggering; doesn't + # have to actually do anything. + break +} +bind Text { + focus [tk_focusNext %W] +} +bind Text { + focus [tk_focusPrev %W] +} +bind Text { + tkTextInsert %W \t +} +bind Text { + tkTextInsert %W \n +} +bind Text { + if {[%W tag nextrange sel 1.0 end] != ""} { + %W delete sel.first sel.last + } else { + %W delete insert + %W see insert + } +} +bind Text { + if {[%W tag nextrange sel 1.0 end] != ""} { + %W delete sel.first sel.last + } elseif [%W compare insert != 1.0] { + %W delete insert-1c + %W see insert + } +} + +bind Text { + %W mark set anchor insert +} +bind Text